section \<open>Computing the Gcd via the subresultant PRS\<close>

text \<open>This theory now formalizes how the subresultant PRS can be used to calculate the gcd
  of two polynomials. Moreover, it proves the connection between resultants and gcd, namely that
  the resultant is 0 iff the degree of the gcd is non-zero.\<close>

theory Subresultant_Gcd
imports
  Subresultant
  Polynomial_Factorization.Missing_Polynomial_Factorial
begin

subsection \<open>Algorithm\<close>

definition gcd_impl_primitive where
  [code del]: "gcd_impl_primitive G1 G2 = normalize (primitive_part (fst (subresultant_prs dichotomous_Lazard G1 G2)))"

definition gcd_impl_main where
  [code del]: "gcd_impl_main G1 G2 = (if G1 = 0 then 0 else if G2 = 0 then normalize G1 else
   smult (gcd (content G1) (content G2))
     (gcd_impl_primitive (primitive_part G1) (primitive_part G2)))"

definition gcd_impl where
  "gcd_impl f g = (if length (coeffs f) \<ge> length (coeffs g) then gcd_impl_main f g  else gcd_impl_main g f)"

subsection \<open>Soundness Proof for @{term "gcd_impl = gcd"}\<close>

locale subresultant_prs_gcd = subresultant_prs_locale2 F n \<delta> f k \<beta> G1 G2 for
       F :: "nat \<Rightarrow> 'a ::  {factorial_ring_gcd,semiring_gcd_mult_normalize} fract poly"
    and n :: "nat \<Rightarrow> nat"
    and \<delta> :: "nat \<Rightarrow> nat"
    and f :: "nat \<Rightarrow> 'a fract"
    and k :: nat
    and \<beta> :: "nat \<Rightarrow> 'a fract"
    and G1 G2 :: "'a poly"
begin
text \<open>The subresultant PRS computes the gcd up to a scalar multiple.\<close>

lemma subresultant_prs_gcd: assumes "subresultant_prs dichotomous_Lazard G1 G2 = (Gk, hk)"
  shows "\<exists> a b. a \<noteq> 0 \<and> b \<noteq> 0 \<and> smult a (gcd G1 G2) = smult b (normalize Gk)"
proof -
  from subresultant_prs[OF dichotomous_Lazard assms]
  have Fk: "F k = ffp Gk" and "\<forall> i. \<exists> H. i \<noteq> 0 \<longrightarrow> F i = ffp H"
    and "\<forall> i. \<exists> b. 3 \<le> i \<longrightarrow> i \<le> Suc k \<longrightarrow> \<beta> i = ff b" by auto
  from choice[OF this(2)] choice[OF this(3)] obtain H beta where
    FH: "\<And> i. i \<noteq> 0 \<Longrightarrow> F i = ffp (H i)" and
    beta: "\<And> i. 3 \<le> i \<Longrightarrow> i \<le> Suc k \<Longrightarrow> \<beta> i = ff (beta i)" by auto
  from Fk FH[OF k0] FH[of 1] FH[of 2] FH[of "Suc k"] F0[of "Suc k"] F1 F2
  have border: "H k = Gk" "H 1 = G1" "H 2 = G2" "H (Suc k) = 0" by auto
  have "i \<noteq> 0 \<Longrightarrow> i \<le> k \<Longrightarrow> \<exists> a b. a \<noteq> 0 \<and> b \<noteq> 0 \<and> smult a (gcd G1 G2) = smult b (gcd (H i) (H (Suc i)))" for i
  proof (induct i rule: less_induct)
    case (less i)
    from less(3) have ik: "i \<le> k" .
    from less(2) have "i = 1 \<or> i \<ge> 2" by auto
    thus ?case
    proof
      assume "i = 1"
      thus ?thesis unfolding border[symmetric] by (intro exI[of _ 1], auto simp: numeral_2_eq_2)
    next
      assume i2: "i \<ge> 2"
      with ik have "i - 1 < i" "i - 1 \<noteq> 0" and imk: "i - 1 \<le> k" by auto
      from less(1)[OF this] i2
      obtain a b where a: "a \<noteq> 0" and b: "b \<noteq> 0" and IH: "smult a (gcd G1 G2) = smult b (gcd (H (i - 1)) (H i))" by auto
      define M where "M = pseudo_mod (H (i - 1)) (H i)"
      define c where "c = \<beta> (Suc i)"
      have M: "pseudo_mod (F (i - 1)) (F i) = ffp M" unfolding to_fract_hom.pseudo_mod_hom[symmetric] M_def
         using i2 FH by auto
      have c: "c \<noteq> 0" using \<beta>0 unfolding c_def .
      from i2 ik have 3: "Suc i \<ge> 3" "Suc i \<le> Suc k" by auto
      from pmod[OF 3]
      have pm: "smult c (F (Suc i)) = pseudo_mod (F (i - 1)) (F i)" unfolding c_def by simp
      from beta[OF 3, folded c_def] obtain d where cd: "c = ff d" by auto
      with c have d: "d \<noteq> 0" by auto
      from pm[unfolded cd M] FH[of "Suc i"]
      have "ffp (smult d (H (Suc i))) = ffp M" by auto
      hence pm: "smult d (H (Suc i)) = M" by (rule map_poly_hom.injectivity)
      from ik F0[of i] i2 FH[of i] have Hi0: "H i \<noteq> 0" by auto
      from pseudo_mod[OF this, of "H (i - 1)", folded M_def]
      obtain c Q where c: "c \<noteq> 0" and "smult c (H (i - 1)) = H i * Q + M" by auto
      from this[folded pm] have "smult c (H (i - 1)) = Q * H i + smult d (H (Suc i))" by simp
      from gcd_add_mult[of "H i" Q "smult d (H (Suc i))", folded this]
      have "gcd (H i) (smult c (H (i - 1))) = gcd (H i) (smult d (H (Suc i)))" .
      with gcd_smult_ex[OF c, of "H (i - 1)" "H i"] obtain e where
        e: "e \<noteq> 0" and "gcd (H i) (smult d (H (Suc i))) = smult e (gcd (H i) (H (i - 1)))"
        unfolding gcd.commute[of "H i"] by auto
      with gcd_smult_ex[OF d, of "H (Suc i)" "H i"] obtain c where
        c: "c \<noteq> 0" and "smult c (gcd (H i) (H (Suc i))) = smult e (gcd (H (i - 1)) (H i))"
        unfolding gcd.commute[of "H i"] by auto
      from arg_cong[OF this(2), of "smult b"] arg_cong[OF IH, of "smult e"]
      have "smult (e * a) (gcd G1 G2) = smult (b * c) (gcd (H i) (H (Suc i)))" unfolding smult_smult
        by (simp add: ac_simps)
      moreover have "e * a \<noteq> 0" "b * c \<noteq> 0" using a b c e by auto
      ultimately show ?thesis by blast
    qed
  qed
  from this[OF k0 le_refl, unfolded border]
  obtain a b where "a \<noteq> 0" "b \<noteq> 0" and "smult a (gcd G1 G2) = smult b (normalize Gk)" by auto
  thus ?thesis by auto
qed

lemma gcd_impl_primitive: assumes "primitive_part G1 = G1" and "primitive_part G2 = G2"
shows "gcd_impl_primitive G1 G2 = gcd G1 G2"
proof -
  let ?pp = primitive_part
  let ?c = "content"
  let ?n = normalize
  from F2 F0[of 2] k2 have G2: "G2 \<noteq> 0" by auto
  obtain Gk hk where sub: "subresultant_prs dichotomous_Lazard G1 G2 = (Gk, hk)" by force
  have impl: "gcd_impl_primitive G1 G2 = ?n (?pp Gk)" unfolding gcd_impl_primitive_def sub by auto
  from subresultant_prs_gcd[OF sub]
  obtain a b where a: "a \<noteq> 0" and b: "b \<noteq> 0" and id: "smult a (gcd G1 G2) = smult b (?n Gk)"
    by auto
  define c where "c = unit_factor (gcd G1 G2)"
  define d where "d = smult (unit_factor a) c"
  from G2 have c: "is_unit c" unfolding c_def by auto
  from arg_cong[OF id, of ?pp, unfolded primitive_part_smult primitive_part_gcd assms
     primitive_part_normalize c_def[symmetric]]
  have id: "d * gcd G1 G2 = smult (unit_factor b) (?n (?pp Gk))" unfolding d_def by simp
  have d: "is_unit d" unfolding d_def using c a
    by (simp add: is_unit_smult_iff)
  from is_unitE[OF d]
  obtain e where e: "is_unit e" and de: "d * e = 1" by metis
  define a where "a = smult (unit_factor b) e"
  from arg_cong[OF id, of "\<lambda> x. e * x"]
  have "(d * e) * gcd G1 G2 = a * (?n (?pp Gk))" by (simp add: ac_simps a_def)
  hence id: "gcd G1 G2 = a * (?n (?pp Gk))" using de by simp
  have a: "is_unit a" unfolding a_def using b e
    by (simp add: is_unit_smult_iff)
  define b where "b = unit_factor (?pp Gk)"
  have "Gk \<noteq> 0" using subresultant_prs[OF dichotomous_Lazard sub] F0[OF k0] by auto
  hence b: "is_unit b" unfolding b_def by auto
  from is_unitE[OF b]
  obtain c where c: "is_unit c" and bc: "b * c = 1" by metis
  obtain d where d: "is_unit d" and dac: "d = a * c" using c a by auto
  have "gcd G1 G2 = d * (b * ?n (?pp Gk))"
    unfolding id dac using bc by (simp add: ac_simps)
  also have "b * ?n (?pp Gk) = ?pp Gk" unfolding b_def by simp
  finally have "gcd G1 G2 = d * ?pp Gk" by simp
  from arg_cong[OF this, of ?n]
  have "gcd G1 G2 = ?n (d * ?pp Gk)" by simp
  also have "\<dots> = ?n (?pp Gk)" using d
    unfolding normalize_mult by (simp add: is_unit_normalize)
  finally show ?thesis unfolding impl ..
qed
end

lemma gcd_impl_main: assumes len: "length (coeffs G1) \<ge> length (coeffs G2)"
  shows "gcd_impl_main G1 G2 = gcd G1 G2"
proof (cases "G1 = 0")
  case G1: False
  show ?thesis
  proof (cases "G2 = 0")
    case G2: False
    let ?pp = "primitive_part"
    from G2 have G2: "?pp G2 \<noteq> 0" and id: "(G2 = 0) = False" by auto
    from len have len: "length (coeffs (?pp G1)) \<ge> length (coeffs (?pp G2))" by simp
    from enter_subresultant_prs[OF len G2] obtain F n d f k b
      where "subresultant_prs_locale2 F n d f k b (?pp G1) (?pp G2)" by auto
    interpret subresultant_prs_locale2 F n d f k b "?pp G1" "?pp G2" by fact
    interpret subresultant_prs_gcd F n d f k b "?pp G1" "?pp G2" ..
    show ?thesis unfolding gcd_impl_main_def gcd_poly_decompose[of G1] id if_False using G1
      by (subst gcd_impl_primitive, auto)
  next
    case True
    thus ?thesis unfolding gcd_impl_main_def by simp
  qed
next
  case True
  with len have "G2 = 0" by auto
  thus ?thesis using True unfolding gcd_impl_main_def by simp
qed

text \<open>The implementation also reveals an important connection between resultant and gcd.\<close>

lemma resultant_0_gcd: "resultant f g = 0 \<longleftrightarrow> degree (gcd f g) \<noteq> 0"
proof -
  {
    fix f g :: "'a poly"
    assume len: "length (coeffs f) \<ge> length (coeffs g)"
    {
      assume g: "g \<noteq> 0"
      with len have f: "f \<noteq> 0" by auto
      let ?f = "primitive_part f"
      let ?g = "primitive_part g"
      let ?c = "content"
      from len have len: "length (coeffs ?f) \<ge> length (coeffs ?g)" by simp
      obtain Gk hk where sub: "subresultant_prs dichotomous_Lazard ?f ?g = (Gk,hk)" by force
      have cf: "?c f \<noteq> 0" and cg: "?c g \<noteq> 0" using f g by auto
      {
        from g have "?g \<noteq> 0" by auto
        from enter_subresultant_prs[OF len this] obtain F n d f k b
          where "subresultant_prs_locale2 F n d f k b ?f ?g" by auto
        interpret subresultant_prs_locale2 F n d f k b ?f ?g by fact
        from subresultant_prs[OF dichotomous_Lazard sub] have "h k = ff hk" by auto
        with h0[OF le_refl] have "hk \<noteq> 0" by auto
      } note hk0 = this
      have "resultant f g = 0 \<longleftrightarrow> resultant (smult (?c f) ?f) (smult (?c g) ?g) = 0" by simp
      also have "\<dots> \<longleftrightarrow> resultant ?f ?g = 0" unfolding resultant_smult_left[OF cf] resultant_smult_right[OF cg]
        using cf cg by auto
      also have "\<dots> \<longleftrightarrow> resultant_impl_main dichotomous_Lazard ?f ?g = 0"
        unfolding resultant_impl[symmetric] resultant_impl_def resultant_impl_main_def
        resultant_impl_generic_def using len by auto
      also have "\<dots> \<longleftrightarrow> (degree Gk \<noteq> 0)"
        unfolding resultant_impl_main_def sub split using g hk0 by auto
      also have "degree Gk = degree (gcd_impl_primitive ?f ?g)"
        unfolding gcd_impl_primitive_def sub by simp
      also have "\<dots> = degree (gcd_impl_main f g)"
        unfolding gcd_impl_main_def using f g by auto
      also have "\<dots> = degree (gcd f g)" unfolding gcd_impl[symmetric] gcd_impl_def using len by auto
      finally have "(resultant f g = 0) = (degree (gcd f g) \<noteq> 0)" .
    }
    moreover
    {
      assume g: "g = 0" and f: "degree f \<noteq> 0"
      have "(resultant f g = 0) = (degree (gcd f g) \<noteq> 0)"
        unfolding g using f by auto
    }
    moreover
    {
      assume g: "g = 0" and f: "degree f = 0"
      have "(resultant f g = 0) = (degree (gcd f g) \<noteq> 0)"
        unfolding g using f by (auto simp: resultant_def sylvester_mat_def sylvester_mat_sub_def)
    }
    ultimately have "(resultant f g = 0) = (degree (gcd f g) \<noteq> 0)" by blast
  } note main = this
  show ?thesis
  proof (cases "length (coeffs f) \<ge> length (coeffs g)")
    case True
    from main[OF True] show ?thesis .
  next
    case False
    hence "length (coeffs g) \<ge> length (coeffs f)" by auto
    from main[OF this] show ?thesis
      unfolding gcd.commute[of g f] resultant_swap[of g f] by (simp split: if_splits)
  qed
qed

subsection \<open>Code Equations\<close>

definition [code del]:
  "gcd_impl_rec = subresultant_prs_main_impl fst"
definition [code del]:
  "gcd_impl_start = subresultant_prs_impl fst"

lemma gcd_impl_rec_code[code]:
  "gcd_impl_rec Gi_1 Gi ni_1 d1_1 hi_2 = (
    let pmod = pseudo_mod Gi_1 Gi
     in
     if pmod = 0 then Gi
        else let
           ni = degree Gi;
           d1 = ni_1 - ni;
           gi_1 = lead_coeff Gi_1;
           hi_1 = (if d1_1 = 1 then gi_1 else dichotomous_Lazard gi_1 hi_2 d1_1);
           divisor = if d1 = 1 then gi_1 * hi_1 else if even d1 then - gi_1 * hi_1 ^ d1 else gi_1 * hi_1 ^ d1;
           Gi_p1 = sdiv_poly pmod divisor
       in gcd_impl_rec Gi Gi_p1 ni d1 hi_1)"
  unfolding gcd_impl_rec_def subresultant_prs_main_impl.simps[of _ Gi_1] split Let_def
  unfolding gcd_impl_rec_def[symmetric]
  by (rule if_cong, auto)

lemma gcd_impl_start_code[code]:
  "gcd_impl_start G1 G2 =
     (let pmod = pseudo_mod G1 G2
         in if pmod = 0 then G2
            else let
                 n2 = degree G2;
                 n1 = degree G1;
                 d1 = n1 - n2;
                 G3 = if even d1 then - pmod else pmod;
                 pmod = pseudo_mod G2 G3
                 in if pmod = 0
                    then G3
                    else let
                           g2 = lead_coeff G2;
                           n3 = degree G3;
                           h2 = (if d1 = 1 then g2 else g2 ^ d1);
                           d2 = n2 - n3;
                           divisor = (if d2 = 1 then g2 * h2 else if even d2 then - g2 * h2 ^ d2 else g2 * h2 ^ d2);
                           G4 = sdiv_poly pmod divisor
                         in gcd_impl_rec G3 G4 n3 d2 h2)"
proof -
  obtain d1 where d1: "degree G1 - degree G2 = d1" by auto
  have id1: "(if even d1 then - pmod else pmod) = (-1)^ (d1 + 1) * (pmod :: 'a poly)" for pmod by simp
  show ?thesis
    unfolding gcd_impl_start_def subresultant_prs_impl_def gcd_impl_rec_def[symmetric] Let_def split
    unfolding d1
    unfolding id1
    by (rule if_cong, auto)
qed

lemma gcd_impl_main_code[code]:
  "gcd_impl_main G1 G2 = (if G1 = 0 then 0 else if G2 = 0 then normalize G1 else
    let c1 = content G1;
      c2 = content G2;
      p1 = map_poly (\<lambda> x. x div c1) G1;
      p2 = map_poly (\<lambda> x. x div c2) G2
     in smult (gcd c1 c2) (normalize (primitive_part (gcd_impl_start p1 p2))))"
  unfolding gcd_impl_main_def Let_def primitive_part_def gcd_impl_start_def gcd_impl_primitive_def
    subresultant_prs_impl by simp

corollary gcd_via_subresultant: "gcd f g = gcd_impl f g" by simp

text \<open>Note that we did not activate @{thm gcd_via_subresultant} as code-equation, since according to our experiments,
  the subresultant-gcd algorithm is not always more efficient than the currently active equation.
  In particular, on @{typ "int poly"} @{const gcd_impl} performs worse, but on multi-variate polynomials,
  e.g., @{typ "int poly poly poly"}, @{const gcd_impl} is preferable.\<close>

end


theory Auxiliary
imports
  "HOL-Library.FuncSet"
  "HOL-Combinatorics.Orbits"
begin

lemma funpow_invs:
  assumes "m \<le> n" and inv: "\<And>x. f (g x) = x"
  shows "(f ^^ m) ((g ^^ n) x) = (g ^^ (n - m)) x"
  using \<open>m \<le> n\<close>
proof (induction m)
  case (Suc m)
  moreover then have "n - m = Suc (n - Suc m)" by auto
  ultimately show ?case by (auto simp: inv)
qed simp

section \<open>Permutation Domains\<close>

definition has_dom :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "has_dom f S \<equiv> \<forall>s. s \<notin> S \<longrightarrow> f s = s"

lemma has_domD: "has_dom f S \<Longrightarrow> x \<notin> S \<Longrightarrow> f x = x"
  by (auto simp: has_dom_def)

lemma has_domI: "(\<And>x. x \<notin> S \<Longrightarrow> f x = x) \<Longrightarrow> has_dom f S"
  by (auto simp: has_dom_def)

lemma permutes_conv_has_dom:
  "f permutes S \<longleftrightarrow> bij f \<and> has_dom f S"
  by (auto simp: permutes_def has_dom_def bij_iff)

section \<open>Segments\<close>

inductive_set segment :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a set" for f a b where
  base: "f a \<noteq> b \<Longrightarrow> f a \<in> segment f a b" |
  step: "x \<in> segment f a b \<Longrightarrow> f x \<noteq> b \<Longrightarrow> f x \<in> segment f a b"

lemma segment_step_2D:
  assumes "x \<in> segment f a (f b)" shows "x \<in> segment f a b \<or> x = b"
  using assms by induct (auto intro: segment.intros)

lemma not_in_segment2D:
  assumes "x \<in> segment f a b" shows "x \<noteq> b"
  using assms by induct auto

lemma segment_altdef:
  assumes "b \<in> orbit f a"
  shows "segment f a b = (\<lambda>n. (f ^^ n) a) ` {1..<funpow_dist1 f a b}" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix x assume "x \<in> ?L"
  have "f a \<noteq>b \<Longrightarrow> b \<in> orbit f (f a)"
    using assms  by (simp add: orbit_step)
  then have *: "f a \<noteq> b \<Longrightarrow> 0 < funpow_dist f (f a) b"
    using assms using gr0I funpow_dist_0_eq[OF \<open>_ \<Longrightarrow> b \<in> orbit f (f a)\<close>] by (simp add: orbit.intros)
  from \<open>x \<in> ?L\<close> show "x \<in> ?R"
  proof induct
    case base then show ?case by (intro image_eqI[where x=1]) (auto simp: *)
  next
    case step then show ?case using assms funpow_dist1_prop less_antisym
      by (fastforce intro!: image_eqI[where x="Suc n" for n])
  qed
next
  fix x assume "x \<in> ?R"
  then obtain n where "(f ^^ n ) a = x" "0 < n" "n < funpow_dist1 f a b" by auto
  then show "x \<in> ?L"
  proof (induct n arbitrary: x)
    case 0 then show ?case by simp
  next
    case (Suc n)
    have "(f ^^ Suc n) a \<noteq> b" using Suc by (meson funpow_dist1_least)
    with Suc show ?case by (cases "n = 0") (auto intro: segment.intros)
  qed
qed

(*XXX move up*)
lemma segmentD_orbit:
  assumes "x \<in> segment f y z" shows "x \<in> orbit f y"
  using assms by induct (auto intro: orbit.intros)

lemma segment1_empty: "segment f x (f x) = {}"
  by (auto simp: segment_altdef orbit.base funpow_dist_0)

lemma segment_subset:
  assumes "y \<in> segment f x z"
  assumes "w \<in> segment f x y"
  shows "w \<in> segment f x z"
  using assms by (induct arbitrary: w) (auto simp: segment1_empty intro: segment.intros dest: segment_step_2D elim: segment.cases)

(* XXX move up*)
lemma not_in_segment1:
  assumes "y \<in> orbit f x" shows "x \<notin> segment f x y"
proof
  assume "x \<in> segment f x y"
  then obtain n where n: "0 < n" "n < funpow_dist1 f x y" "(f ^^ n) x = x"
    using assms by (auto simp: segment_altdef Suc_le_eq)
  then have neq_y: "(f ^^ (funpow_dist1 f x y - n)) x \<noteq> y" by (simp add: funpow_dist1_least)

  have "(f ^^ (funpow_dist1 f x y - n)) x = (f ^^ (funpow_dist1 f x y - n)) ((f ^^ n) x)"
    using n by (simp add: funpow_add)
  also have "\<dots> = (f ^^ funpow_dist1 f x y) x"
    using \<open>n < _\<close> by (simp add: funpow_add)
      (metis assms funpow_0 funpow_neq_less_funpow_dist1 n(1) n(3) nat_neq_iff zero_less_Suc)
  also have "\<dots> = y" using assms by (rule funpow_dist1_prop)
  finally show False using neq_y by contradiction
qed

lemma not_in_segment2: "y \<notin> segment f x y"
  using not_in_segment2D by metis

(*XXX move*)
lemma in_segmentE:
  assumes "y \<in> segment f x z" "z \<in> orbit f x"
  obtains "(f ^^ funpow_dist1 f x y) x = y" "funpow_dist1 f x y < funpow_dist1 f x z"
proof
  from assms show "(f ^^ funpow_dist1 f x y) x = y"
    by (intro segmentD_orbit funpow_dist1_prop)
  moreover
  obtain n where "(f ^^ n) x = y" "0 < n" "n < funpow_dist1 f x z"
    using assms by (auto simp: segment_altdef)
  moreover then have "funpow_dist1 f x y \<le> n" by (meson funpow_dist1_least not_less)
  ultimately show "funpow_dist1 f x y < funpow_dist1 f x z" by linarith
qed

(*XXX move*)
lemma cyclic_split_segment:
  assumes S: "cyclic_on f S" "a \<in> S" "b \<in> S" and "a \<noteq> b"
  shows "S = {a,b} \<union> segment f a b \<union> segment f b a" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix c assume "c \<in> ?L"
  with S have "c \<in> orbit f a" unfolding cyclic_on_alldef by auto
  then show "c \<in> ?R" by induct (auto intro: segment.intros)
next
  fix c assume "c \<in> ?R"
  moreover have "segment f a b \<subseteq> orbit f a" "segment f b a \<subseteq> orbit f b"
    by (auto dest: segmentD_orbit)
  ultimately show "c \<in> ?L" using S by (auto simp: cyclic_on_alldef)
qed

(*XXX move*)
lemma segment_split:
  assumes y_in_seg: "y \<in> segment f x z"
  shows "segment f x z = segment f x y \<union> {y} \<union> segment f y z" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix w assume "w \<in> ?L" then show "w \<in> ?R" by induct (auto intro: segment.intros)
next
  fix w assume "w \<in> ?R"
  moreover
  { assume "w \<in> segment f x y" then have "w \<in> segment f x z"
    using segment_subset[OF y_in_seg] by auto }
  moreover
  { assume "w \<in> segment f y z" then have "w \<in> segment f x z"
      using y_in_seg by induct (auto intro: segment.intros) }
  ultimately
  show "w \<in> ?L" using y_in_seg by (auto intro: segment.intros)
qed

lemma in_segmentD_inv:
  assumes "x \<in> segment f a b" "x \<noteq> f a"
  assumes "inj f"
  shows "inv f x \<in> segment f a b"
  using assms by (auto elim: segment.cases)

lemma in_orbit_invI:
  assumes "b \<in> orbit f a"
  assumes "inj f"
  shows "a \<in> orbit (inv f) b"
  using assms(1)
  apply induct
   apply (simp add: assms(2) orbit_eqI(1))
  by (metis assms(2) inv_f_f orbit.base orbit_trans)

lemma segment_step_2:
  assumes A: "x \<in> segment f a b" "b \<noteq> a" and "inj f"
  shows "x \<in> segment f a (f b)"
  using A by induct (auto intro: segment.intros dest: not_in_segment2D injD[OF \<open>inj f\<close>])

lemma inv_end_in_segment:
  assumes "b \<in> orbit f a" "f a \<noteq> b" "bij f"
  shows "inv f b \<in> segment f a b"
  using assms(1,2)
proof induct
  case base then show ?case by simp
next
  case (step x)
  moreover
  from \<open>bij f\<close> have "inj f" by (rule bij_is_inj)
  moreover
  then have "x \<noteq> f x \<Longrightarrow> f a = x \<Longrightarrow> x \<in> segment f a (f x)" by (meson segment.simps)
  moreover
  have "x \<noteq> f x"
    using step \<open>inj f\<close> by (metis in_orbit_invI inv_f_eq not_in_segment1 segment.base)
  then have "inv f x \<in> segment f a (f x) \<Longrightarrow> x \<in> segment f a (f x)"
    using \<open>bij f\<close> \<open>inj f\<close> by (auto dest: segment.step simp: surj_f_inv_f bij_is_surj)
  then have "inv f x \<in> segment f a x \<Longrightarrow> x \<in> segment f a (f x)"
    using \<open>f a \<noteq> f x\<close> \<open>inj f\<close> by (auto dest: segment_step_2 injD)
  ultimately show ?case by (cases "f a = x") simp_all
qed

lemma segment_overlapping:
  assumes "x \<in> orbit f a" "x \<in> orbit f b" "bij f"
  shows "segment f a x \<subseteq> segment f b x \<or> segment f b x \<subseteq> segment f a x"
  using assms(1,2)
proof induction
  case base then show ?case by (simp add: segment1_empty)
next
  case (step x)
  from \<open>bij f\<close> have "inj f" by (simp add: bij_is_inj)
  have *: "\<And>f x y. y \<in> segment f x (f x) \<Longrightarrow> False" by (simp add: segment1_empty)
  { fix y z
    assume A: "y \<in> segment f b (f x)" "y \<notin> segment f a (f x)" "z \<in> segment f a (f x)"
    from \<open>x \<in> orbit f a\<close> \<open>f x \<in> orbit f b\<close> \<open>y \<in> segment f b (f x)\<close>
    have "x \<in> orbit f b"
      by (metis * inv_end_in_segment[OF _ _ \<open>bij f\<close>] inv_f_eq[OF \<open>inj f\<close>] segmentD_orbit)
    moreover
    with \<open>x \<in> orbit f a\<close> step.IH
    have "segment f a (f x) \<subseteq> segment f b (f x) \<or> segment f b (f x) \<subseteq> segment f a (f x)"
      apply auto
       apply (metis * inv_end_in_segment[OF _ _ \<open>bij f\<close>] inv_f_eq[OF \<open>inj f\<close>] segment_step_2D segment_subset step.prems subsetCE)
      by (metis (no_types, lifting) \<open>inj f\<close> * inv_end_in_segment[OF _ _ \<open>bij f\<close>] inv_f_eq orbit_eqI(2) segment_step_2D segment_subset subsetCE)
    ultimately
    have "segment f a (f x) \<subseteq> segment f b (f x)" using A by auto
  } note C = this
  then show ?case by auto
qed

lemma segment_disj:
  assumes "a \<noteq> b" "bij f"
  shows "segment f a b \<inter> segment f b a = {}"
proof (rule ccontr)
  assume "\<not>?thesis"
  then obtain x where x: "x \<in> segment f a b" "x \<in> segment f b a" by blast
  then have "segment f a b = segment f a x \<union> {x} \<union> segment f x b"
      "segment f b a = segment f b x \<union> {x} \<union> segment f x a"
    by (auto dest: segment_split)
  then have o: "x \<in> orbit f a" "x \<in> orbit f b" by (auto dest: segmentD_orbit)

  note * = segment_overlapping[OF o \<open>bij f\<close>]
  have "inj f" using \<open>bij f\<close> by (simp add: bij_is_inj)

  have "segment f a x = segment f b x"
  proof (intro set_eqI iffI)
    fix y assume A: "y \<in> segment f b x"
    then have "y \<in> segment f a x \<or> f a \<in> segment f b a"
      using * x(2) by (auto intro: segment.base segment_subset)
    then show "y \<in> segment f a x"
      using \<open>inj f\<close> A by (metis (no_types) not_in_segment2 segment_step_2)
  next
    fix y assume A: "y \<in> segment f a x "
    then have "y \<in> segment f b x \<or> f b \<in> segment f a b"
      using * x(1) by (auto intro: segment.base segment_subset)
    then show "y \<in> segment f b x"
      using \<open>inj f\<close> A by (metis (no_types) not_in_segment2 segment_step_2)
  qed
  moreover
  have "segment f a x \<noteq> segment f b x"
    by (metis assms bij_is_inj not_in_segment2 segment.base segment_step_2 segment_subset x(1))
  ultimately show False by contradiction
qed

lemma segment_x_x_eq:
  assumes "permutation f"
  shows "segment f x x = orbit f x - {x}" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix y assume "y \<in> ?L" then show "y \<in> ?R" by (auto dest: segmentD_orbit simp: not_in_segment2)
next
  fix y assume "y \<in> ?R"
  then have "y \<in> orbit f x" "y \<noteq> x" by auto
  then show "y \<in> ?L" by induct (auto intro: segment.intros)
qed

section \<open>Lists of Powers\<close>

definition iterate :: "nat \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a ) \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "iterate m n f x = map (\<lambda>n. (f^^n) x) [m..<n]"

lemma set_iterate:
  "set (iterate m n f x) = (\<lambda>k. (f ^^ k) x) ` {m..<n} "
  by (auto simp: iterate_def)

lemma iterate_empty[simp]: "iterate n m f x = [] \<longleftrightarrow> m \<le> n"
  by (auto simp: iterate_def)

lemma iterate_nth[simp]:
  assumes "k < n - m" shows "iterate m n f x ! k = (f^^(m+k)) x"
  using assms
  by (induct k arbitrary: m) (auto simp: iterate_def)

lemma iterate_applied:
  "iterate n m f (f x) = iterate (Suc n) (Suc m) f x"
  by (induct m arbitrary: n) (auto simp: iterate_def funpow_swap1)

end


\<^marker>\<open>creator Florian Keßler\<close>

section "Binary Arithmetic"

theory Binary_Arithmetic
  imports Main IMP_Minus_Minus_Small_StepT "HOL-Library.Discrete"

begin

text \<open> In this theory, we introduce functions to access bits out of nats, and Lemmas that relate
        the bits in the result of addition and subtraction to the bits of the original numbers. \<close>

fun nth_bit_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nth_bit_nat x 0 = x mod 2" |
  "nth_bit_nat x (Suc n) = nth_bit_nat (x div 2) n"

fun nth_bit_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nth_bit_tail x 0 = x mod 2" |
  "nth_bit_tail x (Suc n) = nth_bit_tail (x div 2) n"

lemma subtail_nth_bit: "nth_bit_tail x n = nth_bit_nat x n"
  by(induct x n rule: nth_bit_tail.induct) simp+

lemma nth_bit_nat_is_right_shift: "nth_bit_nat x n = (x div 2 ^ n) mod 2"
  apply(induction n arbitrary: x)
  by(auto simp:  div_mult2_eq)

definition nth_bit:: "nat \<Rightarrow> nat \<Rightarrow> bit" where
"nth_bit x n = nat_to_bit (nth_bit_nat x n)"

fun nth_bit_of_num:: "num \<Rightarrow> nat \<Rightarrow> bit" where
"nth_bit_of_num Num.One 0 = One" |
"nth_bit_of_num Num.One (Suc n) = Zero" |
"nth_bit_of_num (Num.Bit0 x) 0 = Zero" |
"nth_bit_of_num (Num.Bit1 x) 0 = One" |
"nth_bit_of_num (Num.Bit0 x) (Suc n) = nth_bit_of_num x n" |
"nth_bit_of_num (Num.Bit1 x) (Suc n) = nth_bit_of_num x n"

lemma nth_bit_nat_of_zero[simp]: "nth_bit_nat 0 n = 0"
  by (induction n) auto

lemma nth_bit_of_zero[simp]: "nth_bit 0 n = Zero"
  by (induction n) (auto simp: nth_bit_def)

lemma nth_bit_of_one[simp]: "nth_bit (Suc 0) n = (if n = 0 then One else Zero)"
  apply(cases n)
  by(auto simp: nth_bit_def nat_to_bit_eq_Zero_iff)

lemma one_plus_2n_is_odd[simp]: "Suc (n + n) mod 2 = 1" by presburger

lemma nth_bit_of_nat_of_num: "nth_bit (nat_of_num x) n = nth_bit_of_num x n"
proof(induction n arbitrary: x)
  case 0
  then show ?case by (cases x) (auto simp: nth_bit_def nat_to_bit_eq_One_iff)
next
  case (Suc n)
  then show ?case using Suc by (cases x) (auto simp: nth_bit_def)
qed

lemma nth_bit_is_nth_bit_of_num: "nth_bit x n = (if x = 0 then Zero
  else nth_bit_of_num (num_of_nat x) n)"
proof (cases "x = 0")
  case False
  hence "nth_bit x n = nth_bit (nat_of_num (num_of_nat x)) n" using num_of_nat_inverse by auto
  thus ?thesis using False by(simp add: nth_bit_of_nat_of_num)
qed auto

lemma le_2_to_the_n_then_nth_bit_zero: "x < 2 ^ n \<Longrightarrow> nth_bit x n = Zero"
  by(auto simp: nth_bit_def nat_to_bit_eq_Zero_iff nth_bit_nat_is_right_shift)

lemma nth_bit_add_out_of_range: "(a :: nat) < 2 ^ n \<Longrightarrow> j < n \<Longrightarrow> nth_bit (2 ^ n + a) j = nth_bit a j"
proof-
  assume "a < 2 ^ n" "j < n"
  have "(2 ^ n + a) div 2 ^ j mod 2 = ((2 ^ n) div 2 ^ j + a div 2 ^ j) mod 2"
    using div_plus_div_distrib_dvd_left[OF le_imp_power_dvd[OF less_imp_le_nat[OF \<open>j < n\<close>]]]
    by metis
  also have "... = (2 ^ (n - j) + a div 2 ^ j) mod 2" using \<open>j < n\<close>
    using power_diff[OF _ less_imp_le_nat[OF \<open>j < n\<close>], where ?a=2]
    by (metis nat.simps numeral_2_eq_2)
  also have  "... = a div 2 ^ j mod 2" using \<open>j < n\<close>
    by (metis (no_types, lifting) Suc_leI add.commute add.right_neutral even_iff_mod_2_eq_zero
        le_imp_power_dvd mod_add_left_eq power_Suc0_right zero_less_diff)
  finally show ?thesis
    apply(cases "nth_bit a j")
    by(auto simp: nth_bit_def nat_to_bit_cases nth_bit_nat_is_right_shift)
qed

fun nth_carry:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bit" where
"nth_carry 0 a b = (if (nth_bit a 0 = One \<and> nth_bit b 0 = One) then One else Zero)" |
"nth_carry (Suc n) a b = (if (nth_bit a (Suc n) = One \<and> nth_bit b (Suc n) = One)
  \<or> ((nth_bit a (Suc n) = One \<or> nth_bit b (Suc n) = One) \<and> nth_carry n a b = One)
  then One else Zero)"

lemma a_mod_n_plus_b_mod_n_geq_a_plus_b_mod_n: "(a :: nat) mod n + b mod n \<ge> (a + b) mod n"
  by (metis mod_add_eq mod_less_eq_dividend)

lemma a_mod_2_to_the_n_decomposition: "(a :: nat) mod (2 * 2 ^ n)
  = a div 2 ^ n mod 2 * 2 ^ n +  a mod 2 ^ n"
  by (metis mod_mult2_eq mult.commute)

lemma a_mod_plus_b_mod_div_le_2: "((a :: nat) mod 2 ^ n + b mod 2 ^ n) div 2 ^ n < 2"
proof-
  have "a mod 2 ^ n < 2 ^ n" "b mod 2 ^ n < 2 ^ n" by auto
  hence "(a mod 2 ^ n + b mod 2 ^ n) < 2 * 2 ^ n" by linarith
  thus ?thesis using less_mult_imp_div_less by simp
qed

lemma a_mod_plus_b_mod: "((a :: nat) mod (2 * 2 ^ n) + b mod (2 * 2 ^ n)) div (2 * 2 ^ n) mod 2
  = (a div 2 ^ n mod 2 + b div 2 ^ n mod 2 +
      (a mod (2 ^ n) + b mod (2 ^ n)) div (2 ^ n) mod 2) div 2"
proof -
  have "(a mod (2 * 2 ^ n) + b mod (2 * 2 ^ n)) div (2 * 2 ^ n) mod 2
    = (a div 2 ^ n mod 2 * 2 ^ n + b div 2 ^ n mod 2 * 2 ^ n
      + a mod 2 ^ n + b mod 2 ^ n) div (2 * 2 ^ n) mod 2"
    using a_mod_2_to_the_n_decomposition by presburger
  also have "... = ((a div 2 ^ n mod 2 * 2 ^ n + b div 2 ^ n mod 2 * 2 ^ n
      + a mod 2 ^ n + b mod 2 ^ n) div 2 ^ n) div 2 mod 2"
    by (metis (mono_tags, lifting) div_mult2_eq mult.commute)
  also have "... = ((a div 2 ^ n mod 2 * 2 ^ n) div 2 ^ n  + (b div 2 ^ n mod 2 * 2 ^ n) div 2 ^ n
      + (a mod 2 ^ n + b mod 2 ^ n) div 2 ^ n) div 2 mod 2" by (simp add: add.assoc)
  also have "... = (a div 2 ^ n mod 2  + b div 2 ^ n mod 2
      + (a mod 2 ^ n + b mod 2 ^ n) div 2 ^ n) div 2 mod 2" by simp
  also have "... = (a div 2 ^ n mod 2  + b div 2 ^ n mod 2
      + (a mod 2 ^ n + b mod 2 ^ n) div 2 ^ n mod 2) div 2 mod 2"
    using a_mod_plus_b_mod_div_le_2 by simp
  finally show ?thesis by simp
qed

lemma nth_carry_mod: "nth_carry n a b =
  nth_bit ((a mod 2 ^ Suc n) + (b mod 2 ^ Suc n)) (Suc n)"
proof(induction n)
  case 0
  then show ?case by(auto simp: nth_bit_def nat_to_bit_cases nth_bit_nat_is_right_shift)
next
  case (Suc n)
  then show ?case
    apply(cases "nth_carry n a b")
      by(auto simp: nth_bit_def nat_to_bit_cases nth_bit_nat_is_right_shift
          a_mod_plus_b_mod[where ?n="Suc n", simplified] algebra_simps split: if_splits)
qed

lemma first_bit_of_add: "nth_bit (a + b) 0
  = (if nth_bit a 0 = One then if nth_bit b 0 = One then Zero else One
     else if nth_bit b 0 = One then One else Zero)"
  apply(auto simp: nth_bit_def nat_to_bit_eq_One_iff nat_to_bit_eq_Zero_iff)
  by presburger

lemma nth_bit_of_add: "nth_bit (a + b) (Suc n) = (let u = nth_bit a (Suc n);
  v = nth_bit b (Suc n); w = nth_carry n a b in
  (if u = One then
    if v = One then
     if w = One then One else Zero
    else
     if w = One then Zero else One
   else
    if v = One then
     if w = One then Zero else One
    else
     if w = One then One else Zero))"
  apply(auto simp: Let_def nth_bit_def nth_bit_nat_is_right_shift nat_to_bit_cases nth_carry_mod)
  by (metis div_add1_eq even_add even_iff_mod_2_eq_zero not_mod2_eq_Suc_0_eq_0)+

lemma no_overflow_condition: "a + b < 2 ^ n \<Longrightarrow> nth_carry (n - 1) a b = Zero"
  apply(cases n)
  by(auto simp: nth_carry_mod nth_bit_def nth_bit_nat_is_right_shift nat_to_bit_cases)

lemma has_bit_one_then_greater_zero: "nth_bit a j = One \<Longrightarrow> 0 < a"
  apply(auto simp: nth_bit_def nth_bit_nat_is_right_shift nat_to_bit_cases)
  by (metis One_nat_def div_less dvd_0_right even_mod_2_iff gr_zeroI less_2_cases_iff
      odd_one zero_less_power)

lemma greater_zero_then_has_bit_one: "x > 0 \<Longrightarrow> x < 2 ^ n \<Longrightarrow> \<exists>b \<in> {0..<n}. nth_bit x b = One"
proof(rule ccontr)
  assume "x > 0" "x < 2 ^ n" "\<not> (\<exists>b\<in>{0..<n}. nth_bit x b = One)"
  hence "(\<forall>b. nth_bit x b = Zero) \<or> (\<exists>b \<ge> n. nth_bit x b = One)" by auto
  thus False
  proof(elim disjE)
    assume "\<forall>b. nth_bit x b = Zero"
    hence "nth_bit x (Discrete.log x) = Zero" by auto
    moreover have "x div 2 ^ Discrete.log x = 1"
      using Discrete.log_exp2_gt log_exp2_le[OF \<open>x > 0\<close>]
      by (metis Euclidean_Division.div_eq_0_iff One_nat_def leD less_2_cases_iff
          less_mult_imp_div_less power_not_zero zero_neq_numeral)
    ultimately show False by(auto simp: nth_bit_def nth_bit_nat_is_right_shift nat_to_bit_cases)
  next
    assume "\<exists>b \<ge> n. nth_bit x b = One"
    then obtain b where "b \<ge> n \<and> nth_bit x b = One" by blast
    thus False using \<open>x < 2 ^ n\<close>
      apply(auto simp: nth_bit_def nth_bit_nat_is_right_shift nat_to_bit_cases)
      by (metis div_greater_zero_iff gr0I leD le_less_trans less_2_cases_iff less_Suc0
          mod_less_eq_dividend nat_power_less_imp_less)
  qed
qed

fun nth_carry_sub:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bit" where
"nth_carry_sub 0 a b = (if (nth_bit a 0 = Zero \<and> nth_bit b 0 = One) then One else Zero)" |
"nth_carry_sub (Suc n) a b =
  (if (nth_bit a (Suc n) = Zero \<and> ( nth_bit b (Suc n) = One \<or> nth_carry_sub n a b = One))
    \<or> (nth_bit a (Suc n) = One \<and> (nth_bit b (Suc n)) = One \<and> nth_carry_sub n a b = One) then One
  else Zero)"

lemma a_mod_less_b_mod_iff: "(a :: nat) mod (2 * 2 ^ n) < b mod (2 * 2 ^ n)
  \<longleftrightarrow> ((a div 2 ^ n mod 2 < b div 2 ^ n mod 2)
        \<or> (a div 2 ^ n mod 2 = b div 2 ^ n mod 2 \<and> a mod 2 ^ n < b mod 2 ^ n))"
  apply(auto simp: algebra_simps a_mod_2_to_the_n_decomposition)
    apply (smt add.right_neutral add_self_div_2 le_less_trans le_simps(1) less_Suc0 mod_less_divisor
      mult_0_right mult_numeral_1_right not_add_less2 not_mod_2_eq_0_eq_1 numeral_2_eq_2
      numeral_Bit0_div_2 plus_1_eq_Suc pos2 zero_less_power)
   apply (metis (no_types, lifting) One_nat_def add.right_neutral add_lessD1 add_less_cancel_right
      less_Suc0 mult_0_right not_mod_2_eq_0_eq_1)
  by (smt add.commute add.right_neutral add_self_div_2 mod_less_divisor mult_0_right
      mult_numeral_1_right not_add_less2 not_mod_2_eq_0_eq_1 numeral_2_eq_2
      numeral_Bit0_div_2 plus_1_eq_Suc trans_less_add2 zero_less_power)

lemma nth_carry_sub_mod: "nth_carry_sub n a b =
 (if (a mod 2 ^ Suc n) < (b mod 2 ^ Suc n) then One else Zero)"
proof(induction n)
  case 0
  then show ?case by(auto simp: nth_bit_def nat_to_bit_cases nth_bit_nat_is_right_shift)
next
  case (Suc n)
  then show ?case
    apply(cases "nth_carry_sub n a b")
    by(auto simp: nth_bit_def nat_to_bit_cases nth_bit_nat_is_right_shift
        a_mod_less_b_mod_iff[where ?n="Suc n", simplified] algebra_simps split: if_splits)
qed

lemma first_bit_of_sub_n_no_underflow: "a \<ge> b \<Longrightarrow> nth_bit (a - b) 0 = (if nth_bit a 0 = One then
  (if nth_bit b 0 = One then Zero else One)
  else (if nth_bit b 0 = One then One else Zero))"
  apply(auto simp: nth_bit_def nat_to_bit_eq_One_iff nat_to_bit_eq_Zero_iff)
  by presburger+

lemma a_times_n_minus_one_div_n: "n > 0 \<Longrightarrow> ((a :: nat) * n - 1) div n = a - 1"
proof(induction a)
  case (Suc a)
  then show ?case using Suc
  proof(cases a)
    case (Suc nat)
    hence "((Suc a) * n - 1) div n = (n + (a * n - 1)) div n"
      using Suc.prems by auto
    also have "... = 1 + (a * n - 1) div n" using Suc by (simp add: Suc.prems)
    finally show ?thesis using Suc  using Suc.IH Suc.prems by auto
  qed auto
qed auto

lemma a_times_n_minus_n_minus_one_div_n: "n > 1 \<Longrightarrow> ((a :: nat) * n - (n - 1)) div n = a - 1"
proof(induction a)
  case (Suc a)
  then show ?case using Suc
  proof(cases a)
    case (Suc nat)
    hence "((Suc a) * n - (n - 1)) div n = (n + (a * n - (n - 1))) div n"
      using Suc.prems by auto
    also have "... = 1 + (a * n - (n - 1)) div n" using Suc.prems div_geq by auto
    finally show ?thesis using Suc  using Suc.IH Suc.prems by auto
  qed auto
qed auto

lemma a_plus_b_minus_c_mod:
  assumes "n > 1"
  shows "((a :: nat) * n + b mod n - c mod n) div n
    = a - (if b mod n < c mod n then 1 else 0)"
proof(cases "b mod n < c mod n")
  case True
  hence "(a * n + b mod n - c mod n) div n \<le> (a * n - 1) div n" by(auto intro: div_le_mono)
  hence "(a * n + b mod n - c mod n) div n \<le> a - 1" using \<open>n > 1\<close> a_times_n_minus_one_div_n by simp
  have "(a * n + b mod n - c mod n) div n \<ge> (a * n + b mod n - (n - 1)) div n"
    apply(rule div_le_mono)
    apply(rule diff_le_mono2)
    using  mod_less_divisor[where ?n=n] \<open>n > 1\<close>
    by (metis One_nat_def Suc_pred le_less_trans less_Suc_eq_le zero_le_one)
  moreover have "(a * n + b mod n - (n - 1)) div n \<ge> (a * n - (n - 1)) div n"
    using div_le_mono by simp
  ultimately have "(a * n + b mod n - c mod n) div n \<ge> a - 1"
    using a_times_n_minus_n_minus_one_div_n[OF \<open>n > 1\<close>] by simp
  show ?thesis using \<open>(a * n + b mod n - c mod n) div n \<le> a - 1\<close>
    \<open>(a * n + b mod n - c mod n) div n \<ge> a - 1\<close> using True le_antisym by presburger
next
  case False
  hence "(a * n + b mod n - c mod n) div n = (a * n + (b mod n - c mod n)) div n" by simp
  hence "(a * n + b mod n - c mod n) div n = a + (b mod n - c mod n) div n" using \<open>n > 1\<close> by auto
  thus ?thesis using \<open>\<not> b mod n < c mod n\<close>
    by (metis (mono_tags, lifting) Euclidean_Division.div_eq_0_iff add_cancel_left_right diff_zero
        less_imp_diff_less mod_less_divisor neq0_conv)
qed

lemma a_minus_b_shift_right: "(a - b) div 2 ^ Suc n = (a :: nat) div 2 ^ Suc n - b div 2 ^ Suc n
  - (if a mod 2 ^ Suc n < b mod 2 ^ Suc n then 1 else 0)"
proof -
  have "1 < (2 :: nat) ^ Suc n"
    using one_less_numeral_iff power_gt1 semiring_norm(76) by blast
   have *: "(a - b) div (2 ^ Suc n) = (((a div (2 * 2 ^ n)) * 2 * 2 ^ n + a mod (2 * 2 ^ n))
        - ((b div (2 * 2 ^ n)) * 2 * 2 ^ n + b mod (2 * 2 ^ n))) div (2 * 2 ^ n)"
     by (simp add: div_mult_mod_eq mult.assoc)
   show ?thesis
   proof(cases "(a div (2 * 2 ^ n)) * 2 * 2 ^ n \<ge> (b div (2 * 2 ^ n)) * 2 * 2 ^ n")
     case True
     hence "(a - b) div (2 ^ Suc n)
        = (((a div (2 * 2 ^ n)) - (b div (2 * 2 ^ n))) * (2 * 2 ^ n)
          + a mod (2 * 2 ^ n) - b mod (2 * 2 ^ n))  div (2 * 2 ^ n)"
       using "*" by(auto simp: algebra_simps)
     then show ?thesis
       using a_plus_b_minus_c_mod[OF \<open>1 < (2 :: nat) ^ Suc n\<close>, where
           ?a="(a div (2 * 2 ^ n)) - (b div (2 * 2 ^ n))" and ?b=a and ?c=b, simplified]
       by(auto)
  next
    case False
    hence "a < b"
      by (metis div_le_mono le_neq_implies_less mult_le_mono1 nat_le_linear)
    thus ?thesis using False by auto
  qed
qed

lemma a_minus_b_mod2: "(a :: nat) \<ge> b \<Longrightarrow> (a - b) mod 2 = (if a mod 2 = 0 then
  (if b mod 2 = 0 then 0 else 1)
 else
  (if b mod 2 = 0 then 1 else 0))"
  by presburger

lemma a_le_b_but_a_mod_greater_b_mod_then: "a \<ge> b \<Longrightarrow> a mod n < b mod n
  \<Longrightarrow> a div n \<ge> Suc (b div n)"
proof(rule ccontr)
  assume"a \<ge> b" "a mod n < b mod n" "\<not> (a div n \<ge> Suc (b div n))"
  hence "a = a div n * n + a mod n" by auto
  hence "a < a div n * n + b mod n" using \<open>a mod n < b mod n\<close> by linarith
  moreover have "a div n * n \<le> b div n * n" using \<open>\<not> (a div n \<ge> Suc (b div n))\<close> by simp
  ultimately have "a < b div n * n + b mod n" by linarith
  also have "... = b" by simp
  finally show False using \<open>a \<ge> b\<close> by simp
qed

lemma nth_bit_of_sub_n_no_underflow: "a \<ge> b \<Longrightarrow>
  nth_bit (a - b) (Suc n) = (let an = nth_bit a (Suc n); bn = nth_bit b (Suc n);
  c = nth_carry_sub n a b in
  (if an = One then
    (if bn = One then
      (if c = One then One else Zero)
     else
      (if c = One then Zero else One))
  else
    (if bn = One then
      (if c = One then Zero else One)
     else
      (if c = One then One else Zero))))"
  apply(auto simp: Let_def nth_bit_def nth_bit_nat_is_right_shift nat_to_bit_cases
      a_minus_b_shift_right[simplified] nth_carry_sub_mod a_minus_b_mod2[OF div_le_mono]
      a_minus_b_mod2[OF a_le_b_but_a_mod_greater_b_mod_then] split: if_splits)
  by (metis dvd_imp_mod_0 even_Suc)+

lemma nth_bit_of_sub_n_underflow: "a < b \<Longrightarrow>
  nth_bit (a - b) (Suc n) = Zero"
  by simp

lemma nth_carry_sub_underflow: "a < b \<Longrightarrow> a < 2 ^ n \<Longrightarrow> b < 2 ^ n
  \<Longrightarrow> nth_carry_sub (n - 1) (2^n + a) b = One"
  apply(cases n)
  by(auto simp: nth_carry_sub_mod)

lemma nth_carry_sub_no_underflow: "a \<ge> b \<Longrightarrow> a < 2 ^ n \<Longrightarrow> b < 2 ^ n
  \<Longrightarrow> nth_carry_sub (n - 1) a b = Zero"
  by (smt bit_neq_zero_iff le_add_diff_inverse no_overflow_condition nth_bit_of_add
      nth_bit_of_sub_n_no_underflow)

lemma div2_is_right_shift: "nth_bit (x div 2) n = nth_bit x (Suc n)"
  by(auto simp: nth_bit_def)

fun bit_list_to_nat:: "bit list \<Rightarrow> nat" where
"bit_list_to_nat [] = 0" |
"bit_list_to_nat (x # xs) = (case x of Zero \<Rightarrow> 2 * bit_list_to_nat xs |
  One \<Rightarrow> 1 + 2 * bit_list_to_nat xs)"

lemma bit_list_to_nat_right_shift: "(bit_list_to_nat l) div 2 ^ n
  = (bit_list_to_nat (drop n l))"
proof(induction l arbitrary: n)
  case (Cons a l)
  then show ?case
     apply(cases n)
     apply(auto split: bit.splits)
    by (simp add: div_mult2_eq)
qed simp

lemma bit_list_to_nat_mod2: "bit_list_to_nat l mod 2 = (if l = [] then 0 else
  (if hd l = Zero then 0 else 1))"
  apply(cases l)
  by auto

lemma nth_bit_of_bit_list_to_nat[simp]: "nth_bit (bit_list_to_nat l) k
  = (if k < length l then l ! k else Zero)"
    apply(cases "nat_to_bit (2 * bit_list_to_nat l div 2 ^ k mod 2)")
  by(auto simp: nth_bit_def nth_bit_nat_is_right_shift nat_to_bit_cases
        bit_list_to_nat_right_shift bit_list_to_nat_mod2 hd_drop_conv_nth
        split: bit.splits if_splits)

lemma nth_bit_to_nat_greater_zero_then_has_bit_greater_zero:
  assumes "bit_list_to_nat l > 0"
  shows "\<exists>i < length l. l ! i = One"
  using assms
proof(induction l)
  case (Cons a l)
  then show ?case
  proof(cases a)
    case Zero
    hence "bit_list_to_nat l > 0" using Cons by simp
    show ?thesis using Cons.IH[OF \<open>bit_list_to_nat l > 0\<close>] by auto
  qed auto
qed auto

lemma bit_list_to_nat_geq_two_to_the_k_then: "bit_list_to_nat l \<ge> 2 ^ k
  \<Longrightarrow> (\<exists>i. k \<le> i \<and> i < length l \<and> l ! i = One)"
proof-
  assume "bit_list_to_nat l \<ge> 2 ^ k"
  hence "(bit_list_to_nat l) div 2 ^ k \<ge> 1" by (simp add: Suc_leI div_greater_zero_iff)
  hence "bit_list_to_nat (drop k l) \<ge> 1" using bit_list_to_nat_right_shift by simp
  then obtain i where "i < length (drop k l) \<and> (drop k l) ! i = One"
    using nth_bit_to_nat_greater_zero_then_has_bit_greater_zero by force
  hence "k \<le> (k + i) \<and> k + i < length l \<and> l ! (k + i) = One" by auto
  thus ?thesis by blast
qed

lemma not_One_then_has_bit_one_at_higher_position: "x \<noteq> Num.One
  \<Longrightarrow> (\<exists>i > 0. nth_bit_of_num x i = One)"
proof(induction x)
  case One
  then show ?case by auto
next
  case (Bit0 x)
  then show ?case by (cases x) auto
next
  case (Bit1 x)
  then show ?case by (cases x) auto
qed

lemma num_unequal_then_has_unequal_bit: "x \<noteq> y
  \<Longrightarrow> (\<exists>i. nth_bit_of_num x i \<noteq> nth_bit_of_num y i)"
proof(induction x arbitrary: y)
  case One
  hence "y \<noteq> Num.One" by simp
  then obtain i where "i > 0 \<and> nth_bit_of_num y i = One"
    using not_One_then_has_bit_one_at_higher_position by auto
  moreover hence "nth_bit_of_num Num.One i = Zero" using gr0_implies_Suc nth_bit_of_num.simps by blast
  ultimately show ?case by (metis bit.simps)
next
  case (Bit0 x)
  then show ?case
  proof(cases y)
    case One
    then obtain i where "i > 0 \<and> nth_bit_of_num (Num.Bit0 x) i = One"
      using not_One_then_has_bit_one_at_higher_position by auto
    moreover hence "nth_bit_of_num Num.One i = Zero" using gr0_implies_Suc nth_bit_of_num.simps by blast
    ultimately show ?thesis using One by (metis bit.simps)
  next
    case (Bit0 x2)
    hence "x \<noteq> x2" using \<open>num.Bit0 x \<noteq> y\<close> by simp
    then obtain i where "nth_bit_of_num x i \<noteq> nth_bit_of_num x2 i" using Bit0.IH[OF \<open>x \<noteq> x2\<close>] by blast
    hence "nth_bit_of_num (num.Bit0 x) (Suc i) \<noteq> nth_bit_of_num (num.Bit0 x2) (Suc i)" by simp
    then show ?thesis using \<open>y = num.Bit0 x2\<close> by blast
  next
    case (Bit1 x3)
    then show ?thesis by (metis bit.simps nth_bit_of_num.simps nth_bit_of_num.simps)
  qed
next
  case (Bit1 x)
  then show ?case
  proof(cases y)
    case One
    then obtain i where "i > 0 \<and> nth_bit_of_num (Num.Bit1 x) i = One"
      using not_One_then_has_bit_one_at_higher_position by auto
    moreover hence "nth_bit_of_num Num.One i = Zero" using gr0_implies_Suc nth_bit_of_num.simps by blast
    ultimately show ?thesis using One by (metis bit.simps)
  next
    case (Bit0 x2)
    then show ?thesis by (metis bit.simps nth_bit_of_num.simps nth_bit_of_num.simps)
  next
    case (Bit1 x3)
    hence "x \<noteq> x3" using \<open>num.Bit1 x \<noteq> y\<close> by simp
    then obtain i where "nth_bit_of_num x i \<noteq> nth_bit_of_num x3 i" using Bit1.IH[OF \<open>x \<noteq> x3\<close>] by blast
    hence "nth_bit_of_num (num.Bit1 x) (Suc i) \<noteq> nth_bit_of_num (num.Bit1 x3) (Suc i)" by simp
    then show ?thesis using \<open>y = num.Bit1 x3\<close> by blast
  qed
qed

lemma all_bits_equal_then_equal: "x < 2 ^ n \<Longrightarrow> y < 2 ^ n \<Longrightarrow> (\<forall>i < n. nth_bit x i = nth_bit y i)
  \<Longrightarrow> x = y"
proof(rule ccontr)
  assume "x < 2 ^ n" "y < 2 ^ n" "(\<forall>i < n. nth_bit x i = nth_bit y i)"
  hence "i > n \<longrightarrow> x div 2 ^ i = 0" "i > n \<longrightarrow> y div 2 ^ i = 0" for i
    by (meson div_greater_zero_iff gr0I le_less_trans nat_power_less_imp_less order.asym pos2)+
  hence all_bits_equal: "nth_bit x i = nth_bit y i" for i
    apply(cases "i < n")
    using \<open>\<forall>i < n. nth_bit x i = nth_bit y i\<close>
     apply(auto simp add: nth_bit_def nth_bit_nat_is_right_shift)
    by (metis \<open>x < 2 ^ n\<close> \<open>y < 2 ^ n\<close> div_less linorder_neqE_nat)
  assume "x \<noteq> y"
  have "x \<noteq> 0" apply - apply(rule ccontr)
    using \<open>x \<noteq> y\<close> all_bits_equal greater_zero_then_has_bit_one[OF _ \<open>y < 2 ^ n\<close>] by auto
  have "y \<noteq> 0" apply - apply(rule ccontr)
    using \<open>x \<noteq> y\<close> all_bits_equal greater_zero_then_has_bit_one[OF _ \<open>x < 2 ^ n\<close>] by auto
  have "num_of_nat x \<noteq> num_of_nat y"
  proof (rule ccontr)
    assume "\<not>(num_of_nat x \<noteq> num_of_nat y)"
    hence "nat_of_num (num_of_nat x) = nat_of_num (num_of_nat y)" by simp
    hence "x = y" using \<open>x \<noteq> 0\<close> \<open>y \<noteq> 0\<close> num_of_nat_inverse by auto
    thus False using \<open>x \<noteq> y\<close> by blast
  qed
  then obtain i where "nth_bit_of_num (num_of_nat x) i \<noteq> nth_bit_of_num (num_of_nat y) i"
    using num_unequal_then_has_unequal_bit by auto
  hence "nth_bit x i \<noteq> nth_bit y i" using \<open>x \<noteq> 0\<close> \<open>y \<noteq> 0\<close>
    by(auto simp: nth_bit_is_nth_bit_of_num)
  thus False using all_bits_equal by blast
qed

lemma bit_list_to_nat_less_2_to_the_length: "bit_list_to_nat l < 2 ^ length l"
  apply(rule ccontr)
  using bit_list_to_nat_geq_two_to_the_k_then using not_less by blast

lemma bit_list_to_nat_eq_nat_iff: "bit_list_to_nat l = y \<longleftrightarrow> (y < 2 ^ length l \<and>
  (\<forall>i < length l. l ! i = nth_bit y i))"
proof
  assume "bit_list_to_nat l = y"
  hence "y = bit_list_to_nat l" by simp
  hence "y div 2 ^ length l = 0" by(simp add: \<open>y = bit_list_to_nat l\<close> bit_list_to_nat_right_shift)
  hence "y < 2 ^ length l" by (simp add: Euclidean_Division.div_eq_0_iff)
  thus "y < 2 ^ length l \<and> (\<forall>i < length l. l ! i = nth_bit y i)"
    by(simp add: \<open>y = bit_list_to_nat l\<close>)
next
  assume "y < 2 ^ length l \<and> (\<forall>i < length l. l ! i = nth_bit y i)"
  thus "bit_list_to_nat l = y"
    apply - apply(rule all_bits_equal_then_equal[where ?n="length l"])
    using bit_list_to_nat_less_2_to_the_length by auto
qed

definition bit_length where "bit_length x \<equiv>  Discrete.log x + 1"

lemma bit_length_monotonic: "x \<le> y \<Longrightarrow> bit_length x \<le> bit_length y"
  by(auto simp: bit_length_def log_le_iff)

lemma mod_2_of_zero_is_zero_intro: "x = (0 :: nat) \<Longrightarrow> x mod 2 = 0" by auto

lemma bit_geq_bit_length_is_Zero: "i \<ge> bit_length x \<Longrightarrow> nth_bit x i = Zero"
  apply(auto simp: nth_bit_def nat_to_bit_cases nth_bit_nat_is_right_shift bit_length_def)
  apply(rule mod_2_of_zero_is_zero_intro)
  by (metis div_less leI log_exp log_mono monoD not_less_eq_eq)

end


(* Author: Tobias Nipkow *)

theory Tree_Real
imports
  Complex_Main
  Tree
begin

text \<open>
  This theory is separate from \<^theory>\<open>HOL-Library.Tree\<close> because the former is discrete and
  builds on \<^theory>\<open>Main\<close> whereas this theory builds on \<^theory>\<open>Complex_Main\<close>.
\<close>

lemma size1_height_log: "log 2 (size1 t) \<le> height t"
by (simp add: log2_of_power_le size1_height)

lemma min_height_size1_log: "min_height t \<le> log 2 (size1 t)"
by (simp add: le_log2_of_power min_height_size1)

lemma size1_log_if_complete: "complete t \<Longrightarrow> height t = log 2 (size1 t)"
by (simp add: size1_if_complete)

lemma min_height_size1_log_if_incomplete:
  "\<not> complete t \<Longrightarrow> min_height t < log 2 (size1 t)"
by (simp add: less_log2_of_power min_height_size1_if_incomplete)

lemma min_height_balanced: assumes "balanced t"
shows "min_height t = nat(floor(log 2 (size1 t)))"
proof cases
  assume *: "complete t"
  hence "size1 t = 2 ^ min_height t"
    by (simp add: complete_iff_height size1_if_complete)
  from log2_of_power_eq[OF this] show ?thesis by linarith
next
  assume *: "\<not> complete t"
  hence "height t = min_height t + 1"
    using assms min_height_le_height[of t]
    by(auto simp: balanced_def complete_iff_height)
  hence "size1 t < 2 ^ (min_height t + 1)" by (metis * size1_height_if_incomplete)
  from floor_log_nat_eq_if[OF min_height_size1 this] show ?thesis by simp
qed

lemma height_balanced: assumes "balanced t"
shows "height t = nat(ceiling(log 2 (size1 t)))"
proof cases
  assume *: "complete t"
  hence "size1 t = 2 ^ height t" by (simp add: size1_if_complete)
  from log2_of_power_eq[OF this] show ?thesis by linarith
next
  assume *: "\<not> complete t"
  hence **: "height t = min_height t + 1"
    using assms min_height_le_height[of t]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size1 t \<le> 2 ^ (min_height t + 1)" by (metis size1_height)
  from log2_of_power_le[OF this size1_ge0] min_height_size1_log_if_incomplete[OF *] **
  show ?thesis by linarith
qed

lemma balanced_Node_if_wbal1:
assumes "balanced l" "balanced r" "size l = size r + 1"
shows "balanced \<langle>l, x, r\<rangle>"
proof -
  from assms(3) have [simp]: "size1 l = size1 r + 1" by(simp add: size1_size)
  have "nat \<lceil>log 2 (1 + size1 r)\<rceil> \<ge> nat \<lceil>log 2 (size1 r)\<rceil>"
    by(rule nat_mono[OF ceiling_mono]) simp
  hence 1: "height(Node l x r) = nat \<lceil>log 2 (1 + size1 r)\<rceil> + 1"
    using height_balanced[OF assms(1)] height_balanced[OF assms(2)]
    by (simp del: nat_ceiling_le_eq add: max_def)
  have "nat \<lfloor>log 2 (1 + size1 r)\<rfloor> \<ge> nat \<lfloor>log 2 (size1 r)\<rfloor>"
    by(rule nat_mono[OF floor_mono]) simp
  hence 2: "min_height(Node l x r) = nat \<lfloor>log 2 (size1 r)\<rfloor> + 1"
    using min_height_balanced[OF assms(1)] min_height_balanced[OF assms(2)]
    by (simp)
  have "size1 r \<ge> 1" by(simp add: size1_size)
  then obtain i where i: "2 ^ i \<le> size1 r" "size1 r < 2 ^ (i + 1)"
    using ex_power_ivl1[of 2 "size1 r"] by auto
  hence i1: "2 ^ i < size1 r + 1" "size1 r + 1 \<le> 2 ^ (i + 1)" by auto
  from 1 2 floor_log_nat_eq_if[OF i] ceiling_log_nat_eq_if[OF i1]
  show ?thesis by(simp add:balanced_def)
qed

lemma balanced_sym: "balanced \<langle>l, x, r\<rangle> \<Longrightarrow> balanced \<langle>r, y, l\<rangle>"
by(auto simp: balanced_def)

lemma balanced_Node_if_wbal2:
assumes "balanced l" "balanced r" "abs(int(size l) - int(size r)) \<le> 1"
shows "balanced \<langle>l, x, r\<rangle>"
proof -
  have "size l = size r \<or> (size l = size r + 1 \<or> size r = size l + 1)" (is "?A \<or> ?B")
    using assms(3) by linarith
  thus ?thesis
  proof
    assume "?A"
    thus ?thesis using assms(1,2)
      apply(simp add: balanced_def min_def max_def)
      by (metis assms(1,2) balanced_optimal le_antisym le_less)
  next
    assume "?B"
    thus ?thesis
      by (meson assms(1,2) balanced_sym balanced_Node_if_wbal1)
  qed
qed

lemma balanced_if_wbalanced: "wbalanced t \<Longrightarrow> balanced t"
proof(induction t)
  case Leaf show ?case by (simp add: balanced_def)
next
  case (Node l x r)
  thus ?case by(simp add: balanced_Node_if_wbal2)
qed

end