theory pochhammer_monomials
  imports "~~/src/HOL/Computational_Algebra/Formal_Power_Series"
          "~~/src/HOL/Computational_Algebra/Polynomial"
          "~~/src/HOL/Computational_Algebra/Polynomial_FPS"
begin

(************************************Leading term function*****************************************)

abbreviation "X \<equiv> [:0,1:]"

definition leading_term:: "'a::zero poly \<Rightarrow> 'a poly" where
"leading_term p \<equiv> monom (lead_coeff p) (degree p)"

lemma leading_term_idem:
"leading_term (leading_term p) = leading_term p"
  by (metis (no_types, lifting)
      degree_monom_eq lead_coeff_monom
      leading_term_def monom_eq_iff')

lemma leading_term_degree:
"degree p = degree (leading_term p)"
  by (metis degree_monom_eq lead_coeff_monom leading_coeff_0_iff leading_term_def)

lemma leading_term_lead_coeff:
"lead_coeff p = lead_coeff (leading_term p)"
  by (metis lead_coeff_monom leading_term_def)

lemma minus_leading_term:
  assumes "degree p >0"
  shows "degree (p - (leading_term p))< degree p"
proof-
  let ?n = "degree p"
  let ?q = "p - (leading_term p)"
  show "degree ?q < ?n"
  proof-
    have M: "max (degree p) (degree (leading_term p)) = ?n"
      using leading_term_degree by (metis max.idem)
    then have  "degree ?q \<le> max (degree p) (degree (leading_term p))" using degree_diff_le_max
    proof -
    { assume "0 \<noteq> p \<and> p - leading_term p \<noteq> 0"
      moreover
      { assume "0 - coeff (leading_term p) (degree (p - leading_term p)) = 0 \<and> p - leading_term p \<noteq> 0"
        then have "degree (p - leading_term p) \<le> degree p"
          by (metis le_degree leading_coeff_0_iff minus_poly.rep_eq) }
      ultimately have "degree (p - leading_term p) \<le> degree p"
      by (metis (no_types) cancel_comm_monoid_add_class.diff_cancel le_degree leading_term_degree) }
  then show ?thesis
    by (metis (no_types) assms degree_0 leading_term_degree linear max.idem not_le)
    qed
    then have le:  "degree ?q \<le> ?n"
      using M  by simp
    have "coeff ?q ?n = 0"
      by (simp add: leading_term_def)
    then have "degree ?q \<noteq> ?n"
      by (metis assms degree_0 le leading_coeff_neq_0 not_le)
    then show ?thesis using le by simp
  qed
qed

lemma leading_term_eq_deg_less:
  assumes "degree p1 > 0"
  assumes "leading_term p1 = leading_term p2"
  shows "degree (p1 - p2) < degree p1"
proof-
  let ?q = "p1 - p2"
  let ?n = "degree p1"
  have "degree p2 = ?n"
    using assms(2) leading_term_degree by metis
  then have "coeff ?q ?n = 0"
    by (metis assms(2) cancel_comm_monoid_add_class.diff_cancel coeff_diff leading_term_lead_coeff)
  then show "degree ?q < ?n"
    by (smt One_nat_def Suc_le_eq Suc_pred
        \<open>degree p2 = degree p1\<close> assms(1)
        coeff_0_degree_minus_1 coeff_diff
        degree_0 le_degree leading_coeff_0_iff not_le)
qed

lemma leading_term_decomp:
  assumes "degree (p::('a::comm_ring_1) poly) >0"
  obtains q where "p = q + (leading_term p)" and "degree q < degree p"
proof-
  let ?q = "p - (leading_term p)"
  let ?n = "degree p"
  have 0:"degree ?q < ?n"
    using minus_leading_term assms by blast
  have 1:"p = ?q + (leading_term p)" by simp
  then show ?thesis
    using 0 1 that by blast
qed

lemma leading_term_mult:
  assumes "(a ::'a::comm_ring_1)*b \<noteq>0"
  assumes "a = lead_coeff p"
  assumes "b = lead_coeff q"
  assumes "degree p > 0"
  assumes "degree q >0"
  shows "leading_term (p*q) = (leading_term p)*(leading_term q)"
proof-
  obtain p1 where "p = leading_term p + p1" and "degree p1 < degree p"
    using leading_term_decomp  by (metis add.commute assms(4))
  obtain q1 where "q = leading_term q + q1" and "degree q1 < degree q"
    using leading_term_decomp  by (metis add.commute assms(5))
  then have "p*q = (leading_term p)*(leading_term q) + p1*(leading_term q) + q1*(leading_term p) + p1*q1"
    by (metis \<open>p = leading_term p + p1\<close> add.assoc mult.commute ring_class.ring_distribs(1))
  then have "p*q = (monom a (degree p))*(monom b (degree q)) + p1*(leading_term q) + q1*(leading_term p) + p1*q1"
    by (simp add: assms(2) assms(3) leading_term_def)
  then have "p*q = (monom (a*b) ((degree p)+(degree q))) + p1*(leading_term q) + q1*(leading_term p) + p1*q1"
    by (simp add: mult_monom)
  then show ?thesis
    by (metis (no_types, lifting) assms(1)
        assms(2) assms(3) coeff_mult_degree_sum
        degree_mult_le le_degree leading_term_def
        mult_monom order_antisym)
qed

lemma times_X_degree:
  assumes "(p::('a::comm_ring_1) poly) \<noteq>0"
  shows "degree (X*p) = (Suc (degree p))"
  by (simp add: assms)

lemma leading_term_mult_X:
  assumes "degree (p::('a::comm_ring_1) poly) \<noteq>0"
  shows "leading_term (X*p) = X*(leading_term p)"
proof-
  have "leading_term (X*p) = leading_term (X*(leading_term p))"
  proof -
    have "\<forall>p. degree p = degree (monom (lead_coeff p::'a) (degree p))"
      by (metis leading_term_def leading_term_degree)
    then show ?thesis
      by (simp add: leading_term_def)
  qed
  have "leading_term(X*(leading_term p)) = X*leading_term p"
    by (metis (no_types, lifting) assms coeff_pCons_Suc
      degree_0 leading_term_def leading_term_degree
      leading_term_lead_coeff monom_Suc mult.commute
      mult.right_neutral mult_pCons_left one_pCons smult_0_left times_X_degree)
  then show ?thesis
    using \<open>leading_term (X * p) = leading_term (X * leading_term p)\<close> by auto
qed

lemma leading_term_sum:
  assumes "degree p0 = degree p1"
  assumes "degree q < degree p0"
  assumes "p0 = p1 + q"
  shows "leading_term p0 = leading_term p1"
  by (metis add.commute assms(1) assms(2)
      assms(3) lead_coeff_add_le leading_term_def)

lemma monom_leading_term_monic_lin_comp0:
  assumes "b \<noteq>0"
  assumes A: "degree a = 0"
  shows "leading_term ((monom b n) \<circ>\<^sub>p (X + a)) = leading_term ((monom b n)::('a::comm_ring_1) poly)"
proof(induction n)
  case 0
  then show ?case by (simp add: monom_0)
next
  case (Suc n)
  fix n
  assume IH: "leading_term (monom b n \<circ>\<^sub>p (X + a)) = leading_term (monom b n)"
  show "leading_term (monom b (Suc n) \<circ>\<^sub>p (X + a)) = leading_term (monom b (Suc n)) "
  proof-
    have 0: "(monom b (Suc n)) =(monom b n)* (monom 1 1)"
       by (simp add: mult_monom)
    then have "(monom b (Suc n))\<circ>\<^sub>p(X + a) =(monom b n) \<circ>\<^sub>p(X + a)* (monom 1 1) \<circ>\<^sub>p(X+ a)"
      by (simp add: pcompose_mult)
    then have "(monom b (Suc n))\<circ>\<^sub>p(X + a) = (monom b n) \<circ>\<^sub>p(X+ a)*(X + a)"
      by (simp add: monom_Suc mult.commute pcompose_pCons)
    then have Q: "(monom b (Suc n))\<circ>\<^sub>p(X + a) = X*(monom b n) \<circ>\<^sub>p(X+ a) + a*(monom b n) \<circ>\<^sub>p(X+ a)"
      by (simp add: mult.commute mult_poly_add_left)
    have "((monom b n) \<circ>\<^sub>p(X+ a)) \<noteq>0"
      by (metis IH assms(1) lead_coeff_monom leading_coeff_0_iff leading_term_def)
    then have R: "degree (X*(monom b n) \<circ>\<^sub>p(X+ a)) = 1+  degree  ((monom b n) \<circ>\<^sub>p(X+ a))"
      by simp
    then have S: " degree ((monom b (Suc n))\<circ>\<^sub>p(X + a)) =  degree (X*(monom b n) \<circ>\<^sub>p(X+ a))"
      using Q by (smt A One_nat_def add.commute add_Suc comm_monoid_mult_class.mult_1
        degree_add_eq_left degree_mult_le degree_of_nat leading_term_degree
        leading_term_sum linorder_neqE_nat linorder_not_le not_less_eq_eq
        of_nat_1 one_poly_eq_simps(2) plus_1_eq_Suc)
    have "degree  ((monom b n) \<circ>\<^sub>p(X+ a)) \<ge> degree  (a*(monom b n) \<circ>\<^sub>p(X+ a))"
      using A degree_mult_le by (metis One_nat_def add_Suc
                        not_less_eq_eq plus_1_eq_Suc)
    then have T: "degree (X*(monom b n) \<circ>\<^sub>p(X+ a)) >  degree  (a*(monom b n) \<circ>\<^sub>p(X+ a))"
      using R by linarith
    let ?p0 = "(monom b (Suc n))\<circ>\<^sub>p(X + a) "
    let ?p1 = "(X*(monom b n) \<circ>\<^sub>p(X+ a))"
    let ?q = "(a*(monom b n) \<circ>\<^sub>p(X+ a))"
    have P0: "degree ?p0 = degree ?p1" using S by auto
    have P1: "degree ?q < degree ?p1" using T by auto
    have P2: "?p0 = ?p1 + ?q" using Q by auto
    have "leading_term ?p0 = leading_term ?p1"
      using P0 P1 P2 leading_term_sum by (simp add: leading_term_sum)
    then show ?thesis
      using IH by (metis (no_types, lifting) One_nat_def R 0 assms(1)
          coeff_mult_degree_sum degree_monom_eq lead_coeff_monom
          leading_term_def monom_Suc monom_eq_1 mult.commute
          one_neq_zero one_pCons plus_1_eq_Suc)
  qed
qed

lemma monom_leading_term_monic_lin_comp:
  assumes "b \<noteq>0"
  assumes A: "degree a = 0"
  shows "leading_term ((monom b n) \<circ>\<^sub>p (X + a)) = ((monom b n)::('a::comm_ring_1) poly)"
  using monom_leading_term_monic_lin_comp0
  by (metis A assms(1) degree_monom_eq lead_coeff_monom leading_term_def)

lemma comp_lin_degree:
  assumes A: "degree (a::('a::comm_ring_1) poly) = 0"
  shows "degree (p \<circ>\<^sub>p (X + a)) = degree p"
proof(cases "degree p = 0")
  case True
  then show ?thesis
    by (metis degree_eq_zeroE pcompose_const)
next
  case False
  let ?q = "p - (leading_term p)"
  have "degree ?q < degree p"
    using False minus_leading_term by auto
  have LE:"degree (?q \<circ>\<^sub>p (X+a)) \<le>degree ?q"
    using A by (metis (mono_tags, lifting)
        One_nat_def degree_add_eq_left degree_pCons_eq_if
        degree_pcompose_le mult.right_neutral
        one_neq_zero one_pCons zero_less_one)
  obtain b where I:"leading_term p = monom b (degree p)"
     by (simp add: leading_term_def)
  have N: "b \<noteq>0"
     using False by (metis I degree_0
         leading_term_degree monom_eq_0_iff)
  let ?m = "(monom b (degree p))"
  have B: "leading_term (?m \<circ>\<^sub>p(X + a)) = ?m"
    using A N monom_leading_term_monic_lin_comp by auto
  have "leading_term p = ?m"
    by (simp add: I)
  have P0: "degree ?m = degree (?m \<circ>\<^sub>p (X + a))"
    by (metis B leading_term_degree)
  have "p \<circ>\<^sub>p (X + a) = (?m \<circ>\<^sub>p (X + a)) + (?q \<circ>\<^sub>p (X + a))"
    by (simp add: I pcompose_diff)
  then have "degree (p \<circ>\<^sub>p (X + a)) = degree ?m"
    using P0 LE by (metis (no_types, lifting) I
      \<open>degree (p - leading_term p) < degree p\<close>
      add_lessD1 degree_add_eq_left le_add_diff_inverse
      leading_term_degree)
  then show ?thesis by (simp add: N degree_monom_eq)
qed

lemma leading_term_monic_lin_comp:
  assumes "degree a = 0"
  shows "leading_term (p \<circ>\<^sub>p (X + a)) = leading_term (p::('a::comm_ring_1) poly)"
proof(cases "degree p = 0")
  case True
  then show ?thesis
    by (metis degree_eq_zeroE pcompose_const)
next
  case False
  obtain q where E: "p = q + (leading_term p)" and D: "degree q < degree p"
    using leading_term_decomp False by blast
  then have P0: "leading_term ((leading_term p) \<circ>\<^sub>p (X + a)) = (leading_term p)"
    using monom_leading_term_monic_lin_comp by (metis (no_types, lifting)
        False assms degree_0 leading_coeff_0_iff leading_term_def)
  have "p \<circ>\<^sub>p (X + a) = q \<circ>\<^sub>p (X + a) + (leading_term p) \<circ>\<^sub>p (X + a)"
    using E by (metis pcompose_add)
  have P1: "degree (q \<circ>\<^sub>p (X + a)) < degree (p \<circ>\<^sub>p (X + a))"
    using D by (simp add: assms comp_lin_degree)
  have "degree (p \<circ>\<^sub>p (X + a)) = degree p"
     by (simp add: assms comp_lin_degree)
  then have "leading_term (p \<circ>\<^sub>p (X + a)) = leading_term ((leading_term p) \<circ>\<^sub>p (X + a))"
    by (smt D \<open>p \<circ>\<^sub>p (X + a) = q \<circ>\<^sub>p (X + a) + leading_term p \<circ>\<^sub>p (X + a)\<close>
        add.commute assms comp_lin_degree leading_term_degree
        leading_term_sum)
  then show ?thesis using P0 by auto
qed

(**************************************Pochhammer monomial constructor*****************************)

fun pochhammer_monom:: "'a::comm_ring_1 \<Rightarrow> nat  \<Rightarrow> 'a::comm_ring_1 poly" ("PM _ _")  where
"pochhammer_monom a 0 = monom a 0"|
"pochhammer_monom a (Suc n) = (X - (of_nat n))*(pochhammer_monom a n)"

lemma pochhammer_monom_alt_def:
"pochhammer_monom a n = smult a (pochhammer (X - (of_nat n) + 1) n)"
proof(induction n)
  case 0
  then show ?case  by (simp add: monom_0)
next
  case (Suc n)
  fix n
  assume IH : " (PM a n) = smult a (pochhammer (X - of_nat n + 1) n)"
  show "(PM a (Suc n)) = smult a (pochhammer (X - (of_nat (Suc n)) + 1) (Suc n))"
  proof-
    have "(PM a (Suc n)) = (X - (of_nat n))*(PM a n)"
      by simp
    then have "(PM a (Suc n)) = (X - (of_nat n))* (smult a (pochhammer (X - of_nat n + 1) n))"
      by (simp add: IH)
    then show ?thesis by (simp add: pochhammer_rec)
  qed
qed

lemma pochhammer_zero_root:
  shows "poly (PM (a::('a::comm_ring_1)) (Suc n)) 0 = 0"
proof-
  let ?n = "Suc n"
  have "(pochhammer  ((X::'a poly) - (of_nat ?n) + 1) ?n) = (( (X - (of_nat ?n) + 1) + (of_nat n))* (pochhammer  (X - (of_nat ?n) + 1) n))"
    using pochhammer_rec'  by blast
  then have "(pochhammer  ((X::'a poly) - (of_nat ?n) + 1) ?n) = X* (pochhammer  (X - (of_nat ?n) + 1) n)"
    by simp
  then have  "(PM (a::('a::comm_ring_1)) (Suc n)) = smult a ( X* (pochhammer  (X - (of_nat ?n) + 1) n))"
    by (simp add: pochhammer_monom_alt_def)
  then show ?thesis by simp
qed

lemma pochhammer_roots:
"k < n \<Longrightarrow> poly (PM (a::('a::comm_ring_1)) n) (of_nat k) = 0"
proof(induction n)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  fix n
  assume IH0: "(k < n) \<Longrightarrow> poly (PM a n) (of_nat k) = 0"
  assume IH1: "k < Suc n"
  have "(PM a (Suc n)) = (X - (of_nat n))*(PM a n)"
    by simp
  then show "poly (PM a (Suc n)) (of_nat k) = 0"
    using IH0 IH1 by (metis (no_types, lifting) diff_0
        diff_pCons diff_zero dvdI less_SucE mult_not_zero
        of_nat_poly poly_eq_0_iff_dvd poly_mult)
qed

lemma pochhammer_eval_nat:
  assumes "(a::('a::{idom, ring_char_0})) \<noteq>0"
  shows "k \<ge> d \<Longrightarrow> poly (PM a d) (of_nat k) = a * (of_nat (k choose d))*(pochhammer 1 d)"
proof(induction d)
  case 0
  have "(PM a 0)= smult a 1"
    by (simp add: monom_0)
  then show ?case
    by simp
next
  case (Suc n)
  fix n
  assume IH0: "k \<ge> n\<Longrightarrow>poly (PM a n) (of_nat k) = a * (of_nat (k choose n))*(pochhammer 1 n)"
  assume IH1: "k \<ge> Suc n"
  have "(PM a (Suc n)) = (X - of_nat n)*(PM a n)"
    by simp
  then have "poly (PM a (Suc n)) (of_nat k) = (poly (X - of_nat n) (of_nat k))* a * (of_nat (k choose n))*(pochhammer 1 n)"
    using IH0 IH1 by simp
  then have "poly (PM a (Suc n)) (of_nat k) = ((of_nat k) - of_nat n)* a * (of_nat (k choose n))*(pochhammer 1 n)"
    by (simp add: of_nat_poly)
  then have "poly (PM a (Suc n)) (of_nat k) =  a * ((of_nat k) - of_nat n)*(of_nat (k choose n))*(pochhammer 1 n)"
    by simp
  then have "poly (PM a (Suc n)) (of_nat k) =  a * (of_nat (k - n))*(of_nat (k choose n))*(pochhammer 1 n)"
    by (metis add_diff_cancel_left' binomial_eq_0
        le_add_diff_inverse linorder_not_le
        mult_cancel_right of_nat_add of_nat_eq_0_iff)
  then have "poly (PM a (Suc n)) (of_nat k) =  a * (of_nat ((k - n)*(k choose n)*(pochhammer 1 n)))"
    by (metis (no_types, lifting) mult.assoc
        of_nat_1 of_nat_mult pochhammer_of_nat)
  then have "poly (PM a (Suc n)) (of_nat k) =  a *(of_nat (k choose (Suc n))*(pochhammer 1 (Suc n)))"
    by (smt binomial_absorb_comp binomial_absorption mult.assoc
        mult.left_commute of_nat_1 of_nat_add of_nat_mult
        plus_1_eq_Suc pochhammer_of_nat pochhammer_rec')
  then show "poly (PM a (Suc n)) (of_nat k) = a * (of_nat (k choose Suc n)) *( pochhammer 1 (Suc n))"
    by simp
qed

lemma pochhammer_monom_pcompose:
"pcompose (pochhammer_monom a n) p =  smult a (pochhammer (p - (of_nat n) + 1) n)"
proof(induction n)
  case 0
  then show ?case by (simp add: pochhammer_monom_alt_def)
next
  case (Suc n)
  fix n
  assume IH: " (PM a n) \<circ>\<^sub>p p = smult a (pochhammer (p - of_nat n + 1) n)"
  show "(PM a (Suc n)) \<circ>\<^sub>p p = smult a (pochhammer (p - of_nat (Suc n) + 1) (Suc n))"
  proof-
    have  "(PM a (Suc n)) \<circ>\<^sub>p p = (X - (of_nat n)) \<circ>\<^sub>p p *(PM a n) \<circ>\<^sub>p p "
      by (simp add: pcompose_mult)
    then have "(PM a (Suc n)) \<circ>\<^sub>p p = (p - (of_nat n)) *(PM a n) \<circ>\<^sub>p p "
      using pcompose_pCons by (metis (no_types, lifting) add_cancel_left_left
        mult.commute mult.left_neutral of_nat_poly
        pCons_0_0 pCons_one pcompose_const pcompose_diff)
    then show ?thesis
      using IH pochhammer_monom_alt_def by (simp add: pochhammer_rec)
  qed
qed

(*******************************Pochhammer monomials have the correct degree***********************)

lemma pochhammer_leading_term:
  assumes "a \<noteq>0"
  shows "leading_term (pochhammer_monom a n) = monom a n"
proof(induction n)
  case 0
  then show ?case
    by (simp add: leading_term_def monom_0)
next
  case (Suc n)
  fix n
  assume IH: "leading_term (pochhammer_monom a n) = monom a n"
  show "leading_term (pochhammer_monom a (Suc n)) = monom a (Suc n)"
  proof-
    have P0:"pochhammer_monom a (Suc n)
            = (X - (of_nat n))*(pochhammer_monom a n)" by simp
    then have P1: "pochhammer_monom a (Suc n)
            = X*(pochhammer_monom a n) - (of_nat n)*(pochhammer_monom a n)"
      by (simp add: left_diff_distrib')
    have "(pochhammer_monom a n) \<noteq>0"
      by (metis IH assms coeff_diff degree_0
          degree_monom_eq diff_numeral_special(9)
          lead_coeff_monom leading_term_lead_coeff
          monom_eq_1 one_neq_zero)
    then have "degree (X*(monom a n)) > degree ((of_nat n)*(monom a n))"
      using degree_of_nat  by (metis add.left_neutral assms degree_mult_le
              degree_pCons_eq linorder_not_le monom_eq_0_iff
              mult.left_neutral mult_pCons_left not_less_eq_eq one_pCons smult_0_left)
    then have P2: "degree (X*(pochhammer_monom a n)) > degree ((of_nat n)*(pochhammer_monom a n))"
      using IH by (metis (no_types, lifting) add.left_neutral
                    degree_mult_le degree_of_nat degree_pCons_eq
                    lead_coeff_monom  leading_term_def  linorder_not_le
                    monom_eq_0_iff mult.left_neutral mult_pCons_left
                    not_less_eq_eq  one_pCons smult_0_left)
    then have "degree (pochhammer_monom a (Suc n))  = degree (X*(pochhammer_monom a n))"
      using P1 P2  by (smt IH P0 assms coeff_mult_degree_sum
                    degree_mult_le degree_pCons_eq diff_pCons
                    diff_zero le_degree lead_coeff_1 lead_coeff_monom
                    lead_coeff_pCons(1) leading_term_def mult.left_neutral
                    of_nat_poly one_neq_zero one_pCons order_antisym)
    then show ?thesis
      by (smt IH P1 P2 add.left_neutral
        assms coeff_diff degree_monom_eq
        degree_pCons_eq_if diff_zero le_degree
        lead_coeff_monom lead_coeff_pCons(1)
        leading_term_def linorder_not_le
        mult.left_neutral mult_not_zero
        mult_pCons_left one_pCons smult_0_left)
  qed
qed

lemma pochhammer_monom_degree:
  assumes "a \<noteq>0"
  shows "degree (pochhammer_monom a n) = n"
  using pochhammer_leading_term leading_term_degree by (metis assms degree_monom_eq)

(*****************************Pochhammer leading term function*************************************)

definition pochhammer_lt::"'a::comm_ring_1 poly \<Rightarrow> 'a poly" where
"pochhammer_lt p \<equiv> pochhammer_monom (lead_coeff p) (degree p)"

lemma pochhammer_lt_degree:
"degree (pochhammer_lt p) = degree p"
  by (metis  coeff_0_reflect_poly coeff_0_reflect_poly_0_iff
      degree_0 monom_eq_0 pochhammer_lt_def
      pochhammer_monom.simps(1) pochhammer_monom_degree)

lemma minus_pochhammer_leading_term:
  assumes "degree p >0"
  shows "degree (p - (pochhammer_lt p))< degree p"
proof-
  let ?n = "degree p"
  let ?q = "p - (pochhammer_lt p)"
  show "degree ?q < ?n"
  proof-
    have "leading_term p = leading_term ((pochhammer_lt p))"
      by (metis assms degree_0 leading_coeff_0_iff
        leading_term_def neq0_conv pochhammer_leading_term
        pochhammer_lt_def)
    then show ?thesis by (simp add: assms leading_term_eq_deg_less)
  qed
qed

lemma pochhammer_leading_term_decomp:
  assumes "degree (p::('a::comm_ring_1) poly) >0"
  obtains q where "p = q + (pochhammer_lt p)" and "degree q < degree p"
proof-
  let ?q = "p - (pochhammer_lt p)"
  let ?n = "degree p"
  have 0:"degree ?q < ?n"
    using minus_pochhammer_leading_term assms by blast
  then show ?thesis
    using that by force
qed

lemma pochhammer_monom_id:
  shows "(X - (of_nat n) + 1)*((PM a n) \<circ>\<^sub>p (X + 1)) = (X+1)*(PM a n)"
proof(induction n)
  case 0
  then show ?case by (simp add: monom_0)
next
  case (Suc n)
  fix n
  assume IH: "(X - (of_nat n) + 1)*((PM a n) \<circ>\<^sub>p (X + 1)) = (X+1)*(PM a n)"
  show "(X - (of_nat (Suc n)) + 1)*((PM a (Suc n)) \<circ>\<^sub>p (X + 1)) = (X+1)*(PM a (Suc n))"
    using pochhammer_monom_alt_def by (smt IH add.commute add_diff_cancel_left
        diff_add_eq mult.assoc mult.commute mult_smult_right
        of_nat_Suc pochhammer_monom_pcompose pochhammer_rec)
qed

(*******************Difference operator diff: p(x) \<Longrightarrow> p(x+1) - p(x)*******************************)

definition diff:: "('a::comm_ring_1) poly \<Rightarrow> ('a::comm_ring_1) poly" where
"diff p = pcompose  p [:1, 1:] - p"

(*difference operator is linear*)

lemma diff_additive:
"diff (p + q) = diff p + diff q"
  by (simp add: pcompose_add diff_def)

lemma diff_smult:
"diff (smult a q) = smult a (diff q)"
  by (simp add: diff_def pcompose_smult smult_diff_right)

lemma diff_mult_deg0:
  assumes "degree q = 0"
  shows "diff (q*p) = q* (diff p)"
  by (metis (no_types, lifting) assms degree_eq_zeroE
      diff_def left_diff_distrib' mult.commute pcompose_const pcompose_mult)

(**************************the difference operator evaluates as it should**************************)

lemma(in comm_ring_1)  diff_poly:
  shows "(poly (diff p)) x = ((poly p) (x+1)) - ((poly p) x)"
    by (simp add: diff_def poly_pcompose Groups.add_ac(2))

(******************************iterates of the difference operator*********************************)

fun diff_pow:: "nat \<Rightarrow> ('a::comm_ring_1) poly \<Rightarrow> 'a poly" ("\<Delta>[_]_ ") where
diff_pow_0: "diff_pow 0 p = p"|
diff_pow_suc: "diff_pow (Suc n) p = diff (diff_pow n p)"

lemma diff_pow_compose: "diff_pow (n+m) p = diff_pow n (diff_pow m p)"
proof(induction n arbitrary: m)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  then show ?case
    by simp
qed

lemma diff_pow_additive: "diff_pow n (p+q) = (diff_pow n p) + (diff_pow n q)"
 proof(induction n)
  case 0
  then show ?case
    using diff_pow_0 by simp
next
  case (Suc n)
  then show ?case
    by (simp add: diff_additive)
qed

(********************characterization of degree in terms of the difference operator****************)

lemma diff_const:
assumes "degree p = 0"
shows "diff p = 0"
proof-
  have "pcompose  p [:1, 1:] = p"
    using assms by (metis degree_eq_zeroE pcompose_const)
  then show ?thesis by (simp add: diff_def)
qed

lemma diff_pow_const:
assumes "degree p = 0"
shows "diff_pow (Suc n) p = 0"
proof(induction n)
  case 0
  then show ?case
    by (simp add: diff_const assms)
next
  case (Suc n)
  then show ?case
    by (simp add: diff_const)
qed

lemma one_not_zero:
"([:1:]:: ('a::comm_ring_1) poly) \<noteq> [:0:]"
  by simp

lemma diff_degree:
  assumes "degree (p::('a::{comm_ring_1}) poly) > 0"
  shows "degree p > (degree (diff p))"
proof-
  have 0:"lead_coeff [:1, 1:] = 1"
    by simp
  have "degree [:(1::'a), 1:] =  (Suc (degree [:1:]))" using  degree_pCons_eq one_not_zero
    by simp
  then have 1: "degree [:(1::'a), 1:] = 1"
    by simp
  then have "degree ([:(1::'a), 1:]) > 0"
    by simp
  then have 2: "leading_term (pcompose  p [:1, 1:]) = leading_term p"
    by (metis (no_types, lifting) add.left_neutral
        add.right_neutral add_pCons degree_1
          leading_term_monic_lin_comp one_pCons)
  from 1 have "degree (pcompose p [:1,1:]) = degree p"
     by (metis "2" leading_term_degree)
  then show ?thesis
    using 2 assms(1) diff_def leading_term_eq_deg_less by metis
qed

(*remove SMT!*)
lemma diff_pow_degree0:
  assumes "degree (p::('a::{comm_ring_1}) poly) > 0"
  shows "n <degree p \<Longrightarrow>(degree p) - n \<ge> degree ((diff_pow n) p)"
proof(induction n)
  case 0
  then show ?case
   by (simp add: assms(1))
next
  case (Suc n)
  fix n
  assume IH: "n < degree p \<Longrightarrow> degree (diff_pow n p) \<le> degree p - n"
  show "Suc n < degree p \<Longrightarrow> degree (diff_pow (Suc n) p) \<le> degree p - (Suc n)"
  proof-
    assume "Suc n < degree p"
    consider "degree (diff_pow n p) = 0" | "degree (diff_pow n p) >0"
      by blast
    have "degree (diff_pow n p) = 0 \<or> degree (diff_pow (Suc n) p) < degree (diff_pow n p)"
        using diff_pow_suc diff_degree  by auto
    then show ?thesis
      using IH by (smt Suc_diff_Suc \<open>Suc n < degree p\<close>
          degree_0 diff_const le_Suc_eq less_Suc_eq_le
          less_eq_nat.simps(1) less_le_trans not_le
          pochhammer_monomials.diff_pow_suc)
  qed
qed

(********The nth iterate of the difference operator sends degree m<n polynomials to 0*************)

lemma diff_pow_zero:
  shows "degree (p::('a::{comm_ring_1}) poly) <n \<Longrightarrow> diff_pow n p = 0"
proof(cases "degree p = 0")
  case True
  assume  "degree p <n"
  then have "n >0" by auto
  then show "diff_pow n p = 0" using diff_pow_const
    by (metis Suc_pred True)
next
  case False
  assume A: "degree p <n"
  then have B: "degree p > 0" using False by simp
  let ?n = "(degree p) - 1"
  have "?n < degree p" using B by auto
  then have "1 \<ge> degree (diff_pow ?n  p)" using B diff_pow_degree0
    by (metis One_nat_def Suc_diff_Suc
        cancel_comm_monoid_add_class.diff_cancel
        diff_zero)
  then have "degree (diff_pow (?n + 1) p) < 1"
    by (metis One_nat_def add.commute
        degree_0 diff_const diff_degree diff_pow.simps(2)
        le_Suc_eq le_zero_eq less_one plus_1_eq_Suc)
  then have "degree (diff_pow (?n + 1) p) = 0" by auto
  then have "degree (diff_pow (?n + 1 + (n - (?n + 2))) p) = 0"
    using diff_pow_compose diff_pow_const  by (metis (no_types, lifting) Suc_diff_Suc
                                          add.commute add_cancel_left_right
                                          degree_0 neq0_conv zero_less_diff)
  then have "degree (diff_pow (n-1) p) = 0"
    by (simp add: A B Suc_leI)
  then show ?thesis
    by (metis A B diff_Suc_1
        diff_const diff_pow.elims
        dual_order.strict_trans less_irrefl)
qed

(************************Power rule for diff and pochhammer monomials****************************)

lemma diff_pochhammer_monom:
  "diff (PM a (Suc n)) = (of_nat (Suc n))*(PM a n)"
proof(induction n)
  case 0
  have P0: "(pochhammer_monom a (Suc 0)) = (monom a 1)"
    by (simp add: monom_altdef)
  then have P1: "diff (pochhammer_monom a (Suc 0)) = pcompose  (monom a 1) [:1, 1:] - (monom a 1)"
    by (simp add: diff_def)
  then have "diff (pochhammer_monom a (Suc 0)) = monom a 0"
    by (simp add: monom_0 monom_Suc pcompose_pCons)
  then show ?case by simp
next
  case (Suc n)
  fix n
  let ?n = "Suc n"
  assume IH: "diff (PM a ?n) = of_nat (?n) * (PM a n) "
  then show  "diff (PM a (Suc ?n)) = of_nat (Suc ?n) * PM a ?n"
  proof-
    have "(PM a (Suc ?n)) = (X - of_nat ?n)*(PM a ?n)"
      by simp
    then have P: "diff (PM a (Suc ?n)) = (X  - of_nat ?n)\<circ>\<^sub>p (X + 1) *((PM a ?n) \<circ>\<^sub>p (X + 1)) - (X - of_nat ?n)*(PM a ?n)"
      by (simp add: diff_def one_pCons pcompose_mult)
    have Q:"(X  - of_nat ?n)\<circ>\<^sub>p (X + 1) =  (X   - (of_nat ?n) + 1)"
      by (simp add: of_nat_poly one_pCons pcompose_pCons)
    then have "diff (PM a (Suc ?n)) = (X + 1  - (of_nat ?n)) *((PM a ?n) \<circ>\<^sub>p (X + 1)) - (X - of_nat ?n)*(PM a ?n)"
      using  P by (smt diff_add_eq)
    then have "diff (PM a (Suc ?n)) = (X+1)*(PM a ?n) - (X - of_nat ?n)*(PM a ?n)"
      by (metis P Q pochhammer_monom_id)
    then have "diff (PM a (Suc ?n)) = (1 +  of_nat ?n)*(PM a ?n)"
      by (metis (no_types, lifting)
          add_diff_cancel_left'
          diff_add_cancel diff_add_eq
          left_diff_distrib')
    then show ?thesis by simp
  qed
qed

(***********************************Generalized power rule*****************************************)

lemma diff_pow_pochhammer_monom0:
 shows "n \<ge> k \<Longrightarrow> (\<Delta>[k] (PM a (n+1))) = (pochhammer (of_nat (n + 2 - k)) k)*(PM a (n + 1 - k))"
proof(induction k)
  case 0
  then show ?case by simp
next
  case (Suc k)
  show "\<And>k. (n \<ge> k \<Longrightarrow> (\<Delta>[k] (PM a (n + 1)))  = (pochhammer (of_nat  (n + 2 - k)) k) *( PM a  (n + 1 - k))) \<Longrightarrow>
            n \<ge>(Suc k) \<Longrightarrow> (\<Delta>[Suc k](PM a (n + 1)))  = (pochhammer (of_nat  (n + 2 - (Suc k))) (Suc k)) * (PM a (n + 1 - (Suc k)))"
  proof-
    fix k::nat
    show "(n \<ge>k \<Longrightarrow> (\<Delta>[k] (PM a (n + 1))) = (pochhammer (of_nat  (n + 2 - k)) k) *( PM a  (n + 1 - k))) \<Longrightarrow>
           n \<ge>(Suc k) \<Longrightarrow>   (\<Delta>[Suc k](PM a (n + 1)))  = (pochhammer (of_nat  (n + 2 - (Suc k))) (Suc k)) * (PM a (n + 1 - (Suc k)))"
    proof-
      assume IH0: "(n \<ge>k \<Longrightarrow> (\<Delta>[k] (PM a (n + 1)))  = (pochhammer (of_nat  (n + 2 - k)) k) *( PM a  (n + 1 - k)))"
      show "n \<ge>(Suc k) \<Longrightarrow> (\<Delta>[Suc k](PM a (n + 1))) = (pochhammer (of_nat  (n + 2 - (Suc k))) (Suc k)) * (PM a (n + 1 - (Suc k)))"
      proof-
        assume A: "n \<ge>(Suc k)"
        show " (\<Delta>[Suc k](PM a (n + 1)))  =  (pochhammer (of_nat  (n + 2 - (Suc k))) (Suc k)) * (PM a (n + 1 - (Suc k)))"
        proof-
          have IH: "(\<Delta>[k] (PM a (n + 1))) = (pochhammer (of_nat  (n + 2 - k)) k) *( PM a  (n + 1 - k))"
            using IH0 Suc_lessD A Suc_leD by blast
          let ?p = "(\<Delta>[k] (PM a (n+1)))"
          let ?q = " (pochhammer (of_nat  (n + 2 - k)) k) *( PM a  (n + 1 - k))"
          have  "?p = ?q" using IH by blast
          then have I: "diff ?p = diff ?q" by simp
          have  "(\<Delta>[Suc k] (PM a (n+1))) = diff ?p"  by simp
          then have P: "(\<Delta>[Suc k] (PM a (n+1))) = diff ?q" using I by auto
          have Q: "diff ?q = (pochhammer (of_nat (n + 2 - k)) k)*(diff (PM a (n + 1 - k)))"
            using diff_mult_deg0 by (metis degree_of_nat pochhammer_of_nat)
          then have R: "diff ?q = (pochhammer (of_nat (n + 2 - k)) k)
                            *(of_nat (n + 1 - k))*(PM a (n - k))"
            using diff_pochhammer_monom  by (metis (no_types, lifting)
                    A Suc_diff_le Suc_leD add.commute mult.assoc plus_1_eq_Suc)
          have  "(pochhammer (of_nat (n + 2 - k)) k)*(of_nat (n + 1 - k))
               =  (pochhammer (of_nat (n +  1 - k)) (Suc k))"
            by (simp add: A Suc_diff_le Suc_leD
                add.commute mult.commute pochhammer_rec)
          then have S: "diff ?q = (pochhammer (of_nat (n + 1 - k)) (Suc k))*(PM a (n - k))"
            using R  by metis
          then have T: "(\<Delta>[Suc k] (PM a (n+1)))
               = (pochhammer (of_nat (n + 1 - k)) (Suc k))*(PM a (n - k))"
            using P by simp
          have "n + 2 - (Suc k) =  n + 1 - k"
            using A by linarith
          then have "(\<Delta>[Suc k] (PM a (n+1)))
                 = (pochhammer (of_nat (n + 2 - (Suc k) )) (Suc k))*(PM a (n + 1 - (Suc k)))"
            using T by auto
          then show ?thesis by auto
        qed
      qed
    qed
  qed
qed

lemma diff_pow_pochhammer_monom1:
"(\<Delta>[n] (PM a (n))) = (pochhammer (of_nat (1)) n)* (PM a (0))"
proof(cases "n = 0")
  case True
  then show ?thesis by simp
next
  case False
  let ?n = "n-1"
  have P: "(\<Delta>[?n] (PM a (?n+1))) = (pochhammer (of_nat (2)) ?n)*(PM a 1)"
     using diff_pow_pochhammer_monom0 by (metis (no_types, lifting) add.right_neutral
                                     add_diff_cancel_left' le_numeral_extra(3)
                                      nat_add_left_cancel_le of_nat_1 of_nat_add one_add_one)
  then have "(\<Delta>[n] (PM a (n))) = diff (\<Delta>[?n] (PM a (?n+1)))"
     using False by (metis One_nat_def Suc_diff_Suc
         add.commute diff_zero neq0_conv
         plus_1_eq_Suc pochhammer_monomials.diff_pow_suc)
  then have "(\<Delta>[n] (PM a (n))) = diff ((pochhammer (of_nat (2)) ?n)*(PM a 1))" using P
     by auto
  then have Q:  "(\<Delta>[n] (PM a (n))) = (pochhammer (of_nat 2) ?n)*(diff (PM a 1))"
     using diff_mult_deg0 by (metis degree_of_nat pochhammer_of_nat)
  have "(diff (PM a 1)) =((of_nat 1)*((PM a 0)))"
    using diff_pochhammer_monom  by (metis One_nat_def)
  then have  "(\<Delta>[n] (PM a (n))) = (pochhammer (of_nat 2) ?n)*((of_nat 1)*(PM a 0))"
    using Q by simp
  then show ?thesis  by (simp add: pochhammer_rec_if)
qed

lemma diff_pow_pochhammer_monom:
 assumes "a \<noteq>0"
 shows "(\<Delta>[k] (PM (a::('a::comm_ring_1)) (n+1)))
                = (pochhammer (of_nat (n + 2 - k)) k)*(PM a (n + 1 - k))"
proof(cases "n + 1 \<ge>k")
  case True
  then show ?thesis
  proof(cases "n \<ge>k")
    case True
    then show ?thesis
      using diff_pow_pochhammer_monom0 by blast
  next
    case F: False
    then show ?thesis
      using True F diff_pow_pochhammer_monom1  by (metis One_nat_def Suc_diff_le
          add.commute add_2_eq_Suc' diff_diff_cancel
          diff_is_0_eq diff_zero not_less_eq_eq plus_1_eq_Suc)
  qed
  next
   case F: False
   have IE: "k > n+1" using F by auto
   let ?p = "PM (a::('a::comm_ring_1)) (n+1)"
   have "degree ?p = n+1"
     using assms pochhammer_monom_degree by blast
   then have "degree ?p < k"
     using IE by auto
   then have A: "(\<Delta>[k] ?p) = 0" using diff_pow_zero
     by blast
   have "(pochhammer (of_nat (n + 2 - k)) k) = 0"
      by (metis F Suc_eq_plus1 add_2_eq_Suc'
       diff_is_0_eq' eq_imp_le le_trans linorder_not_le
       not_less_eq_eq of_nat_0 pochhammer_0_left  zero_less_Suc)
   then have  "(pochhammer (of_nat (n + 2 - k)) k)*(PM a (n + 1 - k)) = 0"
     using mult_not_zero by blast
   then have " ((pochhammer (of_nat (n + 2 - k)) k)*(PM a (n + 1 - k))) = 0"
     by blast
   then show "(\<Delta>[k] (PM (a::('a::comm_ring_1)) (n+1))) = (pochhammer (of_nat (n + 2 - k)) k)*(PM a (n + 1 - k))"
     using A by auto
qed

lemma diff_pow_greater_deg:
  assumes "a \<noteq>0"
  assumes "k>n"
  shows "(\<Delta>[k](PM (a::('a::comm_ring_1)) n)) = 0"
proof-
  let ?n = "k - n"
  have "(\<Delta>[k](PM (a::('a::comm_ring_1)) n)) = \<Delta>[?n](\<Delta>[n](PM (a::('a::comm_ring_1)) n))"
    by (metis add.commute assms(2)
        diff_pow_compose le_add_diff_inverse
        linorder_not_le nat_le_linear)
  then have "(\<Delta>[k](PM (a::('a::comm_ring_1)) n)) = \<Delta>[?n]((pochhammer 2 n))"
    by (metis assms(1) assms(2) degree_of_nat
        diff_pow_zero of_nat_numeral
        pochhammer_monom_degree pochhammer_of_nat
        zero_less_diff)
  then show "(\<Delta>[k](PM (a::('a::comm_ring_1)) n)) = 0"
    by (simp add: assms(1) assms(2) diff_pow_zero pochhammer_monom_degree)
qed

end


(*  Title:      CCL/ex/Nat.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section {* Programs defined over the natural numbers *}

theory Nat
imports "../Wfd"
begin

definition not :: "i\<Rightarrow>i"
  where "not(b) == if b then false else true"

definition add :: "[i,i]\<Rightarrow>i"  (infixr "#+" 60)
  where "a #+ b == nrec(a, b, \<lambda>x g. succ(g))"

definition mult :: "[i,i]\<Rightarrow>i"  (infixr "#*" 60)
  where "a #* b == nrec(a, zero, \<lambda>x g. b #+ g)"

definition sub :: "[i,i]\<Rightarrow>i"  (infixr "#-" 60)
  where
    "a #- b ==
      letrec sub x y be ncase(y, x, \<lambda>yy. ncase(x, zero, \<lambda>xx. sub(xx,yy)))
      in sub(a,b)"

definition le :: "[i,i]\<Rightarrow>i"  (infixr "#<=" 60)
  where
    "a #<= b ==
      letrec le x y be ncase(x, true, \<lambda>xx. ncase(y, false, \<lambda>yy. le(xx,yy)))
      in le(a,b)"

definition lt :: "[i,i]\<Rightarrow>i"  (infixr "#<" 60)
  where "a #< b == not(b #<= a)"

definition div :: "[i,i]\<Rightarrow>i"  (infixr "##" 60)
  where
    "a ## b ==
      letrec div x y be if x #< y then zero else succ(div(x#-y,y))
      in div(a,b)"

definition ackermann :: "[i,i]\<Rightarrow>i"
  where
    "ackermann(a,b) ==
      letrec ack n m be ncase(n, succ(m), \<lambda>x.
        ncase(m,ack(x,succ(zero)), \<lambda>y. ack(x,ack(succ(x),y))))
      in ack(a,b)"

lemmas nat_defs = not_def add_def mult_def sub_def le_def lt_def ackermann_def napply_def

lemma natBs [simp]:
  "not(true) = false"
  "not(false) = true"
  "zero #+ n = n"
  "succ(n) #+ m = succ(n #+ m)"
  "zero #* n = zero"
  "succ(n) #* m = m #+ (n #* m)"
  "f^zero`a = a"
  "f^succ(n)`a = f(f^n`a)"
  by (simp_all add: nat_defs)

lemma napply_f: "n:Nat \<Longrightarrow> f^n`f(a) = f^succ(n)`a"
  apply (erule Nat_ind)
   apply simp_all
  done

lemma addT: "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> a #+ b : Nat"
  apply (unfold add_def)
  apply typechk
  done

lemma multT: "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> a #* b : Nat"
  apply (unfold add_def mult_def)
  apply typechk
  done

(* Defined to return zero if a<b *)
lemma subT: "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> a #- b : Nat"
  apply (unfold sub_def)
  apply typechk
  apply clean_ccs
  apply (erule NatPRI [THEN wfstI, THEN NatPR_wf [THEN wmap_wf, THEN wfI]])
  done

lemma leT: "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> a #<= b : Bool"
  apply (unfold le_def)
  apply typechk
  apply clean_ccs
  apply (erule NatPRI [THEN wfstI, THEN NatPR_wf [THEN wmap_wf, THEN wfI]])
  done

lemma ltT: "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> a #< b : Bool"
  apply (unfold not_def lt_def)
  apply (typechk leT)
  done

subsection {* Termination Conditions for Ackermann's Function *}

lemmas relI = NatPR_wf [THEN NatPR_wf [THEN lex_wf, THEN wfI]]

lemma "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> ackermann(a,b) : Nat"
  apply (unfold ackermann_def)
  apply gen_ccs
  apply (erule NatPRI [THEN lexI1 [THEN relI]] NatPRI [THEN lexI2 [THEN relI]])+
  done

end


subsection \<open>Permutability and Isomorphical Uniqueness\<close>

theory StructuralPropertiesTheorems
  imports IsomorphicalUniqueness Permutability CollapsibleParticulars
begin

context ufo_particular_theory
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>It turns out that the set of isomorphically unique particulars of a particular
  structure is identical to the set of non-permutable particulars, as shown in the
  following theorem and lemmas:\<close>

lemma im_unique_particulars_are_non_permutable_particulars:
    \<open>\<P>\<^sub>\<simeq>\<^sub>! \<subseteq> \<P>\<^sub>1\<^sub>!\<close>
proof (intro subsetI ballI ; clarsimp simp: isomorphically_unique_particulars_def)
  fix x \<phi> y
  assume as1: \<open>particular_struct_endomorphism \<Gamma> \<phi>\<close> \<open>x \<in> \<E>\<close>
      \<open>\<forall>\<phi>\<in>BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>. \<forall>\<sigma>\<in>Morphs\<^bsub>\<Gamma>,MorphImg \<phi> \<Gamma>\<^esub>.\<forall>y\<in>\<E>. (\<sigma> y = \<phi> x) = (y = x)\<close>
      \<open>y \<in> \<E>\<close>
  interpret I: particular_struct_endomorphism \<open>\<Gamma>\<close> \<open>\<phi>\<close> using as1(1) by blast
  have A: \<open>\<sigma> y = \<phi> x \<longleftrightarrow> y = x\<close> if \<open>\<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close> \<open>\<sigma> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<phi> \<Gamma>\<^esub>\<close> \<open>y \<in> \<E>\<close> for \<phi> \<sigma> y
    using that as1(3) by metis
  obtain \<pi> :: \<open>'p \<Rightarrow> ZF\<close> where \<open>inj \<pi>\<close>
    using injection_to_ZF_exist by blast
  have pi_isomorph: \<open>\<pi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    using  \<open>inj \<pi>\<close> by (meson UNIV_I inj_morph_img_BijMorphs inj_on_id inj_on_subset subsetI)
  have pi_sigma_morph: \<open>\<pi> \<circ> \<phi> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<pi> \<Gamma>\<^esub>\<close>
    by (meson I.particular_struct_morphism_axioms bijections1_are_morphisms morphisms_are_closed_under_comp morphs_I pi_isomorph)
  have \<open>\<pi> x = \<pi> (\<phi> x)\<close>
    using A[of \<open>\<pi>\<close> \<open>\<pi> \<circ> \<phi>\<close>, OF pi_isomorph pi_sigma_morph \<open>x \<in> \<E>\<close>,simplified]
    by simp
  then have \<open>x = \<phi> x\<close>
    by (rule \<open>inj \<pi>\<close>[THEN inj_onD]; simp)
  then show \<open>\<phi> y = x \<longleftrightarrow> y = x\<close>
    apply (intro iffI ; simp)
    by (rule A[where y=y and \<phi> = \<pi> and \<sigma> = \<open>\<pi> \<circ> \<phi>\<close>,OF _ _ \<open>y \<in> \<E>\<close>,simplified o_apply
          , THEN iffD1] ; (intro pi_sigma_morph pi_isomorph)? ; simp)
qed

lemma non_permutable_particulars_are_im_unique_particulars:
  \<open>\<P>\<^sub>1\<^sub>! \<subseteq> \<P>\<^sub>\<simeq>\<^sub>!\<close>
proof (intro subsetI ballI ; clarsimp simp: isomorphically_unique_particulars_def)
  fix x y :: \<open>'p\<close> and \<phi> \<sigma> :: \<open>'p \<Rightarrow> 'p\<^sub>1\<close> and f :: \<open>'p\<^sub>1 \<Rightarrow> ZF\<close>
  assume as:
      \<open>particular_struct_morphism \<Gamma> (MorphImg \<phi> \<Gamma>) \<sigma>\<close>
      \<open>\<forall>\<phi>\<in>EndoMorphs\<^bsub>\<Gamma>\<^esub>. \<forall>y\<in>\<E>. \<phi> y = x \<longleftrightarrow> y = x\<close>
      \<open>inj_on \<phi> \<E>\<close>
      \<open>inj f\<close>
      \<open>x \<in> \<E>\<close>
      \<open>y \<in> \<E>\<close>
  have A: \<open>\<phi> y = x \<longleftrightarrow> y = x\<close> if \<open>\<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close> \<open>y \<in> \<E>\<close> for \<phi> y using as(2) that by blast
  interpret I1: particular_struct_morphism \<open>\<Gamma>\<close> \<open>MorphImg \<phi> \<Gamma>\<close> \<open>\<sigma>\<close> using as(1) by simp
  interpret I: particular_struct_bijection_1 \<open>\<Gamma>\<close> \<open>\<phi>\<close>
    using as(3,4) inj_morph_img_isomorphism[of \<open>\<phi>\<close>] by blast
  interpret Inv: particular_struct_bijection_1 \<open>MorphImg \<phi> \<Gamma>\<close> \<open>I.inv_morph\<close>
    using particular_struct_bijection_iff_particular_struct_bijection_1 by blast

  have B: \<open>particular_struct_morphism \<Gamma> \<Gamma> (I.inv_morph \<circ> \<sigma>)\<close>
    apply (intro particular_struct_morphism_comp[of _ \<open>MorphImg \<phi> \<Gamma>\<close>])
    subgoal using I1.particular_struct_morphism_axioms by blast
    by (simp add: particular_struct_bijection.axioms(1) particular_struct_injection.axioms(1))

  have C: \<open>I.inv_morph \<circ> \<sigma> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close>
    apply (simp)
    apply (intro_locales)
   using B particular_struct_morphism_def
      pre_particular_struct_morphism_def by blast+

  have D: \<open>I.inv_morph (\<sigma> x) = x\<close> using A[OF C \<open>x \<in> \<E>\<close>,simplified] .
  have E: \<open>I.inv_morph (\<phi> x) = x\<close> using \<open>x \<in> \<E>\<close> by simp
  have F: \<open>I.inv_morph (\<sigma> x) = I.inv_morph (\<phi> x)\<close> using D E by simp
  show \<open>\<sigma> y = \<phi> x \<longleftrightarrow> y = x\<close>
    apply (intro iffI ; simp?)
    subgoal
      apply (rule A[where y=y and \<phi> = \<open>I.inv_morph \<circ> \<sigma>\<close>,OF C \<open>y \<in> \<E>\<close>,THEN iffD1])
      by (simp add: E)
    subgoal
      apply (rule F inj_onD[OF Inv.morph_is_injective,simplified,OF F])
      subgoal using \<open>x \<in> \<E>\<close> by (simp add: I1.morph_preserves_particulars)
      using \<open>x \<in> \<E>\<close> by (simp add: I.morph_preserves_particulars)
    done
qed

theorem non_permutable_particulars_are_the_unique_particulars:
    \<open>\<P>\<^sub>1\<^sub>! = \<P>\<^sub>\<simeq>\<^sub>!\<close>
  using im_unique_particulars_are_non_permutable_particulars
     non_permutable_particulars_are_im_unique_particulars by simp

text \<^marker>\<open>tag bodyonly\<close> \<open>
  The set of non-permutable particulars is a subset of the set of
  non-collapsible particulars, although the converse does not
  hold, in general:
\<close>

theorem  non_permutables_are_non_collapsible: \<open>\<P>\<^sub>1\<^sub>! \<subseteq> \<P>\<^sub>n\<^sub>c\<close>
proof (intro subsetI ; elim non_permutables_E ;
        intro nonCollapsibleParticularsI notI ;
        (elim collapsibleE)? ; assumption?
        ; rename_tac x\<^sub>1 \<phi> x\<^sub>2)
  fix x\<^sub>1 x\<^sub>2 \<phi>
  assume A: \<open>x\<^sub>1 \<in> \<E>\<close> \<open>x\<^sub>2 \<in> \<E>\<close> \<open>x\<^sub>1 \<noteq> x\<^sub>2\<close> \<open>\<phi> x\<^sub>1 = \<phi> x\<^sub>2\<close>
    and B: \<open>non_permutable x\<^sub>1\<close> \<open>\<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close>
  note A(1,2)[simp,intro!]
  note A1[simp] = A(3)[simplified A(4)] A(4)
  interpret phi: particular_struct_endomorphism \<Gamma> \<phi> using B(2) by simp
  note C1 = B(1)[THEN non_permutable_E,OF B(2) \<open>x\<^sub>2 \<in> \<E>\<close>] and
       C2 = B(1)[THEN non_permutable_E,OF B(2) \<open>x\<^sub>1 \<in> \<E>\<close>]
  have D[simp]: \<open>\<phi> x\<^sub>1 = x\<^sub>1\<close> using C2 by simp
  show False
    using A1(1) A1(2) C1 D by presburger
qed

end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_bin_distrib
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs1) y = ZeroAnd (times xs1 y)"
| "times (OneAnd xs12) y = plus (ZeroAnd (times xs12 y)) y"

theorem property0 :
  "((times x (plus y z)) = (plus (times x y) (times x z)))"
  oops

end


theory NFA
  imports "HOL-Library.IArray"
begin

type_synonym state = nat

datatype transition = eps_trans state nat | symb_trans state | split_trans state state

fun state_set :: "transition \<Rightarrow> state set" where
  "state_set (eps_trans s _) = {s}"
| "state_set (symb_trans s) = {s}"
| "state_set (split_trans s s') = {s, s'}"

fun fmla_set :: "transition \<Rightarrow> nat set" where
  "fmla_set (eps_trans _ n) = {n}"
| "fmla_set _ = {}"

lemma rtranclp_closed: "rtranclp R q q' \<Longrightarrow> X = X \<union> {q'. \<exists>q \<in> X. R q q'} \<Longrightarrow>
  q \<in> X \<Longrightarrow> q' \<in> X"
  by (induction q q' rule: rtranclp.induct) auto

lemma rtranclp_closed_sub: "rtranclp R q q' \<Longrightarrow> {q'. \<exists>q \<in> X. R q q'} \<subseteq> X \<Longrightarrow>
  q \<in> X \<Longrightarrow> q' \<in> X"
  by (induction q q' rule: rtranclp.induct) auto

lemma rtranclp_closed_sub': "rtranclp R q q' \<Longrightarrow> q' = q \<or> (\<exists>q''. R q q'' \<and> rtranclp R q'' q')"
  using converse_rtranclpE by force

lemma rtranclp_step: "rtranclp R q q'' \<Longrightarrow> (\<And>q'. R q q' \<longleftrightarrow> q' \<in> X) \<Longrightarrow>
  q = q'' \<or> (\<exists>q' \<in> X. R q q' \<and> rtranclp R q' q'')"
  by (induction q q'' rule: rtranclp.induct)
     (auto intro: rtranclp.rtrancl_into_rtrancl)

lemma rtranclp_unfold: "rtranclp R x z \<Longrightarrow> x = z \<or> (\<exists>y. R x y \<and> rtranclp R y z)"
  by (induction x z rule: rtranclp.induct) auto

context fixes
  q0 :: "state" and
  qf :: "state" and
  transs :: "transition list"
begin

(* sets of states *)

qualified definition SQ :: "state set" where
  "SQ = {q0..<q0 + length transs}"

lemma q_in_SQ[code_unfold]: "q \<in> SQ \<longleftrightarrow> q0 \<le> q \<and> q < q0 + length transs"
  by (auto simp: SQ_def)

lemma finite_SQ: "finite SQ"
  by (auto simp add: SQ_def)

lemma transs_q_in_set: "q \<in> SQ \<Longrightarrow> transs ! (q - q0) \<in> set transs"
  by (auto simp add: SQ_def)

qualified definition Q :: "state set" where
  "Q = SQ \<union> {qf}"

lemma finite_Q: "finite Q"
  by (auto simp add: Q_def SQ_def)

lemma SQ_sub_Q: "SQ \<subseteq> Q"
  by (auto simp add: SQ_def Q_def)

(* set of formula indices *)

qualified definition nfa_fmla_set :: "nat set" where
  "nfa_fmla_set = \<Union>(fmla_set ` set transs)"

(* step relation *)

qualified definition step_eps :: "bool list \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
  "step_eps bs q q' \<longleftrightarrow> q \<in> SQ \<and>
    (case transs ! (q - q0) of eps_trans p n \<Rightarrow> n < length bs \<and> bs ! n \<and> p = q'
    | split_trans p p' \<Rightarrow> p = q' \<or> p' = q' | _ \<Rightarrow> False)"

lemma step_eps_dest: "step_eps bs q q' \<Longrightarrow> q \<in> SQ"
  by (auto simp add: step_eps_def)

lemma step_eps_mono: "step_eps [] q q' \<Longrightarrow> step_eps bs q q'"
  by (auto simp: step_eps_def split: transition.splits)

(* successors in step relation *)

qualified definition step_eps_sucs :: "bool list \<Rightarrow> state \<Rightarrow> state set" where
  "step_eps_sucs bs q = (if q \<in> SQ then
    (case transs ! (q - q0) of eps_trans p n \<Rightarrow> if n < length bs \<and> bs ! n then {p} else {}
    | split_trans p p' \<Rightarrow> {p, p'} | _ \<Rightarrow> {}) else {})"

lemma step_eps_sucs_sound: "q' \<in> step_eps_sucs bs q \<longleftrightarrow> step_eps bs q q'"
  by (auto simp add: step_eps_sucs_def step_eps_def split: transition.splits)

qualified definition step_eps_set :: "bool list \<Rightarrow> state set \<Rightarrow> state set" where
  "step_eps_set bs R = \<Union>(step_eps_sucs bs ` R)"

lemma step_eps_set_sound: "step_eps_set bs R = {q'. \<exists>q \<in> R. step_eps bs q q'}"
  using step_eps_sucs_sound by (auto simp add: step_eps_set_def)

lemma step_eps_set_mono: "R \<subseteq> S \<Longrightarrow> step_eps_set bs R \<subseteq> step_eps_set bs S"
  by (auto simp add: step_eps_set_def)

(* reflexive and transitive closure of step relation *)

qualified definition step_eps_closure :: "bool list \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
  "step_eps_closure bs = (step_eps bs)\<^sup>*\<^sup>*"

lemma step_eps_closure_dest: "step_eps_closure bs q q' \<Longrightarrow> q \<noteq> q' \<Longrightarrow> q \<in> SQ"
  unfolding step_eps_closure_def
  apply (induction q q' rule: rtranclp.induct) using step_eps_dest by auto

qualified definition step_eps_closure_set :: "state set \<Rightarrow> bool list \<Rightarrow> state set" where
  "step_eps_closure_set R bs = \<Union>((\<lambda>q. {q'. step_eps_closure bs q q'}) ` R)"

lemma step_eps_closure_set_refl: "R \<subseteq> step_eps_closure_set R bs"
  by (auto simp add: step_eps_closure_set_def step_eps_closure_def)

lemma step_eps_closure_set_mono: "R \<subseteq> S \<Longrightarrow> step_eps_closure_set R bs \<subseteq> step_eps_closure_set S bs"
  by (auto simp add: step_eps_closure_set_def)

lemma step_eps_closure_set_empty: "step_eps_closure_set {} bs = {}"
  by (auto simp add: step_eps_closure_set_def)

lemma step_eps_closure_set_mono': "step_eps_closure_set R [] \<subseteq> step_eps_closure_set R bs"
  by (auto simp: step_eps_closure_set_def step_eps_closure_def) (metis mono_rtranclp step_eps_mono)

lemma step_eps_closure_set_split: "step_eps_closure_set (R \<union> S) bs =
  step_eps_closure_set R bs \<union> step_eps_closure_set S bs"
  by (auto simp add: step_eps_closure_set_def)

lemma step_eps_closure_set_Un: "step_eps_closure_set (\<Union>x \<in> X. R x) bs =
  (\<Union>x \<in> X. step_eps_closure_set (R x) bs)"
  by (auto simp add: step_eps_closure_set_def)

lemma step_eps_closure_set_idem: "step_eps_closure_set (step_eps_closure_set R bs) bs =
  step_eps_closure_set R bs"
  unfolding step_eps_closure_set_def step_eps_closure_def by auto

lemma step_eps_closure_set_flip:
  assumes "step_eps_closure_set R bs = R \<union> S"
  shows "step_eps_closure_set S bs \<subseteq> R \<union> S"
  using step_eps_closure_set_idem[of R bs, unfolded assms, unfolded step_eps_closure_set_split]
  by auto

lemma step_eps_closure_set_unfold: "(\<And>q'. step_eps bs q q' \<longleftrightarrow> q' \<in> X) \<Longrightarrow>
  step_eps_closure_set {q} bs = {q} \<union> step_eps_closure_set X bs"
  unfolding step_eps_closure_set_def step_eps_closure_def
  using rtranclp_step[of "step_eps bs" q]
  by (auto simp add: converse_rtranclp_into_rtranclp)

lemma step_step_eps_closure: "step_eps bs q q' \<Longrightarrow> q \<in> R \<Longrightarrow> q' \<in> step_eps_closure_set R bs"
  unfolding step_eps_closure_set_def step_eps_closure_def by auto

lemma step_eps_closure_set_code[code]:
  "step_eps_closure_set R bs =
    (let R' = R \<union> step_eps_set bs R in if R = R' then R else step_eps_closure_set R' bs)"
  using rtranclp_closed
  by (auto simp add: step_eps_closure_set_def step_eps_closure_def step_eps_set_sound Let_def)

(* no step_eps *)

lemma step_eps_closure_empty: "step_eps_closure bs q q' \<Longrightarrow> (\<And>q'. \<not>step_eps bs q q') \<Longrightarrow> q = q'"
  unfolding step_eps_closure_def by (induction q q' rule: rtranclp.induct) auto

lemma step_eps_closure_set_step_id: "(\<And>q q'. q \<in> R \<Longrightarrow> \<not>step_eps bs q q') \<Longrightarrow>
  step_eps_closure_set R bs = R"
  using step_eps_closure_empty step_eps_closure_set_refl unfolding step_eps_closure_set_def by blast

(* symbol step relation *)

qualified definition step_symb :: "state \<Rightarrow> state \<Rightarrow> bool" where
  "step_symb q q' \<longleftrightarrow> q \<in> SQ \<and>
    (case transs ! (q - q0) of symb_trans p \<Rightarrow> p = q' | _ \<Rightarrow> False)"

lemma step_symb_dest: "step_symb q q' \<Longrightarrow> q \<in> SQ"
  by (auto simp add: step_symb_def)

(* successors in symbol step relation *)

qualified definition step_symb_sucs :: "state \<Rightarrow> state set" where
  "step_symb_sucs q = (if q \<in> SQ then
    (case transs ! (q - q0) of symb_trans p \<Rightarrow> {p} | _ \<Rightarrow> {}) else {})"

lemma step_symb_sucs_sound: "q' \<in> step_symb_sucs q \<longleftrightarrow> step_symb q q'"
  by (auto simp add: step_symb_sucs_def step_symb_def split: transition.splits)

qualified definition step_symb_set :: "state set \<Rightarrow> state set" where
  "step_symb_set R = {q'. \<exists>q \<in> R. step_symb q q'}"

lemma step_symb_set_mono: "R \<subseteq> S \<Longrightarrow> step_symb_set R \<subseteq> step_symb_set S"
  by (auto simp add: step_symb_set_def)

lemma step_symb_set_empty: "step_symb_set {} = {}"
  by (auto simp add: step_symb_set_def)

lemma step_symb_set_proj: "step_symb_set R = step_symb_set (R \<inter> SQ)"
  using step_symb_dest by (auto simp add: step_symb_set_def)

lemma step_symb_set_split: "step_symb_set (R \<union> S) = step_symb_set R \<union> step_symb_set S"
  by (auto simp add: step_symb_set_def)

lemma step_symb_set_Un: "step_symb_set (\<Union>x \<in> X. R x) = (\<Union>x \<in> X. step_symb_set (R x))"
  by (auto simp add: step_symb_set_def)

lemma step_symb_set_code[code]: "step_symb_set R = \<Union>(step_symb_sucs ` R)"
  using step_symb_sucs_sound by (auto simp add: step_symb_set_def)

(* delta function *)

qualified definition delta :: "state set \<Rightarrow> bool list \<Rightarrow> state set" where
  "delta R bs = step_symb_set (step_eps_closure_set R bs)"

lemma delta_eps: "delta (step_eps_closure_set R bs) bs = delta R bs"
  unfolding delta_def step_eps_closure_set_idem by (rule refl)

lemma delta_eps_split:
  assumes "step_eps_closure_set R bs = R \<union> S"
  shows "delta R bs = step_symb_set R \<union> delta S bs"
  unfolding delta_def assms step_symb_set_split
  using step_symb_set_mono[OF step_eps_closure_set_flip[OF assms], unfolded step_symb_set_split]
    step_symb_set_mono[OF step_eps_closure_set_refl] by auto

lemma delta_split: "delta (R \<union> S) bs = delta R bs \<union> delta S bs"
  by (auto simp add: delta_def step_symb_set_split step_eps_closure_set_split)

lemma delta_Un: "delta (\<Union>x \<in> X. R x) bs = (\<Union>x \<in> X. delta (R x) bs)"
  unfolding delta_def step_eps_closure_set_Un step_symb_set_Un by simp

lemma delta_step_symb_set_absorb: "delta R bs = delta R bs \<union> step_symb_set R"
  using step_eps_closure_set_refl by (auto simp add: delta_def step_symb_set_def)

lemma delta_sub_eps_mono:
  assumes "S \<subseteq> step_eps_closure_set R bs"
  shows "delta S bs \<subseteq> delta R bs"
  unfolding delta_def
  using step_symb_set_mono[OF step_eps_closure_set_mono[OF assms, of bs,
        unfolded step_eps_closure_set_idem]] by simp

(* run delta function *)

qualified definition run :: "state set \<Rightarrow> bool list list \<Rightarrow> state set" where
  "run R bss = foldl delta R bss"

lemma run_eps_split:
  assumes "step_eps_closure_set R bs = R \<union> S" "step_symb_set R = {}"
  shows "run R (bs # bss) = run S (bs # bss)"
  unfolding run_def foldl.simps delta_eps_split[OF assms(1), unfolded assms(2)]
  by auto

lemma run_empty: "run {} bss = {}"
  unfolding run_def
  by (induction bss)
     (auto simp add: delta_def step_symb_set_empty step_eps_closure_set_empty)

lemma run_Nil: "run R [] = R"
  by (auto simp add: run_def)

lemma run_Cons: "run R (bs # bss) = run (delta R bs) bss"
  unfolding run_def by simp

lemma run_split: "run (R \<union> S) bss = run R bss \<union> run S bss"
  unfolding run_def
  by (induction bss arbitrary: R S) (auto simp add: delta_split)

lemma run_Un: "run (\<Union>x \<in> X. R x) bss = (\<Union>x \<in> X. run (R x) bss)"
  unfolding run_def
  by (induction bss arbitrary: R) (auto simp add: delta_Un)

lemma run_comp: "run R (bss @ css) = run (run R bss) css"
  unfolding run_def by simp

(* accept function *)

qualified definition accept_eps :: "state set \<Rightarrow> bool list \<Rightarrow> bool" where
  "accept_eps R bs \<longleftrightarrow> (qf \<in> step_eps_closure_set R bs)"

lemma step_eps_accept_eps: "step_eps bs q qf \<Longrightarrow> q \<in> R \<Longrightarrow> accept_eps R bs"
  unfolding accept_eps_def using step_step_eps_closure by simp

lemma accept_eps_empty: "accept_eps {} bs \<longleftrightarrow> False"
  by (auto simp add: accept_eps_def step_eps_closure_set_def)

lemma accept_eps_split: "accept_eps (R \<union> S) bs \<longleftrightarrow> accept_eps R bs \<or> accept_eps S bs"
  by (auto simp add: accept_eps_def step_eps_closure_set_split)

lemma accept_eps_Un: "accept_eps (\<Union>x \<in> X. R x) bs \<longleftrightarrow> (\<exists>x \<in> X. accept_eps (R x) bs)"
  by (auto simp add: accept_eps_def step_eps_closure_set_def)

qualified definition accept :: "state set \<Rightarrow> bool" where
  "accept R \<longleftrightarrow> accept_eps R []"

(* is a run accepting? *)

qualified definition run_accept_eps :: "state set \<Rightarrow> bool list list \<Rightarrow> bool list \<Rightarrow> bool" where
  "run_accept_eps R bss bs = accept_eps (run R bss) bs"

lemma run_accept_eps_empty: "\<not>run_accept_eps {} bss bs"
  unfolding run_accept_eps_def run_empty accept_eps_empty by simp

lemma run_accept_eps_Nil: "run_accept_eps R [] cs \<longleftrightarrow> accept_eps R cs"
  by (auto simp add: run_accept_eps_def run_Nil)

lemma run_accept_eps_Cons: "run_accept_eps R (bs # bss) cs \<longleftrightarrow> run_accept_eps (delta R bs) bss cs"
  by (auto simp add: run_accept_eps_def run_Cons)

lemma run_accept_eps_Cons_delta_cong: "delta R bs = delta S bs \<Longrightarrow>
  run_accept_eps R (bs # bss) cs \<longleftrightarrow> run_accept_eps S (bs # bss) cs"
  unfolding run_accept_eps_Cons by auto

lemma run_accept_eps_Nil_eps: "run_accept_eps (step_eps_closure_set R bs) [] bs \<longleftrightarrow> run_accept_eps R [] bs"
  unfolding run_accept_eps_Nil accept_eps_def step_eps_closure_set_idem by (rule refl)

lemma run_accept_eps_Cons_eps: "run_accept_eps (step_eps_closure_set R cs) (cs # css) bs \<longleftrightarrow>
  run_accept_eps R (cs # css) bs"
  unfolding run_accept_eps_Cons delta_eps by (rule refl)

lemma run_accept_eps_Nil_eps_split:
  assumes "step_eps_closure_set R bs = R \<union> S" "step_symb_set R = {}" "qf \<notin> R"
  shows "run_accept_eps R [] bs = run_accept_eps S [] bs"
  unfolding Nil run_accept_eps_Nil accept_eps_def assms(1)
  using assms(3) step_eps_closure_set_refl step_eps_closure_set_flip[OF assms(1)] by auto

lemma run_accept_eps_Cons_eps_split:
  assumes "step_eps_closure_set R cs = R \<union> S" "step_symb_set R = {}" "qf \<notin> R"
  shows "run_accept_eps R (cs # css) bs = run_accept_eps S (cs # css) bs"
  unfolding run_accept_eps_def Cons run_eps_split[OF assms(1,2)] by (rule refl)

lemma run_accept_eps_split: "run_accept_eps (R \<union> S) bss bs \<longleftrightarrow>
  run_accept_eps R bss bs \<or> run_accept_eps S bss bs"
  unfolding run_accept_eps_def run_split accept_eps_split by auto

lemma run_accept_eps_Un: "run_accept_eps (\<Union>x \<in> X. R x) bss bs \<longleftrightarrow>
  (\<exists>x \<in> X. run_accept_eps (R x) bss bs)"
  unfolding run_accept_eps_def run_Un accept_eps_Un by simp

qualified definition run_accept :: "state set \<Rightarrow> bool list list \<Rightarrow> bool" where
  "run_accept R bss = accept (run R bss)"

end

definition "iarray_of_list xs = IArray xs"

context fixes
  transs :: "transition iarray"
  and len :: nat
begin

qualified definition step_eps' :: "bool iarray \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
  "step_eps' bs q q' \<longleftrightarrow> q < len \<and>
    (case transs !! q of eps_trans p n \<Rightarrow> n < IArray.length bs \<and> bs !! n \<and> p = q'
    | split_trans p p' \<Rightarrow> p = q' \<or> p' = q' | _ \<Rightarrow> False)"

qualified definition step_eps_closure' :: "bool iarray \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
  "step_eps_closure' bs = (step_eps' bs)\<^sup>*\<^sup>*"

qualified definition step_eps_sucs' :: "bool iarray \<Rightarrow> state \<Rightarrow> state set" where
  "step_eps_sucs' bs q = (if q < len then
    (case transs !! q of eps_trans p n \<Rightarrow> if n < IArray.length bs \<and> bs !! n then {p} else {}
    | split_trans p p' \<Rightarrow> {p, p'} | _ \<Rightarrow> {}) else {})"

lemma step_eps_sucs'_sound: "q' \<in> step_eps_sucs' bs q \<longleftrightarrow> step_eps' bs q q'"
  by (auto simp add: step_eps_sucs'_def step_eps'_def split: transition.splits)

qualified definition step_eps_set' :: "bool iarray \<Rightarrow> state set \<Rightarrow> state set" where
  "step_eps_set' bs R = \<Union>(step_eps_sucs' bs ` R)"

lemma step_eps_set'_sound: "step_eps_set' bs R = {q'. \<exists>q \<in> R. step_eps' bs q q'}"
  using step_eps_sucs'_sound by (auto simp add: step_eps_set'_def)

qualified definition step_eps_closure_set' :: "state set \<Rightarrow> bool iarray \<Rightarrow> state set" where
  "step_eps_closure_set' R bs = \<Union>((\<lambda>q. {q'. step_eps_closure' bs q q'}) ` R)"

lemma step_eps_closure_set'_code[code]:
  "step_eps_closure_set' R bs =
    (let R' = R \<union> step_eps_set' bs R in if R = R' then R else step_eps_closure_set' R' bs)"
  using rtranclp_closed
  by (auto simp add: step_eps_closure_set'_def step_eps_closure'_def step_eps_set'_sound Let_def)

qualified definition step_symb_sucs' :: "state \<Rightarrow> state set" where
  "step_symb_sucs' q = (if q < len then
    (case transs !! q of symb_trans p \<Rightarrow> {p} | _ \<Rightarrow> {}) else {})"

qualified definition step_symb_set' :: "state set \<Rightarrow> state set" where
  "step_symb_set' R = \<Union>(step_symb_sucs' ` R)"

qualified definition delta' :: "state set \<Rightarrow> bool iarray \<Rightarrow> state set" where
  "delta' R bs = step_symb_set' (step_eps_closure_set' R bs)"

qualified definition accept_eps' :: "state set \<Rightarrow> bool iarray \<Rightarrow> bool" where
  "accept_eps' R bs \<longleftrightarrow> (len \<in> step_eps_closure_set' R bs)"

qualified definition accept' :: "state set \<Rightarrow> bool" where
  "accept' R \<longleftrightarrow> accept_eps' R (iarray_of_list [])"

qualified definition run' :: "state set \<Rightarrow> bool iarray list \<Rightarrow> state set" where
  "run' R bss = foldl delta' R bss"

qualified definition run_accept_eps' :: "state set \<Rightarrow> bool iarray list \<Rightarrow> bool iarray \<Rightarrow> bool" where
  "run_accept_eps' R bss bs = accept_eps' (run' R bss) bs"

qualified definition run_accept' :: "state set \<Rightarrow> bool iarray list \<Rightarrow> bool" where
  "run_accept' R bss = accept' (run' R bss)"

end

locale nfa_array =
  fixes transs :: "transition list"
    and transs' :: "transition iarray"
    and len :: nat
  assumes transs_eq: "transs' = IArray transs"
    and len_def: "len = length transs"
begin

abbreviation "step_eps \<equiv> NFA.step_eps 0 transs"
abbreviation "step_eps' \<equiv> NFA.step_eps' transs' len"
abbreviation "step_eps_closure \<equiv> NFA.step_eps_closure 0 transs"
abbreviation "step_eps_closure' \<equiv> NFA.step_eps_closure' transs' len"
abbreviation "step_eps_sucs \<equiv> NFA.step_eps_sucs 0 transs"
abbreviation "step_eps_sucs' \<equiv> NFA.step_eps_sucs' transs' len"
abbreviation "step_eps_set \<equiv> NFA.step_eps_set 0 transs"
abbreviation "step_eps_set' \<equiv> NFA.step_eps_set' transs' len"
abbreviation "step_eps_closure_set \<equiv> NFA.step_eps_closure_set 0 transs"
abbreviation "step_eps_closure_set' \<equiv> NFA.step_eps_closure_set' transs' len"
abbreviation "step_symb_sucs \<equiv> NFA.step_symb_sucs 0 transs"
abbreviation "step_symb_sucs' \<equiv> NFA.step_symb_sucs' transs' len"
abbreviation "step_symb_set \<equiv> NFA.step_symb_set 0 transs"
abbreviation "step_symb_set' \<equiv> NFA.step_symb_set' transs' len"
abbreviation "delta \<equiv> NFA.delta 0 transs"
abbreviation "delta' \<equiv> NFA.delta' transs' len"
abbreviation "accept_eps \<equiv> NFA.accept_eps 0 len transs"
abbreviation "accept_eps' \<equiv> NFA.accept_eps' transs' len"
abbreviation "accept \<equiv> NFA.accept 0 len transs"
abbreviation "accept' \<equiv> NFA.accept' transs' len"
abbreviation "run \<equiv> NFA.run 0 transs"
abbreviation "run' \<equiv> NFA.run' transs' len"
abbreviation "run_accept_eps \<equiv> NFA.run_accept_eps 0 len transs"
abbreviation "run_accept_eps' \<equiv> NFA.run_accept_eps' transs' len"
abbreviation "run_accept \<equiv> NFA.run_accept 0 len transs"
abbreviation "run_accept' \<equiv> NFA.run_accept' transs' len"

lemma q_in_SQ: "q \<in> NFA.SQ 0 transs \<longleftrightarrow> q < len"
  using len_def
  by (auto simp: NFA.SQ_def)

lemma step_eps'_eq: "bs' = IArray bs \<Longrightarrow> step_eps bs q q' \<longleftrightarrow> step_eps' bs' q q'"
  by (auto simp: NFA.step_eps_def NFA.step_eps'_def q_in_SQ transs_eq split: transition.splits)

lemma step_eps_closure'_eq: "bs' = IArray bs \<Longrightarrow> step_eps_closure bs q q' \<longleftrightarrow> step_eps_closure' bs' q q'"
proof -
  assume lassm: "bs' = IArray bs"
  have step_eps_eq_folded: "step_eps bs = step_eps' bs'"
    using step_eps'_eq[OF lassm]
    by auto
  show ?thesis
    by (auto simp: NFA.step_eps_closure_def NFA.step_eps_closure'_def step_eps_eq_folded)
qed

lemma step_eps_sucs'_eq: "bs' = IArray bs \<Longrightarrow> step_eps_sucs bs q = step_eps_sucs' bs' q"
  by (auto simp: NFA.step_eps_sucs_def NFA.step_eps_sucs'_def q_in_SQ transs_eq
      split: transition.splits)

lemma step_eps_set'_eq: "bs' = IArray bs \<Longrightarrow> step_eps_set bs R = step_eps_set' bs' R"
  by (auto simp: NFA.step_eps_set_def NFA.step_eps_set'_def step_eps_sucs'_eq)

lemma step_eps_closure_set'_eq: "bs' = IArray bs \<Longrightarrow> step_eps_closure_set R bs = step_eps_closure_set' R bs'"
  by (auto simp: NFA.step_eps_closure_set_def NFA.step_eps_closure_set'_def step_eps_closure'_eq)

lemma step_symb_sucs'_eq: "bs' = IArray bs \<Longrightarrow> step_symb_sucs R = step_symb_sucs' R"
  by (auto simp: NFA.step_symb_sucs_def NFA.step_symb_sucs'_def q_in_SQ transs_eq
      split: transition.splits)

lemma step_symb_set'_eq: "bs' = IArray bs \<Longrightarrow> step_symb_set R = step_symb_set' R"
  by (auto simp: step_symb_set_code NFA.step_symb_set'_def step_symb_sucs'_eq)

lemma delta'_eq: "bs' = IArray bs \<Longrightarrow> delta R bs = delta' R bs'"
  by (auto simp: NFA.delta_def NFA.delta'_def step_eps_closure_set'_eq step_symb_set'_eq)

lemma accept_eps'_eq: "bs' = IArray bs \<Longrightarrow> accept_eps R bs = accept_eps' R bs'"
  by (auto simp: NFA.accept_eps_def NFA.accept_eps'_def step_eps_closure_set'_eq)

lemma accept'_eq: "accept R = accept' R"
  by (auto simp: NFA.accept_def NFA.accept'_def accept_eps'_eq iarray_of_list_def)

lemma run'_eq: "bss' = map IArray bss \<Longrightarrow> run R bss = run' R bss'"
  by (induction bss arbitrary: R bss') (auto simp: NFA.run_def NFA.run'_def delta'_eq)

lemma run_accept_eps'_eq: "bss' = map IArray bss \<Longrightarrow> bs' = IArray bs \<Longrightarrow>
  run_accept_eps R bss bs \<longleftrightarrow> run_accept_eps' R bss' bs'"
  by (auto simp: NFA.run_accept_eps_def NFA.run_accept_eps'_def accept_eps'_eq run'_eq)

lemma run_accept'_eq: "bss' = map IArray bss \<Longrightarrow>
  run_accept R bss \<longleftrightarrow> run_accept' R bss'"
  by (auto simp: NFA.run_accept_def NFA.run_accept'_def run'_eq accept'_eq)

end

locale nfa =
  fixes q0 :: nat
    and qf :: nat
    and transs :: "transition list"
  assumes state_closed: "\<And>t. t \<in> set transs \<Longrightarrow> state_set t \<subseteq> NFA.Q q0 qf transs"
    and transs_not_Nil: "transs \<noteq> []"
    and qf_not_in_SQ: "qf \<notin> NFA.SQ q0 transs"
begin

abbreviation "SQ \<equiv> NFA.SQ q0 transs"
abbreviation "Q \<equiv> NFA.Q q0 qf transs"
abbreviation "nfa_fmla_set \<equiv> NFA.nfa_fmla_set transs"
abbreviation "step_eps \<equiv> NFA.step_eps q0 transs"
abbreviation "step_eps_sucs \<equiv> NFA.step_eps_sucs q0 transs"
abbreviation "step_eps_set \<equiv> NFA.step_eps_set q0 transs"
abbreviation "step_eps_closure \<equiv> NFA.step_eps_closure q0 transs"
abbreviation "step_eps_closure_set \<equiv> NFA.step_eps_closure_set q0 transs"
abbreviation "step_symb \<equiv> NFA.step_symb q0 transs"
abbreviation "step_symb_sucs \<equiv> NFA.step_symb_sucs q0 transs"
abbreviation "step_symb_set \<equiv> NFA.step_symb_set q0 transs"
abbreviation "delta \<equiv> NFA.delta q0 transs"
abbreviation "run \<equiv> NFA.run q0 transs"
abbreviation "accept_eps \<equiv> NFA.accept_eps q0 qf transs"
abbreviation "run_accept_eps \<equiv> NFA.run_accept_eps q0 qf transs"

lemma Q_diff_qf_SQ: "Q - {qf} = SQ"
  using qf_not_in_SQ by (auto simp add: NFA.Q_def)

lemma q0_sub_SQ: "{q0} \<subseteq> SQ"
  using transs_not_Nil by (auto simp add: NFA.SQ_def)

lemma q0_sub_Q: "{q0} \<subseteq> Q"
  using q0_sub_SQ SQ_sub_Q by auto

lemma step_eps_closed: "step_eps bs q q' \<Longrightarrow> q' \<in> Q"
  using transs_q_in_set state_closed
  by (fastforce simp add: NFA.step_eps_def split: transition.splits)

lemma step_eps_set_closed: "step_eps_set bs R \<subseteq> Q"
  using step_eps_closed by (auto simp add: step_eps_set_sound)

lemma step_eps_closure_closed: "step_eps_closure bs q q' \<Longrightarrow> q \<noteq> q' \<Longrightarrow> q' \<in> Q"
  unfolding NFA.step_eps_closure_def
  apply (induction q q' rule: rtranclp.induct) using step_eps_closed by auto

lemma step_eps_closure_set_closed_union: "step_eps_closure_set R bs \<subseteq> R \<union> Q"
  using step_eps_closure_closed by (auto simp add: NFA.step_eps_closure_set_def NFA.step_eps_closure_def)

lemma step_eps_closure_set_closed: "R \<subseteq> Q \<Longrightarrow> step_eps_closure_set R bs \<subseteq> Q"
  using step_eps_closure_set_closed_union by auto

lemma step_symb_closed: "step_symb q q' \<Longrightarrow> q' \<in> Q"
  using transs_q_in_set state_closed
  by (fastforce simp add: NFA.step_symb_def split: transition.splits)

lemma step_symb_set_closed: "step_symb_set R \<subseteq> Q"
  using step_symb_closed by (auto simp add: NFA.step_symb_set_def)

lemma step_symb_set_qf: "step_symb_set {qf} = {}"
  using qf_not_in_SQ step_symb_set_proj[of _ _ "{qf}"] step_symb_set_empty by auto

lemma delta_closed: "delta R bs \<subseteq> Q"
  using step_symb_set_closed by (auto simp add: NFA.delta_def)

lemma run_closed_Cons: "run R (bs # bss) \<subseteq> Q"
  unfolding NFA.run_def
  using delta_closed by (induction bss arbitrary: R bs) auto

lemma run_closed: "R \<subseteq> Q \<Longrightarrow> run R bss \<subseteq> Q"
  using run_Nil run_closed_Cons by (cases bss) auto

(* transitions from accepting state *)

lemma step_eps_qf: "step_eps bs qf q \<longleftrightarrow> False"
  using qf_not_in_SQ step_eps_dest by force

lemma step_symb_qf: "step_symb qf q \<longleftrightarrow> False"
  using qf_not_in_SQ step_symb_dest by force

lemma step_eps_closure_qf: "step_eps_closure bs q q' \<Longrightarrow> q = qf \<Longrightarrow> q = q'"
  unfolding NFA.step_eps_closure_def
  apply (induction q q' rule: rtranclp.induct) using step_eps_qf by auto

lemma step_eps_closure_set_qf: "step_eps_closure_set {qf} bs = {qf}"
  using step_eps_closure_qf unfolding NFA.step_eps_closure_set_def NFA.step_eps_closure_def by auto

lemma delta_qf: "delta {qf} bs = {}"
  using step_eps_closure_qf step_symb_qf
  by (auto simp add: NFA.delta_def NFA.step_symb_set_def NFA.step_eps_closure_set_def)

lemma run_qf_many: "run {qf} (bs # bss) = {}"
  unfolding run_Cons delta_qf run_empty by (rule refl)

lemma run_accept_eps_qf_many: "run_accept_eps {qf} (bs # bss) cs \<longleftrightarrow> False"
  unfolding NFA.run_accept_eps_def using run_qf_many accept_eps_empty by simp

lemma run_accept_eps_qf_one: "run_accept_eps {qf} [] bs \<longleftrightarrow> True"
  unfolding NFA.run_accept_eps_def NFA.accept_eps_def using run_Nil step_eps_closure_set_refl by force

end

locale nfa_cong = nfa q0 qf transs + nfa': nfa q0' qf' transs'
  for q0 q0' qf qf' transs transs' +
  assumes SQ_sub: "nfa'.SQ \<subseteq> SQ" and
  qf_eq: "qf = qf'" and
  transs_eq: "\<And>q. q \<in> nfa'.SQ \<Longrightarrow> transs ! (q - q0) = transs' ! (q - q0')"
begin

lemma q_Q_SQ_nfa'_SQ:  "q \<in> nfa'.Q \<Longrightarrow> q \<in> SQ \<longleftrightarrow> q \<in> nfa'.SQ"
  using SQ_sub qf_not_in_SQ qf_eq by (auto simp add: NFA.Q_def)

lemma step_eps_cong: "q \<in> nfa'.Q \<Longrightarrow> step_eps bs q q' \<longleftrightarrow> nfa'.step_eps bs q q'"
  using q_Q_SQ_nfa'_SQ transs_eq by (auto simp add: NFA.step_eps_def)

lemma eps_nfa'_step_eps_closure: "step_eps_closure bs q q' \<Longrightarrow> q \<in> nfa'.Q \<Longrightarrow>
  q' \<in> nfa'.Q \<and> nfa'.step_eps_closure bs q q'"
  unfolding NFA.step_eps_closure_def
  apply (induction q q' rule: rtranclp.induct)
  using nfa'.step_eps_closure_closed step_eps_cong by (auto simp add: NFA.step_eps_closure_def)

lemma nfa'_eps_step_eps_closure: "nfa'.step_eps_closure bs q q' \<Longrightarrow> q \<in> nfa'.Q \<Longrightarrow>
  q' \<in> nfa'.Q \<and> step_eps_closure bs q q'"
  unfolding NFA.step_eps_closure_def
  apply (induction q q' rule: rtranclp.induct)
  using nfa'.step_eps_closed step_eps_cong
  by (auto simp add: NFA.step_eps_closure_def intro: rtranclp.intros(2))

lemma step_eps_closure_set_cong: "R \<subseteq> nfa'.Q \<Longrightarrow> step_eps_closure_set R bs =
  nfa'.step_eps_closure_set R bs"
  using eps_nfa'_step_eps_closure nfa'_eps_step_eps_closure
  by (fastforce simp add: NFA.step_eps_closure_set_def)

lemma step_symb_cong: "q \<in> nfa'.Q \<Longrightarrow> step_symb q q' \<longleftrightarrow> nfa'.step_symb q q'"
  using q_Q_SQ_nfa'_SQ transs_eq by (auto simp add: NFA.step_symb_def)

lemma step_symb_set_cong: "R \<subseteq> nfa'.Q \<Longrightarrow> step_symb_set R = nfa'.step_symb_set R"
  using step_symb_cong by (auto simp add: NFA.step_symb_set_def)

lemma delta_cong: "R \<subseteq> nfa'.Q \<Longrightarrow> delta R bs = nfa'.delta R bs"
  using step_symb_set_cong nfa'.step_eps_closure_set_closed
  by (auto simp add: NFA.delta_def step_eps_closure_set_cong)

lemma run_cong: "R \<subseteq> nfa'.Q \<Longrightarrow> run R bss = nfa'.run R bss"
  unfolding NFA.run_def
  using nfa'.delta_closed delta_cong by (induction bss arbitrary: R) auto

lemma accept_eps_cong: "R \<subseteq> nfa'.Q \<Longrightarrow> accept_eps R bs \<longleftrightarrow> nfa'.accept_eps R bs"
  unfolding NFA.accept_eps_def using step_eps_closure_set_cong qf_eq by auto

lemma run_accept_eps_cong:
  assumes "R \<subseteq> nfa'.Q"
  shows "run_accept_eps R bss bs \<longleftrightarrow> nfa'.run_accept_eps R bss bs"
  unfolding NFA.run_accept_eps_def run_cong[OF assms]
    accept_eps_cong[OF nfa'.run_closed[OF assms]] by simp

end

fun list_split :: "'a list \<Rightarrow> ('a list \<times> 'a list) set" where
  "list_split [] = {}"
| "list_split (x # xs) = {([], x # xs)} \<union> (\<Union>(ys, zs) \<in> list_split xs. {(x # ys, zs)})"

lemma list_split_unfold: "(\<Union>(ys, zs) \<in> list_split (x # xs). f ys zs) =
  f [] (x # xs) \<union> (\<Union>(ys, zs) \<in> list_split xs. f (x # ys) zs)"
  by (induction xs) auto

lemma list_split_def: "list_split xs = (\<Union>n < length xs. {(take n xs, drop n xs)})"
  using less_Suc_eq_0_disj by (induction xs rule: list_split.induct) auto+

locale nfa_cong' = nfa q0 qf transs + nfa': nfa q0' qf' transs'
  for q0 q0' qf qf' transs transs' +
  assumes SQ_sub: "nfa'.SQ \<subseteq> SQ" and
  qf'_in_SQ: "qf' \<in> SQ" and
  transs_eq: "\<And>q. q \<in> nfa'.SQ \<Longrightarrow> transs ! (q - q0) = transs' ! (q - q0')"
begin

lemma nfa'_Q_sub_Q: "nfa'.Q \<subseteq> Q"
  unfolding NFA.Q_def using SQ_sub qf'_in_SQ by auto

lemma q_SQ_SQ_nfa'_SQ:  "q \<in> nfa'.SQ \<Longrightarrow> q \<in> SQ \<longleftrightarrow> q \<in> nfa'.SQ"
  using SQ_sub by auto

lemma step_eps_cong_SQ: "q \<in> nfa'.SQ \<Longrightarrow> step_eps bs q q' \<longleftrightarrow> nfa'.step_eps bs q q'"
  using q_SQ_SQ_nfa'_SQ transs_eq by (auto simp add: NFA.step_eps_def)

lemma step_eps_cong_Q: "q \<in> nfa'.Q \<Longrightarrow> nfa'.step_eps bs q q' \<Longrightarrow> step_eps bs q q'"
  using SQ_sub transs_eq by (auto simp add: NFA.step_eps_def)

lemma nfa'_step_eps_closure_cong: "nfa'.step_eps_closure bs q q' \<Longrightarrow> q \<in> nfa'.Q \<Longrightarrow>
  step_eps_closure bs q q'"
  unfolding NFA.step_eps_closure_def
  apply (induction q q' rule: rtranclp.induct)
  using NFA.Q_def NFA.step_eps_closure_def
  by (auto simp add: rtranclp.rtrancl_into_rtrancl step_eps_cong_SQ step_eps_dest)

lemma nfa'_step_eps_closure_set_sub: "R \<subseteq> nfa'.Q \<Longrightarrow> nfa'.step_eps_closure_set R bs \<subseteq>
  step_eps_closure_set R bs"
  unfolding NFA.step_eps_closure_set_def
  using nfa'_step_eps_closure_cong by fastforce

lemma eps_nfa'_step_eps_closure_cong: "step_eps_closure bs q q' \<Longrightarrow> q \<in> nfa'.Q \<Longrightarrow>
  (q' \<in> nfa'.Q \<and> nfa'.step_eps_closure bs q q') \<or>
  (nfa'.step_eps_closure bs q qf' \<and> step_eps_closure bs qf' q')"
  unfolding NFA.step_eps_closure_def
  apply (induction q q' rule: rtranclp.induct)
  using nfa'.step_eps_closure_closed nfa'.step_eps_closed step_eps_cong_SQ NFA.Q_def
  by (auto simp add: intro: rtranclp.rtrancl_into_rtrancl) fastforce+

lemma nfa'_eps_step_eps_closure_cong: "nfa'.step_eps_closure bs q q' \<Longrightarrow> q \<in> nfa'.Q \<Longrightarrow>
  q' \<in> nfa'.Q \<and> step_eps_closure bs q q'"
  unfolding NFA.step_eps_closure_def
  apply (induction q q' rule: rtranclp.induct)
  using nfa'.step_eps_closed step_eps_cong_Q
  by (auto intro: rtranclp.intros(2))

lemma step_eps_closure_set_cong_reach: "R \<subseteq> nfa'.Q \<Longrightarrow> qf' \<in> nfa'.step_eps_closure_set R bs \<Longrightarrow>
  step_eps_closure_set R bs = nfa'.step_eps_closure_set R bs \<union> step_eps_closure_set {qf'} bs"
  using eps_nfa'_step_eps_closure_cong nfa'_eps_step_eps_closure_cong
    rtranclp_trans[of "step_eps bs"]
  unfolding NFA.step_eps_closure_set_def NFA.step_eps_closure_def
  by auto blast+

lemma step_eps_closure_set_cong_unreach: "R \<subseteq> nfa'.Q \<Longrightarrow> qf' \<notin> nfa'.step_eps_closure_set R bs \<Longrightarrow>
  step_eps_closure_set R bs = nfa'.step_eps_closure_set R bs"
  using eps_nfa'_step_eps_closure_cong nfa'_eps_step_eps_closure_cong
  unfolding NFA.step_eps_closure_set_def NFA.step_eps_closure_def
  by auto blast+

lemma step_symb_cong_SQ: "q \<in> nfa'.SQ \<Longrightarrow> step_symb q q' \<longleftrightarrow> nfa'.step_symb q q'"
  using q_SQ_SQ_nfa'_SQ transs_eq by (auto simp add: NFA.step_symb_def)

lemma step_symb_cong_Q: "nfa'.step_symb q q' \<Longrightarrow> step_symb q q'"
  using SQ_sub transs_eq by (auto simp add: NFA.step_symb_def)

lemma step_symb_set_cong_SQ: "R \<subseteq> nfa'.SQ \<Longrightarrow> step_symb_set R = nfa'.step_symb_set R"
  using step_symb_cong_SQ by (auto simp add: NFA.step_symb_set_def)

lemma step_symb_set_cong_Q: "nfa'.step_symb_set R \<subseteq> step_symb_set R"
  using step_symb_cong_Q by (auto simp add: NFA.step_symb_set_def)

lemma delta_cong_unreach:
  assumes "R \<subseteq> nfa'.Q" "\<not>nfa'.accept_eps R bs"
  shows "delta R bs = nfa'.delta R bs"
proof -
  have "nfa'.step_eps_closure_set R bs \<subseteq> nfa'.SQ"
    using nfa'.step_eps_closure_set_closed[OF assms(1), unfolded NFA.Q_def]
      assms(2)[unfolded NFA.accept_eps_def] by auto
  then show ?thesis
    unfolding NFA.accept_eps_def NFA.delta_def using step_symb_set_cong_SQ
      step_eps_closure_set_cong_unreach[OF assms(1) assms(2)[unfolded NFA.accept_eps_def]]
    by auto
qed

lemma nfa'_delta_sub_delta:
  assumes "R \<subseteq> nfa'.Q"
  shows "nfa'.delta R bs \<subseteq> delta R bs"
  unfolding NFA.delta_def
  using step_symb_set_mono[OF nfa'_step_eps_closure_set_sub[OF assms]] step_symb_set_cong_Q
  by fastforce

lemma delta_cong_reach:
  assumes "R \<subseteq> nfa'.Q" "nfa'.accept_eps R bs"
  shows "delta R bs = nfa'.delta R bs \<union> delta {qf'} bs"
proof (rule set_eqI, rule iffI)
  fix q
  assume assm: "q \<in> delta R bs"
  have nfa'_eps_diff_Un: "nfa'.step_eps_closure_set R bs =
    nfa'.step_eps_closure_set R bs - {qf'} \<union> {qf'}"
    using assms(2)[unfolded NFA.accept_eps_def] by auto
  from assm have "q \<in> step_symb_set (nfa'.step_eps_closure_set R bs - {qf'}) \<union>
    step_symb_set {qf'} \<union> delta {qf'} bs"
    unfolding NFA.delta_def step_eps_closure_set_cong_reach[OF assms(1)
      assms(2)[unfolded NFA.accept_eps_def]] step_symb_set_split[symmetric]
      nfa'_eps_diff_Un[symmetric] by simp
  then have "q \<in> step_symb_set (nfa'.step_eps_closure_set R bs - {qf'}) \<union> delta {qf'} bs"
    using step_symb_set_mono[of "{qf'}" "step_eps_closure_set {qf'} bs",
      OF step_eps_closure_set_refl, unfolded NFA.delta_def[symmetric]]
    delta_step_symb_set_absorb by blast
  then show "q \<in> nfa'.delta R bs \<union> delta {qf'} bs"
    unfolding NFA.delta_def
    using nfa'.step_eps_closure_set_closed[OF assms(1), unfolded NFA.Q_def]
      step_symb_set_cong_SQ[of "nfa'.step_eps_closure_set R bs - {qf'}"]
      step_symb_set_mono by blast
next
  fix q
  assume "q \<in> nfa'.delta R bs \<union> delta {qf'} bs"
  then show "q \<in> delta R bs"
    using nfa'_delta_sub_delta[OF assms(1)] delta_sub_eps_mono[of "{qf'}" _ _ R bs]
      assms(2)[unfolded NFA.accept_eps_def] nfa'_step_eps_closure_set_sub[OF assms(1)]
    by fastforce
qed

lemma run_cong:
  assumes "R \<subseteq> nfa'.Q"
  shows "run R bss = nfa'.run R bss \<union> (\<Union>(css, css') \<in> list_split bss.
    if nfa'.run_accept_eps R css (hd css') then run {qf'} css' else {})"
  using assms
proof (induction bss arbitrary: R rule: list_split.induct)
  case 1
  then show ?case
    using run_Nil by simp
next
  case (2 x xs)
  show ?case
    apply (cases "nfa'.accept_eps R x")
    unfolding run_Cons delta_cong_reach[OF 2(2)]
      delta_cong_unreach[OF 2(2)] run_split run_accept_eps_Nil run_accept_eps_Cons
      list_split_unfold[of "\<lambda>ys zs. if nfa'.run_accept_eps R ys (hd zs)
      then run {qf'} zs else {}" x xs] using 2(1)[of "nfa'.delta R x",
    OF nfa'.delta_closed, unfolded run_accept_eps_Nil] by auto
qed

lemma run_cong_Cons_sub:
  assumes "R \<subseteq> nfa'.Q" "delta {qf'} bs \<subseteq> nfa'.delta R bs"
  shows "run R (bs # bss) = nfa'.run R (bs # bss) \<union>
    (\<Union>(css, css') \<in> list_split bss.
    if nfa'.run_accept_eps (nfa'.delta R bs) css (hd css') then run {qf'} css' else {})"
  unfolding run_Cons using run_cong[OF nfa'.delta_closed]
    delta_cong_reach[OF assms(1)] delta_cong_unreach[OF assms(1)]
  by (cases "nfa'.accept_eps R bs") (auto simp add: Un_absorb2[OF assms(2)])

lemma accept_eps_nfa'_run:
  assumes "R \<subseteq> nfa'.Q"
  shows "accept_eps (nfa'.run R bss) bs \<longleftrightarrow>
    nfa'.accept_eps (nfa'.run R bss) bs \<and> accept_eps (run {qf'} []) bs"
  unfolding NFA.accept_eps_def run_Nil
  using step_eps_closure_set_cong_reach[OF nfa'.run_closed[OF assms]]
    step_eps_closure_set_cong_unreach[OF nfa'.run_closed[OF assms]] qf_not_in_SQ
    qf'_in_SQ nfa'.step_eps_closure_set_closed[OF nfa'.run_closed[OF assms],
    unfolded NFA.Q_def] SQ_sub
  by (cases "qf' \<in> nfa'.step_eps_closure_set (nfa'.run R bss) bs") fastforce+

lemma run_accept_eps_cong:
  assumes "R \<subseteq> nfa'.Q"
  shows "run_accept_eps R bss bs \<longleftrightarrow> (nfa'.run_accept_eps R bss bs \<and> run_accept_eps {qf'} [] bs) \<or>
    (\<exists>(css, css') \<in> list_split bss. nfa'.run_accept_eps R css (hd css') \<and>
    run_accept_eps {qf'} css' bs)"
  unfolding NFA.run_accept_eps_def run_cong[OF assms] accept_eps_split
    accept_eps_Un accept_eps_nfa'_run[OF assms]
  using accept_eps_empty by (auto split: if_splits)+

lemma run_accept_eps_cong_Cons_sub:
  assumes "R \<subseteq> nfa'.Q" "delta {qf'} bs \<subseteq> nfa'.delta R bs"
  shows "run_accept_eps R (bs # bss) cs \<longleftrightarrow>
    (nfa'.run_accept_eps R (bs # bss) cs \<and> run_accept_eps {qf'} [] cs) \<or>
    (\<exists>(css, css') \<in> list_split bss. nfa'.run_accept_eps (nfa'.delta R bs) css (hd css') \<and>
    run_accept_eps {qf'} css' cs)"
  unfolding NFA.run_accept_eps_def run_cong_Cons_sub[OF assms]
    accept_eps_split accept_eps_Un accept_eps_nfa'_run[OF assms(1)]
  using accept_eps_empty by (auto split: if_splits)+

lemmas run_accept_eps_cong_Cons_sub_simp =
  run_accept_eps_cong_Cons_sub[unfolded list_split_def, simplified,
    unfolded run_accept_eps_Cons[symmetric] take_Suc_Cons[symmetric]]

end

locale nfa_cong_Plus = nfa_cong q0 q0' qf qf' transs transs' +
  right: nfa_cong q0 q0'' qf qf'' transs transs''
  for q0 q0' q0'' qf qf' qf'' transs transs' transs'' +
  assumes step_eps_q0: "step_eps bs q0 q \<longleftrightarrow> q \<in> {q0', q0''}" and
  step_symb_q0: "\<not>step_symb q0 q"
begin

lemma step_symb_set_q0: "step_symb_set {q0} = {}"
  unfolding NFA.step_symb_set_def using step_symb_q0 by simp

lemma qf_not_q0: "qf \<notin> {q0}"
  using qf_not_in_SQ q0_sub_SQ by auto

lemma step_eps_closure_set_q0: "step_eps_closure_set {q0} bs = {q0} \<union>
  (nfa'.step_eps_closure_set {q0'} bs \<union> right.nfa'.step_eps_closure_set {q0''} bs)"
  using step_eps_closure_set_unfold[OF step_eps_q0]
    insert_is_Un[of q0' "{q0''}"]
    step_eps_closure_set_split[of _ _ "{q0'}" "{q0''}"]
    step_eps_closure_set_cong[OF nfa'.q0_sub_Q]
    right.step_eps_closure_set_cong[OF right.nfa'.q0_sub_Q]
  by auto

lemmas run_accept_eps_Nil_cong =
  run_accept_eps_Nil_eps_split[OF step_eps_closure_set_q0 step_symb_set_q0 qf_not_q0,
    unfolded run_accept_eps_split
    run_accept_eps_cong[OF nfa'.step_eps_closure_set_closed[OF nfa'.q0_sub_Q]]
    right.run_accept_eps_cong[OF right.nfa'.step_eps_closure_set_closed[OF right.nfa'.q0_sub_Q]]
    run_accept_eps_Nil_eps]

lemmas run_accept_eps_Cons_cong =
  run_accept_eps_Cons_eps_split[OF step_eps_closure_set_q0 step_symb_set_q0 qf_not_q0,
    unfolded run_accept_eps_split
    run_accept_eps_cong[OF nfa'.step_eps_closure_set_closed[OF nfa'.q0_sub_Q]]
    right.run_accept_eps_cong[OF right.nfa'.step_eps_closure_set_closed[OF right.nfa'.q0_sub_Q]]
    run_accept_eps_Cons_eps]

lemma run_accept_eps_cong: "run_accept_eps {q0} bss bs \<longleftrightarrow>
  (nfa'.run_accept_eps {q0'} bss bs \<or> right.nfa'.run_accept_eps {q0''} bss bs)"
  using run_accept_eps_Nil_cong run_accept_eps_Cons_cong by (cases bss) auto

end

locale nfa_cong_Times = nfa_cong' q0 q0 qf q0' transs transs' +
  right: nfa_cong q0 q0' qf qf transs transs''
  for q0 q0' qf transs transs' transs''
begin

lemmas run_accept_eps_cong =
  run_accept_eps_cong[OF nfa'.q0_sub_Q, unfolded
    right.run_accept_eps_cong[OF right.nfa'.q0_sub_Q], unfolded list_split_def, simplified]

end

locale nfa_cong_Star = nfa_cong' q0 q0' qf q0 transs transs'
  for q0 q0' qf transs transs' +
  assumes step_eps_q0: "step_eps bs q0 q \<longleftrightarrow> q \<in> {q0', qf}" and
  step_symb_q0: "\<not>step_symb q0 q"
begin

lemma step_symb_set_q0: "step_symb_set {q0} = {}"
  unfolding NFA.step_symb_set_def using step_symb_q0 by simp

lemma run_accept_eps_Nil: "run_accept_eps {q0} [] bs"
  unfolding NFA.run_accept_eps_def NFA.run_def using step_eps_accept_eps step_eps_q0 by fastforce

lemma rtranclp_step_eps_q0_q0': "(step_eps bs)\<^sup>*\<^sup>* q q' \<Longrightarrow> q = q0 \<Longrightarrow>
  q' \<in> {q0, qf} \<or> (q' \<in> nfa'.SQ \<and> (nfa'.step_eps bs)\<^sup>*\<^sup>* q0' q')"
  apply (induction q q' rule: rtranclp.induct)
  using step_eps_q0 step_eps_dest qf_not_in_SQ step_eps_cong_SQ nfa'.q0_sub_SQ
    nfa'.step_eps_closed[unfolded NFA.Q_def] by fastforce+

lemma step_eps_closure_set_q0: "step_eps_closure_set {q0} bs \<subseteq> {q0, qf} \<union>
  (nfa'.step_eps_closure_set {q0'} bs \<inter> nfa'.SQ)"
  unfolding NFA.step_eps_closure_set_def NFA.step_eps_closure_def
  using rtranclp_step_eps_q0_q0' by auto

lemma delta_sub_nfa'_delta: "delta {q0} bs \<subseteq> nfa'.delta {q0'} bs"
  unfolding NFA.delta_def
  using step_symb_set_mono[OF step_eps_closure_set_q0, unfolded step_symb_set_q0
    step_symb_set_qf step_symb_set_split insert_is_Un[of q0 "{qf}"]]
    step_symb_set_cong_SQ
  by (metis boolean_algebra_cancel.sup0 inf_le2 step_symb_set_proj step_symb_set_q0
      step_symb_set_qf sup_commute)

lemma step_eps_closure_set_q0_split: "step_eps_closure_set {q0} bs = {q0, qf} \<union>
  step_eps_closure_set {q0'} bs"
  unfolding NFA.step_eps_closure_set_def NFA.step_eps_closure_def
  using step_eps_qf step_eps_q0
  apply (auto)
   apply (metis rtranclp_unfold)
  by (metis r_into_rtranclp rtranclp.rtrancl_into_rtrancl rtranclp_idemp)

lemma delta_q0_q0': "delta {q0} bs = delta {q0'} bs"
  unfolding NFA.delta_def step_eps_closure_set_q0_split step_symb_set_split
  unfolding NFA.delta_def[symmetric]
  unfolding NFA.step_symb_set_def
  using step_symb_q0 step_symb_dest qf_not_in_SQ
  by fastforce

lemmas run_accept_eps_cong_Cons =
  run_accept_eps_cong_Cons_sub_simp[OF nfa'.q0_sub_Q delta_sub_nfa'_delta,
    unfolded run_accept_eps_Cons_delta_cong[OF delta_q0_q0', symmetric]]

end

end