/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import group_theory.perm.support
import data.fintype.basic
import group_theory.order_of_element
import tactic.norm_swap
import data.finset.sort

/-!
# Sign of a permutation

The main definition of this file is `equiv.perm.sign`, associating a `units ℤ` sign with a
permutation.

This file also contains miscellaneous lemmas about `equiv.perm` and `equiv.swap`, building on top
of those in `data/equiv/basic` and other files in `group_theory/perm/*`.

-/

universes u v
open equiv function fintype finset
open_locale big_operators
variables {α : Type u} {β : Type v}

namespace equiv.perm

/--
`mod_swap i j` contains permutations up to swapping `i` and `j`.

We use this to partition permutations in `matrix.det_zero_of_row_eq`, such that each partition
sums up to `0`.
-/
def mod_swap [decidable_eq α] (i j : α) : setoid (perm α) :=
⟨λ σ τ, σ = τ ∨ σ = swap i j * τ,
 λ σ, or.inl (refl σ),
 λ σ τ h, or.cases_on h (λ h, or.inl h.symm) (λ h, or.inr (by rw [h, swap_mul_self_mul])),
 λ σ τ υ hστ hτυ, by cases hστ; cases hτυ; try {rw [hστ, hτυ, swap_mul_self_mul]}; finish⟩

instance {α : Type*} [fintype α] [decidable_eq α] (i j : α) : decidable_rel (mod_swap i j).r :=
λ σ τ, or.decidable

lemma perm_inv_on_of_perm_on_finset {s : finset α} {f : perm α}
  (h : ∀ x ∈ s, f x ∈ s) {y : α} (hy : y ∈ s) : f⁻¹ y ∈ s :=
begin
  have h0 : ∀ y ∈ s, ∃ x (hx : x ∈ s), y = (λ i (hi : i ∈ s), f i) x hx :=
    finset.surj_on_of_inj_on_of_card_le (λ x hx, (λ i hi, f i) x hx)
    (λ a ha, h a ha) (λ a₁ a₂ ha₁ ha₂ heq, (equiv.apply_eq_iff_eq f).mp heq) rfl.ge,
  obtain ⟨y2, hy2, heq⟩ := h0 y hy,
  convert hy2,
  rw heq,
  simp only [inv_apply_self]
end

lemma perm_inv_maps_to_of_maps_to (f : perm α) {s : set α} [fintype s]
  (h : set.maps_to f s s) : set.maps_to (f⁻¹ : _) s s :=
λ x hx, set.mem_to_finset.mp $
  perm_inv_on_of_perm_on_finset
   (λ a ha, set.mem_to_finset.mpr (h (set.mem_to_finset.mp ha)))
   (set.mem_to_finset.mpr hx)

@[simp] lemma perm_inv_maps_to_iff_maps_to {f : perm α} {s : set α} [fintype s] :
  set.maps_to (f⁻¹ : _) s s ↔ set.maps_to f s s :=
⟨perm_inv_maps_to_of_maps_to f⁻¹, perm_inv_maps_to_of_maps_to f⟩

lemma perm_inv_on_of_perm_on_fintype {f : perm α} {p : α → Prop} [fintype {x // p x}]
  (h : ∀ x, p x → p (f x)) {x : α} (hx : p x) : p (f⁻¹ x) :=
begin
  letI : fintype ↥(show set α, from p) := ‹fintype {x // p x}›,
  exact perm_inv_maps_to_of_maps_to f h hx
end

/-- If the permutation `f` maps `{x // p x}` into itself, then this returns the permutation
  on `{x // p x}` induced by `f`. Note that the `h` hypothesis is weaker than for
  `equiv.perm.subtype_perm`. -/
abbreviation subtype_perm_of_fintype (f : perm α) {p : α → Prop} [fintype {x // p x}]
  (h : ∀ x, p x → p (f x)) : perm {x // p x} :=
f.subtype_perm (λ x, ⟨h x, λ h₂, f.inv_apply_self x ▸ perm_inv_on_of_perm_on_fintype h h₂⟩)

@[simp] lemma subtype_perm_of_fintype_apply (f : perm α) {p : α → Prop} [fintype {x // p x}]
  (h : ∀ x, p x → p (f x)) (x : {x // p x}) : subtype_perm_of_fintype f h x = ⟨f x, h x x.2⟩ := rfl

@[simp] lemma subtype_perm_of_fintype_one (p : α → Prop) [fintype {x // p x}]
  (h : ∀ x, p x → p ((1 : perm α) x)) : @subtype_perm_of_fintype α 1 p _ h = 1 :=
equiv.ext $ λ ⟨_, _⟩, rfl

lemma perm_maps_to_inl_iff_maps_to_inr {m n : Type*} [fintype m] [fintype n]
  (σ : equiv.perm (m ⊕ n)) :
  set.maps_to σ (set.range sum.inl) (set.range sum.inl) ↔
  set.maps_to σ (set.range sum.inr) (set.range sum.inr) :=
begin
  split; id
  { intros h,
    classical,
    rw ←perm_inv_maps_to_iff_maps_to at h,
    intro x,
    cases hx : σ x with l r, },
  { rintros ⟨a, rfl⟩,
    obtain ⟨y, hy⟩ := h ⟨l, rfl⟩,
    rw [←hx, σ.inv_apply_self] at hy,
    exact absurd hy sum.inl_ne_inr},
  { rintros ⟨a, ha⟩, exact ⟨r, rfl⟩, },
  { rintros ⟨a, ha⟩, exact ⟨l, rfl⟩, },
  { rintros ⟨a, rfl⟩,
    obtain ⟨y, hy⟩ := h ⟨r, rfl⟩,
    rw [←hx, σ.inv_apply_self] at hy,
    exact absurd hy sum.inr_ne_inl},
end

lemma mem_sum_congr_hom_range_of_perm_maps_to_inl {m n : Type*} [fintype m] [fintype n]
  {σ : perm (m ⊕ n)} (h : set.maps_to σ (set.range sum.inl) (set.range sum.inl)) :
  σ ∈ (sum_congr_hom m n).range :=
begin
  classical,
  have h1 : ∀ (x : m ⊕ n), (∃ (a : m), sum.inl a = x) → (∃ (a : m), sum.inl a = σ x),
  { rintros x ⟨a, ha⟩, apply h, rw ← ha, exact ⟨a, rfl⟩ },
  have h3 : ∀ (x : m ⊕ n), (∃ (b : n), sum.inr b = x) → (∃ (b : n), sum.inr b = σ x),
  { rintros x ⟨b, hb⟩,
    apply (perm_maps_to_inl_iff_maps_to_inr σ).mp h,
    rw ← hb, exact ⟨b, rfl⟩ },
  let σ₁' := subtype_perm_of_fintype σ h1,
  let σ₂' := subtype_perm_of_fintype σ h3,
  let σ₁ := perm_congr (equiv.of_injective (@sum.inl m n) sum.inl_injective).symm σ₁',
  let σ₂ := perm_congr (equiv.of_injective (@sum.inr m n) sum.inr_injective).symm σ₂',
  rw [monoid_hom.mem_range, prod.exists],
  use [σ₁, σ₂],
  rw [perm.sum_congr_hom_apply],
  ext,
  cases x with a b,
  { rw [equiv.sum_congr_apply, sum.map_inl, perm_congr_apply, equiv.symm_symm,
        apply_of_injective_symm (@sum.inl m n)],
    erw subtype_perm_apply,
    rw [of_injective_apply, subtype.coe_mk, subtype.coe_mk] },
  { rw [equiv.sum_congr_apply, sum.map_inr, perm_congr_apply, equiv.symm_symm,
        apply_of_injective_symm (@sum.inr m n)],
    erw subtype_perm_apply,
    rw [of_injective_apply, subtype.coe_mk, subtype.coe_mk] }
end

lemma disjoint.order_of {σ τ : perm α} (hστ : disjoint σ τ) :
  order_of (σ * τ) = nat.lcm (order_of σ) (order_of τ) :=
begin
  have h : ∀ n : ℕ, (σ * τ) ^ n = 1 ↔ σ ^ n = 1 ∧ τ ^ n = 1 :=
  λ n, by rw [hστ.commute.mul_pow, disjoint.mul_eq_one_iff (hστ.pow_disjoint_pow n n)],
  exact nat.dvd_antisymm hστ.commute.order_of_mul_dvd_lcm (nat.lcm_dvd
    (order_of_dvd_of_pow_eq_one ((h (order_of (σ * τ))).mp (pow_order_of_eq_one (σ * τ))).1)
    (order_of_dvd_of_pow_eq_one ((h (order_of (σ * τ))).mp (pow_order_of_eq_one (σ * τ))).2)),
end

lemma disjoint.extend_domain {α : Type*} {p : β → Prop} [decidable_pred p]
  (f : α ≃ subtype p) {σ τ : perm α} (h : disjoint σ τ) :
  disjoint (σ.extend_domain f) (τ.extend_domain f) :=
begin
  intro b,
  by_cases pb : p b,
  { refine (h (f.symm ⟨b, pb⟩)).imp _ _;
    { intro h,
      rw [extend_domain_apply_subtype _ _ pb, h, apply_symm_apply, subtype.coe_mk] } },
  { left,
    rw [extend_domain_apply_not_subtype _ _ pb] }
end

variable [decidable_eq α]

section fintype
variable [fintype α]

lemma support_pow_coprime {σ : perm α} {n : ℕ} (h : nat.coprime n (order_of σ)) :
  (σ ^ n).support = σ.support :=
begin
  obtain ⟨m, hm⟩ := exists_pow_eq_self_of_coprime h,
  exact le_antisymm (support_pow_le σ n) (le_trans (ge_of_eq (congr_arg support hm))
    (support_pow_le (σ ^ n) m)),
end

end fintype

/-- Given a list `l : list α` and a permutation `f : perm α` such that the nonfixed points of `f`
  are in `l`, recursively factors `f` as a product of transpositions. -/
def swap_factors_aux : Π (l : list α) (f : perm α), (∀ {x}, f x ≠ x → x ∈ l) →
  {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g}
| []       := λ f h, ⟨[], equiv.ext $ λ x, by { rw [list.prod_nil],
    exact (not_not.1 (mt h (list.not_mem_nil _))).symm }, by simp⟩
| (x :: l) := λ f h,
if hfx : x = f x
then swap_factors_aux l f
  (λ y hy, list.mem_of_ne_of_mem (λ h : y = x, by simpa [h, hfx.symm] using hy) (h hy))
else let m := swap_factors_aux l (swap x (f x) * f)
      (λ y hy, have f y ≠ y ∧ y ≠ x, from ne_and_ne_of_swap_mul_apply_ne_self hy,
        list.mem_of_ne_of_mem this.2 (h this.1)) in
  ⟨swap x (f x) :: m.1,
  by rw [list.prod_cons, m.2.1, ← mul_assoc,
    mul_def (swap x (f x)), swap_swap, ← one_def, one_mul],
  λ g hg, ((list.mem_cons_iff _ _ _).1 hg).elim (λ h, ⟨x, f x, hfx, h⟩) (m.2.2 _)⟩

/-- `swap_factors` represents a permutation as a product of a list of transpositions.
The representation is non unique and depends on the linear order structure.
For types without linear order `trunc_swap_factors` can be used. -/
def swap_factors [fintype α] [linear_order α] (f : perm α) :
  {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g} :=
swap_factors_aux ((@univ α _).sort (≤)) f (λ _ _, (mem_sort _).2 (mem_univ _))

/-- This computably represents the fact that any permutation can be represented as the product of
  a list of transpositions. -/
def trunc_swap_factors [fintype α] (f : perm α) :
  trunc {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g} :=
quotient.rec_on_subsingleton (@univ α _).1
  (λ l h, trunc.mk (swap_factors_aux l f h))
  (show ∀ x, f x ≠ x → x ∈ (@univ α _).1, from λ _ _, mem_univ _)

/-- An induction principle for permutations. If `P` holds for the identity permutation, and
is preserved under composition with a non-trivial swap, then `P` holds for all permutations. -/
@[elab_as_eliminator] lemma swap_induction_on [fintype α] {P : perm α → Prop} (f : perm α) :
  P 1 → (∀ f x y, x ≠ y → P f → P (swap x y * f)) → P f :=
begin
  cases (trunc_swap_factors f).out with l hl,
  induction l with g l ih generalizing f,
  { simp only [hl.left.symm, list.prod_nil, forall_true_iff] {contextual := tt} },
  { assume h1 hmul_swap,
    rcases hl.2 g (by simp) with ⟨x, y, hxy⟩,
    rw [← hl.1, list.prod_cons, hxy.2],
    exact hmul_swap _ _ _ hxy.1
      (ih _ ⟨rfl, λ v hv, hl.2 _ (list.mem_cons_of_mem _ hv)⟩ h1 hmul_swap) }
end

lemma closure_is_swap [fintype α] : subgroup.closure {σ : perm α | is_swap σ} = ⊤ :=
begin
  refine eq_top_iff.mpr (λ x hx, _),
  obtain ⟨h1, h2⟩ := subtype.mem (trunc_swap_factors x).out,
  rw ← h1,
  exact subgroup.list_prod_mem _ (λ y hy, subgroup.subset_closure (h2 y hy)),
end

/-- Like `swap_induction_on`, but with the composition on the right of `f`.

An induction principle for permutations. If `P` holds for the identity permutation, and
is preserved under composition with a non-trivial swap, then `P` holds for all permutations. -/
@[elab_as_eliminator] lemma swap_induction_on' [fintype α] {P : perm α → Prop} (f : perm α) :
  P 1 → (∀ f x y, x ≠ y → P f → P (f * swap x y)) → P f :=
λ h1 IH, inv_inv f ▸ swap_induction_on f⁻¹ h1 (λ f, IH f⁻¹)

lemma is_conj_swap {w x y z : α} (hwx : w ≠ x) (hyz : y ≠ z) : is_conj (swap w x) (swap y z) :=
is_conj_iff.2 (have h : ∀ {y z : α}, y ≠ z → w ≠ z →
      (swap w y * swap x z) * swap w x * (swap w y * swap x z)⁻¹ = swap y z :=
    λ y z hyz hwz, by rw [mul_inv_rev, swap_inv, swap_inv, mul_assoc (swap w y),
      mul_assoc (swap w y), ← mul_assoc _ (swap x z), swap_mul_swap_mul_swap hwx hwz,
      ← mul_assoc, swap_mul_swap_mul_swap hwz.symm hyz.symm],
  if hwz : w = z
  then have hwy : w ≠ y, by cc,
    ⟨swap w z * swap x y, by rw [swap_comm y z, h hyz.symm hwy]⟩
  else ⟨swap w y * swap x z, h hyz hwz⟩)

/-- set of all pairs (⟨a, b⟩ : Σ a : fin n, fin n) such that b < a -/
def fin_pairs_lt (n : ℕ) : finset (Σ a : fin n, fin n) :=
(univ : finset (fin n)).sigma (λ a, (range a).attach_fin
  (λ m hm, (mem_range.1 hm).trans a.2))

lemma mem_fin_pairs_lt {n : ℕ} {a : Σ a : fin n, fin n} :
  a ∈ fin_pairs_lt n ↔ a.2 < a.1 :=
by simp only [fin_pairs_lt, fin.lt_iff_coe_lt_coe, true_and, mem_attach_fin, mem_range, mem_univ,
  mem_sigma]

/-- `sign_aux σ` is the sign of a permutation on `fin n`, defined as the parity of the number of
  pairs `(x₁, x₂)` such that `x₂ < x₁` but `σ x₁ ≤ σ x₂` -/
def sign_aux {n : ℕ} (a : perm (fin n)) : units ℤ :=
∏ x in fin_pairs_lt n, if a x.1 ≤ a x.2 then -1 else 1

@[simp] lemma sign_aux_one (n : ℕ) : sign_aux (1 : perm (fin n)) = 1 :=
begin
  unfold sign_aux,
  conv { to_rhs, rw ← @finset.prod_const_one (units ℤ) _
    (fin_pairs_lt n) },
  exact finset.prod_congr rfl (λ a ha, if_neg (mem_fin_pairs_lt.1 ha).not_le)
end

/-- `sign_bij_aux f ⟨a, b⟩` returns the pair consisting of `f a` and `f b` in decreasing order. -/
def sign_bij_aux {n : ℕ} (f : perm (fin n)) (a : Σ a : fin n, fin n) :
  Σ a : fin n, fin n :=
if hxa : f a.2 < f a.1 then ⟨f a.1, f a.2⟩ else ⟨f a.2, f a.1⟩

lemma sign_bij_aux_inj {n : ℕ} {f : perm (fin n)} : ∀ a b : Σ a : fin n, fin n,
   a ∈ fin_pairs_lt n → b ∈ fin_pairs_lt n →
   sign_bij_aux f a = sign_bij_aux f b → a = b :=
λ ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ha hb h, begin
  unfold sign_bij_aux at h,
  rw mem_fin_pairs_lt at *,
  have : ¬b₁ < b₂ := hb.le.not_lt,
  split_ifs at h;
  simp only [*, (equiv.injective f).eq_iff, eq_self_iff_true, and_self, heq_iff_eq] at *,
end

lemma sign_bij_aux_surj {n : ℕ} {f : perm (fin n)} : ∀ a ∈ fin_pairs_lt n,
  ∃ b ∈ fin_pairs_lt n, a = sign_bij_aux f b :=
λ ⟨a₁, a₂⟩ ha,
if hxa : f⁻¹ a₂ < f⁻¹ a₁
then ⟨⟨f⁻¹ a₁, f⁻¹ a₂⟩, mem_fin_pairs_lt.2 hxa,
  by { dsimp [sign_bij_aux],
    rw [apply_inv_self, apply_inv_self, if_pos (mem_fin_pairs_lt.1 ha)] }⟩
else ⟨⟨f⁻¹ a₂, f⁻¹ a₁⟩, mem_fin_pairs_lt.2 $ (le_of_not_gt hxa).lt_of_ne $ λ h,
    by simpa [mem_fin_pairs_lt, (f⁻¹).injective h, lt_irrefl] using ha,
  by { dsimp [sign_bij_aux],
    rw [apply_inv_self, apply_inv_self, if_neg (mem_fin_pairs_lt.1 ha).le.not_lt] }⟩

lemma sign_bij_aux_mem {n : ℕ} {f : perm (fin n)} : ∀ a : Σ a : fin n, fin n,
  a ∈ fin_pairs_lt n → sign_bij_aux f a ∈ fin_pairs_lt n :=
λ ⟨a₁, a₂⟩ ha, begin
  unfold sign_bij_aux,
  split_ifs with h,
  { exact mem_fin_pairs_lt.2 h },
  { exact mem_fin_pairs_lt.2
    ((le_of_not_gt h).lt_of_ne (λ h, (mem_fin_pairs_lt.1 ha).ne (f.injective h.symm))) }
end

@[simp] lemma sign_aux_inv {n : ℕ} (f : perm (fin n)) : sign_aux f⁻¹ = sign_aux f :=
prod_bij (λ a ha, sign_bij_aux f⁻¹ a)
  sign_bij_aux_mem
  (λ ⟨a, b⟩ hab, if h : f⁻¹ b < f⁻¹ a
    then by rw [sign_bij_aux, dif_pos h, if_neg h.not_le, apply_inv_self,
      apply_inv_self, if_neg (mem_fin_pairs_lt.1 hab).not_le]
    else by rw [sign_bij_aux, if_pos (le_of_not_gt h), dif_neg h, apply_inv_self,
      apply_inv_self, if_pos (mem_fin_pairs_lt.1 hab).le])
  sign_bij_aux_inj
  sign_bij_aux_surj

lemma sign_aux_mul {n : ℕ} (f g : perm (fin n)) :
  sign_aux (f * g) = sign_aux f * sign_aux g :=
begin
  rw ← sign_aux_inv g,
  unfold sign_aux,
  rw ← prod_mul_distrib,
  refine prod_bij (λ a ha, sign_bij_aux g a) sign_bij_aux_mem _ sign_bij_aux_inj sign_bij_aux_surj,
  rintros ⟨a, b⟩ hab,
  rw [sign_bij_aux, mul_apply, mul_apply],
  rw mem_fin_pairs_lt at hab,
  by_cases h : g b < g a,
  { rw dif_pos h,
    simp only [not_le_of_gt hab, mul_one, perm.inv_apply_self, if_false] },
  { rw [dif_neg h, inv_apply_self, inv_apply_self, if_pos hab.le],
    by_cases h₁ : f (g b) ≤ f (g a),
    { have : f (g b) ≠ f (g a),
      { rw [ne.def, f.injective.eq_iff, g.injective.eq_iff],
        exact ne_of_lt hab },
      rw [if_pos h₁, if_neg (h₁.lt_of_ne this).not_le],
      refl },
    { rw [if_neg h₁, if_pos (lt_of_not_ge h₁).le],
      refl } }
end

private lemma sign_aux_swap_zero_one' (n : ℕ) :
  sign_aux (swap (0 : fin (n + 2)) 1) = -1 :=
show _ = ∏ x : Σ a : fin (n + 2), fin (n + 2) in {(⟨1, 0⟩ : Σ a : fin (n + 2), fin (n + 2))},
  if (equiv.swap 0 1) x.1 ≤ swap 0 1 x.2 then (-1 : units ℤ) else 1,
begin
  refine eq.symm (prod_subset (λ ⟨x₁, x₂⟩,
    by simp [mem_fin_pairs_lt, fin.one_pos] {contextual := tt}) (λ a ha₁ ha₂, _)),
  rcases a with ⟨a₁, a₂⟩,
  replace ha₁ : a₂ < a₁ := mem_fin_pairs_lt.1 ha₁,
  dsimp only,
  rcases a₁.zero_le.eq_or_lt with rfl|H,
  { exact absurd a₂.zero_le ha₁.not_le },
  rcases a₂.zero_le.eq_or_lt with rfl|H',
  { simp only [and_true, eq_self_iff_true, heq_iff_eq, mem_singleton] at ha₂,
    have : 1 < a₁ := lt_of_le_of_ne (nat.succ_le_of_lt ha₁) (ne.symm ha₂),
    have h01 : equiv.swap (0 : fin (n + 2)) 1 0 = 1, by simp, -- TODO : fix properly
    norm_num [swap_apply_of_ne_of_ne (ne_of_gt H) ha₂, this.not_le, h01] },
  { have le : 1 ≤ a₂ := nat.succ_le_of_lt H',
    have lt : 1 < a₁ := le.trans_lt ha₁,
    have h01 : equiv.swap (0 : fin (n + 2)) 1 1 = 0, by simp, -- TODO
    rcases le.eq_or_lt with rfl|lt',
    { norm_num [swap_apply_of_ne_of_ne H.ne' lt.ne', H.not_le, h01] },
    { norm_num [swap_apply_of_ne_of_ne (ne_of_gt H) (ne_of_gt lt),
        swap_apply_of_ne_of_ne (ne_of_gt H') (ne_of_gt lt'), ha₁.not_le] } }
end

private lemma sign_aux_swap_zero_one {n : ℕ} (hn : 2 ≤ n) :
  sign_aux (swap (⟨0, lt_of_lt_of_le dec_trivial hn⟩ : fin n)
  ⟨1, lt_of_lt_of_le dec_trivial hn⟩) = -1 :=
begin
  rcases n with _|_|n,
  { norm_num at hn },
  { norm_num at hn },
  { exact sign_aux_swap_zero_one' n }
end

lemma sign_aux_swap : ∀ {n : ℕ} {x y : fin n} (hxy : x ≠ y),
  sign_aux (swap x y) = -1
| 0 := dec_trivial
| 1 := dec_trivial
| (n+2) := λ x y hxy,
have h2n : 2 ≤ n + 2 := dec_trivial,
by { rw [← is_conj_iff_eq, ← sign_aux_swap_zero_one h2n],
  exact (monoid_hom.mk' sign_aux sign_aux_mul).map_is_conj (is_conj_swap hxy dec_trivial) }

/-- When the list `l : list α` contains all nonfixed points of the permutation `f : perm α`,
  `sign_aux2 l f` recursively calculates the sign of `f`. -/
def sign_aux2 : list α → perm α → units ℤ
| []     f := 1
| (x::l) f := if x = f x then sign_aux2 l f else -sign_aux2 l (swap x (f x) * f)

lemma sign_aux_eq_sign_aux2 {n : ℕ} : ∀ (l : list α) (f : perm α) (e : α ≃ fin n)
  (h : ∀ x, f x ≠ x → x ∈ l), sign_aux ((e.symm.trans f).trans e) = sign_aux2 l f
| []     f e h := have f = 1, from equiv.ext $
  λ y, not_not.1 (mt (h y) (list.not_mem_nil _)),
by rw [this, one_def, equiv.trans_refl, equiv.symm_trans_self, ← one_def,
  sign_aux_one, sign_aux2]
| (x::l) f e h := begin
  rw sign_aux2,
  by_cases hfx : x = f x,
  { rw if_pos hfx,
    exact sign_aux_eq_sign_aux2 l f _ (λ y (hy : f y ≠ y), list.mem_of_ne_of_mem
      (λ h : y = x, by simpa [h, hfx.symm] using hy) (h y hy) ) },
  { have hy : ∀ y : α, (swap x (f x) * f) y ≠ y → y ∈ l, from λ y hy,
      have f y ≠ y ∧ y ≠ x, from ne_and_ne_of_swap_mul_apply_ne_self hy,
      list.mem_of_ne_of_mem this.2 (h _ this.1),
    have : (e.symm.trans (swap x (f x) * f)).trans e =
      (swap (e x) (e (f x))) * (e.symm.trans f).trans e,
      by ext; simp [← equiv.symm_trans_swap_trans, mul_def],
    have hefx : e x ≠ e (f x), from mt e.injective.eq_iff.1 hfx,
    rw [if_neg hfx, ← sign_aux_eq_sign_aux2 _ _ e hy, this, sign_aux_mul, sign_aux_swap hefx],
    simp only [units.neg_neg, one_mul, units.neg_mul]}
end

/-- When the multiset `s : multiset α` contains all nonfixed points of the permutation `f : perm α`,
  `sign_aux2 f _` recursively calculates the sign of `f`. -/
def sign_aux3 [fintype α] (f : perm α) {s : multiset α} : (∀ x, x ∈ s) → units ℤ :=
quotient.hrec_on s (λ l h, sign_aux2 l f)
  (trunc.induction_on (fintype.trunc_equiv_fin α)
    (λ e l₁ l₂ h, function.hfunext
      (show (∀ x, x ∈ l₁) = ∀ x, x ∈ l₂, by simp only [h.mem_iff])
      (λ h₁ h₂ _, by rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, h₁ _),
        ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, h₂ _)])))

lemma sign_aux3_mul_and_swap [fintype α] (f g : perm α) (s : multiset α) (hs : ∀ x, x ∈ s) :
  sign_aux3 (f * g) hs = sign_aux3 f hs * sign_aux3 g hs ∧ ∀ x y, x ≠ y →
  sign_aux3 (swap x y) hs = -1 :=
let ⟨l, hl⟩ := quotient.exists_rep s in
let e := equiv_fin α in
begin
  clear _let_match,
  subst hl,
  show sign_aux2 l (f * g) = sign_aux2 l f * sign_aux2 l g ∧
    ∀ x y, x ≠ y → sign_aux2 l (swap x y) = -1,
  have hfg : (e.symm.trans (f * g)).trans e = (e.symm.trans f).trans e * (e.symm.trans g).trans e,
    from equiv.ext (λ h, by simp [mul_apply]),
  split,
  { rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _),
      ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), hfg, sign_aux_mul] },
  { assume x y hxy,
    have hexy : e x ≠ e y, from mt e.injective.eq_iff.1 hxy,
    rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), symm_trans_swap_trans, sign_aux_swap hexy] }
end

/-- `sign` of a permutation returns the signature or parity of a permutation, `1` for even
permutations, `-1` for odd permutations. It is the unique surjective group homomorphism from
`perm α` to the group with two elements.-/
def sign [fintype α] : perm α →* units ℤ := monoid_hom.mk'
(λ f, sign_aux3 f mem_univ) (λ f g, (sign_aux3_mul_and_swap f g _ mem_univ).1)

section sign

variable [fintype α]

@[simp] lemma sign_mul (f g : perm α) : sign (f * g) = sign f * sign g :=
monoid_hom.map_mul sign f g

@[simp] lemma sign_trans (f g : perm α) : sign (f.trans g) = sign g * sign f :=
by rw [←mul_def, sign_mul]

@[simp] lemma sign_one : (sign (1 : perm α)) = 1 :=
monoid_hom.map_one sign

@[simp] lemma sign_refl : sign (equiv.refl α) = 1 :=
monoid_hom.map_one sign

@[simp] lemma sign_inv (f : perm α) : sign f⁻¹ = sign f :=
by rw [monoid_hom.map_inv sign f, int.units_inv_eq_self]

@[simp] lemma sign_symm (e : perm α) : sign e.symm = sign e :=
sign_inv e

lemma sign_swap {x y : α} (h : x ≠ y) : sign (swap x y) = -1 :=
(sign_aux3_mul_and_swap 1 1 _ mem_univ).2 x y h

@[simp] lemma sign_swap' {x y : α} :
  (swap x y).sign = if x = y then 1 else -1 :=
if H : x = y then by simp [H, swap_self] else
by simp [sign_swap H, H]

lemma is_swap.sign_eq {f : perm α} (h : f.is_swap) : sign f = -1 :=
let ⟨x, y, hxy⟩ := h in hxy.2.symm ▸ sign_swap hxy.1

@[simp] lemma sign_symm_trans_trans [decidable_eq β] [fintype β] (f : perm α) (e : α ≃ β) :
  sign ((e.symm.trans f).trans e) = sign f :=
sign_aux3_symm_trans_trans f e mem_univ mem_univ

@[simp] lemma sign_trans_trans_symm [decidable_eq β] [fintype β] (f : perm β) (e : α ≃ β) :
  sign ((e.trans f).trans e.symm) = sign f :=
sign_symm_trans_trans f e.symm

lemma sign_prod_list_swap {l : list (perm α)}
  (hl : ∀ g ∈ l, is_swap g) : sign l.prod = (-1) ^ l.length :=
have h₁ : l.map sign = list.repeat (-1) l.length :=
  list.eq_repeat.2 ⟨by simp, λ u hu,
  let ⟨g, hg⟩ := list.mem_map.1 hu in
  hg.2 ▸ (hl _ hg.1).sign_eq⟩,
by rw [← list.prod_repeat, ← h₁, list.prod_hom _ (@sign α _ _)]

variable (α)

lemma sign_surjective [nontrivial α] : function.surjective (sign : perm α → units ℤ) :=
λ a, (int.units_eq_one_or a).elim
  (λ h, ⟨1, by simp [h]⟩)
  (λ h, let ⟨x, y, hxy⟩ := exists_pair_ne α in
    ⟨swap x y, by rw [sign_swap hxy, h]⟩ )

variable {α}

lemma eq_sign_of_surjective_hom {s : perm α →* units ℤ} (hs : surjective s) : s = sign :=
have ∀ {f}, is_swap f → s f = -1 :=
  λ f ⟨x, y, hxy, hxy'⟩, hxy'.symm ▸ by_contradiction (λ h,
    have ∀ f, is_swap f → s f = 1 := λ f ⟨a, b, hab, hab'⟩,
      by { rw [← is_conj_iff_eq, ← or.resolve_right (int.units_eq_one_or _) h, hab'],
        exact s.map_is_conj (is_conj_swap hab hxy) },
  let ⟨g, hg⟩ := hs (-1) in
  let ⟨l, hl⟩ := (trunc_swap_factors g).out in
  have ∀ a ∈ l.map s, a = (1 : units ℤ) := λ a ha,
    let ⟨g, hg⟩ := list.mem_map.1 ha in hg.2 ▸ this _ (hl.2 _ hg.1),
  have s l.prod = 1,
    by rw [← l.prod_hom s, list.eq_repeat'.2 this, list.prod_repeat, one_pow],
  by { rw [hl.1, hg] at this,
    exact absurd this dec_trivial }),
monoid_hom.ext $ λ f,
let ⟨l, hl₁, hl₂⟩ := (trunc_swap_factors f).out in
have hsl : ∀ a ∈ l.map s, a = (-1 : units ℤ) := λ a ha,
  let ⟨g, hg⟩ := list.mem_map.1 ha in hg.2 ▸  this (hl₂ _ hg.1),
by rw [← hl₁, ← l.prod_hom s, list.eq_repeat'.2 hsl, list.length_map,
     list.prod_repeat, sign_prod_list_swap hl₂]

lemma sign_subtype_perm (f : perm α) {p : α → Prop} [decidable_pred p]
  (h₁ : ∀ x, p x ↔ p (f x)) (h₂ : ∀ x, f x ≠ x → p x) : sign (subtype_perm f h₁) = sign f :=
let l := (trunc_swap_factors (subtype_perm f h₁)).out in
have hl' : ∀ g' ∈ l.1.map of_subtype, is_swap g' :=
  λ g' hg',
  let ⟨g, hg⟩ := list.mem_map.1 hg' in
  hg.2 ▸ (l.2.2 _ hg.1).of_subtype_is_swap,
have hl'₂ : (l.1.map of_subtype).prod = f,
  by rw [l.1.prod_hom of_subtype, l.2.1, of_subtype_subtype_perm _ h₂],
by { conv { congr, rw ← l.2.1, skip, rw ← hl'₂ },
  rw [sign_prod_list_swap l.2.2, sign_prod_list_swap hl', list.length_map] }

@[simp] lemma sign_of_subtype {p : α → Prop} [decidable_pred p]
  (f : perm (subtype p)) : sign (of_subtype f) = sign f :=
have ∀ x, of_subtype f x ≠ x → p x, from λ x, not_imp_comm.1 (of_subtype_apply_of_not_mem f),
by conv {to_rhs, rw [← subtype_perm_of_subtype f, sign_subtype_perm _ _ this]}

lemma sign_eq_sign_of_equiv [decidable_eq β] [fintype β] (f : perm α) (g : perm β)
  (e : α ≃ β) (h : ∀ x, e (f x) = g (e x)) : sign f = sign g :=
have hg : g = (e.symm.trans f).trans e, from equiv.ext $ by simp [h],
by rw [hg, sign_symm_trans_trans]

lemma sign_bij [decidable_eq β] [fintype β]
  {f : perm α} {g : perm β} (i : Π x : α, f x ≠ x → β)
  (h : ∀ x hx hx', i (f x) hx' = g (i x hx))
  (hi : ∀ x₁ x₂ hx₁ hx₂, i x₁ hx₁ = i x₂ hx₂ → x₁ = x₂)
  (hg : ∀ y, g y ≠ y → ∃ x hx, i x hx = y) :
  sign f = sign g :=
calc sign f = sign (@subtype_perm _ f (λ x, f x ≠ x) (by simp)) :
  (sign_subtype_perm _ _ (λ _, id)).symm
... = sign (@subtype_perm _ g (λ x, g x ≠ x) (by simp)) :
  sign_eq_sign_of_equiv _ _
    (equiv.of_bijective (λ x : {x // f x ≠ x},
        (⟨i x.1 x.2, have f (f x) ≠ f x, from mt (λ h, f.injective h) x.2,
          by { rw [← h _ x.2 this], exact mt (hi _ _ this x.2) x.2 }⟩ : {y // g y ≠ y}))
        ⟨λ ⟨x, hx⟩ ⟨y, hy⟩ h, subtype.eq (hi _ _ _ _ (subtype.mk.inj h)),
          λ ⟨y, hy⟩, let ⟨x, hfx, hx⟩ := hg y hy in ⟨⟨x, hfx⟩, subtype.eq hx⟩⟩)
      (λ ⟨x, _⟩, subtype.eq (h x _ _))
... = sign g : sign_subtype_perm _ _ (λ _, id)

/-- If we apply `prod_extend_right a (σ a)` for all `a : α` in turn,
we get `prod_congr_right σ`. -/
lemma prod_prod_extend_right {α : Type*} [decidable_eq α] (σ : α → perm β)
  {l : list α} (hl : l.nodup) (mem_l : ∀ a, a ∈ l) :
  (l.map (λ a, prod_extend_right a (σ a))).prod = prod_congr_right σ :=
begin
  ext ⟨a, b⟩ : 1,
  -- We'll use induction on the list of elements,
  -- but we have to keep track of whether we already passed `a` in the list.
  suffices : (a ∈ l ∧ (l.map (λ a, prod_extend_right a (σ a))).prod (a, b) = (a, σ a b)) ∨
             (a ∉ l ∧ (l.map (λ a, prod_extend_right a (σ a))).prod (a, b) = (a, b)),
  { obtain ⟨_, prod_eq⟩ := or.resolve_right this (not_and.mpr (λ h _, h (mem_l a))),
    rw [prod_eq, prod_congr_right_apply] },
  clear mem_l,

  induction l with a' l ih,
  { refine or.inr ⟨list.not_mem_nil _, _⟩,
    rw [list.map_nil, list.prod_nil, one_apply] },

  rw [list.map_cons, list.prod_cons, mul_apply],
  rcases ih (list.nodup_cons.mp hl).2 with ⟨mem_l, prod_eq⟩ | ⟨not_mem_l, prod_eq⟩; rw prod_eq,
  { refine or.inl ⟨list.mem_cons_of_mem _ mem_l, _⟩,
    rw prod_extend_right_apply_ne _ (λ (h : a = a'), (list.nodup_cons.mp hl).1 (h ▸ mem_l)) },
  by_cases ha' : a = a',
  { rw ← ha' at *,
    refine or.inl ⟨l.mem_cons_self a, _⟩,
    rw prod_extend_right_apply_eq },
  { refine or.inr ⟨λ h, not_or ha' not_mem_l ((list.mem_cons_iff _ _ _).mp h), _⟩,
    rw prod_extend_right_apply_ne _ ha' },
end

section congr

variables [decidable_eq β] [fintype β]

@[simp] lemma sign_prod_extend_right (a : α) (σ : perm β) :
  (prod_extend_right a σ).sign = σ.sign :=
sign_bij (λ (ab : α × β) _, ab.snd)
  (λ ⟨a', b⟩ hab hab', by simp [eq_of_prod_extend_right_ne hab])
  (λ ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ hab₁ hab₂ h,
    by simpa [eq_of_prod_extend_right_ne hab₁, eq_of_prod_extend_right_ne hab₂] using h)
  (λ y hy, ⟨(a, y), by simpa, by simp⟩)

lemma sign_prod_congr_right (σ : α → perm β) :
  sign (prod_congr_right σ) = ∏ k, (σ k).sign :=
begin
  obtain ⟨l, hl, mem_l⟩ := fintype.exists_univ_list α,
  have l_to_finset : l.to_finset = finset.univ,
  { apply eq_top_iff.mpr,
    intros b _,
    exact list.mem_to_finset.mpr (mem_l b) },
  rw [← prod_prod_extend_right σ hl mem_l, sign.map_list_prod,
      list.map_map, ← l_to_finset, list.prod_to_finset _ hl],
  simp_rw ← λ a, sign_prod_extend_right a (σ a)
end

lemma sign_prod_congr_left (σ : α → perm β) :
  sign (prod_congr_left σ) = ∏ k, (σ k).sign :=
begin
  refine (sign_eq_sign_of_equiv _ _ (prod_comm β α) _).trans (sign_prod_congr_right σ),
  rintro ⟨b, α⟩,
  refl
end

@[simp] lemma sign_perm_congr (e : α ≃ β) (p : perm α) :
  (e.perm_congr p).sign = p.sign :=
sign_eq_sign_of_equiv _ _ e.symm (by simp)

@[simp] lemma sign_sum_congr (σa : perm α) (σb : perm β) :
  (sum_congr σa σb).sign = σa.sign * σb.sign :=
begin
  suffices : (sum_congr σa (1 : perm β)).sign = σa.sign ∧
             (sum_congr (1 : perm α) σb).sign = σb.sign,
  { rw [←this.1, ←this.2, ←sign_mul, sum_congr_mul, one_mul, mul_one], },
  split,
  { apply σa.swap_induction_on _ (λ σa' a₁ a₂ ha ih, _),
    { simp },
    { rw [←one_mul (1 : perm β), ←sum_congr_mul, sign_mul, sign_mul, ih, sum_congr_swap_one,
          sign_swap ha, sign_swap (sum.inl_injective.ne_iff.mpr ha)], }, },
  { apply σb.swap_induction_on _ (λ σb' b₁ b₂ hb ih, _),
    { simp },
    { rw [←one_mul (1 : perm α), ←sum_congr_mul, sign_mul, sign_mul, ih, sum_congr_one_swap,
          sign_swap hb, sign_swap (sum.inr_injective.ne_iff.mpr hb)], }, }
end

@[simp] lemma sign_subtype_congr {p : α → Prop} [decidable_pred p]
  (ep : perm {a // p a}) (en : perm {a // ¬ p a}) :
  (ep.subtype_congr en).sign = ep.sign * en.sign :=
by simp [subtype_congr]

@[simp] lemma sign_extend_domain (e : perm α)
  {p : β → Prop} [decidable_pred p] (f : α ≃ subtype p) :
  equiv.perm.sign (e.extend_domain f) = equiv.perm.sign e :=
by simp [equiv.perm.extend_domain]

end congr

end sign

end equiv.perm


/-
Copyright (c) 2023 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import ring_theory.dedekind_domain.adic_valuation
import topology.algebra.uniform_ring

/-!
# The finite adèle ring of a Dedekind domain
We define the ring of finite adèles of a Dedekind domain `R`.

## Main definitions
- `dedekind_domain.finite_integral_adeles` : product of `adic_completion_integers`, where `v`
  runs over all maximal ideals of `R`.
- `dedekind_domain.prod_adic_completions` : the product of `adic_completion`, where `v` runs over
  all maximal ideals of `R`.
- `dedekind_domain.finite_adele_ring` : The finite adèle ring of `R`, defined as the
  restricted product `Π'_v K_v`.

## Implementation notes
We are only interested on Dedekind domains of Krull dimension 1 (i.e., not fields). If `R` is a
field, its finite adèle ring is just defined to be the trivial ring.

## References
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]

## Tags
finite adèle ring, dedekind domain
-/

noncomputable theory
open function set is_dedekind_domain is_dedekind_domain.height_one_spectrum

namespace dedekind_domain

variables (R K : Type*) [comm_ring R] [is_domain R] [is_dedekind_domain R] [field K]
  [algebra R K] [is_fraction_ring R K] (v : height_one_spectrum R)

/-- The product of all `adic_completion_integers`, where `v` runs over the maximal ideals of `R`. -/
@[derive [comm_ring, topological_space, inhabited]]
def finite_integral_adeles : Type* := Π (v : height_one_spectrum R), v.adic_completion_integers K

local notation `R_hat` := finite_integral_adeles

/-- The product of all `adic_completion`, where `v` runs over the maximal ideals of `R`. -/
@[derive [non_unital_non_assoc_ring, topological_space, topological_ring, comm_ring, inhabited]]
def prod_adic_completions := Π (v : height_one_spectrum R), v.adic_completion K

local notation `K_hat` := prod_adic_completions

namespace finite_integral_adeles

noncomputable! instance : has_coe (R_hat R K) (K_hat R K) := { coe := λ x v, x v }

lemma coe_apply (x : R_hat R K) (v : height_one_spectrum R) : (x : K_hat R K) v = ↑(x v) := rfl

/-- The inclusion of `R_hat` in `K_hat` as a homomorphism of additive monoids. -/
@[simps] def coe.add_monoid_hom : add_monoid_hom (R_hat R K) (K_hat R K) :=
{ to_fun    := coe,
  map_zero' := rfl,
  map_add'  := λ x y, by { ext v, simp only [coe_apply, pi.add_apply, subring.coe_add] }}

/-- The inclusion of `R_hat` in `K_hat` as a ring homomorphism. -/
@[simps] def coe.ring_hom : ring_hom (R_hat R K) (K_hat R K)  :=
{ to_fun   := coe,
  map_one' := rfl,
  map_mul' := λ x y, by {ext p, simp only [pi.mul_apply, subring.coe_mul], refl },
  ..coe.add_monoid_hom R K }

end finite_integral_adeles

section algebra_instances

instance : algebra K (K_hat R K) :=
(by apply_instance : algebra K $ Π v : height_one_spectrum R, v.adic_completion K)

instance prod_adic_completions.algebra' : algebra R (K_hat R K) :=
(by apply_instance : algebra R $ Π v : height_one_spectrum R, v.adic_completion K)

instance : is_scalar_tower R K (K_hat R K) :=
(by apply_instance : is_scalar_tower R K $ Π v : height_one_spectrum R, v.adic_completion K)

instance : algebra R (R_hat R K) :=
(by apply_instance : algebra R $ Π v : height_one_spectrum R, v.adic_completion_integers K)

instance prod_adic_completions.algebra_completions : algebra (R_hat R K) (K_hat R K) :=
(finite_integral_adeles.coe.ring_hom R K).to_algebra

instance prod_adic_completions.is_scalar_tower_completions :
  is_scalar_tower R (R_hat R K) (K_hat R K) :=
(by apply_instance : is_scalar_tower R (Π v : height_one_spectrum R, v.adic_completion_integers K) $
  Π v : height_one_spectrum R, v.adic_completion K)

end algebra_instances

namespace finite_integral_adeles

/-- The inclusion of `R_hat` in `K_hat` as an algebra homomorphism. -/
def coe.alg_hom : alg_hom R (R_hat R K) (K_hat R K)  :=
{ to_fun    := coe,
  commutes' := λ r, rfl,
  ..coe.ring_hom R K  }

lemma coe.alg_hom_apply (x : R_hat R K) (v : height_one_spectrum R) :
  (coe.alg_hom R K) x v = x v := rfl

end finite_integral_adeles

/-! ### The finite adèle ring of a Dedekind domain
We define the finite adèle ring of `R` as the restricted product over all maximal ideals `v` of `R`
of `adic_completion` with respect to `adic_completion_integers`. We prove that it is a commutative
ring. TODO: show that it is a topological ring with the restricted product topology. -/

namespace prod_adic_completions

variables {R K}

/-- An element `x : K_hat R K` is a finite adèle if for all but finitely many height one ideals
  `v`, the component `x v` is a `v`-adic integer. -/
def is_finite_adele (x : K_hat R K) :=
∀ᶠ v : height_one_spectrum R in filter.cofinite, x v ∈ v.adic_completion_integers K

namespace is_finite_adele

/-- The sum of two finite adèles is a finite adèle. -/
lemma add {x y : K_hat R K} (hx : x.is_finite_adele) (hy : y.is_finite_adele) :
  (x + y).is_finite_adele :=
begin
  rw [is_finite_adele, filter.eventually_cofinite] at hx hy ⊢,
  have h_subset : {v : height_one_spectrum R | ¬ (x + y) v ∈  (v.adic_completion_integers K)} ⊆
    {v : height_one_spectrum R | ¬ x v ∈ (v.adic_completion_integers K)} ∪
    {v : height_one_spectrum R | ¬ y v ∈ (v.adic_completion_integers K)},
  { intros v hv,
    rw [mem_union, mem_set_of_eq, mem_set_of_eq],
    rw mem_set_of_eq at hv,
    contrapose! hv,
    rw [mem_adic_completion_integers, mem_adic_completion_integers, ← max_le_iff] at hv,
    rw [mem_adic_completion_integers, pi.add_apply],
    exact le_trans (valued.v.map_add_le_max' (x v) (y v)) hv },
  exact (hx.union hy).subset h_subset,
end

/-- The tuple `(0)_v` is a finite adèle. -/
lemma zero : (0 : K_hat R K).is_finite_adele :=
begin
  rw [is_finite_adele, filter.eventually_cofinite],
  have h_empty : {v : height_one_spectrum R |
    ¬ ((0 : v.adic_completion K) ∈ v.adic_completion_integers K)} = ∅,
  { ext v, rw [mem_empty_iff_false, iff_false], intro hv,
    rw mem_set_of_eq at hv, apply hv, rw mem_adic_completion_integers,
    have h_zero : (valued.v (0 : v.adic_completion K) : (with_zero(multiplicative ℤ))) = 0 :=
    valued.v.map_zero',
    rw h_zero, exact zero_le_one' _ },
  simp_rw [pi.zero_apply, h_empty],
  exact finite_empty,
end

/-- The negative of a finite adèle is a finite adèle. -/
lemma neg {x : K_hat R K} (hx : x.is_finite_adele) : (-x).is_finite_adele  :=
begin
  rw is_finite_adele at hx ⊢,
  have h : ∀ (v : height_one_spectrum R), (-x v ∈ v.adic_completion_integers K) ↔
    (x v ∈ v.adic_completion_integers K),
  { intro v,
    rw [mem_adic_completion_integers, mem_adic_completion_integers, valuation.map_neg], },
  simpa only [pi.neg_apply, h] using hx,
end

/-- The product of two finite adèles is a finite adèle. -/
lemma mul {x y : K_hat R K} (hx : x.is_finite_adele) (hy : y.is_finite_adele) :
  (x * y).is_finite_adele :=
begin
  rw [is_finite_adele, filter.eventually_cofinite] at hx hy ⊢,
  have h_subset : {v : height_one_spectrum R | ¬ (x * y) v ∈  (v.adic_completion_integers K)} ⊆
    {v : height_one_spectrum R | ¬ x v ∈ (v.adic_completion_integers K)} ∪
    {v : height_one_spectrum R | ¬ y v ∈ (v.adic_completion_integers K)},
  { intros v hv,
    rw [mem_union, mem_set_of_eq, mem_set_of_eq],
    rw mem_set_of_eq at hv,
    contrapose! hv,
    rw [mem_adic_completion_integers, mem_adic_completion_integers] at hv,
    have h_mul : valued.v (x v * y v) = (valued.v (x v)) * (valued.v (y v)) :=
      (valued.v).map_mul' (x v) (y v),
    rw [mem_adic_completion_integers, pi.mul_apply, h_mul],
    exact @mul_le_one' (with_zero (multiplicative ℤ)) _ _
      (ordered_comm_monoid.to_covariant_class_left _) _ _ hv.left hv.right  },
  exact (hx.union hy).subset h_subset,
end

/-- The tuple `(1)_v` is a finite adèle. -/
lemma one : (1 : K_hat R K).is_finite_adele :=
begin
  rw [is_finite_adele, filter.eventually_cofinite],
  have h_empty : {v : height_one_spectrum R |
    ¬ ((1 : v.adic_completion K) ∈ v.adic_completion_integers K)} = ∅,
  { ext v, rw [mem_empty_iff_false, iff_false], intro hv,
    rw mem_set_of_eq at hv, apply hv, rw mem_adic_completion_integers,
    exact le_of_eq valued.v.map_one' },
  simp_rw [pi.one_apply, h_empty],
  exact finite_empty,
end

end is_finite_adele

end prod_adic_completions

open prod_adic_completions.is_finite_adele

variables (R K)
/-- The finite adèle ring of `R` is the restricted product over all maximal ideals `v` of `R`
of `adic_completion` with respect to `adic_completion_integers`. -/
noncomputable! def finite_adele_ring : subring (K_hat R K) :=
{ carrier   := { x : K_hat R K | x.is_finite_adele },
  mul_mem'  := λ _ _ hx hy, mul hx hy,
  one_mem'  := one,
  add_mem'  := λ _ _ hx hy, add hx hy,
  zero_mem' := zero,
  neg_mem'  := λ _ hx, neg hx, }

variables {R K}

@[simp] lemma mem_finite_adele_ring_iff (x : K_hat R K) :
  x ∈ finite_adele_ring R K ↔ x.is_finite_adele :=
iff.rfl

end dedekind_domain


lemma add_assoc (a b c : mynat) : (a + b) + c = a + (b + c) :=
begin
induction c with k Pk,
rw add_zero b, rw add_zero, refl,
rw add_succ, rw Pk, rw ← add_succ, rw ← add_succ, refl,
end


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Stephen Morgan, Scott Morrison
import .semigroups

open categories
open categories.monoidal_category

namespace categories.internal_objects

universes u v

open SemigroupObject

structure SemigroupModuleObject {C : Type u} [monoidal_category.{u v} C] (A : C) [SemigroupObject A] :=
  (module : C)
  (action : (A ⊗ module) ⟶ module)
  (associativity : ((μ A) ⊗ (𝟙 module)) ≫ action = (associator A A module) ≫ ((𝟙 A) ⊗ action) ≫ action)

attribute [ematch] SemigroupModuleObject.associativity

variables {C : Type u} [𝒞 : monoidal_category.{u v} C] {A : C} [SemigroupObject A]
include 𝒞

structure SemigroupModuleMorphism (X Y : SemigroupModuleObject A) :=
  (map : X.module ⟶ Y.module)
  (compatibility : ((𝟙 A) ⊗ map) ≫ Y.action = X.action ≫ map)

attribute [simp,ematch] SemigroupModuleMorphism.compatibility

@[applicable] lemma SemigroupModuleMorphism_pointwise_equal
  {X Y : SemigroupModuleObject A}
  (f g : SemigroupModuleMorphism X Y)
  (w : f.map = g.map) : f = g :=
  begin
    induction f,
    induction g,
    tidy
  end

definition CategoryOfSemigroupModules : category.{(max u v) v} (SemigroupModuleObject A) :=
{ Hom := λ X Y, SemigroupModuleMorphism X Y,
  identity := λ X, ⟨ 𝟙 X.module, by obviously ⟩,
  compose  := λ X Y Z f g, ⟨ f.map ≫ g.map, by obviously ⟩ }

end categories.internal_objects


/-
Copyright (c) 2020 Paul van Wamelen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Paul van Wamelen.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.field
import Mathlib.ring_theory.int.basic
import Mathlib.algebra.group_with_zero.power
import Mathlib.tactic.ring
import Mathlib.tactic.ring_exp
import Mathlib.tactic.field_simp
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Pythagorean Triples
The main result is the classification of pythagorean triples. The final result is for general
pythagorean triples. It follows from the more interesting relatively prime case. We use the
"rational parametrization of the circle" method for the proof. The parametrization maps the point
`(x / z, y / z)` to the slope of the line through `(-1 , 0)` and `(x / z, y / z)`. This quickly
shows that `(x / z, y / z) = (2 * m * n / (m ^ 2 + n ^ 2), (m ^ 2 - n ^ 2) / (m ^ 2 + n ^ 2))` where
`m / n` is the slope. In order to identify numerators and denominators we now need results showing
that these are coprime. This is easy except for the prime 2. In order to deal with that we have to
analyze the parity of `x`, `y`, `m` and `n` and eliminate all the impossible cases. This takes up
the bulk of the proof below.
-/

/-- Three integers `x`, `y`, and `z` form a Pythagorean triple if `x * x + y * y = z * z`. -/
def pythagorean_triple (x : ℤ) (y : ℤ) (z : ℤ) :=
  x * x + y * y = z * z

/-- Pythagorean triples are interchangable, i.e `x * x + y * y = y * y + x * x = z * z`.
This comes from additive commutativity. -/
theorem pythagorean_triple_comm {x : ℤ} {y : ℤ} {z : ℤ} : pythagorean_triple x y z ↔ pythagorean_triple y x z :=
  id
    (eq.mpr (id (Eq._oldrec (Eq.refl (x * x + y * y = z * z ↔ y * y + x * x = z * z)) (add_comm (x * x) (y * y))))
      (iff.refl (y * y + x * x = z * z)))

/-- The zeroth Pythagorean triple is all zeros. -/
theorem pythagorean_triple.zero : pythagorean_triple 0 0 0 := sorry

namespace pythagorean_triple

theorem eq {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) : x * x + y * y = z * z :=
  h

theorem symm {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) : pythagorean_triple y x z :=
  eq.mpr (id (Eq._oldrec (Eq.refl (pythagorean_triple y x z)) (propext pythagorean_triple_comm))) h

/-- A triple is still a triple if you multiply `x`, `y` and `z`
by a constant `k`. -/
theorem mul {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (k : ℤ) : pythagorean_triple (k * x) (k * y) (k * z) := sorry

/-- `(k*x, k*y, k*z)` is a Pythagorean triple if and only if
`(x, y, z)` is also a triple. -/
theorem mul_iff {x : ℤ} {y : ℤ} {z : ℤ} (k : ℤ) (hk : k ≠ 0) : pythagorean_triple (k * x) (k * y) (k * z) ↔ pythagorean_triple x y z := sorry

/-- A pythogorean triple `x, y, z` is “classified” if there exist integers `k, m, n` such that either
 * `x = k * (m ^ 2 - n ^ 2)` and `y = k * (2 * m * n)`, or
 * `x = k * (2 * m * n)` and `y = k * (m ^ 2 - n ^ 2)`. -/
def is_classified {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) :=
  ∃ (k : ℤ),
    ∃ (m : ℤ),
      ∃ (n : ℤ),
        (x = k * (m ^ bit0 1 - n ^ bit0 1) ∧ y = k * (bit0 1 * m * n) ∨
            x = k * (bit0 1 * m * n) ∧ y = k * (m ^ bit0 1 - n ^ bit0 1)) ∧
          int.gcd m n = 1

/-- A primitive pythogorean triple `x, y, z` is a pythagorean triple with `x` and `y` coprime.
 Such a triple is “primitively classified” if there exist coprime integers `m, n` such that either
 * `x = m ^ 2 - n ^ 2` and `y = 2 * m * n`, or
 * `x = 2 * m * n` and `y = m ^ 2 - n ^ 2`.
-/
def is_primitive_classified {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) :=
  ∃ (m : ℤ),
    ∃ (n : ℤ),
      (x = m ^ bit0 1 - n ^ bit0 1 ∧ y = bit0 1 * m * n ∨ x = bit0 1 * m * n ∧ y = m ^ bit0 1 - n ^ bit0 1) ∧
        int.gcd m n = 1 ∧ (m % bit0 1 = 0 ∧ n % bit0 1 = 1 ∨ m % bit0 1 = 1 ∧ n % bit0 1 = 0)

theorem mul_is_classified {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (k : ℤ) (hc : is_classified h) : is_classified (mul h k) := sorry

theorem even_odd_of_coprime {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) : x % bit0 1 = 0 ∧ y % bit0 1 = 1 ∨ x % bit0 1 = 1 ∧ y % bit0 1 = 0 := sorry

theorem gcd_dvd {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) : ↑(int.gcd x y) ∣ z := sorry

theorem normalize {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) : pythagorean_triple (x / ↑(int.gcd x y)) (y / ↑(int.gcd x y)) (z / ↑(int.gcd x y)) := sorry

theorem is_classified_of_is_primitive_classified {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (hp : is_primitive_classified h) : is_classified h := sorry

theorem is_classified_of_normalize_is_primitive_classified {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (hc : is_primitive_classified (normalize h)) : is_classified h := sorry

theorem ne_zero_of_coprime {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) : z ≠ 0 := sorry

theorem is_primitive_classified_of_coprime_of_zero_left {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) (hx : x = 0) : is_primitive_classified h := sorry

theorem coprime_of_coprime {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) : int.gcd y z = 1 := sorry

end pythagorean_triple

/-!
### A parametrization of the unit circle

For the classification of pythogorean triples, we will use a parametrization of the unit circle.
-/

/--  A parameterization of the unit circle that is useful for classifying Pythagorean triples.
 (To be applied in the case where `K = ℚ`.) -/
def circle_equiv_gen {K : Type u_1} [field K] (hk : ∀ (x : K), 1 + x ^ bit0 1 ≠ 0) : K ≃ Subtype fun (p : K × K) => prod.fst p ^ bit0 1 + prod.snd p ^ bit0 1 = 1 ∧ prod.snd p ≠ -1 :=
  equiv.mk
    (fun (x : K) => { val := (bit0 1 * x / (1 + x ^ bit0 1), (1 - x ^ bit0 1) / (1 + x ^ bit0 1)), property := sorry })
    (fun (p : Subtype fun (p : K × K) => prod.fst p ^ bit0 1 + prod.snd p ^ bit0 1 = 1 ∧ prod.snd p ≠ -1) =>
      prod.fst ↑p / (prod.snd ↑p + 1))
    sorry sorry

@[simp] theorem circle_equiv_apply {K : Type u_1} [field K] (hk : ∀ (x : K), 1 + x ^ bit0 1 ≠ 0) (x : K) : ↑(coe_fn (circle_equiv_gen hk) x) = (bit0 1 * x / (1 + x ^ bit0 1), (1 - x ^ bit0 1) / (1 + x ^ bit0 1)) :=
  rfl

@[simp] theorem circle_equiv_symm_apply {K : Type u_1} [field K] (hk : ∀ (x : K), 1 + x ^ bit0 1 ≠ 0) (v : Subtype fun (p : K × K) => prod.fst p ^ bit0 1 + prod.snd p ^ bit0 1 = 1 ∧ prod.snd p ≠ -1) : coe_fn (equiv.symm (circle_equiv_gen hk)) v = prod.fst ↑v / (prod.snd ↑v + 1) :=
  rfl

namespace pythagorean_triple

theorem is_primitive_classified_aux {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) (hzpos : 0 < z) {m : ℤ} {n : ℤ} (hm2n2 : 0 < m ^ bit0 1 + n ^ bit0 1) (hv2 : ↑x / ↑z = bit0 1 * ↑m * ↑n / (↑m ^ bit0 1 + ↑n ^ bit0 1)) (hw2 : ↑y / ↑z = (↑m ^ bit0 1 - ↑n ^ bit0 1) / (↑m ^ bit0 1 + ↑n ^ bit0 1)) (H : int.gcd (m ^ bit0 1 - n ^ bit0 1) (m ^ bit0 1 + n ^ bit0 1) = 1) (co : int.gcd m n = 1) (pp : m % bit0 1 = 0 ∧ n % bit0 1 = 1 ∨ m % bit0 1 = 1 ∧ n % bit0 1 = 0) : is_primitive_classified h := sorry

theorem is_primitive_classified_of_coprime_of_odd_of_pos {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) (hyo : y % bit0 1 = 1) (hzpos : 0 < z) : is_primitive_classified h := sorry

theorem is_primitive_classified_of_coprime_of_pos {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) (hzpos : 0 < z) : is_primitive_classified h := sorry

theorem is_primitive_classified_of_coprime {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) : is_primitive_classified h := sorry

theorem classified {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) : is_classified h := sorry

theorem coprime_classification {x : ℤ} {y : ℤ} {z : ℤ} : pythagorean_triple x y z ∧ int.gcd x y = 1 ↔
  ∃ (m : ℤ),
    ∃ (n : ℤ),
      (x = m ^ bit0 1 - n ^ bit0 1 ∧ y = bit0 1 * m * n ∨ x = bit0 1 * m * n ∧ y = m ^ bit0 1 - n ^ bit0 1) ∧
        (z = m ^ bit0 1 + n ^ bit0 1 ∨ z = -(m ^ bit0 1 + n ^ bit0 1)) ∧
          int.gcd m n = 1 ∧ (m % bit0 1 = 0 ∧ n % bit0 1 = 1 ∨ m % bit0 1 = 1 ∧ n % bit0 1 = 0) := sorry

/-- by assuming `x` is odd and `z` is positive we get a slightly more precise classification of
the pythagorean triple `x ^ 2 + y ^ 2 = z ^ 2`-/
theorem coprime_classification' {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (h_coprime : int.gcd x y = 1) (h_parity : x % bit0 1 = 1) (h_pos : 0 < z) : ∃ (m : ℤ),
  ∃ (n : ℤ),
    x = m ^ bit0 1 - n ^ bit0 1 ∧
      y = bit0 1 * m * n ∧
        z = m ^ bit0 1 + n ^ bit0 1 ∧
          int.gcd m n = 1 ∧ (m % bit0 1 = 0 ∧ n % bit0 1 = 1 ∨ m % bit0 1 = 1 ∧ n % bit0 1 = 0) ∧ 0 ≤ m := sorry

theorem classification {x : ℤ} {y : ℤ} {z : ℤ} : pythagorean_triple x y z ↔
  ∃ (k : ℤ),
    ∃ (m : ℤ),
      ∃ (n : ℤ),
        (x = k * (m ^ bit0 1 - n ^ bit0 1) ∧ y = k * (bit0 1 * m * n) ∨
            x = k * (bit0 1 * m * n) ∧ y = k * (m ^ bit0 1 - n ^ bit0 1)) ∧
          (z = k * (m ^ bit0 1 + n ^ bit0 1) ∨ z = -k * (m ^ bit0 1 + n ^ bit0 1)) := sorry


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import measure_theory.group.measurable_equiv
import measure_theory.measure.regular
import dynamics.ergodic.measure_preserving
import dynamics.minimal

/-!
# Measures invariant under group actions

A measure `μ : measure α` is said to be *invariant* under an action of a group `G` if scalar
multiplication by `c : G` is a measure preserving map for all `c`. In this file we define a
typeclass for measures invariant under action of an (additive or multiplicative) group and prove
some basic properties of such measures.
-/

open_locale ennreal nnreal pointwise topological_space
open measure_theory measure_theory.measure set function

namespace measure_theory

variables {G M α : Type*}

/-- A measure `μ : measure α` is invariant under an additive action of `M` on `α` if for any
measurable set `s : set α` and `c : M`, the measure of its preimage under `λ x, c +ᵥ x` is equal to
the measure of `s`. -/
class vadd_invariant_measure (M α : Type*) [has_vadd M α] {_ : measurable_space α}
  (μ : measure α) : Prop :=
(measure_preimage_vadd [] : ∀ (c : M) ⦃s : set α⦄, measurable_set s → μ ((λ x, c +ᵥ x) ⁻¹' s) = μ s)

/-- A measure `μ : measure α` is invariant under a multiplicative action of `M` on `α` if for any
measurable set `s : set α` and `c : M`, the measure of its preimage under `λ x, c • x` is equal to
the measure of `s`. -/
@[to_additive] class smul_invariant_measure (M α : Type*) [has_scalar M α] {_ : measurable_space α}
  (μ : measure α) : Prop :=
(measure_preimage_smul [] : ∀ (c : M) ⦃s : set α⦄, measurable_set s → μ ((λ x, c • x) ⁻¹' s) = μ s)

namespace smul_invariant_measure

@[to_additive] instance zero [measurable_space α] [has_scalar M α] : smul_invariant_measure M α 0 :=
⟨λ _ _ _, rfl⟩

variables [has_scalar M α] {m : measurable_space α} {μ ν : measure α}

@[to_additive] instance add [smul_invariant_measure M α μ] [smul_invariant_measure M α ν] :
  smul_invariant_measure M α (μ + ν) :=
⟨λ c s hs, show _ + _ = _ + _,
  from congr_arg2 (+) (measure_preimage_smul μ c hs) (measure_preimage_smul ν c hs)⟩

@[to_additive] instance smul [smul_invariant_measure M α μ] (c : ℝ≥0∞) :
  smul_invariant_measure M α (c • μ) :=
⟨λ a s hs, show c • _ = c • _, from congr_arg ((•) c) (measure_preimage_smul μ a hs)⟩

@[to_additive] instance smul_nnreal [smul_invariant_measure M α μ] (c : ℝ≥0) :
  smul_invariant_measure M α (c • μ) :=
smul_invariant_measure.smul c

end smul_invariant_measure

variables (G) {m : measurable_space α} [group G] [mul_action G α] [measurable_space G]
  [has_measurable_smul G α] (c : G) (μ : measure α)

/-- Equivalent definitions of a measure invariant under a multiplicative action of a group.

- 0: `smul_invariant_measure G α μ`;

- 1: for every `c : G` and a measurable set `s`, the measure of the preimage of `s` under scalar
     multiplication by `c` is equal to the measure of `s`;

- 2: for every `c : G` and a measurable set `s`, the measure of the image `c • s` of `s` under
     scalar multiplication by `c` is equal to the measure of `s`;

- 3, 4: properties 2, 3 for any set, including non-measurable ones;

- 5: for any `c : G`, scalar multiplication by `c` maps `μ` to `μ`;

- 6: for any `c : G`, scalar multiplication by `c` is a measure preserving map. -/
@[to_additive] lemma smul_invariant_measure_tfae :
  tfae [smul_invariant_measure G α μ,
    ∀ (c : G) s, measurable_set s → μ (((•) c) ⁻¹' s) = μ s,
    ∀ (c : G) s, measurable_set s → μ (c • s) = μ s,
    ∀ (c : G) s, μ (((•) c) ⁻¹' s) = μ s,
    ∀ (c : G) s, μ (c • s) = μ s,
    ∀ c : G, measure.map ((•) c) μ = μ,
    ∀ c : G, measure_preserving ((•) c) μ μ] :=
begin
  tfae_have : 1 ↔ 2, from ⟨λ h, h.1, λ h, ⟨h⟩⟩,
  tfae_have : 2 → 6,
    from λ H c, ext (λ s hs, by rw [map_apply (measurable_const_smul c) hs, H _ _ hs]),
  tfae_have : 6 → 7, from λ H c, ⟨measurable_const_smul c, H c⟩,
  tfae_have : 7 → 4, from λ H c, (H c).measure_preimage_emb (measurable_embedding_const_smul c),
  tfae_have : 4 → 5, from λ H c s, by { rw [← preimage_smul_inv], apply H },
  tfae_have : 5 → 3, from λ H c s hs, H c s,
  tfae_have : 3 → 2, { intros H c s hs, rw preimage_smul, exact H c⁻¹ s hs },
  tfae_finish
end

/-- Equivalent definitions of a measure invariant under an additive action of a group.

- 0: `vadd_invariant_measure G α μ`;

- 1: for every `c : G` and a measurable set `s`, the measure of the preimage of `s` under
     vector addition `(+ᵥ) c` is equal to the measure of `s`;

- 2: for every `c : G` and a measurable set `s`, the measure of the image `c +ᵥ s` of `s` under
     vector addition `(+ᵥ) c` is equal to the measure of `s`;

- 3, 4: properties 2, 3 for any set, including non-measurable ones;

- 5: for any `c : G`, vector addition of `c` maps `μ` to `μ`;

- 6: for any `c : G`, vector addition of `c` is a measure preserving map. -/
add_decl_doc vadd_invariant_measure_tfae

variables {G} [smul_invariant_measure G α μ]

@[to_additive] lemma measure_preserving_smul : measure_preserving ((•) c) μ μ :=
((smul_invariant_measure_tfae G μ).out 0 6).mp ‹_› c

@[simp, to_additive] lemma map_smul : map ((•) c) μ = μ :=
(measure_preserving_smul c μ).map_eq

@[simp, to_additive] lemma measure_preimage_smul (s : set α) : μ ((•) c ⁻¹' s) = μ s :=
((smul_invariant_measure_tfae G μ).out 0 3).mp ‹_› c s

@[simp, to_additive] lemma measure_smul_set (s : set α) : μ (c • s) = μ s :=
((smul_invariant_measure_tfae G μ).out 0 4).mp ‹_› c s

section is_minimal

variables (G) {μ} [topological_space G] [topological_space α] [has_continuous_smul G α]
  [mul_action.is_minimal G α] {K U : set α}

/-- If measure `μ` is invariant under a group action and is nonzero on a compact set `K`, then it is
positive on any nonempty open set. In case of a regular measure, one can assume `μ ≠ 0` instead of
`μ K ≠ 0`, see `measure_theory.measure_is_open_pos_of_smul_invariant_of_ne_zero`. -/
@[to_additive] lemma measure_is_open_pos_of_smul_invariant_of_compact_ne_zero (hK : is_compact K)
  (hμK : μ K ≠ 0) (hU : is_open U) (hne : U.nonempty) : 0 < μ U :=
let ⟨t, ht⟩ := hK.exists_finite_cover_smul G hU hne
in pos_iff_ne_zero.2 $ λ hμU, hμK $ measure_mono_null ht $
  (measure_bUnion_null_iff t.countable_to_set).2 $ λ _ _, by rwa measure_smul_set

/-- If measure `μ` is invariant under an additive group action and is nonzero on a compact set `K`,
then it is positive on any nonempty open set. In case of a regular measure, one can assume `μ ≠ 0`
instead of `μ K ≠ 0`, see `measure_theory.measure_is_open_pos_of_vadd_invariant_of_ne_zero`. -/
add_decl_doc measure_is_open_pos_of_vadd_invariant_of_compact_ne_zero

@[to_additive] lemma is_locally_finite_measure_of_smul_invariant (hU : is_open U) (hne : U.nonempty)
  (hμU : μ U ≠ ∞) : is_locally_finite_measure μ :=
⟨λ x, let ⟨g, hg⟩ := hU.exists_smul_mem G x hne in
  ⟨(•) g ⁻¹' U, (hU.preimage (continuous_id.const_smul _)).mem_nhds hg, ne.lt_top $
    by rwa [measure_preimage_smul]⟩⟩

variables [measure.regular μ]

@[to_additive] lemma measure_is_open_pos_of_smul_invariant_of_ne_zero (hμ : μ ≠ 0) (hU : is_open U)
  (hne : U.nonempty) : 0 < μ U :=
let ⟨K, hK, hμK⟩ := regular.exists_compact_not_null.mpr hμ
in measure_is_open_pos_of_smul_invariant_of_compact_ne_zero G hK hμK hU hne

@[to_additive] lemma measure_pos_iff_nonempty_of_smul_invariant (hμ : μ ≠ 0) (hU : is_open U) :
  0 < μ U ↔ U.nonempty :=
⟨λ h, nonempty_of_measure_ne_zero h.ne', measure_is_open_pos_of_smul_invariant_of_ne_zero G hμ hU⟩

include G

@[to_additive] lemma measure_eq_zero_iff_eq_empty_of_smul_invariant (hμ : μ ≠ 0) (hU : is_open U) :
  μ U = 0 ↔ U = ∅ :=
by rw [← not_iff_not, ← ne.def, ← pos_iff_ne_zero,
  measure_pos_iff_nonempty_of_smul_invariant G hμ hU, ← ne_empty_iff_nonempty]

end is_minimal

end measure_theory


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import algebra.group.ext
import category_theory.simple
import category_theory.linear
import category_theory.endomorphism
import algebra.algebra.spectrum

/-!
# Schur's lemma
We first prove the part of Schur's Lemma that holds in any preadditive category with kernels,
that any nonzero morphism between simple objects
is an isomorphism.

Second, we prove Schur's lemma for `𝕜`-linear categories with finite dimensional hom spaces,
over an algebraically closed field `𝕜`:
the hom space `X ⟶ Y` between simple objects `X` and `Y` is at most one dimensional,
and is 1-dimensional iff `X` and `Y` are isomorphic.
-/

namespace category_theory

open category_theory.limits

variables {C : Type*} [category C]
variables [preadditive C]

-- See also `epi_of_nonzero_to_simple`, which does not require `preadditive C`.
lemma mono_of_nonzero_from_simple [has_kernels C] {X Y : C} [simple X] {f : X ⟶ Y} (w : f ≠ 0) :
  mono f :=
preadditive.mono_of_kernel_zero (kernel_zero_of_nonzero_from_simple w)

/--
The part of **Schur's lemma** that holds in any preadditive category with kernels:
that a nonzero morphism between simple objects is an isomorphism.
-/
lemma is_iso_of_hom_simple [has_kernels C] {X Y : C} [simple X] [simple Y] {f : X ⟶ Y} (w : f ≠ 0) :
  is_iso f :=
begin
  haveI := mono_of_nonzero_from_simple w,
  exact is_iso_of_mono_of_nonzero w
end

/--
As a corollary of Schur's lemma for preadditive categories,
any morphism between simple objects is (exclusively) either an isomorphism or zero.
-/
lemma is_iso_iff_nonzero [has_kernels C] {X Y : C} [simple X] [simple Y] (f : X ⟶ Y) :
  is_iso f ↔ f ≠ 0 :=
⟨λ I,
  begin
    introI h,
    apply id_nonzero X,
    simp only [←is_iso.hom_inv_id f, h, zero_comp],
  end,
  λ w, is_iso_of_hom_simple w⟩

/--
In any preadditive category with kernels,
the endomorphisms of a simple object form a division ring.
-/
noncomputable
instance [has_kernels C] {X : C} [simple X] : division_ring (End X) :=
by classical; exact
{ inv := λ f, if h : f = 0 then 0 else by { haveI := is_iso_of_hom_simple h, exact inv f, },
  exists_pair_ne := ⟨𝟙 X, 0, id_nonzero _⟩,
  inv_zero := dif_pos rfl,
  mul_inv_cancel := λ f h, begin
    haveI := is_iso_of_hom_simple h,
    convert is_iso.inv_hom_id f,
    exact dif_neg h,
  end,
  ..(infer_instance : ring (End X)) }

open finite_dimensional

section
variables (𝕜 : Type*) [division_ring 𝕜]

/--
Part of **Schur's lemma** for `𝕜`-linear categories:
the hom space between two non-isomorphic simple objects is 0-dimensional.
-/
lemma finrank_hom_simple_simple_eq_zero_of_not_iso
  [has_kernels C] [linear 𝕜 C] {X Y : C} [simple X] [simple Y]
  (h : (X ≅ Y) → false):
  finrank 𝕜 (X ⟶ Y) = 0 :=
begin
  haveI := subsingleton_of_forall_eq (0 : X ⟶ Y) (λ f, begin
    have p := not_congr (is_iso_iff_nonzero f),
    simp only [not_not, ne.def] at p,
    refine p.mp (λ _, by exactI h (as_iso f)),
  end),
  exact finrank_zero_of_subsingleton,
end

end

variables (𝕜 : Type*) [field 𝕜]
variables [is_alg_closed 𝕜] [linear 𝕜 C]

-- In the proof below we have some difficulty using `I : finite_dimensional 𝕜 (X ⟶ X)`
-- where we need a `finite_dimensional 𝕜 (End X)`.
-- These are definitionally equal, but without eta reduction Lean can't see this.
-- To get around this, we use `convert I`,
-- then check the various instances agree field-by-field,

/--
An auxiliary lemma for Schur's lemma.

If `X ⟶ X` is finite dimensional, and every nonzero endomorphism is invertible,
then `X ⟶ X` is 1-dimensional.
-/
-- We prove this with the explicit `is_iso_iff_nonzero` assumption,
-- rather than just `[simple X]`, as this form is useful for
-- Müger's formulation of semisimplicity.
lemma finrank_endomorphism_eq_one
  {X : C} (is_iso_iff_nonzero : ∀ f : X ⟶ X, is_iso f ↔ f ≠ 0)
  [I : finite_dimensional 𝕜 (X ⟶ X)] :
  finrank 𝕜 (X ⟶ X) = 1 :=
begin
  have id_nonzero := (is_iso_iff_nonzero (𝟙 X)).mp (by apply_instance),
  apply finrank_eq_one (𝟙 X),
  { exact id_nonzero, },
  { intro f,
    haveI : nontrivial (End X) := nontrivial_of_ne _ _ id_nonzero,
    obtain ⟨c, nu⟩ := @spectrum.nonempty_of_is_alg_closed_of_finite_dimensional 𝕜 (End X) _ _ _ _ _
      (by { convert I, ext, refl, ext, refl, }) (End.of f),
    use c,
    rw [spectrum.mem_iff, is_unit.sub_iff, is_unit_iff_is_iso, is_iso_iff_nonzero, ne.def,
      not_not, sub_eq_zero, algebra.algebra_map_eq_smul_one] at nu,
    exact nu.symm, },
end

variables [has_kernels C]

/--
**Schur's lemma** for endomorphisms in `𝕜`-linear categories.
-/
lemma finrank_endomorphism_simple_eq_one
  (X : C) [simple X] [I : finite_dimensional 𝕜 (X ⟶ X)] :
  finrank 𝕜 (X ⟶ X) = 1 :=
finrank_endomorphism_eq_one 𝕜 is_iso_iff_nonzero

lemma endomorphism_simple_eq_smul_id
  {X : C} [simple X] [I : finite_dimensional 𝕜 (X ⟶ X)] (f : X ⟶ X) :
  ∃ c : 𝕜, c • 𝟙 X = f :=
(finrank_eq_one_iff_of_nonzero' (𝟙 X) (id_nonzero X)).mp (finrank_endomorphism_simple_eq_one 𝕜 X) f

/--
Endomorphisms of a simple object form a field if they are finite dimensional.
This can't be an instance as `𝕜` would be undetermined.
-/
noncomputable
def field_End_of_finite_dimensional (X : C) [simple X] [I : finite_dimensional 𝕜 (X ⟶ X)] :
  field (End X) :=
by classical; exact
{ mul_comm := λ f g, begin
    obtain ⟨c, rfl⟩ := endomorphism_simple_eq_smul_id 𝕜 f,
    obtain ⟨d, rfl⟩ := endomorphism_simple_eq_smul_id 𝕜 g,
    simp [←mul_smul, mul_comm c d],
  end,
  ..(infer_instance : division_ring (End X)) }

/--
**Schur's lemma** for `𝕜`-linear categories:
if hom spaces are finite dimensional, then the hom space between simples is at most 1-dimensional.

See `finrank_hom_simple_simple_eq_one_iff` and `finrank_hom_simple_simple_eq_zero_iff` below
for the refinements when we know whether or not the simples are isomorphic.
-/
-- There is a symmetric argument that uses `[finite_dimensional 𝕜 (Y ⟶ Y)]` instead,
-- but we don't bother proving that here.
lemma finrank_hom_simple_simple_le_one
  (X Y : C) [finite_dimensional 𝕜 (X ⟶ X)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) ≤ 1 :=
begin
  cases subsingleton_or_nontrivial (X ⟶ Y) with h,
  { resetI,
    rw finrank_zero_of_subsingleton,
    exact zero_le_one },
  { obtain ⟨f, nz⟩ := (nontrivial_iff_exists_ne 0).mp h,
    haveI fi := (is_iso_iff_nonzero f).mpr nz,
    apply finrank_le_one f,
    intro g,
    obtain ⟨c, w⟩ := endomorphism_simple_eq_smul_id 𝕜 (g ≫ inv f),
    exact ⟨c, by simpa using w =≫ f⟩, },
end

lemma finrank_hom_simple_simple_eq_one_iff
  (X Y : C) [finite_dimensional 𝕜 (X ⟶ X)] [finite_dimensional 𝕜 (X ⟶ Y)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) = 1 ↔ nonempty (X ≅ Y) :=
begin
  fsplit,
  { intro h,
    rw finrank_eq_one_iff' at h,
    obtain ⟨f, nz, -⟩ := h,
    rw ←is_iso_iff_nonzero at nz,
    exactI ⟨as_iso f⟩, },
  { rintro ⟨f⟩,
    have le_one := finrank_hom_simple_simple_le_one 𝕜 X Y,
    have zero_lt : 0 < finrank 𝕜 (X ⟶ Y) :=
      finrank_pos_iff_exists_ne_zero.mpr ⟨f.hom, (is_iso_iff_nonzero f.hom).mp infer_instance⟩,
    linarith, }
end

lemma finrank_hom_simple_simple_eq_zero_iff
  (X Y : C) [finite_dimensional 𝕜 (X ⟶ X)] [finite_dimensional 𝕜 (X ⟶ Y)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) = 0 ↔ is_empty (X ≅ Y) :=
begin
  rw [← not_nonempty_iff, ← not_congr (finrank_hom_simple_simple_eq_one_iff 𝕜 X Y)],
  refine ⟨λ h, by { rw h, simp, }, λ h, _⟩,
  have := finrank_hom_simple_simple_le_one 𝕜 X Y,
  interval_cases finrank 𝕜 (X ⟶ Y) with h',
  { exact h', },
  { exact false.elim (h h'), },
end

end category_theory


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Andrew Yang

! This file was ported from Lean 3 source module category_theory.limits.constructions.equalizers
! leanprover-community/mathlib commit 3424a5932a77dcec2c177ce7d805acace6149299
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.Shapes.Equalizers
import Mathlib.CategoryTheory.Limits.Shapes.BinaryProducts
import Mathlib.CategoryTheory.Limits.Shapes.Pullbacks
import Mathlib.CategoryTheory.Limits.Preserves.Shapes.Pullbacks
import Mathlib.CategoryTheory.Limits.Preserves.Shapes.BinaryProducts

/-!
# Constructing equalizers from pullbacks and binary products.

If a category has pullbacks and binary products, then it has equalizers.

TODO: generalize universe
-/

noncomputable section

universe v v' u u'

open CategoryTheory CategoryTheory.Category

namespace CategoryTheory.Limits

variable {C : Type u} [Category.{v} C]

variable {D : Type u'} [Category.{v'} D] (G : C ⥤ D)

-- We hide the "implementation details" inside a namespace
namespace HasEqualizersOfHasPullbacksAndBinaryProducts

variable [HasBinaryProducts C] [HasPullbacks C]

/-- Define the equalizing object -/
@[reducible]
def constructEqualizer (F : WalkingParallelPair ⥤ C) : C :=
  pullback (prod.lift (𝟙 _) (F.map WalkingParallelPairHom.left))
    (prod.lift (𝟙 _) (F.map WalkingParallelPairHom.right))
#align category_theory.limits.has_equalizers_of_has_pullbacks_and_binary_products.construct_equalizer CategoryTheory.Limits.HasEqualizersOfHasPullbacksAndBinaryProducts.constructEqualizer

/-- Define the equalizing morphism -/
abbrev pullbackFst (F : WalkingParallelPair ⥤ C) :
    constructEqualizer F ⟶ F.obj WalkingParallelPair.zero :=
  pullback.fst
#align category_theory.limits.has_equalizers_of_has_pullbacks_and_binary_products.pullback_fst CategoryTheory.Limits.HasEqualizersOfHasPullbacksAndBinaryProducts.pullbackFst

theorem pullbackFst_eq_pullback_snd (F : WalkingParallelPair ⥤ C) : pullbackFst F = pullback.snd :=
  by convert (eq_whisker pullback.condition Limits.prod.fst :
      (_ : constructEqualizer F ⟶  F.obj WalkingParallelPair.zero) = _) <;> simp
#align category_theory.limits.has_equalizers_of_has_pullbacks_and_binary_products.pullback_fst_eq_pullback_snd CategoryTheory.Limits.HasEqualizersOfHasPullbacksAndBinaryProducts.pullbackFst_eq_pullback_snd

/-- Define the equalizing cone -/
@[reducible]
def equalizerCone (F : WalkingParallelPair ⥤ C) : Cone F :=
  Cone.ofFork
    (Fork.ofι (pullbackFst F)
      (by
        conv_rhs => rw [pullbackFst_eq_pullback_snd]
        convert (eq_whisker pullback.condition Limits.prod.snd :
          (_ : constructEqualizer F ⟶  F.obj WalkingParallelPair.one) = _) using 1 <;> simp))
#align category_theory.limits.has_equalizers_of_has_pullbacks_and_binary_products.equalizer_cone CategoryTheory.Limits.HasEqualizersOfHasPullbacksAndBinaryProducts.equalizerCone

/-- Show the equalizing cone is a limit -/
def equalizerConeIsLimit (F : WalkingParallelPair ⥤ C) : IsLimit (equalizerCone F) where
  lift := by
    intro c; apply pullback.lift (c.π.app _) (c.π.app _)
    apply limit.hom_ext
    rintro (_ | _) <;> simp
  fac := by rintro c (_ | _) <;> simp
  uniq := by
    intro c _ J
    have J0 := J WalkingParallelPair.zero; simp at J0
    apply pullback.hom_ext
    · rwa [limit.lift_π]
    · erw [limit.lift_π, ← J0, pullbackFst_eq_pullback_snd]
#align category_theory.limits.has_equalizers_of_has_pullbacks_and_binary_products.equalizer_cone_is_limit CategoryTheory.Limits.HasEqualizersOfHasPullbacksAndBinaryProducts.equalizerConeIsLimit

end HasEqualizersOfHasPullbacksAndBinaryProducts

open HasEqualizersOfHasPullbacksAndBinaryProducts

-- This is not an instance, as it is not always how one wants to construct equalizers!
/-- Any category with pullbacks and binary products, has equalizers. -/
theorem hasEqualizers_of_hasPullbacks_and_binary_products [HasBinaryProducts C] [HasPullbacks C] :
    HasEqualizers C :=
  { has_limit := fun F =>
      HasLimit.mk
        { cone := equalizerCone F
          isLimit := equalizerConeIsLimit F } }
#align category_theory.limits.has_equalizers_of_has_pullbacks_and_binary_products CategoryTheory.Limits.hasEqualizers_of_hasPullbacks_and_binary_products

attribute [local instance] hasPullback_of_preservesPullback

/-- A functor that preserves pullbacks and binary products also presrves equalizers. -/
def preservesEqualizersOfPreservesPullbacksAndBinaryProducts [HasBinaryProducts C] [HasPullbacks C]
    [PreservesLimitsOfShape (Discrete WalkingPair) G] [PreservesLimitsOfShape WalkingCospan G] :
    PreservesLimitsOfShape WalkingParallelPair G :=
  ⟨fun {K} =>
    preservesLimitOfPreservesLimitCone (equalizerConeIsLimit K) <|
      { lift := fun c => by
          refine' pullback.lift ?_ ?_ ?_ ≫ (PreservesPullback.iso _ _ _ ).inv
          · exact c.π.app WalkingParallelPair.zero
          · exact c.π.app WalkingParallelPair.zero
          apply (mapIsLimitOfPreservesOfIsLimit G _ _ (prodIsProd _ _)).hom_ext
          rintro (_ | _)
          · simp only [Category.assoc, ← G.map_comp, prod.lift_fst, BinaryFan.π_app_left,
              BinaryFan.mk_fst]
          · simp only [BinaryFan.π_app_right, BinaryFan.mk_snd, Category.assoc, ← G.map_comp,
              prod.lift_snd]
            exact
              (c.π.naturality WalkingParallelPairHom.left).symm.trans
                (c.π.naturality WalkingParallelPairHom.right)
        fac := fun c j =>
          by
          rcases j with (_ | _) <;>
            simp only [Category.comp_id, PreservesPullback.iso_inv_fst, Cone.ofFork_π, G.map_comp,
              PreservesPullback.iso_inv_fst_assoc, Functor.mapCone_π_app, eqToHom_refl,
              Category.assoc, Fork.ofι_π_app, pullback.lift_fst, pullback.lift_fst_assoc]
          exact (c.π.naturality WalkingParallelPairHom.left).symm.trans (Category.id_comp _)
        uniq := fun s m h => by
          rw [Iso.eq_comp_inv]
          have := h WalkingParallelPair.zero
          dsimp [equalizerCone] at this
          apply pullback.hom_ext <;>
            simp only [PreservesPullback.iso_hom_snd, Category.assoc,
              PreservesPullback.iso_hom_fst, pullback.lift_fst, pullback.lift_snd,
              Category.comp_id, ← pullbackFst_eq_pullback_snd, ← this] }⟩
#align category_theory.limits.preserves_equalizers_of_preserves_pullbacks_and_binary_products CategoryTheory.Limits.preservesEqualizersOfPreservesPullbacksAndBinaryProducts

-- We hide the "implementation details" inside a namespace
namespace HasCoequalizersOfHasPushoutsAndBinaryCoproducts

variable [HasBinaryCoproducts C] [HasPushouts C]

/-- Define the equalizing object -/
@[reducible]
def constructCoequalizer (F : WalkingParallelPair ⥤ C) : C :=
  pushout (coprod.desc (𝟙 _) (F.map WalkingParallelPairHom.left))
    (coprod.desc (𝟙 _) (F.map WalkingParallelPairHom.right))
#align category_theory.limits.has_coequalizers_of_has_pushouts_and_binary_coproducts.construct_coequalizer CategoryTheory.Limits.HasCoequalizersOfHasPushoutsAndBinaryCoproducts.constructCoequalizer

/-- Define the equalizing morphism -/
abbrev pushoutInl (F : WalkingParallelPair ⥤ C) :
    F.obj WalkingParallelPair.one ⟶ constructCoequalizer F :=
  pushout.inl
#align category_theory.limits.has_coequalizers_of_has_pushouts_and_binary_coproducts.pushout_inl CategoryTheory.Limits.HasCoequalizersOfHasPushoutsAndBinaryCoproducts.pushoutInl

theorem pushoutInl_eq_pushout_inr (F : WalkingParallelPair ⥤ C) : pushoutInl F = pushout.inr := by
  convert (whisker_eq Limits.coprod.inl pushout.condition :
    (_ : F.obj _ ⟶  constructCoequalizer _) = _) <;> simp
#align category_theory.limits.has_coequalizers_of_has_pushouts_and_binary_coproducts.pushout_inl_eq_pushout_inr CategoryTheory.Limits.HasCoequalizersOfHasPushoutsAndBinaryCoproducts.pushoutInl_eq_pushout_inr

/-- Define the equalizing cocone -/
@[reducible]
def coequalizerCocone (F : WalkingParallelPair ⥤ C) : Cocone F :=
  Cocone.ofCofork
    (Cofork.ofπ (pushoutInl F) (by
        conv_rhs => rw [pushoutInl_eq_pushout_inr]
        convert (whisker_eq Limits.coprod.inr pushout.condition
          : (_ : F.obj _ ⟶  constructCoequalizer _) = _) using 1 <;> simp))
#align category_theory.limits.has_coequalizers_of_has_pushouts_and_binary_coproducts.coequalizer_cocone CategoryTheory.Limits.HasCoequalizersOfHasPushoutsAndBinaryCoproducts.coequalizerCocone

/-- Show the equalizing cocone is a colimit -/
def coequalizerCoconeIsColimit (F : WalkingParallelPair ⥤ C) : IsColimit (coequalizerCocone F) where
  desc := by
    intro c; apply pushout.desc (c.ι.app _) (c.ι.app _)
    apply colimit.hom_ext
    rintro (_ | _) <;> simp
  fac := by rintro c (_ | _) <;> simp
  uniq := by
    intro c m J
    have J1 : pushoutInl F ≫ m = c.ι.app WalkingParallelPair.one := by
      simpa using J WalkingParallelPair.one
    apply pushout.hom_ext
    · rw [colimit.ι_desc]
      exact J1
    · rw [colimit.ι_desc, ← pushoutInl_eq_pushout_inr]
      exact J1
#align category_theory.limits.has_coequalizers_of_has_pushouts_and_binary_coproducts.coequalizer_cocone_is_colimit CategoryTheory.Limits.HasCoequalizersOfHasPushoutsAndBinaryCoproducts.coequalizerCoconeIsColimit

end HasCoequalizersOfHasPushoutsAndBinaryCoproducts

open HasCoequalizersOfHasPushoutsAndBinaryCoproducts

-- This is not an instance, as it is not always how one wants to construct equalizers!
/-- Any category with pullbacks and binary products, has equalizers. -/
theorem hasCoequalizers_of_hasPushouts_and_binary_coproducts [HasBinaryCoproducts C]
    [HasPushouts C] : HasCoequalizers C :=
  {
    has_colimit := fun F =>
      HasColimit.mk
        { cocone := coequalizerCocone F
          isColimit := coequalizerCoconeIsColimit F } }
#align category_theory.limits.has_coequalizers_of_has_pushouts_and_binary_coproducts CategoryTheory.Limits.hasCoequalizers_of_hasPushouts_and_binary_coproducts

attribute [local instance] hasPushout_of_preservesPushout

/-- A functor that preserves pushouts and binary coproducts also presrves coequalizers. -/
def preservesCoequalizersOfPreservesPushoutsAndBinaryCoproducts [HasBinaryCoproducts C]
    [HasPushouts C] [PreservesColimitsOfShape (Discrete WalkingPair) G]
    [PreservesColimitsOfShape WalkingSpan G] : PreservesColimitsOfShape WalkingParallelPair G :=
  ⟨fun {K} =>
    preservesColimitOfPreservesColimitCocone (coequalizerCoconeIsColimit K) <|
      { desc := fun c =>
          by
          refine' (PreservesPushout.iso _ _ _).inv ≫ pushout.desc _ _ _
          · exact c.ι.app WalkingParallelPair.one
          · exact c.ι.app WalkingParallelPair.one
          apply (mapIsColimitOfPreservesOfIsColimit G _ _ (coprodIsCoprod _ _)).hom_ext
          rintro (_ | _)
          · simp only [BinaryCofan.ι_app_left, BinaryCofan.mk_inl, Category.assoc, ←
              G.map_comp_assoc, coprod.inl_desc]
          · simp only [BinaryCofan.ι_app_right, BinaryCofan.mk_inr, Category.assoc, ←
              G.map_comp_assoc, coprod.inr_desc]
            exact
              (c.ι.naturality WalkingParallelPairHom.left).trans
                (c.ι.naturality WalkingParallelPairHom.right).symm
        fac := fun c j =>
          by
          rcases j with (_ | _) <;>
            simp only [Functor.mapCocone_ι_app, Cocone.ofCofork_ι, Category.id_comp,
              eqToHom_refl, Category.assoc, Functor.map_comp, Cofork.ofπ_ι_app, pushout.inl_desc,
              PreservesPushout.inl_iso_inv_assoc]
          exact (c.ι.naturality WalkingParallelPairHom.left).trans (Category.comp_id _)
        uniq := fun s m h => by
          rw [Iso.eq_inv_comp]
          have := h WalkingParallelPair.one
          dsimp [coequalizerCocone] at this
          apply pushout.hom_ext <;>
            simp only [PreservesPushout.inl_iso_hom_assoc, Category.id_comp, pushout.inl_desc,
              pushout.inr_desc, PreservesPushout.inr_iso_hom_assoc, ← pushoutInl_eq_pushout_inr, ←
              this] }⟩
#align category_theory.limits.preserves_coequalizers_of_preserves_pushouts_and_binary_coproducts CategoryTheory.Limits.preservesCoequalizersOfPreservesPushoutsAndBinaryCoproducts

end CategoryTheory.Limits