/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.succ_pred.basic

/-!
# Successors and predecessors of naturals

In this file, we show that `ℕ` is both an archimedean `succ_order` and an archimedean `pred_order`.
-/

open function order

namespace nat

@[reducible] -- so that Lean reads `nat.succ` through `succ_order.succ`
instance : succ_order ℕ :=
{ succ := succ,
  ..succ_order.of_succ_le_iff succ (λ a b, iff.rfl) }

@[reducible] -- so that Lean reads `nat.pred` through `pred_order.pred`
instance : pred_order ℕ :=
{ pred := pred,
  pred_le := pred_le,
  min_of_le_pred := λ a ha, begin
    cases a,
    { exact is_min_bot },
    { exact (not_succ_le_self _ ha).elim }
  end,
  le_pred_of_lt := λ a b h, begin
    cases b,
    { exact (a.not_lt_zero h).elim },
    { exact le_of_succ_le_succ h }
  end,
  le_of_pred_lt := λ a b h, begin
    cases a,
    { exact b.zero_le },
    { exact h }
  end }

@[simp] lemma succ_eq_succ : order.succ = succ := rfl
@[simp] lemma pred_eq_pred : order.pred = pred := rfl

lemma succ_iterate (a : ℕ) : ∀ n, succ^[n] a = a + n
| 0       := rfl
| (n + 1) := by { rw [function.iterate_succ', add_succ], exact congr_arg _ n.succ_iterate }

lemma pred_iterate (a : ℕ) : ∀ n, pred^[n] a = a - n
| 0       := rfl
| (n + 1) := by { rw [function.iterate_succ', sub_succ], exact congr_arg _ n.pred_iterate }

instance : is_succ_archimedean ℕ :=
⟨λ a b h, ⟨b - a, by rw [succ_eq_succ, succ_iterate, add_tsub_cancel_of_le h]⟩⟩

instance : is_pred_archimedean ℕ :=
⟨λ a b h, ⟨b - a, by rw [pred_eq_pred, pred_iterate, tsub_tsub_cancel_of_le h]⟩⟩

/-! ### Covering relation -/

protected lemma covby_iff_succ_eq {m n : ℕ} : m ⋖ n ↔ m + 1 = n := succ_eq_iff_covby.symm

end nat

@[simp, norm_cast] lemma fin.coe_covby_iff {n : ℕ} {a b : fin n} : (a : ℕ) ⋖ b ↔ a ⋖ b :=
and_congr_right' ⟨λ h c hc, h hc, λ h c ha hb, @h ⟨c, hb.trans b.prop⟩ ha hb⟩

alias fin.coe_covby_iff ↔ _ covby.coe_fin


namespace Fin

  instance decEq {n} (a b : Fin n) : Decidable (Eq a b) :=
    match Nat.decEq a.val b.val with
    | isFalse h => isFalse (Fin.ne_of_val_ne h)
    | isTrue h => isTrue (Fin.eq_of_val_eq h)

  def extended_add (a : Fin m) (b : Fin n) : Fin (m+n-1) :=
    Fin.mk (a.val + b.val) (by {
      match m, n with
      | Nat.zero, _ => exact Fin.elim0 a
      | _, Nat.zero => exact Fin.elim0 b
      | Nat.succ m, Nat.succ n => {
        rw [Nat.add_succ, Nat.succ_sub_succ, Nat.sub_zero, Nat.succ_add];
        apply Nat.lt_succ_of_le;
        apply Nat.add_le_add;
        exact Nat.le_of_lt_succ a.isLt;
        exact Nat.le_of_lt_succ b.isLt;
      }
    })

  def cast {m n : Nat} (h : m = n) (a : Fin m) : Fin n := Fin.mk a.val (by rw [←h]; apply Fin.isLt)

  def inbound_succ (a : Fin n) (hne : a.val.succ ≠ n) : Fin n :=
    {val := a.val.succ, isLt := Nat.lt_of_le_of_ne (Nat.lt_of_succ_le a.isLt) hne}

  def inbound_pred (a : Fin n) (hne : a.val ≠ 0) : Fin n :=
    {val := a.val.pred, isLt := Nat.lt_trans (Nat.pred_lt hne) (a.isLt)}

  def inbound_pred_succ (a : Fin n) (hne : a.val.succ ≠ n) : Fin n :=
    have h : (inbound_succ a hne).val ≠ 0 := by rw [inbound_succ]; simp;
    inbound_pred (inbound_succ a hne) h

  def inbound_succ_pred (a : Fin n) (hne : a.val ≠ 0) : Fin n :=
    have h : (inbound_pred a hne).val.succ ≠ n := by rw [inbound_pred]; simp; rw [Nat.succ_pred hne]; apply Nat.ne_of_lt; apply a.isLt;
    inbound_succ (inbound_pred a hne) h

  theorem inbound_pred_succ_eq : ∀ (a : Fin n) (hne : a.val.succ ≠ n), a = inbound_pred_succ a hne := by
    intro a hne;
    apply Fin.eq_of_val_eq;
    rw [inbound_pred_succ]; simp;
    rw [inbound_pred]; simp;
    rw [inbound_succ]; simp;

  theorem inbound_succ_pred_eq : ∀ (a : Fin n) (hne : a.val ≠ 0), a = inbound_succ_pred a hne := by
    intro a hne;
    apply Fin.eq_of_val_eq;
    rw [inbound_succ_pred]; simp;
    rw [inbound_succ]; simp;
    rw [inbound_pred]; simp;
    rw [Nat.succ_pred hne];

  theorem lt_from_inbound_succ : ∀ {a b : Fin n} {hne : a.val.succ ≠ n}, inbound_succ a hne = b → a < b := by
    intro a b hne h;
    rw [inbound_succ] at h;
    apply Nat.lt_of_succ_le;
    apply Nat.le_of_eq;
    exact Fin.val_eq_of_eq h;

  theorem extended_add_eq_add_right : ∀ {a1 a2 : Fin m} {b : Fin n}, a1 = a2 ↔ Fin.extended_add a1 b = Fin.extended_add a2 b := by
    intro a1 a2 b
    apply Iff.intro;
    {
      intro h;
      simp [h];
    }
    {
      intro h;
      simp [extended_add] at h;
      match m, n with
      | Nat.zero, _ => exact a1.elim0;
      | _, Nat.zero => exact b.elim0;
      | Nat.succ m, Nat.succ n => simp at h; apply Fin.eq_of_val_eq; apply Nat.add_right_cancel h;
    }

  theorem extended_add_eq_add_left : ∀ {a1 a2 : Fin m} {b : Fin n}, a1 = a2 ↔ Fin.extended_add b a1 = Fin.extended_add b a2 := by
    intro a1 a2 b
    apply Iff.intro;
    {
      intro h;
      simp [h];
    }
    {
      intro h;
      simp [extended_add] at h;
      match m, n with
      | Nat.zero, _ => exact a1.elim0;
      | _, Nat.zero => exact b.elim0;
      | Nat.succ m, Nat.succ n => simp at h; apply Fin.eq_of_val_eq; apply Nat.add_left_cancel h;
    }

  theorem extended_add_le_add_right : ∀ {a1 a2 : Fin m} {b : Fin n}, a1 ≤ a2 → Fin.extended_add a1 b ≤ Fin.extended_add a2 b := by
    intro a1 a2 b h
    simp [extended_add];
    match m, n with
    | Nat.zero, _ => exact a1.elim0
    | _, Nat.zero => exact b.elim0
    | Nat.succ m, Nat.succ n => simp; apply Nat.add_le_add_right h;

  theorem extended_add_le_add_left : ∀ {a1 a2 : Fin m} {b : Fin n}, a1 ≤ a2 → Fin.extended_add b a1 ≤ Fin.extended_add b a2 := by
    intro a1 a2 b h
    simp [extended_add];
    match m, n with
    | Nat.zero, _ => exact a1.elim0
    | _, Nat.zero => exact b.elim0
    | Nat.succ m, Nat.succ n => simp; apply Nat.add_le_add_left h;

  theorem extended_add_le_add : ∀ {a1 a2 : Fin m} {b1 b2 : Fin n}, a1 ≤ a2 → b1 ≤ b2 → Fin.extended_add a1 b1 ≤ Fin.extended_add a2 b2 := by
    intro a1 a2 b1 b2 ha hb;
    simp [extended_add, extended_add];
    match m, n with
    | Nat.zero, _ => exact a1.elim0
    | _, Nat.zero => exact b1.elim0
    | Nat.succ m, Nat.succ n => simp; apply Nat.add_le_add ha hb;

  theorem Nat.eq_eq_of_le_le_eq : ∀ {a b c d : Nat}, a ≤ c → b ≤ d → a + b = c + d → (a = c ∧ b = d) := by
    intro a b c d le_ac le_bd h;
    cases Nat.eq_or_lt_of_le le_ac;
    {
      simp_all; exact Nat.add_left_cancel h;
    }
    {
      cases Nat.eq_or_lt_of_le le_bd;
      {
        simp_all;
        exact Nat.add_right_cancel h;
      }
      {
        have g : a + b ≠ c + d := by apply Nat.ne_of_lt; apply Nat.add_lt_add; assumption; assumption;
        contradiction;
      }
    }

  theorem extended_eq_eq_of_le_le_eq : ∀ {a c : Fin m} {b d : Fin n}, a ≤ c → b ≤ d → Fin.extended_add a b = Fin.extended_add c d → (a = c ∧ b = d) := by
    intro a c b d le_ac le_bd h;
    simp [extended_add] at h;
    match m, n with
    | Nat.zero, _ => exact a.elim0;
    | _, Nat.zero => exact b.elim0;
    | Nat.succ m, Nat.succ n =>
      {
        simp_all;
        have g := Nat.eq_eq_of_le_le_eq le_ac le_bd h;
        exact ⟨Fin.eq_of_val_eq g.left, Fin.eq_of_val_eq g.right⟩;
      }

  theorem le_trans : ∀ {a b c : Fin n}, a ≤ b → b ≤ c → a ≤ c := by
    intro a b c hab hbc;
    apply Nat.le_trans hab hbc;

  theorem le_cast : ∀ {a b : Fin m} {h : m = n}, a ≤ b → Fin.cast h a ≤ Fin.cast h b := by
    intro a b h hab;
    rw [Fin.cast];
    exact hab;

  def max (h : n > 0) : Fin n := Fin.mk n.pred (Nat.pred_lt' h)
  def min (h : n > 0) : Fin n := Fin.mk 0 h

  def IsMax (x : Fin n) : Prop := x.val.succ = n
  def IsMin (x : Fin n) : Prop := x.val = 0
end Fin


/-
Copyright (c) 2023 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard
-/

import tactic
import algebra.euclidean_domain.instances
import data.polynomial.field_division -- polynomial rings over a field are EDs
/-

# Euclidean Domains

Lean's definition of a Euclidean domain is more general than the usual one presented
to undergraduates. First things first: here's how to say "let R be a Euclidean domain"

-/

variables (R : Type) [euclidean_domain R]

/-

And there's various theorems (all known by the typeclass inference system) about
Euclidean domains:

-/

example : euclidean_domain ℤ := by apply_instance

open_locale polynomial

-- I neither know nor care why it's noncomputable, but it doesn't matter to mathematicians
noncomputable example (k : Type) [field k] : euclidean_domain k[X] := infer_instance

-- Euclidean domains are PIDs
example (R : Type) [euclidean_domain R] : is_principal_ideal_ring R := infer_instance
example (R : Type) [euclidean_domain R] : is_domain R := infer_instance

/-

Internally the definition of a Euclidean domain is this. It's a ring with the following
structure/axioms:

1) You have a "quotient" function `quotient r s` and a remainder function `remainder r s`,
both of type `R → R → R` (i.e. functions from `R²` to `R`)

2) You have an axiom saying `∀ a b, a = b * quotient a b + remainder a b`

3) You have a binary relation `≺` on the ring such that `remainder a b ≺ b`

4) You have an axiom saying that `≺` is well-founded, i.e., there are no infinite decreasing
sequences.

The point is that these axioms are enough to get Euclid's algorithm to work.

In usual maths you have a function from `R` to `ℕ` sending an element `b` to its "size",
and an axiom saying that the remainder when you divide something by `b` is sent to a smaller
natural number. In Lean the natural numbers are not involved; all that we guarantee is
that you can't keep taking remainders infinitely often, which turns out to be a very slightly
weaker statement. Let's prove that any "normal" Euclidean domain is a mathlib Euclidean domain.

-/

open_locale classical

noncomputable example (R : Type) [comm_ring R] [is_domain R] (φ : R → ℕ)
  (h : ∀ a b : R, b ≠ 0 → ∃ q r : R, a = b * q + r ∧ (r = 0 ∨ φ r < φ b))
  (h0 : ∀ a b : R, a ≠ 0 → b ≠ 0 → φ a ≤ φ (a * b)) :
  euclidean_domain R :=
begin
  let φ' : R → ℕ := λ r, if r = 0 then 0 else 1 + φ r,
  have h' : ∀ a b : R, ∃ q r : R, a = b * q + r ∧ ((b = 0 ∧ q = 0 ∧ r = a) ∨ (b ≠ 0 ∧ φ' r < φ' b)),
  { intros a b,
    by_cases hb : b = 0,
    { use [0,a, by simp],
      left, exact ⟨hb, rfl, rfl⟩, },
    { rcases h a b hb with ⟨q, r, h1, h2⟩,
      use [q, r, h1],
      right,
      refine ⟨hb, _⟩,
      cases h2 with h2 h2,
      { simp [φ'],
        rw if_pos h2,
        rw if_neg hb,
        linarith, },
      { simp [φ'],
        rw if_neg hb,
        split_ifs,
        { linarith },
        { linarith }, }, }, },
  choose quot rem h'' using h',
  exact
{ quotient := quot,
  quotient_zero := begin
    intro a,
    cases h'' a 0 with _ h1,
    cases h1,
    { exact h1.2.1, },
    { cases h1 with h1 h2, exfalso, apply h1, refl, },
  end,
  remainder := rem,
  quotient_mul_add_remainder_eq := begin
    intros a b,
    rw ← (h'' a b).1,
  end,
  r := λ a b, φ' a < φ' b,
  r_well_founded := begin
    apply inv_image.wf,
    exact is_well_founded.wf,
  end,
  remainder_lt := begin
    intros a b hb,
    rcases h'' a b with ⟨h1, ⟨h2, -⟩ | h3⟩,
    { contradiction },
    exact h3.2,
  end,
  mul_left_not_lt := begin
    intros a b hb,
    push_neg,
    by_cases ha : a = 0,
    { simp [φ'],
      subst ha,
      simp, },
    { specialize h0 a b ha hb,
      simp [φ'],
      rw if_neg ha,
      split_ifs with hab hab,
      { exfalso,
        revert hab,
        exact mul_ne_zero ha hb,
      },
      { linarith, } },
  end },
end


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module analysis.special_functions.bernstein
! leanprover-community/mathlib commit acb3d204d4ee883eb686f45d486a2a6811a01329
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Order.Field.Basic
import Mathbin.Analysis.SpecificLimits.Basic
import Mathbin.RingTheory.Polynomial.Bernstein
import Mathbin.Topology.ContinuousFunction.Polynomial
import Mathbin.Topology.ContinuousFunction.Compact

/-!
# Bernstein approximations and Weierstrass' theorem

We prove that the Bernstein approximations
```
∑ k : fin (n+1), f (k/n : ℝ) * n.choose k * x^k * (1-x)^(n-k)
```
for a continuous function `f : C([0,1], ℝ)` converge uniformly to `f` as `n` tends to infinity.

Our proof follows [Richard Beals' *Analysis, an introduction*][beals-analysis], §7D.
The original proof, due to [Bernstein](bernstein1912) in 1912, is probabilistic,
and relies on Bernoulli's theorem,
which gives bounds for how quickly the observed frequencies in a
Bernoulli trial approach the underlying probability.

The proof here does not directly rely on Bernoulli's theorem,
but can also be given a probabilistic account.
* Consider a weighted coin which with probability `x` produces heads,
  and with probability `1-x` produces tails.
* The value of `bernstein n k x` is the probability that
  such a coin gives exactly `k` heads in a sequence of `n` tosses.
* If such an appearance of `k` heads results in a payoff of `f(k / n)`,
  the `n`-th Bernstein approximation for `f` evaluated at `x` is the expected payoff.
* The main estimate in the proof bounds the probability that
  the observed frequency of heads differs from `x` by more than some `δ`,
  obtaining a bound of `(4 * n * δ^2)⁻¹`, irrespective of `x`.
* This ensures that for `n` large, the Bernstein approximation is (uniformly) close to the
  payoff function `f`.

(You don't need to think in these terms to follow the proof below: it's a giant `calc` block!)

This result proves Weierstrass' theorem that polynomials are dense in `C([0,1], ℝ)`,
although we defer an abstract statement of this until later.
-/

noncomputable section

open Classical

open BigOperators

open BoundedContinuousFunction

open unitInterval

/-- The Bernstein polynomials, as continuous functions on `[0,1]`.
-/
def bernstein (n ν : ℕ) : C(I, ℝ) :=
  (bernsteinPolynomial ℝ n ν).toContinuousMapOn I
#align bernstein bernstein

@[simp]
theorem bernstein_apply (n ν : ℕ) (x : I) :
    bernstein n ν x = n.choose ν * x ^ ν * (1 - x) ^ (n - ν) :=
  by
  dsimp [bernstein, Polynomial.toContinuousMapOn, Polynomial.toContinuousMap, bernsteinPolynomial]
  simp
#align bernstein_apply bernstein_apply

theorem bernstein_nonneg {n ν : ℕ} {x : I} : 0 ≤ bernstein n ν x :=
  by
  simp only [bernstein_apply]
  exact
    mul_nonneg (mul_nonneg (Nat.cast_nonneg _) (pow_nonneg (by unit_interval) _))
      (pow_nonneg (by unit_interval) _)
#align bernstein_nonneg bernstein_nonneg

/-!
We now give a slight reformulation of `bernstein_polynomial.variance`.
-/

namespace bernstein

/-- Send `k : fin (n+1)` to the equally spaced points `k/n` in the unit interval.
-/
def z {n : ℕ} (k : Fin (n + 1)) : I :=
  ⟨(k : ℝ) / n, by
    cases n
    · norm_num
    · have h₁ : 0 < (n.succ : ℝ) := by exact_mod_cast Nat.succ_pos _
      have h₂ : ↑k ≤ n.succ := by exact_mod_cast Fin.le_last k
      rw [Set.mem_Icc, le_div_iff h₁, div_le_iff h₁]
      norm_cast
      simp [h₂]⟩
#align bernstein.z bernstein.z

-- mathport name: «expr /ₙ»
local postfix:90 "/ₙ" => z

theorem probability (n : ℕ) (x : I) : (∑ k : Fin (n + 1), bernstein n k x) = 1 :=
  by
  have := bernsteinPolynomial.sum ℝ n
  apply_fun fun p => Polynomial.aeval (x : ℝ) p  at this
  simp [AlgHom.map_sum, Finset.sum_range] at this
  exact this
#align bernstein.probability bernstein.probability

theorem variance {n : ℕ} (h : 0 < (n : ℝ)) (x : I) :
    (∑ k : Fin (n + 1), (x - k/ₙ : ℝ) ^ 2 * bernstein n k x) = x * (1 - x) / n :=
  by
  have h' : (n : ℝ) ≠ 0 := ne_of_gt h
  apply_fun fun x : ℝ => x * n using GroupWithZero.mul_right_injective h'
  apply_fun fun x : ℝ => x * n using GroupWithZero.mul_right_injective h'
  dsimp
  conv_lhs => simp only [Finset.sum_mul, z]
  conv_rhs => rw [div_mul_cancel _ h']
  have := bernsteinPolynomial.variance ℝ n
  apply_fun fun p => Polynomial.aeval (x : ℝ) p  at this
  simp [AlgHom.map_sum, Finset.sum_range, ← Polynomial.nat_cast_mul] at this
  convert this using 1
  · congr 1
    funext k
    rw [mul_comm _ (n : ℝ), mul_comm _ (n : ℝ), ← mul_assoc, ← mul_assoc]
    congr 1
    field_simp [h]
    ring
  · ring
#align bernstein.variance bernstein.variance

end bernstein

open bernstein

-- mathport name: «expr /ₙ»
local postfix:1024 "/ₙ" => z

/-- The `n`-th approximation of a continuous function on `[0,1]` by Bernstein polynomials,
given by `∑ k, f (k/n) * bernstein n k x`.
-/
def bernsteinApproximation (n : ℕ) (f : C(I, ℝ)) : C(I, ℝ) :=
  ∑ k : Fin (n + 1), f k/ₙ • bernstein n k
#align bernstein_approximation bernsteinApproximation

/-!
We now set up some of the basic machinery of the proof that the Bernstein approximations
converge uniformly.

A key player is the set `S f ε h n x`,
for some function `f : C(I, ℝ)`, `h : 0 < ε`, `n : ℕ` and `x : I`.

This is the set of points `k` in `fin (n+1)` such that
`k/n` is within `δ` of `x`, where `δ` is the modulus of uniform continuity for `f`,
chosen so `|f x - f y| < ε/2` when `|x - y| < δ`.

We show that if `k ∉ S`, then `1 ≤ δ^-2 * (x - k/n)^2`.
-/

namespace bernsteinApproximation

@[simp]
theorem apply (n : ℕ) (f : C(I, ℝ)) (x : I) :
    bernsteinApproximation n f x = ∑ k : Fin (n + 1), f k/ₙ * bernstein n k x := by
  simp [bernsteinApproximation]
#align bernstein_approximation.apply bernsteinApproximation.apply

/-- The modulus of (uniform) continuity for `f`, chosen so `|f x - f y| < ε/2` when `|x - y| < δ`.
-/
def δ (f : C(I, ℝ)) (ε : ℝ) (h : 0 < ε) : ℝ :=
  f.modulus (ε / 2) (half_pos h)
#align bernstein_approximation.δ bernsteinApproximation.δ

theorem δ_pos {f : C(I, ℝ)} {ε : ℝ} {h : 0 < ε} : 0 < δ f ε h :=
  f.modulus_pos
#align bernstein_approximation.δ_pos bernsteinApproximation.δ_pos

/-- The set of points `k` so `k/n` is within `δ` of `x`.
-/
def s (f : C(I, ℝ)) (ε : ℝ) (h : 0 < ε) (n : ℕ) (x : I) : Finset (Fin (n + 1)) :=
  { k : Fin (n + 1) | dist k/ₙ x < δ f ε h }.toFinset
#align bernstein_approximation.S bernsteinApproximation.s

/-- If `k ∈ S`, then `f(k/n)` is close to `f x`.
-/
theorem lt_of_mem_s {f : C(I, ℝ)} {ε : ℝ} {h : 0 < ε} {n : ℕ} {x : I} {k : Fin (n + 1)}
    (m : k ∈ s f ε h n x) : |f k/ₙ - f x| < ε / 2 :=
  by
  apply f.dist_lt_of_dist_lt_modulus (ε / 2) (half_pos h)
  simpa [S] using m
#align bernstein_approximation.lt_of_mem_S bernsteinApproximation.lt_of_mem_s

/-- If `k ∉ S`, then as `δ ≤ |x - k/n|`, we have the inequality `1 ≤ δ^-2 * (x - k/n)^2`.
This particular formulation will be helpful later.
-/
theorem le_of_mem_s_compl {f : C(I, ℝ)} {ε : ℝ} {h : 0 < ε} {n : ℕ} {x : I} {k : Fin (n + 1)}
    (m : k ∈ s f ε h n xᶜ) : (1 : ℝ) ≤ δ f ε h ^ (-2 : ℤ) * (x - k/ₙ) ^ 2 :=
  by
  simp only [Finset.mem_compl, not_lt, Set.mem_toFinset, Set.mem_setOf_eq, S] at m
  rw [zpow_neg, ← div_eq_inv_mul, zpow_two, ← pow_two, one_le_div (pow_pos δ_pos 2), sq_le_sq,
    abs_of_pos δ_pos]
  rwa [dist_comm] at m
#align bernstein_approximation.le_of_mem_S_compl bernsteinApproximation.le_of_mem_s_compl

end bernsteinApproximation

open bernsteinApproximation

open BoundedContinuousFunction

open Filter

open Topology

/-- The Bernstein approximations
```
∑ k : fin (n+1), f (k/n : ℝ) * n.choose k * x^k * (1-x)^(n-k)
```
for a continuous function `f : C([0,1], ℝ)` converge uniformly to `f` as `n` tends to infinity.

This is the proof given in [Richard Beals' *Analysis, an introduction*][beals-analysis], §7D,
and reproduced on wikipedia.
-/
theorem bernsteinApproximation_uniform (f : C(I, ℝ)) :
    Tendsto (fun n : ℕ => bernsteinApproximation n f) atTop (𝓝 f) :=
  by
  simp only [metric.nhds_basis_ball.tendsto_right_iff, Metric.mem_ball, dist_eq_norm]
  intro ε h
  let δ := δ f ε h
  have nhds_zero := tendsto_const_div_atTop_nhds_0_nat (2 * ‖f‖ * δ ^ (-2 : ℤ))
  filter_upwards [nhds_zero.eventually (gt_mem_nhds (half_pos h)),
    eventually_gt_at_top 0]with n nh npos'
  have npos : 0 < (n : ℝ) := by exact_mod_cast npos'
  -- Two easy inequalities we'll need later:
  have w₁ : 0 ≤ 2 * ‖f‖ := mul_nonneg (by norm_num) (norm_nonneg f)
  have w₂ : 0 ≤ 2 * ‖f‖ * δ ^ (-2 : ℤ) := mul_nonneg w₁ (zpow_neg_two_nonneg _)
  -- As `[0,1]` is compact, it suffices to check the inequality pointwise.
  rw [ContinuousMap.norm_lt_iff _ h]
  intro x
  -- The idea is to split up the sum over `k` into two sets,
  -- `S`, where `x - k/n < δ`, and its complement.
  let S := S f ε h n x
  calc
    |(bernsteinApproximation n f - f) x| = |bernsteinApproximation n f x - f x| := rfl
    _ = |bernsteinApproximation n f x - f x * 1| := by rw [mul_one]
    _ = |bernsteinApproximation n f x - f x * ∑ k : Fin (n + 1), bernstein n k x| := by
      rw [bernstein.probability]
    _ = |∑ k : Fin (n + 1), (f k/ₙ - f x) * bernstein n k x| := by
      simp [bernsteinApproximation, Finset.mul_sum, sub_mul]
    _ ≤ ∑ k : Fin (n + 1), |(f k/ₙ - f x) * bernstein n k x| := (Finset.abs_sum_le_sum_abs _ _)
    _ = ∑ k : Fin (n + 1), |f k/ₙ - f x| * bernstein n k x := by
      simp_rw [abs_mul, abs_eq_self.mpr bernstein_nonneg]
    _ = (∑ k in S, |f k/ₙ - f x| * bernstein n k x) + ∑ k in Sᶜ, |f k/ₙ - f x| * bernstein n k x :=
      (S.sum_add_sum_compl _).symm
    -- We'll now deal with the terms in `S` and the terms in `Sᶜ` in separate calc blocks.
        _ <
        ε / 2 + ε / 2 :=
      (add_lt_add_of_le_of_lt _ _)
    _ = ε := add_halves ε

  ·-- We now work on the terms in `S`: uniform continuity and `bernstein.probability`
    -- quickly give us a bound.
    calc
      (∑ k in S, |f k/ₙ - f x| * bernstein n k x) ≤ ∑ k in S, ε / 2 * bernstein n k x :=
        Finset.sum_le_sum fun k m =>
          mul_le_mul_of_nonneg_right (le_of_lt (lt_of_mem_S m)) bernstein_nonneg
      _ = ε / 2 * ∑ k in S, bernstein n k x := by rw [Finset.mul_sum]
      -- In this step we increase the sum over `S` back to a sum over all of `fin (n+1)`,
          -- so that we can use `bernstein.probability`.
          _ ≤
          ε / 2 * ∑ k : Fin (n + 1), bernstein n k x :=
        (mul_le_mul_of_nonneg_left (Finset.sum_le_univ_sum_of_nonneg fun k => bernstein_nonneg)
          (le_of_lt (half_pos h)))
      _ = ε / 2 := by rw [bernstein.probability, mul_one]

  ·-- We now turn to working on `Sᶜ`: we control the difference term just using `‖f‖`,
    -- and then insert a `δ^(-2) * (x - k/n)^2` factor
    -- (which is at least one because we are not in `S`).
    calc
      (∑ k in Sᶜ, |f k/ₙ - f x| * bernstein n k x) ≤ ∑ k in Sᶜ, 2 * ‖f‖ * bernstein n k x :=
        Finset.sum_le_sum fun k m =>
          mul_le_mul_of_nonneg_right (f.dist_le_two_norm _ _) bernstein_nonneg
      _ = 2 * ‖f‖ * ∑ k in Sᶜ, bernstein n k x := by rw [Finset.mul_sum]
      _ ≤ 2 * ‖f‖ * ∑ k in Sᶜ, δ ^ (-2 : ℤ) * (x - k/ₙ) ^ 2 * bernstein n k x :=
        (mul_le_mul_of_nonneg_left
          (Finset.sum_le_sum fun k m =>
            by
            conv_lhs => rw [← one_mul (bernstein _ _ _)]
            exact mul_le_mul_of_nonneg_right (le_of_mem_S_compl m) bernstein_nonneg)
          w₁)
      -- Again enlarging the sum from `Sᶜ` to all of `fin (n+1)`
          _ ≤
          2 * ‖f‖ * ∑ k : Fin (n + 1), δ ^ (-2 : ℤ) * (x - k/ₙ) ^ 2 * bernstein n k x :=
        (mul_le_mul_of_nonneg_left
          (Finset.sum_le_univ_sum_of_nonneg fun k =>
            mul_nonneg (mul_nonneg (zpow_neg_two_nonneg _) (sq_nonneg _)) bernstein_nonneg)
          w₁)
      _ = 2 * ‖f‖ * δ ^ (-2 : ℤ) * ∑ k : Fin (n + 1), (x - k/ₙ) ^ 2 * bernstein n k x := by
        conv_rhs =>
          rw [mul_assoc, Finset.mul_sum]
          simp only [← mul_assoc]
      -- `bernstein.variance` and `x ∈ [0,1]` gives the uniform bound
          _ =
          2 * ‖f‖ * δ ^ (-2 : ℤ) * x * (1 - x) / n :=
        by
        rw [variance npos]
        ring
      _ ≤ 2 * ‖f‖ * δ ^ (-2 : ℤ) / n :=
        ((div_le_div_right npos).mpr <| by
          refine' mul_le_of_le_of_le_one' (mul_le_of_le_one_right w₂ _) _ _ w₂ <;> unit_interval)
      _ < ε / 2 := nh

#align bernstein_approximation_uniform bernsteinApproximation_uniform


import algebra.field
import gtm106.weierstrass_equation.linear_change_of_variable.basic
import gtm106.weierstrass_equation.linear_change_of_variable.change_curve
import gtm106.weierstrass_equation.linear_change_of_variable.change_point
import tactic

namespace linear_change_of_variable

def is_translation {K : Type*} [field K] (C : linear_change_of_variable K)
:= C.u = 1 ∧ C.s = 0

def is_scale {K : Type*} [field K] (C : linear_change_of_variable K)
:= C.r = 0 ∧ C.s = 0 ∧ C.t = 0

def is_shear {K : Type*} [field K] (C : linear_change_of_variable K)
:= C.u = 1 ∧ C.r = 0 ∧ C.t = 0

def mk_translation {K : Type*} [field K] (r t : K) : linear_change_of_variable K
:= ⟨ 1, r, 0, t, by simp ⟩

def mk_scale {K : Type*} [field K] (u : K) (hu : u ≠ 0) : linear_change_of_variable K
:= ⟨ u, 0, 0, 0, hu ⟩

def mk_shear {K : Type*} [field K] (s : K) : linear_change_of_variable K
:= ⟨ 1, 0, s, 0, by simp ⟩

@[simp]
lemma mk_translation.sound {K : Type*} [field K] (r t : K)
: is_translation (mk_translation r t) :=
begin
  simp [mk_translation, is_translation],
end

@[simp]
lemma mk_scale.sound {K : Type*} [field K] (u : K) (hu : u ≠ 0)
: is_scale (mk_scale u hu) :=
begin
  simp [mk_scale, is_scale],
end

@[simp]
lemma mk_shear.sound {K : Type*} [field K] (s : K)
: is_shear (mk_shear s) :=
begin
  simp [mk_shear, is_shear],
end

lemma decomposition' {K : Type*} [field K] (C : linear_change_of_variable K)
: C = ((mk_scale C.u C.hu).composite (mk_shear C.s)).composite (mk_translation C.r C.t) :=
begin
  simp [mk_scale, mk_shear, mk_translation, composite, ext_iff],
end

lemma decomposition {K : Type*} [field K] (C : linear_change_of_variable K)
: ∃ (C1 C2 C3 : linear_change_of_variable K),
is_scale C1 ∧ is_shear C2 ∧ is_translation C3 ∧ C = (C1.composite C2).composite C3 :=
begin
  use [mk_scale C.u C.hu, mk_shear C.s, mk_translation C.r C.t],
  rw ← decomposition' C,
  simp,
end

end linear_change_of_variable


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.coeff
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# Theory of univariate polynomials

The main results are `induction_on` and `as_sum`.
-/

namespace polynomial

theorem sum_C_mul_X_eq {R : Type u} [semiring R] (p : polynomial R) :
    (finsupp.sum p fun (n : ℕ) (a : R) => coe_fn C a * X ^ n) = p :=
  Eq.trans
    (finset.sum_congr rfl fun (n : ℕ) (hn : n ∈ finsupp.support p) => Eq.symm single_eq_C_mul_X)
    (finsupp.sum_single p)

theorem sum_monomial_eq {R : Type u} [semiring R] (p : polynomial R) :
    (finsupp.sum p fun (n : ℕ) (a : R) => coe_fn (monomial n) a) = p :=
  sorry

protected theorem induction_on {R : Type u} [semiring R] {M : polynomial R → Prop}
    (p : polynomial R) (h_C : ∀ (a : R), M (coe_fn C a))
    (h_add : ∀ (p q : polynomial R), M p → M q → M (p + q))
    (h_monomial : ∀ (n : ℕ) (a : R), M (coe_fn C a * X ^ n) → M (coe_fn C a * X ^ (n + 1))) : M p :=
  sorry

/--
To prove something about polynomials,
it suffices to show the condition is closed under taking sums,
and it holds for monomials.
-/
protected theorem induction_on' {R : Type u} [semiring R] {M : polynomial R → Prop}
    (p : polynomial R) (h_add : ∀ (p q : polynomial R), M p → M q → M (p + q))
    (h_monomial : ∀ (n : ℕ) (a : R), M (coe_fn (monomial n) a)) : M p :=
  polynomial.induction_on p (h_monomial 0) h_add
    fun (n : ℕ) (a : R) (h : M (coe_fn C a * X ^ n)) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (M (coe_fn C a * X ^ (n + 1)))) (Eq.symm single_eq_C_mul_X)))
        (h_monomial (n + 1) a)

theorem coeff_mul_monomial {R : Type u} [semiring R] (p : polynomial R) (n : ℕ) (d : ℕ) (r : R) :
    coeff (p * coe_fn (monomial n) r) (d + n) = coeff p d * r :=
  sorry

theorem coeff_monomial_mul {R : Type u} [semiring R] (p : polynomial R) (n : ℕ) (d : ℕ) (r : R) :
    coeff (coe_fn (monomial n) r * p) (d + n) = r * coeff p d :=
  sorry

-- This can already be proved by `simp`.

theorem coeff_mul_monomial_zero {R : Type u} [semiring R] (p : polynomial R) (d : ℕ) (r : R) :
    coeff (p * coe_fn (monomial 0) r) d = coeff p d * r :=
  coeff_mul_monomial p 0 d r

-- This can already be proved by `simp`.

theorem coeff_monomial_zero_mul {R : Type u} [semiring R] (p : polynomial R) (d : ℕ) (r : R) :
    coeff (coe_fn (monomial 0) r * p) d = r * coeff p d :=
  coeff_monomial_mul p 0 d r

end Mathlib


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.tensor_algebra.basic
import ring_theory.graded_algebra.basic

/-!
# Results about the grading structure of the tensor algebra

The main result is `tensor_algebra.graded_algebra`, which says that the tensor algebra is a
ℕ-graded algebra.
-/

namespace tensor_algebra
variables {R M : Type*} [comm_semiring R] [add_comm_monoid M] [module R M]

open_locale direct_sum

variables (R M)

/-- A version of `tensor_algebra.ι` that maps directly into the graded structure. This is
primarily an auxiliary construction used to provide `tensor_algebra.graded_algebra`. -/
def graded_algebra.ι : M →ₗ[R] ⨁ i : ℕ, ↥((ι R : M →ₗ[_] _).range ^ i) :=
direct_sum.lof R ℕ (λ i, ↥((ι R : M →ₗ[_] _).range ^ i)) 1
  ∘ₗ (ι R).cod_restrict _ (λ m, by simpa only [pow_one] using linear_map.mem_range_self _ m)

lemma graded_algebra.ι_apply (m : M) :
  graded_algebra.ι R M m =
    direct_sum.of (λ i, ↥((ι R : M →ₗ[_] _).range ^ i)) 1
      (⟨ι R m, by simpa only [pow_one] using linear_map.mem_range_self _ m⟩) := rfl

variables {R M}

/-- The tensor algebra is graded by the powers of the submodule `(tensor_algebra.ι R).range`. -/
instance graded_algebra :
  graded_algebra ((^) (ι R : M →ₗ[R] tensor_algebra R M).range : ℕ → submodule R _) :=
graded_algebra.of_alg_hom _
  (lift R $ graded_algebra.ι R M)
  (begin
    ext m,
    dsimp only [linear_map.comp_apply, alg_hom.to_linear_map_apply, alg_hom.comp_apply,
      alg_hom.id_apply],
    rw [lift_ι_apply, graded_algebra.ι_apply R M, direct_sum.coe_alg_hom_of, subtype.coe_mk],
  end)
  (λ i x, begin
    cases x with x hx,
    dsimp only [subtype.coe_mk, direct_sum.lof_eq_of],
    refine submodule.pow_induction_on_left' _
      (λ r, _) (λ x y i hx hy ihx ihy, _) (λ m hm i x hx ih, _) hx,
    { rw [alg_hom.commutes, direct_sum.algebra_map_apply], refl },
    { rw [alg_hom.map_add, ihx, ihy, ←map_add], refl },
    { obtain ⟨_, rfl⟩ := hm,
      rw [alg_hom.map_mul, ih, lift_ι_apply, graded_algebra.ι_apply R M, direct_sum.of_mul_of],
      exact direct_sum.of_eq_of_graded_monoid_eq (sigma.subtype_ext (add_comm _ _) rfl) }
  end)

end tensor_algebra


/-
Copyright (c) 2021 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky

! This file was ported from Lean 3 source module data.fintype.list
! leanprover-community/mathlib commit 9003f28797c0664a49e4179487267c494477d853
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Fintype.Basic
import Mathlib.Data.Finset.Powerset

/-!

# Fintype instance for nodup lists

The subtype of `{l : List α // l.nodup}` over a `[Fintype α]`
admits a `Fintype` instance.

## Implementation details
To construct the `Fintype` instance, a function lifting a `Multiset α`
to the `Finset (list α)` that can construct it is provided.
This function is applied to the `Finset.powerset` of `Finset.univ`.

In general, a `DecidableEq` instance is not necessary to define this function,
but a proof of `(List.permutations l).nodup` is required to avoid it,
which is a TODO.

-/

variable {α : Type _} [DecidableEq α]

open List

namespace Multiset

/-- The `Finset` of `l : List α` that, given `m : Multiset α`, have the property `⟦l⟧ = m`.
-/
def lists : Multiset α → Finset (List α) := fun s =>
  Quotient.liftOn s (fun l => l.permutations.toFinset) fun l l' (h : l ~ l') => by
    ext sl
    simp only [mem_permutations, List.mem_toFinset]
    exact ⟨fun hs => hs.trans h, fun hs => hs.trans h.symm⟩
#align multiset.lists Multiset.lists

@[simp]
theorem lists_coe (l : List α) : lists (l : Multiset α) = l.permutations.toFinset :=
  rfl
#align multiset.lists_coe Multiset.lists_coe

@[simp]
theorem mem_lists_iff (s : Multiset α) (l : List α) : l ∈ lists s ↔ s = ⟦l⟧ := by
  induction s using Quotient.inductionOn
  simpa using perm_comm
#align multiset.mem_lists_iff Multiset.mem_lists_iff

end Multiset

instance fintypeNodupList [Fintype α] : Fintype { l : List α // l.Nodup } :=
  Fintype.subtype ((Finset.univ : Finset α).powerset.bunionᵢ fun s => s.val.lists) fun l => by
    suffices (∃ a : Finset α, a.val = ↑l) ↔ l.Nodup by simpa
    constructor
    · rintro ⟨s, hs⟩
      simpa [← Multiset.coe_nodup, ← hs] using s.nodup
    · intro hl
      refine' ⟨⟨↑l, hl⟩, _⟩
      simp
#align fintype_nodup_list fintypeNodupList


/-
© 2021 by the Rector and Visitors of the University of Virginia
-/

import .lin2kcoord

/-
This file tests and illustrates the use of lin2kcoord.lean.
Note: When writing and proving propositions here, be sure
to explicitly declare the types of scalars and tuples. In
this file, we've let K = ℚ, the rationals. If you make the
mistake of writing 5 instead of (5 : ℚ), for example, you
might run into mysterious failures to simplify expressions.
-/

-- Define a few 2D values in ℚ × ℚ
def v1 := ((1, 1) : ℚ × ℚ)
def v2 := ((-1,1) : ℚ × ℚ)

/-
Test the addition and scalar multiplication
operators provided by the module typeclass
-/
def v3 := v1 + v2       -- expect (0,2) : ℚ × ℚ
def v4 := (5 : ℚ) • v3  -- expect (0,10) : ℚ × ℚ

-- element addition, abstract now
example : v3 = (0,2) :=
begin
unfold v1 v2 v3,
simp,
trivial,
end

example : v4 = ((0,10) : ℚ × ℚ) :=
begin
unfold v4 v3 v2 v1,
norm_num,
end


-- Chapter 2. Love Letters Called Formulas

import init.data.list.lemmas init.data.nat.lemmas init.data.list.basic init.data.int.order
import tactic.norm_num tactic.tauto tactic tactic.basic
import ..common ..list ..factorize

open tactic

local attribute [simp, reducible] nat.factors
local attribute [simp, reducible] ite

example: 1024 = 2^10 := rfl
#eval divisors 1024
-- TIMEOUT
-- lemma divisors_of_1024: divisors 1024 = [1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024] := begin
-- norm_num,
-- reflexivity,
-- end

#eval (divisors 1024).length -- = 11

#eval (divisors 1024).sum -- 2047

#print nat.prime -- the definition of primes
example: ¬ (nat.prime 1) := begin
unfold nat.prime, intro h, let h:=h.left,
have: ¬ (2 ≤ 1), from dec_trivial, contradiction
end

-- Regarding `1` a prime brakes prime-decomposition uniqueness
example: 24=2*2*2*3 ∧ 24=1*2*2*2*3 ∧ 24=1*1*2*2*2*3 := by repeat {split}; reflexivity

example {x: ℤ}: x = -3 -> abs(-x) = 3 := begin
intro h,
calc abs(-x) = abs(-(-3)): by rw [h]
... = abs(3): rfl
... = 3: rfl
end

section sec_2_7
-- Problem 2.7:
-- Let n: ℕ ≥ 1, show how to derive "the sum of n's divisors".
@[simp, reducible]
def sumdiv (n: ℕ) := (divisors n).sum
#eval sumdiv 1024 -- = 2047
#eval sumdiv 6 -- = 12

open pnat
open decidable

-- sum_pow (n, e) = Σ n^k (k = 0...e)
--   For notational bravity, recall geom p=(n, e) = [n^0, n^1, n^e],  abbr. <| p |>
@[simp, reducible]
def sum_pow (p: ℕ × ℕ) := <| p |>.sum

#eval sum_pow (2, 10) -- = 2047

-- A wrong equation:
--  let n = factorize n = p1^b1 * p2^b2 * ... pm^bm, where
--    pi: ℙ, bi ≥ 1,
--  sumdiv n = (sum_pow p1 b1) + ... + (sum_pow pm bm) = Σ(sum_pow pi bi) (i=1..m) :: wrong!
@[simp, reducible]
def sum_sum_pow (n: ℕ) := (list.map sum_pow (factorize n)).sum -- shorthand
#eval sum_sum_pow 6 -- = 7

def wrong_eqn := ∀ n, sumdiv n = sum_sum_pow n

-- Show wrong_eqn is indeed wrong, by
--  sumdiv 6 = 12 ≠ sum_sum_pow 6 = 7

-- I'll excessively use `factorize 6`, for which dumb `simp factorize 6` timeouts;
-- so, hand-reproduce the outcome here
lemma factorize_6: factorize 6 = [(2,1), (3,1)] := begin
unfold factorize,
have: nat.factors 6 = [2, 3], {
  unfold nat.factors,
  have: nat.min_fac (4+2) = 2, {
    unfold nat.min_fac,
    have: 2 ∣ 4, by norm_num,
    have: ite (2 ∣ 4) 2 _ = 2, by apply if_pos; assumption, assumption,
  }, rw this, clear this,
  simp,
  have: nat.factors 3 = [3], {
    unfold nat.factors,
    have: nat.min_fac 3 = 3, {
      unfold nat.min_fac,
      have: (nat.min_fac_aux (1 + 2) 3) = 3, {
        rw nat.min_fac_aux,
        reflexivity,
      }, rw this, clear this,
      have: ¬ (2 ∣ 1), by norm_num,
      have: ite (2 ∣ 1) _ 3 = 3, by apply if_neg; assumption, assumption,
    }, rw this, clear this,
    simp,
  },
  have triv3: (nat.succ (4/2)) = 3, by reflexivity,
  rw [triv3, this],
}, rw this, clear this,
simp,
have: list.count 2 [3] = 0, by reflexivity, rw this, clear this,
have: list.count 3 [2, 3] = 1, by reflexivity, rw this, clear this,
have: list.nodup [(2,1), (3,1)], by norm_num,
apply list.erase_dup_eq_self.mpr this,
end

lemma sumdiv_6: sumdiv 6 = 12 := begin
unfold sumdiv, unfold divisors,
rw factorize_6,
rw divisors_aux,
simp,
repeat {rw list.map},
simp only [list.range, list.range_core],
norm_num,
end

lemma sum_sum_pow_6: sum_sum_pow 6 = 7 := begin
unfold sum_sum_pow, rw factorize_6, reflexivity,
end

theorem wrong_eqn_is_wrong: ¬ wrong_eqn := begin
intro h,
specialize h 6,
rw [sumdiv_6, sum_sum_pow_6] at h,
have: 12 ≠ 7, from dec_trivial,
contradiction,
end

-- Theorem:
--  let n = factorize n = p1^b1 * p2^b2 * ... pm^bm, as above,
--  sumdiv n = (sum_pow p1 b1) * ... * (sum_pow pm bm) = Π(sum_pow pi bi) (i=1..m)
@[simp, reducible]
def prod_sum_pow (n: ℕ) := (list.map sum_pow (factorize n)).prod

theorem sumdiv_eqn: ∀ n, sumdiv n = prod_sum_pow n := begin
intro,
rw [sumdiv, divisors],
rw [prod_sum_pow],
induction (factorize n), reflexivity, {
  rw divisors_aux,
  rw tensor_sum,
  rw ih,
  rw list.map_cons,
  rw list.prod_cons,
}
end

end sec_2_7

section sec_2_8
-- Section 2.8: elaborates Thm 2.7

-- Theorem (geometric series):
--  1 + x + x^2 + ... x^n = (1-x^(n+1))/(1-x), (x ≠ 1)
theorem geom_sum (x: ℤ) (n: ℕ) (h: x ≠ 1): <| (x, n) |>.sum = (1 - x^(n+1))/(1-x) := begin
have h': 1-x ≠ 0, by_contradiction hc, {
  simp at hc,
  have: x=1, by rw add_neg_eq_zero.mp hc,
  contradiction,
},
have: (1 - x^(n+1)) = (1-x)*(<| (x, n) |>.sum), {
  induction n,
  case nat.zero {
    simp,
  },
  case nat.succ: n ih {
    rw geom_succ (x, n),
    rw list.sum_cons,
    have: (x, n).fst = x, by reflexivity, rw this, clear this,
    rw mul_add,
    rw scalar_l_sum,
    rw [<-mul_assoc (1-x), mul_comm (1-x) x],
    rw mul_assoc x (1-x) (list.sum _),
    rw <-ih,
    repeat {rw pow_succ},
    simp,
    rw [mul_add, <-add_assoc, mul_one, add_comm (-x) x, add_neg_self],
    rw mul_neg_eq_neg_mul_symm,
    rw zero_add,
  },
},
symmetry,
rw [this, mul_comm],
rw int.mul_div_cancel (<|(x, n)|>.sum) h',
end

-- Shorthand for (1 - x^(n+1))/(1-x)
@[simp]
def gs (p: ℤ × ℕ) := (1 - p.1^(p.2+1))/(1-p.1)

-- I will type-cast ℕ <- from&to -> ℤ
lemma gs_nonneg {p: ℤ × ℕ} (h: p.1 ≥ 0): (gs p) ≥ 0 := begin
unfold gs,
have: p.1 = 1 ∨ p.1 ≠ 1, by apply decidable.em,
cases this,
  rw this, simp,
  rw <-geom_sum p.1 p.2 this, simp, clear this,
  have hran: ∀ m ∈ list.range (1 + p.snd), pow p.1 m ≥ 0,{
    intros, apply pow_nonneg, assumption,
  },
  have: ∀ z:ℤ, z ∈ (list.map (pow p.fst) (list.range (1 + p.snd))) -> z ≥ 0, by tidy,
  apply sum_nonneg, assumption,
end

@[simp]
def nonneg_gs_to_nat (p: ℤ × ℕ) (h: p.1 ≥ 0): ℕ := nonneg_to_nat (gs p) (gs_nonneg h)

@[simp]
def gs_nat (p: ℕ × ℕ): ℕ := nonneg_gs_to_nat (↑p: ℤ × ℕ) (by tidy)

lemma gs_eq_gs_nat {p: ℕ × ℕ}: gs ↑p = gs_nat p := begin
have h: (↑p: (ℤ × ℕ)).1 ≥ 0, by tidy,
have: gs ↑p ≥ 0, from gs_nonneg h,
rw gs_nat,
rw nonneg_gs_to_nat,
apply nonneg_to_nat_eq,
end

lemma int_one {x: ℤ}: 1=x ↔ 1-x = 0 := begin
apply iff.intro,
  omega,
  omega,
end
lemma int_ne_one {x: ℤ}: 1 ≠ x ↔ 1-x ≠ 0 := begin
apply iff.intro,
  omega,
  omega,
end

lemma geom_sum_cast (x: ℕ) (n: ℕ): (<| (x, n) |>.sum: ℤ) = <| ((x: ℤ), n) |>.sum := begin
induction n with n ih, {
  simp,
}, {
  rw geom_succ (x, n), rw geom_succ (↑x, n),
  rw list.sum_cons, rw list.sum_cons,
  rw scalar_l_sum, rw scalar_l_sum,
  rw <-ih,
  norm_cast,
}
end

theorem geom_sum_nat (x: ℕ) (n: ℕ) (h: x ≠ 1): (<| (x, n) |>.sum: ℤ) = (1 - (x:ℤ)^(n+1))/(1-x) := begin
have h': (1:ℤ) + (-(x: ℤ)) ≠ 0, {
  apply int_ne_one.mp,
  symmetry, assumption_mod_cast,
},
have h_int: (x: ℤ) ≠ 1, by tidy,
rw <-geom_sum (x: ℤ) n h_int,
rw geom_sum_cast x n,
end

-- Lift the theorems to lists (of prime powers)
lemma geom_sums {l: list (ℤ × ℕ)} (h: ∀ p: ℤ × ℕ, p ∈ l -> p.1 ≠ 1):
  list.map (λ (x: ℤ × ℕ), <| x |>.sum) l = list.map gs l := begin
induction l, reflexivity,
case list.cons: hd tl ih {
  have hps: hd.fst ≠ 1 ∧ ∀ (x : ℤ × ℕ), x ∈ tl → x.fst ≠ 1, from list.forall_mem_cons.mp h,
  repeat {rw list.map_cons},
  have hhd': hd.1 ≠ 1, from hps.1,
  have hhd: (hd.1 : ℤ) ≠ 1, by assumption_mod_cast, clear hhd',
  rw geom_sum (hd.1: ℤ) hd.2 hhd,
  rw ih hps.2,
  reflexivity,
}
end

lemma geom_sums_nat {l: list (ℕ × ℕ)} (h: ∀ p: ℕ × ℕ, p ∈ l -> p.1 ≠ 1):
  (list.map (λ (x: ℕ × ℕ), <| x |>.sum) l) = list.map (λ p:ℕ × ℕ, gs_nat p) l := begin
induction l, reflexivity,
case list.cons: hd tl ih {
  have hps: hd.fst ≠ 1 ∧ ∀ (x : ℕ × ℕ), x ∈ tl → x.fst ≠ 1, from list.forall_mem_cons.mp h,
  repeat {rw list.map_cons},
  have hhd': hd.1 ≠ 1, from hps.1,
  have hhd: (↑hd: ℤ × ℕ).1 ≠ 1, {
    have: ↑(hd.1) = (↑hd: ℤ × ℕ).1, by tidy,
    intro hc, rw <-this at hc, clear this,
    have: ↑(hd.1) = (1: ℤ) -> hd.1 = 1, by tidy,
    exact hhd' (this hc),
  }, clear hhd',
  rw ih hps.2,
  norm_cast,
  apply and.intro, {
    have: (<|hd|>.sum : ℤ) = (gs_nat hd: ℤ), {
      rw <-gs_eq_gs_nat,
      rw gs,
      rw <-geom_sum _ _ hhd,
      rw geom_sum_cast,
      have: (↑(hd.fst), hd.snd) = ((↑hd: ℤ × ℕ).fst, (↑hd: ℤ × ℕ).snd), by tidy,
      rw this,
    },
    assumption_mod_cast,
  }, {
    reflexivity,
  }
}
end

-- Theorem 2.8:
--  sumdiv n = Π (1-p^(m+1)/(1-p)), (p, m) ∈ factorize n
theorem sumdiv_eqn': ∀ n, sumdiv n = (list.map (λ p:ℕ × ℕ, gs_nat p) (factorize n)).prod := begin
intro,
unfold sumdiv, unfold divisors,
have all_ne_1: ∀ p: ℕ × ℕ, p ∈ (factorize n) -> p.1 ≠ 1, by {
  intros p h,
  cases p,
  have: nat.prime p_fst, from factors_are_prime h,
  simp,
  apply nat.prime.ne_one, assumption,
},
rw <- geom_sums_nat all_ne_1,

induction (factorize n), reflexivity,
{
  rw divisors_aux,
  rw tensor_sum,
  rw ih,
  rw list.map_cons,
  rw list.prod_cons,
}
end
end sec_2_8

section sec_2_9
-- Section 2.9 "At the School Library"
--  2.9.1: Equations and Identities,

-- "x - 1 = 0" is an equation,
example: ∃ x: ℤ, x - 1 = 0 := ⟨1, rfl⟩ -- x = 1 ↔ x - 1 = 0

-- while "2(x-1) = 2x - 2" is an identity.
example: ∀ x: ℤ, 2*(x-1) = 2*x - 2 := begin
intros, apply mul_add,
end

-- A rewrite chain of identities
lemma sub_left_comm (a b c: ℤ): a - b - c = a - c - b := begin
rw sub_eq_add_neg a b,
rw sub_eq_add_neg _ c,
norm_num,
end

theorem square_completion_one (x: ℤ): (x+1)*(x-1) = x^2 - 1 := calc
  (x+1)*(x-1) =
  (x+1)*x - (x+1)*1: by rw mul_sub
  ... = x*x + 1*x -(x+1)*1: by rw add_mul
  ... = x*x + 1*x - x*1 - 1*1: by rw [add_mul, sub_add_eq_sub_sub_swap, sub_left_comm]
  ... = x^2 + x - x - 1: by rw [<-pow_two, mul_one, one_mul, one_mul]
  ... = x^2 - 1: by rw [sub_eq_add_neg _ x, add_assoc (x^2), add_neg_self x, add_zero]
.
-- This is an identity: holds for all x:
#check square_completion_one

-- Square-complete x^2 - 5*x + 6
theorem square_completion_2_and_3 (x: ℤ): x^2 - 5*x + 6 = (x-2)*(x-3) := by ring.
-- if it's an equation (of RHS = 0), the solutions are 2&3
example (x: ℤ): x^2 - 5*x + 6 = 0 -> x=2 ∨ x=3 := begin
rw square_completion_2_and_3 x,
intro h,
simp  at h,
omega,
end

-- 2.9.2: Product Forms and Sum Forms
--  elementary quadratic equations over a general (commutative) ring R
variables {R: Type}
variable [comm_ring R]
variables {x α β: R}

-- A complete-form equation of R:
#check (x-α)*(x-β) = 0
-- Expand this one-step into: x^2 - α*x - β*x +α*β
theorem expand1: (x-α)*(x-β) = x^2 - α*x - β*x +α*β := begin
norm_num,
repeat { rw mul_add <|> rw add_mul },
rw pow_two,
tidy,
rw mul_comm x β,
apply add_comm,
end
-- ... then, group the degree-1 terms:
theorem group1: x^2 - α*x - β*x +α*β = x^2 - (α+β)*x +α*β := begin
ring,
end
-- Confirm these two forms are equivalent:
theorem square_completion_id: (x-α)*(x-β) = 0 ↔ x^2 - (α+β)*x +α*β = 0 := begin
apply iff.intro, {
  intro h,
  rw pow_two,
  ring at h,
  rw sub_eq_neg_add at h,
  repeat {rw add_mul at h},
  rw add_mul,
  rw sub_eq_neg_add,
  rw neg_eq_neg_one_mul,
  rw mul_add,
  repeat {rw <-mul_assoc},
  repeat {rw <-neg_eq_neg_one_mul},
  rw mul_comm α β,
  rw add_comm (-α*x) _,
  rw add_comm (x*x) at h,
  assumption,
}, {
  intro h,
  rw pow_two at h,
  repeat {rw sub_mul <|> rw mul_sub},
  rw sub_eq_add_neg, rw neg_eq_neg_one_mul,
  rw mul_sub,
  repeat {rw <-neg_eq_neg_one_mul},
  rw neg_sub_neg,
  rw add_mul at h,
  rw sub_add_eq_sub_sub_swap at h,
  rw mul_comm β x at h,
  tidy,
}
end

end sec_2_9


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module order.heyting.regular
! leanprover-community/mathlib commit 09597669f02422ed388036273d8848119699c22f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.GaloisConnection

/-!
# Heyting regular elements

This file defines Heyting regular elements, elements of an Heyting algebra that are their own double
complement, and proves that they form a boolean algebra.

From a logic standpoint, this means that we can perform classical logic within intuitionistic logic
by simply double-negating all propositions. This is practical for synthetic computability theory.

## Main declarations

* `IsRegular`: `a` is Heyting-regular if `aᶜᶜ = a`.
* `Regular`: The subtype of Heyting-regular elements.
* `Regular.BooleanAlgebra`: Heyting-regular elements form a boolean algebra.

## References

* [Francis Borceux, *Handbook of Categorical Algebra III*][borceux-vol3]
-/

open Function

variable {α : Type _}

namespace Heyting

section HasCompl

variable [HasCompl α] {a : α}

/-- An element of an Heyting algebra is regular if its double complement is itself. -/
def IsRegular (a : α) : Prop :=
  aᶜᶜ = a
#align heyting.is_regular Heyting.IsRegular

protected theorem IsRegular.eq : IsRegular a → aᶜᶜ = a :=
  id
#align heyting.is_regular.eq Heyting.IsRegular.eq

instance IsRegular.decidablePred [DecidableEq α] : @DecidablePred α IsRegular := fun _ =>
  ‹DecidableEq α› _ _
#align heyting.is_regular.decidable_pred Heyting.IsRegular.decidablePred

end HasCompl

section HeytingAlgebra

variable [HeytingAlgebra α] {a b : α}

theorem isRegular_bot : IsRegular (⊥ : α) := by rw [IsRegular, compl_bot, compl_top]
#align heyting.is_regular_bot Heyting.isRegular_bot

theorem isRegular_top : IsRegular (⊤ : α) := by rw [IsRegular, compl_top, compl_bot]
#align heyting.is_regular_top Heyting.isRegular_top

theorem IsRegular.inf (ha : IsRegular a) (hb : IsRegular b) : IsRegular (a ⊓ b) := by
  rw [IsRegular, compl_compl_inf_distrib, ha.eq, hb.eq]
#align heyting.is_regular.inf Heyting.IsRegular.inf

theorem IsRegular.himp (ha : IsRegular a) (hb : IsRegular b) : IsRegular (a ⇨ b) := by
  rw [IsRegular, compl_compl_himp_distrib, ha.eq, hb.eq]
#align heyting.is_regular.himp Heyting.IsRegular.himp

theorem isRegular_compl (a : α) : IsRegular (aᶜ) :=
  compl_compl_compl _
#align heyting.is_regular_compl Heyting.isRegular_compl

protected theorem IsRegular.disjoint_compl_left_iff (ha : IsRegular a) : Disjoint (aᶜ) b ↔ b ≤ a :=
  by rw [← le_compl_iff_disjoint_left, ha.eq]
#align heyting.is_regular.disjoint_compl_left_iff Heyting.IsRegular.disjoint_compl_left_iff

protected theorem IsRegular.disjoint_compl_right_iff (hb : IsRegular b) : Disjoint a (bᶜ) ↔ a ≤ b :=
  by rw [← le_compl_iff_disjoint_right, hb.eq]
#align heyting.is_regular.disjoint_compl_right_iff Heyting.IsRegular.disjoint_compl_right_iff

-- See note [reducible non-instances]
/-- A Heyting algebra with regular excluded middle is a boolean algebra. -/
@[reducible]
def _root_.BooleanAlgebra.ofRegular (h : ∀ a : α, IsRegular (a ⊔ aᶜ)) : BooleanAlgebra α :=
  have : ∀ a : α, IsCompl a (aᶜ) := fun a =>
    ⟨disjoint_compl_right,
      codisjoint_iff.2 <| by erw [← (h a), compl_sup, inf_compl_eq_bot, compl_bot]⟩
  { ‹HeytingAlgebra α›,
    GeneralizedHeytingAlgebra.toDistribLattice with
    himp_eq := fun a b =>
      eq_of_forall_le_iff fun c => le_himp_iff.trans (this _).le_sup_right_iff_inf_left_le.symm
    inf_compl_le_bot := fun a => (this _).1.le_bot
    top_le_sup_compl := fun a => (this _).2.top_le }
#align boolean_algebra.of_regular BooleanAlgebra.ofRegular

variable (α)

/-- The boolean algebra of Heyting regular elements. -/
def Regular : Type _ :=
  { a : α // IsRegular a }
#align heyting.regular Heyting.Regular

variable {α}

namespace Regular

--Porting note: `val` and `prop` are new
/-- The coercion `Regular α → α` -/
@[coe] def val : Regular α → α :=
  Subtype.val

theorem prop : ∀ a : Regular α, IsRegular a.val := Subtype.prop

instance : Coe (Regular α) α := ⟨Regular.val⟩

theorem coe_injective : Injective ((↑) : Regular α → α) :=
  Subtype.coe_injective
#align heyting.regular.coe_injective Heyting.Regular.coe_injective

@[simp]
theorem coe_inj {a b : Regular α} : (a : α) = b ↔ a = b :=
  Subtype.coe_inj
#align heyting.regular.coe_inj Heyting.Regular.coe_inj

instance top : Top (Regular α) :=
  ⟨⟨⊤, isRegular_top⟩⟩

instance bot : Bot (Regular α) :=
  ⟨⟨⊥, isRegular_bot⟩⟩

instance inf : Inf (Regular α) :=
  ⟨fun a b => ⟨a ⊓ b, a.2.inf b.2⟩⟩

instance himp : HImp (Regular α) :=
  ⟨fun a b => ⟨a ⇨ b, a.2.himp b.2⟩⟩

instance hasCompl : HasCompl (Regular α) :=
  ⟨fun a => ⟨aᶜ, isRegular_compl _⟩⟩

@[simp, norm_cast]
theorem coe_top : ((⊤ : Regular α) : α) = ⊤ :=
  rfl
#align heyting.regular.coe_top Heyting.Regular.coe_top

@[simp, norm_cast]
theorem coe_bot : ((⊥ : Regular α) : α) = ⊥ :=
  rfl
#align heyting.regular.coe_bot Heyting.Regular.coe_bot

@[simp, norm_cast]
theorem coe_inf (a b : Regular α) : (↑(a ⊓ b) : α) = (a : α) ⊓ b :=
  rfl
#align heyting.regular.coe_inf Heyting.Regular.coe_inf

@[simp, norm_cast]
theorem coe_himp (a b : Regular α) : (↑(a ⇨ b) : α) = (a : α) ⇨ b :=
  rfl
#align heyting.regular.coe_himp Heyting.Regular.coe_himp

@[simp, norm_cast]
theorem coe_compl (a : Regular α) : (↑(aᶜ) : α) = (a : α)ᶜ :=
  rfl
#align heyting.regular.coe_compl Heyting.Regular.coe_compl

instance : Inhabited (Regular α) :=
  ⟨⊥⟩

instance : SemilatticeInf (Regular α) :=
  coe_injective.semilatticeInf _ coe_inf

instance boundedOrder : BoundedOrder (Regular α) :=
  BoundedOrder.lift ((↑) : Regular α → α) (fun _ _ => id) coe_top coe_bot

@[simp, norm_cast]
theorem coe_le_coe {a b : Regular α} : (a : α) ≤ b ↔ a ≤ b :=
  Iff.rfl
#align heyting.regular.coe_le_coe Heyting.Regular.coe_le_coe

@[simp, norm_cast]
theorem coe_lt_coe {a b : Regular α} : (a : α) < b ↔ a < b :=
  Iff.rfl
#align heyting.regular.coe_lt_coe Heyting.Regular.coe_lt_coe

/-- **Regularization** of `a`. The smallest regular element greater than `a`. -/
def toRegular : α →o Regular α :=
  ⟨fun a => ⟨aᶜᶜ, isRegular_compl _⟩, fun _ _ h =>
    coe_le_coe.1 <| compl_le_compl <| compl_le_compl h⟩
#align heyting.regular.to_regular Heyting.Regular.toRegular

@[simp, norm_cast]
theorem coe_toRegular (a : α) : (toRegular a : α) = aᶜᶜ :=
  rfl
#align heyting.regular.coe_to_regular Heyting.Regular.coe_toRegular

@[simp]
theorem toRegular_coe (a : Regular α) : toRegular (a : α) = a :=
  coe_injective a.2
#align heyting.regular.to_regular_coe Heyting.Regular.toRegular_coe

/-- The Galois insertion between `Regular.toRegular` and `coe`. -/
def gi : GaloisInsertion toRegular ((↑) : Regular α → α)
    where
  choice a ha := ⟨a, ha.antisymm le_compl_compl⟩
  gc _ b :=
    coe_le_coe.symm.trans <|
      ⟨le_compl_compl.trans, fun h => (compl_anti <| compl_anti h).trans_eq b.2⟩
  le_l_u _ := le_compl_compl
  choice_eq _ ha := coe_injective <| le_compl_compl.antisymm ha
#align heyting.regular.gi Heyting.Regular.gi

instance lattice : Lattice (Regular α) :=
  gi.liftLattice

@[simp, norm_cast]
theorem coe_sup (a b : Regular α) : (↑(a ⊔ b) : α) = ((a : α) ⊔ b)ᶜᶜ :=
  rfl
#align heyting.regular.coe_sup Heyting.Regular.coe_sup

instance : BooleanAlgebra (Regular α) :=
  { Regular.lattice, Regular.boundedOrder, Regular.himp,
    Regular.hasCompl with
    le_sup_inf := fun a b c =>
      coe_le_coe.1 <| by
        dsimp
        rw [sup_inf_left, compl_compl_inf_distrib]
    inf_compl_le_bot := fun a => coe_le_coe.1 <| disjoint_iff_inf_le.1 disjoint_compl_right
    top_le_sup_compl := fun a =>
      coe_le_coe.1 <| by
        dsimp
        rw [compl_sup, inf_compl_eq_bot, compl_bot]
    himp_eq := fun a b =>
      coe_injective
        (by
          dsimp
          rw [compl_sup, a.prop.eq]
          refine' eq_of_forall_le_iff fun c => le_himp_iff.trans _
          rw [le_compl_iff_disjoint_right, disjoint_left_comm]
          rw [b.prop.disjoint_compl_left_iff]) }

@[simp, norm_cast]
theorem coe_sdiff (a b : Regular α) : (↑(a \ b) : α) = (a : α) ⊓ bᶜ :=
  rfl
#align heyting.regular.coe_sdiff Heyting.Regular.coe_sdiff

end Regular

end HeytingAlgebra

variable [BooleanAlgebra α]

theorem isRegular_of_boolean : ∀ a : α, IsRegular a :=
  compl_compl
#align heyting.is_regular_of_boolean Heyting.isRegular_of_boolean

/-- A decidable proposition is intuitionistically Heyting-regular. -/
--Porting note: removed @[nolint decidable_classical]
theorem isRegular_of_decidable (p : Prop) [Decidable p] : IsRegular p :=
  propext <| Decidable.not_not
#align heyting.is_regular_of_decidable Heyting.isRegular_of_decidable

end Heyting