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

section \<open>Some useful lemmas in algebra\<close>

theory Missing_Algebraic imports
  "HOL-Computational_Algebra.Polynomial_Factorial"
  "HOL-Computational_Algebra.Fundamental_Theorem_Algebra"
  "HOL-Complex_Analysis.Complex_Analysis"
  Missing_Topology
  "Budan_Fourier.BF_Misc"
begin

subsection \<open>Misc\<close>

lemma poly_holomorphic_on[simp]:
  "(poly p) holomorphic_on s"
  apply (rule holomorphic_onI)
  apply (unfold field_differentiable_def)
  apply (rule_tac x="poly (pderiv p) x" in exI)
  by (simp add:has_field_derivative_at_within)

lemma order_zorder:
  fixes p::"complex poly" and z::complex
  assumes "p\<noteq>0"
  shows "order z p = nat (zorder (poly p) z)"
proof -
  define n where "n=nat (zorder (poly p) z)"
  define h where "h=zor_poly (poly p) z"
  have "\<exists>w. poly p w \<noteq> 0" using assms poly_all_0_iff_0 by auto
  then obtain r where "0 < r" "cball z r \<subseteq> UNIV" and
      h_holo: "h holomorphic_on cball z r" and
      poly_prod:"(\<forall>w\<in>cball z r. poly p w = h w * (w - z) ^ n \<and> h w \<noteq> 0)"
    using zorder_exist_zero[of "poly p" UNIV z,folded h_def] poly_holomorphic_on
    unfolding n_def by auto
  then have "h holomorphic_on ball z r"
    and "(\<forall>w\<in>ball z r. poly p w = h w * (w - z) ^ n)"
    and "h z\<noteq>0"
    by auto
  then have "order z p = n" using \<open>p\<noteq>0\<close>
  proof (induct n arbitrary:p h)
    case 0
    then have "poly p z=h z" using \<open>r>0\<close> by auto
    then have "poly p z\<noteq>0" using \<open>h z\<noteq>0\<close> by auto
    then show ?case using order_root by blast
  next
    case (Suc n)
    define sn where "sn=Suc n"
    define h' where "h'\<equiv> \<lambda>w. deriv h w * (w-z)+ sn * h w"
    have "(poly p has_field_derivative poly (pderiv p) w) (at w)" for w
      using poly_DERIV[of p w] .
    moreover have "(poly p has_field_derivative (h' w)*(w-z)^n ) (at w)" when "w\<in>ball z r" for w
    proof (subst DERIV_cong_ev[of w w "poly p" "\<lambda>w.  h w * (w - z) ^ Suc n" ],simp_all)
      show "\<forall>\<^sub>F x in nhds w. poly p x = h x * ((x - z) * (x - z) ^ n)"
        unfolding eventually_nhds using Suc(3) \<open>w\<in>ball z r\<close>
        apply (intro exI[where x="ball z r"])
        by auto
      next
        have "(h has_field_derivative deriv h w) (at w)"
          using \<open>h holomorphic_on ball z r\<close> \<open>w\<in>ball z r\<close> holomorphic_on_imp_differentiable_at
          by (simp add: holomorphic_derivI)
        then have "((\<lambda>w. h w * ((w - z) ^ sn))
                      has_field_derivative h' w * (w - z) ^ (sn - 1)) (at w)"
          unfolding h'_def
          apply (auto intro!: derivative_eq_intros simp add:field_simps)
          by (auto simp add:field_simps sn_def)
        then show "((\<lambda>w. h w * ((w - z) * (w - z) ^ n))
                      has_field_derivative h' w * (w - z) ^ n) (at w)"
          unfolding sn_def by auto
      qed
    ultimately have "\<forall>w\<in>ball z r. poly (pderiv p) w = h' w * (w - z) ^ n"
      using DERIV_unique by blast
    moreover have "h' holomorphic_on ball z r"
      unfolding h'_def using \<open>h holomorphic_on ball z r\<close>
      by (auto intro!: holomorphic_intros)
    moreover have "h' z\<noteq>0" unfolding h'_def sn_def using \<open>h z \<noteq> 0\<close> of_nat_neq_0 by auto
    moreover have "pderiv p \<noteq> 0"
    proof
      assume "pderiv p = 0"
      obtain c where "p=[:c:]" using \<open>pderiv p = 0\<close> using pderiv_iszero by blast
      then have "c=0"
        using Suc(3)[rule_format,of z] \<open>r>0\<close> by auto
      then show False using \<open>p\<noteq>0\<close> using \<open>p=[:c:]\<close> by auto
    qed
    ultimately have "order z (pderiv p) = n" by (auto elim: Suc.hyps)
    moreover have "order z p \<noteq> 0"
      using Suc(3)[rule_format,of z] \<open>r>0\<close> order_root \<open>p\<noteq>0\<close> by auto
    ultimately show ?case using order_pderiv[OF \<open>pderiv p \<noteq> 0\<close>] by auto
  qed
  then show ?thesis unfolding n_def .
qed

lemma pcompose_pCons_0:"pcompose p [:a:] = [:poly p a:]"
  apply (induct p)
  by (auto simp add:pcompose_pCons algebra_simps)

lemma pcompose_coeff_0:
  "coeff (pcompose p q) 0 = poly p (coeff q 0)"
  apply (induct p)
  by (auto simp add:pcompose_pCons coeff_mult)

lemma poly_field_differentiable_at[simp]:
  "poly p field_differentiable (at x within s)"
apply (unfold field_differentiable_def)
apply (rule_tac x="poly (pderiv p) x" in exI)
by (simp add:has_field_derivative_at_within)

lemma deriv_pderiv:
  "deriv (poly p) = poly (pderiv p)"
apply (rule ext)
apply (rule DERIV_imp_deriv)
  using poly_DERIV .

lemma lead_coeff_map_poly_nz:
  assumes "f (lead_coeff p) \<noteq>0" "f 0=0"
  shows "lead_coeff (map_poly f p) = f (lead_coeff p) "
proof -
  have "lead_coeff (Poly (map f (coeffs p))) = f (lead_coeff p)"
    by (metis (mono_tags, lifting) antisym assms(1) assms(2) coeff_0_degree_minus_1 coeff_map_poly
        degree_Poly degree_eq_length_coeffs le_degree length_map map_poly_def)
  then show ?thesis
    by (simp add: map_poly_def)
qed

lemma filterlim_poly_at_infinity:
  fixes p::"'a::real_normed_field poly"
  assumes "degree p>0"
  shows "filterlim (poly p) at_infinity at_infinity"
using assms
proof (induct p)
  case 0
  then show ?case by auto
next
  case (pCons a p)
  have ?case when "degree p=0"
  proof -
    obtain c where c_def:"p=[:c:]" using \<open>degree p = 0\<close> degree_eq_zeroE by blast
    then have "c\<noteq>0" using \<open>0 < degree (pCons a p)\<close> by auto
    then show ?thesis unfolding c_def
      apply (auto intro!:tendsto_add_filterlim_at_infinity)
      apply (subst mult.commute)
      by (auto intro!:tendsto_mult_filterlim_at_infinity filterlim_ident)
  qed
  moreover have ?case when "degree p\<noteq>0"
  proof -
    have "filterlim (poly p) at_infinity at_infinity"
      using that by (auto intro:pCons)
    then show ?thesis
      by (auto intro!:tendsto_add_filterlim_at_infinity filterlim_at_infinity_times filterlim_ident)
  qed
  ultimately show ?case by auto
qed

lemma poly_eventually_not_zero:
  fixes p::"real poly"
  assumes "p\<noteq>0"
  shows "eventually (\<lambda>x. poly p x\<noteq>0) at_infinity"
proof (rule eventually_at_infinityI[of "Max (norm ` {x. poly p x=0}) + 1"])
  fix x::real assume asm:"Max (norm ` {x. poly p x=0}) + 1 \<le> norm x"
  have False when "poly p x=0"
  proof -
    define S where "S=norm `{x. poly p x = 0}"
    have "norm x\<in>S" using that unfolding S_def by auto
    moreover have "finite S" using \<open>p\<noteq>0\<close> poly_roots_finite unfolding S_def by blast
    ultimately have "norm x\<le>Max S" by simp
    moreover have "Max S + 1 \<le> norm x" using asm unfolding S_def by simp
    ultimately show False by argo
  qed
  then show "poly p x \<noteq> 0" by auto
qed

subsection \<open>More about @{term degree}\<close>

lemma degree_div_less:
  fixes x y::"'a::field poly"
  assumes "degree x\<noteq>0" "degree y\<noteq>0"
  shows "degree (x div y) < degree x"
proof -
  have "x\<noteq>0" "y\<noteq>0" using assms by auto
  define q r where "q=x div y" and "r=x mod y"
  have *:"eucl_rel_poly x y (q, r)" unfolding q_def r_def
    by (simp add: eucl_rel_poly)
  then have "r = 0 \<or> degree r < degree y" using \<open>y\<noteq>0\<close> unfolding eucl_rel_poly_iff by auto
  moreover have ?thesis when "r=0"
  proof -
    have "x = q * y" using * that unfolding eucl_rel_poly_iff by auto
    then have "q\<noteq>0" using \<open>x\<noteq>0\<close> \<open>y\<noteq>0\<close> by auto
    from degree_mult_eq[OF this \<open>y\<noteq>0\<close>] \<open>x = q * y\<close>
    have "degree x = degree q +degree y" by auto
    then show ?thesis unfolding q_def using assms by auto
  qed
  moreover have ?thesis when "degree r<degree y"
  proof (cases "degree y>degree x")
    case True
    then have "q=0" unfolding q_def using div_poly_less by auto
    then show ?thesis unfolding q_def using assms(1) by auto
  next
    case False
    then have "degree x>degree r" using that by auto
    then have "degree x = degree (x-r)" using degree_add_eq_right[of "-r" x] by auto
    have "x-r = q*y" using * unfolding eucl_rel_poly_iff by auto
    then have "q\<noteq>0" using \<open>degree r < degree x\<close> by auto
    have "degree x = degree q +degree y"
      using  degree_mult_eq[OF \<open>q\<noteq>0\<close> \<open>y\<noteq>0\<close>] \<open>x-r = q*y\<close> \<open>degree x = degree (x-r)\<close> by auto
    then show ?thesis unfolding q_def using assms by auto
  qed
  ultimately show ?thesis by auto
qed

lemma map_poly_degree_eq:
  assumes "f (lead_coeff p) \<noteq>0"
  shows "degree (map_poly f p) = degree p"
  using assms
  unfolding map_poly_def degree_eq_length_coeffs coeffs_Poly lead_coeff_list_def
  by (metis (full_types) last_conv_nth_default length_map no_trailing_unfold nth_default_coeffs_eq
      nth_default_map_eq strip_while_idem)

lemma map_poly_degree_less:
  assumes "f (lead_coeff p) =0" "degree p\<noteq>0"
  shows "degree (map_poly f p) < degree p"
proof -
  have "length (coeffs p) >1"
    using \<open>degree p\<noteq>0\<close> by (simp add: degree_eq_length_coeffs)
  then obtain xs x where xs_def:"coeffs p=xs@[x]" "length xs>0"
    by (metis One_nat_def add.commute add_diff_cancel_left' append_Nil assms(2)
        degree_eq_length_coeffs length_greater_0_conv list.size(3) list.size(4) not_less_zero
        rev_exhaust)
  have "f x=0" using assms(1) by (simp add: lead_coeff_list_def xs_def(1))
  have "degree (map_poly f p) = length (strip_while ((=) 0) (map f (xs@[x]))) - 1"
    unfolding map_poly_def degree_eq_length_coeffs coeffs_Poly
    by (subst xs_def,auto)
  also have "... = length (strip_while ((=) 0) (map f xs)) - 1"
    using \<open>f x=0\<close> by simp
  also have "... \<le> length xs -1"
    using length_strip_while_le by (metis diff_le_mono length_map)
  also have "... < length (xs@[x]) - 1"
    using xs_def(2) by auto
  also have "... = degree p"
    unfolding degree_eq_length_coeffs xs_def by simp
  finally show ?thesis .
qed

lemma map_poly_degree_leq[simp]:
  shows "degree (map_poly f p) \<le> degree p"
  unfolding map_poly_def degree_eq_length_coeffs
  by (metis coeffs_Poly diff_le_mono length_map length_strip_while_le)

subsection \<open>roots / zeros of a univariate function\<close>

definition roots_within::"('a \<Rightarrow> 'b::zero) \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "roots_within f s = {x\<in>s. f x = 0}"

abbreviation roots::"('a \<Rightarrow> 'b::zero) \<Rightarrow> 'a set" where
  "roots f \<equiv> roots_within f UNIV"

subsection \<open>The argument principle specialised to polynomials.\<close>

lemma argument_principle_poly:
  assumes "p\<noteq>0" and valid:"valid_path g" and loop: "pathfinish g = pathstart g"
    and no_proots:"path_image g \<subseteq> - proots p"
  shows "contour_integral g (\<lambda>x. deriv (poly p) x / poly p x) = 2 * of_real pi * \<i> *
            (\<Sum>x\<in>proots p. winding_number g x * of_nat (order x p))"
proof -
  have "contour_integral g (\<lambda>x. deriv (poly p) x / poly p x) = 2 * of_real pi * \<i> *
          (\<Sum>x | poly p x = 0. winding_number g x * of_int (zorder (poly p) x))"
    apply (rule argument_principle[of UNIV "poly p" "{}" "\<lambda>_. 1" g,simplified,OF _ valid loop])
    using no_proots[unfolded proots_def] by (auto simp add:poly_roots_finite[OF \<open>p\<noteq>0\<close>] )
  also have "... =  2 * of_real pi * \<i> * (\<Sum>x\<in>proots p. winding_number g x * of_nat (order x p))"
  proof -
    have "nat (zorder (poly p) x) = order x p" when "x\<in>proots p" for x
      using order_zorder[OF \<open>p\<noteq>0\<close>] that unfolding proots_def by auto
    then show ?thesis unfolding proots_def
      apply (auto intro!:comm_monoid_add_class.sum.cong)
      by (metis assms(1) nat_eq_iff2 of_nat_nat order_root)
  qed
  finally show ?thesis .
qed

end


theory Efficient_Distinct
imports
  "../../Automatic_Refinement/Lib/Misc" (*mergesort*)
  "~~/src/HOL/Library/List_lexord"
  "~~/src/HOL/Library/Code_Char"
  TopoS_Util
begin

text {*efficient distinct code*}

  lemma list_length_iff_distinct:
  "\<lbrakk>set xs = set ys; distinct ys\<rbrakk> \<Longrightarrow> distinct xs \<longleftrightarrow> length xs = length ys"
  by (metis distinct_card card_distinct)

  lemma distinct_by_mergesort: "(length (mergesort_remdups xs) = length xs) \<longleftrightarrow> distinct xs"
  by (metis list_length_iff_distinct mergesort_remdups_correct)

  text{*providing tail recursive versions of certain functions*}
  (*otherwise scala code generated with this code always produces a StackOverflowException for large inputs*)

text{* @{const List.map} *}

  fun map_tailrec ::  "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
  "map_tailrec f [] accs = accs" |
  "map_tailrec f (a#as) accs = (map_tailrec f as ((f a)#accs))"

  lemma map_tailrec_is_listmap: "rev (map_tailrec f l accs) = (rev accs)@(List.map f l)"
  by (induction l accs rule: map_tailrec.induct) auto

  definition efficient_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
    "efficient_map f l \<equiv> rev (map_tailrec f l [])"

  lemma [code]: "List.map f l = efficient_map f l"
  by (simp add: efficient_map_def map_tailrec_is_listmap)

text{* @{const merge} *}

 (*inefficient version*)
 fun merge_tailrec_inefficient :: "('a::linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "merge_tailrec_inefficient (a#as) (b#bs) accs = (if a < b
      then merge_tailrec_inefficient (as) (b#bs) (accs@[a])
      else if a = b then merge_tailrec_inefficient (as) (bs) (accs@[a])
      else merge_tailrec_inefficient (a#as) (bs) (accs@[b]))"
  | "merge_tailrec_inefficient [] bs accs= accs@bs"
  | "merge_tailrec_inefficient as [] accs = accs@as"

  lemma merge_tailrec_inefficient_prepend:
  "merge_tailrec_inefficient as bs (a # accs) = a # merge_tailrec_inefficient as bs accs"
  by (induction as bs accs rule: merge_tailrec_inefficient.induct) auto

  lemma merge_as_tailrec_inefficient: "merge as bs = merge_tailrec_inefficient as bs []"
  by (induction as bs rule: merge.induct)  (auto simp: merge_tailrec_inefficient_prepend)

 fun merge_tailrec :: "('a::linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "merge_tailrec (a#as) (b#bs) accs = (if a < b
      then merge_tailrec (as) (b#bs) (a#accs)
      else if a = b then merge_tailrec (as) (bs) (a#accs)
      else merge_tailrec (a#as) (bs) (b#accs))"
  | "merge_tailrec [] bs accs= (rev accs)@bs"
  | "merge_tailrec as [] accs = (rev accs)@as"

  lemma merge_tailrec_listappend:
    "merge_tailrec as bs (accs1@accs2) = (rev accs2)@(merge_tailrec as bs accs1)"
  proof (induction as bs "accs1@accs2" arbitrary: accs1 accs2 rule: merge_tailrec.induct)
    case (1 a as b bs)
    thus ?case
      by (cases a b rule: linorder_cases) (metis append_Cons merge_tailrec.simps(1))+
  qed auto

  lemma merge_tailrec_acc_append:
    "merge_tailrec as bs (accs@[a]) = a#(merge_tailrec as bs (accs))"
  by (induction as bs accs rule: merge_tailrec.induct) auto

  lemma merge_inefficient_as_efficient:
    "merge_tailrec_inefficient as bs (rev accs) = (merge_tailrec as bs accs)"
  proof (induction as bs accs arbitrary: accs rule: merge_tailrec_inefficient.induct)
    case (1 a as b bs)
    thus ?case
      by (cases a b rule: linorder_cases) (metis merge_tailrec.simps(1) merge_tailrec_inefficient.simps(1) rev.simps(2))+
  qed auto

  lemma [code]: "merge as bs = merge_tailrec as bs []"
  apply (subst merge_as_tailrec_inefficient)
  apply (subst merge_inefficient_as_efficient[where accs = "[]", unfolded rev.simps(1)])
  apply (rule refl)
  done

(*import scala.annotation.tailrec*)
  export_code distinct in Scala

  value "distinct [(CHR ''A'')]"
  value "distinct [''a'', ''b'']"
  value "distinct [(''a'', ''b'')]"
  value "distinct (map fst [(''a'', ''b''), (''a'', ''c'')])"

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_13
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

theorem property0 :
  "((drop (S n) (cons2 x xs)) = (drop n xs))"
  oops

end