(*
    Author:     Wenda Li <wl302@cam.ac.uk / liwenda1990@hotmail.com>
*)
theory Count_Line imports
  CC_Polynomials_Extra
  Winding_Number_Eval.Winding_Number_Eval
  Extended_Sturm
  Budan_Fourier.Sturm_Multiple_Roots
begin

subsection \<open>Misc\<close>

lemma closed_segment_imp_Re_Im:
  fixes x::complex
  assumes "x\<in>closed_segment lb ub"
  shows "Re lb \<le> Re ub \<Longrightarrow> Re lb \<le> Re x \<and> Re x \<le> Re ub"
        "Im lb \<le> Im ub \<Longrightarrow> Im lb \<le> Im x \<and> Im x \<le> Im ub"
proof -
  obtain u where x_u:"x=(1 - u) *\<^sub>R lb + u *\<^sub>R ub " and "0 \<le> u" "u \<le> 1"
    using assms unfolding closed_segment_def by auto
  have "Re lb \<le> Re x" when "Re lb \<le> Re ub"
  proof -
    have "Re x = Re ((1 - u) *\<^sub>R lb + u *\<^sub>R ub)"
      using x_u by blast
    also have "... = Re (lb + u *\<^sub>R (ub - lb))" by (auto simp add:algebra_simps)
    also have "... = Re lb + u * (Re ub - Re lb)" by auto
    also have "... \<ge> Re lb" using \<open>u\<ge>0\<close> \<open>Re lb \<le> Re ub\<close> by auto
    finally show ?thesis .
  qed
  moreover have "Im lb \<le> Im x" when "Im lb \<le> Im ub"
  proof -
    have "Im x = Im ((1 - u) *\<^sub>R lb + u *\<^sub>R ub)"
      using x_u by blast
    also have "... = Im (lb + u *\<^sub>R (ub - lb))" by (auto simp add:algebra_simps)
    also have "... = Im lb + u * (Im ub - Im lb)" by auto
    also have "... \<ge> Im lb" using \<open>u\<ge>0\<close> \<open>Im lb \<le> Im ub\<close> by auto
    finally show ?thesis .
  qed
  moreover have "Re x \<le> Re ub" when "Re lb \<le> Re ub"
  proof -
    have "Re x = Re ((1 - u) *\<^sub>R lb + u *\<^sub>R ub)"
      using x_u by blast
    also have "... = (1 - u) * Re lb + u * Re ub" by auto
    also have "... \<le> (1 - u) * Re ub + u * Re ub"
      using \<open>u\<le>1\<close> \<open>Re lb \<le> Re ub\<close> by (auto simp add: mult_left_mono)
    also have "... = Re ub" by (auto simp add:algebra_simps)
    finally show ?thesis .
  qed
  moreover have "Im x \<le> Im ub" when "Im lb \<le> Im ub"
  proof -
    have "Im x = Im ((1 - u) *\<^sub>R lb + u *\<^sub>R ub)"
      using x_u by blast
    also have "... = (1 - u) * Im lb + u * Im ub" by auto
    also have "... \<le> (1 - u) * Im ub + u * Im ub"
      using \<open>u\<le>1\<close> \<open>Im lb \<le> Im ub\<close> by (auto simp add: mult_left_mono)
    also have "... = Im ub" by (auto simp add:algebra_simps)
    finally show ?thesis .
  qed
  ultimately show
      "Re lb \<le> Re ub \<Longrightarrow> Re lb \<le> Re x \<and> Re x \<le> Re ub"
      "Im lb \<le> Im ub \<Longrightarrow> Im lb \<le> Im x \<and> Im x \<le> Im ub"
    by auto
qed

lemma closed_segment_degen_complex:
  "\<lbrakk>Re lb = Re ub; Im lb \<le> Im ub \<rbrakk>
    \<Longrightarrow> x \<in> closed_segment lb ub \<longleftrightarrow> Re x = Re lb \<and> Im lb \<le> Im x \<and> Im x \<le> Im ub "
  "\<lbrakk>Im lb = Im ub; Re lb \<le> Re ub \<rbrakk>
    \<Longrightarrow> x \<in> closed_segment lb ub \<longleftrightarrow> Im x = Im lb \<and> Re lb \<le> Re x \<and> Re x \<le> Re ub "
proof -
  show "x \<in> closed_segment lb ub \<longleftrightarrow> Re x = Re lb \<and> Im lb \<le> Im x \<and> Im x \<le> Im ub"
    when "Re lb = Re ub" "Im lb \<le> Im ub"
  proof
    show "Re x = Re lb \<and> Im lb \<le> Im x \<and> Im x \<le> Im ub" when "x \<in> closed_segment lb ub"
      using closed_segment_imp_Re_Im[OF that] \<open>Re lb = Re ub\<close> \<open>Im lb \<le> Im ub\<close> by fastforce
  next
    assume asm:"Re x = Re lb \<and> Im lb \<le> Im x \<and> Im x \<le> Im ub"
    define u where "u=(Im x - Im lb)/ (Im ub - Im lb)"
    have "x = (1 - u) *\<^sub>R lb + u *\<^sub>R ub"
      unfolding u_def using asm \<open>Re lb = Re ub\<close> \<open>Im lb \<le> Im ub\<close>
      apply (intro complex_eqI)
      apply (auto simp add:field_simps)
      apply (cases "Im ub - Im lb =0")
      apply (auto simp add:field_simps)
      done
    moreover have "0\<le>u" "u\<le>1" unfolding u_def
      using \<open>Im lb \<le> Im ub\<close> asm
      by (cases "Im ub - Im lb =0",auto simp add:field_simps)+
    ultimately show "x \<in> closed_segment lb ub" unfolding closed_segment_def by auto
  qed
  show "x \<in> closed_segment lb ub \<longleftrightarrow> Im x = Im lb \<and> Re lb \<le> Re x \<and> Re x \<le> Re ub"
    when "Im lb = Im ub" "Re lb \<le> Re ub"
  proof
    show "Im x = Im lb \<and> Re lb \<le> Re x \<and> Re x \<le> Re ub" when "x \<in> closed_segment lb ub"
      using closed_segment_imp_Re_Im[OF that] \<open>Im lb = Im ub\<close> \<open>Re lb \<le> Re ub\<close> by fastforce
  next
    assume asm:"Im x = Im lb \<and> Re lb \<le> Re x \<and> Re x \<le> Re ub"
    define u where "u=(Re x - Re lb)/ (Re ub - Re lb)"
    have "x = (1 - u) *\<^sub>R lb + u *\<^sub>R ub"
      unfolding u_def using asm \<open>Im lb = Im ub\<close> \<open>Re lb \<le> Re ub\<close>
      apply (intro complex_eqI)
       apply (auto simp add:field_simps)
      apply (cases "Re ub - Re lb =0")
       apply (auto simp add:field_simps)
      done
    moreover have "0\<le>u" "u\<le>1" unfolding u_def
      using \<open>Re lb \<le> Re ub\<close> asm
      by (cases "Re ub - Re lb =0",auto simp add:field_simps)+
    ultimately show "x \<in> closed_segment lb ub" unfolding closed_segment_def by auto
  qed
qed

(*refined version of the library one with the same name by dropping unnecessary assumptions*)
corollary path_image_part_circlepath_subset:
  assumes "r\<ge>0"
  shows "path_image(part_circlepath z r st tt) \<subseteq> sphere z r"
proof (cases "st\<le>tt")
  case True
  then show ?thesis
    by (auto simp: assms path_image_part_circlepath sphere_def dist_norm algebra_simps norm_mult)
next
  case False
  then have "path_image(part_circlepath z r tt st) \<subseteq> sphere z r"
    by (auto simp: assms path_image_part_circlepath sphere_def dist_norm algebra_simps norm_mult)
  moreover have "path_image(part_circlepath z r tt st) = path_image(part_circlepath z r st tt)"
    using path_image_reversepath by fastforce
  ultimately show ?thesis by auto
qed

(*refined version of the library one with the same name by dropping unnecessary assumptions*)
proposition in_path_image_part_circlepath:
  assumes "w \<in> path_image(part_circlepath z r st tt)" "0 \<le> r"
  shows "norm(w - z) = r"
proof -
  have "w \<in> {c. dist z c = r}"
    by (metis (no_types) path_image_part_circlepath_subset sphere_def subset_eq assms)
  thus ?thesis
    by (simp add: dist_norm norm_minus_commute)
qed

lemma infinite_ball:
  fixes a :: "'a::euclidean_space"
  assumes "r > 0"
  shows "infinite (ball a r)"
  using uncountable_ball[OF assms, THEN uncountable_infinite] .

lemma infinite_cball:
  fixes a :: "'a::euclidean_space"
  assumes "r > 0"
  shows "infinite (cball a r)"
  using uncountable_cball[OF assms, THEN uncountable_infinite,of a] .

(*FIXME: to generalise*)
lemma infinite_sphere:
  fixes a :: complex
  assumes "r > 0"
  shows "infinite (sphere a r)"
proof -
  have "uncountable (path_image (circlepath a r))"
    apply (rule simple_path_image_uncountable)
    using simple_path_circlepath assms by simp
  then have "uncountable (sphere a r)"
    using assms by simp
  from uncountable_infinite[OF this] show ?thesis .
qed

lemma infinite_halfspace_Im_gt: "infinite {x. Im x > b}"
  apply (rule connected_uncountable[THEN uncountable_infinite,of _ "(b+1)* \<i>" "(b+2)*\<i>"])
  by (auto intro!:convex_connected simp add: convex_halfspace_Im_gt)

lemma (in ring_1) Ints_minus2: "- a \<in> \<int> \<Longrightarrow> a \<in> \<int>"
  using Ints_minus[of "-a"] by auto

lemma dvd_divide_Ints_iff:
  "b dvd a \<or> b=0 \<longleftrightarrow> of_int a / of_int b \<in> (\<int> :: 'a :: {field,ring_char_0} set)"
proof
  assume asm:"b dvd a \<or> b=0"
  let ?thesis = "of_int a / of_int b \<in> (\<int> :: 'a :: {field,ring_char_0} set)"
  have ?thesis when "b dvd a"
  proof -
    obtain c where "a=b * c" using \<open>b dvd a\<close> unfolding dvd_def by auto
    then show ?thesis by (auto simp add:field_simps)
  qed
  moreover have ?thesis when "b=0"
    using that by auto
  ultimately show ?thesis using asm by auto
next
  assume "of_int a / of_int b \<in> (\<int> :: 'a :: {field,ring_char_0} set)"
  from Ints_cases[OF this] obtain c where *:"(of_int::_ \<Rightarrow> 'a) c= of_int a / of_int b"
    by metis
  have "b dvd a" when "b\<noteq>0"
  proof -
    have "(of_int::_ \<Rightarrow> 'a) a = of_int b * of_int c" using that * by auto
    then have "a = b * c" using of_int_eq_iff by fastforce
    then show ?thesis unfolding dvd_def by auto
  qed
  then show " b dvd a \<or> b = 0" by auto
qed

lemma of_int_div_field:
  assumes "d dvd n"
  shows "(of_int::_\<Rightarrow>'a::field_char_0) (n div d) = of_int n / of_int d"
  apply (subst (2) dvd_mult_div_cancel[OF assms,symmetric])
  by (auto simp add:field_simps)

lemma powr_eq_1_iff:
  assumes "a>0"
  shows "(a::real) powr b =1 \<longleftrightarrow> a=1 \<or> b=0"
proof
  assume "a powr b = 1"
  have "b * ln a = 0"
    using \<open>a powr b = 1\<close> ln_powr[of a b] assms by auto
  then have "b=0 \<or> ln a =0" by auto
  then show "a = 1 \<or> b = 0" using assms by auto
qed (insert assms, auto)

lemma tan_inj_pi:
  "- (pi/2) < x \<Longrightarrow> x < pi/2 \<Longrightarrow> - (pi/2) < y \<Longrightarrow> y < pi/2 \<Longrightarrow> tan x = tan y \<Longrightarrow> x = y"
  by (metis arctan_tan)

(*TODO: can we avoid fcompose in the proof?*)
lemma finite_ReZ_segments_poly_circlepath:
          "finite_ReZ_segments (poly p \<circ> circlepath z0 r) 0"
proof (cases "\<forall>t\<in>({0..1} - {1/2}). Re ((poly p \<circ> circlepath z0 r) t) = 0")
  case True
  have "isCont (Re \<circ> poly p \<circ> circlepath z0 r) (1/2)"
    by (auto intro!:continuous_intros simp:circlepath)
  moreover have "(Re \<circ> poly p \<circ> circlepath z0 r)\<midarrow> 1/2 \<rightarrow> 0"
  proof -
    have "\<forall>\<^sub>F x in at (1 / 2). (Re \<circ> poly p \<circ> circlepath z0 r) x = 0"
      unfolding eventually_at_le
      apply (rule exI[where x="1/2"])
      unfolding dist_real_def abs_diff_le_iff
      by (auto intro!:True[rule_format, unfolded comp_def])
    then show ?thesis by (rule tendsto_eventually)
  qed
  ultimately have "Re ((poly p \<circ> circlepath z0 r) (1/2)) = 0"
    unfolding comp_def by (simp add: LIM_unique continuous_within)
  then have "\<forall>t\<in>{0..1}. Re ((poly p \<circ> circlepath z0 r) t) = 0"
    using True by blast
  then show ?thesis
    apply (rule_tac finite_ReZ_segments_constI[THEN finite_ReZ_segments_congE])
    by auto
next
  case False
   define q1 q2 where "q1=fcompose p [:(z0+r)*\<i>,z0-r:] [:\<i>,1:]" and
                      "q2=([:\<i>, 1:] ^ degree p)"
  define q1R q1I where "q1R=map_poly Re q1" and "q1I=map_poly Im q1"
  define q2R q2I where "q2R=map_poly Re q2" and "q2I=map_poly Im q2"
  define qq where "qq=q1R*q2R + q1I*q2I"

  have poly_eq:"Re ((poly p \<circ> circlepath z0 r) t) = 0 \<longleftrightarrow> poly qq (tan (pi * t)) = 0"
    when "0\<le>t" "t\<le>1" "t\<noteq>1/2" for t
  proof -
    define tt where "tt=tan (pi * t)"
    have "Re ((poly p \<circ> circlepath z0 r) t) = 0 \<longleftrightarrow> Re (poly q1 tt / poly q2 tt) = 0"
      unfolding comp_def
      apply (subst poly_circlepath_tan_eq[of t p z0 r,folded q1_def q2_def tt_def])
      using that by simp_all
    also have "... \<longleftrightarrow> poly q1R tt * poly q2R tt + poly q1I tt * poly q2I tt = 0"
      unfolding q1I_def q1R_def q2R_def q2I_def
      by (simp add:Re_complex_div_eq_0 Re_poly_of_real Im_poly_of_real)
    also have "... \<longleftrightarrow> poly qq tt = 0"
      unfolding qq_def by simp
    finally show ?thesis unfolding tt_def .
  qed

  have "finite {t. Re ((poly p \<circ> circlepath z0 r) t) = 0 \<and> 0 \<le> t \<and> t \<le> 1}"
  proof -
    define P where "P=(\<lambda>t. Re ((poly p \<circ> circlepath z0 r) t) = 0)"
    define A where "A= ({0..1}::real set)"
    define S where "S={t\<in>A-{1,1/2}. P t}"
    have "finite {t. poly qq (tan (pi * t)) = 0 \<and> 0 \<le> t \<and> t < 1 \<and> t\<noteq>1/2}"
    proof -
      define A where "A={t::real. 0 \<le> t \<and> t < 1 \<and> t \<noteq> 1 / 2}"
      have "finite ((\<lambda>t. tan (pi * t))  -`  {x. poly qq x=0} \<inter> A)"
      proof (rule finite_vimage_IntI)
        have "x = y" when "tan (pi * x) = tan (pi * y)" "x\<in>A" "y\<in>A" for x y
        proof -
          define x' where "x'=(if x<1/2 then x else x-1)"
          define y' where "y'=(if y<1/2 then y else y-1)"
          have "x'*pi = y'*pi"
          proof (rule tan_inj_pi)
            have *:"- 1 / 2 < x'" "x' < 1 / 2" "- 1 / 2 < y'" "y' < 1 / 2"
              using that(2,3) unfolding x'_def y'_def A_def by simp_all
            show "- (pi / 2) < x'  * pi" "x'  * pi < pi / 2" "- (pi / 2) < y'  * pi"
                  "y'*pi < pi / 2"
              using mult_strict_right_mono[OF *(1),of pi]
                    mult_strict_right_mono[OF *(2),of pi]
                    mult_strict_right_mono[OF *(3),of pi]
                    mult_strict_right_mono[OF *(4),of pi]
              by auto
          next
            have "tan (x' * pi) = tan (x * pi)"
              unfolding x'_def using tan_periodic_int[of _ "- 1",simplified]
              by (auto simp add:algebra_simps)
            also have "... = tan (y * pi)"
              using \<open>tan (pi * x) = tan (pi * y)\<close> by (auto simp:algebra_simps)
            also have "... = tan (y' * pi)"
              unfolding y'_def using tan_periodic_int[of _ "- 1",simplified]
              by (auto simp add:algebra_simps)
            finally show "tan (x' * pi) = tan (y' * pi)" .
          qed
          then have "x'=y'" by auto
          then show ?thesis
            using that(2,3) unfolding x'_def y'_def A_def by (auto split:if_splits)
        qed
        then show "inj_on (\<lambda>t. tan (pi * t)) A"
          unfolding inj_on_def by blast
      next
        have "qq\<noteq>0"
        proof (rule ccontr)
          assume "\<not> qq \<noteq> 0"
          then have "Re ((poly p \<circ> circlepath z0 r) t) = 0" when "t\<in>{0..1} - {1/2}" for t
            apply (subst poly_eq)
            using that by auto
          then show False using False by blast
        qed
        then show "finite {x. poly qq x = 0}" by (simp add: poly_roots_finite)
      qed
      then show ?thesis by (elim rev_finite_subset) (auto simp:A_def)
    qed
    moreover have "{t. poly qq (tan (pi * t)) = 0 \<and> 0 \<le> t \<and> t < 1 \<and> t\<noteq>1/2} = S"
      unfolding S_def P_def A_def using poly_eq by force
    ultimately have "finite S" by blast
    then have "finite (S \<union> (if P 1 then {1} else {}) \<union> (if P (1/2) then {1/2} else {}))"
      by auto
    moreover have "(S \<union> (if P 1 then {1} else {}) \<union> (if P (1/2) then {1/2} else {}))
                      = {t. P t \<and> 0 \<le> t \<and> t \<le> 1}"
    proof -
      have "1\<in>A" "1/2 \<in>A" unfolding A_def by auto
      then have "(S \<union> (if P 1 then {1} else {}) \<union> (if P (1/2) then {1/2} else {}))
                      = {t\<in>A. P t}"
        unfolding S_def
        apply auto
        by (metis eq_divide_eq_numeral1(1) zero_neq_numeral)+
      also have "... = {t. P t \<and> 0 \<le> t \<and> t \<le> 1}"
        unfolding A_def by auto
      finally show ?thesis .
    qed
    ultimately have "finite {t. P t \<and> 0 \<le> t \<and> t \<le> 1}" by auto
    then show ?thesis unfolding P_def by simp
  qed
  then show ?thesis
    apply (rule_tac finite_imp_finite_ReZ_segments)
    by auto
qed

lemma changes_itv_smods_ext_geq_0:
  assumes "a<b" "poly p a\<noteq>0" "poly p b \<noteq>0"
  shows "changes_itv_smods_ext a b p (pderiv p) \<ge>0"
  using sturm_ext_interval[OF assms] by auto

subsection \<open>Some useful conformal/@{term bij_betw} properties\<close>

lemma bij_betw_plane_ball:"bij_betw (\<lambda>x. (\<i>-x)/(\<i>+x)) {x. Im x>0} (ball 0 1)"
proof (rule bij_betw_imageI)
  have neq:"\<i> + x \<noteq>0" when "Im x>0" for x
    using that
    by (metis add_less_same_cancel2 add_uminus_conv_diff diff_0 diff_add_cancel
        imaginary_unit.simps(2) not_one_less_zero uminus_complex.sel(2))
  then show "inj_on (\<lambda>x. (\<i> - x) / (\<i> + x)) {x. 0 < Im x}"
    unfolding inj_on_def by (auto simp add:divide_simps algebra_simps)
  have "cmod ((\<i> - x) / (\<i> + x)) < 1" when "0 < Im x " for x
  proof -
    have "cmod (\<i> - x) < cmod (\<i> + x)"
      unfolding norm_lt inner_complex_def using that
      by (auto simp add:algebra_simps)
    then show ?thesis
      unfolding norm_divide using neq[OF that] by auto
  qed
  moreover have "x \<in> (\<lambda>x. (\<i> - x) / (\<i> + x)) ` {x. 0 < Im x}" when "cmod x < 1" for x
  proof (rule rev_image_eqI[of "\<i>*(1-x)/(1+x)"])
    have "1 + x\<noteq>0" "\<i> * 2 + \<i> * (x * 2) \<noteq>0"
      subgoal using that by (metis complex_mod_triangle_sub norm_one norm_zero not_le pth_7(1))
      subgoal using that by (metis \<open>1 + x \<noteq> 0\<close> complex_i_not_zero div_mult_self4 mult_2
            mult_zero_right nonzero_mult_div_cancel_left nonzero_mult_div_cancel_right
            one_add_one zero_neq_numeral)
      done
    then show "x = (\<i> - \<i> * (1 - x) / (1 + x)) / (\<i> + \<i> * (1 - x) / (1 + x))"
      by (auto simp add:field_simps)
    show " \<i> * (1 - x) / (1 + x) \<in> {x. 0 < Im x}"
      apply (auto simp:Im_complex_div_gt_0 algebra_simps)
      using that unfolding cmod_def by (auto simp:power2_eq_square)
  qed
  ultimately show "(\<lambda>x. (\<i> - x) / (\<i> + x)) ` {x. 0 < Im x} = ball 0 1"
    by auto
qed

lemma bij_betw_axis_sphere:"bij_betw (\<lambda>x. (\<i>-x)/(\<i>+x)) {x. Im x=0} (sphere 0 1 - {-1})"
proof (rule bij_betw_imageI)
  have neq:"\<i> + x \<noteq>0" when "Im x=0" for x
    using that
    by (metis add_diff_cancel_left' imaginary_unit.simps(2) minus_complex.simps(2)
         right_minus_eq zero_complex.simps(2) zero_neq_one)
  then show "inj_on (\<lambda>x. (\<i> - x) / (\<i> + x)) {x. Im x = 0}"
    unfolding inj_on_def by (auto simp add:divide_simps algebra_simps)
  have "cmod ((\<i> - x) / (\<i> + x)) = 1" "(\<i> - x) / (\<i> + x) \<noteq> - 1" when "Im x = 0" for x
  proof -
    have "cmod (\<i> + x) = cmod (\<i> - x)"
      using that unfolding cmod_def by auto
    then show "cmod ((\<i> - x) / (\<i> + x)) = 1"
      unfolding norm_divide using neq[OF that] by auto
    show "(\<i> - x) / (\<i> + x) \<noteq> - 1" using neq[OF that] by (auto simp add:divide_simps)
  qed
  moreover have "x \<in> (\<lambda>x. (\<i> - x) / (\<i> + x)) ` {x. Im x = 0}"
    when "cmod x = 1" "x\<noteq>-1" for x
  proof (rule rev_image_eqI[of "\<i>*(1-x)/(1+x)"])
    have "1 + x\<noteq>0" "\<i> * 2 + \<i> * (x * 2) \<noteq>0"
      subgoal using that(2) by algebra
      subgoal using that by (metis \<open>1 + x \<noteq> 0\<close> complex_i_not_zero div_mult_self4 mult_2
            mult_zero_right nonzero_mult_div_cancel_left nonzero_mult_div_cancel_right
            one_add_one zero_neq_numeral)
      done
    then show "x = (\<i> - \<i> * (1 - x) / (1 + x)) / (\<i> + \<i> * (1 - x) / (1 + x))"
      by (auto simp add:field_simps)
    show " \<i> * (1 - x) / (1 + x) \<in> {x. Im x = 0}"
      apply (auto simp:algebra_simps Im_complex_div_eq_0)
      using that(1) unfolding cmod_def by (auto simp:power2_eq_square)
  qed
  ultimately show "(\<lambda>x. (\<i> - x) / (\<i> + x)) ` {x. Im x = 0} = sphere 0 1 - {- 1}"
    by force
qed

lemma bij_betw_ball_uball:
  assumes "r>0"
  shows "bij_betw (\<lambda>x. complex_of_real r*x + z0) (ball 0 1) (ball z0 r)"
proof (rule bij_betw_imageI)
  show "inj_on (\<lambda>x. complex_of_real r * x + z0) (ball 0 1)"
    unfolding inj_on_def using assms by simp
  have "dist z0 (complex_of_real r * x + z0) < r" when "cmod x<1" for x
    using that assms by (auto simp:dist_norm norm_mult abs_of_pos)
  moreover have "x \<in> (\<lambda>x. complex_of_real r * x + z0) ` ball 0 1" when "dist z0 x < r" for x
    apply (rule rev_image_eqI[of "(x-z0)/r"])
    using that assms by (auto simp add: dist_norm norm_divide norm_minus_commute)
  ultimately show "(\<lambda>x. complex_of_real r  * x + z0) ` ball 0 1 = ball z0 r"
    by auto
qed

lemma bij_betw_sphere_usphere:
  assumes "r>0"
  shows "bij_betw (\<lambda>x. complex_of_real r*x + z0) (sphere 0 1) (sphere z0 r)"
proof (rule bij_betw_imageI)
  show "inj_on (\<lambda>x. complex_of_real r * x + z0) (sphere 0 1)"
    unfolding inj_on_def using assms by simp
  have "dist z0 (complex_of_real r * x + z0) = r" when "cmod x=1" for x
    using that assms by (auto simp:dist_norm norm_mult abs_of_pos)
  moreover have "x \<in> (\<lambda>x. complex_of_real r * x + z0) ` sphere 0 1" when "dist z0 x = r" for x
    apply (rule rev_image_eqI[of "(x-z0)/r"])
    using that assms by (auto simp add: dist_norm norm_divide norm_minus_commute)
  ultimately show "(\<lambda>x. complex_of_real r  * x + z0) ` sphere 0 1 = sphere z0 r"
    by auto
qed

lemma proots_ball_plane_eq:
  defines "q1\<equiv>[:\<i>,-1:]" and "q2\<equiv>[:\<i>,1:]"
  assumes "p\<noteq>0"
  shows "proots_count p (ball 0 1) = proots_count (fcompose p q1 q2) {x. 0 < Im x}"
  unfolding q1_def q2_def
proof (rule proots_fcompose_bij_eq[OF _ \<open>p\<noteq>0\<close>])
  show "\<forall>x\<in>{x. 0 < Im x}. poly [:\<i>, 1:] x \<noteq> 0"
    apply simp
    by (metis add_less_same_cancel2 imaginary_unit.simps(2) not_one_less_zero
          plus_complex.simps(2) zero_complex.simps(2))
  show "infinite (UNIV::complex set)" by (simp add: infinite_UNIV_char_0)
qed (use bij_betw_plane_ball in auto)

lemma proots_sphere_axis_eq:
  defines "q1\<equiv>[:\<i>,-1:]" and "q2\<equiv>[:\<i>,1:]"
  assumes "p\<noteq>0"
  shows "proots_count p (sphere 0 1 - {- 1}) = proots_count (fcompose p q1 q2) {x. 0 = Im x}"
unfolding q1_def q2_def
proof (rule proots_fcompose_bij_eq[OF _ \<open>p\<noteq>0\<close>])
  show "\<forall>x\<in>{x. 0 = Im x}. poly [:\<i>, 1:] x \<noteq> 0" by (simp add: Complex_eq_0 plus_complex.code)
  show "infinite (UNIV::complex set)" by (simp add: infinite_UNIV_char_0)
qed (use bij_betw_axis_sphere in auto)

lemma proots_card_ball_plane_eq:
  defines "q1\<equiv>[:\<i>,-1:]" and "q2\<equiv>[:\<i>,1:]"
  assumes "p\<noteq>0"
  shows "card (proots_within p (ball 0 1)) = card (proots_within (fcompose p q1 q2) {x. 0 < Im x})"
unfolding q1_def q2_def
proof (rule proots_card_fcompose_bij_eq[OF _ \<open>p\<noteq>0\<close>])
  show "\<forall>x\<in>{x. 0 < Im x}. poly [:\<i>, 1:] x \<noteq> 0"
    apply simp
    by (metis add_less_same_cancel2 imaginary_unit.simps(2) not_one_less_zero
          plus_complex.simps(2) zero_complex.simps(2))
qed (use bij_betw_plane_ball infinite_UNIV_char_0 in auto)

lemma proots_card_sphere_axis_eq:
  defines "q1\<equiv>[:\<i>,-1:]" and "q2\<equiv>[:\<i>,1:]"
  assumes "p\<noteq>0"
  shows "card (proots_within p (sphere 0 1 - {- 1}))
            = card (proots_within (fcompose p q1 q2) {x. 0 = Im x})"
unfolding q1_def q2_def
proof (rule proots_card_fcompose_bij_eq[OF _ \<open>p\<noteq>0\<close>])
  show "\<forall>x\<in>{x. 0 = Im x}. poly [:\<i>, 1:] x \<noteq> 0" by (simp add: Complex_eq_0 plus_complex.code)
qed (use bij_betw_axis_sphere infinite_UNIV_char_0 in auto)

lemma proots_uball_eq:
  fixes z0::complex and r::real
  defines "q\<equiv>[:z0, of_real r:]"
  assumes "p\<noteq>0" and "r>0"
  shows "proots_count p (ball z0 r) = proots_count (p \<circ>\<^sub>p q) (ball 0 1)"
proof -
  show ?thesis
    apply (rule proots_pcompose_bij_eq[OF _ \<open>p\<noteq>0\<close>])
    subgoal unfolding q_def using bij_betw_ball_uball[OF \<open>r>0\<close>,of z0] by (auto simp:algebra_simps)
    subgoal unfolding q_def using \<open>r>0\<close> by auto
    done
qed

lemma proots_card_uball_eq:
  fixes z0::complex and r::real
  defines "q\<equiv>[:z0, of_real r:]"
  assumes "r>0"
  shows "card (proots_within p (ball z0 r)) = card (proots_within (p \<circ>\<^sub>p q) (ball 0 1))"
proof -
  have ?thesis
    when "p=0"
  proof -
    have "card (ball z0 r) = 0" "card (ball (0::complex) 1) = 0"
      using infinite_ball[OF \<open>r>0\<close>,of z0] infinite_ball[of 1 "0::complex"] by auto
    then show ?thesis using that by auto
  qed
  moreover have ?thesis
    when "p\<noteq>0"
    apply (rule proots_card_pcompose_bij_eq[OF _ \<open>p\<noteq>0\<close>])
    subgoal unfolding q_def using bij_betw_ball_uball[OF \<open>r>0\<close>,of z0] by (auto simp:algebra_simps)
    subgoal unfolding q_def using \<open>r>0\<close> by auto
    done
  ultimately show ?thesis
    by blast
qed

lemma proots_card_usphere_eq:
  fixes z0::complex and r::real
  defines "q\<equiv>[:z0, of_real r:]"
  assumes "r>0"
  shows "card (proots_within p (sphere z0 r)) = card (proots_within (p \<circ>\<^sub>p q) (sphere 0 1))"
proof -
  have ?thesis
    when "p=0"
  proof -
    have "card (sphere z0 r) = 0" "card (sphere (0::complex) 1) = 0"
      using infinite_sphere[OF \<open>r>0\<close>,of z0] infinite_sphere[of 1 "0::complex"] by auto
    then show ?thesis using that by auto
  qed
  moreover have ?thesis
    when "p\<noteq>0"
    apply (rule proots_card_pcompose_bij_eq[OF _ \<open>p\<noteq>0\<close>])
    subgoal unfolding q_def using bij_betw_sphere_usphere[OF \<open>r>0\<close>,of z0]
      by (auto simp:algebra_simps)
    subgoal unfolding q_def using \<open>r>0\<close> by auto
    done
  ultimately show "card (proots_within p (sphere z0 r)) = card (proots_within (p \<circ>\<^sub>p q) (sphere 0 1))"
    by blast
qed

subsection \<open>Number of roots on a (bounded or unbounded) segment\<close>

\<comment> \<open>1 dimensional hyperplane\<close>
definition unbounded_line::"'a::real_vector \<Rightarrow> 'a \<Rightarrow> 'a set" where
   "unbounded_line a b = ({x. \<exists>u::real. x= (1 - u) *\<^sub>R a + u *\<^sub>R b})"

definition proots_line_card:: "complex poly \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> nat" where
  "proots_line_card p st tt = card (proots_within p (open_segment st tt))"

definition proots_unbounded_line_card:: "complex poly \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> nat" where
  "proots_unbounded_line_card p st tt = card (proots_within p (unbounded_line st tt))"

definition proots_unbounded_line :: "complex poly \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> nat" where
  "proots_unbounded_line p st tt = proots_count p (unbounded_line st tt)"

lemma card_proots_open_segments:
  assumes "poly p st \<noteq>0" "poly p tt \<noteq> 0"
  shows "card (proots_within p (open_segment st tt)) =
                (let pc = pcompose p [:st, tt - st:];
                     pR = map_poly Re pc;
                     pI = map_poly Im pc;
                     g  = gcd pR pI
                 in changes_itv_smods 0 1 g (pderiv g))" (is "?L = ?R")
proof -
  define pc pR pI g where
      "pc = pcompose p [:st, tt-st:]" and
      "pR = map_poly Re pc" and
      "pI = map_poly Im pc" and
      "g  = gcd pR pI"
  have poly_iff:"poly g t=0 \<longleftrightarrow> poly pc t =0" for t
  proof -
    have "poly g t = 0 \<longleftrightarrow> poly pR t =0 \<and> poly pI t =0"
      unfolding g_def using poly_gcd_0_iff by auto
    also have "... \<longleftrightarrow> poly pc t =0"
    proof -
      have "cpoly_of pR pI = pc"
        unfolding pc_def pR_def pI_def using cpoly_of_decompose by auto
      then show ?thesis using poly_cpoly_of_real_iff by blast
    qed
    finally show ?thesis by auto
  qed

  have "?R = changes_itv_smods 0 1 g (pderiv g)"
    unfolding pc_def g_def pI_def pR_def by (auto simp add:Let_def)
  also have "... = card {t. poly g t = 0 \<and> 0 < t \<and> t < 1}"
  proof -
    have "poly g 0 \<noteq> 0"
      using poly_iff[of 0] assms unfolding pc_def by (auto simp add:poly_pcompose)
    moreover have "poly g 1 \<noteq> 0"
      using poly_iff[of 1] assms unfolding pc_def by (auto simp add:poly_pcompose)
    ultimately show ?thesis using sturm_interval[of 0 1 g] by auto
  qed
  also have "... = card {t::real. poly pc (of_real t) = 0 \<and> 0 < t \<and> t < 1}"
    unfolding poly_iff by simp
  also have "... = ?L"
  proof (cases "st=tt")
    case True
    then show ?thesis unfolding pc_def poly_pcompose using \<open>poly p tt \<noteq> 0\<close>
      by auto
  next
    case False
    define ff where "ff = (\<lambda>t::real. st + t*(tt-st))"
    define ll where "ll = {t. poly pc (complex_of_real t) = 0 \<and> 0 < t \<and> t < 1}"
    have "ff ` ll = proots_within p (open_segment st tt)"
    proof (rule equalityI)
      show "ff ` ll \<subseteq> proots_within p (open_segment st tt)"
        unfolding ll_def ff_def pc_def poly_pcompose
        by (auto simp add:in_segment False scaleR_conv_of_real algebra_simps)
    next
      show "proots_within p (open_segment st tt) \<subseteq> ff ` ll"
      proof clarify
        fix x assume asm:"x \<in> proots_within p (open_segment st tt)"
        then obtain u where "0<u" and "u < 1" and u:"x = (1 - u) *\<^sub>R st + u *\<^sub>R tt"
          by (auto simp add:in_segment)
        then have "poly p ((1 - u) *\<^sub>R st + u *\<^sub>R tt) = 0" using asm by simp
        then have "u \<in> ll"
          unfolding ll_def pc_def poly_pcompose
          by (simp add:scaleR_conv_of_real algebra_simps \<open>0<u\<close> \<open>u<1\<close>)
        moreover have "x = ff u"
          unfolding ff_def using u by (auto simp add:algebra_simps scaleR_conv_of_real)
        ultimately show "x \<in> ff ` ll" by (rule rev_image_eqI[of "u"])
      qed
    qed
    moreover have "inj_on ff ll"
      unfolding ff_def using False inj_on_def by fastforce
    ultimately show ?thesis unfolding ll_def
      using card_image[of ff] by fastforce
  qed
  finally show ?thesis by simp
qed

lemma unbounded_line_closed_segment: "closed_segment a b \<subseteq> unbounded_line a b"
  unfolding unbounded_line_def closed_segment_def by auto

lemma card_proots_unbounded_line:
  assumes "st\<noteq>tt"
  shows "card (proots_within p (unbounded_line st tt)) =
                (let pc = pcompose p [:st, tt - st:];
                     pR = map_poly Re pc;
                     pI = map_poly Im pc;
                     g  = gcd pR pI
                 in nat (changes_R_smods g (pderiv g)))" (is "?L = ?R")
proof -
  define pc pR pI g where
      "pc = pcompose p [:st, tt-st:]" and
      "pR = map_poly Re pc" and
      "pI = map_poly Im pc" and
      "g  = gcd pR pI"
  have poly_iff:"poly g t=0 \<longleftrightarrow> poly pc t =0" for t
  proof -
    have "poly g t = 0 \<longleftrightarrow> poly pR t =0 \<and> poly pI t =0"
      unfolding g_def using poly_gcd_0_iff by auto
    also have "... \<longleftrightarrow> poly pc t =0"
    proof -
      have "cpoly_of pR pI = pc"
        unfolding pc_def pR_def pI_def using cpoly_of_decompose by auto
      then show ?thesis using poly_cpoly_of_real_iff by blast
    qed
    finally show ?thesis by auto
  qed

  have "?R = nat (changes_R_smods g (pderiv g))"
    unfolding pc_def g_def pI_def pR_def by (auto simp add:Let_def)
  also have "... = card {t. poly g t = 0}"
    using sturm_R[of g] by simp
  also have "... = card {t::real. poly pc t = 0}"
    unfolding poly_iff by simp
  also have "... = ?L"
  proof (cases "st=tt")
    case True
    then show ?thesis unfolding pc_def poly_pcompose unbounded_line_def using assms
      by (auto simp add:proots_within_def)
  next
    case False
    define ff where "ff = (\<lambda>t::real. st + t*(tt-st))"
    define ll where "ll = {t. poly pc (complex_of_real t) = 0}"
    have "ff ` ll = proots_within p (unbounded_line st tt)"
    proof (rule equalityI)
      show "ff ` ll \<subseteq> proots_within p (unbounded_line st tt)"
        unfolding ll_def ff_def pc_def poly_pcompose
        by (auto simp add:unbounded_line_def False scaleR_conv_of_real algebra_simps)
    next
      show "proots_within p (unbounded_line st tt) \<subseteq> ff ` ll"
      proof clarify
        fix x assume asm:"x \<in> proots_within p (unbounded_line st tt)"
        then obtain u where u:"x = (1 - u) *\<^sub>R st + u *\<^sub>R tt"
          by (auto simp add:unbounded_line_def)
        then have "poly p ((1 - u) *\<^sub>R st + u *\<^sub>R tt) = 0" using asm by simp
        then have "u \<in> ll"
          unfolding ll_def pc_def poly_pcompose
          by (simp add:scaleR_conv_of_real algebra_simps unbounded_line_def)
        moreover have "x = ff u"
          unfolding ff_def using u by (auto simp add:algebra_simps scaleR_conv_of_real)
        ultimately show "x \<in> ff ` ll" by (rule rev_image_eqI[of "u"])
      qed
    qed
    moreover have "inj_on ff ll"
      unfolding ff_def using False inj_on_def by fastforce
    ultimately show ?thesis unfolding ll_def
      using card_image[of ff] by metis
  qed
  finally show ?thesis by simp
qed

lemma proots_count_gcd_eq:
  fixes p::"complex poly" and st tt::complex
    and g::"real poly"
  defines "pc \<equiv> pcompose p [:st, tt - st:]"
  defines "pR \<equiv> map_poly Re pc" and "pI \<equiv> map_poly Im pc"
  defines "g  \<equiv> gcd pR pI"
  assumes "st\<noteq>tt" "p\<noteq>0"
      and s1_def:"s1 = (\<lambda>x. poly [:st, tt - st:] (of_real x)) ` s2"
    shows "proots_count p s1 = proots_count g s2"
proof -
  have [simp]: "g\<noteq>0" "pc\<noteq>0"
  proof -
    show "pc\<noteq>0" using assms pc_def pcompose_eq_0
      by (metis cancel_comm_monoid_add_class.diff_cancel degree_pCons_eq_if
          diff_eq_diff_eq less_nat_zero_code pCons_eq_0_iff zero_less_Suc)
    then have "pR\<noteq>0 \<or> pI\<noteq>0" unfolding pR_def pI_def by (metis cpoly_of_decompose map_poly_0)
    then show "g\<noteq>0" unfolding g_def by simp
  qed
  have order_eq:"order t g = order t pc" for t
    apply (subst order_cpoly_gcd_eq[of pR pI,folded g_def,symmetric])
    subgoal using \<open>g\<noteq>0\<close> unfolding g_def by simp
    subgoal unfolding pR_def pI_def by (simp add:cpoly_of_decompose[symmetric])
    done

  have "proots_count g s2 = proots_count (map_poly complex_of_real g)
            (of_real ` s2)"
    apply (subst proots_count_of_real)
    by auto
  also have "... = proots_count pc (of_real ` s2)"
    apply (rule proots_count_cong)
    by (auto simp add: map_poly_order_of_real order_eq)
  also have "... = proots_count p s1"
    unfolding pc_def s1_def
    apply (subst proots_pcompose)
    using \<open>st\<noteq>tt\<close> \<open>p\<noteq>0\<close> by (simp_all add:image_image)
  finally show ?thesis by simp
qed

lemma proots_unbounded_line:
  assumes "st\<noteq>tt" "p\<noteq>0"
  shows "(proots_count p (unbounded_line st tt)) =
                (let pc = pcompose p [:st, tt - st:];
                     pR = map_poly Re pc;
                     pI = map_poly Im pc;
                     g  = gcd pR pI
                 in nat (changes_R_smods_ext g (pderiv g)))" (is "?L = ?R")
proof -
  define pc pR pI g where
      "pc = pcompose p [:st, tt-st:]" and
      "pR = map_poly Re pc" and
      "pI = map_poly Im pc" and
      "g  = gcd pR pI"
  have [simp]: "g\<noteq>0" "pc\<noteq>0"
  proof -
    show "pc\<noteq>0" using assms(1) assms(2) pc_def pcompose_eq_0
      by (metis cancel_comm_monoid_add_class.diff_cancel degree_pCons_eq_if
          diff_eq_diff_eq less_nat_zero_code pCons_eq_0_iff zero_less_Suc)
    then have "pR\<noteq>0 \<or> pI\<noteq>0" unfolding pR_def pI_def by (metis cpoly_of_decompose map_poly_0)
    then show "g\<noteq>0" unfolding g_def by simp
  qed
  have order_eq:"order t g = order t pc" for t
    apply (subst order_cpoly_gcd_eq[of pR pI,folded g_def,symmetric])
    subgoal using \<open>g\<noteq>0\<close> unfolding g_def by simp
    subgoal unfolding pR_def pI_def by (simp add:cpoly_of_decompose[symmetric])
    done

  have "?R = nat (changes_R_smods_ext g (pderiv g))"
    unfolding pc_def g_def pI_def pR_def by (auto simp add:Let_def)
  also have "... = proots_count g UNIV"
    using sturm_ext_R[OF \<open>g\<noteq>0\<close>] by auto
  also have "... = proots_count (map_poly complex_of_real g) (of_real ` UNIV)"
    apply (subst proots_count_of_real)
    by auto
  also have "... = proots_count (map_poly complex_of_real g) {x. Im x = 0}"
    apply (rule arg_cong2[where f=proots_count])
    using Reals_def complex_is_Real_iff by auto
  also have "... = proots_count pc {x. Im x = 0}"
    apply (rule proots_count_cong)
    apply (metis (mono_tags) Im_complex_of_real Re_complex_of_real \<open>g \<noteq> 0\<close> complex_surj
            map_poly_order_of_real mem_Collect_eq order_eq)
    by auto
  also have "... = proots_count p (unbounded_line st tt)"
  proof -
    have "poly [:st, tt - st:] ` {x. Im x = 0} = unbounded_line st tt"
      unfolding unbounded_line_def
      apply safe
      subgoal for _ x
        apply (rule_tac x="Re x" in exI)
        apply (simp add:algebra_simps)
        by (simp add: mult.commute scaleR_complex.code times_complex.code)
      subgoal for _ u
        apply (rule rev_image_eqI[of "of_real u"])
        by (auto simp:scaleR_conv_of_real algebra_simps)
      done
    then show ?thesis
      unfolding pc_def
      apply (subst proots_pcompose)
      using \<open>p\<noteq>0\<close> \<open>st\<noteq>tt\<close> by auto
  qed
  finally show ?thesis by simp
qed

lemma proots_unbounded_line_card_code[code]:
  "proots_unbounded_line_card p st tt =
              (if st\<noteq>tt then
                (let pc = pcompose p [:st, tt - st:];
                     pR = map_poly Re pc;
                     pI = map_poly Im pc;
                     g  = gcd pR pI
                 in nat (changes_R_smods g (pderiv g)))
              else
                  Code.abort (STR ''proots_unbounded_line_card fails due to invalid hyperplanes.'')
                      (\<lambda>_. proots_unbounded_line_card p st tt))"
  unfolding proots_unbounded_line_card_def using card_proots_unbounded_line[of st tt p] by auto

lemma proots_unbounded_line_code[code]:
  "proots_unbounded_line p st tt =
              ( if st\<noteq>tt then
                if p\<noteq>0 then
                  (let pc = pcompose p [:st, tt - st:];
                     pR = map_poly Re pc;
                     pI = map_poly Im pc;
                     g  = gcd pR pI
                  in nat (changes_R_smods_ext g (pderiv g)))
                else
                  Code.abort (STR ''proots_unbounded_line fails due to p=0'')
                      (\<lambda>_. proots_unbounded_line p st tt)
                else
                  Code.abort (STR ''proots_unbounded_line fails due to invalid hyperplanes.'')
                      (\<lambda>_. proots_unbounded_line p st tt) )"
  unfolding proots_unbounded_line_def using proots_unbounded_line by auto

subsection \<open>Checking if there a polynomial root on a closed segment\<close>

definition no_proots_line::"complex poly \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> bool" where
  "no_proots_line p st tt = (proots_within p (closed_segment st tt) = {})"

(*TODO: the proof can probably be simplified using Lemma card_proots_open_segments*)
lemma no_proots_line_code[code]: "no_proots_line p st tt = (if poly p st \<noteq>0 \<and> poly p tt \<noteq> 0 then
                (let pc = pcompose p [:st, tt - st:];
                     pR = map_poly Re pc;
                     pI = map_poly Im pc;
                     g  = gcd pR pI
                 in if changes_itv_smods 0 1 g (pderiv g) = 0 then True else False) else False)"
            (is "?L = ?R")
proof (cases "poly p st \<noteq>0 \<and> poly p tt \<noteq> 0")
  case False
  thus ?thesis unfolding no_proots_line_def by auto
next
  case True
  then have "poly p st \<noteq> 0" "poly p tt \<noteq> 0" by auto
  define pc pR pI g where
      "pc = pcompose p [:st, tt-st:]" and
      "pR = map_poly Re pc" and
      "pI = map_poly Im pc" and
      "g  = gcd pR pI"
  have poly_iff:"poly g t=0 \<longleftrightarrow> poly pc t =0" for t
  proof -
    have "poly g t = 0 \<longleftrightarrow> poly pR t =0 \<and> poly pI t =0"
      unfolding g_def using poly_gcd_0_iff by auto
    also have "... \<longleftrightarrow> poly pc t =0"
    proof -
      have "cpoly_of pR pI = pc"
        unfolding pc_def pR_def pI_def using cpoly_of_decompose by auto
      then show ?thesis using poly_cpoly_of_real_iff by blast
    qed
    finally show ?thesis by auto
  qed
  have "?R = (changes_itv_smods 0 1 g (pderiv g) = 0)"
    using True unfolding pc_def g_def pI_def pR_def
    by (auto simp add:Let_def)
  also have "... = (card {x. poly g x = 0 \<and> 0 < x \<and> x < 1} = 0)"
  proof -
    have "poly g 0 \<noteq> 0"
      using poly_iff[of 0] True unfolding pc_def by (auto simp add:poly_pcompose)
    moreover have "poly g 1 \<noteq> 0"
      using poly_iff[of 1] True unfolding pc_def by (auto simp add:poly_pcompose)
    ultimately show ?thesis using sturm_interval[of 0 1 g] by auto
  qed
  also have "... = ({x. poly g (of_real x) = 0 \<and> 0 < x \<and> x < 1} = {})"
  proof -
    have "g\<noteq>0"
    proof (rule ccontr)
      assume "\<not> g \<noteq> 0"
      then have "poly pc 0 =0"
        using poly_iff[of 0] by auto
      then show False using True unfolding pc_def by (auto simp add:poly_pcompose)
    qed
    from poly_roots_finite[OF this] have "finite {x. poly g x = 0 \<and> 0 < x \<and> x < 1}"
      by auto
    then show ?thesis using card_eq_0_iff by auto
  qed
  also have "... = ?L"
  proof -
    have "(\<exists>t. poly g (of_real t) = 0 \<and> 0 < t \<and> t < 1) \<longleftrightarrow>
          (\<exists>t::real. poly pc (of_real t) = 0 \<and> 0 < t \<and> t < 1)"
      using poly_iff by auto
    also have "... \<longleftrightarrow> (\<exists>x. x \<in> closed_segment st tt \<and> poly p x = 0)"
    proof
      assume "\<exists>t. poly pc (complex_of_real t) = 0 \<and> 0 < t \<and> t < 1"
      then obtain t where *:"poly pc (of_real t) = 0" and "0 < t" "t < 1" by auto
      define x where "x=poly [:st, tt - st:] t"
      have "x \<in> closed_segment st tt" using \<open>0<t\<close> \<open>t<1\<close> unfolding x_def in_segment
        by (intro exI[where x=t],auto simp add: algebra_simps scaleR_conv_of_real)
      moreover have "poly p x=0" using * unfolding pc_def x_def
        by (auto simp add:poly_pcompose)
      ultimately show "\<exists>x. x \<in> closed_segment st tt \<and> poly p x = 0" by auto
    next
      assume "\<exists>x. x \<in> closed_segment st tt \<and> poly p x = 0"
      then obtain x where "x \<in> closed_segment st tt" "poly p x = 0" by auto
      then obtain t::real where *:"x = (1 - t) *\<^sub>R st + t *\<^sub>R tt" and "0\<le>t" "t\<le>1"
        unfolding in_segment by auto
      then have "x=poly [:st, tt - st:] t" by (auto simp add: algebra_simps scaleR_conv_of_real)
      then have "poly pc (complex_of_real t) = 0"
        using \<open>poly p x=0\<close> unfolding pc_def by (auto simp add:poly_pcompose)
      moreover have "t\<noteq>0" "t\<noteq>1" using True *  \<open>poly p x=0\<close> by auto
      then have "0<t" "t<1" using \<open>0\<le>t\<close> \<open>t\<le>1\<close> by auto
      ultimately show "\<exists>t. poly pc (complex_of_real t) = 0 \<and> 0 < t \<and> t < 1" by auto
    qed
    finally show ?thesis
      unfolding no_proots_line_def proots_within_def
      by blast
  qed
  finally show ?thesis by simp
qed

subsection \<open>Number of roots on a bounded open segment\<close>

definition proots_line:: "complex poly \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> nat" where
  "proots_line p st tt = proots_count p (open_segment st tt)"

lemma proots_line_commute:
  "proots_line p st tt = proots_line p tt st"
  unfolding proots_line_def by (simp add: open_segment_commute)

lemma proots_line_smods:
  assumes "poly p st \<noteq>0" "poly p tt \<noteq> 0" "st\<noteq>tt"
  shows "proots_line p st tt =
                        (let pc = pcompose p [:st, tt - st:];
                             pR = map_poly Re pc;
                             pI = map_poly Im pc;
                             g  = gcd pR pI
                         in nat (changes_itv_smods_ext 0 1 g (pderiv g)))"
  (is "_=?R")
proof -
  have "p\<noteq>0" using assms(2) poly_0 by blast

  define pc pR pI g where
      "pc = pcompose p [:st, tt-st:]" and
      "pR = map_poly Re pc" and
      "pI = map_poly Im pc" and
      "g  = gcd pR pI"
  have [simp]: "g\<noteq>0" "pc\<noteq>0"
  proof -
    show "pc\<noteq>0"
      by (metis assms(1) coeff_pCons_0 pCons_0_0 pc_def pcompose_coeff_0)
    then have "pR\<noteq>0 \<or> pI\<noteq>0" unfolding pR_def pI_def
      by (metis cpoly_of_decompose map_poly_0)
    then show "g\<noteq>0" unfolding g_def by simp
  qed
  have order_eq:"order t g = order t pc" for t
    apply (subst order_cpoly_gcd_eq[of pR pI,folded g_def,symmetric])
    subgoal using \<open>g\<noteq>0\<close> unfolding g_def by simp
    subgoal unfolding pR_def pI_def by (simp add:cpoly_of_decompose[symmetric])
    done
  have poly_iff:"poly g t=0 \<longleftrightarrow> poly pc t =0" for t
    using order_eq by (simp add: order_root)
  have "poly g 0 \<noteq> 0" "poly g 1 \<noteq>0"
    unfolding poly_iff pc_def
    using assms by (simp_all add:poly_pcompose)

  have "?R = changes_itv_smods_ext 0 1 g (pderiv g)"
    unfolding Let_def
    apply (fold pc_def g_def pI_def pR_def)
    using assms changes_itv_smods_ext_geq_0[OF _ \<open>poly g  0\<noteq>0\<close> \<open>poly g 1\<noteq>0\<close>]
    by auto
  also have "... = int (proots_count g {x. 0 < x \<and> x < 1})"
    apply (rule sturm_ext_interval[symmetric])
    by simp fact+
  also have "... =  int (proots_count p (open_segment st tt))"
  proof -
    define f where "f = (\<lambda>x. poly [:st, tt - st:] (complex_of_real x))"
    have "x\<in>f ` {x. 0 < x \<and> x < 1}"  if "x\<in>open_segment st tt" for x
    proof -
      obtain u where u:"u>0" "u < 1" "x = (1 - u) *\<^sub>R st + u *\<^sub>R tt"
        using \<open>x\<in>open_segment st tt\<close> unfolding in_segment by auto
      show ?thesis
        apply (rule rev_image_eqI[where x=u])
        using u unfolding f_def
        by (auto simp:algebra_simps scaleR_conv_of_real)
    qed
    moreover have "x\<in>open_segment st tt" if "x\<in>f ` {x. 0 < x \<and> x < 1}" for x
      using that \<open>st\<noteq>tt\<close> unfolding in_segment f_def
      by (auto simp:scaleR_conv_of_real algebra_simps)
    ultimately have "open_segment st tt = f ` {x. 0 < x \<and> x < 1}"
      by auto
    then have "proots_count p (open_segment st tt)
              = proots_count g {x. 0 < x \<and> x < 1}"
      using proots_count_gcd_eq[OF \<open>st\<noteq>tt\<close> \<open>p\<noteq>0\<close>,
              folded pc_def pR_def pI_def g_def] unfolding f_def
      by auto
    then show ?thesis by auto
  qed
  also have "... =proots_line p st tt"
    unfolding proots_line_def by simp
  finally show ?thesis by simp
qed

lemma proots_line_code[code]:
    "proots_line p st tt =
        (if poly p st \<noteq>0 \<and> poly p tt \<noteq> 0 then
            (if st\<noteq>tt then
                (let pc = pcompose p [:st, tt - st:];
                     pR = map_poly Re pc;
                     pI = map_poly Im pc;
                     g  = gcd pR pI
                 in nat (changes_itv_smods_ext 0 1 g (pderiv g)))
            else 0)
   else  Code.abort (STR ''prootsline does not handle vanishing endpoints for now'')
                      (\<lambda>_. proots_line p st tt))" (is "?L = ?R")
proof (cases "poly p st \<noteq>0 \<and> poly p tt \<noteq> 0 \<and> st\<noteq>tt")
  case False
  moreover have ?thesis if "st=tt" "p\<noteq>0"
    using that unfolding proots_line_def by auto
  ultimately show ?thesis by fastforce
next
  case True
  then show ?thesis using proots_line_smods by auto
qed

end


theory Edrel
  imports
    Transitive_Models.ZF_Miscellanea
    Transitive_Models.Recursion_Thms

begin

subsection\<open>The well-founded relation \<^term>\<open>ed\<close>\<close>

lemma eclose_sing : "x \<in> eclose(a) \<Longrightarrow> x \<in> eclose({a})"
  using subsetD[OF mem_eclose_subset]
  by simp

lemma ecloseE :
  assumes  "x \<in> eclose(A)"
  shows  "x \<in> A \<or> (\<exists> B \<in> A . x \<in> eclose(B))"
  using assms
proof (induct rule:eclose_induct_down)
  case (1 y)
  then
  show ?case
    using arg_into_eclose by auto
next
  case (2 y z)
  from \<open>y \<in> A \<or> (\<exists>B\<in>A. y \<in> eclose(B))\<close>
  consider (inA) "y \<in> A" | (exB) "(\<exists>B\<in>A. y \<in> eclose(B))"
    by auto
  then show ?case
  proof (cases)
    case inA
    then
    show ?thesis using 2 arg_into_eclose by auto
  next
    case exB
    then obtain B where "y \<in> eclose(B)" "B\<in>A"
      by auto
    then
    show ?thesis using 2 ecloseD[of y B z] by auto
  qed
qed

lemma eclose_singE : "x \<in> eclose({a}) \<Longrightarrow> x = a \<or> x \<in> eclose(a)"
  by(blast dest: ecloseE)

lemma in_eclose_sing :
  assumes "x \<in> eclose({a})" "a \<in> eclose(z)"
  shows "x \<in> eclose({z})"
proof -
  from \<open>x\<in>eclose({a})\<close>
  consider "x=a" | "x\<in>eclose(a)"
    using eclose_singE by auto
  then
  show ?thesis
    using eclose_sing mem_eclose_trans assms
    by (cases, auto)
qed

lemma in_dom_in_eclose :
  assumes "x \<in> domain(z)"
  shows "x \<in> eclose(z)"
proof -
  from assms
  obtain y where "\<langle>x,y\<rangle> \<in> z"
    unfolding domain_def by auto
  then
  show ?thesis
    unfolding Pair_def
    using ecloseD[of "{x,x}"] ecloseD[of "{{x,x},{x,y}}"] arg_into_eclose
    by auto
qed

text\<open>term\<open>ed\<close> is the well-founded relation on which \<^term>\<open>val\<close> is defined.\<close>
definition ed :: "[i,i] \<Rightarrow> o" where
  "ed(x,y) \<equiv> x \<in> domain(y)"

definition edrel :: "i \<Rightarrow> i" where
  "edrel(A) \<equiv> Rrel(ed,A)"

lemma edI[intro!]: "t\<in>domain(x) \<Longrightarrow> ed(t,x)"
  unfolding ed_def .

lemma edD[dest!]: "ed(t,x) \<Longrightarrow> t\<in>domain(x)"
  unfolding ed_def .

lemma rank_ed:
  assumes "ed(y,x)"
  shows "succ(rank(y)) \<le> rank(x)"
proof
  from assms
  obtain p where "\<langle>y,p\<rangle>\<in>x" by auto
  moreover
  obtain s where "y\<in>s" "s\<in>\<langle>y,p\<rangle>" unfolding Pair_def by auto
  ultimately
  have "rank(y) < rank(s)" "rank(s) < rank(\<langle>y,p\<rangle>)" "rank(\<langle>y,p\<rangle>) < rank(x)"
    using rank_lt by blast+
  then
  show "rank(y) < rank(x)"
    using lt_trans by blast
qed

lemma edrel_dest [dest]: "x \<in> edrel(A) \<Longrightarrow> \<exists> a \<in> A. \<exists> b \<in> A. x =\<langle>a,b\<rangle>"
  by(auto simp add:ed_def edrel_def Rrel_def)

lemma edrelD : "x \<in> edrel(A) \<Longrightarrow> \<exists> a\<in> A. \<exists> b \<in> A. x =\<langle>a,b\<rangle> \<and> a \<in> domain(b)"
  by(auto simp add:ed_def edrel_def Rrel_def)

lemma edrelI [intro!]: "x\<in>A \<Longrightarrow> y\<in>A \<Longrightarrow> x \<in> domain(y) \<Longrightarrow> \<langle>x,y\<rangle>\<in>edrel(A)"
  by (simp add:ed_def edrel_def Rrel_def)

lemma edrel_trans: "Transset(A) \<Longrightarrow> y\<in>A \<Longrightarrow> x \<in> domain(y) \<Longrightarrow> \<langle>x,y\<rangle>\<in>edrel(A)"
  by (rule edrelI, auto simp add:Transset_def domain_def Pair_def)

lemma domain_trans: "Transset(A) \<Longrightarrow> y\<in>A \<Longrightarrow> x \<in> domain(y) \<Longrightarrow> x\<in>A"
  by (auto simp add: Transset_def domain_def Pair_def)

lemma relation_edrel : "relation(edrel(A))"
  by(auto simp add: relation_def)

lemma field_edrel : "field(edrel(A))\<subseteq>A"
  by blast

lemma edrel_sub_memrel: "edrel(A) \<subseteq> trancl(Memrel(eclose(A)))"
proof
  let
    ?r="trancl(Memrel(eclose(A)))"
  fix z
  assume "z\<in>edrel(A)"
  then
  obtain x y where "x\<in>A" "y\<in>A" "z=\<langle>x,y\<rangle>" "x\<in>domain(y)"
    using edrelD
    by blast
  moreover from this
  obtain u v where "x\<in>u" "u\<in>v" "v\<in>y"
    unfolding domain_def Pair_def by auto
  moreover from calculation
  have "x\<in>eclose(A)" "y\<in>eclose(A)" "y\<subseteq>eclose(A)"
    using arg_into_eclose Transset_eclose[unfolded Transset_def]
    by simp_all
  moreover from calculation
  have "v\<in>eclose(A)"
    by auto
  moreover from calculation
  have "u\<in>eclose(A)"
    using Transset_eclose[unfolded Transset_def]
    by auto
  moreover from calculation
  have"\<langle>x,u\<rangle>\<in>?r" "\<langle>u,v\<rangle>\<in>?r" "\<langle>v,y\<rangle>\<in>?r"
    by (auto simp add: r_into_trancl)
  moreover from this
  have "\<langle>x,y\<rangle>\<in>?r"
    using trancl_trans[OF _ trancl_trans[of _ v _ y]]
    by simp
  ultimately
  show "z\<in>?r"
    by simp
qed

lemma wf_edrel : "wf(edrel(A))"
  using wf_subset[of "trancl(Memrel(eclose(A)))"] edrel_sub_memrel
    wf_trancl wf_Memrel
  by auto

lemma ed_induction:
  assumes "\<And>x. \<lbrakk>\<And>y.  ed(y,x) \<Longrightarrow> Q(y) \<rbrakk> \<Longrightarrow> Q(x)"
  shows "Q(a)"
proof(induct rule: wf_induct2[OF wf_edrel[of "eclose({a})"] ,of a "eclose({a})"])
  case 1
  then show ?case using arg_into_eclose by simp
next
  case 2
  then show ?case using field_edrel .
next
  case (3 x)
  then
  show ?case
    using assms[of x] edrelI domain_trans[OF Transset_eclose 3(1)] by blast
qed

lemma dom_under_edrel_eclose: "edrel(eclose({x})) -`` {x} = domain(x)"
proof(intro equalityI)
  show "edrel(eclose({x})) -`` {x} \<subseteq> domain(x)"
    unfolding edrel_def Rrel_def ed_def
    by auto
next
  show "domain(x) \<subseteq> edrel(eclose({x})) -`` {x}"
    unfolding edrel_def Rrel_def
    using in_dom_in_eclose eclose_sing arg_into_eclose
    by blast
qed

lemma ed_eclose : "\<langle>y,z\<rangle> \<in> edrel(A) \<Longrightarrow> y \<in> eclose(z)"
  by(drule edrelD,auto simp add:domain_def in_dom_in_eclose)

lemma tr_edrel_eclose : "\<langle>y,z\<rangle> \<in> edrel(eclose({x}))^+ \<Longrightarrow> y \<in> eclose(z)"
  by(rule trancl_induct,(simp add: ed_eclose mem_eclose_trans)+)

lemma restrict_edrel_eq :
  assumes "z \<in> domain(x)"
  shows "edrel(eclose({x})) \<inter> eclose({z})\<times>eclose({z}) = edrel(eclose({z}))"
proof(intro equalityI subsetI)
  let ?ec="\<lambda> y . edrel(eclose({y}))"
  let ?ez="eclose({z})"
  let ?rr="?ec(x) \<inter> ?ez \<times> ?ez"
  fix y
  assume "y \<in> ?rr"
  then
  obtain a b where "\<langle>a,b\<rangle> \<in> ?rr" "a \<in> ?ez" "b \<in> ?ez" "\<langle>a,b\<rangle> \<in> ?ec(x)" "y=\<langle>a,b\<rangle>"
    by blast
  moreover from this
  have "a \<in> domain(b)"
    using edrelD by blast
  ultimately
  show "y \<in> edrel(eclose({z}))"
    by blast
next
  let ?ec="\<lambda> y . edrel(eclose({y}))"
  let ?ez="eclose({z})"
  let ?rr="?ec(x) \<inter> ?ez \<times> ?ez"
  fix y
  assume "y \<in> edrel(?ez)"
  then
  obtain a b where "a \<in> ?ez" "b \<in> ?ez" "y=\<langle>a,b\<rangle>" "a \<in> domain(b)"
    using edrelD by blast
  moreover
  from this assms
  have "z \<in> eclose(x)"
    using in_dom_in_eclose by simp
  moreover
  from assms calculation
  have "a \<in> eclose({x})" "b \<in> eclose({x})"
    using in_eclose_sing by simp_all
  moreover from calculation
  have "\<langle>a,b\<rangle> \<in> edrel(eclose({x}))"
    by blast
  ultimately
  show "y \<in> ?rr"
    by simp
qed

lemma tr_edrel_subset :
  assumes "z \<in> domain(x)"
  shows   "tr_down(edrel(eclose({x})),z) \<subseteq> eclose({z})"
proof(intro subsetI)
  let ?r="\<lambda> x . edrel(eclose({x}))"
  fix y
  assume "y \<in> tr_down(?r(x),z)"
  then
  have "\<langle>y,z\<rangle> \<in> ?r(x)^+"
    using tr_downD by simp
  with assms
  show "y \<in> eclose({z})"
    using tr_edrel_eclose eclose_sing by simp
qed

end


theory seminarski
  imports Main
begin

(*
   Student: Lea Petkovic 163/2016
   Seminarski rad iz UIDT-a
   Strana 5, prvi zadatak, prvi razred
   https://imomath.com/srb/zadaci/2016_opstinsko.pdf?fbclid=IwAR3K8wjcxn7muwZW1rgwycqBa66I76o7Qt4buBXJSPb6m-nBD_N_NvV6ngQ
*)

(* Resenje zadatka:
(A \ (B \ C)) \ (B \ (C \ A)) = (A \ (B \<inter> -C)) \ (B \ (C \<inter> -A))      I se oslobadjamo razlike
      = (A \<inter> -(B \<inter> -C)) \ (B \<inter> -(C \<inter> -A))
      = (A \<inter> -(B \<inter> -C)) \<inter> -(B \<inter> -(C \<inter> -A))
      = (A \<inter> (-B \<union> C)) \<inter> (-B \<union> (C \<inter> -A))
      = (A \<inter> (-B \<union> C) \<inter> -B) \<union> (A \<inter> (-B \<union> C) \<inter> C \<inter> -A)
      = (A \<inter> -B) \<union> (\<emptyset> \<inter> (-B \<union> C) \<inter> C)
      = (A \<inter> -B) \<union> \<emptyset>
      = A \<inter> -B = A \ B.
Dakle, posto vazi B \<inter> C \<subseteq> B, dobijamo A \ (B \<inter> C) \<supseteq> A \ B,
tj.  A \ (B \<inter> C) \<supseteq> (A \ (B \ C)) \ (B \ (C \ A))   *)

lemma pomocna_lema:
  shows "B \<inter> C \<subseteq> B"
proof
  fix x
  assume "x \<in> B \<inter> C"
  then have "x \<in> B" "x \<in> C"
    by auto
  then show "x \<in> B"
    by auto
qed

lemma zadatak:
  shows "(A - (B - C)) - (B - (C - A)) \<subseteq> A - (B \<inter> C) "
proof
  fix x
  assume "x \<in> (A - (B - C)) - (B - (C - A))"
  then have "x \<in> (A - (B \<inter> -C)) - (B - (C \<inter> -A))"                       (*using prva_jednakost *)
    by auto
  then have "x \<in> (A \<inter> (-(B \<inter> -C))) - (B \<inter> (-(C \<inter> -A)))"
    by auto
  then have "x \<in> (A \<inter> (-(B \<inter> -C))) \<inter> ( -(B \<inter> (-(C \<inter> -A))) )"
    by auto
  then have "x \<in> (A \<inter> (-B \<union> C)) \<inter> (-B \<union> (C \<inter> -A))"                      (*using druga_jednakost*)
    by auto
  then have "x \<in> (A \<inter> (-B \<union> C) \<inter> (-B)) \<union> (A \<inter> (-B \<union> C) \<inter> (C \<inter> -A))"    (*using treca_jednakost*)
    by auto
  then have "x \<in> (A \<inter> -B) \<union> ({}  \<inter> (-B \<union> C) \<inter> C)"
    by auto
  then have "x \<in> (A \<inter> -B) \<union> {}"
    by auto
  then have "x \<in> A \<inter> -B"
    by auto
  then show "x \<in> A - B \<inter> C"
    using pomocna_lema
    by auto
qed

(* Pojedinacno dokazane koje se koriste *)
lemma prva_jednakost:
  shows "A - B = A \<inter> -B"
proof
  show "A - B \<subseteq> A \<inter> -B"
  proof
    fix x
    assume "x \<in> A - B"
    then have "x \<in> A" "x \<notin> B"
      by auto
    then have "x \<in> -B"
      by auto
    then show "x \<in> A \<inter> -B"
      using \<open>x \<in> A\<close> \<open>x \<in> -B\<close>
      by blast
  qed
next
  show "A \<inter> -B \<subseteq> A - B"
  proof
    fix x
    assume "x \<in> A \<inter> -B"
    then have "x \<in> A" "x \<in> -B"
      by auto
    then have "x \<notin> B"
      by auto
    then show "x \<in> A - B"
      using \<open>x \<in> A\<close> \<open>x \<notin> B\<close>
      by auto
  qed
qed

lemma druga_jednakost:
  shows "-(B \<inter> C) = -B \<union> -C"
proof
  show "-(B \<inter> C) \<subseteq> -B \<union> -C"
    by auto
next
  show "-B \<union> -C \<subseteq> -(B \<inter> C)"
  proof
    fix x
    assume "x \<in> -B \<union> -C"
    then have "x \<in> -B \<or> x \<in> -C"
      by auto
    then show "x \<in> -(B \<inter> C)"
    proof
      assume "x \<in> -B"
      then have "x \<notin> B"
        by auto
      then have "x \<notin> B \<inter> C"
        by auto
      then show "x \<in> - (B \<inter> C)"
        by auto
    next
      assume "x \<in> -C"
      then have "x \<notin> C"
        by auto
      then have "x \<notin> B \<inter> C"
        by auto
      then show "x \<in> - (B \<inter> C)"
        by auto
    qed
  qed
qed

lemma treca_jednakost:
  shows "A \<inter> (B \<union> C) = (A \<inter> B) \<union> (A \<inter> C)"
  (* by (simp add: Int_Un_distrib) *)
proof
  show "A \<inter> (B \<union> C) \<subseteq> A \<inter> B \<union> A \<inter> C"
  proof
    fix x
    assume "x \<in> A \<inter> (B \<union> C)"
    then have "x \<in> A" "x \<in> B \<or> x \<in> C"
      by auto
    then have "x \<in> A \<and> x \<in> B \<or> x \<in> A \<and> x \<in> C"
      by auto
    then have "x \<in> A \<inter> B \<or> x \<in> A \<inter> C"
      by auto
    then show "x \<in> (A \<inter> B) \<union> (A \<inter> C)"
      by auto
  qed
next
  show "(A \<inter> B) \<union> (A \<inter> C) \<subseteq> A \<inter> (B \<union> C)"
  proof
    fix x
    assume "x \<in> (A \<inter> B) \<union> (A \<inter> C)"
    then have "x \<in> A \<inter> B \<or> x \<in> A \<inter> C"
      by auto
    then have "(x \<in> A \<and> x \<in> B) \<or> (x \<in> A \<and> x \<in> C)"
      by auto
    then have "x \<in> A" "x \<in> B \<or> x \<in> C"
      by auto
    then show "x \<in> A \<inter> (B \<union> C)"
      by auto
  qed
qed

end


(*X. Parent, 25/08/2019, and C. Benzmüller, 2020 *)
(*This file introduces David Lewis DDL and studies its
relationship with the Aqvist-Hansson DDL  *)
(*This uses material from a chapter for the second volume of the
handbook of deontic logic  *)

theory Lewis_DDL  imports Main
begin
typedecl i \<comment>\<open>type for possible worlds\<close>
type_synonym \<tau> = "(i\<Rightarrow>bool)"
consts  aw::i \<comment>\<open>actual world\<close>

abbreviation(input) mtrue  :: "\<tau>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation(input) mfalse :: "\<tau>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation(input) mnot   :: "\<tau>\<Rightarrow>\<tau>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation(input) mand   :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation(input) mor    :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation(input) mimp   :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation(input) mequ   :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

abbreviation(input) mbox :: "\<tau>\<Rightarrow>\<tau>" ("\<box>") where "\<box>\<phi> \<equiv> \<lambda>w.  \<forall>v. \<phi>(v)"
definition ddediomond  :: "\<tau>\<Rightarrow>\<tau>" ("\<diamond>") where "\<diamond>\<phi> \<equiv> \<lambda>w. \<exists>v. \<phi>(v)"

consts r :: "i\<Rightarrow>\<tau>"  (infixr "r" 70)
 \<comment>\<open>the betterness relation r, used in definition of \<circle><_|_>  \<close>
abbreviation(input) mopt  :: "\<tau>\<Rightarrow>\<tau>" ("opt<_>")
  where "opt<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x)  \<longrightarrow>  v r x) )) )"
abbreviation(input) msubset :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"

(*David Lewis's evaluation rule for the conditional *)
abbreviation(input) mcond  :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv> (\<lambda>v. (\<not>(\<exists>x. (\<phi>)(x))\<or>  (\<exists>x. ((\<phi>)(x)\<and>(\<psi>)(x) \<and> (\<forall>y. ((y r x) \<longrightarrow> (\<phi>)(y)\<longrightarrow>(\<psi>)(y)))))))"
definition ddeperm :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("P<_|_>")
  where "P<\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<circle><\<^bold>\<not>\<psi>|\<phi>>"

(*Hansson-Aqvist's evaluation rule for the conditional *)
abbreviation(input) mcond2  :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<circle>o<_|_>")
  where "\<circle>o<\<psi>|\<phi>> \<equiv> (\<lambda>v. opt<\<phi>> \<^bold>\<subseteq> \<psi>)"

abbreviation limitedness  where "limitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x))"
abbreviation transitivity where "transitivity \<equiv> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z)"
abbreviation totalness where "totalness \<equiv> (\<forall>x y. (x r y \<or> y r x))"
abbreviation reflexivity where "reflexivity \<equiv> (\<forall>x. (x r x))"

abbreviation(input) valid :: "\<tau>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
definition cjactual :: "\<tau>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

lemma True nitpick [satisfy, user_axioms, show_all, expect=genuine] oops

(*relation with optimality*)
(*The lewis rule is stronger*)
lemma "\<lfloor>\<circle>o<\<psi>|\<phi>>\<^bold>\<rightarrow>\<circle><\<psi>|\<phi>>\<rfloor>" nitpick oops  (*countermodel*)
lemma "\<lfloor>\<circle><\<psi>|\<phi>>\<^bold>\<rightarrow>\<circle>o<\<psi>|\<phi>>\<rfloor>" by blast

lemma
assumes "limitedness"
  assumes "transitivity"
  shows "\<lfloor>\<circle>o<\<psi>|\<phi>>\<^bold>\<rightarrow>\<circle><\<psi>|\<phi>>\<rfloor>"
  sledgehammer
  by (smt assms(1) assms(2))

(*axioms of E holding irrespective of the properties of r*)
lemma Abs:"\<lfloor>\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> \<box>\<circle><\<psi>|\<phi>>\<rfloor>"  sledgehammer oops
lemma Nec:"\<lfloor>\<box>\<psi> \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>>\<rfloor>" by blast
lemma Ext:"\<lfloor>\<box>(\<phi>\<^sub>1\<^bold>\<leftrightarrow>\<phi>\<^sub>2) \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>\<^sub>1> \<^bold>\<leftrightarrow> \<circle><\<psi>|\<phi>\<^sub>2>)\<rfloor>" by simp
lemma Id:"\<lfloor>\<circle><\<phi>|\<phi>>\<rfloor>" by auto
lemma Sh:"\<lfloor>\<circle><\<psi>|\<phi>\<^sub>1\<^bold>\<and>\<phi>\<^sub>2> \<^bold>\<rightarrow> \<circle><(\<phi>\<^sub>2\<^bold>\<rightarrow>\<psi>)|\<phi>\<^sub>1>\<rfloor>" by blast
lemma MP:"(\<lfloor>\<phi>\<rfloor>\<and>\<lfloor>\<phi>\<^bold>\<rightarrow>\<psi>\<rfloor>)\<Longrightarrow>\<lfloor>\<psi>\<rfloor>" by blast
lemma N:"\<lfloor>\<phi>\<rfloor>\<Longrightarrow>\<lfloor>\<box>\<phi>\<rfloor>" by auto

(*axioms of E holding if r transitive and totale*)

lemma COK:"\<lfloor>\<circle><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circle><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circle><\<psi>\<^sub>2|\<phi>>)\<rfloor>" nitpick oops (*countermodel*)

lemma
  assumes "transitivity"
  shows COK:"\<lfloor>\<circle><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circle><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circle><\<psi>\<^sub>2|\<phi>>)\<rfloor>" nitpick oops  (*countermodel*)

  lemma
  assumes "totalness"
  shows COK:"\<lfloor>\<circle><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circle><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circle><\<psi>\<^sub>2|\<phi>>)\<rfloor>" nitpick oops (*countermodel*)

lemma
  assumes "transitivity"
  assumes "totalness"
  shows COK:"\<lfloor>\<circle><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circle><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circle><\<psi>\<^sub>2|\<phi>>)\<rfloor>" by (smt assms(1) assms(2))

lemma D : "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>)\<rfloor>"  nitpick oops (*countermodel*)

lemma
 assumes "totalness"
  shows D : "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>)\<rfloor>"  by (smt assms ddediomond_def ddeperm_def)

lemma  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>" nitpick oops (*countermodel*)

lemma
 assumes "transitivity"
 shows Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>" by (smt assms ddeperm_def)

lemma CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>" nitpick oops (*countermodel*)

lemma
  assumes "transitivity"
  shows CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>" nitpick oops (*countermodel*)

lemma
  assumes "transitivity"
  assumes "totalness"
  shows CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>" by (metis assms(1) assms(2))

lemma SA:"\<lfloor>\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow>  \<circle><\<psi>|\<phi>\<^bold>\<and>\<chi>>\<rfloor>" nitpick oops (*countermodel*)
end


(*  Title:      HOL/Algebra/QuotRing.thy
    Author:     Stephan Hohe
*)

theory QuotRing
imports RingHom
begin

section {* Quotient Rings *}

subsection {* Multiplication on Cosets *}

definition rcoset_mult :: "[('a, _) ring_scheme, 'a set, 'a set, 'a set] \<Rightarrow> 'a set"
    ("[mod _:] _ \<Otimes>\<index> _" [81,81,81] 80)
  where "rcoset_mult R I A B = (\<Union>a\<in>A. \<Union>b\<in>B. I +>\<^bsub>R\<^esub> (a \<otimes>\<^bsub>R\<^esub> b))"

text {* @{const "rcoset_mult"} fulfils the properties required by
  congruences *}
lemma (in ideal) rcoset_mult_add:
    "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> [mod I:] (I +> x) \<Otimes> (I +> y) = I +> (x \<otimes> y)"
  apply rule
  apply (rule, simp add: rcoset_mult_def, clarsimp)
  defer 1
  apply (rule, simp add: rcoset_mult_def)
  defer 1
proof -
  fix z x' y'
  assume carr: "x \<in> carrier R" "y \<in> carrier R"
    and x'rcos: "x' \<in> I +> x"
    and y'rcos: "y' \<in> I +> y"
    and zrcos: "z \<in> I +> x' \<otimes> y'"

  from x'rcos have "\<exists>h\<in>I. x' = h \<oplus> x"
    by (simp add: a_r_coset_def r_coset_def)
  then obtain hx where hxI: "hx \<in> I" and x': "x' = hx \<oplus> x"
    by fast+

  from y'rcos have "\<exists>h\<in>I. y' = h \<oplus> y"
    by (simp add: a_r_coset_def r_coset_def)
  then obtain hy where hyI: "hy \<in> I" and y': "y' = hy \<oplus> y"
    by fast+

  from zrcos have "\<exists>h\<in>I. z = h \<oplus> (x' \<otimes> y')"
    by (simp add: a_r_coset_def r_coset_def)
  then obtain hz where hzI: "hz \<in> I" and z: "z = hz \<oplus> (x' \<otimes> y')"
    by fast+

  note carr = carr hxI[THEN a_Hcarr] hyI[THEN a_Hcarr] hzI[THEN a_Hcarr]

  from z have "z = hz \<oplus> (x' \<otimes> y')" .
  also from x' y' have "\<dots> = hz \<oplus> ((hx \<oplus> x) \<otimes> (hy \<oplus> y))" by simp
  also from carr have "\<dots> = (hz \<oplus> (hx \<otimes> (hy \<oplus> y)) \<oplus> x \<otimes> hy) \<oplus> x \<otimes> y" by algebra
  finally have z2: "z = (hz \<oplus> (hx \<otimes> (hy \<oplus> y)) \<oplus> x \<otimes> hy) \<oplus> x \<otimes> y" .

  from hxI hyI hzI carr have "hz \<oplus> (hx \<otimes> (hy \<oplus> y)) \<oplus> x \<otimes> hy \<in> I"
    by (simp add: I_l_closed I_r_closed)

  with z2 have "\<exists>h\<in>I. z = h \<oplus> x \<otimes> y" by fast
  then show "z \<in> I +> x \<otimes> y" by (simp add: a_r_coset_def r_coset_def)
next
  fix z
  assume xcarr: "x \<in> carrier R"
    and ycarr: "y \<in> carrier R"
    and zrcos: "z \<in> I +> x \<otimes> y"
  from xcarr have xself: "x \<in> I +> x" by (intro a_rcos_self)
  from ycarr have yself: "y \<in> I +> y" by (intro a_rcos_self)
  show "\<exists>a\<in>I +> x. \<exists>b\<in>I +> y. z \<in> I +> a \<otimes> b"
    using xself and yself and zrcos by fast
qed

subsection {* Quotient Ring Definition *}

definition FactRing :: "[('a,'b) ring_scheme, 'a set] \<Rightarrow> ('a set) ring"
    (infixl "Quot" 65)
  where "FactRing R I =
    \<lparr>carrier = a_rcosets\<^bsub>R\<^esub> I, mult = rcoset_mult R I,
      one = (I +>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>), zero = I, add = set_add R\<rparr>"

subsection {* Factorization over General Ideals *}

text {* The quotient is a ring *}
lemma (in ideal) quotient_is_ring: "ring (R Quot I)"
apply (rule ringI)
   --{* abelian group *}
   apply (rule comm_group_abelian_groupI)
   apply (simp add: FactRing_def)
   apply (rule a_factorgroup_is_comm_group[unfolded A_FactGroup_def'])
  --{* mult monoid *}
  apply (rule monoidI)
      apply (simp_all add: FactRing_def A_RCOSETS_def RCOSETS_def
             a_r_coset_def[symmetric])
      --{* mult closed *}
      apply (clarify)
      apply (simp add: rcoset_mult_add, fast)
     --{* mult @{text one_closed} *}
     apply force
    --{* mult assoc *}
    apply clarify
    apply (simp add: rcoset_mult_add m_assoc)
   --{* mult one *}
   apply clarify
   apply (simp add: rcoset_mult_add)
  apply clarify
  apply (simp add: rcoset_mult_add)
 --{* distr *}
 apply clarify
 apply (simp add: rcoset_mult_add a_rcos_sum l_distr)
apply clarify
apply (simp add: rcoset_mult_add a_rcos_sum r_distr)
done

text {* This is a ring homomorphism *}

lemma (in ideal) rcos_ring_hom: "(op +> I) \<in> ring_hom R (R Quot I)"
apply (rule ring_hom_memI)
   apply (simp add: FactRing_def a_rcosetsI[OF a_subset])
  apply (simp add: FactRing_def rcoset_mult_add)
 apply (simp add: FactRing_def a_rcos_sum)
apply (simp add: FactRing_def)
done

lemma (in ideal) rcos_ring_hom_ring: "ring_hom_ring R (R Quot I) (op +> I)"
apply (rule ring_hom_ringI)
     apply (rule is_ring, rule quotient_is_ring)
   apply (simp add: FactRing_def a_rcosetsI[OF a_subset])
  apply (simp add: FactRing_def rcoset_mult_add)
 apply (simp add: FactRing_def a_rcos_sum)
apply (simp add: FactRing_def)
done

text {* The quotient of a cring is also commutative *}
lemma (in ideal) quotient_is_cring:
  assumes "cring R"
  shows "cring (R Quot I)"
proof -
  interpret cring R by fact
  show ?thesis
    apply (intro cring.intro comm_monoid.intro comm_monoid_axioms.intro)
      apply (rule quotient_is_ring)
     apply (rule ring.axioms[OF quotient_is_ring])
    apply (simp add: FactRing_def A_RCOSETS_defs a_r_coset_def[symmetric])
    apply clarify
    apply (simp add: rcoset_mult_add m_comm)
    done
qed

text {* Cosets as a ring homomorphism on crings *}
lemma (in ideal) rcos_ring_hom_cring:
  assumes "cring R"
  shows "ring_hom_cring R (R Quot I) (op +> I)"
proof -
  interpret cring R by fact
  show ?thesis
    apply (rule ring_hom_cringI)
      apply (rule rcos_ring_hom_ring)
     apply (rule is_cring)
    apply (rule quotient_is_cring)
   apply (rule is_cring)
   done
qed

subsection {* Factorization over Prime Ideals *}

text {* The quotient ring generated by a prime ideal is a domain *}
lemma (in primeideal) quotient_is_domain: "domain (R Quot I)"
  apply (rule domain.intro)
   apply (rule quotient_is_cring, rule is_cring)
  apply (rule domain_axioms.intro)
   apply (simp add: FactRing_def) defer 1
    apply (simp add: FactRing_def A_RCOSETS_defs a_r_coset_def[symmetric], clarify)
    apply (simp add: rcoset_mult_add) defer 1
proof (rule ccontr, clarsimp)
  assume "I +> \<one> = I"
  then have "\<one> \<in> I" by (simp only: a_coset_join1 one_closed a_subgroup)
  then have "carrier R \<subseteq> I" by (subst one_imp_carrier, simp, fast)
  with a_subset have "I = carrier R" by fast
  with I_notcarr show False by fast
next
  fix x y
  assume carr: "x \<in> carrier R" "y \<in> carrier R"
    and a: "I +> x \<otimes> y = I"
    and b: "I +> y \<noteq> I"

  have ynI: "y \<notin> I"
  proof (rule ccontr, simp)
    assume "y \<in> I"
    then have "I +> y = I" by (rule a_rcos_const)
    with b show False by simp
  qed

  from carr have "x \<otimes> y \<in> I +> x \<otimes> y" by (simp add: a_rcos_self)
  then have xyI: "x \<otimes> y \<in> I" by (simp add: a)

  from xyI and carr have xI: "x \<in> I \<or> y \<in> I" by (simp add: I_prime)
  with ynI have "x \<in> I" by fast
  then show "I +> x = I" by (rule a_rcos_const)
qed

text {* Generating right cosets of a prime ideal is a homomorphism
        on commutative rings *}
lemma (in primeideal) rcos_ring_hom_cring: "ring_hom_cring R (R Quot I) (op +> I)"
  by (rule rcos_ring_hom_cring) (rule is_cring)

subsection {* Factorization over Maximal Ideals *}

text {* In a commutative ring, the quotient ring over a maximal ideal
        is a field.
        The proof follows ``W. Adkins, S. Weintraub: Algebra --
        An Approach via Module Theory'' *}
lemma (in maximalideal) quotient_is_field:
  assumes "cring R"
  shows "field (R Quot I)"
proof -
  interpret cring R by fact
  show ?thesis
    apply (intro cring.cring_fieldI2)
      apply (rule quotient_is_cring, rule is_cring)
     defer 1
     apply (simp add: FactRing_def A_RCOSETS_defs a_r_coset_def[symmetric], clarsimp)
     apply (simp add: rcoset_mult_add) defer 1
  proof (rule ccontr, simp)
    --{* Quotient is not empty *}
    assume "\<zero>\<^bsub>R Quot I\<^esub> = \<one>\<^bsub>R Quot I\<^esub>"
    then have II1: "I = I +> \<one>" by (simp add: FactRing_def)
    from a_rcos_self[OF one_closed] have "\<one> \<in> I"
      by (simp add: II1[symmetric])
    then have "I = carrier R" by (rule one_imp_carrier)
    with I_notcarr show False by simp
  next
    --{* Existence of Inverse *}
    fix a
    assume IanI: "I +> a \<noteq> I" and acarr: "a \<in> carrier R"

    --{* Helper ideal @{text "J"} *}
    def J \<equiv> "(carrier R #> a) <+> I :: 'a set"
    have idealJ: "ideal J R"
      apply (unfold J_def, rule add_ideals)
       apply (simp only: cgenideal_eq_rcos[symmetric], rule cgenideal_ideal, rule acarr)
      apply (rule is_ideal)
      done

    --{* Showing @{term "J"} not smaller than @{term "I"} *}
    have IinJ: "I \<subseteq> J"
    proof (rule, simp add: J_def r_coset_def set_add_defs)
      fix x
      assume xI: "x \<in> I"
      have Zcarr: "\<zero> \<in> carrier R" by fast
      from xI[THEN a_Hcarr] acarr
      have "x = \<zero> \<otimes> a \<oplus> x" by algebra
      with Zcarr and xI show "\<exists>xa\<in>carrier R. \<exists>k\<in>I. x = xa \<otimes> a \<oplus> k" by fast
    qed

    --{* Showing @{term "J \<noteq> I"} *}
    have anI: "a \<notin> I"
    proof (rule ccontr, simp)
      assume "a \<in> I"
      then have "I +> a = I" by (rule a_rcos_const)
      with IanI show False by simp
    qed

    have aJ: "a \<in> J"
    proof (simp add: J_def r_coset_def set_add_defs)
      from acarr
      have "a = \<one> \<otimes> a \<oplus> \<zero>" by algebra
      with one_closed and additive_subgroup.zero_closed[OF is_additive_subgroup]
      show "\<exists>x\<in>carrier R. \<exists>k\<in>I. a = x \<otimes> a \<oplus> k" by fast
    qed

    from aJ and anI have JnI: "J \<noteq> I" by fast

    --{* Deducing @{term "J = carrier R"} because @{term "I"} is maximal *}
    from idealJ and IinJ have "J = I \<or> J = carrier R"
    proof (rule I_maximal, unfold J_def)
      have "carrier R #> a \<subseteq> carrier R"
        using subset_refl acarr by (rule r_coset_subset_G)
      then show "carrier R #> a <+> I \<subseteq> carrier R"
        using a_subset by (rule set_add_closed)
    qed

    with JnI have Jcarr: "J = carrier R" by simp

    --{* Calculating an inverse for @{term "a"} *}
    from one_closed[folded Jcarr]
    have "\<exists>r\<in>carrier R. \<exists>i\<in>I. \<one> = r \<otimes> a \<oplus> i"
      by (simp add: J_def r_coset_def set_add_defs)
    then obtain r i where rcarr: "r \<in> carrier R"
      and iI: "i \<in> I" and one: "\<one> = r \<otimes> a \<oplus> i" by fast
    from one and rcarr and acarr and iI[THEN a_Hcarr]
    have rai1: "a \<otimes> r = \<ominus>i \<oplus> \<one>" by algebra

    --{* Lifting to cosets *}
    from iI have "\<ominus>i \<oplus> \<one> \<in> I +> \<one>"
      by (intro a_rcosI, simp, intro a_subset, simp)
    with rai1 have "a \<otimes> r \<in> I +> \<one>" by simp
    then have "I +> \<one> = I +> a \<otimes> r"
      by (rule a_repr_independence, simp) (rule a_subgroup)

    from rcarr and this[symmetric]
    show "\<exists>r\<in>carrier R. I +> a \<otimes> r = I +> \<one>" by fast
  qed
qed

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Jeremy Dawson, NICTA *)

section \<open>Shift operations with infix syntax\<close>

theory Bit_Shifts_Infix_Syntax
  imports "HOL-Library.Word" More_Word
begin

context semiring_bit_operations
begin

definition shiftl :: \<open>'a \<Rightarrow> nat \<Rightarrow> 'a\<close>  (infixl "<<" 55)
  where [code_unfold]: \<open>a << n = push_bit n a\<close>

lemma bit_shiftl_iff [bit_simps]:
  \<open>bit (a << m) n \<longleftrightarrow> m \<le> n \<and> possible_bit TYPE('a) n \<and> bit a (n - m)\<close>
  by (simp add: shiftl_def bit_simps)

definition shiftr :: \<open>'a \<Rightarrow> nat \<Rightarrow> 'a\<close>  (infixl ">>" 55)
  where [code_unfold]: \<open>a >> n = drop_bit n a\<close>

lemma bit_shiftr_eq [bit_simps]:
  \<open>bit (a >> n) = bit a \<circ> (+) n\<close>
  by (simp add: shiftr_def bit_simps)

end

definition sshiftr :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> 'a word\<close>  (infixl \<open>>>>\<close> 55)
  where [code_unfold]: \<open>w >>> n = signed_drop_bit n w\<close>

lemma bit_sshiftr_iff [bit_simps]:
  \<open>bit (w >>> m) n \<longleftrightarrow> bit w (if LENGTH('a) - m \<le> n \<and> n < LENGTH('a) then LENGTH('a) - 1 else m + n)\<close>
  for w :: \<open>'a::len word\<close>
  by (simp add: sshiftr_def bit_simps)

context
  includes lifting_syntax
begin

lemma shiftl_word_transfer [transfer_rule]:
  \<open>(pcr_word ===> (=) ===> pcr_word) (\<lambda>k n. push_bit n k) (<<)\<close>
  apply (unfold shiftl_def)
  apply transfer_prover
  done

lemma shiftr_word_transfer [transfer_rule]:
  \<open>((pcr_word :: int \<Rightarrow> 'a::len word \<Rightarrow> _) ===> (=) ===> pcr_word)
    (\<lambda>k n. drop_bit n (take_bit LENGTH('a) k))
    (>>)\<close>
proof -
  have \<open>((pcr_word :: int \<Rightarrow> 'a::len word \<Rightarrow> _) ===> (=) ===> pcr_word)
    (\<lambda>k n. (drop_bit n \<circ> take_bit LENGTH('a)) k)
    (>>)\<close>
    by (unfold shiftr_def) transfer_prover
  then show ?thesis
    by simp
qed

lemma sshiftr_transfer [transfer_rule]:
  \<open>((pcr_word :: int \<Rightarrow> 'a::len word \<Rightarrow> _) ===> (=) ===> pcr_word)
    (\<lambda>k n. drop_bit n (signed_take_bit (LENGTH('a) - Suc 0) k))
    (>>>)\<close>
proof -
  have \<open>((pcr_word :: int \<Rightarrow> 'a::len word \<Rightarrow> _) ===> (=) ===> pcr_word)
    (\<lambda>k n. (drop_bit n \<circ> signed_take_bit (LENGTH('a) - Suc 0)) k)
    (>>>)\<close>
    by (unfold sshiftr_def) transfer_prover
  then show ?thesis
    by simp
qed

end

context semiring_bit_operations
begin

lemma shiftl_0 [simp]:
  \<open>0 << n = 0\<close>
  by (simp add: shiftl_def)

lemma shiftl_of_0 [simp]:
  \<open>a << 0 = a\<close>
  by (simp add: shiftl_def)

lemma shiftl_of_Suc [simp]:
  \<open>a << Suc n = (a * 2) << n\<close>
  by (simp add: shiftl_def)

lemma shiftl_1 [simp]:
  \<open>1 << n = 2 ^ n\<close>
  by (simp add: shiftl_def)

lemma shiftl_numeral_Suc [simp]:
  \<open>numeral m << Suc n = push_bit (Suc n) (numeral m)\<close>
  by (fact shiftl_def)

lemma shiftl_numeral_numeral [simp]:
  \<open>numeral m << numeral n = push_bit (numeral n) (numeral m)\<close>
  by (fact shiftl_def)

lemma shiftr_0 [simp]:
  \<open>0 >> n = 0\<close>
  by (simp add: shiftr_def)

lemma shiftr_of_0 [simp]:
  \<open>a >> 0 = a\<close>
  by (simp add: shiftr_def)

lemma shiftr_1 [simp]:
  \<open>1 >> n = of_bool (n = 0)\<close>
  by (simp add: shiftr_def)

lemma shiftr_numeral_Suc [simp]:
  \<open>numeral m >> Suc n = drop_bit (Suc n) (numeral m)\<close>
  by (fact shiftr_def)

lemma shiftr_numeral_numeral [simp]:
  \<open>numeral m >> numeral n = drop_bit (numeral n) (numeral m)\<close>
  by (fact shiftr_def)

lemma shiftl_eq_mult:
  \<open>x << n = x * 2 ^ n\<close>
  unfolding shiftl_def by (fact push_bit_eq_mult)

lemma shiftr_eq_div:
  \<open>x >> n = x div 2 ^ n\<close>
  unfolding shiftr_def by (fact drop_bit_eq_div)

end

context ring_bit_operations
begin

context
  includes bit_operations_syntax
begin

lemma shiftl_minus_1_numeral [simp]:
  \<open>- 1 << numeral n = NOT (mask (numeral n))\<close>
  by (simp add: shiftl_def)

end

end

lemma shiftl_Suc_0 [simp]:
  \<open>Suc 0 << n = 2 ^ n\<close>
  by (simp add: shiftl_def)

lemma shiftr_Suc_0 [simp]:
  \<open>Suc 0 >> n = of_bool (n = 0)\<close>
  by (simp add: shiftr_def)

lemma sshiftr_numeral_Suc [simp]:
  \<open>numeral m >>> Suc n = signed_drop_bit (Suc n) (numeral m)\<close>
  by (fact sshiftr_def)

lemma sshiftr_numeral_numeral [simp]:
  \<open>numeral m >>> numeral n = signed_drop_bit (numeral n) (numeral m)\<close>
  by (fact sshiftr_def)

context ring_bit_operations
begin

lemma shiftl_minus_numeral_Suc [simp]:
  \<open>- numeral m << Suc n = push_bit (Suc n) (- numeral m)\<close>
  by (fact shiftl_def)

lemma shiftl_minus_numeral_numeral [simp]:
  \<open>- numeral m << numeral n = push_bit (numeral n) (- numeral m)\<close>
  by (fact shiftl_def)

lemma shiftr_minus_numeral_Suc [simp]:
  \<open>- numeral m >> Suc n = drop_bit (Suc n) (- numeral m)\<close>
  by (fact shiftr_def)

lemma shiftr_minus_numeral_numeral [simp]:
  \<open>- numeral m >> numeral n = drop_bit (numeral n) (- numeral m)\<close>
  by (fact shiftr_def)

end

lemma sshiftr_0 [simp]:
  \<open>0 >>> n = 0\<close>
  by (simp add: sshiftr_def)

lemma sshiftr_of_0 [simp]:
  \<open>w >>> 0 = w\<close>
  by (simp add: sshiftr_def)

lemma sshiftr_1 [simp]:
  \<open>(1 :: 'a::len word) >>> n = of_bool (LENGTH('a) = 1 \<or> n = 0)\<close>
  by (simp add: sshiftr_def)

lemma sshiftr_minus_numeral_Suc [simp]:
  \<open>- numeral m >>> Suc n = signed_drop_bit (Suc n) (- numeral m)\<close>
  by (fact sshiftr_def)

lemma sshiftr_minus_numeral_numeral [simp]:
  \<open>- numeral m >>> numeral n = signed_drop_bit (numeral n) (- numeral m)\<close>
  by (fact sshiftr_def)

end