/- Copyright (c) 2022 Sina Hazratpour. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
----------------

# Fake Integers
Sina Hazratpour
Introduction to Proof
MATH 301, Johns Hopkins University, Fall 2022
-/

import ..prooflab
import lectures.lec10_surj_inj_fact
import lectures.lec13_structures_on_gaussian_int
import lectures.lec14_inductive_naturals

import homework.hw11

/-
We will learn about the construction of __quotient by equivalence relation__. Your mission is to use this construction to develop (fake) integers from (fake) natural numbers. You do this by replacing the `sorry` placeholders in **challenges** below with your own solutions.
-/

open PROOFS
open PROOFS.STR

/-
Having constructed the type of integers `ℤ`, we can prove that there is  a surjection `mat × mat → ℤ` sending
`(m, n)` to their difference `m - n`. Check for yourself that the pairs `(m, n)`
and `(k, l)` are sent to the same integer if and only if `m + l = n + k`.
However, we are not going to use Lean's type of integers, but we will define our own ad-hoc type of integers in order to learn about quotient types in the process.
-/

@[simp]
def same_diff (a b : mat × mat) : Prop :=
a.1 + b.2 = b.1 + a.2 -- note that at this point, we can write `a.1 - a.2 = b.1 - b.2`, since we do not have the operation of additive inverse (i.e. `- a.2` does not make sense yet, since it is not defined for `mat`. However, if once we have additive inverses then `same_diff a b ↔ (a.1 - a.2 = b.1 - b.2)` which says that `a` and `b` have the same differences.  )

#check same_diff -- `same_diff` is a binary relation on `mat × mat`

#check same_diff (2,4) (1,3)

example : same_diff (2,4) (1,3) :=
begin
  simp,
  refl,
end

#check add_left_cancel

class left_cancel_additive_monoid_str (M : Type) extends additive_monoid_str M :=
(left_cancel : ∀ a b c : M, a + b = a + c → b = c)

class right_cancel_additive_monoid_str (M : Type) extends additive_monoid_str M :=
(right_cancel : ∀ a b c : M, b + a = c + a → b = c)

instance : left_cancel_additive_monoid_str mat :=
{
left_cancel :=
by
  {
    -- we want to show that for all a b c : mat if a + b = a + c then b = c.
    intros a b c habc, -- Suppose arbitrary a b c : mat are given such that a + b = a + c.
    induction a with d ihd, -- We do not have additive inverses in mat, and as such, we cannot simply subtract a from both sides of the equation. Therefore, we use induction on a.
    { -- the base case of induction
    simpa using habc, --simpa is combination of rw/simp combined with exact.
    },
    { -- the inductive step of induction
    rw [mat.succ_add, mat.succ_add] at habc, -- rewriting d.succ + b and d.succ + c as (d + b).succ and (d + c).succ respectively.
    simp at habc,
    apply ihd,
    exact habc,
    },
  }
}

lemma mat.add_left_cancel :
  ∀ a b c : mat, a + b = a + c → b = c :=
begin
  exact left_cancel_additive_monoid_str.left_cancel,
end

/-! ## Challenge
Prove that the addition operation on `mat` is __right cancellative__.
Hint: You might like to use the instance `left_cancel_additive_monoid_str mat` together with the commutativity of addition (which we proved before using induction).
-/
instance : right_cancel_additive_monoid_str mat :=
sorry

/- ## Challenge
Use the instance above to prove the lemma below.
-/

lemma mat.add_right_cancel :
  ∀ a b c : mat, b + a =  c + a → b = c :=
begin
  sorry,
end

@[simp]
def add_mon_add_left_comm (M : Type) [additive_monoid_str M] := ∀ m n k : M, m + (n + k) = n + (m + k)

/- ## Challenge
Prove that the addition operation on mat is __left commutative__ in the sense that for all `m n k : mat` we have `m + (n + k) = n + (m + k)`.
-/

@[simp]
lemma mat.add_left_comm :
  add_mon_add_left_comm mat :=
begin
  unfold add_mon_add_left_comm,
  sorry,
end

/-
It's nice to be able to rw to get rid of explicit occurrences of same_diff.So let's make two lemmas suitable for rewriting.
-/
@[simp]
lemma same_diff_defn (a b : mat × mat) :
same_diff a b ↔ (a.1 + b.2 = b.1 + a.2) :=
begin
refl,
end

-- The one below is more useful if you've already done `cases` on the pairs.
lemma same_diff_pairs_defn {a b c d : mat} :
  same_diff (a,b) (c,d) ↔ a + d = c + b :=
begin
  refl,
end

/- In below we show that the binary relation `same_diff` is an equivalence relation.-/

def same_diff_rflx : reflexive same_diff :=
begin
  unfold reflexive, -- the same as rw
  intro x,
  rw same_diff,
end

def same_diff_symm : symmetric same_diff :=
begin
  intros x y,
  intro hxy,
  rw same_diff at hxy,
  rw same_diff,
  exact hxy.symm,
end

-- an alternative proof
lemma same_diff_symm_alt : symmetric same_diff :=
begin
  rintro ⟨i, j⟩ ⟨k, l⟩ h,
  rw same_diff at h ⊢ ,
  simp at h ⊢,
  symmetry,
  assumption,
end

-- to prove transitivity we need the following lemmas
#check add_left_cancel
#check mat.add_right_cancel
#check mat.add_assoc

/- ## Challenge
Prove that `same_diff` is a transitive relation.
-/

lemma same_diff_trans : transitive same_diff :=
begin
  rintros ⟨i, j⟩ ⟨k, l⟩ ⟨m, n⟩,
  repeat {rw same_diff},
  dsimp,
  intros h₁ h₂,
  suffices : (i + n) + (l + k) = (m + j) + (l + k),
    by {apply mat.add_right_cancel _ _ _ this},
  calc i + n + (l + k) = (i + l) + (k + n) : sorry
  ...                        = (k + j) + (m + l) : sorry
  ...                        = (m + j) + (l + k) : sorry,
end

lemma same_diff_equiv :
  equivalence same_diff :=
begin
  unfold equivalence,
  repeat {split} ,
  exact same_diff_rflx,
  exact same_diff_symm,
  exact same_diff_trans,
end

/-
A __setoid__ structure on a type `X` is a tuple `⟨ρ, hρ⟩` where `ρ : X → X → Prop` is an binary relation and `hρ` a proof that `rho` is an equivalence relation. The relation `ρ` is supposed to tell us which elements of `X` are equivalent to each other.
-/

#check setoid

/-
We give `mat × mat` a setoid structure coming from the equivalence relation `same_diff`.
-/

instance mat.setoid : setoid (mat × mat) :=
⟨same_diff, same_diff_equiv⟩

/-
We can use `≈` notation. This notation is inherited from
class has_equiv X := (equiv : X → X → Prop) and

instance {X : Type} [setoid X] : has_equiv X :=
⟨setoid.r⟩
-/
example (x y : mat × mat) : x ≈ y ↔ same_diff x y :=
begin
  -- true by definition of instance `mat.setoid`
  refl,
end

/-
`same_diff x y` and `x ≈ y` are definitionally equal but not syntactically equal, rather annoyingly, so we need two more lemmas enabling us to rewrite.
-/

@[simp]
lemma equiv_def (a b : mat × mat) :
  a ≈ b ↔ a.1 + b.2 = b.1 + a.2 :=
begin
  refl,
end

@[simp]
lemma equiv_def_pair (a b c d : mat) :
  (a,b) ≈ (c,d) ↔ a + d = c + b :=
begin
  refl,
end

example : ((3 : mat), (5 : mat) ) ≈ (4, 6) :=
begin
  rw equiv_def_pair,
  refl,
end

/-! ## Building Integers Out of Natural Numbers
We can define integers out of natural numbers by the operation of taking the __quotient__ of the relation `same_diff`. Here's the idea: We essentially think of a pair `(m , n)`, where `m n : mat` as an "integer", namely by taking the "difference" `m - n`. Therefore, we stipulate that `1` corresponds to the  `(1, 0)` and `-1` corresponds to the pair `(0, 1)`. However, this is not a 1-1 correspondence; while every "integer" corresponds to a unique pair (the integer `k` corresponds to `(k, 0)` if `k` is nonnegative and to `(0, k)` if `k` is negative),  there are many pairs which correspond to the same integer. For instance the pairs of the form `(m, m)` all have the same difference, namely `0` and hence by our consideration correspond to the integer `0`. Can you find all pairs which correspond to the integer `-1`? Indeed, they are all pairs `(m , n)` where `m + 1 = n`. We would like to construct a type in which we can identify all pairs with the same difference, i.e. we want to force `(0, 0)`, `(1, 1)`, `(2, 2)`, etc to be the same in this new type. In this new type, therefore, there is a one-to-one correspondence between our idea of integers and the pairs of natural numbers. The operation of __quotient__ handles this identification.
-/

/-! ## What is quotient, really?

Let `X` be any type, and let `r` be an equivalence relation on `X`. It is mathematically common to form the __quotient__  `X/r`, that is, the type of elements of `X` "modulo" `r`. A term of `X/r` is called an __equivalence class__ and is denoted by `⟦x⟧` where `x : X`.

Note that `X/r` is not a syntax reconnizable by Lean, it is just our informal notation for the type which is the quotient of `X` by the relation `r`.

In general, there is a function `X → X/r` given by `quotient.mk` which maps `x : X` to the equivalence class
`⟦x⟧`. Our notation for `quotient.mk x` is `⟦x⟧`.
-/

#check @quotient.mk

/- We give a shorter name to `quotient.mk`-/
def qmk {X : Type} [s : setoid X] : X → quotient s  :=
quotient.mk

#check @qmk

/-
If `f : X → Y` is any function that __respects the equivalence relation__ in the sense that for every `x y : X`, the proposition `r x y` implies `f x = f y`, then the function `f : X → Y` __lifts__ to a function
`f_q : X/r → Y ` defined on each equivalence class `⟦x⟧` by `f_q ⟦x⟧ = f x`. Moreover, `f_q ∘ quotient.mk = f`.

The main use of `qlift` is to define functions out of a quotient type, say `X/≈`. To do this, we define a function out of `X` and prove that it respects the relation ~.
A function `g : X/≈  → Y` is equivalent to a function `f : X → Y` with the property that `f x = f y` for all `x y : X` with `x ∼ y`.

In particular, given such a function `f` and proof `hf : ∀ (a b : X), a ≈ b → f a = f b` we obtain `g` from `qlift f hf`. See below for more details.
-/

/-
The API for such lifts is given by `quotient.lift`.
-/

#check @quotient.lift

section
variables {X Y : Type}

class resp_rel (f : X → Y) [s : setoid X]  : Prop :=
(rel_eq : ∀ (a b : X), a ≈ b → f a = f b)

-- The quotient map `qmk : X → quotient s` maps any two `s`-related elements of `X` to the same element in `quotient s`.
instance resp_rel_qmk {X : Type} [s : setoid X] :
  resp_rel (qmk : X → quotient s) :=
{
  rel_eq := by {intros a b, intro h, apply quot.sound h, },
}

instance resp_rel_comp {Z : Type} (f : X → Y) (g : Y → Z) [s : setoid X]
[resp_rel f] : resp_rel (g ∘ f) :=
{
  rel_eq := by {
                  intros a b h,
                  dsimp,
                  simp [congr_arg g (resp_rel.rel_eq a b h)]
               }
}

@[simp]
def qlift (f : X → Y) [s : setoid X] [resp_rel f] : quotient s → Y :=
quotient.lift f resp_rel.rel_eq

/-
qlift : Π {X Y : Type} (f : X → Y) [s : setoid X] [_inst_1 : resp_rel f], quotient s → Y
-/

#check @qlift

end

/-
Here's a diagram which helps you imagine the quotient construction and the universal property.
See
![](images/quotient_lift.png)
-/

@[simp]
lemma qmk_comp_lift {X Y : Type} [s : setoid X] (f : X → Y)
[resp_rel f] :
  (qlift f) ∘ qmk = f :=
begin
  funext x,
  dsimp,
  refl,
end

/- Furthermore, such a lift is __uniquely__ determined: any other function `g` with the property that ` g ∘ qmk = f` is necessarily equal to `qlift f`. This is the so-called __universal property__ of quotient construction which is key to their mathematical usage.

Let's recap: quotient construction has three essential components:

1. A __quotient function__ `qmk : X → quotient s`
2. For any function `f : X → Y` which respects the relation of `s`, there **exists** a __lift__ function `qlift f : quotient s → Y` which has the additional property that  `(qlift f) ∘ qmk = f`.
3. `qlift f` with this property is **unique**: any other function `g : quotient s → Y` with the property that ` g ∘ qmk = f` is necessarily equal to `qlift f`. We prove the uniqueness property in below using induction on terms of `quotient s`.
-/

lemma quotient.lift_unique {X Y : Type} [s : setoid X] (f : X → Y)
[resp_rel f] (g : quotient s → Y) :
  (∀ x : X, g ⟦x⟧  = f x) → (g = qlift f) :=
begin
  intro h₁, -- suppose that `∀ x : X, g ⟦x⟧  = f x`.
  funext q, -- let `q : X/s` be given
  -- Our goal is to prove that `g q = quotient.lift f hfs q`. To this end, by the induction property of quotient we only need to prove a similar statement but only for when q is an equivalence class, i.e. it suffices to prove `∀ x : X, g ⟦x⟧ = quotient.lift f hfs ⟦x⟧,`
  apply quotient.induction_on q,
  simp,
  exact h₁,
end

/-! ## Challenge
Give a proof of the following fact.
-/

lemma qlift_qmk {X : Type} [s : setoid X]  :
  qlift (qmk :  X → quotient s) = id :=
begin
  sorry,
end

lemma quotient.comp_lift_unique {X Y Z : Type} [s : setoid X] (f : X → Y) (g : Y → Z) [resp_rel f] :
  qlift (g ∘ f) = g ∘ (qlift f) :=
begin
  apply eq.symm,
  apply quotient.lift_unique,
  intro x,
  simp,
end

/- In what follows, we give two trivial examples of quotient in a general setting. -/

/-
The __least equivalence relation__ on a type is the so-called __diagonal__ relation: suppose `X` is a type and `r` is an equivalence relation on `X`. By reflexivity of `r` we must have `r x x` for all `x : X`. You can prove that the relation `Δ` which relates every `x : X` to itself but nothing else is in fact an equivalence relation and in a precise sense the least equivalence relation on `X`.
-/

@[simp]
def diagonal_rel (X : Type) [decidable_eq X] (x y : X) : Prop :=
(x = y)

local notation  ` Δ ` : 15 := diagonal_rel

/-! ## Challenge
Complete the proof below which shows that the diagonal relation on any type is an equivalence relation.
-/

lemma diag_rel_equiv {X : Type} [decidable_eq X] :
  equivalence (Δ X) :=
begin
  unfold equivalence,
  repeat{split},
  {
    unfold reflexive,
    intro x,
    simp,
  },
  {
    unfold symmetric,
    intros x y ,
    simp,
    exact eq.symm,
  },
  {
    sorry,
  },
end

@[simp]
instance minimal_setoid (X : Type) [decidable_eq X] : setoid X :=
⟨diagonal_rel X, diag_rel_equiv⟩

/-
We claim that if we take the quotient of a type `X` (with decidable equality) with respect to the diagonal equivalence relation on `X`, the quotient type is equivalent to `X`. To prove this we first define the quotient type `quot_by_diag`. We also need to prove that the identity function `id : X → X` respects the diagonal relation `Δ`.
-/

def quot_by_diag (X : Type) [decidable_eq X] := quotient  (minimal_setoid X)

/-
We prove that the identity function `id : X → X` respects the relation `Δ` and therefore, we can lift `id : X → X` to a unique function `id_q : X/r → X`
-/

/-! ## Challenge
Complete the proof below
-/
@[simp]
instance id_resp_diag {X : Type} [decidable_eq X] : resp_rel (id : X → X) :=
{ rel_eq := by {  intros a b,
                  intro h,
                  simp,
                  have : (a = b) ∨ ¬ (a = b), from decidable.eq_or_ne a b,
                  cases this,
                  {
                    exact this,
                  },
                  {
                    sorry,
                  },
                }
}

/- We show that, for any type `X`, the types `X` and `X/Δ` are equivalent, i.e. nothing is changed by quotienting `X` with the least equivalence relation on `X`.

See ![](images/quotient_diagonal.png)
-/
def quot_by_diag_eqv {X : Type}[decidable_eq X]:
  X ≅ quot_by_diag X  :=
{
  to_fun := λ x, ⟦ x ⟧, -- the function `X → quot_by_diag X` takes x to the equivalence class `⟦x⟧`.
  inv_fun := qlift (id), -- the inverse function `X → quot_by_diag X` is defined using the universal property of quotient.
  left_inv := by {simp, },
  right_inv := by { simp,
                    calc  qmk ∘ (qlift id) = qlift (qmk ∘ id) :
                    by {rw ← quotient.comp_lift_unique (@id X) qmk,}
                    ... = id : by {change qlift (qmk) = id, apply qlift_qmk, },
                  }
}

-- Now we can take the quotient of the setoid `mat × mat` by the equivalence relation `same_diff`. This the type of __fake integers__.
def Int := quotient mat.setoid

#check Int

instance : has_zero Int := ⟨⟦(0,0)⟧⟩

def zero : Int := has_zero.zero

@[simp]
lemma zero_defn :
  zero = ⟦(0,0)⟧ :=
begin
  refl,
end

/-
There is a function `mat × mat → Int` given by `quotient.mk` which maps a pair `(m, n) : mat × mat` to the equivalence class
`⟦ (m, n) ⟧`. Our notation for `quotient.mk x` is `⟦x⟧`.
-/

namespace integers

def one_two_pair : mat × mat := (1,2)

def one_two_int : Int := quotient.mk one_two_pair -- `one_two_integer` is morally "-1".

example :
  one_two_int = ⟦ one_two_pair ⟧ :=
begin
  refl,
end

example (x y : mat × mat ) : x ≈ y → ⟦x⟧ = ⟦y⟧ :=
quotient.sound

example (x y : mat × mat) : ⟦x⟧ = ⟦y⟧ → x ≈ y :=
quotient.exact

example (x y : mat × mat) : ⟦x⟧ = ⟦y⟧ ↔ x ≈ y :=
quotient.eq

example :
  ⟦ ((1,1) : mat × mat) ⟧ = ⟦ (2, 2) ⟧ :=
begin
  apply quotient.sound,
  simp,
end

-- every (fake) natural number is a (fake) integer.
@[simp]
instance : has_coe mat Int := ⟨λ n, ⟦(n, 0) ⟧⟩

/-! ### Addition of Integers
We define an auxiliary addition function on integers.
-/
def add_aux (x y : mat × mat) : Int := ⟦(x.1 + y.1, x.2 + y.2)⟧

/- Note that this is not the final addition function we would like to have, since the output type is different than inputs type.-/
#check add_aux

example :
  add_aux (1, 0) (0, 1) = ⟦ (0, 0) ⟧ :=
begin
  unfold add_aux,
  dsimp,
  apply quotient.sound,
  simp,
  refl,
end

@[simp]
lemma add_aux_defn (i j k l : mat) : add_aux (i, j) (k, l) = ⟦(i + k, j + l)⟧ :=
begin
  refl,
end

/- ## Challenge:
Complete the proof below. It shows that the function `add_aux`, which takes two inputs, respects the relation `≈` in both variables (inputs). We use this lemma to define the operation of addition on `Int` in below.
-/

lemma add_aux_lemma : ∀ a b x y : mat × mat,
(a ≈ x) → (b ≈ y) → add_aux a b = add_aux x y :=
begin
  rintros ⟨i, j⟩ ⟨k, l⟩ ⟨m, n⟩ ⟨p, q⟩ h₁ h₂,
  repeat {rw add_aux_def},
  apply quotient.sound,
  rw equiv_def_pair at h₁ h₂ ⊢,
  calc i + k + (n + q) = (i + n) + (k + q) : sorry
  ...                        = (m + j) + (p + l) : sorry
  ...                        = m + p + (j + l) : sorry
end

@[simp]
def add : Int → Int → Int :=
quotient.lift₂ add_aux add_aux_lemma

#check integers.add

example :
  add ⟦(0,1)⟧ ⟦(1,0)⟧ = ⟦ (0,0) ⟧ :=
begin
 simp,
end

/- ## Challenge
Show that type `Int` of fake integers admit a commutative monoid structure with respect to the addition operation we defined above. As usual, you need to prove several lemmas and then you fill in the `sorry` placeholders using those lemmas. See `comm_additive_monoid_str mat` for a comparison.
 -/

/-
For proving `associativity`, `add_zero`, `zero_add` and `add_comm` you will need to use `quotient.induction_on`. More specifically, by quotient induction, to prove a statement of the form
`∀ a : Int, P a` where `P : Int → Prop` is a predicate on `Int`, it suffices to prove `∀ (m,n), P ⟦(m,n)⟧ `.
-/

instance : comm_additive_monoid_str Int :=
{ add := sorry,
  add_assoc := sorry,
  zero := sorry,
  add_zero := sorry,
  zero_add := sorry,
  add_comm := sorry,
}

/- ## Challenge
Show that the function `λ x : mat, x : mat → Int` can be promoted to an additive monoid morphism. You might like to prove two additional lemmas to use in the definition below. Alternatively, you can have a longer proof inside the definition.
-/

#check additive_monoid.morphism

def mat_to_int : additive_monoid.morphism mat Int :=
{ to_fun := λ x : mat, x,
  resp_zero := sorry,
  resp_add := sorry, }

/-! ## Challenge
Show that type `Int` of fake integers admit an additive group structure with respect to the addition operation we defined above. As usual, you need to prove several lemmas and then you fill in the `sorry` placeholders using those lemmas. See `comm_additive_monoid_str mat` for a comparison.
 -/

instance : additive_group_str Int :=
{
  inv := sorry,
  left_inv := sorry,
  right_inv := sorry,
}

end integers


/-
Copyright (c) 2022 Jake Levinson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jake Levinson
-/
import combinatorics.young.young_diagram

/-!
# Semistandard Young tableaux

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

A semistandard Young tableau is a filling of a Young diagram by natural numbers, such that
the entries are weakly increasing left-to-right along rows (i.e. for fixed `i`), and
strictly-increasing top-to-bottom along columns (i.e. for fixed `j`).

An example of an SSYT of shape `μ = [4, 2, 1]` is:

```text
0 0 0 2
1 1
2
```

We represent an SSYT as a function `ℕ → ℕ → ℕ`, which is required to be zero for all pairs
`(i, j) ∉ μ` and to satisfy the row-weak and column-strict conditions on `μ`.

## Main definitions

- `ssyt (μ : young_diagram)` : semistandard Young tableaux of shape `μ`. There is
  a `has_coe_to_fun` instance such that `T i j` is value of the `(i, j)` entry of the SSYT `T`.
- `ssyt.highest_weight (μ : young_diagram)`: the semistandard Young tableau whose `i`th row
  consists entirely of `i`s, for each `i`.

## Tags

Semistandard Young tableau

## References

<https://en.wikipedia.org/wiki/Young_tableau>

-/

/-- A semistandard Young tableau (SSYT) is a filling of the cells of a Young diagram by natural
numbers, such that the entries in each row are weakly increasing (left to right), and the entries
in each column are strictly increasing (top to bottom).

Here, an SSYT is represented as an unrestricted function `ℕ → ℕ → ℕ` that, for reasons
of extensionality, is required to vanish outside `μ`. -/
structure ssyt (μ : young_diagram) :=
(entry : ℕ → ℕ → ℕ)
(row_weak' : ∀ {i j1 j2 : ℕ}, j1 < j2 → (i, j2) ∈ μ → entry i j1 ≤ entry i j2)
(col_strict' : ∀ {i1 i2 j : ℕ}, i1 < i2 → (i2, j) ∈ μ → entry i1 j < entry i2 j)
(zeros' : ∀ {i j}, (i, j) ∉ μ → entry i j = 0)

namespace ssyt

instance fun_like {μ : young_diagram} : fun_like (ssyt μ) ℕ (λ _, ℕ → ℕ) :=
{ coe := ssyt.entry,
  coe_injective' := λ T T' h, by { cases T, cases T', congr' } }

/-- Helper instance for when there's too many metavariables to apply
`fun_like.has_coe_to_fun` directly. -/
instance {μ : young_diagram} : has_coe_to_fun (ssyt μ) (λ _, ℕ → ℕ → ℕ) :=
fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {μ : young_diagram} {T : ssyt μ} : T.entry = (T : ℕ → ℕ → ℕ) := rfl

@[ext] theorem ext {μ : young_diagram} {T T' : ssyt μ} (h : ∀ i j, T i j = T' i j) : T = T' :=
fun_like.ext T T' (λ x, by { funext, apply h })

/-- Copy of an `ssyt μ` with a new `entry` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy {μ : young_diagram} (T : ssyt μ) (entry' : ℕ → ℕ → ℕ) (h : entry' = T) :
  ssyt μ :=
{ entry := entry',
  row_weak' := λ _ _ _, h.symm ▸ T.row_weak',
  col_strict' := λ _ _ _, h.symm ▸ T.col_strict',
  zeros' := λ _ _, h.symm ▸ T.zeros' }

@[simp] lemma coe_copy {μ : young_diagram} (T : ssyt μ) (entry' : ℕ → ℕ → ℕ) (h : entry' = T) :
  ⇑(T.copy entry' h) = entry' :=
rfl

lemma copy_eq {μ : young_diagram} (T : ssyt μ) (entry' : ℕ → ℕ → ℕ) (h : entry' = T) :
  T.copy entry' h = T :=
fun_like.ext' h

lemma row_weak {μ : young_diagram} (T : ssyt μ) {i j1 j2 : ℕ}
  (hj : j1 < j2) (hcell : (i, j2) ∈ μ) : T i j1 ≤ T i j2 :=
T.row_weak' hj hcell

lemma col_strict {μ : young_diagram} (T : ssyt μ) {i1 i2 j : ℕ}
  (hi : i1 < i2) (hcell : (i2, j) ∈ μ) : T i1 j < T i2 j :=
T.col_strict' hi hcell

lemma zeros {μ : young_diagram} (T : ssyt μ)
  {i j : ℕ} (not_cell : (i, j) ∉ μ) : T i j = 0 := T.zeros' not_cell

lemma row_weak_of_le {μ : young_diagram} (T : ssyt μ) {i j1 j2 : ℕ}
  (hj : j1 ≤ j2) (cell : (i, j2) ∈ μ) : T i j1 ≤ T i j2 :=
by { cases eq_or_lt_of_le hj, subst h, exact T.row_weak h cell }

lemma col_weak {μ : young_diagram} (T : ssyt μ) {i1 i2 j : ℕ}
  (hi : i1 ≤ i2) (cell : (i2, j) ∈ μ) : T i1 j ≤ T i2 j :=
by { cases eq_or_lt_of_le hi, subst h, exact le_of_lt (T.col_strict h cell) }

/-- The "highest weight" SSYT of a given shape is has all i's in row i, for each i. -/
def highest_weight (μ : young_diagram) : ssyt μ :=
{ entry := λ i j, if (i, j) ∈ μ then i else 0,
  row_weak' := λ i j1 j2 hj hcell,
    by rw [if_pos hcell, if_pos (μ.up_left_mem (by refl) (le_of_lt hj) hcell)],
  col_strict' := λ i1 i2 j hi hcell,
    by rwa [if_pos hcell, if_pos (μ.up_left_mem (le_of_lt hi) (by refl) hcell)],
  zeros' := λ i j not_cell, if_neg not_cell }

@[simp] lemma highest_weight_apply {μ : young_diagram} {i j : ℕ} :
  highest_weight μ i j = if (i, j) ∈ μ then i else 0 := rfl

instance {μ : young_diagram} : inhabited (ssyt μ) := ⟨ssyt.highest_weight μ⟩

end ssyt


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Julian Kuelshammer, Heather Macbeth
-/
import data.polynomial.derivative
import tactic.linear_combination

/-!
# Chebyshev polynomials

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

The Chebyshev polynomials are two families of polynomials indexed by `ℕ`,
with integral coefficients.

## Main definitions

* `polynomial.chebyshev.T`: the Chebyshev polynomials of the first kind.
* `polynomial.chebyshev.U`: the Chebyshev polynomials of the second kind.

## Main statements

* The formal derivative of the Chebyshev polynomials of the first kind is a scalar multiple of the
  Chebyshev polynomials of the second kind.
* `polynomial.chebyshev.mul_T`, the product of the `m`-th and `(m + k)`-th Chebyshev polynomials of
  the first kind is the sum of the `(2 * m + k)`-th and `k`-th Chebyshev polynomials of the first
  kind.
* `polynomial.chebyshev.T_mul`, the `(m * n)`-th Chebyshev polynomial of the first kind is the
  composition of the `m`-th and `n`-th Chebyshev polynomials of the first kind.

## Implementation details

Since Chebyshev polynomials have interesting behaviour over the complex numbers and modulo `p`,
we define them to have coefficients in an arbitrary commutative ring, even though
technically `ℤ` would suffice.
The benefit of allowing arbitrary coefficient rings, is that the statements afterwards are clean,
and do not have `map (int.cast_ring_hom R)` interfering all the time.

## References

[Lionel Ponton, _Roots of the Chebyshev polynomials: A purely algebraic approach_]
[ponton2020chebyshev]

## TODO

* Redefine and/or relate the definition of Chebyshev polynomials to `linear_recurrence`.
* Add explicit formula involving square roots for Chebyshev polynomials
* Compute zeroes and extrema of Chebyshev polynomials.
* Prove that the roots of the Chebyshev polynomials (except 0) are irrational.
* Prove minimax properties of Chebyshev polynomials.
-/

noncomputable theory
namespace polynomial.chebyshev

open polynomial
open_locale polynomial

variables (R S : Type*) [comm_ring R] [comm_ring S]

/-- `T n` is the `n`-th Chebyshev polynomial of the first kind -/
noncomputable def T : ℕ → R[X]
| 0       := 1
| 1       := X
| (n + 2) := 2 * X * T (n + 1) - T n

@[simp] lemma T_zero : T R 0 = 1 := rfl
@[simp] lemma T_one : T R 1 = X := rfl
@[simp] lemma T_add_two (n : ℕ) : T R (n + 2) = 2 * X * T R (n + 1) - T R n := by rw T

lemma T_two : T R 2 = 2 * X ^ 2 - 1 := by simp only [T, sub_left_inj, sq, mul_assoc]

lemma T_of_two_le (n : ℕ) (h : 2 ≤ n) : T R n = 2 * X * T R (n - 1) - T R (n - 2) :=
begin
  obtain ⟨n, rfl⟩ := nat.exists_eq_add_of_le h,
  rw add_comm,
  exact T_add_two R n
end

/-- `U n` is the `n`-th Chebyshev polynomial of the second kind -/
noncomputable def U : ℕ → R[X]
| 0       := 1
| 1       := 2 * X
| (n + 2) := 2 * X * U (n + 1) - U n

@[simp] lemma U_zero : U R 0 = 1 := rfl
@[simp] lemma U_one : U R 1 = 2 * X := rfl
@[simp] lemma U_add_two (n : ℕ) : U R (n + 2) = 2 * X * U R (n + 1) - U R n := by rw U

lemma U_of_two_le (n : ℕ) (h : 2 ≤ n) : U R n = 2 * X * U R (n - 1) - U R (n - 2) :=
begin
  obtain ⟨n, rfl⟩ := nat.exists_eq_add_of_le h,
  rw add_comm,
  exact U_add_two R n
end

lemma U_eq_X_mul_U_add_T : ∀ n : ℕ, U R (n + 1) = X * U R n + T R (n + 1)
| 0        := by { simp only [U_zero, U_one, T_one], ring }
| 1        := by { simp only [U_one, T_two, U_two], ring }
| (n + 2)  :=
  calc U R (n + 2 + 1) = 2 * X * (X * U R (n + 1) + T R (n + 2)) - (X * U R n + T R (n + 1)) :
            by simp only [U_add_two, U_eq_X_mul_U_add_T n, U_eq_X_mul_U_add_T (n + 1)]
  ... = X * (2 * X * U R (n + 1) - U R n) + (2 * X * T R (n + 2) - T R (n + 1)) : by ring
  ... = X * U R (n + 2) + T R (n + 2 + 1) : by simp only [U_add_two, T_add_two]

lemma T_eq_U_sub_X_mul_U (n : ℕ) : T R (n + 1) = U R (n + 1) - X * U R n :=
by rw [U_eq_X_mul_U_add_T, add_comm (X * U R n), add_sub_cancel]

lemma T_eq_X_mul_T_sub_pol_U : ∀ n : ℕ, T R (n + 2) = X * T R (n + 1) - (1 - X ^ 2) * U R n
| 0        := by { simp only [T_one, T_two, U_zero], ring }
| 1        := by { simp only [T_add_two, T_zero, T_add_two,
                              U_one, T_one], ring }
| (n + 2)  :=
calc T R (n + 2 + 2)
    = 2 * X * T R (n + 2 + 1) - T R (n + 2) : T_add_two _ _
... = 2 * X * (X * T R (n + 2) - (1 - X ^ 2) * U R (n + 1))
      - (X * T R (n + 1) - (1 - X ^ 2) * U R n) : by simp only [T_eq_X_mul_T_sub_pol_U]
... = X * (2 * X * T R (n + 2) -  T R (n + 1)) - (1 - X ^ 2) * (2 * X * U R (n + 1) - U R n) :
            by ring
... = X * T R (n + 2 + 1) - (1 - X ^ 2) * U R (n + 2) : by rw [T_add_two _ (n + 1), U_add_two]

lemma one_sub_X_sq_mul_U_eq_pol_in_T (n : ℕ) :
  (1 - X ^ 2) * U R n = X * T R (n + 1) - T R (n + 2) :=
by rw [T_eq_X_mul_T_sub_pol_U, ←sub_add, sub_self, zero_add]

variables {R S}

@[simp] lemma map_T (f : R →+* S) : ∀ n : ℕ, map f (T R n) = T S n
| 0       := by simp only [T_zero, polynomial.map_one]
| 1       := by simp only [T_one, map_X]
| (n + 2) :=
begin
  simp only [T_add_two, polynomial.map_mul, polynomial.map_sub, map_X, bit0,
             polynomial.map_add, polynomial.map_one],
  rw [map_T (n + 1), map_T n],
end

@[simp] lemma map_U (f : R →+* S) : ∀ n : ℕ, map f (U R n) = U S n
| 0       := by simp only [U_zero, polynomial.map_one]
| 1       :=
begin
  simp only [U_one, map_X, polynomial.map_mul, polynomial.map_add, polynomial.map_one],
  change map f (1 + 1) * X = 2 * X,
  simpa only [polynomial.map_add, polynomial.map_one]
end
| (n + 2) :=
begin
  simp only [U_add_two, polynomial.map_mul, polynomial.map_sub, map_X, bit0, polynomial.map_add,
             polynomial.map_one],
  rw [map_U (n + 1), map_U n],
end

lemma T_derivative_eq_U : ∀ n : ℕ, derivative (T R (n + 1)) = (n + 1) * U R n
| 0        := by simp only [T_one, U_zero, derivative_X, nat.cast_zero, zero_add, mul_one]
| 1        := by { simp only [T_two, U_one, derivative_sub, derivative_one, derivative_mul,
                              derivative_X_pow, nat.cast_one, nat.cast_two],
                    norm_num }
| (n + 2)  :=
  calc derivative (T R (n + 2 + 1))
      = 2 * T R (n + 2) + 2 * X * derivative (T R (n + 1 + 1)) - derivative (T R (n + 1)) :
              by simp only [T_add_two _ (n + 1), derivative_sub, derivative_mul, derivative_X,
                            derivative_bit0, derivative_one, bit0_zero, zero_mul, zero_add, mul_one]
  ... = 2 * (U R (n + 1 + 1) - X * U R (n + 1)) + 2 * X * ((n + 1 + 1) * U R (n + 1))
        - (n + 1) * U R n : by rw_mod_cast [T_derivative_eq_U, T_derivative_eq_U,
                                            T_eq_U_sub_X_mul_U]
  ... = (n + 1) * (2 * X * U R (n + 1) - U R n) + 2 * U R (n + 2) : by ring
  ... = (n + 1) * U R (n + 2) + 2 * U R (n + 2) : by rw U_add_two
  ... = (n + 2 + 1) * U R (n + 2) : by ring
  ... = (↑(n + 2) + 1) * U R (n + 2) : by norm_cast

lemma one_sub_X_sq_mul_derivative_T_eq_poly_in_T (n : ℕ) :
  (1 - X ^ 2) * (derivative (T R (n + 1))) = (n + 1) * (T R n - X * T R (n+1)) :=
  calc
  (1 - X ^ 2) * (derivative (T R (n + 1))) = (1 - X ^ 2) * ((n + 1) * U R n) :
            by rw T_derivative_eq_U
  ... = (n + 1) * ((1 - X ^ 2) * U R n) : by ring
  ... = (n + 1) * (X * T R (n + 1) - (2 * X * T R (n + 1) - T R n)) :
            by rw [one_sub_X_sq_mul_U_eq_pol_in_T, T_add_two]
  ... = (n + 1) * (T R n - X * T R (n + 1)) : by ring

lemma add_one_mul_T_eq_poly_in_U (n : ℕ) :
  ((n : R[X]) + 1) * T R (n + 1) = X * U R n - (1 - X ^ 2) * derivative (U R n) :=
begin
  have h : derivative (T R (n + 2)) = (U R (n + 1) - X * U R n) + X * derivative (T R (n + 1))
                                      + 2 * X * U R n - (1 - X ^ 2) * derivative (U R n),
  { conv_lhs { rw T_eq_X_mul_T_sub_pol_U },
    simp only [derivative_sub, derivative_mul, derivative_X, derivative_one, derivative_X_pow,
              one_mul, T_derivative_eq_U],
    rw [T_eq_U_sub_X_mul_U, C_eq_nat_cast, nat.cast_bit0, nat.cast_one],
    ring },
  calc ((n : R[X]) + 1) * T R (n + 1)
      = ((n : R[X]) + 1 + 1) * (X * U R n + T R (n + 1))
        - X * ((n + 1) * U R n) - (X * U R n + T R (n + 1)) : by ring
  ... = derivative (T R (n + 2)) - X * derivative (T R (n + 1)) - U R (n + 1) :
            by rw [←U_eq_X_mul_U_add_T, ←T_derivative_eq_U, ←nat.cast_one, ←nat.cast_add,
                  nat.cast_one, ←T_derivative_eq_U (n + 1)]
  ... = (U R (n + 1) - X * U R n) + X * derivative (T R (n + 1))
        + 2 * X * U R n - (1 - X ^ 2) * derivative (U R n)
        - X * derivative (T R (n + 1)) - U R (n + 1) : by rw h
  ... = X * U R n - (1 - X ^ 2) * derivative (U R n) : by ring,
end

variables (R)

/-- The product of two Chebyshev polynomials is the sum of two other Chebyshev polynomials. -/
lemma mul_T : ∀ m k, 2 * T R m * T R (m + k) = T R (2 * m + k) + T R k
| 0 := by simp [two_mul, add_mul]
| 1 := by simp [add_comm]
| (m + 2) := begin
  intros k,
  -- clean up the `T` nat indices in the goal
  suffices : 2 * T R (m + 2) * T R (m + k + 2) = T R (2 * m + k + 4) + T R k,
  { have h_nat₁ : 2 * (m + 2) + k = 2 * m + k + 4 := by ring,
    have h_nat₂ : m + 2 + k = m + k + 2 := by simp [add_comm, add_assoc],
    simpa [h_nat₁, h_nat₂] using this },
  -- clean up the `T` nat indices in the inductive hypothesis applied to `m + 1` and
  -- `k + 1`
  have H₁ : 2 * T R (m + 1) * T R (m + k + 2) = T R (2 * m + k + 3) + T R (k + 1),
  { have h_nat₁ : m + 1 + (k + 1) = m + k + 2 := by ring,
    have h_nat₂ : 2 * (m + 1) + (k + 1) = 2 * m + k + 3 := by ring,
    simpa [h_nat₁, h_nat₂] using mul_T (m + 1) (k + 1) },
  -- clean up the `T` nat indices in the inductive hypothesis applied to `m` and `k + 2`
  have H₂ : 2 * T R m * T R (m + k + 2) = T R (2 * m + k + 2) + T R (k + 2),
  { have h_nat₁ : 2 * m + (k + 2) = 2 * m + k + 2 := by simp [add_assoc],
    have h_nat₂ : m + (k + 2) = m + k + 2 := by simp [add_assoc],
    simpa [h_nat₁, h_nat₂] using mul_T m (k + 2) },
  -- state the `T` recurrence relation for a few useful indices
  have h₁ := T_add_two R m,
  have h₂ := T_add_two R (2 * m + k + 2),
  have h₃ := T_add_two R k,
  -- the desired identity is an appropriate linear combination of H₁, H₂, h₁, h₂, h₃
  linear_combination 2 * T R (m + k + 2) * h₁ + 2 * X * H₁ - H₂ - h₂ - h₃,
end

/-- The `(m * n)`-th Chebyshev polynomial is the composition of the `m`-th and `n`-th -/
lemma T_mul : ∀ m n, T R (m * n) = (T R m).comp (T R n)
| 0 := by simp
| 1 := by simp
| (m + 2) := begin
  intros n,
  have : 2 * T R n * T R ((m + 1) * n) = T R ((m + 2) * n) + T R (m * n),
  { convert mul_T R n (m * n); ring },
  simp [this, T_mul m, ← T_mul (m + 1)]
end

end polynomial.chebyshev


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import ring_theory.polynomial.basic
import ring_theory.ideal.local_ring
import tactic.ring_exp

/-!
# Expand a polynomial by a factor of p, so `∑ aₙ xⁿ` becomes `∑ aₙ xⁿᵖ`.

## Main definitions

* `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] (p q : ℕ)

/-- Expand the polynomial by a factor of p, so `∑ aₙ xⁿ` becomes `∑ aₙ xⁿᵖ`. -/
noncomputable def expand : R[X] →ₐ[R] R[X] :=
{ commutes' := λ r, eval₂_C _ _,
  .. (eval₂_ring_hom C (X ^ p) : R[X] →+* R[X]) }

lemma coe_expand : (expand R p : R[X] → R[X]) = eval₂ C (X ^ p) := rfl

variables {R}

lemma expand_eq_sum {f : R[X]} :
  expand R p f = f.sum (λ e a, C a * (X ^ p) ^ e) :=
by { dsimp [expand, eval₂], refl, }

@[simp] lemma expand_C (r : R) : expand R p (C r) = C r := eval₂_C _ _
@[simp] lemma expand_X : expand R p X = X ^ p := eval₂_X _ _
@[simp]

theorem expand_expand (f : R[X]) : expand R p (expand R q f) = expand R (p * q) f :=
polynomial.induction_on f (λ r, by simp_rw expand_C)
  (λ f g ihf ihg, by simp_rw [alg_hom.map_add, ihf, ihg])
  (λ n r ih, by simp_rw [alg_hom.map_mul, expand_C, alg_hom.map_pow, expand_X,
    alg_hom.map_pow, expand_X, pow_mul])

theorem expand_mul (f : R[X]) : expand R (p * q) f = expand R p (expand R q f) :=
(expand_expand p q f).symm

@[simp] theorem expand_zero (f : R[X]) : expand R 0 f = C (eval 1 f) :=
by simp [expand]

@[simp] theorem expand_one (f : R[X]) : expand R 1 f = f :=
polynomial.induction_on f
  (λ r, by rw expand_C)
  (λ f g ihf ihg, by rw [alg_hom.map_add, ihf, ihg])
  (λ n r ih, by rw [alg_hom.map_mul, expand_C, alg_hom.map_pow, expand_X, pow_one])

theorem expand_pow (f : R[X]) : expand R (p ^ q) f = (expand R p ^[q] f) :=
nat.rec_on q (by rw [pow_zero, expand_one, function.iterate_zero, id]) $ λ n ih,
by rw [function.iterate_succ_apply', pow_succ, expand_mul, ih]

theorem derivative_expand (f : R[X]) :
  (expand R p f).derivative = expand R p f.derivative * (p * X ^ (p - 1)) :=
by rw [coe_expand, derivative_eval₂_C, derivative_pow, C_eq_nat_cast, derivative_X, mul_one]

theorem coeff_expand {p : ℕ} (hp : 0 < p) (f : R[X]) (n : ℕ) :
  (expand R p f).coeff n = if p ∣ n then f.coeff (n / p) else 0 :=
begin
  simp only [expand_eq_sum],
  simp_rw [coeff_sum, ← pow_mul, C_mul_X_pow_eq_monomial, coeff_monomial, sum],
  split_ifs with h,
  { rw [finset.sum_eq_single (n/p), nat.mul_div_cancel' h, if_pos rfl],
    { intros b hb1 hb2, rw if_neg, intro hb3, apply hb2, rw [← hb3, nat.mul_div_cancel_left b hp] },
    { intro hn, rw not_mem_support_iff.1 hn, split_ifs; refl } },
  { rw finset.sum_eq_zero, intros k hk, rw if_neg, exact λ hkn, h ⟨k, hkn.symm⟩, },
end

@[simp] theorem coeff_expand_mul {p : ℕ} (hp : 0 < p) (f : R[X]) (n : ℕ) :
  (expand R p f).coeff (n * p) = f.coeff n :=
by rw [coeff_expand hp, if_pos (dvd_mul_left _ _), nat.mul_div_cancel _ hp]

@[simp] theorem coeff_expand_mul' {p : ℕ} (hp : 0 < p) (f : R[X]) (n : ℕ) :
  (expand R p f).coeff (p * n) = f.coeff n :=
by rw [mul_comm, coeff_expand_mul hp]

/-- Expansion is injective. -/
lemma expand_injective {n : ℕ} (hn : 0 < n) : function.injective (expand R n) :=
λ g g' H, ext $ λ k, by rw [← coeff_expand_mul hn, H, coeff_expand_mul hn]

theorem expand_inj {p : ℕ} (hp : 0 < p) {f g : R[X]} :
  expand R p f = expand R p g ↔ f = g :=
(expand_injective hp).eq_iff

theorem expand_eq_zero {p : ℕ} (hp : 0 < p) {f : R[X]} : expand R p f = 0 ↔ f = 0 :=
(expand_injective hp).eq_iff' (map_zero _)

theorem expand_ne_zero {p : ℕ} (hp : 0 < p) {f : R[X]} : expand R p f ≠ 0 ↔ f ≠ 0 :=
(expand_eq_zero hp).not

theorem expand_eq_C {p : ℕ} (hp : 0 < p) {f : R[X]} {r : R} :
  expand R p f = C r ↔ f = C r :=
by rw [← expand_C, expand_inj hp, expand_C]

theorem nat_degree_expand (p : ℕ) (f : R[X]) :
  (expand R p f).nat_degree = f.nat_degree * p :=
begin
  cases p.eq_zero_or_pos with hp hp,
  { rw [hp, coe_expand, pow_zero, mul_zero, ← C_1, eval₂_hom, nat_degree_C] },
  by_cases hf : f = 0,
  { rw [hf, alg_hom.map_zero, nat_degree_zero, zero_mul] },
  have hf1 : expand R p f ≠ 0 := mt (expand_eq_zero hp).1 hf,
  rw [← with_bot.coe_eq_coe, ← degree_eq_nat_degree hf1],
  refine le_antisymm ((degree_le_iff_coeff_zero _ _).2 $ λ n hn, _) _,
  { rw coeff_expand hp, split_ifs with hpn,
    { rw coeff_eq_zero_of_nat_degree_lt, contrapose! hn,
      rw [with_bot.coe_le_coe, ← nat.div_mul_cancel hpn], exact nat.mul_le_mul_right p hn },
    { refl } },
  { refine le_degree_of_ne_zero _,
    rw [coeff_expand_mul hp, ← leading_coeff], exact mt leading_coeff_eq_zero.1 hf }
end

lemma monic.expand {p : ℕ} {f : R[X]} (hp : 0 < p) (h : f.monic) : (expand R p f).monic :=
begin
  rw [monic.def, leading_coeff, nat_degree_expand, coeff_expand hp],
  simp [hp, h],
end

theorem map_expand {p : ℕ} {f : R →+* S} {q : R[X]} :
  map f (expand R p q) = expand S p (map f q) :=
begin
  by_cases hp : p = 0,
  { simp [hp] },
  ext,
  rw [coeff_map, coeff_expand (nat.pos_of_ne_zero hp), coeff_expand (nat.pos_of_ne_zero hp)],
  split_ifs; simp,
end

@[simp]
lemma expand_eval (p : ℕ) (P : R[X]) (r : R) : eval r (expand R p P) = eval (r ^ p) P :=
begin
  refine polynomial.induction_on P (λ a, by simp) (λ f g hf hg, _) (λ n a h, by simp),
  rw [alg_hom.map_add, eval_add, eval_add, hf, hg]
end

@[simp]
lemma expand_aeval {A : Type*} [semiring A] [algebra R A] (p : ℕ) (P : R[X]) (r : A) :
  aeval r (expand R p P) = aeval (r ^ p) P :=
begin
  refine polynomial.induction_on P (λ a, by simp) (λ f g hf hg, _) (λ n a h, by simp),
  rw [alg_hom.map_add, aeval_add, aeval_add, hf, hg]
end

/-- The opposite of `expand`: sends `∑ aₙ xⁿᵖ` to `∑ aₙ xⁿ`. -/
noncomputable def contract (p : ℕ) (f : R[X]) : R[X] :=
∑ n in range (f.nat_degree + 1), monomial n (f.coeff (n * p))

theorem coeff_contract {p : ℕ} (hp : p ≠ 0) (f : R[X]) (n : ℕ) :
  (contract p f).coeff n = f.coeff (n * p) :=
begin
  simp only [contract, coeff_monomial, sum_ite_eq', finset_sum_coeff, mem_range, not_lt,
    ite_eq_left_iff],
  assume hn,
  apply (coeff_eq_zero_of_nat_degree_lt _).symm,
  calc f.nat_degree < f.nat_degree + 1 : nat.lt_succ_self _
    ... ≤ n * 1 : by simpa only [mul_one] using hn
    ... ≤ n * p : mul_le_mul_of_nonneg_left (show 1 ≤ p, from hp.bot_lt) (zero_le n)
end

theorem contract_expand {f : R[X]} (hp : p ≠ 0) : contract p (expand R p f) = f :=
begin
  ext,
  simp [coeff_contract hp, coeff_expand hp.bot_lt, nat.mul_div_cancel _ hp.bot_lt]
end

section char_p

variable [char_p R p]

theorem expand_contract [no_zero_divisors R] {f : R[X]} (hf : f.derivative = 0)
  (hp : p ≠ 0) : expand R p (contract p f) = f :=
begin
  ext n,
  rw [coeff_expand hp.bot_lt, coeff_contract hp],
  split_ifs with h,
  { rw nat.div_mul_cancel h },
  { cases n,
    { exact absurd (dvd_zero p) h },
    have := coeff_derivative f n,
    rw [hf, coeff_zero, zero_eq_mul] at this,
    cases this,
    { rw this },
    rw [← nat.cast_succ, char_p.cast_eq_zero_iff R p] at this,
    exact absurd this h }
end

variable [hp : fact p.prime]
include hp

theorem expand_char (f : R[X]) : map (frobenius R p) (expand R p f) = f ^ p :=
begin
  refine f.induction_on' (λ a b ha hb, _) (λ n a, _),
  { rw [alg_hom.map_add, polynomial.map_add, ha, hb, add_pow_char], },
  { rw [expand_monomial, map_monomial, ← C_mul_X_pow_eq_monomial, ← C_mul_X_pow_eq_monomial,
        mul_pow, ← C.map_pow, frobenius_def],
    ring_exp }
end

theorem map_expand_pow_char (f : R[X]) (n : ℕ) :
   map ((frobenius R p) ^ n) (expand R (p ^ n) f) = f ^ (p ^ n) :=
begin
  induction n,
  { simp [ring_hom.one_def] },
  symmetry,
  rw [pow_succ', pow_mul, ← n_ih, ← expand_char, pow_succ, ring_hom.mul_def,
      ← map_map, mul_comm, expand_mul, ← map_expand]
end

end char_p

end comm_semiring

section is_domain

variables (R : Type u) [comm_ring R] [is_domain R]

theorem is_local_ring_hom_expand {p : ℕ} (hp : 0 < p) :
  is_local_ring_hom (↑(expand R p) : R[X] →+* R[X]) :=
begin
  refine ⟨λ f hf1, _⟩, rw ← coe_fn_coe_base at hf1,
  have hf2 := eq_C_of_degree_eq_zero (degree_eq_zero_of_is_unit hf1),
  rw [coeff_expand hp, if_pos (dvd_zero _), p.zero_div] at hf2,
  rw [hf2, is_unit_C] at hf1, rw expand_eq_C hp at hf2, rwa [hf2, is_unit_C]
end

variable {R}

theorem of_irreducible_expand {p : ℕ} (hp : p ≠ 0) {f : R[X]}
  (hf : irreducible (expand R p f)) : irreducible f :=
let _ := is_local_ring_hom_expand R hp.bot_lt in by exactI of_irreducible_map ↑(expand R p) hf

theorem of_irreducible_expand_pow {p : ℕ} (hp : p ≠ 0) {f : R[X]} {n : ℕ} :
  irreducible (expand R (p ^ n) f) → irreducible f :=
nat.rec_on n (λ hf, by rwa [pow_zero, expand_one] at hf) $ λ n ih hf,
ih $ of_irreducible_expand hp $ by { rw pow_succ at hf, rwa [expand_expand] }

end is_domain

end polynomial


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

/-!
# The pointwise product on `finsupp`.

For the convolution product on `finsupp` when the domain has a binary operation,
see the type synonyms `add_monoid_algebra`
(which is in turn used to define `polynomial` and `mv_polynomial`)
and `monoid_algebra`.
-/

noncomputable theory

open finset

universes u₁ u₂ u₃ u₄ u₅
variables {α : Type u₁} {β : Type u₂} {γ : Type u₃} {δ : Type u₄} {ι : Type u₅}

namespace finsupp

/-! ### Declarations about the pointwise product on `finsupp`s -/

section
variables [mul_zero_class β]

/-- The product of `f g : α →₀ β` is the finitely supported function
  whose value at `a` is `f a * g a`. -/
instance : has_mul (α →₀ β) := ⟨zip_with (*) (mul_zero 0)⟩

lemma coe_mul (g₁ g₂ : α →₀ β) : ⇑(g₁ * g₂) = g₁ * g₂ := rfl

@[simp] lemma mul_apply {g₁ g₂ : α →₀ β} {a : α} : (g₁ * g₂) a = g₁ a * g₂ a :=
rfl

lemma support_mul [decidable_eq α] {g₁ g₂ : α →₀ β} : (g₁ * g₂).support ⊆ g₁.support ∩ g₂.support :=
begin
  intros a h,
  simp only [mul_apply, mem_support_iff] at h,
  simp only [mem_support_iff, mem_inter, ne.def],
  rw ←not_or_distrib,
  intro w,
  apply h,
  cases w; { rw w, simp },
end

instance : mul_zero_class (α →₀ β) :=
finsupp.coe_fn_injective.mul_zero_class _ coe_zero coe_mul

end

instance [semigroup_with_zero β] : semigroup_with_zero (α →₀ β) :=
finsupp.coe_fn_injective.semigroup_with_zero _ coe_zero coe_mul

instance [non_unital_non_assoc_semiring β] : non_unital_non_assoc_semiring (α →₀ β) :=
finsupp.coe_fn_injective.non_unital_non_assoc_semiring _ coe_zero coe_add coe_mul (λ _ _, rfl)

instance [non_unital_semiring β] : non_unital_semiring (α →₀ β) :=
finsupp.coe_fn_injective.non_unital_semiring _ coe_zero coe_add coe_mul (λ _ _, rfl)

instance [non_unital_non_assoc_ring β] : non_unital_non_assoc_ring (α →₀ β) :=
finsupp.coe_fn_injective.non_unital_non_assoc_ring _
  coe_zero coe_add coe_mul coe_neg coe_sub (λ _ _, rfl) (λ _ _, rfl)

instance [non_unital_ring β] : non_unital_ring (α →₀ β) :=
finsupp.coe_fn_injective.non_unital_ring _
  coe_zero coe_add coe_mul coe_neg coe_sub (λ _ _, rfl) (λ _ _, rfl)

-- TODO can this be generalized in the direction of `pi.has_scalar'`
-- (i.e. dependent functions and finsupps)
-- TODO in theory this could be generalised, we only really need `smul_zero` for the definition
instance pointwise_scalar [semiring β] : has_scalar (α → β) (α →₀ β) :=
{ smul := λ f g, finsupp.of_support_finite (λ a, f a • g a) begin
    apply set.finite.subset g.finite_support,
    simp only [function.support_subset_iff, finsupp.mem_support_iff, ne.def,
      finsupp.fun_support_eq, finset.mem_coe],
    intros x hx h,
    apply hx,
    rw [h, smul_zero],
  end }

@[simp]
lemma coe_pointwise_smul [semiring β] (f : α → β) (g : α →₀ β) :
  ⇑(f • g) = f • g := rfl

/-- The pointwise multiplicative action of functions on finitely supported functions -/
instance pointwise_module [semiring β] : module (α → β) (α →₀ β) :=
function.injective.module _ coe_fn_add_hom coe_fn_injective coe_pointwise_smul

end finsupp


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

! This file was ported from Lean 3 source module algebra.gcd_monoid.finset
! leanprover-community/mathlib commit 9003f28797c0664a49e4179487267c494477d853
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Finset.Fold
import Mathlib.Algebra.GCDMonoid.Multiset

/-!
# GCD and LCM operations on finsets

## Main definitions

- `Finset.gcd` - the greatest common denominator of a `Finset` of elements of a `GCDMonoid`
- `Finset.lcm` - the least common multiple of a `Finset` of elements of a `GCDMonoid`

## Implementation notes

Many of the proofs use the lemmas `gcd_def` and `lcm_def`, which relate `Finset.gcd`
and `Finset.lcm` to `Multiset.gcd` and `Multiset.lcm`.

TODO: simplify with a tactic and `Data.Finset.Lattice`

## Tags

finset, gcd
-/

variable {α β γ : Type _}

namespace Finset

open Multiset

variable [CancelCommMonoidWithZero α] [NormalizedGCDMonoid α]

/-! ### lcm -/

section lcm

/-- Least common multiple of a finite set -/
def lcm (s : Finset β) (f : β → α) : α :=
  s.fold GCDMonoid.lcm 1 f
#align finset.lcm Finset.lcm

variable {s s₁ s₂ : Finset β} {f : β → α}

theorem lcm_def : s.lcm f = (s.1.map f).lcm :=
  rfl
#align finset.lcm_def Finset.lcm_def

@[simp]
theorem lcm_empty : (∅ : Finset β).lcm f = 1 :=
  fold_empty
#align finset.lcm_empty Finset.lcm_empty

@[simp]
theorem lcm_dvd_iff {a : α} : s.lcm f ∣ a ↔ ∀ b ∈ s, f b ∣ a := by
  apply Iff.trans Multiset.lcm_dvd
  simp only [Multiset.mem_map, and_imp, exists_imp]
  exact ⟨fun k b hb ↦ k _ _ hb rfl, fun k a' b hb h ↦ h ▸ k _ hb⟩
#align finset.lcm_dvd_iff Finset.lcm_dvd_iff

theorem lcm_dvd {a : α} : (∀ b ∈ s, f b ∣ a) → s.lcm f ∣ a :=
  lcm_dvd_iff.2
#align finset.lcm_dvd Finset.lcm_dvd

theorem dvd_lcm {b : β} (hb : b ∈ s) : f b ∣ s.lcm f :=
  lcm_dvd_iff.1 dvd_rfl _ hb
#align finset.dvd_lcm Finset.dvd_lcm

@[simp]
theorem lcm_insert [DecidableEq β] {b : β} :
    (insert b s : Finset β).lcm f = GCDMonoid.lcm (f b) (s.lcm f) := by
  by_cases h : b ∈ s
  · rw [insert_eq_of_mem h,
      (lcm_eq_right_iff (f b) (s.lcm f) (Multiset.normalize_lcm (s.1.map f))).2 (dvd_lcm h)]
  apply fold_insert h
#align finset.lcm_insert Finset.lcm_insert

@[simp]
theorem lcm_singleton {b : β} : ({b} : Finset β).lcm f = normalize (f b) :=
  Multiset.lcm_singleton
#align finset.lcm_singleton Finset.lcm_singleton

-- Porting note: Priority changed for `simpNF`
@[simp 1100]
theorem normalize_lcm : normalize (s.lcm f) = s.lcm f := by simp [lcm_def]
#align finset.normalize_lcm Finset.normalize_lcm

theorem lcm_union [DecidableEq β] : (s₁ ∪ s₂).lcm f = GCDMonoid.lcm (s₁.lcm f) (s₂.lcm f) :=
  Finset.induction_on s₁ (by rw [empty_union, lcm_empty, lcm_one_left, normalize_lcm])
    fun a s _ ih ↦ by rw [insert_union, lcm_insert, lcm_insert, ih, lcm_assoc]
#align finset.lcm_union Finset.lcm_union

theorem lcm_congr {f g : β → α} (hs : s₁ = s₂) (hfg : ∀ a ∈ s₂, f a = g a)
    : s₁.lcm f = s₂.lcm g := by
  subst hs
  exact Finset.fold_congr hfg
#align finset.lcm_congr Finset.lcm_congr

theorem lcm_mono_fun {g : β → α} (h : ∀ b ∈ s, f b ∣ g b) : s.lcm f ∣ s.lcm g :=
  lcm_dvd fun b hb ↦ (h b hb).trans (dvd_lcm hb)
#align finset.lcm_mono_fun Finset.lcm_mono_fun

theorem lcm_mono (h : s₁ ⊆ s₂) : s₁.lcm f ∣ s₂.lcm f :=
  lcm_dvd fun _ hb ↦ dvd_lcm (h hb)
#align finset.lcm_mono Finset.lcm_mono

theorem lcm_image [DecidableEq β] {g : γ → β} (s : Finset γ) : (s.image g).lcm f = s.lcm (f ∘ g) :=
  by classical induction' s using Finset.induction with c s _ ih <;> simp [*]
#align finset.lcm_image Finset.lcm_image

theorem lcm_eq_lcm_image [DecidableEq α] : s.lcm f = (s.image f).lcm id :=
  Eq.symm <| lcm_image _
#align finset.lcm_eq_lcm_image Finset.lcm_eq_lcm_image

theorem lcm_eq_zero_iff [Nontrivial α] : s.lcm f = 0 ↔ 0 ∈ f '' s := by
  simp only [Multiset.mem_map, lcm_def, Multiset.lcm_eq_zero_iff, Set.mem_image, mem_coe, ←
    Finset.mem_def]
#align finset.lcm_eq_zero_iff Finset.lcm_eq_zero_iff

end lcm

/-! ### gcd -/

section gcd

/-- Greatest common divisor of a finite set -/
def gcd (s : Finset β) (f : β → α) : α :=
  s.fold GCDMonoid.gcd 0 f
#align finset.gcd Finset.gcd

variable {s s₁ s₂ : Finset β} {f : β → α}

theorem gcd_def : s.gcd f = (s.1.map f).gcd :=
  rfl
#align finset.gcd_def Finset.gcd_def

@[simp]
theorem gcd_empty : (∅ : Finset β).gcd f = 0 :=
  fold_empty
#align finset.gcd_empty Finset.gcd_empty

theorem dvd_gcd_iff {a : α} : a ∣ s.gcd f ↔ ∀ b ∈ s, a ∣ f b := by
  apply Iff.trans Multiset.dvd_gcd
  simp only [Multiset.mem_map, and_imp, exists_imp]
  exact ⟨fun k b hb ↦ k _ _ hb rfl, fun k a' b hb h ↦ h ▸ k _ hb⟩
#align finset.dvd_gcd_iff Finset.dvd_gcd_iff

theorem gcd_dvd {b : β} (hb : b ∈ s) : s.gcd f ∣ f b :=
  dvd_gcd_iff.1 dvd_rfl _ hb
#align finset.gcd_dvd Finset.gcd_dvd

theorem dvd_gcd {a : α} : (∀ b ∈ s, a ∣ f b) → a ∣ s.gcd f :=
  dvd_gcd_iff.2
#align finset.dvd_gcd Finset.dvd_gcd

@[simp]
theorem gcd_insert [DecidableEq β] {b : β} :
    (insert b s : Finset β).gcd f = GCDMonoid.gcd (f b) (s.gcd f) := by
  by_cases h : b ∈ s
  ·
    rw [insert_eq_of_mem h,
      (gcd_eq_right_iff (f b) (s.gcd f) (Multiset.normalize_gcd (s.1.map f))).2 (gcd_dvd h)]
  apply fold_insert h
#align finset.gcd_insert Finset.gcd_insert

@[simp]
theorem gcd_singleton {b : β} : ({b} : Finset β).gcd f = normalize (f b) :=
  Multiset.gcd_singleton
#align finset.gcd_singleton Finset.gcd_singleton

-- Porting note: Priority changed for `simpNF`
@[simp 1100]
theorem normalize_gcd : normalize (s.gcd f) = s.gcd f := by simp [gcd_def]
#align finset.normalize_gcd Finset.normalize_gcd

theorem gcd_union [DecidableEq β] : (s₁ ∪ s₂).gcd f = GCDMonoid.gcd (s₁.gcd f) (s₂.gcd f) :=
  Finset.induction_on s₁ (by rw [empty_union, gcd_empty, gcd_zero_left, normalize_gcd])
    fun a s _ ih ↦ by rw [insert_union, gcd_insert, gcd_insert, ih, gcd_assoc]
#align finset.gcd_union Finset.gcd_union

theorem gcd_congr {f g : β → α} (hs : s₁ = s₂) (hfg : ∀ a ∈ s₂, f a = g a)
    : s₁.gcd f = s₂.gcd g := by
  subst hs
  exact Finset.fold_congr hfg
#align finset.gcd_congr Finset.gcd_congr

theorem gcd_mono_fun {g : β → α} (h : ∀ b ∈ s, f b ∣ g b) : s.gcd f ∣ s.gcd g :=
  dvd_gcd fun b hb ↦ (gcd_dvd hb).trans (h b hb)
#align finset.gcd_mono_fun Finset.gcd_mono_fun

theorem gcd_mono (h : s₁ ⊆ s₂) : s₂.gcd f ∣ s₁.gcd f :=
  dvd_gcd fun _ hb ↦ gcd_dvd (h hb)
#align finset.gcd_mono Finset.gcd_mono

theorem gcd_image [DecidableEq β] {g : γ → β} (s : Finset γ) : (s.image g).gcd f = s.gcd (f ∘ g) :=
  by classical induction' s using Finset.induction with c s _ ih <;> simp [*]
#align finset.gcd_image Finset.gcd_image

theorem gcd_eq_gcd_image [DecidableEq α] : s.gcd f = (s.image f).gcd id :=
  Eq.symm <| gcd_image _
#align finset.gcd_eq_gcd_image Finset.gcd_eq_gcd_image

theorem gcd_eq_zero_iff : s.gcd f = 0 ↔ ∀ x : β, x ∈ s → f x = 0 := by
  rw [gcd_def, Multiset.gcd_eq_zero_iff]
  constructor <;> intro h
  · intro b bs
    apply h (f b)
    simp only [Multiset.mem_map, mem_def.1 bs]
    use b
    simp only [mem_def.1 bs, eq_self_iff_true, and_self]
  · intro a as
    rw [Multiset.mem_map] at as
    rcases as with ⟨b, ⟨bs, rfl⟩⟩
    apply h b (mem_def.1 bs)
#align finset.gcd_eq_zero_iff Finset.gcd_eq_zero_iff

/- Porting note: The change from `p : α → Prop` to `p : α → Bool` made this slightly less nice with
all the `decide`s around. -/
theorem gcd_eq_gcd_filter_ne_zero [DecidablePred fun x : β ↦ f x = 0] :
    s.gcd f = (s.filter fun x ↦ f x ≠ 0).gcd f := by
  classical
    trans ((s.filter fun x ↦ f x = 0) ∪ s.filter fun x ↦ (f x ≠ 0)).gcd f
    · rw [filter_union_filter_neg_eq]
    rw [gcd_union]
    refine' Eq.trans (_ : _ = GCDMonoid.gcd (0 : α) _) (_ : GCDMonoid.gcd (0 : α) _ = _)
    · exact (gcd (filter (fun x => (f x ≠ 0)) s) f)
    · refine' congr (congr rfl <| s.induction_on _ _) (by simp)
      · simp
      · intro a s _ h
        rw [filter_insert]
        split_ifs with h1 <;> simp [h, h1]
    simp only [gcd_zero_left, normalize_gcd]
#align finset.gcd_eq_gcd_filter_ne_zero Finset.gcd_eq_gcd_filter_ne_zero

nonrec theorem gcd_mul_left {a : α} : (s.gcd fun x ↦ a * f x) = normalize a * s.gcd f := by
  classical
    refine' s.induction_on _ _
    · simp
    · intro b t _ h
      rw [gcd_insert, gcd_insert, h, ← gcd_mul_left]
      apply ((normalize_associated a).mul_right _).gcd_eq_right
#align finset.gcd_mul_left Finset.gcd_mul_left

nonrec theorem gcd_mul_right {a : α} : (s.gcd fun x ↦ f x * a) = s.gcd f * normalize a := by
  classical
    refine' s.induction_on _ _
    · simp
    · intro b t _ h
      rw [gcd_insert, gcd_insert, h, ← gcd_mul_right]
      apply ((normalize_associated a).mul_left _).gcd_eq_right
#align finset.gcd_mul_right Finset.gcd_mul_right

theorem extract_gcd' (f g : β → α) (hs : ∃ x, x ∈ s ∧ f x ≠ 0)
    (hg : ∀ b ∈ s, f b = s.gcd f * g b) : s.gcd g = 1 :=
  ((@mul_right_eq_self₀ _ _ (s.gcd f) _).1 <| by
        conv_lhs => rw [← normalize_gcd, ← gcd_mul_left, ← gcd_congr rfl hg]).resolve_right <| by
    contrapose! hs
    exact gcd_eq_zero_iff.1 hs
#align finset.extract_gcd' Finset.extract_gcd'

theorem extract_gcd (f : β → α) (hs : s.Nonempty) :
    ∃ g : β → α, (∀ b ∈ s, f b = s.gcd f * g b) ∧ s.gcd g = 1 := by
  classical
    by_cases h : ∀ x ∈ s, f x = (0 : α)
    · refine' ⟨fun _ ↦ 1, fun b hb ↦ by rw [h b hb, gcd_eq_zero_iff.2 h, mul_one], _⟩
      rw [gcd_eq_gcd_image, image_const hs, gcd_singleton, id, normalize_one]
    · choose g' hg using @gcd_dvd _ _ _ _ s f
      push_neg  at h
      refine' ⟨fun b ↦ if hb : b ∈ s then g' hb else 0, fun b hb ↦ _,
          extract_gcd' f _ h <| fun b hb ↦ _⟩
      simp only [hb, hg, dite_true]
      rw [dif_pos hb, hg hb]
#align finset.extract_gcd Finset.extract_gcd

end gcd

end Finset

namespace Finset

section IsDomain

variable [CommRing α] [IsDomain α] [NormalizedGCDMonoid α]

theorem gcd_eq_of_dvd_sub {s : Finset β} {f g : β → α} {a : α}
    (h : ∀ x : β, x ∈ s → a ∣ f x - g x) :
    GCDMonoid.gcd a (s.gcd f) = GCDMonoid.gcd a (s.gcd g) := by
  classical
    revert h
    refine' s.induction_on _ _
    · simp
    intro b s _ hi h
    rw [gcd_insert, gcd_insert, gcd_comm (f b), ← gcd_assoc,
      hi fun x hx ↦ h _ (mem_insert_of_mem hx), gcd_comm a, gcd_assoc,
      gcd_comm a (GCDMonoid.gcd _ _), gcd_comm (g b), gcd_assoc _ _ a, gcd_comm _ a]
    exact congr_arg _ (gcd_eq_of_dvd_sub_right (h _ (mem_insert_self _ _)))
#align finset.gcd_eq_of_dvd_sub Finset.gcd_eq_of_dvd_sub

end IsDomain

end Finset


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

! This file was ported from Lean 3 source module combinatorics.simple_graph.regularity.energy
! leanprover-community/mathlib commit f7707875544ef1f81b32cb68c79e0e24e45a0e76
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.BigOperators.Order
import Mathlib.Algebra.Module.Basic
import Mathlib.Combinatorics.SimpleGraph.Density

/-!
# Energy of a partition

This file defines the energy of a partition.

The energy is the auxiliary quantity that drives the induction process in the proof of Szemerédi's
Regularity Lemma. As long as we do not have a suitable equipartition, we will find a new one that
has an energy greater than the previous one plus some fixed constant.
-/

open Finset

open BigOperators

variable {α : Type _} [DecidableEq α] {s : Finset α} (P : Finpartition s) (G : SimpleGraph α)
  [DecidableRel G.Adj]

namespace Finpartition

/-- The energy of a partition, also known as index. Auxiliary quantity for Szemerédi's regularity
lemma.  -/
def energy : ℚ :=
  ((∑ uv in P.parts.offDiag, G.edgeDensity uv.1 uv.2 ^ 2) : ℚ) / (P.parts.card ^ 2 : ℕ)
#align finpartition.energy Finpartition.energy

theorem energy_nonneg : 0 ≤ P.energy G := by
  refine' div_nonneg (Finset.sum_nonneg fun _ _ => sq_nonneg _) <| Nat.cast_nonneg _
#align finpartition.energy_nonneg Finpartition.energy_nonneg

theorem energy_le_one : P.energy G ≤ 1 :=
  div_le_of_nonneg_of_le_mul (Nat.cast_nonneg _) zero_le_one <|
    calc
      (∑ uv in P.parts.offDiag, G.edgeDensity uv.1 uv.2 ^ 2) ≤ P.parts.offDiag.card • (1 : ℚ) :=
        sum_le_card_nsmul _ _ 1 fun uv _ =>
          (sq_le_one_iff <| G.edgeDensity_nonneg _ _).2 <| G.edgeDensity_le_one _ _
      _ = P.parts.offDiag.card := (Nat.smul_one_eq_coe _)
      _ ≤ _ := by
        rw [offDiag_card, one_mul]
        norm_cast
        rw [sq]
        exact tsub_le_self

#align finpartition.energy_le_one Finpartition.energy_le_one

end Finpartition


import algebra.ofe.basic

universes u v w

instance {α : Type u} {β : Type v} [ofe α] [ofe β] : ofe (α × β) := {
  eq_at := λ n x y, x.1 =[n] y.1 ∧ x.2 =[n] y.2,
  eq_at_reflexive := begin
    intros n x,
    split;
    refl,
  end,
  eq_at_symmetric := begin
    intros n x y h,
    exact ⟨eq_at_symmetric n h.1, eq_at_symmetric n h.2⟩,
  end,
  eq_at_transitive := begin
    intros n x y z hxy hyz,
    exact ⟨eq_at_trans _ hxy.1 hyz.1, eq_at_trans _ hxy.2 hyz.2⟩,
  end,
  eq_at_mono' := begin
    intros m n hmn x y h,
    exact ⟨eq_at_mono hmn h.1, eq_at_mono hmn h.2⟩,
  end,
  eq_at_limit' := begin
    intros x y h,
    ext1;
    rw eq_at_limit;
    intro n,
    exact (h n).1,
    exact (h n).2,
  end,
}

@[simp] lemma prod.eq_at {α : Type u} {β : Type v} [ofe α] [ofe β] (n : ℕ) (x y : α × β) :
  x =[n] y ↔ x.1 =[n] y.1 ∧ x.2 =[n] y.2 := iff.rfl

lemma is_nonexpansive.uncurry_apply_eq_at {α : Type u} {β : Type v} {γ : Type w}
  [ofe α] [ofe β] [ofe γ] {f : α → β → γ}
  (h : is_nonexpansive (function.uncurry f)) {a b : α} {c d : β} {n : ℕ}
  (hab : a =[n] b) (hcd : c =[n] d) : f a c =[n] f b d :=
h (⟨hab, hcd⟩ : (a, c) =[n] (b, d))

/-!
# Locally nonexpansive bifunctors
We can now define bifunctors in terms of functors and the product OFE.
-/

def locally_nonexpansive_bifunctor (F : ofe_bifunctor) : Prop :=
∀ (α β γ δ : Type u) [ofe α] [ofe β] [ofe γ] [ofe δ],
begin
  resetI,
  letI := F.ofe_obj α β,
  letI := F.ofe_obj γ δ,
  exact is_nonexpansive (λ f, F.map f.1 f.2 :
    (γ →ₙₑ α) × (β →ₙₑ δ) → (F.obj α β →ₙₑ F.obj γ δ)),
end

def locally_contractive_bifunctor (F : ofe_bifunctor) : Prop :=
∀ (α β γ δ : Type u) [ofe α] [ofe β] [ofe γ] [ofe δ],
begin
  resetI,
  letI := F.ofe_obj α β,
  letI := F.ofe_obj γ δ,
  exact is_contractive (λ f, F.map f.1 f.2 :
    (γ →ₙₑ α) × (β →ₙₑ δ) → (F.obj α β →ₙₑ F.obj γ δ)),
end


/-
This module defines an exponentiation function where the exponent
is a natural number, and the base is a monoid.

It uses an efficient sum of squares method to support large exponents.
-/

import .simplify_eq

universe u

namespace nat

section exp

parameter {α : Type u}
parameter [inst : monoid α]

include inst

def exp.f (x : α) (b:bool) (n : ℕ) (r:α) : α :=
  if b then
    x * r * r
  else
    r * r

def exp (x : α) (n : ℕ) : α := nat.binary_rec 1 (exp.f x) n

theorem exp_zero : ∀ (x : α) , exp x 0 = 1 :=
begin
  intro x,
  unfold exp,
  unfold binary_rec,
  simp [eq.mpr],
end

theorem exp_one (x : α) : exp x 1 = x :=
begin
  unfold exp,
  unfold binary_rec,
  simp [exp.f, eq.mpr],
  dsimp [div2_one],
  unfold binary_rec,
  simp [eq.mpr],
  rw if_pos, constructor,
end

theorem exp_bit (x : α) (b:bool) (n:ℕ)
: exp x (bit b n) = (if b then x else 1) * exp x n * exp x n :=
begin
  transitivity,
  unfold1 exp,
  rw binary_rec_eq,
  simp [exp.f],
  cases b; simp [exp],
  rw if_neg, rw if_neg, simp, contradiction, contradiction,
  rw if_pos, rw if_pos, constructor, constructor,
  dsimp [exp.f], rw if_neg, simp,
  contradiction,
end

theorem exp_bit0 (x : α) (n:ℕ)
: exp x (bit0 n) = exp x n * exp x n :=
begin
  have p := exp_bit x ff n,
  simp [bit] at p,
  rw if_neg at p, simp at p,
  exact p, contradiction,
end

theorem exp_bit1 (x : α) (n:ℕ)
: exp x (bit1 n) = x * (exp x n * exp x n) :=
begin
  have p := exp_bit x tt n,
  simp [bit, mul_assoc] at p,
  exact p,
end

theorem exp_succ_identities
: ∀(x:α)(n:ℕ),
      x * exp x n = exp x (succ n)
    ∧ exp x n * x = exp x (succ n) :=
begin
  intros x n,
  revert x,
  revert n,

  apply @nat.binary_rec
    (λ(n:ℕ), (∀(x : α),
       x * exp x n = exp x (succ n)
     ∧ exp x n * x = exp x (succ n))),
  {
    simp [exp_one, exp_zero],
  },
  {
    intros b n ind x,
    have ind_left := λx, (ind x).left,
    have ind_right := λx, (ind x).right,
    cases b,

    case tt {
      simp only [ bit, cond ],
      rw [ nat.succ_bit1, exp_bit0, exp_bit1 ],

      apply and.intro,
      { transitivity,
        rw [← mul_assoc x (exp x n), ind_left, ← ind_right],
        -- Collect first successor
        rw [mul_assoc, ind_left],
        -- Collect second
        rw [← mul_assoc, ind_left],
      },
      {
        rw [mul_assoc, mul_assoc, ind_right],
        rw [← mul_assoc, ind_left],
      }
    },
    case ff {
      simp only [bit, cond],
      rw [← nat.bit1_eq_succ_bit0, exp_bit0, exp_bit1],
      apply and.intro,
      { trivial, },
      {
        -- Move extra x from right to left.
        rw [mul_assoc, ind_right],
        rw [← ind_left, ← mul_assoc, ind_right, ← ind_left],
        rw [mul_assoc],
      }
    }
  }
end

end exp

end nat


/-
## Relation classes

Init.Core provides some utilities, specifically `Init.Core.Equivalence`, but
we're not using it because it's not a typeclass (and difficult to relate to the
other relation classes).
-/

import GeneralizedRewriting.Eauto

abbrev relation (α: Type _) := α → α → Prop

class Reflexive {α: Type _} (R: relation α) where
  refl: ∀ x, R x x

class Symmetric {α: Type _} (R: relation α) where
  symm: ∀ {x y}, R x y → R y x

class Transitive {α: Type _} (R: relation α) where
  trans: ∀ {x y z}, R x y → R y z → R x z

class PER {α: Type _} (R: relation α) extends Symmetric R, Transitive R

class Equiv {α: Type _} (R: relation α) extends PER R, Reflexive R

/-
## Morphisms
-/

def respectful (Rα: relation α) (Rβ: relation β): relation (α → β) :=
  fun f g => forall a a', Rα a a' → Rβ (f a) (g a')

def pointwise_relation (α: Type _) {β} (R: relation β) : relation (α -> β) :=
  fun f g => forall a, R (f a) (g a)

def forall_relation {α: Type _} {P: α → Type _}
    (sig: forall a, relation (P a)): relation (forall x, P x) :=
  fun f g => forall a, sig a (f a) (g a)

def impl (P Q: Prop) := P → Q

class Proper (R: relation α) (x: α): Prop where
  prf: R x x

class Subrel {α} (R₁ R₂: relation α): Prop where
  prf: Subrelation R₁ R₂

notation Rα " ++> " Rβ => respectful Rα Rβ
notation Rα " --> " Rβ => respectful (flip Rα) Rβ
notation Rα " ==> " Rβ => respectful Rα Rβ

-- Instances used by the search algorithm

-- Avoid a `Reflexive (@Subrel α)` instance because that would allow `Subrel`
-- to be guessed as a codomain relation without an explicit hint, which almost
-- never makes sense.
theorem Reflexive_Subrel (R: relation α): Subrel R R := ⟨id⟩

instance Subrel_respectful [Sα: @Subrel α R₂ R₁] [Sβ: @Subrel β S₁ S₂]:
    Subrel (R₁ ==> S₁) (R₂ ==> S₂) where
  prf H _ _ h := Sβ.prf (H _ _ (Sα.prf h))

instance Subrel_pointwise [S: @Subrel β R₁ R₂]:
    Subrel (pointwise_relation α R₁) (pointwise_relation α R₂) where
  prf h a := S.prf (h a)

instance Proper_pointwise_relation {α β: Type _}:
    Proper (Subrel ==> Subrel) (@pointwise_relation α β) where
  prf _ _ h := ⟨fun hpr a => h.prf (hpr a)⟩

-- TODO: Introduce some `ProperProxy` to go faster with this one
instance Proper_Reflexive {α: Type _} (Rα: relation α) [Reflexive Rα] (a: α):
    Proper Rα a where
  prf := Reflexive.refl _

instance Subrel_Eq_respectful_Eq_Eq {α β: Type _}:
    Subrel Eq (@Eq α ==> @Eq β) :=
  ⟨fun h₁ _ _ h₂ => by simp [h₁, h₂]⟩

-- TODO: We can assume `Transitive R` and instead put `flip` in judicious
-- places for these rules. (This might require better suport for `flip`.)

instance {R: relation α} [PER R]: Proper (R ==> R ==> Iff) R where
  prf _ _ h_a _ _ h_b :=
    ⟨fun h => Transitive.trans (Transitive.trans (Symmetric.symm h_a) h) h_b,
     fun h => Transitive.trans (Transitive.trans h_a h) (Symmetric.symm h_b)⟩

instance {R: relation α} [PER R]: Proper (R ==> Eq ==> Iff) R where
  prf a a' h_a b b' h_b :=
    ⟨by rewrite [h_b]; exact fun h => Transitive.trans (Symmetric.symm h_a) h,
     by rewrite [h_b]; exact fun h => Transitive.trans h_a h⟩

instance {R: relation α} [PER R]: Proper (Eq ==> R ==> Iff) R where
  prf a a' h_a b b' h_b :=
    ⟨by rewrite [h_a]; exact fun h => Transitive.trans h h_b,
     by rewrite [h_a]; exact fun h => Transitive.trans h (Symmetric.symm h_b)⟩

-- Standard instances

instance: Equiv (@Eq α) where
  refl  := Eq.refl
  symm  := Eq.symm
  trans := Eq.trans

instance: Equiv Iff where
  refl  := Iff.refl
  symm  := Iff.symm
  trans := Iff.trans

instance Proper_flip [P: Proper (Rα ==> Rβ ==> Rγ) f]:
    Proper (Rβ ==> Rα ==> Rγ) (flip f) where
  prf _ _ h_b _ _ h_a := P.prf _ _ h_a _ _ h_b

instance Subrel_Eq [Reflexive R]: Subrel Eq R where
  prf h := h ▸ Reflexive.refl _

instance respectful_PER [PER R₁] [PER R₂]: PER (R₁ ==> R₂) where
  symm h x y h₁ := Symmetric.symm <| h y x <| Symmetric.symm h₁
  trans h h' x y h₁ :=
    Transitive.trans
      (h x y h₁)
      (h' y y (Transitive.trans (Symmetric.symm h₁) h₁))

instance Subrel_Iff_impl: Subrel Iff impl where
  prf h := h.1

instance Subrel_Iff_flip_impl: Subrel Iff (flip impl) where
  prf h := h.2

-- Some standard functions

instance Proper_And_Iff: Proper (Iff ==> Iff ==> Iff) And :=
 ⟨fun _ _ hx _ _ hy => by simp [hx, hy]⟩

instance Proper_Or_Iff: Proper (Iff ==> Iff ==> Iff) Or :=
 ⟨fun _ _ hx _ _ hy => by simp [hx, hy]⟩

instance Proper_Not_Iff: Proper (Iff ==> Iff) Not :=
 ⟨fun _ _ h => by simp [h]⟩

-- Theorem hints (ordered by most specific first)

eauto_create_db grewrite
eauto_hint Reflexive_Subrel: grewrite
eauto_hint Reflexive.refl: grewrite


/-
Copyright (c) 2022 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Floris van Doorn, Yury Kudryashov
-/
import order.filter.lift
import order.filter.at_top_bot

/-!
# The filter of small sets

This file defines the filter of small sets w.r.t. a filter `f`, which is the largest filter
containing all powersets of members of `f`.

`g` converges to `f.small_sets` if for all `s ∈ f`, eventually we have `g x ⊆ s`.

An example usage is that if `f : ι → E → ℝ` is a family of nonnegative functions with integral 1,
then saying that `λ i, support (f i)` tendsto `(𝓝 0).small_sets` is a way of saying that
`f` tends to the Dirac delta distribution.
-/

open_locale filter
open filter set

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

namespace filter

variables {l l' la : filter α} {lb : filter β}

/-- The filter `l.small_sets` is the largest filter containing all powersets of members of `l`. -/
def small_sets (l : filter α) : filter (set α) := l.lift' powerset

lemma small_sets_eq_generate {f : filter α} : f.small_sets = generate (powerset '' f.sets) :=
by { simp_rw [generate_eq_binfi, small_sets, infi_image], refl }

lemma has_basis.small_sets {p : ι → Prop} {s : ι → set α}
  (h : has_basis l p s) : has_basis l.small_sets p (λ i, 𝒫 (s i)) :=
h.lift' monotone_powerset

lemma has_basis_small_sets (l : filter α) :
  has_basis l.small_sets (λ t : set α, t ∈ l) powerset :=
l.basis_sets.small_sets

/-- `g` converges to `f.small_sets` if for all `s ∈ f`, eventually we have `g x ⊆ s`. -/
lemma tendsto_small_sets_iff {f : α → set β} :
  tendsto f la lb.small_sets ↔ ∀ t ∈ lb, ∀ᶠ x in la, f x ⊆ t :=
(has_basis_small_sets lb).tendsto_right_iff

lemma eventually_small_sets {p : set α → Prop} :
  (∀ᶠ s in l.small_sets, p s) ↔ ∃ s ∈ l, ∀ t ⊆ s, p t :=
eventually_lift'_iff monotone_powerset

lemma eventually_small_sets' {p : set α → Prop} (hp : ∀ ⦃s t⦄, s ⊆ t → p t → p s) :
  (∀ᶠ s in l.small_sets, p s) ↔ ∃ s ∈ l, p s :=
eventually_small_sets.trans $ exists₂_congr $ λ s hsf,
  ⟨λ H, H s subset.rfl, λ hs t ht, hp ht hs⟩

lemma frequently_small_sets {p : set α → Prop} :
  (∃ᶠ s in l.small_sets, p s) ↔ ∀ t ∈ l, ∃ s ⊆ t, p s :=
l.has_basis_small_sets.frequently_iff

lemma frequently_small_sets_mem (l : filter α) : ∃ᶠ s in l.small_sets, s ∈ l :=
frequently_small_sets.2 $ λ t ht, ⟨t, subset.rfl, ht⟩

lemma has_antitone_basis.tendsto_small_sets {ι} [preorder ι] {s : ι → set α}
  (hl : l.has_antitone_basis s) : tendsto s at_top l.small_sets :=
tendsto_small_sets_iff.2 $ λ t ht, hl.eventually_subset ht

@[mono] lemma monotone_small_sets : monotone (@small_sets α) :=
monotone_lift' monotone_id monotone_const

@[simp] lemma small_sets_bot : (⊥ : filter α).small_sets = pure ∅ :=
by rw [small_sets, lift'_bot monotone_powerset, powerset_empty, principal_singleton]

@[simp] lemma small_sets_top : (⊤ : filter α).small_sets = ⊤ :=
by rw [small_sets, lift'_top, powerset_univ, principal_univ]

@[simp] lemma small_sets_principal (s : set α) : (𝓟 s).small_sets = 𝓟(𝒫 s) :=
lift'_principal monotone_powerset

lemma small_sets_comap (l : filter β) (f : α → β) :
  (comap f l).small_sets = l.lift' (powerset ∘ preimage f) :=
comap_lift'_eq2 monotone_powerset

lemma comap_small_sets (l : filter β) (f : α → set β) :
  comap f l.small_sets = l.lift' (preimage f ∘ powerset) :=
comap_lift'_eq

lemma small_sets_infi {f : ι → filter α} :
  (infi f).small_sets = (⨅ i, (f i).small_sets) :=
lift'_infi_of_map_univ powerset_inter powerset_univ

lemma small_sets_inf (l₁ l₂ : filter α) :
  (l₁ ⊓ l₂).small_sets = l₁.small_sets ⊓ l₂.small_sets :=
lift'_inf _ _ powerset_inter

instance small_sets_ne_bot (l : filter α) : ne_bot l.small_sets :=
(lift'_ne_bot_iff monotone_powerset).2 $ λ _ _, powerset_nonempty

lemma tendsto.small_sets_mono {s t : α → set β}
  (ht : tendsto t la lb.small_sets) (hst : ∀ᶠ x in la, s x ⊆ t x) :
  tendsto s la lb.small_sets :=
begin
  rw [tendsto_small_sets_iff] at ht ⊢,
  exact λ u hu, (ht u hu).mp (hst.mono $ λ a hst ht, subset.trans hst ht)
end

@[simp] lemma eventually_small_sets_eventually {p : α → Prop} :
  (∀ᶠ s in l.small_sets, ∀ᶠ x in l', x ∈ s → p x) ↔ ∀ᶠ x in l ⊓ l', p x :=
calc _ ↔ ∃ s ∈ l, ∀ᶠ x in l', x ∈ s → p x :
  eventually_small_sets' $ λ s t hst ht, ht.mono $ λ x hx hs, hx (hst hs)
... ↔ ∃ (s ∈ l) (t ∈ l'), ∀ x, x ∈ t → x ∈ s → p x :
  by simp only [eventually_iff_exists_mem]
... ↔ ∀ᶠ x in l ⊓ l', p x : by simp only [eventually_inf, and_comm, mem_inter_iff, ← and_imp]

@[simp] lemma eventually_small_sets_forall {p : α → Prop} :
  (∀ᶠ s in l.small_sets, ∀ x ∈ s, p x) ↔ ∀ᶠ x in l, p x :=
by simpa only [inf_top_eq, eventually_top] using @eventually_small_sets_eventually α l ⊤ p

alias eventually_small_sets_forall ↔ filter.eventually.of_small_sets filter.eventually.small_sets

@[simp] lemma eventually_small_sets_subset {s : set α} :
  (∀ᶠ t in l.small_sets, t ⊆ s) ↔ s ∈ l :=
eventually_small_sets_forall

end filter