(*  Title:      HOL/Computational_Algebra/Polynomial_Factorial.thy
    Author:     Manuel Eberl
*)

section \<open>Polynomials, fractions and rings\<close>

theory Polynomial_Factorial
imports
  Complex_Main
  Polynomial
  Normalized_Fraction
begin

subsection \<open>Lifting elements into the field of fractions\<close>

definition to_fract :: "'a :: idom \<Rightarrow> 'a fract"
  where "to_fract x = Fract x 1"
  \<comment> \<open>FIXME: more idiomatic name, abbreviation\<close>

lemma to_fract_0 [simp]: "to_fract 0 = 0"
  by (simp add: to_fract_def eq_fract Zero_fract_def)

lemma to_fract_1 [simp]: "to_fract 1 = 1"
  by (simp add: to_fract_def eq_fract One_fract_def)

lemma to_fract_add [simp]: "to_fract (x + y) = to_fract x + to_fract y"
  by (simp add: to_fract_def)

lemma to_fract_diff [simp]: "to_fract (x - y) = to_fract x - to_fract y"
  by (simp add: to_fract_def)

lemma to_fract_uminus [simp]: "to_fract (-x) = -to_fract x"
  by (simp add: to_fract_def)

lemma to_fract_mult [simp]: "to_fract (x * y) = to_fract x * to_fract y"
  by (simp add: to_fract_def)

lemma to_fract_eq_iff [simp]: "to_fract x = to_fract y \<longleftrightarrow> x = y"
  by (simp add: to_fract_def eq_fract)

lemma to_fract_eq_0_iff [simp]: "to_fract x = 0 \<longleftrightarrow> x = 0"
  by (simp add: to_fract_def Zero_fract_def eq_fract)

lemma to_fract_quot_of_fract:
  assumes "snd (quot_of_fract x) = 1"
  shows   "to_fract (fst (quot_of_fract x)) = x"
proof -
  have "x = Fract (fst (quot_of_fract x)) (snd (quot_of_fract x))" by simp
  also note assms
  finally show ?thesis by (simp add: to_fract_def)
qed

lemma Fract_conv_to_fract: "Fract a b = to_fract a / to_fract b"
  by (simp add: to_fract_def)

lemma quot_of_fract_to_fract [simp]: "quot_of_fract (to_fract x) = (x, 1)"
  unfolding to_fract_def by transfer (simp add: normalize_quot_def)

lemma snd_quot_of_fract_to_fract [simp]: "snd (quot_of_fract (to_fract x)) = 1"
  unfolding to_fract_def by (rule snd_quot_of_fract_Fract_whole) simp_all

subsection \<open>Lifting polynomial coefficients to the field of fractions\<close>

abbreviation (input) fract_poly :: \<open>'a::idom poly \<Rightarrow> 'a fract poly\<close>
  where "fract_poly \<equiv> map_poly to_fract"

abbreviation (input) unfract_poly :: \<open>'a::{ring_gcd,semiring_gcd_mult_normalize,idom_divide} fract poly \<Rightarrow> 'a poly\<close>
  where "unfract_poly \<equiv> map_poly (fst \<circ> quot_of_fract)"

lemma fract_poly_smult [simp]: "fract_poly (smult c p) = smult (to_fract c) (fract_poly p)"
  by (simp add: smult_conv_map_poly map_poly_map_poly o_def)

lemma fract_poly_0 [simp]: "fract_poly 0 = 0"
  by (simp add: poly_eqI coeff_map_poly)

lemma fract_poly_1 [simp]: "fract_poly 1 = 1"
  by (simp add: map_poly_pCons)

lemma fract_poly_add [simp]:
  "fract_poly (p + q) = fract_poly p + fract_poly q"
  by (intro poly_eqI) (simp_all add: coeff_map_poly)

lemma fract_poly_diff [simp]:
  "fract_poly (p - q) = fract_poly p - fract_poly q"
  by (intro poly_eqI) (simp_all add: coeff_map_poly)

lemma to_fract_sum [simp]: "to_fract (sum f A) = sum (\<lambda>x. to_fract (f x)) A"
  by (cases "finite A", induction A rule: finite_induct) simp_all

lemma fract_poly_mult [simp]:
  "fract_poly (p * q) = fract_poly p * fract_poly q"
  by (intro poly_eqI) (simp_all add: coeff_map_poly coeff_mult)

lemma fract_poly_eq_iff [simp]: "fract_poly p = fract_poly q \<longleftrightarrow> p = q"
  by (auto simp: poly_eq_iff coeff_map_poly)

lemma fract_poly_eq_0_iff [simp]: "fract_poly p = 0 \<longleftrightarrow> p = 0"
  using fract_poly_eq_iff[of p 0] by (simp del: fract_poly_eq_iff)

lemma fract_poly_dvd: "p dvd q \<Longrightarrow> fract_poly p dvd fract_poly q"
  by auto

lemma prod_mset_fract_poly:
  "(\<Prod>x\<in>#A. map_poly to_fract (f x)) = fract_poly (prod_mset (image_mset f A))"
  by (induct A) (simp_all add: ac_simps)

lemma is_unit_fract_poly_iff:
  "p dvd 1 \<longleftrightarrow> fract_poly p dvd 1 \<and> content p = 1"
proof safe
  assume A: "p dvd 1"
  with fract_poly_dvd [of p 1] show "is_unit (fract_poly p)"
    by simp
  from A show "content p = 1"
    by (auto simp: is_unit_poly_iff normalize_1_iff)
next
  assume A: "fract_poly p dvd 1" and B: "content p = 1"
  from A obtain c where c: "fract_poly p = [:c:]" by (auto simp: is_unit_poly_iff)
  {
    fix n :: nat assume "n > 0"
    have "to_fract (coeff p n) = coeff (fract_poly p) n" by (simp add: coeff_map_poly)
    also note c
    also from \<open>n > 0\<close> have "coeff [:c:] n = 0" by (simp add: coeff_pCons split: nat.splits)
    finally have "coeff p n = 0" by simp
  }
  hence "degree p \<le> 0" by (intro degree_le) simp_all
  with B show "p dvd 1" by (auto simp: is_unit_poly_iff normalize_1_iff elim!: degree_eq_zeroE)
qed

lemma fract_poly_is_unit: "p dvd 1 \<Longrightarrow> fract_poly p dvd 1"
  using fract_poly_dvd[of p 1] by simp

lemma fract_poly_smult_eqE:
  fixes c :: "'a :: {idom_divide,ring_gcd,semiring_gcd_mult_normalize} fract"
  assumes "fract_poly p = smult c (fract_poly q)"
  obtains a b
    where "c = to_fract b / to_fract a" "smult a p = smult b q" "coprime a b" "normalize a = a"
proof -
  define a b where "a = fst (quot_of_fract c)" and "b = snd (quot_of_fract c)"
  have "smult (to_fract a) (fract_poly q) = smult (to_fract b) (fract_poly p)"
    by (subst smult_eq_iff) (simp_all add: a_def b_def Fract_conv_to_fract [symmetric] assms)
  hence "fract_poly (smult a q) = fract_poly (smult b p)" by (simp del: fract_poly_eq_iff)
  hence "smult b p = smult a q" by (simp only: fract_poly_eq_iff)
  moreover have "c = to_fract a / to_fract b" "coprime b a" "normalize b = b"
    by (simp_all add: a_def b_def coprime_quot_of_fract [of c] ac_simps
          normalize_snd_quot_of_fract Fract_conv_to_fract [symmetric])
  ultimately show ?thesis by (intro that[of a b])
qed

subsection \<open>Fractional content\<close>

abbreviation (input) Lcm_coeff_denoms
    :: "'a :: {semiring_Gcd,idom_divide,ring_gcd,semiring_gcd_mult_normalize} fract poly \<Rightarrow> 'a"
  where "Lcm_coeff_denoms p \<equiv> Lcm (snd ` quot_of_fract ` set (coeffs p))"

definition fract_content ::
      "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} fract poly \<Rightarrow> 'a fract" where
  "fract_content p =
     (let d = Lcm_coeff_denoms p in Fract (content (unfract_poly (smult (to_fract d) p))) d)"

definition primitive_part_fract ::
      "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} fract poly \<Rightarrow> 'a poly" where
  "primitive_part_fract p =
     primitive_part (unfract_poly (smult (to_fract (Lcm_coeff_denoms p)) p))"

lemma primitive_part_fract_0 [simp]: "primitive_part_fract 0 = 0"
  by (simp add: primitive_part_fract_def)

lemma fract_content_eq_0_iff [simp]:
  "fract_content p = 0 \<longleftrightarrow> p = 0"
  unfolding fract_content_def Let_def Zero_fract_def
  by (subst eq_fract) (auto simp: Lcm_0_iff map_poly_eq_0_iff)

lemma content_primitive_part_fract [simp]:
  fixes p :: "'a :: {semiring_gcd_mult_normalize,
                     factorial_semiring, ring_gcd, semiring_Gcd,idom_divide} fract poly"
  shows "p \<noteq> 0 \<Longrightarrow> content (primitive_part_fract p) = 1"
  unfolding primitive_part_fract_def
  by (rule content_primitive_part)
     (auto simp: primitive_part_fract_def map_poly_eq_0_iff Lcm_0_iff)

lemma content_times_primitive_part_fract:
  "smult (fract_content p) (fract_poly (primitive_part_fract p)) = p"
proof -
  define p' where "p' = unfract_poly (smult (to_fract (Lcm_coeff_denoms p)) p)"
  have "fract_poly p' =
          map_poly (to_fract \<circ> fst \<circ> quot_of_fract) (smult (to_fract (Lcm_coeff_denoms p)) p)"
    unfolding primitive_part_fract_def p'_def
    by (subst map_poly_map_poly) (simp_all add: o_assoc)
  also have "\<dots> = smult (to_fract (Lcm_coeff_denoms p)) p"
  proof (intro map_poly_idI, unfold o_apply)
    fix c assume "c \<in> set (coeffs (smult (to_fract (Lcm_coeff_denoms p)) p))"
    then obtain c' where c: "c' \<in> set (coeffs p)" "c = to_fract (Lcm_coeff_denoms p) * c'"
      by (auto simp add: Lcm_0_iff coeffs_smult split: if_splits)
    note c(2)
    also have "c' = Fract (fst (quot_of_fract c')) (snd (quot_of_fract c'))"
      by simp
    also have "to_fract (Lcm_coeff_denoms p) * \<dots> =
                 Fract (Lcm_coeff_denoms p * fst (quot_of_fract c')) (snd (quot_of_fract c'))"
      unfolding to_fract_def by (subst mult_fract) simp_all
    also have "snd (quot_of_fract \<dots>) = 1"
      by (intro snd_quot_of_fract_Fract_whole dvd_mult2 dvd_Lcm) (insert c(1), auto)
    finally show "to_fract (fst (quot_of_fract c)) = c"
      by (rule to_fract_quot_of_fract)
  qed
  also have "p' = smult (content p') (primitive_part p')"
    by (rule content_times_primitive_part [symmetric])
  also have "primitive_part p' = primitive_part_fract p"
    by (simp add: primitive_part_fract_def p'_def)
  also have "fract_poly (smult (content p') (primitive_part_fract p)) =
               smult (to_fract (content p')) (fract_poly (primitive_part_fract p))" by simp
  finally have "smult (to_fract (content p')) (fract_poly (primitive_part_fract p)) =
                      smult (to_fract (Lcm_coeff_denoms p)) p" .
  thus ?thesis
    by (subst (asm) smult_eq_iff)
       (auto simp add: Let_def p'_def Fract_conv_to_fract field_simps Lcm_0_iff fract_content_def)
qed

lemma fract_content_fract_poly [simp]: "fract_content (fract_poly p) = to_fract (content p)"
proof -
  have "Lcm_coeff_denoms (fract_poly p) = 1"
    by (auto simp: set_coeffs_map_poly)
  hence "fract_content (fract_poly p) =
           to_fract (content (map_poly (fst \<circ> quot_of_fract \<circ> to_fract) p))"
    by (simp add: fract_content_def to_fract_def fract_collapse map_poly_map_poly del: Lcm_1_iff)
  also have "map_poly (fst \<circ> quot_of_fract \<circ> to_fract) p = p"
    by (intro map_poly_idI) simp_all
  finally show ?thesis .
qed

lemma content_decompose_fract:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,
                     semiring_gcd_mult_normalize} fract poly"
  obtains c p' where "p = smult c (map_poly to_fract p')" "content p' = 1"
proof (cases "p = 0")
  case True
  hence "p = smult 0 (map_poly to_fract 1)" "content 1 = 1" by simp_all
  thus ?thesis ..
next
  case False
  thus ?thesis
    by (rule that[OF content_times_primitive_part_fract [symmetric] content_primitive_part_fract])
qed

lemma fract_poly_dvdD:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,
                     semiring_gcd_mult_normalize} poly"
  assumes "fract_poly p dvd fract_poly q" "content p = 1"
  shows   "p dvd q"
proof -
  from assms(1) obtain r where r: "fract_poly q = fract_poly p * r" by (erule dvdE)
  from content_decompose_fract[of r]
  obtain c r' where r': "r = smult c (map_poly to_fract r')" "content r' = 1" .
  from r r' have eq: "fract_poly q = smult c (fract_poly (p * r'))" by simp
  from fract_poly_smult_eqE[OF this] obtain a b
    where ab:
      "c = to_fract b / to_fract a"
      "smult a q = smult b (p * r')"
      "coprime a b"
      "normalize a = a" .
  have "content (smult a q) = content (smult b (p * r'))" by (simp only: ab(2))
  hence eq': "normalize b = a * content q" by (simp add: assms content_mult r' ab(4))
  have "1 = gcd a (normalize b)" by (simp add: ab)
  also note eq'
  also have "gcd a (a * content q) = a" by (simp add: gcd_proj1_if_dvd ab(4))
  finally have [simp]: "a = 1" by simp
  from eq ab have "q = p * ([:b:] * r')" by simp
  thus ?thesis by (rule dvdI)
qed

subsection \<open>Polynomials over a field are a Euclidean ring\<close>

context
begin

interpretation field_poly:
  normalization_euclidean_semiring_multiplicative where zero = "0 :: 'a :: field poly"
    and one = 1 and plus = plus and minus = minus
    and times = times
    and normalize = "\<lambda>p. smult (inverse (lead_coeff p)) p"
    and unit_factor = "\<lambda>p. [:lead_coeff p:]"
    and euclidean_size = "\<lambda>p. if p = 0 then 0 else 2 ^ degree p"
    and divide = divide and modulo = modulo
  rewrites "dvd.dvd (times :: 'a poly \<Rightarrow> _) = Rings.dvd"
    and "comm_monoid_mult.prod_mset times 1 = prod_mset"
    and "comm_semiring_1.irreducible times 1 0 = irreducible"
    and "comm_semiring_1.prime_elem times 1 0 = prime_elem"
proof -
  show "dvd.dvd (times :: 'a poly \<Rightarrow> _) = Rings.dvd"
    by (simp add: dvd_dict)
  show "comm_monoid_mult.prod_mset times 1 = prod_mset"
    by (simp add: prod_mset_dict)
  show "comm_semiring_1.irreducible times 1 0 = irreducible"
    by (simp add: irreducible_dict)
  show "comm_semiring_1.prime_elem times 1 0 = prime_elem"
    by (simp add: prime_elem_dict)
  show "class.normalization_euclidean_semiring_multiplicative divide plus minus (0 :: 'a poly) times 1
    modulo (\<lambda>p. if p = 0 then 0 else 2 ^ degree p)
    (\<lambda>p. [:lead_coeff p:]) (\<lambda>p. smult (inverse (lead_coeff p)) p)"
  proof (standard, fold dvd_dict)
    fix p :: "'a poly"
    show "[:lead_coeff p:] * smult (inverse (lead_coeff p)) p = p"
      by (cases "p = 0") simp_all
  next
    fix p :: "'a poly" assume "is_unit p"
    then show "[:lead_coeff p:] = p"
      by (elim is_unit_polyE) (auto simp: monom_0 one_poly_def field_simps)
  next
    fix p :: "'a poly" assume "p \<noteq> 0"
    then show "is_unit [:lead_coeff p:]"
      by (simp add: is_unit_pCons_iff)
  next
    fix a b :: "'a poly" assume "is_unit a"
    thus "[:lead_coeff (a * b):] = a * [:lead_coeff b:]"
      by (auto elim!: is_unit_polyE)
  qed (auto simp: lead_coeff_mult Rings.div_mult_mod_eq intro!: degree_mod_less' degree_mult_right_le)
qed

lemma field_poly_irreducible_imp_prime:
  "prime_elem p" if "irreducible p" for p :: "'a :: field poly"
  using that by (fact field_poly.irreducible_imp_prime_elem)

lemma field_poly_prod_mset_prime_factorization:
  "prod_mset (field_poly.prime_factorization p) = smult (inverse (lead_coeff p)) p"
  if "p \<noteq> 0" for p :: "'a :: field poly"
  using that by (fact field_poly.prod_mset_prime_factorization)

lemma field_poly_in_prime_factorization_imp_prime:
  "prime_elem p" if "p \<in># field_poly.prime_factorization x"
  for p :: "'a :: field poly"
  by (rule field_poly.prime_imp_prime_elem, rule field_poly.in_prime_factors_imp_prime)
    (fact that)

subsection \<open>Primality and irreducibility in polynomial rings\<close>

lemma nonconst_poly_irreducible_iff:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} poly"
  assumes "degree p \<noteq> 0"
  shows   "irreducible p \<longleftrightarrow> irreducible (fract_poly p) \<and> content p = 1"
proof safe
  assume p: "irreducible p"

  from content_decompose[of p] obtain p' where p': "p = smult (content p) p'" "content p' = 1" .
  hence "p = [:content p:] * p'" by simp
  from p this have "[:content p:] dvd 1 \<or> p' dvd 1" by (rule irreducibleD)
  moreover have "\<not>p' dvd 1"
  proof
    assume "p' dvd 1"
    hence "degree p = 0" by (subst p') (auto simp: is_unit_poly_iff)
    with assms show False by contradiction
  qed
  ultimately show [simp]: "content p = 1" by (simp add: is_unit_const_poly_iff)

  show "irreducible (map_poly to_fract p)"
  proof (rule irreducibleI)
    have "fract_poly p = 0 \<longleftrightarrow> p = 0" by (intro map_poly_eq_0_iff) auto
    with assms show "map_poly to_fract p \<noteq> 0" by auto
  next
    show "\<not>is_unit (fract_poly p)"
    proof
      assume "is_unit (map_poly to_fract p)"
      hence "degree (map_poly to_fract p) = 0"
        by (auto simp: is_unit_poly_iff)
      hence "degree p = 0" by (simp add: degree_map_poly)
      with assms show False by contradiction
   qed
 next
   fix q r assume qr: "fract_poly p = q * r"
   from content_decompose_fract[of q]
   obtain cg q' where q: "q = smult cg (map_poly to_fract q')" "content q' = 1" .
   from content_decompose_fract[of r]
   obtain cr r' where r: "r = smult cr (map_poly to_fract r')" "content r' = 1" .
   from qr q r p have nz: "cg \<noteq> 0" "cr \<noteq> 0" by auto
   from qr have eq: "fract_poly p = smult (cr * cg) (fract_poly (q' * r'))"
     by (simp add: q r)
   from fract_poly_smult_eqE[OF this] obtain a b
     where ab: "cr * cg = to_fract b / to_fract a"
       "smult a p = smult b (q' * r')" "coprime a b" "normalize a = a" .
   hence "content (smult a p) = content (smult b (q' * r'))" by (simp only:)
   with ab(4) have a: "a = normalize b" by (simp add: content_mult q r)
   then have "normalize b = gcd a b"
     by simp
   with \<open>coprime a b\<close> have "normalize b = 1"
     by simp
   then have "a = 1" "is_unit b"
     by (simp_all add: a normalize_1_iff)

   note eq
   also from ab(1) \<open>a = 1\<close> have "cr * cg = to_fract b" by simp
   also have "smult \<dots> (fract_poly (q' * r')) = fract_poly (smult b (q' * r'))" by simp
   finally have "p = ([:b:] * q') * r'" by (simp del: fract_poly_smult)
   from p and this have "([:b:] * q') dvd 1 \<or> r' dvd 1" by (rule irreducibleD)
   hence "q' dvd 1 \<or> r' dvd 1" by (auto dest: dvd_mult_right simp del: mult_pCons_left)
   hence "fract_poly q' dvd 1 \<or> fract_poly r' dvd 1" by (auto simp: fract_poly_is_unit)
   with q r show "is_unit q \<or> is_unit r"
     by (auto simp add: is_unit_smult_iff dvd_field_iff nz)
 qed

next

  assume irred: "irreducible (fract_poly p)" and primitive: "content p = 1"
  show "irreducible p"
  proof (rule irreducibleI)
    from irred show "p \<noteq> 0" by auto
  next
    from irred show "\<not>p dvd 1"
      by (auto simp: irreducible_def dest: fract_poly_is_unit)
  next
    fix q r assume qr: "p = q * r"
    hence "fract_poly p = fract_poly q * fract_poly r" by simp
    from irred and this have "fract_poly q dvd 1 \<or> fract_poly r dvd 1"
      by (rule irreducibleD)
    with primitive qr show "q dvd 1 \<or> r dvd 1"
      by (auto simp:  content_prod_eq_1_iff is_unit_fract_poly_iff)
  qed
qed

lemma irreducible_imp_prime_poly:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} poly"
  assumes "irreducible p"
  shows   "prime_elem p"
proof (cases "degree p = 0")
  case True
  with assms show ?thesis
    by (auto simp: prime_elem_const_poly_iff irreducible_const_poly_iff
             intro!: irreducible_imp_prime_elem elim!: degree_eq_zeroE)
next
  case False
  from assms False have irred: "irreducible (fract_poly p)" and primitive: "content p = 1"
    by (simp_all add: nonconst_poly_irreducible_iff)
  from irred have prime: "prime_elem (fract_poly p)" by (rule field_poly_irreducible_imp_prime)
  show ?thesis
  proof (rule prime_elemI)
    fix q r assume "p dvd q * r"
    hence "fract_poly p dvd fract_poly (q * r)" by (rule fract_poly_dvd)
    hence "fract_poly p dvd fract_poly q * fract_poly r" by simp
    from prime and this have "fract_poly p dvd fract_poly q \<or> fract_poly p dvd fract_poly r"
      by (rule prime_elem_dvd_multD)
    with primitive show "p dvd q \<or> p dvd r" by (auto dest: fract_poly_dvdD)
  qed (insert assms, auto simp: irreducible_def)
qed

lemma degree_primitive_part_fract [simp]:
  "degree (primitive_part_fract p) = degree p"
proof -
  have "p = smult (fract_content p) (fract_poly (primitive_part_fract p))"
    by (simp add: content_times_primitive_part_fract)
  also have "degree \<dots> = degree (primitive_part_fract p)"
    by (auto simp: degree_map_poly)
  finally show ?thesis ..
qed

lemma irreducible_primitive_part_fract:
  fixes p :: "'a :: {idom_divide, ring_gcd, factorial_semiring, semiring_Gcd,semiring_gcd_mult_normalize} fract poly"
  assumes "irreducible p"
  shows   "irreducible (primitive_part_fract p)"
proof -
  from assms have deg: "degree (primitive_part_fract p) \<noteq> 0"
    by (intro notI)
       (auto elim!: degree_eq_zeroE simp: irreducible_def is_unit_poly_iff dvd_field_iff)
  hence [simp]: "p \<noteq> 0" by auto

  note \<open>irreducible p\<close>
  also have "p = [:fract_content p:] * fract_poly (primitive_part_fract p)"
    by (simp add: content_times_primitive_part_fract)
  also have "irreducible \<dots> \<longleftrightarrow> irreducible (fract_poly (primitive_part_fract p))"
    by (intro irreducible_mult_unit_left) (simp_all add: is_unit_poly_iff dvd_field_iff)
  finally show ?thesis using deg
    by (simp add: nonconst_poly_irreducible_iff)
qed

lemma prime_elem_primitive_part_fract:
  fixes p :: "'a :: {idom_divide, ring_gcd, factorial_semiring, semiring_Gcd,semiring_gcd_mult_normalize} fract poly"
  shows "irreducible p \<Longrightarrow> prime_elem (primitive_part_fract p)"
  by (intro irreducible_imp_prime_poly irreducible_primitive_part_fract)

lemma irreducible_linear_field_poly:
  fixes a b :: "'a::field"
  assumes "b \<noteq> 0"
  shows "irreducible [:a,b:]"
proof (rule irreducibleI)
  fix p q assume pq: "[:a,b:] = p * q"
  also from pq assms have "degree \<dots> = degree p + degree q"
    by (intro degree_mult_eq) auto
  finally have "degree p = 0 \<or> degree q = 0" using assms by auto
  with assms pq show "is_unit p \<or> is_unit q"
    by (auto simp: is_unit_const_poly_iff dvd_field_iff elim!: degree_eq_zeroE)
qed (insert assms, auto simp: is_unit_poly_iff)

lemma prime_elem_linear_field_poly:
  "(b :: 'a :: field) \<noteq> 0 \<Longrightarrow> prime_elem [:a,b:]"
  by (rule field_poly_irreducible_imp_prime, rule irreducible_linear_field_poly)

lemma irreducible_linear_poly:
  fixes a b :: "'a::{idom_divide,ring_gcd,factorial_semiring,semiring_Gcd,semiring_gcd_mult_normalize}"
  shows "b \<noteq> 0 \<Longrightarrow> coprime a b \<Longrightarrow> irreducible [:a,b:]"
  by (auto intro!: irreducible_linear_field_poly
           simp:   nonconst_poly_irreducible_iff content_def map_poly_pCons)

lemma prime_elem_linear_poly:
  fixes a b :: "'a::{idom_divide,ring_gcd,factorial_semiring,semiring_Gcd,semiring_gcd_mult_normalize}"
  shows "b \<noteq> 0 \<Longrightarrow> coprime a b \<Longrightarrow> prime_elem [:a,b:]"
  by (rule irreducible_imp_prime_poly, rule irreducible_linear_poly)

subsection \<open>Prime factorisation of polynomials\<close>

lemma poly_prime_factorization_exists_content_1:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} poly"
  assumes "p \<noteq> 0" "content p = 1"
  shows   "\<exists>A. (\<forall>p. p \<in># A \<longrightarrow> prime_elem p) \<and> prod_mset A = normalize p"
proof -
  let ?P = "field_poly.prime_factorization (fract_poly p)"
  define c where "c = prod_mset (image_mset fract_content ?P)"
  define c' where "c' = c * to_fract (lead_coeff p)"
  define e where "e = prod_mset (image_mset primitive_part_fract ?P)"
  define A where "A = image_mset (normalize \<circ> primitive_part_fract) ?P"
  have "content e = (\<Prod>x\<in>#field_poly.prime_factorization (map_poly to_fract p).
                      content (primitive_part_fract x))"
    by (simp add: e_def content_prod_mset multiset.map_comp o_def)
  also have "image_mset (\<lambda>x. content (primitive_part_fract x)) ?P = image_mset (\<lambda>_. 1) ?P"
    by (intro image_mset_cong content_primitive_part_fract) auto
  finally have content_e: "content e = 1"
    by simp

  from \<open>p \<noteq> 0\<close> have "fract_poly p = [:lead_coeff (fract_poly p):] *
    smult (inverse (lead_coeff (fract_poly p))) (fract_poly p)"
    by simp
  also have "[:lead_coeff (fract_poly p):] = [:to_fract (lead_coeff p):]"
    by (simp add: monom_0 degree_map_poly coeff_map_poly)
  also from assms have "smult (inverse (lead_coeff (fract_poly p))) (fract_poly p) = prod_mset ?P"
    by (subst field_poly_prod_mset_prime_factorization) simp_all
  also have "\<dots> = prod_mset (image_mset id ?P)" by simp
  also have "image_mset id ?P =
               image_mset (\<lambda>x. [:fract_content x:] * fract_poly (primitive_part_fract x)) ?P"
    by (intro image_mset_cong) (auto simp: content_times_primitive_part_fract)
  also have "prod_mset \<dots> = smult c (fract_poly e)"
    by (subst prod_mset.distrib) (simp_all add: prod_mset_fract_poly prod_mset_const_poly c_def e_def)
  also have "[:to_fract (lead_coeff p):] * \<dots> = smult c' (fract_poly e)"
    by (simp add: c'_def)
  finally have eq: "fract_poly p = smult c' (fract_poly e)" .
  also obtain b where b: "c' = to_fract b" "is_unit b"
  proof -
    from fract_poly_smult_eqE[OF eq]
    obtain a b where ab:
      "c' = to_fract b / to_fract a"
      "smult a p = smult b e"
      "coprime a b"
      "normalize a = a" .
    from ab(2) have "content (smult a p) = content (smult b e)" by (simp only: )
    with assms content_e have "a = normalize b" by (simp add: ab(4))
    with ab have ab': "a = 1" "is_unit b"
      by (simp_all add: normalize_1_iff)
    with ab ab' have "c' = to_fract b" by auto
    from this and \<open>is_unit b\<close> show ?thesis by (rule that)
  qed
  hence "smult c' (fract_poly e) = fract_poly (smult b e)" by simp
  finally have "p = smult b e" by (simp only: fract_poly_eq_iff)
  hence "p = [:b:] * e" by simp
  with b have "normalize p = normalize e"
    by (simp only: normalize_mult) (simp add: is_unit_normalize is_unit_poly_iff)
  also have "normalize e = prod_mset A"
    by (simp add: multiset.map_comp e_def A_def normalize_prod_mset)
  finally have "prod_mset A = normalize p" ..

  have "prime_elem p" if "p \<in># A" for p
    using that by (auto simp: A_def prime_elem_primitive_part_fract prime_elem_imp_irreducible
                        dest!: field_poly_in_prime_factorization_imp_prime )
  from this and \<open>prod_mset A = normalize p\<close> show ?thesis
    by (intro exI[of _ A]) blast
qed

lemma poly_prime_factorization_exists:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} poly"
  assumes "p \<noteq> 0"
  shows   "\<exists>A. (\<forall>p. p \<in># A \<longrightarrow> prime_elem p) \<and> normalize (prod_mset A) = normalize p"
proof -
  define B where "B = image_mset (\<lambda>x. [:x:]) (prime_factorization (content p))"
  have "\<exists>A. (\<forall>p. p \<in># A \<longrightarrow> prime_elem p) \<and> prod_mset A = normalize (primitive_part p)"
    by (rule poly_prime_factorization_exists_content_1) (insert assms, simp_all)
  then obtain A where A: "\<forall>p. p \<in># A \<longrightarrow> prime_elem p" "\<Prod>\<^sub># A = normalize (primitive_part p)"
    by blast
  have "normalize (prod_mset (A + B)) = normalize (prod_mset A * normalize (prod_mset B))"
    by simp
  also from assms have "normalize (prod_mset B) = normalize [:content p:]"
    by (simp add: prod_mset_const_poly normalize_const_poly prod_mset_prime_factorization_weak B_def)
  also have "prod_mset A = normalize (primitive_part p)"
    using A by simp
  finally have "normalize (prod_mset (A + B)) = normalize (primitive_part p * [:content p:])"
    by simp
  moreover have "\<forall>p. p \<in># B \<longrightarrow> prime_elem p"
    by (auto simp: B_def intro!: lift_prime_elem_poly dest: in_prime_factors_imp_prime)
  ultimately show ?thesis using A by (intro exI[of _ "A + B"]) (auto)
qed

end

subsection \<open>Typeclass instances\<close>

instance poly :: ("{factorial_ring_gcd,semiring_gcd_mult_normalize}") factorial_semiring
  by standard (rule poly_prime_factorization_exists)

instantiation poly :: ("{factorial_ring_gcd, semiring_gcd_mult_normalize}") factorial_ring_gcd
begin

definition gcd_poly :: "'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  [code del]: "gcd_poly = gcd_factorial"

definition lcm_poly :: "'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  [code del]: "lcm_poly = lcm_factorial"

definition Gcd_poly :: "'a poly set \<Rightarrow> 'a poly" where
 [code del]: "Gcd_poly = Gcd_factorial"

definition Lcm_poly :: "'a poly set \<Rightarrow> 'a poly" where
 [code del]: "Lcm_poly = Lcm_factorial"

instance by standard (simp_all add: gcd_poly_def lcm_poly_def Gcd_poly_def Lcm_poly_def)

end

instance poly :: ("{factorial_ring_gcd, semiring_gcd_mult_normalize}") semiring_gcd_mult_normalize ..

instance poly :: ("{field,factorial_ring_gcd,semiring_gcd_mult_normalize}")
   "normalization_euclidean_semiring" ..

instance poly :: ("{field, normalization_euclidean_semiring, factorial_ring_gcd,
                    semiring_gcd_mult_normalize}") euclidean_ring_gcd
  by (rule euclidean_ring_gcd_class.intro, rule factorial_euclidean_semiring_gcdI) standard

subsection \<open>Polynomial GCD\<close>

lemma gcd_poly_decompose:
  fixes p q :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
  shows "gcd p q =
           smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q))"
proof (rule sym, rule gcdI)
  have "[:gcd (content p) (content q):] * gcd (primitive_part p) (primitive_part q) dvd
          [:content p:] * primitive_part p" by (intro mult_dvd_mono) simp_all
  thus "smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q)) dvd p"
    by simp
next
  have "[:gcd (content p) (content q):] * gcd (primitive_part p) (primitive_part q) dvd
          [:content q:] * primitive_part q" by (intro mult_dvd_mono) simp_all
  thus "smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q)) dvd q"
    by simp
next
  fix d assume "d dvd p" "d dvd q"
  hence "[:content d:] * primitive_part d dvd
           [:gcd (content p) (content q):] * gcd (primitive_part p) (primitive_part q)"
    by (intro mult_dvd_mono) auto
  thus "d dvd smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q))"
    by simp
qed (auto simp: normalize_smult)

lemma gcd_poly_pseudo_mod:
  fixes p q :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
  assumes nz: "q \<noteq> 0" and prim: "content p = 1" "content q = 1"
  shows   "gcd p q = gcd q (primitive_part (pseudo_mod p q))"
proof -
  define r s where "r = fst (pseudo_divmod p q)" and "s = snd (pseudo_divmod p q)"
  define a where "a = [:coeff q (degree q) ^ (Suc (degree p) - degree q):]"
  have [simp]: "primitive_part a = unit_factor a"
    by (simp add: a_def unit_factor_poly_def unit_factor_power monom_0)
  from nz have [simp]: "a \<noteq> 0" by (auto simp: a_def)

  have rs: "pseudo_divmod p q = (r, s)" by (simp add: r_def s_def)
  have "gcd (q * r + s) q = gcd q s"
    using gcd_add_mult[of q r s] by (simp add: gcd.commute add_ac mult_ac)
  with pseudo_divmod(1)[OF nz rs]
    have "gcd (p * a) q = gcd q s" by (simp add: a_def)
  also from prim have "gcd (p * a) q = gcd p q"
    by (subst gcd_poly_decompose)
       (auto simp: primitive_part_mult gcd_mult_unit1 primitive_part_prim
             simp del: mult_pCons_right )
  also from prim have "gcd q s = gcd q (primitive_part s)"
    by (subst gcd_poly_decompose) (simp_all add: primitive_part_prim)
  also have "s = pseudo_mod p q" by (simp add: s_def pseudo_mod_def)
  finally show ?thesis .
qed

lemma degree_pseudo_mod_less:
  assumes "q \<noteq> 0" "pseudo_mod p q \<noteq> 0"
  shows   "degree (pseudo_mod p q) < degree q"
  using pseudo_mod(2)[of q p] assms by auto

function gcd_poly_code_aux :: "'a :: factorial_ring_gcd poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  "gcd_poly_code_aux p q =
     (if q = 0 then normalize p else gcd_poly_code_aux q (primitive_part (pseudo_mod p q)))"
by auto
termination
  by (relation "measure ((\<lambda>p. if p = 0 then 0 else Suc (degree p)) \<circ> snd)")
     (auto simp: degree_pseudo_mod_less)

declare gcd_poly_code_aux.simps [simp del]

lemma gcd_poly_code_aux_correct:
  assumes "content p = 1" "q = 0 \<or> content q = 1"
  shows   "gcd_poly_code_aux p q = gcd p q"
  using assms
proof (induction p q rule: gcd_poly_code_aux.induct)
  case (1 p q)
  show ?case
  proof (cases "q = 0")
    case True
    thus ?thesis by (subst gcd_poly_code_aux.simps) auto
  next
    case False
    hence "gcd_poly_code_aux p q = gcd_poly_code_aux q (primitive_part (pseudo_mod p q))"
      by (subst gcd_poly_code_aux.simps) simp_all
    also from "1.prems" False
      have "primitive_part (pseudo_mod p q) = 0 \<or>
              content (primitive_part (pseudo_mod p q)) = 1"
      by (cases "pseudo_mod p q = 0") auto
    with "1.prems" False
      have "gcd_poly_code_aux q (primitive_part (pseudo_mod p q)) =
              gcd q (primitive_part (pseudo_mod p q))"
      by (intro 1) simp_all
    also from "1.prems" False
      have "\<dots> = gcd p q" by (intro gcd_poly_pseudo_mod [symmetric]) auto
    finally show ?thesis .
  qed
qed

definition gcd_poly_code
    :: "'a :: factorial_ring_gcd poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly"
  where "gcd_poly_code p q =
           (if p = 0 then normalize q else if q = 0 then normalize p else
              smult (gcd (content p) (content q))
                (gcd_poly_code_aux (primitive_part p) (primitive_part q)))"

lemma gcd_poly_code [code]: "gcd p q = gcd_poly_code p q"
  by (simp add: gcd_poly_code_def gcd_poly_code_aux_correct gcd_poly_decompose [symmetric])

lemma lcm_poly_code [code]:
  fixes p q :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
  shows "lcm p q = normalize (p * q div gcd p q)"
  by (fact lcm_gcd)

lemmas Gcd_poly_set_eq_fold [code] =
  Gcd_set_eq_fold [where ?'a = "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"]
lemmas Lcm_poly_set_eq_fold [code] =
  Lcm_set_eq_fold [where ?'a = "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"]

text \<open>Example:
  @{lemma "Lcm {[:1, 2, 3:], [:2, 3, 4:]} = [:[:2:], [:7:], [:16:], [:17:], [:12 :: int:]:]" by eval}
\<close>

end


theory Paths_Cycles
  imports Floyd_Warshall Timed_Automata
begin

chapter \<open>Library for Paths, Arcs and Lengths\<close>

lemma length_eq_distinct:
  assumes "set xs = set ys" "distinct xs" "length xs = length ys"
  shows "distinct ys"
using assms card_distinct distinct_card by fastforce

section \<open>Arcs\<close>

fun arcs :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> (nat * nat) list" where
  "arcs a b [] = [(a,b)]" |
  "arcs a b (x # xs) = (a, x) # arcs x b xs"

definition arcs' :: "nat list \<Rightarrow> (nat * nat) set" where
  "arcs' xs = set (arcs (hd xs) (last xs) (butlast (tl xs)))"

lemma arcs'_decomp:
  "length xs > 1 \<Longrightarrow> (i, j) \<in> arcs' xs \<Longrightarrow> \<exists> zs ys. xs = zs @ i # j # ys"
proof (induction xs)
  case Nil thus ?case by auto
next
  case (Cons x xs)
  then have "length xs > 0" by auto
  then obtain y ys where xs: "xs = y # ys" by (metis Suc_length_conv less_imp_Suc_add)
  show ?case
  proof (cases "(i, j) = (x, y)")
    case True
    with xs have "x # xs = [] @ i # j # ys" by simp
    then show ?thesis by auto
  next
    case False
    then show ?thesis
    proof (cases "length ys > 0", goal_cases)
      case 2
      then have "ys = []" by auto
      then have "arcs' (x#xs) = {(x,y)}" using xs by (auto simp add: arcs'_def)
      with Cons.prems(2) 2(1) show ?case by auto
    next
      case True
      with xs Cons.prems(2) False have "(i, j) \<in> arcs' xs" by (auto simp add: arcs'_def)
      with Cons.IH[OF _ this] True xs obtain zs ys where "xs = zs @ i # j # ys" by auto
      then have "x # xs = (x # zs) @ i # j # ys" by simp
      then show ?thesis by blast
    qed
  qed
qed

lemma arcs_decomp_tail:
  "arcs j l (ys @ [i]) = arcs j i ys @ [(i, l)]"
by (induction ys arbitrary: j) auto

lemma arcs_decomp: "xs = ys @ y # zs \<Longrightarrow> arcs x z xs = arcs x y ys @ arcs y z zs"
by (induction ys arbitrary: x xs) simp+

lemma distinct_arcs_ex:
  "distinct xs \<Longrightarrow> i \<notin> set xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> \<exists> a b. a \<noteq> x \<and> (a,b) \<in> set (arcs i j xs)"
 apply (induction xs arbitrary: i)
  apply simp
 apply (rename_tac a xs i)
 apply (case_tac xs)
  apply simp
  apply metis
by auto

lemma cycle_rotate_2_aux:
  "(i, j) \<in> set (arcs a b (xs @ [c])) \<Longrightarrow> (i,j) \<noteq> (c,b) \<Longrightarrow> (i, j) \<in> set (arcs a c xs)"
by (induction xs arbitrary: a) auto

lemma arcs_set_elem1:
  assumes "j \<noteq> k" "k \<in> set (i # xs)"
  shows "\<exists> l. (k, l) \<in> set (arcs i j xs)" using assms
by (induction xs arbitrary: i) auto

lemma arcs_set_elem2:
  assumes "i \<noteq> k" "k \<in> set (j # xs)"
  shows "\<exists> l. (l, k) \<in> set (arcs i j xs)" using assms
proof (induction xs arbitrary: i)
  case Nil then show ?case by simp
next
  case (Cons x xs)
  then show ?case by (cases "k = x") auto
qed

section \<open>Length of Paths\<close>

lemmas (in linordered_ab_monoid_add) comm = add.commute

lemma len_add:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  shows "len M i j xs + len M i j xs = len (\<lambda>i j. M i j + M i j) i j xs"
proof (induction xs arbitrary: i j)
  case Nil thus ?case by auto
next
  case (Cons x xs)
  have "M i x + len M x j xs + (M i x + len M x j xs) = M i x + (len M x j xs + M i x) + len M x j xs"
  by (simp add: assoc)
  also have "\<dots> = M i x + (M i x + len M x j xs) + len M x j xs" by (simp add: comm)
  also have "\<dots> = (M i x + M i x) + (len M x j xs + len M x j xs)" by (simp add: assoc)
  finally have "M i x + len M x j xs + (M i x + len M x j xs)
                = (M i x + M i x) + len (\<lambda>i j. M i j + M i j) x j xs"
  using Cons by simp
  thus ?case by simp
qed

section \<open>Canonical Matrices\<close>

abbreviation
  "canonical M n \<equiv> \<forall> i j k. i \<le> n \<and> j \<le> n \<and> k \<le> n \<longrightarrow> M i k \<le> M i j + M j k"

lemma fw_canonical:
 "cycle_free m n \<Longrightarrow> canonical (fw m n n n n) n"
proof (clarify, goal_cases)
  case 1
  with fw_shortest[OF \<open>cycle_free m n\<close>] show ?case
  by auto
qed

lemma canonical_len:
  "canonical M n \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> set xs \<subseteq> {0..n} \<Longrightarrow> M i j \<le> len M i j xs"
proof (induction xs arbitrary: i)
  case Nil thus ?case by auto
next
  case (Cons x xs)
  then have "M x j \<le> len M x j xs" by auto
  from Cons.prems \<open>canonical M n\<close> have "M i j \<le> M i x + M x j" by simp
  also with Cons have "\<dots> \<le> M i x + len M x j xs" by (simp add: add_mono)
  finally show ?case by simp
qed

section \<open>Cycle Rotation\<close>

lemma cycle_rotate:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "length xs > 1" "(i, j) \<in> arcs' xs"
  shows "\<exists> ys zs. len M a a xs = len M i i (j # ys @ a # zs) \<and> xs = zs @ i # j # ys" using assms
proof -
  assume A: "length xs > 1" "(i, j) \<in> arcs' xs"
  from arcs'_decomp[OF this] obtain ys zs where xs: "xs = zs @ i # j # ys" by blast
  from len_decomp[OF this, of M a a]
  have "len M a a xs = len M a i zs + len M i a (j # ys)" .
  also have "\<dots> = len M i a (j # ys) + len M a i zs" by (simp add: comm)
  also from len_comp[of M i i "j # ys" a zs] have "\<dots> = len M i i (j # ys @ a # zs)" by auto
  finally show ?thesis using xs by auto
qed

lemma cycle_rotate_2:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "xs \<noteq> []" "(i, j) \<in> set (arcs a a xs)"
  shows "\<exists> ys. len M a a xs = len M i i (j # ys) \<and> set ys \<subseteq> set (a # xs) \<and> length ys < length xs"
using assms proof -
  assume A:"xs \<noteq> []" "(i, j) \<in> set (arcs a a xs)"
  { fix ys assume A:"a = i" "xs = j # ys"
    then have ?thesis by auto
  } note * = this
  { fix b ys assume A:"a = j" "xs = ys @ [i]"
    then have ?thesis
    proof (auto, goal_cases)
      case 1
      have "len M j j (ys @ [i]) = M i j + len M j i ys"
      using len_decomp[of "ys @ [i]" ys i "[]" M j j] by (auto simp: comm)
      thus ?case by blast
    qed
  } note ** = this
  { assume "length xs = 1"
    then obtain b where xs: "xs = [b]" by (metis One_nat_def length_0_conv length_Suc_conv)
    with A(2) have "a = i \<and> b = j \<or> a = j \<and> b = i" by auto
    then have ?thesis using * ** xs by auto
  } note *** = this
  show ?thesis
  proof (cases "length xs = 0")
    case True with A show ?thesis by auto
  next
    case False
    thus ?thesis
    proof (cases "length xs = 1", goal_cases)
      case True with *** show ?thesis by auto
    next
      case 2
      hence "length xs > 1" by linarith
      then obtain b c ys where ys:"xs = b # ys @ [c]"
      by (metis One_nat_def assms(1) 2(2) length_0_conv length_Cons list.exhaust rev_exhaust)
      thus ?thesis
      proof (cases "(i,j) = (a,b)", goal_cases)
        case True
        with ys * show ?thesis by auto
      next
        case False
        then show ?thesis
        proof (cases "(i,j) = (c,a)", goal_cases)
          case True
          with ys ** show ?thesis by auto
        next
          case 2
          with A(2) ys have "(i, j) \<in> arcs' xs"
          using cycle_rotate_2_aux by (auto simp: arcs'_def) (* slow *)
          from cycle_rotate[OF \<open>length xs > 1\<close> this, of M a] show ?thesis by auto
        qed
      qed
    qed
  qed
qed

lemma cycle_rotate_len_arcs:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "length xs > 1" "(i, j) \<in> arcs' xs"
  shows "\<exists> ys zs. len M a a xs = len M i i (j # ys @ a # zs)
                \<and> set (arcs a a xs) = set (arcs i i (j # ys @ a # zs)) \<and> xs = zs @ i # j # ys"
using assms
proof -
  assume A: "length xs > 1" "(i, j) \<in> arcs' xs"
  from arcs'_decomp[OF this] obtain ys zs where xs: "xs = zs @ i # j # ys" by blast
  from len_decomp[OF this, of M a a]
  have "len M a a xs = len M a i zs + len M i a (j # ys)" .
  also have "\<dots> = len M i a (j # ys) + len M a i zs" by (simp add: comm)
  also from len_comp[of M i i "j # ys" a zs] have "\<dots> = len M i i (j # ys @ a # zs)" by auto
  finally show ?thesis
  using xs arcs_decomp[OF xs, of a a] arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i] by force
qed

lemma cycle_rotate_2':
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "xs \<noteq> []" "(i, j) \<in> set (arcs a a xs)"
  shows "\<exists> ys. len M a a xs = len M i i (j # ys) \<and> set (i # j # ys) = set (a # xs)
             \<and> 1 + length ys = length xs \<and> set (arcs a a xs) = set (arcs i i (j # ys))"
proof -
  note A = assms
  { fix ys assume A:"a = i" "xs = j # ys"
    then have ?thesis by auto
  } note * = this
  { fix b ys assume A:"a = j" "xs = ys @ [i]"
    then have ?thesis
    proof (auto, goal_cases)
      case 1
      have "len M j j (ys @ [i]) = M i j + len M j i ys"
      using len_decomp[of "ys @ [i]" ys i "[]" M j j] by (auto simp: comm)
      moreover have "arcs j j (ys @ [i]) = arcs j i ys @ [(i, j)]" using arcs_decomp_tail by auto
      ultimately show ?case by auto
    qed
  } note ** = this
  { assume "length xs = 1"
    then obtain b where xs: "xs = [b]" by (metis One_nat_def length_0_conv length_Suc_conv)
    with A(2) have "a = i \<and> b = j \<or> a = j \<and> b = i" by auto
    then have ?thesis using * ** xs by auto
  } note *** = this
  show ?thesis
  proof (cases "length xs = 0")
    case True with A show ?thesis by auto
  next
    case False
    thus ?thesis
    proof (cases "length xs = 1", goal_cases)
      case True with *** show ?thesis by auto
    next
      case 2
      hence "length xs > 1" by linarith
      then obtain b c ys where ys:"xs = b # ys @ [c]"
      by (metis One_nat_def assms(1) 2(2) length_0_conv length_Cons list.exhaust rev_exhaust)
      thus ?thesis
      proof (cases "(i,j) = (a,b)")
        case True
        with ys * show ?thesis by blast
      next
        case False
        then show ?thesis
        proof (cases "(i,j) = (c,a)", goal_cases)
          case True
          with ys ** show ?thesis by force
        next
          case 2
          with A(2) ys have "(i, j) \<in> arcs' xs"
          using cycle_rotate_2_aux by (auto simp add: arcs'_def) (* slow *)
          from cycle_rotate_len_arcs[OF \<open>length xs > 1\<close> this, of M a] show ?thesis by auto
        qed
      qed
    qed
  qed
qed

section \<open>Equivalent Characterizations of Cycle-Freeness\<close>

lemma negative_cycle_dest_diag:
  "\<not> cycle_free M n \<Longrightarrow> \<exists> i xs. i \<le> n \<and> set xs \<subseteq> {0..n} \<and> len M i i xs < \<one>"
proof (auto simp: cycle_free_def, goal_cases)
  case (1 i xs j)
  from this(4) have "len M i j xs < len M i j (rem_cycles i j xs)" by auto
  from negative_cycle_dest[OF this] obtain i' ys
  where *:"len M i' i' ys < \<one>" "set (i' # ys) \<subseteq> set (i # j # xs)" by auto
  from this(2) 1(1-3) have "set ys \<subseteq> {0..n}" "i' \<le> n" by auto
  with * show ?case by auto
next
  case 2 then show ?case by fastforce
qed

abbreviation cyc_free :: "('a::linordered_ab_monoid_add) mat \<Rightarrow> nat \<Rightarrow> bool" where
  "cyc_free m n \<equiv> \<forall> i xs. i \<le> n \<and> set xs \<subseteq> {0..n} \<longrightarrow> len m i i xs \<ge> \<one>"

lemma cycle_free_diag_intro:
  "cyc_free M n \<Longrightarrow> cycle_free M n"
using negative_cycle_dest_diag by force

lemma cycle_free_diag_equiv:
  "cyc_free M n \<longleftrightarrow> cycle_free M n" using negative_cycle_dest_diag
by (force simp: cycle_free_def)

lemma cycle_free_diag_dest:
  "cycle_free M n \<Longrightarrow> cyc_free M n"
using cycle_free_diag_equiv by blast

lemma cyc_free_diag_dest:
  assumes "cyc_free M n" "i \<le> n" "set xs \<subseteq> {0..n}"
  shows "len M i i xs \<ge> \<one>"
using assms by auto

lemma cycle_free_0_0:
  fixes M :: "('a::linordered_ab_monoid_add) mat"
  assumes "cycle_free M n"
  shows "M 0 0 \<ge> \<one>"
using cyc_free_diag_dest[OF cycle_free_diag_dest[OF assms], of 0 "[]"] by auto

section \<open>More Theorems Related to Floyd-Warshall\<close>

lemma D_cycle_free_len_dest:
  "cycle_free m n
    \<Longrightarrow> \<forall> i \<le> n. \<forall> j \<le> n. D m i j n = m' i j \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> set xs \<subseteq> {0..n}
    \<Longrightarrow> \<exists> ys. set ys \<subseteq> {0..n} \<and> len m' i j xs = len m i j ys"
proof (induction xs arbitrary: i)
  case Nil
  with Nil have "m' i j = D m i j n" by simp
  from D_dest''[OF this]
  obtain ys where "set ys \<subseteq> {0..n}" "len m' i j [] = len m i j ys"
  by auto
  then show ?case by auto
next
  case (Cons y ys)
  from Cons.IH[OF Cons.prems(1,2) _ \<open>j \<le> n\<close>, of y] Cons.prems(5)
  obtain zs where zs:"set zs \<subseteq> {0..n}" "len m' y j ys = len m y j zs" by auto
  with Cons have "m' i y = D m i y n" by simp
  from D_dest''[OF this] obtain ws where ws:"set ws \<subseteq> {0..n}" "m' i y = len m i y ws" by auto
  with len_comp[of m i j ws y zs] zs Cons.prems(5)
  have "len m' i j (y # ys) = len m i j (ws @ y # zs)" "set (ws @ y # zs) \<subseteq> {0..n}" by auto
  then show ?case by blast
qed

lemma D_cyc_free_preservation:
  "cyc_free m n \<Longrightarrow> \<forall> i \<le> n. \<forall> j \<le> n. D m i j n = m' i j \<Longrightarrow> cyc_free m' n"
proof (auto, goal_cases)
  case (1 i xs)
  from D_cycle_free_len_dest[OF _ 1(2,3,3,4)] 1(1) cycle_free_diag_equiv
  obtain ys where "set ys \<subseteq> {0..n} \<and> len m' i i xs = len m i i ys" by fast
  with 1(1,3) show ?case by auto
qed

abbreviation "FW m n \<equiv> fw m n n n n"

lemma FW_cyc_free_preservation:
  "cyc_free m n \<Longrightarrow> cyc_free (FW m n) n"
apply (rule D_cyc_free_preservation)
 apply assumption
apply safe
apply (rule fw_shortest_path)
using cycle_free_diag_equiv by auto

lemma cyc_free_diag_dest':
  "cyc_free m n \<Longrightarrow> i \<le> n \<Longrightarrow> m i i \<ge> \<one>"
proof goal_cases
  case 1
  then have "i \<le> n \<and> set [] \<subseteq> {0..n}" by auto
  with 1(1) have "\<one> \<le> len m i i []" by blast
  then show ?case by auto
qed

lemma FW_diag_neutral_preservation:
  "\<forall> i \<le> n. M i i = \<one> \<Longrightarrow> cyc_free M n \<Longrightarrow> \<forall> i\<le>n. (FW M n) i i = \<one>"
proof (auto, goal_cases)
  case (1 i)
  from this(3) have "(FW M n) i i \<le> M i i" by (auto intro: fw_mono)
  with 1 have "(FW M n) i i \<le> \<one>" by auto
  with cyc_free_diag_dest'[OF FW_cyc_free_preservation[OF 1(2)] \<open>i \<le> n\<close>] show "FW M n i i = \<one>" by auto
qed

lemma FW_fixed_preservation:
  fixes M :: "('a::linordered_ab_monoid_add) mat"
  assumes A: "i \<le> n" "M 0 i + M i 0 = \<one>" "canonical (FW M n) n" "cyc_free (FW M n) n"
  shows "FW M n 0 i + FW M n i 0 = \<one>" using assms
proof -
  let ?M' = "FW M n"
  assume A: "i \<le> n" "M 0 i + M i 0 = \<one>" "canonical ?M' n" "cyc_free ?M' n"
  from \<open>i \<le> n\<close> have "?M' 0 i + ?M' i 0 \<le> M 0 i + M i 0" by (auto intro: fw_mono add_mono)
  with A(2) have "?M' 0 i + ?M' i 0 \<le> \<one>" by auto
  moreover from \<open>canonical ?M' n\<close> \<open>i \<le> n\<close>
  have "?M' 0 0 \<le> ?M' 0 i + ?M' i 0" by auto
  moreover from cyc_free_diag_dest'[OF  \<open>cyc_free ?M' n\<close>] have "\<one> \<le> ?M' 0 0" by simp
  ultimately show "?M' 0 i + ?M' i 0 = \<one>" by (auto simp: add_mono)
qed

lemma diag_cyc_free_neutral:
  "cyc_free M n \<Longrightarrow> \<forall>k\<le>n. M k k \<le> \<one> \<Longrightarrow> \<forall>i\<le>n. M i i = \<one>"
proof (clarify, goal_cases)
  case (1 i)
  note A = this
  then have "i \<le> n \<and> set [] \<subseteq> {0..n}" by auto
  with A(1) have "\<one> \<le> M i i" by fastforce
  with A(2) \<open>i \<le> n\<close> show "M i i = \<one>" by auto
qed

lemma fw_upd_canonical_id:
  "canonical M n \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> k \<le> n \<Longrightarrow> fw_upd M k i j = M"
proof (auto simp: fw_upd_def upd_def less_eq[symmetric] min.coboundedI2, goal_cases)
  case 1
  then have "M i j \<le> M i k + M k j" by auto
  then have "min (M i j) (M i k + M k j) = M i j" by (simp split: split_min)
  thus ?case by force
qed

lemma fw_canonical_id:
  "canonical M n \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> k \<le> n \<Longrightarrow> fw M n k i j = M"
proof (induction k arbitrary: i j)
  case 0
  then show ?case
  proof (induction i arbitrary: j)
    case 0
    then show ?case
    proof (induction j)
      case 0 thus ?case by (auto intro: fw_upd_canonical_id)
    next
      case Suc thus ?case by (auto intro: fw_upd_canonical_id)
    qed
  next
    case Suc
    then show ?case
    proof (induction j)
      case 0 thus ?case by (auto intro: fw_upd_canonical_id)
    next
      case Suc thus ?case by (auto intro: fw_upd_canonical_id)
    qed
  qed
next
  case Suc
  then show ?case
  proof (induction i arbitrary: j)
    case 0
    then show ?case
    proof (induction j)
      case 0 thus ?case by (auto intro: fw_upd_canonical_id)
    next
      case Suc thus ?case by (auto intro: fw_upd_canonical_id)
    qed
  next
    case Suc
    then show ?case
    proof (induction j)
      case 0 thus ?case by (auto intro: fw_upd_canonical_id)
    next
      case Suc thus ?case by (auto intro: fw_upd_canonical_id)
    qed
  qed
qed

lemmas FW_canonical_id = fw_canonical_id[OF _ order.refl order.refl order.refl]

section \<open>Helper Lemmas for Bouyer's Theorem on Approximation\<close>

lemma aux1: "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> set xs \<subseteq> {0..n} \<Longrightarrow> (a,b) \<in> set (arcs i j xs) \<Longrightarrow> a \<le> n \<and> b \<le> n"
by (induction xs arbitrary: i) auto

lemma arcs_distinct1:
  "i \<notin> set xs \<Longrightarrow> j \<notin> set xs \<Longrightarrow> distinct xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> (a,b) \<in> set (arcs i j xs) \<Longrightarrow> a \<noteq> b"
apply (induction xs arbitrary: i)
 apply fastforce
apply (rename_tac a' xs i)
apply (case_tac xs)
 apply auto
done

lemma arcs_distinct2:
  "i \<notin> set xs \<Longrightarrow> j \<notin> set xs \<Longrightarrow> distinct xs \<Longrightarrow> i \<noteq> j \<Longrightarrow> (a,b) \<in> set (arcs i j xs) \<Longrightarrow> a \<noteq> b"
by (induction xs arbitrary: i) auto

lemma arcs_distinct3: "distinct (a # b # c # xs) \<Longrightarrow> (i,j) \<in> set (arcs a b xs) \<Longrightarrow> i \<noteq> c \<and> j \<noteq> c"
by (induction xs arbitrary: a) force+

lemma arcs_elem:
  assumes "(a, b) \<in> set (arcs i j xs)" shows "a \<in> set (i # xs)" "b \<in> set (j # xs)"
using assms by (induction xs arbitrary: i) auto

lemma arcs_distinct_dest1:
  "distinct (i # a # zs) \<Longrightarrow> (b,c) \<in> set (arcs a j zs) \<Longrightarrow> b \<noteq> i"
using arcs_elem by fastforce

lemma arcs_distinct_fix:
  "distinct (a # x # xs @ [b]) \<Longrightarrow> (a,c) \<in> set (arcs a b (x # xs)) \<Longrightarrow> c = x"
using arcs_elem(1) by fastforce

lemma disjE3: "A \<or> B \<or> C \<Longrightarrow> (A \<Longrightarrow> G) \<Longrightarrow> (B \<Longrightarrow> G) \<Longrightarrow> (C \<Longrightarrow> G) \<Longrightarrow> G"
by auto

lemma arcs_predecessor:
  assumes "(a, b) \<in> set (arcs i j xs)" "a \<noteq> i"
  shows "\<exists> c. (c, a) \<in> set (arcs i j xs)" using assms
by (induction xs arbitrary: i) auto

lemma arcs_successor:
  assumes "(a, b) \<in> set (arcs i j xs)" "b \<noteq> j"
  shows "\<exists> c. (b,c) \<in> set (arcs i j xs)" using assms
apply (induction xs arbitrary: i)
 apply simp
apply (rename_tac aa xs i)
apply (case_tac xs)
by auto

lemma arcs_predecessor':
  assumes "(a, b) \<in> set (arcs i j (x # xs))" "(a,b) \<noteq> (i, x)"
  shows "\<exists> c. (c, a) \<in> set (arcs i j (x # xs))" using assms
by (induction xs arbitrary: i x) auto

lemma arcs_cases:
  assumes "(a, b) \<in> set (arcs i j xs)" "xs \<noteq> []"
  shows "(\<exists> ys. xs = b # ys \<and> a = i) \<or> (\<exists> ys. xs = ys @ [a] \<and> b = j)
       \<or> (\<exists> c d ys. (a,b) \<in> set (arcs c d ys) \<and> xs = c # ys @ [d])"
using assms
proof (induction xs arbitrary: i)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "(a, b) = (i, x)")
    case True
    with Cons.prems show ?thesis by auto
  next
    case False
    note F = this
    show ?thesis
    proof (cases "xs = []")
      case True
      with F Cons.prems show ?thesis by auto
    next
      case False
      from F Cons.prems have "(a, b) \<in> set (arcs x j xs)" by auto
      from Cons.IH[OF this False] have
        "(\<exists>ys. xs = b # ys \<and> a = x) \<or> (\<exists>ys. xs = ys @ [a] \<and> b = j)
         \<or> (\<exists>c d ys. (a, b) \<in> set (arcs c d ys) \<and> xs = c # ys @ [d])"
      .
      then show ?thesis
      proof (rule disjE3, goal_cases)
        case 1
        from 1 obtain ys where *: "xs = b # ys \<and> a = x" by auto
        show ?thesis
        proof (cases "ys = []")
          case True
          with * show ?thesis by auto
        next
          case False
          then obtain z zs where zs: "ys = zs @ [z]" by (metis append_butlast_last_id)
          with * show ?thesis by auto
        qed
      next
        case 2 then show ?case by auto
      next
        case 3 with False show ?case by auto
      qed
    qed
  qed
qed

lemma arcs_cases':
  assumes "(a, b) \<in> set (arcs i j xs)" "xs \<noteq> []"
  shows "(\<exists> ys. xs = b # ys \<and> a = i) \<or> (\<exists> ys. xs = ys @ [a] \<and> b = j) \<or> (\<exists> ys zs. xs = ys @ a # b # zs)"
using assms
proof (induction xs arbitrary: i)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "(a, b) = (i, x)")
    case True
    with Cons.prems show ?thesis by auto
  next
    case False
    note F = this
    show ?thesis
    proof (cases "xs = []")
      case True
      with F Cons.prems show ?thesis by auto
    next
      case False
      from F Cons.prems have "(a, b) \<in> set (arcs x j xs)" by auto
      from Cons.IH[OF this False] have
        "(\<exists>ys. xs = b # ys \<and> a = x) \<or> (\<exists>ys. xs = ys @ [a] \<and> b = j)
         \<or> (\<exists>ys zs. xs = ys @ a # b # zs)"
      .
      then show ?thesis
      proof (rule disjE3, goal_cases)
        case 1
        from 1 obtain ys where *: "xs = b # ys \<and> a = x" by auto
        show ?thesis
        proof (cases "ys = []")
          case True
          with * show ?thesis by auto
        next
          case False
          then obtain z zs where zs: "ys = zs @ [z]" by (metis append_butlast_last_id)
          with * show ?thesis by auto
        qed
      next
        case 2 then show ?case by auto
      next
        case 3
        then obtain ys zs where "xs = ys @ a # b # zs" by auto
        then have "x # xs = (x # ys) @ a # b # zs" by auto
        then show ?thesis by blast
      qed
    qed
  qed
qed

lemma arcs_successor':
  assumes "(a, b) \<in> set (arcs i j xs)" "b \<noteq> j"
  shows "\<exists> c. xs = [b] \<and> a = i \<or> (\<exists> ys. xs = b # c # ys \<and> a = i) \<or> (\<exists> ys. xs = ys @ [a,b] \<and> c = j)
       \<or> (\<exists> ys zs. xs = ys @ a # b # c # zs)"
using assms
proof (induction xs arbitrary: i)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "(a, b) = (i, x)")
    case True
    with Cons.prems show ?thesis by (cases xs) auto
  next
    case False
    note F = this
    show ?thesis
    proof (cases "xs = []")
      case True
      with F Cons.prems show ?thesis by auto
    next
      case False
      from F Cons.prems have "(a, b) \<in> set (arcs x j xs)" by auto
      from Cons.IH[OF this \<open>b \<noteq> j\<close>] obtain c where c:
        "xs = [b] \<and> a = x \<or> (\<exists>ys. xs = b # c # ys \<and> a = x) \<or> (\<exists>ys. xs = ys @ [a, b] \<and> c = j)
         \<or> (\<exists>ys zs. xs = ys @ a # b # c # zs)"
      ..
      then show ?thesis
      proof (standard, goal_cases)
        case 1 with Cons.prems show ?case by auto
      next
        case 2
        then show ?thesis
        proof (rule disjE3, goal_cases)
          case 1
          from 1 obtain ys where *: "xs = b # ys \<and> a = x" by auto
          show ?thesis
          proof (cases "ys = []")
            case True
            with * show ?thesis by auto
          next
            case False
            then obtain z zs where zs: "ys = z # zs" by (cases ys) auto
            with * show ?thesis by fastforce
          qed
        next
          case 2 then show ?case by auto
        next
          case 3
          then obtain ys zs where "xs = ys @ a # b # c # zs" by auto
          then have "x # xs = (x # ys) @ a # b # c # zs" by auto
          then show ?thesis by blast
        qed
      qed
    qed
  qed
qed

lemma list_last:
  "xs = [] \<or> (\<exists> y ys. xs = ys @ [y])"
by (induction xs) auto

lemma arcs_predecessor'':
  assumes "(a, b) \<in> set (arcs i j xs)" "a \<noteq> i"
 shows "\<exists> c. xs = [a] \<or> (\<exists> ys. xs = a # b # ys) \<or> (\<exists> ys. xs = ys @ [c,a] \<and> b = j)
       \<or> (\<exists> ys zs. xs = ys @ c # a # b # zs)"
using assms
proof (induction xs arbitrary: i)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "(a, b) = (i, x)")
    case True
    with Cons.prems show ?thesis by (cases xs) auto
  next
    case False
    note F = this
    show ?thesis
    proof (cases "xs = []")
      case True
      with F Cons.prems show ?thesis by auto
    next
      case False
      from F Cons.prems have *: "(a, b) \<in> set (arcs x j xs)" by auto
      from False obtain y ys where xs: "xs = y # ys" by (cases xs) auto
      show ?thesis
      proof (cases "(a,b) = (x,y)")
        case True with * xs show ?thesis by auto
      next
        case False
        with * xs have **: "(a, b) \<in> set (arcs y j ys)" by auto
        show ?thesis
        proof (cases "ys = []")
          case True with ** xs show ?thesis by force
        next
          case False
          from arcs_cases'[OF ** this] obtain ws zs where ***:
            "ys = b # ws \<and> a = y \<or> ys = ws @ [a] \<and> b = j \<or> ys = ws @ a # b # zs"
          by auto
          then show ?thesis
           apply rule
            using xs apply blast
           apply safe
            using xs list_last[of ws] apply -
            apply (rotate_tac 3)
            apply (case_tac "ws = []")
             apply auto[]
            apply (subgoal_tac "\<exists>y ys. ws = ys @ [y]")
             apply fastforce
            apply simp
           apply (case_tac "ws = []")
            apply (subgoal_tac "x # xs = [x] @ y # a # b # zs")
             apply (rule exI[where x = y])
             apply blast
            apply simp
           subgoal
           proof goal_cases
             case 1
             then obtain u us where "ws = us @ [u]" by auto
             with 1(1,2) have "x # xs = (x # y # us) @ u # a # b # zs" by auto
             then show ?case by blast
           qed
          done
        qed
      qed
    qed
  qed
qed

lemma arcs_ex_middle:
  "\<exists> b. (a, b) \<in> set (arcs i j (ys @ a # xs))"
by (induction xs arbitrary: i ys) (auto simp: arcs_decomp)

lemma arcs_ex_head:
  "\<exists> b. (i, b) \<in> set (arcs i j xs)"
by (cases xs) auto

subsection \<open>Successive\<close>

fun successive where
  "successive _ [] = True" |
  "successive P [_] = True" |
  "successive P (x # y # xs) \<longleftrightarrow> \<not> P y \<and> successive P xs \<or> \<not> P x \<and> successive P (y # xs)"

lemma "\<not> successive (\<lambda> x. x > (0 :: nat)) [Suc 0, Suc 0]" by simp
lemma "successive (\<lambda> x. x > (0 :: nat)) [Suc 0]" by simp
lemma "successive (\<lambda> x. x > (0 :: nat)) [Suc 0, 0, Suc 0]" by simp
lemma "\<not> successive (\<lambda> x. x > (0 :: nat)) [Suc 0, 0, Suc 0, Suc 0]" by simp
lemma "\<not> successive (\<lambda> x. x > (0 :: nat)) [Suc 0, 0, 0, Suc 0, Suc 0]" by simp
lemma "successive (\<lambda> x. x > (0 :: nat)) [Suc 0, 0, Suc 0, 0, Suc 0]" by simp
lemma "\<not> successive (\<lambda> x. x > (0 :: nat)) [Suc 0, Suc 0, 0, Suc 0]" by simp
lemma "successive (\<lambda> x. x > (0 :: nat)) [0, 0, Suc 0, 0]" by simp

lemma successive_step: "successive P (x # xs) \<Longrightarrow> \<not> P x \<Longrightarrow> successive P xs"
  apply (cases xs)
   apply simp
  apply (rename_tac y ys)
  apply (case_tac ys)
   apply auto
done

lemma successive_step_2: "successive P (x # y # xs) \<Longrightarrow> \<not> P y \<Longrightarrow> successive P xs"
  apply (cases xs)
   apply simp
  apply (rename_tac z zs)
  apply (case_tac zs)
   apply auto
done

lemma successive_stepI:
  "successive P xs \<Longrightarrow> \<not> P x \<Longrightarrow> successive P (x # xs)"
by (cases xs) auto

theorem list_two_induct[case_names Nil Single Cons]:
  fixes P :: "'a list \<Rightarrow> bool"
    and list :: "'a list"
  assumes Nil: "P []"
  assumes Single: "\<And> x. P [x]"
    and Cons: "\<And>x1 x2 xs. P xs \<Longrightarrow> P (x2 # xs) \<Longrightarrow> P (x1 # x2 # xs)"
  shows "P xs"
using assms
 apply (induction "length xs" arbitrary: xs rule: less_induct)
 apply (rename_tac xs)
 apply (case_tac xs)
  apply simp
 apply (rename_tac ys)
 apply (case_tac ys)
  apply simp
 apply (rename_tac zs)
 apply (case_tac zs)
by auto

lemma successive_end_1:
  "successive P xs \<Longrightarrow> \<not> P x \<Longrightarrow> successive P (xs @ [x])"
by (induction _ xs rule: list_two_induct) auto

lemma successive_ends_1:
  "successive P xs \<Longrightarrow> \<not> P x \<Longrightarrow> successive P ys \<Longrightarrow> successive P (xs @ x # ys)"
by (induction _ xs rule: list_two_induct) (fastforce intro: successive_stepI)+

lemma successive_ends_1':
  "successive P xs \<Longrightarrow> \<not> P x \<Longrightarrow> P y \<Longrightarrow> \<not> P z \<Longrightarrow> successive P ys \<Longrightarrow> successive P (xs @ x # y # z # ys)"
by (induction _ xs rule: list_two_induct) (fastforce intro: successive_stepI)+

lemma successive_end_2:
  "successive P xs \<Longrightarrow> \<not> P x \<Longrightarrow> successive P (xs @ [x,y])"
by (induction _ xs rule: list_two_induct) auto

lemma successive_end_2':
  "successive P (xs @ [x]) \<Longrightarrow> \<not> P x \<Longrightarrow> successive P (xs @ [x,y])"
by (induction _ xs rule: list_two_induct) auto

lemma successive_step_rev:
  "successive P (xs @ [x]) \<Longrightarrow> \<not> P x \<Longrightarrow> successive P xs"
by (induction _ xs rule: list_two_induct) auto

lemma successive_glue:
  "successive P (zs @ [z]) \<Longrightarrow> successive P (x # xs) \<Longrightarrow> \<not> P z \<or> \<not> P x \<Longrightarrow> successive P (zs @ [z] @ x # xs)"
proof goal_cases
  case A: 1
  show ?thesis
  proof (cases "P x")
    case False
    with A(1,2) successive_ends_1 successive_step show ?thesis by fastforce
  next
    case True
    with A(1,3) successive_step_rev have "\<not> P z" "successive P zs" by fastforce+
    with A(2) successive_ends_1 show ?thesis by fastforce
  qed
qed

lemma successive_glue':
  "successive P (zs @ [y]) \<and> \<not> P z \<or> successive P zs \<and> \<not> P y
  \<Longrightarrow> successive P (x # xs) \<and> \<not> P w \<or> successive P xs \<and> \<not> P x
  \<Longrightarrow> \<not> P z \<or> \<not> P w \<Longrightarrow> successive P (zs @ y # z # w # x # xs)"
by (metis append_Cons append_Nil successive.simps(3) successive_ends_1 successive_glue successive_stepI)

lemma successive_dest_head:
  "xs = w # x # ys \<Longrightarrow> successive P xs \<Longrightarrow> successive P (x # xs) \<and> \<not> P w \<or> successive P xs \<and> \<not> P x"
by auto

lemma successive_dest_tail:
  "xs = zs @ [y,z] \<Longrightarrow> successive P xs \<Longrightarrow> successive P (zs @ [y]) \<and> \<not> P z \<or> successive P zs \<and> \<not> P y"
 apply (induction _ xs arbitrary: zs rule: list_two_induct)
   apply simp+
 apply (rename_tac zs)
 apply (case_tac zs)
  apply simp
 apply (rename_tac ws)
 apply (case_tac ws)
  apply force+
done

lemma successive_split:
  "xs = ys @ zs \<Longrightarrow> successive P xs \<Longrightarrow> successive P ys \<and> successive P zs"
 apply (induction _ xs arbitrary: ys rule: list_two_induct)
   apply simp
  apply (rename_tac ys, case_tac ys)
   apply simp
  apply simp
 apply (rename_tac ys, case_tac ys)
  apply simp
 apply (rename_tac list, case_tac list)
  apply (auto intro: successive_stepI)
done

lemma successive_decomp:
  "xs = x # ys @ zs @ [z] \<Longrightarrow> successive P xs \<Longrightarrow> \<not> P x \<or> \<not> P z \<Longrightarrow> successive P (zs @ [z] @ (x # ys))"
by (metis Cons_eq_appendI successive_glue successive_split)

lemma successive_predecessor:
  assumes "(a, b) \<in> set (arcs i j xs)" "a \<noteq> i" "successive P (arcs i j xs)" "P (a,b)" "xs \<noteq> []"
 shows "\<exists> c. (xs = [a] \<and> c = i \<or> (\<exists> ys. xs = a # b # ys \<and> c = i) \<or> (\<exists> ys. xs = ys @ [c,a] \<and> b = j)
       \<or> (\<exists> ys zs. xs = ys @ c # a # b # zs)) \<and> \<not> P (c,a)"
proof -
  from arcs_predecessor''[OF assms(1,2)] obtain c where c:
    "xs = [a] \<or> (\<exists>ys. xs = a # b # ys) \<or> (\<exists>ys. xs = ys @ [c, a] \<and> b = j)
    \<or> (\<exists>ys zs. xs = ys @ c # a # b # zs)"
  by auto
  then show ?thesis
  proof (safe, goal_cases)
    case 1
    with assms have "arcs i j xs = [(i, a), (a, j)]" by auto
    with assms have "\<not> P (i, a)" by auto
    with 1 show ?case by simp
  next
    case 2
    with assms have "\<not> P (i, a)" by fastforce
    with 2 show ?case by auto
  next
    case 3
    with assms have "\<not> P (c, a)" using arcs_decomp successive_dest_tail by fastforce
    with 3 show ?case by auto
  next
    case 4
    with assms(3,4) have "\<not> P (c, a)" using arcs_decomp successive_split by fastforce
    with 4 show ?case by auto
  qed
qed

thm arcs_successor'

lemmas add_mono_right = add_mono[OF order_refl]
lemmas add_mono_left  = add_mono[OF _ order_refl]

subsubsection \<open>Obtaining successive and distinct paths\<close>

lemma canonical_successive:
  fixes A B
  defines "M \<equiv> \<lambda> i j. min (A i j) (B i j)"
  assumes "canonical A n"
  assumes "set xs \<subseteq> {0..n}"
  assumes "i \<le> n" "j \<le> n"
  shows "\<exists> ys. len M i j ys \<le> len M i j xs \<and> set ys \<subseteq> {0..n}
               \<and> successive (\<lambda> (a, b). M a b = A a b) (arcs i j ys)"
using assms
proof (induction xs arbitrary: i rule: list_two_induct)
  case Nil show ?case by fastforce
next
  case 2: (Single x i)
  show ?case
  proof (cases "M i x = A i x \<and> M x j = A x j")
    case False
    then have "successive (\<lambda>(a, b). M a b = A a b) (arcs i j [x])" by auto
    with 2 show ?thesis by blast
  next
    case True
    with 2 have "M i j \<le> M i x + M x j" unfolding min_def by fastforce
    with 2(3-) show ?thesis apply simp apply (rule exI[where x = "[]"]) by auto
  qed
next
  case 3: (Cons x y xs i)
  show ?case
  proof (cases "M i y \<le> M i x + M x y", goal_cases)
    case 1
    from 3 obtain ys where
      "len M i j ys \<le> len M i j (y # xs) \<and> set ys \<subseteq> {0..n}
       \<and> successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j ys)"
    by fastforce
    moreover from 1 have "len M i j (y # xs) \<le> len M i j (x # y # xs)"
    using add_mono by (auto simp: assoc[symmetric])
    ultimately show ?case by force
  next
    case False
    { assume "M i x = A i x" "M x y = A x y"
      with 3(3-) have "A i y \<le> M i x + M x y" by auto
      then have "M i y \<le> M i x + M x y" unfolding M_def min_def by auto
    } note * = this
    with False have "M i x \<noteq> A i x \<or> M x y \<noteq> A x y" by auto
    then show ?thesis
    proof (standard, goal_cases)
      case 1
      from 3 obtain ys where ys:
        "len M x j ys \<le> len M x j (y # xs)" "set ys \<subseteq> {0..n}"
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs x j ys)"
      by force+
      from 1 successive_stepI[OF ys(3), of "(i, x)"] have
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j (x # ys))"
      by auto
      moreover have "len M i j (x # ys) \<le> len M i j (x # y # xs)" using add_mono_right[OF ys(1)]
      by auto
      ultimately show ?case using 3(5) ys(2) by fastforce
    next
      case 2
      from 3 obtain ys where ys:
        "len M y j ys \<le> len M y j xs" "set ys \<subseteq> {0..n}"
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs y j ys)"
      by force+
      from this(3) 2 have
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j (x # y # ys))"
      by simp
      moreover from add_mono_right[OF ys(1)] have
        "len M i j (x # y # ys) \<le> len M i j (x # y # xs)"
      by (auto simp: assoc[symmetric])
      ultimately show ?thesis using ys(2) 3(5) by fastforce
    qed
  qed
qed

lemma canonical_successive_distinct:
  fixes A B
  defines "M \<equiv> \<lambda> i j. min (A i j) (B i j)"
  assumes "canonical A n"
  assumes "set xs \<subseteq> {0..n}"
  assumes "i \<le> n" "j \<le> n"
  assumes "distinct xs" "i \<notin> set xs" "j \<notin> set xs"
  shows "\<exists> ys. len M i j ys \<le> len M i j xs \<and> set ys \<subseteq> set xs
               \<and> successive (\<lambda> (a, b). M a b = A a b) (arcs i j ys)
               \<and> distinct ys \<and> i \<notin> set ys \<and> j \<notin> set ys"
using assms
proof (induction xs arbitrary: i rule: list_two_induct)
  case Nil show ?case by fastforce
next
  case 2: (Single x i)
  show ?case
  proof (cases "M i x = A i x \<and> M x j = A x j")
    case False
    then have "successive (\<lambda>(a, b). M a b = A a b) (arcs i j [x])" by auto
    with 2 show ?thesis by blast
  next
    case True
    with 2 have "M i j \<le> M i x + M x j" unfolding min_def by fastforce
    with 2(3-) show ?thesis apply simp apply (rule exI[where x = "[]"]) by auto
  qed
next
  case 3: (Cons x y xs i)
  show ?case
  proof (cases "M i y \<le> M i x + M x y")
    case 1: True
    from 3(2)[OF 3(3,4)] 3(5-10) obtain ys where ys:
      "len M i j ys \<le> len M i j (y # xs)" "set ys \<subseteq> set (x # y # xs)"
       "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j ys)"
       "distinct ys \<and> i \<notin> set ys \<and> j \<notin> set ys"
    by fastforce
    moreover from 1 have "len M i j (y # xs) \<le> len M i j (x # y # xs)"
    using add_mono by (auto simp: assoc[symmetric])
    ultimately have "len M i j ys \<le> len M i j (x # y # xs)" by auto
    then show ?thesis using ys(2-) by blast
  next
    case False
    { assume "M i x = A i x" "M x y = A x y"
      with 3(3-) have "A i y \<le> M i x + M x y" by auto
      then have "M i y \<le> M i x + M x y" unfolding M_def min_def by auto
    } note * = this
    with False have "M i x \<noteq> A i x \<or> M x y \<noteq> A x y" by auto
    then show ?thesis
    proof (standard, goal_cases)
      case 1
      from 3(2)[OF 3(3,4)] 3(5-10) obtain ys where ys:
        "len M x j ys \<le> len M x j (y # xs)" "set ys \<subseteq> set (y # xs)"
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs x j ys)"
        "distinct ys" "i \<notin> set ys" "x \<notin> set ys" "j \<notin> set ys"
      by fastforce
      from 1 successive_stepI[OF ys(3), of "(i, x)"] have
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j (x # ys))"
      by auto
      moreover have "len M i j (x # ys) \<le> len M i j (x # y # xs)" using add_mono_right[OF ys(1)]
      by auto
      moreover have "distinct (x # ys)" "i \<notin> set (x # ys)" "j \<notin> set (x # ys)" using ys(4-) 3(8-)
      by auto
      moreover from ys(2) have "set (x # ys) \<subseteq> set (x # y # xs)" by auto
      ultimately show ?case by fastforce
    next
      case 2
      from 3(1)[OF 3(3,4)] 3(5-) obtain ys where ys:
        "len M y j ys \<le> len M y j xs" "set ys \<subseteq> set xs"
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs y j ys)"
        "distinct ys" "j \<notin> set ys" "y \<notin> set ys" "i \<notin> set ys" "x \<notin> set ys"
      by fastforce
      from this(3) 2 have
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j (x # y # ys))"
      by simp
      moreover from add_mono_right[OF ys(1)] have
        "len M i j (x # y # ys) \<le> len M i j (x # y # xs)"
      by (auto simp: assoc[symmetric])
      moreover have "distinct (x # y # ys)" "i \<notin> set (x # y # ys)" "j \<notin> set (x # y # ys)"
      using ys(4-) 3(8-) by auto
      ultimately show ?thesis using ys(2) by fastforce
    qed
  qed
qed

lemma successive_snd_last: "successive P (xs @ [x, y]) \<Longrightarrow> P y \<Longrightarrow> \<not> P x"
by (induction _ xs rule: list_two_induct) auto

lemma canonical_shorten_rotate_neg_cycle:
  fixes A B
  defines "M \<equiv> \<lambda> i j. min (A i j) (B i j)"
  assumes "canonical A n"
  assumes "set xs \<subseteq> {0..n}"
  assumes "i \<le> n"
  assumes "len M i i xs < \<one>"
  shows "\<exists> j ys. len M j j ys < \<one> \<and> set (j # ys) \<subseteq> set (i # xs)
               \<and> successive (\<lambda> (a, b). M a b = A a b) (arcs j j ys)
               \<and> distinct ys \<and> j \<notin> set ys \<and>
               (ys \<noteq> [] \<longrightarrow> M j (hd ys) \<noteq> A j (hd ys) \<or> M (last ys) j \<noteq> A (last ys) j)"
using assms
proof -
  note A = assms
  from negative_len_shortest[OF _ A(5)] obtain j ys where ys:
    "distinct (j # ys)" "len M j j ys < \<one>" "j \<in> set (i # xs)" "set ys \<subseteq> set xs"
  by blast
  from this(1,3) canonical_successive_distinct[OF A(2) subset_trans[OF this(4) A(3)], of j j B] A(3,4)
  obtain zs where zs:
    "len M j j zs \<le> len M j j ys"
    "set zs \<subseteq> set ys" "successive (\<lambda>(a, b). M a b = A a b) (arcs j j zs)"
    "distinct zs" "j \<notin> set zs"
  by (force simp: M_def)
  show ?thesis
  proof (cases "zs = []")
    assume "zs \<noteq> []"
    then obtain w ws where ws: "zs = w # ws" by (cases zs) auto
    show ?thesis
    proof (cases "ws = []")
      case False
      then obtain u us where us: "ws = us @ [u]" by (induction ws) auto
      show ?thesis
      proof (cases "M j w = A j w \<and> M u j = A u j")
        case True
        have "u \<le> n" "j \<le> n" "w \<le> n" using us ws zs(2) ys(3,4) A(3,4) by auto
        with A(2) True have "M u w \<le> M u j + M j w" unfolding M_def min_def by fastforce
        then have
          "len M u u (w # us) \<le> len M j j zs"
        using ws us by (simp add: len_comp comm) (auto intro: add_mono simp: assoc[symmetric])
        moreover have "set (u # w # us) \<subseteq> set (i # xs)" using ws us zs(2) ys(3,4) by auto
        moreover have "distinct (w # us)" "u \<notin> set (w # us)" using ws us zs(4) by auto
        moreover have "successive (\<lambda>(a, b). M a b = A a b) (arcs u u (w # us))"
        proof (cases us)
          case Nil
          with zs(3) ws us True show ?thesis by auto
        next
          case (Cons v vs)
          with zs(3) ws us True have "M w v \<noteq> A w v" by auto
          with ws us Cons zs(3) True arcs_decomp_tail successive_split show ?thesis by (simp, blast)
        qed
        moreover have "M (last (w # us)) u \<noteq> A (last (w # us)) u"
        proof (cases "us = []")
          case T: True
          with zs(3) ws us True show ?thesis by auto
        next
          case False
          then obtain v vs where vs: "us = vs @ [v]" by (induction us) auto
          with ws us have "arcs j j zs = arcs j v (w # vs) @ [(v, u), (u,j)]" by (simp add: arcs_decomp)
          with zs(3) True have "M v u \<noteq> A v u"
          using successive_snd_last[of "\<lambda>(a, b). M a b = A a b" "arcs j v (w # vs)"] by auto
          with vs show ?thesis by simp
        qed
        ultimately show ?thesis using zs(1) ys(2)
        by (intro exI[where x = u], intro exI[where x = "w # us"]) fastforce
      next
        case False
        with zs ws us ys show ?thesis by (intro exI[where x = j], intro exI[where x = "zs"]) auto
      qed
    next
      case True
      with True ws zs ys show ?thesis by (intro exI[where x = j], intro exI[where x = "zs"]) fastforce
    qed
  next
    case True
    with ys zs show ?thesis by (intro exI[where x = j], intro exI[where x = "zs"]) fastforce
  qed
qed

(* Generated by sledgehammer/z3 *)
lemma successive_arcs_extend_last:
  "successive P (arcs i j xs) \<Longrightarrow> \<not> P (i, hd xs) \<or> \<not> P (last xs, j) \<Longrightarrow> xs \<noteq> []
  \<Longrightarrow> successive P (arcs i j xs @ [(i, hd xs)])"
proof -
  assume a1: "\<not> P (i, hd xs) \<or> \<not> P (last xs, j)"
  assume a2: "successive P (arcs i j xs)"
  assume a3: "xs \<noteq> []"
  then have f4: "\<not> P (last xs, j) \<longrightarrow> successive P (arcs i (last xs) (butlast xs))"
    using a2 by (metis (no_types) append_butlast_last_id arcs_decomp_tail successive_step_rev)
  have f5: "arcs i j xs = arcs i (last xs) (butlast xs) @ [(last xs, j)]"
    using a3 by (metis (no_types) append_butlast_last_id arcs_decomp_tail)
  have "([] @ arcs i j xs @ [(i, hd xs)]) @ [(i, hd xs)] = arcs i j xs @ [(i, hd xs), (i, hd xs)]"
    by simp
  then have "P (last xs, j) \<longrightarrow> successive P (arcs i j xs @ [(i, hd xs)])"
    using a2 a1 by (metis (no_types) self_append_conv2 successive_end_2 successive_step_rev)
  then show ?thesis
    using f5 f4 successive_end_2 by fastforce
qed

lemma cycle_rotate_arcs:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "length xs > 1" "(i, j) \<in> arcs' xs"
  shows "\<exists> ys zs. set (arcs a a xs) = set (arcs i i (j # ys @ a # zs)) \<and> xs = zs @ i # j # ys" using assms
proof -
  assume A: "length xs > 1" "(i, j) \<in> arcs' xs"
  from arcs'_decomp[OF this] obtain ys zs where xs: "xs = zs @ i # j # ys" by blast
  with arcs_decomp[OF this, of a a] arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i]
  show ?thesis by force
qed

lemma cycle_rotate_len_arcs_successive:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "length xs > 1" "(i, j) \<in> arcs' xs" "successive P (arcs a a xs)" "\<not> P (a, hd xs) \<or> \<not> P (last xs, a)"
  shows "\<exists> ys zs. len M a a xs = len M i i (j # ys @ a # zs)
                \<and> set (arcs a a xs) = set (arcs i i (j # ys @ a # zs)) \<and> xs = zs @ i # j # ys
                \<and> successive P (arcs i i (j # ys @ a # zs))"
using assms
proof -
  note A = assms
  from arcs'_decomp[OF A(1,2)] obtain ys zs where xs: "xs = zs @ i # j # ys" by blast
  note arcs1 = arcs_decomp[OF xs, of a a]
  note arcs2 = arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i]
  have *:"successive P (arcs i i (j # ys @ a # zs))"
  proof (cases "ys = []")
    case True
    show ?thesis
    proof (cases zs)
      case Nil
      with A(3,4) xs True show ?thesis by auto
    next
      case (Cons z zs')
      with True arcs2 A(3,4) xs show ?thesis apply simp
      by (metis arcs.simps(1,2) arcs1 successive.simps(3) successive_split successive_step)
    qed
  next
    case False
    then obtain y ys' where ys: "ys = ys' @ [y]" by (metis append_butlast_last_id)
    show ?thesis
    proof (cases zs)
      case Nil
      with A(3,4) xs ys have
        "\<not> P (a, i) \<or> \<not> P (y, a)" "successive P (arcs a a (i # j # ys' @ [y]))"
      by simp+
      from successive_decomp[OF _ this(2,1)] show ?thesis using ys Nil arcs_decomp by fastforce
    next
      case (Cons z zs')
      with A(3,4) xs ys have
        "\<not> P (a, z) \<or> \<not> P (y, a)" "successive P (arcs a a (z # zs' @ i # j # ys' @ [y]))"
      by simp+
      from successive_decomp[OF _ this(2,1)] show ?thesis using ys Cons arcs_decomp by fastforce
    qed
  qed
  from len_decomp[OF xs, of M a a] have "len M a a xs = len M a i zs + len M i a (j # ys)" .
  also have "\<dots> = len M i a (j # ys) + len M a i zs" by (simp add: comm)
  also from len_comp[of M i i "j # ys" a zs] have "\<dots> = len M i i (j # ys @ a # zs)" by auto
  finally show ?thesis
  using * xs arcs_decomp[OF xs, of a a] arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i] by force
qed

lemma successive_successors:
  "xs = ys @ a # b # c # zs \<Longrightarrow> successive P (arcs i j xs) \<Longrightarrow> \<not> P (a,b) \<or> \<not> P (b, c)"
 apply (induction _ xs arbitrary: i ys rule: list_two_induct)
   apply fastforce
  apply fastforce
 apply (rename_tac ys, case_tac ys)
  apply fastforce
 apply (rename_tac list, case_tac list)
  apply fastforce+
done

lemma successive_successors':
  "xs = ys @ a # b # zs \<Longrightarrow> successive P xs \<Longrightarrow> \<not> P a \<or> \<not> P b"
using successive_split by fastforce

lemma cycle_rotate_len_arcs_successive':
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "length xs > 1" "(i, j) \<in> arcs' xs" "successive P (arcs a a xs)"
          "\<not> P (a, hd xs) \<or> \<not> P (last xs, a)"
  shows "\<exists> ys zs. len M a a xs = len M i i (j # ys @ a # zs)
                \<and> set (arcs a a xs) = set (arcs i i (j # ys @ a # zs)) \<and> xs = zs @ i # j # ys
                \<and> successive P (arcs i i (j # ys @ a # zs) @ [(i,j)])"
using assms
proof -
  note A = assms
  from arcs'_decomp[OF A(1,2)] obtain ys zs where xs: "xs = zs @ i # j # ys" by blast
  note arcs1 = arcs_decomp[OF xs, of a a]
  note arcs2 = arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i]
  have *:"successive P (arcs i i (j # ys @ a # zs) @ [(i,j)])"
  proof (cases "ys = []")
    case True
    show ?thesis
    proof (cases zs)
      case Nil
      with A(3,4) xs True show ?thesis by auto
    next
      case (Cons z zs')
      with True arcs2 A(3,4) xs show ?thesis
       apply simp
       apply (cases "P (a, z)")
        apply (simp add: arcs_decomp)
        apply (simp only: append_Cons[symmetric])
        using successive_split[of "((a, z) # arcs z i zs') @ [(i, j), (j, a)]" _ "[(j, a)]" P]
        apply auto[]
       subgoal (* Generated by sledgehammer *)
       proof simp
         assume a1: "successive P ((a, z) # arcs z a (zs' @ [i, j]))"
         assume a2: "\<not> P (a, z)"
         assume a3: "zs = z # zs'"
         assume a4: "ys = []"
         assume a5: "xs = z # zs' @ [i, j]"
         have f6: "\<forall>p pa ps. \<not> successive p ((pa::nat \<times> nat) # ps) \<or> p pa \<or> successive p ps"
           by (meson successive_step)
         have "(a, z) # arcs z i zs' @ (i, j) # arcs j a [] = arcs a a xs"
           using a4 a3 by (simp add: arcs1)
         then have "arcs z a (zs' @ [i, j]) = arcs z i zs' @ [(i, j), (j, a)]"
           using a5 by simp
         then show
           "\<not> P (j, a) \<and> successive P ((a, z) # arcs z i zs' @ [(i, j)])
          \<or> \<not> P (i, j) \<and> (successive P (arcs z i zs' @ [(i, j)])
          \<or> \<not> P (j, a) \<and> successive P ((a, z) # arcs z i zs' @ [(i, j)]))"
         using f6 a2 a1
         by (metis successive.simps(1) successive_dest_tail successive_ends_1 successive_stepI)
       qed
      done
    qed
  next
    case False
    then obtain y ys' where ys: "ys = ys' @ [y]" by (metis append_butlast_last_id)
    show ?thesis
    proof (cases zs)
      case Nil
      with A(3,4) xs ys have *:
        "\<not> P (a, i) \<or> \<not> P (y, a)" "successive P (arcs a a (i # j # ys' @ [y]))"
      by simp+
      from successive_decomp[OF _ this(2,1)] ys Nil arcs_decomp have
        "successive P (arcs i i (j # ys @ a # zs))"
      by fastforce
      moreover from * have "\<not> P (a, i) \<or> \<not> P (i, j)" by auto
      ultimately show ?thesis
      by (metis append_Cons last_snoc list.distinct(1) list.sel(1) Nil successive_arcs_extend_last)
    next
      case (Cons z zs')
      with A(3,4) xs ys have *:
        "\<not> P (a, z) \<or> \<not> P (y, a)" "successive P (arcs a a (z # zs' @ i # j # ys' @ [y]))"
        by simp_all
      from successive_decomp[OF _ this(2,1)] ys Cons arcs_decomp have **:
        "successive P (arcs i i (j # ys @ a # zs))"
        by fastforce
      from Cons have "zs \<noteq> []" by auto
      then obtain w ws where ws: "zs = ws @ [w]" by (induction zs) auto
      with A(3,4) xs ys have *:
        "successive P (arcs a a (ws @ [w] @ i # j # ys' @ [y]))"
        by simp
      from successive_successors[OF _ *] have "\<not> P (w, i) \<or> \<not> P (i, j)" by auto
      with * show ?thesis
        by (metis ** append_is_Nil_conv last.simps last_append list.distinct(2) list.sel(1)
                successive_arcs_extend_last ws)
    qed
  qed
  from len_decomp[OF xs, of M a a] have "len M a a xs = len M a i zs + len M i a (j # ys)" .
  also have "\<dots> = len M i a (j # ys) + len M a i zs" by (simp add: comm)
  also from len_comp[of M i i "j # ys" a zs] have "\<dots> = len M i i (j # ys @ a # zs)" by auto
  finally show ?thesis
  using * xs arcs_decomp[OF xs, of a a] arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i] by force
qed

lemma cycle_rotate_3:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "xs \<noteq> []" "(i, j) \<in> set (arcs a a xs)" "successive P (arcs a a xs)" "\<not> P (a, hd xs) \<or> \<not> P (last xs, a)"
  shows "\<exists> ys. len M a a xs = len M i i (j # ys) \<and> set (i # j # ys) = set (a # xs) \<and> 1 + length ys = length xs
             \<and> set (arcs a a xs) = set (arcs i i (j # ys))
             \<and> successive P (arcs i i (j # ys))"
proof -
  note A = assms
  { fix ys assume A:"a = i" "xs = j # ys"
    with assms(3) have ?thesis by auto
  } note * = this
  have **: ?thesis if A: "a = j" "xs = ys @ [i]" for ys using A
  proof (safe, goal_cases)
    case 1
    have "len M j j (ys @ [i]) = M i j + len M j i ys"
    using len_decomp[of "ys @ [i]" ys i "[]" M j j] by (auto simp: comm)
    moreover have "arcs j j (ys @ [i]) = arcs j i ys @ [(i, j)]" using arcs_decomp_tail by auto
    moreover with assms(3,4) A have "successive P ((i,j) # arcs j i ys)"
     apply simp
     apply (case_tac ys)
      apply simp
     apply simp
    by (metis arcs.simps(2) calculation(2) 1(1) successive_split successive_step)
    ultimately show ?case by auto
  qed
  { assume "length xs = 1"
    then obtain b where xs: "xs = [b]" by (metis One_nat_def length_0_conv length_Suc_conv)
    with A(2) have "a = i \<and> b = j \<or> a = j \<and> b = i" by auto
    then have ?thesis using * ** xs by auto
  } note *** = this
  show ?thesis
  proof (cases "length xs = 0")
    case True with A show ?thesis by auto
  next
    case False
    thus ?thesis
    proof (cases "length xs = 1", goal_cases)
      case True with *** show ?thesis by auto
    next
      case 2
      hence "length xs > 1" by linarith
      then obtain b c ys where ys:"xs = b # ys @ [c]"
      by (metis One_nat_def assms(1) 2(2) length_0_conv length_Cons list.exhaust rev_exhaust)
      thus ?thesis
      proof (cases "(i,j) = (a,b)")
        case True
        with ys * show ?thesis by blast
      next
        case False
        then show ?thesis
        proof (cases "(i,j) = (c,a)", goal_cases)
          case True
          with ys ** show ?thesis by force
        next
          case 2
          with A(2) ys have "(i, j) \<in> arcs' xs"
          using cycle_rotate_2_aux by (auto simp add: arcs'_def) (* slow *)
          from cycle_rotate_len_arcs_successive[OF \<open>length xs > 1\<close> this A(3,4), of M] show ?thesis
          by auto
        qed
      qed
    qed
  qed
qed

end


section \<open>Polynomial coefficients with integer index\<close>

text \<open>We provide a function to access the coefficients of a polynomial
  via an integer index. Then index-shifting becomes more convenient,
  e.g., compare in the lemmas for accessing the coeffiencent of a product
  with a monomial there is no special case for integer coefficients, whereas
  for natural number coefficients there is a case-distinction.\<close>

theory Coeff_Int
  imports
    "HOL-Combinatorics.Permutations"
    Polynomial_Interpolation.Missing_Polynomial
begin

definition coeff_int :: "'a :: zero poly \<Rightarrow> int \<Rightarrow> 'a" where
  "coeff_int p i = (if i < 0 then 0 else coeff p (nat i))"

lemma coeff_int_eq_0: "i < 0 \<or> i > int (degree p) \<Longrightarrow> coeff_int p i = 0"
  unfolding coeff_int_def
  by (cases "i < 0", auto intro: coeff_eq_0)

lemma coeff_int_smult[simp]: "coeff_int (smult c p) i = c * coeff_int p i"
  unfolding coeff_int_def by simp

lemma coeff_int_signof_mult: "coeff_int (of_int (sign x) * f) i = of_int (sign x) * coeff_int f i"
  by (auto simp: coeff_int_def sign_def)

lemma coeff_int_sum: "coeff_int (sum p A) i = (\<Sum>x\<in>A. coeff_int (p x) i)"
  using coeff_sum[of p A "nat i"] unfolding coeff_int_def
  by (cases "i < 0", auto)

lemma coeff_int_0[simp]: "coeff_int f 0 = coeff f 0" unfolding coeff_int_def by simp

lemma coeff_int_monom_mult: "coeff_int (monom a d * f) i = (a * coeff_int f (i - d))"
proof (cases "i < 0")
  case True
  thus ?thesis unfolding coeff_int_def by simp
next
  case False
  hence "i \<ge> 0" by auto
  then obtain j where i: "i = int j" by (rule nonneg_eq_int)
  show ?thesis
  proof (cases "i \<ge> d")
    case True
    with i have "nat (int j - int d) = j - d" by auto
    with coeff_monom_mult[of a] show ?thesis unfolding coeff_int_def i
      by simp
  next
    case False
    thus ?thesis unfolding i by (simp add: coeff_int_def coeff_monom_mult)
  qed
qed

lemma coeff_prod_const: assumes "finite xs" and "y \<notin> xs"
  and "\<And> x. x \<in> xs \<Longrightarrow> degree (f x) = 0"
shows "coeff (prod f (insert y xs)) i = prod (\<lambda> x. coeff (f x) 0) xs * coeff (f y) i"
  using assms
proof (induct xs rule: finite_induct)
  case (insert x xs)
  from insert(2,4) have id: "insert y (insert x xs) - {x} = insert y xs" by auto
  have "prod f (insert y (insert x xs)) = f x * prod f (insert y xs)"
    by (subst prod.remove[of _ x], insert insert(1,2) id, auto)
  hence "coeff (prod f (insert y (insert x xs))) i = coeff (f x * prod f (insert y xs)) i" by simp
  also have "\<dots> = coeff (f x) 0 * (coeff (prod f (insert y xs)) i)"
  proof -
    from insert(5)[of x] degree0_coeffs[of "f x"] obtain c where fx: "f x = [: c :]" by auto
    show ?thesis unfolding fx by auto
  qed
  also have "(coeff (prod f (insert y xs)) i) = (\<Prod>x\<in>xs. coeff (f x) 0) * coeff (f y) i" using insert by auto
  also have "coeff (f x) 0 * \<dots> = prod (\<lambda> x. coeff (f x) 0) (insert x xs) * coeff (f y) i"
    by (subst prod.insert_remove, insert insert(1,2,4), auto simp: ac_simps)
  finally show ?case .
qed simp

lemma coeff_int_prod_const: assumes "finite xs" and "y \<notin> xs"
  and "\<And> x. x \<in> xs \<Longrightarrow> degree (f x) = 0"
shows "coeff_int (prod f (insert y xs)) i = prod (\<lambda> x. coeff_int (f x) 0) xs * coeff_int (f y) i"
  using coeff_prod_const[OF assms] unfolding coeff_int_def by (cases "i < 0", auto)

lemma coeff_int[simp]: "coeff_int p n = coeff p n"  unfolding coeff_int_def by auto

lemma coeff_int_minus[simp]:
  "coeff_int (a - b) i = coeff_int a i - coeff_int b i"
  by (auto simp: coeff_int_def)

lemma coeff_int_pCons_0[simp]: "coeff_int (pCons 0 b) i = coeff_int b (i - 1)"
  by (auto simp: Nitpick.case_nat_unfold coeff_int_def coeff_pCons nat_diff_distrib')

end


section \<open>Commonly used Lemmas\<close>
theory Common
imports
  Main
  "HOL-Library.Extended_Nat"
  "HOL-Eisbach.Eisbach"
begin

declare [[coercion_enabled = false]]

subsection \<open>Miscellaneous\<close>

lemma split_sym_rel:
  fixes G :: "'a rel"
  assumes "sym G" "irrefl G"
  obtains E where "E\<inter>E\<inverse> = {}" "G = E \<union> E\<inverse>"
proof -
  obtain R :: "'a rel"
  where WO: "well_order_on UNIV R" using Zorn.well_order_on ..

  let ?E = "G \<inter> R"

  from \<open>irrefl G\<close> have [simp, intro!]: "(x,x)\<notin>G" for x
    by (auto simp: irrefl_def)

  have "?E \<inter> ?E\<inverse> = {}"
    using WO
    unfolding well_order_on_def linear_order_on_def
      partial_order_on_def antisym_def
    by fastforce
  moreover
  have "G = ?E \<union> ?E\<inverse>"
    apply safe
    apply (simp_all add: symD[OF \<open>sym G\<close>])
    using WO unfolding well_order_on_def linear_order_on_def total_on_def
    by force
  ultimately show ?thesis by (rule that)
qed

lemma least_antimono: "X\<noteq>{} \<Longrightarrow> X\<subseteq>Y \<Longrightarrow> (LEAST y::_::wellorder. y\<in>Y) \<le> (LEAST x. x\<in>X)"
  by (metis LeastI_ex Least_le equals0I rev_subsetD)

lemma distinct_map_snd_inj: "distinct (map snd l) \<Longrightarrow> (a,b)\<in>set l \<Longrightarrow> (a',b)\<in>set l \<Longrightarrow> a=a'"
  by (metis distinct_map inj_onD prod.sel(2) prod.simps(1))

lemma map_add_apply: "(m\<^sub>1 ++ m\<^sub>2) k = (case m\<^sub>2 k of None \<Rightarrow> m\<^sub>1 k | Some x \<Rightarrow> Some x)"
  by (auto simp: map_add_def)

lemma map_eq_append_conv: "map f xs = ys\<^sub>1@ys\<^sub>2
  \<longleftrightarrow> (\<exists>xs\<^sub>1 xs\<^sub>2. xs = xs\<^sub>1@xs\<^sub>2 \<and> map f xs\<^sub>1 = ys\<^sub>1 \<and> map f xs\<^sub>2 = ys\<^sub>2)"
  apply rule
  subgoal
    apply (rule exI[where x="take (length ys\<^sub>1) xs"])
    apply (rule exI[where x="drop (length ys\<^sub>1) xs"])
    apply (drule sym)
    by (auto simp: append_eq_conv_conj take_map drop_map)
  subgoal by auto
  done

lemma prod_case_const[simp]: "case_prod (\<lambda>_ _. c) = (\<lambda>_. c)" by auto

lemma card2_eq: "card e = 2 \<longleftrightarrow> (\<exists>u v. u\<noteq>v \<and> e={u,v})"
  by (auto simp: eval_nat_numeral card_Suc_eq)

lemma in_ranE:
  assumes "v \<in> ran m"
  obtains k where "m k = Some v"
  using assms unfolding ran_def by auto

lemma Inf_in:
  fixes A :: "'a::{linorder,complete_lattice} set"
  assumes "finite A" "A\<noteq>{}"
  shows "Inf A \<in> A"
  using assms
  proof (induction A rule: finite_induct)
    case empty
    then show ?case by simp
  next
    have [simp]: "inf a b = (if a\<le>b then a else b)" for a b :: 'a
      by (meson inf_absorb2 le_iff_inf linear)

    case (insert x F)
    show ?case proof cases
      assume "F={}" thus ?thesis by auto
    next
      assume "F\<noteq>{}"
      with insert.IH have "Inf F \<in> F" .
      then show ?thesis
        using le_less_linear[of x "Inf F"]
        by auto

  qed
qed

lemma INF_of_enat_infty_iff1: "(INF x \<in> A. enat (f x)) = \<infinity> \<longleftrightarrow> A={}"
  apply (cases "A={}")
  subgoal by (simp add: top_enat_def)
  subgoal by safe (metis INF_top_conv(2) enat.distinct(1) top_enat_def)+
  done

lemma INF_of_enat_infty_iff2:
  "\<infinity> = (INF x \<in> A. enat (f x)) \<longleftrightarrow> A={}"
  by (metis INF_of_enat_infty_iff1)

lemmas INF_of_enat_infty_iff[simp] = INF_of_enat_infty_iff1 INF_of_enat_infty_iff2

lemma INF_of_enat_nat_conv1:
  assumes "finite A"
  shows "(INF x \<in> A. enat (f x)) = enat d \<longleftrightarrow> (\<exists>x\<in>A. d = f x \<and> (\<forall>y\<in>A. f x \<le> f y))"
proof -
  from assms have F: "finite (enat`f`A)" by auto

  show ?thesis proof (cases "A={}")
    case True thus ?thesis by (auto simp: top_enat_def)
  next
    case [simp]: False
    note * = Inf_in[OF F, simplified]
    show ?thesis
      apply (rule iffI)
      subgoal by (smt False Inf_in assms enat.inject enat_ord_simps(1) finite_imageI imageE image_is_empty le_INF_iff order_refl)
      subgoal by clarsimp (meson INF_greatest INF_lower antisym enat_ord_simps(1))
      done
  qed
qed

lemma INF_of_enat_nat_conv2:
  assumes "finite A"
  shows "enat d = (INF x \<in> A. enat (f x)) \<longleftrightarrow> (\<exists>x\<in>A. d = f x \<and> (\<forall>y\<in>A. f x \<le> f y))"
  using INF_of_enat_nat_conv1[OF assms] by metis

lemmas INF_of_enat_nat_conv = INF_of_enat_nat_conv1 INF_of_enat_nat_conv2

lemma finite_inf_linorder_ne_ex:
  fixes f :: "_ \<Rightarrow> _::{complete_lattice,linorder}"
  assumes "finite S"
  assumes "S\<noteq>{}"
  shows "\<exists>x\<in>S. (INF x \<in> S. f x) = f x"
  using assms
  by (meson Inf_in finite_imageI imageE image_is_empty)

lemma finite_linorder_eq_INF_conv: "finite S
  \<Longrightarrow> a = (INF x \<in> S. f x) \<longleftrightarrow> (if S={} then a=top else \<exists>x\<in>S. a=f x \<and> (\<forall>y\<in>S. a \<le> f y))"
  for a :: "_::{complete_lattice,linorder}"
  by (auto
    simp: INF_greatest INF_lower
    intro: finite_inf_linorder_ne_ex antisym)

lemma sym_inv_eq[simp]: "sym E \<Longrightarrow> E\<inverse> = E" unfolding sym_def by auto

lemma insert_inv[simp]: "(insert e E)\<inverse> = insert (prod.swap e) (E\<inverse>)"
  by (cases e) auto

lemma inter_compl_eq_diff[simp]: "x \<inter> - s = x - s"
  by auto

subsection \<open>The-Default\<close>
fun the_default :: "'a \<Rightarrow> 'a option \<Rightarrow> 'a" where
  "the_default d None = d"
| "the_default _ (Some x) = x"

lemma the_default_alt: "the_default d x = (case x of None \<Rightarrow> d | Some v \<Rightarrow> v)" by (auto split: option.split)

subsection \<open>Implementing \<open>enat\<close> by Option\<close>

text \<open>Our maps are functions to \<open>nat option\<close>,which are interpreted as \<open>enat\<close>,
  \<open>None\<close> being \<open>\<infinity>\<close>\<close>

fun enat_of_option :: "nat option \<Rightarrow> enat" where
  "enat_of_option None = \<infinity>"
| "enat_of_option (Some n) = enat n"

lemma enat_of_option_inj[simp]: "enat_of_option x = enat_of_option y \<longleftrightarrow> x=y"
  by (cases x; cases y; simp)

lemma enat_of_option_simps[simp]:
  "enat_of_option x = enat n \<longleftrightarrow> x = Some n"
  "enat_of_option x = \<infinity> \<longleftrightarrow> x = None"
  "enat n = enat_of_option x \<longleftrightarrow> x = Some n"
  "\<infinity> = enat_of_option x \<longleftrightarrow> x = None"
  by (cases x; auto; fail)+

lemma enat_of_option_le_conv: "enat_of_option m \<le> enat_of_option n \<longleftrightarrow> (case (m,n) of
    (_,None) \<Rightarrow> True
  | (Some a, Some b) \<Rightarrow> a\<le>b
  | (_, _) \<Rightarrow> False
)"
  by (auto split: option.split)

subsection \<open>Foldr-Refine\<close>
lemma foldr_refine:
  assumes "I s"
  assumes "\<And>s x. I s \<Longrightarrow> x\<in>set l \<Longrightarrow> I (f x s) \<and> \<alpha> (f x s) = f' x (\<alpha> s)"
  shows "I (foldr f l s) \<and> \<alpha> (foldr f l s) = foldr f' l (\<alpha> s)"
  using assms
  by (induction l arbitrary: s) auto

end