import ring_theory.derivation

namespace CMP_2020

universe u

section left_cancel_monoid

variables {M : Type u} [left_cancel_monoid M]

@[to_additive] lemma eq_one_of_mul_self_left_cancel {a : M} (h : a * a = a) : a = 1 :=
mul_left_cancel (show a * a = a * 1, by rwa mul_one)

@[to_additive] lemma eq_one_of_left_cancel_mul_self {a : M} (h : a = a * a) : a = 1 :=
mul_left_cancel (show a * a = a * 1, by rwa [mul_one, eq_comm])

end left_cancel_monoid

section right_cancel_monoid

variables {M : Type u} [right_cancel_monoid M]

@[to_additive] lemma eq_one_of_mul_self_right_cancel {a : M} (h : a * a = a) : a = 1 :=
mul_right_cancel (show a * a = 1 * a, by rwa one_mul)

@[to_additive] lemma eq_one_of_right_cancel_mul_self {a : M} (h : a = a * a) : a = 1 :=
mul_right_cancel (show a * a = 1 * a, by rwa [one_mul, eq_comm])

end right_cancel_monoid

/-- A monoid in which multiplication is left-cancellative. -/
@[protect_proj, ancestor left_cancel_semigroup monoid, to_additive add_left_cancel_monoid]
class left_cancel_monoid (M : Type u) extends left_cancel_semigroup M, monoid M

/-- Commutative version of add_left_cancel_monoid. -/
@[protect_proj, ancestor add_left_cancel_monoid add_comm_monoid]
class add_left_cancel_comm_monoid (M : Type u) extends add_left_cancel_monoid M, add_comm_monoid M

/-- Commutative version of left_cancel_monoid. -/
@[protect_proj, ancestor left_cancel_monoid comm_monoid, to_additive add_left_cancel_comm_monoid]
class left_cancel_comm_monoid (M : Type u) extends left_cancel_monoid M, comm_monoid M

end left_cancel_monoid

section right_cancel_monoid

/-- An additive monoid in which addition is right-cancellative.
Main examples are `ℕ` and groups. This is the right typeclass for many sum lemmas, as having a zero
is useful to define the sum over the empty set, so `add_right_cancel_semigroup` is not enough. -/
@[protect_proj, ancestor add_right_cancel_semigroup add_monoid]
class add_right_cancel_monoid (M : Type u) extends add_right_cancel_semigroup M, add_monoid M

/-- A monoid in which multiplication is right-cancellative. -/
@[protect_proj, ancestor right_cancel_semigroup monoid, to_additive add_right_cancel_monoid]
class right_cancel_monoid (M : Type u) extends right_cancel_semigroup M, monoid M

/-- Commutative version of add_right_cancel_monoid. -/
@[protect_proj, ancestor add_right_cancel_monoid add_comm_monoid]
class add_right_cancel_comm_monoid (M : Type u) extends add_right_cancel_monoid M, add_comm_monoid M

/-- Commutative version of right_cancel_monoid. -/
@[protect_proj, ancestor right_cancel_monoid comm_monoid, to_additive add_right_cancel_comm_monoid]
class right_cancel_comm_monoid (M : Type u) extends right_cancel_monoid M, comm_monoid M

end right_cancel_monoid

section cancel_monoid

/-- An additive monoid in which addition is cancellative on both sides.
Main examples are `ℕ` and groups. This is the right typeclass for many sum lemmas, as having a zero
is useful to define the sum over the empty set, so `add_right_cancel_semigroup` is not enough. -/
@[protect_proj, ancestor add_left_cancel_monoid add_right_cancel_monoid]
class add_cancel_monoid (M : Type u)
  extends add_left_cancel_monoid M, add_right_cancel_monoid M

/-- A monoid in which multiplication is cancellative. -/
@[protect_proj, ancestor left_cancel_monoid right_cancel_monoid, to_additive add_cancel_monoid]
class cancel_monoid (M : Type u) extends left_cancel_monoid M, right_cancel_monoid M

/-- Commutative version of add_cancel_monoid. -/
@[protect_proj, ancestor add_left_cancel_comm_monoid add_right_cancel_comm_monoid]
class add_cancel_comm_monoid (M : Type u)
  extends add_left_cancel_comm_monoid M, add_right_cancel_comm_monoid M

/-- Commutative version of cancel_monoid. -/
@[protect_proj, ancestor right_cancel_comm_monoid left_cancel_comm_monoid, to_additive add_cancel_comm_monoid]
class cancel_comm_monoid (M : Type u) extends left_cancel_comm_monoid M, right_cancel_comm_monoid M

end cancel_monoid

@[to_additive]
instance group.to_cancel_monoid : cancel_monoid G :=
{ ..‹group G›, .. group.to_left_cancel_semigroup,
  ..group.to_right_cancel_semigroup }

section comm_group

variables {G : Type u} [comm_group G]

@[to_additive]
instance comm_group.to_cancel_comm_monoid : cancel_comm_monoid G :=
{ ..‹comm_group G›,
  ..group.to_left_cancel_semigroup,
  ..group.to_right_cancel_semigroup }

end comm_group

section is_scalar_tower

variables {R : Type*} [comm_semiring R]
variables (A : Type*) [semiring A] [algebra R A]
variables {M : Type*} [add_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M]
variables {N : Type*} [add_comm_monoid N] [semimodule A N] [semimodule R N] [is_scalar_tower R A N]

lemma algebra_compatible_smul (r : R) (m : M) : r • m = ((algebra_map R A) r) • m :=
by rw [←(one_smul A m), ←smul_assoc, algebra.smul_def, mul_one, one_smul]

variable {A}

lemma smul_algebra_smul_comm (r : R) (a : A) (m : M) : a • r • m = r • a • m :=
by rw [algebra_compatible_smul A r (a • m), smul_smul, algebra.commutes, mul_smul, ←algebra_compatible_smul]

@[simp] lemma map_smul_eq_smul_map (f : M →ₗ[A] N) (r : R) (m : M) :
  f (r • m) = r • f m :=
by rw [algebra_compatible_smul A r m, linear_map.map_smul, ←algebra_compatible_smul A r (f m)]

instance : has_coe (M →ₗ[A] N) (M →ₗ[R] N) :=
⟨λ f, ⟨f.to_fun, λ x y, f.map_add' x y, λ r n, map_smul_eq_smul_map _ _ _⟩⟩

end is_scalar_tower

/-!
# Derivations
This file defines derivation. A derivation `D` from the `R`-algebra `A` to the `A`-module `M` is an
`R`-linear map that satisfy the Leibniz rule `D (a * b) = a * D b + D a * b`.
## Notation
The notation `⁅D1, D2⁆` is used for the commutator of two derivations.
TODO: this file is just a stub to go on with some PRs in the geometry section. It only
implements the definition of derivations in commutative algebra. This will soon change: as soon
as bimodules will be there in mathlib I will change this file to take into account the
non-commutative case. Any development on the theory of derivations is discouraged until the
definitive definition of derivation will be implemented.
-/

open algebra ring_hom

/-- `D : derivation R A M` is an `R`-linear map from `A` to `M` that satisfies the `leibniz`
equality.
TODO: update this when bimodules are defined. -/
@[protect_proj]
structure derivation (R : Type*) (A : Type*) [comm_semiring R] [comm_semiring A]
  [algebra R A] (M : Type*) [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
  [is_scalar_tower R A M]
  extends A →ₗ[R] M :=
(leibniz' (a b : A) : to_fun (a * b) = a • to_fun b + b • to_fun a)

namespace derivation

section

variables {R : Type*} [comm_semiring R]
variables {A : Type*} [comm_semiring A] [algebra R A]
variables {M : Type*} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
variables [is_scalar_tower R A M]
variables (D : derivation R A M) {D1 D2 : derivation R A M} (r : R) (a b : A)

instance : has_coe_to_fun (derivation R A M) := ⟨_, λ D, D.to_linear_map.to_fun⟩

instance has_coe_to_linear_map : has_coe (derivation R A M) (A →ₗ[R] M) :=
⟨λ D, D.to_linear_map⟩

@[simp] lemma to_fun_eq_coe : D.to_fun = ⇑D := rfl

@[simp, norm_cast]
lemma coe_fn_coe (f : derivation R A M) :
  ⇑(f : A →ₗ[R] M) = f := rfl

lemma coe_injective (H : ⇑D1 = D2) : D1 = D2 :=
by { cases D1, cases D2, congr', exact linear_map.coe_inj H }

@[ext] theorem ext (H : ∀ a, D1 a = D2 a) : D1 = D2 :=
coe_injective $ funext H

@[simp] lemma map_add : D (a + b) = D a + D b := is_add_hom.map_add D a b
@[simp] lemma map_zero : D 0 = 0 := is_add_monoid_hom.map_zero D
@[simp] lemma map_smul : D (r • a) = r • D a := linear_map.map_smul D r a
@[simp] lemma leibniz : D (a * b) = a • D b + b • D a := D.leibniz' _ _

@[simp] lemma map_one_eq_zero : D 1 = 0 :=
begin
  have h : D 1 = D (1 * 1) := by rw mul_one,
  rw [leibniz D 1 1, one_smul] at h,
  exact eq_zero_of_left_cancel_add_self h,
end

@[simp] lemma map_algebra_map : D (algebra_map R A r) = 0 :=
by rw [←mul_one r, ring_hom.map_mul, map_one, ←smul_def, map_smul, map_one_eq_zero, smul_zero]

instance : has_zero (derivation R A M) :=
⟨⟨(0 : A →ₗ[R] M), λ a b, by simp only [add_zero, linear_map.zero_apply,
                                        linear_map.to_fun_eq_coe, smul_zero]⟩⟩

instance : inhabited (derivation R A M) := ⟨0⟩

instance : add_comm_monoid (derivation R A M) :=
{ add := λ D1 D2, ⟨D1 + D2, λ a b, by { simp only [leibniz, linear_map.add_apply,
    linear_map.to_fun_eq_coe, coe_fn_coe, smul_add], cc }⟩,
  add_assoc := λ D E F, ext $ λ a, add_assoc _ _ _,
  zero_add := λ D, ext $ λ a, zero_add _,
  add_zero := λ D, ext $ λ a, add_zero _,
  add_comm := λ D E, ext $ λ a, add_comm _ _,
  ..derivation.has_zero }

@[simp] lemma add_apply : (D1 + D2) a = D1 a + D2 a := rfl

@[priority 100]
instance derivation.Rsemimodule : semimodule R (derivation R A M) :=
{ smul := λ r D, ⟨r • D, λ a b, by simp only [linear_map.smul_apply, leibniz,
    linear_map.to_fun_eq_coe, smul_algebra_smul_comm, coe_fn_coe, smul_add, add_comm],⟩,
  mul_smul := λ a1 a2 D, ext $ λ b, mul_smul _ _ _,
  one_smul := λ D, ext $ λ b, one_smul _ _,
  smul_add := λ a D1 D2, ext $ λ b, smul_add _ _ _,
  smul_zero := λ a, ext $ λ b, smul_zero _,
  add_smul := λ a1 a2 D, ext $ λ b, add_smul _ _ _,
  zero_smul := λ D, ext $ λ b, zero_smul _ _ }

@[simp] lemma smul_to_linear_map_coe : ↑(r • D) = (r • D : A →ₗ[R] M) := rfl
@[simp] lemma Rsmul_apply : (r • D) a = r • D a := rfl

instance : semimodule A (derivation R A M) :=
{ smul := λ a D, ⟨⟨λ b, a • D b,
    λ a1 a2, by rw [D.map_add, smul_add],
    λ a1 a2, by rw [D.map_smul, smul_algebra_smul_comm]⟩,
    λ b c, by { dsimp, simp only [smul_add, leibniz, smul_comm, add_comm] }⟩,
  mul_smul := λ a1 a2 D, ext $ λ b, mul_smul _ _ _,
  one_smul := λ D, ext $ λ b, one_smul A _,
  smul_add := λ a D1 D2, ext $ λ b, smul_add _ _ _,
  smul_zero := λ a, ext $ λ b, smul_zero _,
  add_smul := λ a1 a2 D, ext $ λ b, add_smul _ _ _,
  zero_smul := λ D, ext $ λ b, zero_smul A _ }

@[simp] lemma smul_apply : (a • D) b = a • D b := rfl

instance : is_scalar_tower R A (derivation R A M) :=
⟨λ x y z, ext (λ a, smul_assoc _ _ _)⟩

end

section

variables {R : Type*} [comm_ring R]
variables {A : Type*} [comm_ring A] [algebra R A]

section

variables {M : Type*} [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M]
variables (D : derivation R A M) {D1 D2 : derivation R A M} (r : R) (a b : A)

@[simp] lemma map_neg : D (-a) = -D a := linear_map.map_neg D a
@[simp] lemma map_sub : D (a - b) = D a - D b := linear_map.map_sub D a b

instance : add_comm_group (derivation R A M) :=
{ neg := λ D, ⟨-D, λ a b, by simp only [linear_map.neg_apply, smul_neg, neg_add_rev, leibniz,
    linear_map.to_fun_eq_coe, coe_fn_coe, add_comm]⟩,
  add_left_neg := λ D, ext $ λ a, add_left_neg _,
  ..derivation.add_comm_monoid }

end

section lie_structures

/-! # Lie structures -/

variables (D : derivation R A A) {D1 D2 : derivation R A A} (r : R) (a b : A)

open ring_commutator

/-- The commutator of derivations is again a derivation. -/
def commutator (D1 D2 : derivation R A A) : derivation R A A :=
⟨⁅D1, D2⁆, λ a b, by {simp only [commutator, map_add, id.smul_eq_mul, linear_map.mul_app,
  leibniz, linear_map.to_fun_eq_coe, coe_fn_coe, linear_map.sub_apply], ring }⟩

instance : has_bracket (derivation R A A) := ⟨derivation.commutator⟩

@[simp] lemma commutator_coe_linear_map : ↑⁅D1, D2⁆ = (⁅D1, D2⁆ : A →ₗ[R] A) := rfl

lemma commutator_apply : ⁅D1, D2⁆ a = D1 (D2 a) - D2 (D1 a) := rfl

instance : lie_ring (derivation R A A) :=
{ add_lie := λ d e f, by { ext a, simp only [commutator_apply, add_apply, map_add], ring },
  lie_add := λ d e f, by { ext a, simp only [commutator_apply, add_apply, map_add], ring },
  lie_self := λ d, by { ext a, simp only [commutator_apply, add_apply, map_add], ring },
  jacobi := λ d e f, by { ext a, simp only [commutator_apply, add_apply, map_sub], ring } }

instance : lie_algebra R (derivation R A A) :=
{ lie_smul := λ r d e, by { ext a, simp only [commutator_apply, map_smul, smul_sub, Rsmul_apply]},
  ..derivation.Rsemimodule }

end lie_structures

end

end derivation

section comp_der

namespace linear_map

variables {R : Type*} [comm_semiring R]
variables {A : Type*} [comm_semiring A] [algebra R A]
variables {M : Type*} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M]
variables {N : Type*} [add_cancel_comm_monoid N] [semimodule A N] [semimodule R N]
variables [is_scalar_tower R A M] [is_scalar_tower R A N]

/-- The composition of a linear map and a derivation is a derivation. -/
def comp_der (f : M →ₗ[A] N) (D : derivation R A M) : derivation R A N :=
{ to_fun := λ a, f (D a),
  map_add' := λ a1 a2, by rw [D.map_add, f.map_add],
  map_smul' := λ r a, by rw [derivation.map_smul, map_smul_eq_smul_map],
  leibniz' := λ a b, by simp only [derivation.leibniz, linear_map.map_smul, linear_map.map_add, add_comm] }

@[simp] lemma comp_der_apply (f : M →ₗ[A] N) (D : derivation R A M) (a : A) :
  f.comp_der D a = f (D a) := rfl

end linear_map

end comp_der

end CMP_2020


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

! This file was ported from Lean 3 source module category_theory.idempotents.biproducts
! leanprover-community/mathlib commit 31019c2504b17f85af7e0577585fad996935a317
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Idempotents.Karoubi
import Mathbin.CategoryTheory.Additive.Basic

/-!

# Biproducts in the idempotent completion of a preadditive category

In this file, we define an instance expressing that if `C` is an additive category,
then `karoubi C` is also an additive category.

We also obtain that for all `P : karoubi C` where `C` is a preadditive category `C`, there
is a canonical isomorphism `P ⊞ P.complement ≅ (to_karoubi C).obj P.X` in the category
`karoubi C` where `P.complement` is the formal direct factor of `P.X` corresponding to
the idempotent endomorphism `𝟙 P.X - P.p`.

-/

noncomputable section

open CategoryTheory.Category

open CategoryTheory.Limits

open CategoryTheory.Preadditive

universe v

namespace CategoryTheory

namespace Idempotents

namespace Karoubi

variable {C : Type _} [Category.{v} C] [Preadditive C]

namespace Biproducts

/-- The `bicone` used in order to obtain the existence of
the biproduct of a functor `J ⥤ karoubi C` when the category `C` is additive. -/
@[simps]
def bicone [HasFiniteBiproducts C] {J : Type} [Fintype J] (F : J → Karoubi C) : Bicone F
    where
  pt :=
    { pt := biproduct fun j => (F j).pt
      p := biproduct.map fun j => (F j).p
      idem := by
        ext j
        simp only [biproduct.ι_map_assoc, biproduct.ι_map]
        slice_lhs 1 2 => rw [(F j).idem] }
  π j :=
    { f := (biproduct.map fun j => (F j).p) ≫ Bicone.π _ j
      comm := by
        simp only [assoc, biproduct.bicone_π, biproduct.map_π, biproduct.map_π_assoc, (F j).idem] }
  ι j :=
    { f := bicone.ι _ j ≫ biproduct.map fun j => (F j).p
      comm := by
        rw [biproduct.ι_map, ← assoc, ← assoc, (F j).idem, assoc, biproduct.ι_map, ← assoc,
          (F j).idem] }
  ι_π j j' := by
    split_ifs
    · subst h
      simp only [assoc, idem, biproduct.map_π, biproduct.map_π_assoc, eq_to_hom_refl, id_eq,
        hom_ext, comp_f, biproduct.ι_π_self_assoc]
    ·
      simp only [biproduct.ι_π_ne_assoc _ h, assoc, biproduct.map_π, biproduct.map_π_assoc, hom_ext,
        comp_f, zero_comp, quiver.hom.add_comm_group_zero_f]
#align category_theory.idempotents.karoubi.biproducts.bicone CategoryTheory.Idempotents.Karoubi.Biproducts.bicone

end Biproducts

theorem karoubi_hasFiniteBiproducts [HasFiniteBiproducts C] : HasFiniteBiproducts (Karoubi C) :=
  {
    out := fun n =>
      {
        HasBiproduct := fun F => by
          classical
            apply has_biproduct_of_total (biproducts.bicone F)
            ext1
            ext1
            simp only [id_eq, comp_id, biproducts.bicone_X_p, biproduct.ι_map]
            rw [sum_hom, comp_sum, Finset.sum_eq_single j]
            rotate_left
            · intro j' h1 h2
              simp only [biproduct.ι_map, biproducts.bicone_ι_f, biproducts.bicone_π_f, assoc,
                comp_f, biproduct.map_π]
              slice_lhs 1 2 => rw [biproduct.ι_π]
              split_ifs
              · exfalso
                exact h2 h.symm
              · simp only [zero_comp]
            · intro h
              exfalso
              simpa only [Finset.mem_univ, not_true] using h
            · simp only [biproducts.bicone_π_f, comp_f, biproduct.ι_map, assoc,
                biproducts.bicone_ι_f, biproduct.map_π]
              slice_lhs 1 2 => rw [biproduct.ι_π]
              split_ifs
              swap
              · exfalso
                exact h rfl
              simp only [eq_to_hom_refl, id_comp, (F j).idem] } }
#align category_theory.idempotents.karoubi.karoubi_has_finite_biproducts CategoryTheory.Idempotents.Karoubi.karoubi_hasFiniteBiproducts

instance {D : Type _} [Category D] [AdditiveCategory D] : AdditiveCategory (Karoubi D)
    where
  toPreadditive := inferInstance
  to_hasFiniteBiproducts := karoubi_hasFiniteBiproducts

/-- `P.complement` is the formal direct factor of `P.X` given by the idempotent
endomorphism `𝟙 P.X - P.p` -/
@[simps]
def complement (P : Karoubi C) : Karoubi C
    where
  pt := P.pt
  p := 𝟙 _ - P.p
  idem := idem_of_id_sub_idem P.p P.idem
#align category_theory.idempotents.karoubi.complement CategoryTheory.Idempotents.Karoubi.complement

instance (P : Karoubi C) : HasBinaryBiproduct P P.complement :=
  hasBinaryBiproduct_of_total
    { pt := P.pt
      fst := P.decompIdP
      snd := P.complement.decompIdP
      inl := P.decompIdI
      inr := P.complement.decompIdI
      inl_fst := P.decomp_id.symm
      inl_snd :=
        by
        simp only [decomp_id_i_f, decomp_id_p_f, complement_p, comp_sub, comp_f, hom_ext,
          quiver.hom.add_comm_group_zero_f, P.idem]
        erw [comp_id, sub_self]
      inr_fst :=
        by
        simp only [decomp_id_i_f, complement_p, decomp_id_p_f, sub_comp, comp_f, hom_ext,
          quiver.hom.add_comm_group_zero_f, P.idem]
        erw [id_comp, sub_self]
      inr_snd := P.complement.decomp_id.symm }
    (by
      simp only [hom_ext, ← decomp_p, quiver.hom.add_comm_group_add_f, to_karoubi_map_f, id_eq,
        coe_p, complement_p, add_sub_cancel'_right])

/-- A formal direct factor `P : karoubi C` of an object `P.X : C` in a
preadditive category is actually a direct factor of the image `(to_karoubi C).obj P.X`
of `P.X` in the category `karoubi C` -/
def decomposition (P : Karoubi C) : P ⊞ P.complement ≅ (toKaroubi _).obj P.pt
    where
  Hom := biprod.desc P.decompIdI P.complement.decompIdI
  inv := biprod.lift P.decompIdP P.complement.decompIdP
  hom_inv_id' := by
    ext1
    · simp only [← assoc, biprod.inl_desc, comp_id, biprod.lift_eq, comp_add, ← decomp_id, id_comp,
        add_right_eq_self]
      convert zero_comp
      ext
      simp only [decomp_id_i_f, decomp_id_p_f, complement_p, comp_sub, comp_f,
        quiver.hom.add_comm_group_zero_f, P.idem]
      erw [comp_id, sub_self]
    · simp only [← assoc, biprod.inr_desc, biprod.lift_eq, comp_add, ← decomp_id, comp_id, id_comp,
        add_left_eq_self]
      convert zero_comp
      ext
      simp only [decomp_id_i_f, decomp_id_p_f, complement_p, sub_comp, comp_f,
        quiver.hom.add_comm_group_zero_f, P.idem]
      erw [id_comp, sub_self]
  inv_hom_id' := by
    rw [biprod.lift_desc]
    simp only [← decomp_p]
    ext
    dsimp only [complement, to_karoubi]
    simp only [quiver.hom.add_comm_group_add_f, add_sub_cancel'_right, id_eq]
#align category_theory.idempotents.karoubi.decomposition CategoryTheory.Idempotents.Karoubi.decomposition

end Karoubi

end Idempotents

end CategoryTheory


/-
Copyright (c) 2022 Alex Kontorovich and Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex Kontorovich, Heather Macbeth
-/

import measure_theory.measure.haar
import measure_theory.group.fundamental_domain
import topology.compact_open
import algebra.group.opposite

/-!
# Haar quotient measure

In this file, we consider properties of fundamental domains and measures for the action of a
subgroup of a group `G` on `G` itself.

## Main results

* `measure_theory.is_fundamental_domain.smul_invariant_measure_map `: given a subgroup `Γ` of a
  topological group `G`, the pushforward to the coset space `G ⧸ Γ` of the restriction of a both
  left- and right-invariant measure on `G` to a fundamental domain `𝓕` is a `G`-invariant measure
  on `G ⧸ Γ`.

* `measure_theory.is_fundamental_domain.is_mul_left_invariant_map `: given a normal subgroup `Γ` of
  a topological group `G`, the pushforward to the quotient group `G ⧸ Γ` of the restriction of
  a both left- and right-invariant measure on `G` to a fundamental domain `𝓕` is a left-invariant
  measure on `G ⧸ Γ`.

Note that a group `G` with Haar measure that is both left and right invariant is called
**unimodular**.
-/

open set measure_theory topological_space measure_theory.measure
open_locale pointwise

variables {G : Type*} [group G] [measurable_space G] [topological_space G]
  [topological_group G] [borel_space G]
  {μ : measure G}
  {Γ : subgroup G}

/-- Given a subgroup `Γ` of `G` and a right invariant measure `μ` on `G`, the measure is also
  invariant under the action of `Γ` on `G` by **right** multiplication. -/
@[to_additive "Given a subgroup `Γ` of an additive group `G` and a right invariant measure `μ` on
  `G`, the measure is also invariant under the action of `Γ` on `G` by **right** addition."]
lemma subgroup.smul_invariant_measure [μ.is_mul_right_invariant] :
  smul_invariant_measure Γ.opposite G μ :=
{ measure_preimage_smul :=
begin
  rintros ⟨c, hc⟩ s hs,
  dsimp [(•)],
  refine measure_preimage_mul_right μ (mul_opposite.unop c) s,
end}

/-- Measurability of the action of the topological group `G` on the left-coset space `G/Γ`. -/
@[to_additive "Measurability of the action of the additive topological group `G` on the left-coset
  space `G/Γ`."]
instance quotient_group.has_measurable_smul [measurable_space (G ⧸ Γ)] [borel_space (G ⧸ Γ)] :
  has_measurable_smul G (G ⧸ Γ) :=
{ measurable_const_smul := λ g, (continuous_const_smul g).measurable,
  measurable_smul_const := λ x, (quotient_group.continuous_smul₁ x).measurable }

variables {𝓕 : set G} (h𝓕 : is_fundamental_domain Γ.opposite 𝓕 μ)
include h𝓕

variables [encodable Γ] [measurable_space (G ⧸ Γ)] [borel_space (G ⧸ Γ)]

/-- The pushforward to the coset space `G ⧸ Γ` of the restriction of a both left- and right-
  invariant measure on `G` to a fundamental domain `𝓕` is a `G`-invariant measure on `G ⧸ Γ`. -/
@[to_additive "The pushforward to the coset space `G ⧸ Γ` of the restriction of a both left- and
  right-invariant measure on an additive topological group `G` to a fundamental domain `𝓕` is a
  `G`-invariant measure on `G ⧸ Γ`."]
lemma measure_theory.is_fundamental_domain.smul_invariant_measure_map
  [μ.is_mul_left_invariant] [μ.is_mul_right_invariant] :
  smul_invariant_measure G (G ⧸ Γ) (measure.map quotient_group.mk (μ.restrict 𝓕)) :=
{ measure_preimage_smul :=
  begin
    let π : G → G ⧸ Γ := quotient_group.mk,
    have meas_π : measurable π :=
      continuous_quotient_mk.measurable,
    have 𝓕meas : null_measurable_set 𝓕 μ := h𝓕.null_measurable_set,
    intros g A hA,
    have meas_πA : measurable_set (π ⁻¹' A) := measurable_set_preimage meas_π hA,
    rw [measure.map_apply meas_π hA,
      measure.map_apply meas_π (measurable_set_preimage (measurable_const_smul g) hA),
      measure.restrict_apply₀' 𝓕meas, measure.restrict_apply₀' 𝓕meas],
    set π_preA := π ⁻¹' A,
    have : (quotient_group.mk ⁻¹' ((λ (x : G ⧸ Γ), g • x) ⁻¹' A)) = has_mul.mul g ⁻¹' π_preA,
    { ext1, simp },
    rw this,
    have : μ (has_mul.mul g ⁻¹' π_preA ∩ 𝓕) = μ (π_preA ∩ has_mul.mul (g⁻¹) ⁻¹' 𝓕),
    { transitivity μ (has_mul.mul g ⁻¹' (π_preA ∩ has_mul.mul g⁻¹ ⁻¹' 𝓕)),
      { rw preimage_inter,
        congr,
        rw [← preimage_comp, comp_mul_left, mul_left_inv],
        ext,
        simp, },
      rw measure_preimage_mul, },
    rw this,
    haveI : smul_invariant_measure ↥(Γ.opposite) G μ := subgroup.smul_invariant_measure,
    haveI : smul_invariant_measure G G μ := ⟨λ c s hs, measure_preimage_mul μ c s⟩,
    -- Lean can generate the next instance but it has no additive version of the autogenerated proof
    haveI : smul_comm_class G Γ.opposite G := ⟨λ a b c, (mul_assoc _ _ _).symm⟩,
    have h𝓕_translate_fundom : is_fundamental_domain Γ.opposite (g • 𝓕) μ := h𝓕.smul_of_comm g,
    rw [h𝓕.measure_set_eq h𝓕_translate_fundom meas_πA, ← preimage_smul_inv], refl,
    rintros ⟨γ, γ_in_Γ⟩,
    ext,
    have : π (x * (mul_opposite.unop γ)) = π (x) := by simpa [quotient_group.eq'] using γ_in_Γ,
    simp [(•), this],
  end }

/-- Assuming `Γ` is a normal subgroup of a topological group `G`, the pushforward to the quotient
  group `G ⧸ Γ` of the restriction of a both left- and right-invariant measure on `G` to a
  fundamental domain `𝓕` is a left-invariant measure on `G ⧸ Γ`. -/
@[to_additive "Assuming `Γ` is a normal subgroup of an additive topological group `G`, the
  pushforward to the quotient group `G ⧸ Γ` of the restriction of a both left- and right-invariant
  measure on `G` to a fundamental domain `𝓕` is a left-invariant measure on `G ⧸ Γ`."]
lemma measure_theory.is_fundamental_domain.is_mul_left_invariant_map [subgroup.normal Γ]
  [μ.is_mul_left_invariant] [μ.is_mul_right_invariant] :
  (measure.map (quotient_group.mk' Γ) (μ.restrict 𝓕)).is_mul_left_invariant :=
{ map_mul_left_eq_self := begin
    intros x,
    apply measure.ext,
    intros A hA,
    obtain ⟨x₁, _⟩ := @quotient.exists_rep _ (quotient_group.left_rel Γ) x,
    haveI := h𝓕.smul_invariant_measure_map,
    convert measure_preimage_smul x₁ ((measure.map quotient_group.mk) (μ.restrict 𝓕)) A using 1,
    rw [← h, measure.map_apply],
    { refl, },
    { exact measurable_const_mul _, },
    { exact hA, },
  end }

variables [t2_space (G ⧸ Γ)] [second_countable_topology (G ⧸ Γ)] (K : positive_compacts (G ⧸ Γ))

/-- Given a normal subgroup `Γ` of a topological group `G` with Haar measure `μ`, which is also
  right-invariant, and a finite volume fundamental domain `𝓕`, the pushforward to the quotient
  group `G ⧸ Γ` of the restriction of `μ` to `𝓕` is a multiple of Haar measure on `G ⧸ Γ`. -/
@[to_additive "Given a normal subgroup `Γ` of an additive topological group `G` with Haar measure
  `μ`, which is also right-invariant, and a finite volume fundamental domain `𝓕`, the pushforward
  to the quotient group `G ⧸ Γ` of the restriction of `μ` to `𝓕` is a multiple of Haar measure on
  `G ⧸ Γ`."]
lemma measure_theory.is_fundamental_domain.map_restrict_quotient [subgroup.normal Γ]
  [measure_theory.measure.is_haar_measure μ] [μ.is_mul_right_invariant]
  (h𝓕_finite : μ 𝓕 < ⊤) : measure.map (quotient_group.mk' Γ) (μ.restrict 𝓕)
  = (μ (𝓕 ∩ (quotient_group.mk' Γ) ⁻¹' K)) • (measure_theory.measure.haar_measure K) :=
begin
  let π : G →* G ⧸ Γ := quotient_group.mk' Γ,
  have meas_π : measurable π := continuous_quotient_mk.measurable,
  have 𝓕meas : null_measurable_set 𝓕 μ := h𝓕.null_measurable_set,
  haveI : is_finite_measure (μ.restrict 𝓕) :=
    ⟨by { rw [measure.restrict_apply₀' 𝓕meas, univ_inter], exact h𝓕_finite }⟩,
  -- the measure is left-invariant, so by the uniqueness of Haar measure it's enough to show that
  -- it has the stated size on the reference compact set `K`.
  haveI : (measure.map (quotient_group.mk' Γ) (μ.restrict 𝓕)).is_mul_left_invariant :=
    h𝓕.is_mul_left_invariant_map,
  rw [measure.haar_measure_unique (measure.map (quotient_group.mk' Γ) (μ.restrict 𝓕)) K,
    measure.map_apply meas_π, measure.restrict_apply₀' 𝓕meas, inter_comm],
  exact K.compact.measurable_set,
end


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/

import logic.eq
open eq.ops decidable

namespace option
  definition is_none {A : Type} : option A →  Prop
  | none     := true
  | (some v) := false

  theorem is_none_none {A : Type} : is_none (@none A) :=
  trivial

  theorem not_is_none_some {A : Type} (a : A) : ¬ is_none (some a) :=
  not_false

  theorem none_ne_some {A : Type} (a : A) : none ≠ some a :=
  by contradiction

  theorem some.inj {A : Type} {a₁ a₂ : A} (H : some a₁ = some a₂) : a₁ = a₂ :=
  by injection H; assumption

  protected definition is_inhabited [instance] (A : Type) : inhabited (option A) :=
  inhabited.mk none

  protected definition has_decidable_eq [instance] {A : Type} [H : decidable_eq A] : ∀ o₁ o₂ : option A, decidable (o₁ = o₂)
  | none      none      := by left;  reflexivity
  | none      (some v₂) := by right; contradiction
  | (some v₁) none      := by right; contradiction
  | (some v₁) (some v₂) :=
    match H v₁ v₂ with
    | inl e := by left; congruence; assumption
    | inr n := by right; intro h; injection h; contradiction
    end
end option


variables A B C D : Prop
variable hA : A
example (h : A \/ B) (h2 : A -> C) (h3 : B -> D) : (C \/ D) :=
have hC : C, from h2 hA,
show C \/ D, from or.inl hC


import data.set.basic

import topology.basic
import algebra.module.basic
import algebra.module.submodule

import order.complete_lattice

import analysis.normed_space.basic

-- Soit E une espace vectoriel normé.
-- (a) Soient F une partie fermée non vide de E et x ∈ E . Montrer
--      d(x, F ) = 0 ⇐⇒ x ∈ F .

theorem a {R E: Type*} [normed_field R] [normed_group E] [normed_space R E] :
  forall (F: set E) (x: E), (is_closed F) -> (set.nonempty F) ->
    set.mem x F <-> infi (dist x) = 0
:= sorry


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

import number_theory.cyclotomic.primitive_roots
import ring_theory.discriminant

/-!
# Discriminant of cyclotomic fields
We compute the discriminant of a `p ^ n`-th cyclotomic extension.

## Main results
* `is_cyclotomic_extension.discr_odd_prime` : if `p` is an odd prime such that
  `is_cyclotomic_extension {p} K L` and `irreducible (cyclotomic p K)`, then
  `discr K (hζ.power_basis K).basis = (-1) ^ ((p - 1) / 2) * p ^ (p - 2)` for any
  `hζ : is_primitive_root ζ p`.

-/

universes u v

open algebra polynomial nat is_primitive_root power_basis

open_locale polynomial cyclotomic

namespace is_primitive_root

variables {n : ℕ+} {K : Type u} [field K] [char_zero K] {ζ : K}
variables [is_cyclotomic_extension {n} ℚ K]

/-- The discriminant of the power basis given by a primitive root of unity `ζ` is the same as the
discriminant of the power basis given by `ζ - 1`. -/
lemma discr_zeta_eq_discr_zeta_sub_one (hζ : is_primitive_root ζ n) :
  discr ℚ (hζ.power_basis ℚ).basis = discr ℚ (hζ.sub_one_power_basis ℚ).basis :=
begin
  haveI : number_field K := number_field.mk,
  have H₁ : (aeval (hζ.power_basis ℚ).gen) (X - 1 : ℤ[X]) = (hζ.sub_one_power_basis ℚ).gen :=
    by simp,
  have H₂ : (aeval (hζ.sub_one_power_basis ℚ).gen) (X + 1 : ℤ[X]) = (hζ.power_basis ℚ).gen :=
    by simp,
  refine discr_eq_discr_of_to_matrix_coeff_is_integral _
    (λ i j, to_matrix_is_integral H₁ _ _ _ _)
    (λ i j, to_matrix_is_integral H₂ _ _ _ _),
  { exact hζ.is_integral n.pos },
  { refine minpoly.gcd_domain_eq_field_fractions _ (hζ.is_integral n.pos) },
  { exact is_integral_sub (hζ.is_integral n.pos) is_integral_one },
  { refine minpoly.gcd_domain_eq_field_fractions _ _,
    exact is_integral_sub (hζ.is_integral n.pos) is_integral_one }
end

end is_primitive_root

namespace is_cyclotomic_extension

variables {p : ℕ+} {k : ℕ} {K : Type u} {L : Type v} {ζ : L} [field K] [field L]
variables [algebra K L]

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ (k + 1)} K L`, then the discriminant of
`hζ.power_basis K` is `(-1) ^ ((p ^ (k + 1).totient) / 2) * p ^ (p ^ k * ((p - 1) * (k + 1) - 1))`
if `irreducible (cyclotomic (p ^ (k + 1)) K))`, and `p ^ (k + 1) ≠ 2`. -/
lemma discr_prime_pow_ne_two [is_cyclotomic_extension {p ^ (k + 1)} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ ↑(p ^ (k + 1))) (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K))
  (hk : p ^ (k + 1) ≠ 2) :
  discr K (hζ.power_basis K).basis =
  (-1) ^ (((p ^ (k + 1) : ℕ).totient) / 2) * p ^ ((p : ℕ) ^ k * ((p - 1) * (k + 1) - 1)) :=
begin
  haveI hne := is_cyclotomic_extension.ne_zero' (p ^ (k + 1)) K L,
  have hp2 : p = 2 → 1 ≤ k,
  { intro hp,
    refine one_le_iff_ne_zero.2 (λ h, _),
    rw [h, hp, zero_add, pow_one] at hk,
    exact hk rfl },

  rw [discr_power_basis_eq_norm, finrank _ hirr, hζ.power_basis_gen _,
    ← hζ.minpoly_eq_cyclotomic_of_irreducible hirr, pnat.pow_coe, totient_prime_pow hp.out
    (succ_pos k)],
  congr' 1,
  { by_cases hptwo : p = 2,
    { obtain ⟨k₁, hk₁⟩ := nat.exists_eq_succ_of_ne_zero (one_le_iff_ne_zero.1 (hp2 hptwo)),
      rw [hk₁, succ_sub_one, hptwo, pnat.coe_bit0, pnat.one_coe, succ_sub_succ_eq_sub, tsub_zero,
        mul_one, pow_succ, mul_assoc, nat.mul_div_cancel_left _ zero_lt_two,
        nat.mul_div_cancel_left _ zero_lt_two],
      by_cases hk₁zero : k₁ = 0,
      { simp [hk₁zero] },
      obtain ⟨k₂, rfl⟩ := nat.exists_eq_succ_of_ne_zero hk₁zero,
      rw [pow_succ, mul_assoc, pow_mul (-1 : K), pow_mul (-1 : K), neg_one_sq, one_pow, one_pow] },
    { simp only [succ_sub_succ_eq_sub, tsub_zero],
      replace hptwo : ↑p ≠ 2,
      { intro h,
        rw [← pnat.one_coe, ← pnat.coe_bit0, pnat.coe_inj] at h,
        exact hptwo h },
      obtain ⟨a, ha⟩ := even_sub_one_of_prime_ne_two hp.out hptwo,
      rw [mul_comm ((p : ℕ) ^ k), mul_assoc, ha],
      nth_rewrite 0 [← mul_one a],
      nth_rewrite 4 [← mul_one a],
      rw [← nat.mul_succ, mul_comm a, mul_assoc, mul_assoc 2, nat.mul_div_cancel_left _
        zero_lt_two, nat.mul_div_cancel_left _ zero_lt_two, ← mul_assoc, mul_comm
        (a * (p : ℕ) ^ k), pow_mul, ← ha],
      congr' 1,
      refine odd.neg_one_pow (nat.even.sub_odd (nat.succ_le_iff.2 (mul_pos (tsub_pos_iff_lt.2
        hp.out.one_lt) (pow_pos hp.out.pos _))) (even.mul_right (nat.even_sub_one_of_prime_ne_two
        hp.out hptwo) _) odd_one) } },
  { have H := congr_arg derivative (cyclotomic_prime_pow_mul_X_pow_sub_one K p k),
    rw [derivative_mul, derivative_sub, derivative_one, sub_zero, derivative_pow,
      derivative_X, mul_one, derivative_sub, derivative_one, sub_zero, derivative_pow,
      derivative_X, mul_one, ← pnat.pow_coe, hζ.minpoly_eq_cyclotomic_of_irreducible hirr] at H,
    replace H := congr_arg (λ P, aeval ζ P) H,
    simp only [aeval_add, aeval_mul, minpoly.aeval, zero_mul, add_zero, aeval_nat_cast,
      _root_.map_sub, aeval_one, aeval_X_pow] at H,
    replace H := congr_arg (algebra.norm K) H,
    have hnorm : (norm K) (ζ ^ (p : ℕ) ^ k - 1) = p ^ ((p : ℕ) ^ k),
    { by_cases hp : p = 2,
      { exact hζ.pow_sub_one_norm_prime_pow_of_one_le hirr rfl.le (hp2 hp) },
      { exact hζ.pow_sub_one_norm_prime_ne_two hirr rfl.le hp } },
    rw [monoid_hom.map_mul, hnorm, monoid_hom.map_mul, ← map_nat_cast (algebra_map K L),
      algebra.norm_algebra_map, finrank _ hirr, pnat.pow_coe, totient_prime_pow hp.out (succ_pos k),
      nat.sub_one, nat.pred_succ, ← hζ.minpoly_eq_cyclotomic_of_irreducible hirr, map_pow,
      hζ.norm_eq_one hk hirr, one_pow, mul_one, cast_pow, ← coe_coe, ← pow_mul, ← mul_assoc,
      mul_comm (k + 1), mul_assoc] at H,
    { have := mul_pos (succ_pos k) (tsub_pos_iff_lt.2 hp.out.one_lt),
      rw [← succ_pred_eq_of_pos this, mul_succ, pow_add _ _ ((p : ℕ) ^ k)] at H,
      replace H := (mul_left_inj' (λ h, _)).1 H,
      { simpa only [← pnat.pow_coe, H, mul_comm _ (k + 1)] },
      { replace h := pow_eq_zero h,
        rw [coe_coe] at h,
        simpa using hne.1 } },
    all_goals { apply_instance } },
  all_goals { apply_instance }
end

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ (k + 1)} K L`, then the discriminant of
`hζ.power_basis K` is `(-1) ^ (p ^ k * (p - 1) / 2) * p ^ (p ^ k * ((p - 1) * (k + 1) - 1))`
if `irreducible (cyclotomic (p ^ (k + 1)) K))`, and `p ^ (k + 1) ≠ 2`. -/
lemma discr_prime_pow_ne_two' [is_cyclotomic_extension {p ^ (k + 1)} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ ↑(p ^ (k + 1))) (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K))
  (hk : p ^ (k + 1) ≠ 2) :
  discr K (hζ.power_basis K).basis =
  (-1) ^ (((p : ℕ) ^ k  * (p - 1)) / 2) * p ^ ((p : ℕ) ^ k * ((p - 1) * (k + 1) - 1)) :=
by simpa [totient_prime_pow hp.out (succ_pos k)] using discr_prime_pow_ne_two hζ hirr hk

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ k} K L`, then the discriminant of
`hζ.power_basis K` is `(-1) ^ ((p ^ k).totient / 2) * p ^ (p ^ (k - 1) * ((p - 1) * k - 1))`
if `irreducible (cyclotomic (p ^ k) K))`. Beware that in the cases `p ^ k = 1` and `p ^ k = 2`
the formula uses `1 / 2 = 0` and `0 - 1 = 0`. It is useful only to have a uniform result.
See also `is_cyclotomic_extension.discr_prime_pow_eq_unit_mul_pow`. -/
lemma discr_prime_pow [hcycl : is_cyclotomic_extension {p ^ k} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ ↑(p ^ k)) (hirr : irreducible (cyclotomic (↑(p ^ k) : ℕ) K)) :
  discr K (hζ.power_basis K).basis =
  (-1) ^ (((p ^ k : ℕ).totient) / 2) * p ^ ((p : ℕ) ^ (k - 1) * ((p - 1) * k - 1)) :=
begin
  unfreezingI { cases k },
  { simp only [coe_basis, pow_zero, power_basis_gen, totient_one, mul_zero, mul_one, show 1 / 2 = 0,
      by refl, discr, trace_matrix],
    have hζone : ζ = 1 := by simpa using hζ,
    rw [hζ.power_basis_dim _, hζone, ← (algebra_map K L).map_one,
      minpoly.eq_X_sub_C_of_algebra_map_inj _ (algebra_map K L).injective, nat_degree_X_sub_C],
    simp only [trace_matrix, map_one, one_pow, matrix.det_unique, trace_form_apply, mul_one],
    rw [← (algebra_map K L).map_one, trace_algebra_map, finrank _ hirr],
    { simp },
    { apply_instance },
    { exact hcycl } },
  { by_cases hk : p ^ (k + 1) = 2,
    { have hp : p = 2,
      { rw [← pnat.coe_inj, pnat.coe_bit0, pnat.one_coe, pnat.pow_coe, ← pow_one 2] at hk,
      replace hk := eq_of_prime_pow_eq (prime_iff.1 hp.out) (prime_iff.1 nat.prime_two)
        (succ_pos _) hk,
      rwa [show 2 = ((2 : ℕ+) : ℕ), by simp, pnat.coe_inj] at hk },
      rw [hp, ← pnat.coe_inj, pnat.pow_coe, pnat.coe_bit0, pnat.one_coe] at hk,
      nth_rewrite 1 [← pow_one 2] at hk,
      replace hk := nat.pow_right_injective rfl.le hk,
      rw [add_left_eq_self] at hk,
      simp only [hp, hk, pow_one, pnat.coe_bit0, pnat.one_coe] at hζ,
      simp only [hp, hk, show 1 / 2 = 0, by refl, coe_basis, pow_one, power_basis_gen,
        pnat.coe_bit0, pnat.one_coe, totient_two, pow_zero, mul_one, mul_zero],
      rw [power_basis_dim, hζ.eq_neg_one_of_two_right, show (-1 : L) = algebra_map K L (-1),
        by simp, minpoly.eq_X_sub_C_of_algebra_map_inj _ (algebra_map K L).injective,
        nat_degree_X_sub_C],
      simp only [discr, trace_matrix, matrix.det_unique, fin.default_eq_zero, fin.coe_zero,
        pow_zero, trace_form_apply, mul_one],
      rw [← (algebra_map K L).map_one, trace_algebra_map, finrank _ hirr, hp, hk],
      { simp },
      { apply_instance },
      { exact hcycl } },
    { exact discr_prime_pow_ne_two hζ hirr hk } }
end

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ k} K L`, then there are `u : ℤˣ` and
`n : ℕ` such that the discriminant of `hζ.power_basis K` is `u * p ^ n`. Often this is enough and
less cumbersome to use than `is_cyclotomic_extension.discr_prime_pow`. -/
lemma discr_prime_pow_eq_unit_mul_pow [is_cyclotomic_extension {p ^ k} K L]
  [hp : fact (p : ℕ).prime] (hζ : is_primitive_root ζ ↑(p ^ k))
  (hirr : irreducible (cyclotomic (↑(p ^ k) : ℕ) K)) :
  ∃ (u : ℤˣ) (n : ℕ), discr K (hζ.power_basis K).basis = u * p ^ n :=
begin
  rw [discr_prime_pow hζ hirr],
  by_cases heven : even (((p ^ k : ℕ).totient) / 2),
  { refine ⟨1, (p : ℕ) ^ (k - 1) * ((p - 1) * k - 1), by simp [heven.neg_one_pow]⟩ },
  { exact ⟨-1, (p : ℕ) ^ (k - 1) * ((p - 1) * k - 1),
      by simp [(odd_iff_not_even.2 heven).neg_one_pow]⟩ },
end

/-- If `p` is an odd prime and `is_cyclotomic_extension {p} K L`, then
`discr K (hζ.power_basis K).basis = (-1) ^ ((p - 1) / 2) * p ^ (p - 2)` if
`irreducible (cyclotomic p K)`. -/
lemma discr_odd_prime [is_cyclotomic_extension {p} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ p) (hirr : irreducible (cyclotomic p K)) (hodd : p ≠ 2) :
  discr K (hζ.power_basis K).basis = (-1) ^ (((p : ℕ) - 1) / 2) * p ^ ((p : ℕ) - 2) :=
begin
  haveI : is_cyclotomic_extension {p ^ (0 + 1)} K L,
  { rw [zero_add, pow_one],
    apply_instance },
  have hζ' : is_primitive_root ζ ↑(p ^ (0 + 1)) := by simpa using hζ,
  convert discr_prime_pow_ne_two hζ' (by simpa [hirr]) (by simp [hodd]),
  { rw [zero_add, pow_one, totient_prime hp.out] },
  { rw [pow_zero, one_mul, zero_add, mul_one, nat.sub_sub] }
end

end is_cyclotomic_extension


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johan Commelin, Andrew Yang, Joël Riou
-/
import category_theory.limits.preserves.shapes.zero
import category_theory.monoidal.End
import category_theory.monoidal.discrete

/-!
# Shift

A `shift` on a category `C` indexed by a monoid `A` is nothing more than a monoidal functor
from `A` to `C ⥤ C`. A typical example to keep in mind might be the category of
complexes `⋯ → C_{n-1} → C_n → C_{n+1} → ⋯`. It has a shift indexed by `ℤ`, where we assign to
each `n : ℤ` the functor `C ⥤ C` that re-indexes the terms, so the degree `i` term of `shift n C`
would be the degree `i+n`-th term of `C`.

## Main definitions
* `has_shift`: A typeclass asserting the existence of a shift functor.
* `shift_equiv`: When the indexing monoid is a group, then the functor indexed by `n` and `-n` forms
  an self-equivalence of `C`.
* `shift_comm`: When the indexing monoid is commutative, then shifts commute as well.

## Implementation Notes

`[has_shift C A]` is implemented using `monoidal_functor (discrete A) (C ⥤ C)`.
However, the API of monodial functors is used only internally: one should use the API of
shifts functors which includes `shift_functor C a : C ⥤ C` for `a : A`,
`shift_functor_zero C A : shift_functor C (0 : A) ≅ 𝟭 C` and
`shift_functor_add C i j : shift_functor C (i + j) ≅ shift_functor C i ⋙ shift_functor C j`
(and its variant `shift_functor_add'`). These isomorphisms satisfy some coherence properties
which are stated in lemmas like `shift_functor_add'_assoc`, `shift_functor_add'_zero_add` and
`shift_functor_add'_add_zero`.

-/
namespace category_theory

noncomputable theory

universes v u

variables (C : Type u) (A : Type*) [category.{v} C]

local attribute [instance] endofunctor_monoidal_category

section defs

variables (A C) [add_monoid A]

/-- A category has a shift indexed by an additive monoid `A`
if there is a monoidal functor from `A` to `C ⥤ C`. -/
class has_shift (C : Type u) (A : Type*) [category.{v} C] [add_monoid A] :=
(shift : monoidal_functor (discrete A) (C ⥤ C))

/-- A helper structure to construct the shift functor `(discrete A) ⥤ (C ⥤ C)`. -/
@[nolint has_nonempty_instance]
structure shift_mk_core :=
(F : A → (C ⥤ C))
(zero : F 0 ≅ 𝟭 C)
(add : Π n m : A, F (n + m) ≅ F n ⋙ F m)
(assoc_hom_app : ∀ (m₁ m₂ m₃ : A) (X : C),
  (add (m₁ + m₂) m₃).hom.app X ≫ (F m₃).map ((add m₁ m₂).hom.app X) =
    eq_to_hom (by rw [add_assoc]) ≫ (add m₁ (m₂ + m₃)).hom.app X ≫
      (add m₂ m₃).hom.app ((F m₁).obj X))
(zero_add_hom_app : ∀ (n : A) (X : C), (add 0 n).hom.app X =
  eq_to_hom (by dsimp; rw [zero_add]) ≫ (F n).map (zero.inv.app X))
(add_zero_hom_app : ∀ (n : A)  (X : C), (add n 0).hom.app X =
  eq_to_hom (by dsimp; rw [add_zero]) ≫ zero.inv.app ((F n).obj X))

namespace shift_mk_core

variables {C A}

attribute [reassoc] assoc_hom_app

@[reassoc]
lemma assoc_inv_app (h : shift_mk_core C A) (m₁ m₂ m₃ : A) (X : C) :
  (h.F m₃).map ((h.add m₁ m₂).inv.app X) ≫ (h.add (m₁ + m₂) m₃).inv.app X =
    (h.add m₂ m₃).inv.app ((h.F m₁).obj X) ≫ (h.add m₁ (m₂ + m₃)).inv.app X ≫
      eq_to_hom (by rw [add_assoc]) :=
begin
  rw [← cancel_mono ((h.add (m₁ + m₂) m₃).hom.app X ≫ (h.F m₃).map ((h.add m₁ m₂).hom.app X)),
    category.assoc, category.assoc, category.assoc, iso.inv_hom_id_app_assoc, ← functor.map_comp,
    iso.inv_hom_id_app, functor.map_id, h.assoc_hom_app, eq_to_hom_trans_assoc, eq_to_hom_refl,
    category.id_comp, iso.inv_hom_id_app_assoc, iso.inv_hom_id_app],
  refl,
end

lemma zero_add_inv_app (h : shift_mk_core C A) (n : A) (X : C) :
  (h.add 0 n).inv.app X = (h.F n).map (h.zero.hom.app X) ≫
    eq_to_hom (by dsimp; rw [zero_add]) :=
by rw [← cancel_epi ((h.add 0 n).hom.app X), iso.hom_inv_id_app, h.zero_add_hom_app,
  category.assoc, ← functor.map_comp_assoc, iso.inv_hom_id_app, functor.map_id,
  category.id_comp, eq_to_hom_trans, eq_to_hom_refl]

lemma add_zero_inv_app (h : shift_mk_core C A) (n : A) (X : C) :
    (h.add n 0).inv.app X = h.zero.hom.app ((h.F n).obj X) ≫
      eq_to_hom (by dsimp; rw [add_zero]) :=
by rw [← cancel_epi ((h.add n 0).hom.app X), iso.hom_inv_id_app, h.add_zero_hom_app,
  category.assoc, iso.inv_hom_id_app_assoc, eq_to_hom_trans, eq_to_hom_refl]

end shift_mk_core

section

local attribute [simp] eq_to_hom_map
local attribute [reducible] endofunctor_monoidal_category discrete.add_monoidal

/-- Constructs a `has_shift C A` instance from `shift_mk_core`. -/
def has_shift_mk (h : shift_mk_core C A) : has_shift C A :=
⟨ { ε := h.zero.inv,
    μ := λ m n, (h.add m.as n.as).inv,
    μ_natural' := by { rintros ⟨X⟩ ⟨Y⟩ ⟨X'⟩ ⟨Y'⟩ ⟨⟨⟨rfl⟩⟩⟩ ⟨⟨⟨rfl⟩⟩⟩, ext,
      dsimp, simp only [discrete.functor_map_id, category.assoc], dsimp, simp },
    associativity' :=
    begin
      rintros ⟨m₁⟩ ⟨m₂⟩ ⟨m₃⟩,
      ext X,
      dsimp,
      simp [h.assoc_inv_app_assoc m₁ m₂ m₃ X],
    end,
    left_unitality' :=
    begin
      rintro ⟨n⟩,
      ext X,
      dsimp,
      simp only [h.zero_add_inv_app, ←functor.map_comp, category.id_comp, eq_to_hom_map,
        eq_to_hom_app, category.assoc, eq_to_hom_trans, eq_to_hom_refl, category.comp_id,
        iso.inv_hom_id_app],
      erw [functor.map_id],
    end,
    right_unitality' :=
    begin
      rintro ⟨n⟩,
      ext X,
      dsimp,
      simpa only [h.add_zero_inv_app, functor.map_id, category.comp_id, eq_to_hom_map,
        eq_to_hom_app, category.assoc, eq_to_hom_trans, eq_to_hom_refl, iso.inv_hom_id_app],
    end,
    ..(discrete.functor h.F) }⟩

end

section

variables [has_shift C A]

/-- The monoidal functor from `A` to `C ⥤ C` given a `has_shift` instance. -/
def shift_monoidal_functor : monoidal_functor (discrete A) (C ⥤ C) := has_shift.shift

variable {A}

/-- The shift autoequivalence, moving objects and morphisms 'up'. -/
def shift_functor (i : A) : C ⥤ C := (shift_monoidal_functor C A).obj ⟨i⟩

/-- Shifting by `i + j` is the same as shifting by `i` and then shifting by `j`. -/
def shift_functor_add (i j : A) :
  shift_functor C (i + j) ≅ shift_functor C i ⋙ shift_functor C j :=
((shift_monoidal_functor C A).μ_iso ⟨i⟩ ⟨j⟩).symm

/-- When `k = i + j`, shifting by `k` is the same as shifting by `i` and then shifting by `j`. -/
def shift_functor_add' (i j k : A) (h : i + j = k) :
  shift_functor C k ≅ shift_functor C i ⋙ shift_functor C j :=
eq_to_iso (by rw [h]) ≪≫ shift_functor_add C i j

lemma shift_functor_add'_eq_shift_functor_add (i j : A) :
  shift_functor_add' C i j (i+j) rfl = shift_functor_add C i j :=
by { ext1, apply category.id_comp }

variables (A)

/-- Shifting by zero is the identity functor. -/
def shift_functor_zero : shift_functor C (0 : A) ≅ 𝟭 C :=
(shift_monoidal_functor C A).ε_iso.symm

end

variables {C A}

lemma shift_mk_core.shift_functor_eq (h : shift_mk_core C A) (a : A) :
    @shift_functor _ _ _ _ (has_shift_mk C A h) a = h.F a :=
functor.ext (by tidy) (by tidy)

lemma shift_mk_core.shift_functor_zero_eq (h : shift_mk_core C A) :
  @shift_functor_zero _ _ _ _ (has_shift_mk C A h) = h.zero :=
begin
  letI := has_shift_mk C A h,
  ext1,
  suffices : (shift_functor_zero C A).inv = h.zero.inv,
  { rw [← cancel_mono (h.zero.inv), h.zero.hom_inv_id, ← this, iso.hom_inv_id],
    refl, },
  refl,
end

lemma shift_mk_core.shift_functor_add_eq (h : shift_mk_core C A) (a b : A) :
  @shift_functor_add _ _ _ _ (has_shift_mk C A h) a b = h.add a b :=
begin
  letI := has_shift_mk C A h,
  ext1,
  suffices : (shift_functor_add C a b).inv = (h.add a b).inv,
  { rw [← cancel_mono ((h.add a b).inv), (h.add a b).hom_inv_id, ← this, iso.hom_inv_id],
    refl, },
  refl,
end

-- Any better notational suggestions?
notation X`⟦`n`⟧`:20 := (shift_functor _ n).obj X
notation f`⟦`n`⟧'`:80 := (shift_functor _ n).map f

variable (C)

variables [has_shift C A]

local attribute [reducible] endofunctor_monoidal_category discrete.add_monoidal

lemma shift_functor_add'_zero_add (a : A) :
  shift_functor_add' C 0 a a (zero_add a) = (functor.left_unitor _).symm ≪≫
    iso_whisker_right (shift_functor_zero C A).symm (shift_functor C a) :=
begin
  ext X,
  dsimp [shift_functor_add'],
  erw [obj_ε_app],
  simpa [eq_to_hom_map],
end

lemma shift_functor_add'_add_zero (a : A) :
  shift_functor_add' C a 0 a (add_zero a) = (functor.right_unitor _).symm ≪≫
    iso_whisker_left (shift_functor C a) (shift_functor_zero C A).symm :=
begin
  ext X,
  dsimp [shift_functor_add'],
  erw [ε_app_obj],
  simpa [eq_to_hom_map],
end

lemma shift_functor_add'_assoc (a₁ a₂ a₃ a₁₂ a₂₃ a₁₂₃ : A)
  (h₁₂ : a₁ + a₂ = a₁₂) (h₂₃ : a₂ + a₃ = a₂₃) (h₁₂₃ : a₁ + a₂ + a₃ = a₁₂₃) :
  shift_functor_add' C a₁₂ a₃ a₁₂₃ (by rw [← h₁₂, h₁₂₃]) ≪≫
    iso_whisker_right (shift_functor_add' C a₁ a₂ a₁₂ h₁₂) _ ≪≫ functor.associator _ _ _  =
  shift_functor_add' C a₁ a₂₃ a₁₂₃ (by rw [← h₂₃, ← add_assoc, h₁₂₃]) ≪≫
    iso_whisker_left _ (shift_functor_add' C a₂ a₃ a₂₃ h₂₃) :=
begin
  substs h₁₂ h₂₃ h₁₂₃,
  ext X,
  dsimp,
  simp only [shift_functor_add'_eq_shift_functor_add, category.comp_id],
  dsimp [shift_functor_add', shift_functor_add, shift_functor],
  simp [obj_μ_inv_app, eq_to_hom_map],
end

lemma shift_functor_add_assoc (a₁ a₂ a₃ : A) :
  shift_functor_add C (a₁ + a₂) a₃ ≪≫
    iso_whisker_right (shift_functor_add C a₁ a₂) _ ≪≫ functor.associator _ _ _  =
  shift_functor_add' C a₁ (a₂ + a₃) _ (add_assoc a₁ a₂ a₃).symm ≪≫
    iso_whisker_left _ (shift_functor_add C a₂ a₃) :=
begin
  ext X,
  simpa [shift_functor_add'_eq_shift_functor_add]
    using nat_trans.congr_app (congr_arg iso.hom
      (shift_functor_add'_assoc C a₁ a₂ a₃ _ _ _ rfl rfl rfl)) X,
end

variable {C}

lemma shift_functor_add'_zero_add_hom_app (a : A) (X : C) :
  (shift_functor_add' C 0 a a (zero_add a)).hom.app X =
    ((shift_functor_zero C A).inv.app X)⟦a⟧' :=
by simpa using nat_trans.congr_app (congr_arg iso.hom (shift_functor_add'_zero_add C a)) X

lemma shift_functor_add_zero_add_hom_app (a : A) (X : C) :
  (shift_functor_add C 0 a).hom.app X =
    eq_to_hom (by dsimp; rw [zero_add]) ≫ ((shift_functor_zero C A).inv.app X)⟦a⟧' :=
begin
  erw [← shift_functor_add'_zero_add_hom_app],
  dsimp [shift_functor_add'],
  simp,
end

lemma shift_functor_add'_zero_add_inv_app (a : A) (X : C) :
  (shift_functor_add' C 0 a a (zero_add a)).inv.app X =
    ((shift_functor_zero C A).hom.app X)⟦a⟧' :=
begin
  have := nat_trans.congr_app (congr_arg iso.inv (shift_functor_add'_zero_add C a)) X,
  simp only [iso.trans_inv, iso_whisker_right_inv, iso.symm_inv, nat_trans.comp_app,
    whisker_right_app, functor.left_unitor_hom_app] at this,
  dsimp at this,
  simpa only [category.comp_id] using this,
end

lemma shift_functor_add_zero_add_inv_app (a : A) (X : C) :
  (shift_functor_add C 0 a).inv.app X =
    ((shift_functor_zero C A).hom.app X)⟦a⟧' ≫ eq_to_hom (by dsimp; rw [zero_add]) :=
begin
  erw [← shift_functor_add'_zero_add_inv_app],
  dsimp [shift_functor_add'],
  simp,
end

lemma shift_functor_add'_add_zero_hom_app (a : A) (X : C):
  (shift_functor_add' C a 0 a (add_zero a)).hom.app X =
    (shift_functor_zero C A).inv.app (X⟦a⟧) :=
by simpa using nat_trans.congr_app (congr_arg iso.hom (shift_functor_add'_add_zero C a)) X

lemma shift_functor_add_add_zero_hom_app (a : A) (X : C):
  (shift_functor_add C a 0).hom.app X =
    eq_to_hom (by dsimp; rw [add_zero]) ≫ (shift_functor_zero C A).inv.app (X⟦a⟧) :=
begin
  rw [← shift_functor_add'_add_zero_hom_app],
  dsimp [shift_functor_add'],
  simp,
end

lemma shift_functor_add'_add_zero_inv_app (a : A) (X : C):
  (shift_functor_add' C a 0 a (add_zero a)).inv.app X =
    (shift_functor_zero C A).hom.app (X⟦a⟧) :=
begin
  have := nat_trans.congr_app (congr_arg iso.inv (shift_functor_add'_add_zero C a)) X,
  simp only [iso.trans_inv, iso_whisker_left_inv, iso.symm_inv, nat_trans.comp_app,
    whisker_left_app, functor.right_unitor_hom_app] at this,
  dsimp at this,
  simpa only [category.comp_id] using this,
end

@[reassoc]
lemma shift_functor_add'_assoc_hom_app (a₁ a₂ a₃ a₁₂ a₂₃ a₁₂₃ : A)
  (h₁₂ : a₁ + a₂ = a₁₂) (h₂₃ : a₂ + a₃ = a₂₃) (h₁₂₃ : a₁ + a₂ + a₃ = a₁₂₃) (X : C) :
  (shift_functor_add' C a₁₂ a₃ a₁₂₃ (by rw [← h₁₂, h₁₂₃])).hom.app X ≫
    ((shift_functor_add' C a₁ a₂ a₁₂ h₁₂).hom.app X)⟦a₃⟧' =
  (shift_functor_add' C a₁ a₂₃ a₁₂₃ (by rw [← h₂₃, ← add_assoc, h₁₂₃])).hom.app X ≫
    (shift_functor_add' C a₂ a₃ a₂₃ h₂₃).hom.app (X⟦a₁⟧) :=
by simpa using nat_trans.congr_app (congr_arg iso.hom
  (shift_functor_add'_assoc C _ _ _ _ _ _ h₁₂ h₂₃ h₁₂₃)) X

@[reassoc]
lemma shift_functor_add'_assoc_inv_app (a₁ a₂ a₃ a₁₂ a₂₃ a₁₂₃ : A)
  (h₁₂ : a₁ + a₂ = a₁₂) (h₂₃ : a₂ + a₃ = a₂₃) (h₁₂₃ : a₁ + a₂ + a₃ = a₁₂₃) (X : C) :
  ((shift_functor_add' C a₁ a₂ a₁₂ h₁₂).inv.app X)⟦a₃⟧' ≫
    (shift_functor_add' C a₁₂ a₃ a₁₂₃ (by rw [← h₁₂, h₁₂₃])).inv.app X =
  (shift_functor_add' C a₂ a₃ a₂₃ h₂₃).inv.app (X⟦a₁⟧) ≫
    (shift_functor_add' C a₁ a₂₃ a₁₂₃ (by rw [← h₂₃, ← add_assoc, h₁₂₃])).inv.app X :=
by simpa using nat_trans.congr_app (congr_arg iso.inv
  (shift_functor_add'_assoc C _ _ _ _ _ _ h₁₂ h₂₃ h₁₂₃)) X

@[reassoc]
lemma shift_functor_add_assoc_hom_app (a₁ a₂ a₃ : A) (X : C) :
  (shift_functor_add C (a₁ + a₂) a₃).hom.app X ≫
    ((shift_functor_add C a₁ a₂).hom.app X)⟦a₃⟧' =
  (shift_functor_add' C a₁ (a₂ + a₃) (a₁ + a₂ + a₃) (add_assoc _ _ _).symm).hom.app X ≫
    (shift_functor_add C a₂ a₃).hom.app (X⟦a₁⟧) :=
by simpa using nat_trans.congr_app (congr_arg iso.hom
  (shift_functor_add_assoc C a₁ a₂ a₃)) X

@[reassoc]
lemma shift_functor_add_assoc_inv_app (a₁ a₂ a₃ : A) (X : C) :
  ((shift_functor_add C a₁ a₂).inv.app X)⟦a₃⟧' ≫
    (shift_functor_add C (a₁ + a₂) a₃).inv.app X =
  (shift_functor_add C a₂ a₃).inv.app (X⟦a₁⟧) ≫
    (shift_functor_add' C a₁ (a₂ + a₃) (a₁ + a₂ + a₃) (add_assoc _ _ _).symm).inv.app X :=
by simpa using nat_trans.congr_app (congr_arg iso.inv
  (shift_functor_add_assoc C a₁ a₂ a₃)) X

end defs

section add_monoid

variables {C A} [add_monoid A] [has_shift C A] (X Y : C) (f : X ⟶ Y)

@[simp] lemma has_shift.shift_obj_obj (n : A) (X : C) : (has_shift.shift.obj ⟨n⟩).obj X = X⟦n⟧ :=
rfl

/-- Shifting by `i + j` is the same as shifting by `i` and then shifting by `j`. -/
abbreviation shift_add (i j : A) : X⟦i + j⟧ ≅ X⟦i⟧⟦j⟧ := (shift_functor_add C i j).app _

lemma shift_shift' (i j : A) :
  f⟦i⟧'⟦j⟧' = (shift_add X i j).inv ≫ f⟦i + j⟧' ≫ (shift_add Y i j).hom :=
by { symmetry, apply nat_iso.naturality_1 }

variables (A)

/-- Shifting by zero is the identity functor. -/
abbreviation shift_zero  :
  X⟦0⟧ ≅ X := (shift_functor_zero C A).app _

lemma shift_zero' :
  f⟦(0 : A)⟧' = (shift_zero A X).hom ≫ f ≫ (shift_zero A Y).inv :=
by { symmetry, apply nat_iso.naturality_2 }

variables (C) {A}

/-- When `i + j = 0`, shifting by `i` and by `j` gives the identity functor -/
def shift_functor_comp_iso_id (i j : A) (h : i + j = 0) :
  shift_functor C i ⋙ shift_functor C j ≅ 𝟭 C :=
(shift_functor_add' C i j 0 h).symm ≪≫ shift_functor_zero C A

end add_monoid

section add_group

variables (C) {A} [add_group A] [has_shift C A]

/-- shifting by `i` and shifting by `j` forms an equivalence when `i + j = 0`. -/
@[simps]
def shift_equiv' (i j : A) (h : i + j = 0) : C ≌ C :=
{ functor := shift_functor C i,
  inverse := shift_functor C j,
  unit_iso := (shift_functor_comp_iso_id C i j h).symm,
  counit_iso := (shift_functor_comp_iso_id C j i
    (by rw [← add_left_inj j, add_assoc, h, zero_add, add_zero])),
  functor_unit_iso_comp' := λ X, begin
    let E := equiv_of_tensor_iso_unit (shift_monoidal_functor C A) ⟨i⟩ ⟨j⟩
      (eq_to_iso (by ext; exact h))
      (eq_to_iso (by ext; dsimp; rw [← add_left_inj j, add_assoc, h, zero_add, add_zero]))
      (subsingleton.elim _ _),
    convert equivalence.functor_unit_iso_comp E X,
    all_goals
    { ext X,
      dsimp [shift_functor_comp_iso_id, unit_of_tensor_iso_unit, shift_functor_add'],
      simpa only [eq_to_hom_map, category.assoc], },
  end }

/-- shifting by `n` and shifting by `-n` forms an equivalence. -/
abbreviation shift_equiv (i : A) : C ≌ C := shift_equiv' C i (-i) (add_neg_self i)

variables (X Y : C) (f : X ⟶ Y)

/-- Shifting by `i` is an equivalence. -/
instance (i : A) : is_equivalence (shift_functor C i) :=
is_equivalence.of_equivalence (shift_equiv C i)

@[simp] lemma shift_functor_inv (i : A) :
  (shift_functor C i).inv = shift_functor C (-i) :=
rfl

section

variables (C)

/-- Shifting by `n` is an essentially surjective functor. -/
instance shift_functor_ess_surj (i : A) : ess_surj (shift_functor C i) :=
  equivalence.ess_surj_of_equivalence _

end

variables {C}

/-- Shifting by `i` and then shifting by `-i` is the identity. -/
abbreviation shift_shift_neg (i : A) : X⟦i⟧⟦-i⟧ ≅ X :=
(shift_equiv C i).unit_iso.symm.app _

/-- Shifting by `-i` and then shifting by `i` is the identity. -/
abbreviation shift_neg_shift (i : A) : X⟦-i⟧⟦i⟧ ≅ X :=
(shift_equiv C i).counit_iso.app _

variables {X Y}

lemma shift_shift_neg' (i : A) :
  f⟦i⟧'⟦-i⟧' = (shift_functor_comp_iso_id C i (-i) (add_neg_self i)).hom.app X ≫
    f ≫ (shift_functor_comp_iso_id C i (-i) (add_neg_self i)).inv.app Y :=
(nat_iso.naturality_2 (shift_functor_comp_iso_id C i (-i) (add_neg_self i)) f).symm

lemma shift_neg_shift' (i : A) :
  f⟦-i⟧'⟦i⟧' = (shift_functor_comp_iso_id C (-i) i (neg_add_self i)).hom.app X ≫ f ≫
    (shift_functor_comp_iso_id C (-i) i (neg_add_self i)).inv.app Y :=
(nat_iso.naturality_2 (shift_functor_comp_iso_id C (-i) i (neg_add_self i)) f).symm

lemma shift_equiv_triangle (n : A) (X : C) :
  (shift_shift_neg X n).inv⟦n⟧' ≫ (shift_neg_shift (X⟦n⟧) n).hom = 𝟙 (X⟦n⟧) :=
(shift_equiv C n).functor_unit_iso_comp X

section

lemma shift_shift_functor_comp_iso_id_hom_app (n m : A) (h : n + m = 0) (X : C) :
  ((shift_functor_comp_iso_id C n m h).hom.app X)⟦n⟧' =
    (shift_functor_comp_iso_id C m n
      (by rw [← neg_eq_of_add_eq_zero_left h, add_right_neg])).hom.app (X⟦n⟧) :=
begin
  dsimp [shift_functor_comp_iso_id],
  simpa only [functor.map_comp, ← shift_functor_add'_zero_add_inv_app n X,
    ← shift_functor_add'_add_zero_inv_app n X ]
    using shift_functor_add'_assoc_inv_app n m n 0 0 n h
      (by rw [← neg_eq_of_add_eq_zero_left h, add_right_neg]) (by rw [h, zero_add]) X,
end

lemma shift_shift_functor_comp_iso_id_inv_app (n m : A) (h : n + m = 0) (X : C) :
  ((shift_functor_comp_iso_id C n m h).inv.app X)⟦n⟧' =
    ((shift_functor_comp_iso_id C m n
      (by rw [← neg_eq_of_add_eq_zero_left h, add_right_neg])).inv.app (X⟦n⟧)) :=
begin
  rw [← cancel_mono (((shift_functor_comp_iso_id C n m h).hom.app X)⟦n⟧'),
    ← functor.map_comp, iso.inv_hom_id_app, functor.map_id,
    shift_shift_functor_comp_iso_id_hom_app, iso.inv_hom_id_app],
  refl,
end

lemma shift_shift_functor_comp_iso_id_add_neg_self_hom_app (n : A) (X : C) :
  ((shift_functor_comp_iso_id C n (-n) (add_neg_self n)).hom.app X)⟦n⟧' =
    (shift_functor_comp_iso_id C (-n) n (neg_add_self n)).hom.app (X⟦n⟧) :=
by apply shift_shift_functor_comp_iso_id_hom_app

lemma shift_shift_functor_comp_iso_id_add_neg_self_inv_app (n : A) (X : C) :
  ((shift_functor_comp_iso_id C n (-n) (add_neg_self n)).inv.app X)⟦n⟧' =
    (shift_functor_comp_iso_id C (-n) n (neg_add_self n)).inv.app (X⟦n⟧) :=
by apply shift_shift_functor_comp_iso_id_inv_app

lemma shift_shift_functor_comp_iso_id_neg_add_self_hom_app (n : A) (X : C) :
  ((shift_functor_comp_iso_id C (-n) n (neg_add_self n)).hom.app X)⟦-n⟧' =
    (shift_functor_comp_iso_id C n (-n) (add_neg_self n)).hom.app (X⟦-n⟧) :=
by apply shift_shift_functor_comp_iso_id_hom_app

lemma shift_shift_functor_comp_iso_id_neg_add_self_inv_app (n : A) (X : C) :
  ((shift_functor_comp_iso_id C (-n) n (neg_add_self n)).inv.app X)⟦-n⟧' =
    (shift_functor_comp_iso_id C n (-n) (add_neg_self n)).inv.app (X⟦-n⟧) :=
by apply shift_shift_functor_comp_iso_id_inv_app

end

variables {A C}

open category_theory.limits

variables [has_zero_morphisms C]

lemma shift_zero_eq_zero (X Y : C) (n : A) : (0 : X ⟶ Y)⟦n⟧' = (0 : X⟦n⟧ ⟶ Y⟦n⟧) :=
category_theory.functor.map_zero _ _ _

end add_group

section add_comm_monoid

variables (C) {A} [add_comm_monoid A] [has_shift C A]

/-- When shifts are indexed by an additive commutative monoid, then shifts commute. -/
def shift_functor_comm (i j : A) :
  shift_functor C i ⋙ shift_functor C j ≅
    shift_functor C j ⋙ shift_functor C i :=
(shift_functor_add C i j).symm ≪≫ shift_functor_add' C j i (i + j) (add_comm j i)

lemma shift_functor_comm_eq (i j k : A) (h : i + j = k):
  shift_functor_comm C i j = (shift_functor_add' C i j k h).symm ≪≫
    shift_functor_add' C j i k (by rw [add_comm j i, h]) :=
begin
  subst h,
  rw [shift_functor_add'_eq_shift_functor_add],
  refl,
end

lemma shift_functor_comm_symm (i j : A) :
  (shift_functor_comm C i j).symm = shift_functor_comm C j i :=
begin
  ext1,
  dsimp,
  simpa only [shift_functor_comm_eq C i j (i + j) rfl,
    shift_functor_comm_eq C j i (i + j) (add_comm j i)],
end

variables {C} (X Y : C) (f : X ⟶ Y)

/-- When shifts are indexed by an additive commutative monoid, then shifts commute. -/
abbreviation shift_comm (i j : A) : X⟦i⟧⟦j⟧ ≅ X⟦j⟧⟦i⟧ :=
  (shift_functor_comm C i j).app X

@[simp] lemma shift_comm_symm (i j : A) : (shift_comm X i j).symm = shift_comm X j i :=
begin
  ext1,
  exact nat_trans.congr_app (congr_arg iso.hom (shift_functor_comm_symm C i j)) X,
end

variables {X Y}

/-- When shifts are indexed by an additive commutative monoid, then shifts commute. -/
lemma shift_comm' (i j : A) :
  f⟦i⟧'⟦j⟧' = (shift_comm _ _ _).hom ≫ f⟦j⟧'⟦i⟧' ≫ (shift_comm _ _ _).hom :=
begin
  erw [← shift_comm_symm Y i j, ← ((shift_functor_comm C i j).hom.naturality_assoc f),
    iso.hom_inv_id_app, category.comp_id],
  refl,
end

@[reassoc] lemma shift_comm_hom_comp (i j : A) :
  (shift_comm X i j).hom ≫ f⟦j⟧'⟦i⟧' = f⟦i⟧'⟦j⟧' ≫ (shift_comm Y i j).hom :=
by rw [shift_comm', ← shift_comm_symm, iso.symm_hom, iso.inv_hom_id_assoc]

lemma shift_functor_zero_hom_app_shift (n : A) :
  (shift_functor_zero C A).hom.app (X⟦n⟧) =
    (shift_functor_comm C n 0).hom.app X ≫ ((shift_functor_zero C A).hom.app X)⟦n⟧' :=
begin
  rw [← shift_functor_add'_zero_add_inv_app n X, shift_functor_comm_eq C n 0 n (add_zero n)],
  dsimp,
  rw [category.assoc, iso.hom_inv_id_app, category.comp_id, shift_functor_add'_add_zero_inv_app],
end

lemma shift_functor_zero_inv_app_shift (n : A) :
  (shift_functor_zero C A).inv.app (X⟦n⟧) =
  ((shift_functor_zero C A).inv.app X)⟦n⟧' ≫ (shift_functor_comm C n 0).inv.app X :=
begin
  rw [← cancel_mono ((shift_functor_zero C A).hom.app (X⟦n⟧)), category.assoc, iso.inv_hom_id_app,
    shift_functor_zero_hom_app_shift, iso.inv_hom_id_app_assoc, ← functor.map_comp,
    iso.inv_hom_id_app],
  dsimp,
  rw [functor.map_id],
end

@[reassoc]
lemma shift_functor_comm_hom_app_comp_shift_shift_functor_add_hom_app (m₁ m₂ m₃ : A) (X : C) :
  (shift_functor_comm C m₁ (m₂ + m₃)).hom.app X ≫
    ((shift_functor_add C m₂ m₃).hom.app X)⟦m₁⟧' =
  (shift_functor_add C m₂ m₃).hom.app (X⟦m₁⟧) ≫
    ((shift_functor_comm C m₁ m₂).hom.app X)⟦m₃⟧' ≫
    (shift_functor_comm C m₁ m₃).hom.app (X⟦m₂⟧) :=
begin
  simp only [← cancel_mono ((shift_functor_comm C m₁ m₃).inv.app (X⟦m₂⟧)),
    ← cancel_mono (((shift_functor_comm C m₁ m₂).inv.app X)⟦m₃⟧'),
    category.assoc, iso.hom_inv_id_app],
  dsimp,
  simp only [category.id_comp, ← functor.map_comp, iso.hom_inv_id_app],
  dsimp,
  simp only [functor.map_id, category.comp_id,
    shift_functor_comm_eq C _ _ _ rfl, ← shift_functor_add'_eq_shift_functor_add],
  dsimp,
  simp only [category.assoc, iso.hom_inv_id_app_assoc, iso.inv_hom_id_app_assoc,
    ← functor.map_comp,
    shift_functor_add'_assoc_hom_app_assoc m₂ m₃ m₁ (m₂ + m₃) (m₁ + m₃) (m₁ + (m₂ + m₃)) rfl
      (add_comm m₃ m₁) (add_comm _ m₁) X,
    ← shift_functor_add'_assoc_hom_app_assoc m₂ m₁ m₃ (m₁ + m₂) (m₁ + m₃)
      (m₁ + (m₂ + m₃)) (add_comm _ _) rfl (by rw [add_comm m₂ m₁, add_assoc]) X,
    shift_functor_add'_assoc_hom_app m₁ m₂ m₃
      (m₁ + m₂) (m₂ + m₃) (m₁ + (m₂ + m₃)) rfl rfl (add_assoc _ _ _) X],
end

end add_comm_monoid

variables {C A} {D : Type*} [category D] [add_monoid A] [has_shift D A]
variables (F : C ⥤ D) [full F] [faithful F]

section

variables (s : A → C ⥤ C) (i : ∀ i, s i ⋙ F ≅ F ⋙ shift_functor D i)

include F s i

/-- auxiliary definition for `has_shift_of_fully_faithful` -/
def has_shift_of_fully_faithful_zero : s 0 ≅ 𝟭 C :=
nat_iso_of_comp_fully_faithful F ((i 0) ≪≫ iso_whisker_left F (shift_functor_zero D A) ≪≫
  functor.right_unitor _ ≪≫ (functor.left_unitor _).symm)

@[simp]
lemma map_has_shift_of_fully_faithful_zero_hom_app (X : C) :
  F.map ((has_shift_of_fully_faithful_zero F s i).hom.app X) =
    (i 0).hom.app X ≫ (shift_functor_zero D A).hom.app (F.obj X) :=
by { dsimp [has_shift_of_fully_faithful_zero], simp, }

@[simp]
lemma map_has_shift_of_fully_faithful_zero_inv_app (X : C) :
F.map ((has_shift_of_fully_faithful_zero F s i).inv.app X) =
  (shift_functor_zero D A).inv.app (F.obj X) ≫ (i 0).inv.app X :=
by { dsimp [has_shift_of_fully_faithful_zero], simp, }

/-- auxiliary definition for `has_shift_of_fully_faithful` -/
def has_shift_of_fully_faithful_add (a b : A) : s (a + b) ≅ s a ⋙ s b :=
nat_iso_of_comp_fully_faithful F (i (a + b) ≪≫
  iso_whisker_left _ (shift_functor_add D a b) ≪≫
  (functor.associator _ _ _).symm ≪≫ (iso_whisker_right (i a).symm _) ≪≫
  functor.associator _ _ _ ≪≫ (iso_whisker_left _ (i b).symm) ≪≫
  (functor.associator _ _ _).symm)

@[simp]
lemma map_has_shift_of_fully_faithful_add_hom_app (a b : A) (X : C) :
  F.map ((has_shift_of_fully_faithful_add F s i a b).hom.app X) =
    (i (a + b)).hom.app X ≫ (shift_functor_add D a b).hom.app (F.obj X) ≫
      ((i a).inv.app X)⟦b⟧' ≫ (i b).inv.app ((s a).obj X) :=
by { dsimp [has_shift_of_fully_faithful_add], simp, }

@[simp]
lemma map_has_shift_of_fully_faithful_add_inv_app (a b : A) (X : C) :
  F.map ((has_shift_of_fully_faithful_add F s i a b).inv.app X) =
    (i b).hom.app ((s a).obj X) ≫ ((i a).hom.app X)⟦b⟧' ≫
      (shift_functor_add D a b).inv.app (F.obj X) ≫ (i (a + b)).inv.app X :=
by { dsimp [has_shift_of_fully_faithful_add], simp, }

/-- Given a family of endomorphisms of `C` which are interwined by a fully faithful `F : C ⥤ D`
with shift functors on `D`, we can promote that family to shift functors on `C`. -/
def has_shift_of_fully_faithful : has_shift C A := has_shift_mk C A
  { F := s,
    zero := has_shift_of_fully_faithful_zero F s i,
    add := has_shift_of_fully_faithful_add F s i,
    assoc_hom_app := λ m₁ m₂ m₃ X, F.map_injective begin
      rw [← cancel_mono ((i m₃).hom.app ((s m₂).obj ((s m₁).obj X)))],
      simp only [functor.map_comp, map_has_shift_of_fully_faithful_add_hom_app, category.assoc,
        iso.inv_hom_id_app_assoc, iso.inv_hom_id_app],
      erw [(i m₃).hom.naturality],
      have := dcongr_arg (λ a, (i a).hom.app X) (add_assoc m₁ m₂ m₃),
      dsimp at this,
      dsimp,
      rw [iso.inv_hom_id_app_assoc, map_has_shift_of_fully_faithful_add_hom_app, this,
        eq_to_hom_map, category.comp_id, ← functor.map_comp, category.assoc,
        iso.inv_hom_id_app_assoc, functor.map_comp, functor.map_comp,
        shift_functor_add_assoc_hom_app_assoc m₁ m₂ m₃ (F.obj X)],
      dsimp [shift_functor_add'],
      simp only [eq_to_hom_app, category.assoc, eq_to_hom_trans_assoc, eq_to_hom_refl,
        category.id_comp, nat_trans.naturality_assoc, functor.comp_map],
    end,
    zero_add_hom_app := λ n X, F.map_injective begin
      have this := dcongr_arg (λ a, (i a).hom.app X) (zero_add n),
      dsimp at this,
      rw [← cancel_mono ((i n).hom.app ((s 0).obj X))],
      simp only [this, map_has_shift_of_fully_faithful_add_hom_app,
        shift_functor_add_zero_add_hom_app, eq_to_hom_map, category.assoc,
        eq_to_hom_trans_assoc, eq_to_hom_refl, category.id_comp, iso.inv_hom_id_app,
        functor.map_comp],
      erw [(i n).hom.naturality],
      dsimp,
      simp,
    end,
    add_zero_hom_app := λ n X, F.map_injective begin
      have := dcongr_arg (λ a, (i a).hom.app X) (add_zero n),
      dsimp at this,
      simpa [this, ← nat_trans.naturality_assoc, eq_to_hom_map,
        shift_functor_add_add_zero_hom_app],
    end, }

end

end category_theory


def get_neighbs (p : point) (g : grid_2D) : list point :=
  let idxs : list (ℤ × ℤ) := get_idxs p g.c in
  let cells : list (option (list point)) := idxs.map (λ i, g.data.find i) in
  let cells' : list (list point) := cells.map lift_option_list in
  let flat_cells : list point := cells'.join in
  flat_cells.filter (λ q, q ≠ p)
def point := ℤ × ℤ
instance : has_repr point :=
  ⟨λ p, "(" ++ (repr p.1) ++ ", " ++ (repr p.2) ++ ")"⟩
instance : has_add point :=
  ⟨λ p₁ p₂, (p₁.1 + p₂.1, p₁.2 + p₂.2)⟩
instance : has_sub point :=
  ⟨λ p₁ p₂, (p₁.1 - p₂.1, p₁.2 - p₂.2)⟩
instance : has_neg point :=
  ⟨λ p, (-p.1, -p.2)⟩
instance : inhabited point :=
  ⟨(0, 0)⟩
def point_norm (p : point) : ℤ :=
  p.1 * p.1 + p.2 * p.2
notation `∥` e `∥` := point_norm e
def point_le' (xy zw : option (point × point)) : bool :=
  match (xy, zw) with
  | (none, none) := true
  | (none, some _) := false
  | (some _, none) := true
  | (some (x, y), some (z, w)) := ∥ x - y ∥ ≤ ∥ z - w ∥
  end
def point_lt' (xy zw : option (point × point)) : bool :=
  match (xy, zw) with
  | (none, none) := false
  | (none, some _) := false
  | (some _, none) := true
  | (some (x, y), some (z, w)) := ∥ x - y ∥ < ∥ z - w ∥
  end
def get_hypercube (bound : ℕ) : list (ℤ × ℤ) :=
  (do
    j <- list.range (2 * bound + 1),
    return (do
      i <- list.range (2 * bound + 1),
      return (-(bound : ℤ) + i, -(bound : ℤ) + j))).join
def get_idxs (p : point) (c : ℕ⁺) :=
  let grid_idx := get_grid_idx p in
  let bound := nat.sqrt c + 1 in
  let hypercube := get_hypercube bound in
  hypercube.map (λ offs, grid_idx + offs)

def lift_option_list {α} : option (list α) → list α
| none := []
| (some l) := l
def get_grid_idx (p : point) : grid_idx :=
  (p.1, p.2)
def grid_points (c : ℕ⁺) : list point → grid_2D
| [] := ⟨mk_hash_map point_hash, c, []⟩
| (x :: xs) :=
    let g := grid_points xs in
    let grid_idx := get_grid_idx x in
    let l := match g.data.find grid_idx with
      | none := []
      | some l' := l'
      end
    in
    ⟨g.data.insert grid_idx (x :: l), c, x :: g.ps⟩
structure grid_2D :=
  (data : hash_map grid_idx (λ _, list point))
  (c : ℕ⁺)
  (ps : list point)
def grid_idx := ℤ × ℤ
def find_closest_pair
  (c : ℕ⁺)
  (points : list point)
  : option (point × point) :=
  let g := grid_points c points in
  aux g points >>= (
    λ pq : point × point,
      if ∥ pq.1 - pq.2 ∥ > c
      then none
      else some pq
  )
def aux (g : grid_2D) : list point → option (point × point)
| [] := none
| (p :: ps) :=
    let rec_res := aux ps in
    let curr_res := mdp_with p g in
    -- TODO figure out why we can't get decidable to work on `point_le`.
    if point_lt' curr_res rec_res then curr_res else rec_res
lemma min_dist_pair_in_ball :
  ∀ (p q : point) (g : grid_2D),
    (mdp_with p g = some (p, q)) →
    pt_in_ball p q g.c g.ps := begin
  sorry
end
def mdp_with (p : point) (g : grid_2D) : option (point × point) :=
  let ps := get_neighbs p g in
  min_dist_pair p ps
def min_dist_pair (p : point) : list point → option (point × point)
| [] := none
| (q :: ps') :=
    let pq' := min_dist_pair ps' in
    if point_lt' (p, q) pq' then some (p, q) else pq'
def point_hash : point → ℕ
| (a, b) := a.nat_abs + b.nat_abs
structure pos_nat :=
  (val : ℕ)
  (val_nonzero : val > 0)
notation `ℕ⁺` := pos_nat
instance : has_coe ℕ⁺ ℕ :=
  ⟨λ pos_n, pos_n.val⟩


import algebra.group_with_zero.basic
import algebra.group.hom

-- Deserves its place in matlib, as `monoid_with_zero_hom.map_inv`
theorem monoid_with_zero_hom.map_inv {G₁ G₂: Type} [group_with_zero G₁] [group_with_zero G₂]
  (φ: monoid_with_zero_hom G₁ G₂) (a: G₁) (a_ne_zero: a ≠ 0): φ a⁻¹ = (φ a)⁻¹ :=
begin
  apply eq_inv_of_mul_left_eq_one,
  rw ← monoid_with_zero_hom.map_mul,
  rw inv_mul_cancel a_ne_zero,
  rw monoid_with_zero_hom.map_one,
end