/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.adjunction.basic
import category_theory.conj

/-!
# Mate of natural transformations

This file establishes the bijection between the 2-cells

         L₁                  R₁
      C --→ D             C ←-- D
    G ↓  ↗  ↓ H         G ↓  ↘  ↓ H
      E --→ F             E ←-- F
         L₂                  R₂

where `L₁ ⊣ R₁` and `L₂ ⊣ R₂`, and shows that in the special case where `G,H` are identity then the
bijection preserves and reflects isomorphisms (i.e. we have bijections `(L₂ ⟶ L₁) ≃ (R₁ ⟶ R₂)`, and
if either side is an iso then the other side is as well).

On its own, this bijection is not particularly useful but it includes a number of interesting cases
as specializations.

For instance, this generalises the fact that adjunctions are unique (since if `L₁ ≅ L₂` then we
deduce `R₁ ≅ R₂`).
Another example arises from considering the square representing that a functor `H` preserves
products, in particular the morphism `HA ⨯ H- ⟶ H(A ⨯ -)`. Then provided `(A ⨯ -)` and `HA ⨯ -` have
left adjoints (for instance if the relevant categories are cartesian closed), the transferred
natural transformation is the exponential comparison morphism: `H(A ^ -) ⟶ HA ^ H-`.
Furthermore if `H` has a left adjoint `L`, this morphism is an isomorphism iff its mate
`L(HA ⨯ -) ⟶ A ⨯ L-` is an isomorphism, see
https://ncatlab.org/nlab/show/Frobenius+reciprocity#InCategoryTheory.
This also relates to Grothendieck's yoga of six operations, though this is not spelled out in
mathlib: https://ncatlab.org/nlab/show/six+operations.
-/
universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

namespace category_theory
open category

variables {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₂} D]

section square

variables {E : Type u₃} {F : Type u₄} [category.{v₃} E] [category.{v₄} F]

variables {G : C ⥤ E} {H : D ⥤ F} {L₁ : C ⥤ D} {R₁ : D ⥤ C} {L₂ : E ⥤ F} {R₂ : F ⥤ E}
variables (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂)

include adj₁ adj₂

/--
Suppose we have a square of functors (where the top and bottom are adjunctions `L₁ ⊣ R₁` and
`L₂ ⊣ R₂` respectively).

      C ↔ D
    G ↓   ↓ H
      E ↔ F

Then we have a bijection between natural transformations `G ⋙ L₂ ⟶ L₁ ⋙ H` and
`R₁ ⋙ G ⟶ H ⋙ R₂`.
This can be seen as a bijection of the 2-cells:

         L₁                  R₁
      C --→ D             C ←-- D
    G ↓  ↗  ↓ H         G ↓  ↘  ↓ H
      E --→ F             E ←-- F
         L₂                  R₂

Note that if one of the transformations is an iso, it does not imply the other is an iso.
-/
def transfer_nat_trans : (G ⋙ L₂ ⟶ L₁ ⋙ H) ≃ (R₁ ⋙ G ⟶ H ⋙ R₂) :=
{ to_fun := λ h,
  { app := λ X, adj₂.unit.app _ ≫ R₂.map (h.app _ ≫ H.map (adj₁.counit.app _)),
    naturality' := λ X Y f,
    begin
      dsimp,
      rw [assoc, ← R₂.map_comp, assoc, ← H.map_comp, ← adj₁.counit_naturality, H.map_comp,
          ←functor.comp_map L₁, ←h.naturality_assoc],
      simp,
    end },
  inv_fun := λ h,
  { app := λ X, L₂.map (G.map (adj₁.unit.app _) ≫ h.app _) ≫ adj₂.counit.app _,
  naturality' := λ X Y f,
  begin
    dsimp,
    rw [← L₂.map_comp_assoc, ← G.map_comp_assoc, ← adj₁.unit_naturality, G.map_comp_assoc,
        ← functor.comp_map, h.naturality],
    simp,
  end },
  left_inv := λ h,
  begin
    ext X,
    dsimp,
    simp only [L₂.map_comp, assoc, adj₂.counit_naturality, adj₂.left_triangle_components_assoc,
      ←functor.comp_map G L₂, h.naturality_assoc, functor.comp_map L₁, ←H.map_comp,
      adj₁.left_triangle_components],
    dsimp,
    simp, -- See library note [dsimp, simp].
  end,
  right_inv := λ h,
  begin
    ext X,
    dsimp,
    simp [-functor.comp_map, ←functor.comp_map H, functor.comp_map R₁, -nat_trans.naturality,
      ←h.naturality, -functor.map_comp, ←functor.map_comp_assoc G, R₂.map_comp],
  end }

lemma transfer_nat_trans_counit (f : G ⋙ L₂ ⟶ L₁ ⋙ H) (Y : D) :
  L₂.map ((transfer_nat_trans adj₁ adj₂ f).app _) ≫ adj₂.counit.app _ =
    f.app _ ≫ H.map (adj₁.counit.app Y) :=
by { erw functor.map_comp, simp }

lemma unit_transfer_nat_trans (f : G ⋙ L₂ ⟶ L₁ ⋙ H) (X : C) :
  G.map (adj₁.unit.app X) ≫ (transfer_nat_trans adj₁ adj₂ f).app _ =
    adj₂.unit.app _ ≫ R₂.map (f.app _) :=
begin
  dsimp [transfer_nat_trans],
  rw [←adj₂.unit_naturality_assoc, ←R₂.map_comp, ← functor.comp_map G L₂, f.naturality_assoc,
    functor.comp_map, ← H.map_comp],
  dsimp, simp, -- See library note [dsimp, simp]
end

end square

section self

variables {L₁ L₂ L₃ : C ⥤ D} {R₁ R₂ R₃ : D ⥤ C}
variables (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂) (adj₃ : L₃ ⊣ R₃)

/--
Given two adjunctions `L₁ ⊣ R₁` and `L₂ ⊣ R₂` both between categories `C`, `D`, there is a
bijection between natural transformations `L₂ ⟶ L₁` and natural transformations `R₁ ⟶ R₂`.
This is defined as a special case of `transfer_nat_trans`, where the two "vertical" functors are
identity.
TODO: Generalise to when the two vertical functors are equivalences rather than being exactly `𝟭`.

Furthermore, this bijection preserves (and reflects) isomorphisms, i.e. a transformation is an iso
iff its image under the bijection is an iso, see eg `category_theory.transfer_nat_trans_self_iso`.
This is in contrast to the general case `transfer_nat_trans` which does not in general have this
property.
-/
def transfer_nat_trans_self : (L₂ ⟶ L₁) ≃ (R₁ ⟶ R₂) :=
calc (L₂ ⟶ L₁) ≃ _         : (iso.hom_congr L₂.left_unitor L₁.right_unitor).symm
           ... ≃ _         : transfer_nat_trans adj₁ adj₂
           ... ≃ (R₁ ⟶ R₂) : R₁.right_unitor.hom_congr R₂.left_unitor

lemma transfer_nat_trans_self_counit (f : L₂ ⟶ L₁) (X) :
  L₂.map ((transfer_nat_trans_self adj₁ adj₂ f).app _) ≫ adj₂.counit.app X =
    f.app _ ≫ adj₁.counit.app X :=
begin
  dsimp [transfer_nat_trans_self],
  rw [id_comp, comp_id],
  have := transfer_nat_trans_counit adj₁ adj₂ (L₂.left_unitor.hom ≫ f ≫ L₁.right_unitor.inv) X,
  dsimp at this,
  rw this,
  simp,
end

lemma unit_transfer_nat_trans_self (f : L₂ ⟶ L₁) (X) :
  adj₁.unit.app _ ≫ (transfer_nat_trans_self adj₁ adj₂ f).app _ =
    adj₂.unit.app X ≫ functor.map _ (f.app _) :=
begin
  dsimp [transfer_nat_trans_self],
  rw [id_comp, comp_id],
  have := unit_transfer_nat_trans adj₁ adj₂ (L₂.left_unitor.hom ≫ f ≫ L₁.right_unitor.inv) X,
  dsimp at this,
  rw this,
  simp
end

@[simp]
lemma transfer_nat_trans_self_id : transfer_nat_trans_self adj₁ adj₁ (𝟙 _) = 𝟙 _ :=
by { ext, dsimp [transfer_nat_trans_self, transfer_nat_trans], simp }
  -- See library note [dsimp, simp]

@[simp]
lemma transfer_nat_trans_self_symm_id :
  (transfer_nat_trans_self adj₁ adj₁).symm (𝟙 _) = 𝟙 _ :=
by { rw equiv.symm_apply_eq, simp }

lemma transfer_nat_trans_self_comp (f g) :
  transfer_nat_trans_self adj₁ adj₂ f ≫ transfer_nat_trans_self adj₂ adj₃ g =
    transfer_nat_trans_self adj₁ adj₃ (g ≫ f) :=
begin
  ext,
  dsimp [transfer_nat_trans_self, transfer_nat_trans],
  simp only [id_comp, comp_id],
  rw [←adj₃.unit_naturality_assoc, ←R₃.map_comp, g.naturality_assoc, L₂.map_comp, assoc,
    adj₂.counit_naturality, adj₂.left_triangle_components_assoc, assoc],
end

lemma transfer_nat_trans_self_symm_comp (f g) :
  (transfer_nat_trans_self adj₂ adj₁).symm f ≫ (transfer_nat_trans_self adj₃ adj₂).symm g =
    (transfer_nat_trans_self adj₃ adj₁).symm (g ≫ f) :=
by { rw [equiv.eq_symm_apply, ← transfer_nat_trans_self_comp _ adj₂], simp }

lemma transfer_nat_trans_self_comm {f g} (gf : g ≫ f = 𝟙 _) :
  transfer_nat_trans_self adj₁ adj₂ f ≫ transfer_nat_trans_self adj₂ adj₁ g = 𝟙 _ :=
by rw [transfer_nat_trans_self_comp, gf, transfer_nat_trans_self_id]

lemma transfer_nat_trans_self_symm_comm {f g} (gf : g ≫ f = 𝟙 _) :
  (transfer_nat_trans_self adj₁ adj₂).symm f ≫ (transfer_nat_trans_self adj₂ adj₁).symm g = 𝟙 _ :=
by rw [transfer_nat_trans_self_symm_comp, gf, transfer_nat_trans_self_symm_id]

/--
If `f` is an isomorphism, then the transferred natural transformation is an isomorphism.
The converse is given in `transfer_nat_trans_self_of_iso`.
-/
instance transfer_nat_trans_self_iso (f : L₂ ⟶ L₁) [is_iso f] :
  is_iso (transfer_nat_trans_self adj₁ adj₂ f) :=
⟨⟨transfer_nat_trans_self adj₂ adj₁ (inv f),
  ⟨transfer_nat_trans_self_comm _ _ (by simp), transfer_nat_trans_self_comm _ _ (by simp)⟩⟩⟩

/--
If `f` is an isomorphism, then the un-transferred natural transformation is an isomorphism.
The converse is given in `transfer_nat_trans_self_symm_of_iso`.
-/
instance transfer_nat_trans_self_symm_iso (f : R₁ ⟶ R₂) [is_iso f] :
  is_iso ((transfer_nat_trans_self adj₁ adj₂).symm f) :=
⟨⟨(transfer_nat_trans_self adj₂ adj₁).symm (inv f),
  ⟨transfer_nat_trans_self_symm_comm _ _ (by simp),
   transfer_nat_trans_self_symm_comm _ _ (by simp)⟩⟩⟩

/--
If `f` is a natural transformation whose transferred natural transformation is an isomorphism,
then `f` is an isomorphism.
The converse is given in `transfer_nat_trans_self_iso`.
-/
lemma transfer_nat_trans_self_of_iso (f : L₂ ⟶ L₁) [is_iso (transfer_nat_trans_self adj₁ adj₂ f)] :
  is_iso f :=
begin
  suffices :
    is_iso ((transfer_nat_trans_self adj₁ adj₂).symm (transfer_nat_trans_self adj₁ adj₂ f)),
  { simpa using this },
  apply_instance,
end

/--
If `f` is a natural transformation whose un-transferred natural transformation is an isomorphism,
then `f` is an isomorphism.
The converse is given in `transfer_nat_trans_self_symm_iso`.
-/

end self

end category_theory


/-
Copyright (c) 2020 Shing Tak Lam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Shing Tak Lam
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.zmod.basic
import Mathlib.group_theory.order_of_element
import Mathlib.PostPort

universes l

namespace Mathlib

/-!
# Dihedral Groups

We define the dihedral groups `dihedral n`, with elements `r i` and `sr i` for `i : zmod n`.

For `n ≠ 0`, `dihedral n` represents the symmetry group of the regular `n`-gon. `r i` represents
the rotations of the `n`-gon by `2πi/n`, and `sr i` represents the reflections of the `n`-gon.
`dihedral 0` corresponds to the infinite dihedral group.
-/

/--
For `n ≠ 0`, `dihedral n` represents the symmetry group of the regular `n`-gon. `r i` represents
the rotations of the `n`-gon by `2πi/n`, and `sr i` represents the reflections of the `n`-gon.
`dihedral 0` corresponds to the infinite dihedral group.
-/
inductive dihedral (n : ℕ)
where
| r : zmod n → dihedral n
| sr : zmod n → dihedral n

namespace dihedral

/--
Multiplication of the dihedral group.
-/
/--
The identity `1` is the rotation by `0`.
-/
protected instance inhabited {n : ℕ} : Inhabited (dihedral n) :=
  { default := one }

/--
The inverse of a an element of the dihedral group.
-/
/--
The group structure on `dihedral n`.
-/
protected instance group {n : ℕ} : group (dihedral n) :=
  group.mk mul sorry one sorry sorry inv (div_inv_monoid.div._default mul sorry one sorry sorry inv) sorry

@[simp] theorem r_mul_r {n : ℕ} (i : zmod n) (j : zmod n) : r i * r j = r (i + j) :=
  rfl

@[simp] theorem r_mul_sr {n : ℕ} (i : zmod n) (j : zmod n) : r i * sr j = sr (j - i) :=
  rfl

@[simp] theorem sr_mul_r {n : ℕ} (i : zmod n) (j : zmod n) : sr i * r j = sr (i + j) :=
  rfl

@[simp] theorem sr_mul_sr {n : ℕ} (i : zmod n) (j : zmod n) : sr i * sr j = r (j - i) :=
  rfl

theorem one_def {n : ℕ} : 1 = r 0 :=
  rfl

/--
If `0 < n`, then `dihedral n` is a finite group.
-/
protected instance fintype {n : ℕ} [fact (0 < n)] : fintype (dihedral n) :=
  fintype.of_equiv (zmod n ⊕ zmod n) fintype_helper

protected instance nontrivial {n : ℕ} : nontrivial (dihedral n) :=
  nontrivial.mk (Exists.intro (r 0) (Exists.intro (sr 0) (of_as_true trivial)))

/--
If `0 < n`, then `dihedral n` has `2n` elements.
-/
theorem card {n : ℕ} [fact (0 < n)] : fintype.card (dihedral n) = bit0 1 * n := sorry

@[simp] theorem r_one_pow {n : ℕ} (k : ℕ) : r 1 ^ k = r ↑k := sorry

@[simp] theorem r_one_pow_n {n : ℕ} : r 1 ^ n = 1 := sorry

@[simp] theorem sr_mul_self {n : ℕ} (i : zmod n) : sr i * sr i = 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (sr i * sr i = 1)) (sr_mul_sr i i)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (r (i - i) = 1)) (sub_self i)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (r 0 = 1)) one_def)) (Eq.refl (r 0))))

/--
If `0 < n`, then `sr i` has order 2.
-/
@[simp] theorem order_of_sr {n : ℕ} [fact (0 < n)] (i : zmod n) : order_of (sr i) = bit0 1 := sorry

/--
If `0 < n`, then `r 1` has order `n`.
-/
@[simp] theorem order_of_r_one {n : ℕ} [hnpos : fact (0 < n)] : order_of (r 1) = n := sorry

/--
If `0 < n`, then `i : zmod n` has order `n / gcd n i`
-/
theorem order_of_r {n : ℕ} [fact (0 < n)] (i : zmod n) : order_of (r i) = n / nat.gcd n (zmod.val i) := sorry


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import number_theory.divisors
import ring_theory.int.basic
import tactic.ring_exp

/-!
# p-adic Valuation

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

This file defines the `p`-adic valuation on `ℕ`, `ℤ`, and `ℚ`.

The `p`-adic valuation on `ℚ` is the difference of the multiplicities of `p` in the numerator and
denominator of `q`. This function obeys the standard properties of a valuation, with the appropriate
assumptions on `p`. The `p`-adic valuations on `ℕ` and `ℤ` agree with that on `ℚ`.

The valuation induces a norm on `ℚ`. This norm is defined in padic_norm.lean.

## Notations

This file uses the local notation `/.` for `rat.mk`.

## Implementation notes

Much, but not all, of this file assumes that `p` is prime. This assumption is inferred automatically
by taking `[fact p.prime]` as a type class argument.

## References

* [F. Q. Gouvêa, *p-adic numbers*][gouvea1997]
* [R. Y. Lewis, *A formal proof of Hensel's lemma over the p-adic integers*][lewis2019]
* <https://en.wikipedia.org/wiki/P-adic_number>

## Tags

p-adic, p adic, padic, norm, valuation
-/

universe u

open nat

open_locale rat

open multiplicity

/-- For `p ≠ 1`, the `p`-adic valuation of a natural `n ≠ 0` is the largest natural number `k` such
that `p^k` divides `z`. If `n = 0` or `p = 1`, then `padic_val_nat p q` defaults to `0`. -/
def padic_val_nat (p : ℕ) (n : ℕ) : ℕ :=
if h : p ≠ 1 ∧ 0 < n then (multiplicity p n).get (multiplicity.finite_nat_iff.2 h) else 0

namespace padic_val_nat

open multiplicity

variables {p : ℕ}

/-- `padic_val_nat p 0` is `0` for any `p`. -/
@[simp] protected

/-- `padic_val_nat p 1` is `0` for any `p`. -/
@[simp] protected lemma one : padic_val_nat p 1 = 0 := by { unfold padic_val_nat, split_ifs, simp }

/-- If `p ≠ 0` and `p ≠ 1`, then `padic_val_rat p p` is `1`. -/
@[simp] lemma self (hp : 1 < p) : padic_val_nat p p = 1 :=
begin
  have neq_one : (¬ p = 1) ↔ true,
  { exact iff_of_true ((ne_of_lt hp).symm) trivial },
  have eq_zero_false : p = 0 ↔ false,
  { exact iff_false_intro ((ne_of_lt (trans zero_lt_one hp)).symm) },
  simp [padic_val_nat, neq_one, eq_zero_false]
end

@[simp] lemma eq_zero_iff {n : ℕ} : padic_val_nat p n = 0 ↔ p = 1 ∨ n = 0 ∨ ¬ p ∣ n :=
by simp only [padic_val_nat, dite_eq_right_iff, part_enat.get_eq_iff_eq_coe, nat.cast_zero,
  multiplicity_eq_zero, and_imp, pos_iff_ne_zero, ne.def, ← or_iff_not_imp_left]

lemma eq_zero_of_not_dvd {n : ℕ} (h : ¬ p ∣ n) : padic_val_nat p n = 0 :=
eq_zero_iff.2 $ or.inr $ or.inr h

end padic_val_nat

/-- For `p ≠ 1`, the `p`-adic valuation of an integer `z ≠ 0` is the largest natural number `k` such
that `p^k` divides `z`. If `x = 0` or `p = 1`, then `padic_val_int p q` defaults to `0`. -/
def padic_val_int (p : ℕ) (z : ℤ) : ℕ := padic_val_nat p z.nat_abs

namespace padic_val_int

open multiplicity

variables {p : ℕ}

lemma of_ne_one_ne_zero {z : ℤ} (hp : p ≠ 1) (hz : z ≠ 0) : padic_val_int p z =
  (multiplicity (p : ℤ) z).get (by {apply multiplicity.finite_int_iff.2, simp [hp, hz]}) :=
begin
  rw [padic_val_int, padic_val_nat, dif_pos (and.intro hp (int.nat_abs_pos_of_ne_zero hz))],
  simp only [multiplicity.int.nat_abs p z],
  refl
end

/-- `padic_val_int p 0` is `0` for any `p`. -/
@[simp] protected lemma zero : padic_val_int p 0 = 0 := by simp [padic_val_int]

/-- `padic_val_int p 1` is `0` for any `p`. -/
@[simp] protected lemma one : padic_val_int p 1 = 0 := by simp [padic_val_int]

/-- The `p`-adic value of a natural is its `p`-adic value as an integer. -/
@[simp] lemma of_nat {n : ℕ} : padic_val_int p n = padic_val_nat p n := by simp [padic_val_int]

/-- If `p ≠ 0` and `p ≠ 1`, then `padic_val_int p p` is `1`. -/
lemma self (hp : 1 < p) : padic_val_int p p = 1 := by simp [padic_val_nat.self hp]

lemma eq_zero_of_not_dvd {z : ℤ} (h : ¬ (p : ℤ) ∣ z) : padic_val_int p z = 0 :=
begin
  rw [padic_val_int, padic_val_nat],
  split_ifs; simp [multiplicity.int.nat_abs, multiplicity_eq_zero.2 h],
end

end padic_val_int

/-- `padic_val_rat` defines the valuation of a rational `q` to be the valuation of `q.num` minus the
valuation of `q.denom`. If `q = 0` or `p = 1`, then `padic_val_rat p q` defaults to `0`. -/
def padic_val_rat (p : ℕ) (q : ℚ) : ℤ := padic_val_int p q.num - padic_val_nat p q.denom

namespace padic_val_rat

open multiplicity

variables {p : ℕ}

/-- `padic_val_rat p q` is symmetric in `q`. -/
@[simp] protected lemma neg (q : ℚ) : padic_val_rat p (-q) = padic_val_rat p q :=
by simp [padic_val_rat, padic_val_int]

/-- `padic_val_rat p 0` is `0` for any `p`. -/
@[simp] protected lemma zero : padic_val_rat p 0 = 0 := by simp [padic_val_rat]

/-- `padic_val_rat p 1` is `0` for any `p`. -/
@[simp] protected lemma one : padic_val_rat p 1 = 0 := by simp [padic_val_rat]

/-- The `p`-adic value of an integer `z ≠ 0` is its `p`-adic_value as a rational. -/
@[simp] lemma of_int {z : ℤ} : padic_val_rat p z = padic_val_int p z := by simp [padic_val_rat]

/-- The `p`-adic value of an integer `z ≠ 0` is the multiplicity of `p` in `z`. -/
lemma of_int_multiplicity {z : ℤ} (hp : p ≠ 1) (hz : z ≠ 0) :
  padic_val_rat p (z : ℚ) = (multiplicity (p : ℤ) z).get (finite_int_iff.2 ⟨hp, hz⟩) :=
by rw [of_int, padic_val_int.of_ne_one_ne_zero hp hz]

lemma multiplicity_sub_multiplicity {q : ℚ} (hp : p ≠ 1) (hq : q ≠ 0) : padic_val_rat p q =
  (multiplicity (p : ℤ) q.num).get (finite_int_iff.2 ⟨hp, rat.num_ne_zero_of_ne_zero hq⟩) -
  (multiplicity p q.denom).get (by { rw [← finite_iff_dom, finite_nat_iff], exact ⟨hp, q.pos⟩ }) :=
begin
  rw [padic_val_rat, padic_val_int.of_ne_one_ne_zero hp, padic_val_nat, dif_pos],
  { refl },
  { exact ⟨hp, q.pos⟩ },
  { exact rat.num_ne_zero_of_ne_zero hq }
end

/-- The `p`-adic value of an integer `z ≠ 0` is its `p`-adic value as a rational. -/
@[simp] lemma of_nat {n : ℕ} : padic_val_rat p n = padic_val_nat p n := by simp [padic_val_rat]

/-- If `p ≠ 0` and `p ≠ 1`, then `padic_val_rat p p` is `1`. -/
lemma self (hp : 1 < p) : padic_val_rat p p = 1 := by simp [hp]

end padic_val_rat

section padic_val_nat

variables {p : ℕ}

lemma zero_le_padic_val_rat_of_nat (n : ℕ) : 0 ≤ padic_val_rat p n := by simp

/-- `padic_val_rat` coincides with `padic_val_nat`. -/
@[norm_cast] lemma padic_val_rat_of_nat (n : ℕ) : ↑(padic_val_nat p n) = padic_val_rat p n :=
by simp

/-- A simplification of `padic_val_nat` when one input is prime, by analogy with
`padic_val_rat_def`. -/
lemma padic_val_nat_def [hp : fact p.prime] {n : ℕ} (hn : 0 < n) :
  padic_val_nat p n
    = (multiplicity p n).get (multiplicity.finite_nat_iff.2 ⟨hp.out.ne_one, hn⟩) :=
dif_pos ⟨hp.out.ne_one, hn⟩

lemma padic_val_nat_def' {n : ℕ} (hp : p ≠ 1) (hn : 0 < n) :
  ↑(padic_val_nat p n) = multiplicity p n :=
by simp [padic_val_nat, hp, hn]

@[simp] lemma padic_val_nat_self [fact p.prime] : padic_val_nat p p = 1 :=
by simp [padic_val_nat_def (fact.out p.prime).pos]

lemma one_le_padic_val_nat_of_dvd {n : ℕ} [hp : fact p.prime] (hn : 0 < n) (div : p ∣ n) :
  1 ≤ padic_val_nat p n :=
by rwa [← part_enat.coe_le_coe, padic_val_nat_def' hp.out.ne_one hn, ← pow_dvd_iff_le_multiplicity,
  pow_one]

lemma dvd_iff_padic_val_nat_ne_zero {p n : ℕ} [fact p.prime] (hn0 : n ≠ 0) :
  (p ∣ n) ↔ padic_val_nat p n ≠ 0 :=
⟨λ h, one_le_iff_ne_zero.mp (one_le_padic_val_nat_of_dvd hn0.bot_lt h),
 λ h, not_not.1 (mt padic_val_nat.eq_zero_of_not_dvd h)⟩

end padic_val_nat

namespace padic_val_rat

open multiplicity

variables {p : ℕ} [hp : fact p.prime]

include hp

/-- The multiplicity of `p : ℕ` in `a : ℤ` is finite exactly when `a ≠ 0`. -/
lemma finite_int_prime_iff {a : ℤ} : finite (p : ℤ) a ↔ a ≠ 0 :=
by simp [finite_int_iff, ne.symm (ne_of_lt hp.1.one_lt)]

/-- A rewrite lemma for `padic_val_rat p q` when `q` is expressed in terms of `rat.mk`. -/
protected lemma defn (p : ℕ) [hp : fact p.prime] {q : ℚ} {n d : ℤ} (hqz : q ≠ 0)
  (qdf : q = n /. d) : padic_val_rat p q
    = (multiplicity (p : ℤ) n).get
      (finite_int_iff.2 ⟨ne.symm $ ne_of_lt hp.1.one_lt, λ hn, by simp * at *⟩)
    - (multiplicity (p : ℤ) d).get
      (finite_int_iff.2 ⟨ne.symm $ ne_of_lt hp.1.one_lt, λ hd, by simp * at *⟩) :=
have hd : d ≠ 0, from rat.mk_denom_ne_zero_of_ne_zero hqz qdf,
let ⟨c, hc1, hc2⟩ := rat.num_denom_mk hd qdf in
begin
  rw [padic_val_rat.multiplicity_sub_multiplicity];
  simp [hc1, hc2, multiplicity.mul' (nat.prime_iff_prime_int.1 hp.1),
    ne.symm (ne_of_lt hp.1.one_lt), hqz, pos_iff_ne_zero, int.coe_nat_multiplicity p q.denom]
end

/-- A rewrite lemma for `padic_val_rat p (q * r)` with conditions `q ≠ 0`, `r ≠ 0`. -/
protected lemma mul {q r : ℚ} (hq : q ≠ 0) (hr : r ≠ 0) :
  padic_val_rat p (q * r) = padic_val_rat p q + padic_val_rat p r :=
have q * r = (q.num * r.num) /. (q.denom * r.denom), by rw_mod_cast rat.mul_num_denom,
have hq' : q.num /. q.denom ≠ 0, by rw rat.num_denom; exact hq,
have hr' : r.num /. r.denom ≠ 0, by rw rat.num_denom; exact hr,
have hp' : _root_.prime (p : ℤ), from nat.prime_iff_prime_int.1 hp.1,
begin
  rw [padic_val_rat.defn p (mul_ne_zero hq hr) this],
  conv_rhs { rw [← @rat.num_denom q, padic_val_rat.defn p hq', ← @rat.num_denom r,
    padic_val_rat.defn p hr'] },
  rw [multiplicity.mul' hp', multiplicity.mul' hp']; simp [add_comm, add_left_comm, sub_eq_add_neg]
end

/-- A rewrite lemma for `padic_val_rat p (q^k)` with condition `q ≠ 0`. -/
protected lemma pow {q : ℚ} (hq : q ≠ 0) {k : ℕ} :
  padic_val_rat p (q ^ k) = k * padic_val_rat p q :=
by induction k; simp [*, padic_val_rat.mul hq (pow_ne_zero _ hq), pow_succ, add_mul, add_comm]

/-- A rewrite lemma for `padic_val_rat p (q⁻¹)` with condition `q ≠ 0`. -/
protected lemma inv (q : ℚ) : padic_val_rat p q⁻¹ = -padic_val_rat p q :=
begin
  by_cases hq : q = 0,
  { simp [hq] },
  { rw [eq_neg_iff_add_eq_zero, ← padic_val_rat.mul (inv_ne_zero hq) hq, inv_mul_cancel hq,
      padic_val_rat.one],
    exact hp },
end

/-- A rewrite lemma for `padic_val_rat p (q / r)` with conditions `q ≠ 0`, `r ≠ 0`. -/
protected lemma div {q r : ℚ} (hq : q ≠ 0) (hr : r ≠ 0) :
  padic_val_rat p (q / r) = padic_val_rat p q - padic_val_rat p r :=
begin
  rw [div_eq_mul_inv, padic_val_rat.mul hq (inv_ne_zero hr), padic_val_rat.inv r, sub_eq_add_neg],
  all_goals { exact hp }
end

/-- A condition for `padic_val_rat p (n₁ / d₁) ≤ padic_val_rat p (n₂ / d₂)`, in terms of
divisibility by `p^n`. -/
lemma padic_val_rat_le_padic_val_rat_iff {n₁ n₂ d₁ d₂ : ℤ}
  (hn₁ : n₁ ≠ 0) (hn₂ : n₂ ≠ 0) (hd₁ : d₁ ≠ 0) (hd₂ : d₂ ≠ 0) :
  padic_val_rat p (n₁ /. d₁) ≤ padic_val_rat p (n₂ /. d₂) ↔
  ∀ n : ℕ, ↑p ^ n ∣ n₁ * d₂ → ↑p ^ n ∣ n₂ * d₁ :=
have hf1 : finite (p : ℤ) (n₁ * d₂),
  from finite_int_prime_iff.2 (mul_ne_zero hn₁ hd₂),
have hf2 : finite (p : ℤ) (n₂ * d₁),
  from finite_int_prime_iff.2 (mul_ne_zero hn₂ hd₁),
  by conv
  { to_lhs,
    rw [padic_val_rat.defn p (rat.mk_ne_zero_of_ne_zero hn₁ hd₁) rfl,
      padic_val_rat.defn p (rat.mk_ne_zero_of_ne_zero hn₂ hd₂) rfl,
      sub_le_iff_le_add', ← add_sub_assoc, le_sub_iff_add_le],
    norm_cast,
    rw [← multiplicity.mul' (nat.prime_iff_prime_int.1 hp.1) hf1, add_comm,
      ← multiplicity.mul' (nat.prime_iff_prime_int.1 hp.1) hf2,
      part_enat.get_le_get, multiplicity_le_multiplicity_iff] }

/-- Sufficient conditions to show that the `p`-adic valuation of `q` is less than or equal to the
`p`-adic valuation of `q + r`. -/
theorem le_padic_val_rat_add_of_le {q r : ℚ} (hqr : q + r ≠ 0)
  (h : padic_val_rat p q ≤ padic_val_rat p r) : padic_val_rat p q ≤ padic_val_rat p (q + r) :=
if hq : q = 0 then by simpa [hq] using h else
if hr : r = 0 then by simp [hr] else
have hqn : q.num ≠ 0, from rat.num_ne_zero_of_ne_zero hq,
have hqd : (q.denom : ℤ) ≠ 0, by exact_mod_cast rat.denom_ne_zero _,
have hrn : r.num ≠ 0, from rat.num_ne_zero_of_ne_zero hr,
have hrd : (r.denom : ℤ) ≠ 0, by exact_mod_cast rat.denom_ne_zero _,
have hqreq : q + r = (q.num * r.denom + q.denom * r.num) /. (q.denom * r.denom),
  from rat.add_num_denom _ _,
have hqrd : q.num * r.denom + q.denom * r.num ≠ 0,
  from rat.mk_num_ne_zero_of_ne_zero hqr hqreq,
begin
  conv_lhs { rw ← @rat.num_denom q },
  rw [hqreq, padic_val_rat_le_padic_val_rat_iff hqn hqrd hqd (mul_ne_zero hqd hrd),
    ← multiplicity_le_multiplicity_iff, mul_left_comm,
    multiplicity.mul (nat.prime_iff_prime_int.1 hp.1), add_mul],
  rw [← @rat.num_denom q, ← @rat.num_denom r, padic_val_rat_le_padic_val_rat_iff hqn hrn hqd hrd,
    ← multiplicity_le_multiplicity_iff] at h,
  calc _ ≤ min (multiplicity ↑p (q.num * ↑r.denom * ↑q.denom))
    (multiplicity ↑p (↑q.denom * r.num * ↑q.denom)) : (le_min
    (by rw [@multiplicity.mul _ _ _ _ (_ * _) _ (nat.prime_iff_prime_int.1 hp.1), add_comm])
    (by rw [mul_assoc, @multiplicity.mul _ _ _ _ (q.denom : ℤ)
        (_ * _) (nat.prime_iff_prime_int.1 hp.1)]; exact add_le_add_left h _))
    ... ≤ _ : min_le_multiplicity_add,
  all_goals { exact hp }
end

/-- The minimum of the valuations of `q` and `r` is at most the valuation of `q + r`. -/
theorem min_le_padic_val_rat_add {q r : ℚ} (hqr : q + r ≠ 0) :
  min (padic_val_rat p q) (padic_val_rat p r) ≤ padic_val_rat p (q + r) :=
(le_total (padic_val_rat p q) (padic_val_rat p r)).elim
  (λ h, by rw [min_eq_left h]; exact le_padic_val_rat_add_of_le hqr h)
  (λ h, by rw [min_eq_right h, add_comm]; exact le_padic_val_rat_add_of_le (by rwa add_comm) h)

open_locale big_operators

/-- A finite sum of rationals with positive `p`-adic valuation has positive `p`-adic valuation
(if the sum is non-zero). -/
theorem sum_pos_of_pos {n : ℕ} {F : ℕ → ℚ} (hF : ∀ i, i < n → 0 < padic_val_rat p (F i))
  (hn0 : ∑ i in finset.range n, F i ≠ 0) : 0 < padic_val_rat p (∑ i in finset.range n, F i) :=
begin
  induction n with d hd,
  { exact false.elim (hn0 rfl) },
  { rw finset.sum_range_succ at hn0 ⊢,
    by_cases h : ∑ (x : ℕ) in finset.range d, F x = 0,
    { rw [h, zero_add],
      exact hF d (lt_add_one _) },
    { refine lt_of_lt_of_le _ (min_le_padic_val_rat_add hn0),
      { refine lt_min (hd (λ i hi, _) h) (hF d (lt_add_one _)),
        exact hF _ (lt_trans hi (lt_add_one _)) } } }
end

end padic_val_rat

namespace padic_val_nat

variables {p a b : ℕ} [hp : fact p.prime]

include hp

/-- A rewrite lemma for `padic_val_nat p (a * b)` with conditions `a ≠ 0`, `b ≠ 0`. -/
protected lemma mul : a ≠ 0 → b ≠ 0 →
  padic_val_nat p (a * b) = padic_val_nat p a + padic_val_nat p b :=
by exact_mod_cast @padic_val_rat.mul p _ a b

protected lemma div_of_dvd (h : b ∣ a) :
  padic_val_nat p (a / b) = padic_val_nat p a - padic_val_nat p b :=
begin
  rcases eq_or_ne a 0 with rfl | ha,
  { simp },
  obtain ⟨k, rfl⟩ := h,
  obtain ⟨hb, hk⟩ := mul_ne_zero_iff.mp ha,
  rw [mul_comm, k.mul_div_cancel hb.bot_lt, padic_val_nat.mul hk hb, nat.add_sub_cancel],
  exact hp
end

/-- Dividing out by a prime factor reduces the `padic_val_nat` by `1`. -/
protected lemma div (dvd : p ∣ b) : padic_val_nat p (b / p) = (padic_val_nat p b) - 1 :=
begin
  convert padic_val_nat.div_of_dvd dvd,
  rw padic_val_nat_self,
  exact hp
end

/-- A version of `padic_val_rat.pow` for `padic_val_nat`. -/
protected lemma pow (n : ℕ) (ha : a ≠ 0) :
  padic_val_nat p (a ^ n) = n * padic_val_nat p a :=
by simpa only [← @nat.cast_inj ℤ] with push_cast using padic_val_rat.pow (cast_ne_zero.mpr ha)

@[simp] protected lemma prime_pow (n : ℕ) : padic_val_nat p (p ^ n) = n :=
by rwa [padic_val_nat.pow _ (fact.out p.prime).ne_zero, padic_val_nat_self, mul_one]

protected lemma div_pow (dvd : p ^ a ∣ b) : padic_val_nat p (b / p ^ a) = (padic_val_nat p b) - a :=
begin
  rw [padic_val_nat.div_of_dvd dvd, padic_val_nat.prime_pow],
  exact hp
end

protected lemma div' {m : ℕ} (cpm : coprime p m) {b : ℕ} (dvd : m ∣ b) :
  padic_val_nat p (b / m) = padic_val_nat p b :=
by rw [padic_val_nat.div_of_dvd dvd, eq_zero_of_not_dvd (hp.out.coprime_iff_not_dvd.mp cpm),
  nat.sub_zero]; assumption

end padic_val_nat

section padic_val_nat

variables {p : ℕ}

lemma dvd_of_one_le_padic_val_nat {n : ℕ} (hp : 1 ≤ padic_val_nat p n) : p ∣ n :=
begin
  by_contra h,
  rw padic_val_nat.eq_zero_of_not_dvd h at hp,
  exact lt_irrefl 0 (lt_of_lt_of_le zero_lt_one hp)
end

lemma pow_padic_val_nat_dvd {n : ℕ} : p ^ padic_val_nat p n ∣ n :=
begin
  rcases n.eq_zero_or_pos with rfl | hn, { simp },
  rcases eq_or_ne p 1 with rfl | hp, { simp },
  rw [multiplicity.pow_dvd_iff_le_multiplicity, padic_val_nat_def']; assumption
end

lemma padic_val_nat_dvd_iff_le [hp : fact p.prime] {a n : ℕ} (ha : a ≠ 0) :
  p ^ n ∣ a ↔ n ≤ padic_val_nat p a :=
by rw [pow_dvd_iff_le_multiplicity, ← padic_val_nat_def' hp.out.ne_one ha.bot_lt,
  part_enat.coe_le_coe]

lemma padic_val_nat_dvd_iff (n : ℕ) [hp : fact p.prime] (a : ℕ) :
  p ^ n ∣ a ↔ a = 0 ∨ n ≤ padic_val_nat p a :=
begin
  rcases eq_or_ne a 0 with rfl | ha,
  { exact iff_of_true (dvd_zero _) (or.inl rfl) },
  { simp only [ha, false_or, padic_val_nat_dvd_iff_le ha] }
end

lemma pow_succ_padic_val_nat_not_dvd {n : ℕ} [hp : fact p.prime] (hn : n ≠ 0) :
  ¬ p ^ (padic_val_nat p n + 1) ∣ n :=
begin
  rw [padic_val_nat_dvd_iff_le hn, not_le],
  exacts [nat.lt_succ_self _, hp]
end

lemma padic_val_nat_primes {q : ℕ} [hp : fact p.prime] [hq : fact q.prime] (neq : p ≠ q) :
  padic_val_nat p q = 0 :=
@padic_val_nat.eq_zero_of_not_dvd p q $
  (not_congr (iff.symm (prime_dvd_prime_iff_eq hp.1 hq.1))).mp neq

open_locale big_operators

lemma range_pow_padic_val_nat_subset_divisors {n : ℕ} (hn : n ≠ 0) :
  (finset.range (padic_val_nat p n + 1)).image (pow p) ⊆ n.divisors :=
begin
  intros t ht,
  simp only [exists_prop, finset.mem_image, finset.mem_range] at ht,
  obtain ⟨k, hk, rfl⟩ := ht,
  rw nat.mem_divisors,
  exact ⟨(pow_dvd_pow p $ by linarith).trans pow_padic_val_nat_dvd, hn⟩
end

lemma range_pow_padic_val_nat_subset_divisors' {n : ℕ} [hp : fact p.prime] :
  (finset.range (padic_val_nat p n)).image (λ t, p ^ (t + 1)) ⊆ n.divisors.erase 1 :=
begin
  rcases eq_or_ne n 0 with rfl | hn,
  { simp },
  intros t ht,
  simp only [exists_prop, finset.mem_image, finset.mem_range] at ht,
  obtain ⟨k, hk, rfl⟩ := ht,
  rw [finset.mem_erase, nat.mem_divisors],
  refine ⟨_, (pow_dvd_pow p $ succ_le_iff.2 hk).trans pow_padic_val_nat_dvd, hn⟩,
  exact (nat.one_lt_pow _ _ k.succ_pos hp.out.one_lt).ne'
end

end padic_val_nat

section padic_val_int

variables {p : ℕ} [hp : fact p.prime]

include hp

lemma padic_val_int_dvd_iff (n : ℕ) (a : ℤ) : (p : ℤ) ^ n ∣ a ↔ a = 0 ∨ n ≤ padic_val_int p a :=
by rw [padic_val_int, ← int.nat_abs_eq_zero, ← padic_val_nat_dvd_iff, ← int.coe_nat_dvd_left,
    int.coe_nat_pow]

lemma padic_val_int_dvd (a : ℤ) : (p : ℤ) ^ padic_val_int p a ∣ a :=
begin
  rw padic_val_int_dvd_iff,
  exact or.inr le_rfl
end

lemma padic_val_int_self : padic_val_int p p = 1 := padic_val_int.self hp.out.one_lt

lemma padic_val_int.mul {a b : ℤ} (ha : a ≠ 0) (hb : b ≠ 0) :
  padic_val_int p (a * b) = padic_val_int p a + padic_val_int p b :=
begin
  simp_rw padic_val_int,
  rw [int.nat_abs_mul, padic_val_nat.mul];
  rwa int.nat_abs_ne_zero
end

lemma padic_val_int_mul_eq_succ (a : ℤ) (ha : a ≠ 0) :
  padic_val_int p (a * p) = (padic_val_int p a) + 1 :=
begin
  rw padic_val_int.mul ha (int.coe_nat_ne_zero.mpr hp.out.ne_zero),
  simp only [eq_self_iff_true, padic_val_int.of_nat, padic_val_nat_self],
  exact hp
end

end padic_val_int


import order.boolean_algebra
import for_mathlib.closure

variables {B : Type*} [boolean_algebra B]
-- Main example of interest: B = set α, or a boolean subalgebra.

-- Other descriptions are possible (the dual one using ⊤ and ⊓, for a start);
-- we could provide alternate constructors for these.
structure is_boolean_subalgebra (s : set B) : Prop :=
(mem_bot : ⊥ ∈ s)
(mem_sup {x y} : x ∈ s → y ∈ s → x ⊔ y ∈ s)
(mem_compl {x} : x ∈ s → xᶜ ∈ s)

lemma is_boolean_subalgebra.mem_inf {s : set B} (h : is_boolean_subalgebra s)
  {x y} (hx : x ∈ s) (hy : y ∈ s) : x ⊓ y ∈ s :=
begin
  convert h.mem_compl (h.mem_sup (h.mem_compl hx) (h.mem_compl hy)),
  simp
end

lemma is_boolean_subalgebra.mem_top {s : set B} (h : is_boolean_subalgebra s) :
  ⊤ ∈ s :=
begin
  convert h.mem_compl h.mem_bot,
  rw compl_bot
end

namespace boolean_subalgebra

/-- The smallest boolean subalgebra containing a given set `s`. -/
inductive gen (s : set B) : set B
| basic {x} : x ∈ s → gen x
| bot : gen ⊥
| sup {x y} : gen x → gen y → gen (x ⊔ y)
| compl {x} : gen x → gen (xᶜ)

lemma gen.is_boolean_subalgebra {s : set B} : is_boolean_subalgebra (gen s) :=
⟨gen.bot, λ x y, gen.sup, λ x, gen.compl⟩

-- TODO(?): These lemmas don't have quite the same shape as the constructors
-- (phrased in terms of ∈, not function application)

lemma gen.top {s : set B} : ⊤ ∈ gen s :=
gen.is_boolean_subalgebra.mem_top

lemma gen.inf {s : set B} {x y} : x ∈ gen s → y ∈ gen s → x ⊓ y ∈ gen s :=
gen.is_boolean_subalgebra.mem_inf

lemma gen_subset_iff_subset {s t : set B} (ht : is_boolean_subalgebra t) :
  gen s ⊆ t ↔ s ⊆ t :=
begin
  split; intro h,
  { intros x hx,
    exact h (gen.basic hx) },
  { intros x₀ hx₀,
    induction hx₀ with x hx x y hx hy IHx IHy x hx IHx; clear x₀,
    { exact h hx },
    { exact ht.mem_bot },
    { exact ht.mem_sup IHx IHy },
    { exact ht.mem_compl IHx } }
end

lemma gen_subset_gen_iff_subset_gen {s t : set B} :
  gen s ⊆ gen t ↔ s ⊆ gen t :=
gen_subset_iff_subset gen.is_boolean_subalgebra

lemma self_subset_gen {s : set B} : s ⊆ gen s :=
by rw ←gen_subset_gen_iff_subset_gen

lemma gen_mono {s t : set B} (h : s ⊆ t) : gen s ⊆ gen t :=
begin
  rw gen_subset_gen_iff_subset_gen,
  exact set.subset.trans h self_subset_gen,
end

end boolean_subalgebra

variables {α : Type*}
lemma finite_union_closure_subset_gen {s : set (set α)} :
  finite_union_closure s ⊆ boolean_subalgebra.gen s :=
begin
  intros x hx,
  induction hx with x hx x y hx hy IHx IHy,
  { exact boolean_subalgebra.gen.basic hx },
  { exact boolean_subalgebra.gen.bot },
  { exact boolean_subalgebra.gen.sup IHx IHy }
end


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

import data.polynomial.algebra_map
import ring_theory.localization.basic

/-!  # Laurent polynomials

We introduce Laurent polynomials over a semiring `R`.  Mathematically, they are expressions of the
form
$$
\sum_{i \in \mathbb{Z}} a_i T ^ i
$$
where the sum extends over a finite subset of `ℤ`.  Thus, negative exponents are allowed.  The
coefficients come from the semiring `R` and the variable `T` commutes with everything.

Since we are going to convert back and forth between polynomials and Laurent polynomials, we
decided to maintain some distinction by using the symbol `T`, rather than `X`, as the variable for
Laurent polynomials

## Notation
The symbol `R[T;T⁻¹]` stands for `laurent_polynomial R`.  We also define

* `C : R →+* R[T;T⁻¹]` the inclusion of constant polynomials, analogous to the one for `R[X]`;
* `T : ℤ → R[T;T⁻¹]` the sequence of powers of the variable `T`.

## Implementation notes

We define Laurent polynomials as `add_monoid_algebra R ℤ`.
Thus, they are essentially `finsupp`s `ℤ →₀ R`.
This choice differs from the current irreducible design of `polynomial`, that instead shields away
the implementation via `finsupp`s.  It is closer to the original definition of polynomials.

As a consequence, `laurent_polynomial` plays well with polynomials, but there is a little roughness
in establishing the API, since the `finsupp` implementation of `polynomial R` is well-shielded.

Unlike the case of polynomials, I felt that the exponent notation was not too easy to use, as only
natural exponents would be allowed.  Moreover, in the end, it seems likely that we should aim to
perform computations on exponents in `ℤ` anyway and separating this via the symbol `T` seems
convenient.

I made a *heavy* use of `simp` lemmas, aiming to bring Laurent polynomials to the form `C a * T n`.
Any comments or suggestions for improvements is greatly appreciated!

##  Future work
Lots is missing!
-- (Riccardo) add inclusion into Laurent series.
-- (Riccardo) giving a morphism (as `R`-alg, so in the commutative case)
  from `R[T,T⁻¹]` to `S` is the same as choosing a unit of `S`.
-- A "better" definition of `trunc` would be as an `R`-linear map.  This works:
--  ```
--  def trunc : R[T;T⁻¹] →[R] R[X] :=
--  begin
--    refine (_ : add_monoid_algebra R ℕ →[R] R[X]).comp _,
--    { exact ⟨(to_finsupp_iso R).symm, by simp⟩ },
--    { refine ⟨λ r, comap_domain _ r (set.inj_on_of_injective (λ a b ab, int.of_nat.inj ab) _), _⟩,
--      exact λ r f, comap_domain_smul _ _ _ }
--  end
--  ```
--  but it would make sense to bundle the maps better, for a smoother user experience.
--  I (DT) did not have the strength to embark on this (possibly short!) journey, after getting to
--  this stage of the Laurent process!
--  This would likely involve adding a `comap_domain` analogue of
--  `add_monoid_algebra.map_domain_alg_hom` and an `R`-linear version of
--  `polynomial.to_finsupp_iso`.
-- Add `degree, int_degree, int_trailing_degree, leading_coeff, trailing_coeff,...`.
-/

open_locale polynomial big_operators
open polynomial add_monoid_algebra finsupp
noncomputable theory

variables {R : Type*}

/--  The semiring of Laurent polynomials with coefficients in the semiring `R`.
We denote it by `R[T;T⁻¹]`.
The ring homomorphism `C : R →+* R[T;T⁻¹]` includes `R` as the constant polynomials. -/
abbreviation laurent_polynomial (R : Type*) [semiring R] := add_monoid_algebra R ℤ

local notation R`[T;T⁻¹]`:9000 := laurent_polynomial R

/--  The ring homomorphism, taking a polynomial with coefficients in `R` to a Laurent polynomial
with coefficients in `R`. -/
def polynomial.to_laurent [semiring R] : R[X] →+* R[T;T⁻¹] :=
(map_domain_ring_hom R int.of_nat_hom).comp (to_finsupp_iso R)

/-- This is not a simp lemma, as it is usually preferable to use the lemmas about `C` and `X`
instead. -/
lemma polynomial.to_laurent_apply [semiring R] (p : R[X]) :
  p.to_laurent = p.to_finsupp.map_domain coe := rfl

/--  The `R`-algebra map, taking a polynomial with coefficients in `R` to a Laurent polynomial
with coefficients in `R`. -/
def polynomial.to_laurent_alg [comm_semiring R] :
  R[X] →ₐ[R] R[T;T⁻¹] :=
begin
  refine alg_hom.comp _ (to_finsupp_iso_alg R).to_alg_hom,
  exact (map_domain_alg_hom R R int.of_nat_hom),
end

@[simp]
lemma polynomial.to_laurent_alg_apply [comm_semiring R] (f : R[X]) :
  f.to_laurent_alg = f.to_laurent := rfl

namespace laurent_polynomial

section semiring
variables [semiring R]

lemma single_zero_one_eq_one : (single 0 1 : R[T;T⁻¹]) = (1 : R[T;T⁻¹]) := rfl

/-!  ### The functions `C` and `T`. -/
/--  The ring homomorphism `C`, including `R` into the ring of Laurent polynomials over `R` as
the constant Laurent polynomials. -/
def C : R →+* R[T;T⁻¹] :=
single_zero_ring_hom

lemma algebra_map_apply {R A : Type*} [comm_semiring R] [semiring A] [algebra R A] (r : R) :
  algebra_map R (laurent_polynomial A) r = C (algebra_map R A r) :=
rfl

/--
When we have `[comm_semiring R]`, the function `C` is the same as `algebra_map R R[T;T⁻¹]`.
(But note that `C` is defined when `R` is not necessarily commutative, in which case
`algebra_map` is not available.)
-/
lemma C_eq_algebra_map {R : Type*} [comm_semiring R] (r : R) :
  C r = algebra_map R R[T;T⁻¹] r :=
rfl

lemma single_eq_C (r : R) : single 0 r = C r := rfl

/--  The function `n ↦ T ^ n`, implemented as a sequence `ℤ → R[T;T⁻¹]`.

Using directly `T ^ n` does not work, since we want the exponents to be of Type `ℤ` and there
is no `ℤ`-power defined on `R[T;T⁻¹]`.  Using that `T` is a unit introduces extra coercions.
For these reasons, the definition of `T` is as a sequence. -/
def T (n : ℤ) : R[T;T⁻¹] := single n 1

@[simp]
lemma T_zero : (T 0 : R[T;T⁻¹]) = 1 := rfl

lemma T_add (m n : ℤ) : (T (m + n) : R[T;T⁻¹]) = T m * T n :=
by { convert single_mul_single.symm, simp [T] }

lemma T_sub (m n : ℤ) : (T (m - n) : R[T;T⁻¹]) = T m * T (-n) :=
by rw [← T_add, sub_eq_add_neg]

@[simp]
lemma T_pow (m : ℤ) (n : ℕ) : (T m ^ n : R[T;T⁻¹]) = T (n * m) :=
by rw [T, T, single_pow n, one_pow, nsmul_eq_mul]

/-- The `simp` version of `mul_assoc`, in the presence of `T`'s. -/
@[simp]
lemma mul_T_assoc (f : R[T;T⁻¹]) (m n : ℤ) : f * T m * T n = f * T (m + n) :=
by simp [← T_add, mul_assoc]

@[simp]
lemma single_eq_C_mul_T (r : R) (n : ℤ) :
  (single n r : R[T;T⁻¹]) = (C r * T n : R[T;T⁻¹]) :=
by convert single_mul_single.symm; simp

-- This lemma locks in the right changes and is what Lean proved directly.
-- The actual `simp`-normal form of a Laurent monomial is `C a * T n`, whenever it can be reached.
@[simp]
lemma _root_.polynomial.to_laurent_C_mul_T (n : ℕ) (r : R) :
  ((polynomial.monomial n r).to_laurent : R[T;T⁻¹]) = C r * T n :=
show map_domain coe (monomial n r).to_finsupp = (C r * T n : R[T;T⁻¹]),
by rw [to_finsupp_monomial, map_domain_single, single_eq_C_mul_T]

@[simp]
lemma _root_.polynomial.to_laurent_C (r : R) :
  (polynomial.C r).to_laurent = C r :=
begin
  convert polynomial.to_laurent_C_mul_T 0 r,
  simp only [int.coe_nat_zero, T_zero, mul_one],
end

@[simp]
lemma _root_.polynomial.to_laurent_X :
  (polynomial.X.to_laurent : R[T;T⁻¹]) = T 1 :=
begin
  have : (polynomial.X : R[X]) = monomial 1 1,
  { simp [monomial_eq_C_mul_X] },
  simp [this, polynomial.to_laurent_C_mul_T],
end

@[simp] lemma _root_.polynomial.to_laurent_one : (polynomial.to_laurent : R[X] → R[T;T⁻¹]) 1 = 1 :=
map_one polynomial.to_laurent

@[simp]
lemma _root_.polynomial.to_laurent_C_mul_eq (r : R) (f : R[X]):
  (polynomial.C r * f).to_laurent = C r * f.to_laurent :=
by simp only [_root_.map_mul, polynomial.to_laurent_C]

@[simp]
lemma _root_.polynomial.to_laurent_X_pow (n : ℕ) :
  (X ^ n : R[X]).to_laurent = T n :=
by simp only [map_pow, polynomial.to_laurent_X, T_pow, mul_one]

@[simp]
lemma _root_.polynomial.to_laurent_C_mul_X_pow (n : ℕ) (r : R) :
  (polynomial.C r * X ^ n).to_laurent = C r * T n :=
by simp only [_root_.map_mul, polynomial.to_laurent_C, polynomial.to_laurent_X_pow]

instance invertible_T (n : ℤ) : invertible (T n : R[T;T⁻¹]) :=
{ inv_of := T (- n),
  inv_of_mul_self := by rw [← T_add, add_left_neg, T_zero],
  mul_inv_of_self := by rw [← T_add, add_right_neg, T_zero] }

@[simp]
lemma inv_of_T (n : ℤ) : ⅟ (T n : R[T;T⁻¹]) = T (- n) := rfl

lemma is_unit_T (n : ℤ) : is_unit (T n : R[T;T⁻¹]) :=
is_unit_of_invertible _

@[elab_as_eliminator] protected lemma induction_on {M : R[T;T⁻¹] → Prop} (p : R[T;T⁻¹])
  (h_C         : ∀ a, M (C a))
  (h_add       : ∀ {p q}, M p → M q → M (p + q))
  (h_C_mul_T   : ∀ (n : ℕ) (a : R), M (C a * T n) → M (C a * T (n + 1)))
  (h_C_mul_T_Z : ∀ (n : ℕ) (a : R), M (C a * T (- n)) → M (C a * T (- n - 1))) :
  M p :=
begin
  have A : ∀ {n : ℤ} {a : R}, M (C a * T n),
  { assume n a,
    apply n.induction_on,
    { simpa only [T_zero, mul_one] using h_C a },
    { exact λ m, h_C_mul_T m a },
    { exact λ m, h_C_mul_T_Z m a } },
  have B : ∀ (s : finset ℤ), M (s.sum (λ (n : ℤ), C (p.to_fun n) * T n)),
  { apply finset.induction,
    { convert h_C 0, simp only [finset.sum_empty, _root_.map_zero] },
    { assume n s ns ih, rw finset.sum_insert ns, exact h_add A ih } },
  convert B p.support,
  ext a,
  simp_rw [← single_eq_C_mul_T, finset.sum_apply', single_apply, finset.sum_ite_eq'],
  split_ifs with h h,
  { refl },
  { exact finsupp.not_mem_support_iff.mp h }
end

/--  To prove something about Laurent polynomials, it suffices to show that
* the condition is closed under taking sums, and
* it holds for monomials.
-/
@[elab_as_eliminator] protected lemma induction_on' {M : R[T;T⁻¹] → Prop} (p : R[T;T⁻¹])
  (h_add     : ∀p q, M p → M q → M (p + q))
  (h_C_mul_T : ∀(n : ℤ) (a : R), M (C a * T n)) :
  M p :=
begin
  refine p.induction_on (λ a, _) h_add _ _;
  try { exact λ n f _, h_C_mul_T _ f },
  convert h_C_mul_T 0 a,
  exact (mul_one _).symm,
end

lemma commute_T (n : ℤ) (f : R[T;T⁻¹]) : commute (T n) f :=
f.induction_on' (λ p q Tp Tq, commute.add_right Tp Tq) $ λ m a,
show T n * _ = _, by
{ rw [T, T, ← single_eq_C, single_mul_single, single_mul_single, single_mul_single],
  simp [add_comm] }

@[simp]
lemma T_mul (n : ℤ) (f : R[T;T⁻¹]) : T n * f = f * T n :=
(commute_T n f).eq

/--  `trunc : R[T;T⁻¹] →+ R[X]` maps a Laurent polynomial `f` to the polynomial whose terms of
nonnegative degree coincide with the ones of `f`.  The terms of negative degree of `f` "vanish".
`trunc` is a left-inverse to `polynomial.to_laurent`. -/
def trunc : R[T;T⁻¹] →+ R[X] :=
((to_finsupp_iso R).symm.to_add_monoid_hom).comp $
  comap_domain.add_monoid_hom $ λ a b, int.of_nat.inj

@[simp]
lemma trunc_C_mul_T (n : ℤ) (r : R) : trunc (C r * T n) = ite (0 ≤ n) (monomial n.to_nat r) 0 :=
begin
  apply (to_finsupp_iso R).injective,
  rw [← single_eq_C_mul_T, trunc, add_monoid_hom.coe_comp, function.comp_app,
    comap_domain.add_monoid_hom_apply, to_finsupp_iso_apply],
  by_cases n0 : 0 ≤ n,
  { lift n to ℕ using n0,
    erw [comap_domain_single, to_finsupp_iso_symm_apply],
    simp only [int.coe_nat_nonneg, int.to_nat_coe_nat, if_true, to_finsupp_iso_apply,
      to_finsupp_monomial] },
  { lift (- n) to ℕ using (neg_pos.mpr (not_le.mp n0)).le with m,
    rw [to_finsupp_iso_apply, to_finsupp_inj, if_neg n0],
    erw to_finsupp_iso_symm_apply,
    ext a,
    have := ((not_le.mp n0).trans_le (int.coe_zero_le a)).ne',
    simp only [coeff, comap_domain_apply, int.of_nat_eq_coe, coeff_zero, single_apply_eq_zero, this,
      forall_false_left] }
end

@[simp] lemma left_inverse_trunc_to_laurent :
  function.left_inverse (trunc : R[T;T⁻¹] → R[X]) polynomial.to_laurent :=
begin
  refine λ f, f.induction_on' _ _,
  { exact λ f g hf hg, by simp only [hf, hg, _root_.map_add] },
  { exact λ n r, by simp only [polynomial.to_laurent_C_mul_T, trunc_C_mul_T, int.coe_nat_nonneg,
      int.to_nat_coe_nat, if_true] }
end

@[simp] lemma _root_.polynomial.trunc_to_laurent (f : R[X]) : trunc f.to_laurent = f :=
left_inverse_trunc_to_laurent _

lemma _root_.polynomial.to_laurent_injective :
  function.injective (polynomial.to_laurent : R[X] → R[T;T⁻¹]) :=
left_inverse_trunc_to_laurent.injective

@[simp] lemma _root_.polynomial.to_laurent_inj (f g : R[X]) :
  f.to_laurent = g.to_laurent ↔ f = g :=
⟨λ h, polynomial.to_laurent_injective h, congr_arg _⟩

lemma exists_T_pow (f : R[T;T⁻¹]) :
  ∃ (n : ℕ) (f' : R[X]), f'.to_laurent = f * T n :=
begin
  apply f.induction_on' _ (λ n a, _); clear f,
  { rintros f g ⟨m, fn, hf⟩ ⟨n, gn, hg⟩,
    refine ⟨m + n, fn * X ^ n + gn * X ^ m, _⟩,
    simp only [hf, hg, add_mul, add_comm (n : ℤ), map_add, map_mul, polynomial.to_laurent_X_pow,
      mul_T_assoc, int.coe_nat_add] },
  { cases n with n n,
    { exact ⟨0, polynomial.C a * X ^ n, by simp⟩ },
    { refine ⟨n + 1, polynomial.C a, _⟩,
      simp only [int.neg_succ_of_nat_eq, polynomial.to_laurent_C, int.coe_nat_succ, mul_T_assoc,
        add_left_neg, T_zero, mul_one] } }
end

/--  This is a version of `exists_T_pow` stated as an induction principle. -/
@[elab_as_eliminator] lemma induction_on_mul_T {Q : R[T;T⁻¹] → Prop} (f : R[T;T⁻¹])
  (Qf : ∀ {f : R[X]} {n : ℕ}, Q (f.to_laurent * T (- n))) :
  Q f :=
begin
  rcases f.exists_T_pow with ⟨n, f', hf⟩,
  rw [← mul_one f, ← T_zero, ← nat.cast_zero, ← nat.sub_self n, nat.cast_sub rfl.le, T_sub,
    ← mul_assoc, ← hf],
  exact Qf,
end

/--  Suppose that `Q` is a statement about Laurent polynomials such that
* `Q` is true on *ordinary* polynomials;
* `Q (f * T)` implies `Q f`;
it follow that `Q` is true on all Laurent polynomials. -/
lemma reduce_to_polynomial_of_mul_T (f : R[T;T⁻¹]) {Q : R[T;T⁻¹] → Prop}
  (Qf : ∀ (f : R[X]), Q f.to_laurent)
  (QT : ∀ f, Q (f * T 1) → Q f) :
  Q f :=
begin
  induction f using laurent_polynomial.induction_on_mul_T with f n,
  induction n with n hn,
  { simpa only [int.coe_nat_zero, neg_zero', T_zero, mul_one] using Qf _ },
  { convert QT _ _,
    simpa using hn }
end

instance : module R[X] R[T;T⁻¹] :=
module.comp_hom _ polynomial.to_laurent

instance (R : Type*) [semiring R] : is_scalar_tower R[X] R[X] R[T;T⁻¹] :=
{ smul_assoc := λ x y z, by simp only [has_scalar.smul, has_scalar.comp.smul, map_mul, mul_assoc] }

end semiring

section comm_semiring
variable [comm_semiring R]

instance algebra_polynomial (R : Type*) [comm_semiring R] : algebra R[X] R[T;T⁻¹] :=
{ commutes' := λ f l, by simp [mul_comm],
  smul_def' := λ f l, rfl,
  .. polynomial.to_laurent }

lemma algebra_map_X_pow (n : ℕ) : algebra_map R[X] R[T;T⁻¹] (X ^ n) = T n :=
polynomial.to_laurent_X_pow n

@[simp]
lemma algebra_map_eq_to_laurent (f : R[X]) : algebra_map R[X] R[T;T⁻¹] f = f.to_laurent :=
rfl

lemma is_localization : is_localization (submonoid.closure ({X} : set R[X])) R[T;T⁻¹] :=
{ map_units := λ t, begin
    cases t with t ht,
    rcases submonoid.mem_closure_singleton.mp ht with ⟨n, rfl⟩,
    simp only [is_unit_T n, set_like.coe_mk, algebra_map_eq_to_laurent, polynomial.to_laurent_X_pow]
  end,
  surj := λ f, begin
    induction f using laurent_polynomial.induction_on_mul_T with f n,
    have := (submonoid.closure ({X} : set R[X])).pow_mem submonoid.mem_closure_singleton_self n,
    refine ⟨(f, ⟨_, this⟩), _⟩,
    simp only [set_like.coe_mk, algebra_map_eq_to_laurent, polynomial.to_laurent_X_pow, mul_T_assoc,
      add_left_neg, T_zero, mul_one],
  end,
  eq_iff_exists := λ f g, begin
    rw [algebra_map_eq_to_laurent, algebra_map_eq_to_laurent, polynomial.to_laurent_inj],
    refine ⟨_, _⟩,
    { rintro rfl,
      exact ⟨1, rfl⟩ },
    { rintro ⟨⟨h, hX⟩, h⟩,
      rcases submonoid.mem_closure_singleton.mp hX with ⟨n, rfl⟩,
      exact mul_X_pow_injective n (by simpa only [X_pow_mul] using h) }
  end }

end comm_semiring

end laurent_polynomial


/-
Copyright (c) 2020 Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa
-/
import data.polynomial.erase_lead
import data.polynomial.eval

/-!
# Denominators of evaluation of polynomials at ratios

Let `i : R → K` be a homomorphism of semirings.  Assume that `K` is commutative.  If `a` and
`b` are elements of `R` such that `i b ∈ K` is invertible, then for any polynomial
`f ∈ R[X]` the "mathematical" expression `b ^ f.nat_degree * f (a / b) ∈ K` is in
the image of the homomorphism `i`.
-/

open polynomial finset
open_locale polynomial

section denoms_clearable

variables {R K : Type*} [semiring R] [comm_semiring K] {i : R →+* K}
variables {a b : R} {bi : K}
-- TODO: use hypothesis (ub : is_unit (i b)) to work with localizations.

/-- `denoms_clearable` formalizes the property that `b ^ N * f (a / b)`
does not have denominators, if the inequality `f.nat_degree ≤ N` holds.

The definition asserts the existence of an element `D` of `R` and an
element `bi = 1 / i b` of `K` such that clearing the denominators of
the fraction equals `i D`.
-/
def denoms_clearable (a b : R) (N : ℕ) (f : R[X]) (i : R →+* K) : Prop :=
  ∃ (D : R) (bi : K), bi * i b = 1 ∧ i D = i b ^ N * eval (i a * bi) (f.map i)

lemma denoms_clearable_zero (N : ℕ) (a : R) (bu : bi * i b = 1) :
  denoms_clearable a b N 0 i :=
⟨0, bi, bu, by simp only [eval_zero, ring_hom.map_zero, mul_zero, polynomial.map_zero]⟩

lemma denoms_clearable_C_mul_X_pow {N : ℕ} (a : R) (bu : bi * i b = 1) {n : ℕ} (r : R)
  (nN : n ≤ N) : denoms_clearable a b N (C r * X ^ n) i :=
begin
  refine ⟨r * a ^ n * b ^ (N - n), bi, bu, _⟩,
  rw [C_mul_X_pow_eq_monomial, map_monomial, ← C_mul_X_pow_eq_monomial, eval_mul, eval_pow, eval_C],
  rw [ring_hom.map_mul, ring_hom.map_mul, ring_hom.map_pow, ring_hom.map_pow, eval_X, mul_comm],
  rw [← tsub_add_cancel_of_le nN] {occs := occurrences.pos [2]},
  rw [pow_add, mul_assoc, mul_comm (i b ^ n), mul_pow, mul_assoc, mul_assoc (i a ^ n), ← mul_pow],
  rw [bu, one_pow, mul_one],
end

lemma denoms_clearable.add {N : ℕ} {f g : R[X]} :
  denoms_clearable a b N f i → denoms_clearable a b N g i → denoms_clearable a b N (f + g) i :=
λ ⟨Df, bf, bfu, Hf⟩ ⟨Dg, bg, bgu, Hg⟩, ⟨Df + Dg, bf, bfu,
  begin
    rw [ring_hom.map_add, polynomial.map_add, eval_add, mul_add, Hf, Hg],
    congr,
    refine @inv_unique K _ (i b) bg bf _ _;
    rwa mul_comm,
  end ⟩

lemma denoms_clearable_of_nat_degree_le (N : ℕ) (a : R) (bu : bi * i b = 1) :
  ∀ (f : R[X]), f.nat_degree ≤ N → denoms_clearable a b N f i :=
induction_with_nat_degree_le _ N
  (denoms_clearable_zero N a bu)
  (λ N_1 r r0, denoms_clearable_C_mul_X_pow a bu r)
  (λ f g fg gN df dg, df.add dg)

/-- If `i : R → K` is a ring homomorphism, `f` is a polynomial with coefficients in `R`,
`a, b` are elements of `R`, with `i b` invertible, then there is a `D ∈ R` such that
`b ^ f.nat_degree * f (a / b)` equals `i D`. -/
theorem denoms_clearable_nat_degree
  (i : R →+* K) (f : R[X]) (a : R) (bu : bi * i b = 1) :
  denoms_clearable a b f.nat_degree f i :=
denoms_clearable_of_nat_degree_le f.nat_degree a bu f le_rfl

end denoms_clearable

open ring_hom

/--  Evaluating a polynomial with integer coefficients at a rational number and clearing
denominators, yields a number greater than or equal to one.  The target can be any
`linear_ordered_field K`.
The assumption on `K` could be weakened to `linear_ordered_comm_ring` assuming that the
image of the denominator is invertible in `K`. -/
lemma one_le_pow_mul_abs_eval_div {K : Type*} [linear_ordered_field K] {f : ℤ[X]}
  {a b : ℤ} (b0 : 0 < b) (fab : eval ((a : K) / b) (f.map (algebra_map ℤ K)) ≠ 0) :
  (1 : K) ≤ b ^ f.nat_degree * |eval ((a : K) / b) (f.map (algebra_map ℤ K))| :=
begin
  obtain ⟨ev, bi, bu, hF⟩ := @denoms_clearable_nat_degree _ _ _ _ b _ (algebra_map ℤ K)
    f a (by { rw [eq_int_cast, one_div_mul_cancel], rw [int.cast_ne_zero], exact (b0.ne.symm) }),
  obtain Fa := congr_arg abs hF,
  rw [eq_one_div_of_mul_eq_one_left bu, eq_int_cast, eq_int_cast, abs_mul] at Fa,
  rw [abs_of_pos (pow_pos (int.cast_pos.mpr b0) _ : 0 < (b : K) ^ _), one_div, eq_int_cast] at Fa,
  rw [div_eq_mul_inv, ← Fa, ← int.cast_abs, ← int.cast_one, int.cast_le],
  refine int.le_of_lt_add_one ((lt_add_iff_pos_left 1).mpr (abs_pos.mpr (λ F0, fab _))),
  rw [eq_one_div_of_mul_eq_one_left bu, F0, one_div, eq_int_cast, int.cast_zero, zero_eq_mul] at hF,
  cases hF with hF hF,
  { exact (not_le.mpr b0 (le_of_eq (int.cast_eq_zero.mp (pow_eq_zero hF)))).elim },
  { rwa div_eq_mul_inv }
end


/-
Copyright (c) 2021 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth
-/
import geometry.manifold.instances.real

/-!
# Manifold structure on the sphere

This file defines stereographic projection from the sphere in an inner product space `E`, and uses
it to put a smooth manifold structure on the sphere.

## Main results

For a unit vector `v` in `E`, the definition `stereographic` gives the stereographic projection
centred at `v`, a local homeomorphism from the sphere to `(ℝ ∙ v)ᗮ` (the orthogonal complement of
`v`).

For finite-dimensional `E`, we then construct a smooth manifold instance on the sphere; the charts
here are obtained by composing the local homeomorphisms `stereographic` with arbitrary isometries
from `(ℝ ∙ v)ᗮ` to Euclidean space.

Finally, two lemmas about smooth maps:
* `times_cont_mdiff_coe_sphere` states that the coercion map from the sphere into `E` is smooth;
  this is a useful tool for constructing smooth maps *from* the sphere.
* `times_cont_mdiff.cod_restrict_sphere` states that a map from a manifold into the sphere is
  smooth if its lift to a map to `E` is smooth; this is a useful tool for constructing smooth maps
  *to* the sphere.

As an application we prove `times_cont_mdiff_neg_sphere`, that the antipodal map is smooth.

## Implementation notes

The model space for the charted space instance is `euclidean_space ℝ (fin n)`, where `n` is a
natural number satisfying the typeclass assumption `[fact (finrank ℝ E = n + 1)]`.  This may seem a
little awkward, but it is designed to circumvent the problem that the literal expression for the
dimension of the model space (up to definitional equality) determines the type.  If one used the
naive expression `euclidean_space ℝ (fin (finrank ℝ E - 1))` for the model space, then the sphere in
`ℂ` would be a manifold with model space `euclidean_space ℝ (fin (2 - 1))` but not with model space
`euclidean_space ℝ (fin 1)`.
-/

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

noncomputable theory

open metric finite_dimensional
open_locale manifold

local attribute [instance] finite_dimensional_of_finrank_eq_succ

section stereographic_projection
variables (v : E)

/-! ### Construction of the stereographic projection -/

/-- Stereographic projection, forward direction. This is a map from an inner product space `E` to
the orthogonal complement of an element `v` of `E`. It is smooth away from the affine hyperplane
through `v` parallel to the orthogonal complement.  It restricts on the sphere to the stereographic
projection. -/
def stereo_to_fun [complete_space E] (x : E) : (ℝ ∙ v)ᗮ :=
(2 / ((1:ℝ) - inner_right v x)) • orthogonal_projection (ℝ ∙ v)ᗮ x

variables {v}

@[simp] lemma stereo_to_fun_apply [complete_space E] (x : E) :
  stereo_to_fun v x = (2 / ((1:ℝ) - inner_right v x)) • orthogonal_projection (ℝ ∙ v)ᗮ x :=
rfl

lemma times_cont_diff_on_stereo_to_fun [complete_space E] :
  times_cont_diff_on ℝ ⊤ (stereo_to_fun v) {x : E | inner_right v x ≠ (1:ℝ)} :=
begin
  refine times_cont_diff_on.smul _
    (orthogonal_projection ((ℝ ∙ v)ᗮ)).times_cont_diff.times_cont_diff_on,
  refine times_cont_diff_const.times_cont_diff_on.div _ _,
  { exact (times_cont_diff_const.sub (inner_right v).times_cont_diff).times_cont_diff_on },
  { intros x h h',
    exact h (sub_eq_zero.mp h').symm }
end

lemma continuous_on_stereo_to_fun [complete_space E] :
  continuous_on (stereo_to_fun v) {x : E | inner_right v x ≠ (1:ℝ)} :=
times_cont_diff_on_stereo_to_fun.continuous_on

variables (v)

/-- Auxiliary function for the construction of the reverse direction of the stereographic
projection.  This is a map from the orthogonal complement of a unit vector `v` in an inner product
space `E` to `E`; we will later prove that it takes values in the unit sphere.

For most purposes, use `stereo_inv_fun`, not `stereo_inv_fun_aux`. -/
def stereo_inv_fun_aux (w : E) : E := (∥w∥ ^ 2 + 4)⁻¹ • ((4:ℝ) • w + (∥w∥ ^ 2 - 4) • v)

variables {v}

@[simp] lemma stereo_inv_fun_aux_apply (w : E) :
  stereo_inv_fun_aux v w = (∥w∥ ^ 2 + 4)⁻¹ • ((4:ℝ) • w + (∥w∥ ^ 2 - 4) • v) :=
rfl

lemma stereo_inv_fun_aux_mem (hv : ∥v∥ = 1) {w : E} (hw : w ∈ (ℝ ∙ v)ᗮ) :
  stereo_inv_fun_aux v w ∈ (sphere (0:E) 1) :=
begin
  have h₁ : 0 ≤ ∥w∥ ^ 2 + 4 := by nlinarith,
  suffices : ∥(4:ℝ) • w + (∥w∥ ^ 2 - 4) • v∥ = ∥w∥ ^ 2 + 4,
  { have h₂ : ∥w∥ ^ 2 + 4 ≠ 0 := by nlinarith,
    simp only [mem_sphere_zero_iff_norm, norm_smul, real.norm_eq_abs, abs_inv, this,
      abs_of_nonneg h₁, stereo_inv_fun_aux_apply],
    field_simp },
  suffices : ∥(4:ℝ) • w + (∥w∥ ^ 2 - 4) • v∥ ^ 2 = (∥w∥ ^ 2 + 4) ^ 2,
  { have h₃ : 0 ≤ ∥stereo_inv_fun_aux v w∥ := norm_nonneg _,
    simpa [h₁, h₃, -one_pow] using this },
  simp [norm_add_sq_real, norm_smul, inner_smul_left, inner_smul_right,
    inner_left_of_mem_orthogonal_singleton _ hw, mul_pow, real.norm_eq_abs, hv],
  ring
end

lemma times_cont_diff_stereo_inv_fun_aux : times_cont_diff ℝ ⊤ (stereo_inv_fun_aux v) :=
begin
  have h₀ : times_cont_diff ℝ ⊤ (λ w : E, ∥w∥ ^ 2) := times_cont_diff_norm_sq,
  have h₁ : times_cont_diff ℝ ⊤ (λ w : E, (∥w∥ ^ 2 + 4)⁻¹),
  { refine (h₀.add times_cont_diff_const).inv _,
    intros x,
    nlinarith },
  have h₂ : times_cont_diff ℝ ⊤ (λ w, (4:ℝ) • w + (∥w∥ ^ 2 - 4) • v),
  { refine (times_cont_diff_const.smul times_cont_diff_id).add _,
    refine (h₀.sub times_cont_diff_const).smul times_cont_diff_const },
  exact h₁.smul h₂
end

/-- Stereographic projection, reverse direction.  This is a map from the orthogonal complement of a
unit vector `v` in an inner product space `E` to the unit sphere in `E`. -/
def stereo_inv_fun (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) : sphere (0:E) 1 :=
⟨stereo_inv_fun_aux v (w:E), stereo_inv_fun_aux_mem hv w.2⟩

@[simp] lemma stereo_inv_fun_apply (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) :
  (stereo_inv_fun hv w : E) = (∥w∥ ^ 2 + 4)⁻¹ • ((4:ℝ) • w + (∥w∥ ^ 2 - 4) • v) :=
rfl

lemma stereo_inv_fun_ne_north_pole (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) :
  stereo_inv_fun hv w ≠ (⟨v, by simp [hv]⟩ : sphere (0:E) 1) :=
begin
  refine subtype.ne_of_val_ne _,
  rw ← inner_lt_one_iff_real_of_norm_one _ hv,
  { have hw : ⟪v, w⟫_ℝ = 0 := inner_right_of_mem_orthogonal_singleton v w.2,
    have hw' : (∥(w:E)∥ ^ 2 + 4)⁻¹ * (∥(w:E)∥ ^ 2 - 4) < 1,
    { refine (inv_mul_lt_iff' _).mpr _,
      { nlinarith },
      linarith },
    simpa [real_inner_comm, inner_add_right, inner_smul_right, real_inner_self_eq_norm_sq, hw,
      hv] using hw' },
  { simpa using stereo_inv_fun_aux_mem hv w.2 }
end

lemma continuous_stereo_inv_fun (hv : ∥v∥ = 1) : continuous (stereo_inv_fun hv) :=
continuous_induced_rng (times_cont_diff_stereo_inv_fun_aux.continuous.comp continuous_subtype_coe)

variables [complete_space E]

lemma stereo_left_inv (hv : ∥v∥ = 1) {x : sphere (0:E) 1} (hx : (x:E) ≠ v) :
  stereo_inv_fun hv (stereo_to_fun v x) = x :=
begin
  ext,
  simp only [stereo_to_fun_apply, stereo_inv_fun_apply, smul_add],
  -- name two frequently-occuring quantities and write down their basic properties
  set a : ℝ := inner_right v x,
  set y := orthogonal_projection (ℝ ∙ v)ᗮ x,
  have split : ↑x = a • v + ↑y,
  { convert eq_sum_orthogonal_projection_self_orthogonal_complement (ℝ ∙ v) x,
    exact (orthogonal_projection_unit_singleton ℝ hv x).symm },
  have hvy : ⟪v, y⟫_ℝ = 0 := inner_right_of_mem_orthogonal_singleton v y.2,
  have pythag : 1 = a ^ 2 + ∥y∥ ^ 2,
  { have hvy' : ⟪a • v, y⟫_ℝ = 0 := by simp [inner_smul_left, hvy],
    convert norm_add_sq_eq_norm_sq_add_norm_sq_of_inner_eq_zero _ _ hvy' using 2,
    { simp [← split] },
    { simp [norm_smul, hv, real.norm_eq_abs, ← sq, sq_abs] },
    { exact sq _ } },
  -- two facts which will be helpful for clearing denominators in the main calculation
  have ha : 1 - a ≠ 0,
  { have : a < 1 := (inner_lt_one_iff_real_of_norm_one hv (by simp)).mpr hx.symm,
    linarith },
  have : 2 ^ 2 * ∥y∥ ^ 2 + 4 * (1 - a) ^ 2 ≠ 0,
  { refine ne_of_gt _,
    have := norm_nonneg (y:E),
    have : 0 < (1 - a) ^ 2 := sq_pos_of_ne_zero (1 - a) ha,
    nlinarith },
  -- the core of the problem is these two algebraic identities:
  have h₁ : (2 ^ 2 / (1 - a) ^ 2 * ∥y∥ ^ 2 + 4)⁻¹ * 4 * (2 / (1 - a)) = 1,
  { field_simp,
    nlinarith },
  have h₂ : (2 ^ 2 / (1 - a) ^ 2 * ∥y∥ ^ 2 + 4)⁻¹ * (2 ^ 2 / (1 - a) ^ 2 * ∥y∥ ^ 2 - 4) = a,
  { field_simp,
    transitivity (1 - a) ^ 2 * (a * (2 ^ 2 * ∥y∥ ^ 2 + 4 * (1 - a) ^ 2)),
    { congr,
      nlinarith },
    ring_nf, ring },
  -- deduce the result
  convert congr_arg2 has_add.add (congr_arg (λ t, t • (y:E)) h₁) (congr_arg (λ t, t • v) h₂)
    using 1,
  { simp [inner_add_right, inner_smul_right, hvy, real_inner_self_eq_norm_sq, hv, mul_smul,
      mul_pow, real.norm_eq_abs, sq_abs, norm_smul] },
  { simp [split, add_comm] }
end

lemma stereo_right_inv (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) :
  stereo_to_fun v (stereo_inv_fun hv w) = w :=
begin
  have : 2 / (1 - (∥(w:E)∥ ^ 2 + 4)⁻¹ * (∥(w:E)∥ ^ 2 - 4)) * (∥(w:E)∥ ^ 2 + 4)⁻¹ * 4 = 1,
  { have : ∥(w:E)∥ ^ 2 + 4 ≠ 0 := by nlinarith,
    have : (4:ℝ) + 4 ≠ 0 := by nlinarith,
    field_simp,
    ring },
  convert congr_arg (λ c, c • w) this,
  { have h₁ : orthogonal_projection (ℝ ∙ v)ᗮ v = 0 :=
      orthogonal_projection_orthogonal_complement_singleton_eq_zero v,
    have h₂ : orthogonal_projection (ℝ ∙ v)ᗮ w = w :=
      orthogonal_projection_mem_subspace_eq_self w,
    have h₃ : inner_right v w = (0:ℝ) := inner_right_of_mem_orthogonal_singleton v w.2,
    have h₄ : inner_right v v = (1:ℝ) := by simp [real_inner_self_eq_norm_sq, hv],
    simp [h₁, h₂, h₃, h₄, continuous_linear_map.map_add, continuous_linear_map.map_smul,
      mul_smul] },
  { simp }
end

/-- Stereographic projection from the unit sphere in `E`, centred at a unit vector `v` in `E`; this
is the version as a local homeomorphism. -/
def stereographic (hv : ∥v∥ = 1) : local_homeomorph (sphere (0:E) 1) (ℝ ∙ v)ᗮ :=
{ to_fun := (stereo_to_fun v) ∘ coe,
  inv_fun := stereo_inv_fun hv,
  source := {⟨v, by simp [hv]⟩}ᶜ,
  target := set.univ,
  map_source' := by simp,
  map_target' := λ w _, stereo_inv_fun_ne_north_pole hv w,
  left_inv' := λ _ hx, stereo_left_inv hv (λ h, hx (subtype.ext h)),
  right_inv' := λ w _, stereo_right_inv hv w,
  open_source := is_open_compl_singleton,
  open_target := is_open_univ,
  continuous_to_fun := continuous_on_stereo_to_fun.comp continuous_subtype_coe.continuous_on
    (λ w h, h ∘ subtype.ext ∘ eq.symm ∘ (inner_eq_norm_mul_iff_of_norm_one hv (by simp)).mp),
  continuous_inv_fun := (continuous_stereo_inv_fun hv).continuous_on }

@[simp] lemma stereographic_source (hv : ∥v∥ = 1) :
  (stereographic hv).source = {⟨v, by simp [hv]⟩}ᶜ :=
rfl

@[simp] lemma stereographic_target (hv : ∥v∥ = 1) : (stereographic hv).target = set.univ := rfl

end stereographic_projection

section charted_space

/-!
### Charted space structure on the sphere

In this section we construct a charted space structure on the unit sphere in a finite-dimensional
real inner product space `E`; that is, we show that it is locally homeomorphic to the Euclidean
space of dimension one less than `E`.

The restriction to finite dimension is for convenience.  The most natural `charted_space`
structure for the sphere uses the stereographic projection from the antipodes of a point as the
canonical chart at this point.  However, the codomain of the stereographic projection constructed
in the previous section is `(ℝ ∙ v)ᗮ`, the orthogonal complement of the vector `v` in `E` which is
the "north pole" of the projection, so a priori these charts all have different codomains.

So it is necessary to prove that these codomains are all continuously linearly equivalent to a
fixed normed space.  This could be proved in general by a simple case of Gram-Schmidt
orthogonalization, but in the finite-dimensional case it follows more easily by dimension-counting.
-/

/-- Variant of the stereographic projection, for the sphere in an `n + 1`-dimensional inner product
space `E`.  This version has codomain the Euclidean space of dimension `n`, and is obtained by
composing the original sterographic projection (`stereographic`) with an arbitrary linear isometry
from `(ℝ ∙ v)ᗮ` to the Euclidean space. -/
def stereographic' (n : ℕ) [fact (finrank ℝ E = n + 1)] (v : sphere (0:E) 1) :
  local_homeomorph (sphere (0:E) 1) (euclidean_space ℝ (fin n)) :=
(stereographic (norm_eq_of_mem_sphere v)) ≫ₕ
(linear_isometry_equiv.from_orthogonal_span_singleton n
  (nonzero_of_mem_unit_sphere v)).to_homeomorph.to_local_homeomorph

@[simp] lemma stereographic'_source {n : ℕ} [fact (finrank ℝ E = n + 1)] (v : sphere (0:E) 1) :
  (stereographic' n v).source = {v}ᶜ :=
by simp [stereographic']

@[simp] lemma stereographic'_target {n : ℕ} [fact (finrank ℝ E = n + 1)] (v : sphere (0:E) 1) :
  (stereographic' n v).target = set.univ :=
by simp [stereographic']

/-- The unit sphere in an `n + 1`-dimensional inner product space `E` is a charted space
modelled on the Euclidean space of dimension `n`. -/
instance {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  charted_space (euclidean_space ℝ (fin n)) (sphere (0:E) 1) :=
{ atlas            := {f | ∃ v : (sphere (0:E) 1), f = stereographic' n v},
  chart_at         := λ v, stereographic' n (-v),
  mem_chart_source := λ v, by simpa using ne_neg_of_mem_unit_sphere ℝ v,
  chart_mem_atlas  := λ v, ⟨-v, rfl⟩ }

end charted_space

section smooth_manifold

/-! ### Smooth manifold structure on the sphere -/

/-- The unit sphere in an `n + 1`-dimensional inner product space `E` is a smooth manifold,
modelled on the Euclidean space of dimension `n`. -/
instance {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  smooth_manifold_with_corners (𝓡 n) (sphere (0:E) 1) :=
smooth_manifold_with_corners_of_times_cont_diff_on (𝓡 n) (sphere (0:E) 1)
begin
  rintros _ _ ⟨v, rfl⟩ ⟨v', rfl⟩,
  let U : (ℝ ∙ (v:E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
    linear_isometry_equiv.from_orthogonal_span_singleton n
      (nonzero_of_mem_unit_sphere v),
  let U' : (ℝ ∙ (v':E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
    linear_isometry_equiv.from_orthogonal_span_singleton n
      (nonzero_of_mem_unit_sphere v'),
  have hUv : stereographic' n v = (stereographic (norm_eq_of_mem_sphere v)) ≫ₕ
    U.to_homeomorph.to_local_homeomorph := rfl,
  have hU'v' : stereographic' n v' = (stereographic (norm_eq_of_mem_sphere v')).trans
    U'.to_homeomorph.to_local_homeomorph := rfl,
  have H₁ := U'.times_cont_diff.comp_times_cont_diff_on times_cont_diff_on_stereo_to_fun,
  have H₂ := (times_cont_diff_stereo_inv_fun_aux.comp
      (ℝ ∙ (v:E))ᗮ.subtypeL.times_cont_diff).comp U.symm.times_cont_diff,
  convert H₁.comp' (H₂.times_cont_diff_on : times_cont_diff_on ℝ ⊤ _ set.univ) using 1,
  have h_set : ∀ p : sphere (0:E) 1, p = v' ↔ ⟪(p:E), v'⟫_ℝ = 1,
  { simp [subtype.ext_iff, inner_eq_norm_mul_iff_of_norm_one] },
  ext,
  simp [h_set, hUv, hU'v', stereographic, real_inner_comm]
end

/-- The inclusion map (i.e., `coe`) from the sphere in `E` to `E` is smooth.  -/
lemma times_cont_mdiff_coe_sphere {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  times_cont_mdiff (𝓡 n) 𝓘(ℝ, E) ∞ (coe : (sphere (0:E) 1) → E) :=
begin
  rw times_cont_mdiff_iff,
  split,
  { exact continuous_subtype_coe },
  { intros v _,
    let U : (ℝ ∙ ((-v):E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
      linear_isometry_equiv.from_orthogonal_span_singleton n (nonzero_of_mem_unit_sphere (-v)),
    exact ((times_cont_diff_stereo_inv_fun_aux.comp
      (ℝ ∙ ((-v):E))ᗮ.subtypeL.times_cont_diff).comp U.symm.times_cont_diff).times_cont_diff_on }
end

variables {F : Type*} [normed_group F] [normed_space ℝ F]
variables {H : Type*} [topological_space H] {I : model_with_corners ℝ F H}
variables {M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]

/-- If a `times_cont_mdiff` function `f : M → E`, where `M` is some manifold, takes values in the
sphere, then it restricts to a `times_cont_mdiff` function from `M` to the sphere. -/
lemma times_cont_mdiff.cod_restrict_sphere {n : ℕ} [fact (finrank ℝ E = n + 1)]
  {m : with_top ℕ} {f : M → E} (hf : times_cont_mdiff I 𝓘(ℝ, E) m f)
  (hf' : ∀ x, f x ∈ sphere (0:E) 1) :
  times_cont_mdiff I (𝓡 n) m (set.cod_restrict _ _ hf' : M → (sphere (0:E) 1)) :=
begin
  rw times_cont_mdiff_iff_target,
  refine ⟨continuous_induced_rng hf.continuous, _⟩,
  intros v,
  let U : (ℝ ∙ ((-v):E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
    (linear_isometry_equiv.from_orthogonal_span_singleton n (nonzero_of_mem_unit_sphere (-v))),
  have h : times_cont_diff_on ℝ ⊤ U set.univ :=
    U.times_cont_diff.times_cont_diff_on,
  have H₁ := (h.comp' times_cont_diff_on_stereo_to_fun).times_cont_mdiff_on,
  have H₂ : times_cont_mdiff_on _ _ _ _ set.univ := hf.times_cont_mdiff_on,
  convert (H₁.of_le le_top).comp' H₂ using 1,
  ext x,
  have hfxv : f x = -↑v ↔ ⟪f x, -↑v⟫_ℝ = 1,
  { have hfx : ∥f x∥ = 1 := by simpa using hf' x,
    rw inner_eq_norm_mul_iff_of_norm_one hfx,
    exact norm_eq_of_mem_sphere (-v) },
  dsimp [chart_at],
  simp [not_iff_not, subtype.ext_iff, hfxv, real_inner_comm]
end

/-- The antipodal map is smooth. -/
lemma times_cont_mdiff_neg_sphere {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  times_cont_mdiff (𝓡 n) (𝓡 n) ∞ (λ x : sphere (0:E) 1, -x) :=
(times_cont_diff_neg.times_cont_mdiff.comp times_cont_mdiff_coe_sphere).cod_restrict_sphere _

end smooth_manifold