(*
    Author:     Wenda Li <wl302@cam.ac.uk / liwenda1990@hotmail.com>
*)

section \<open>Some useful lemmas about transcendental functions\<close>

theory Missing_Transcendental imports
  Missing_Topology
  Missing_Algebraic
begin

subsection \<open>Misc\<close>

lemma exp_Arg2pi2pi_multivalue:
  assumes "exp (\<i> * of_real x) = z"
  shows "\<exists>k::int. x = Arg2pi z + 2*k*pi"
proof -
  define k where "k=floor( x/(2*pi))"
  define x' where "x'= x - (2*k*pi)"
  have "x'/(2*pi) \<ge>0"  unfolding x'_def k_def by (simp add: diff_divide_distrib)
  moreover have "x'/(2*pi) < 1"
  proof -
    have "x/(2*pi) - k < 1" unfolding k_def by linarith
    thus ?thesis unfolding k_def x'_def by (auto simp add:field_simps)
  qed
  ultimately have "x'\<ge>0" and "x'<2*pi" by (auto simp add:field_simps)
  moreover have "exp (\<i> * complex_of_real x') = z"
    using assms x'_def by  (auto simp add:field_simps )
  ultimately have "Arg2pi z = x'" using Arg2pi_unique[of 1 x' z,simplified] by auto
  hence " x = Arg2pi z + 2*k*pi" unfolding x'_def by auto
  thus ?thesis by auto
qed

lemma uniform_discrete_tan_eq:
  "uniform_discrete {x::real. tan x = y}"
proof -
  have "x1=x2" when dist:"dist x1 x2<pi/2" and "tan x1=y" "tan x2=y" for x1 x2
  proof -
    obtain k1::int where x1:"x1 = arctan y + k1*pi \<or> (x1 = pi/2 + k1*pi \<and> y=0)"
      using tan_eq_arctan_Ex \<open>tan x1=y\<close> by auto
    obtain k2::int where x2:"x2 = arctan y + k2*pi \<or> (x2 = pi/2 + k2*pi \<and> y=0)"
      using tan_eq_arctan_Ex \<open>tan x2=y\<close> by auto
    let ?xk1="x1 = arctan y + k1*pi" and ?xk1'="x1 = pi/2 + k1*pi \<and> y=0"
    let ?xk2="x2 = arctan y + k2*pi" and ?xk2'="x2 = pi/2 + k2*pi \<and> y=0"
    have ?thesis when "(?xk1 \<and> ?xk2) \<or> (?xk1' \<and> ?xk2')"
    proof -
      have "x1-x2= (k1 - k2) *pi" when ?xk1 ?xk2
        using arg_cong2[where f=minus,OF \<open>?xk1\<close> \<open>?xk2\<close>]
        by (auto simp add:algebra_simps)
      moreover have "x1-x2= (k1 - k2) *pi" when ?xk1' ?xk2'
        using arg_cong2[where f=minus,OF conjunct1[OF \<open>?xk1'\<close>] conjunct1[OF \<open>?xk2'\<close>]]
        by (auto simp add:algebra_simps)
      ultimately have "x1-x2= (k1 - k2) *pi" using that by auto
      then have "\<bar>k1 - k2\<bar> < 1/2"
        using dist[unfolded dist_real_def] by (auto simp add:abs_mult)
      then have "k1=k2" by linarith
      then show ?thesis using that by auto
    qed
    moreover have ?thesis when ?xk1 ?xk2'
    proof -
      have "x1 = k1*pi" "x2 = pi / 2 + k2 * pi" using \<open>?xk2'\<close> \<open>?xk1\<close> by auto
      from arg_cong2[where f=minus,OF this] have "x1 - x2 = (k1 - k2) * pi -pi/2"
        by (auto simp add:algebra_simps)
      then have "\<bar>(k1 - k2) * pi -pi/2\<bar> < pi/2" using dist[unfolded dist_real_def] by auto
      then have "0<k1-k2" "k1-k2<1"
        unfolding abs_less_iff  by (auto simp add: zero_less_mult_iff)
      then have False by simp
      then show ?thesis by auto
    qed
    moreover have ?thesis when ?xk1' ?xk2
    proof -
      have "x1 = pi / 2 + k1*pi" "x2 = k2 * pi" using \<open>?xk2\<close> \<open>?xk1'\<close> by auto
      from arg_cong2[where f=minus,OF this] have "x1 - x2 = (k1 - k2) * pi + pi/2"
        by (auto simp add:algebra_simps)
      then have "\<bar>(k1 - k2) * pi + pi/2\<bar> < pi/2" using dist[unfolded dist_real_def] by auto
      then have "\<bar>(k1 - k2 + 1/2)*pi\<bar> < pi/2" by (auto simp add:algebra_simps)
      then have "\<bar>(k1 - k2 + 1/2)\<bar> < 1/2" by (auto simp add:abs_mult)
      then have "-1<k1-k2 \<and> k1-k2<0"
        unfolding abs_less_iff by linarith
      then have False by auto
      then show ?thesis by auto
    qed
    ultimately show ?thesis using x1 x2 by blast
  qed
  then show ?thesis unfolding uniform_discrete_def
    apply (intro exI[where x="pi/2"])
    by auto
qed

lemma get_norm_value:
  fixes a::"'a::{floor_ceiling}"
  assumes "pp>0"
  obtains k::int and a1 where "a=(of_int k)*pp+a1" "a0\<le>a1" "a1<a0+pp"
proof -
  define k where "k=floor ((a-a0)/pp)"
  define a1 where "a1=a-(of_int k)*pp"
  have "of_int \<lfloor>(a - a0) / pp\<rfloor> * pp \<le> a- a0"
    using assms by (meson le_divide_eq of_int_floor_le)
  moreover have "a-a0 < of_int (\<lfloor>(a - a0) / pp\<rfloor>+1) * pp"
    using assms by (meson divide_less_eq floor_correct)
  ultimately show ?thesis
    apply (intro that[of k a1])
    unfolding k_def a1_def using assms by (auto simp add:algebra_simps)
qed

(*Is it possible to generalise or simplify this messy proof?*)
lemma filtermap_tan_at_right:
  fixes a::real
  assumes "cos a\<noteq>0"
  shows "filtermap tan (at_right a) = at_right (tan a)"
proof -
  obtain k::int and a1 where aa1:"a=k*pi+a1" and pi_a1: "-pi/2\<le>a1" "a1<pi/2"
    using get_norm_value[of pi a "-pi/2"] by auto
  have "-pi/2 < a1"
  using assms
    by (smt (verit, ccfv_SIG) pi_a1 aa1 cos_2pi_minus cos_diff cos_pi_half cos_two_pi divide_minus_left mult_of_int_commute sin_add sin_npi_int sin_pi_half sin_two_pi)
  have "eventually P (at_right (tan a))"
    when "eventually P (filtermap tan (at_right a))" for P
  proof -
    obtain b1 where "b1>a" and b1_imp:" \<forall>y>a. y < b1 \<longrightarrow> P (tan y)"
      by (metis Sturm_Tarski.eventually_at_right \<open>eventually P (filtermap tan (at_right a))\<close> eventually_filtermap)
    define b2 where "b2=min b1 (k*pi+pi/4+a1/2)"
    define b3 where "b3=b2 - k*pi"
    have "-pi/2 < b3" "b3<pi/2"
    proof -
      have "a1<b3"
        using \<open>b1>a\<close> aa1 \<open>a1<pi/2\<close> unfolding b2_def b3_def by (auto simp add:field_simps)
      then show "-pi/2 < b3" using \<open>-pi/2\<le>a1\<close> by auto
      show "b3 < pi/2"
        using b2_def b3_def pi_a1(2) by linarith
    qed
    have "tan b2 > tan a"
    proof -
      have "tan a = tan a1"
        using aa1 by (simp add: add.commute)
      also have "... < tan b3"
      proof -
        have "a1<b3"
          using \<open>b1>a\<close> aa1 \<open>a1<pi/2\<close> unfolding b2_def b3_def by (auto simp add:field_simps)
        then show ?thesis
          using tan_monotone \<open>-pi/2 < a1\<close> \<open>b3 < pi/2\<close> by simp
      qed
      also have "... = tan b2" unfolding b3_def
        by (metis Groups.mult_ac(2) add_uminus_conv_diff mult_minus_right of_int_minus
          tan_periodic_int)
      finally show ?thesis .
    qed
    moreover have "P y" when "y>tan a" "y < tan b2" for y
    proof -
      define y1 where "y1=arctan y+ k * pi"
      have "a<y1"
      proof -
        have "arctan (tan a) < arctan y" using \<open>y>tan a\<close> arctan_monotone by auto
        then have "a1<arctan y"
          using arctan_tan \<open>-pi/2 < a1\<close> \<open>a1<pi/2\<close> unfolding aa1 by (simp add: add.commute)
        then show ?thesis unfolding y1_def aa1 by auto
      qed
      moreover have "y1<b2"
      proof -
        have "arctan y < arctan (tan b2)"
          using \<open>y < tan b2\<close> arctan_monotone by auto
        moreover have "arctan (tan b2) = b3"
          using arctan_tan[of b3] \<open>-pi/2 < b3\<close> \<open>b3<pi/2\<close> unfolding b3_def
          by (metis add.inverse_inverse diff_minus_eq_add divide_minus_left mult.commute
            mult_minus_right of_int_minus tan_periodic_int)
        ultimately have "arctan y < b3" by auto
        then show ?thesis unfolding y1_def b3_def by auto
      qed
      moreover have "\<forall>y>a. y < b2 \<longrightarrow> P (tan y)"
        using b1_imp unfolding b2_def by auto
      moreover have "tan y1=y" unfolding y1_def by (auto simp add:tan_arctan)
      ultimately show ?thesis by auto
    qed
    ultimately show "eventually P (at_right (tan a))"
      unfolding eventually_at_right by (metis eventually_at_right_field)
  qed
  moreover have "eventually P (filtermap tan (at_right a))"
    when "eventually P (at_right (tan a))" for P
  proof -
    obtain b1 where "b1>tan a" and b1_imp:"\<forall>y>tan a. y < b1 \<longrightarrow> P y"
      using \<open>eventually P (at_right (tan a))\<close> unfolding eventually_at_right
      by (metis eventually_at_right_field)
    define b2 where "b2=arctan b1 + k*pi"
    have "a1 < arctan b1"
      by (metis \<open>- pi / 2 < a1\<close> \<open>a1 < pi / 2\<close> \<open>tan a < b1\<close> aa1 add.commute arctan_less_iff
            arctan_tan divide_minus_left tan_periodic_int)
    then have "b2>a" unfolding aa1 b2_def by auto
    moreover have "P (tan y)" when "y>a" "y < b2" for y
    proof -
      define y1 where "y1 = y - k*pi"
      have "a1 < y1" "y1 < arctan b1" unfolding y1_def
        subgoal using \<open>y>a\<close> unfolding aa1 by auto
        subgoal using b2_def that(2) by linarith
        done
      then have "tan a1 < tan y1" "tan y1< b1"
        subgoal using \<open>a1>-pi/2\<close>
          apply (intro tan_monotone,simp,simp)
          using arctan_ubound less_trans by blast
        subgoal
          by (metis \<open>- pi / 2 < a1\<close> \<open>a1 < y1\<close> \<open>y1 < arctan b1\<close> arctan_less_iff arctan_tan
              arctan_ubound divide_minus_left less_trans)
        done
      have "tan y>tan a"
        by (metis \<open>tan a1 < tan y1\<close> aa1 add.commute add_uminus_conv_diff mult.commute
            mult_minus_right of_int_minus tan_periodic_int y1_def)
      moreover have "tan y<b1"
        by (metis \<open>tan y1 < b1\<close> add_uminus_conv_diff mult.commute mult_minus_right
            of_int_minus tan_periodic_int y1_def)
      ultimately show ?thesis using b1_imp by auto
    qed
    ultimately show ?thesis unfolding eventually_filtermap eventually_at_right
      by (metis eventually_at_right_field)
  qed
  ultimately show ?thesis unfolding filter_eq_iff by blast
qed

lemma filtermap_tan_at_left:
  fixes a::real
  assumes "cos a\<noteq>0"
  shows "filtermap tan (at_left a) = at_left (tan a)"
proof -
  have "filtermap tan (at_right (- a)) = at_right (tan (- a))"
    using filtermap_tan_at_right[of "-a"] assms by auto
  then have "filtermap (uminus o tan) (at_left a) = filtermap uminus (at_left (tan a))"
    unfolding at_right_minus filtermap_filtermap comp_def by auto
  then have "filtermap uminus (filtermap (uminus o tan) (at_left a))
      = filtermap uminus (filtermap uminus (at_left (tan a)))"
    by auto
  then show ?thesis
    unfolding filtermap_filtermap comp_def by auto
qed

lemma filtermap_tan_at_right_inf:
  fixes a::real
  assumes "cos a=0"
  shows "filtermap tan (at_right a) = at_bot"
proof -
  obtain k::int where ak:"a=k*pi + pi/2"
    using cos_zero_iff_int2 assms by auto
  have "eventually P at_bot" when "eventually P (filtermap tan (at_right a))" for P
  proof -
    obtain b1 where "b1>a" and b1_imp:"\<forall>y>a. y < b1 \<longrightarrow> P (tan y)"
      using \<open>eventually P (filtermap tan (at_right a))\<close>
      unfolding eventually_filtermap eventually_at_right
      by (metis eventually_at_right_field)
    define b2 where "b2=min (k*pi+pi) b1"
    have "P y" when "y<tan b2" for y
    proof -
      define y1 where "y1=(k+1)*pi+arctan y"
      have "a < y1"
        unfolding ak y1_def using arctan_lbound[of y]
        by (auto simp add:field_simps)
      moreover have "y1 < b2"
      proof -
        define b3 where "b3=b2-(k+1) * pi"
        have "-pi/2 < b3" "b3<pi/2"
          using \<open>b1>a\<close> unfolding b3_def b2_def ak
          by (auto simp add:field_simps min_mult_distrib_left intro!:min.strict_coboundedI1)
        then have "arctan (tan b3) = b3"
          by (simp add: arctan_tan)
        then have "arctan (tan b2) = b3"
          unfolding b3_def by (metis diff_eq_eq tan_periodic_int)
        then have "arctan y < b3"
          using arctan_monotone[OF \<open>y<tan b2\<close>] by simp
        then show ?thesis
          unfolding y1_def b3_def by auto
      qed
      then have "y1<b1" unfolding b2_def by auto
      ultimately have " P (tan y1)" using b1_imp[rule_format,of y1,simplified] by auto
      then show ?thesis unfolding y1_def by (metis add.commute arctan tan_periodic_int)
    qed
    then show ?thesis unfolding eventually_at_bot_dense by auto
  qed
  moreover have "eventually P (filtermap tan (at_right a))" when "eventually P at_bot" for P
  proof -
    obtain b1 where b1_imp:"\<forall>n<b1. P n"
      using \<open>eventually P at_bot\<close> unfolding eventually_at_bot_dense by auto
    define b2 where "b2=arctan b1 + (k+1)*pi"
    have "b2>a" unfolding ak b2_def using arctan_lbound[of b1]
      by (auto simp add:algebra_simps)
    moreover have "P (tan y)" when "a < y" " y < b2 " for y
    proof -
      define y1 where "y1=y-(k+1)*pi"
      have "tan y1 < tan (arctan b1)"
        apply (rule tan_monotone)
        subgoal using \<open>a<y\<close> unfolding y1_def ak by (auto simp add:algebra_simps)
        subgoal using \<open>y < b2\<close> unfolding y1_def b2_def by (auto simp add:algebra_simps)
        subgoal using arctan_ubound by auto
        done
      then have "tan y1<b1" by (simp add: arctan)
      then have "tan y < b1" unfolding y1_def
        by (metis diff_eq_eq tan_periodic_int)
      then show ?thesis using b1_imp by auto
    qed
    ultimately show "eventually P (filtermap tan (at_right a))"
      unfolding eventually_filtermap eventually_at_right
      by (metis eventually_at_right_field)
  qed
  ultimately show ?thesis unfolding filter_eq_iff by auto
qed

lemma filtermap_tan_at_left_inf:
  fixes a::real
  assumes "cos a=0"
  shows "filtermap tan (at_left a) = at_top"
proof -
  have "filtermap tan (at_right (- a)) = at_bot"
    using filtermap_tan_at_right_inf[of "-a"] assms by auto
  then have "filtermap (uminus o tan) (at_left a) = at_bot"
    unfolding at_right_minus filtermap_filtermap comp_def by auto
  then have "filtermap uminus (filtermap (uminus o tan) (at_left a)) = filtermap uminus at_bot"
    by auto
  then show ?thesis
    unfolding filtermap_filtermap comp_def using at_top_mirror[where 'a=real] by auto
qed

subsection \<open>Periodic set\<close>

(*Devised to characterize roots of Trigonometric equations, which are usually uniformly discrete.*)
definition periodic_set:: "real set \<Rightarrow> real \<Rightarrow> bool" where
  "periodic_set S \<delta> \<longleftrightarrow> (\<exists>B. finite B \<and> (\<forall>x\<in>S. \<exists>b\<in>B. \<exists>k::int. x =b + k * \<delta> ))"

lemma periodic_set_multiple:
  assumes "k\<noteq>0"
  shows "periodic_set S \<delta> \<longleftrightarrow> periodic_set S (of_int k*\<delta>)"
proof
  assume asm:"periodic_set S \<delta> "
  then obtain B1 where "finite B1" and B1_def:"\<forall>x\<in>S. \<exists>b\<in>B1. (\<exists>k::int. x = b + k * \<delta>)"
    unfolding periodic_set_def by metis
  define B where "B = B1 \<union> {b+i*\<delta> | b i. b\<in>B1 \<and> i\<in>{0..<\<bar>k\<bar>}}"
  have "\<exists>b\<in>B. \<exists>k'. x = b + real_of_int k' * (real_of_int k * \<delta>)" when "x\<in>S" for x
  proof -
    obtain b1 and k1::int where "b1\<in>B1" and x_\<delta>:"x = b1 + k1 * \<delta>"
      using B1_def[rule_format, OF \<open>x\<in>S\<close>] by auto
    define r d where "r= k1 mod \<bar>k\<bar>" and "d = k1 div \<bar>k\<bar>"
    define b kk where "b=b1+r*\<delta>" and "kk = (if k>0 then d else -d)"
    have "x = b1 + (r+\<bar>k\<bar>*d)*\<delta>" using x_\<delta> unfolding r_def d_def by auto
    then have "x = b + kk*(k*\<delta>)" unfolding b_def kk_def using \<open>k\<noteq>0\<close>
      by (auto simp add:algebra_simps)
    moreover have "b\<in>B"
    proof -
      have "r \<in> {0..<\<bar>k\<bar>}" unfolding r_def by (simp add: \<open>k\<noteq>0\<close>)
      then show ?thesis unfolding b_def B_def using \<open>b1\<in>B1\<close> by blast
    qed
    ultimately show ?thesis by auto
  qed
  moreover have "finite B" unfolding B_def using \<open>finite B1\<close>
    by (simp add: finite_image_set2)
  ultimately show "periodic_set S (real_of_int k * \<delta>)" unfolding periodic_set_def by auto
next
  assume "periodic_set S (real_of_int k * \<delta>)"
  then show "periodic_set S \<delta>" unfolding periodic_set_def
    by (metis mult.commute mult.left_commute of_int_mult)
qed

lemma periodic_set_empty[simp]: "periodic_set {} \<delta>"
  unfolding periodic_set_def by auto

lemma periodic_set_finite:
  assumes "finite S"
  shows "periodic_set S \<delta>"
unfolding periodic_set_def using assms mult.commute by force

lemma periodic_set_subset[elim]:
  assumes "periodic_set S \<delta>" "T \<subseteq> S"
  shows "periodic_set T \<delta>"
using assms unfolding periodic_set_def by (meson subsetCE)

lemma periodic_set_union:
  assumes "periodic_set S \<delta>" "periodic_set T \<delta>"
  shows "periodic_set (S \<union> T) \<delta>"
using assms unfolding periodic_set_def by (metis Un_iff infinite_Un)

lemma periodic_imp_uniform_discrete:
  assumes "periodic_set S \<delta>"
  shows "uniform_discrete S"
proof -
  have ?thesis when "S\<noteq>{}" "\<delta>\<noteq>0"
  proof -
    obtain B g where "finite B" and g_def:"\<forall>x\<in>S. g x\<in>B \<and> (\<exists>k::int. x = g x + k * \<delta>)"
      using assms unfolding periodic_set_def by metis
    define P where "P = ((*) \<delta>) ` Ints"
    define B_diff where "B_diff = {\<bar>x-y\<bar> | x y.  x\<in>B \<and> y\<in>B} - P"
    have "finite B_diff" unfolding B_diff_def using \<open>finite B\<close>
      by (simp add: finite_image_set2)
    define e where "e = (if setdist B_diff P = 0 then \<bar>\<delta>\<bar> else min (setdist B_diff P) (\<bar>\<delta>\<bar>))"
    have "e>0"
      unfolding e_def using setdist_pos_le[unfolded order_class.le_less] \<open>\<delta>\<noteq>0\<close>
      by auto
    moreover have "x=y" when "x\<in>S" "y\<in>S" "dist x y<e" for x y
    proof -
      obtain k1::int where k1:"x = g x + k1 * \<delta>" and "g x\<in>B" using g_def \<open>x\<in>S\<close> by auto
      obtain k2::int where k2:"y = g y + k2 * \<delta>" and "g y\<in>B" using g_def \<open>y\<in>S\<close> by auto
      have ?thesis when "\<bar>g x - g y\<bar> \<in> P"
      proof -
        obtain k::int where k:"g x - g y = k * \<delta>"
        proof -
          obtain k' where "k'\<in>Ints" and *:"\<bar>g x - g y\<bar> = \<delta> * k'"
            using \<open>\<bar>g x - g y\<bar> \<in> P\<close> unfolding P_def image_iff by auto
          then obtain k where **:"k' = of_int k" using Ints_cases by auto
          show ?thesis
            apply (cases "g x - g y \<ge> 0")
            subgoal using that[of k] * ** by simp
            subgoal using that[of "-k"] * ** by (auto simp add:algebra_simps)
            done
        qed
        have "dist x y = \<bar>(g x - g y)+(k1-k2)*\<delta>\<bar>"
          unfolding dist_real_def by (subst k1,subst k2,simp add:algebra_simps)
        also have "... = \<bar>(k+k1-k2)*\<delta>\<bar>"
          by (subst k,simp add:algebra_simps)
        also have "... = \<bar>k+k1-k2\<bar>*\<bar>\<delta>\<bar>" by (simp add: abs_mult)
        finally have *:"dist x y = \<bar>k+k1-k2\<bar>*\<bar>\<delta>\<bar>" .
        then have "\<bar>k+k1-k2\<bar>*\<bar>\<delta>\<bar> < e" using \<open>dist x y<e\<close> by auto
        then have "\<bar>k+k1-k2\<bar>*\<bar>\<delta>\<bar> < \<bar>\<delta>\<bar>"
          by (simp add: e_def split: if_splits)
        then have "\<bar>k+k1-k2\<bar> = 0" unfolding e_def using \<open>\<delta>\<noteq>0\<close> by force
        then have "dist x y=0" using * by auto
        then show ?thesis by auto
      qed
      moreover have ?thesis when "\<bar>g x - g y\<bar> \<notin> P"
      proof -
        have "\<bar>g x - g y\<bar> \<in> B_diff" unfolding B_diff_def using \<open>g x\<in>B\<close> \<open>g y\<in>B\<close> that by auto
        have "e \<le> \<bar>\<bar>g x - g y\<bar> - \<bar>(k1-k2)*\<delta>\<bar>\<bar>"
        proof -
          have "\<bar>g x - g y\<bar> \<in> B_diff" unfolding B_diff_def using \<open>g x\<in>B\<close> \<open>g y\<in>B\<close> that by auto
          moreover have "\<bar>(k1-k2)*\<delta>\<bar> \<in> P" unfolding P_def
            apply (intro rev_image_eqI[of "(if \<delta>\<ge>0 then \<bar>of_int(k1-k2)\<bar> else - \<bar>of_int(k1-k2)\<bar>)"])
            apply (metis Ints_minus Ints_of_int of_int_abs)
            by (auto simp add:abs_mult)
          ultimately have "\<bar>\<bar>g x - g y\<bar> - \<bar>(k1-k2)*\<delta>\<bar>\<bar> \<ge> setdist B_diff P"
            using setdist_le_dist[of _ B_diff  _ P] dist_real_def by auto
          moreover have "setdist B_diff P \<noteq> 0"
          proof -
            have "compact B_diff " using  \<open>finite B_diff\<close> using finite_imp_compact by blast
            moreover have "closed P"
              unfolding P_def using closed_scaling[OF closed_Ints[where 'a=real], of \<delta>] by auto
            moreover have "P \<noteq> {}" using Ints_0 unfolding P_def by blast
            moreover have "B_diff \<inter> P = {}" unfolding B_diff_def by auto
            moreover have "B_diff \<noteq>{}" unfolding B_diff_def using \<open>g x\<in>B\<close> \<open>g y\<in>B\<close> that by auto
            ultimately show ?thesis using setdist_eq_0_compact_closed[of B_diff P] by auto
          qed
          ultimately show ?thesis unfolding e_def by argo
        qed
        also have "... \<le> \<bar>(g x - g y) + (k1-k2)*\<delta>\<bar>"
        proof -
          define t1 where "t1=g x - g y"
          define t2 where "t2 = of_int (k1 - k2) * \<delta>"
          show ?thesis
            apply (fold t1_def t2_def)
            by linarith
        qed
        also have "... = dist x y"
          unfolding dist_real_def
          by (subst (2) k1,subst (2) k2,simp add:algebra_simps)
        finally have "dist x y\<ge>e" .
        then have False using \<open>dist x y<e\<close> by auto
        then show ?thesis by auto
      qed
      ultimately show ?thesis by auto
    qed
    ultimately show ?thesis unfolding uniform_discrete_def by auto
  qed
  moreover have ?thesis when "S={}" using that by auto
  moreover have ?thesis when "\<delta>=0"
  proof -
    obtain B g where "finite B" and g_def:"\<forall>x\<in>S. g x\<in>B \<and> (\<exists>k::int. x = g x + k * \<delta>)"
      using assms unfolding periodic_set_def by metis
    then have "\<forall>x\<in>S. g x\<in>B \<and> (x = g x)" using that by fastforce
    then have "S \<subseteq> g ` B" by auto
    then have "finite S" using \<open>finite B\<close> by (auto elim:finite_subset)
    then show ?thesis using uniform_discrete_finite_iff by blast
  qed
  ultimately show ?thesis by blast
qed

lemma periodic_set_tan_linear:
  assumes "a\<noteq>0" "c\<noteq>0"
  shows "periodic_set (roots (\<lambda>x. a*tan (x/c) + b)) (c*pi)"
proof -
  define B where "B = { c*arctan (- b / a), c*pi/2}"
  have "\<exists>b\<in>B. \<exists>k::int. x = b + k * (c*pi)" when "x\<in>roots (\<lambda>x. a * tan (x/c) + b)" for x
  proof -
    define C1 where "C1 = (\<exists>k::int. x = c*arctan (- b / a) + k * (c*pi))"
    define C2 where "C2 = (\<exists>k::int. x = c*pi / 2 + k  * (c*pi) \<and> - b / a = 0)"
    have "tan (x/c) = - b/a" using that \<open>a\<noteq>0\<close> unfolding roots_within_def
      by (auto simp add:field_simps)
    then have "C1 \<or> C2" unfolding C1_def C2_def using tan_eq_arctan_Ex[of "x/c" "-b/a"]  \<open>c\<noteq>0\<close>
      by (auto simp add:field_simps)
    moreover have ?thesis when C1 using that unfolding C1_def B_def by blast
    moreover have ?thesis when C2 using that unfolding C2_def B_def by blast
    ultimately show ?thesis by auto
  qed
  moreover have "finite B" unfolding B_def by auto
  ultimately show ?thesis unfolding periodic_set_def by auto
qed

lemma periodic_set_cos_linear:
  assumes "a\<noteq>0" "c\<noteq>0"
  shows "periodic_set (roots (\<lambda>x. a*cos (x/c) + b)) (2*c*pi)"
proof -
  define B where "B = { c*arccos (- b / a), - c*arccos (- b / a)}"
  have "\<exists>b\<in>B. \<exists>k::int. x = b + k * (2*c*pi)"
    when "x\<in>roots (\<lambda>x. a * cos (x/c) + b)" for x
  proof -
    define C1 where "C1 = (\<exists>k::int. x = c*arccos (- b / a) + k * (2*c*pi))"
    define C2 where "C2 = (\<exists>k::int. x = - c*arccos (- b / a) + k * (2*c*pi))"
    have "cos (x/c) = - b/a" using that \<open>a\<noteq>0\<close> unfolding roots_within_def
      by (auto simp add:field_simps)
    then have "C1 \<or> C2"
      unfolding cos_eq_arccos_Ex ex_disj_distrib C1_def C2_def using \<open>c\<noteq>0\<close>
      apply (auto simp add:divide_simps)
      by (auto simp add:algebra_simps)
    moreover have ?thesis when C1 using that unfolding C1_def B_def by blast
    moreover have ?thesis when C2 using that unfolding C2_def B_def by blast
    ultimately show ?thesis by auto
  qed
  moreover have "finite B" unfolding B_def by auto
  ultimately show ?thesis unfolding periodic_set_def by auto
qed

lemma periodic_set_tan_poly:
  assumes "p\<noteq>0" "c\<noteq>0"
  shows "periodic_set (roots (\<lambda>x. poly p (tan (x/c)))) (c*pi)"
  using assms
proof (induct rule:poly_root_induct_alt)
  case 0
  then show ?case by simp
next
  case (no_proots p)
  then show ?case unfolding roots_within_def by simp
next
  case (root a p)
  have "roots (\<lambda>x. poly ([:- a, 1:] * p) (tan (x/c))) = roots (\<lambda>x. tan (x/c) - a)
          \<union> roots (\<lambda>x. poly p (tan (x/c)))"
    unfolding roots_within_def by auto
  moreover have "periodic_set (roots (\<lambda>x. tan (x/c) - a)) (c*pi)"
    using periodic_set_tan_linear[OF _ \<open>c\<noteq>0\<close> ,of 1 "-a",simplified] .
  moreover have "periodic_set (roots (\<lambda>x. poly p (tan (x/c)))) (c*pi)" using root by fastforce
  ultimately show ?case using periodic_set_union by simp
qed

lemma periodic_set_sin_cos_linear:
  fixes a b c ::real
  assumes "a\<noteq>0 \<or> b\<noteq>0 \<or> c\<noteq>0"
  shows "periodic_set (roots (\<lambda>x. a * cos x + b * sin x + c)) (4*pi)"
proof -
  define f where "f x= a * cos x + b * sin x + c" for x
  have "roots f = (roots f \<inter> {x. cos (x/2) = 0}) \<union> (roots f \<inter> {x. cos (x/2) \<noteq> 0})"
    by auto
  moreover have "periodic_set (roots f \<inter> {x. cos (x/2) = 0}) (4*pi)"
  proof -
    have "periodic_set ({x. cos (x/2) = 0}) (4*pi)"
      using periodic_set_cos_linear[of 1 2 0,unfolded roots_within_def,simplified] by simp
    then show ?thesis by auto
  qed
  moreover have "periodic_set (roots f \<inter> {x. cos (x/2) \<noteq> 0}) (4*pi)"
  proof -
    define p where "p=[:a+c,2*b,c-a:]"
    have "poly p (tan (x/2)) = 0 \<longleftrightarrow> f x=0" when "cos (x/2) \<noteq>0" for x
    proof -
      define t where "t=tan (x/2)"
      define tt where "tt = 1+t^2"
      have "cos x = (1-t^2) / tt" unfolding tt_def t_def
        using cos_tan_half[OF that,simplified] by simp
      moreover have "sin x = 2*t / tt" unfolding tt_def t_def
        using sin_tan_half[of "x/2",simplified] by simp
      moreover have "tt\<noteq>0" unfolding tt_def
        by (metis power_one sum_power2_eq_zero_iff zero_neq_one)
      ultimately show ?thesis
        unfolding f_def p_def
        apply (fold t_def)
        apply simp
        apply (auto simp add:field_simps)
        by (auto simp add:algebra_simps tt_def power2_eq_square)
    qed
    then have "roots f \<inter> {x. cos (x/2) \<noteq> 0} = roots (\<lambda>x. poly p (tan (x/2))) \<inter> {x. cos (x/2) \<noteq> 0}"
      unfolding roots_within_def by auto
    moreover have "periodic_set (roots (\<lambda>x. poly p (tan (x/2))) \<inter> {x. cos (x/2) \<noteq> 0}) (4*pi)"
    proof -
      have "p\<noteq>0" unfolding p_def using assms by auto
      then have "periodic_set (roots (\<lambda>x. poly p (tan (x/2)))) (4*pi)"
        using periodic_set_tan_poly[of p 2,simplified]
          periodic_set_multiple[of 2 _ "2*pi",simplified]
        by auto
      then show ?thesis by auto
    qed
    ultimately show ?thesis by auto
  qed
  ultimately show "periodic_set (roots f) (4*pi)" using periodic_set_union by metis
qed

end


section\<open>Array List\<close>
text\<open>Most of this has been contributed by Peter Lammich.\<close>
theory Array_List
imports
  "$AFP/Separation_Logic_Imperative_HOL/Examples/Array_Blit"
begin
  text\<open>
    This implements a datastructure that efficiently supports two operations: appending an element and looking up the nth element.
  The implementation is straightforward.
\<close>
  text\<open>
    As underlying data structure an array is used.
  Since changing the length of an array requires copying, we double the size whenever the array needs to be expanded.
  We use a counter for the current length to track which elements are used and which are spares.
\<close>
  type_synonym 'a array_list = "'a array \<times> nat"

  definition "is_array_list l \<equiv> \<lambda>(a,n). \<exists>\<^sub>Al'. a \<mapsto>\<^sub>a l' * \<up>(n \<le> length l' \<and> l = take n l' \<and> length l'>0)"

  definition "initial_capacity \<equiv> 16::nat"

  definition "arl_empty \<equiv> do {
    a \<leftarrow> Array.new initial_capacity default;
    return (a,0)
  }"

  lemma [sep_heap_rules]: "< emp > arl_empty <is_array_list []>"
    by (sep_auto simp: arl_empty_def is_array_list_def initial_capacity_def)

  definition "arl_nth \<equiv> \<lambda>(a,n) i. do {
    Array.nth a i
  }"

  lemma [sep_heap_rules]: "i<length l \<Longrightarrow> < is_array_list l a > arl_nth a i <\<lambda>x. is_array_list l a * \<up>(x = l!i) >"
    by (sep_auto simp: arl_nth_def is_array_list_def split: prod.splits)

  definition "arl_append \<equiv> \<lambda>(a,n) x. do {
    len \<leftarrow> Array.len a;

    if n<len then do {
      a \<leftarrow> Array.upd n x a;
      return (a,n+1)
    } else do {
      let newcap = 2 * len;
      a \<leftarrow> array_grow a newcap default;
      a \<leftarrow> Array.upd n x a;
      return (a,n+1)
    }
  }"

  lemma [sep_heap_rules]: "
    < is_array_list l a >
      arl_append a x
    <\<lambda>a. is_array_list (l@[x]) a >\<^sub>t"
    by (sep_auto
      simp: arl_append_def is_array_list_def take_update_last neq_Nil_conv
      split: prod.splits nat.split)

  lemma is_array_list_prec: "precise is_array_list"
    unfolding is_array_list_def[abs_def]
    apply(rule preciseI)
    apply(simp split: prod.splits)
    using preciseD snga_prec by fastforce

  lemma is_array_list_lengthIA: "is_array_list l li \<Longrightarrow>\<^sub>A \<up>(snd li = length l) * true"
    by(sep_auto simp: is_array_list_def split: prod.splits)
    find_consts "assn \<Rightarrow> bool"
  lemma is_array_list_lengthI: "x \<Turnstile> is_array_list l li \<Longrightarrow> snd li = length l"
  using is_array_list_lengthIA by (metis (full_types) ent_pure_post_iff star_aci(2))

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Fragments on permuations\<close>

theory Perm_Fragments
imports "HOL-Library.Dlist" "HOL-Combinatorics.Perm"
begin

text \<open>On cycles\<close>

context
  includes permutation_syntax
begin

lemma cycle_prod_list:
  "\<langle>a # as\<rangle> = prod_list (map (\<lambda>b. \<langle>a \<leftrightarrow> b\<rangle>) (rev as))"
  by (induct as) simp_all

lemma cycle_append [simp]:
  "\<langle>a # as @ bs\<rangle> = \<langle>a # bs\<rangle> * \<langle>a # as\<rangle>"
proof (induct as rule: cycle.induct)
  case (3 b c as)
  then have "\<langle>a # (b # as) @ bs\<rangle> = \<langle>a # bs\<rangle> * \<langle>a # b # as\<rangle>"
    by simp
  then have "\<langle>a # as @ bs\<rangle> * \<langle>a \<leftrightarrow> b\<rangle> =
    \<langle>a # bs\<rangle> * \<langle>a # as\<rangle> * \<langle>a \<leftrightarrow> b\<rangle>"
    by (simp add: ac_simps)
  then have "\<langle>a # as @ bs\<rangle> * \<langle>a \<leftrightarrow> b\<rangle> * \<langle>a \<leftrightarrow> b\<rangle> =
    \<langle>a # bs\<rangle> * \<langle>a # as\<rangle> * \<langle>a \<leftrightarrow> b\<rangle> * \<langle>a \<leftrightarrow> b\<rangle>"
    by simp
  then have "\<langle>a # as @ bs\<rangle> = \<langle>a # bs\<rangle> * \<langle>a # as\<rangle>"
    by (simp add: ac_simps)
  then show "\<langle>a # (b # c # as) @ bs\<rangle> =
    \<langle>a # bs\<rangle> * \<langle>a # b # c # as\<rangle>"
    by (simp add: ac_simps)
qed simp_all

lemma affected_cycle:
  "affected \<langle>as\<rangle> \<subseteq> set as"
proof (induct as rule: cycle.induct)
  case (3 a b as)
  from affected_times
  have "affected (\<langle>a # as\<rangle> * \<langle>a \<leftrightarrow> b\<rangle>)
    \<subseteq> affected \<langle>a # as\<rangle> \<union> affected \<langle>a \<leftrightarrow> b\<rangle>" .
  moreover from 3
  have "affected (\<langle>a # as\<rangle>) \<subseteq> insert a (set as)"
    by simp
  moreover
  have "affected \<langle>a \<leftrightarrow> b\<rangle> \<subseteq> {a, b}"
    by (cases "a = b") (simp_all add: affected_swap)
  ultimately have "affected (\<langle>a # as\<rangle> * \<langle>a \<leftrightarrow> b\<rangle>)
    \<subseteq> insert a (insert b (set as))"
    by blast
  then show ?case by auto
qed simp_all

lemma orbit_cycle_non_elem:
  assumes "a \<notin> set as"
  shows "orbit \<langle>as\<rangle> a = {a}"
  unfolding not_in_affected_iff_orbit_eq_singleton [symmetric]
  using assms affected_cycle [of as] by blast

lemma inverse_cycle:
  assumes "distinct as"
  shows "inverse \<langle>as\<rangle> = \<langle>rev as\<rangle>"
using assms proof (induct as rule: cycle.induct)
  case (3 a b as)
  then have *: "inverse \<langle>a # as\<rangle> = \<langle>rev (a # as)\<rangle>"
    and distinct: "distinct (a # b # as)"
    by simp_all
  show " inverse \<langle>a # b # as\<rangle> = \<langle>rev (a # b # as)\<rangle>"
  proof (cases as rule: rev_cases)
    case Nil with * show ?thesis
      by (simp add: swap_sym)
  next
    case (snoc cs c)
    with distinct have "distinct (a # b # cs @ [c])"
      by simp
    then have **: "\<langle>a \<leftrightarrow> b\<rangle> * \<langle>c \<leftrightarrow> a\<rangle> = \<langle>c \<leftrightarrow> a\<rangle> * \<langle>c \<leftrightarrow> b\<rangle>"
      by transfer (auto simp add: fun_eq_iff transpose_def)
    with snoc * show ?thesis
      by (simp add: mult.assoc [symmetric])
  qed
qed simp_all

lemma order_cycle_non_elem:
  assumes "a \<notin> set as"
  shows "order \<langle>as\<rangle> a = 1"
proof -
  from assms have "orbit \<langle>as\<rangle> a = {a}"
    by (rule orbit_cycle_non_elem)
  then have "card (orbit \<langle>as\<rangle> a) = card {a}"
    by simp
  then show ?thesis
    by simp
qed

lemma orbit_cycle_elem:
  assumes "distinct as" and "a \<in> set as"
  shows "orbit \<langle>as\<rangle> a = set as"
  oops \<comment> \<open>(we need rotation here\<close>

lemma order_cycle_elem:
  assumes "distinct as" and "a \<in> set as"
  shows "order \<langle>as\<rangle> a = length as"
  oops

text \<open>Adding fixpoints\<close>

definition fixate :: "'a \<Rightarrow> 'a perm \<Rightarrow> 'a perm"
where
  "fixate a f = (if a \<in> affected f then f * \<langle>inverse f \<langle>$\<rangle> a \<leftrightarrow> a\<rangle> else f)"

lemma affected_fixate_trivial:
  assumes "a \<notin> affected f"
  shows "affected (fixate a f) = affected f"
  using assms by (simp add: fixate_def)

lemma affected_fixate_binary_circle:
  assumes "order f a = 2"
  shows "affected (fixate a f) = affected f - {a, apply f a}" (is "?A = ?B")
proof (rule set_eqI)
  interpret bijection "apply f"
    by standard simp
  fix b
  from assms order_greater_eq_two_iff [of f a] have "a \<in> affected f"
    by simp
  moreover have "apply (f ^ 2) a = a"
    by (simp add: assms [symmetric])
  ultimately show "b \<in> ?A \<longleftrightarrow> b \<in> ?B"
    by (cases "b \<in> {a, apply (inverse f) a}")
      (auto simp add: in_affected power2_eq_square apply_inverse apply_times fixate_def)
qed

lemma affected_fixate_no_binary_circle:
  assumes "order f a > 2"
  shows "affected (fixate a f) = affected f - {a}" (is "?A = ?B")
proof (rule set_eqI)
  interpret bijection "apply f"
    by standard simp
  fix b
  from assms order_greater_eq_two_iff [of f a]
  have "a \<in> affected f"
    by simp
  moreover from assms
  have "apply f (apply f a) \<noteq> a"
    using apply_power_eq_iff [of f 2 a 0]
    by (simp add: power2_eq_square apply_times)
  ultimately show "b \<in> ?A \<longleftrightarrow> b \<in> ?B"
    by (cases "b \<in> {a, apply (inverse f) a}")
      (auto simp add: in_affected apply_inverse apply_times fixate_def)
qed

lemma affected_fixate:
  "affected (fixate a f) \<subseteq> affected f - {a}"
proof -
  have "a \<notin> affected f \<or> order f a = 2 \<or> order f a > 2"
    by (auto simp add: not_less dest: affected_order_greater_eq_two)
  then consider "a \<notin> affected f" | "order f a = 2" | "order f a > 2"
    by blast
  then show ?thesis apply cases
  using affected_fixate_trivial [of a f]
    affected_fixate_binary_circle [of f a]
    affected_fixate_no_binary_circle [of f a]
    by auto
qed

lemma orbit_fixate_self [simp]:
  "orbit (fixate a f) a = {a}"
proof -
  have "apply (f * inverse f) a = a"
    by simp
  then have "apply f (apply (inverse f) a) = a"
    by (simp only: apply_times comp_apply)
  then show ?thesis
    by (simp add: fixate_def not_in_affected_iff_orbit_eq_singleton [symmetric] in_affected apply_times)
qed

lemma order_fixate_self [simp]:
  "order (fixate a f) a = 1"
proof -
  have "card (orbit (fixate a f) a) = card {a}"
    by simp
  then show ?thesis
    by (simp only: card_orbit_eq) simp
qed

lemma
  assumes "b \<notin> orbit f a"
  shows "orbit (fixate b f) a = orbit f a"
  oops

lemma
  assumes "b \<in> orbit f a" and "b \<noteq> a"
  shows "orbit (fixate b f) a = orbit f a - {b}"
  oops

text \<open>Distilling cycles from permutations\<close>

inductive_set orbits :: "'a perm \<Rightarrow> 'a set set" for f
where
  in_orbitsI: "a \<in> affected f \<Longrightarrow> orbit f a \<in> orbits f"

lemma orbits_unfold:
  "orbits f = orbit f ` affected f"
  by (auto intro: in_orbitsI elim: orbits.cases)

lemma in_orbit_affected:
  assumes "b \<in> orbit f a"
  assumes "a \<in> affected f"
  shows "b \<in> affected f"
proof (cases "a = b")
  case True with assms show ?thesis by simp
next
  case False with assms have "{a, b} \<subseteq> orbit f a"
    by auto
  also from assms have "orbit f a \<subseteq> affected f"
    by (blast intro!: orbit_subset_eq_affected)
  finally show ?thesis by simp
qed

lemma Union_orbits [simp]:
  "\<Union>(orbits f) = affected f"
  by (auto simp add: orbits.simps intro: in_orbitsI in_orbit_affected)

lemma finite_orbits [simp]:
  "finite (orbits f)"
  by (simp add: orbits_unfold)

lemma card_in_orbits:
  assumes "A \<in> orbits f"
  shows "card A \<ge> 2"
  using assms by cases
    (auto dest: affected_order_greater_eq_two)

lemma disjoint_orbits:
  assumes "A \<in> orbits f" and "B \<in> orbits f" and "A \<noteq> B"
  shows "A \<inter> B = {}"
  using \<open>A \<in> orbits f\<close> apply cases
  using \<open>B \<in> orbits f\<close> apply cases
  using \<open>A \<noteq> B\<close> apply (simp_all add: orbit_disjoint)
  done

definition trace :: "'a \<Rightarrow> 'a perm \<Rightarrow> 'a list"
where
  "trace a f = map (\<lambda>n. apply (f ^ n) a) [0..<order f a]"

lemma set_trace_eq [simp]:
  "set (trace a f) = orbit f a"
  by (auto simp add: trace_def orbit_unfold_image)

definition seeds :: "'a perm \<Rightarrow> 'a::linorder list"
where
  "seeds f = sorted_list_of_set (Min ` orbits f)"

definition cycles :: "'a perm \<Rightarrow> 'a::linorder list list"
where
  "cycles f = map (\<lambda>a. trace a f) (seeds f)"

end

text \<open>Misc\<close>

lemma (in comm_monoid_list_set) sorted_list_of_set:
  assumes "finite A"
  shows "list.F (map h (sorted_list_of_set A)) = set.F h A"
proof -
  from distinct_sorted_list_of_set
  have "set.F h (set (sorted_list_of_set A)) = list.F (map h (sorted_list_of_set A))"
    by (rule distinct_set_conv_list)
  with \<open>finite A\<close> show ?thesis
    by (simp)
qed

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

lemma length_subtract_less_eq [simp]:
  "length (subtract xs ys) \<le> length ys"
proof (induct xs arbitrary: ys)
  case Nil then show ?case by simp
next
  case (Cons x xs)
  then have "length (subtract xs (removeAll x ys)) \<le> length (removeAll x ys)" .
  also have "length (removeAll x ys) \<le> length ys"
    by simp
  finally show ?case
    by simp
qed

end


theory Cones
imports
  "HOL-Analysis.Analysis"
  Triangle.Triangle
  "../ODE_Auxiliarities"
begin

lemma arcsin_eq_zero_iff[simp]: "-1 \<le> x \<Longrightarrow> x \<le> 1 \<Longrightarrow> arcsin x = 0 \<longleftrightarrow> x = 0"
  using sin_arcsin by fastforce

definition conemem :: "'a::real_vector \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a" where "conemem u v t = cos t *\<^sub>R u + sin t *\<^sub>R v"
definition "conesegment u v = conemem u v ` {0.. pi / 2}"

lemma
  bounded_linear_image_conemem:
  assumes "bounded_linear F"
  shows "F (conemem u v t) = conemem (F u) (F v) t"
proof -
  from assms interpret bounded_linear F .
  show ?thesis
    by (auto simp: conemem_def[abs_def] cone_hull_expl closed_segment_def add scaleR)
qed

lemma
  bounded_linear_image_conesegment:
  assumes "bounded_linear F"
  shows "F ` conesegment u v = conesegment (F u) (F v)"
proof -
  from assms interpret bounded_linear F .
  show ?thesis
    apply (auto simp: conesegment_def conemem_def[abs_def] cone_hull_expl closed_segment_def add scaleR)
    apply (auto simp: add[symmetric] scaleR[symmetric])
    done
qed

(* This is vangle in $AFP/Triangles/Angles *)

lemma discriminant: "a * x\<^sup>2 + b * x + c = (0::real) \<Longrightarrow> 0 \<le> b\<^sup>2 - 4 * a * c"
  by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))")

lemma quadratic_eq_factoring:
  assumes D: "D = b\<^sup>2 - 4 * a * c"
  assumes nn: "0 \<le> D"
  assumes x1: "x\<^sub>1 = (-b + sqrt D) / (2 * a)"
  assumes x2: "x\<^sub>2 = (-b - sqrt D) / (2 * a)"
  assumes a: "a \<noteq> 0"
  shows "a * x\<^sup>2 + b * x + c = a * (x - x\<^sub>1) * (x - x\<^sub>2)"
  using nn
  by (simp add: D x1 x2)
    (simp add: assms algebra_simps power2_eq_square power3_eq_cube divide_simps)

lemma quadratic_eq_zeroes_iff:
  assumes D: "D = b\<^sup>2 - 4 * a * c"
  assumes x1: "x\<^sub>1 = (-b + sqrt D) / (2 * a)"
  assumes x2: "x\<^sub>2 = (-b - sqrt D) / (2 * a)"
  assumes a: "a \<noteq> 0"
  shows "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> (D \<ge> 0 \<and> (x = x\<^sub>1 \<or> x = x\<^sub>2))" (is "?z \<longleftrightarrow> _")
  using quadratic_eq_factoring[OF D _ x1 x2 a, of x] discriminant[of a x b c] a
  by (auto simp: D)

lemma quadratic_ex_zero_iff:
  "(\<exists>x. a * x\<^sup>2 + b * x + c = 0) \<longleftrightarrow> (a \<noteq> 0 \<and> b\<^sup>2 - 4 * a * c \<ge> 0 \<or> a = 0 \<and> (b = 0 \<longrightarrow> c = 0))"
  for a b c::real
  apply (cases "a = 0")
  subgoal by (auto simp: intro: exI[where x="- c / b"])
  subgoal by (subst quadratic_eq_zeroes_iff[OF refl refl refl]) auto
  done

lemma Cauchy_Schwarz_eq_iff:
  shows "(inner x y)\<^sup>2 = inner x x * inner y y \<longleftrightarrow> ((\<exists>k. x = k *\<^sub>R y) \<or> y = 0)"
proof safe
  assume eq: "(x \<bullet> y)\<^sup>2 = x \<bullet> x * (y \<bullet> y)" and "y \<noteq> 0"
  define f where "f \<equiv> \<lambda>l. inner (x - l *\<^sub>R y) (x - l *\<^sub>R y)"
  have f_quadratic: "f l = inner y y * l\<^sup>2 + - 2 * inner x y * l + inner x x" for l
    by (auto simp: f_def algebra_simps power2_eq_square inner_commute)
  have "\<exists>l. f l = 0"
    unfolding f_quadratic quadratic_ex_zero_iff
    using \<open>y \<noteq> 0\<close>
    by (auto simp: eq)
  then show "(\<exists>k. x = k *\<^sub>R y)"
    by (auto simp: f_def)
qed (auto simp: power2_eq_square)

lemma Cauchy_Schwarz_strict_ineq:
  "(inner x y)\<^sup>2 < inner x x * inner y y" if "y \<noteq> 0" "\<And>k. x \<noteq> k *\<^sub>R y"
  apply (rule neq_le_trans)
  subgoal
    using that
    unfolding Cauchy_Schwarz_eq_iff
    by auto
  subgoal by (rule Cauchy_Schwarz_ineq)
  done

lemma Cauchy_Schwarz_eq2_iff:
  "\<bar>inner x y\<bar> = norm x * norm y \<longleftrightarrow> ((\<exists>k. x = k *\<^sub>R y) \<or> y = 0)"
  using Cauchy_Schwarz_eq_iff[of x y]
  by (subst power_eq_iff_eq_base[symmetric, where n = 2])
     (simp_all add: dot_square_norm power_mult_distrib)

lemma Cauchy_Schwarz_strict_ineq2:
  "\<bar>inner x y\<bar> < norm x * norm y" if "y \<noteq> 0" "\<And>k. x \<noteq> k *\<^sub>R y"
  apply (rule neq_le_trans)
  subgoal
    using that
    unfolding Cauchy_Schwarz_eq2_iff
    by auto
  subgoal by (rule Cauchy_Schwarz_ineq2)
  done

lemma gt_minus_one_absI: "abs k < 1 \<Longrightarrow> - 1 < k" for k::real
  by auto
lemma gt_one_absI: "abs k < 1 \<Longrightarrow> k < 1" for k::real
  by auto

lemma abs_impossible:
  "\<bar>y1\<bar> < x1 \<Longrightarrow> \<bar>y2\<bar> < x2 \<Longrightarrow> x1 * x2 + y1 * y2 \<noteq> 0" for x1 x2::real
proof goal_cases
  case 1
  have "- y1 * y2 \<le> abs y1 * abs y2"
    by (metis abs_ge_minus_self abs_mult mult.commute mult_minus_right)
  also have "\<dots> < x1 * x2"
    apply (rule mult_strict_mono)
    using 1 by auto
  finally show ?case by auto
qed

lemma vangle_eq_arctan_minus:\<comment> \<open>TODO: generalize?!\<close>
  assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
  assumes xy1: "\<bar>y1\<bar> < x1"
  assumes xy2: "\<bar>y2\<bar> < x2"
  assumes less: "y2 / x2 > y1 / x1"
  shows "vangle (x1 *\<^sub>R i + y1 *\<^sub>R j) (x2 *\<^sub>R i + y2 *\<^sub>R j) = arctan (y2 / x2) - arctan (y1 / x1)"
    (is "vangle ?u ?v = _")
proof -
  from assms have less2: "x2 * y1 - x1 * y2 < 0"
    by (auto simp: divide_simps abs_real_def algebra_simps split: if_splits)
  have norm_eucl: "norm (x *\<^sub>R i + y *\<^sub>R j) = sqrt ((norm x)\<^sup>2 + (norm y)\<^sup>2)" for x y
    apply (subst norm_eq_sqrt_inner)
    using ij ij_neq
    by (auto simp: inner_simps inner_Basis power2_eq_square)
  have nonzeroes: "x1 *\<^sub>R i + y1 *\<^sub>R j \<noteq> 0" "x2 *\<^sub>R i + y2 *\<^sub>R j \<noteq> 0"
     apply (auto simp: euclidean_eq_iff[where 'a='a] inner_simps intro!: bexI[where x=i])
    using assms
    by (auto simp: inner_Basis)
  have indep: "x1 *\<^sub>R i + y1 *\<^sub>R j \<noteq> k *\<^sub>R (x2 *\<^sub>R i + y2 *\<^sub>R j)" for k
  proof
    assume "x1 *\<^sub>R i + y1 *\<^sub>R j = k *\<^sub>R (x2 *\<^sub>R i + y2 *\<^sub>R j)"
    then have "x1 / x2 = k" "y1 = k * y2"
      using ij ij_neq xy1 xy2
       apply (auto simp: abs_real_def divide_simps algebra_simps euclidean_eq_iff[where 'a='a] inner_simps
          split: if_splits)
      by (auto simp: inner_Basis split: if_splits)
    then have "y1 = x1 / x2 * y2" by simp
    with less show False using xy1 by (auto split: if_splits)
  qed
  have "((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) *
          (1 - ((x1 *\<^sub>R i + y1 *\<^sub>R j) \<bullet> (x2 *\<^sub>R i + y2 *\<^sub>R j))\<^sup>2 / ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2)))) =
    ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) *
          (1 - (x1 * x2 + y1 * y2)\<^sup>2 / ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2))))"
    using ij_neq ij
    by (auto simp: algebra_simps divide_simps inner_simps inner_Basis)
  also have "\<dots> = (x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) - (x1 * x2 + y1 * y2)\<^sup>2"
    unfolding right_diff_distrib by simp
  also have "\<dots> = (x2 * y1 - x1 * y2)^2"
    by (auto simp: algebra_simps power2_eq_square)
  also have "sqrt \<dots> = \<bar>x2 * y1 - x1 * y2\<bar>"
    by simp
  also have "\<dots> = x1 * y2 - x2 * y1"
    using less2
    by (simp add: abs_real_def)
  finally have sqrt_eq: "sqrt ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) *
        (1 - ((x1 *\<^sub>R i + y1 *\<^sub>R j) \<bullet> (x2 *\<^sub>R i + y2 *\<^sub>R j))\<^sup>2 / ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2)))) =
    x1 * y2 - x2 * y1"
    .
  show ?thesis
    using ij xy1 xy2
    unfolding vangle_def
    apply (subst arccos_arctan)
    subgoal
      apply (rule gt_minus_one_absI)
      apply (simp add: )
      apply (subst pos_divide_less_eq)
      subgoal
        apply (rule mult_pos_pos)
        using nonzeroes
        by auto
      subgoal
        apply simp
        apply (rule Cauchy_Schwarz_strict_ineq2)
        using nonzeroes indep
        by auto
      done
    subgoal
      apply (rule gt_one_absI)
      apply (simp add: )
      apply (subst pos_divide_less_eq)
      subgoal
        apply (rule mult_pos_pos)
        using nonzeroes
        by auto
      subgoal
        apply simp
        apply (rule Cauchy_Schwarz_strict_ineq2)
        using nonzeroes indep
        by auto
      done
    subgoal
      apply (auto simp: nonzeroes)
      apply (subst (3) diff_conv_add_uminus)
      apply (subst arctan_minus[symmetric])
      apply (subst arctan_add)
        apply force
       apply force
      apply (subst arctan_inverse[symmetric])
      subgoal
        apply (rule divide_pos_pos)
        subgoal
          apply (auto simp add: inner_simps inner_Basis algebra_simps )
           apply (thin_tac "_ \<in> Basis")+ apply (thin_tac "j = i")
           apply (sos "((((A<0 * (A<1 * (A<2 * A<3))) * R<1) + ((A<=0 * (A<0 * (A<2 * R<1))) * (R<1 * [1]^2))))")
          apply (thin_tac "_ \<in> Basis")+ apply (thin_tac "j \<noteq> i")
          by (sos "((((A<0 * (A<1 * (A<2 * A<3))) * R<1) + (((A<2 * (A<3 * R<1)) * (R<1/3 * [y1]^2)) + (((A<1 * (A<3 * R<1)) * ((R<1/12 * [x2 + y1]^2) + (R<1/12 * [x1 + y2]^2))) + (((A<1 * (A<2 * R<1)) * (R<1/12 * [~1*x1 + x2 + y1 + y2]^2)) + (((A<0 * (A<3 * R<1)) * (R<1/12 * [~1*x1 + x2 + ~1*y1 + ~1*y2]^2)) + (((A<0 * (A<2 * R<1)) * ((R<1/12 * [x2 + ~1*y1]^2) + (R<1/12 * [~1*x1 + y2]^2))) + (((A<0 * (A<1 * R<1)) * (R<1/3 * [y2]^2)) + ((A<=0 * R<1) * (R<1/3 * [x1 + x2]^2))))))))))")
        subgoal
          apply (intro mult_pos_pos)
          using nonzeroes indep
            apply auto
          apply (rule gt_one_absI)
          apply (simp add: power_divide power_mult_distrib power2_norm_eq_inner)
          apply (rule Cauchy_Schwarz_strict_ineq)
           apply auto
          done
        done
      subgoal
        apply (rule arg_cong[where f=arctan])
        using nonzeroes ij_neq
        apply (auto simp: norm_eucl)
        apply (subst real_sqrt_mult[symmetric])
        apply (subst real_sqrt_mult[symmetric])
        apply (subst real_sqrt_mult[symmetric])
        apply (subst power_divide)
        apply (subst real_sqrt_pow2)
         apply simp
        apply (subst nonzero_divide_eq_eq)
        subgoal
          apply (auto simp: algebra_simps inner_simps inner_Basis)
          by (auto simp: algebra_simps divide_simps abs_real_def abs_impossible)
        apply (subst sqrt_eq)
        apply (auto simp: algebra_simps inner_simps inner_Basis)
        apply (auto simp: algebra_simps divide_simps abs_real_def abs_impossible)
        by (auto split: if_splits)
      done
    done
qed

lemma vangle_le_pi2: "0 \<le> u \<bullet> v \<Longrightarrow> vangle u v \<le> pi/2"
  unfolding vangle_def atLeastAtMost_iff
  apply (simp del: le_divide_eq_numeral1)
  apply (intro impI arccos_le_pi2 arccos_lbound)
  using Cauchy_Schwarz_ineq2[of u v]
  by (auto simp: algebra_simps)

lemma inner_eq_vangle: "u \<bullet> v = cos (vangle u v) * (norm u * norm v)"
  by (simp add: cos_vangle)

lemma vangle_scaleR_self:
  "vangle (k *\<^sub>R v) v = (if k = 0 \<or> v = 0 then pi / 2 else if k > 0 then 0 else pi)"
  "vangle v (k *\<^sub>R v) = (if k = 0 \<or> v = 0 then pi / 2 else if k > 0 then 0 else pi)"
  by (auto simp: vangle_def dot_square_norm power2_eq_square)

lemma vangle_scaleR:
  "vangle (k *\<^sub>R v) w = vangle v w" "vangle w (k *\<^sub>R v) = vangle w v" if "k > 0"
  using that
  by (auto simp: vangle_def)

lemma cos_vangle_eq_zero_iff_vangle:
  "cos (vangle u v) = 0 \<longleftrightarrow> (u = 0 \<or> v = 0 \<or> u \<bullet> v = 0)"
  using Cauchy_Schwarz_ineq2[of u v]
  by (auto simp: vangle_def divide_simps algebra_split_simps split: if_splits)

lemma ortho_imp_angle_pi_half: "u \<bullet> v = 0 \<Longrightarrow> vangle u v = pi / 2"
  using orthogonal_iff_vangle[of u v]
  by (auto simp: orthogonal_def)

lemma arccos_eq_zero_iff: "arccos x = 0 \<longleftrightarrow> x = 1" if "-1 \<le> x" "x \<le> 1"
  using that
  apply auto
  using cos_arccos by fastforce

lemma vangle_eq_zeroD: "vangle u v = 0 \<Longrightarrow> (\<exists>k. v = k *\<^sub>R u)"
  apply (auto simp: vangle_def split: if_splits)
   apply (subst (asm) arccos_eq_zero_iff)
  apply (auto simp: divide_simps mult_less_0_iff split: if_splits)
  apply (metis Real_Vector_Spaces.norm_minus_cancel inner_minus_left minus_le_iff norm_cauchy_schwarz)
    apply (metis norm_cauchy_schwarz)
  by (metis Cauchy_Schwarz_eq2_iff abs_of_pos inner_commute mult.commute mult_sign_intros(5) zero_less_norm_iff)

lemma less_one_multI:\<comment> \<open>TODO: also in AA!\<close>
  fixes e x::real
  shows "e \<le> 1 \<Longrightarrow> 0 < x \<Longrightarrow> x < 1 \<Longrightarrow> e * x < 1"
  by (metis (erased, hide_lams) less_eq_real_def monoid_mult_class.mult.left_neutral
    mult_strict_mono zero_less_one)

lemma conemem_expansion_estimate:
  fixes u v u' v'::"'a::euclidean_space"
  assumes "t \<in> {0 .. pi / 2}"
  assumes angle_pos: "0 < vangle u v" "vangle u v < pi / 2"
  assumes angle_le: "(vangle u' v') \<le> (vangle u v)"
  assumes "norm u = 1" "norm v = 1"
  shows "norm (conemem u' v' t) \<ge> min (norm u') (norm v') * norm (conemem u v t)"
proof -
  define e_pre where "e_pre = min (norm u') (norm v')"
  let ?w = "conemem u v"
  let ?w' = "conemem u' v'"
  have cos_angle_le: "cos (vangle u' v') \<ge> cos (vangle u v)"
    using angle_pos vangle_bounds
    by (auto intro!: cos_monotone_0_pi_le angle_le)
  have e_pre_le: "e_pre\<^sup>2 \<le> norm u' * norm v'"
    by (auto simp: e_pre_def min_def power2_eq_square intro: mult_left_mono mult_right_mono)
  have lt: "0 < 1 + 2 * (u \<bullet> v) * sin t * cos t"
  proof -
    have "\<bar>u \<bullet> v\<bar> < norm u * norm v"
      apply (rule Cauchy_Schwarz_strict_ineq2)
      using assms
       apply auto
      apply (subst (asm) vangle_scaleR_self)+
      by (auto simp: split: if_splits)
    then have "abs (u \<bullet> v * sin (2 * t)) < 1"
      using assms
      apply (auto simp add: abs_mult)
      apply (subst mult.commute)
      apply (rule less_one_multI)
      apply (auto simp add: abs_mult inner_eq_vangle )
      by (auto simp: cos_vangle_eq_zero_iff_vangle dest!: ortho_imp_angle_pi_half)
    then show ?thesis
      by (subst mult.assoc sin_times_cos)+ auto
  qed
  have le: "0 \<le> 1 + 2 * (u \<bullet> v) * sin t * cos t"
  proof -
    have "\<bar>u \<bullet> v\<bar> \<le> norm u * norm v"
      by (rule Cauchy_Schwarz_ineq2)
    then have "abs (u \<bullet> v * sin (2 * t)) \<le> 1"
      by (auto simp add: abs_mult assms intro!: mult_le_one)
    then show ?thesis
      by (subst mult.assoc sin_times_cos)+ auto
  qed
  have "(norm (?w t))\<^sup>2 = (cos t)\<^sup>2 *\<^sub>R (norm u)\<^sup>2 + (sin t)\<^sup>2 *\<^sub>R (norm v)\<^sup>2 + 2 * (u \<bullet> v) * sin t * cos t"
    by (auto simp: conemem_def algebra_simps power2_norm_eq_inner)
      (auto simp: power2_eq_square inner_commute)
  also have "\<dots> = 1 + 2 * (u \<bullet> v) * sin t * cos t"
    by (auto simp: sin_squared_eq algebra_simps assms)
  finally have "(norm (conemem u v t))\<^sup>2 = 1 + 2 * (u \<bullet> v) * sin t * cos t" by simp
  moreover
  have "(norm (?w' t))\<^sup>2 = (cos t)\<^sup>2 *\<^sub>R (norm u')\<^sup>2 + (sin t)\<^sup>2 *\<^sub>R (norm v')\<^sup>2 + 2 * (u' \<bullet> v') * sin t * cos t"
    by (auto simp: conemem_def algebra_simps power2_norm_eq_inner)
      (auto simp: power2_eq_square inner_commute)
  ultimately
  have "(norm (?w' t) / norm (?w t))\<^sup>2 =
    ((cos t)\<^sup>2 *\<^sub>R (norm u')\<^sup>2 + (sin t)\<^sup>2 *\<^sub>R (norm v')\<^sup>2 + 2 * (u' \<bullet> v') * sin t * cos t) /
    (1 + 2 * (u \<bullet> v) * sin t * cos t)"
    (is "_ = (?a + ?b) / ?c")
    by (auto simp: divide_inverse power_mult_distrib) (auto simp: inverse_eq_divide power2_eq_square)
  also have "\<dots> \<ge> (e_pre\<^sup>2 + ?b) / ?c"
    apply (rule divide_right_mono)
     apply (rule add_right_mono)
    subgoal using assms e_pre_def
      apply (auto simp: min_def)
      subgoal by (auto simp: algebra_simps cos_squared_eq intro!: mult_right_mono power_mono)
      subgoal by (auto simp: algebra_simps sin_squared_eq intro!: mult_right_mono power_mono)
      done
    subgoal by (rule le)
    done
  also (xtrans)
  have inner_nonneg: "u' \<bullet> v' \<ge> 0"
    using angle_le(1) angle_pos vangle_bounds[of u' v']
    by (auto simp: inner_eq_vangle intro!: mult_nonneg_nonneg cos_ge_zero)
  from vangle_bounds[of u' v'] vangle_le_pi2[OF this]
  have u'v'e_pre: "u' \<bullet> v' \<ge> cos (vangle u' v') * e_pre\<^sup>2"
    apply (subst inner_eq_vangle)
    apply (rule mult_left_mono)
     apply (rule e_pre_le)
    apply (rule cos_ge_zero)
    by auto
  have "(e_pre\<^sup>2 + ?b) / ?c \<ge> (e_pre\<^sup>2 + 2 * (cos (vangle u' v') * e_pre\<^sup>2) * sin t * cos t) / ?c"
    (is "_ \<ge> ?ddd")
    apply (intro divide_right_mono add_left_mono mult_right_mono mult_left_mono u'v'e_pre)
    using \<open>t \<in> _\<close>
    by (auto intro!: mult_right_mono sin_ge_zero divide_right_mono le cos_ge_zero
        simp: sin_times_cos u'v'e_pre)
  also (xtrans) have "?ddd = e_pre\<^sup>2 * ((1 + 2 * cos (vangle u' v') * sin t * cos t) / ?c)" (is "_ = ?ddd")
    by (auto simp add: divide_simps algebra_simps)
  also (xtrans)
  have sc_ge_0: "0 \<le> sin t * cos t"
    using \<open>t \<in> _\<close>
    by (auto simp: assms cos_angle_le intro!: mult_nonneg_nonneg sin_ge_zero cos_ge_zero)
  have "?ddd \<ge> e_pre\<^sup>2"
    apply (subst mult_le_cancel_left1)
    apply (auto simp add: divide_simps split: if_splits)
      apply (rule mult_right_mono)
    using lt
    by (auto simp: assms inner_eq_vangle intro!: mult_right_mono sc_ge_0 cos_angle_le)
  finally (xtrans)
  have "(norm (conemem u' v' t))\<^sup>2 \<ge> (e_pre * norm (conemem u v t))\<^sup>2"
    by (simp add: divide_simps power_mult_distrib split: if_splits)
  then show "norm (conemem u' v' t) \<ge> e_pre * norm (conemem u v t)"
    using norm_imp_pos_and_ge power2_le_imp_le by blast
qed

lemma conemem_commute: "conemem a b t = conemem b a (pi / 2 - t)" if "0 \<le> t" "t \<le> pi / 2"
  using that by (auto simp: conemem_def cos_sin_eq algebra_simps)

lemma conesegment_commute: "conesegment a b = conesegment b a"
  apply (auto simp: conesegment_def )
   apply (subst conemem_commute)
  apply auto
   apply (subst conemem_commute)
    apply auto
  done

definition "conefield u v = cone hull (conesegment u v)"

lemma conefield_alt_def: "conefield u v = cone hull {u--v}"
  apply (auto simp: conesegment_def conefield_def cone_hull_expl in_segment)
  subgoal premises prems for c t
  proof -
    from prems
    have sc_pos: "sin t + cos t > 0"
      apply (cases "t = 0")
      subgoal
        by (rule add_nonneg_pos) auto
      subgoal
         by (auto intro!: add_pos_nonneg sin_gt_zero cos_ge_zero)
       done
    then have 1: "(sin t / (sin t + cos t) + cos t / (sin t + cos t)) = 1"
      by (auto simp: divide_simps)
    have "\<exists>c x. c > 0 \<and> 0 \<le> x \<and> x \<le> 1 \<and> c *\<^sub>R conemem u v t = (1 - x) *\<^sub>R u + x *\<^sub>R v"
      apply (auto simp: algebra_simps conemem_def)
      apply (rule exI[where x="1 / (sin t + cos t)"])
      using prems
      by (auto intro!: exI[where x="(1 / (sin t + cos t) * sin t)"] sc_pos
          divide_nonneg_nonneg sin_ge_zero add_nonneg_nonneg cos_ge_zero
          simp: scaleR_add_left[symmetric] 1 divide_le_eq_1)
    then obtain d x where dx: "d > 0" "conemem u v t = (1 / d) *\<^sub>R ((1 - x) *\<^sub>R u + x *\<^sub>R v)"
        "0 \<le> x" "x \<le> 1"
      by (auto simp: eq_vector_fraction_iff)
    show ?thesis
      apply (rule exI[where x="c / d"])
      using dx
      by (auto simp: intro!: divide_nonneg_nonneg prems )
  qed
  subgoal premises prems for c t
  proof -
    let ?x = "arctan (t / (1 - t))"
    let ?s = "t / sin ?x"
    have *: "c *\<^sub>R ((1 - t) *\<^sub>R u + t *\<^sub>R v) = (c * ?s) *\<^sub>R (cos ?x *\<^sub>R u + sin ?x *\<^sub>R v)"
      if "0 < t" "t < 1"
      using that
      by (auto simp: scaleR_add_right sin_arctan cos_arctan divide_simps)
    show ?thesis
      apply (cases "t = 0")
      subgoal
        apply simp
        apply (rule exI[where x=c])
        apply (rule exI[where x=u])
        using prems
        by (auto simp: conemem_def[abs_def] intro!: image_eqI[where x=0])
      subgoal apply (cases "t = 1")
        subgoal
          apply simp
          apply (rule exI[where x=c])
          apply (rule exI[where x=v])
          using prems
          by (auto simp: conemem_def[abs_def] intro!: image_eqI[where x="pi/2"])
        subgoal
          apply (rule exI[where x="(c * ?s)"])
          apply (rule exI[where x="(cos ?x *\<^sub>R u + sin ?x *\<^sub>R v)"])
          using prems * arctan_ubound[of "t / (1 - t)"]
          apply (auto simp: conemem_def[abs_def]  intro!: imageI)
          by (auto simp: scaleR_add_right sin_arctan)
        done
      done
  qed
  done

lemma
  bounded_linear_image_cone_hull:
  assumes "bounded_linear F"
  shows "F ` (cone hull T) = cone hull (F ` T)"
proof -
  from assms interpret bounded_linear F .
  show ?thesis
    apply (auto simp: conefield_def cone_hull_expl closed_segment_def add scaleR)
     apply (auto simp: )
    apply (auto simp: add[symmetric] scaleR[symmetric])
    done
qed

lemma
  bounded_linear_image_conefield:
  assumes "bounded_linear F"
  shows "F ` conefield u v = conefield (F u) (F v)"
  unfolding conefield_def
  using assms
  by (auto simp: bounded_linear_image_conesegment bounded_linear_image_cone_hull)

lemma conefield_commute: "conefield x y = conefield y x"
  by (auto simp: conefield_def conesegment_commute)

lemma convex_conefield: "convex (conefield x y)"
  by (auto simp: conefield_alt_def convex_cone_hull)

lemma conefield_scaleRI: "v \<in> conefield (r *\<^sub>R x) y" if "v \<in> conefield x y" "r > 0"
  using that
  using \<open>r > 0\<close>
  unfolding conefield_alt_def cone_hull_expl
  apply (auto simp: in_segment)
proof goal_cases
  case (1 c u)
  let ?d = "c * (1 - u) / r + c * u"
  let ?t = "c * u / ?d"
  have "c * (1 - u) = ?d * (1 - ?t) * r" if "0 < u"
    using \<open>0 < r\<close> that(1) 1(3,5) mult_pos_pos
    by (force simp: divide_simps ac_simps ring_distribs[symmetric])
  then have eq1: "(c * (1 - u)) *\<^sub>R x = (?d * (1 - ?t) * r) *\<^sub>R x" if "0 < u"
    using that by simp
  have "c * u = ?d * ?t" if "u < 1"
    using \<open>0 < r\<close> that(1) 1(3,4,5) mult_pos_pos
    apply (auto simp: divide_simps ac_simps ring_distribs[symmetric])
  proof -
    assume "0 \<le> u"
      "0 < r"
      "1 - u + r * u = 0"
      "u < 1"
    then have False
      by (sos "((((A<0 * A<1) * R<1) + (([~1*r] * A=0) + ((A<=0 * R<1) * (R<1 * [r]^2)))))")
    then show "u = 0"
      by metis
  qed
  then have eq2: "(c * u) *\<^sub>R y = (?d * ?t) *\<^sub>R y" if "u < 1"
    using that by simp
  have *: "c *\<^sub>R ((1 - u) *\<^sub>R x + u *\<^sub>R y) = ?d *\<^sub>R ((1 - ?t) *\<^sub>R r *\<^sub>R x + ?t *\<^sub>R y)"
    if "0 < u" "u < 1"
    using that eq1 eq2
    by (auto simp: algebra_simps)
  show ?case
    apply (cases "u = 0")
    subgoal using 1 by (intro exI[where x="c / r"] exI[where x="r *\<^sub>R x"]) auto
    apply (cases "u = 1")
    subgoal using 1 by (intro exI[where x="c"] exI[where x="y"]) (auto intro!: exI[where x=1])
    subgoal
      apply (rule exI[where x="?d"])
      apply (rule exI[where x="((1 - ?t) *\<^sub>R r *\<^sub>R x + ?t *\<^sub>R y)"])
      apply (subst *)
      using 1
        apply (auto intro!: exI[where x = ?t])
      apply (auto simp: algebra_simps divide_simps)
      defer
    proof -
      assume a1: "c + c * (r * u) < c * u"
      assume a2: "0 \<le> c"
      assume a3: "0 \<le> u"
      assume a4: "u \<noteq> 0"
      assume a5: "0 < r"
      have "c + c * (r * u) \<le> c * u"
        using a1 less_eq_real_def by blast
      then show "c \<le> c * u"
        using a5 a4 a3 a2 by (metis (no_types) less_add_same_cancel1 less_eq_real_def
            mult_pos_pos order_trans real_scaleR_def real_vector.scale_zero_left)
    next
      assume a1: "0 \<le> c"
      assume a2: "u \<le> 1"
      have f3: "\<forall>x0. ((x0::real) < 1) = (\<not> 1 \<le> x0)"
        by auto
      have f4: "\<forall>x0. ((1::real) < x0) = (\<not> x0 \<le> 1)"
        by fastforce
      have "\<forall>x0 x1. ((x1::real) < x1 * x0) = (\<not> 0 \<le> x1 + - 1 * (x1 * x0))"
        by auto
      then have "(\<forall>r ra. ((r::real) < r * ra) = ((0 \<le> r \<longrightarrow> 1 < ra) \<and> (r \<le> 0 \<longrightarrow> ra < 1))) = (\<forall>r ra. (\<not> (0::real) \<le> r + - 1 * (r * ra)) = ((\<not> 0 \<le> r \<or> \<not> ra \<le> 1) \<and> (\<not> r \<le> 0 \<or> \<not> 1 \<le> ra)))"
        using f4 f3 by presburger
      then have "0 \<le> c + - 1 * (c * u)"
        using a2 a1 mult_less_cancel_left1 by blast
      then show "c * u \<le> c"
        by auto
    qed
    done
qed

lemma conefield_scaleRD: "v \<in> conefield x y" if "v \<in> conefield (r *\<^sub>R x) y" "r > 0"
  using conefield_scaleRI[OF that(1) positive_imp_inverse_positive[OF that(2)]] that(2)
  by auto

lemma conefield_scaleR: "conefield (r *\<^sub>R x) y = conefield x y" if "r > 0"
  using conefield_scaleRD conefield_scaleRI that
  by blast

lemma conefield_expansion_estimate:
  fixes u v::"'a::euclidean_space" and F::"'a \<Rightarrow> 'a"
  assumes "t \<in> {0 .. pi / 2}"
  assumes angle_pos: "0 < vangle u v" "vangle u v < pi / 2"
  assumes angle_le: "vangle (F u) (F v) \<le> vangle u v"
  assumes "bounded_linear F"
  assumes "x \<in> conefield u v"
  shows "norm (F x) \<ge> min (norm (F u)/norm u) (norm (F v)/norm v) * norm x"
proof cases
  assume [simp]: "x \<noteq> 0"
  from assms have [simp]: "u \<noteq> 0" "v \<noteq> 0" by auto
  interpret bounded_linear F by fact
  define u1 where "u1 = u /\<^sub>R norm u"
  define v1 where "v1 = v /\<^sub>R norm v"
  note \<open>x \<in> conefield u v\<close>
  also have \<open>conefield u v = conefield u1 v1\<close>
    by (auto simp: u1_def v1_def conefield_scaleR conefield_commute[of u])
  finally obtain c t where x: "x = c *\<^sub>R conemem u1 v1 t" "t \<in> {0 .. pi / 2}" "c \<ge> 0"
    by (auto simp: conefield_def cone_hull_expl conesegment_def)
  then have xc: "x /\<^sub>R c = conemem u1 v1 t"
    by (auto simp: divide_simps)
  also have "F \<dots> = conemem (F u1) (F v1) t"
    by (simp add: bounded_linear_image_conemem assms)
  also have "norm \<dots> \<ge> min (norm (F u1)) (norm (F v1)) * norm (conemem u1 v1 t)"
    apply (rule conemem_expansion_estimate)
    subgoal by fact
    subgoal using angle_pos by (simp add: u1_def v1_def vangle_scaleR)
    subgoal using angle_pos by (simp add: u1_def v1_def vangle_scaleR)
    subgoal using angle_le by (simp add: u1_def v1_def scaleR vangle_scaleR)
    subgoal using angle_le by (simp add: u1_def v1_def scaleR vangle_scaleR)
    subgoal using angle_le by (simp add: u1_def v1_def scaleR vangle_scaleR)
    done
  finally show "norm (F x) \<ge> min (norm (F u)/norm u) (norm (F v)/norm v) * norm x"
    unfolding xc[symmetric] scaleR u1_def v1_def norm_scaleR x
    using \<open>c \<ge> 0\<close>
    by (simp add: divide_simps split: if_splits)
qed simp

lemma conefield_right_vangleI:
  assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
  assumes "y \<in> {y1 .. y2}" "y1 < y2"
  shows "(i + y *\<^sub>R j) \<in> conefield (i + y1 *\<^sub>R j) (i + y2 *\<^sub>R j)"
  unfolding conefield_alt_def
  apply (rule hull_inc)
  using assms
  by (auto simp: in_segment divide_simps inner_Basis algebra_simps
      intro!: exI[where x="(y - y1) / (y2 - y1)"] euclidean_eqI[where 'a='a] )

lemma cone_conefield[intro, simp]: "cone (conefield x y)"
  unfolding conefield_def
  by (rule cone_cone_hull)

lemma conefield_mk_rightI:
  assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
  assumes "(i + (y / x) *\<^sub>R j) \<in> conefield (i + (y1 / x1) *\<^sub>R j) (i + (y2 / x2) *\<^sub>R j)"
  assumes "x > 0" "x1 > 0" "x2 > 0"
  shows "(x *\<^sub>R i + y *\<^sub>R j) \<in> conefield (x1 *\<^sub>R i + y1 *\<^sub>R j) (x2 *\<^sub>R i + y2 *\<^sub>R j)"
proof -
  have rescale: "(x *\<^sub>R i + y *\<^sub>R j) = x *\<^sub>R (i + (y / x) *\<^sub>R j)" if "x > 0" for x y
    using that by (auto simp: algebra_simps)
  show ?thesis
    unfolding rescale[OF \<open>x > 0\<close>] rescale[OF \<open>x1 > 0\<close>] rescale[OF \<open>x2 > 0\<close>]
      conefield_scaleR[OF \<open>x1 > 0\<close>]
    apply (subst conefield_commute)
    unfolding conefield_scaleR[OF \<open>x2 > 0\<close>]
    apply (rule mem_cone)
      apply simp
     apply (subst conefield_commute)
    by (auto intro!: assms less_imp_le)
qed

lemma conefield_prod3I:
  assumes "x > 0" "x1 > 0" "x2 > 0"
  assumes "y1 / x1 \<le> y / x" "y / x \<le> y2 / x2"
  shows "(x, y, 0) \<in> (conefield (x1, y1, 0) (x2, y2, 0)::(real*real*real) set)"
proof -
  have "(x *\<^sub>R (1, 0, 0) + y *\<^sub>R (0, 1, 0)) \<in>
    (conefield (x1 *\<^sub>R (1, 0, 0) + y1 *\<^sub>R (0, 1, 0)) (x2 *\<^sub>R (1, 0, 0) + y2 *\<^sub>R (0, 1, 0))::(real*real*real) set)"
    apply (rule conefield_mk_rightI)
    subgoal by (auto simp: Basis_prod_def zero_prod_def)
    subgoal by (auto simp: Basis_prod_def zero_prod_def)
    subgoal by (auto simp: Basis_prod_def zero_prod_def)
    subgoal using assms by (intro conefield_rightI) (auto simp: Basis_prod_def zero_prod_def)
    by (auto intro: assms)
  then show ?thesis by simp
qed

end