import Complexes.Structures.Quiver

/-- Serre's definition of an undirected graph. -/
class SerreGraph (V : Sort _) extends Quiver V where
  op : {A B : V} → (A ⟶ B) → (B ⟶ A)
  opInv : {A B : V} → (e : A ⟶ B) → op (op e) = e

attribute [reducible] SerreGraph.op
attribute [simp] SerreGraph.opInv

/-- Every `Quiver` can be turned into a `SerreGraph` by adding a formal inverse for each edge. -/
def Quiver.symmetrize {V : Sort _} (Q : Quiver V) : SerreGraph V :=
{ hom := λ A B => Q.hom A B ⊕ Q.hom B A,
  op := fun | .inl e => .inr e | .inr e => .inl e,
  opInv := fun | .inl _ => rfl | .inr _ => rfl }

namespace Path

variable {V : Sort _} [G : SerreGraph V] {A B C : V} (p : Path A B)

/-- The inverse of a path in a Serre graph. -/
def inverse {A B : V} : Path A B → Path B A
  | .nil => .nil
  | .cons e p => .snoc p.inverse (SerreGraph.op e)

@[simp] theorem inverse_snoc {A B : V} : (p : Path A B) → (e : B ⟶ C) →
  inverse (.snoc p e) = .cons (SerreGraph.op e) (inverse p)
  | .nil, e => rfl
  | .cons e' p', e => by dsimp [inverse]; rw [inverse_snoc p' e]

@[simp] theorem inverse_inv {A B : V} : (p : Path A B) → p.inverse.inverse = p
  | .nil => rfl
  | .cons e p' => by simp [inverse]; apply inverse_inv

@[simp] theorem inverse_append {A B C : V} : (p : Path A B) → (q : Path B C) →
    inverse (append p q) = .append (inverse q) (inverse p)
  | .nil, q => by simp [inverse]
  | p, .nil => by simp [inverse]
  | .cons _ p', .cons _ q' => by
    dsimp [inverse]
    rw [inverse_append p' _, append_snoc]
    rfl

theorem length_inverse {A B : V} : (p : Path A B) → p.inverse.length = p.length
  | .nil => rfl
  | .cons _ p' => by
    dsimp [inverse, length]
    rw [snoc_length]
    apply congrArg
    apply length_inverse

theorem first_eq_inv_last : {A B : V} →
    (p : Path A B) → p.first = p.inverse.last
  | _, _, .nil => rfl
  | _, _, .cons e p' => by simp [first, last, inverse, snoc, last_snoc]

theorem last_eq_inv_first :
    (p : Path A B) → p.last = p.inverse.first := by
    intro p
    let p' := p.inverse
    have pinv : p = p'.inverse := by simp
    rw [pinv, inverse_inv p']
    apply Eq.symm
    apply first_eq_inv_last

end Path

namespace Loop

variable {V : Sort _} [SerreGraph V] (A : V)

abbrev inv {A : V} : Loop A → Loop A := Path.inverse

@[simp] theorem inv_inv (l : Loop A) : l.inv.inv = l := by simp

-- alternative to using `Path.last`
abbrev prev : Loop A → V := λ l => (l.inv).next

def rotate : (l : Loop A) → Loop (l.next A)
  | .nil' A => .nil' A
  | .cons' _ _ _ e p => p.snoc e

def rotate' : (l : Loop A) → Loop (l.prev A) :=
  λ l => ((l |>.inv) |>.rotate) |>.inv

@[simp] theorem inv_rotate_inv (l : Loop A) :
  (rotate A l.inv).inv = rotate' A l := by simp [rotate']

@[simp] theorem prev_inv (l : Loop A) : (prev A l.inv) = next A l := by simp [prev]

@[simp] theorem next_inv (l : Loop A) : (next A l.inv) = prev A l := by simp

@[simp] theorem rotate_prev : (l : Loop A) → (l.rotate A).prev _ = A
  | .nil' _ => rfl
  | .cons' _ _ _ e p => by
    dsimp [prev, rotate, inv]
    rw [Path.inverse_snoc]
    rfl

@[simp] theorem rotate'_next (l : Loop A) : (l.rotate' A).next _ = A := by
  show prev _ (rotate _ l.inv) = A
  simp

@[simp] theorem rotate_rotate' : (l : Loop A) → rotate' _ (rotate A l) = cast (congrArg Loop $ Eq.symm $ rotate_prev A l) l
  | .nil' _ => rfl
  | .cons' _ _ _ e p => sorry

@[simp] theorem rotate'_rotate : (l : Loop A) → rotate _ (rotate' A l) = cast (congrArg Loop $ Eq.symm $ rotate'_next A l) l
  | .nil' _ => rfl
  | .cons' _ _ _ e p => sorry

theorem rotate'_inv_heq (l : Loop A) : HEq (rotate' A l.inv) (rotate A l).inv := by
  rw [← inv_rotate_inv A l.inv]
  congr 2 <;> rw [inv_inv]

theorem rotate_inv_heq (l : Loop A) : HEq (rotate A l.inv) (rotate' A l).inv := by
  rw [rotate', inv_inv]
  exact .refl _

theorem HEq.toEqCast {A B : Sort _} {a : A} {b : B} : (h : A = B) → HEq a b → a = h ▸ b
  | rfl, .refl _ => rfl

theorem rotate'_inv (l : Loop A) : (rotate' A l.inv) = (congrArg Loop $ prev_inv A l) ▸ (rotate A l).inv :=
  HEq.toEqCast (congrArg Loop $ prev_inv A l) (rotate'_inv_heq A l)

theorem rotate_inv (l : Loop A) : (rotate A l.inv) = (congrArg Loop $ next_inv A l) ▸ (rotate' A l).inv :=
  HEq.toEqCast (congrArg Loop $ next_inv A l) (rotate_inv_heq A l)

end Loop


import data.fintype.basic data.finset data.prod algebra.big_operators
import tactic

open_locale classical
noncomputable theory

@[ext] structure bigraph (α β:Type*):=
(A: finset α)
(B: finset β)
(E:α → β → Prop)

variables {α :Type*} {β :Type*}

def uncurried (G:bigraph α β):(α × β) → Prop:=
  function.uncurry (G.E)

@[simp] lemma recurry (G:bigraph α β){x : α × β}:
  (uncurried G) x=G.E x.fst x.snd:=
begin
  unfold uncurried,
  unfold function.uncurry,
end

def swap_inputs (E:α → β → Prop): β → α → Prop:=
  function.curry ((function.uncurry E) ∘ prod.swap)

@[simp] lemma swap_inputs' (E:α → β → Prop){a:α}{b:β}:
  swap_inputs E b a=E a b:=
begin
  unfold swap_inputs,
  simp only [eq_iff_iff],
  unfold function.uncurry,
  unfold function.curry,
  simp,
end

@[simp] lemma swap_inputs_invol (E:α → β → Prop):
  swap_inputs (swap_inputs E)=E:=
begin
  ext,
  simp,
end

def bigraph.swap (G:bigraph α β):bigraph β α:=
{
  A:=G.B,
  B:=G.A,
  E:=swap_inputs G.E,
}

@[simp] lemma bigraph.A_swap (G:bigraph α β):
  G.swap.A=G.B:=rfl

@[simp] lemma bigraph.B_swap (G:bigraph α β):
  G.swap.B=G.A:=rfl

@[simp] lemma bigraph.E_swap (G:bigraph α β):
  G.swap.E=swap_inputs G.E:=rfl

@[simp] lemma bigraph.swap_swap (G:bigraph α β):
  G.swap.swap=G:=
begin
  ext,
  unfold bigraph.swap,
  unfold bigraph.swap,
  dsimp; simp,
end

def edges  (G:bigraph α β): finset (α × β):=
  finset.filter (uncurried G) (finset.product G.A G.B)

@[simp] lemma mem_edges (G:bigraph α β){x:(α × β)}:
  x ∈ edges G ↔ (x.fst ∈ G.A ∧ x.snd ∈ G.B) ∧ G.E x.fst x.snd := by { unfold edges, simp }

def card_edges (G:bigraph α β): ℕ :=
  (edges G).card

lemma mem_edges_swap (G:bigraph α β) {x : β × α} :
  x ∈ edges G.swap ↔ x.swap ∈ edges G := by {simp, tauto}

lemma edges_swap (G:bigraph α β):
  edges G.swap = finset.image prod.swap (edges G):=
begin
  ext, rw [finset.mem_image, mem_edges_swap],
  split,
  { intro h1, use [a.swap, h1], simp },
  rintro ⟨ _, _, h⟩,
  rw ← h, rwa prod.swap_swap,
end

lemma card_edges_symm (G:bigraph α β):
  card_edges (bigraph.swap G)=card_edges G:=
begin
  change (edges (bigraph.swap G)).card=(edges G).card,
  apply nat.le_antisymm,
  { rw edges_swap, apply finset.card_image_le },
  rw ← bigraph.swap_swap G,
  rw bigraph.swap_swap G.swap,
  rw edges_swap,
  apply finset.card_image_le,
end

def left_fiber (G:bigraph α β)(b: β): finset α:=
  finset.filter (λ (a1:α), (uncurried G) (a1, b)) G.A

def right_fiber (G:bigraph α β)(a:α): finset β:=
  finset.filter (λ (b1:β), (uncurried G) (a, b1)) G.B

def left_fiber' (G:bigraph α β)(b: β): finset (α × β):=
  finset.image (λ a:α, (a,b)) (left_fiber G b)

def right_fiber' (G:bigraph α β)(a:α): finset (α × β):=
  finset.image (λ b:β, (a,b)) (right_fiber G a)

@[simp] lemma mem_left_fiber (G : bigraph α β) {b : β} {x : α}:
x ∈ (left_fiber G b) ↔ x ∈ G.A ∧ G.E x b := by { unfold left_fiber, simp }

@[simp] lemma mem_right_fiber (G : bigraph α β) {a : α} {x : β} :
x ∈ (right_fiber G a) ↔ x ∈ G.B ∧ G.E a x := by { unfold right_fiber, simp }

@[simp] lemma left_fiber_swap (G : bigraph α β) {a : α} :
left_fiber G.swap a=right_fiber G a := by { ext, simp }

@[simp] lemma right_fiber_swap (G : bigraph α β) {b : β} :
right_fiber G.swap b = left_fiber G b := by { ext, simp }

@[simp] lemma mem_left_fiber' (G : bigraph α β) {b : β} {x : α × β} :
x ∈ (left_fiber' G b) ↔  (x.fst ∈ G.A ∧ x.snd = b) ∧ G.E x.fst x.snd:=
begin
  unfold left_fiber', tidy,
  -- here's a human proof that runs a little faster than tidy:
  -- simp only [exists_prop, mem_left_fiber, finset.mem_image],
  -- split,

  -- simp only [and_imp, exists_imp_distrib],
  -- intros h1 h2 h3 h4,
  -- rw ← h4, tauto,

  -- simp,
  -- intros h1 h2 h3,
  -- use x.fst,
  -- rw ← h2,
  -- simp; tauto,
end
-- can the following be proven with swap and the above?
@[simp] lemma mem_right_fiber' (G:bigraph α β) {a:α} {x : α × β} :
x ∈ (right_fiber' G a) ↔ (x.fst = a ∧ x.snd ∈ G.B) ∧ G.E x.fst x.snd :=
begin
  unfold right_fiber', tidy,
  -- here's a human proof that runs a little faster than tidy:

  -- simp,
  -- split,

  -- simp,
  -- intros b h2 h3 h4,
  -- rw ← h4,
  -- simp,
  -- tauto,

  -- simp,
  -- intros h1 h2 h3,
  -- use x.snd,
  -- rw ← h1,
  -- simp,
  -- tauto,
end

@[simp] lemma left_fiber'_swap (G : bigraph α β) {a : α} :
left_fiber' G.swap a = finset.image prod.swap (right_fiber' G a) :=
begin
  have h : right_fiber' G a = finset.image (λ b:β,(a,b)) (right_fiber G a) := by refl,
  rw [h, finset.image_image],
  have h2 : left_fiber' G.swap a = finset.image (λ b:β,(b,a)) (left_fiber G.swap a) := by refl,
  simp [h2]; refl,
end

@[simp] lemma right_fiber'_swap (G:bigraph α β){b:β}:
  right_fiber' G.swap b = finset.image prod.swap (left_fiber' G b):=
begin
  have h : left_fiber' G b = finset.image (λ a:α,(a,b)) (left_fiber G b),
    refl,
  rw h,
  rw finset.image_image,
  have h:right_fiber' G.swap b = finset.image (λ a:α,(b,a)) (right_fiber G.swap b),
    refl,
  rw h,
  simp,
  refl,
end

@[simp] lemma card_left_fiber_eq_' {G:bigraph α β}{b: β}:
  (left_fiber G b).card=(left_fiber' G b).card:=
begin
  symmetry,
  apply finset.card_image_of_injective,
  unfold function.injective,
  intros a1 a2 h,
  change (a1,b).fst=(a2,b).fst,
  rw h,
end

lemma card_left_fiber_fun_eq_' {G:bigraph α β}:
  (λ (b:β), (left_fiber G b).card)=λ (b:β),(left_fiber' G b).card:=by simp

lemma disjoint_left_fiber' (G:bigraph α β){b1 b2: β}:
  b1 ≠ b2 → disjoint (left_fiber' G b1) (left_fiber' G b2):=
begin
  intro neq,
  rw finset.disjoint_iff_inter_eq_empty,
  ext,
  simp,
  intros h1 h2 h3 h4 h5 h6,
  apply neq,
  rw ← h2,
  rw ← h5,
end

lemma edges_eq_bind_left_fibers (G:bigraph α β):
  edges G=(G.B).bind (λ (b : β), left_fiber' G b):=
begin
  ext,
  simp,
  split,
  simp,
  intros h1 h2 h3,
  use a.snd,
  tauto,
  simp,
  intros x h1 h2 h3 h4,
  rw h3,
  rw h3 at h4,
  tauto,
end

lemma edges_eq_bind_right_fibers (G:bigraph α β):
  edges G=(G.A).bind (λ (a : α), right_fiber' G a):=
begin
  transitivity finset.image prod.swap (edges G.swap),
  rw ← bigraph.swap_swap G,
  rw bigraph.swap_swap G.swap,
  rw edges_swap,
  rw edges_eq_bind_left_fibers,
  rw finset.bind_image,
  simp,
  refine congr rfl _,
  ext,
  rw finset.image_image,
  rw prod.swap_swap_eq,
  rw finset.image_id,
end

theorem sum_left_fibers (G:bigraph α β):
  card_edges G = G.B.sum(λ (b1:β), (left_fiber G b1).card):=
begin
  rw card_left_fiber_fun_eq_',
  change (edges G).card = G.B.sum(λ (b1:β), (left_fiber' G b1).card),
  rw edges_eq_bind_left_fibers,
  apply finset.card_bind,
  intros x hx y hy neq,
  apply disjoint_left_fiber' G neq,
end

theorem sum_right_fibers (G : bigraph α β):
  card_edges G = G.A.sum(λ (a1:α), (right_fiber G a1).card):=
begin
  transitivity G.A.sum(λ (a1:α), (left_fiber G.swap a1).card),
  transitivity card_edges G.swap,
  rw card_edges_symm,
  apply sum_left_fibers,
  simp,
end

variable (G : bigraph α β)

def left_regular (d : ℕ) : Prop :=
  ∀ (b : β), b ∈ G.B→ (left_fiber G b).card = d

def right_regular (d:ℕ):Prop:=
  ∀ (a : α), a ∈ G.A → (right_fiber G a).card = d

def left_unique : Prop :=
  ∀ (b : β), b ∈ G.B→∃!(a : α), a ∈ G.A ∧ G.E a b

def right_unique : Prop :=
  ∀ (a : α), a ∈ G.A→∃!(b : β), b ∈ G.B ∧ G.E a b

@[simp] lemma right_regular_swap (d  :ℕ) : right_regular G.swap d ↔ left_regular G d :=
begin
  unfold left_regular,
  unfold right_regular,
  simp,
end

@[simp] lemma left_regular_swap {d : ℕ} : left_regular G.swap d ↔ right_regular G d :=
begin
  unfold left_regular,
  unfold right_regular,
  simp,
end

@[simp] lemma right_unique_swap : right_unique G.swap ↔ left_unique G :=
begin
  unfold left_unique,
  unfold right_unique,
  refl,
end

@[simp] lemma left_unique_swap : left_unique G.swap ↔ right_unique G :=
begin
  unfold left_unique,
  unfold right_unique,
  refl,
end

@[simp] lemma left_unique_one_reg : left_unique G ↔ left_regular G 1 :=
begin
  transitivity ∀ b:β, b ∈ G.B → ∃!(a:α), a ∈ left_fiber G b,
  unfold left_unique,
  simp,
  unfold left_regular,
  apply forall_congr,
  intro x,
  apply imp_congr_right,
  intro hx,
  rw finset.card_eq_one,
  rw finset.singleton_iff_unique_mem,
end

@[simp] lemma right_unique_one_reg : right_unique G ↔ right_regular G 1 :=
begin
  rw ← left_unique_swap,
  rw ← left_regular_swap,
  apply left_unique_one_reg,
end

theorem card_edges_of_lreg {l : ℕ} (hl : left_regular G l) : card_edges G = l * G.B.card:=
by {rwa [sum_left_fibers, mul_comm l, finset.sum_const_nat]}

theorem card_edges_of_lunique :
  left_unique G → card_edges G = G.B.card :=
begin
  rw left_unique_one_reg,
  intro h,
  have h1 := card_edges_of_lreg G h,
  simp at h1,
  apply h1,
end

theorem card_edges_of_rreg {r : ℕ} (hr : right_regular G r) : card_edges G = r * G.A.card :=
by { rwa [sum_right_fibers, mul_comm r, finset.sum_const_nat] }

theorem card_edges_of_runique : right_unique G → card_edges G = G.A.card :=
begin
  rw right_unique_one_reg,
  intro h,
  have h1 := card_edges_of_rreg G h,
  simp at h1,
  apply h1,
end

theorem double_count_of_lreg_rreg {l r : ℕ} (hl : left_regular G l) (hr : right_regular G r) :
r * G.A.card = l * G.B.card :=
by { rwa [← card_edges_of_rreg _ hr, ← card_edges_of_lreg] }

theorem card_eq_of_lunique_runique (hl : left_unique G) (hr : right_unique G ) :
G.A.card = G.B.card :=
begin
  simp only [right_unique_one_reg, left_unique_one_reg] at hl hr,
  have h := double_count_of_lreg_rreg _ hl hr,
  revert h, simp,
end

lemma edges_disjoint_of_eq_disj_eq {A : finset α} {B1 B2 : finset β} {E : α → β → Prop} :
  disjoint B1 B2 → disjoint (edges ⟨A, B1, E⟩) (edges ⟨A, B2, E⟩) :=
begin
  intro disj,
  change disjoint (finset.filter (function.uncurry E)(A.product B1)) (finset.filter (function.uncurry E)(A.product B2)),
  apply finset.disjoint_filter_filter,
  rw finset.disjoint_iff_ne,
  intros a ha b hb,
  intro contra,
  rw finset.mem_product at *,
  rw finset.disjoint_iff_ne at disj,
  apply disj a.snd ha.right b.snd hb.right,
  rw contra,
end

lemma edges_union_of_eq_union_eq {A : finset α} {B1 B2 : finset β} {E : α→ β→ Prop} :
  edges ⟨ A, B1 ∪ B2, E⟩=edges ⟨A, B1, E⟩ ∪ edges ⟨A, B2, E⟩ :=
begin
  change finset.filter (function.uncurry E)(A.product (B1 ∪ B2)) = finset.filter (function.uncurry E)(A.product B1) ∪ finset.filter (function.uncurry E)(A.product B2),
  rw ← finset.filter_union,
  refine congr rfl _,
  ext,
  rw finset.mem_union,
  repeat {rw finset.mem_product},
  rw finset.mem_union,
  tauto,
end

theorem card_edges_add_of_eq_disj_union_eq {A : finset α} {B1 B2 : finset β} (h : disjoint B1 B2) (E : α → β → Prop) :
card_edges ⟨A, B1 ∪ B2, E⟩ = card_edges ⟨A, B1, E⟩ + card_edges ⟨A, B2, E⟩ :=
begin
  unfold card_edges,
  rw edges_union_of_eq_union_eq,
  apply finset.card_disjoint_union,
  exact edges_disjoint_of_eq_disj_eq h,
end


/-
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 algebra.monoid_algebra.basic

/-!
# Theory of univariate polynomials

This file defines `polynomial R`, the type of univariate polynomials over the semiring `R`, builds
a semiring structure on it, and gives basic definitions that are expanded in other files in this
directory.

## Main definitions

* `monomial n a` is the polynomial `a X^n`. Note that `monomial n` is defined as an `R`-linear map.
* `C a` is the constant polynomial `a`. Note that `C` is defined as a ring homomorphism.
* `X` is the polynomial `X`, i.e., `monomial 1 1`.
* `p.sum f` is `∑ n in p.support, f n (p.coeff n)`, i.e., one sums the values of functions applied
  to coefficients of the polynomial `p`.
* `p.erase n` is the polynomial `p` in which one removes the `c X^n` term.

There are often two natural variants of lemmas involving sums, depending on whether one acts on the
polynomials, or on the function. The naming convention is that one adds `index` when acting on
the polynomials. For instance,
* `sum_add_index` states that `(p + q).sum f = p.sum f + q.sum f`;
* `sum_add` states that `p.sum (λ n x, f n x + g n x) = p.sum f + p.sum g`.
* Notation to refer to `polynomial R`, as `R[X]` or `R[t]`.

## Implementation

Polynomials are defined using `add_monoid_algebra R ℕ`, where `R` is a semiring.
The variable `X` commutes with every polynomial `p`: lemma `X_mul` proves the identity
`X * p = `p * X`.  The relationship to `add_monoid_algebra R ℕ` is through a structure
to make polynomials irreducible from the point of view of the kernel. Most operations
are irreducible since Lean can not compute anyway with `add_monoid_algebra`. There are two
exceptions that we make semireducible:
* The zero polynomial, so that its coefficients are definitionally equal to `0`.
* The scalar action, to permit typeclass search to unfold it to resolve potential instance
  diamonds.

The raw implementation of the equivalence between `polynomial R` and `add_monoid_algebra R ℕ` is
done through `of_finsupp` and `to_finsupp` (or, equivalently, `rcases p` when `p` is a polynomial
gives an element `q` of `add_monoid_algebra R ℕ`, and conversely `⟨q⟩` gives back `p`). The
equivalence is also registered as a ring equiv in `polynomial.to_finsupp_iso`. These should
in general not be used once the basic API for polynomials is constructed.
-/

noncomputable theory

/-- `polynomial R` is the type of univariate polynomials over `R`.

Polynomials should be seen as (semi-)rings with the additional constructor `X`.
The embedding from `R` is called `C`. -/
structure polynomial (R : Type*) [semiring R] := of_finsupp ::
(to_finsupp : add_monoid_algebra R ℕ)

localized "notation R`[X]`:9000 := polynomial R" in polynomial
open finsupp add_monoid_algebra
open_locale big_operators polynomial

namespace polynomial
universes u
variables {R : Type u} {a b : R} {m n : ℕ}

section semiring
variables [semiring R] {p q : R[X]}

lemma forall_iff_forall_finsupp (P : R[X] → Prop) :
  (∀ p, P p) ↔ ∀ (q : add_monoid_algebra R ℕ), P ⟨q⟩ :=
⟨λ h q, h ⟨q⟩, λ h ⟨p⟩, h p⟩

lemma exists_iff_exists_finsupp (P : R[X] → Prop) :
  (∃ p, P p) ↔ ∃ (q : add_monoid_algebra R ℕ), P ⟨q⟩ :=
⟨λ ⟨⟨p⟩, hp⟩, ⟨p, hp⟩, λ ⟨q, hq⟩, ⟨⟨q⟩, hq⟩ ⟩

/-! ### Conversions to and from `add_monoid_algebra`

Since `polynomial R` is not defeq to `add_monoid_algebra R ℕ`, but instead is a structure wrapping
it, we have to copy across all the arithmetic operators manually, along with the lemmas about how
they unfold around `polynomial.of_finsupp` and `polynomial.to_finsupp`.
-/
section add_monoid_algebra

/-- The function version of `monomial`. Use `monomial` instead of this one. -/
@[irreducible] def monomial_fun (n : ℕ) (a : R) : R[X] := ⟨finsupp.single n a⟩
@[irreducible] private def add : R[X] → R[X] → R[X]
| ⟨a⟩ ⟨b⟩ := ⟨a + b⟩
@[irreducible] private def neg {R : Type u} [ring R] : R[X] → R[X]
| ⟨a⟩ := ⟨-a⟩
@[irreducible] private def mul : R[X] → R[X] → R[X]
| ⟨a⟩ ⟨b⟩ := ⟨a * b⟩

instance : has_zero R[X] := ⟨⟨0⟩⟩
instance : has_one R[X] := ⟨monomial_fun 0 (1 : R)⟩
instance : has_add R[X] := ⟨add⟩
instance {R : Type u} [ring R] : has_neg R[X] := ⟨neg⟩
instance {R : Type u} [ring R] : has_sub R[X] := ⟨λ a b, a + -b⟩
instance : has_mul R[X] := ⟨mul⟩
instance {S : Type*} [monoid S] [distrib_mul_action S R] : has_scalar S R[X] :=
⟨λ r p, ⟨r • p.to_finsupp⟩⟩
@[priority 1]  -- to avoid a bug in the `ring` tactic
instance has_pow : has_pow R[X] ℕ := { pow := λ p n, npow_rec n p }

@[simp] lemma of_finsupp_zero : (⟨0⟩ : R[X]) = 0 :=
rfl

@[simp] lemma of_finsupp_one : (⟨1⟩ : R[X]) = 1 :=
begin
  change (⟨1⟩ : R[X]) = monomial_fun 0 (1 : R),
  rw [monomial_fun],
  refl
end

@[simp] lemma of_finsupp_add {a b} : (⟨a + b⟩ : R[X]) = ⟨a⟩ + ⟨b⟩ := show _ = add _ _, by rw add
@[simp] lemma of_finsupp_neg {R : Type u} [ring R] {a} : (⟨-a⟩ : R[X]) = -⟨a⟩ :=
show _ = neg _, by rw neg
@[simp] lemma of_finsupp_sub {R : Type u} [ring R] {a b} : (⟨a - b⟩ : R[X]) = ⟨a⟩ - ⟨b⟩ :=
by { rw [sub_eq_add_neg, of_finsupp_add, of_finsupp_neg], refl }
@[simp] lemma of_finsupp_mul (a b) : (⟨a * b⟩ : R[X]) = ⟨a⟩ * ⟨b⟩ := show _ = mul _ _, by rw mul
@[simp] lemma of_finsupp_smul {S : Type*} [monoid S] [distrib_mul_action S R] (a : S) (b) :
  (⟨a • b⟩ : R[X]) = (a • ⟨b⟩ : R[X]) := rfl
@[simp] lemma of_finsupp_pow (a) (n : ℕ) : (⟨a ^ n⟩ : R[X]) = ⟨a⟩ ^ n :=
begin
  change _ = npow_rec n _,
  induction n,
  { simp [npow_rec], } ,
  { simp [npow_rec, n_ih, pow_succ] }
end

@[simp] lemma to_finsupp_zero : (0 : R[X]).to_finsupp = 0 :=
rfl

@[simp] lemma to_finsupp_one : (1 : R[X]).to_finsupp = 1 :=
begin
  change to_finsupp (monomial_fun _ _) = _,
  rw monomial_fun,
  refl,
end

@[simp] lemma to_finsupp_add (a b : R[X]) : (a + b).to_finsupp = a.to_finsupp + b.to_finsupp :=
by { cases a, cases b, rw ←of_finsupp_add }
@[simp] lemma to_finsupp_neg {R : Type u} [ring R] (a : R[X]) : (-a).to_finsupp = -a.to_finsupp :=
by { cases a, rw ←of_finsupp_neg }
@[simp] lemma to_finsupp_sub {R : Type u} [ring R] (a b : R[X]) :
  (a - b).to_finsupp = a.to_finsupp - b.to_finsupp :=
by { rw [sub_eq_add_neg, ←to_finsupp_neg, ←to_finsupp_add], refl }
@[simp] lemma to_finsupp_mul (a b : R[X]) : (a * b).to_finsupp = a.to_finsupp * b.to_finsupp :=
by { cases a, cases b, rw ←of_finsupp_mul }
@[simp] lemma to_finsupp_smul {S : Type*} [monoid S] [distrib_mul_action S R] (a : S) (b : R[X]) :
  (a • b).to_finsupp = a • b.to_finsupp := rfl
@[simp] lemma to_finsupp_pow (a : R[X]) (n : ℕ) : (a ^ n).to_finsupp = a.to_finsupp ^ n :=
by { cases a, rw ←of_finsupp_pow }

lemma _root_.is_smul_regular.polynomial {S : Type*} [monoid S] [distrib_mul_action S R] {a : S}
  (ha : is_smul_regular R a) : is_smul_regular R[X] a
| ⟨x⟩ ⟨y⟩ h := congr_arg _ $ ha.finsupp (polynomial.of_finsupp.inj h)

lemma to_finsupp_injective : function.injective (to_finsupp : R[X] → add_monoid_algebra _ _) :=
λ ⟨x⟩ ⟨y⟩, congr_arg _

@[simp] lemma to_finsupp_inj {a b : R[X]} : a.to_finsupp = b.to_finsupp ↔ a = b :=
to_finsupp_injective.eq_iff

@[simp] lemma to_finsupp_eq_zero {a : R[X]} : a.to_finsupp = 0 ↔ a = 0 :=
by rw [←to_finsupp_zero, to_finsupp_inj]

@[simp] lemma to_finsupp_eq_one {a : R[X]} : a.to_finsupp = 1 ↔ a = 1 :=
by rw [←to_finsupp_one, to_finsupp_inj]

/-- A more convenient spelling of `polynomial.of_finsupp.inj_eq` in terms of `iff`. -/
lemma of_finsupp_inj {a b} : (⟨a⟩ : R[X]) = ⟨b⟩ ↔ a = b :=
iff_of_eq of_finsupp.inj_eq

@[simp] lemma of_finsupp_eq_zero {a} : (⟨a⟩ : R[X]) = 0 ↔ a = 0 :=
by rw [←of_finsupp_zero, of_finsupp_inj]

@[simp] lemma of_finsupp_eq_one {a} : (⟨a⟩ : R[X]) = 1 ↔ a = 1 :=
by rw [←of_finsupp_one, of_finsupp_inj]

instance : inhabited R[X] := ⟨0⟩

instance : semiring R[X] :=
function.injective.semiring to_finsupp to_finsupp_injective
  to_finsupp_zero to_finsupp_one to_finsupp_add to_finsupp_mul
  (λ _ _, to_finsupp_smul _ _) to_finsupp_pow

instance {S} [monoid S] [distrib_mul_action S R] : distrib_mul_action S R[X] :=
function.injective.distrib_mul_action
  ⟨to_finsupp, to_finsupp_zero, to_finsupp_add⟩ to_finsupp_injective to_finsupp_smul

instance {S} [monoid S] [distrib_mul_action S R] [has_faithful_scalar S R] :
  has_faithful_scalar S R[X] :=
{ eq_of_smul_eq_smul := λ s₁ s₂ h, eq_of_smul_eq_smul $ λ a : ℕ →₀ R, congr_arg to_finsupp (h ⟨a⟩) }

instance {S} [semiring S] [module S R] : module S R[X] :=
function.injective.module _
  ⟨to_finsupp, to_finsupp_zero, to_finsupp_add⟩ to_finsupp_injective to_finsupp_smul

instance {S₁ S₂} [monoid S₁] [monoid S₂] [distrib_mul_action S₁ R] [distrib_mul_action S₂ R]
  [smul_comm_class S₁ S₂ R] : smul_comm_class S₁ S₂ R[X] :=
⟨by { rintros _ _ ⟨⟩, simp_rw [←of_finsupp_smul, smul_comm] }⟩

instance {S₁ S₂} [has_scalar S₁ S₂] [monoid S₁] [monoid S₂] [distrib_mul_action S₁ R]
  [distrib_mul_action S₂ R] [is_scalar_tower S₁ S₂ R] : is_scalar_tower S₁ S₂ R[X] :=
⟨by { rintros _ _ ⟨⟩, simp_rw [←of_finsupp_smul, smul_assoc] }⟩

instance {S} [monoid S] [distrib_mul_action S R] [distrib_mul_action Sᵐᵒᵖ R]
  [is_central_scalar S R] : is_central_scalar S R[X] :=
⟨by { rintros _ ⟨⟩, simp_rw [←of_finsupp_smul, op_smul_eq_smul] }⟩

instance [subsingleton R] : unique R[X] :=
{ uniq := by { rintros ⟨x⟩, refine congr_arg of_finsupp _, simp },
.. polynomial.inhabited }

variable (R)

/-- Ring isomorphism between `R[X]` and `add_monoid_algebra R ℕ`. This is just an
implementation detail, but it can be useful to transfer results from `finsupp` to polynomials. -/
@[simps apply symm_apply]
def to_finsupp_iso : R[X] ≃+* add_monoid_algebra R ℕ :=
{ to_fun := to_finsupp,
  inv_fun := of_finsupp,
  left_inv := λ ⟨p⟩, rfl,
  right_inv := λ p, rfl,
  map_mul' := to_finsupp_mul,
  map_add' := to_finsupp_add }

end add_monoid_algebra

/-- Ring isomorphism between `R[X]ᵐᵒᵖ` and `Rᵐᵒᵖ[X]` sending each coefficient of a polynomial
to the corresponding element of the opposite ring. -/
@[simps]
def op_ring_equiv : R[X]ᵐᵒᵖ ≃+* Rᵐᵒᵖ[X] :=
((to_finsupp_iso R).op.trans add_monoid_algebra.op_ring_equiv).trans (to_finsupp_iso _).symm

variable {R}

lemma of_finsupp_sum {ι : Type*} (s : finset ι) (f : ι → add_monoid_algebra R ℕ) :
  (⟨∑ i in s, f i⟩ : R[X]) = ∑ i in s, ⟨f i⟩ :=
map_sum (to_finsupp_iso R).symm f s

lemma to_finsupp_sum {ι : Type*} (s : finset ι) (f : ι → R[X]) :
  (∑ i in s, f i : R[X]).to_finsupp = ∑ i in s, (f i).to_finsupp :=
map_sum (to_finsupp_iso R) f s

/--
The set of all `n` such that `X^n` has a non-zero coefficient.
-/
@[simp]
def support : R[X] → finset ℕ
| ⟨p⟩ := p.support

@[simp] lemma support_of_finsupp (p) : support (⟨p⟩ : R[X]) = p.support :=
by rw support

@[simp] lemma support_zero : (0 : R[X]).support = ∅ :=
rfl

@[simp] lemma support_eq_empty : p.support = ∅ ↔ p = 0 :=
by { rcases p, simp [support] }

lemma card_support_eq_zero : p.support.card = 0 ↔ p = 0 :=
by simp

/-- `monomial s a` is the monomial `a * X^s` -/
def monomial (n : ℕ) : R →ₗ[R] R[X] :=
{ to_fun := monomial_fun n,
  map_add' := by simp [monomial_fun],
  map_smul' := by simp [monomial_fun, ←of_finsupp_smul] }

@[simp] lemma to_finsupp_monomial (n : ℕ) (r : R) :
  (monomial n r).to_finsupp = finsupp.single n r :=
by simp [monomial, monomial_fun]

@[simp] lemma of_finsupp_single (n : ℕ) (r : R) :
  (⟨finsupp.single n r⟩ : R[X]) = monomial n r :=
by simp [monomial, monomial_fun]

@[simp]
lemma monomial_zero_right (n : ℕ) :
  monomial n (0 : R) = 0 :=
(monomial n).map_zero

-- This is not a `simp` lemma as `monomial_zero_left` is more general.
lemma monomial_zero_one : monomial 0 (1 : R) = 1 := rfl

-- TODO: can't we just delete this one?
lemma monomial_add (n : ℕ) (r s : R) :
  monomial n (r + s) = monomial n r + monomial n s :=
(monomial n).map_add _ _

lemma monomial_mul_monomial (n m : ℕ) (r s : R) :
  monomial n r * monomial m s = monomial (n + m) (r * s) :=
to_finsupp_injective $
  by simp only [to_finsupp_monomial, to_finsupp_mul, add_monoid_algebra.single_mul_single]

@[simp]
lemma monomial_pow (n : ℕ) (r : R) (k : ℕ) :
  (monomial n r)^k = monomial (n*k) (r^k) :=
begin
  induction k with k ih,
  { simp [pow_zero, monomial_zero_one], },
  { simp [pow_succ, ih, monomial_mul_monomial, nat.succ_eq_add_one, mul_add, add_comm] },
end

lemma smul_monomial {S} [monoid S] [distrib_mul_action S R] (a : S) (n : ℕ) (b : R) :
  a • monomial n b = monomial n (a • b) :=
to_finsupp_injective $ by simp

lemma monomial_injective (n : ℕ) :
  function.injective (monomial n : R → R[X]) :=
begin
  convert (to_finsupp_iso R).symm.injective.comp (single_injective n),
  ext,
  simp
end

@[simp] lemma monomial_eq_zero_iff (t : R) (n : ℕ) :
  monomial n t = 0 ↔ t = 0 :=
linear_map.map_eq_zero_iff _ (polynomial.monomial_injective n)

lemma support_add : (p + q).support ⊆ p.support ∪ q.support :=
begin
  rcases p, rcases q,
  simp only [←of_finsupp_add, support],
  exact support_add
end

/--
`C a` is the constant polynomial `a`.
`C` is provided as a ring homomorphism.
-/
def C : R →+* R[X] :=
{ map_one' := by simp [monomial_zero_one],
  map_mul' := by simp [monomial_mul_monomial],
  map_zero' := by simp,
  .. monomial 0 }

@[simp] lemma monomial_zero_left (a : R) : monomial 0 a = C a := rfl

@[simp] lemma to_finsupp_C (a : R) : (C a).to_finsupp = single 0 a :=
by rw [←monomial_zero_left, to_finsupp_monomial]

lemma C_0 : C (0 : R) = 0 := by simp

lemma C_1 : C (1 : R) = 1 := rfl

lemma C_mul : C (a * b) = C a * C b := C.map_mul a b

lemma C_add : C (a + b) = C a + C b := C.map_add a b

@[simp] lemma smul_C {S} [monoid S] [distrib_mul_action S R] (s : S) (r : R) :
  s • C r = C (s • r) :=
smul_monomial _ _ r

@[simp] lemma C_bit0 : C (bit0 a) = bit0 (C a) := C_add

@[simp] lemma C_bit1 : C (bit1 a) = bit1 (C a) := by simp [bit1, C_bit0]

lemma C_pow : C (a ^ n) = C a ^ n := C.map_pow a n

@[simp]
lemma C_eq_nat_cast (n : ℕ) : C (n : R) = (n : R[X]) :=
map_nat_cast C n

@[simp] lemma C_mul_monomial : C a * monomial n b = monomial n (a * b) :=
by simp only [←monomial_zero_left, monomial_mul_monomial, zero_add]

@[simp] lemma monomial_mul_C : monomial n a * C b = monomial n (a * b) :=
by simp only [←monomial_zero_left, monomial_mul_monomial, add_zero]

/-- `X` is the polynomial variable (aka indeterminate). -/
def X : R[X] := monomial 1 1

lemma monomial_one_one_eq_X : monomial 1 (1 : R) = X := rfl

lemma monomial_one_right_eq_X_pow (n : ℕ) : monomial n (1 : R) = X^n :=
begin
  induction n with n ih,
  { simp [monomial_zero_one], },
  { rw [pow_succ, ←ih, ←monomial_one_one_eq_X, monomial_mul_monomial, add_comm, one_mul], }
end

/-- `X` commutes with everything, even when the coefficients are noncommutative. -/
lemma X_mul : X * p = p * X :=
begin
  rcases p,
  simp only [X, ←of_finsupp_single, ←of_finsupp_mul, linear_map.coe_mk],
  ext,
  simp [add_monoid_algebra.mul_apply, sum_single_index, add_comm],
  congr; ext; congr,
end

lemma X_pow_mul {n : ℕ} : X^n * p = p * X^n :=
begin
  induction n with n ih,
  { simp, },
  { conv_lhs { rw pow_succ', },
    rw [mul_assoc, X_mul, ←mul_assoc, ih, mul_assoc, ←pow_succ'], }
end

/-- Prefer putting constants to the left of `X`.

This lemma is the loop-avoiding `simp` version of `polynomial.X_mul`. -/
@[simp] lemma X_mul_C (r : R) : X * C r = C r * X :=
X_mul

/-- Prefer putting constants to the left of `X ^ n`.

This lemma is the loop-avoiding `simp` version of `X_pow_mul`. -/
@[simp] lemma X_pow_mul_C (r : R) (n : ℕ) : X^n * C r = C r * X^n :=
X_pow_mul

lemma X_pow_mul_assoc {n : ℕ} : (p * X^n) * q = (p * q) * X^n :=
by rw [mul_assoc, X_pow_mul, ←mul_assoc]

/-- Prefer putting constants to the left of `X ^ n`.

This lemma is the loop-avoiding `simp` version of `X_pow_mul_assoc`. -/
@[simp] lemma X_pow_mul_assoc_C {n : ℕ} (r : R) : (p * X^n) * C r = p * C r * X^n :=
X_pow_mul_assoc

lemma commute_X (p : R[X]) : commute X p := X_mul

lemma commute_X_pow (p : R[X]) (n : ℕ) : commute (X ^ n) p := X_pow_mul

@[simp]
lemma monomial_mul_X (n : ℕ) (r : R) : monomial n r * X = monomial (n+1) r :=
by erw [monomial_mul_monomial, mul_one]

@[simp]
lemma monomial_mul_X_pow (n : ℕ) (r : R) (k : ℕ) : monomial n r * X^k = monomial (n+k) r :=
begin
  induction k with k ih,
  { simp, },
  { simp [ih, pow_succ', ←mul_assoc, add_assoc], },
end

@[simp]
lemma X_mul_monomial (n : ℕ) (r : R) : X * monomial n r = monomial (n+1) r :=
by rw [X_mul, monomial_mul_X]

@[simp]
lemma X_pow_mul_monomial (k n : ℕ) (r : R) : X^k * monomial n r = monomial (n+k) r :=
by rw [X_pow_mul, monomial_mul_X_pow]

/-- `coeff p n` (often denoted `p.coeff n`) is the coefficient of `X^n` in `p`. -/
@[simp] def coeff : R[X] → ℕ → R
| ⟨p⟩ := p

lemma coeff_monomial : coeff (monomial n a) m = if n = m then a else 0 :=
by { simp only [←of_finsupp_single, coeff, linear_map.coe_mk], rw finsupp.single_apply }

@[simp] lemma coeff_zero (n : ℕ) : coeff (0 : R[X]) n = 0 := rfl

@[simp] lemma coeff_one_zero : coeff (1 : R[X]) 0 = 1 :=
by { rw [← monomial_zero_one, coeff_monomial], simp }

@[simp] lemma coeff_X_one : coeff (X : R[X]) 1 = 1 := coeff_monomial

@[simp] lemma coeff_X_zero : coeff (X : R[X]) 0 = 0 := coeff_monomial

@[simp] lemma coeff_monomial_succ : coeff (monomial (n+1) a) 0 = 0 :=
by simp [coeff_monomial]

lemma coeff_X : coeff (X : R[X]) n = if 1 = n then 1 else 0 := coeff_monomial

lemma coeff_X_of_ne_one {n : ℕ} (hn : n ≠ 1) : coeff (X : R[X]) n = 0 :=
by rw [coeff_X, if_neg hn.symm]

@[simp] lemma mem_support_iff : n ∈ p.support ↔ p.coeff n ≠ 0 :=
by { rcases p, simp }

lemma not_mem_support_iff : n ∉ p.support ↔ p.coeff n = 0 :=
by simp

lemma coeff_C : coeff (C a) n = ite (n = 0) a 0 :=
by { convert coeff_monomial using 2, simp [eq_comm], }

@[simp] lemma coeff_C_zero : coeff (C a) 0 = a := coeff_monomial

lemma coeff_C_ne_zero (h : n ≠ 0) : (C a).coeff n = 0 :=
by rw [coeff_C, if_neg h]

theorem nontrivial.of_polynomial_ne (h : p ≠ q) : nontrivial R :=
nontrivial_of_ne 0 1 $ λ h01, h $
  by rw [← mul_one p, ← mul_one q, ← C_1, ← h01, C_0, mul_zero, mul_zero]

lemma monomial_eq_C_mul_X : ∀{n}, monomial n a = C a * X^n
| 0     := (mul_one _).symm
| (n+1) :=
  calc monomial (n + 1) a = monomial n a * X : by { rw [X, monomial_mul_monomial, mul_one], }
    ... = (C a * X^n) * X : by rw [monomial_eq_C_mul_X]
    ... = C a * X^(n+1) : by simp only [pow_add, mul_assoc, pow_one]

@[simp] lemma C_inj : C a = C b ↔ a = b :=
⟨λ h, coeff_C_zero.symm.trans (h.symm ▸ coeff_C_zero), congr_arg C⟩

@[simp] lemma C_eq_zero : C a = 0 ↔ a = 0 :=
calc C a = 0 ↔ C a = C 0 : by rw C_0
         ... ↔ a = 0 : C_inj

theorem ext_iff {p q : R[X]} : p = q ↔ ∀ n, coeff p n = coeff q n :=
by { rcases p, rcases q, simp [coeff, finsupp.ext_iff] }

@[ext] lemma ext {p q : R[X]} : (∀ n, coeff p n = coeff q n) → p = q :=
ext_iff.2

/-- Monomials generate the additive monoid of polynomials. -/
lemma add_submonoid_closure_set_of_eq_monomial :
  add_submonoid.closure {p : R[X] | ∃ n a, p = monomial n a} = ⊤ :=
begin
  apply top_unique,
  rw [← add_submonoid.map_equiv_top (to_finsupp_iso R).symm.to_add_equiv,
    ← finsupp.add_closure_set_of_eq_single, add_monoid_hom.map_mclosure],
  refine add_submonoid.closure_mono (set.image_subset_iff.2 _),
  rintro _ ⟨n, a, rfl⟩,
  exact ⟨n, a, polynomial.of_finsupp_single _ _⟩,
end

lemma add_hom_ext {M : Type*} [add_monoid M] {f g : R[X] →+ M}
  (h : ∀ n a, f (monomial n a) = g (monomial n a)) :
  f = g :=
add_monoid_hom.eq_of_eq_on_mdense add_submonoid_closure_set_of_eq_monomial $
  by { rintro p ⟨n, a, rfl⟩, exact h n a }

@[ext] lemma add_hom_ext' {M : Type*} [add_monoid M] {f g : R[X] →+ M}
  (h : ∀ n, f.comp (monomial n).to_add_monoid_hom = g.comp (monomial n).to_add_monoid_hom) :
  f = g :=
add_hom_ext (λ n, add_monoid_hom.congr_fun (h n))

@[ext] lemma lhom_ext' {M : Type*} [add_comm_monoid M] [module R M] {f g : R[X] →ₗ[R] M}
  (h : ∀ n, f.comp (monomial n) = g.comp (monomial n)) :
  f = g :=
linear_map.to_add_monoid_hom_injective $ add_hom_ext $ λ n, linear_map.congr_fun (h n)

-- this has the same content as the subsingleton
lemma eq_zero_of_eq_zero (h : (0 : R) = (1 : R)) (p : R[X]) : p = 0 :=
by rw [←one_smul R p, ←h, zero_smul]

lemma support_monomial (n) (a : R) (H : a ≠ 0) : (monomial n a).support = singleton n :=
by rw [←of_finsupp_single, support, finsupp.support_single_ne_zero H]

lemma support_monomial' (n) (a : R) : (monomial n a).support ⊆ singleton n :=
by { rw [←of_finsupp_single, support], exact finsupp.support_single_subset }

lemma X_pow_eq_monomial (n) : X ^ n = monomial n (1:R) :=
begin
  induction n with n hn,
  { rw [pow_zero, monomial_zero_one] },
  { rw [pow_succ', hn, X, monomial_mul_monomial, one_mul] },
end

lemma monomial_eq_smul_X {n} : monomial n (a : R) = a • X^n :=
calc monomial n a = monomial n (a * 1) : by simp
  ... = a • monomial n 1 : by rw [smul_monomial, smul_eq_mul]
  ... = a • X^n  : by rw X_pow_eq_monomial

lemma support_X_pow (H : ¬ (1:R) = 0) (n : ℕ) : (X^n : R[X]).support = singleton n :=
begin
  convert support_monomial n 1 H,
  exact X_pow_eq_monomial n,
end

lemma support_X_empty (H : (1:R)=0) : (X : R[X]).support = ∅ :=
begin
  rw [X, H, monomial_zero_right, support_zero],
end

lemma support_X (H : ¬ (1 : R) = 0) : (X : R[X]).support = singleton 1 :=
begin
  rw [← pow_one X, support_X_pow H 1],
end

lemma monomial_left_inj {R : Type*} [semiring R] {a : R} (ha : a ≠ 0) {i j : ℕ} :
  (monomial i a) = (monomial j a) ↔ i = j :=
by simp_rw [←of_finsupp_single, finsupp.single_left_inj ha]

lemma nat_cast_mul {R : Type*} [semiring R] (n : ℕ) (p : R[X]) :
  (n : R[X]) * p = n • p :=
(nsmul_eq_mul _ _).symm

/-- Summing the values of a function applied to the coefficients of a polynomial -/
def sum {S : Type*} [add_comm_monoid S] (p : R[X]) (f : ℕ → R → S) : S :=
∑ n in p.support, f n (p.coeff n)

lemma sum_def {S : Type*} [add_comm_monoid S] (p : R[X]) (f : ℕ → R → S) :
  p.sum f = ∑ n in p.support, f n (p.coeff n) := rfl

lemma sum_eq_of_subset {S : Type*} [add_comm_monoid S] (p : R[X])
  (f : ℕ → R → S) (hf : ∀ i, f i 0 = 0) (s : finset ℕ) (hs : p.support ⊆ s) :
  p.sum f = ∑ n in s, f n (p.coeff n) :=
begin
  apply finset.sum_subset hs (λ n hn h'n, _),
  rw not_mem_support_iff at h'n,
  simp [h'n, hf]
end

/-- Expressing the product of two polynomials as a double sum. -/
lemma mul_eq_sum_sum :
  p * q = ∑ i in p.support, q.sum (λ j a, (monomial (i + j)) (p.coeff i * a)) :=
begin
  apply to_finsupp_injective,
  rcases p, rcases q,
  simp [support, sum, coeff, to_finsupp_sum],
  refl
end

@[simp] lemma sum_zero_index {S : Type*} [add_comm_monoid S] (f : ℕ → R → S) :
  (0 : R[X]).sum f = 0 :=
by simp [sum]

@[simp] lemma sum_monomial_index {S : Type*} [add_comm_monoid S]
  (n : ℕ) (a : R) (f : ℕ → R → S) (hf : f n 0 = 0) :
  (monomial n a : R[X]).sum f = f n a :=
begin
  by_cases h : a = 0,
  { simp [h, hf] },
  { simp [sum, support_monomial, h, coeff_monomial] }
end

@[simp] lemma sum_C_index {a} {β} [add_comm_monoid β] {f : ℕ → R → β} (h : f 0 0 = 0) :
  (C a).sum f = f 0 a :=
sum_monomial_index 0 a f h

-- the assumption `hf` is only necessary when the ring is trivial
@[simp] lemma sum_X_index {S : Type*} [add_comm_monoid S] {f : ℕ → R → S} (hf : f 1 0 = 0) :
  (X : R[X]).sum f = f 1 1 :=
sum_monomial_index 1 1 f hf

lemma sum_add_index {S : Type*} [add_comm_monoid S] (p q : R[X])
  (f : ℕ → R → S) (hf : ∀ i, f i 0 = 0) (h_add : ∀a b₁ b₂, f a (b₁ + b₂) = f a b₁ + f a b₂) :
  (p + q).sum f = p.sum f + q.sum f :=
begin
  rcases p, rcases q,
  simp only [←of_finsupp_add, sum, support, coeff, pi.add_apply, coe_add],
  exact finsupp.sum_add_index' hf h_add,
end

lemma sum_add' {S : Type*} [add_comm_monoid S] (p : R[X]) (f g : ℕ → R → S) :
  p.sum (f + g) = p.sum f + p.sum g :=
by simp [sum_def, finset.sum_add_distrib]

lemma sum_add {S : Type*} [add_comm_monoid S] (p : R[X]) (f g : ℕ → R → S) :
  p.sum (λ n x, f n x + g n x) = p.sum f + p.sum g :=
sum_add' _ _ _

lemma sum_smul_index {S : Type*} [add_comm_monoid S] (p : R[X]) (b : R)
  (f : ℕ → R → S) (hf : ∀ i, f i 0 = 0) : (b • p).sum f = p.sum (λ n a, f n (b * a)) :=
begin
  rcases p,
  simpa [sum, support, coeff] using finsupp.sum_smul_index hf,
end

/-- `erase p n` is the polynomial `p` in which the `X^n` term has been erased. -/
@[irreducible] definition erase (n : ℕ) : R[X] → R[X]
| ⟨p⟩ := ⟨p.erase n⟩

@[simp] lemma to_finsupp_erase (p : R[X]) (n : ℕ) :
  to_finsupp (p.erase n) = (p.to_finsupp).erase n :=
by { rcases p, simp only [erase] }

@[simp] lemma of_finsupp_erase (p : add_monoid_algebra R ℕ) (n : ℕ) :
  (⟨p.erase n⟩ : R[X]) = (⟨p⟩ : R[X]).erase n :=
by { rcases p, simp only [erase] }

@[simp] lemma support_erase (p : R[X]) (n : ℕ) :
  support (p.erase n) = (support p).erase n :=
by { rcases p, simp only [support, erase, support_erase] }

lemma monomial_add_erase (p : R[X]) (n : ℕ) : monomial n (coeff p n) + p.erase n = p :=
to_finsupp_injective $ begin
  rcases p,
  rw [to_finsupp_add, to_finsupp_monomial, to_finsupp_erase, coeff],
  exact finsupp.single_add_erase _ _,
end

lemma coeff_erase (p : R[X]) (n i : ℕ) :
  (p.erase n).coeff i = if i = n then 0 else p.coeff i :=
begin
  rcases p,
  simp only [erase, coeff],
  convert rfl
end

@[simp] lemma erase_zero (n : ℕ) : (0 : R[X]).erase n = 0 :=
to_finsupp_injective $ by simp

@[simp]

@[simp] lemma erase_same (p : R[X]) (n : ℕ) : coeff (p.erase n) n = 0 :=
by simp [coeff_erase]

@[simp] lemma erase_ne (p : R[X]) (n i : ℕ) (h : i ≠ n) :
  coeff (p.erase n) i = coeff p i :=
by simp [coeff_erase, h]

section update

/-- Replace the coefficient of a `p : polynomial p` at a given degree `n : ℕ`
by a given value `a : R`. If `a = 0`, this is equal to `p.erase n`
If `p.nat_degree < n` and `a ≠ 0`, this increases the degree to `n`.  -/
def update (p : R[X]) (n : ℕ) (a : R) :
  R[X] :=
polynomial.of_finsupp (p.to_finsupp.update n a)

lemma coeff_update (p : R[X]) (n : ℕ) (a : R) :
  (p.update n a).coeff = function.update p.coeff n a :=
begin
  ext,
  cases p,
  simp only [coeff, update, function.update_apply, coe_update],
end

lemma coeff_update_apply (p : R[X]) (n : ℕ) (a : R) (i : ℕ) :
  (p.update n a).coeff i = if (i = n) then a else p.coeff i :=
by rw [coeff_update, function.update_apply]

@[simp] lemma coeff_update_same (p : R[X]) (n : ℕ) (a : R) :
  (p.update n a).coeff n = a :=
by rw [p.coeff_update_apply, if_pos rfl]

lemma coeff_update_ne (p : R[X]) {n : ℕ} (a : R) {i : ℕ} (h : i ≠ n) :
  (p.update n a).coeff i = p.coeff i :=
by rw [p.coeff_update_apply, if_neg h]

@[simp] lemma update_zero_eq_erase (p : R[X]) (n : ℕ) :
  p.update n 0 = p.erase n :=
by { ext, rw [coeff_update_apply, coeff_erase] }

lemma support_update (p : R[X]) (n : ℕ) (a : R) [decidable (a = 0)] :
  support (p.update n a) = if a = 0 then p.support.erase n else insert n p.support :=
by { cases p, simp only [support, update, support_update], congr }

lemma support_update_zero (p : R[X]) (n : ℕ) :
  support (p.update n 0) = p.support.erase n :=
by rw [update_zero_eq_erase, support_erase]

lemma support_update_ne_zero (p : R[X]) (n : ℕ) {a : R} (ha : a ≠ 0) :
  support (p.update n a) = insert n p.support :=
by classical; rw [support_update, if_neg ha]

end update

end semiring

section comm_semiring
variables [comm_semiring R]

instance : comm_semiring R[X] :=
function.injective.comm_semiring to_finsupp to_finsupp_injective
  to_finsupp_zero to_finsupp_one to_finsupp_add to_finsupp_mul
  (λ _ _, to_finsupp_smul _ _) to_finsupp_pow

end comm_semiring

section ring
variables [ring R]

instance : ring R[X] :=
function.injective.ring to_finsupp to_finsupp_injective
  to_finsupp_zero to_finsupp_one to_finsupp_add to_finsupp_mul to_finsupp_neg to_finsupp_sub
  (λ _ _, to_finsupp_smul _ _) (λ _ _, to_finsupp_smul _ _) to_finsupp_pow

@[simp] lemma coeff_neg (p : R[X]) (n : ℕ) : coeff (-p) n = -coeff p n :=
by { rcases p, rw [←of_finsupp_neg, coeff, coeff, finsupp.neg_apply] }

@[simp]
lemma coeff_sub (p q : R[X]) (n : ℕ) : coeff (p - q) n = coeff p n - coeff q n :=
by { rcases p, rcases q, rw [←of_finsupp_sub, coeff, coeff, coeff, finsupp.sub_apply] }

@[simp] lemma monomial_neg (n : ℕ) (a : R) : monomial n (-a) = -(monomial n a) :=
by rw [eq_neg_iff_add_eq_zero, ←monomial_add, neg_add_self, monomial_zero_right]

@[simp] lemma support_neg {p : R[X]} : (-p).support = p.support :=
by { rcases p, rw [←of_finsupp_neg, support, support, finsupp.support_neg] }

@[simp]
lemma C_eq_int_cast (n : ℤ) : C (n : R) = n :=
(C : R →+* _).map_int_cast n

end ring

instance [comm_ring R] : comm_ring R[X] :=
function.injective.comm_ring to_finsupp to_finsupp_injective
  to_finsupp_zero to_finsupp_one to_finsupp_add to_finsupp_mul to_finsupp_neg to_finsupp_sub
  (λ _ _, to_finsupp_smul _ _) (λ _ _, to_finsupp_smul _ _) to_finsupp_pow

section nonzero_semiring

variables [semiring R] [nontrivial R]
instance : nontrivial R[X] :=
begin
  have h : nontrivial (add_monoid_algebra R ℕ) := by apply_instance,
  rcases h.exists_pair_ne with ⟨x, y, hxy⟩,
  refine ⟨⟨⟨x⟩, ⟨y⟩, _⟩⟩,
  simp [hxy],
end

lemma X_ne_zero : (X : R[X]) ≠ 0 :=
mt (congr_arg (λ p, coeff p 1)) (by simp)

end nonzero_semiring

@[simp] lemma nontrivial_iff [semiring R] : nontrivial R[X] ↔ nontrivial R :=
⟨λ h, let ⟨r, s, hrs⟩ := @exists_pair_ne _ h in nontrivial.of_polynomial_ne hrs,
  λ h, @polynomial.nontrivial _ _ h⟩

section repr
variables [semiring R]
open_locale classical

instance [has_repr R] : has_repr R[X] :=
⟨λ p, if p = 0 then "0"
  else (p.support.sort (≤)).foldr
    (λ n a, a ++ (if a = "" then "" else " + ") ++
      if n = 0
        then "C (" ++ repr (coeff p n) ++ ")"
        else if n = 1
          then if (coeff p n) = 1 then "X" else "C (" ++ repr (coeff p n) ++ ") * X"
          else if (coeff p n) = 1 then "X ^ " ++ repr n
            else "C (" ++ repr (coeff p n) ++ ") * X ^ " ++ repr n) ""⟩

end repr

end polynomial


import algebra.order.archimedean

/-! # IMO 2006 A1 -/

namespace IMOSL
namespace IMO2006A1

open function

private lemma int_seq_eventually_constant_of_mono_bdd_above
  {a : ℕ → ℤ} (h : monotone a) {c : ℤ} (h0 : ∀ n : ℕ, a n ≤ c) :
  ∃ (d : ℤ) (_ : d ≤ c) (N : ℕ), ∀ n : ℕ, N ≤ n → a n = d :=
begin
  suffices : ∃ N : ℕ, ∀ n : ℕ, N ≤ n → a n.succ ≤ a n,
  { rcases this with ⟨N, h1⟩,
    refine ⟨a N, h0 N, N, nat.le_induction (by refl) _⟩,
    intros n h2 h3; rw ← h3; clear h3,
    exact le_antisymm (h1 n h2) (h n.le_succ) },

  contrapose! h0,
  cases exists_lt (a 0) with d h1,
  cases lt_or_le c d with h2 h2,
  exact ⟨0, lt_trans h2 h1⟩,
  revert h2 c; refine int.le_induction ⟨0, h1⟩ _,
  rintros x - ⟨k, h3⟩; clear h1 d,
  replace h0 := h0 k,
  rcases h0 with ⟨n, h0, h1⟩,
  exact ⟨n.succ, lt_of_le_of_lt (le_trans h3 (h h0)) h1⟩
end

section basic_results

variables {R : Type*} [linear_ordered_ring R] [floor_ring R]

def f (r : R) := (⌊r⌋ : R) * int.fract r

private lemma f_nonneg_of_nonneg {r : R} (h : 0 ≤ r) : 0 ≤ f r :=
  mul_nonneg (by rwa [int.cast_nonneg, int.le_floor, int.cast_zero]) (int.fract_nonneg r)

private lemma f_iterate_nonneg {r : R} (h : 0 ≤ r) (n : ℕ) : 0 ≤ (f^[n] r) :=
begin
  induction n with n n_ih,
  rw [iterate_zero, id.def]; exact h,
  rw [iterate_succ', comp_app]; exact f_nonneg_of_nonneg n_ih
end

private lemma f_floor_eq_zero {r : R} (h : ⌊r⌋ = 0) : f r = 0 :=
  by rw [f, h, int.cast_zero, zero_mul]

private lemma f_floor_lt_floor_of_ge_one {r : R} (h : 1 ≤ r) : ⌊f r⌋ < ⌊r⌋ :=
begin
  rw [int.floor_lt, f, ← sub_pos, ← mul_one_sub]; apply mul_pos,
  rwa [int.cast_pos, ← int.add_one_le_iff, zero_add, int.le_floor, int.cast_one],
  rw sub_pos; exact int.fract_lt_one r
end

private lemma f_nonpos_of_nonpos {r : R} (h : r ≤ 0) : f r ≤ 0 :=
  mul_nonpos_of_nonpos_of_nonneg (le_trans (int.floor_le r) h) (int.fract_nonneg r)

private lemma f_iterate_nonpos {r : R} (h : r ≤ 0) (n : ℕ) : f^[n] r ≤ 0 :=
begin
  induction n with n n_ih,
  rw [iterate_zero, id.def]; exact h,
  rw [iterate_succ', comp_app]; exact f_nonpos_of_nonpos n_ih
end

private lemma f_floor_ge_of_nonpos {r : R} (h : r ≤ 0) : ⌊r⌋ ≤ ⌊f r⌋ :=
begin
  rw [int.le_floor, f, ← sub_nonpos, ← mul_one_sub]; apply mul_nonpos_of_nonpos_of_nonneg,
  rw int.cast_nonpos; exact int.floor_nonpos h,
  rw sub_nonneg; exact le_of_lt (int.fract_lt_one r)
end

private lemma f_between_neg_one_and_zero {r : R} (h : -1 < r) (h0 : r < 0) :
  f r = -1 - r ∧ (f^[2]) r = r :=
begin
  revert r h h0,
  suffices : ∀ {r : R}, -1 < r → r < 0 → f r = -1 - r,
  { intros r h1 h2,
    have h3 := this h1 h2,
    refine ⟨h3, _⟩,
    rw ← sub_neg at h1; rw [← add_right_neg (1 : R), ← neg_lt_sub_iff_lt_add] at h2,
    rw [iterate_succ, iterate_one, comp_app, h3, this h2 h1, sub_sub_cancel] },

  intros r h h0,
  suffices : ⌊r⌋ = -1,
    rw [f, int.fract, this, int.cast_neg, int.cast_one, neg_one_mul, neg_sub],
  rw [int.floor_eq_iff, int.cast_neg, int.cast_one, neg_add_self],
  exact ⟨le_of_lt h, h0⟩
end

private lemma f_special_value {k : ℕ} {r : R} (h : (k + 1 : R) * r = -k ^ 2) : f r = r :=
begin
  suffices : ⌊r⌋ = -k,
    rw [f, int.fract, this, int.cast_neg, int.cast_coe_nat, neg_mul, sub_neg_eq_add,
        mul_add, ← sq, neg_add, ← h, add_one_mul, neg_add_cancel_left],
  have h0 : 0 < (k : R) + 1 := add_pos_of_nonneg_of_pos k.cast_nonneg one_pos,
  rw [int.floor_eq_iff, int.cast_neg, int.cast_coe_nat]; split,
  rw [← mul_le_mul_left h0, h, add_one_mul, mul_neg, ← sq, add_le_iff_nonpos_right, neg_nonpos],
  exact k.cast_nonneg,
  rw [← mul_lt_mul_left h0, h, add_one_mul, mul_add_one, mul_neg, add_assoc,
      ← sq, lt_add_iff_pos_right, ← add_assoc, add_neg_self, zero_add],
  exact one_pos
end

private lemma f_floor_iterate_const [archimedean R]
  {k : ℕ} (h : 1 < k) {r : R} (h0 : ∀ n : ℕ, ⌊(f^[n]) r⌋ = -k) : (k + 1 : R) * r = -k ^ 2 :=
begin
  ---- Setup
  rw eq_neg_iff_add_eq_zero,
  generalize h1 : (k + 1 : R) * r + k ^ 2 = c,

  ---- For any `n : ℕ`, `(k + 1) (f^n(r) - r) = ((-k)^n - 1) c`
  replace h1 : ∀ n : ℕ, (k + 1 : R) * ((f^[n]) r - r) = ((-k) ^ n - 1) * c :=
  begin
    intros n,
    rw sub_one_mul; nth_rewrite 1 ← h1,
    rw [eq_sub_iff_add_eq, mul_sub, ← add_assoc, sub_add_cancel],
    induction n with n n_ih,
    rw [iterate_zero, id.def, h1, pow_zero, one_mul],
    rw [iterate_succ', comp_app, pow_succ _ n, mul_assoc, ← n_ih],
    replace h0 := h0 n,
    generalize_hyp : (f^[n]) r = x at h0 n_ih ⊢,
    rw [f, int.fract, h0, int.cast_neg, int.cast_coe_nat, sub_neg_eq_add,
        neg_mul, neg_mul, mul_neg, ← sub_eq_neg_add, ← neg_sub, neg_inj, mul_add,
        ← sq, mul_add, add_sub_assoc, ← sub_one_mul, add_sub_cancel, mul_add,
        add_left_inj, ← mul_assoc, ← mul_assoc, add_one_mul, mul_add_one]
  end,

  ---- For any `n : ℕ`, `|f^n(r) - r| < 1`
  replace h0 : ∀ n : ℕ, |(f^[n]) r - r| < 1 :=
  begin
    intros n,
    have h2 := h0 n,
    replace h0 := h0 0,
    rw [iterate_zero, id.def] at h0,
    rw [int.floor_eq_iff, int.cast_neg, int.cast_coe_nat] at h0 h2,
    rw [abs_sub_lt_iff, sub_lt_iff_lt_add, sub_lt_iff_lt_add, add_comm, add_comm (1 : R)],
    exact ⟨lt_of_lt_of_le h2.2 (add_le_add_right h0.1 _),
           lt_of_lt_of_le h0.2 (add_le_add_right h2.1 _)⟩
  end,

  ---- Final step
  by_contra h2; rw [← ne.def, ← abs_pos] at h2,
  replace h2 := archimedean.arch (k + 1 : R) h2,
  cases h2 with n h2,
  replace h1 := congr_arg has_abs.abs (h1 n),
  revert h1; have h1 : 0 < (k : R) + 1 := add_pos_of_nonneg_of_pos k.cast_nonneg one_pos,
  rw [abs_mul, abs_mul, abs_of_nonneg (le_of_lt h1)],
  refine ne_of_lt (lt_of_lt_of_le ((mul_lt_mul_left h1).mpr (h0 n)) _),
  rw mul_one; refine le_trans h2 _,
  clear h0 h1 h2,
  rw nsmul_eq_mul,
  refine mul_le_mul_of_nonneg_right (le_trans _ (abs_sub_abs_le_abs_sub _ _)) (abs_nonneg c),
  rw [abs_one, abs_pow, abs_neg, nat.abs_cast, le_sub_iff_add_le,
      ← nat.cast_succ, ← nat.cast_pow, nat.cast_le, nat.succ_le_iff],
  exact nat.lt_pow_self h n
end

end basic_results

/-- Final solution, case `x ≥ 0` -/
theorem final_solution_x_nonneg {R : Type*} [linear_ordered_ring R] [floor_ring R]
  {x : R} (h : 0 ≤ x) : ∀ n : ℕ, ⌊x⌋ < n → (f^[n]) x = 0 :=
begin
  ---- Start with casting `⌊x⌋` to `K : ℕ`
  lift ⌊x⌋ to ℕ using by rwa [int.le_floor, int.cast_zero] with K h0,

  ---- Reduce to showing `0 ≤ ⌊f^n(x)⌋ ≤ K - n` for all `n ≤ K`
  suffices : ∀ n : ℕ, n ≤ K → ⌊(f^[n]) x⌋ ≤ ↑(K - n),
  { replace this := this K (le_refl K),
    rw [nat.sub_self, nat.cast_zero] at this,
    simp_rw [nat.cast_lt, ← nat.succ_le_iff],
    refine nat.le_induction _ (λ n h1 h2, _),
    rw [iterate_succ', comp_app, f_floor_eq_zero (le_antisymm this _)],
    rw [int.le_floor, int.cast_zero]; exact f_iterate_nonneg h K,
    rw [iterate_succ', comp_app, h2, f, int.floor_zero, int.cast_zero, zero_mul] },

  ---- Proceed by induction, with trivial base case
  intros n h1; induction n with n n_ih,
  rw [iterate_zero, id.def, ← h0, nat.sub_zero],
  replace n_ih := n_ih (le_trans n.le_succ h1),
  rw [iterate_succ', comp_app],
  have h2 := f_iterate_nonneg h n,
  rw [← int.cast_zero, ← int.le_floor, le_iff_eq_or_lt, eq_comm] at h2,
  cases h2 with h2 h2,
  rw [f_floor_eq_zero h2, int.floor_zero]; exact nat.cast_nonneg _,
  rw [← int.add_one_le_iff, zero_add, int.le_floor, int.cast_one] at h2,
  replace n_ih := lt_of_lt_of_le (f_floor_lt_floor_of_ge_one h2) n_ih,
  rw ← int.le_sub_one_iff at n_ih,
  convert n_ih; clear h0 h2 n_ih,
  rw le_iff_exists_add at h1,
  rcases h1 with ⟨c, rfl⟩,
  rw [nat.add_sub_cancel_left, nat.succ_eq_add_one, add_assoc,
      nat.add_sub_cancel_left, nat.cast_add, nat.cast_one, add_tsub_cancel_left]
end

/-- Final solution, case `x ≤ 0` -/
theorem final_solution_x_nonpos {R : Type*} [linear_ordered_ring R] [floor_ring R] [archimedean R]
  {x : R} (h : x ≤ 0) :
  (∃ N k : ℕ, (k + 1 : R) * (f^[N] x) = -k ^ 2) ∨ (∃ N : ℕ, -1 < (f^[N]) x ∧ (f^[N]) x < 0) :=
begin
  ---- First obtain some `N` such that `(⌊f^n(x)⌋)_{n ≥ 0}` stabilizes
  obtain ⟨d, h0, N, h1⟩ : ∃ (d : ℤ) (_ : d ≤ 0) (N : ℕ), ∀ n : ℕ, N ≤ n → ⌊(f^[n]) x⌋ = d :=
  begin
    have h0 : ∀ n : ℕ, ⌊(f^[n]) x⌋ ≤ 0 := λ n, int.floor_nonpos (f_iterate_nonpos h n),
    convert int_seq_eventually_constant_of_mono_bdd_above _ h0,
    intros m; refine nat.le_induction (by refl) _,
    simp only []; intros n h0 h1,
    rw [iterate_succ', comp_app],
    exact le_trans h1 (f_floor_ge_of_nonpos (f_iterate_nonpos h n))
  end,

  ---- Remove the case `d = 0` and `d = -1`
  rw [le_iff_eq_or_lt, ← int.le_sub_one_iff, zero_sub, le_iff_eq_or_lt] at h0,
  rcases h0 with rfl | rfl | h0,
  left; refine ⟨N + 1, 0, _⟩,
  rw [nat.cast_zero, zero_add, one_mul, zero_pow two_pos, neg_zero, iterate_succ', comp_app],
  exact f_floor_eq_zero (h1 N (le_refl N)),
  have h2 := h1 N (le_refl N),
  rw [int.floor_eq_iff, le_iff_lt_or_eq] at h2,
  rcases h2 with ⟨h2 | h2, h3⟩,
  rw [int.cast_neg, int.cast_one] at h2 h3,
  rw neg_add_self at h3; right; exact ⟨N, h2, h3⟩,
  exfalso; clear h3,
  replace h1 := h1 N.succ N.le_succ,
  rw [iterate_succ', comp_app, ← h2, f, int.fract, int.floor_int_cast,
      sub_self, mul_zero, int.floor_zero, zero_eq_neg] at h1,
  revert h1; exact one_ne_zero,

  ---- Work on the case `d < -1`
  left; rw lt_neg at h0,
  lift -d to ℕ using le_trans zero_le_one (le_of_lt h0) with k h2,
  rw eq_neg_iff_eq_neg at h2; subst h2,
  rw nat.one_lt_cast at h0,
  refine ⟨N, k, f_floor_iterate_const h0 (λ n, _)⟩,
  replace h1 := h1 (n + N) le_add_self,
  rwa [iterate_add, comp_app] at h1
end

/-- Final solution -/
theorem final_solution {R : Type*} [linear_ordered_ring R] [floor_ring R] [archimedean R] (x : R) :
  ∃ N : ℕ, ∀ n : ℕ, N ≤ n → (f^[n + 2]) x = (f^[n]) x :=
begin
  cases le_total 0 x with h h,

  ---- Case 1: `x ≥ 0`
  { lift ⌊x⌋ to ℕ using by rwa [int.le_floor, int.cast_zero] with K h0,
    replace h := final_solution_x_nonneg h,
    simp_rw [← h0, nat.cast_lt, ← nat.succ_le_iff] at h,
    exact ⟨K + 1, λ n h1, by rw [h n h1, h (n + 2) (le_add_right h1)]⟩ },

  ---- Case 2: `x ≤ 0`
  { replace h := final_solution_x_nonpos h,
    rcases h with ⟨N, k, h⟩ | ⟨N, h, h0⟩,

    -- Subcase 2.1: `(k + 1) f^N(x) = -k^2` for some `N k : ℕ`
    { replace h := f_special_value h; clear k,
      suffices : ∀ {n : ℕ}, N ≤ n → (f^[n]) x = (f^[N]) x,
        exact ⟨N, λ n h0, by rw [this h0, this (le_add_right h0)]⟩,
      refine nat.le_induction (by refl) _,
      rintros n - h0; rw [iterate_succ', comp_app, h0, h] },

    -- Subcase 2.2: `-1 < f^N(x) < 0` for some `N : ℕ`
    { replace h := f_between_neg_one_and_zero h h0,
      rcases h with ⟨-, h⟩; clear h0,
      refine ⟨N, λ n h0, _⟩,
      rw le_iff_exists_add at h0; rcases h0 with ⟨c, rfl⟩,
      simp_rw [add_comm N, add_right_comm c N, iterate_add, comp_app, h] } }
end

end IMO2006A1
end IMOSL


/-!
# Monad Laws

In the previous sections you learned how to use [Functors](functors.lean.md),
[Applicatives](applicatives.lean.md), and [Monads](monads.lean.md), and you played with some useful
instances including [Option](monads.lean.md), [IO](monads.lean.md), [Reader](readers.lean.md),
[State](states.lean.md) and [Except](except.lean.md) and you learned about composition using [Monad
Transformers](transformers.lean.md).

So far, you've learned the concrete details you need in order to _use_ monads in your Lean programs.
But there's still one more important concept you need if you want to _create_ new functors,
applicatives and monads. Namely, the notion of _structural "laws"_ -- rules that these type
classes should follow in order to meet other programmers' expectations about your code.

## Life without Laws

Remember Lean represents each of these abstract structures by a type class. Each of these type classes
has one or two main functions. So, as long as you implement those functions and it type checks, you
have a new functor, applicative, or monad, right?

Well not quite. Yes, your program will compile and you'll be able to use the instances. But this
doesn't mean your instances follow the mathematical constructs. If they don't, your instances won't
fulfill other programmers' expectations. Each type class has its own "laws". For instance, suppose
you have the following Point Functor:
-/
structure Point (α : Type) where
  x : α
  y : α
  deriving Repr, BEq

def Point.map (f : α → β) (s : Point α) : Point β :=
  { x := f s.y,  -- an example of something weird
    y := f s.x }

instance : Functor Point where
  map := Point.map

#eval (·+2) <$> (Point.mk 1 2) -- { x := 4, y := 3 }

/-!
This Point does something weird, when you `map` it because it transposes the `x` and `y` coordinates
which is not what other people would expect from a `map` function.  In fact, it breaks the rules
as you will see below.

## What are the Functor laws?

Functors have two laws: the _identity_ law, and the _composition_ law. These laws express behaviors that
your functor instances should follow. If they don't, other programmers will be very confused at the
effect your instances have on their program.

The identity law says that if you "map" the identity function (`id`) over your functor, the
resulting functor should be the same. A succinct way of showing this on a `List` functor is:

-/
def list1 := [1,2,3]

#eval id <$> list1 == list1 -- true
/-!

Now let's try the same test on the `Point` functor:
-/

def p1 : Point Nat := (Point.mk 1 2)

#eval id <$> p1 == p1 -- false

/-!
Oh, and look while the `List` is behaving well, the `Point` functor fails this identity test.

The _composition_ law says that if you "map" two functions in succession over a functor, this
should be the same as "composing" the functions and simply mapping that one super-function over the
functor.  In Lean you can compose two functions using `Function.comp f g` (or the syntax `f ∘ g`,
which you can type in VS code using `\o `) and you will get the same results from both of these
showing that the composition law holds for `List Nat`:

-/
def double (x : Nat) := x + x
def square (x : Nat) := x * x

#eval double <$> (square <$> list1) -- [2, 8, 18]

#eval (double <$> (square <$> list1)) == ((double ∘ square) <$> list1) -- true

-- ok, what about the Point class?
#eval double <$> (square <$> p1) -- { x := 2, y := 8 }
#eval (double ∘ square) <$> p1   -- { x := 8, y := 2 }

#eval double <$> (square <$> p1) == (double ∘ square) <$> p1  -- false
/-!
Note that composition also fails on the bad `Point` because the x/y transpose.

As you can see this bad `Point` implementation violates both of the functor laws. In this case it
would not be a true functor. Its behavior would confuse any other programmers trying to use it. You
should take care to make sure that your instances make sense. Once you get a feel for these type
classes, the likelihood is that the instances you'll create will follow the laws.

You can also write a bad functor that passes one law but not the other like this:
-/
def bad_option_map {α β : Type u} : (α → β) → Option α → Option β
  | _, _ => none

instance : Functor Option where
    map := bad_option_map

def t1 : Option Nat := some 10

#eval id <$> t1 == t1 -- false
#eval double <$> (square <$> t1) == (double ∘ square) <$> t1  -- true
/-!

This fails the id law but obeys the composition law. Hopefully this explains the value of these
laws, and you don't need to see any more bad examples!

## What are the Applicative Laws?

While functors have two laws, applicatives have four laws:

- Identity
- Homomorphism
- Interchange
- Composition

### Identity

`pure id <*> v = v`

Applying the identity function through an applicative structure should not change the underlying
values or structure.  For example:
-/
instance : Applicative List where
  pure := List.pure
  seq f x := List.bind f fun y => Functor.map y (x ())

#eval pure id <*> [1, 2, 3]  -- [1, 2, 3]
/-!

The `pure id` statement here is wrapping the identity function in an applicative structure
so that you can apply that over the container `[1, 2, 3]` using the Applicative `seq` operation
which has the notation `<*>`.

To prove this for all values `v` and any applicative `m` you can write this theorem:
-/
example [Applicative m] [LawfulApplicative m] (v : m α) :
  pure id <*> v = v :=
  by simp -- Goals accomplished 🎉
/-!

### Homomorphism

`pure f <*> pure x = pure (f x)`

Suppose you wrap a function and an object in `pure`. You can then apply the wrapped function over the
wrapped object. Of course, you could also apply the normal function over the normal object, and then
wrap it in `pure`. The homomorphism law states these results should be the same.

For example:

-/
def x := 1
def f := (· + 2)

#eval pure f <*> pure x = (pure (f x) : List Nat) -- true
/-!

You should see a distinct pattern here. The overriding theme of almost all these laws is that these
`Applicative` types should behave like normal containers. The `Applicative` functions should not
have any side effects. All they should do is facilitate the wrapping, unwrapping, and transformation
of data contained in the container resulting in a new container that has the same structure.

### Interchange

`u <*> pure y = pure (. y) <*> u`.

This law is is a little more complicated, so don't sweat it too much. It states that the order that
you wrap things shouldn't matter. One the left, you apply any applicative `u` over a pure wrapped
object. On the right, you first wrap a function applying the object as an argument. Note that `(·
y)` is short hand for: `fun f => f y`. Then you apply this to the first applicative `u`. These
should be the same.

For example:

-/
def y := 4
def g : List (Nat → Nat) := [(· + 2)]

#eval g <*> pure y = pure (· y) <*> g      -- true
/-!

You can prove this with the following theorem:
-/
example [Applicative m] [LawfulApplicative m] (u : m (α → β)) (y : α) :
  u <*> pure y = pure (· y) <*> u :=
  by simp [pure_seq] -- Goals accomplished 🎉

/-!

### Composition:

`u <*> v <*> w = u <*> (v <*> w)`

This final applicative law mimics the second functor law. It is a composition law. It states that
function composition holds across applications within the applicative:

For example:

-/
def u := [1, 2]
def v := [3, 4]
def w := [5, 6]

#eval pure (·+·+·) <*> u <*> v <*> w
-- [9, 10, 10, 11, 10, 11, 11, 12]

#eval let grouping := pure (·+·) <*> v <*> w
      pure (·+·) <*> u <*> grouping
-- [9, 10, 10, 11, 10, 11, 11, 12]
/-!

To test composition you see the separate grouping `(v <*> w)` then that can be used in the outer
sequence `u <*> grouping` to get the same final result `[9, 10, 10, 11, 10, 11, 11, 12]`.

## What are the Monad Laws?

Monads have three laws:

- Left Identity
- Right Identity
- Associativity

### Left Identity

Identity laws for monads specify that `pure` by itself shouldn't really change anything about the
structure or its values.

Left identity is `x >>= pure = x` and is demonstrated by the following examples on a monadic `List`:
-/
instance : Monad List  where
  pure := List.pure
  bind := List.bind

def a := ["apple", "orange"]

#eval a >>= pure      -- ["apple", "orange"]

#eval a >>= pure = a  -- true

/-!

### Right Identity

Right identity is `pure x >>= f = f x` and is demonstrated by the following example:
-/
def h (x : Nat) : Option Nat :=  some (x + 1)
def z := 5

#eval pure z >>= h                  -- some 6
#eval h z                           -- some 6

#eval pure z >>= h = h z            -- true
/-!

So in this example, with this specific `z` and `h`, you see that the rule holds true.

### Associativity

The associativity law is written as:
```lean,ignore
  x >>= f >>= g = x >>= (λ x => f x >>= g)
```
where `(x : m α)` and `(f : α → m β)` and `(g : β → m γ)`.

The associativity law is difficult to parse like some of the applicative laws, but what it is saying
is that if you change the grouping of `bind` operations, you should still get the same result.
This law has a parallel structure to the other composition laws.

You can see this in action in the following rewrite of `runOptionFuncsBind` from [monads](monads.lean.md):
-/
def optionFunc1 : String -> Option Nat
  | "" => none
  | str => some str.length

def optionFunc2 (i : Nat) : Option Float :=
  if i % 2 == 0 then none else some (i.toFloat * 3.14159)

def optionFunc3 (f : Float) : Option (List Nat) :=
  if f > 15.0 then none else some [f.floor.toUInt32.toNat, f.ceil.toUInt32.toNat]

def runOptionFuncsBind (input : String) : Option (List Nat) :=
   optionFunc1 input >>= optionFunc2 >>= optionFunc3

def runOptionFuncsBindGrouped (input : String) : Option (List Nat) :=
   optionFunc1 input >>= (λ x => optionFunc2 x >>= optionFunc3)

#eval runOptionFuncsBind "big"        -- some [9, 10]
#eval runOptionFuncsBindGrouped "big" -- some [9, 10]
/-!

Notice here we had to insert a `λ` function just like the definition says: `(λ x => f x >>= g)`.
This is because unlike applicatives, you can't resolve the structure of later operations without the
results of earlier operations quite as well because of the extra context monads provide. But you can
still group their later operations into composite functions taking their inputs from earlier on, and
the result should be the same.

## Summary

While these laws may be a bit difficult to understand just by looking at them, the good news is that
most of the instances you'll make will naturally follow the laws so long as you keep it simple, so
you shouldn't have to worry about them too much.

There are two main ideas from all the laws:

1. Applying the identity or pure function should not change the underlying values or structure.
1. It should not matter what order you group operations in.  Another way to state this is function
   composition should hold across your structures.

Following these laws will ensure other programmers are not confused by the behavior of your
new functors, applicatives and monads.

-/


import data.nat.basic

section universal
variables (α : Type) (p q : α → Prop)

example : (∀ x : α, p x ∧ q x) → ∀ y : α, p y :=
assume h : ∀ x : α, p x ∧ q x,
assume y: α,
show p y, from (h y).left

variable r : α → α → Prop
variable trans_r : ∀ {x y z}, r x y → r y z → r x z

variables a b c : α
variables (hab : r a b) (hbc : r b c)

#check trans_r
#check @trans_r a b c
#check trans_r hab
#check trans_r hab hbc
#check @trans_r a b c hab hbc

variable refl_r : ∀ x, r x x
variable symm_r : ∀ {x y}, r x y → r y x

example (a b c d : α) (hab : r a b) (hcb : r c b) (hcd : r c d) : r a d :=
  trans_r (trans_r hab (symm_r hcb)) hcd
end universal

section equality
universe u

#check @eq.refl.{u}
#check @eq.symm.{u}
#check @eq.trans.{u}

variables (α β : Type u) (a b c d: α)
variables (hab : a = b) (hcb : c = b) (hcd : c = d)

example : a = d := (hab.trans hcb.symm).trans hcd

example (f : α → β) (a : α) : (λ x, f x) a = f a := eq.refl _
example : 2 + 3 = 5 := rfl

example (α : Type u) (a b : α) (p : α → Prop) (h1 : a = b) (h2 : p a) : p b :=
  eq.subst h1 h2

example (α : Type u) (a b : α) (p : α → Prop) (h1 : a = b) (h2 : p a) : p b :=
  h1 ▸ h2

variables f g : α → ℕ
variable h₁ : a = b
variable h₂ : f = g

example : f a = f b := congr_arg f h₁
example : f a = g a := congr_fun h₂ a
example : f a = g b := congr h₂ h₁

variables (x y z : ℤ)

example (x y : ℕ) :
  (x + y) * (x + y) = x * x + y * x + x * y + y * y :=
have h1 : (x + y) * (x + y) = (x + y) * x + (x + y) * y,
  from mul_add (x + y) x y,
have h2 : (x + y) * (x + y) = x * x + y * x + (x * y + y * y),
  from (add_mul x y x) ▸ (add_mul x y y) ▸ h1,
h2.trans (add_assoc (x * x + y * x) (x * y) (y * y)).symm

end equality

section calculate

variables (a b c d e : ℕ)
variable h1 : a = b
variable h2 : b = c + 1
variable h3 : c = d
variable h4 : e = 1 + d

theorem T : a = e :=
calc
  a = b : h1
  ... = c + 1 : h2
  ... = d + 1 : congr_arg _ h3
  ... = 1 + d : add_comm d (1 : ℕ)
  ... = e : eq.symm h4

include h1 h2 h3 h4
theorem T' : a = e :=
calc
  a = b : by rw h1
  ... = c + 1 : by rw h2
  ... = d + 1 : by rw h3
  ... = 1 + d : by rw add_comm
  ... = e : by rw h4

theorem T'' : a = e := by rw [h1, h2, h3, add_comm, h4]

theorem T''' : a = e := by simp [add_comm, h1, h2, h3, h4]

example (x y : ℕ) :
  (x + y) * (x + y) = x * x + y * x + x * y + y * y :=
by rw [mul_add, add_mul, add_mul, ←add_assoc]

-- example (x y : ℕ) :
--   (x + y) * (x + y) = x * x + y * x + x * y + y * y :=
-- by simp [mul_add, ←add_assoc]

end calculate

section existential

open nat

example : ∃ x : ℕ, x > 0 :=
have h : 1 > 0, from zero_lt_succ 0,
exists.intro 1 h

#check @exists.intro

example (x y z : ℕ) (hxy : x < y) (hyz : y < z) : ∃ w, x < w ∧ w < z :=
  ⟨y, hxy, hyz⟩

variable g : ℕ → ℕ → ℕ
variable hg : g 0 0 = 0

theorem gex1 : ∃ x, g x x = x := ⟨0, hg⟩
theorem gex2 : ∃ x, g x 0 = x := ⟨0, hg⟩
theorem gex3 : ∃ x, g 0 0 = x := ⟨0, hg⟩
theorem gex4 : ∃ x, g x x = 0 := ⟨0, hg⟩

set_option pp.implicit true  -- display implicit arguments
#print gex1
#print gex2
#print gex3
#print gex4

variables (α : Type) (p q : α → Prop)

example (h : ∃ x, p x ∧ q x) : ∃ x, q x ∧ p x :=
exists.elim h
  (assume w,
    assume hw : p w ∧ q w,
    show ∃ x, q x ∧ p x, from ⟨w, hw.right, hw.left⟩)

example (h : ∃ x, p x ∧ q x) : ∃ x, q x ∧ p x :=
match h with ⟨w, hw⟩ :=
  ⟨w, hw.right, hw.left⟩
end

example (h : ∃ x, p x ∧ q x) : ∃ x, q x ∧ p x :=
match h with ⟨w, hpw, hqw⟩ :=
  ⟨w, hqw, hpw⟩
end

example (h : ∃ x, p x ∧ q x) : ∃ x, q x ∧ p x :=
let ⟨w, hpw, hqw⟩ := h in ⟨w, hqw, hpw⟩

example : (∃ x, p x ∧ q x) → ∃ x, q x ∧ p x :=
assume ⟨w, hpw, hqw⟩, ⟨w, hqw, hpw⟩

def is_even (a : nat) := ∃ b, a = 2 * b

theorem even_plus_even {a b : nat} (h1 : is_even a) (h2 : is_even b) : is_even (a + b) :=
exists.elim h1 (assume w1, assume hw1 : a = 2 * w1,
exists.elim h2 (assume w2, assume hw2 : b = 2 * w2,
exists.intro (w1 + w2)
  (calc
    a + b = 2 * w1 + 2 * w2 : by rw [hw1, hw2]
    ... = 2 * (w1 + w2) : by rw mul_add)))

theorem even_plus_even' {a b : nat} (h1 : is_even a) (h2 : is_even b) : is_even (a + b) :=
match h1, h2 with
  ⟨w1, hw1⟩, ⟨w2, hw2⟩ := ⟨w1 + w2, by rw [hw1, hw2, mul_add]⟩
end

variable a : α
variable r : Prop

open classical

example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) :=
iff.intro
  (assume ⟨a, (h : p a ∨ q a)⟩,
    or.elim h
      (assume hp : p a, or.inl ⟨a, hp⟩)
      (assume hq : q a, or.inr ⟨a, hq⟩)
  )
  (assume h : (∃ x, p x) ∨ (∃ x, q x),
    or.elim h
      (assume ⟨a, (h : p a)⟩, ⟨a, (or.inl h)⟩)
      (assume ⟨a, (h : q a)⟩, ⟨a, (or.inr h)⟩)
  )

example : (∃ x, p x → r) ↔ (∀ x, p x) → r :=
iff.intro
  (assume ⟨b, (hb : p b → r)⟩,
    assume h2 : ∀ x, p x,
    show r, from  hb (h2 b))
  (assume h1 : (∀ x, p x) → r,
    show ∃ x, p x → r, from
      by_cases
        (assume hap : ∀ x, p x, ⟨a, (λ _, h1 hap)⟩)
        (assume hnap : ¬ ∀ x, p x,
          by_contradiction
            (assume hnex : ¬ ∃ x, p x → r,
              have hap : ∀ x, p x, from
                assume x,
                by_contradiction
                  (assume hnp : ¬ p x,
                    have hex : ∃ x, p x → r,
                      from ⟨x, (assume hp, absurd hp hnp)⟩,
                    show false, from hnex hex),
              show false, from hnap hap)))

end existential


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.instances.irrational
import topology.algebra.order.archimedean
import topology.paracompact
import topology.metric_space.metrizable
import topology.metric_space.emetric_paracompact
import data.set.intervals.monotone

/-!
# Sorgenfrey line

In this file we define `sorgenfrey_line` (notation: `ℝₗ`) to be the Sorgenfrey line. It is the real
line with the topology space structure generated by half-open intervals `set.Ico a b`.

We prove that this line is a completely normal Hausdorff space but its product with itself is not a
normal space. In particular, this implies that the topology on `ℝₗ` is neither metrizable, nor
second countable.

## Notations

- `ℝₗ`: Sorgenfrey line.

## TODO

Prove that the Sorgenfrey line is a paracompact space.

-/

open set filter topological_space
open_locale topology filter
noncomputable theory

/-- The Sorgenfrey line. It is the real line with the topology space structure generated by
half-open intervals `set.Ico a b`. -/
@[derive [conditionally_complete_linear_order, linear_ordered_field, archimedean]]
def sorgenfrey_line : Type := ℝ

localized "notation (name := sorgenfrey_line) `ℝₗ` := sorgenfrey_line" in sorgenfrey_line

namespace sorgenfrey_line

/-- Ring homomorphism between the Sorgenfrey line and the standard real line. -/
def to_real : ℝₗ ≃+* ℝ := ring_equiv.refl ℝ

instance : topological_space ℝₗ :=
topological_space.generate_from {s : set ℝₗ | ∃ a b : ℝₗ, Ico a b = s}

lemma is_open_Ico (a b : ℝₗ) : is_open (Ico a b) :=
topological_space.generate_open.basic _ ⟨a, b, rfl⟩

lemma is_open_Ici (a : ℝₗ) : is_open (Ici a) :=
Union_Ico_right a ▸ is_open_Union (is_open_Ico a)

lemma nhds_basis_Ico (a : ℝₗ) : (𝓝 a).has_basis (λ b, a < b) (λ b, Ico a b) :=
begin
  rw topological_space.nhds_generate_from,
  haveI : nonempty {x // x ≤ a} := set.nonempty_Iic_subtype,
  have : (⨅ (x : {i // i ≤ a}), 𝓟 (Ici ↑x)) = 𝓟 (Ici a),
  { refine (is_least.is_glb _).infi_eq,
    exact ⟨⟨⟨a, le_rfl⟩, rfl⟩, forall_range_iff.2 $
      λ b, principal_mono.2 $ Ici_subset_Ici.2 b.2⟩, },
  simp only [mem_set_of_eq, infi_and, infi_exists, @infi_comm _ (_ ∈ _),
    @infi_comm _ (set ℝₗ), infi_infi_eq_right],
  simp_rw [@infi_comm _ ℝₗ (_ ≤ _), infi_subtype', ← Ici_inter_Iio, ← inf_principal, ← inf_infi,
    ← infi_inf, this, infi_subtype],
  suffices : (⨅ x ∈ Ioi a, 𝓟 (Iio x)).has_basis ((<) a) Iio, from this.principal_inf _,
  refine has_basis_binfi_principal _ nonempty_Ioi,
  exact directed_on_iff_directed.2 (directed_of_inf $ λ x y hxy, Iio_subset_Iio hxy),
end

lemma nhds_basis_Ico_rat (a : ℝₗ) :
  (𝓝 a).has_countable_basis (λ r : ℚ, a < r) (λ r, Ico a r) :=
begin
  refine ⟨(nhds_basis_Ico a).to_has_basis (λ b hb, _) (λ r hr, ⟨_, hr, subset.rfl⟩),
    set.to_countable _⟩,
  rcases exists_rat_btwn hb with ⟨r, har, hrb⟩,
  exact ⟨r, har, Ico_subset_Ico_right hrb.le⟩
end

lemma nhds_basis_Ico_inv_pnat (a : ℝₗ) :
  (𝓝 a).has_basis (λ n : ℕ+, true) (λ n, Ico a (a + n⁻¹)) :=
begin
  refine (nhds_basis_Ico a).to_has_basis (λ b hb, _)
    (λ n hn, ⟨_, lt_add_of_pos_right _ (inv_pos.2 $ nat.cast_pos.2 n.pos), subset.rfl⟩),
  rcases exists_nat_one_div_lt (sub_pos.2 hb) with ⟨k, hk⟩,
  rw [one_div] at hk,
  rw [← nat.cast_add_one] at hk,
  exact ⟨k.succ_pnat, trivial, Ico_subset_Ico_right (le_sub_iff_add_le'.1 hk.le)⟩
end

lemma nhds_countable_basis_Ico_inv_pnat (a : ℝₗ) :
  (𝓝 a).has_countable_basis (λ n : ℕ+, true) (λ n, Ico a (a + n⁻¹)) :=
⟨nhds_basis_Ico_inv_pnat a, set.to_countable _⟩

lemma nhds_antitone_basis_Ico_inv_pnat (a : ℝₗ) :
  (𝓝 a).has_antitone_basis (λ n : ℕ+, Ico a (a + n⁻¹)) :=
⟨nhds_basis_Ico_inv_pnat a, monotone_const.Ico $
  antitone.const_add (λ k l hkl, inv_le_inv_of_le (nat.cast_pos.2 k.pos) (nat.mono_cast hkl)) _⟩

lemma is_open_iff {s : set ℝₗ} : is_open s ↔ ∀ x ∈ s, ∃ y > x, Ico x y ⊆ s :=
is_open_iff_mem_nhds.trans $ forall₂_congr $ λ x hx, (nhds_basis_Ico x).mem_iff

lemma is_closed_iff {s : set ℝₗ} : is_closed s ↔ ∀ x ∉ s, ∃ y > x, disjoint (Ico x y) s :=
by simp only [← is_open_compl_iff, is_open_iff, mem_compl_iff, subset_compl_iff_disjoint_right]

lemma exists_Ico_disjoint_closed {a : ℝₗ} {s : set ℝₗ} (hs : is_closed s) (ha : a ∉ s) :
  ∃ b > a, disjoint (Ico a b) s :=
is_closed_iff.1 hs a ha

@[simp] lemma map_to_real_nhds (a : ℝₗ) : map to_real (𝓝 a) = 𝓝[≥] (to_real a) :=
begin
  refine ((nhds_basis_Ico a).map _).eq_of_same_basis _,
  simpa only [to_real.image_eq_preimage] using nhds_within_Ici_basis_Ico (to_real a)
end

lemma nhds_eq_map (a : ℝₗ) : 𝓝 a = map to_real.symm (𝓝[≥] a.to_real) :=
by simp_rw [← map_to_real_nhds, map_map, (∘), to_real.symm_apply_apply, map_id']

lemma nhds_eq_comap (a : ℝₗ) : 𝓝 a = comap to_real (𝓝[≥] a.to_real) :=
by rw [← map_to_real_nhds, comap_map to_real.injective]

@[continuity] lemma continuous_to_real : continuous to_real :=
continuous_iff_continuous_at.2 $ λ x,
  by { rw [continuous_at, tendsto, map_to_real_nhds], exact inf_le_left }

instance : order_closed_topology ℝₗ :=
⟨is_closed_le_prod.preimage (continuous_to_real.prod_map continuous_to_real)⟩

instance : has_continuous_add ℝₗ :=
begin
  refine ⟨continuous_iff_continuous_at.2 _⟩,
  rintro ⟨x, y⟩,
  simp only [continuous_at, nhds_prod_eq, nhds_eq_map, nhds_eq_comap (x + y), prod_map_map_eq,
    tendsto_comap_iff, tendsto_map'_iff, (∘), ← nhds_within_prod_eq],
  exact (continuous_add.tendsto _).inf (maps_to.tendsto $ λ x hx, add_le_add hx.1 hx.2)
end

lemma is_clopen_Ici (a : ℝₗ) : is_clopen (Ici a) := ⟨is_open_Ici a, is_closed_Ici⟩

lemma is_clopen_Iio (a : ℝₗ) : is_clopen (Iio a) :=
by simpa only [compl_Ici] using (is_clopen_Ici a).compl

lemma is_clopen_Ico (a b : ℝₗ) : is_clopen (Ico a b) :=
(is_clopen_Ici a).inter (is_clopen_Iio b)

instance : totally_disconnected_space ℝₗ :=
⟨λ s hs' hs x hx y hy, le_antisymm (hs.subset_clopen (is_clopen_Ici x) ⟨x, hx, le_rfl⟩ hy)
  (hs.subset_clopen (is_clopen_Ici y) ⟨y, hy, le_rfl⟩ hx)⟩

instance : first_countable_topology ℝₗ := ⟨λ x, (nhds_basis_Ico_rat x).is_countably_generated⟩

/-- Sorgenfrey line is a completely normal Hausdorff topological space. -/
instance : t5_space ℝₗ :=
begin
  /- Let `s` and `t` be disjoint closed sets. For each `x ∈ s` we choose `X x` such that
  `set.Ico x (X x)` is disjoint with `t`. Similarly, for each `y ∈ t` we choose `Y y` such that
  `set.Ico y (Y y)` is disjoint with `s`. Then `⋃ x ∈ s, Ico x (X x)` and `⋃ y ∈ t, Ico y (Y y)` are
  disjoint open sets that include `s` and `t`. -/
  refine ⟨λ s t hd₁ hd₂, _⟩,
  choose! X hX hXd
    using λ x (hx : x ∈ s), exists_Ico_disjoint_closed is_closed_closure (disjoint_left.1 hd₂ hx),
  choose! Y hY hYd
    using λ y (hy : y ∈ t), exists_Ico_disjoint_closed is_closed_closure (disjoint_right.1 hd₁ hy),
  refine disjoint_of_disjoint_of_mem _
    (bUnion_mem_nhds_set $ λ x hx, (is_open_Ico x (X x)).mem_nhds $ left_mem_Ico.2 (hX x hx))
    (bUnion_mem_nhds_set $ λ y hy, (is_open_Ico y (Y y)).mem_nhds $ left_mem_Ico.2 (hY y hy)),
  simp only [disjoint_Union_left, disjoint_Union_right, Ico_disjoint_Ico],
  intros y hy x hx,
  cases le_total x y with hle hle,
  { calc min (X x) (Y y) ≤ X x : min_le_left _ _
    ... ≤ y : not_lt.1 (λ hyx, (hXd x hx).le_bot ⟨⟨hle, hyx⟩, subset_closure hy⟩)
    ... ≤ max x y : le_max_right _ _ },
  { calc min (X x) (Y y) ≤ Y y : min_le_right _ _
    ... ≤ x : not_lt.1 $ λ hxy, (hYd y hy).le_bot ⟨⟨hle, hxy⟩, subset_closure hx⟩
    ... ≤ max x y : le_max_left _ _ }
end

lemma dense_range_coe_rat : dense_range (coe : ℚ → ℝₗ) :=
begin
  refine dense_iff_inter_open.2 _,
  rintro U Uo ⟨x, hx⟩,
  rcases is_open_iff.1 Uo _ hx with ⟨y, hxy, hU⟩,
  rcases exists_rat_btwn hxy with ⟨z, hxz, hzy⟩,
  exact ⟨z, hU ⟨hxz.le, hzy⟩, mem_range_self _⟩
end

instance : separable_space ℝₗ := ⟨⟨_, countable_range _, dense_range_coe_rat⟩⟩

lemma is_closed_antidiagonal (c : ℝₗ) : is_closed {x : ℝₗ × ℝₗ | x.1 + x.2 = c} :=
is_closed_singleton.preimage continuous_add

lemma is_clopen_Ici_prod (x : ℝₗ × ℝₗ) : is_clopen (Ici x) :=
(Ici_prod_eq x).symm ▸ (is_clopen_Ici _).prod (is_clopen_Ici _)

/-- Any subset of an antidiagonal `{(x, y) : ℝₗ × ℝₗ| x + y = c}` is a closed set. -/
lemma is_closed_of_subset_antidiagonal {s : set (ℝₗ × ℝₗ)} {c : ℝₗ}
  (hs : ∀ x : ℝₗ × ℝₗ, x ∈ s → x.1 + x.2 = c) : is_closed s :=
begin
  rw [← closure_subset_iff_is_closed],
  rintro ⟨x, y⟩ H,
  obtain rfl : x + y = c,
  { change (x, y) ∈ {p : ℝₗ × ℝₗ | p.1 + p.2 = c},
    exact closure_minimal (hs : s ⊆ {x | x.1 + x.2 = c}) (is_closed_antidiagonal c) H },
  rcases mem_closure_iff.1 H (Ici (x, y)) (is_clopen_Ici_prod _).1 le_rfl
    with ⟨⟨x', y'⟩, ⟨hx : x ≤ x', hy : y ≤ y'⟩, H⟩,
  convert H,
  { refine hx.antisymm _,
    rwa [← add_le_add_iff_right, hs _ H, add_le_add_iff_left] },
  { refine hy.antisymm _,
    rwa [← add_le_add_iff_left, hs _ H, add_le_add_iff_right] }
end

lemma nhds_prod_antitone_basis_inv_pnat (x y : ℝₗ) :
  (𝓝 (x, y)).has_antitone_basis (λ n : ℕ+, Ico x (x + n⁻¹) ×ˢ Ico y (y + n⁻¹)) :=
begin
  rw [nhds_prod_eq],
  exact (nhds_antitone_basis_Ico_inv_pnat x).prod (nhds_antitone_basis_Ico_inv_pnat y)
end

/-- The product of the Sorgenfrey line and itself is not a normal topological space. -/
lemma not_normal_space_prod : ¬normal_space (ℝₗ × ℝₗ) :=
begin
  have h₀ : ∀ {n : ℕ+}, (0 : ℝ) < n⁻¹, from λ n, inv_pos.2 (nat.cast_pos.2 n.pos),
  have h₀' : ∀ {n : ℕ+} {x : ℝ}, x < x + n⁻¹, from λ n x, lt_add_of_pos_right _ h₀,
  introI,
  /- Let `S` be the set of points `(x, y)` on the line `x + y = 0` such that `x` is rational.
  Let `T` be the set of points `(x, y)` on the line `x + y = 0` such that `x` is irrational.
  These sets are closed, see `sorgenfrey_line.is_closed_of_subset_antidiagonal`, and disjoint. -/
  set S := {x : ℝₗ × ℝₗ | x.1 + x.2 = 0 ∧ ∃ r : ℚ, ↑r = x.1},
  set T := {x : ℝₗ × ℝₗ | x.1 + x.2 = 0 ∧ irrational x.1.to_real},
  have hSc : is_closed S, from is_closed_of_subset_antidiagonal (λ x hx, hx.1),
  have hTc : is_closed T, from is_closed_of_subset_antidiagonal (λ x hx, hx.1),
  have hd : disjoint S T,
  { rw disjoint_iff_inf_le,
    rintro ⟨x, y⟩ ⟨⟨-, r, rfl : _ = x⟩, -, hr⟩,
    exact r.not_irrational hr },
  /- Consider disjoint open sets `U ⊇ S` and `V ⊇ T`. -/
  rcases normal_separation hSc hTc hd with ⟨U, V, Uo, Vo, SU, TV, UV⟩,
  /- For each point `(x, -x) ∈ T`, choose a neighborhood
  `Ico x (x + k⁻¹) ×ˢ Ico (-x) (-x + k⁻¹) ⊆ V`. -/
  have : ∀ x : ℝₗ, irrational x.to_real →
    ∃ k : ℕ+, Ico x (x + k⁻¹) ×ˢ Ico (-x) (-x + k⁻¹) ⊆ V,
  { intros x hx,
    have hV : V ∈ 𝓝 (x, -x), from Vo.mem_nhds (@TV (x, -x) ⟨add_neg_self x, hx⟩),
    exact (nhds_prod_antitone_basis_inv_pnat _ _).mem_iff.1 hV },
  choose! k hkV,
  /- Since the set of irrational numbers is a dense Gδ set in the usual topology of `ℝ`, there
  exists `N > 0` such that the set `C N = {x : ℝ | irrational x ∧ k x = N}` is dense in a nonempty
  interval. In other words, the closure of this set has a nonempty interior. -/
  set C : ℕ+ → set ℝ := λ n, closure {x | irrational x ∧ k (to_real.symm x) = n},
  have H : {x : ℝ | irrational x} ⊆ ⋃ n, C n,
    from λ x hx, mem_Union.2 ⟨_, subset_closure ⟨hx, rfl⟩⟩,
  have Hd : dense (⋃ n, interior (C n)) :=
    is_Gδ_irrational.dense_Union_interior_of_closed dense_irrational (λ _, is_closed_closure) H,
  obtain ⟨N, hN⟩ : ∃ n : ℕ+, (interior $ C n).nonempty, from nonempty_Union.mp Hd.nonempty,
  /- Choose a rational number `r` in the interior of the closure of `C N`, then choose `n ≥ N > 0`
  such that `Ico r (r + n⁻¹) × Ico (-r) (-r + n⁻¹) ⊆ U`. -/
  rcases rat.dense_range_cast.exists_mem_open is_open_interior hN with ⟨r, hr⟩,
  have hrU : ((r, -r) : ℝₗ × ℝₗ) ∈ U, from @SU (r, -r) ⟨add_neg_self _, r, rfl⟩,
  obtain ⟨n, hnN, hn⟩ : ∃ n  (hnN : N ≤ n), Ico (r : ℝₗ) (r + n⁻¹) ×ˢ Ico (-r : ℝₗ) (-r + n⁻¹) ⊆ U,
    from ((nhds_prod_antitone_basis_inv_pnat _ _).has_basis_ge N).mem_iff.1 (Uo.mem_nhds hrU),
  /- Finally, choose `x ∈ Ioo (r : ℝ) (r + n⁻¹) ∩ C N`. Then `(x, -r)` belongs both to `U` and `V`,
  so they are not disjoint. This contradiction completes the proof. -/
  obtain ⟨x, hxn, hx_irr, rfl⟩ :
    ∃ x : ℝ, x ∈ Ioo (r : ℝ) (r + n⁻¹) ∧ irrational x ∧ k (to_real.symm x) = N,
  { have : (r : ℝ) ∈ closure (Ioo (r : ℝ) (r + n⁻¹)),
    { rw [closure_Ioo h₀'.ne, left_mem_Icc], exact h₀'.le },
    rcases mem_closure_iff_nhds.1 this _ (mem_interior_iff_mem_nhds.1 hr) with ⟨x', hx', hx'ε⟩,
    exact mem_closure_iff.1 hx' _ is_open_Ioo hx'ε },
  refine UV.le_bot (_ : (to_real.symm x, -↑r) ∈ _),
  refine ⟨hn ⟨_, _⟩, hkV (to_real.symm x) hx_irr ⟨_, _⟩⟩,
  { exact Ioo_subset_Ico_self hxn },
  { exact left_mem_Ico.2 h₀' },
  { exact left_mem_Ico.2 h₀' },
  { refine (nhds_antitone_basis_Ico_inv_pnat (-x)).2 hnN ⟨neg_le_neg hxn.1.le, _⟩,
    simp only [add_neg_lt_iff_le_add', lt_neg_add_iff_add_lt],
    exact hxn.2 }
end

/-- Topology on the Sorgenfrey line is not metrizable. -/
lemma not_metrizable_space : ¬metrizable_space ℝₗ :=
begin
  introI,
  letI := metrizable_space_metric ℝₗ,
  exact not_normal_space_prod infer_instance
end

/-- Topology on the Sorgenfrey line is not second countable. -/
lemma not_second_countable_topology : ¬second_countable_topology ℝₗ :=
by { introI, exact not_metrizable_space (metrizable_space_of_t3_second_countable _) }

end sorgenfrey_line


/-
Copyright (c) 2022 Praneeth Kolichala. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Praneeth Kolichala
-/
import data.nat.basic

/-!
# Additional properties of binary recursion on `nat`

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file documents additional properties of binary recursion,
which allows us to more easily work with operations which do depend
on the number of leading zeros in the binary representation of `n`.
For example, we can more easily work with `nat.bits` and `nat.size`.

See also: `nat.bitwise`, `nat.pow` (for various lemmas about `size` and `shiftl`/`shiftr`),
and `nat.digits`.
-/

namespace nat

universe u
variables {n : ℕ}

/-! ### `bodd_div2` and `bodd` -/

@[simp] theorem bodd_div2_eq (n : ℕ) : bodd_div2 n = (bodd n, div2 n) :=
by unfold bodd div2; cases bodd_div2 n; refl

@[simp] lemma bodd_bit0 (n) : bodd (bit0 n) = ff := bodd_bit ff n
@[simp] lemma bodd_bit1 (n) : bodd (bit1 n) = tt := bodd_bit tt n

@[simp] lemma div2_bit0 (n) : div2 (bit0 n) = n := div2_bit ff n
@[simp] lemma div2_bit1 (n) : div2 (bit1 n) = n := div2_bit tt n

/-! ### `bit0` and `bit1` -/

-- There is no need to prove `bit0_eq_zero : bit0 n = 0 ↔ n = 0`
-- as this is true for any `[semiring R] [no_zero_divisors R] [char_zero R]`

-- However the lemmas `bit0_eq_bit0`, `bit1_eq_bit1`, `bit1_eq_one`, `one_eq_bit1`
-- need `[ring R] [no_zero_divisors R] [char_zero R]` in general,
-- so we prove `ℕ` specialized versions here.
@[simp] lemma bit0_eq_bit0 {m n : ℕ} : bit0 m = bit0 n ↔ m = n :=
⟨nat.bit0_inj, λ h, by subst h⟩

@[simp] lemma bit1_eq_bit1 {m n : ℕ} : bit1 m = bit1 n ↔ m = n :=
⟨nat.bit1_inj, λ h, by subst h⟩

@[simp] lemma bit1_eq_one {n : ℕ} : bit1 n = 1 ↔ n = 0 :=
⟨@nat.bit1_inj n 0, λ h, by subst h⟩
@[simp] lemma one_eq_bit1 {n : ℕ} : 1 = bit1 n ↔ n = 0 :=
⟨λ h, (@nat.bit1_inj 0 n h).symm, λ h, by subst h⟩

theorem bit_add : ∀ (b : bool) (n m : ℕ), bit b (n + m) = bit ff n + bit b m
| tt := bit1_add
| ff := bit0_add

theorem bit_add' : ∀ (b : bool) (n m : ℕ), bit b (n + m) = bit b n + bit ff m
| tt := bit1_add'
| ff := bit0_add

theorem bit_ne_zero (b) {n} (h : n ≠ 0) : bit b n ≠ 0 :=
by cases b; [exact nat.bit0_ne_zero h, exact nat.bit1_ne_zero _]

lemma bit0_mod_two : bit0 n % 2 = 0 := by { rw nat.mod_two_of_bodd, simp }

lemma bit1_mod_two : bit1 n % 2 = 1 := by { rw nat.mod_two_of_bodd, simp }

lemma pos_of_bit0_pos {n : ℕ} (h : 0 < bit0 n) : 0 < n :=
by { cases n, cases h, apply succ_pos, }

@[simp]

@[simp] lemma bit_cases_on_bit0 {C : ℕ → Sort u} (H : Π b n, C (bit b n)) (n : ℕ) :
  bit_cases_on (bit0 n) H = H ff n :=
bit_cases_on_bit H ff n

@[simp] lemma bit_cases_on_bit1 {C : ℕ → Sort u} (H : Π b n, C (bit b n)) (n : ℕ) :
  bit_cases_on (bit1 n) H = H tt n :=
bit_cases_on_bit H tt n

lemma bit_cases_on_injective {C : ℕ → Sort u} :
  function.injective (λ H : Π b n, C (bit b n), λ n, bit_cases_on n H) :=
begin
  intros H₁ H₂ h,
  ext b n,
  simpa only [bit_cases_on_bit] using congr_fun h (bit b n)
end

@[simp] lemma bit_cases_on_inj {C : ℕ → Sort u} (H₁ H₂ : Π b n, C (bit b n)) :
  (λ n, bit_cases_on n H₁) = (λ n, bit_cases_on n H₂) ↔ H₁ = H₂ :=
bit_cases_on_injective.eq_iff

protected lemma bit0_eq_zero {n : ℕ} : bit0 n = 0 ↔ n = 0 :=
⟨nat.eq_zero_of_add_eq_zero_left, λ h, by simp [h]⟩

lemma bit_eq_zero_iff {n : ℕ} {b : bool} : bit b n = 0 ↔ n = 0 ∧ b = ff :=
by { split, { cases b; simp [nat.bit, nat.bit0_eq_zero], }, rintro ⟨rfl, rfl⟩, refl, }

/-- The same as binary_rec_eq, but that one unfortunately requires `f` to be the identity when
  appending `ff` to `0`. Here, we allow you to explicitly say that that case is not happening, i.e.
  supplying `n = 0 → b = tt`. -/
lemma binary_rec_eq' {C : ℕ → Sort*} {z : C 0} {f : ∀ b n, C n → C (bit b n)}
  (b n) (h : f ff 0 z = z ∨ (n = 0 → b = tt)) :
  binary_rec z f (bit b n) = f b n (binary_rec z f n) :=
begin
  rw [binary_rec],
  split_ifs with h',
  { rcases bit_eq_zero_iff.mp h' with ⟨rfl, rfl⟩,
    rw binary_rec_zero,
    simp only [imp_false, or_false, eq_self_iff_true, not_true] at h,
    exact h.symm },
  { generalize_proofs e, revert e,
    rw [bodd_bit, div2_bit],
    intros, refl, }
end

/-- The same as `binary_rec`, but the induction step can assume that if `n=0`,
  the bit being appended is `tt`-/
@[elab_as_eliminator]
def binary_rec' {C : ℕ → Sort*} (z : C 0) (f : ∀ b n, (n = 0 → b = tt) → C n → C (bit b n)) :
  ∀ n, C n :=
binary_rec z (λ b n ih, if h : n = 0 → b = tt then f b n h ih else
  by { convert z, rw bit_eq_zero_iff, simpa using h, })

/-- The same as `binary_rec`, but special casing both 0 and 1 as base cases -/
@[elab_as_eliminator]
def binary_rec_from_one {C : ℕ → Sort*} (z₀ : C 0) (z₁ : C 1)
  (f : ∀ b n, n ≠ 0 → C n → C (bit b n)) : ∀ n, C n :=
binary_rec' z₀ (λ b n h ih, if h' : n = 0 then by { rw [h', h h'], exact z₁ } else f b n h' ih)

@[simp] lemma zero_bits : bits 0 = [] := by simp [nat.bits]

@[simp] lemma bits_append_bit (n : ℕ) (b : bool) (hn : n = 0 → b = tt) :
  (bit b n).bits = b :: n.bits :=
by { rw [nat.bits, binary_rec_eq'], simpa, }

@[simp] lemma bit0_bits (n : ℕ) (hn : n ≠ 0) : (bit0 n).bits = ff :: n.bits :=
bits_append_bit n ff (λ hn', absurd hn' hn)

@[simp] lemma bit1_bits (n : ℕ) : (bit1 n).bits = tt :: n.bits :=
bits_append_bit n tt (λ _, rfl)

@[simp] lemma one_bits : nat.bits 1 = [tt] := by { convert bit1_bits 0, simp, }

-- TODO Find somewhere this can live.
-- example : bits 3423 = [tt, tt, tt, tt, tt, ff, tt, ff, tt, ff, tt, tt] := by norm_num

lemma bodd_eq_bits_head (n : ℕ) : n.bodd = n.bits.head :=
begin
  induction n using nat.binary_rec' with b n h ih, { simp, },
  simp [bodd_bit, bits_append_bit _ _ h],
end

lemma div2_bits_eq_tail (n : ℕ) : n.div2.bits = n.bits.tail :=
begin
  induction n using nat.binary_rec' with b n h ih, { simp, },
  simp [div2_bit, bits_append_bit _ _ h],
end

end nat


import «08_lib» analysis.specific_limits

def majorant (A : set ℝ) (x : ℝ) := ∀ a ∈ A, a ≤ x
def borne_sup (A : set ℝ) (x : ℝ) := majorant A x ∧ ∀ y, majorant A y → x ≤ y

lemma lt_sup {A : set ℝ} {x : ℝ} (hx : borne_sup A x) :
∀ y, y < x → ∃ a ∈ A, y < a :=
begin
  -- sorry
  intro y,
  contrapose!,
  exact hx.right y,
  -- sorry
end

lemma inferieur_si_inferieur_plus_eps {x y : ℝ} :
  (∀ ε > 0, y ≤ x + ε) →  y ≤ x :=
begin
  -- sorry
  contrapose!,
  intro h,
  use (y-x)/2,
  split,
    linarith,
  linarith,
  -- sorry
end

-- Si u tend vers x et u_n ≤ y pour tout n alors x ≤ y.
lemma lim_le {x y : ℝ} {u : ℕ → ℝ} (hu : limite_suite u x)
  (ineg : ∀ n, u n ≤ y) : x ≤ y :=
begin
  -- sorry
  apply inferieur_si_inferieur_plus_eps,
  intros ε ε_pos,
  cases hu ε ε_pos with N hN,
  specialize hN N (by linarith),
  specialize ineg N,
  rw abs_inferieur_ssi at hN,
--  cases hN,
  linarith',
  -- sorry
end

def limite_infinie_suite (u : ℕ → ℝ) := ∀ A, ∃ N, ∀ n ≥ N, u n ≥ A

lemma limite_infinie_pas_finie {u : ℕ → ℝ} :
  limite_infinie_suite u → ∀ x, ¬ limite_suite u x :=
begin
  -- sorry
  intros lim_infinie x lim_x,
  cases lim_x 1 (by linarith) with N hN,
  cases lim_infinie (x+2) with N' hN',
  let N₀ := max N N',
  specialize hN N₀ (inferieur_max_gauche _ _),
  specialize hN' N₀ (inferieur_max_droite _ _),
  rw abs_inferieur_ssi at hN,
  linarith',
  -- sorry
end

lemma inv_succ_pos : ∀ n : ℕ, 1/(n + 1 : ℝ) > 0 :=
by apply nat.one_div_pos_of_nat

lemma limite_inv_succ :  ∀ ε > 0, ∃ N : ℕ, ∀ n ≥ N, 1/(n + 1 : ℝ) ≤ ε :=
begin
  convert metric.tendsto_at_top.mp (tendsto_one_div_add_at_top_nhds_0_nat),
  apply propext,
  simp only [real.dist_eq, sub_zero],
  split,
    intros h ε ε_pos,
    cases h (ε/2) (by linarith) with N hN,
    use N,
    intros n hn,
    rw abs_of_pos (inv_succ_pos n),
    specialize hN n hn,
    linarith,
  intros h ε ε_pos,
  cases h ε (by linarith) with N hN,
  use N,
  intros n hn,
  specialize hN n hn,
  rw abs_of_pos (inv_succ_pos n) at hN,
  linarith,
end

lemma lim_constante (x : ℝ) : limite_suite (λ n, x) x :=
λ ε ε_pos, ⟨0, λ _ _, by simp [le_of_lt ε_pos]⟩

lemma limite_si_inferieur_un_sur {u : ℕ → ℝ} {x : ℝ} (h : ∀ n, |u n - x| ≤ 1/(n+1)) :
limite_suite u x :=
begin
  intros ε ε_pos,
  rcases limite_inv_succ ε ε_pos with ⟨N, hN⟩,
  use N,
  intros n hn,
  specialize h n,
  specialize hN n hn,
  linarith,
end

lemma lim_plus_un_sur (x : ℝ) : limite_suite (λ n, x + 1/(n+1)) x :=
limite_si_inferieur_un_sur (λ n, by rw abs_of_pos ; linarith [inv_succ_pos n])

lemma lim_moins_un_sur (x : ℝ) : limite_suite (λ n, x - 1/(n+1)) x :=
begin
  refine limite_si_inferieur_un_sur (λ n, _),
  rw [show x - 1 / (n + 1) - x = -(1/(n+1)), by ring, abs_neg,  abs_of_pos],
  linarith [inv_succ_pos n]
end

lemma gendarmes {u v w : ℕ → ℝ} {l : ℝ}
(lim_u : limite_suite u l) (lim_w : limite_suite w l)
(hu : ∀ n, u n ≤ v n) (hw : ∀ n, v n ≤ w n)  : limite_suite v l :=
begin
  intros ε ε_pos,
  cases lim_u ε ε_pos with N hN,
  cases lim_w ε ε_pos with N' hN',
  use max N N',
  intros n hn,
  rw superieur_max_ssi at hn,
  cases hn with hn hn',
  specialize hN n (by linarith),
  specialize hN' n (by linarith),
  specialize hu n,
  specialize hw n,
  rw abs_inferieur_ssi at *,
  cases hN with hNl hNd,
  cases hN' with hN'l hN'd,
  split,
  -- Ici linarith peut finir, mais sur papier on écrirait
  calc -ε ≤ u n - l : by linarith
      ... ≤ v n - l : by linarith,
  calc v n - l ≤ w n - l : by linarith
      ... ≤ ε : by linarith,
end

def extraction (φ : ℕ → ℕ) := ∀ n m, n < m → φ n < φ m

-- Dans la suite, φ désignera toujours une fonction de ℕ dans ℕ
variable { φ : ℕ → ℕ}

/-- Un réel `a` est valeur d'adhérence d'une suite `u` s'il
existe une suite extraite de `u` qui tend vers `a`. -/
def valeur_adherence (u : ℕ → ℝ) (a : ℝ) :=
∃ φ, extraction φ ∧ limite_suite (u ∘ φ) a

/-- Toute extraction est supérieure à l'identité. -/
lemma extraction_superieur_id : extraction φ → ∀ n, n ≤ φ n :=
begin
  intros hyp n,
  induction n with n hn,
    exact nat.zero_le _,
  exact nat.succ_le_of_lt (by linarith [hyp n (n+1) (by linarith)]),
end

open filter

lemma extraction_machine (ψ : ℕ → ℕ) (hψ : ∀ n, ψ n ≥ n) : ∃ f : ℕ → ℕ, extraction (ψ ∘ f) ∧ ∀ n, f n ≥ n :=
begin
  refine ⟨λ n, nat.rec_on n 0 (λ n ih, ψ ih + 1), λ m n h, _, λ n, _⟩,
  { induction h; dsimp [(∘)],
    { exact hψ _ },
    { exact lt_trans h_ih (hψ _) } },
  { induction n, {apply le_refl},
    exact nat.succ_le_succ (le_trans n_ih (hψ _)) }
end

variables {u : ℕ → ℝ} {l : ℝ}

/-- Si `u` tend vers `l` alors toutes ses suites extraites tendent vers `l`. -/
lemma limite_extraction_si_limite (h : limite_suite u l) (hφ : extraction φ) :
limite_suite (u ∘ φ) l :=
begin
  -- sorry
  intros ε ε_pos,
  cases h ε ε_pos with N hN,
  use N,
  intros n hn,
  apply hN,
  calc N ≤ n   : hn -- on peut écrire « by exact hn » si on a un clavier solide
     ... ≤ φ n : extraction_superieur_id hφ n, -- idem
  -- sorry
end

def segment (a b : ℝ) := {x | a ≤ x ∧ x ≤ b}

notation `[`a `, ` b `]` := segment a b

lemma bolzano_weierstrass {a b : ℝ} {u : ℕ → ℝ} (h : ∀ n, u n ∈ [a, b]) :
∃ c ∈ [a, b], valeur_adherence u c :=
begin
  have cpct : compact [a, b],
    exact compact_Icc,
  have :  map u at_top ≤ principal [a, b],
  { change tendsto u _ _,
    rw tendsto_principal,
    filter_upwards [univ_mem_sets],
    intros n hn,
    exact h n },
  rcases cpct (map u at_top) (map_ne_bot at_top_ne_bot) this with ⟨c, h, h'⟩,
  clear this,
  use [c, h],
  unfold valeur_adherence,
  have : ∀ N, ∃ n ≥ N, |u n -c| ≤ 1/(N+1),
    intro N,
    rw ← forall_sets_neq_empty_iff_neq_bot at h',
    specialize h' (u '' {n | n ≥ N} ∩ {x | |x-c| ≤ 1/(N+1)}) _,
    { simp only [set.not_eq_empty_iff_exists,
                set.mem_image,
                set.mem_inter_eq,
                ne.def,
                set.mem_set_of_eq] at h',
      rcases h' with ⟨_, ⟨n, ⟨hn, rfl⟩⟩, ineg⟩,
      use [n, hn, ineg] },
    { apply inter_mem_inf_sets,
      { apply image_mem_map,
        apply mem_at_top },
      { have fact: (0 : ℝ) < 1/(N+2),
          exact_mod_cast inv_succ_pos (N+1),
        apply mem_sets_of_superset (metric.ball_mem_nhds c fact),
        intros x x_in,
        rw [metric.mem_ball, real.dist_eq] at x_in,
        exact le_of_lt (
          calc |x - c| < 1 / (N + 2) : x_in
                   ... = 1/((N+1)+1) : by { congr' 1, norm_cast }
                   ... ≤ 1 / (N + 1) : nat.one_div_le_one_div (nat.le_succ N)),

       } },
  choose ψ hψ using this,
  cases forall_and_distrib.mp hψ with hψ_id hψ', clear hψ,
  rcases extraction_machine ψ hψ_id with ⟨f, hf, hf'⟩,
  use [ψ ∘ f, hf],
  apply limite_si_inferieur_un_sur ,
  intros n,
  transitivity 1/(f n + 1 : ℝ),
  apply hψ',
  exact nat.one_div_le_one_div (hf' n),
end

lemma limite_suite_id : ∀ A : ℝ, ∃ N : ℕ, ∀ n ≥ N, (n : ℝ) ≥ A:=
begin
  intro A,
  cases exists_nat_gt A with N hN,
  use N,
  intros n hn,
  have : (n : ℝ) ≥ N, exact_mod_cast hn,  --- pfff
  linarith,
end

open real

lemma sup_segment {a b : ℝ} {A : set ℝ} (hnonvide : ∃ x, x ∈ A) (h : A ⊆ [a, b]) :
  ∃ x ∈ [a, b], borne_sup A x :=
begin
  have b_maj :  ∀ (y : ℝ), y ∈ A → y ≤ b,
    from λ y y_in, (h y_in).2,
  have Sup_maj : majorant A (Sup A),
  { apply le_Sup,
    use [b, b_maj] } ,
  refine ⟨real.Sup A, _, _⟩,
  { split,
    { cases hnonvide with x x_in,
      exact le_trans (h x_in).1 (Sup_maj _ x_in) },
    { apply Sup_le_ub A hnonvide b_maj } },
  { use Sup_maj,
    intros y y_in,
    rwa Sup_le _ hnonvide ⟨b, b_maj⟩ },
end