/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import data.finset.lattice
import order.hom.basic
import order.conditionally_complete_lattice.finset

/-!
# The monotone sequence of partial supremums of a sequence

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

We define `partial_sups : (ℕ → α) → ℕ →o α` inductively. For `f : ℕ → α`, `partial_sups f` is
the sequence `f 0 `, `f 0 ⊔ f 1`, `f 0 ⊔ f 1 ⊔ f 2`, ... The point of this definition is that
* it doesn't need a `⨆`, as opposed to `⨆ (i ≤ n), f i` (which also means the wrong thing on
  `conditionally_complete_lattice`s).
* it doesn't need a `⊥`, as opposed to `(finset.range (n + 1)).sup f`.
* it avoids needing to prove that `finset.range (n + 1)` is nonempty to use `finset.sup'`.

Equivalence with those definitions is shown by `partial_sups_eq_bsupr`, `partial_sups_eq_sup_range`,
`partial_sups_eq_sup'_range` and respectively.

## Notes

One might dispute whether this sequence should start at `f 0` or `⊥`. We choose the former because :
* Starting at `⊥` requires... having a bottom element.
* `λ f n, (finset.range n).sup f` is already effectively the sequence starting at `⊥`.
* If we started at `⊥` we wouldn't have the Galois insertion. See `partial_sups.gi`.

## TODO

One could generalize `partial_sups` to any locally finite bot preorder domain, in place of `ℕ`.
Necessary for the TODO in the module docstring of `order.disjointed`.
-/

variables {α : Type*}

section semilattice_sup
variables [semilattice_sup α]

/-- The monotone sequence whose value at `n` is the supremum of the `f m` where `m ≤ n`. -/
def partial_sups (f : ℕ → α) : ℕ →o α :=
⟨@nat.rec (λ _, α) (f 0) (λ (n : ℕ) (a : α), a ⊔ f (n + 1)),
  monotone_nat_of_le_succ (λ n, le_sup_left)⟩

@[simp] lemma partial_sups_zero (f : ℕ → α) : partial_sups f 0 = f 0 := rfl
@[simp] lemma partial_sups_succ (f : ℕ → α) (n : ℕ) :
  partial_sups f (n + 1) = partial_sups f n ⊔ f (n + 1) := rfl

lemma le_partial_sups_of_le (f : ℕ → α) {m n : ℕ} (h : m ≤ n) :
  f m ≤ partial_sups f n :=
begin
  induction n with n ih,
  { cases h, exact le_rfl, },
  { cases h with h h,
    { exact le_sup_right, },
    { exact (ih h).trans le_sup_left, } },
end

lemma le_partial_sups (f : ℕ → α) :
  f ≤ partial_sups f :=
λ n, le_partial_sups_of_le f le_rfl

lemma partial_sups_le (f : ℕ → α) (n : ℕ)
  (a : α) (w : ∀ m, m ≤ n → f m ≤ a) : partial_sups f n ≤ a :=
begin
  induction n with n ih,
  { apply w 0 le_rfl, },
  { exact sup_le (ih (λ m p, w m (nat.le_succ_of_le p))) (w (n + 1) le_rfl) }
end

@[simp] lemma bdd_above_range_partial_sups {f : ℕ → α} :
  bdd_above (set.range (partial_sups f)) ↔ bdd_above (set.range f) :=
begin
  apply exists_congr (λ a, _),
  split,
  { rintros h b ⟨i, rfl⟩,
    exact (le_partial_sups _ _).trans (h (set.mem_range_self i)) },
  { rintros h b ⟨i, rfl⟩,
    exact (partial_sups_le _ _ _ $ λ _ _, h (set.mem_range_self _)), },
end

lemma monotone.partial_sups_eq {f : ℕ → α} (hf : monotone f) :
  (partial_sups f : ℕ → α) = f :=
begin
  ext n,
  induction n with n ih,
  { refl },
  { rw [partial_sups_succ, ih, sup_eq_right.2 (hf (nat.le_succ _))] }
end

lemma partial_sups_mono : monotone (partial_sups : (ℕ → α) → ℕ →o α) :=
begin
  rintro f g h n,
  induction n with n ih,
  { exact h 0 },
  { exact sup_le_sup ih (h _) }
end

/-- `partial_sups` forms a Galois insertion with the coercion from monotone functions to functions.
-/
def partial_sups.gi : galois_insertion (partial_sups : (ℕ → α) → ℕ →o α) coe_fn :=
{ choice := λ f h, ⟨f, begin
    convert (partial_sups f).monotone,
    exact (le_partial_sups f).antisymm h,
  end⟩,
  gc := λ f g, begin
    refine ⟨(le_partial_sups f).trans, λ h, _⟩,
    convert partial_sups_mono h,
    exact order_hom.ext _ _ g.monotone.partial_sups_eq.symm,
  end,
  le_l_u := λ f, le_partial_sups f,
  choice_eq := λ f h, order_hom.ext _ _ ((le_partial_sups f).antisymm h) }

lemma partial_sups_eq_sup'_range (f : ℕ → α) (n : ℕ) :
  partial_sups f n = (finset.range (n + 1)).sup' ⟨n, finset.self_mem_range_succ n⟩ f :=
begin
  induction n with n ih,
  { simp },
  { dsimp [partial_sups] at ih ⊢,
    simp_rw @finset.range_succ n.succ,
    rw [ih, finset.sup'_insert, sup_comm] }
end

end semilattice_sup

lemma partial_sups_eq_sup_range [semilattice_sup α] [order_bot α] (f : ℕ → α) (n : ℕ) :
  partial_sups f n = (finset.range (n + 1)).sup f :=
begin
  induction n with n ih,
  { simp },
  { dsimp [partial_sups] at ih ⊢,
    rw [finset.range_succ, finset.sup_insert, sup_comm, ih] }
end

/- Note this lemma requires a distributive lattice, so is not useful (or true) in situations such as
submodules. -/
lemma partial_sups_disjoint_of_disjoint [distrib_lattice α] [order_bot α]
  (f : ℕ → α) (h : pairwise (disjoint on f)) {m n : ℕ} (hmn : m < n) :
  disjoint (partial_sups f m) (f n) :=
begin
  induction m with m ih,
  { exact h hmn.ne, },
  { rw [partial_sups_succ, disjoint_sup_left],
    exact ⟨ih (nat.lt_of_succ_lt hmn), h hmn.ne⟩ }
end

section conditionally_complete_lattice
variables [conditionally_complete_lattice α]

lemma partial_sups_eq_csupr_Iic (f : ℕ → α) (n : ℕ) : partial_sups f n = ⨆ i : set.Iic n, f i :=
begin
  have : set.Iio (n + 1) = set.Iic n := set.ext (λ _, nat.lt_succ_iff),
  rw [partial_sups_eq_sup'_range, finset.sup'_eq_cSup_image, finset.coe_range,
    supr, set.range_comp, subtype.range_coe, this],
end

@[simp] lemma csupr_partial_sups_eq {f : ℕ → α} (h : bdd_above (set.range f)) :
  (⨆ n, partial_sups f n) = ⨆ n, f n :=
begin
  refine (csupr_le $ λ n, _).antisymm (csupr_mono _ $ le_partial_sups f),
  { rw partial_sups_eq_csupr_Iic,
    exact csupr_le (λ i, le_csupr h _), },
  { rwa bdd_above_range_partial_sups },
end

end conditionally_complete_lattice

section complete_lattice
variables [complete_lattice α]

lemma partial_sups_eq_bsupr (f : ℕ → α) (n : ℕ) :
  partial_sups f n = ⨆ (i ≤ n), f i :=
by simpa only [supr_subtype] using partial_sups_eq_csupr_Iic f n

@[simp] lemma supr_partial_sups_eq (f : ℕ → α) :
  (⨆ n, partial_sups f n) = ⨆ n, f n :=
csupr_partial_sups_eq $ order_top.bdd_above _

lemma supr_le_supr_of_partial_sups_le_partial_sups {f g : ℕ → α}
  (h : partial_sups f ≤ partial_sups g) :
  (⨆ n, f n) ≤ ⨆ n, g n :=
begin
  rw [←supr_partial_sups_eq f, ←supr_partial_sups_eq g],
  exact supr_mono h,
end

lemma supr_eq_supr_of_partial_sups_eq_partial_sups {f g : ℕ → α}
  (h : partial_sups f = partial_sups g) :
  (⨆ n, f n) = ⨆ n, g n :=
by simp_rw [←supr_partial_sups_eq f, ←supr_partial_sups_eq g, h]

end complete_lattice


def concat {α : Type} : list (list α) → list α
| [] := []
| (xs :: xss) := xs ++ concat xss

def map {α β : Type} (f : α → β) : list α → list β |
 [] := [] |
  (x :: xs) := f x :: map xs

def reverse {α: Type}: list α → list α
| [] := []
| (x::xs) := reverse xs ++ [x]

lemma concat_snoc {α : Type} : ∀(xs : list α) (xss : list (list α)), concat (xss ++ [xs]) = concat xss ++ xs:=sorry
lemma reverse_append {α : Type} : ∀xs ys : list α, reverse (xs ++ ys) = reverse xs ++ reverse ys := sorry

lemma reverse_concat {α : Type} : ∀xss : list (list α), reverse (concat xss) = concat (reverse (map reverse xss))
| [] := by refl
| (x :: xs) := begin simp[concat], simp[map], simp[reverse], simp[reverse_append], simp[concat_snoc], rw[reverse_concat xs]  end

inductive sorted: list ℕ → Prop
| nil : sorted []
| single {n: ℕ} : sorted [n]
| largertwo {x y: ℕ} {xs: list ℕ} (xy: x <= y) (yxs: sorted (y :: xs)) : sorted (x :: y :: xs)
-- intro xss,
-- induction xss,
-- refl,
-- simp[map],
-- simp[concat],
-- rw[<-xss_ih],

example : sorted [] := sorted.nil

example : sorted [2] := sorted.single

example : sorted [3, 5] := begin apply sorted.largertwo, trivial, sorted.single  end
example : sorted [7, 9, 9, 11] := begin apply repeat{sorted.largertwo}, trivial, end

inductive program (σ : Type) : Type
| skip {} : program
| assign : (σ → σ) → program
| seq : program → program → program
| ite : (σ → Prop) → program → program → program
| while : (σ → Prop) → program → program

def program_equiv (p1 p2 : program σ) : Prop :=
 ∀s t, (p1, s) =⇒ t ↔ (p2, s) =⇒ t

inductive finite {α: Type}: set α → Prop
| empty: finite ∅
| single {a: α}: finite(insert a ∅)
| both_fin {A B: set α} (fin_A: finite A) (fin_B: finite B): finite (A ∪ B)

lemma finite.union {α : Type} : ∀A B : set α, finite A → finite B → finite (A ∪ B) :=
begin
intros A B,
intros finA finB,
apply finite.both_fin,
assumption,
assumption
end

instance fin_set.rel (α : Type) : setoid (list α) :=
{ r := λxs ys, ∀x, x ∈ xs ↔ x ∈ ys,
 iseqv := r x x
  }

lemma isreflective {α: Type} (xs: list α): xs = xs := sorry

namespace v1

def concat {α: Type}: list (list α) → list α
| [] := []
| (xs :: xss) := xs ++ concat xss

def reverse {α: Type}: list α → list α
| [] := []
| (x :: xs) := reverse xs ++ [x]

#reduce reverse [2,3,4]

def map {α β: Type} (f: α → β): list α → list β
| [] := []
| (x :: xs) := f x :: map xs

lemma map_append {α: Type}: ∀xs ys : list α, map f (xs ++ ys) = (map xs) ++ (map ys)
#reduce  map 2 [2,3,4]

lemma map_concat {α β : Type} (f : α → β) : ∀xss : list (list α), map f (concat xss) = concat (map (map f) xss)
| [] := by refl
| (x :: xss) := begin simp[concat], simp[map], simp[concat], rw[<-map_concat xss], induction xss, simp[concat], simp[map], simp[map_concat], simp[map], simp[concat],  end

lemma concat_snoc {α : Type} : ∀(xs : list α) (xss : list (list α)), concat (xss ++ [xs]) = concat xss ++ xs := sorry

lemma reverse_append {α : Type} : ∀xs ys : list α, reverse (xs ++ ys) = reverse xs ++ reverse ys := sorry

lemma reverse_concat {α : Type} : ∀xss : list (list α), reverse (concat xss) = concat (reverse (map reverse xss))
| [] := by refl
| (x :: xss) := begin simp[concat], simp[map], simp[reverse], simp[concat_snoc],simp[reverse_append], rw[reverse_concat xss], simp end

inductive sorted: list ℕ → Prop
| empty : sorted []
| any_list {a: ℕ}: sorted [a]
| greater_two {xs: list ℕ} {x y: ℕ} (xsmallery: x <= y) (sxy: sorted (y :: xs)) : sorted (x :: y :: xs)

example : sorted [] := sorted.empty
example : sorted [2] := sorted.any_list
example : sorted [3, 5] := begin apply sorted.greater_two, apply trivial, apply sorted.any_list end
example : sorted [7, 9, 9, 11] := begin apply sorted.greater_two, apply trivial, apply sorted.greater_two...end
example : ¬ sorted [17, 13] := begin assume s : sorted [17,13],begin have 17 <= 13 := match s with sorted.greater_two xy yxs := xy end end

-- inductive finite {α: Type} : set α → Prop
-- | empty : finite ∅
-- | finite_set {a: α} {A: set α} (finA : finite A) : finite ({a} ∪ A)

inductive finite {α: Type} : set α → Prop
| empty : finite ∅
| singleton {a: α} : finite (insert a ∅)
| ABFinite {finiteA finiteB: set α} (afinite: finite finiteA) (bfinite: finite finiteB) : finite (finiteA ∪ finiteB)

lemma finite.union {α : Type} :
∀A B : set α, finite A → finite B → finite (A ∪ B) :=
begin
intros A B,
intros finiteA finiteB,
apply finite.ABFinite,
repeat{assumption}
end

lemma refleciver {α: Type} (xs: list α): xs = xs := by refl

lemma symmetric {α: Type} (xs ys: list α): xs → ys = ys → xs := sorry

lemma transitive {α: Type} (xs ys zs: list α): xs → ys ∧ ys → zs = xs → zs := sorry

def fin_empty {α : Type} (a: α) : fin_set α := [[a]]

end v1


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import algebra.big_operators.order
import data.nat.basic

/-!
# Equitable functions

This file defines equitable functions.

A function `f` is equitable on a set `s` if `f a₁ ≤ f a₂ + 1` for all `a₁, a₂ ∈ s`. This is mostly
useful when the codomain of `f` is `ℕ` or `ℤ` (or more generally a successor order).

## TODO

`ℕ` can be replaced by any `succ_order` + `conditionally_complete_monoid`, but we don't have the
latter yet.
-/

open_locale big_operators

variables {α β : Type*}

namespace set

/-- A set is equitable if no element value is more than one bigger than another. -/
def equitable_on [has_le β] [has_add β] [has_one β] (s : set α) (f : α → β) : Prop :=
∀ ⦃a₁ a₂⦄, a₁ ∈ s → a₂ ∈ s → f a₁ ≤ f a₂ + 1

@[simp]
lemma equitable_on_empty [has_le β] [has_add β] [has_one β] (f : α → β) : equitable_on ∅ f :=
λ a _ ha, (set.not_mem_empty _ ha).elim

lemma equitable_on_iff_exists_le_le_add_one {s : set α} {f : α → ℕ} :
  s.equitable_on f ↔ ∃ b, ∀ a ∈ s, b ≤ f a ∧ f a ≤ b + 1 :=
begin
  refine ⟨_, λ ⟨b, hb⟩ x y hx hy, (hb x hx).2.trans (add_le_add_right (hb y hy).1 _)⟩,
  obtain rfl | ⟨x, hx⟩ := s.eq_empty_or_nonempty,
  { simp },
  intros hs,
  by_cases h : ∀ y ∈ s, f x ≤ f y,
  { exact ⟨f x, λ y hy, ⟨h _ hy, hs hy hx⟩⟩ },
  push_neg at h,
  obtain ⟨w, hw, hwx⟩ := h,
  refine ⟨f w, λ y hy, ⟨nat.le_of_succ_le_succ _, hs hy hw⟩⟩,
  rw (nat.succ_le_of_lt hwx).antisymm (hs hx hw),
  exact hs hx hy,
end

lemma equitable_on_iff_exists_image_subset_Icc {s : set α} {f : α → ℕ} :
  s.equitable_on f ↔ ∃ b, f '' s ⊆ Icc b (b + 1) :=
by simpa only [image_subset_iff] using equitable_on_iff_exists_le_le_add_one

lemma equitable_on_iff_exists_eq_eq_add_one {s : set α} {f : α → ℕ} :
  s.equitable_on f ↔ ∃ b, ∀ a ∈ s, f a = b ∨ f a = b + 1 :=
by simp_rw [equitable_on_iff_exists_le_le_add_one, nat.le_and_le_add_one_iff]

section ordered_semiring
variables [ordered_semiring β]

lemma subsingleton.equitable_on {s : set α} (hs : s.subsingleton) (f : α → β) : s.equitable_on f :=
λ i j hi hj, by { rw hs hi hj, exact le_add_of_nonneg_right zero_le_one }

lemma equitable_on_singleton (a : α) (f : α → β) : set.equitable_on {a} f :=
set.subsingleton_singleton.equitable_on f

end ordered_semiring
end set

open set

namespace finset

lemma equitable_on_iff {s : finset α} {f : α → ℕ} :
  equitable_on (s : set α) f ↔
    ∀ a ∈ s, f a = (∑ i in s, f i) / s.card ∨ f a = (∑ i in s, f i) / s.card + 1 :=
by simp_rw [equitable_on_iff_le_le_add_one, nat.le_and_le_add_one_iff]

end finset


/-
Copyright (c) 2019 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Mario Carneiro
-/
import analysis.special_functions.trigonometric.basic

/-!
# Pi

This file contains lemmas which establish bounds on `real.pi`.
Notably, these include `pi_gt_sqrt_two_add_series` and `pi_lt_sqrt_two_add_series`,
which bound `π` using series;
numerical bounds on `π` such as `pi_gt_314`and `pi_lt_315` (more precise versions are given, too).

See also `data.real.pi.leibniz` and `data.real.pi.wallis` for infinite formulas for `π`.
-/

open_locale real
namespace real

lemma pi_gt_sqrt_two_add_series (n : ℕ) : 2 ^ (n+1) * sqrt (2 - sqrt_two_add_series 0 n) < π :=
begin
  have : sqrt (2 - sqrt_two_add_series 0 n) / 2 * 2 ^ (n+2) < π,
  { rw [← lt_div_iff, ←sin_pi_over_two_pow_succ], apply sin_lt, apply div_pos pi_pos,
    all_goals { apply pow_pos, norm_num } },
  apply lt_of_le_of_lt (le_of_eq _) this,
  rw [pow_succ _ (n+1), ←mul_assoc, div_mul_cancel, mul_comm], norm_num
end

lemma pi_lt_sqrt_two_add_series (n : ℕ) :
  π < 2 ^ (n+1) * sqrt (2 - sqrt_two_add_series 0 n) + 1 / 4 ^ n :=
begin
  have : π < (sqrt (2 - sqrt_two_add_series 0 n) / 2 + 1 / (2 ^ n) ^ 3 / 4) * 2 ^ (n+2),
  { rw [← div_lt_iff, ← sin_pi_over_two_pow_succ],
    refine lt_of_lt_of_le (lt_add_of_sub_right_lt (sin_gt_sub_cube _ _)) _,
    { apply div_pos pi_pos, apply pow_pos, norm_num },
    { rw div_le_iff',
      { refine le_trans pi_le_four _,
        simp only [show ((4 : ℝ) = 2 ^ 2), by norm_num, mul_one],
        apply pow_le_pow, norm_num, apply le_add_of_nonneg_left, apply nat.zero_le },
      { apply pow_pos, norm_num } },
    apply add_le_add_left, rw div_le_div_right,
    rw [le_div_iff, ←mul_pow],
    refine le_trans _ (le_of_eq (one_pow 3)), apply pow_le_pow_of_le_left,
    { apply le_of_lt, apply mul_pos, apply div_pos pi_pos, apply pow_pos, norm_num, apply pow_pos,
      norm_num },
    rw ← le_div_iff,
    refine le_trans ((div_le_div_right _).mpr pi_le_four) _, apply pow_pos, norm_num,
    rw [pow_succ, pow_succ, ←mul_assoc, ←div_div_eq_div_mul],
    convert le_refl _,
    all_goals { repeat {apply pow_pos}, norm_num }},
  apply lt_of_lt_of_le this (le_of_eq _), rw [add_mul], congr' 1,
  { rw [pow_succ _ (n+1), ←mul_assoc, div_mul_cancel, mul_comm], norm_num },
  rw [pow_succ, ←pow_mul, mul_comm n 2, pow_mul, show (2 : ℝ) ^ 2 = 4, by norm_num, pow_succ,
      pow_succ, ←mul_assoc (2 : ℝ), show (2 : ℝ) * 2 = 4, by norm_num, ←mul_assoc, div_mul_cancel,
      mul_comm ((2 : ℝ) ^ n), ←div_div_eq_div_mul, div_mul_cancel],
  apply pow_ne_zero, norm_num, norm_num
end

/-- From an upper bound on `sqrt_two_add_series 0 n = 2 cos (π / 2 ^ (n+1))` of the form
`sqrt_two_add_series 0 n ≤ 2 - (a / 2 ^ (n + 1)) ^ 2)`, one can deduce the lower bound `a < π`
thanks to basic trigonometric inequalities as expressed in `pi_gt_sqrt_two_add_series`. -/
theorem pi_lower_bound_start (n : ℕ) {a}
  (h : sqrt_two_add_series ((0:ℕ) / (1:ℕ)) n ≤ 2 - (a / 2 ^ (n + 1)) ^ 2) : a < π :=
begin
  refine lt_of_le_of_lt _ (pi_gt_sqrt_two_add_series n), rw [mul_comm],
  refine (div_le_iff (pow_pos (by norm_num) _ : (0 : ℝ) < _)).mp (le_sqrt_of_sq_le _),
  rwa [le_sub, show (0:ℝ) = (0:ℕ)/(1:ℕ), by rw [nat.cast_zero, zero_div]],
end

lemma sqrt_two_add_series_step_up (c d : ℕ) {a b n : ℕ} {z : ℝ}
  (hz : sqrt_two_add_series (c/d) n ≤ z) (hb : 0 < b) (hd : 0 < d)
  (h : (2 * b + a) * d ^ 2 ≤ c ^ 2 * b) : sqrt_two_add_series (a/b) (n+1) ≤ z :=
begin
  refine le_trans _ hz, rw sqrt_two_add_series_succ, apply sqrt_two_add_series_monotone_left,
  have hb' : 0 < (b:ℝ) := nat.cast_pos.2 hb,
  have hd' : 0 < (d:ℝ) := nat.cast_pos.2 hd,
  rw [sqrt_le_left (div_nonneg c.cast_nonneg d.cast_nonneg), div_pow,
    add_div_eq_mul_add_div _ _ (ne_of_gt hb'), div_le_div_iff hb' (pow_pos hd' _)],
  exact_mod_cast h
end

/-- Create a proof of `a < π` for a fixed rational number `a`, given a witness, which is a
sequence of rational numbers `sqrt 2 < r 1 < r 2 < ... < r n < 2` satisfying the property that
`sqrt (2 + r i) ≤ r(i+1)`, where `r 0 = 0` and `sqrt (2 - r n) ≥ a/2^(n+1)`. -/
meta def pi_lower_bound (l : list ℚ) : tactic unit :=
do let n := l.length,
  tactic.apply `(@pi_lower_bound_start %%(reflect n)),
  l.mmap' (λ r, do
    let a := r.num.to_nat, let b := r.denom,
    (() <$ tactic.apply `(@sqrt_two_add_series_step_up %%(reflect a) %%(reflect b)));
    [tactic.skip, `[norm_num1], `[norm_num1], `[norm_num1]]),
  `[simp only [sqrt_two_add_series, nat.cast_bit0, nat.cast_bit1, nat.cast_one, nat.cast_zero]],
  `[norm_num1]

/-- From a lower bound on `sqrt_two_add_series 0 n = 2 cos (π / 2 ^ (n+1))` of the form
`2 - ((a - 1 / 4 ^ n) / 2 ^ (n + 1)) ^ 2 ≤ sqrt_two_add_series 0 n`, one can deduce the upper bound
`π < a` thanks to basic trigonometric formulas as expressed in `pi_lt_sqrt_two_add_series`. -/
theorem pi_upper_bound_start (n : ℕ) {a}
  (h : 2 - ((a - 1 / 4 ^ n) / 2 ^ (n + 1)) ^ 2 ≤ sqrt_two_add_series ((0:ℕ) / (1:ℕ)) n)
  (h₂ : 1 / 4 ^ n ≤ a) : π < a :=
begin
  refine lt_of_lt_of_le (pi_lt_sqrt_two_add_series n) _,
  rw [← le_sub_iff_add_le, ← le_div_iff', sqrt_le_left, sub_le],
  { rwa [nat.cast_zero, zero_div] at h },
  { exact div_nonneg (sub_nonneg.2 h₂) (pow_nonneg (le_of_lt zero_lt_two) _) },
  { exact pow_pos zero_lt_two _ }
end

lemma sqrt_two_add_series_step_down (a b : ℕ) {c d n : ℕ} {z : ℝ}
  (hz : z ≤ sqrt_two_add_series (a/b) n) (hb : 0 < b) (hd : 0 < d)
  (h : a ^ 2 * d ≤ (2 * d + c) * b ^ 2) : z ≤ sqrt_two_add_series (c/d) (n+1) :=
begin
  apply le_trans hz, rw sqrt_two_add_series_succ, apply sqrt_two_add_series_monotone_left,
  apply le_sqrt_of_sq_le,
  have hb' : 0 < (b:ℝ) := nat.cast_pos.2 hb,
  have hd' : 0 < (d:ℝ) := nat.cast_pos.2 hd,
  rw [div_pow, add_div_eq_mul_add_div _ _ (ne_of_gt hd'), div_le_div_iff (pow_pos hb' _) hd'],
  exact_mod_cast h
end

/-- Create a proof of `π < a` for a fixed rational number `a`, given a witness, which is a
sequence of rational numbers `sqrt 2 < r 1 < r 2 < ... < r n < 2` satisfying the property that
`sqrt (2 + r i) ≥ r(i+1)`, where `r 0 = 0` and `sqrt (2 - r n) ≥ (a - 1/4^n) / 2^(n+1)`. -/
meta def pi_upper_bound (l : list ℚ) : tactic unit :=
do let n := l.length,
  (() <$ tactic.apply `(@pi_upper_bound_start %%(reflect n))); [pure (), `[norm_num1]],
  l.mmap' (λ r, do
    let a := r.num.to_nat, let b := r.denom,
    (() <$ tactic.apply `(@sqrt_two_add_series_step_down %%(reflect a) %%(reflect b)));
    [pure (), `[norm_num1], `[norm_num1], `[norm_num1]]),
  `[simp only [sqrt_two_add_series, nat.cast_bit0, nat.cast_bit1, nat.cast_one, nat.cast_zero]],
  `[norm_num]

lemma pi_gt_three : 3 < π := by pi_lower_bound [23/16]

lemma pi_gt_314 : 3.14 < π := by pi_lower_bound [99/70, 874/473, 1940/989, 1447/727]

lemma pi_lt_315 : π < 3.15 := by pi_upper_bound [140/99, 279/151, 51/26, 412/207]

lemma pi_gt_31415 : 3.1415 < π := by pi_lower_bound [
  11482/8119, 5401/2923, 2348/1197, 11367/5711, 25705/12868, 23235/11621]

lemma pi_gt_3141592 : 3.141592 < π := by pi_lower_bound [
  11482/8119, 7792/4217, 54055/27557, 949247/476920, 3310126/1657059,
  2635492/1318143, 1580265/790192, 1221775/610899, 3612247/1806132, 849943/424972]

lemma pi_lt_3141593 : π < 3.141593 := by pi_upper_bound [
  27720/19601, 56935/30813, 49359/25163, 258754/130003, 113599/56868, 1101994/551163,
  8671537/4336095, 3877807/1938940, 52483813/26242030, 56946167/28473117, 23798415/11899211]

end real


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson, Alex J. Best, Johan Commelin, Eric Rodriguez, Ruben Van de Velde
-/

import algebra.char_p.algebra
import field_theory.finite.basic
import field_theory.separable
import linear_algebra.finite_dimensional

/-!
# Galois fields

If `p` is a prime number, and `n` a natural number,
then `galois_field p n` is defined as the splitting field of `X^(p^n) - X` over `zmod p`.
It is a finite field with `p ^ n` elements.

## Main definition

* `galois_field p n` is a field with `p ^ n` elements

## Main Results

- `galois_field.alg_equiv_galois_field`: Any finite field is isomorphic to some Galois field
- `finite_field.alg_equiv_of_card_eq`: Uniqueness of finite fields : algebra isomorphism
- `finite_field.ring_equiv_of_card_eq`: Uniqueness of finite fields : ring isomorphism

-/

noncomputable theory

open polynomial

lemma galois_poly_separable {K : Type*} [field K] (p q : ℕ) [char_p K p] (h : p ∣ q) :
  separable (X ^ q - X : polynomial K) :=
begin
  use [1, (X ^ q - X - 1)],
  rw [← char_p.cast_eq_zero_iff (polynomial K) p] at h,
  rw [derivative_sub, derivative_pow, derivative_X, h],
  ring,
end

/-- A finite field with `p ^ n` elements.
Every field with the same cardinality is (non-canonically)
isomorphic to this field. -/
@[derive field]
def galois_field (p : ℕ) [fact p.prime] (n : ℕ) :=
splitting_field (X^(p^n) - X : polynomial (zmod p))

instance : inhabited (@galois_field 2 (fact.mk nat.prime_two) 1) :=
⟨37⟩

namespace galois_field
variables (p : ℕ) [fact p.prime] (n : ℕ)

instance : algebra (zmod p) (galois_field p n) :=
splitting_field.algebra _

instance : is_splitting_field (zmod p) (galois_field p n) (X^(p^n) - X) :=
polynomial.is_splitting_field.splitting_field _

instance : char_p (galois_field p n) p :=
(algebra.char_p_iff (zmod p) (galois_field p n) p).mp (by apply_instance)

instance : fintype (galois_field p n) := by {dsimp only [galois_field],
  exact finite_dimensional.fintype_of_fintype (zmod p) (galois_field p n) }

lemma finrank {n} (h : n ≠ 0) : finite_dimensional.finrank (zmod p) (galois_field p n) = n :=
begin
  set g_poly := (X^(p^n) - X : polynomial (zmod p)),
  have hp : 1 < p := (fact.out (nat.prime p)).one_lt,
  have aux : g_poly ≠ 0 := finite_field.X_pow_card_pow_sub_X_ne_zero _ h hp,
  have key : fintype.card ((g_poly).root_set (galois_field p n)) = (g_poly).nat_degree :=
    card_root_set_eq_nat_degree (galois_poly_separable p _ (dvd_pow (dvd_refl p) h))
    (splitting_field.splits g_poly),
  have nat_degree_eq : (g_poly).nat_degree = p ^ n :=
    finite_field.X_pow_card_pow_sub_X_nat_degree_eq _ h hp,
  rw nat_degree_eq at key,
  suffices : (g_poly).root_set (galois_field p n) = set.univ,
  { simp_rw [this, ←fintype.of_equiv_card (equiv.set.univ _)] at key,
    rw [@card_eq_pow_finrank (zmod p), zmod.card] at key,
    exact nat.pow_right_injective ((nat.prime.one_lt' p).out) key },
  rw set.eq_univ_iff_forall,
  suffices : ∀ x (hx : x ∈ (⊤ : subalgebra (zmod p) (galois_field p n))),
    x ∈ (X ^ p ^ n - X : polynomial (zmod p)).root_set (galois_field p n),
  { simpa, },
  rw ← splitting_field.adjoin_root_set,
  simp_rw algebra.mem_adjoin_iff,
  intros x hx,
  -- We discharge the `p = 0` separately, to avoid typeclass issues on `zmod p`.
  unfreezingI { cases p, cases hp, },
  apply subring.closure_induction hx; clear_dependent x; simp_rw mem_root_set aux,
  { rintros x (⟨r, rfl⟩ | hx),
    { simp only [aeval_X_pow, aeval_X, alg_hom.map_sub],
      rw [← ring_hom.map_pow, zmod.pow_card_pow, sub_self], },
    { dsimp only [galois_field] at hx,
      rwa mem_root_set aux at hx, }, },
  { dsimp only [g_poly],
    rw [← coeff_zero_eq_aeval_zero'],
    simp only [coeff_X_pow, coeff_X_zero, sub_zero, ring_hom.map_eq_zero, ite_eq_right_iff,
      one_ne_zero, coeff_sub],
    intro hn,
    exact nat.not_lt_zero 1 (pow_eq_zero hn.symm ▸ hp), },
  { simp, },
  { simp only [aeval_X_pow, aeval_X, alg_hom.map_sub, add_pow_char_pow, sub_eq_zero],
    intros x y hx hy,
    rw [hx, hy], },
  { intros x hx,
    simp only [sub_eq_zero, aeval_X_pow, aeval_X, alg_hom.map_sub, sub_neg_eq_add] at *,
    rw [neg_pow, hx, char_p.neg_one_pow_char_pow],
    simp, },
  { simp only [aeval_X_pow, aeval_X, alg_hom.map_sub, mul_pow, sub_eq_zero],
    intros x y hx hy,
    rw [hx, hy], },
end

lemma card (h : n ≠ 0) : fintype.card (galois_field p n) = p ^ n :=
begin
  let b := is_noetherian.finset_basis (zmod p) (galois_field p n),
  rw [module.card_fintype b, ← finite_dimensional.finrank_eq_card_basis b, zmod.card, finrank p h],
end

theorem splits_zmod_X_pow_sub_X : splits (ring_hom.id (zmod p)) (X ^ p - X) :=
begin
  have hp : 1 < p := (fact.out (nat.prime p)).one_lt,
  have h1 : roots (X ^ p - X : polynomial (zmod p)) = finset.univ.val,
  { convert finite_field.roots_X_pow_card_sub_X _,
    exact (zmod.card p).symm },
  have h2 := finite_field.X_pow_card_sub_X_nat_degree_eq (zmod p) hp,
  -- We discharge the `p = 0` separately, to avoid typeclass issues on `zmod p`.
  unfreezingI { cases p, cases hp, },
  rw [splits_iff_card_roots, h1, ←finset.card_def, finset.card_univ, h2, zmod.card],
end

/-- A Galois field with exponent 1 is equivalent to `zmod` -/
def equiv_zmod_p : galois_field p 1 ≃ₐ[zmod p] (zmod p) :=
have h : (X ^ p ^ 1 : polynomial (zmod p)) = X ^ (fintype.card (zmod p)),
  by rw [pow_one, zmod.card p],
have inst : is_splitting_field (zmod p) (zmod p) (X ^ p ^ 1 - X),
  by { rw h, apply_instance },
by exactI (is_splitting_field.alg_equiv (zmod p) (X ^ (p ^ 1) - X : polynomial (zmod p))).symm

variables {K : Type*} [field K] [fintype K] [algebra (zmod p) K]

theorem splits_X_pow_card_sub_X : splits (algebra_map (zmod p) K) (X ^ fintype.card K - X) :=
by rw [←splits_id_iff_splits, polynomial.map_sub, map_pow, map_X, splits_iff_card_roots,
  finite_field.roots_X_pow_card_sub_X, ←finset.card_def, finset.card_univ,
  finite_field.X_pow_card_sub_X_nat_degree_eq]; exact fintype.one_lt_card

lemma is_splitting_field_of_card_eq (h : fintype.card K = p ^ n) :
  is_splitting_field (zmod p) K (X ^ (p ^ n) - X) :=
{ splits := by { rw ← h, exact splits_X_pow_card_sub_X p },
  adjoin_roots :=
  begin
    have hne : n ≠ 0,
    { rintro rfl, rw [pow_zero, fintype.card_eq_one_iff_nonempty_unique] at h,
      cases h, resetI, exact false_of_nontrivial_of_subsingleton K },
    refine algebra.eq_top_iff.mpr (λ x, algebra.subset_adjoin _),
    rw [polynomial.map_sub, map_pow, map_X, finset.mem_coe, multiset.mem_to_finset, mem_roots,
        is_root.def, eval_sub, eval_pow, eval_X, ← h, finite_field.pow_card, sub_self],
    exact finite_field.X_pow_card_pow_sub_X_ne_zero K hne (fact.out _)
  end }

/-- Any finite field is (possibly non canonically) isomorphic to some Galois field. -/
def alg_equiv_galois_field (h : fintype.card K = p ^ n) :
  K ≃ₐ[zmod p] galois_field p n :=
by haveI := is_splitting_field_of_card_eq _ _ h; exact is_splitting_field.alg_equiv _ _

end galois_field

namespace finite_field

variables {K : Type*} [field K] [fintype K] {K' : Type*} [field K'] [fintype K']

/-- Uniqueness of finite fields:
  Any two finite fields of the same cardinality are (possibly non canonically) isomorphic-/
def alg_equiv_of_card_eq (p : ℕ) [fact p.prime] [algebra (zmod p) K] [algebra (zmod p) K']
  (hKK' : fintype.card K = fintype.card K') :
  K ≃ₐ[zmod p] K' :=
begin
  haveI : char_p K p,
  { rw ← algebra.char_p_iff (zmod p) K p, exact zmod.char_p p, },
  haveI : char_p K' p,
  { rw ← algebra.char_p_iff (zmod p) K' p, exact zmod.char_p p, },
  choose n a hK using finite_field.card K p,
  choose n' a' hK' using finite_field.card K' p,
  rw [hK,hK'] at hKK',
  have hGalK := galois_field.alg_equiv_galois_field p n hK,
  have hK'Gal := (galois_field.alg_equiv_galois_field p n' hK').symm,
  rw (nat.pow_right_injective (fact.out (nat.prime p)).one_lt hKK') at *,
  use alg_equiv.trans hGalK hK'Gal,
end

/-- Uniqueness of finite fields:
  Any two finite fields of the same cardinality are (possibly non canonically) isomorphic-/
def ring_equiv_of_card_eq (hKK' : fintype.card K = fintype.card K') : K ≃+* K' :=
begin
  choose p _char_p_K using char_p.exists K,
  choose p' _char_p'_K' using char_p.exists K',
  resetI,
  choose n hp hK using finite_field.card K p,
  choose n' hp' hK' using finite_field.card K' p',
  have hpp' : p = p', -- := eq_prime_of_eq_prime_pow
  { by_contra hne,
    have h2 := nat.coprime_pow_primes n n' hp hp' hne,
    rw [(eq.congr hK hK').mp hKK', nat.coprime_self, pow_eq_one_iff (pnat.ne_zero n')] at h2,
    exact nat.prime.ne_one hp' h2,
    all_goals {apply_instance}, },
  rw ← hpp' at *,
  haveI := fact_iff.2 hp,
  exact alg_equiv_of_card_eq p hKK',
end

end finite_field


/-
This is a d∃∀duction file providing exercises for sets and maps. French version.
-/

import data.set
import tactic

-- dEAduction tactics
import structures2      -- hypo_analysis, targets_analysis
import utils            -- no_meta_vars
import user_notations   -- notations that can be used in deaduction UI for a new object
import push_neg_once    -- pushing negation just one step

-- dEAduction definitions
import set_definitions

-------------------------
-- dEAduction METADATA --
-------------------------
/- dEAduction
Title
    Ensembles et applications
Author
    Frédéric Le Roux, Camille Lichère, Zoé Mesnil
Institution
    Université du monde
Description
    Ce fichier contient une série d'exercices concernant les opérations ensemblistes
    préservées par image directe ou réciproque par une application.
    ATTENTION, certains énoncés sont faux ! Si vous n'arrivez pas à démontrer un énoncé,
    cherchez un contre-exemple...
AvailableProof
    proof_methods new_object
AvailableMagic
    assumption
AvailableExercises
  UNTIL_NOW -image_directe_et_inclusion_II -image_reciproque_et_inclusion_II -image_directe_et_intersection_II
  -image_de_image_reciproque_I -image_reciproque_de_image_II
  -injective_si_compo_injective_I -surjective_si_compo_surjective_II
  -image_directe_et_intersection_VI
AvailableDefinitions
  UNTIL_NOW -singleton -paire -identite -egalite_fonctions
AvailableTheorems
  UNTIL_NOW -image_singleton -image_paire
-/

local attribute [instance] classical.prop_decidable
---------------------------------------------
-- global parameters = implicit variables --
---------------------------------------------
section course
parameters {X Y Z: Type}

open set

------------------
-- COURSE TITLE --
------------------
namespace ensembles_et_applications
/- dEAduction
PrettyName
    Ensembles et applications
-/

namespace logique

lemma definition.iff {P Q : Prop} : (P ↔ Q) ↔ ((P → Q) and (Q → P)) :=
/- dEAduction
PrettyName
    Equivalence logique
-/
begin
  exact iff_def,
end

end logique

namespace definitions
/- dEAduction
PrettyName
    Définitions
-/
namespace generalites

/- dEAduction
PrettyName
    Généralités
-/

lemma definition.inclusion {A B : set X} : A ⊆ B ↔ ∀ {x:X}, x ∈ A → x ∈ B :=
/- dEAduction
ImplicitUse
  True
-/
begin
    exact iff.rfl
end

lemma definition.egalite_deux_ensembles {A A' : set X} :
(A = A') ↔ ( ∀ x, x ∈ A ↔ x ∈ A' ) :=
/- dEAduction
PrettyName
    Egalité de deux ensembles
-/
begin
     exact set.ext_iff
end

-- Unfortunately split cannot work
lemma definition.double_inclusion (A A' : set X) :
A = A' ↔ (A ⊆ A' ∧ A' ⊆ A) :=
/- dEAduction
PrettyName
    Double inclusion
ImplicitUse
  True
-/
begin
    exact set.subset.antisymm_iff
end

lemma definition.ensemble_vide
{A: set X} :
(A = ∅) ↔ ∀ x : X, x ∉ A
:=
begin
    exact eq_empty_iff_forall_not_mem,
end

lemma definition.ensemble_non_vide
(A: set X) :
(A ≠ ∅) ↔ ∃ x : X, x ∈ A
:=
/- dEAduction
ImplicitUse
  True
-/
begin
    todo
end

lemma definition.singleton
{x x_0: X} :
(x ∈  (sing x_0) ) ↔ x=x_0
:=
begin
    refl,
end

lemma definition.paire
{x x_0 x_1: X} :
(x ∈ (pair x_0 x_1) ) ↔ (x=x_0 ∨ x=x_1)
:=
begin
    refl,
end

end generalites

---------------
-- SECTION 1 --
---------------
namespace unions_et_intersections
-- variables unions_et_intersections --
variables {A B C : set X}

lemma definition.intersection_deux_ensembles {A B : set X} {x : X} :
x ∈ A ∩ B ↔ ( x ∈ A ∧ x ∈ B) :=
/- dEAduction
PrettyName
    Intersection de deux ensembles
ImplicitUse
    True
-/
begin
    exact iff.rfl
end

lemma definition.union_deux_ensembles  {A : set X} {B : set X} {x : X} :
x ∈ A ∪ B ↔ ( x ∈ A ∨ x ∈ B) :=
/- dEAduction
PrettyName
    Union de deux ensembles
ImplicitUse
    True
-/
begin
    exact iff.rfl
end

end unions_et_intersections

namespace applications

-- variables applications --

variables  {A A': set X}
variables {f: X → Y} {B B': set Y}

lemma definition.egalite_fonctions (f' : X → Y) :
f = f' ↔ ∀ x, f x = f' x :=
/- dEAduction
PrettyName
    Egalité de deux fonctions
-/
begin
    exact function.funext_iff,
end

lemma definition.identite (f₀: X → X) :
f₀ = Identite ↔ ∀ x, f₀ x = x :=
/- dEAduction
PrettyName
    Application identité
-/
begin
    apply definition.egalite_fonctions,
end

lemma definition.image_directe (y : Y) :
y ∈ f '' A ↔ ∃ x : X, x ∈ A ∧  f x = y
:=
begin
    todo
end

lemma theorem.image_directe :
∀ f: X→Y, ∀{A: set X}, ∀{x: X},
 (x ∈ A → f x ∈ f '' A)
:=
begin
    todo
end

lemma definition.image_reciproque (x:X) :
x ∈ f  ⁻¹' B ↔ f(x) ∈ B
:=
begin
    todo
end

variables (g : Y → Z)

lemma definition.composition {x:X}:
composition g f x = g (f x)
:=
begin
    todo,
end

lemma definition.injectivite :
injective f ↔ ∀ x x' : X, (f x = f x' → x = x')
:=
/- dEAduction
PrettyName
    Application injective
ImplicitUse
    True
-/
begin
    refl,
end

lemma definition.surjectivite :
surjective f ↔ ∀ y : Y, ∃ x : X, y = f x
:=
/- dEAduction
PrettyName
    Application surjective
ImplicitUse
    True
-/
begin
    refl,
end

lemma theorem.image_singleton :
∀ {f: X→Y}, ∀{x_0: X},
 f '' (sing x_0) = sing (f(x_0))
:=
/- dEAduction
PrettyName
  Image d'un singleton
-/
begin
    todo
end

lemma theorem.image_paire :
∀ {f: X→Y}, ∀{x_0 x_1: X},
 f '' (pair x_0 x_1) = pair (f x_0) (f x_1)
:=
/- dEAduction
PrettyName
  Image d'une paire
-/
begin
  todo
end

end applications

end definitions

-----------------
--- EXERCICES ---
-----------------
namespace exercices
variables  {A A': set X}
variables {f: X → Y} {g: Y → Z} {B B': set Y}

/-
ANCIEN SCHEMA :

1. ∀A,B⊆E A⊆B⇒f(A)⊆f(B)
2. ∀A,B⊆E f(A)⊆f(B)⇒A⊆B
3. Sif estinjective,alors∀A,B⊆E f(A)⊆f(B)⇒A⊆B
4. f est injective sietseulementsi ∀A,B⊆E f(A)⊆f(B)⇒A⊆B

5. ∀A,B⊆F A⊆B⇒f−1(A)⊆f−1(B)
6. ∀A,B⊆F f−1(A)⊆f−1(B)⇒A⊆B
7. Si f est surjective, alors ∀A,B ⊆ F f−1(A) ⊆ f−1(B) ⇒ A ⊆ B
8. festsurjectivesietseulementsi∀A,B⊆F f−1(A)⊆f−1(B)⇒A⊆B

9. ∀A ⊆ F f(f−1(A)) ⊆ A
10. ∀A ⊆ F A ⊆ f(f−1(A))
11. Si f est surjective, alors ∀A ⊆ F A ⊆ f(f−1(A))
12. f est surjective si et seulement si ∀A ⊆ F A = f(f−1(A))

13. ∀A ⊆ E A ⊆ f−1(f(A))
14. ∀A ⊆ E f−1(f(A)) ⊆ A
15. Si f est injective alors ∀A ⊆ E f−1(f(A)) ⊆ A
16. f est injective si et seulement si ∀A ⊆ E f−1(f(A)) = A

17. ∀A,B⊆E f(A∩B)⊆f(A)∩f(B)
18. ∀A,B⊆E f(A)∩f(B)⊆f(A∩B)
19. Sif estinjective,alors∀A,B⊆E f(A)∩f(B)⊆f(A∩B)
20. f estinjectivesietseulementsi∀A,B⊆E f(A)∩f(B)=f(A∩B)

21. ∀A,B⊆E 22.∀A,B⊆F 23.∀A,B⊆F
22. f(A∪B)=f(A)∪f(B)
23. f−1(A ∩ B) = f−1(A) ∩ f−1(B) f−1(A ∪ B) = f−1(A) ∪ f−1(B)
-/

-----------------------------------------------------------
-- Atelier 2 : images directe et réciproque, composition --
-----------------------------------------------------------
namespace composition_et_images

lemma exercise.composition_image_directe
(A: set X) :
(composition g f) '' A = g '' (f '' A)
:=
/- dEAduction
PrettyName
    Image directe par une composition
-/
begin
    todo
end

lemma exercise.composition_image_reciproque
(C: set Z) :
(composition g f) ⁻¹' C = f ⁻¹' (g ⁻¹' C)
:=
/- dEAduction
PrettyName
    Image réciproque par une composition
-/
begin
    todo
end

end composition_et_images

namespace image_et_image_reciproque
/- dEAduction
PrettyName
  Image et image réciproque
-/

lemma exercise.image_reciproque_de_image_I :
∀ A, A ⊆ f ⁻¹' (f '' (A))
:=
/- dEAduction
PrettyName
  Image réciproque de l'image
-/
begin
  todo
end

lemma exercise.image_reciproque_de_image_II :
∀ A, f ⁻¹' (f '' (A)) ⊆ A
:=
/- dEAduction
PrettyName
  Image réciproque de l'image : inclusion réciproque
-/
begin
  todo
end

lemma exercise.image_de_image_reciproque_I :
∀ B, B ⊆ f '' (f ⁻¹' (B))
:=
/- dEAduction
PrettyName
  Image de l'image réciproque
-/
begin
  todo
end

lemma exercise.image_de_image_reciproque_II :
∀ B, f '' (f ⁻¹' (B)) ⊆ B
:=
/- dEAduction
PrettyName
  Image de l'image réciproque : inclusion réciproque
-/
begin
  todo
end

end image_et_image_reciproque

------------------------------------
-- Atelier 3 : Rédiger une preuve --
------------------------------------

---------------------------------
namespace images_inclusion
/- dEAduction
PrettyName
  Images et inclusion
-/

lemma exercise.image_directe_et_inclusion :
∀ A A': set X, A ⊆ A' → f '' (A) ⊆ f '' (A')
:=
/- dEAduction
PrettyName
  Image directe et inclusion
-/
begin
  todo
end

-- lemma exercise.image_directe_et_inclusion_II :
-- ∀ A A': set X,  f '' (A) ⊆ f '' (A') → A ⊆ A'
-- :=
-- /- dEAduction
-- PrettyName
--   Image directe et inclusion : implication réciproque
-- -/
-- begin
--   todo
-- end

lemma exercise.image_reciproque_et_inclusion :
∀ B B': set Y, B ⊆ B' → f ⁻¹' (B) ⊆ f ⁻¹' (B')
:=
/- dEAduction
PrettyName
  Image réciproque et inclusion
-/
begin
  todo
end

-- lemma exercise.image_reciproque_et_inclusion_II :
-- ∀ B B': set Y,  f ⁻¹' (B) ⊆ f ⁻¹' (B') → B ⊆ B'
-- :=
-- /- dEAduction
-- PrettyName
--   Image réciproque et inclusion : implication réciproque
-- -/
-- begin
--   todo
-- end

end images_inclusion

namespace images_union
/- dEAduction
PrettyName
  Images et union
-/

lemma exercise.image_directe_union :
∀ A A' : set X, f '' ( A ∪ A') = f '' (A) ∪ f '' (A')
:=
/- dEAduction
PrettyName
  Image directe et union
-/
begin
  todo
end

lemma exercise.image_reciproque_union :
∀ B B' : set Y, f ⁻¹' ( B ∪ B') = f ⁻¹' (B) ∪ f ⁻¹' (B')
:=
/- dEAduction
PrettyName
  Image réciproque et union
-/
begin
  todo
end

end images_union

------------------------------------------
-- Atelier 4 : Injectivité, surjectvité --
------------------------------------------

namespace injectivite_surjectivite_composition
/- dEAduction
PrettyName
    Injectivité/surjectivité et composition
-/

lemma exercise.composition_injections
(H1 : injective f) (H2 : injective g)
:
injective (composition g f)
:=
/- dEAduction
PrettyName
    Composition d'injections
-/
begin
    todo
end

lemma exercise.composition_surjections
(H1 : surjective f) (H2 : surjective g) :
surjective (composition g f)
:=
/- dEAduction
PrettyName
    Composition de surjections
-/
begin
    todo
end

lemma exercise.injective_si_compo_injective_I
(H1 : injective (composition g f)) :
injective g
:=
/- dEAduction
PrettyName
    Injective si composition injective (i)
-/
begin
    todo
end

lemma exercise.injective_si_compo_injective_II
(H1 : injective (composition g f)) :
injective f
:=
/- dEAduction
PrettyName
    Injective si composition injective (ii)
-/
begin
    todo
end

lemma exercise.surjective_si_compo_surjective_I
(H1 : surjective (composition g f)) :
surjective g
:=
/- dEAduction
PrettyName
    Surjective si composition surjective (i)
-/
begin
    todo
end

lemma exercise.surjective_si_coompo_surjective_II
(H1 : surjective (composition g f)) :
surjective f
:=
/- dEAduction
PrettyName
    Surjective si composition surjective (ii)
-/
begin
    todo
end

end injectivite_surjectivite_composition

-------------------------------------------------
-- Atelier 5 : Conjecturer, démontrer, rédiger --
-------------------------------------------------
namespace image_intersection
/- dEAduction
PrettyName
  Image de l'intersection
-/

lemma exercise.image_directe_et_intersection_I :
∀ A B: set X, f '' (A ∩ B) ⊆ f '' (A) ∩ f '' (B)
:=
/- dEAduction
PrettyName
  Image directe et intersection (i)
-/
begin
  todo
end

lemma exercise.image_directe_et_intersection_II :
∀ A B: set X,  f '' (A) ∩ f '' (B) ⊆ f '' (A ∩ B)
:=
/- dEAduction
PrettyName
  Image directe et intersection (ii)
-/
begin
  todo
end

lemma exercise.image_directe_et_intersection_III
(H : injective f) :
∀ A B: set X,  f '' (A) ∩ f '' (B) ⊆ f '' (A ∩ B)
:=
/- dEAduction
PrettyName
  Image directe et intersection (iii)
-/
begin
  todo
end

lemma exercise.image_directe_et_intersection_VI
(H : surjective f) :
∀ A B: set X,  f '' (A) ∩ f '' (B) ⊆ f '' (A ∩ B)
:=
/- dEAduction
PrettyName
  Image directe et intersection (iv)
-/
begin
  todo
end

lemma exercise.image_reciproque_inter :
∀ A' B' : set Y, f ⁻¹' ( A' ∩ B') = f ⁻¹' (A') ∩ f ⁻¹' (B')
:=
/- dEAduction
PrettyName
  Image réciproque et intersection
-/
begin
  todo
end

end image_intersection

namespace image_et_image_reciproque_II
/- dEAduction
PrettyName
  Image et image réciproque II
-/

lemma exercise.image_reciproque_de_image_III :
(injective f) → ∀ A, f ⁻¹' (f '' (A)) ⊆ A
:=
/- dEAduction
PrettyName
  Image réciproque de l'image, et injectivité
-/
begin
  todo
end

lemma exercise.image_reciproque_de_image_IV :
(surjective f) → ∀ A, f ⁻¹' (f '' (A)) ⊆ A
:=
/- dEAduction
PrettyName
  Image réciproque de l'image, et surjectivité
-/
begin
  todo
end

lemma exercise.image_de_image_reciproque_III :
(injective f) → ∀ B, B ⊆ f '' (f ⁻¹' (B))
:=
/- dEAduction
PrettyName
  Image de l'image réciproque, et injectivité
-/
begin
  todo
end

lemma exercise.image_de_image_reciproque_IV :
(surjective f) → ∀ B, B ⊆ f '' (f ⁻¹' (B))
:=
/- dEAduction
PrettyName
  Image de l'image réciproque, et surjectivité
-/
begin
  todo
end

end image_et_image_reciproque_II

namespace injectivite_surjectivite_caracterisation
/- dEAduction
PrettyName
  Formules caractérisant l'injectivité et la surjectivité
-/

lemma exercise.caracterisation_injectivite :
∀ f: X→Y, (∀ A: set X, A = f ⁻¹' (f '' A)) → injective f
:=
/- dEAduction
PrettyName
  Une caractérisation de l'injectivité
AvailableDefinitions
  UNTIL_NOW
AvailableTheorems
  UNTIL_NOW
-/
begin
  todo
end

lemma exercise.caracterisation_surjectivite :
∀ f: X→Y, (∀ B: set Y, B = f '' (f ⁻¹' B) ) → surjective f
:=
/- dEAduction
PrettyName
  Une caractérisation de la surjectivité
AvailableDefinitions
  UNTIL_NOW
AvailableTheorems
  UNTIL_NOW
-/
begin
  todo
end

lemma exercise.caracterisation_injectivite_II :
∀ f: X→Y, (∀ A A': set X, f '' A ⊆ f '' A' → A ⊆ A' ) → injective f
:=
/- dEAduction
PrettyName
  Une autre caractérisation de l'injectivité
AvailableDefinitions
  UNTIL_NOW
AvailableTheorems
  UNTIL_NOW
-/
begin
  todo
end

lemma exercise.caracterisation_injectivite_III :
∀ f: X→Y, (∀ A A': set X, f '' (A ∩  A') = f '' A ∩ f '' A' ) → injective f
:=
/- dEAduction
PrettyName
  Une autre caractérisation de l'injectivité
AvailableDefinitions
  UNTIL_NOW
AvailableTheorems
  UNTIL_NOW
-/
begin
  todo
end

lemma exercise.caracterisation_surjectivite_II :
∀ f: X→Y, (∀ B B': set Y, (f ⁻¹' B ⊆ f ⁻¹' B' → B ⊆ B') ) → surjective f
:=
/- dEAduction
PrettyName
  Une autre caractérisation de la surjectivité
AvailableDefinitions
  UNTIL_NOW
AvailableTheorems
  UNTIL_NOW
-/
begin
  todo
end

end injectivite_surjectivite_caracterisation

namespace injectivite_surjectivite_autres
/- dEAduction
PrettyName
  Injectivité/surjectivité : divers
-/

lemma exercise.injectivite_surjecivite (f: X → Y) (g: Y → Z)
(H1 : injective (composition g f)) (H2 : surjective f)
:
injective g
:=
/- dEAduction
PrettyName
    Injectivité et surjectivité
AvailableDefinitions
  UNTIL_NOW
AvailableTheorems
  UNTIL_NOW
-/
begin
    todo
end

-- NB: naming a bound var with '__' suffix forces use of its name
lemma exercise.injectivite_categorielle
(f: Y → Z):
(injective f) → (∀X__: Type, ∀ g h : X__ → Y, (composition f g) = (composition f h) → g = h)
:=
/- dEAduction
PrettyName
    Injectivité catégorielle
AvailableDefinitions
  UNTIL_NOW
AvailableTheorems
  UNTIL_NOW
-/
begin
    todo
end

lemma exercise.surjectivite_categorielle
(f: X → Y):
(surjective f) →  (∀Z: Type, ∀ g h : Y → Z, (composition g f ) = (composition h f ) → g = h)
:=
/- dEAduction
PrettyName
    Surjectivité catégorielle
AvailableDefinitions
  UNTIL_NOW
AvailableTheorems
  UNTIL_NOW
-/
begin
    todo
end

lemma exercise.surjective_ssi_inverse_droite : (surjective f) ↔
∃ F: Y → X, (composition f F) = Identite :=
/- dEAduction
PrettyName
    (*) Surjectivité et inverse à droite
AvailableDefinitions
  UNTIL_NOW
AvailableTheorems
  UNTIL_NOW
-/
begin
    todo
end

lemma exercise.image_directe_et_inclusion_III :
(injective f) →  (∀ A B: set X,  f '' (A) ⊆ f '' (B) → A ⊆ B)
:=
/- dEAduction
PrettyName
  Image directe et inclusion (iii)
AvailableDefinitions
  UNTIL_NOW
AvailableTheorems
  UNTIL_NOW
-/
begin
  todo
end

lemma exercise.image_reciproque_et_inclusion_III :
(surjective f) → (∀ A' B': set Y,  f ⁻¹' (A') ⊆ f ⁻¹' (B') → A' ⊆ B')
:=
/- dEAduction
PrettyName
  Image réciproque et inclusion (iii)
-/
begin
  -- intros surj_f A B incl y y_dans_A,
  -- have ex_x := surj_f y, cases ex_x with x eq,
  -- have but: (x dans (set.preimage f A)),
  -- todo, todo,
  todo
end

end injectivite_surjectivite_autres

end exercices

end ensembles_et_applications

end course


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Kevin Buzzard, Yury Kudryashov
-/
import group_theory.quotient_group
import linear_algebra.span

/-!
# Quotients by submodules

* If `p` is a submodule of `M`, `M ⧸ p` is the quotient of `M` with respect to `p`:
  that is, elements of `M` are identified if their difference is in `p`. This is itself a module.

-/

-- For most of this file we work over a noncommutative ring
section ring

namespace submodule

variables {R M : Type*} {r : R} {x y : M} [ring R] [add_comm_group M] [module R M]
variables (p p' : submodule R M)

open linear_map quotient_add_group

/-- The equivalence relation associated to a submodule `p`, defined by `x ≈ y` iff `-x + y ∈ p`.

Note this is equivalent to `y - x ∈ p`, but defined this way to be be defeq to the `add_subgroup`
version, where commutativity can't be assumed. -/
def quotient_rel : setoid M :=
quotient_add_group.left_rel p.to_add_subgroup

lemma quotient_rel_r_def {x y : M} : @setoid.r _ (p.quotient_rel) x y ↔ x - y ∈ p :=
iff.trans (by { rw [left_rel_apply, sub_eq_add_neg, neg_add, neg_neg], refl }) neg_mem_iff

/-- The quotient of a module `M` by a submodule `p ⊆ M`. -/
instance has_quotient : has_quotient M (submodule R M) := ⟨λ p, quotient (quotient_rel p)⟩

namespace quotient

/-- Map associating to an element of `M` the corresponding element of `M/p`,
when `p` is a submodule of `M`. -/
def mk {p : submodule R M} : M → M ⧸ p := quotient.mk'

@[simp] theorem mk_eq_mk {p : submodule R M} (x : M) :
  (@_root_.quotient.mk _ (quotient_rel p) x) = mk x := rfl
@[simp] theorem mk'_eq_mk {p : submodule R M} (x : M) : (quotient.mk' x : M ⧸ p) = mk x := rfl
@[simp] theorem quot_mk_eq_mk {p : submodule R M} (x : M) : (quot.mk _ x : M ⧸ p) = mk x := rfl

protected theorem eq' {x y : M} : (mk x : M ⧸ p) = mk y ↔ -x + y ∈ p := quotient_add_group.eq

protected theorem eq {x y : M} : (mk x : M ⧸ p) = mk y ↔ x - y ∈ p :=
(p^.quotient.eq').trans (left_rel_apply.symm.trans p.quotient_rel_r_def)

instance : has_zero (M ⧸ p) := ⟨mk 0⟩
instance : inhabited (M ⧸ p) := ⟨0⟩

@[simp] theorem mk_zero : mk 0 = (0 : M ⧸ p) := rfl

@[simp] theorem mk_eq_zero : (mk x : M ⧸ p) = 0 ↔ x ∈ p :=
by simpa using (quotient.eq p : mk x = 0 ↔ _)

instance add_comm_group : add_comm_group (M ⧸ p) :=
quotient_add_group.add_comm_group p.to_add_subgroup

@[simp] theorem mk_add : (mk (x + y) : M ⧸ p) = mk x + mk y := rfl

@[simp] theorem mk_neg : (mk (-x) : M ⧸ p) = -mk x := rfl

@[simp] theorem mk_sub : (mk (x - y) : M ⧸ p) = mk x - mk y := rfl

section has_smul

variables {S : Type*} [has_smul S R] [has_smul S M] [is_scalar_tower S R M] (P : submodule R M)

instance has_smul' : has_smul S (M ⧸ P) :=
⟨λ a, quotient.map' ((•) a) $ λ x y h, left_rel_apply.mpr $
  by simpa [smul_sub] using P.smul_mem (a • 1 : R) (left_rel_apply.mp h)⟩

/-- Shortcut to help the elaborator in the common case. -/
instance has_smul : has_smul R (M ⧸ P) :=
quotient.has_smul' P

@[simp] theorem mk_smul (r : S) (x : M) : (mk (r • x) : M ⧸ p) = r • mk x := rfl

instance smul_comm_class (T : Type*) [has_smul T R] [has_smul T M] [is_scalar_tower T R M]
  [smul_comm_class S T M] : smul_comm_class S T (M ⧸ P) :=
{ smul_comm := λ x y, quotient.ind' $ by exact λ z, congr_arg mk (smul_comm _ _ _) }

instance is_scalar_tower (T : Type*) [has_smul T R] [has_smul T M] [is_scalar_tower T R M]
  [has_smul S T] [is_scalar_tower S T M] : is_scalar_tower S T (M ⧸ P) :=
{ smul_assoc := λ x y, quotient.ind' $ by exact λ z, congr_arg mk (smul_assoc _ _ _) }

instance is_central_scalar [has_smul Sᵐᵒᵖ R] [has_smul Sᵐᵒᵖ M] [is_scalar_tower Sᵐᵒᵖ R M]
  [is_central_scalar S M] : is_central_scalar S (M ⧸ P) :=
{ op_smul_eq_smul := λ x, quotient.ind' $ by exact λ z, congr_arg mk $ op_smul_eq_smul _ _ }

end has_smul

section module

variables {S : Type*}

instance mul_action' [monoid S] [has_smul S R] [mul_action S M] [is_scalar_tower S R M]
  (P : submodule R M) : mul_action S (M ⧸ P) :=
function.surjective.mul_action mk (surjective_quot_mk _) P^.quotient.mk_smul

instance mul_action (P : submodule R M) : mul_action R (M ⧸ P) :=
quotient.mul_action' P

instance distrib_mul_action' [monoid S] [has_smul S R] [distrib_mul_action S M]
  [is_scalar_tower S R M]
  (P : submodule R M) : distrib_mul_action S (M ⧸ P) :=
function.surjective.distrib_mul_action
  ⟨mk, rfl, λ _ _, rfl⟩ (surjective_quot_mk _) P^.quotient.mk_smul

instance distrib_mul_action (P : submodule R M) : distrib_mul_action R (M ⧸ P) :=
quotient.distrib_mul_action' P

instance module' [semiring S] [has_smul S R] [module S M] [is_scalar_tower S R M]
  (P : submodule R M) : module S (M ⧸ P) :=
function.surjective.module _
  ⟨mk, rfl, λ _ _, rfl⟩ (surjective_quot_mk _) P^.quotient.mk_smul

instance module (P : submodule R M) : module R (M ⧸ P) :=
quotient.module' P

variables (S)

/-- The quotient of `P` as an `S`-submodule is the same as the quotient of `P` as an `R`-submodule,
where `P : submodule R M`.
-/
def restrict_scalars_equiv [ring S] [has_smul S R] [module S M] [is_scalar_tower S R M]
  (P : submodule R M) :
  (M ⧸ P.restrict_scalars S) ≃ₗ[S] M ⧸ P :=
{ map_add' := λ x y, quotient.induction_on₂' x y (λ x' y', rfl),
  map_smul' := λ c x, quotient.induction_on' x (λ x', rfl),
  ..quotient.congr_right $ λ _ _, iff.rfl }

@[simp] lemma restrict_scalars_equiv_mk
  [ring S] [has_smul S R] [module S M] [is_scalar_tower S R M] (P : submodule R M)
  (x : M) : restrict_scalars_equiv S P (mk x) = mk x :=
rfl

@[simp] lemma restrict_scalars_equiv_symm_mk
  [ring S] [has_smul S R] [module S M] [is_scalar_tower S R M] (P : submodule R M)
  (x : M) : (restrict_scalars_equiv S P).symm (mk x) = mk x :=
rfl

end module

lemma mk_surjective : function.surjective (@mk _ _ _ _ _ p) :=
by { rintros ⟨x⟩, exact ⟨x, rfl⟩ }

lemma nontrivial_of_lt_top (h : p < ⊤) : nontrivial (M ⧸ p) :=
begin
  obtain ⟨x, _, not_mem_s⟩ := set_like.exists_of_lt h,
  refine ⟨⟨mk x, 0, _⟩⟩,
  simpa using not_mem_s
end

end quotient

section

variables {M₂ : Type*} [add_comm_group M₂] [module R M₂]

lemma quot_hom_ext ⦃f g : M ⧸ p →ₗ[R] M₂⦄ (h : ∀ x, f (quotient.mk x) = g (quotient.mk x)) :
  f = g :=
linear_map.ext $ λ x, quotient.induction_on' x h

/-- The map from a module `M` to the quotient of `M` by a submodule `p` as a linear map. -/
def mkq : M →ₗ[R] M ⧸ p :=
{ to_fun := quotient.mk, map_add' := by simp, map_smul' := by simp }

@[simp] theorem mkq_apply (x : M) : p.mkq x = quotient.mk x := rfl

lemma mkq_surjective (A : submodule R M) : function.surjective A.mkq :=
by rintro ⟨x⟩; exact ⟨x, rfl⟩

end

variables {R₂ M₂ : Type*} [ring R₂] [add_comm_group M₂] [module R₂ M₂] {τ₁₂ : R →+* R₂}

/-- Two `linear_map`s from a quotient module are equal if their compositions with
`submodule.mkq` are equal.

See note [partially-applied ext lemmas]. -/
@[ext]
lemma linear_map_qext ⦃f g : M ⧸ p →ₛₗ[τ₁₂] M₂⦄ (h : f.comp p.mkq = g.comp p.mkq) : f = g :=
linear_map.ext $ λ x, quotient.induction_on' x $ (linear_map.congr_fun h : _)

/-- The map from the quotient of `M` by a submodule `p` to `M₂` induced by a linear map `f : M → M₂`
vanishing on `p`, as a linear map. -/
def liftq (f : M →ₛₗ[τ₁₂] M₂) (h : p ≤ f.ker) : M ⧸ p →ₛₗ[τ₁₂] M₂ :=
{ map_smul' := by rintro a ⟨x⟩; exact f.map_smulₛₗ a x,
  ..quotient_add_group.lift p.to_add_subgroup f.to_add_monoid_hom h }

@[simp] theorem liftq_apply (f : M →ₛₗ[τ₁₂] M₂) {h} (x : M) :
  p.liftq f h (quotient.mk x) = f x := rfl

@[simp] theorem liftq_mkq (f : M →ₛₗ[τ₁₂] M₂) (h) : (p.liftq f h).comp p.mkq = f :=
by ext; refl

/--Special case of `liftq` when `p` is the span of `x`. In this case, the condition on `f` simply
becomes vanishing at `x`.-/
def liftq_span_singleton (x : M) (f : M →ₛₗ[τ₁₂] M₂) (h : f x = 0) : (M ⧸ R ∙ x) →ₛₗ[τ₁₂] M₂ :=
(R ∙ x).liftq f $ by rw [span_singleton_le_iff_mem, linear_map.mem_ker, h]

@[simp] lemma liftq_span_singleton_apply (x : M) (f : M →ₛₗ[τ₁₂] M₂) (h : f x = 0) (y : M) :
liftq_span_singleton x f h (quotient.mk y) = f y := rfl

@[simp] theorem range_mkq : p.mkq.range = ⊤ :=
eq_top_iff'.2 $ by rintro ⟨x⟩; exact ⟨x, rfl⟩

@[simp] theorem ker_mkq : p.mkq.ker = p :=
by ext; simp

lemma le_comap_mkq (p' : submodule R (M ⧸ p)) : p ≤ comap p.mkq p' :=
by simpa using (comap_mono bot_le : p.mkq.ker ≤ comap p.mkq p')

@[simp] theorem mkq_map_self : map p.mkq p = ⊥ :=
by rw [eq_bot_iff, map_le_iff_le_comap, comap_bot, ker_mkq]; exact le_rfl

@[simp] theorem comap_map_mkq : comap p.mkq (map p.mkq p') = p ⊔ p' :=
by simp [comap_map_eq, sup_comm]

@[simp] theorem map_mkq_eq_top : map p.mkq p' = ⊤ ↔ p ⊔ p' = ⊤ :=
by simp only [map_eq_top_iff p.range_mkq, sup_comm, ker_mkq]

variables (q : submodule R₂ M₂)

/-- The map from the quotient of `M` by submodule `p` to the quotient of `M₂` by submodule `q` along
`f : M → M₂` is linear. -/
def mapq (f : M →ₛₗ[τ₁₂] M₂) (h : p ≤ comap f q) :
  (M ⧸ p) →ₛₗ[τ₁₂] (M₂ ⧸ q) :=
p.liftq (q.mkq.comp f) $ by simpa [ker_comp] using h

@[simp] theorem mapq_apply (f : M →ₛₗ[τ₁₂] M₂) {h} (x : M) :
  mapq p q f h (quotient.mk x) = quotient.mk (f x) := rfl

theorem mapq_mkq (f : M →ₛₗ[τ₁₂] M₂) {h} : (mapq p q f h).comp p.mkq = q.mkq.comp f :=
by ext x; refl

@[simp] lemma mapq_zero (h : p ≤ q.comap (0 : M →ₛₗ[τ₁₂] M₂) := by simp) :
  p.mapq q (0 : M →ₛₗ[τ₁₂] M₂) h = 0 :=
by { ext, simp, }

/-- Given submodules `p ⊆ M`, `p₂ ⊆ M₂`, `p₃ ⊆ M₃` and maps `f : M → M₂`, `g : M₂ → M₃` inducing
`mapq f : M ⧸ p → M₂ ⧸ p₂` and `mapq g : M₂ ⧸ p₂ → M₃ ⧸ p₃` then
`mapq (g ∘ f) = (mapq g) ∘ (mapq f)`. -/
lemma mapq_comp {R₃ M₃ : Type*} [ring R₃] [add_comm_group M₃] [module R₃ M₃]
  (p₂ : submodule R₂ M₂) (p₃ : submodule R₃ M₃)
  {τ₂₃ : R₂ →+* R₃} {τ₁₃ : R →+* R₃} [ring_hom_comp_triple τ₁₂ τ₂₃ τ₁₃]
  (f : M →ₛₗ[τ₁₂] M₂) (g : M₂ →ₛₗ[τ₂₃] M₃) (hf : p ≤ p₂.comap f) (hg : p₂ ≤ p₃.comap g)
  (h := (hf.trans (comap_mono hg))) :
  p.mapq p₃ (g.comp f) h = (p₂.mapq p₃ g hg).comp (p.mapq p₂ f hf) :=
by { ext, simp, }

@[simp] lemma mapq_id (h : p ≤ p.comap linear_map.id := by simp) :
  p.mapq p linear_map.id h = linear_map.id :=
by { ext, simp, }

lemma mapq_pow {f : M →ₗ[R] M} (h : p ≤ p.comap f) (k : ℕ)
  (h' : p ≤ p.comap (f^k) := p.le_comap_pow_of_le_comap h k) :
  p.mapq p (f^k) h' = (p.mapq p f h)^k :=
begin
  induction k with k ih,
  { simp [linear_map.one_eq_id], },
  { simp only [linear_map.iterate_succ, ← ih],
    apply p.mapq_comp, },
end

theorem comap_liftq (f : M →ₛₗ[τ₁₂] M₂) (h) :
  q.comap (p.liftq f h) = (q.comap f).map (mkq p) :=
le_antisymm
  (by rintro ⟨x⟩ hx; exact ⟨_, hx, rfl⟩)
  (by rw [map_le_iff_le_comap, ← comap_comp, liftq_mkq]; exact le_rfl)

theorem map_liftq [ring_hom_surjective τ₁₂] (f : M →ₛₗ[τ₁₂] M₂) (h) (q : submodule R (M ⧸ p)) :
  q.map (p.liftq f h) = (q.comap p.mkq).map f :=
le_antisymm
  (by rintro _ ⟨⟨x⟩, hxq, rfl⟩; exact ⟨x, hxq, rfl⟩)
  (by rintro _ ⟨x, hxq, rfl⟩; exact ⟨quotient.mk x, hxq, rfl⟩)

theorem ker_liftq (f : M →ₛₗ[τ₁₂] M₂) (h) :
  ker (p.liftq f h) = (ker f).map (mkq p) := comap_liftq _ _ _ _

theorem range_liftq [ring_hom_surjective τ₁₂] (f : M →ₛₗ[τ₁₂] M₂) (h) :
  range (p.liftq f h) = range f :=
by simpa only [range_eq_map] using map_liftq _ _ _ _

theorem ker_liftq_eq_bot (f : M →ₛₗ[τ₁₂] M₂) (h) (h' : ker f ≤ p) : ker (p.liftq f h) = ⊥ :=
by rw [ker_liftq, le_antisymm h h', mkq_map_self]

/-- The correspondence theorem for modules: there is an order isomorphism between submodules of the
quotient of `M` by `p`, and submodules of `M` larger than `p`. -/
def comap_mkq.rel_iso :
  submodule R (M ⧸ p) ≃o {p' : submodule R M // p ≤ p'} :=
{ to_fun    := λ p', ⟨comap p.mkq p', le_comap_mkq p _⟩,
  inv_fun   := λ q, map p.mkq q,
  left_inv  := λ p', map_comap_eq_self $ by simp,
  right_inv := λ ⟨q, hq⟩, subtype.ext_val $ by simpa [comap_map_mkq p],
  map_rel_iff'      := λ p₁ p₂, comap_le_comap_iff $ range_mkq _ }

/-- The ordering on submodules of the quotient of `M` by `p` embeds into the ordering on submodules
of `M`. -/
def comap_mkq.order_embedding :
  submodule R (M ⧸ p) ↪o submodule R M :=
(rel_iso.to_rel_embedding $ comap_mkq.rel_iso p).trans (subtype.rel_embedding _ _)

@[simp] lemma comap_mkq_embedding_eq (p' : submodule R (M ⧸ p)) :
  comap_mkq.order_embedding p p' = comap p.mkq p' := rfl

lemma span_preimage_eq [ring_hom_surjective τ₁₂] {f : M →ₛₗ[τ₁₂] M₂} {s : set M₂} (h₀ : s.nonempty)
  (h₁ : s ⊆ range f) :
  span R (f ⁻¹' s) = (span R₂ s).comap f :=
begin
  suffices : (span R₂ s).comap f ≤ span R (f ⁻¹' s),
  { exact le_antisymm (span_preimage_le f s) this, },
  have hk : ker f ≤ span R (f ⁻¹' s),
  { let y := classical.some h₀, have hy : y ∈ s, { exact classical.some_spec h₀, },
    rw ker_le_iff, use [y, h₁ hy], rw ← set.singleton_subset_iff at hy,
    exact set.subset.trans subset_span (span_mono (set.preimage_mono hy)), },
  rw ← left_eq_sup at hk, rw f.range_coe at h₁,
  rw [hk, ←linear_map.map_le_map_iff, map_span, map_comap_eq, set.image_preimage_eq_of_subset h₁],
  exact inf_le_right,
end

end submodule

open submodule

namespace linear_map

section ring

variables {R M R₂ M₂ R₃ M₃ : Type*}
variables [ring R] [ring R₂] [ring R₃]
variables [add_comm_monoid M] [add_comm_group M₂] [add_comm_monoid M₃]
variables [module R M] [module R₂ M₂] [module R₃ M₃]
variables {τ₁₂ : R →+* R₂} {τ₂₃ : R₂ →+* R₃} {τ₁₃ : R →+* R₃}
variables [ring_hom_comp_triple τ₁₂ τ₂₃ τ₁₃] [ring_hom_surjective τ₁₂]

lemma range_mkq_comp (f : M →ₛₗ[τ₁₂] M₂) : f.range.mkq.comp f = 0 :=
linear_map.ext $ λ x, by simp

lemma ker_le_range_iff {f : M →ₛₗ[τ₁₂] M₂} {g : M₂ →ₛₗ[τ₂₃] M₃} :
  g.ker ≤ f.range ↔ f.range.mkq.comp g.ker.subtype = 0 :=
by rw [←range_le_ker_iff, submodule.ker_mkq, submodule.range_subtype]

/-- An epimorphism is surjective. -/
lemma range_eq_top_of_cancel {f : M →ₛₗ[τ₁₂] M₂}
  (h : ∀ (u v : M₂ →ₗ[R₂] M₂ ⧸ f.range), u.comp f = v.comp f → u = v) : f.range = ⊤ :=
begin
  have h₁ : (0 : M₂ →ₗ[R₂] M₂ ⧸ f.range).comp f = 0 := zero_comp _,
  rw [←submodule.ker_mkq f.range, ←h 0 f.range.mkq (eq.trans h₁ (range_mkq_comp _).symm)],
  exact ker_zero
end

end ring

end linear_map

open linear_map

namespace submodule

variables {R M : Type*} {r : R} {x y : M} [ring R] [add_comm_group M] [module R M]
variables (p p' : submodule R M)

/-- If `p = ⊥`, then `M / p ≃ₗ[R] M`. -/
def quot_equiv_of_eq_bot (hp : p = ⊥) : (M ⧸ p) ≃ₗ[R] M :=
linear_equiv.of_linear (p.liftq id $ hp.symm ▸ bot_le) p.mkq (liftq_mkq _ _ _) $
  p.quot_hom_ext $ λ x, rfl

@[simp] lemma quot_equiv_of_eq_bot_apply_mk (hp : p = ⊥) (x : M) :
  p.quot_equiv_of_eq_bot hp (quotient.mk x) = x := rfl

@[simp] lemma quot_equiv_of_eq_bot_symm_apply (hp : p = ⊥) (x : M) :
  (p.quot_equiv_of_eq_bot hp).symm x = quotient.mk x := rfl

@[simp] lemma coe_quot_equiv_of_eq_bot_symm (hp : p = ⊥) :
  ((p.quot_equiv_of_eq_bot hp).symm : M →ₗ[R] M ⧸ p) = p.mkq := rfl

/-- Quotienting by equal submodules gives linearly equivalent quotients. -/
def quot_equiv_of_eq (h : p = p') : (M ⧸ p) ≃ₗ[R] M ⧸ p' :=
{ map_add' := by { rintros ⟨x⟩ ⟨y⟩, refl }, map_smul' := by { rintros x ⟨y⟩, refl },
  ..@quotient.congr _ _ (quotient_rel p) (quotient_rel p') (equiv.refl _) $
    λ a b, by { subst h, refl } }

@[simp]
lemma quot_equiv_of_eq_mk (h : p = p') (x : M) :
  submodule.quot_equiv_of_eq p p' h (submodule.quotient.mk x) = submodule.quotient.mk x :=
rfl

end submodule

end ring

section comm_ring

variables {R M M₂ : Type*} {r : R} {x y : M} [comm_ring R]
  [add_comm_group M] [module R M] [add_comm_group M₂] [module R M₂]
  (p : submodule R M) (q : submodule R M₂)

namespace submodule

/-- Given modules `M`, `M₂` over a commutative ring, together with submodules `p ⊆ M`, `q ⊆ M₂`,
the natural map $\{f ∈ Hom(M, M₂) | f(p) ⊆ q \} \to Hom(M/p, M₂/q)$ is linear. -/
def mapq_linear : compatible_maps p q →ₗ[R] (M ⧸ p) →ₗ[R] (M₂ ⧸ q) :=
{ to_fun    := λ f, mapq _ _ f.val f.property,
  map_add'  := λ x y, by { ext, refl, },
  map_smul' := λ c f, by { ext, refl, } }

end submodule

end comm_ring


/-
Here are some thoughts on dlists ("difference lists? can't remember what the d stood for").
It's a way of giving a new model of lists built using the old model. A list l is encoded
as the function list α → list α defined by λ m, m ++ l . The miracle is that associativity
is rfl which is a type theory bonus.

-/

/- apparently...
import data.dlist.basic

variable {α : Type*}
example (a b c : dlist α) :
  dlist.append (dlist.append a b) c = dlist.append a (dlist.append b c) :=
rfl -- doesn't work

ℤ
-/

import data.equiv.basic

namespace xena

structure dlist (α : Type*) :=
(apply : list α → list α) -- λ l, l ++ d.to_list
(thm : ∀ l, apply l = l ++ apply [])

instance (α : Type*) : has_coe_to_fun (dlist α) :=
{ F := λ _, list α → list α,
  coe := dlist.apply }

variable {α : Type*}

def dlist.to_list (d : dlist α) : list α := d.apply []

def dlist.of_list (l : list α) : dlist α :=
{ apply := λ m, m ++ l,
  thm := λ m, by simp}

@[simp] theorem apply_def (d : dlist α) (l : list α) : d.apply l = l ++ d.to_list :=
begin
  rw d.thm,
  refl
end

def dlist.nil (α : Type*) : dlist α :=
{ apply := λ l, l,
  thm := λ l, (list.append_nil l).symm}

def dlist.append (d e : dlist α) : dlist α :=
{ apply := λ l, e.apply (d.apply l),
  thm := by simp }

instance : has_add (dlist α) := ⟨dlist.append⟩

-- rfl proof of associative
example (c d e : dlist α) : (c + d) + e = c + (d + e) := rfl
-- works because it's composition of functions

instance : has_zero (dlist α) := ⟨dlist.nil α⟩

@[extensionality] def dlist.ext (d e : dlist α) : (d : list α → list α) = e → d = e :=
begin intro h, cases d, cases e, cases h, congr' end

-- ext then refl
example (e : dlist α) : 0 + e = e := by ext; refl

example (e : dlist α) : e + 0 = e := by ext; refl

end xena


import category_theory.basic
import misc.set

namespace topology

open set
open classical

universes u v

class topology (X : Type u) :=
  (is_open : set X → Prop)
  (whole_space_open : is_open univ)
  (empty_set_open : is_open ∅)
  (arbitary_unions_open (s: set (set X)) : (∀ t : set X, t ∈ s → is_open t) → is_open (⋃₀ s))
  (pairwise_inters_open : ∀ s t : set X, is_open s → is_open t → is_open (s ∩ t))

def is_open {X : Type u} [T_X: topology X] : set X → Prop := T_X.is_open

def is_continous_map {X : Type u} {Y : Type v} [T_X : topology X][T_Y : topology Y] (f : X → Y) : Prop :=
∀ {s : set Y} , is_open s → is_open (pre_image f s)

structure Open (X : Type u) [topology X] : Type u:=
  (val : set X)
  (val_open : is_open val)

def open_set_membership {X : Type u} [topology X] : X → Open X → Prop
  := λ p O, p ∈ O.val

instance open_set_has_mem (X : Type u) [topology X] : has_mem X (Open X)
  := ⟨open_set_membership⟩

inductive inclusion {X : Type u} [topology X] (O₁ O₂ : Open X) : Type u
  | proof : O₁.val ⊆ O₂.val → inclusion

theorem inclusion_equality {X : Type u} [topology X] {O₁ O₂ : Open X}
  : ∀ x y : inclusion O₁ O₂, x = y :=
begin
  intros x y,
  cases x,
  cases y,
  refl,
end

def inclusion_comp {X : Type u} [topology X] {O₁ O₂ O₃ : Open X}
  : inclusion O₂ O₃ → inclusion O₁ O₂ → inclusion O₁ O₃ :=
begin
  intros i₁ i₂,
  apply inclusion.proof,
  cases i₁,
  cases i₂,
  intros x hx,
  apply i₁,
  apply i₂,
  assumption,
end

def open_set_intersection {X : Type u} [topology X] : Open X → Open X → Open X
  | O₁ O₂ := ⟨O₁.val ∩ O₂.val, topology.pairwise_inters_open O₁.val O₂.val O₁.val_open O₂.val_open⟩

instance open_set_has_inter {X : Type u} [topology X] : has_inter (Open X) := ⟨topology.open_set_intersection⟩

lemma open_set_inter_val {X : Type u} [topology X] (O₁ O₂ : Open X) : (O₁ ∩ O₂).val = O₁.val ∩ O₂.val := rfl

instance category_of_open_sets (X : Type u) [topology X] : category (Open X) :=
{
  Mor := λ O₁ O₂, inclusion O₁ O₂,
  idₘ := λ O, inclusion.proof (λ x hx, hx),
  comp := λ O₁ O₂ O₃ i₁ i₂, inclusion_comp i₁ i₂,
  comp_assoc :=
    begin
      intros O₁ O₂ O₃ O₄ i₁ i₂ i₃,
      apply inclusion_equality,
    end,
  id_comp_left :=
    begin
      intros O₁ O₂ f,
      apply inclusion_equality,
    end,
  id_comp_right :=
    begin
      intros O₁ O₂ f,
      apply inclusion_equality,
    end,
}

instance category_of_open_sets_at_point {X : Type u} (p : X) [topology X] : category ({O :Open X // p ∈ O}) :=
{
  Mor := λ O₁ O₂, inclusion O₁.val O₂.val,
  idₘ := λ O, inclusion.proof (λ x hx, hx),
  comp := λ O₁ O₂ O₃ i₁ i₂, inclusion_comp i₁ i₂,
  comp_assoc :=
    begin
      intros O₁ O₂ O₃ O₄ i₁ i₂ i₃,
      apply inclusion_equality,
    end,
  id_comp_left :=
    begin
      intros O₁ O₂ f,
      apply inclusion_equality,
    end,
  id_comp_right :=
    begin
      intros O₁ O₂ f,
      apply inclusion_equality,
    end,
}

instance open_sets_at_a_point_nonempty {X : Type u} [topology X] (p : X) : nonempty ({O: Open X // p ∈ O}) :=
begin
  split,
  existsi Open.mk univ topology.whole_space_open,
  trivial,
end

def open_cover_of {X : Type u} [topology X] (C : set (Open X)) (S : Open X)
  : Prop := (∀ {U : Open X} , U ∈ C → U.val ⊆ S.val) ∧ (∀ {x}, x ∈ S.val → ∃ U : Open X, U ∈ C ∧ x ∈ U.val)

def is_open_cover {X : Type u} [topology X] {I : Type u} (f : I → Open X) (S : Open X) : Prop :=
  (∀ i : I, (f i).val ⊆ S.val) ∧ (∀ {x}, x ∈ S → ∃ i, x ∈ (f i))

def is_open_cover_includes {X : Type u} [topology X] {I : Type u} {f : I → Open X} {S : Open X}
  (hf : is_open_cover f S) : Π i, inclusion (f i) S :=
begin
  intro i,
  apply inclusion.proof,
  apply hf.1,
end

def open_cover_includes {X : Type u} [topology X] {C : set (Open X)} {S : Open X}
  (hC : open_cover_of C S)  : Π {O}, O ∈ C → inclusion O S :=
begin
  intros O hO,
  apply inclusion.proof,
  apply hC.1,
  exact hO,
end

def inter_inc_left {X : Type u} [topology X] (O₁ O₂ : Open X) : inclusion (O₁ ∩ O₂) O₁ :=
begin
  apply inclusion.proof,
  rw open_set_inter_val,
  apply intersection_in_set,
end

def inter_inc_right {X : Type u} [topology X] (O₁ O₂ : Open X) : inclusion (O₁ ∩ O₂) O₂ :=
begin
  apply inclusion.proof,
  rw open_set_inter_val,
  rw intersection_commuative,
  apply intersection_in_set,
end

def open_at_point_forget {X : Type u} [topology X] (p : X) : {O: Open X // p ∈ O} +→ Open X :=
{
  map := λ O, O.val,
  fmap := λ O₁ O₂ f, f,
  fmap_prevs_comp := λ _ _ _ _ _, rfl,
  fmap_prevs_id := λ _, rfl,
}

def open_transport {X : Type u} [topology X] {Y : Type v} [topology Y]
  {f : X → Y} (hf : is_continous_map f) : Open Y +→ Open X :=
{
  map := λ O_Y, ⟨pre_image f O_Y.val, hf O_Y.val_open⟩,
  fmap :=
    begin
      intros O₁ O₂ i,
      cases i,
      split,
      simp,
      apply pre_image_prevs_subset,
      assumption,
    end,
  fmap_prevs_comp := λ _ _ _ _ _, rfl,
  fmap_prevs_id := λ _, rfl,
}

end topology


open classical

lemma imp_or : ∀ p q: Prop, (p → q) → (¬p ∨ q) := begin
intros p q h, apply by_cases, {
  assume: p, right, exact (h this)
}, {
  assume: ¬ p, left, assumption
}
end
#check imp_or

lemma nall_en: ∀ α: Type, ∀ p: α -> Prop, (¬ ∀ x, p x) -> (∃ x, ¬ p x) := begin
intros,
apply by_contradiction, {
  intro hc,
  have: ∀ x, p x, {
    intro, apply by_contradiction, {
      intro hnpx,
      have: ∃ x, ¬ p x, from ⟨x, hnpx⟩, contradiction
    }
  }, contradiction
}
end
#check nall_en

variables (α : Type) (p q : α → Prop)
variable a : α
variable r : Prop

example : (∃ x : α, r) → r := begin
intro h, cases h, assumption
end

include a
example : r → (∃ x : α, r) := begin
intro hr, exact ⟨a, hr⟩
end

example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r := begin
apply iff.intro, {
  intro h, cases h, constructor,
    exact ⟨h_w, h_h.1⟩,
    exact h_h.2
}, {
  intro h, cases h.1, existsi w, constructor, exact h_1, exact h.2
}
end

example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) := begin
apply iff.intro, {
  intro h, cases h, cases h_h,
    left, exact ⟨h_w, h_h⟩,
    right, exact ⟨h_w, h_h⟩
}, {
  intro h, cases h,
    cases h, existsi h_w, left, assumption,
    cases h, existsi h_w, right, assumption,
}
end

example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) := begin
apply iff.intro, {
  intro h, intro h1,
  cases h1 with w hnpw, exact hnpw (h w)
}, {
  intro h, intro x,
  apply by_contradiction, {
    intro hnpx,
    have h2: (∃ x, ¬ p x), from ⟨x, hnpx⟩,
    contradiction
  }
}
end

example : (∃ x, p x) ↔ ¬ (∀ x, ¬ p x) := begin
apply iff.intro, {
  intro h, cases h,
  intro hnpx, exact hnpx h_w h_h
}, {
  intro h, apply by_contradiction, {
    intro hc,
    have: ∀ x, ¬ p x, {
      intro x,
      intro hpx,
      have: ∃ x, p x, from ⟨x, hpx⟩,
      contradiction
    }, contradiction
  }
}
end

example : (¬ ∃ x, p x) ↔ (∀ x, ¬ p x) := begin
apply iff.intro, {
  intros h x,
  assume: p x, exact h ⟨x, this⟩
}, {
  intros h hnxp, cases hnxp with w pw,
  have: ¬ p w, from h w, contradiction
}
end

example : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) := begin
apply iff.intro, {
  intro h,
  exact nall_en α p h,
}, {
  intro h, cases h,
  intro hpx,
  have: p h_w, from hpx h_w, contradiction
}
end

example : (∀ x, p x → r) ↔ (∃ x, p x) → r := begin
apply iff.intro, {
  intros h he, cases he,
  exact h he_w he_h
}, {
  intro h, intros x hpx,
  exact h ⟨x, hpx⟩
}
end

example : (∃ x, p x → r) ↔ (∀ x, p x) → r := begin
apply iff.intro, {
  intros h hpx, cases h,
  have: p h_w, from hpx h_w,
  exact h_h this
}, {
  intro h,
  have: (¬ ∀ x, p x) ∨ r, from imp_or (∀ x, p x) r h,
  cases this, {
    have: ∃ x, ¬ p x, from nall_en α p this,
    cases this with w hnpw,
    existsi w, intro, contradiction
  }, {
    existsi a, intro, assumption
  }
}
end

example : (∃ x, r → p x) ↔ (r → ∃ x, p x) := begin
apply iff.intro, {
  intros h hr,
  cases h,
  exact ⟨h_w, h_h hr⟩
}, {
  intro h, apply by_cases, {
    assume hr: r,
    cases (h hr) with w pw,
    existsi w, intro, assumption
  }, {
    assume: ¬ r,
    existsi a, intro hr, contradiction
  }
}
end


-- Exercises
-- #1

variables p q r : Prop

-- commutativity of ∧ and ∨

example : p ∧ q ↔ q ∧ p :=
iff.intro
(show p ∧ q → q ∧ p, from
  assume h : p ∧ q, ⟨h.right, h.left⟩)
(show q ∧ p → p ∧ q, from
  assume h : q ∧ p, ⟨h.right, h.left⟩)

example : p ∨ q ↔ q ∨ p :=
iff.intro
(show p ∨ q → q ∨ p, from
  assume h : p ∨ q,
  show q ∨ p, from or.elim h
    (assume hp : p, or.inr hp)
    (assume hq : q, or.inl hq))
(show q ∨ p → p ∨ q, from
  assume h : q ∨ p,
  show p ∨ q, from or.elim h
    (assume hq : q, or.inr hq)
    (assume hp : p, or.inl hp))

-- associativity of ∧ and ∨

example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) :=
iff.intro
(assume h : (p ∧ q) ∧ r,
  have hpq : p ∧ q := h.left,
  have hp : p := hpq.left,
  have hq : q := hpq.right,
  have hr : r := h.right,
  ⟨hp, ⟨hq, hr⟩⟩)
(assume h : p ∧ (q ∧ r),
  have hp : p := h.left,
  have hqr : q ∧ r := h.right,
  have hq : q := hqr.left,
  have hr : r := hqr.right,
  show (p ∧ q) ∧ r, from ⟨ ⟨ hp, hq⟩, hr⟩
)

example : p ∨ (q ∨ r) ↔ (p ∨ q) ∨ r :=
iff.intro
(assume h : p ∨ (q ∨ r),
  show (p ∨ q) ∨ r,
  from or.elim h
    (assume hp : p, or.inl (or.inl hp))
    (assume hqr : q ∨ r,
      show (p ∨ q) ∨ r,
      from or.elim hqr
        (assume hq : q, or.inl (or.inr hq))
        (assume hr : r, or.inr hr)
    )
)
(assume h : (p ∨ q) ∨ r,
  show p ∨ (q ∨ r),
  from or.elim h
    (assume hpq : p ∨ q,
      or.elim hpq
      (assume hp : p, or.inl hp)
      (assume hq : q, or.inr (or.inl hq))
    )
    (assume hr : r, or.inr (or.inr hr))
)

-- distributivity
example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
iff.intro
(assume h : p ∧ (q ∨ r),
  have hp : p := h.left,
  have hqr : q ∨ r := h.right,
  show (p ∧ q) ∨ (p ∧ r),
  from or.elim hqr
    (assume hq : q, or.inl ⟨hp, hq⟩)
    (assume hr : r, or.inr ⟨hp, hr⟩)
)
(assume h : (p ∧ q) ∨ (p ∧ r),
  show p ∧ (q ∨ r),
  from or.elim h
    (assume hpq : p ∧ q, ⟨hpq.left, or.inl hpq.right⟩)
    (assume hpr : p ∧ r, ⟨hpr.left, or.inr hpr.right⟩)
)

example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) :=
iff.intro
(assume h : p ∨ (q ∧ r),
  show (p ∨ q) ∧ (p ∨ r),
  from or.elim h
    (assume hp : p,
      ⟨or.inl hp, or.inl hp⟩
    )
    (assume hqr : q ∧ r,
      have hq : q := hqr.left,
      have hr : r := hqr.right,
      ⟨or.inr hq, or.inr hr⟩
    )
)
(assume h : (p ∨ q) ∧ (p ∨ r),
  have hpq : p ∨ q := h.left,
  have hpr : p ∨ r := h.right,
  show p ∨ (q ∧ r),
  from or.elim hpq
    (assume hp : p, or.inl hp)
    (assume hq : q,
      or.elim hpr
        (assume hp : p, or.inl hp)
        (assume hr : r, or.inr ⟨hq, hr⟩)
    )
)

-- other properties

example : (p → (q → r)) ↔ (p ∧ q → r) :=
iff.intro
(assume h : p → (q → r),
  show p ∧ q → r,
  from assume hpq : p ∧ q,
    have hp : p := hpq.left,
    have hq : q := hpq.right,
    h hp hq
)
(assume h : p ∧ q → r,
  show p → (q → r),
  from assume hp : p,
    assume hq : q,
    h ⟨hp, hq⟩
)

example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) :=
iff.intro
(assume h : (p ∨ q) → r,
  have hpr : p → r := (assume hp : p, h (or.inl hp)),
  have hqr : q → r := (assume hq : q, h (or.inr hq)),
  show (p → r) ∧ (q → r),
  from ⟨hpr, hqr⟩
)
(assume h : (p → r) ∧ (q → r),
  have hpr : p → r := h.left,
  have hqr : q → r := h.right,
  show (p ∨ q) → r,
  from assume hpq : p ∨ q,
    or.elim hpq
    (assume hp : p, hpr hp)
    (assume hq : q, hqr hq)
)

example : ¬(p ∨ q) ↔ ¬p ∧ ¬q :=
iff.intro
(assume h : ¬(p ∨ q),
  show ¬p ∧ ¬q,
  from
    have hnp : ¬p := (assume hp : p, h (or.inl hp)),
    have hnq : ¬q := (assume hq : q, h (or.inr hq)),
    ⟨hnp, hnq⟩
)
(assume h : ¬p ∧ ¬q,
  have hnp : ¬ p := h.left,
  have hnq : ¬ q := h.right,
  show ¬(p ∨ q),
  from assume hpq : p ∨ q,
    or.elim hpq
    (assume hp : p, hnp hp)
    (assume hq : q, hnq hq)
)

example : ¬p ∨ ¬q → ¬(p ∧ q) :=
assume h : ¬p ∨ ¬q,
show ¬(p ∧ q),
from assume hpq : p ∧ q,
  have hp : p := hpq.left,
  have hq : q := hpq.right,
    or.elim h
    (assume hnp : ¬ p, hnp hp)
    (assume hnq : ¬ q, hnq hq)

example : ¬(p ∧ ¬p) :=
assume h : p ∧ ¬p,
have hp : p := h.left,
have hnp : ¬p := h.right,
show false,
from hnp hp

example : p ∧ ¬q → ¬(p → q) :=
assume h : p ∧ ¬q,
have hp : p := h.left,
have hnq : ¬q := h.right,
show ¬(p → q),
from assume hpq : p → q,
hnq (hpq hp)

example : ¬p → (p → q) :=
assume hnp : ¬p,
show p → q,
from assume hp : p,
absurd hp hnp

example : (¬p ∨ q) → (p → q) :=
assume h : ¬p ∨ q,
assume hp : p,
show q,
from or.elim h
(assume hnp : ¬p, absurd hp hnp)
(assume hq : q, hq)

example : p ∨ false ↔ p :=
iff.intro
(assume h : p ∨ false,
  show p,
  from or.elim h
  (assume hp : p, hp)
  (assume hf : false, false.elim hf)
)
(assume hp : p,
  show p ∨ false,
  from or.inl hp
)

example : p ∧ false ↔ false :=
iff.intro
(assume h : p ∧ false, false.elim (h.right))
(assume hf : false, false.elim hf)

example : (p → q) → (¬q → ¬p) :=
assume h : p → q,
show ¬q → ¬p,
from
  assume hnq : ¬q,
  show ¬p,
  from
    assume hp : p,
    hnq (h hp)


import linear_algebra.matrix.spectrum
import missing.analysis.inner_product_space.spectrum

namespace matrix

variables {𝕜 : Type*} [is_R_or_C 𝕜] [decidable_eq 𝕜] {n : Type*} [fintype n] [decidable_eq n]
variables {A : matrix n n 𝕜}

open_locale matrix
open_locale big_operators

lemma is_hermitian.has_eigenvector_eigenvector_basis (hA : A.is_hermitian) (i : n) :
  module.End.has_eigenvector A.to_lin' (hA.eigenvalues i) (hA.eigenvector_basis i) :=
begin
  simp only [is_hermitian.eigenvector_basis, orthonormal_basis.coe_reindex],
  apply linear_map.is_symmetric.has_eigenvector_eigenvector_basis
end

-- TODO: can be used to prove `spectral_theorem`.
/-- *Diagonalization theorem*, *spectral theorem* for matrices; A hermitian matrix can be
diagonalized by a change of basis using a matrix consisting of eigenvectors. -/
theorem spectral_theorem (xs : orthonormal_basis n 𝕜 (euclidean_space 𝕜 n)) (as : n → ℝ)
    (hxs : ∀ j, module.End.has_eigenvector A.to_lin' (as j) (xs j)) :
  xs.to_basis.to_matrix (pi.basis_fun 𝕜 n) ⬝ A =
    diagonal (coe ∘ as) ⬝ xs.to_basis.to_matrix (pi.basis_fun 𝕜 n) :=
begin
  rw [basis_to_matrix_basis_fun_mul],
  ext i j,
  let xs' := xs.reindex (fintype.equiv_of_card_eq (fintype.card_fin _)).symm,
  let as' : fin (fintype.card n) → ℝ := λ i, as $ (fintype.equiv_of_card_eq (fintype.card_fin _)) i,
  have hxs' : ∀ j, module.End.has_eigenvector A.to_lin' (as' j) (xs' j),
    by simp only [hxs, orthonormal_basis.coe_reindex, equiv.symm_symm, implies_true_iff],
  convert @linear_map.spectral_theorem' 𝕜 _ _
    (pi_Lp 2 (λ (_ : n), 𝕜)) _ _ (fintype.card n) A.to_lin'
    (euclidean_space.single j 1)
    ((fintype.equiv_of_card_eq (fintype.card_fin _)).symm i)
    xs' as' hxs',
  { rw [to_lin'_apply],
    simp only [orthonormal_basis.coe_to_basis_repr_apply, of_apply, orthonormal_basis.reindex_repr],
    rw [equiv.symm_apply_apply, euclidean_space.single, pi_Lp.equiv_symm_apply', mul_vec_single],
    simp_rw [mul_one],
    refl },
  { simp only [diagonal_mul, (∘), as'],
    rw [basis.to_matrix_apply,
      orthonormal_basis.coe_to_basis_repr_apply, orthonormal_basis.reindex_repr,
      pi.basis_fun_apply, linear_map.coe_std_basis,
      euclidean_space.single, pi_Lp.equiv_symm_apply', equiv.symm_apply_apply,
      equiv.apply_symm_apply] }
end

-- TODO: use this to derive `is_hermitian.det_eq_prod_eigenvalues`
/-- The determinant of a matrix is the product of its eigenvalues. -/
lemma det_eq_prod_eigenvalues (xs : orthonormal_basis n 𝕜 (euclidean_space 𝕜 n)) (as : n → ℝ)
    (hxs : ∀ j, module.End.has_eigenvector A.to_lin' (as j) (xs j)) :
  det A = ∏ i, as i :=
begin
  apply mul_left_cancel₀ (det_ne_zero_of_left_inverse
    (basis.to_matrix_mul_to_matrix_flip (pi.basis_fun 𝕜 n) xs.to_basis)),
  rw [←det_mul, spectral_theorem xs as hxs, det_mul, mul_comm, det_diagonal]
end

end matrix


import combinatorics.simple_graph.basic
import order.antichain
import set_theory.cardinal.finite
import data.fintype.order

noncomputable theory

open set function

namespace simple_graph

variables {V : Type*} (G : simple_graph V)

/-- A family of vertices is independent if none of them are adjacent. -/
def independent {ι : Type*} (f : ι → V) :=
∀ i j, ¬ G.adj (f i) (f j)

/-- A subset of vertices is independent if none of them are adjacent. -/
def independent_set (s : set V) :=
G.independent (coe : s → V)

lemma independent_set_iff_is_antichain (s : set V) :
  G.independent_set s ↔ is_antichain G.adj s :=
  begin
    unfold independent_set,
    unfold independent,
    unfold is_antichain,
    unfold compl,
    split,
    {
    intro h,
    intros v hvs w hws hvw,
    lift v to s using hvs,
    lift w to s using hws,
    apply h v w
    },
    {
    intro h,
    intros i j,
    cases i with i hi,
    cases j with j hj,
    specialize h hi hj,
    by_cases hij : i = j,
    {subst hij,
    apply G.loopless i},
    {exact h hij},
    }
  end

/-- The _independence number_ of a graph is the cardinality of an independent set containing as many
vertices as possible.

Almost all useful lemmas about this definition will require the assumption that the graph is finite
since it can produce the "junk value" `0` for infinite graphs (via `nat.card`). -/
def independence_number : ℕ :=
Sup $ nat.card ∘ coe_sort '' G.independent_set

instance independent_set_fintype [fintype V] :
  fintype $ subtype G.independent_set :=
fintype.of_injective (coe : subtype G.independent_set → set V) subtype.coe_injective

lemma independent_number_bdd_above [fintype V] :
  bdd_above $ nat.card ∘ coe_sort '' G.independent_set :=
begin
  obtain ⟨M, hM⟩ := fintype.exists_le (nat.card ∘ coe_sort : subtype G.independent_set → ℕ),
  refine ⟨M, _⟩, rintros _ ⟨S, ⟨hx, rfl⟩⟩,
  refine (hM ⟨S, hx⟩).trans _, refl,
end

lemma nat.find_eq_find_of_iff {p q : ℕ → Prop}
  [decidable_pred (λ (n : ℕ), q n)] [decidable_pred (λ (n : ℕ), p n)]
  (P : ∃ n, p n) (Q : ∃ n, q n) (h : ∀ n, p n ↔ q n) :
  nat.find P = nat.find Q :=
begin
  have eq1 : p = q,
  { ext, apply h },
  unfreezingI { subst eq1 }, resetI,
  have eq1 : P = Q := rfl,
  rw eq1, congr,
end

lemma nat.supr_pos {p : Prop} (h : p) (f : p → ℕ) :
  (⨆ (i : p), f i) = f h :=
begin
  rw [supr, nat.Sup_def], swap,
  { refine ⟨f h, _⟩, rintros _ ⟨h', rfl⟩, exact le_refl _, },
  rw nat.find_eq_iff, split,
  { rintros _ ⟨h', rfl⟩, exact le_refl _ },
  { rintros m hm r,
    specialize r (f h) ⟨_, rfl⟩, linarith }
end

lemma independence_number_eq_bcsupr [fintype V] :
  G.independence_number = ⨆ s (hs : G.independent_set s), nat.card s :=
begin
  classical,
  obtain ⟨M, hM⟩ := G.independent_number_bdd_above,
  rw [independence_number, supr, nat.Sup_def, nat.Sup_def],
  work_on_goal 2
  { refine ⟨M, _⟩, rintros n ⟨S, rfl⟩,
    dsimp only, rw [supr, nat.Sup_def], swap,
    { refine ⟨M, _⟩, rintros n ⟨hS, rfl⟩, dsimp only,
      apply hM, rw [set.mem_image], exact ⟨_, hS, rfl⟩, } },
  work_on_goal 3
  { refine ⟨M, _⟩, rintros n ⟨S, hS, rfl⟩, apply hM,
    rw set.mem_image, exact ⟨_, hS, rfl⟩, },
  work_on_goal 2
  { generalize_proofs h,
    refine nat.find_le _, rintros _ ⟨hS, rfl⟩, dsimp only,
    apply hM, refine ⟨_, hS, rfl⟩, },
  { generalize_proofs h₁ h₂,
    refine nat.find_eq_find_of_iff _ _ (λ n, _), split,
    { rintros h _ ⟨S, rfl⟩, dsimp only,
      rw [supr, nat.Sup_def], swap,
      { refine ⟨M, _⟩, rintros _ ⟨hS, rfl⟩, dsimp only, apply hM,
        exact ⟨_, hS, rfl⟩, },
      rw nat.find_le_iff, refine ⟨n, le_refl _, _⟩,
      rintro m ⟨hS, rfl⟩, apply h, exact ⟨_, hS, rfl⟩, },
    { rintros h _ ⟨S, hS, rfl⟩, apply h, refine ⟨S, _⟩,
      dsimp only, rw [nat.supr_pos], exact hS },
  },
end

lemma exists_maximal_independent_set [fintype V] : ∃ (s : set V) (hs : G.independent_set s),
  nat.card s = G.independence_number :=
begin
  rw independence_number,
  have ne : (nat.card ∘ coe_sort '' G.independent_set).nonempty,
  { refine ⟨_, ⟨∅, λ x, false.elim (not_mem_empty x.1 x.2), rfl⟩⟩, },
  haveI : nonempty (nat.card ∘ coe_sort '' G.independent_set) :=
    ⟨⟨ne.some, ne.some_spec⟩⟩,
  have : G.independence_number ∈ _:= nat.Sup_mem _ _,
  rw [set.mem_image] at this,
  obtain ⟨s, hs1, hs2⟩ := this,
  refine ⟨s, hs1, _⟩,
  simp only [comp_app] at hs2, rw hs2, refl, assumption,
  haveI : fintype (nat.card ∘ coe_sort '' G.independent_set),
  { apply_instance, },
  obtain ⟨M, hM⟩ := @fintype.exists_le (nat.card ∘ coe_sort '' G.independent_set)
    _ _ _ (nat.card ∘ coe_sort '' G.independent_set) _ id,
  refine ⟨M, _⟩,
  rintros _ ⟨s, hs, rfl⟩,
  specialize hM ⟨nat.card s, ⟨s, hs, rfl⟩⟩,
  convert hM,
end

def maximal_independent_set [fintype V] : set V := G.exists_maximal_independent_set.some

lemma maximal_independent_set_is_independent [fintype V] :
  G.independent_set G.maximal_independent_set :=
G.exists_maximal_independent_set.some_spec.some

lemma card_maximal_independent_set [fintype V] :
  nat.card G.maximal_independent_set = G.independence_number :=
G.exists_maximal_independent_set.some_spec.some_spec

instance [fintype V] : fintype G.maximal_independent_set :=
fintype.of_finite (maximal_independent_set G)

end simple_graph


import MyNat.Definition
import MyNat.Inequality -- le_iff_exists_add
import Mathlib.Tactic.Use -- use tactic
import AdditionWorld.Level1 -- zero_add
namespace MyNat
open MyNat
/-!

# Inequality world.

## Level 4: `zero_le`

Another easy one.

## Lemma : zero_le
For all naturals `a`, `0 ≤ a`.
-/
lemma zero_le (a : MyNat) : 0 ≤ a := by
  use a
  rw [zero_add]

/-!
Next up [Level 5](./Level5.lean.md)
-/


/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan, David Loeffler
-/
import data.polynomial.algebra_map
import data.polynomial.derivative
import data.nat.choose.cast
import number_theory.bernoulli

/-!
# Bernoulli polynomials

The Bernoulli polynomials (defined here : https://en.wikipedia.org/wiki/Bernoulli_polynomials)
are an important tool obtained from Bernoulli numbers.

## Mathematical overview

The $n$-th Bernoulli polynomial is defined as
$$ B_n(X) = ∑_{k = 0}^n {n \choose k} (-1)^k * B_k * X^{n - k} $$
where $B_k$ is the $k$-th Bernoulli number. The Bernoulli polynomials are generating functions,
$$ t * e^{tX} / (e^t - 1) = ∑_{n = 0}^{\infty} B_n(X) * \frac{t^n}{n!} $$

## Implementation detail

Bernoulli polynomials are defined using `bernoulli`, the Bernoulli numbers.

## Main theorems

- `sum_bernoulli`: The sum of the $k^\mathrm{th}$ Bernoulli polynomial with binomial
  coefficients up to n is `(n + 1) * X^n`.
- `bernoulli_generating_function`: The Bernoulli polynomials act as generating functions
  for the exponential.

## TODO

- `bernoulli_eval_one_neg` : $$ B_n(1 - x) = (-1)^n B_n(x) $$

-/

noncomputable theory
open_locale big_operators
open_locale nat polynomial

open nat finset

namespace polynomial

/-- The Bernoulli polynomials are defined in terms of the negative Bernoulli numbers. -/
def bernoulli (n : ℕ) : ℚ[X] :=
  ∑ i in range (n + 1), polynomial.monomial (n - i) ((_root_.bernoulli i) * (choose n i))

lemma bernoulli_def (n : ℕ) : bernoulli n =
  ∑ i in range (n + 1), polynomial.monomial i ((_root_.bernoulli (n - i)) * (choose n i)) :=
begin
  rw [←sum_range_reflect, add_succ_sub_one, add_zero, bernoulli],
  apply sum_congr rfl,
  rintros x hx,
  rw mem_range_succ_iff at hx, rw [choose_symm hx, tsub_tsub_cancel_of_le hx],
end

/-
### examples
-/

section examples

@[simp] lemma bernoulli_zero : bernoulli 0 = 1 :=
by simp [bernoulli]

@[simp] lemma bernoulli_eval_zero (n : ℕ) : (bernoulli n).eval 0 = _root_.bernoulli n :=
begin
 rw [bernoulli, eval_finset_sum, sum_range_succ],
  have : ∑ (x : ℕ) in range n, _root_.bernoulli x * (n.choose x) * 0 ^ (n - x) = 0,
  { apply sum_eq_zero (λ x hx, _),
    have h : 0 < n - x := tsub_pos_of_lt (mem_range.1 hx),
    simp [h] },
  simp [this],
end

@[simp] lemma bernoulli_eval_one (n : ℕ) : (bernoulli n).eval 1 = _root_.bernoulli' n :=
begin
  simp only [bernoulli, eval_finset_sum],
  simp only [←succ_eq_add_one, sum_range_succ, mul_one, cast_one, choose_self,
    (_root_.bernoulli _).mul_comm, sum_bernoulli, one_pow, mul_one, eval_C, eval_monomial],
  by_cases h : n = 1,
  { norm_num [h], },
  { simp [h],
    exact bernoulli_eq_bernoulli'_of_ne_one h, }
end

end examples

lemma derivative_bernoulli_add_one (k : ℕ) :
  (bernoulli (k + 1)).derivative = (k + 1) * bernoulli k :=
begin
  simp_rw [bernoulli, derivative_sum, derivative_monomial, nat.sub_sub, nat.add_sub_add_right],
  -- LHS sum has an extra term, but the coefficient is zero:
  rw [range_add_one, sum_insert not_mem_range_self, tsub_self, cast_zero, mul_zero, map_zero,
    zero_add, mul_sum],
  -- the rest of the sum is termwise equal:
  refine sum_congr (by refl) (λ m hm, _),
  conv_rhs { rw [←nat.cast_one, ←nat.cast_add, ←C_eq_nat_cast, C_mul_monomial, mul_comm], },
  rw [mul_assoc, mul_assoc, ←nat.cast_mul, ←nat.cast_mul],
  congr' 3,
  rw [(choose_mul_succ_eq k m).symm, mul_comm],
end

lemma derivative_bernoulli (k : ℕ) : (bernoulli k).derivative = k * bernoulli (k - 1) :=
begin
  cases k,
  { rw [nat.cast_zero, zero_mul, bernoulli_zero, derivative_one], },
  { exact_mod_cast derivative_bernoulli_add_one k, }
end

@[simp] theorem sum_bernoulli (n : ℕ) :
  ∑ k in range (n + 1), ((n + 1).choose k : ℚ) • bernoulli k = monomial n (n + 1 : ℚ) :=
begin
 simp_rw [bernoulli_def, finset.smul_sum, finset.range_eq_Ico, ←finset.sum_Ico_Ico_comm,
    finset.sum_Ico_eq_sum_range],
  simp only [cast_succ, add_tsub_cancel_left, tsub_zero, zero_add, linear_map.map_add],
  simp_rw [smul_monomial, mul_comm (_root_.bernoulli _) _, smul_eq_mul, ←mul_assoc],
  conv_lhs { apply_congr, skip, conv
    { apply_congr, skip,
      rw [← nat.cast_mul, choose_mul ((le_tsub_iff_left $ mem_range_le H).1
        $ mem_range_le H_1) (le.intro rfl), nat.cast_mul, add_comm x x_1, add_tsub_cancel_right,
        mul_assoc, mul_comm, ←smul_eq_mul, ←smul_monomial] },
    rw [←sum_smul], },
  rw [sum_range_succ_comm],
  simp only [add_right_eq_self, cast_succ, mul_one, cast_one, cast_add, add_tsub_cancel_left,
    choose_succ_self_right, one_smul, _root_.bernoulli_zero, sum_singleton, zero_add,
    linear_map.map_add, range_one],
  apply sum_eq_zero (λ x hx, _),
  have f : ∀ x ∈ range n, ¬ n + 1 - x = 1,
  { rintros x H, rw [mem_range] at H,
    rw [eq_comm],
    exact ne_of_lt (nat.lt_of_lt_of_le one_lt_two (le_tsub_of_add_le_left (succ_le_succ H))) },
  rw [sum_bernoulli],
  have g : (ite (n + 1 - x = 1) (1 : ℚ) 0) = 0,
  { simp only [ite_eq_right_iff, one_ne_zero],
    intro h₁,
    exact (f x hx) h₁, },
  rw [g, zero_smul],
end

/-- Another version of `polynomial.sum_bernoulli`. -/
lemma bernoulli_eq_sub_sum (n : ℕ) : (n.succ : ℚ) • bernoulli n = monomial n (n.succ : ℚ) -
  ∑ k in finset.range n, ((n + 1).choose k : ℚ) • bernoulli k :=
by rw [nat.cast_succ, ← sum_bernoulli n, sum_range_succ, add_sub_cancel',
  choose_succ_self_right, nat.cast_succ]

/-- Another version of `bernoulli.sum_range_pow`. -/
lemma sum_range_pow_eq_bernoulli_sub (n p : ℕ) :
  (p + 1 : ℚ) * ∑ k in range n, (k : ℚ) ^ p = (bernoulli p.succ).eval n -
  (_root_.bernoulli p.succ) :=
begin
  rw [sum_range_pow, bernoulli_def, eval_finset_sum, ←sum_div, mul_div_cancel' _ _],
  { simp_rw [eval_monomial],
    symmetry,
    rw [←sum_flip _, sum_range_succ],
    simp only [tsub_self, tsub_zero, choose_zero_right, cast_one, mul_one, pow_zero,
      add_tsub_cancel_right],
    apply sum_congr rfl (λ x hx, _),
    apply congr_arg2 _ (congr_arg2 _ _ _) rfl,
    { rw nat.sub_sub_self (mem_range_le hx), },
    { rw ←choose_symm (mem_range_le hx), }, },
  { norm_cast, apply succ_ne_zero _, },
end

/-- Rearrangement of `polynomial.sum_range_pow_eq_bernoulli_sub`. -/
lemma bernoulli_succ_eval (n p : ℕ) : (bernoulli p.succ).eval n =
  _root_.bernoulli (p.succ) + (p + 1 : ℚ) * ∑ k in range n, (k : ℚ) ^ p :=
by { apply eq_add_of_sub_eq', rw sum_range_pow_eq_bernoulli_sub, }

lemma bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (bernoulli n).eval (1 + x) = (bernoulli n).eval x + n * x^(n - 1) :=
begin
  apply nat.strong_induction_on n (λ d hd, _),
  have nz : ((d.succ : ℕ): ℚ) ≠ 0,
  { norm_cast, exact d.succ_ne_zero, },
  apply (mul_right_inj' nz).1,
  rw [← smul_eq_mul, ←eval_smul, bernoulli_eq_sub_sum, mul_add, ←smul_eq_mul,
    ←eval_smul, bernoulli_eq_sub_sum, eval_sub, eval_finset_sum],
  conv_lhs { congr, skip, apply_congr, skip, rw [eval_smul, hd x_1 (mem_range.1 H)], },
  rw [eval_sub, eval_finset_sum],
  simp_rw [eval_smul, smul_add],
  rw [sum_add_distrib, sub_add, sub_eq_sub_iff_sub_eq_sub, _root_.add_sub_sub_cancel],
  conv_rhs { congr, skip, congr, rw [succ_eq_add_one, ←choose_succ_self_right d], },
  rw [nat.cast_succ, ← smul_eq_mul, ←sum_range_succ _ d, eval_monomial_one_add_sub],
  simp_rw [smul_eq_mul],
end

open power_series
variables {A : Type*} [comm_ring A] [algebra ℚ A]

-- TODO: define exponential generating functions, and use them here
-- This name should probably be updated afterwards

/-- The theorem that `∑ Bₙ(t)X^n/n!)(e^X-1)=Xe^{tX}`  -/
theorem bernoulli_generating_function (t : A) :
  mk (λ n, aeval t ((1 / n! : ℚ) • bernoulli n)) * (exp A - 1) =
    power_series.X * rescale t (exp A) :=
begin
  -- check equality of power series by checking coefficients of X^n
  ext n,
  -- n = 0 case solved by `simp`
  cases n, { simp },
  -- n ≥ 1, the coefficients is a sum to n+2, so use `sum_range_succ` to write as
  -- last term plus sum to n+1
  rw [coeff_succ_X_mul, coeff_rescale, coeff_exp, power_series.coeff_mul,
    nat.sum_antidiagonal_eq_sum_range_succ_mk, sum_range_succ],
  -- last term is zero so kill with `add_zero`
  simp only [ring_hom.map_sub, tsub_self, constant_coeff_one, constant_coeff_exp,
    coeff_zero_eq_constant_coeff, mul_zero, sub_self, add_zero],
  -- Let's multiply both sides by (n+1)! (OK because it's a unit)
  set u : units ℚ := ⟨(n+1)!, (n+1)!⁻¹,
    mul_inv_cancel (by exact_mod_cast factorial_ne_zero (n+1)),
      inv_mul_cancel (by exact_mod_cast factorial_ne_zero (n+1))⟩ with hu,
  rw ←units.mul_right_inj (units.map (algebra_map ℚ A).to_monoid_hom u),
  -- now tidy up unit mess and generally do trivial rearrangements
  -- to make RHS (n+1)*t^n
  rw [units.coe_map, mul_left_comm, ring_hom.to_monoid_hom_eq_coe,
      ring_hom.coe_monoid_hom, ←ring_hom.map_mul, hu, units.coe_mk],
  change _ = t^n * algebra_map ℚ A (((n+1)*n! : ℕ)*(1/n!)),
  rw [cast_mul, mul_assoc, mul_one_div_cancel
    (show (n! : ℚ) ≠ 0, from cast_ne_zero.2 (factorial_ne_zero n)), mul_one, mul_comm (t^n),
    ← aeval_monomial, cast_add, cast_one],
  -- But this is the RHS of `sum_bernoulli_poly`
  rw [← sum_bernoulli, finset.mul_sum, alg_hom.map_sum],
  -- and now we have to prove a sum is a sum, but all the terms are equal.
  apply finset.sum_congr rfl,
  -- The rest is just trivialities, hampered by the fact that we're coercing
  -- factorials and binomial coefficients between ℕ and ℚ and A.
  intros i hi,
  -- deal with coefficients of e^X-1
  simp only [nat.cast_choose ℚ (mem_range_le hi), coeff_mk,
    if_neg (mem_range_sub_ne_zero hi), one_div, alg_hom.map_smul, power_series.coeff_one,
    units.coe_mk, coeff_exp, sub_zero, linear_map.map_sub, algebra.smul_mul_assoc, algebra.smul_def,
    mul_right_comm _ ((aeval t) _), ←mul_assoc, ← ring_hom.map_mul, succ_eq_add_one],
  -- finally cancel the Bernoulli polynomial and the algebra_map
  congr',
  apply congr_arg,
  rw [mul_assoc, div_eq_mul_inv, ← mul_inv],
end

end polynomial