theory Poincare_Lines_Ideal_Points
imports Poincare_Lines
begin

(* ------------------------------------------------------------------ *)
subsection\<open>Ideal points of h-lines\<close>
(* ------------------------------------------------------------------ *)

(* TODO: Introduce ideal points for the oriented circline -
   it would be a list, not a set of two points *)

text\<open>\emph{Ideal points} of an h-line are points where the h-line intersects the unit disc.\<close>

(* ------------------------------------------------------------------ *)
subsubsection \<open>Calculation of ideal points\<close>
(* ------------------------------------------------------------------ *)

text \<open>We decided to define ideal points constructively, i.e., we calculate the coordinates of ideal
points for a given h-line explicitly. Namely, if the h-line is determined by $A$ and $B$, the two
intersection points are $$\frac{B}{|B|^2}\left(-A \pm i\cdot \sqrt{|B|^2 - A^2}\right).$$\<close>

definition calc_ideal_point1_cvec :: "complex \<Rightarrow> complex \<Rightarrow> complex_vec" where
 [simp]:  "calc_ideal_point1_cvec A B =
    (let discr = Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2) in
         (B*(-A - \<i>*sqrt(discr)), (cmod B)\<^sup>2))"

definition calc_ideal_point2_cvec :: "complex \<Rightarrow> complex \<Rightarrow> complex_vec" where
  [simp]: "calc_ideal_point2_cvec A B =
    (let discr = Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2) in
         (B*(-A + \<i>*sqrt(discr)), (cmod B)\<^sup>2))"

definition calc_ideal_points_cmat_cvec :: "complex_mat \<Rightarrow> complex_vec set" where
 [simp]:  "calc_ideal_points_cmat_cvec H =
    (if is_poincare_line_cmat H then
        let (A, B, C, D) = H
         in {calc_ideal_point1_cvec A B, calc_ideal_point2_cvec A B}
     else
        {(-1, 1), (1, 1)})"

lift_definition calc_ideal_points_clmat_hcoords :: "circline_mat \<Rightarrow> complex_homo_coords set" is calc_ideal_points_cmat_cvec
  by (auto simp add: Let_def split: if_split_asm)

lift_definition calc_ideal_points :: "circline \<Rightarrow> complex_homo set" is calc_ideal_points_clmat_hcoords
proof transfer
  fix H1 H2
  assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
  obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
    by (cases H1, cases H2, auto)
  assume "circline_eq_cmat H1 H2"
  then obtain k where k: "k \<noteq> 0" "H2 = cor k *\<^sub>s\<^sub>m H1"
    by auto
  thus "rel_set (\<approx>\<^sub>v) (calc_ideal_points_cmat_cvec H1) (calc_ideal_points_cmat_cvec H2)"
  proof (cases "is_poincare_line_cmat H1")
    case True
    hence "is_poincare_line_cmat H2"
      using k * hermitean_mult_real[of H1 k] hh
      by (auto simp add: power2_eq_square)
    have **: "sqrt (\<bar>k\<bar> * cmod B1 * (\<bar>k\<bar> * cmod B1) - k * Re D1 * (k * Re D1)) =
         \<bar>k\<bar> * sqrt(cmod B1 * cmod B1 - Re D1 * Re D1)"
    proof-
      have "\<bar>k\<bar> * cmod B1 * (\<bar>k\<bar> * cmod B1) - k * Re D1 * (k * Re D1) =
            k\<^sup>2 * (cmod B1 * cmod B1 - Re D1 * Re D1)"
        by (simp add: power2_eq_square field_simps)
      thus ?thesis
        by (simp add: real_sqrt_mult)
    qed
    show ?thesis
      using \<open>is_poincare_line_cmat H1\<close> \<open>is_poincare_line_cmat H2\<close>
      using * k
      apply (simp add: Let_def)
      apply safe
      apply (simp add: power2_eq_square rel_set_def)
      apply safe
         apply (cases "k > 0")
          apply (rule_tac x="(cor k)\<^sup>2" in exI)
          apply (subst **)
          apply (simp add: power2_eq_square field_simps)
         apply (erule notE, rule_tac x="(cor k)\<^sup>2" in exI)
         apply (subst **)
         apply (simp add: power2_eq_square field_simps)
        apply (cases "k > 0")
        apply (erule notE, rule_tac x="(cor k)\<^sup>2" in exI)
        apply (subst **)
        apply (simp add: power2_eq_square field_simps)
        apply (rule_tac x="(cor k)\<^sup>2" in exI)
        apply (subst **)
        apply (simp add: power2_eq_square field_simps)
       apply (cases "k > 0")
        apply (rule_tac x="(cor k)\<^sup>2" in exI)
        apply (subst **)
        apply (simp add: power2_eq_square field_simps)
       apply (erule notE, rule_tac x="(cor k)\<^sup>2" in exI)
       apply (subst **)
       apply (simp add: power2_eq_square field_simps)
      apply (cases "k > 0")
       apply (erule notE, rule_tac x="(cor k)\<^sup>2" in exI)
       apply (subst **)
       apply (simp add: power2_eq_square field_simps)
      apply (rule_tac x="(cor k)\<^sup>2" in exI)
      apply (subst **)
      apply (simp add: power2_eq_square field_simps)
      done
  next
    case False
    hence "\<not> is_poincare_line_cmat H2"
      using k * hermitean_mult_real[of H1 k] hh
      by (auto simp add: power2_eq_square)
    have "rel_set (\<approx>\<^sub>v) {(- 1, 1), (1, 1)} {(- 1, 1), (1, 1)}"
      by (simp add: rel_set_def)
    thus ?thesis
      using \<open>\<not> is_poincare_line_cmat H1\<close> \<open>\<not> is_poincare_line_cmat H2\<close>
      using *
      apply (simp add: Let_def)
      apply safe
      done
  qed
qed

text \<open>Correctness of the calculation\<close>

text\<open>We show that for every h-line its two calculated ideal points are different and are on the
intersection of that line and the unit circle.\<close>

text \<open>Calculated ideal points are on the unit circle\<close>

lemma calc_ideal_point_1_unit:
  assumes "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
  assumes "(z1, z2) = calc_ideal_point1_cvec A B"
  shows "z1 * cnj z1 = z2 * cnj z2"
proof-
  let ?discr = "Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2)"
  have "?discr > 0"
    using assms
    by (simp add: cmod_power2)
  have "(B*(-A - \<i>*sqrt(?discr))) * cnj (B*(-A - \<i>*sqrt(?discr))) = (B * cnj B) * (A\<^sup>2 + cor (abs ?discr))"
    using \<open>is_real A\<close> eq_cnj_iff_real[of A]
    by (simp add: field_simps power2_eq_square)
  also have "... = (B * cnj B) * (cmod B)\<^sup>2"
    using \<open>?discr > 0\<close>
    using assms
    using complex_of_real_Re[of "(cmod B)\<^sup>2 - (Re A)\<^sup>2"] complex_of_real_Re[of A] \<open>is_real A\<close>
    by (simp add: power2_eq_square)
  also have "... = (cmod B)\<^sup>2 * cnj ((cmod B)\<^sup>2)"
    using complex_cnj_complex_of_real complex_mult_cnj_cmod
    by presburger
  finally show ?thesis
    using assms
    by simp
qed

lemma calc_ideal_point_2_unit:
  assumes "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
  assumes "(z1, z2) = calc_ideal_point2_cvec A B"
  shows "z1 * cnj z1 = z2 * cnj z2"
proof-
  let ?discr = "Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2)"
  have "?discr > 0"
    using assms
    by (simp add: cmod_power2)
  have "(B*(-A + \<i>*sqrt(?discr))) * cnj (B*(-A + \<i>*sqrt(?discr))) = (B * cnj B) * (A\<^sup>2 + cor (abs ?discr))"
    using \<open>is_real A\<close> eq_cnj_iff_real[of A]
    by (simp add: field_simps power2_eq_square)
  also have "... = (B * cnj B) * (cmod B)\<^sup>2"
    using \<open>?discr > 0\<close>
    using assms
    using complex_of_real_Re[of "(cmod B)\<^sup>2 - (Re A)\<^sup>2"] complex_of_real_Re[of A] \<open>is_real A\<close>
    by (simp add: power2_eq_square)
  also have "... = (cmod B)\<^sup>2 * cnj ((cmod B)\<^sup>2)"
    using complex_cnj_complex_of_real complex_mult_cnj_cmod
    by presburger
  finally show ?thesis
    using assms
    by simp
qed

lemma calc_ideal_points_on_unit_circle:
  shows "\<forall> z \<in> calc_ideal_points H. z \<in> circline_set unit_circle"
  unfolding circline_set_def
  apply simp
proof (transfer, transfer)
  fix H
  assume hh: "hermitean H \<and> H \<noteq> mat_zero"
  obtain A B C D where *: "H = (A, B, C, D)"
    by (cases H, auto)
  have "\<forall> (z1, z2) \<in> calc_ideal_points_cmat_cvec H. z1 * cnj z1 = z2 * cnj z2"
    using hermitean_elems[of A B C D]
    unfolding calc_ideal_points_cmat_cvec_def
    using calc_ideal_point_1_unit[of A B]
    using calc_ideal_point_2_unit[of A B]
    using hh *
    apply (cases "calc_ideal_point1_cvec A B", cases "calc_ideal_point2_cvec A B")
    apply (auto simp add: Let_def simp del: calc_ideal_point1_cvec_def calc_ideal_point2_cvec_def)
    done
  thus "Ball (calc_ideal_points_cmat_cvec H) (on_circline_cmat_cvec unit_circle_cmat)"
    using on_circline_cmat_cvec_unit
    by (auto simp del: on_circline_cmat_cvec_def calc_ideal_points_cmat_cvec_def)
qed

text \<open>Calculated ideal points are on the h-line\<close>

lemma calc_ideal_point1_sq:
  assumes "(z1, z2) = calc_ideal_point1_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
  shows "z1 * cnj z1 + z2 * cnj z2 = 2 * (B * cnj B)\<^sup>2"
proof-
  let ?discr = "Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2)"
  have "?discr > 0"
    using assms
    by (simp add: cmod_power2)
  have "z1 * cnj z1 = (B * cnj B) * (-A + \<i>*sqrt(?discr))*(-A - \<i>*sqrt(?discr))"
    using assms eq_cnj_iff_real[of A]
    by (simp)
  also have "... = (B * cnj B) * (A\<^sup>2 + ?discr)"
    using complex_of_real_Re[of A] \<open>is_real A\<close> \<open>?discr > 0\<close>
    by (simp add: power2_eq_square field_simps)
  finally
  have "z1 * cnj z1 = (B * cnj B)\<^sup>2"
    using complex_of_real_Re[of "(cmod B)\<^sup>2 - (Re A)\<^sup>2"] complex_of_real_Re[of A] \<open>is_real A\<close>
    using complex_mult_cnj_cmod[of B]
    by (simp add: power2_eq_square)
  moreover
  have "z2 * cnj z2 = (B * cnj B)\<^sup>2"
    using assms
    by simp
  ultimately
  show ?thesis
    by simp
qed

lemma calc_ideal_point2_sq:
  assumes "(z1, z2) = calc_ideal_point2_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
  shows "z1 * cnj z1 + z2 * cnj z2 = 2 * (B * cnj B)\<^sup>2"
proof-
  let ?discr = "Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2)"
  have "?discr > 0"
    using assms
    by (simp add: cmod_power2)
  have "z1 * cnj z1 = (B * cnj B) * (-A + \<i>*sqrt(?discr))*(-A - \<i>*sqrt(?discr))"
    using assms eq_cnj_iff_real[of A]
    by simp
  also have "... = (B * cnj B) * (A\<^sup>2 + ?discr)"
    using complex_of_real_Re[of A] \<open>is_real A\<close> \<open>?discr > 0\<close>
    by (simp add: power2_eq_square field_simps)
  finally
  have "z1 * cnj z1 = (B * cnj B)\<^sup>2"
    using complex_of_real_Re[of "(cmod B)\<^sup>2 - (Re A)\<^sup>2"] complex_of_real_Re[of A] \<open>is_real A\<close>
    using complex_mult_cnj_cmod[of B]
    by (simp add: power2_eq_square)
  moreover
  have "z2 * cnj z2 = (B * cnj B)\<^sup>2"
    using assms
    by simp
  ultimately
  show ?thesis
    by simp
qed

lemma calc_ideal_point1_mix:
  assumes "(z1, z2) = calc_ideal_point1_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
  shows "B * cnj z1 * z2 + cnj B * z1 * cnj z2 = - 2 * A * (B * cnj B)\<^sup>2 "
proof-
  have "B*cnj z1 + cnj B*z1 = -2*A*B*cnj B"
    using assms eq_cnj_iff_real[of A]
    by (simp, simp add: field_simps)
  moreover
  have "cnj z2 = z2"
    using assms
    by simp
  hence "B*cnj z1*z2 + cnj B*z1*cnj z2 = (B*cnj z1 + cnj B*z1)*z2"
    by (simp add: field_simps)
  ultimately
  have "B*cnj z1*z2 + cnj B*z1*cnj z2 = -2*A*(B* cnj B)*z2"
    by simp
  also have "\<dots> = -2*A*(B * cnj B)\<^sup>2"
    using assms
    using complex_mult_cnj_cmod[of B]
    by (simp add: power2_eq_square)
  finally
  show ?thesis
    .
qed

lemma calc_ideal_point2_mix:
  assumes "(z1, z2) = calc_ideal_point2_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
  shows "B * cnj z1 * z2 + cnj B * z1 * cnj z2 = - 2 * A * (B * cnj B)\<^sup>2 "
proof-
  have "B*cnj z1 + cnj B*z1 = -2*A*B*cnj B"
    using assms eq_cnj_iff_real[of A]
    by (simp, simp add: field_simps)
  moreover
  have "cnj z2 = z2"
    using assms
    by simp
  hence "B*cnj z1*z2 + cnj B*z1*cnj z2 = (B*cnj z1 + cnj B*z1)*z2"
    by (simp add: field_simps)
  ultimately
  have "B*cnj z1*z2 + cnj B*z1*cnj z2 = -2*A*(B* cnj B)*z2"
    by simp
  also have "\<dots> = -2*A*(B * cnj B)\<^sup>2"
    using assms
    using complex_mult_cnj_cmod[of B]
    by (simp add: power2_eq_square)
  finally
  show ?thesis
    .
qed

lemma calc_ideal_point1_on_circline:
  assumes "(z1, z2) = calc_ideal_point1_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
  shows "A*z1*cnj z1 + B*cnj z1*z2 + cnj B*z1*cnj z2 + A*z2*cnj z2 = 0" (is "?lhs = 0")
proof-
  have "?lhs = A * (z1 * cnj z1 + z2 * cnj z2) + (B * cnj z1 * z2 + cnj B * z1 * cnj z2)"
    by (simp add: field_simps)
  also have "... = 2*A*(B*cnj B)\<^sup>2 + (-2*A*(B*cnj B)\<^sup>2)"
    using calc_ideal_point1_sq[OF assms]
    using calc_ideal_point1_mix[OF assms]
    by simp
  finally
  show ?thesis
    by simp
qed

lemma calc_ideal_points_on_circline:
  assumes "is_poincare_line H"
  shows "\<forall> z \<in> calc_ideal_points H. z \<in> circline_set H"
  using assms
  unfolding circline_set_def
  apply simp
proof (transfer, transfer)
  fix H
  assume hh: "hermitean H \<and> H \<noteq> mat_zero"
  obtain A B C D where *: "H = (A, B, C, D)"
    by (cases H, auto)
  obtain z11 z12 z21 z22 where **: "(z11, z12) = calc_ideal_point1_cvec A B" "(z21, z22) = calc_ideal_point2_cvec A B"
    by (cases "calc_ideal_point1_cvec A B", cases "calc_ideal_point2_cvec A B") auto

  assume "is_poincare_line_cmat H"
  hence "\<forall> (z1, z2) \<in> calc_ideal_points_cmat_cvec H. A*z1*cnj z1 + B*cnj z1*z2 + C*z1*cnj z2 + D*z2*cnj z2 = 0"
    using * ** hh
    using hermitean_elems[of A B C D]
    using calc_ideal_point1_on_circline[of z11 z12 A B]
    using calc_ideal_point2_on_circline[of z21 z22 A B]
    by (auto simp del: calc_ideal_point1_cvec_def calc_ideal_point2_cvec_def)
  thus "Ball (calc_ideal_points_cmat_cvec H) (on_circline_cmat_cvec H)"
    using on_circline_cmat_cvec_circline_equation *
    by (auto simp del: on_circline_cmat_cvec_def calc_ideal_points_cmat_cvec_def simp add: field_simps)
qed

text \<open>Calculated ideal points of an h-line are different\<close>

lemma calc_ideal_points_cvec_different [simp]:
  assumes "(cmod B)\<^sup>2 > (cmod A)\<^sup>2" "is_real A"
  shows "\<not> (calc_ideal_point1_cvec A B \<approx>\<^sub>v calc_ideal_point2_cvec A B)"
  using assms
  by (auto) (auto simp add: cmod_def)

lemma calc_ideal_points_different:
  assumes "is_poincare_line H"
  shows  "\<exists> i1 \<in> (calc_ideal_points H). \<exists> i2 \<in> (calc_ideal_points H). i1 \<noteq> i2"
  using assms
proof (transfer, transfer)
  fix H
  assume hh: "hermitean H \<and> H \<noteq> mat_zero" "is_poincare_line_cmat H"
  obtain A B C D where *: "H = (A, B, C, D)"
    by (cases H, auto)
  hence "is_real A" using hh hermitean_elems by auto
  thus "\<exists>i1\<in>calc_ideal_points_cmat_cvec H. \<exists>i2\<in>calc_ideal_points_cmat_cvec H. \<not> i1 \<approx>\<^sub>v i2"
    using * hh calc_ideal_points_cvec_different[of A B]
    apply (rule_tac x="calc_ideal_point1_cvec A B" in bexI)
    apply (rule_tac x="calc_ideal_point2_cvec A B" in bexI)
    by auto
qed

lemma two_calc_ideal_points [simp]:
  assumes "is_poincare_line H"
  shows "card (calc_ideal_points H) = 2"
proof-
  have  "\<exists> x \<in> calc_ideal_points H. \<exists> y \<in> calc_ideal_points H. \<forall> z \<in> calc_ideal_points H. z = x \<or> z = y"
    by (transfer, transfer, case_tac H, simp del: calc_ideal_point1_cvec_def calc_ideal_point2_cvec_def)
  then obtain x y where *: "calc_ideal_points H = {x, y}"
    by auto
  moreover
  have "x \<noteq> y"
    using calc_ideal_points_different[OF assms] *
    by auto
  ultimately
  show ?thesis
    by auto
qed

subsubsection \<open>Ideal points\<close>

text \<open>Next we give a genuine definition of ideal points -- these are the intersections of the h-line with the unit circle\<close>

definition ideal_points :: "circline \<Rightarrow> complex_homo set" where
  "ideal_points H = circline_intersection H unit_circle"

text \<open>Ideal points are on the unit circle and on the h-line\<close>
lemma ideal_points_on_unit_circle:
  shows "\<forall> z \<in> ideal_points H. z \<in> circline_set unit_circle"
  unfolding ideal_points_def circline_intersection_def circline_set_def
  by simp

lemma ideal_points_on_circline:
  shows "\<forall> z \<in> ideal_points H. z \<in> circline_set H"
  unfolding ideal_points_def circline_intersection_def circline_set_def
  by simp

text \<open>For each h-line there are exactly two ideal points\<close>
lemma two_ideal_points:
  assumes "is_poincare_line H"
  shows "card (ideal_points H) = 2"
proof-
  have "H \<noteq> unit_circle"
    using assms not_is_poincare_line_unit_circle
    by auto
  let ?int = "circline_intersection H unit_circle"
  obtain i1 i2 where "i1 \<in> ?int" "i2 \<in> ?int" "i1 \<noteq> i2"
    using calc_ideal_points_on_circline[OF assms]
    using calc_ideal_points_on_unit_circle[of H]
    using calc_ideal_points_different[OF assms]
    unfolding circline_intersection_def circline_set_def
    by auto
  thus ?thesis
    unfolding ideal_points_def
    using circline_intersection_at_most_2_points[OF \<open>H \<noteq> unit_circle\<close>]
    using card_geq_2_iff_contains_2_elems[of ?int]
    by auto
qed

text \<open>They are exactly the two points that our calculation finds\<close>
lemma ideal_points_unique:
  assumes "is_poincare_line H"
  shows "ideal_points H = calc_ideal_points H"
proof-
  have "calc_ideal_points H \<subseteq> ideal_points H"
    using calc_ideal_points_on_circline[OF assms]
    using calc_ideal_points_on_unit_circle[of H]
    unfolding ideal_points_def circline_intersection_def circline_set_def
    by auto
  moreover
  have "H \<noteq> unit_circle"
    using not_is_poincare_line_unit_circle assms
    by auto
  hence "finite (ideal_points H)"
    using circline_intersection_at_most_2_points[of H unit_circle]
    unfolding ideal_points_def
    by auto
  ultimately
  show ?thesis
    using card_subset_eq[of "ideal_points H" "calc_ideal_points H"]
    using two_calc_ideal_points[OF assms]
    using two_ideal_points[OF assms]
    by auto
qed

text \<open>For each h-line we can obtain two different ideal points\<close>
lemma obtain_ideal_points:
  assumes "is_poincare_line H"
  obtains i1 i2 where "i1 \<noteq> i2" "ideal_points H = {i1, i2}"
  using two_ideal_points[OF assms] card_eq_2_iff_doubleton[of "ideal_points H"]
  by blast

text \<open>Ideal points of each h-line constructed from two points in the disc are different than those two points\<close>
lemma ideal_points_different:
  assumes "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
  assumes "ideal_points (poincare_line u v) = {i1, i2}"
  shows "i1 \<noteq> i2" "u \<noteq> i1" "u \<noteq> i2" "v \<noteq> i1" "v \<noteq> i2"
proof-
  have "i1 \<in> ocircline_set ounit_circle" "i2 \<in> ocircline_set ounit_circle"
    using assms(3) assms(4) ideal_points_on_unit_circle is_poincare_line_poincare_line
    by fastforce+
  thus "u \<noteq> i1" "u \<noteq> i2" "v \<noteq> i1" "v \<noteq> i2"
    using assms(1-2)
    using disc_inter_ocircline_set[of ounit_circle]
    unfolding unit_disc_def
    by auto
  show "i1 \<noteq> i2"
    using assms
    by (metis doubleton_eq_iff is_poincare_line_poincare_line obtain_ideal_points)
qed

text \<open>H-line is uniquely determined by its ideal points\<close>
lemma ideal_points_line_unique:
  assumes "is_poincare_line H" "ideal_points H = {i1, i2}"
  shows "H = poincare_line i1 i2"
  by (smt assms(1) assms(2) calc_ideal_points_on_unit_circle circline_set_def ex_poincare_line_points ideal_points_different(1) ideal_points_on_circline ideal_points_unique insertI1 insert_commute inversion_unit_circle mem_Collect_eq unique_poincare_line_general)

text \<open>Ideal points of some special h-lines\<close>

text\<open>Ideal points of @{term x_axis}\<close>
lemma ideal_points_x_axis
  [simp]: "ideal_points x_axis = {of_complex (-1), of_complex 1}"
proof (subst ideal_points_unique, simp)
  have "calc_ideal_points_clmat_hcoords x_axis_clmat = {of_complex_hcoords (- 1), of_complex_hcoords 1}"
    by transfer auto
  thus "calc_ideal_points x_axis = {of_complex (- 1), of_complex 1}"
    by (simp add: calc_ideal_points.abs_eq of_complex.abs_eq x_axis_def)
qed

text \<open>Ideal points are proportional vectors only if h-line is a line segment passing trough zero\<close>

  have "i1 \<in> circline_set unit_circle" "i2 \<in> circline_set unit_circle"
    using assms calc_ideal_points_on_unit_circle ideal_points_unique
    by blast+

  hence "cmod (cor k) = 1"
    using `to_complex i1 = cor k * to_complex i2`
    by (metis (mono_tags, lifting) circline_set_unit_circle imageE mem_Collect_eq mult.right_neutral norm_mult to_complex_of_complex unit_circle_set_def)
  hence "k = -1"
    using `to_complex i1 = cor k * to_complex i2` `i1 \<noteq> i2`
    using \<open>i1 \<in> circline_set unit_circle\<close> \<open>i2 \<in> circline_set unit_circle\<close>
    by (metis (no_types, lifting) circline_set_unit_circle complex_cnj_complex_of_real complex_mult_cnj_cmod cor_neg_one imageE mult_cancel_right2 norm_one of_real_eq_iff square_eq_1_iff to_complex_of_complex)

  have "\<forall> i1 \<in> calc_ideal_points H. \<forall> i2 \<in> calc_ideal_points H. is_poincare_line H \<and> i1 \<noteq> i2 \<and> to_complex i1 = - to_complex i2 \<longrightarrow>
           0\<^sub>h \<in> circline_set H"
    unfolding circline_set_def
  proof (simp, transfer, transfer, safe)
    fix A B C D i11 i12 i21 i22 k
    assume H:"hermitean (A, B, C, D)" "(A, B, C, D) \<noteq> mat_zero"
    assume line: "is_poincare_line_cmat (A, B, C, D)"
    assume i1: "(i11, i12) \<in> calc_ideal_points_cmat_cvec (A, B, C, D)"
    assume i2:"(i21, i22) \<in> calc_ideal_points_cmat_cvec (A, B, C, D)"
    assume "\<not> (i11, i12) \<approx>\<^sub>v (i21, i22)"
    assume opposite: "to_complex_cvec (i11, i12) = - to_complex_cvec (i21, i22)"

    let ?discr =  "sqrt ((cmod B)\<^sup>2 - (Re D)\<^sup>2)"
    let ?den = "(cmod B)\<^sup>2"
    let ?i1 = "B * (- D - \<i> * ?discr)"
    let ?i2 = "B * (- D + \<i> * ?discr)"

    have "i11 = ?i1 \<or> i11 = ?i2" "i12 = ?den"
      "i21 = ?i1 \<or> i21 = ?i2" "i22 = ?den"
      using i1 i2 H line
      by (auto split: if_split_asm)
    hence i: "i11 = ?i1 \<and> i21 = ?i2 \<or> i11 = ?i2 \<and> i21 = ?i1"
      using `\<not> (i11, i12) \<approx>\<^sub>v (i21, i22)`
      by auto

    have "?den \<noteq> 0"
      using line
      by auto

    hence "i11 = - i21"
      using opposite `i12 = ?den` `i22 = ?den`
      by (simp add: nonzero_neg_divide_eq_eq2)

    hence "?i1 = - ?i2"
      using i
      by (metis add.inverse_inverse)

    hence "D = 0"
      using `?den \<noteq> 0`
      by (simp add: field_simps)

    thus "on_circline_cmat_cvec (A, B, C, D) 0\<^sub>v"
      by (simp add: vec_cnj_def)
  qed

  thus ?thesis
    using assms `k = -1`
    using calc_ideal_points_different ideal_points_unique
    by fastforce
qed

text \<open>Transformations of ideal points\<close>

text \<open>Möbius transformations that fix the unit disc when acting on h-lines map their ideal points to ideal points.\<close>
lemma ideal_points_moebius_circline [simp]:
  assumes  "unit_circle_fix M" "is_poincare_line H"
  shows "ideal_points (moebius_circline M H) = (moebius_pt M) ` (ideal_points H)" (is "?I' = ?M ` ?I")
proof-
  obtain i1 i2 where *: "i1 \<noteq> i2" "?I = {i1, i2}"
    using assms(2)
    by (rule obtain_ideal_points)
  let ?Mi1 = "?M i1" and ?Mi2 = "?M i2"
  have "?Mi1 \<in> ?M ` (circline_set H)"
       "?Mi2 \<in> ?M ` (circline_set H)"
       "?Mi1 \<in> ?M ` (circline_set unit_circle)"
       "?Mi2 \<in> ?M ` (circline_set unit_circle)"
    using *
    unfolding ideal_points_def circline_intersection_def circline_set_def
    by blast+
  hence "?Mi1 \<in> ?I'"
        "?Mi2 \<in> ?I'"
    using unit_circle_fix_iff[of M] assms
    unfolding ideal_points_def circline_intersection_def circline_set_def
    by (metis mem_Collect_eq moebius_circline)+
  moreover
  have "?Mi1 \<noteq> ?Mi2"
    using bij_moebius_pt[of M] *
    using moebius_pt_invert by blast
  moreover
  have "is_poincare_line (moebius_circline M H)"
    using assms unit_circle_fix_preserve_is_poincare_line
    by simp
  ultimately
  have "?I' = {?Mi1, ?Mi2}"
    using two_ideal_points[of "moebius_circline M H"]
    using card_eq_2_doubleton[of ?I' ?Mi1 ?Mi2]
    by simp
  thus ?thesis
    using *(2)
    by auto
qed

lemma ideal_points_poincare_line_moebius [simp]:
  assumes "unit_disc_fix M"  "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
  assumes "ideal_points (poincare_line u v) = {i1, i2}"
  shows "ideal_points (poincare_line (moebius_pt M u) (moebius_pt M v)) = {moebius_pt M i1, moebius_pt M i2}"
  using assms
  by auto

text \<open>Conjugation also maps ideal points to ideal points\<close>
lemma ideal_points_conjugate [simp]:
  assumes "is_poincare_line H"
  shows "ideal_points (conjugate_circline H) = conjugate ` (ideal_points H)" (is "?I' = ?M ` ?I")
proof-
  obtain i1 i2 where *: "i1 \<noteq> i2" "?I = {i1, i2}"
    using assms
    by (rule obtain_ideal_points)
  let ?Mi1 = "?M i1" and ?Mi2 = "?M i2"
  have "?Mi1 \<in> ?M ` (circline_set H)"
       "?Mi2 \<in> ?M ` (circline_set H)"
       "?Mi1 \<in> ?M ` (circline_set unit_circle)"
       "?Mi2 \<in> ?M ` (circline_set unit_circle)"
    using *
    unfolding ideal_points_def circline_intersection_def circline_set_def
    by blast+
  hence "?Mi1 \<in> ?I'"
        "?Mi2 \<in> ?I'"
    unfolding ideal_points_def circline_intersection_def circline_set_def
    using circline_set_conjugate_circline circline_set_def conjugate_unit_circle_set
    by blast+
  moreover
  have "?Mi1 \<noteq> ?Mi2"
    using \<open>i1 \<noteq> i2\<close>
    by (auto simp add: conjugate_inj)
  moreover
  have "is_poincare_line (conjugate_circline H)"
    using assms
    by simp
  ultimately
  have "?I' = {?Mi1, ?Mi2}"
    using two_ideal_points[of "conjugate_circline H"]
    using card_eq_2_doubleton[of ?I' ?Mi1 ?Mi2]
    by simp
  thus ?thesis
    using *(2)
    by auto
qed

lemma ideal_points_poincare_line_conjugate [simp]:
  assumes"u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
  assumes "ideal_points (poincare_line u v) = {i1, i2}"
  shows "ideal_points (poincare_line (conjugate u) (conjugate v)) = {conjugate i1, conjugate i2}"
  using assms
  by auto

end


theory rationalPowers
  imports Complex_Main sqrt2Irrational
begin

theorem ratPow:
  shows "\<exists>a b. (a\<notin>\<rat> \<and> b\<notin>\<rat>) \<longrightarrow> a powr b \<in> \<rat>"
proof cases
  assume inRat: "sqrt (real 2) powr sqrt (real 2) \<in> \<rat>"
  show ?thesis using inRat sqrt_2_irrational Rats_1 by blast
next
  assume notRat: "\<not>(sqrt (real 2) powr sqrt (real 2) \<in> \<rat>)"
  show ?thesis using notRat sqrt_2_irrational Rats_1 by blast
qed
end


(*  Title:      HOL/Cardinals/Wellorder_Embedding.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Well-order embeddings.
*)

section \<open>Well-Order Embeddings\<close>

theory Wellorder_Embedding
imports BNF_Wellorder_Embedding Fun_More Wellorder_Relation
begin

subsection \<open>Auxiliaries\<close>

lemma UNION_bij_betw_ofilter:
assumes WELL: "Well_order r" and
        OF: "\<And> i. i \<in> I \<Longrightarrow> ofilter r (A i)" and
       BIJ: "\<And> i. i \<in> I \<Longrightarrow> bij_betw f (A i) (A' i)"
shows "bij_betw f (\<Union>i \<in> I. A i) (\<Union>i \<in> I. A' i)"
proof-
  have "wo_rel r" using WELL by (simp add: wo_rel_def)
  hence "\<And> i j. \<lbrakk>i \<in> I; j \<in> I\<rbrakk> \<Longrightarrow> A i \<le> A j \<or> A j \<le> A i"
  using wo_rel.ofilter_linord[of r] OF by blast
  with WELL BIJ show ?thesis
  by (auto simp add: bij_betw_UNION_chain)
qed

subsection \<open>(Well-order) embeddings, strict embeddings, isomorphisms and order-compatible
functions\<close>

lemma embed_halfcong:
assumes EQ: "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a" and
        EMB: "embed r r' f"
shows "embed r r' g"
proof(unfold embed_def, auto)
  fix a assume *: "a \<in> Field r"
  hence "bij_betw f (under r a) (under r' (f a))"
  using EMB unfolding embed_def by simp
  moreover
  {have "under r a \<le> Field r"
   by (auto simp add: under_Field)
   hence "\<And> b. b \<in> under r a \<Longrightarrow> f b = g b"
   using EQ by blast
  }
  moreover have "f a = g a" using * EQ by auto
  ultimately show "bij_betw g (under r a) (under r' (g a))"
  using bij_betw_cong[of "under r a" f g "under r' (f a)"] by auto
qed

lemma embed_cong[fundef_cong]:
assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
shows "embed r r' f = embed r r' g"
using assms embed_halfcong[of r f g r']
            embed_halfcong[of r g f r'] by auto

lemma embedS_cong[fundef_cong]:
assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
shows "embedS r r' f = embedS r r' g"
unfolding embedS_def using assms
embed_cong[of r f g r'] bij_betw_cong[of "Field r" f g "Field r'"] by blast

lemma iso_cong[fundef_cong]:
assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
shows "iso r r' f = iso r r' g"
unfolding iso_def using assms
embed_cong[of r f g r'] bij_betw_cong[of "Field r" f g "Field r'"] by blast

lemma id_compat: "compat r r id"
by(auto simp add: id_def compat_def)

lemma comp_compat:
"\<lbrakk>compat r r' f; compat r' r'' f'\<rbrakk> \<Longrightarrow> compat r r'' (f' o f)"
by(auto simp add: comp_def compat_def)

corollary one_set_greater:
"(\<exists>f::'a \<Rightarrow> 'a'. f ` A \<le> A' \<and> inj_on f A) \<or> (\<exists>g::'a' \<Rightarrow> 'a. g ` A' \<le> A \<and> inj_on g A')"
proof-
  obtain r where "well_order_on A r" by (fastforce simp add: well_order_on)
  hence 1: "A = Field r \<and> Well_order r"
  using well_order_on_Well_order by auto
  obtain r' where 2: "well_order_on A' r'" by (fastforce simp add: well_order_on)
  hence 2: "A' = Field r' \<and> Well_order r'"
  using well_order_on_Well_order by auto
  hence "(\<exists>f. embed r r' f) \<or> (\<exists>g. embed r' r g)"
  using 1 2 by (auto simp add: wellorders_totally_ordered)
  moreover
  {fix f assume "embed r r' f"
   hence "f`A \<le> A' \<and> inj_on f A"
   using 1 2 by (auto simp add: embed_Field embed_inj_on)
  }
  moreover
  {fix g assume "embed r' r g"
   hence "g`A' \<le> A \<and> inj_on g A'"
   using 1 2 by (auto simp add: embed_Field embed_inj_on)
  }
  ultimately show ?thesis by blast
qed

corollary one_type_greater:
"(\<exists>f::'a \<Rightarrow> 'a'. inj f) \<or> (\<exists>g::'a' \<Rightarrow> 'a. inj g)"
using one_set_greater[of UNIV UNIV] by auto

subsection \<open>Uniqueness of embeddings\<close>

lemma comp_embedS:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
        and  EMB: "embedS r r' f" and EMB': "embedS r' r'' f'"
shows "embedS r r'' (f' o f)"
proof-
  have "embed r' r'' f'" using EMB' unfolding embedS_def by simp
  thus ?thesis using assms by (auto simp add: embedS_comp_embed)
qed

lemma iso_iff4:
assumes WELL: "Well_order r"  and WELL': "Well_order r'"
shows "iso r r' f = (embed r r' f \<and> embed r' r (inv_into (Field r) f))"
using assms embed_bothWays_iso
by(unfold iso_def, auto simp add: inv_into_Field_embed_bij_betw)

lemma embed_embedS_iso:
"embed r r' f = (embedS r r' f \<or> iso r r' f)"
unfolding embedS_def iso_def by blast

lemma not_embedS_iso:
"\<not> (embedS r r' f \<and> iso r r' f)"
unfolding embedS_def iso_def by blast

lemma embed_embedS_iff_not_iso:
assumes "embed r r' f"
shows "embedS r r' f = (\<not> iso r r' f)"
using assms unfolding embedS_def iso_def by blast

lemma iso_inv_into:
assumes WELL: "Well_order r" and ISO: "iso r r' f"
shows "iso r' r (inv_into (Field r) f)"
using assms unfolding iso_def
using bij_betw_inv_into inv_into_Field_embed_bij_betw by blast

lemma embedS_or_iso:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "(\<exists>g. embedS r r' g) \<or> (\<exists>h. embedS r' r h) \<or> (\<exists>f. iso r r' f)"
proof-
  {fix f assume *: "embed r r' f"
   {assume "bij_betw f (Field r) (Field r')"
    hence ?thesis using * by (auto simp add: iso_def)
   }
   moreover
   {assume "\<not> bij_betw f (Field r) (Field r')"
    hence ?thesis using * by (auto simp add: embedS_def)
   }
   ultimately have ?thesis by auto
  }
  moreover
  {fix f assume *: "embed r' r f"
   {assume "bij_betw f (Field r') (Field r)"
    hence "iso r' r f" using * by (auto simp add: iso_def)
    hence "iso r r' (inv_into (Field r') f)"
    using WELL' by (auto simp add: iso_inv_into)
    hence ?thesis by blast
   }
   moreover
   {assume "\<not> bij_betw f (Field r') (Field r)"
    hence ?thesis using * by (auto simp add: embedS_def)
   }
   ultimately have ?thesis by auto
  }
  ultimately show ?thesis using WELL WELL'
  wellorders_totally_ordered[of r r'] by blast
qed

end


(*
Author:     Tobias Nipkow, Daniel Stüwe
Largely derived from AFP entry AVL.
*)

section "AVL Tree Implementation of Sets"

theory AVL_Set
imports
 Cmp
 Isin2
  "~~/src/HOL/Number_Theory/Fib"
begin

type_synonym 'a avl_tree = "('a,nat) tree"

text {* Invariant: *}

fun avl :: "'a avl_tree \<Rightarrow> bool" where
"avl Leaf = True" |
"avl (Node h l a r) =
 ((height l = height r \<or> height l = height r + 1 \<or> height r = height l + 1) \<and>
  h = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"

fun ht :: "'a avl_tree \<Rightarrow> nat" where
"ht Leaf = 0" |
"ht (Node h l a r) = h"

definition node :: "'a avl_tree \<Rightarrow> 'a \<Rightarrow> 'a avl_tree \<Rightarrow> 'a avl_tree" where
"node l a r = Node (max (ht l) (ht r) + 1) l a r"

definition balL :: "'a avl_tree \<Rightarrow> 'a \<Rightarrow> 'a avl_tree \<Rightarrow> 'a avl_tree" where
"balL l a r =
  (if ht l = ht r + 2 then
     case l of
       Node _ bl b br \<Rightarrow>
         if ht bl < ht br then
           case br of
             Node _ cl c cr \<Rightarrow> node (node bl b cl) c (node cr a r)
         else node bl b (node br a r)
   else node l a r)"

definition balR :: "'a avl_tree \<Rightarrow> 'a \<Rightarrow> 'a avl_tree \<Rightarrow> 'a avl_tree" where
"balR l a r =
   (if ht r = ht l + 2 then
      case r of
        Node _ bl b br \<Rightarrow>
          if ht bl > ht br then
            case bl of
              Node _ cl c cr \<Rightarrow> node (node l a cl) c (node cr b br)
          else node (node l a bl) b br
  else node l a r)"

fun insert :: "'a::linorder \<Rightarrow> 'a avl_tree \<Rightarrow> 'a avl_tree" where
"insert x Leaf = Node 1 Leaf x Leaf" |
"insert x (Node h l a r) = (case cmp x a of
   EQ \<Rightarrow> Node h l a r |
   LT \<Rightarrow> balL (insert x l) a r |
   GT \<Rightarrow> balR l a (insert x r))"

fun del_max :: "'a avl_tree \<Rightarrow> 'a avl_tree * 'a" where
"del_max (Node _ l a r) =
  (if r = Leaf then (l,a) else let (r',a') = del_max r in (balL l a r', a'))"

lemmas del_max_induct = del_max.induct[case_names Node Leaf]

fun del_root :: "'a avl_tree \<Rightarrow> 'a avl_tree" where
"del_root (Node h Leaf a r) = r" |
"del_root (Node h l a Leaf) = l" |
"del_root (Node h l a r) = (let (l', a') = del_max l in balR l' a' r)"

lemmas del_root_cases = del_root.cases[case_names Leaf_t Node_Leaf Node_Node]

fun delete :: "'a::linorder \<Rightarrow> 'a avl_tree \<Rightarrow> 'a avl_tree" where
"delete _ Leaf = Leaf" |
"delete x (Node h l a r) =
  (case cmp x a of
     EQ \<Rightarrow> del_root (Node h l a r) |
     LT \<Rightarrow> balR (delete x l) a r |
     GT \<Rightarrow> balL l a (delete x r))"

subsection {* Functional Correctness Proofs *}

text{* Very different from the AFP/AVL proofs *}

subsubsection "Proofs for insert"

lemma inorder_balL:
  "inorder (balL l a r) = inorder l @ a # inorder r"
by (auto simp: node_def balL_def split:tree.splits)

lemma inorder_balR:
  "inorder (balR l a r) = inorder l @ a # inorder r"
by (auto simp: node_def balR_def split:tree.splits)

theorem inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
by (induct t)
   (auto simp: ins_list_simps inorder_balL inorder_balR)

subsubsection "Proofs for delete"

lemma inorder_del_maxD:
  "\<lbrakk> del_max t = (t',a); t \<noteq> Leaf \<rbrakk> \<Longrightarrow>
   inorder t' @ [a] = inorder t"
by(induction t arbitrary: t' rule: del_max.induct)
  (auto simp: inorder_balL split: if_splits prod.splits tree.split)

lemma inorder_del_root:
  "inorder (del_root (Node h l a r)) = inorder l @ inorder r"
by(cases "Node h l a r" rule: del_root.cases)
  (auto simp: inorder_balL inorder_balR inorder_del_maxD split: if_splits prod.splits)

theorem inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder (delete x t) = del_list x (inorder t)"
by(induction t)
  (auto simp: del_list_simps inorder_balL inorder_balR
    inorder_del_root inorder_del_maxD split: prod.splits)

subsubsection "Overall functional correctness"

interpretation Set_by_Ordered
where empty = Leaf and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
qed (rule TrueI)+

subsection {* AVL invariants *}

text{* Essentially the AFP/AVL proofs *}

subsubsection {* Insertion maintains AVL balance *}

declare Let_def [simp]

lemma height_balL:
  "\<lbrakk> height l = height r + 2; avl l; avl r \<rbrakk> \<Longrightarrow>
   height (balL l a r) = height r + 2 \<or>
   height (balL l a r) = height r + 3"
by (cases l) (auto simp:node_def balL_def split:tree.split)

lemma height_balR:
  "\<lbrakk> height r = height l + 2; avl l; avl r \<rbrakk> \<Longrightarrow>
   height (balR l a r) = height l + 2 \<or>
   height (balR l a r) = height l + 3"
by (cases r) (auto simp add:node_def balR_def split:tree.split)

lemma [simp]: "height(node l a r) = max (height l) (height r) + 1"
by (simp add: node_def)

lemma avl_node:
  "\<lbrakk> avl l; avl r;
     height l = height r \<or> height l = height r + 1 \<or> height r = height l + 1
   \<rbrakk> \<Longrightarrow> avl(node l a r)"
by (auto simp add:max_def node_def)

lemma height_balL2:
  "\<lbrakk> avl l; avl r; height l \<noteq> height r + 2 \<rbrakk> \<Longrightarrow>
   height (balL l a r) = (1 + max (height l) (height r))"
by (cases l, cases r) (simp_all add: balL_def)

lemma height_balR2:
  "\<lbrakk> avl l;  avl r;  height r \<noteq> height l + 2 \<rbrakk> \<Longrightarrow>
   height (balR l a r) = (1 + max (height l) (height r))"
by (cases l, cases r) (simp_all add: balR_def)

lemma avl_balL:
  assumes "avl l" "avl r" and "height l = height r \<or> height l = height r + 1
    \<or> height r = height l + 1 \<or> height l = height r + 2"
  shows "avl(balL l a r)"
proof(cases l)
  case Leaf
  with assms show ?thesis by (simp add: node_def balL_def)
next
  case (Node ln ll lr lh)
  with assms show ?thesis
  proof(cases "height l = height r + 2")
    case True
    from True Node assms show ?thesis
      by (auto simp: balL_def intro!: avl_node split: tree.split) arith+
  next
    case False
    with assms show ?thesis by (simp add: avl_node balL_def)
  qed
qed

lemma avl_balR:
  assumes "avl l" and "avl r" and "height l = height r \<or> height l = height r + 1
    \<or> height r = height l + 1 \<or> height r = height l + 2"
  shows "avl(balR l a r)"
proof(cases r)
  case Leaf
  with assms show ?thesis by (simp add: node_def balR_def)
next
  case (Node rn rl rr rh)
  with assms show ?thesis
  proof(cases "height r = height l + 2")
    case True
      from True Node assms show ?thesis
        by (auto simp: balR_def intro!: avl_node split: tree.split) arith+
  next
    case False
    with assms show ?thesis by (simp add: balR_def avl_node)
  qed
qed

(* It appears that these two properties need to be proved simultaneously: *)

text{* Insertion maintains the AVL property: *}

theorem avl_insert_aux:
  assumes "avl t"
  shows "avl(insert x t)"
        "(height (insert x t) = height t \<or> height (insert x t) = height t + 1)"
using assms
proof (induction t)
  case (Node h l a r)
  case 1
  with Node show ?case
  proof(cases "x = a")
    case True
    with Node 1 show ?thesis by simp
  next
    case False
    with Node 1 show ?thesis
    proof(cases "x<a")
      case True
      with Node 1 show ?thesis by (auto simp add:avl_balL)
    next
      case False
      with Node 1 `x\<noteq>a` show ?thesis by (auto simp add:avl_balR)
    qed
  qed
  case 2
  from 2 Node show ?case
  proof(cases "x = a")
    case True
    with Node 1 show ?thesis by simp
  next
    case False
    with Node 1 show ?thesis
     proof(cases "x<a")
      case True
      with Node 2 show ?thesis
      proof(cases "height (insert x l) = height r + 2")
        case False with Node 2 `x < a` show ?thesis by (auto simp: height_balL2)
      next
        case True
        hence "(height (balL (insert x l) a r) = height r + 2) \<or>
          (height (balL (insert x l) a r) = height r + 3)" (is "?A \<or> ?B")
          using Node 2 by (intro height_balL) simp_all
        thus ?thesis
        proof
          assume ?A
          with 2 `x < a` show ?thesis by (auto)
        next
          assume ?B
          with True 1 Node(2) `x < a` show ?thesis by (simp) arith
        qed
      qed
    next
      case False
      with Node 2 show ?thesis
      proof(cases "height (insert x r) = height l + 2")
        case False
        with Node 2 `\<not>x < a` show ?thesis by (auto simp: height_balR2)
      next
        case True
        hence "(height (balR l a (insert x r)) = height l + 2) \<or>
          (height (balR l a (insert x r)) = height l + 3)"  (is "?A \<or> ?B")
          using Node 2 by (intro height_balR) simp_all
        thus ?thesis
        proof
          assume ?A
          with 2 `\<not>x < a` show ?thesis by (auto)
        next
          assume ?B
          with True 1 Node(4) `\<not>x < a` show ?thesis by (simp) arith
        qed
      qed
    qed
  qed
qed simp_all

subsubsection {* Deletion maintains AVL balance *}

lemma avl_del_max:
  assumes "avl x" and "x \<noteq> Leaf"
  shows "avl (fst (del_max x))" "height x = height(fst (del_max x)) \<or>
         height x = height(fst (del_max x)) + 1"
using assms
proof (induct x rule: del_max_induct)
  case (Node h l a r)
  case 1
  thus ?case using Node
    by (auto simp: height_balL height_balL2 avl_balL
      linorder_class.max.absorb1 linorder_class.max.absorb2
      split:prod.split)
next
  case (Node h l a r)
  case 2
  let ?r' = "fst (del_max r)"
  from `avl x` Node 2 have "avl l" and "avl r" by simp_all
  thus ?case using Node 2 height_balL[of l ?r' a] height_balL2[of l ?r' a]
    apply (auto split:prod.splits simp del:avl.simps) by arith+
qed auto

lemma avl_del_root:
  assumes "avl t" and "t \<noteq> Leaf"
  shows "avl(del_root t)"
using assms
proof (cases t rule:del_root_cases)
  case (Node_Node h lh ll ln lr n rh rl rn rr)
  let ?l = "Node lh ll ln lr"
  let ?r = "Node rh rl rn rr"
  let ?l' = "fst (del_max ?l)"
  from `avl t` and Node_Node have "avl ?r" by simp
  from `avl t` and Node_Node have "avl ?l" by simp
  hence "avl(?l')" "height ?l = height(?l') \<or>
         height ?l = height(?l') + 1" by (rule avl_del_max,simp)+
  with `avl t` Node_Node have "height ?l' = height ?r \<or> height ?l' = height ?r + 1
            \<or> height ?r = height ?l' + 1 \<or> height ?r = height ?l' + 2" by fastforce
  with `avl ?l'` `avl ?r` have "avl(balR ?l' (snd(del_max ?l)) ?r)"
    by (rule avl_balR)
  with Node_Node show ?thesis by (auto split:prod.splits)
qed simp_all

lemma height_del_root:
  assumes "avl t" and "t \<noteq> Leaf"
  shows "height t = height(del_root t) \<or> height t = height(del_root t) + 1"
using assms
proof (cases t rule: del_root_cases)
  case (Node_Node h lh ll ln lr n rh rl rn rr)
  let ?l = "Node lh ll ln lr"
  let ?r = "Node rh rl rn rr"
  let ?l' = "fst (del_max ?l)"
  let ?t' = "balR ?l' (snd(del_max ?l)) ?r"
  from `avl t` and Node_Node have "avl ?r" by simp
  from `avl t` and Node_Node have "avl ?l" by simp
  hence "avl(?l')"  by (rule avl_del_max,simp)
  have l'_height: "height ?l = height ?l' \<or> height ?l = height ?l' + 1" using `avl ?l` by (intro avl_del_max) auto
  have t_height: "height t = 1 + max (height ?l) (height ?r)" using `avl t` Node_Node by simp
  have "height t = height ?t' \<or> height t = height ?t' + 1" using  `avl t` Node_Node
  proof(cases "height ?r = height ?l' + 2")
    case False
    show ?thesis using l'_height t_height False by (subst  height_balR2[OF `avl ?l'` `avl ?r` False])+ arith
  next
    case True
    show ?thesis
    proof(cases rule: disjE[OF height_balR[OF True `avl ?l'` `avl ?r`, of "snd (del_max ?l)"]])
      case 1
      thus ?thesis using l'_height t_height True by arith
    next
      case 2
      thus ?thesis using l'_height t_height True by arith
    qed
  qed
  thus ?thesis using Node_Node by (auto split:prod.splits)
qed simp_all

text{* Deletion maintains the AVL property: *}

theorem avl_delete_aux:
  assumes "avl t"
  shows "avl(delete x t)" and "height t = (height (delete x t)) \<or> height t = height (delete x t) + 1"
using assms
proof (induct t)
  case (Node h l n r)
  case 1
  with Node show ?case
  proof(cases "x = n")
    case True
    with Node 1 show ?thesis by (auto simp:avl_del_root)
  next
    case False
    with Node 1 show ?thesis
    proof(cases "x<n")
      case True
      with Node 1 show ?thesis by (auto simp add:avl_balR)
    next
      case False
      with Node 1 `x\<noteq>n` show ?thesis by (auto simp add:avl_balL)
    qed
  qed
  case 2
  with Node show ?case
  proof(cases "x = n")
    case True
    with 1 have "height (Node h l n r) = height(del_root (Node h l n r))
      \<or> height (Node h l n r) = height(del_root (Node h l n r)) + 1"
      by (subst height_del_root,simp_all)
    with True show ?thesis by simp
  next
    case False
    with Node 1 show ?thesis
     proof(cases "x<n")
      case True
      show ?thesis
      proof(cases "height r = height (delete x l) + 2")
        case False with Node 1 `x < n` show ?thesis by(auto simp: balR_def)
      next
        case True
        hence "(height (balR (delete x l) n r) = height (delete x l) + 2) \<or>
          height (balR (delete x l) n r) = height (delete x l) + 3" (is "?A \<or> ?B")
          using Node 2 by (intro height_balR) auto
        thus ?thesis
        proof
          assume ?A
          with `x < n` Node 2 show ?thesis by(auto simp: balR_def)
        next
          assume ?B
          with `x < n` Node 2 show ?thesis by(auto simp: balR_def)
        qed
      qed
    next
      case False
      show ?thesis
      proof(cases "height l = height (delete x r) + 2")
        case False with Node 1 `\<not>x < n` `x \<noteq> n` show ?thesis by(auto simp: balL_def)
      next
        case True
        hence "(height (balL l n (delete x r)) = height (delete x r) + 2) \<or>
          height (balL l n (delete x r)) = height (delete x r) + 3" (is "?A \<or> ?B")
          using Node 2 by (intro height_balL) auto
        thus ?thesis
        proof
          assume ?A
          with `\<not>x < n` `x \<noteq> n` Node 2 show ?thesis by(auto simp: balL_def)
        next
          assume ?B
          with `\<not>x < n` `x \<noteq> n` Node 2 show ?thesis by(auto simp: balL_def)
        qed
      qed
    qed
  qed
qed simp_all

subsection \<open>Height-Size Relation\<close>

text \<open>By Daniel St\"uwe\<close>

fun fib_tree :: "nat \<Rightarrow> unit avl_tree" where
"fib_tree 0 = Leaf" |
"fib_tree (Suc 0) = Node 1 Leaf () Leaf" |
"fib_tree (Suc(Suc n)) = Node (Suc(Suc(n))) (fib_tree (Suc n)) () (fib_tree n)"

lemma [simp]: "ht (fib_tree h) = h"
by (induction h rule: "fib_tree.induct") auto

lemma [simp]: "height (fib_tree h) = h"
by (induction h rule: "fib_tree.induct") auto

lemma "avl(fib_tree h)"
by (induction h rule: "fib_tree.induct") auto

lemma fib_tree_size1: "size1 (fib_tree h) = fib (h+2)"
by (induction h rule: fib_tree.induct) auto

lemma height_invers[simp]:
  "(height t = 0) = (t = Leaf)"
  "avl t \<Longrightarrow> (height t = Suc h) = (\<exists> l a r . t = Node (Suc h) l a r)"
by (induction t) auto

lemma fib_Suc_lt: "fib n \<le> fib (Suc n)"
by (induction n rule: fib.induct) auto

lemma fib_mono: "n \<le> m \<Longrightarrow> fib n \<le> fib m"
proof (induction n arbitrary: m rule: fib.induct )
  case (2 m)
  thus ?case using fib_neq_0_nat[of m] by auto
next
  case (3 n m)
  from 3 obtain m' where "m = Suc (Suc m')"
    by (metis le_Suc_ex plus_nat.simps(2))
  thus ?case using 3(1)[of "Suc m'"] 3(2)[of m'] 3(3) by auto
qed simp

lemma size1_fib_tree_mono:
  assumes "n \<le> m"
  shows   "size1 (fib_tree n) \<le> size1 (fib_tree m)"
using fib_tree_size1 fib_mono[OF assms] fib_mono[of "Suc n"] add_le_mono assms by fastforce

lemma fib_tree_minimal: "avl t \<Longrightarrow> size1 (fib_tree (ht t)) \<le> size1 t"
proof (induction "ht t" arbitrary: t rule: fib_tree.induct)
  case (2 t)
  from 2 obtain l a r where "t = Node (Suc 0) l a r" by (cases t) auto
  with 2 show ?case by auto
next
  case (3 h t)
  note [simp] = 3(3)[symmetric]
  from 3 obtain l a r where [simp]: "t = Node (Suc (Suc h)) l a r" by (cases t) auto
  show ?case proof (cases rule: linorder_cases[of "ht l" "ht r"])
    case equal
    with 3(3,4) have ht: "ht l = Suc h" "ht r = Suc h" by auto
    with 3 have "size1 (fib_tree (ht l)) \<le> size1 l" by auto moreover
    from 3(1)[of r] 3(3,4) ht(2) have "size1 (fib_tree (ht r)) \<le> size1 r" by auto ultimately
    show ?thesis using ht size1_fib_tree_mono[of h "Suc h"] by auto
  next
    case greater
    with 3(3,4) have ht: "ht l = Suc h"  "ht r = h" by auto
    from ht 3(1,2,4) have "size1 (fib_tree (Suc h)) \<le> size1 l" by auto moreover
    from ht 3(1,2,4) have "size1 (fib_tree h) \<le> size1 r" by auto ultimately
    show ?thesis by auto
  next
    case less (* analogously *)
    with 3 have ht: "ht l = h"  "Suc h = ht r" by auto
    from ht 3 have "size1 (fib_tree h) \<le> size1 l" by auto moreover
    from ht 3 have "size1 (fib_tree (Suc h)) \<le> size1 r" by auto ultimately
    show ?thesis by auto
  qed
qed auto

theorem avl_size_bound: "avl t \<Longrightarrow> fib(height t + 2) \<le> size1 t"
using fib_tree_minimal fib_tree_size1 by fastforce

end


(*  Title:      HOL/Quickcheck_Examples/Quickcheck_Lattice_Examples.thy
    Author:     Lukas Bulwahn
    Copyright   2010 TU Muenchen
*)

theory Quickcheck_Lattice_Examples
imports MainRLT
begin

declare [[quickcheck_finite_type_size=5]]

text \<open>We show how other default types help to find counterexamples to propositions if
  the standard default type \<^typ>\<open>int\<close> is insufficient.\<close>

notation
  less_eq  (infix "\<sqsubseteq>" 50) and
  less  (infix "\<sqsubset>" 50) and
  top ("\<top>") and
  bot ("\<bottom>") and
  inf (infixl "\<sqinter>" 70) and
  sup (infixl "\<squnion>" 65)

declare [[quickcheck_narrowing_active = false, quickcheck_timeout = 3600]]

subsection \<open>Distributive lattices\<close>

lemma sup_inf_distrib2:
 "((y :: 'a :: distrib_lattice) \<sqinter> z) \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  quickcheck[expect = no_counterexample]
by(simp add: inf_sup_aci sup_inf_distrib1)

lemma sup_inf_distrib2_1:
 "((y :: 'a :: lattice) \<sqinter> z) \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  quickcheck[expect = counterexample]
  oops

lemma sup_inf_distrib2_2:
 "((y :: 'a :: distrib_lattice) \<sqinter> z') \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  quickcheck[expect = counterexample]
  oops

lemma inf_sup_distrib1_1:
 "(x :: 'a :: distrib_lattice) \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x' \<sqinter> z)"
  quickcheck[expect = counterexample]
  oops

lemma inf_sup_distrib2_1:
 "((y :: 'a :: distrib_lattice) \<squnion> z) \<sqinter> x = (y \<sqinter> x) \<squnion> (y \<sqinter> x)"
  quickcheck[expect = counterexample]
  oops

subsection \<open>Bounded lattices\<close>

lemma inf_bot_left [simp]:
  "\<bottom> \<sqinter> (x :: 'a :: bounded_lattice_bot) = \<bottom>"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb1) simp

lemma inf_bot_left_1:
  "\<bottom> \<sqinter> (x :: 'a :: bounded_lattice_bot) = x"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_left_2:
  "y \<sqinter> (x :: 'a :: bounded_lattice_bot) = \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_left_3:
  "x \<noteq> \<bottom> ==> y \<sqinter> (x :: 'a :: bounded_lattice_bot) \<noteq> \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_right [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<sqinter> \<bottom> = \<bottom>"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb2) simp

lemma inf_bot_right_1:
  "x \<noteq> \<bottom> ==> (x :: 'a :: bounded_lattice_bot) \<sqinter> \<bottom> = y"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_right_2:
  "(x :: 'a :: bounded_lattice_bot) \<sqinter> \<bottom> ~= \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma sup_bot_right [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<squnion> \<bottom> = \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma sup_bot_left [simp]:
  "\<bottom> \<squnion> (x :: 'a :: bounded_lattice_bot) = x"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb2) simp

lemma sup_bot_right_2 [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<squnion> \<bottom> = x"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb1) simp

lemma sup_eq_bot_iff [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<squnion> y = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
  quickcheck[expect = no_counterexample]
  by (simp add: eq_iff)

lemma sup_top_left [simp]:
  "\<top> \<squnion> (x :: 'a :: bounded_lattice_top) = \<top>"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb1) simp

lemma sup_top_right [simp]:
  "(x :: 'a :: bounded_lattice_top) \<squnion> \<top> = \<top>"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb2) simp

lemma inf_top_left [simp]:
  "\<top> \<sqinter> x = (x :: 'a :: bounded_lattice_top)"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb2) simp

lemma inf_top_right [simp]:
  "x \<sqinter> \<top> = (x :: 'a :: bounded_lattice_top)"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb1) simp

lemma inf_eq_top_iff [simp]:
  "(x :: 'a :: bounded_lattice_top) \<sqinter> y = \<top> \<longleftrightarrow> x = \<top> \<and> y = \<top>"
  quickcheck[expect = no_counterexample]
  by (simp add: eq_iff)

no_notation
  less_eq  (infix "\<sqsubseteq>" 50) and
  less (infix "\<sqsubset>" 50) and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65) and
  top ("\<top>") and
  bot ("\<bottom>")

end


(*
  File:     Carmichael_Numbers.thy
  Authors:  Daniel Stüwe

  Definition and basic properties of Carmichael numbers
*)
section \<open>Carmichael Numbers\<close>
theory Carmichael_Numbers
imports
  Residues_Nat
begin

text \<open>
  A Carmichael number is a composite number \<open>n\<close> that Fermat's test incorrectly labels
  as primes no matter which witness \<open>a\<close> is chosen (except in the case that \<open>a\<close> shares a
  factor with \<open>n\<close>). \cite{Carmichael_numbers, wiki:Carmichael_number}
\<close>
definition Carmichael_number :: "nat \<Rightarrow> bool" where
  "Carmichael_number n \<longleftrightarrow> n > 1 \<and> \<not>prime n \<and> (\<forall>a. coprime a n \<longrightarrow> [a ^ (n - 1) = 1] (mod n))"

lemma Carmichael_number_0[simp, intro]: "\<not>Carmichael_number 0"
  unfolding Carmichael_number_def by simp

lemma Carmichael_number_1[simp, intro]: "\<not>Carmichael_number 1"
  by (auto simp: Carmichael_number_def)

lemma Carmichael_number_Suc_0[simp, intro]: "\<not>Carmichael_number (Suc 0)"
  by (auto simp: Carmichael_number_def)

lemma Carmichael_number_not_prime: "Carmichael_number n \<Longrightarrow> \<not>prime n"
  by (auto simp: Carmichael_number_def)

lemma Carmichael_number_gt_3: "Carmichael_number n \<Longrightarrow> n > 3"
proof -
  assume *: "Carmichael_number n"
  hence "n > 1" by (auto simp: Carmichael_number_def)
  {
    assume "\<not>(n > 3)"
    with \<open>n > 1\<close> have "n = 2 \<or> n = 3" by auto
    with * and Carmichael_number_not_prime[of n] have False by auto
  }
  thus "n > 3" by auto
qed

text \<open>
  The proofs are inspired by \cite{Carmichael_numbers, Carmichael_number_square_free}.
\<close>
lemma Carmichael_number_imp_squarefree_aux:
  assumes "Carmichael_number n"
  assumes n: "n = p^r * l" and "prime p" "\<not>p dvd l"
  assumes "r > 1"
  shows False
proof -
  have "\<not> prime n" using \<open>Carmichael_number n\<close> unfolding Carmichael_number_def by blast

  have * : "[a^(n-1) = 1] (mod n)" if "coprime a n" for a
    using \<open>Carmichael_number n\<close> that
    unfolding Carmichael_number_def
    by blast

  have "1 \<le> n"
    unfolding n using \<open>prime p\<close> \<open>\<not> p dvd l\<close>
    by (auto intro: gre1I_nat)

  have "2 \<le> n"
  proof(cases "n = 1")
    case True
    then show ?thesis
      unfolding n using \<open>1 < r\<close> prime_gt_1_nat[OF \<open>prime p\<close>]
      by simp
  next
    case False
    then show ?thesis using \<open>1 \<le> n\<close> by linarith
  qed

  have "p < p^r"
    using prime_gt_1_nat[OF \<open>prime p\<close>] \<open>1 < r\<close>
    by (metis power_one_right power_strict_increasing_iff)

  hence "p < n" using \<open>1 \<le> n\<close> less_le_trans n by fastforce

  then have [simp]: "{..n} - {0..Suc 0} = {2..n}" by auto

  obtain a where a: "[a = p + 1] (mod p^r)" "[a = 1] (mod l)"
    using binary_chinese_remainder_nat[of "p^r" l "p + 1" 1]
    and \<open>prime p\<close> prime_imp_coprime_nat coprime_power_left_iff \<open>\<not>p dvd l\<close>
    by blast

  hence "coprime a n"
    using lucas_coprime_lemma[of 1 a l] cong_imp_coprime[of "p+1" a "p^r"]
      and coprime_add_one_left cong_sym
    unfolding \<open>n = p ^ r * l\<close> coprime_mult_right_iff coprime_power_right_iff power_one_right
    by blast

  hence "[a ^ (n - 1) = 1] (mod n)"
    using * by blast

  hence "[a ^ (n - 1) = 1] (mod p^r)"
    using n cong_modulus_mult_nat by blast

  hence A: "[a ^ n = a] (mod p^r)"
    using cong_scalar_right[of "a^(n-1)" 1 "p^r" a] \<open>1 \<le> n\<close>
    unfolding power_Suc2[symmetric]
    by simp

  have "r = Suc (Suc (r - 2))"
    using \<open>1 < r\<close> by linarith

  then have "p^r = p^2 * p^(r-2)"
    by (simp add: algebra_simps flip: power_add power_Suc)

  hence "[a ^ n = a] (mod p^2)" "[a = p + 1] (mod p^2)"
    using \<open>1 < r\<close> A cong_modulus_mult_nat \<open>[a = p + 1] (mod p^r)\<close>
    by algebra+

  hence 1: "[(p + 1) ^ n = (p + 1)] (mod p^2)"
    by (metis (mono_tags) cong_def power_mod)

  have "[(p + 1) ^ n = (\<Sum>k\<le>n. of_nat (n choose k) * p ^ k * 1 ^ (n - k))] (mod p^2)"
    using binomial[of p 1 n] by simp

  also have "(\<Sum>k\<le>n. of_nat (n choose k) * p ^ k * 1 ^ (n - k)) =
             (\<Sum>k = 0..1. (n choose k) * p ^ k) + (\<Sum>k\<in> {2..n}. of_nat (n choose k) * p ^ k * 1 ^ (n - k))"
    using \<open>2 \<le> n\<close> finite_atMost[of n]
    by (subst sum.subset_diff[where B = "{0..1}"]) auto

  also have "[(\<Sum>k = 0..1. (n choose k) * p ^ k) = 1] (mod p^2)"
    by (simp add: cong_altdef_nat \<open>p ^ r = p\<^sup>2 * p ^ (r - 2)\<close> n)

  also have "[(\<Sum>k\<in> {2..n}. of_nat (n choose k) * p ^ k * 1 ^ (n - k)) = 0] (mod p^2)"
    by (rule cong_eq_0_I) (clarsimp simp: cong_0_iff le_imp_power_dvd)

  finally have 2: "[(p + 1) ^ n = 1] (mod p^2)" by simp

  from cong_trans[OF cong_sym[OF 1] 2]
  show ?thesis
    using prime_gt_1_nat[OF \<open>prime p\<close>]
    by (auto dest: residue_one_dvd[unfolded One_nat_def] simp add: cong_def numeral_2_eq_2)
qed

theorem Carmichael_number_imp_squarefree:
  assumes "Carmichael_number n"
  shows "squarefree n"
proof(rule squarefreeI, rule ccontr)
  fix x :: nat
  assume "x\<^sup>2 dvd n"
  from assms have "n > 0" using Carmichael_number_gt_3[of n] by auto
  from \<open>x\<^sup>2 dvd n\<close> and \<open>0 < n\<close> have "0 < x" by auto

  assume "\<not> is_unit x"
  then obtain p where "prime p" "p dvd x"
    using prime_divisor_exists[of x] \<open>0 < x\<close>
    by blast

  with \<open>x\<^sup>2 dvd n\<close> have "p^2 dvd n"
    by auto

  obtain l where n: "n = p ^ multiplicity p n * l"
    using multiplicity_dvd[of p n] by blast

  then have "\<not> p dvd l"
    using multiplicity_decompose'[where x = n and p = p]
    using \<open>prime p\<close> \<open>0 < n\<close>
    by (metis nat_dvd_1_iff_1 nat_mult_eq_cancel1 neq0_conv prime_prime_factor_sqrt zero_less_power)

  have "2 \<le> multiplicity p n"
    using \<open>p\<^sup>2 dvd n\<close> \<open>0 < n\<close> prime_gt_1_nat[OF \<open>prime p\<close>]
    by (auto intro!: multiplicity_geI simp: power2_eq_square)

  then show False
    using Carmichael_number_imp_squarefree_aux[OF \<open>Carmichael_number n\<close> n] \<open>prime p\<close> \<open>\<not> p dvd l\<close>
    by auto
qed

corollary Carmichael_not_primepow:
  assumes "Carmichael_number n"
  shows   "\<not>primepow n"
  using Carmichael_number_imp_squarefree[of n] Carmichael_number_not_prime[of n] assms
        primepow_gt_0_nat[of n] by (auto simp: not_squarefree_primepow)

lemma Carmichael_number_imp_squarefree_alt_weak:
  assumes "Carmichael_number n"
  shows "\<exists>p l. (n = p * l) \<and> prime p \<and> \<not>p dvd l"
proof -
  from assms have "n > 1"
    using Carmichael_number_gt_3[of n] by simp
  have "squarefree n"
    using Carmichael_number_imp_squarefree assms
    by blast

  obtain p l where "p * l = n" "prime p" "1 < p"
    using assms prime_divisor_exists_strong_nat prime_gt_1_nat
    unfolding Carmichael_number_def by blast

  then have "multiplicity p n = 1"
    using \<open>1 < n\<close> \<open>squarefree n\<close> and multiplicity_eq_zero_iff[of n p] squarefree_factorial_semiring''[of n]
    by auto

  then have "\<not>p dvd l"
    using \<open>1 < n\<close> \<open>prime p\<close> \<open>p * l = n\<close> multiplicity_decompose'[of n p]
    by force

  show ?thesis
    using \<open>p * l = n\<close> \<open>prime p\<close> \<open>\<not>p dvd l\<close>
    by blast
qed

theorem Carmichael_number_odd:
  assumes "Carmichael_number n"
  shows   "odd n"
proof (rule ccontr)
  assume "\<not> odd n"
  hence "even n" by simp
  from assms have "n \<ge> 4" using Carmichael_number_gt_3[of n] by simp
  have "[(n - 1) ^ (n - 1) = n - 1] (mod n)"
    using \<open>even n\<close> and \<open>n \<ge> 4\<close> by (intro odd_pow_cong) auto

  then have "[(n - 1) ^ (n - 1) \<noteq> 1] (mod n)"
    using cong_trans[of 1 "(n - 1) ^ (n - 1)" n "n-1", OF cong_sym] \<open>4 \<le> n\<close>
    by (auto simp: cong_def)

  moreover have "coprime (n - 1) n"
    using \<open>n \<ge> 4\<close> coprime_diff_one_left_nat[of n] by auto

  ultimately show False
    using assms unfolding Carmichael_number_def by blast
qed

lemma Carmichael_number_imp_squarefree_alt:
  assumes "Carmichael_number n"
  shows "\<exists>p l. (n = p * l) \<and> prime p \<and> \<not>p dvd l \<and> 2 < l"
proof -
  obtain p l where [simp]: "(n = p * l)" and "prime p" "\<not>p dvd l"
    using Carmichael_number_imp_squarefree_alt_weak and assms by blast

  moreover have "odd n" using Carmichael_number_odd and assms by blast

  consider "l = 0 \<or> l = 2" | "l = 1" | "2 < l"
    by fastforce

  then have "2 < l"
  proof cases
    case 1
    then show ?thesis
      using \<open>odd n\<close> by auto
  next
    case 2
    then show ?thesis
      using \<open>n = p * l\<close> \<open>prime p\<close> \<open>Carmichael_number n\<close>
      unfolding Carmichael_number_def by simp
  qed simp

  ultimately show ?thesis by blast
qed

lemma Carmichael_number_imp_dvd:
  fixes n :: nat
  assumes Carmichael_number: "Carmichael_number n" and "prime p" "p dvd n"
  shows "p - 1 dvd n - 1"
proof -
  have "\<not>prime n" using Carmichael_number unfolding Carmichael_number_def by blast
  obtain u where "n = p * u" using \<open>p dvd n\<close> by blast
  have "squarefree n" using Carmichael_number_imp_squarefree assms by blast
  then have "\<not>p dvd u"
    using \<open>prime p\<close> not_prime_unit[of p]
    unfolding power2_eq_square squarefree_def \<open>n = p * u\<close>
    by fastforce

  define R where "R = Residues_nat p"
  interpret residues_nat_prime p R
    by unfold_locales (simp_all only: \<open>prime p\<close> R_def)

  obtain a where a: "a \<in> {0<..<p}" "units.ord a = p - 1"
    using residues_prime_cyclic' \<open>prime p\<close> by metis
  from a have "a \<in> totatives p" by (auto simp: totatives_prime \<open>prime p\<close>)

  have "coprime p u"
    using \<open>prime p\<close> \<open>\<not> p dvd u\<close>
    by (simp add: prime_imp_coprime_nat)

  then obtain x where "[x = a] (mod p)" "[x = 1] (mod u)"
    using binary_chinese_remainder_nat[of p u a 1] by blast

  have "coprime x p"
    using \<open>a \<in> totatives p\<close> and cong_imp_coprime[OF cong_sym[OF \<open>[x = a] (mod p)\<close>]]
    by (simp add: coprime_commute totatives_def)
  moreover have "coprime x u"
    using coprime_1_left and cong_imp_coprime[OF cong_sym[OF \<open>[x = 1] (mod u)\<close>]] by blast
  ultimately have "coprime x n"
    by (simp add: \<open>n = p * u\<close>)

  have "[a ^ (n - 1) = x ^ (n - 1)] (mod p)"
    using \<open>[x = a] (mod p)\<close> by (intro cong_pow) (auto simp: cong_sym_eq)
  also have "[x ^ (n - 1) = 1] (mod n)"
    using Carmichael_number \<open>coprime x n\<close> unfolding Carmichael_number_def by blast
  then have "[x ^ (n - 1) = 1] (mod p)"
    using \<open>n = p * u\<close> cong_modulus_mult_nat by blast
  finally have "ord p a dvd n - 1"
    by (simp add: ord_divides [symmetric])
  also have "ord p a = p - 1"
    using a \<open>a \<in> totatives p\<close> by (simp add: units.ord_residue_mult_group)
  finally show ?thesis .
qed

text \<open>
  The following lemma is also called Korselt's criterion.
\<close>
lemma Carmichael_numberI:
  fixes n :: nat
  assumes "\<not> prime n" "squarefree n" "1 < n" and
          DIV: "\<And>p. p \<in> prime_factors n \<Longrightarrow> p - 1 dvd n - 1"
  shows   "Carmichael_number n"
  unfolding Carmichael_number_def
proof (intro assms conjI allI impI)
  fix a :: nat assume "coprime a n"

  have n: "n = \<Prod>(prime_factors n)"
    using prime_factorization_nat and squarefree_factorial_semiring'[of n] \<open>1 < n\<close> \<open>squarefree n\<close>
    by fastforce

  have "x \<in># prime_factorization n \<Longrightarrow> y \<in># prime_factorization n \<Longrightarrow> x \<noteq> y \<Longrightarrow> coprime x y" for x y
    using in_prime_factors_imp_prime primes_coprime
    by blast

  moreover {
    fix p
    assume p: "p \<in># prime_factorization n"

    have "\<not>p dvd a"
      using \<open>coprime a n\<close> p coprime_common_divisor_nat[of a n p]
      by (auto simp: in_prime_factors_iff)
    with p have "[a ^ (p - 1) = 1] (mod p)"
      by (intro fermat_theorem) auto
    hence "ord p a dvd p - 1"
      by (subst (asm) ord_divides)
    also from p have "p - 1 dvd n - 1"
      by (rule DIV)
    finally have "[a ^ (n - 1) = 1] (mod p)"
      by (subst ord_divides)
  }

  ultimately show "[a ^ (n - 1) = 1] (mod n)"
    using n coprime_cong_prod_nat by metis
qed

theorem Carmichael_number_iff:
  "Carmichael_number n \<longleftrightarrow>
     n \<noteq> 1 \<and> \<not>prime n \<and> squarefree n \<and> (\<forall>p\<in>prime_factors n. p - 1 dvd n - 1)"
proof -
  consider "n = 0" | "n = 1" | "n > 1" by force
  thus ?thesis using Carmichael_numberI[of n] Carmichael_number_imp_dvd[of n]
    by cases (auto simp: Carmichael_number_not_prime Carmichael_number_imp_squarefree)
qed

text \<open>
  Every Carmichael number has at least three distinct prime factors.
\<close>
theorem Carmichael_number_card_prime_factors:
  assumes "Carmichael_number n"
  shows   "card (prime_factors n) \<ge> 3"
proof (rule ccontr)
  from assms have "n > 3"
    using Carmichael_number_gt_3[of n] by simp
  assume "\<not>(card (prime_factors n) \<ge> 3)"
  moreover have "card (prime_factors n) \<noteq> 0"
    using assms Carmichael_number_gt_3[of n] by (auto simp: prime_factorization_empty_iff)
  moreover have "card (prime_factors n) \<noteq> 1"
    using assms by (auto simp: one_prime_factor_iff_primepow Carmichael_not_primepow)
  ultimately have "card (prime_factors n) = 2"
    by linarith
  then obtain p q where pq: "prime_factors n = {p, q}" "p \<noteq> q"
    by (auto simp: card_Suc_eq numeral_2_eq_2)
  hence "prime p" "prime q" by (auto simp: in_prime_factors_iff)

  have "n = \<Prod>(prime_factors n)"
    using assms by (subst squarefree_imp_prod_prime_factors_eq)
                   (auto simp: Carmichael_number_imp_squarefree)
  with pq have n_eq: "n = p * q" by simp

  have "p - 1 dvd n - 1" and "q - 1 dvd n - 1" using assms pq
    unfolding Carmichael_number_iff by blast+
  with \<open>prime p\<close> \<open>prime q\<close> \<open>n = p * q\<close> \<open>p \<noteq> q\<close> show False
  proof (induction p q rule: linorder_wlog)
    case (le p q)
    hence "p < q" by auto
    have "[q = 1] (mod q - 1)"
      using prime_gt_1_nat[of q] \<open>prime q\<close> by (simp add: cong_def le_mod_geq)
    hence "[p * q - 1 = p * 1 - 1] (mod q - 1)"
      using le prime_gt_1_nat[of p] by (intro cong_diff_nat cong_mult) auto
    hence "[p - 1 = n - 1] (mod q - 1)"
      by (simp add: \<open>n = p * q\<close> cong_sym_eq)
    also have "[n - 1 = 0] (mod q - 1)"
      using le by (simp add: cong_def)
    finally have "(p - 1) mod (q - 1) = 0"
      by (simp add: cong_def)
    also have "(p - 1) mod (q - 1) = p - 1"
      using prime_gt_1_nat[of p] \<open>prime p\<close> \<open>p < q\<close> by (intro mod_less) auto
    finally show False
      using prime_gt_1_nat[of p] \<open>prime p\<close> by simp
  qed (simp_all add: mult.commute)
qed

lemma Carmichael_number_iff':
  fixes n :: nat
  defines "P \<equiv> prime_factorization n"
  shows "Carmichael_number n \<longleftrightarrow>
           n > 1 \<and> size P \<noteq> 1 \<and> (\<forall>p\<in>#P. count P p = 1 \<and> p - 1 dvd n - 1)"
  unfolding Carmichael_number_iff
  by (cases "n = 0") (auto simp: P_def squarefree_factorial_semiring' count_prime_factorization)

text \<open>
  The smallest Carmichael number is 561, and it was found and proven so by
  Carmichael in 1910~\cite{carmichael1910note}.
\<close>
lemma Carmichael_number_561: "Carmichael_number 561" (is "Carmichael_number ?n")
proof -
  have [simp]: "prime_factorization (561 :: nat) = {#3, 11, 17#}"
    by (rule prime_factorization_eqI) auto
  show ?thesis by (subst Carmichael_number_iff') auto
qed

end


(* Author: Hauke Brinkop and Tobias Nipkow *)

section \<open>Pairing Heap in Binary Tree Representation\<close>

theory Pairing_Heap_Tree
imports
  "HOL-Library.Tree_Multiset"
  "HOL-Data_Structures.Priority_Queue_Specs"
begin

subsection \<open>Definitions\<close>

text \<open>Pairing heaps \<^cite>\<open>"FredmanSST86"\<close>
in their original representation as binary trees.\<close>

fun get_min  :: "'a :: linorder tree \<Rightarrow> 'a" where
"get_min (Node _ x _) = x"

fun link :: "('a::linorder) tree \<Rightarrow> 'a tree" where
"link (Node hsx x (Node hsy y hs)) =
   (if x < y then Node (Node hsy y hsx) x hs else Node (Node hsx x hsy) y hs)" |
"link t = t"

fun pass\<^sub>1 :: "('a::linorder) tree \<Rightarrow> 'a tree" where
"pass\<^sub>1 (Node hsx x (Node hsy y hs)) = link (Node hsx x (Node hsy y (pass\<^sub>1 hs)))" |
"pass\<^sub>1 hs = hs"

fun pass\<^sub>2 :: "('a::linorder) tree \<Rightarrow> 'a tree" where
"pass\<^sub>2 (Node hsx x hs) = link(Node hsx x (pass\<^sub>2 hs))" |
"pass\<^sub>2 Leaf = Leaf"

fun del_min :: "('a::linorder) tree \<Rightarrow> 'a tree" where
  "del_min Leaf = Leaf"
| "del_min (Node hs _ Leaf) = pass\<^sub>2 (pass\<^sub>1 hs)"

fun merge :: "('a::linorder) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "merge Leaf hp = hp"
| "merge hp Leaf = hp"
| "merge (Node hsx x Leaf) (Node hsy y Leaf) = link (Node hsx x (Node hsy y Leaf))"

fun insert :: "('a::linorder) \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x hp = merge (Node Leaf x Leaf) hp"

text \<open>The invariant is the conjunction of \<open>is_root\<close> and \<open>pheap\<close>:\<close>

fun is_root :: "'a tree \<Rightarrow> bool" where
  "is_root hp = (case hp of Leaf \<Rightarrow> True | Node l x r \<Rightarrow> r = Leaf)"

fun pheap :: "('a :: linorder) tree \<Rightarrow> bool" where
"pheap Leaf = True" |
"pheap (Node l x r) = ((\<forall>y \<in> set_tree l. x \<le> y) \<and> pheap l \<and> pheap r)"

subsection \<open>Correctness Proofs\<close>

subsubsection \<open>Invariants\<close>

lemma link_struct: "\<exists>l a. link (Node hsx x (Node hsy y hs)) = Node l a hs"
by simp

lemma pass\<^sub>1_struct: "\<exists>l a r. pass\<^sub>1 (Node hs1 x hs) = Node l a r"
by (cases hs) simp_all

lemma pass\<^sub>2_struct: "\<exists>l a. pass\<^sub>2 (Node hs1 x hs) = Node l a Leaf"
by(induction hs arbitrary: hs1 x rule: pass\<^sub>2.induct) (auto, metis link_struct)

lemma is_root_merge:
  "is_root h1 \<Longrightarrow> is_root h2 \<Longrightarrow> is_root (merge h1 h2)"
by (simp split: tree.splits)

lemma is_root_insert: "is_root h \<Longrightarrow> is_root (insert x h)"
by (simp split: tree.splits)

lemma is_root_del_min:
  assumes "is_root h" shows "is_root (del_min h)"
proof (cases h)
  case [simp]: (Node lx x rx)
  have "rx = Leaf" using assms by simp
  thus ?thesis
  proof (cases lx)
    case (Node ly y ry)
    then obtain la a ra where "pass\<^sub>1 lx = Node a la ra"
      using pass\<^sub>1_struct by blast
    moreover obtain lb b where "pass\<^sub>2 \<dots> = Node b lb Leaf"
      using pass\<^sub>2_struct by blast
    ultimately show ?thesis using assms by simp
  qed simp
qed simp

lemma pheap_merge:
  "\<lbrakk> is_root h1; is_root h2; pheap h1; pheap h2 \<rbrakk> \<Longrightarrow> pheap (merge h1 h2)"
by (auto split: tree.splits)

lemma pheap_insert: "is_root h \<Longrightarrow> pheap h \<Longrightarrow> pheap (insert x h)"
by (auto split: tree.splits)

lemma pheap_link: "t \<noteq> Leaf \<Longrightarrow> pheap t \<Longrightarrow> pheap (link t)"
by(induction t rule: link.induct)(auto)

lemma pheap_pass1: "pheap h \<Longrightarrow> pheap (pass\<^sub>1 h)"
by(induction h rule: pass\<^sub>1.induct) (auto)

lemma pheap_pass2: "pheap h \<Longrightarrow> pheap (pass\<^sub>2 h)"
by (induction h)(auto simp: pheap_link)

lemma pheap_del_min: "is_root h \<Longrightarrow> pheap h \<Longrightarrow> pheap (del_min h)"
by (auto simp: pheap_pass1 pheap_pass2 split: tree.splits)

subsubsection \<open>Functional Correctness\<close>

lemma get_min_in:
  "h \<noteq> Leaf \<Longrightarrow> get_min h \<in> set_tree h"
by(auto simp add: neq_Leaf_iff)

lemma get_min_min: "\<lbrakk> is_root h; pheap h; x \<in> set_tree h \<rbrakk> \<Longrightarrow> get_min h \<le> x"
by(auto split: tree.splits)

lemma mset_link: "mset_tree (link t) = mset_tree t"
by(cases t rule: link.cases)(auto simp: add_ac)

lemma mset_pass\<^sub>1: "mset_tree (pass\<^sub>1 h) = mset_tree h"
by (induction h rule: pass\<^sub>1.induct) auto

lemma mset_pass\<^sub>2: "mset_tree (pass\<^sub>2 h) = mset_tree h"
by (induction h rule: pass\<^sub>2.induct) (auto simp: mset_link)

lemma mset_merge: "\<lbrakk> is_root h1; is_root h2 \<rbrakk>
 \<Longrightarrow>  mset_tree (merge h1 h2) = mset_tree h1 + mset_tree h2"
by (induction h1 h2 rule: merge.induct) (auto simp add: ac_simps)
(*
lemma mset_merge_pairs: "mset_tree (merge_pairs h) = mset_tree h"
by(induction h rule: merge_pairs.induct)(auto simp: mset_link add_ac)
*)
lemma mset_del_min: "\<lbrakk> is_root h; t \<noteq> Leaf \<rbrakk> \<Longrightarrow>
  mset_tree (del_min h) = mset_tree h - {#get_min h#}"
by(induction h rule: del_min.induct)(auto simp: mset_pass\<^sub>1 mset_pass\<^sub>2)

text \<open>Last step: prove all axioms of the priority queue specification:\<close>

interpretation pairing: Priority_Queue_Merge
where empty = Leaf and is_empty = "\<lambda>h. h = Leaf"
and merge = merge and insert = insert
and del_min = del_min and get_min = get_min
and invar = "\<lambda>h. is_root h \<and> pheap h" and mset = mset_tree
proof(standard, goal_cases)
  case 1 show ?case by simp
next
  case (2 q) show ?case by (cases q) auto
next
  case 3 thus ?case by(simp add: mset_merge)
next
  case 4 thus ?case by(simp add: mset_del_min)
next
  case 5 thus ?case by(simp add: eq_Min_iff get_min_in get_min_min)
next
  case 6 thus ?case by(simp)
next
  case 7 thus ?case using is_root_insert pheap_insert by blast
next
  case 8 thus ?case using is_root_del_min pheap_del_min by blast
next
  case 9 thus ?case by (simp add: mset_merge)
next
  case 10 thus ?case using is_root_merge pheap_merge by blast
qed

end


theory Category imports FreeLogic

abbrevs "modphism" = ":\<rightarrow>" and
        "wedge" = "\<leftarrow>-()-\<rightarrow>"

begin

 (*Begin: some useful parameter settings*)
declare [[ smt_solver = cvc4, smt_oracle = true, smt_timeout = 120]] declare [[ show_types ]]
sledgehammer_params [provers = cvc4 z3 spass e vampire remote_leo3]
nitpick_params [user_axioms, show_all, format = 2]
(*nitpick_params[user_axioms, show_all, format = 2, expect = genuine]*)
 (*End: some useful parameter settings*)

section \<open>The basis of category theory\<close>

class category =
  fixes domain:: "'a \<Rightarrow> 'a" ("dom _" [108] 109) and
        codomain:: "'a\<Rightarrow> 'a" ("cod _" [110] 111) and
        composition:: "'a \<Rightarrow> 'a  \<Rightarrow> 'a" (infix "\<cdot>" 110)

  assumes
        S1: "E(dom x) \<^bold>\<rightarrow> E x" and
        S2: "E(cod y) \<^bold>\<rightarrow> E y" and
        S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
        S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
        S5: "x\<cdot>(dom x) \<cong> x" and
        S6: "(cod y)\<cdot>y \<cong> y"
begin

definition arrow ("(_):(_)\<rightarrow>(_)" [120,120,120] 119) where
  "x:a\<rightarrow>b \<equiv> dom x \<simeq> a \<and> cod x \<simeq> b"

definition wedge ("_\<leftarrow>_- (_) -_\<rightarrow>_" [120,0,0,0,120] 119) where
  "a \<leftarrow>f- (x) -g\<rightarrow> b \<equiv> dom f \<simeq> x \<and> cod f \<simeq> a \<and> dom g \<simeq> x \<and> cod g \<simeq> b"

definition monic::"'a \<Rightarrow> bool" where
  "monic m \<equiv> \<forall>f g. m\<cdot>f \<simeq> m\<cdot>g \<longrightarrow> f \<simeq> g"

definition epi::"'a \<Rightarrow> bool" where
  "epi m \<equiv> \<forall>f g. f\<cdot>m \<simeq> g\<cdot>m \<longrightarrow> f \<simeq> g"

definition isomorphism::"'a \<Rightarrow> bool" where
  "isomorphism f \<equiv> \<exists>g. f\<cdot>g \<cong> (dom g) \<and> g\<cdot>f \<cong> (dom f)"

definition isomorphic::"'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "isomorphic z y \<equiv> \<exists>f. dom f \<cong> z \<and> cod f \<cong> y \<and> isomorphism f"

definition initial::"'a \<Rightarrow> bool" where
  "initial z \<equiv> \<^bold>\<forall>t. (\<exists>!f. dom f \<simeq> z \<and> cod f \<simeq> t)"

definition final::"'a \<Rightarrow> bool" where
  "final z \<equiv> \<^bold>\<forall>t. (\<exists>!f. dom f \<simeq> t \<and> cod f \<simeq> z)"

\<comment>\<open>Checking equivalences of definitions\<close>
lemma StrongerInitial1: "(initial z) \<longrightarrow>  (\<^bold>\<forall>t. (\<^bold>\<exists>!f. dom f \<simeq> z \<and> cod f \<simeq> t))"
  by (metis (no_types) S1 initial_def)

lemma StrongerInitial2: "(\<^bold>\<forall>t. (\<^bold>\<exists>!f. dom f \<simeq> z \<and> cod f \<simeq> t)) \<longrightarrow> initial z"
  by (smt S2 initial_def)

lemma WeakerInitial1: "(\<^bold>\<forall>t. (\<exists>!f. dom f \<cong> z \<and> cod f \<cong> t)) \<longrightarrow> initial z"
  by (smt S5 category.S2 category.S3 category_axioms initial_def)
lemma WeakerInitial2: "initial z \<longrightarrow> (\<^bold>\<forall>t. (\<exists>!f. dom f \<cong> z \<and> cod f \<cong> t))"
  by (smt initial_def)
(*The same as above would do for final*)

end

lemma (in category) InitialsAreIsomorphic: "initial z \<and> initial y \<longrightarrow> isomorphic z y" (*sledgehammer sledgehammer [remote_leo3]*)
  by (smt S1 S3 S5 S6 category_axioms epi_def initial_def isomorphic_def isomorphism_def)

lemma (in category) InitialIsUnique: "\<forall>z. \<forall>f. initial z \<and> (dom f \<cong> z \<and> cod f \<cong> z) \<longrightarrow> z \<cong> f" (*sledgehammer sledgehammer [remote_leo3]*)
  by (metis(no_types) S3 S5 S6 initial_def)

lemma (in category) FinalsAreIsomorphic: "final z \<and> final y \<longrightarrow> isomorphic z y" (*sledgehammer sledgehammer [remote_leo3]*)
  by (smt S2 S3 S5 final_def isomorphic_def isomorphism_def)

lemma (in category) FinalIsUnique: "\<forall>z. \<forall>f. final z \<and> ( dom f \<cong> z \<and> cod f \<cong> z) \<longrightarrow> z \<cong> f" (*sledgehammer sledgehammer [remote_leo3]*)
  by (metis(no_types) S3 S5 S6 final_def)

lemma (in category) TwoMonicsBetweenTypes: "(\<^bold>\<forall>(m::'a) (n::'a). monic m \<and> monic n \<and> dom m \<simeq> dom n \<and> cod m \<simeq> cod n \<longrightarrow> (m\<simeq>n))" nitpick oops

(*Relationship between isomorphisms and epic and monic maps*)
proposition (in category) "isomorphism m \<longrightarrow> monic m \<and> epi m"  \<comment>\<open>cvc4 and Leo-III proves this\<close>
  (*sledgehammer sledgehammer [remote_leo3]*)
  by (smt S1 S3 S4 S5 S6 epi_def isomorphism_def monic_def)

proposition (in category) "monic m \<and> epi m \<longrightarrow> isomorphism m" nitpick oops

section \<open>Product\<close>

definition (in category) product::"'a \<Rightarrow> 'a \<Rightarrow> 'a  \<Rightarrow> bool" where
"product a b c \<equiv> \<^bold>\<exists>p1 p2. p1:c\<rightarrow>a \<and> p2:c\<rightarrow>b \<and>
                  (\<^bold>\<forall>x f g. (a\<leftarrow>f-(x)-g\<rightarrow>b) \<longrightarrow> (\<^bold>\<exists>!h. h:x\<rightarrow>c \<and> f \<simeq> p1\<cdot>h \<and> g \<simeq> p2\<cdot>h))"

lemma (in category) "((product a b c) \<and> (product a b d)) \<longrightarrow> isomorphic c d"
  unfolding isomorphic_def  isomorphism_def  product_def arrow_def wedge_def
  (* sledgehammer sledgehammer [remote_leo3] *)
  by (smt S3 S4 S5)

lemma (in category) "(product b a c) \<longrightarrow> (product a b c)"
  unfolding product_def arrow_def wedge_def
   (* sledgehammer sledgehammer [remote_leo3] *)
  by smt

end


theory Chapters123
  imports Main
begin

lemma "[a] = [b] \<Longrightarrow> a = b"
  by simp

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add 0 n = n" |
  "add (Suc n) m = Suc (add n m)"

lemma add_02 [simp]: "add n 0 = n"
  apply (induction n)
  apply (auto)
done

thm add_02

datatype 'a list' = Nil' | Cons' 'a "'a list'"

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "app [] ys = ys" |
  "app (x # xs) ys = x # app xs ys"

fun rev' :: "'a list \<Rightarrow> 'a list" where
  "rev' [] = []" |
  "rev' (x # xs) = app (rev' xs) [x]"

value "rev' (Cons True (Cons False Nil))"
value "rev' [a, b]"

lemma app_Nil2 [simp]: "app xs [] = xs"
  apply (induction xs)
  apply auto
done

lemma app_assoc [simp]:
  "app (app a b) c = app a (app b c)"
  apply (induction a)
  apply auto
done

lemma rev_app [simp]:
  "rev' (app a b) = app (rev' b) (rev' a)"
  apply (induction a)
  apply auto
done

theorem rev_rev [simp]: "rev' (rev' xs) = xs"
  apply (induction xs)
  apply auto
done

value "1 + 2 :: nat"
value "1 - 2 :: nat"

theorem add_assoc [simp]:
  "add (add a b) c = add a (add b c)"
  apply (induction a)
  apply auto
done

lemma add_12 [simp]:
  "Suc (add a b) = add a (Suc b)"
  apply (induction a)
  apply auto
done

theorem add_comm [simp]: "add a b = add b a"
  apply (induction a)
  apply auto
done

fun double :: "nat \<Rightarrow> nat" where
  "double 0 = 0" |
  "double (Suc n) = Suc (Suc (double n))"

theorem add_double: "double n = add n n"
  apply (induction n)
  apply auto
done

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count _ [] = 0" |
  "count a (x # xs) = (if a = x
                       then Suc (count a xs)
                       else count a xs)"

theorem count_max: "count a xs \<le> length xs"
  apply (induction xs)
  apply auto
done

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc [] a = [a]" |
  "snoc (x # xs) a = x # snoc xs a"

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse [] = []" |
  "reverse (x # xs) = snoc (reverse xs) x"

lemma reverse_snoc [simp]:
  "reverse (snoc xs x) = x # reverse xs"
  apply (induction xs)
  apply auto
done

theorem reverse_reverse: "reverse (reverse a) = a"
  apply (induction a)
  apply auto
done

fun sum_upto :: "nat \<Rightarrow> nat" where
  "sum_upto 0 = 0" |
  "sum_upto (Suc n) = Suc n + sum_upto n"

theorem sum_upto: "sum_upto n = n * (n + 1) div 2"
  apply (induction n)
  apply auto
done

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
  "mirror Tip = Tip" |
  "mirror (Node l a r) = Node (mirror r) a (mirror l)"

lemma "mirror (mirror t) = t"
  apply induction apply auto done

fun lookup :: "('a * 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" where
  "lookup [] _ = None" |
  "lookup ((k,v) # xs) a =
    (if a = k then Some v else lookup xs a)"

definition sq :: "nat \<Rightarrow> nat" where
  "sq n = n * n"

abbreviation sq' :: "nat \<Rightarrow> nat" where
  "sq' n == n * n"

fun contents :: "'a tree \<Rightarrow> 'a list" where
  "contents Tip = []" |
  "contents (Node l a r) =
    app (contents l) (app [a] (contents r))"

fun treesum :: "nat tree \<Rightarrow> nat" where
  "treesum Tip = 0" |
  "treesum (Node l a r) = treesum l + a + treesum r"

fun listsum :: "nat list \<Rightarrow> nat" where
  "listsum [] = 0" |
  "listsum (x # xs) = x + listsum xs"

theorem "treesum t = listsum (contents t)"
  apply induction
  apply auto
done

datatype 'a tree2 =
  Tip2 'a |
  Node2 "'a tree2" 'a "'a tree2"

fun mirror2 :: "'a tree2 \<Rightarrow> 'a tree2" where
  "mirror2 (Tip2 a) = Tip2 a" |
  "mirror2 (Node2 l a r) =
     Node2 (mirror2 r) a (mirror2 l)"

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
  "pre_order (Tip2 a) = [a]" |
  "pre_order (Node2 l a r) =
     a # (pre_order l @ pre_order r)"

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
  "post_order (Tip2 a) = [a]" |
  "post_order (Node2 l a r) =
     post_order l @ post_order r @ [a]"

lemma rev_snoc: "x # rev xs = rev (snoc xs x)"
  apply (induction xs) apply auto done

lemma app_rev:
  "rev a @ rev b = rev (b @ a)"
  apply (induction a)
  apply auto
done

theorem "pre_order (mirror2 t) = rev (post_order t)"
  apply (induction t)
  apply auto
done

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intersperse _ [] = []" |
  "intersperse _ [x] = [x]" |
  "intersperse a (x # xs) = x # a # intersperse a xs"

lemma "f x # map f xs = map f (x # xs)"
  by simp

theorem
  "map f (intersperse a xs) =
   intersperse (f a) (map f xs)"
  apply (induction xs rule: intersperse.induct)
  apply auto
done

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "itrev [] ys = ys" |
  "itrev (x # xs) ys = itrev xs (x # ys)"

lemma "itrev xs ys = rev xs @ ys"
  apply (induction xs arbitrary: ys)
  apply auto
done

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "itadd 0 b = b" |
  "itadd (Suc a) b = itadd a (Suc b)"

lemma [simp]: "add a (Suc b) = add b (Suc a)"
  apply (induction a)
  apply (induction b)
  apply auto
done

theorem "itadd a b = add a b"
  apply (induction a arbitrary: b)
  apply auto
done

datatype tree0 = Tip0 | Node0 tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
  "nodes Tip0 = 0" |
  "nodes (Node0 l r) = nodes l + nodes r"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
  "explode 0 t = t" |
  "explode (Suc n) t = explode n (Node0 t t)"

theorem "nodes (explode n t) = 2 ^ n * nodes t"
  apply (induction n arbitrary: t)
  apply simp_all
done

datatype exp =
  Var |
  Const int |
  Add exp exp |
  Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval Var v = v" |
  "eval (Const n) _ = n" |
  "eval (Add a b) v = eval a v + eval b v" |
  "eval (Mult a b) v = eval a v * eval b v"

value "let f = (\<lambda>x y. x) in f a b"
value "case True of True \<Rightarrow> 1 | False \<Rightarrow> 2"

value "let x = 4;
    go = (\<lambda>poly xn. (case poly of
      [] \<Rightarrow> 0 |
      (c # cs) \<Rightarrow> c * xn + go cs (xn * x)))
   in go [2, 3] 4 :: int"

fun evalp_helper :: "int list \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int" where
  "evalp_helper [] _ _ = 0" |
  "evalp_helper (c # cs) x xn =
    c * xn + evalp_helper cs x (xn * x)"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp poly x = evalp_helper poly x 1"

value "eval (Add (Const 1) (Mult (Const 2) Var)) 3"
value "evalp [4, 2, -1, 3] 2"

fun coeffs_add :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "coeffs_add [] b = b" |
  "coeffs_add a [] = a" |
  "coeffs_add (a # as) (b # bs) = (a + b) # coeffs_add as bs"

fun pcons :: "int \<Rightarrow> int list \<Rightarrow> int list" where
  "pcons a [] = (if a = 0 then [] else [a])" |
  "pcons a b = a # b"

fun coeffs_mult :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "coeffs_mult [] _ = []" |
  "coeffs_mult (a # as) bs =
    coeffs_add
      (map (op * a) bs)
      (pcons 0 (coeffs_mult as bs))"

fun coeffs :: "exp \<Rightarrow> int list" where
  "coeffs Var = [0,1]" |
  "coeffs (Const n) = [n]" |
  "coeffs (Mult a b) = coeffs_mult (coeffs a) (coeffs b)" |
  "coeffs (Add a b) = coeffs_add (coeffs a) (coeffs b)"

lemma [simp]: "coeffs_mult a [] = []"
  apply (induction a)
  apply auto
done

lemma
  "coeffs_mult as (b # bs) = coeffs_add (map (op * b) as) (pcons 0 (coeffs_mult as bs))"
  apply (induction as arbitrary: b bs)
  apply auto
  apply (simp add: algebra_simps)
oops

lemma "coeffs_mult a b = coeffs_mult b a"
  apply (induction a)
  apply simp
  apply auto
  apply (cases b)
  apply simp
  apply simp
oops

lemma "coeffs (Add (Const 1) (Mult (Const 2) Var)) = [1, 2]" by simp
lemma "coeffs_mult [0,1] [0,1] = [0, 0, 1]" by simp
lemma "coeffs_mult [2, 3] [5, 7] = [10, 29, 21]" by simp

fun poly_helper :: "int list \<Rightarrow> exp \<Rightarrow> exp" where
  "poly_helper [] _ = Const 0" |
  "poly_helper (x # xs) v = Add (Mult (Const x) v) (poly_helper xs (Mult Var v))"

fun poly :: "int list \<Rightarrow> exp" where
  "poly p = poly_helper p (Const 1)"

value "poly [1,2,3]"

fun iterate :: "nat \<Rightarrow> ('x \<Rightarrow> 'x) \<Rightarrow> 'x \<Rightarrow> 'x" where
  "iterate 0 _ a = a" |
  "iterate (Suc n) f a = iterate n f (f a)"

value "iterate 5 (\<lambda>x. x + 1) 0 :: int"
value "iterate 5 (Add Var) (Const 0) :: exp"

lemma [simp]: "eval (iterate n (Mult Var) k) x = x ^ n * eval k x"
  apply (induction n arbitrary: x k)
  apply auto
done

lemma iterate_more: "iterate n f (f a) = iterate (Suc n) f a"
  by simp

lemma [simp]: "f (iterate n f a) = iterate (Suc n) f a"
  apply (induction n arbitrary: f a)
  apply auto
done

lemma add_power: "(x ^ n * x :: int) = (x ^ Suc n)"
  by simp

lemma evalp_is_eval_poly:
  "(xn :: int) = x ^ n
   \<Longrightarrow> v = iterate n (Mult Var) (Const 1)
   \<Longrightarrow> evalp_helper p x xn = eval (poly_helper p v) x"
  apply (induction p arbitrary: n v x xn)
  apply simp
  apply auto
  apply (subst iterate_more)
  apply (subst add_power)
  apply blast
done

thm evalp_helper.induct

lemma [simp]: "evalp_helper (coeffs_add a b) x xn =
       evalp_helper a x xn + evalp_helper b x xn"
  apply (induction arbitrary: xn rule: coeffs_add.induct)
  apply simp
  apply simp
  apply auto
  apply (simp add: algebra_simps)
done

lemma [simp]: "evalp_helper (map (op * a) bs) x xn = a * evalp_helper bs x xn"
  apply (induction bs arbitrary: x xn)
  apply auto
  apply (simp add: algebra_simps)
done

lemma evalp_helper_evacuate_x: "evalp_helper p x (xn * x) = x * evalp_helper p x xn"
  apply (induction arbitrary: x xn rule: evalp_helper.induct)
  apply simp
  apply (simp add: algebra_simps)
done

lemma [simp]: "evalp_helper (coeffs_mult a b) x xn =
       evalp_helper a x xn * evalp_helper b x xn"
  apply (induction arbitrary: xn rule: coeffs_mult.induct)
  apply simp
  apply (simp add: algebra_simps evalp_helper_evacuate_x)

oops

theorem "evalp (coeffs e) x = eval e x"
  apply (induction e)
  apply auto
oops

fun treeset where
  "treeset Tip = {}" |
  "treeset (Node l a r) = treeset l \<union> {a} \<union> treeset r"

fun option_lt where
  "option_lt _ None = True" |
  "option_lt None _ = True" |
  "option_lt (Some x) (Some y) = (x < y)"

fun ordb :: "int tree \<Rightarrow> int option \<Rightarrow> int option \<Rightarrow> bool" where
  "ordb Tip a b = option_lt a b" |
  "ordb (Node l a r) bl br = (ordb l bl (Some a) \<and> ordb r (Some a) br)"

fun ord where "ord t = ordb t None None"

fun ins where
  "ins x Tip = Node Tip x Tip" |
  "ins x (Node l a r) =
    (if x < a then Node (ins x l) a r
    else if x = a then Node l a r
    else Node l a (ins x r))"

theorem "treeset (ins x t) = {x} \<union> treeset t"
  apply (induction t)
  apply auto
done

fun bounded where
  "bounded a c b =
    (option_lt a (Some b) \<and> option_lt (Some b) c)"

lemma [simp]:
  "ordb t l r
   \<Longrightarrow> bounded l r a
   \<Longrightarrow> ordb (ins a t) l r"
  apply (induction t arbitrary: l r)
  apply auto
done

theorem "ord t \<Longrightarrow> ord (ins x t)"
  apply (induction t)
  apply auto
done

lemma "\<lbrakk> xs @ ys = ys @ xs; length xs = length ys \<rbrakk> \<Longrightarrow> xs = ys"
  using append_eq_append_conv by blast

inductive palindrome :: "'a list \<Rightarrow> bool" where
  "palindrome []" |
  "palindrome [a]" |
  "palindrome xs \<Longrightarrow> palindrome (a # xs @ [a])"

fun init where
  "init [] = []" |
  "init [_] = []" |
  "init (x # xs) = x # init xs"

lemma unsnoc: "(xs = []) \<or> (\<exists>ys x. xs = ys @ [x])"
  apply (cases xs)
  apply simp
  apply (metis append_butlast_last_id)
done

theorem "rev xs = xs \<Longrightarrow> palindrome xs"
  apply (induction xs)
  apply (simp add: palindrome.intros)
oops

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  star_refl: "star r x x" |
  star_step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  star'_refl: "star' r x x" |
  star'_step: "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

theorem "star' r x y \<Longrightarrow> star r x y"
  apply (induction rule: star'.induct)
  apply (simp add: star.intros)
oops

theorem "star' r x y \<Longrightarrow> star r x y"
oops

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "iter r 0 x x" |
  "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

theorem "star r x y \<Longrightarrow> iter r n x y"
  nitpick
oops

datatype alpha = a | b

inductive S where
  "S []" |
  "S x \<Longrightarrow> S (a # x @ [b])" |
  "S x \<Longrightarrow> S y \<Longrightarrow> S (x @ y)"

inductive T where
  "T []" |
  "T x \<Longrightarrow> T y \<Longrightarrow> T (x @ [a] @ y @ [b])"

theorem "S w \<Longrightarrow> T w"
  apply (induction rule: S.induct)
  apply (simp add: T.intros)
oops

value "(0 - 1 :: nat) = 0"
value "1 div 0 :: int"