/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import data.fintype.card
import data.finset.sort
import algebra.big_operators.order

/-!
# Compositions

A composition of a natural number `n` is a decomposition `n = i₀ + ... + i_{k-1}` of `n` into a sum
of positive integers. Combinatorially, it corresponds to a decomposition of `{0, ..., n-1}` into
non-empty blocks of consecutive integers, where the `iⱼ` are the lengths of the blocks.
This notion is closely related to that of a partition of `n`, but in a composition of `n` the
order of the `iⱼ`s matters.

We implement two different structures covering these two viewpoints on compositions. The first
one, made of a list of positive integers summing to `n`, is the main one and is called
`composition n`. The second one is useful for combinatorial arguments (for instance to show that
the number of compositions of `n` is `2^(n-1)`). It is given by a subset of `{0, ..., n}`
containing `0` and `n`, where the elements of the subset (other than `n`) correspond to the leftmost
points of each block. The main API is built on `composition n`, and we provide an equivalence
between the two types.

## Main functions

* `c : composition n` is a structure, made of a list of integers which are all positive and
  add up to `n`.
* `composition_card` states that the cardinality of `composition n` is exactly
  `2^(n-1)`, which is proved by constructing an equiv with `composition_as_set n` (see below), which
  is itself in bijection with the subsets of `fin (n-1)` (this holds even for `n = 0`, where `-` is
  nat subtraction).

Let `c : composition n` be a composition of `n`. Then
* `c.blocks` is the list of blocks in `c`.
* `c.length` is the number of blocks in the composition.
* `c.blocks_fun : fin c.length → ℕ` is the realization of `c.blocks` as a function on
  `fin c.length`. This is the main object when using compositions to understand the composition of
    analytic functions.
* `c.size_up_to : ℕ → ℕ` is the sum of the size of the blocks up to `i`.;
* `c.embedding i : fin (c.blocks_fun i) → fin n` is the increasing embedding of the `i`-th block in
  `fin n`;
* `c.index j`, for `j : fin n`, is the index of the block containing `j`.

* `composition.ones n` is the composition of `n` made of ones, i.e., `[1, ..., 1]`.
* `composition.single n (hn : 0 < n)` is the composition of `n` made of a single block of size `n`.

Compositions can also be used to split lists. Let `l` be a list of length `n` and `c` a composition
of `n`.
* `l.split_wrt_composition c` is a list of lists, made of the slices of `l` corresponding to the
  blocks of `c`.
* `join_split_wrt_composition` states that splitting a list and then joining it gives back the
  original list.
* `split_wrt_composition_join` states that joining a list of lists, and then splitting it back
  according to the right composition, gives back the original list of lists.

We turn to the second viewpoint on compositions, that we realize as a finset of `fin (n+1)`.
`c : composition_as_set n` is a structure made of a finset of `fin (n+1)` called `c.boundaries`
and proofs that it contains `0` and `n`. (Taking a finset of `fin n` containing `0` would not
make sense in the edge case `n = 0`, while the previous description works in all cases).
The elements of this set (other than `n`) correspond to leftmost points of blocks.
Thus, there is an equiv between `composition n` and `composition_as_set n`. We
only construct basic API on `composition_as_set` (notably `c.length` and `c.blocks`) to be able
to construct this equiv, called `composition_equiv n`. Since there is a straightforward equiv
between `composition_as_set n` and finsets of `{1, ..., n-1}` (obtained by removing `0` and `n`
from a `composition_as_set` and called `composition_as_set_equiv n`), we deduce that
`composition_as_set n` and `composition n` are both fintypes of cardinality `2^(n - 1)`
(see `composition_as_set_card` and `composition_card`).

## Implementation details

The main motivation for this structure and its API is in the construction of the composition of
formal multilinear series, and the proof that the composition of analytic functions is analytic.

The representation of a composition as a list is very handy as lists are very flexible and already
have a well-developed API.

## Tags

Composition, partition

## References

<https://en.wikipedia.org/wiki/Composition_(combinatorics)>
-/

open list
open_locale big_operators

variable {n : ℕ}

/-- A composition of `n` is a list of positive integers summing to `n`. -/
@[ext] structure composition (n : ℕ) :=
(blocks : list ℕ)
(blocks_pos : ∀ {i}, i ∈ blocks → 0 < i)
(blocks_sum : blocks.sum = n)

/-- Combinatorial viewpoint on a composition of `n`, by seeing it as non-empty blocks of
consecutive integers in `{0, ..., n-1}`. We register every block by its left end-point, yielding
a finset containing `0`. As this does not make sense for `n = 0`, we add `n` to this finset, and
get a finset of `{0, ..., n}` containing `0` and `n`. This is the data in the structure
`composition_as_set n`. -/
@[ext] structure composition_as_set (n : ℕ) :=
(boundaries : finset (fin n.succ))
(zero_mem   : (0 : fin n.succ) ∈ boundaries)
(last_mem   : fin.last n ∈ boundaries)

instance {n : ℕ} : inhabited (composition_as_set n) :=
⟨⟨finset.univ, finset.mem_univ _, finset.mem_univ _⟩⟩

/-!
### Compositions

A composition of an integer `n` is a decomposition `n = i₀ + ... + i_{k-1}` of `n` into a sum of
positive integers.
-/

namespace composition

variables (c : composition n)

instance (n : ℕ) : has_to_string (composition n) :=
⟨λ c, to_string c.blocks⟩

/-- The length of a composition, i.e., the number of blocks in the composition. -/
@[reducible] def length : ℕ := c.blocks.length

lemma blocks_length : c.blocks.length = c.length := rfl

/-- The blocks of a composition, seen as a function on `fin c.length`. When composing analytic
functions using compositions, this is the main player. -/
def blocks_fun : fin c.length → ℕ := λ i, nth_le c.blocks i i.2

lemma of_fn_blocks_fun : of_fn c.blocks_fun = c.blocks :=
of_fn_nth_le _

lemma sum_blocks_fun : ∑ i, c.blocks_fun i = n :=
by conv_rhs { rw [← c.blocks_sum, ← of_fn_blocks_fun, sum_of_fn] }

lemma blocks_fun_mem_blocks (i : fin c.length) : c.blocks_fun i ∈ c.blocks :=
nth_le_mem _ _ _

@[simp] lemma one_le_blocks {i : ℕ} (h : i ∈ c.blocks) : 1 ≤ i :=
c.blocks_pos h

@[simp] lemma one_le_blocks' {i : ℕ} (h : i < c.length) : 1 ≤ nth_le c.blocks i h:=
c.one_le_blocks (nth_le_mem (blocks c) i h)

@[simp] lemma blocks_pos' (i : ℕ) (h : i < c.length) : 0 < nth_le c.blocks i h:=
c.one_le_blocks' h

lemma one_le_blocks_fun (i : fin c.length) : 1 ≤ c.blocks_fun i :=
c.one_le_blocks (c.blocks_fun_mem_blocks i)

lemma length_le : c.length ≤ n :=
begin
  conv_rhs { rw ← c.blocks_sum },
  exact length_le_sum_of_one_le _ (λ i hi, c.one_le_blocks hi)
end

lemma length_pos_of_pos (h : 0 < n) : 0 < c.length :=
begin
  apply length_pos_of_sum_pos,
  convert h,
  exact c.blocks_sum
end

/-- The sum of the sizes of the blocks in a composition up to `i`. -/
def size_up_to (i : ℕ) : ℕ := (c.blocks.take i).sum

@[simp] lemma size_up_to_zero : c.size_up_to 0 = 0 := by simp [size_up_to]

lemma size_up_to_of_length_le (i : ℕ) (h : c.length ≤ i) : c.size_up_to i = n :=
begin
  dsimp [size_up_to],
  convert c.blocks_sum,
  exact take_all_of_le h
end

@[simp] lemma size_up_to_length : c.size_up_to c.length = n :=
c.size_up_to_of_length_le c.length (le_refl _)

lemma size_up_to_le (i : ℕ) : c.size_up_to i ≤ n :=
begin
  conv_rhs { rw [← c.blocks_sum, ← sum_take_add_sum_drop _ i] },
  exact nat.le_add_right _ _
end

lemma size_up_to_succ {i : ℕ} (h : i < c.length) :
  c.size_up_to (i+1) = c.size_up_to i + c.blocks.nth_le i h :=
by { simp only [size_up_to], rw sum_take_succ _ _ h }

lemma size_up_to_succ' (i : fin c.length) :
  c.size_up_to ((i : ℕ) + 1) = c.size_up_to i + c.blocks_fun i :=
c.size_up_to_succ i.2

lemma size_up_to_strict_mono {i : ℕ} (h : i < c.length) : c.size_up_to i < c.size_up_to (i+1) :=
by { rw c.size_up_to_succ h, simp }

lemma monotone_size_up_to : monotone c.size_up_to :=
monotone_sum_take _

/-- The `i`-th boundary of a composition, i.e., the leftmost point of the `i`-th block. We include
a virtual point at the right of the last block, to make for a nice equiv with
`composition_as_set n`. -/
def boundary : fin (c.length + 1) ↪o fin (n+1) :=
order_embedding.of_strict_mono (λ i, ⟨c.size_up_to i, nat.lt_succ_of_le (c.size_up_to_le i)⟩) $
 fin.strict_mono_iff_lt_succ.2 $ λ i hi, c.size_up_to_strict_mono $
   lt_of_add_lt_add_right hi

@[simp] lemma boundary_zero : c.boundary 0 = 0 :=
by simp [boundary, fin.ext_iff]

@[simp] lemma boundary_last : c.boundary (fin.last c.length) = fin.last n :=
by simp [boundary, fin.ext_iff]

/-- The boundaries of a composition, i.e., the leftmost point of all the blocks. We include
a virtual point at the right of the last block, to make for a nice equiv with
`composition_as_set n`. -/
def boundaries : finset (fin (n+1)) :=
finset.univ.map c.boundary.to_embedding

lemma card_boundaries_eq_succ_length : c.boundaries.card = c.length + 1 :=
by simp [boundaries]

/-- To `c : composition n`, one can associate a `composition_as_set n` by registering the leftmost
point of each block, and adding a virtual point at the right of the last block. -/
def to_composition_as_set : composition_as_set n :=
{ boundaries := c.boundaries,
  zero_mem := begin
    simp only [boundaries, finset.mem_univ, exists_prop_of_true, finset.mem_map],
    exact ⟨0, rfl⟩,
  end,
  last_mem := begin
    simp only [boundaries, finset.mem_univ, exists_prop_of_true, finset.mem_map],
    exact ⟨fin.last c.length, c.boundary_last⟩,
  end }

/-- The canonical increasing bijection between `fin (c.length + 1)` and `c.boundaries` is
exactly `c.boundary`. -/
lemma order_emb_of_fin_boundaries :
  c.boundaries.order_emb_of_fin c.card_boundaries_eq_succ_length = c.boundary :=
begin
  refine (finset.order_emb_of_fin_unique' _ _).symm,
  exact λ i, (finset.mem_map' _).2 (finset.mem_univ _)
end

/-- Embedding the `i`-th block of a composition (identified with `fin (c.blocks_fun i)`) into
`fin n` at the relevant position. -/
def embedding (i : fin c.length) : fin (c.blocks_fun i) ↪o fin n :=
(fin.nat_add $ c.size_up_to i).trans $ fin.cast_le $
calc c.size_up_to i + c.blocks_fun i = c.size_up_to (i + 1) : (c.size_up_to_succ _).symm
... ≤ c.size_up_to c.length : monotone_sum_take _ i.2
... = n : c.size_up_to_length

@[simp] lemma coe_embedding (i : fin c.length) (j : fin (c.blocks_fun i)) :
  (c.embedding i j : ℕ) = c.size_up_to i + j := rfl

/--
`index_exists` asserts there is some `i` with `j < c.size_up_to (i+1)`.
In the next definition `index` we use `nat.find` to produce the minimal such index.
-/
lemma index_exists {j : ℕ} (h : j < n) :
  ∃ i : ℕ, j < c.size_up_to i.succ ∧ i < c.length :=
begin
  have n_pos : 0 < n := lt_of_le_of_lt (zero_le j) h,
  have : 0 < c.blocks.sum, by rwa [← c.blocks_sum] at n_pos,
  have length_pos : 0 < c.blocks.length := length_pos_of_sum_pos (blocks c) this,
  refine ⟨c.length.pred, _, nat.pred_lt (ne_of_gt length_pos)⟩,
  have : c.length.pred.succ = c.length := nat.succ_pred_eq_of_pos length_pos,
  simp [this, h]
end

/-- `c.index j` is the index of the block in the composition `c` containing `j`. -/
def index (j : fin n) : fin c.length :=
⟨nat.find (c.index_exists j.2), (nat.find_spec (c.index_exists j.2)).2⟩

lemma lt_size_up_to_index_succ (j : fin n) : (j : ℕ) < c.size_up_to (c.index j).succ :=
(nat.find_spec (c.index_exists j.2)).1

lemma size_up_to_index_le (j : fin n) : c.size_up_to (c.index j) ≤ j :=
begin
  by_contradiction H,
  set i := c.index j with hi,
  push_neg at H,
  have i_pos : (0 : ℕ) < i,
  { by_contradiction i_pos,
    push_neg at i_pos,
    revert H, simp [nonpos_iff_eq_zero.1 i_pos, c.size_up_to_zero] },
  let i₁ := (i : ℕ).pred,
  have i₁_lt_i : i₁ < i := nat.pred_lt (ne_of_gt i_pos),
  have i₁_succ : i₁.succ = i := nat.succ_pred_eq_of_pos i_pos,
  have := nat.find_min (c.index_exists j.2) i₁_lt_i,
  simp [lt_trans i₁_lt_i (c.index j).2, i₁_succ] at this,
  exact nat.lt_le_antisymm H this
end

/-- Mapping an element `j` of `fin n` to the element in the block containing it, identified with
`fin (c.blocks_fun (c.index j))` through the canonical increasing bijection. -/
def inv_embedding (j : fin n) : fin (c.blocks_fun (c.index j)) :=
⟨j - c.size_up_to (c.index j),
begin
  rw [nat.sub_lt_right_iff_lt_add, add_comm, ← size_up_to_succ'],
  { exact lt_size_up_to_index_succ _ _ },
  { exact size_up_to_index_le _ _ }
end⟩

@[simp] lemma coe_inv_embedding (j : fin n) :
  (c.inv_embedding j : ℕ) = j - c.size_up_to (c.index j) := rfl

lemma embedding_comp_inv (j : fin n) :
  c.embedding (c.index j) (c.inv_embedding j) = j :=
begin
  rw fin.ext_iff,
  apply nat.add_sub_cancel' (c.size_up_to_index_le j),
end

lemma mem_range_embedding_iff {j : fin n} {i : fin c.length} :
  j ∈ set.range (c.embedding i) ↔
  c.size_up_to i ≤ j ∧ (j : ℕ) < c.size_up_to (i : ℕ).succ :=
begin
  split,
  { assume h,
    rcases set.mem_range.2 h with ⟨k, hk⟩,
    rw fin.ext_iff at hk,
    change c.size_up_to i + k = (j : ℕ) at hk,
    rw ← hk,
    simp [size_up_to_succ', k.is_lt] },
  { assume h,
    apply set.mem_range.2,
    refine ⟨⟨j - c.size_up_to i, _⟩, _⟩,
    { rw [nat.sub_lt_left_iff_lt_add, ← size_up_to_succ'],
      { exact h.2 },
      { exact h.1 } },
    { rw fin.ext_iff,
      exact nat.add_sub_cancel' h.1 } }
end

/-- The embeddings of different blocks of a composition are disjoint. -/
lemma disjoint_range {i₁ i₂ : fin c.length} (h : i₁ ≠ i₂) :
  disjoint (set.range (c.embedding i₁)) (set.range (c.embedding i₂)) :=
begin
  classical,
  wlog h' : i₁ ≤ i₂ using i₁ i₂,
  by_contradiction d,
  obtain ⟨x, hx₁, hx₂⟩ :
    ∃ x : fin n, (x ∈ set.range (c.embedding i₁) ∧ x ∈ set.range (c.embedding i₂)) :=
  set.not_disjoint_iff.1 d,
  have : i₁ < i₂ := lt_of_le_of_ne h' h,
  have A : (i₁ : ℕ).succ ≤ i₂ := nat.succ_le_of_lt this,
  apply lt_irrefl (x : ℕ),
  calc (x : ℕ) < c.size_up_to (i₁ : ℕ).succ : (c.mem_range_embedding_iff.1 hx₁).2
  ... ≤ c.size_up_to (i₂ : ℕ) : monotone_sum_take _ A
  ... ≤ x : (c.mem_range_embedding_iff.1 hx₂).1
end

lemma mem_range_embedding (j : fin n) :
  j ∈ set.range (c.embedding (c.index j)) :=
begin
  have : c.embedding (c.index j) (c.inv_embedding j)
    ∈ set.range (c.embedding (c.index j)) := set.mem_range_self _,
  rwa c.embedding_comp_inv j at this
end

lemma mem_range_embedding_iff' {j : fin n} {i : fin c.length} :
  j ∈ set.range (c.embedding i) ↔ i = c.index j :=
begin
  split,
  { rw ← not_imp_not,
    assume h,
    exact set.disjoint_right.1 (c.disjoint_range h) (c.mem_range_embedding j) },
  { assume h,
    rw h,
    exact c.mem_range_embedding j }
end

lemma index_embedding (i : fin c.length) (j : fin (c.blocks_fun i)) :
  c.index (c.embedding i j) = i :=
begin
  symmetry,
  rw ← mem_range_embedding_iff',
  apply set.mem_range_self
end

lemma inv_embedding_comp (i : fin c.length) (j : fin (c.blocks_fun i)) :
  (c.inv_embedding (c.embedding i j) : ℕ) = j :=
by simp_rw [coe_inv_embedding, index_embedding, coe_embedding, nat.add_sub_cancel_left]

/-- Equivalence between the disjoint union of the blocks (each of them seen as
`fin (c.blocks_fun i)`) with `fin n`. -/
def blocks_fin_equiv : (Σ i : fin c.length, fin (c.blocks_fun i)) ≃ fin n :=
{ to_fun := λ x, c.embedding x.1 x.2,
  inv_fun := λ j, ⟨c.index j, c.inv_embedding j⟩,
  left_inv := λ x, begin
    rcases x with ⟨i, y⟩,
    dsimp,
    congr, { exact c.index_embedding _ _ },
    rw fin.heq_ext_iff,
    { exact c.inv_embedding_comp _ _ },
    { rw c.index_embedding }
  end,
  right_inv := λ j, c.embedding_comp_inv j }

lemma blocks_fun_congr {n₁ n₂ : ℕ} (c₁ : composition n₁) (c₂ : composition n₂)
  (i₁ : fin c₁.length) (i₂ : fin c₂.length) (hn : n₁ = n₂)
  (hc : c₁.blocks = c₂.blocks) (hi : (i₁ : ℕ) = i₂) :
  c₁.blocks_fun i₁ = c₂.blocks_fun i₂ :=
by { cases hn, rw ← composition.ext_iff at hc, cases hc, congr, rwa fin.ext_iff }

/-- Two compositions (possibly of different integers) coincide if and only if they have the
same sequence of blocks. -/
lemma sigma_eq_iff_blocks_eq {c : Σ n, composition n} {c' : Σ n, composition n} :
  c = c' ↔ c.2.blocks = c'.2.blocks :=
begin
  refine ⟨λ H, by rw H, λ H, _⟩,
  rcases c with ⟨n, c⟩,
  rcases c' with ⟨n', c'⟩,
  have : n = n', by { rw [← c.blocks_sum, ← c'.blocks_sum, H] },
  induction this,
  simp only [true_and, eq_self_iff_true, heq_iff_eq],
  ext1,
  exact H
end

/-! ### The composition `composition.ones` -/

/-- The composition made of blocks all of size `1`. -/
def ones (n : ℕ) : composition n :=
⟨repeat (1 : ℕ) n, λ i hi, by simp [list.eq_of_mem_repeat hi], by simp⟩

instance {n : ℕ} : inhabited (composition n) :=
⟨composition.ones n⟩

@[simp] lemma ones_length (n : ℕ) : (ones n).length = n :=
list.length_repeat 1 n

@[simp] lemma ones_blocks (n : ℕ) : (ones n).blocks = repeat (1 : ℕ) n := rfl

@[simp] lemma ones_blocks_fun (n : ℕ) (i : fin (ones n).length) :
  (ones n).blocks_fun i = 1 :=
by simp [blocks_fun, ones, blocks, i.2]

@[simp] lemma ones_size_up_to (n : ℕ) (i : ℕ) : (ones n).size_up_to i = min i n :=
by simp [size_up_to, ones_blocks, take_repeat]

@[simp] lemma ones_embedding (i : fin (ones n).length) (h : 0 < (ones n).blocks_fun i) :
  (ones n).embedding i ⟨0, h⟩ = ⟨i, lt_of_lt_of_le i.2 (ones n).length_le⟩ :=
by { ext, simpa using i.2.le }

lemma eq_ones_iff {c : composition n} :
  c = ones n ↔ ∀ i ∈ c.blocks, i = 1 :=
begin
  split,
  { rintro rfl,
    exact λ i, eq_of_mem_repeat },
  { assume H,
    ext1,
    have A : c.blocks = repeat 1 c.blocks.length := eq_repeat_of_mem H,
    have : c.blocks.length = n, by { conv_rhs { rw [← c.blocks_sum, A] }, simp },
    rw [A, this, ones_blocks] },
end

lemma ne_ones_iff {c : composition n} :
  c ≠ ones n ↔ ∃ i ∈ c.blocks, 1 < i :=
begin
  refine (not_congr eq_ones_iff).trans _,
  have : ∀ j ∈ c.blocks, j = 1 ↔ j ≤ 1 := λ j hj, by simp [le_antisymm_iff, c.one_le_blocks hj],
  simp [this] {contextual := tt}
end

lemma eq_ones_iff_length {c : composition n} :
  c = ones n ↔ c.length = n :=
begin
  split,
  { rintro rfl,
    exact ones_length n },
  { contrapose,
    assume H length_n,
    apply lt_irrefl n,
    calc
      n = ∑ (i : fin c.length), 1 : by simp [length_n]
      ... < ∑ (i : fin c.length), c.blocks_fun i :
      begin
        obtain ⟨i, hi, i_blocks⟩ : ∃ i ∈ c.blocks, 1 < i := ne_ones_iff.1 H,
        rw [← of_fn_blocks_fun, mem_of_fn c.blocks_fun, set.mem_range] at hi,
        obtain ⟨j : fin c.length, hj : c.blocks_fun j = i⟩ := hi,
        rw ← hj at i_blocks,
        exact finset.sum_lt_sum (λ i hi, by simp [blocks_fun]) ⟨j, finset.mem_univ _, i_blocks⟩,
      end
      ... = n : c.sum_blocks_fun }
end

lemma eq_ones_iff_le_length {c : composition n} :
  c = ones n ↔ n ≤ c.length :=
by simp [eq_ones_iff_length, le_antisymm_iff, c.length_le]

/-! ### The composition `composition.single` -/

/-- The composition made of a single block of size `n`. -/
def single (n : ℕ) (h : 0 < n) : composition n :=
⟨[n], by simp [h], by simp⟩

@[simp] lemma single_length {n : ℕ} (h : 0 < n) : (single n h).length = 1 := rfl

@[simp] lemma single_blocks {n : ℕ} (h : 0 < n) : (single n h).blocks = [n] := rfl

@[simp] lemma single_blocks_fun {n : ℕ} (h : 0 < n) (i : fin (single n h).length) :
  (single n h).blocks_fun i = n :=
by simp [blocks_fun, single, blocks, i.2]

@[simp] lemma single_embedding {n : ℕ} (h : 0 < n) (i : fin n) :
  (single n h).embedding ⟨0, single_length h ▸ zero_lt_one⟩ i = i :=
by { ext, simp }

lemma eq_single_iff_length {n : ℕ} (h : 0 < n) {c : composition n} :
  c = single n h ↔ c.length = 1 :=
begin
  split,
  { assume H,
    rw H,
    exact single_length h },
  { assume H,
    ext1,
    have A : c.blocks.length = 1 := H ▸ c.blocks_length,
    have B : c.blocks.sum = n := c.blocks_sum,
    rw eq_cons_of_length_one A at B ⊢,
    simpa [single_blocks] using B }
end

lemma ne_single_iff {n : ℕ} (hn : 0 < n) {c : composition n} :
  c ≠ single n hn ↔ ∀ i, c.blocks_fun i < n :=
begin
  rw ← not_iff_not,
  push_neg,
  split,
  { rintros rfl,
    exact ⟨⟨0, by simp⟩, by simp⟩ },
  { rintros ⟨i, hi⟩,
    rw eq_single_iff_length,
    have : ∀ j : fin c.length, j = i,
    { intros j,
      by_contradiction ji,
      apply lt_irrefl ∑ k, c.blocks_fun k,
      calc ∑ k, c.blocks_fun k ≤ c.blocks_fun i      : by simp only [c.sum_blocks_fun, hi]
                           ... < ∑ k, c.blocks_fun k :
        finset.single_lt_sum ji (finset.mem_univ _) (finset.mem_univ _) (c.one_le_blocks_fun j)
          (λ _ _ _, zero_le _) },
    simpa using fintype.card_eq_one_of_forall_eq this }
end

end composition

/-!
### Splitting a list

Given a list of length `n` and a composition `c` of `n`, one can split `l` into `c.length` sublists
of respective lengths `c.blocks_fun 0`, ..., `c.blocks_fun (c.length-1)`. This is inverse to the
join operation.
-/
namespace list
variable {α : Type*}

/-- Auxiliary for `list.split_wrt_composition`. -/
def split_wrt_composition_aux : list α → list ℕ → list (list α)
| l [] := []
| l (n :: ns) :=
  let (l₁, l₂) := l.split_at n in
  l₁ :: split_wrt_composition_aux l₂ ns

/-- Given a list of length `n` and a composition `[i₁, ..., iₖ]` of `n`, split `l` into a list of
`k` lists corresponding to the blocks of the composition, of respective lengths `i₁`, ..., `iₖ`.
This makes sense mostly when `n = l.length`, but this is not necessary for the definition. -/
def split_wrt_composition (l : list α) (c : composition n) : list (list α) :=
split_wrt_composition_aux l c.blocks

local attribute [simp] split_wrt_composition_aux.equations._eqn_1

local attribute [simp]
lemma split_wrt_composition_aux_cons (l : list α) (n ns) :
  l.split_wrt_composition_aux (n :: ns) = take n l :: (drop n l).split_wrt_composition_aux ns :=
by simp [split_wrt_composition_aux]

lemma length_split_wrt_composition_aux (l : list α) (ns) :
  length (l.split_wrt_composition_aux ns) = ns.length :=
by induction ns generalizing l; simp *

/-- When one splits a list along a composition `c`, the number of sublists thus created is
`c.length`. -/
@[simp] lemma length_split_wrt_composition (l : list α) (c : composition n) :
  length (l.split_wrt_composition c) = c.length :=
length_split_wrt_composition_aux _ _

lemma map_length_split_wrt_composition_aux {ns : list ℕ} :
  ∀ {l : list α}, ns.sum ≤ l.length → map length (l.split_wrt_composition_aux ns) = ns :=
begin
  induction ns with n ns IH; intros l h; simp at h ⊢,
  have := le_trans (nat.le_add_right _ _) h,
  rw IH, {simp [this]},
  rwa [length_drop, nat.le_sub_left_iff_add_le this]
end

/-- When one splits a list along a composition `c`, the lengths of the sublists thus created are
given by the block sizes in `c`. -/
lemma map_length_split_wrt_composition (l : list α) (c : composition l.length) :
  map length (l.split_wrt_composition c) = c.blocks :=
map_length_split_wrt_composition_aux (le_of_eq c.blocks_sum)

lemma length_pos_of_mem_split_wrt_composition {l l' : list α} {c : composition l.length}
  (h : l' ∈ l.split_wrt_composition c) : 0 < length l' :=
begin
  have : l'.length ∈ (l.split_wrt_composition c).map list.length :=
    list.mem_map_of_mem list.length h,
  rw map_length_split_wrt_composition at this,
  exact c.blocks_pos this
end

lemma sum_take_map_length_split_wrt_composition
  (l : list α) (c : composition l.length) (i : ℕ) :
  (((l.split_wrt_composition c).map length).take i).sum = c.size_up_to i :=
by { congr, exact map_length_split_wrt_composition l c }

lemma nth_le_split_wrt_composition_aux (l : list α) (ns : list ℕ) {i : ℕ} (hi) :
  nth_le (l.split_wrt_composition_aux ns) i hi =
  (l.take (ns.take (i+1)).sum).drop (ns.take i).sum :=
begin
  induction ns with n ns IH generalizing l i, {cases hi},
  cases i; simp [IH],
  rw [add_comm n, drop_add, drop_take],
end

/-- The `i`-th sublist in the splitting of a list `l` along a composition `c`, is the slice of `l`
between the indices `c.size_up_to i` and `c.size_up_to (i+1)`, i.e., the indices in the `i`-th
block of the composition. -/
lemma nth_le_split_wrt_composition (l : list α) (c : composition n)
  {i : ℕ} (hi : i < (l.split_wrt_composition c).length) :
  nth_le (l.split_wrt_composition c) i hi = (l.take (c.size_up_to (i+1))).drop (c.size_up_to i) :=
nth_le_split_wrt_composition_aux _ _ _

theorem join_split_wrt_composition_aux {ns : list ℕ} :
  ∀ {l : list α}, ns.sum = l.length → (l.split_wrt_composition_aux ns).join = l :=
begin
  induction ns with n ns IH; intros l h; simp at h ⊢,
  { exact (length_eq_zero.1 h.symm).symm },
  rw IH, {simp},
  rwa [length_drop, ← h, nat.add_sub_cancel_left]
end

/-- If one splits a list along a composition, and then joins the sublists, one gets back the
original list. -/
@[simp] theorem join_split_wrt_composition (l : list α) (c : composition l.length) :
  (l.split_wrt_composition c).join = l :=
join_split_wrt_composition_aux c.blocks_sum

/-- If one joins a list of lists and then splits the join along the right composition, one gets
back the original list of lists. -/
@[simp] theorem split_wrt_composition_join (L : list (list α)) (c : composition L.join.length)
  (h : map length L = c.blocks) : split_wrt_composition (join L) c = L :=
by simp only [eq_self_iff_true, and_self, eq_iff_join_eq, join_split_wrt_composition,
              map_length_split_wrt_composition, h]

end list

/-!
### Compositions as sets

Combinatorial viewpoints on compositions, seen as finite subsets of `fin (n+1)` containing `0` and
`n`, where the points of the set (other than `n`) correspond to the leftmost points of each block.
-/

/-- Bijection between compositions of `n` and subsets of `{0, ..., n-2}`, defined by
considering the restriction of the subset to `{1, ..., n-1}` and shifting to the left by one. -/
def composition_as_set_equiv (n : ℕ) : composition_as_set n ≃ finset (fin (n - 1)) :=
{ to_fun := λ c, {i : fin (n-1) |
    (⟨1 + (i : ℕ), begin
       apply (add_lt_add_left i.is_lt 1).trans_le,
       rw [nat.succ_eq_add_one, add_comm],
       exact add_le_add (nat.sub_le n 1) (le_refl 1)
    end ⟩ : fin n.succ) ∈ c.boundaries}.to_finset,
  inv_fun := λ s,
    { boundaries := {i : fin n.succ | (i = 0) ∨ (i = fin.last n)
        ∨ (∃ (j : fin (n-1)) (hj : j ∈ s), (i : ℕ) = j + 1)}.to_finset,
      zero_mem   := by simp,
      last_mem   := by simp },
  left_inv := begin
    assume c,
    ext i,
    simp only [exists_prop, add_comm, set.mem_to_finset, true_or, or_true, set.mem_set_of_eq],
    split,
    { rintro (rfl | rfl | ⟨j, hj1, hj2⟩),
      { exact c.zero_mem },
      { exact c.last_mem },
      { convert hj1, rwa fin.ext_iff } },
    { simp only [or_iff_not_imp_left],
      assume i_mem i_ne_zero i_ne_last,
      simp [fin.ext_iff] at i_ne_zero i_ne_last,
      have A : (1 + (i-1) : ℕ) = (i : ℕ),
        by { rw add_comm, exact nat.succ_pred_eq_of_pos (pos_iff_ne_zero.mpr i_ne_zero) },
      refine ⟨⟨i - 1, _⟩, _, _⟩,
      { have : (i : ℕ) < n + 1 := i.2,
        simp [nat.lt_succ_iff_lt_or_eq, i_ne_last] at this,
        exact nat.pred_lt_pred i_ne_zero this },
      { convert i_mem,
        rw fin.ext_iff,
        simp only [fin.coe_mk, A] },
      { simp [A] } },
  end,
  right_inv := begin
    assume s,
    ext i,
    have : 1 + (i : ℕ) ≠ n,
    { apply ne_of_lt,
      convert add_lt_add_left i.is_lt 1,
      rw add_comm,
      apply (nat.succ_pred_eq_of_pos _).symm,
      exact (zero_le i.val).trans_lt (i.2.trans_le (nat.sub_le n 1)) },
    simp only [fin.ext_iff, exists_prop, fin.coe_zero, add_comm,
      set.mem_to_finset, set.mem_set_of_eq, fin.coe_last],
    erw [set.mem_set_of_eq],
    simp only [this, false_or, add_right_inj, add_eq_zero_iff, one_ne_zero, false_and, fin.coe_mk],
    split,
    { rintros ⟨j, js, hj⟩, convert js, exact (fin.ext_iff _ _).2 hj },
    { assume h, exact ⟨i, h, rfl⟩ }
  end }

instance composition_as_set_fintype (n : ℕ) : fintype (composition_as_set n) :=
fintype.of_equiv _ (composition_as_set_equiv n).symm

lemma composition_as_set_card (n : ℕ) : fintype.card (composition_as_set n) = 2 ^ (n - 1) :=
begin
  have : fintype.card (finset (fin (n-1))) = 2 ^ (n - 1), by simp,
  rw ← this,
  exact fintype.card_congr (composition_as_set_equiv n)
end

namespace composition_as_set

variables (c : composition_as_set n)

lemma boundaries_nonempty : c.boundaries.nonempty :=
⟨0, c.zero_mem⟩

lemma card_boundaries_pos : 0 < finset.card c.boundaries :=
finset.card_pos.mpr c.boundaries_nonempty

/-- Number of blocks in a `composition_as_set`. -/
def length : ℕ := finset.card c.boundaries - 1

lemma card_boundaries_eq_succ_length : c.boundaries.card = c.length + 1 :=
(nat.sub_eq_iff_eq_add c.card_boundaries_pos).mp rfl

lemma length_lt_card_boundaries : c.length < c.boundaries.card :=
by { rw c.card_boundaries_eq_succ_length, exact lt_add_one _ }

lemma lt_length (i : fin c.length) : (i : ℕ) + 1 < c.boundaries.card :=
nat.add_lt_of_lt_sub_right i.2

lemma lt_length' (i : fin c.length) : (i : ℕ) < c.boundaries.card :=
lt_of_le_of_lt (nat.le_succ i) (c.lt_length i)

/-- Canonical increasing bijection from `fin c.boundaries.card` to `c.boundaries`. -/
def boundary : fin c.boundaries.card ↪o fin (n + 1) := c.boundaries.order_emb_of_fin rfl

@[simp] lemma boundary_zero : (c.boundary ⟨0, c.card_boundaries_pos⟩ : fin (n + 1)) = 0 :=
begin
  rw [boundary, finset.order_emb_of_fin_zero rfl c.card_boundaries_pos],
  exact le_antisymm (finset.min'_le _ _ c.zero_mem) (fin.zero_le _),
end

@[simp] lemma boundary_length : c.boundary ⟨c.length, c.length_lt_card_boundaries⟩ = fin.last n :=
begin
  convert finset.order_emb_of_fin_last rfl c.card_boundaries_pos,
  exact le_antisymm (finset.le_max' _ _ c.last_mem) (fin.le_last _)
end

/-- Size of the `i`-th block in a `composition_as_set`, seen as a function on `fin c.length`. -/
def blocks_fun (i : fin c.length) : ℕ :=
(c.boundary ⟨(i : ℕ) + 1, c.lt_length i⟩) - (c.boundary ⟨i, c.lt_length' i⟩)

lemma blocks_fun_pos (i : fin c.length) : 0 < c.blocks_fun i :=
begin
  have : (⟨i, c.lt_length' i⟩ : fin c.boundaries.card) < ⟨i + 1, c.lt_length i⟩ :=
    nat.lt_succ_self _,
  exact nat.lt_sub_left_of_add_lt ((c.boundaries.order_emb_of_fin rfl).strict_mono this)
end

/-- List of the sizes of the blocks in a `composition_as_set`. -/
def blocks (c : composition_as_set n) : list ℕ :=
of_fn c.blocks_fun

@[simp] lemma blocks_length : c.blocks.length = c.length :=
length_of_fn _

lemma blocks_partial_sum {i : ℕ} (h : i < c.boundaries.card) :
  (c.blocks.take i).sum = c.boundary ⟨i, h⟩ :=
begin
  induction i with i IH, { simp },
  have A : i < c.blocks.length,
  { rw c.card_boundaries_eq_succ_length at h,
    simp [blocks, nat.lt_of_succ_lt_succ h] },
  have B : i < c.boundaries.card := lt_of_lt_of_le A (by simp [blocks, length, nat.sub_le]),
  rw [sum_take_succ _ _ A, IH B],
  simp only [blocks, blocks_fun, nth_le_of_fn'],
  apply nat.add_sub_cancel',
  simp
end

lemma mem_boundaries_iff_exists_blocks_sum_take_eq {j : fin (n+1)} :
  j ∈ c.boundaries ↔ ∃ i < c.boundaries.card, (c.blocks.take i).sum = j :=
begin
  split,
  { assume hj,
    rcases (c.boundaries.order_iso_of_fin rfl).surjective ⟨j, hj⟩ with ⟨i, hi⟩,
    rw [subtype.ext_iff, subtype.coe_mk] at hi,
    refine ⟨i.1, i.2, _⟩,
    rw [← hi, c.blocks_partial_sum i.2],
    refl },
  { rintros ⟨i, hi, H⟩,
    convert (c.boundaries.order_iso_of_fin rfl ⟨i, hi⟩).2,
    have : c.boundary ⟨i, hi⟩ = j, by rwa [fin.ext_iff, ← c.blocks_partial_sum hi],
    exact this.symm }
end

/-- Associating a `composition n` to a `composition_as_set n`, by registering the sizes of the
blocks as a list of positive integers. -/
def to_composition : composition n :=
{ blocks     := c.blocks,
  blocks_pos := by simp only [blocks, forall_mem_of_fn_iff, blocks_fun_pos c, forall_true_iff],
  blocks_sum := c.blocks_sum }

end composition_as_set

/-!
### Equivalence between compositions and compositions as sets

In this section, we explain how to go back and forth between a `composition` and a
`composition_as_set`, by showing that their `blocks` and `length` and `boundaries` correspond to
each other, and construct an equivalence between them called `composition_equiv`.
-/

@[simp] lemma composition.to_composition_as_set_length (c : composition n) :
  c.to_composition_as_set.length = c.length :=
by simp [composition.to_composition_as_set, composition_as_set.length,
         c.card_boundaries_eq_succ_length]

@[simp] lemma composition_as_set.to_composition_length (c : composition_as_set n) :
  c.to_composition.length = c.length :=
by simp [composition_as_set.to_composition, composition.length, composition.blocks]

@[simp] lemma composition.to_composition_as_set_blocks (c : composition n) :
  c.to_composition_as_set.blocks = c.blocks :=
begin
  let d := c.to_composition_as_set,
  change d.blocks = c.blocks,
  have length_eq : d.blocks.length = c.blocks.length,
  { convert c.to_composition_as_set_length,
    simp [composition_as_set.blocks] },
  suffices H : ∀ (i ≤ d.blocks.length), (d.blocks.take i).sum = (c.blocks.take i).sum,
    from eq_of_sum_take_eq length_eq H,
  assume i hi,
  have i_lt : i < d.boundaries.card,
  { convert nat.lt_succ_iff.2 hi,
    convert d.card_boundaries_eq_succ_length,
    exact length_of_fn _ },
  have i_lt' : i < c.boundaries.card := i_lt,
  have i_lt'' : i < c.length + 1, by rwa c.card_boundaries_eq_succ_length at i_lt',
  have A : d.boundaries.order_emb_of_fin rfl ⟨i, i_lt⟩
    = c.boundaries.order_emb_of_fin c.card_boundaries_eq_succ_length ⟨i, i_lt''⟩ := rfl,
  have B : c.size_up_to i = c.boundary ⟨i, i_lt''⟩ := rfl,
  rw [d.blocks_partial_sum i_lt, composition_as_set.boundary, ← composition.size_up_to, B,
    A, c.order_emb_of_fin_boundaries]
end

@[simp] lemma composition_as_set.to_composition_blocks (c : composition_as_set n) :
  c.to_composition.blocks = c.blocks := rfl

@[simp] lemma composition_as_set.to_composition_boundaries (c : composition_as_set n) :
  c.to_composition.boundaries = c.boundaries :=
begin
  ext j,
  simp [c.mem_boundaries_iff_exists_blocks_sum_take_eq, c.card_boundaries_eq_succ_length,
    composition.boundary, fin.ext_iff, composition.size_up_to, exists_prop, finset.mem_univ,
    take, exists_prop_of_true, finset.mem_image, composition_as_set.to_composition_blocks,
    composition.boundaries],
  split,
  { rintros ⟨i, hi⟩,
    refine ⟨i.1, _, hi⟩,
    convert i.2,
    simp },
  { rintros ⟨i, i_lt, hi⟩,
    have : i < c.to_composition.length + 1, by simpa using i_lt,
    exact ⟨⟨i, this⟩, hi⟩ }
end

@[simp] lemma composition.to_composition_as_set_boundaries (c : composition n) :
  c.to_composition_as_set.boundaries = c.boundaries := rfl

/-- Equivalence between `composition n` and `composition_as_set n`. -/
def composition_equiv (n : ℕ) : composition n ≃ composition_as_set n :=
{ to_fun    := λ c, c.to_composition_as_set,
  inv_fun   := λ c, c.to_composition,
  left_inv  := λ c, by { ext1, exact c.to_composition_as_set_blocks },
  right_inv := λ c, by { ext1, exact c.to_composition_boundaries } }

instance composition_fintype (n : ℕ) : fintype (composition n) :=
fintype.of_equiv _ (composition_equiv n).symm

lemma composition_card (n : ℕ) : fintype.card (composition n) = 2 ^ (n - 1) :=
begin
  rw ← composition_as_set_card n,
  exact fintype.card_congr (composition_equiv n)
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.algebra.hom
import ring_theory.ideal.quotient

/-!
# Quotients of non-commutative rings

Unfortunately, ideals have only been developed in the commutative case as `ideal`,
and it's not immediately clear how one should formalise ideals in the non-commutative case.

In this file, we directly define the quotient of a semiring by any relation,
by building a bigger relation that represents the ideal generated by that relation.

We prove the universal properties of the quotient, and recommend avoiding relying on the actual
definition, which is made irreducible for this purpose.

Since everything runs in parallel for quotients of `R`-algebras, we do that case at the same time.
-/

universes u₁ u₂ u₃ u₄

variables {R : Type u₁} [semiring R]
variables {S : Type u₂} [comm_semiring S]
variables {A : Type u₃} [semiring A] [algebra S A]

namespace ring_quot

/--
Given an arbitrary relation `r` on a ring, we strengthen it to a relation `rel r`,
such that the equivalence relation generated by `rel r` has `x ~ y` if and only if
`x - y` is in the ideal generated by elements `a - b` such that `r a b`.
-/
inductive rel (r : R → R → Prop) : R → R → Prop
| of ⦃x y : R⦄ (h : r x y) : rel x y
| add_left ⦃a b c⦄ : rel a b → rel (a + c) (b + c)
| mul_left ⦃a b c⦄ : rel a b → rel (a * c) (b * c)
| mul_right ⦃a b c⦄ : rel b c → rel (a * b) (a * c)

theorem rel.add_right {r : R → R → Prop} ⦃a b c : R⦄ (h : rel r b c) : rel r (a + b) (a + c) :=
by { rw [add_comm a b, add_comm a c], exact rel.add_left h }

theorem rel.neg {R : Type u₁} [ring R] {r : R → R → Prop} ⦃a b : R⦄ (h : rel r a b) :
  rel r (-a) (-b) :=
by simp only [neg_eq_neg_one_mul a, neg_eq_neg_one_mul b, rel.mul_right h]

theorem rel.sub_left {R : Type u₁} [ring R] {r : R → R → Prop} ⦃a b c : R⦄ (h : rel r a b) :
  rel r (a - c) (b - c) :=
by simp only [sub_eq_add_neg, h.add_left]

theorem rel.sub_right {R : Type u₁} [ring R] {r : R → R → Prop} ⦃a b c : R⦄ (h : rel r b c) :
  rel r (a - b) (a - c) :=
by simp only [sub_eq_add_neg, h.neg.add_right]

theorem rel.smul {r : A → A → Prop} (k : S) ⦃a b : A⦄ (h : rel r a b) : rel r (k • a) (k • b) :=
by simp only [algebra.smul_def, rel.mul_right h]

end ring_quot

/-- The quotient of a ring by an arbitrary relation. -/
structure ring_quot (r : R → R → Prop) :=
(to_quot : quot (ring_quot.rel r))

namespace ring_quot

variable (r : R → R → Prop)

@[irreducible] private def nat_cast (n : ℕ) : ring_quot r := ⟨quot.mk _ n⟩
@[irreducible] private def zero : ring_quot r := ⟨quot.mk _ 0⟩
@[irreducible] private def one : ring_quot r := ⟨quot.mk _ 1⟩
@[irreducible] private def add : ring_quot r → ring_quot r → ring_quot r
| ⟨a⟩ ⟨b⟩ := ⟨quot.map₂ (+) rel.add_right rel.add_left a b⟩
@[irreducible] private def mul : ring_quot r → ring_quot r → ring_quot r
| ⟨a⟩ ⟨b⟩ := ⟨quot.map₂ (*) rel.mul_right rel.mul_left a b⟩
@[irreducible] private def neg {R : Type u₁} [ring R] (r : R → R → Prop) : ring_quot r → ring_quot r
| ⟨a⟩:= ⟨quot.map (λ a, -a) rel.neg a⟩
@[irreducible] private def sub {R : Type u₁} [ring R] (r : R → R → Prop) :
  ring_quot r → ring_quot r → ring_quot r
| ⟨a⟩ ⟨b⟩ := ⟨quot.map₂ has_sub.sub rel.sub_right rel.sub_left a b⟩
@[irreducible] private def npow (n : ℕ) : ring_quot r → ring_quot r
| ⟨a⟩ := ⟨quot.lift
          (λ a, quot.mk (ring_quot.rel r) (a ^ n))
          (λ a b (h : rel r a b), begin
            -- note we can't define a `rel.pow` as `rel` isn't reflexive so `rel r 1 1` isn't true
            dsimp only,
            induction n,
            { rw [pow_zero, pow_zero] },
            { rw [pow_succ, pow_succ],
              simpa only [mul] using congr_arg2 (λ x y, mul r ⟨x⟩ ⟨y⟩) (quot.sound h) n_ih }
          end)
          a⟩
@[irreducible] private def smul [algebra S R] (n : S) : ring_quot r → ring_quot r
| ⟨a⟩ := ⟨quot.map (λ a, n • a) (rel.smul n) a⟩

instance : has_zero (ring_quot r) := ⟨zero r⟩
instance : has_one (ring_quot r) := ⟨one r⟩
instance : has_add (ring_quot r) := ⟨add r⟩
instance : has_mul (ring_quot r) := ⟨mul r⟩
instance : has_pow (ring_quot r) ℕ := ⟨λ x n, npow r n x⟩
instance {R : Type u₁} [ring R] (r : R → R → Prop) : has_neg (ring_quot r) := ⟨neg r⟩
instance {R : Type u₁} [ring R] (r : R → R → Prop) : has_sub (ring_quot r) := ⟨sub r⟩
instance [algebra S R] : has_smul S (ring_quot r) := ⟨smul r⟩

lemma zero_quot : (⟨quot.mk _ 0⟩ : ring_quot r) = 0 := show _ = zero r, by rw zero
lemma one_quot : (⟨quot.mk _ 1⟩ : ring_quot r) = 1 := show _ = one r, by rw one
lemma add_quot {a b} : (⟨quot.mk _ a⟩ + ⟨quot.mk _ b⟩ : ring_quot r) = ⟨quot.mk _ (a + b)⟩ :=
by { show add r _ _ = _, rw add, refl }
lemma mul_quot {a b} : (⟨quot.mk _ a⟩ * ⟨quot.mk _ b⟩ : ring_quot r) = ⟨quot.mk _ (a * b)⟩ :=
by { show mul r _ _ = _, rw mul, refl }
lemma pow_quot {a} {n : ℕ}: (⟨quot.mk _ a⟩ ^ n : ring_quot r) = ⟨quot.mk _ (a ^ n)⟩ :=
by { show npow r _ _ = _, rw npow }
lemma neg_quot {R : Type u₁} [ring R] (r : R → R → Prop) {a} :
  (-⟨quot.mk _ a⟩ : ring_quot r) = ⟨quot.mk _ (-a)⟩ :=
by { show neg r _ = _, rw neg, refl }
lemma sub_quot {R : Type u₁} [ring R] (r : R → R → Prop) {a b} :
  (⟨quot.mk _ a⟩ - ⟨ quot.mk _ b⟩ : ring_quot r) = ⟨quot.mk _ (a - b)⟩ :=
by { show sub r _ _ = _, rw sub, refl }
lemma smul_quot [algebra S R] {n : S} {a : R} :
  (n • ⟨quot.mk _ a⟩ : ring_quot r) = ⟨quot.mk _ (n • a)⟩ :=
by { show smul r _ _ = _, rw smul, refl }

instance (r : R → R → Prop) : semiring (ring_quot r) :=
{ add           := (+),
  mul           := (*),
  zero          := 0,
  one           := 1,
  nat_cast      := nat_cast r,
  nat_cast_zero := by simp [nat.cast, nat_cast, ← zero_quot],
  nat_cast_succ := by simp [nat.cast, nat_cast, ← one_quot, add_quot],
  add_assoc     := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [add_quot, add_assoc] },
  zero_add      := by { rintros ⟨⟨⟩⟩, simp [add_quot, ← zero_quot] },
  add_zero      := by { rintros ⟨⟨⟩⟩, simp [add_quot, ← zero_quot], },
  zero_mul      := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← zero_quot], },
  mul_zero      := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← zero_quot], },
  add_comm      := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [add_quot, add_comm], },
  mul_assoc     := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, mul_assoc] },
  one_mul       := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← one_quot] },
  mul_one       := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← one_quot] },
  left_distrib  := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, add_quot, left_distrib] },
  right_distrib := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, add_quot, right_distrib] },
  npow          := λ n x, x ^ n,
  npow_zero'    := by { rintros ⟨⟨⟩⟩, simp [pow_quot, ← one_quot] },
  npow_succ'    := by { rintros n ⟨⟨⟩⟩, simp [pow_quot, mul_quot, pow_succ] },
  nsmul         := (•),
  nsmul_zero'   := by { rintros ⟨⟨⟩⟩, simp [smul_quot, ← zero_quot] },
  nsmul_succ'   := by { rintros n ⟨⟨⟩⟩, simp [smul_quot, add_quot, add_mul, add_comm] } }

instance {R : Type u₁} [ring R] (r : R → R → Prop) : ring (ring_quot r) :=
{ neg           := has_neg.neg,
  add_left_neg  := by { rintros ⟨⟨⟩⟩, simp [neg_quot, add_quot, ← zero_quot], },
  sub            := has_sub.sub,
  sub_eq_add_neg := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [neg_quot, sub_quot, add_quot, sub_eq_add_neg] },
  zsmul          := (•),
  zsmul_zero'   := by { rintros ⟨⟨⟩⟩, simp [smul_quot, ← zero_quot] },
  zsmul_succ'   := by { rintros n ⟨⟨⟩⟩, simp [smul_quot, add_quot, add_mul, add_comm] },
  zsmul_neg'   := by { rintros n ⟨⟨⟩⟩, simp [smul_quot, neg_quot, add_mul] },
  .. (ring_quot.semiring r) }

instance {R : Type u₁} [comm_semiring R] (r : R → R → Prop) : comm_semiring (ring_quot r) :=
{ mul_comm := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, mul_comm], }
  .. (ring_quot.semiring r) }

instance {R : Type u₁} [comm_ring R] (r : R → R → Prop) : comm_ring (ring_quot r) :=
{ .. (ring_quot.comm_semiring r),
  .. (ring_quot.ring r) }

instance (r : R → R → Prop) : inhabited (ring_quot r) := ⟨0⟩

instance [algebra S R] (r : R → R → Prop) : algebra S (ring_quot r) :=
{ smul      := (•),
  to_fun    := λ r, ⟨quot.mk _ (algebra_map S R r)⟩,
  map_one'  := by simp [← one_quot],
  map_mul'  := by simp [mul_quot],
  map_zero' := by simp [← zero_quot],
  map_add'  := by simp [add_quot],
  commutes' := λ r, by { rintro ⟨⟨a⟩⟩, simp [algebra.commutes, mul_quot] },
  smul_def' := λ r, by { rintro ⟨⟨a⟩⟩, simp [smul_quot, algebra.smul_def, mul_quot], }, }

/--
The quotient map from a ring to its quotient, as a homomorphism of rings.
-/
@[irreducible] def mk_ring_hom (r : R → R → Prop) : R →+* ring_quot r :=
{ to_fun := λ x, ⟨quot.mk _ x⟩,
  map_one'  := by simp [← one_quot],
  map_mul'  := by simp [mul_quot],
  map_zero' := by simp [← zero_quot],
  map_add'  := by simp [add_quot], }

lemma mk_ring_hom_rel {r : R → R → Prop} {x y : R} (w : r x y) :
  mk_ring_hom r x = mk_ring_hom r y :=
by simp [mk_ring_hom, quot.sound (rel.of w)]

lemma mk_ring_hom_surjective (r : R → R → Prop) : function.surjective (mk_ring_hom r) :=
by { dsimp [mk_ring_hom], rintro ⟨⟨⟩⟩, simp, }

@[ext]
lemma ring_quot_ext {T : Type u₄} [semiring T] {r : R → R → Prop} (f g : ring_quot r →+* T)
  (w : f.comp (mk_ring_hom r) = g.comp (mk_ring_hom r)) : f = g :=
begin
  ext,
  rcases mk_ring_hom_surjective r x with ⟨x, rfl⟩,
  exact (ring_hom.congr_fun w x : _),
end

variables  {T : Type u₄} [semiring T]

/--
Any ring homomorphism `f : R →+* T` which respects a relation `r : R → R → Prop`
factors uniquely through a morphism `ring_quot r →+* T`.
-/
@[irreducible] def lift {r : R → R → Prop} :
  {f : R →+* T // ∀ ⦃x y⦄, r x y → f x = f y} ≃ (ring_quot r →+* T) :=
{ to_fun := λ f', let f := (f' : R →+* T) in
  { to_fun := λ x, quot.lift f
    begin
      rintros _ _ r,
      induction r,
      case of : _ _ r { exact f'.prop r, },
      case add_left : _ _ _ _ r' { simp [r'], },
      case mul_left : _ _ _ _ r' { simp [r'], },
      case mul_right : _ _ _ _ r' { simp [r'], },
    end x.to_quot,
    map_zero' := by simp [← zero_quot, f.map_zero],
    map_add' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [add_quot, f.map_add x y], },
    map_one' := by simp [← one_quot, f.map_one],
    map_mul' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [mul_quot, f.map_mul x y] }, },
  inv_fun := λ F, ⟨F.comp (mk_ring_hom r), λ x y h, by { dsimp, rw mk_ring_hom_rel h, }⟩,
  left_inv := λ f, by { ext, simp [mk_ring_hom] },
  right_inv := λ F, by { ext, simp [mk_ring_hom] } }

@[simp]
lemma lift_mk_ring_hom_apply (f : R →+* T) {r : R → R → Prop} (w : ∀ ⦃x y⦄, r x y → f x = f y) (x) :
  lift ⟨f, w⟩ (mk_ring_hom r x) = f x :=
by { simp_rw [lift, mk_ring_hom], refl }

-- note this is essentially `lift.symm_apply_eq.mp h`
lemma lift_unique (f : R →+* T) {r : R → R → Prop} (w : ∀ ⦃x y⦄, r x y → f x = f y)
  (g : ring_quot r →+* T) (h : g.comp (mk_ring_hom r) = f) : g = lift ⟨f, w⟩ :=
by { ext, simp [h], }

lemma eq_lift_comp_mk_ring_hom {r : R → R → Prop} (f : ring_quot r →+* T) :
  f = lift ⟨f.comp (mk_ring_hom r), λ x y h, by { dsimp, rw mk_ring_hom_rel h, }⟩ :=
begin
  conv_lhs { rw ← lift.apply_symm_apply f },
  rw lift,
  refl,
end

section comm_ring
/-!
We now verify that in the case of a commutative ring, the `ring_quot` construction
agrees with the quotient by the appropriate ideal.
-/

variables {B : Type u₁} [comm_ring B]

/-- The universal ring homomorphism from `ring_quot r` to `B ⧸ ideal.of_rel r`. -/
def ring_quot_to_ideal_quotient (r : B → B → Prop) :
  ring_quot r →+* B ⧸ ideal.of_rel r :=
lift
  ⟨ideal.quotient.mk (ideal.of_rel r),
    λ x y h, ideal.quotient.eq.2 $ submodule.mem_Inf.mpr (λ p w, w ⟨x, y, h, sub_add_cancel x y⟩)⟩

@[simp] lemma ring_quot_to_ideal_quotient_apply (r : B → B → Prop) (x : B) :
  ring_quot_to_ideal_quotient r (mk_ring_hom r x) = ideal.quotient.mk _ x :=
begin
  simp_rw [ring_quot_to_ideal_quotient, lift, mk_ring_hom],
  refl
end

/-- The universal ring homomorphism from `B ⧸ ideal.of_rel r` to `ring_quot r`. -/
def ideal_quotient_to_ring_quot (r : B → B → Prop) :
  B ⧸ ideal.of_rel r →+* ring_quot r :=
ideal.quotient.lift (ideal.of_rel r) (mk_ring_hom r)
begin
  refine λ x h, submodule.span_induction h _ _ _ _,
  { rintro y ⟨a, b, h, su⟩,
    symmetry' at su,
    rw ←sub_eq_iff_eq_add at su,
    rw [ ← su, ring_hom.map_sub, mk_ring_hom_rel h, sub_self], },
  { simp, },
  { intros a b ha hb, simp [ha, hb], },
  { intros a x hx, simp [hx], },
end

@[simp] lemma ideal_quotient_to_ring_quot_apply (r : B → B → Prop) (x : B) :
  ideal_quotient_to_ring_quot r (ideal.quotient.mk _ x) = mk_ring_hom r x := rfl

/--
The ring equivalence between `ring_quot r` and `(ideal.of_rel r).quotient`
-/
def ring_quot_equiv_ideal_quotient (r : B → B → Prop) :
  ring_quot r ≃+* B ⧸ ideal.of_rel r :=
ring_equiv.of_hom_inv (ring_quot_to_ideal_quotient r) (ideal_quotient_to_ring_quot r)
  (begin
    ext,
    simp_rw [ring_quot_to_ideal_quotient, lift, mk_ring_hom],
    dsimp,
    rw [mk_ring_hom],
    refl
  end)
  (begin
    ext,
    simp_rw [ring_quot_to_ideal_quotient, lift, mk_ring_hom],
    dsimp,
    rw [mk_ring_hom],
    refl
  end)

end comm_ring

section star_ring

variables [star_ring R] (r) (hr : ∀ a b, r a b → r (star a) (star b))
include hr

theorem rel.star ⦃a b : R⦄ (h : rel r a b) :
  rel r (star a) (star b) :=
begin
  induction h,
  { exact rel.of (hr _ _ h_h) },
  { rw [star_add, star_add], exact rel.add_left h_ih, },
  { rw [star_mul, star_mul], exact rel.mul_right h_ih, },
  { rw [star_mul, star_mul], exact rel.mul_left h_ih, },
end

@[irreducible] private def star' : ring_quot r → ring_quot r
| ⟨a⟩ := ⟨quot.map (star : R → R) (rel.star r hr) a⟩

lemma star'_quot (hr : ∀ a b, r a b → r (star a) (star b)) {a} :
  (star' r hr ⟨quot.mk _ a⟩ : ring_quot r) = ⟨quot.mk _ (star a)⟩ :=
by { show star' r _ _ = _, rw star', refl }

/-- Transfer a star_ring instance through a quotient, if the quotient is invariant to `star` -/
def star_ring {R : Type u₁} [semiring R] [star_ring R] (r : R → R → Prop)
  (hr : ∀ a b, r a b → r (star a) (star b)) :
  star_ring (ring_quot r) :=
{ star := star' r hr,
  star_involutive := by { rintros ⟨⟨⟩⟩, simp [star'_quot], },
  star_mul := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [star'_quot, mul_quot, star_mul], },
  star_add := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [star'_quot, add_quot, star_add], } }

end star_ring

section algebra

variables (S)

/--
The quotient map from an `S`-algebra to its quotient, as a homomorphism of `S`-algebras.
-/
@[irreducible] def mk_alg_hom (s : A → A → Prop) : A →ₐ[S] ring_quot s :=
{ commutes' := λ r, by { simp [mk_ring_hom], refl },
  ..mk_ring_hom s }

@[simp]
lemma mk_alg_hom_coe (s : A → A → Prop) : (mk_alg_hom S s : A →+* ring_quot s) = mk_ring_hom s :=
by { simp_rw [mk_alg_hom, mk_ring_hom], refl }

lemma mk_alg_hom_rel {s : A → A → Prop} {x y : A} (w : s x y) :
  mk_alg_hom S s x = mk_alg_hom S s y :=
by simp [mk_alg_hom, mk_ring_hom, quot.sound (rel.of w)]

lemma mk_alg_hom_surjective (s : A → A → Prop) : function.surjective (mk_alg_hom S s) :=
by { dsimp [mk_alg_hom, mk_ring_hom], rintro ⟨⟨a⟩⟩, use a, refl, }

variables {B : Type u₄} [semiring B] [algebra S B]

@[ext]
lemma ring_quot_ext' {s : A → A → Prop}
  (f g : ring_quot s →ₐ[S] B) (w : f.comp (mk_alg_hom S s) = g.comp (mk_alg_hom S s)) : f = g :=
begin
  ext,
  rcases mk_alg_hom_surjective S s x with ⟨x, rfl⟩,
  exact (alg_hom.congr_fun w x : _),
end

/--
Any `S`-algebra homomorphism `f : A →ₐ[S] B` which respects a relation `s : A → A → Prop`
factors uniquely through a morphism `ring_quot s →ₐ[S]  B`.
-/
@[irreducible] def lift_alg_hom {s : A → A → Prop} :
  {f : A →ₐ[S] B // ∀ ⦃x y⦄, s x y → f x = f y} ≃ (ring_quot s →ₐ[S] B) :=
{ to_fun := λ f', let f := (f' : A →ₐ[S] B) in
  { to_fun := λ x, quot.lift f
    begin
      rintros _ _ r,
      induction r,
      case of : _ _ r { exact f'.prop r, },
      case add_left : _ _ _ _ r' { simp [r'], },
      case mul_left : _ _ _ _ r' { simp [r'], },
      case mul_right : _ _ _ _ r' { simp [r'], },
    end x.to_quot,
    map_zero' := by simp [← zero_quot, f.map_zero],
    map_add' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [add_quot, f.map_add x y] },
    map_one' := by simp [← one_quot, f.map_one],
    map_mul' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [mul_quot, f.map_mul x y], },
    commutes' := by { rintros x, simp [← one_quot, smul_quot, algebra.algebra_map_eq_smul_one] } },
  inv_fun := λ F, ⟨F.comp (mk_alg_hom S s), λ _ _ h, by { dsimp, erw mk_alg_hom_rel S h }⟩,
  left_inv := λ f, by { ext, simp [mk_alg_hom, mk_ring_hom] },
  right_inv := λ F, by { ext, simp [mk_alg_hom, mk_ring_hom] } }

@[simp]
lemma lift_alg_hom_mk_alg_hom_apply (f : A →ₐ[S] B) {s : A → A → Prop}
  (w : ∀ ⦃x y⦄, s x y → f x = f y) (x) :
  (lift_alg_hom S ⟨f, w⟩) ((mk_alg_hom S s) x) = f x :=
by { simp_rw [lift_alg_hom, mk_alg_hom, mk_ring_hom], refl, }

-- note this is essentially `(lift_alg_hom S).symm_apply_eq.mp h`
lemma lift_alg_hom_unique (f : A →ₐ[S] B) {s : A → A → Prop} (w : ∀ ⦃x y⦄, s x y → f x = f y)
  (g : ring_quot s →ₐ[S] B) (h : g.comp (mk_alg_hom S s) = f) : g = lift_alg_hom S ⟨f, w⟩ :=
by { ext, simp [h], }

lemma eq_lift_alg_hom_comp_mk_alg_hom {s : A → A → Prop} (f : ring_quot s →ₐ[S] B) :
  f = lift_alg_hom S ⟨f.comp (mk_alg_hom S s), λ x y h, by { dsimp, erw mk_alg_hom_rel S h, }⟩ :=
begin
  conv_lhs { rw ← ((lift_alg_hom S).apply_symm_apply f) },
  rw lift_alg_hom,
  refl,
end

end algebra

end ring_quot


/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Joseph Myers
-/

import data.complex.exponential
import analysis.special_functions.log.deriv

/-!
# Bounds on specific values of the exponential
-/
namespace real

open is_absolute_value finset cau_seq complex

lemma exp_one_near_10 : |exp 1 - 2244083/825552| ≤ 1/10^10 :=
begin
  apply exp_approx_start,
  iterate 13 { refine exp_1_approx_succ_eq (by norm_num1; refl) (by norm_cast; refl) _ },
  norm_num1,
  refine exp_approx_end' _ (by norm_num1; refl) _ (by norm_cast; refl) (by simp) _,
  rw [_root_.abs_one, abs_of_pos]; norm_num1,
end

lemma exp_one_near_20 : |exp 1 - 363916618873/133877442384| ≤ 1/10^20 :=
begin
  apply exp_approx_start,
  iterate 21 { refine exp_1_approx_succ_eq (by norm_num1; refl) (by norm_cast; refl) _ },
  norm_num1,
  refine exp_approx_end' _ (by norm_num1; refl) _ (by norm_cast; refl) (by simp) _,
  rw [_root_.abs_one, abs_of_pos]; norm_num1,
end

lemma exp_one_gt_d9 : 2.7182818283 < exp 1 :=
lt_of_lt_of_le (by norm_num) (sub_le.1 (abs_sub_le_iff.1 exp_one_near_10).2)

lemma exp_one_lt_d9 : exp 1 < 2.7182818286 :=
lt_of_le_of_lt (sub_le_iff_le_add.1 (abs_sub_le_iff.1 exp_one_near_10).1) (by norm_num)

lemma exp_neg_one_gt_d9 : 0.36787944116 < exp (-1) :=
begin
  rw [exp_neg, lt_inv _ (exp_pos _)],
  refine lt_of_le_of_lt (sub_le_iff_le_add.1 (abs_sub_le_iff.1 exp_one_near_10).1) _,
  all_goals {norm_num},
end

lemma exp_neg_one_lt_d9 : exp (-1) < 0.36787944120 :=
begin
  rw [exp_neg, inv_lt (exp_pos _)],
  refine lt_of_lt_of_le _ (sub_le.1 (abs_sub_le_iff.1 exp_one_near_10).2),
  all_goals {norm_num},
end

lemma log_two_near_10 : |log 2 - 287209 / 414355| ≤ 1/10^10 :=
begin
  suffices : |log 2 - 287209 / 414355| ≤ 1/17179869184 + (1/10^10 - 1/2^34),
  { norm_num1 at *,
    assumption },
  have t : |(2⁻¹ : ℝ)| = 2⁻¹,
  { rw abs_of_pos, norm_num },
  have z := real.abs_log_sub_add_sum_range_le (show |(2⁻¹ : ℝ)| < 1, by { rw t, norm_num }) 34,
  rw t at z,
  norm_num1 at z,
  rw [one_div (2:ℝ), log_inv, ←sub_eq_add_neg, _root_.abs_sub_comm] at z,
  apply le_trans (_root_.abs_sub_le _ _ _) (add_le_add z _),
  simp_rw [sum_range_succ],
  norm_num,
  rw abs_of_pos;
  norm_num
end

lemma log_two_gt_d9 : 0.6931471803 < log 2 :=
lt_of_lt_of_le (by norm_num1) (sub_le.1 (abs_sub_le_iff.1 log_two_near_10).2)

lemma log_two_lt_d9 : log 2 < 0.6931471808 :=
lt_of_le_of_lt (sub_le_iff_le_add.1 (abs_sub_le_iff.1 log_two_near_10).1) (by norm_num)

end real


import algebra.associated

import abvs_equiv

import valuations.basic
import valuations.bounded
import valuations.abv_pid

import ostrowski.rationals.basic

import for_mathlib.padic_norm
import for_mathlib.int
import for_mathlib.exp_log

import number_theory.padics.padic_norm

open is_absolute_value

open_locale classical
noncomputable theory

lemma padic_norm_q (p: ℕ) (q: ℤ) [p_prime: fact (nat.prime p)] [q_prime: fact (prime q)]:
  padic_norm p q = if associated q p then 1/p else 1 :=
begin
  exact if h: associated q p
    then by {
      rw show padic_norm p q = padic_norm p p,
      by unfreezingI {
        rcases h.symm with ⟨ u, rfl ⟩,
        push_cast,
        rw abv_mul (padic_norm p),
        rw show padic_norm p (u: ℤ) = 1,
        by { cases units_int.values u with h h; simp [h], },
        rw mul_one,
      },
      simp [h, padic_norm.padic_norm_p_of_prime p],
    }
    else by {
      unfold padic_norm,
      unfold padic_val_rat,
      have: multiplicity (p: ℤ) q = 0,
      {
        have p_int_prime: prime (p: ℤ) := nat.prime_iff_prime_int.1
          (fact_iff.1 p_prime),
        simp [h, multiplicity.multiplicity_eq_zero_of_not_dvd
          (λ h', h (primes_associated_of_dvd p_int_prime (fact_iff.1 q_prime) h').symm)],
      },
      simp [h, (fact_iff.1 p_prime).1, (fact_iff.1 q_prime).1, (fact_iff.1 p_prime).ne_one, this],
    },
end

def rat_padic_abv (p: ℕ) [p_prime: fact (nat.prime p)]: ℚ → ℝ := λ x: ℚ, (padic_norm p x: ℝ)

instance rat_padic_abv_is_absolute_value (p: ℕ) [p_prime: fact (nat.prime p)]:
  is_absolute_value (rat_padic_abv p) :=
begin
  exact { abv_nonneg := by { unfold rat_padic_abv, norm_cast, exact abv_nonneg (padic_norm p), },
    abv_eq_zero := by { unfold rat_padic_abv, norm_cast, intro x, exact abv_eq_zero (padic_norm p), },
    abv_add := by { unfold rat_padic_abv, norm_cast, exact abv_add (padic_norm p), },
    abv_mul := by { unfold rat_padic_abv, norm_cast, exact abv_mul (padic_norm p), } }
end

def inj_ℤ_ℚ_hom: monoid_with_zero_hom ℤ ℚ :=
{ to_fun := λ k, k,
  map_zero' := by simp,
  map_one' := by simp,
  map_mul' := by simp }

def inj_ℚ_ℝ_hom: monoid_with_zero_hom ℚ ℝ :=
{ to_fun := λ k, k,
  map_zero' := by simp,
  map_one' := by simp,
  map_mul' := by simp }

lemma rat_abs_val_one_bounded_padic (abv : ℚ → ℝ) [habv : is_absolute_value abv]
      (hnontriv: abv ≠ trivial_abs)
      (bounded: (∀ z : ℕ, abv z ≤ 1)):
      ∃ (p) [p_prime: fact (nat.prime p)], abvs_equiv abv (@rat_padic_abv p p_prime) :=
begin
  set abv': ℤ → ℝ := (λ k, abv k) with abv'_def,
  haveI: is_absolute_value abv' := {
    abv_nonneg := λ k, by { rw abv'_def, dsimp, exact abv_nonneg abv k, },
    abv_eq_zero := λ k, by {
      rw abv'_def,
      dsimp,
      have: abv k = 0 ↔ (k: ℚ) = 0 := abv_eq_zero abv,
      norm_cast at this,
      exact this,
    },
    abv_add := λ h k, by { rw abv'_def, dsimp, push_cast, exact abv_add abv h k, },
    abv_mul := λ h k, by { rw abv'_def, dsimp, push_cast, exact abv_mul abv h k, }
  },
  have bounded': ∀ k: ℤ, abv' k ≤ 1,
  {
    intro k,
    cases k.nat_abs_eq with h; rw h,
    exact bounded k.nat_abs,
    rw abv_neg abv',
    exact bounded k.nat_abs,
  },
  have nontrivial': ∃ k: ℤ, k ≠ 0 ∧ abv' k ≠ 1,
  {
    by_contra h,
    push_neg at h,
    have h_abv: ∀ k: ℤ, k ≠ 0 → abv k = 1,
    from λ k hk, abv'_def ▸ h k hk,
    apply hnontriv,
    ext,
    exact if hx: x = 0
      then by { unfold trivial_abs, simp [hx, abv_zero abv], }
      else by {
        revert x,
        rw rat.forall,
        intros a b,
        intro h',
        have: a ≠ 0 ∧ b ≠ 0,
        {
          by_contra h,
          rw not_and_distrib at h,
          push_neg at h,
          apply h',
          simp [h],
        },
        unfold trivial_abs,
        simp [abv_div abv, h_abv a this.1, h_abv b this.2, this],
      },
  },

  obtain ⟨ p, p_prime, equiv ⟩: ∃ (p: ℤ) [p_prime: fact (prime p)],
    abvs_equiv abv' (@sample_padic_abv _ _ _ _ p p_prime),
  from abv_bounded_padic abv' bounded' nontrivial',
  haveI p_abs_prime: fact (p.nat_abs.prime) := fact_iff.2 (int.prime_iff_nat_abs_prime.1 (fact_iff.1 p_prime)),
  use [p.nat_abs, p_abs_prime],
  have p_abs_pos: 0 < (p.nat_abs: ℝ),
  { norm_cast, exact (gt_iff_lt.1 $ int.nat_abs_pos_of_ne_zero (fact_iff.1 p_prime).1), },

  rcases equiv with ⟨ α, α_pos, h ⟩,
  have eq_α: ∀ x, (abv' x) ^ α = sample_padic_abv p x,
  { rw ← h, exact λ x, rfl, },
  set β := real.log (1/p.nat_abs) / real.log (1/2) with β_def,
  have β_pos: 0 < β,
  {
    refine div_pos_of_neg_of_neg
      (real.log_neg (div_pos zero_lt_one p_abs_pos) $ (div_lt_one p_abs_pos).2 _)
      (real.log_neg one_half_pos $ (div_lt_one _).2 one_lt_two),
    norm_cast, exact nat.prime.one_lt (fact_iff.1 p_abs_prime),
    exact zero_lt_two,
  },
  have αβ_pos: 0 < α * β := mul_pos α_pos β_pos,

  have eq_β: ∀ x, sample_padic_abv p x ^ β = @rat_padic_abv p.nat_abs p_abs_prime x,
  {
    unfold rat_padic_abv,
    suffices: (λ x, sample_padic_abv p x ^ β) = (λ x, padic_norm p.nat_abs x),
    {
      intro x,
      have: (λ x, sample_padic_abv p x ^ β) x = (λ x, padic_norm p.nat_abs x) x,
      by rw this,
      exact this,
    },
    haveI: fact (nat.prime p.nat_abs) := p_abs_prime,
    set φ₁ := hom_of_equiv (hom_of_abv (sample_padic_abv p)) β β_pos
      (by {
        have φ_f: sample_padic_abv p = hom_of_abv (sample_padic_abv p) := rfl,
        rw ← φ_f,
        exact abv_nonneg (sample_padic_abv p),
      }) with φ₁_def,
    set φ₂ := (inj_ℚ_ℝ_hom.comp $ hom_of_abv (padic_norm p.nat_abs)).comp inj_ℤ_ℚ_hom with φ₂_def,
    have φ₁_f: (λ x, sample_padic_abv p x ^ β) = φ₁ := rfl,
    have φ₂_f: (λ k: ℤ, (padic_norm p.nat_abs k: ℝ)) = φ₂ := rfl,
    rw [φ₁_f, φ₂_f],
    suffices: φ₁ = φ₂, by rw this,
    apply ext_hom_primes,
    {
      rw [← φ₁_f, ← φ₂_f],
      dsimp,
      intro u,
      cases units_int.values u with h h;
      simp [h, abv_neg (sample_padic_abv p), abv_one (sample_padic_abv p)],
    },
    {
      intros q hq,
      haveI q_prime := fact_iff.2 (principal_ideal_ring.irreducible_iff_prime.1 hq),
      rw [← φ₁_f, ← φ₂_f],
      dsimp,
      haveI : fact (prime p.nat_abs) := fact_iff.2 (nat.prime_iff.1 (fact_iff.1 p_abs_prime)),
      rw padic_norm_q p.nat_abs q,
      rw sample_padic_abv_on_primes p q (fact_iff.1 q_prime),
      exact if h: associated q p
        then by {
          have: associated q p.nat_abs,
          from associated.trans h (int.associated_nat_abs p),
          simp only [h, this, rat.cast_coe_nat, rat.cast_div,
            rat.cast_one, if_true, eq_self_iff_true],
          rw β_def,
          apply log_inj_pos (real.rpow_pos_of_pos one_half_pos _)
            (div_pos zero_lt_one p_abs_pos),
          rw real.log_rpow one_half_pos,
          calc real.log (1/p.nat_abs) / real.log (1/2) * real.log (1/2)
            = real.log (1/p.nat_abs) * (real.log (1/2) / real.log (1/2)) : by ring
            ... = real.log (1/p.nat_abs) : by rw [div_self (real.log_ne_zero_of_ne_one
              (1/2) one_half_pos $ ne_of_lt one_half_lt_one), mul_one],
        }
        else by {
          have: ¬ associated q p.nat_abs,
          from λ h', h (associated.trans h' $ associated.symm $ int.associated_nat_abs _),
          simp [h, this],
        },
    },
  },

  use [α*β, αβ_pos],
  apply funext,
  rw rat.forall,
  intros a b,
  rw [abv_div abv, abv_div (rat_padic_abv _)],
  {
    rw real.div_rpow (abv_nonneg abv _) (abv_nonneg abv _),
    rw real.rpow_mul (abv_nonneg abv _),
    rw real.rpow_mul (abv_nonneg abv _),
    rw [eq_α a, eq_α b, eq_β a, eq_β b],
  },
  -- I didn't find a way to make the typeclasses work :/
  -- But, I did. :-)
  exact rat_padic_abv_is_absolute_value p.nat_abs,
end


/-
Copyright (c) 2021 Manuel Candales. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Manuel Candales, Benjamin Davidson
-/
import geometry.euclidean.triangle

/-!
# Spheres

This file proves basic geometrical results about distances and angles
in spheres in real inner product spaces and Euclidean affine spaces.

## Main theorems

* `mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_pi`: Intersecting Chords Theorem (Freek No. 55).
* `mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_zero`: Intersecting Secants Theorem.
* `mul_dist_add_mul_dist_eq_mul_dist_of_cospherical`: Ptolemy’s Theorem (Freek No. 95).

TODO: The current statement of Ptolemy’s theorem works around the lack of a "cyclic polygon" concept
in mathlib, which is what the theorem statement would naturally use (or two such concepts, since
both a strict version, where all vertices must be distinct, and a weak version, where consecutive
vertices may be equal, would be useful; Ptolemy's theorem should then use the weak one).

An API needs to be built around that concept, which would include:
- strict cyclic implies weak cyclic,
- weak cyclic and consecutive points distinct implies strict cyclic,
- weak/strict cyclic implies weak/strict cyclic for any subsequence,
- any three points on a sphere are weakly or strictly cyclic according to whether they are distinct,
- any number of points on a sphere intersected with a two-dimensional affine subspace are cyclic in
  some order,
- a list of points is cyclic if and only if its reversal is,
- a list of points is cyclic if and only if any cyclic permutation is, while other permutations
  are not when the points are distinct,
- a point P where the diagonals of a cyclic polygon cross exists (and is unique) with weak/strict
  betweenness depending on weak/strict cyclicity,
- four points on a sphere with such a point P are cyclic in the appropriate order,
and so on.
-/

open real
open_locale euclidean_geometry real_inner_product_space real

variables {V : Type*} [inner_product_space ℝ V]

namespace inner_product_geometry

/-!
### Geometrical results on spheres in real inner product spaces

This section develops some results on spheres in real inner product spaces,
which are used to deduce corresponding results for Euclidean affine spaces.
-/

lemma mul_norm_eq_abs_sub_sq_norm {x y z : V}
  (h₁ : ∃ k : ℝ, k ≠ 1 ∧ x + y = k • (x - y)) (h₂ : ∥z - y∥ = ∥z + y∥) :
  ∥x - y∥ * ∥x + y∥ = |∥z + y∥ ^ 2 - ∥z - x∥ ^ 2| :=
begin
  obtain ⟨k, hk_ne_one, hk⟩ := h₁,
  let r := (k - 1)⁻¹ * (k + 1),

  have hxy : x = r • y,
  { rw [← smul_smul, eq_inv_smul_iff₀ (sub_ne_zero.mpr hk_ne_one), ← sub_eq_zero],
    calc  (k - 1) • x - (k + 1) • y
        = (k • x - x) - (k • y + y) : by simp_rw [sub_smul, add_smul, one_smul]
    ... = (k • x - k • y) - (x + y) : by simp_rw [← sub_sub, sub_right_comm]
    ... = k • (x - y) - (x + y)     : by rw ← smul_sub k x y
    ... = 0                         : sub_eq_zero.mpr hk.symm },

  have hzy : ⟪z, y⟫ = 0,
    by rwa [inner_eq_zero_iff_angle_eq_pi_div_two, ← norm_add_eq_norm_sub_iff_angle_eq_pi_div_two,
      eq_comm],

  have hzx : ⟪z, x⟫ = 0 := by rw [hxy, inner_smul_right, hzy, mul_zero],

  calc  ∥x - y∥ * ∥x + y∥
      = ∥(r - 1) • y∥ * ∥(r + 1) • y∥      : by simp [sub_smul, add_smul, hxy]
  ... = ∥r - 1∥ * ∥y∥ * (∥r + 1∥ * ∥y∥)      : by simp_rw [norm_smul]
  ... = ∥r - 1∥ * ∥r + 1∥ * ∥y∥ ^ 2         : by ring
  ... = |(r - 1) * (r + 1) * ∥y∥ ^ 2| : by simp [abs_mul, norm_eq_abs]
  ... = |r ^ 2 * ∥y∥ ^ 2 - ∥y∥ ^ 2|    : by ring_nf
  ... = |∥x∥ ^ 2 - ∥y∥ ^ 2|            : by simp [hxy, norm_smul, mul_pow, norm_eq_abs, sq_abs]
  ... = |∥z + y∥ ^ 2 - ∥z - x∥ ^ 2|    : by simp [norm_add_sq_real, norm_sub_sq_real,
                                                    hzy, hzx, abs_sub_comm],
end

end inner_product_geometry

namespace euclidean_geometry

/-!
### Geometrical results on spheres in Euclidean affine spaces

This section develops some results on spheres in Euclidean affine spaces.
-/

open inner_product_geometry

variables {P : Type*} [metric_space P] [normed_add_torsor V P]
include V

/-- If `P` is a point on the line `AB` and `Q` is equidistant from `A` and `B`, then
`AP * BP = abs (BQ ^ 2 - PQ ^ 2)`. -/
lemma mul_dist_eq_abs_sub_sq_dist {a b p q : P}
  (hp : ∃ k : ℝ, k ≠ 1 ∧ b -ᵥ p = k • (a -ᵥ p)) (hq : dist a q = dist b q) :
  dist a p * dist b p = |dist b q ^ 2 - dist p q ^ 2| :=
begin
  let m : P := midpoint ℝ a b,
  obtain ⟨v, h1, h2, h3⟩ := ⟨vsub_sub_vsub_cancel_left, v a p m, v p q m, v a q m⟩,
  have h : ∀ r, b -ᵥ r = (m -ᵥ r) + (m -ᵥ a) :=
    λ r, by rw [midpoint_vsub_left, ← right_vsub_midpoint, add_comm, vsub_add_vsub_cancel],
  iterate 4 { rw dist_eq_norm_vsub V },
  rw [← h1, ← h2, h, h],
  rw [← h1, h] at hp,
  rw [dist_eq_norm_vsub V a q, dist_eq_norm_vsub V b q, ← h3, h] at hq,
  exact mul_norm_eq_abs_sub_sq_norm hp hq,
end

/-- If `A`, `B`, `C`, `D` are cospherical and `P` is on both lines `AB` and `CD`, then
`AP * BP = CP * DP`. -/
lemma mul_dist_eq_mul_dist_of_cospherical {a b c d p : P}
  (h : cospherical ({a, b, c, d} : set P))
  (hapb : ∃ k₁ : ℝ, k₁ ≠ 1 ∧ b -ᵥ p = k₁ • (a -ᵥ p))
  (hcpd : ∃ k₂ : ℝ, k₂ ≠ 1 ∧ d -ᵥ p = k₂ • (c -ᵥ p)) :
  dist a p * dist b p = dist c p * dist d p :=
begin
  obtain ⟨q, r, h'⟩ := (cospherical_def {a, b, c, d}).mp h,
  obtain ⟨ha, hb, hc, hd⟩ := ⟨h' a _, h' b _, h' c _, h' d _⟩,
  { rw ← hd at hc,
    rw ← hb at ha,
    rw [mul_dist_eq_abs_sub_sq_dist hapb ha, hb, mul_dist_eq_abs_sub_sq_dist hcpd hc, hd] },
  all_goals { simp },
end

/-- **Intersecting Chords Theorem**. -/
theorem mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_pi {a b c d p : P}
  (h : cospherical ({a, b, c, d} : set P))
  (hapb : ∠ a p b = π) (hcpd : ∠ c p d = π) :
  dist a p * dist b p = dist c p * dist d p :=
begin
  obtain ⟨-, k₁, _, hab⟩ := angle_eq_pi_iff.mp hapb,
  obtain ⟨-, k₂, _, hcd⟩ := angle_eq_pi_iff.mp hcpd,
  exact mul_dist_eq_mul_dist_of_cospherical h ⟨k₁, (by linarith), hab⟩ ⟨k₂, (by linarith), hcd⟩,
end

/-- **Intersecting Secants Theorem**. -/
theorem mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_zero {a b c d p : P}
  (h : cospherical ({a, b, c, d} : set P))
  (hab : a ≠ b) (hcd : c ≠ d) (hapb : ∠ a p b = 0) (hcpd : ∠ c p d = 0) :
  dist a p * dist b p = dist c p * dist d p :=
begin
  obtain ⟨-, k₁, -, hab₁⟩ := angle_eq_zero_iff.mp hapb,
  obtain ⟨-, k₂, -, hcd₁⟩ := angle_eq_zero_iff.mp hcpd,
  refine mul_dist_eq_mul_dist_of_cospherical h ⟨k₁, _, hab₁⟩ ⟨k₂, _, hcd₁⟩;
  by_contra hnot;
  simp only [not_not, *, one_smul] at *,
  exacts [hab (vsub_left_cancel hab₁).symm, hcd (vsub_left_cancel hcd₁).symm],
end

/-- **Ptolemy’s Theorem**. -/
theorem mul_dist_add_mul_dist_eq_mul_dist_of_cospherical {a b c d p : P}
  (h : cospherical ({a, b, c, d} : set P))
  (hapc : ∠ a p c = π) (hbpd : ∠ b p d = π) :
  dist a b * dist c d + dist b c * dist d a = dist a c * dist b d :=
begin
  have h' : cospherical ({a, c, b, d} : set P), { rwa set.insert_comm c b {d} },
  have hmul := mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_pi h' hapc hbpd,
  have hbp := left_dist_ne_zero_of_angle_eq_pi hbpd,
  have h₁ : dist c d = dist c p / dist b p * dist a b,
  { rw [dist_mul_of_eq_angle_of_dist_mul b p a c p d, dist_comm a b],
    { rw [angle_eq_angle_of_angle_eq_pi_of_angle_eq_pi hbpd hapc, angle_comm] },
    all_goals { field_simp [mul_comm, hmul] } },
  have h₂ : dist d a = dist a p / dist b p * dist b c,
  { rw [dist_mul_of_eq_angle_of_dist_mul c p b d p a, dist_comm c b],
    { rwa [angle_comm, angle_eq_angle_of_angle_eq_pi_of_angle_eq_pi], rwa angle_comm },
    all_goals { field_simp [mul_comm, hmul] } },
  have h₃ : dist d p = dist a p * dist c p / dist b p, { field_simp [mul_comm, hmul] },
  have h₄ : ∀ x y : ℝ, x * (y * x) = x * x * y := λ x y, by rw [mul_left_comm, mul_comm],
  field_simp [h₁, h₂, dist_eq_add_dist_of_angle_eq_pi hbpd, h₃, hbp, dist_comm a b,
              h₄, ← sq, dist_sq_mul_dist_add_dist_sq_mul_dist b, hapc],
end

end euclidean_geometry


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/

import algebra.polynomial.big_operators
import algebra.squarefree
import field_theory.minpoly
import field_theory.splitting_field
import data.polynomial.expand

/-!

# Separable polynomials

We define a polynomial to be separable if it is coprime with its derivative. We prove basic
properties about separable polynomials here.

## Main definitions

* `polynomial.separable f`: a polynomial `f` is separable iff it is coprime with its derivative.
* `polynomial.expand R p f`: expand the polynomial `f` with coefficients in a
  commutative semiring `R` by a factor of p, so `expand R p (∑ aₙ xⁿ)` is `∑ aₙ xⁿᵖ`.
* `polynomial.contract p f`: the opposite of `expand`, so it sends `∑ aₙ xⁿᵖ` to `∑ aₙ xⁿ`.

-/

universes u v w
open_locale classical big_operators polynomial
open finset

namespace polynomial

section comm_semiring

variables {R : Type u} [comm_semiring R] {S : Type v} [comm_semiring S]

/-- A polynomial is separable iff it is coprime with its derivative. -/
def separable (f : R[X]) : Prop :=
is_coprime f f.derivative

lemma separable_def (f : R[X]) :
  f.separable ↔ is_coprime f f.derivative :=
iff.rfl

lemma separable_def' (f : R[X]) :
  f.separable ↔ ∃ a b : R[X], a * f + b * f.derivative = 1 :=
iff.rfl

lemma not_separable_zero [nontrivial R] : ¬ separable (0 : R[X]) :=
begin
  rintro ⟨x, y, h⟩,
  simpa only [derivative_zero, mul_zero, add_zero, zero_ne_one] using h,
end

lemma separable_one : (1 : R[X]).separable :=
is_coprime_one_left

@[nontriviality] lemma separable_of_subsingleton [subsingleton R] (f : R[X]) :
  f.separable := by simp [separable]

lemma separable_X_add_C (a : R) : (X + C a).separable :=
by { rw [separable_def, derivative_add, derivative_X, derivative_C, add_zero],
  exact is_coprime_one_right }

lemma separable_X : (X : R[X]).separable :=
by { rw [separable_def, derivative_X], exact is_coprime_one_right }

lemma separable_C (r : R) : (C r).separable ↔ is_unit r :=
by rw [separable_def, derivative_C, is_coprime_zero_right, is_unit_C]

lemma separable.of_mul_left {f g : R[X]} (h : (f * g).separable) : f.separable :=
begin
  have := h.of_mul_left_left, rw derivative_mul at this,
  exact is_coprime.of_mul_right_left (is_coprime.of_add_mul_left_right this)
end

lemma separable.of_mul_right {f g : R[X]} (h : (f * g).separable) : g.separable :=
by { rw mul_comm at h, exact h.of_mul_left }

lemma separable.of_dvd {f g : R[X]} (hf : f.separable) (hfg : g ∣ f) : g.separable :=
by { rcases hfg with ⟨f', rfl⟩, exact separable.of_mul_left hf }

lemma separable_gcd_left {F : Type*} [field F] {f : F[X]}
  (hf : f.separable) (g : F[X]) : (euclidean_domain.gcd f g).separable :=
separable.of_dvd hf (euclidean_domain.gcd_dvd_left f g)

lemma separable_gcd_right {F : Type*} [field F] {g : F[X]}
  (f : F[X]) (hg : g.separable) : (euclidean_domain.gcd f g).separable :=
separable.of_dvd hg (euclidean_domain.gcd_dvd_right f g)

lemma separable.is_coprime {f g : R[X]} (h : (f * g).separable) : is_coprime f g :=
begin
  have := h.of_mul_left_left, rw derivative_mul at this,
  exact is_coprime.of_mul_right_right (is_coprime.of_add_mul_left_right this)
end

theorem separable.of_pow' {f : R[X]} :
  ∀ {n : ℕ} (h : (f ^ n).separable), is_unit f ∨ (f.separable ∧ n = 1) ∨ n = 0
| 0     := λ h, or.inr $ or.inr rfl
| 1     := λ h, or.inr $ or.inl ⟨pow_one f ▸ h, rfl⟩
| (n+2) := λ h, by { rw [pow_succ, pow_succ] at h,
    exact or.inl (is_coprime_self.1 h.is_coprime.of_mul_right_left) }

theorem separable.of_pow {f : R[X]} (hf : ¬is_unit f) {n : ℕ} (hn : n ≠ 0)
  (hfs : (f ^ n).separable) : f.separable ∧ n = 1 :=
(hfs.of_pow'.resolve_left hf).resolve_right hn

theorem separable.map {p : R[X]} (h : p.separable) {f : R →+* S} : (p.map f).separable :=
let ⟨a, b, H⟩ := h in ⟨a.map f, b.map f,
by rw [derivative_map, ← polynomial.map_mul, ← polynomial.map_mul, ← polynomial.map_add, H,
       polynomial.map_one]⟩

variables (p q : ℕ)

lemma is_unit_of_self_mul_dvd_separable {p q : R[X]}
  (hp : p.separable) (hq : q * q ∣ p) : is_unit q :=
begin
  obtain ⟨p, rfl⟩ := hq,
  apply is_coprime_self.mp,
  have : is_coprime (q * (q * p)) (q * (q.derivative * p + q.derivative * p + q * p.derivative)),
  { simp only [← mul_assoc, mul_add],
    convert hp,
    rw [derivative_mul, derivative_mul],
    ring },
  exact is_coprime.of_mul_right_left (is_coprime.of_mul_left_left this)
end

lemma multiplicity_le_one_of_separable {p q : R[X]} (hq : ¬ is_unit q)
  (hsep : separable p) : multiplicity q p ≤ 1 :=
begin
  contrapose! hq,
  apply is_unit_of_self_mul_dvd_separable hsep,
  rw ← sq,
  apply multiplicity.pow_dvd_of_le_multiplicity,
  simpa only [nat.cast_one, nat.cast_bit0] using enat.add_one_le_of_lt hq
end

lemma separable.squarefree {p : R[X]} (hsep : separable p) : squarefree p :=
begin
  rw multiplicity.squarefree_iff_multiplicity_le_one p,
  intro f,
  by_cases hunit : is_unit f,
  { exact or.inr hunit },
  exact or.inl (multiplicity_le_one_of_separable hunit hsep)
end

end comm_semiring

section comm_ring

variables {R : Type u} [comm_ring R]

lemma separable_X_sub_C {x : R} : separable (X - C x) :=
by simpa only [sub_eq_add_neg, C_neg] using separable_X_add_C (-x)

lemma separable.mul {f g : R[X]} (hf : f.separable) (hg : g.separable)
  (h : is_coprime f g) : (f * g).separable :=
by { rw [separable_def, derivative_mul], exact ((hf.mul_right h).add_mul_left_right _).mul_left
  ((h.symm.mul_right hg).mul_add_right_right _) }

lemma separable_prod' {ι : Sort*} {f : ι → R[X]} {s : finset ι} :
  (∀x∈s, ∀y∈s, x ≠ y → is_coprime (f x) (f y)) → (∀x∈s, (f x).separable) →
  (∏ x in s, f x).separable :=
finset.induction_on s (λ _ _, separable_one) $ λ a s has ih h1 h2, begin
  simp_rw [finset.forall_mem_insert, forall_and_distrib] at h1 h2, rw prod_insert has,
  exact h2.1.mul (ih h1.2.2 h2.2) (is_coprime.prod_right $ λ i his, h1.1.2 i his $
    ne.symm $ ne_of_mem_of_not_mem his has)
end

lemma separable_prod {ι : Sort*} [fintype ι] {f : ι → R[X]}
  (h1 : pairwise (is_coprime on f)) (h2 : ∀ x, (f x).separable) : (∏ x, f x).separable :=
separable_prod' (λ x hx y hy hxy, h1 x y hxy) (λ x hx, h2 x)

lemma separable.inj_of_prod_X_sub_C [nontrivial R] {ι : Sort*} {f : ι → R} {s : finset ι}
  (hfs : (∏ i in s, (X - C (f i))).separable)
  {x y : ι} (hx : x ∈ s) (hy : y ∈ s) (hfxy : f x = f y) : x = y :=
begin
  by_contra hxy,
  rw [← insert_erase hx, prod_insert (not_mem_erase _ _),
      ← insert_erase (mem_erase_of_ne_of_mem (ne.symm hxy) hy),
      prod_insert (not_mem_erase _ _), ← mul_assoc, hfxy, ← sq] at hfs,
  cases (hfs.of_mul_left.of_pow (by exact not_is_unit_X_sub_C _) two_ne_zero).2
end

lemma separable.injective_of_prod_X_sub_C [nontrivial R] {ι : Sort*} [fintype ι] {f : ι → R}
  (hfs : (∏ i, (X - C (f i))).separable) : function.injective f :=
λ x y hfxy, hfs.inj_of_prod_X_sub_C (mem_univ _) (mem_univ _) hfxy

lemma nodup_of_separable_prod [nontrivial R] {s : multiset R}
  (hs : separable (multiset.map (λ a, X - C a) s).prod) : s.nodup :=
begin
  rw multiset.nodup_iff_ne_cons_cons,
  rintros a t rfl,
  refine not_is_unit_X_sub_C a (is_unit_of_self_mul_dvd_separable hs _),
  simpa only [multiset.map_cons, multiset.prod_cons] using mul_dvd_mul_left _ (dvd_mul_right _ _)
end

/--If `is_unit n` in a `comm_ring R`, then `X ^ n - u` is separable for any unit `u`. -/
lemma separable_X_pow_sub_C_unit {n : ℕ} (u : Rˣ) (hn : is_unit (n : R)) :
  separable (X ^ n - C (u : R)) :=
begin
  nontriviality R,
  rcases n.eq_zero_or_pos with rfl | hpos,
  { simpa using hn },
  apply (separable_def' (X ^ n - C (u : R))).2,
  obtain ⟨n', hn'⟩ := hn.exists_left_inv,
  refine ⟨-C ↑u⁻¹, C ↑u⁻¹ * C n' * X, _⟩,
  rw [derivative_sub, derivative_C, sub_zero, derivative_pow X n, derivative_X, mul_one],
  calc  - C ↑u⁻¹ * (X ^ n - C ↑u) + C ↑u⁻¹ * C n' * X * (↑n * X ^ (n - 1))
      = C (↑u⁻¹ * ↑ u) - C ↑u⁻¹ * X^n + C ↑ u ⁻¹ * C (n' * ↑n) * (X * X ^ (n - 1)) :
    by { simp only [C.map_mul, C_eq_nat_cast], ring }
  ... = 1 : by simp only [units.inv_mul, hn', C.map_one, mul_one, ← pow_succ,
              nat.sub_add_cancel (show 1 ≤ n, from hpos), sub_add_cancel]
end

lemma root_multiplicity_le_one_of_separable [nontrivial R] {p : R[X]}
  (hsep : separable p) (x : R) : root_multiplicity x p ≤ 1 :=
begin
  by_cases hp : p = 0,
  { simp [hp], },
  rw [root_multiplicity_eq_multiplicity, dif_neg hp, ← enat.coe_le_coe, enat.coe_get, nat.cast_one],
  exact multiplicity_le_one_of_separable (not_is_unit_X_sub_C _) hsep
end

end comm_ring

section is_domain

variables {R : Type u} [comm_ring R] [is_domain R]

lemma count_roots_le_one {p : R[X]} (hsep : separable p) (x : R) :
  p.roots.count x ≤ 1 :=
begin
  rw count_roots p,
  exact root_multiplicity_le_one_of_separable hsep x
end

lemma nodup_roots {p : R[X]} (hsep : separable p) : p.roots.nodup :=
multiset.nodup_iff_count_le_one.mpr (count_roots_le_one hsep)

end is_domain

section field

variables {F : Type u} [field F] {K : Type v} [field K]

theorem separable_iff_derivative_ne_zero {f : F[X]} (hf : irreducible f) :
  f.separable ↔ f.derivative ≠ 0 :=
⟨λ h1 h2, hf.not_unit $ is_coprime_zero_right.1 $ h2 ▸ h1,
  λ h, euclidean_domain.is_coprime_of_dvd (mt and.right h) $ λ g hg1 hg2 ⟨p, hg3⟩ hg4,
let ⟨u, hu⟩ := (hf.is_unit_or_is_unit hg3).resolve_left hg1 in
  have f ∣ f.derivative, by { conv_lhs { rw [hg3, ← hu] }, rwa units.mul_right_dvd },
  not_lt_of_le (nat_degree_le_of_dvd this h) $
  nat_degree_derivative_lt $ mt derivative_of_nat_degree_zero h⟩

theorem separable_map (f : F →+* K) {p : F[X]} : (p.map f).separable ↔ p.separable :=
by simp_rw [separable_def, derivative_map, is_coprime_map]

lemma separable_prod_X_sub_C_iff' {ι : Sort*} {f : ι → F} {s : finset ι} :
  (∏ i in s, (X - C (f i))).separable ↔ (∀ (x ∈ s) (y ∈ s), f x = f y → x = y) :=
⟨λ hfs x hx y hy hfxy, hfs.inj_of_prod_X_sub_C hx hy hfxy,
λ H, by { rw ← prod_attach, exact separable_prod' (λ x hx y hy hxy,
    @pairwise_coprime_X_sub_C _ _ { x // x ∈ s } (λ x, f x)
      (λ x y hxy, subtype.eq $ H x.1 x.2 y.1 y.2 hxy) _ _ hxy)
  (λ _ _, separable_X_sub_C) }⟩

lemma separable_prod_X_sub_C_iff {ι : Sort*} [fintype ι] {f : ι → F} :
  (∏ i, (X - C (f i))).separable ↔ function.injective f :=
separable_prod_X_sub_C_iff'.trans $ by simp_rw [mem_univ, true_implies_iff, function.injective]

section char_p

variables (p : ℕ) [HF : char_p F p]
include HF

theorem separable_or {f : F[X]} (hf : irreducible f) : f.separable ∨
  ¬f.separable ∧ ∃ g : F[X], irreducible g ∧ expand F p g = f :=
if H : f.derivative = 0 then
begin
  unfreezingI { rcases p.eq_zero_or_pos with rfl | hp },
  { haveI := char_p.char_p_to_char_zero F,
    have := nat_degree_eq_zero_of_derivative_eq_zero H,
    have := (nat_degree_pos_iff_degree_pos.mpr $ degree_pos_of_irreducible hf).ne',
    contradiction },
  haveI := is_local_ring_hom_expand F hp,
  exact or.inr
        ⟨by rw [separable_iff_derivative_ne_zero hf, not_not, H],
        contract p f,
        of_irreducible_map ↑(expand F p) (by rwa ← expand_contract p H hp.ne' at hf),
        expand_contract p H hp.ne'⟩
end
else or.inl $ (separable_iff_derivative_ne_zero hf).2 H

theorem exists_separable_of_irreducible {f : F[X]} (hf : irreducible f) (hp : p ≠ 0) :
  ∃ (n : ℕ) (g : F[X]), g.separable ∧ expand F (p ^ n) g = f :=
begin
  replace hp : p.prime := (char_p.char_is_prime_or_zero F p).resolve_right hp,
  unfreezingI
  { induction hn : f.nat_degree using nat.strong_induction_on with N ih generalizing f },
  rcases separable_or p hf with h | ⟨h1, g, hg, hgf⟩,
  { refine ⟨0, f, h, _⟩, rw [pow_zero, expand_one] },
  { cases N with N,
    { rw [nat_degree_eq_zero_iff_degree_le_zero, degree_le_zero_iff] at hn,
      rw [hn, separable_C, is_unit_iff_ne_zero, not_not] at h1,
      have hf0 : f ≠ 0 := hf.ne_zero,
      rw [h1, C_0] at hn, exact absurd hn hf0 },
    have hg1 : g.nat_degree * p = N.succ,
    { rwa [← nat_degree_expand, hgf] },
    have hg2 : g.nat_degree ≠ 0,
    { intro this, rw [this, zero_mul] at hg1, cases hg1 },
    have hg3 : g.nat_degree < N.succ,
    { rw [← mul_one g.nat_degree, ← hg1],
      exact nat.mul_lt_mul_of_pos_left hp.one_lt hg2.bot_lt },
    rcases ih _ hg3 hg rfl with ⟨n, g, hg4, rfl⟩, refine ⟨n+1, g, hg4, _⟩,
    rw [← hgf, expand_expand, pow_succ] }
end

theorem is_unit_or_eq_zero_of_separable_expand {f : F[X]} (n : ℕ) (hp : 0 < p)
  (hf : (expand F (p ^ n) f).separable) : is_unit f ∨ n = 0 :=
begin
  rw or_iff_not_imp_right,
  rintro hn : n ≠ 0,
  have hf2 : (expand F (p ^ n) f).derivative = 0,
  { rw [derivative_expand, nat.cast_pow, char_p.cast_eq_zero,
      zero_pow hn.bot_lt, zero_mul, mul_zero] },
  rw [separable_def, hf2, is_coprime_zero_right, is_unit_iff] at hf,
  rcases hf with ⟨r, hr, hrf⟩,
  rw [eq_comm, expand_eq_C (pow_pos hp _)] at hrf,
  rwa [hrf, is_unit_C]
end

theorem unique_separable_of_irreducible {f : F[X]} (hf : irreducible f) (hp : 0 < p)
  (n₁ : ℕ) (g₁ : F[X]) (hg₁ : g₁.separable) (hgf₁ : expand F (p ^ n₁) g₁ = f)
  (n₂ : ℕ) (g₂ : F[X]) (hg₂ : g₂.separable) (hgf₂ : expand F (p ^ n₂) g₂ = f) :
  n₁ = n₂ ∧ g₁ = g₂ :=
begin
  revert g₁ g₂,
  wlog hn : n₁ ≤ n₂ := le_total n₁ n₂ using [n₁ n₂, n₂ n₁],
  have hf0 : f ≠ 0 := hf.ne_zero,
  unfreezingI { intros, rw le_iff_exists_add at hn, rcases hn with ⟨k, rfl⟩,
    rw [← hgf₁, pow_add, expand_mul, expand_inj (pow_pos hp n₁)] at hgf₂, subst hgf₂,
    subst hgf₁,
    rcases is_unit_or_eq_zero_of_separable_expand p k hp hg₁ with h | rfl,
    { rw is_unit_iff at h, rcases h with ⟨r, hr, rfl⟩,
      simp_rw expand_C at hf, exact absurd (is_unit_C.2 hr) hf.1 },
    { rw [add_zero, pow_zero, expand_one], split; refl } },
  obtain ⟨hn, hg⟩ := this g₂ g₁ hg₂ hgf₂ hg₁ hgf₁,
  exact ⟨hn.symm, hg.symm⟩
end

end char_p

/--If `n ≠ 0` in `F`, then ` X ^ n - a` is separable for any `a ≠ 0`. -/
lemma separable_X_pow_sub_C {n : ℕ} (a : F) (hn : (n : F) ≠ 0) (ha : a ≠ 0) :
  separable (X ^ n - C a) :=
separable_X_pow_sub_C_unit (units.mk0 a ha) (is_unit.mk0 n hn)

-- this can possibly be strengthened to making `separable_X_pow_sub_C_unit` a
-- bi-implication, but it is nontrivial!
/-- In a field `F`, `X ^ n - 1` is separable iff `↑n ≠ 0`. -/
lemma X_pow_sub_one_separable_iff {n : ℕ} :
  (X ^ n - 1 : F[X]).separable ↔ (n : F) ≠ 0 :=
begin
  refine ⟨_, λ h, separable_X_pow_sub_C_unit 1 (is_unit.mk0 ↑n h)⟩,
  rw [separable_def', derivative_sub, derivative_X_pow, derivative_one, sub_zero],
  -- Suppose `(n : F) = 0`, then the derivative is `0`, so `X ^ n - 1` is a unit, contradiction.
  rintro (h : is_coprime _ _) hn',
  rw [← C_eq_nat_cast, hn', C.map_zero, zero_mul, is_coprime_zero_right] at h,
  have := not_is_unit_X_pow_sub_one F n,
  contradiction
end

section splits

lemma card_root_set_eq_nat_degree [algebra F K] {p : F[X]} (hsep : p.separable)
  (hsplit : splits (algebra_map F K) p) : fintype.card (p.root_set K) = p.nat_degree :=
begin
  simp_rw [root_set_def, finset.coe_sort_coe, fintype.card_coe],
  rw [multiset.to_finset_card_of_nodup, ←nat_degree_eq_card_roots hsplit],
  exact nodup_roots hsep.map,
end

variable {i : F →+* K}

lemma eq_X_sub_C_of_separable_of_root_eq {x : F} {h : F[X]}
  (h_sep : h.separable) (h_root : h.eval x = 0) (h_splits : splits i h)
  (h_roots : ∀ y ∈ (h.map i).roots, y = i x) : h = (C (leading_coeff h)) * (X - C x) :=
begin
  have h_ne_zero : h ≠ 0 := by { rintro rfl, exact not_separable_zero h_sep },
  apply polynomial.eq_X_sub_C_of_splits_of_single_root i h_splits,
  apply finset.mk.inj,
  { change _ = {i x},
    rw finset.eq_singleton_iff_unique_mem,
    split,
    { apply finset.mem_mk.mpr,
      rw mem_roots (show h.map i ≠ 0, by exact map_ne_zero h_ne_zero),
      rw [is_root.def,←eval₂_eq_eval_map,eval₂_hom,h_root],
      exact ring_hom.map_zero i },
    { exact h_roots } },
  { exact nodup_roots (separable.map h_sep) },
end

lemma exists_finset_of_splits
  (i : F →+* K) {f : F[X]} (sep : separable f) (sp : splits i f) :
  ∃ (s : finset K), f.map i = C (i f.leading_coeff) * (s.prod (λ a : K, X - C a)) :=
begin
  obtain ⟨s, h⟩ := (splits_iff_exists_multiset _).1 sp,
  use s.to_finset,
  rw [h, finset.prod_eq_multiset_prod, ←multiset.to_finset_eq],
  apply nodup_of_separable_prod,
  apply separable.of_mul_right,
  rw ←h,
  exact sep.map,
end

end splits

theorem _root_.irreducible.separable [char_zero F] {f : F[X]}
  (hf : irreducible f) : f.separable :=
begin
  rw [separable_iff_derivative_ne_zero hf, ne, ← degree_eq_bot, degree_derivative_eq],
  { rintro ⟨⟩ },
  rw [pos_iff_ne_zero, ne, nat_degree_eq_zero_iff_degree_le_zero, degree_le_zero_iff],
  refine λ hf1, hf.not_unit _,
  rw [hf1, is_unit_C, is_unit_iff_ne_zero],
  intro hf2,
  rw [hf2, C_0] at hf1,
  exact absurd hf1 hf.ne_zero
end

end field

end polynomial

open polynomial

section comm_ring

variables (F K : Type*) [comm_ring F] [ring K] [algebra F K]

-- TODO: refactor to allow transcendental extensions?
-- See: https://en.wikipedia.org/wiki/Separable_extension#Separability_of_transcendental_extensions
-- Note that right now a Galois extension (class `is_galois`) is defined to be an extension which
-- is separable and normal, so if the definition of separable changes here at some point
-- to allow non-algebraic extensions, then the definition of `is_galois` must also be changed.

/-- Typeclass for separable field extension: `K` is a separable field extension of `F` iff
the minimal polynomial of every `x : K` is separable.

We define this for general (commutative) rings and only assume `F` and `K` are fields if this
is needed for a proof.
-/
class is_separable : Prop :=
(is_integral' (x : K) : is_integral F x)
(separable' (x : K) : (minpoly F x).separable)

variables (F) {K}

theorem is_separable.is_integral [is_separable F K] :
  ∀ x : K, is_integral F x := is_separable.is_integral'

theorem is_separable.separable [is_separable F K] :
  ∀ x : K, (minpoly F x).separable := is_separable.separable'

variables {F K}

theorem is_separable_iff : is_separable F K ↔ ∀ x : K, is_integral F x ∧ (minpoly F x).separable :=
⟨λ h x, ⟨@@is_separable.is_integral F _ _ _ h x, @@is_separable.separable F _ _ _ h x⟩,
 λ h, ⟨λ x, (h x).1, λ x, (h x).2⟩⟩

end comm_ring

instance is_separable_self (F : Type*) [field F] : is_separable F F :=
⟨λ x, is_integral_algebra_map, λ x, by { rw minpoly.eq_X_sub_C', exact separable_X_sub_C }⟩

/-- A finite field extension in characteristic 0 is separable. -/
@[priority 100] -- See note [lower instance priority]
instance is_separable.of_finite (F K : Type*) [field F] [field K] [algebra F K]
  [finite_dimensional F K] [char_zero F] : is_separable F K :=
have ∀ (x : K), is_integral F x,
from λ x, algebra.is_integral_of_finite _ _ _,
⟨this, λ x, (minpoly.irreducible (this x)).separable⟩

section is_separable_tower
variables (F K E : Type*) [field F] [field K] [field E] [algebra F K] [algebra F E]
  [algebra K E] [is_scalar_tower F K E]

lemma is_separable_tower_top_of_is_separable [is_separable F E] : is_separable K E :=
⟨λ x, is_integral_of_is_scalar_tower x (is_separable.is_integral F x),
 λ x, (is_separable.separable F x).map.of_dvd (minpoly.dvd_map_of_is_scalar_tower _ _ _)⟩

lemma is_separable_tower_bot_of_is_separable [h : is_separable F E] : is_separable F K :=
is_separable_iff.2 $ λ x, begin
  refine (is_separable_iff.1 h (algebra_map K E x)).imp
    is_integral_tower_bot_of_is_integral_field (λ hs, _),
  obtain ⟨q, hq⟩ := minpoly.dvd F x
    (is_scalar_tower.aeval_eq_zero_of_aeval_algebra_map_eq_zero_field
      (minpoly.aeval F ((algebra_map K E) x))),
  rw hq at hs,
  exact hs.of_mul_left
end

variables {E}

lemma is_separable.of_alg_hom (E' : Type*) [field E'] [algebra F E']
  (f : E →ₐ[F] E') [is_separable F E'] : is_separable F E :=
begin
  letI : algebra E E' := ring_hom.to_algebra f.to_ring_hom,
  haveI : is_scalar_tower F E E' := is_scalar_tower.of_algebra_map_eq (λ x, (f.commutes x).symm),
  exact is_separable_tower_bot_of_is_separable F E E',
end

end is_separable_tower

section card_alg_hom

variables {R S T : Type*} [comm_ring S]
variables {K L F : Type*} [field K] [field L] [field F]
variables [algebra K S] [algebra K L]

lemma alg_hom.card_of_power_basis (pb : power_basis K S) (h_sep : (minpoly K pb.gen).separable)
  (h_splits : (minpoly K pb.gen).splits (algebra_map K L)) :
  @fintype.card (S →ₐ[K] L) (power_basis.alg_hom.fintype pb) = pb.dim :=
begin
  let s := ((minpoly K pb.gen).map (algebra_map K L)).roots.to_finset,
  have H := λ x, multiset.mem_to_finset,
  rw [fintype.card_congr pb.lift_equiv', fintype.card_of_subtype s H,
      ← pb.nat_degree_minpoly, nat_degree_eq_card_roots h_splits, multiset.to_finset_card_of_nodup],
  exact nodup_roots ((separable_map (algebra_map K L)).mpr h_sep)
end

end card_alg_hom


import data.real.basic

-- BEGIN
example {x : ℝ} (h : x ≠ 0) : x < 0 ∨ x > 0 :=
begin
  rcases lt_trichotomy x 0 with xlt | xeq | xgt,
  { left, exact xlt },
  { contradiction },
  right,
  exact xgt,
end

/- using the cases tactic recursively -/
example {x : ℝ} (h : x ≠ 0) : x < 0 ∨ x > 0 :=
begin
  cases lt_trichotomy x 0 with xlt xle,
    left,
    exact xlt,
      cases xle with xeq xlt,
      contradiction,
    right,
    exact xlt,
end
-- END


/-
Copyright (c) 2021 Jakob von Raumer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jakob von Raumer
-/
import linear_algebra.direct_sum.finsupp
import linear_algebra.finsupp_vector_space

/-!
# Bases and dimensionality of tensor products of modules

These can not go into `linear_algebra.tensor_product` since they depend on
`linear_algebra.finsupp_vector_space` which in turn imports `linear_algebra.tensor_product`.

-/
noncomputable theory
open set linear_map submodule

section comm_ring
variables {R : Type*} {M : Type*} {N : Type*} {ι : Type*} {κ : Type*}
variables [comm_ring R] [add_comm_group M] [module R M] [add_comm_group N] [module R N]

/-- If b : ι → M and c : κ → N are bases then so is λ i, b i.1 ⊗ₜ c i.2 : ι × κ → M ⊗ N. -/
def basis.tensor_product (b : basis ι R M) (c : basis κ R N) :
  basis (ι × κ) R (tensor_product R M N) :=
finsupp.basis_single_one.map
  ((tensor_product.congr b.repr c.repr).trans $
    (finsupp_tensor_finsupp R _ _ _ _).trans $
    finsupp.lcongr (equiv.refl _) (tensor_product.lid R R)).symm

@[simp]
lemma basis.tensor_product_apply (b : basis ι R M) (c : basis κ R N) (i : ι) (j : κ) :
  basis.tensor_product b c (i, j) = b i ⊗ₜ c j :=
by simp [basis.tensor_product]

lemma basis.tensor_product_apply' (b : basis ι R M) (c : basis κ R N) (i : ι × κ) :
  basis.tensor_product b c i = b i.1 ⊗ₜ c i.2 :=
by simp [basis.tensor_product]

end comm_ring