/-
Copyright (c) 2022 Jakob von Raumer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jakob von Raumer, Kevin Klinge
-/
import group_theory.monoid_localization
import ring_theory.non_zero_divisors
import ring_theory.ore_localization.ore_set
import tactic.noncomm_ring

/-!

# Localization over right Ore sets.

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

This file defines the localization of a monoid over a right Ore set and proves its universal
mapping property. It then extends the definition and its properties first to semirings and then
to rings. We show that in the case of a commutative monoid this definition coincides with the
common monoid localization. Finally we show that in a ring without zero divisors, taking the Ore
localization at `R - {0}` results in a division ring.

## Notations

Introduces the notation `R[S⁻¹]` for the Ore localization of a monoid `R` at a right Ore
subset `S`. Also defines a new heterogeneos division notation `r /ₒ s` for a numerator `r : R` and
a denominator `s : S`.

## References

* <https://ncatlab.org/nlab/show/Ore+localization>
* [Zoran Škoda, *Noncommutative localization in noncommutative geometry*][skoda2006]

## Tags
localization, Ore, non-commutative

-/

universe u

open ore_localization

namespace ore_localization

variables (R : Type*) [monoid R] (S : submonoid R) [ore_set S]

/-- The setoid on `R × S` used for the Ore localization. -/
def ore_eqv : setoid (R × S) :=
{ r := λ rs rs', ∃ (u : S) (v : R), rs'.1 * u = rs.1 * v
                            ∧ (rs'.2 : R) * u = rs.2 * v,
  iseqv :=
  begin
    refine ⟨_, _, _⟩,
    { rintro ⟨r,s⟩, use 1, use 1, simp [submonoid.one_mem] },
    { rintros ⟨r, s⟩ ⟨r', s'⟩ ⟨u, v, hru, hsu⟩,
      rcases ore_condition (s : R) s' with ⟨r₂, s₂, h₁⟩,
      rcases ore_condition r₂ u with ⟨r₃, s₃, h₂⟩,
      have : (s : R) * ((v : R) * r₃) = (s : R) * (s₂ * s₃),
      { assoc_rw [h₁, h₂, hsu], symmetry, apply mul_assoc },
      rcases ore_left_cancel (v * r₃) (s₂ * s₃) s this with ⟨w, hw⟩,
      use s₂ * s₃ * w, use u * r₃ * w, split; simp only [submonoid.coe_mul],
      { assoc_rw [hru, ←hw], simp [mul_assoc] },
      { assoc_rw [hsu, ←hw], simp [mul_assoc] } },
    { rintros ⟨r₁, s₁⟩ ⟨r₂, s₂⟩ ⟨r₃, s₃⟩ ⟨u, v, hur₁, hs₁u⟩ ⟨u', v', hur₂, hs₂u⟩,
      rcases ore_condition v' u with ⟨r', s', h⟩,
      use u' * s', use v * r', split; simp only [submonoid.coe_mul],
      { assoc_rw [hur₂, h, hur₁, mul_assoc] },
      { assoc_rw [hs₂u, h, hs₁u, mul_assoc] } }
  end }

end ore_localization

/-- The ore localization of a monoid and a submonoid fulfilling the ore condition. -/
def ore_localization (R : Type*) [monoid R] (S : submonoid R) [ore_set S] :=
quotient (ore_localization.ore_eqv R S)

namespace ore_localization

section monoid

variables {R : Type*} [monoid R] {S : submonoid R}

variables (R S) [ore_set S]

notation R `[`:1075 S `⁻¹]`:1075 := ore_localization R S

local attribute [instance] ore_eqv

variables {R S}

/-- The division in the ore localization `R[S⁻¹]`, as a fraction of an element of `R` and `S`. -/
def ore_div (r : R) (s : S) : R[S⁻¹] := quotient.mk (r, s)

infixl ` /ₒ `:70 := ore_div

@[elab_as_eliminator]
protected lemma ind {β : R [S ⁻¹] → Prop} (c : ∀ (r : R) (s : S), β (r /ₒ s)) : ∀ q, β q :=
by { apply quotient.ind, rintro ⟨r, s⟩, exact c r s }

lemma ore_div_eq_iff {r₁ r₂ : R} {s₁ s₂ : S} :
  r₁ /ₒ s₁ = r₂ /ₒ s₂ ↔ (∃ (u : S) (v : R), r₂ * u = r₁ * v ∧ (s₂ : R) * u = s₁ * v) :=
quotient.eq'

/-- A fraction `r /ₒ s` is equal to its expansion by an arbitrary factor `t` if `s * t ∈ S`. -/
protected lemma expand (r : R) (s : S) (t : R) (hst : (s : R) * t ∈ S) :
  r /ₒ s = (r * t) /ₒ (⟨s * t, hst⟩) :=
by { apply quotient.sound, refine ⟨s, t * s, _, _⟩; dsimp; rw [mul_assoc]; refl }

/-- A fraction is equal to its expansion by an factor from s. -/
protected lemma expand' (r : R) (s s' : S) : r /ₒ s = (r * s') /ₒ (s * s') :=
ore_localization.expand r s s' (by norm_cast; apply set_like.coe_mem)

/-- Fractions which differ by a factor of the numerator can be proven equal if
those factors expand to equal elements of `R`. -/
protected lemma eq_of_num_factor_eq {r r' r₁ r₂ : R} {s t : S}
  (h : r * t = r' * t) : (r₁ * r * r₂) /ₒ s = (r₁ * r' * r₂) /ₒ s :=
begin
  rcases ore_condition r₂ t with ⟨r₂',t', hr₂⟩,
  calc (r₁ * r * r₂) /ₒ s = (r₁ * r * r₂ * t') /ₒ (s * t') : ore_localization.expand _ _ t' _
  ...                     = ((r₁ * r) * (r₂ * t')) /ₒ (s * t') : by simp [←mul_assoc]
  ...                     = ((r₁ * r) * (t * r₂')) /ₒ (s * t') : by rw hr₂
  ...                     = (r₁ * (r * t) * r₂') /ₒ (s * t') : by simp [←mul_assoc]
  ...                     = (r₁ * (r' * t) * r₂') /ₒ (s * t') : by rw h
  ...                     = (r₁ * r' * (t * r₂')) /ₒ (s * t') : by simp [←mul_assoc]
  ...                     = (r₁ * r' * (r₂ * t')) /ₒ (s * t') : by rw hr₂
  ...                     = (r₁ * r' * r₂ * t') /ₒ (s * t') : by simp [←mul_assoc]
  ...                     = (r₁ * r' * r₂) /ₒ s : by symmetry; apply ore_localization.expand
end

/-- A function or predicate over `R` and `S` can be lifted to `R[S⁻¹]` if it is invariant
under expansion on the right. -/
def lift_expand {C : Sort*} (P : R → S → C)
  (hP : ∀ (r t : R) (s : S) (ht : ((s : R) * t) ∈ S), P r s = P (r * t) ⟨s * t, ht⟩) :
  R[S⁻¹] → C :=
quotient.lift (λ (p : R × S), P p.1 p.2) $ λ p q pq,
begin
  cases p with r₁ s₁, cases q with r₂ s₂, rcases pq with ⟨u, v, hr₂, hs₂⟩,
  dsimp at *,
  have s₁vS : (s₁ : R) * v ∈ S,
  { rw [←hs₂, ←S.coe_mul], exact set_like.coe_mem (s₂ * u) },
  replace hs₂ : s₂ * u = ⟨(s₁ : R) * v, s₁vS⟩, { ext, simp [hs₂] },
  rw [hP r₁ v s₁ s₁vS, hP r₂ u s₂ (by { norm_cast, rw hs₂, assumption }), hr₂],
  simpa [← hs₂]
end

@[simp]
lemma lift_expand_of {C : Sort*} {P : R → S → C}
  {hP : ∀ (r t : R) (s : S) (ht : ((s : R) * t) ∈ S), P r s = P (r * t) ⟨s * t, ht⟩}
  (r : R) (s : S) :
  lift_expand P hP (r /ₒ s) = P r s := rfl

/-- A version of `lift_expand` used to simultaneously lift functions with two arguments
in ``R[S⁻¹]`.-/
def lift₂_expand {C : Sort*} (P : R → S → R → S → C)
  (hP : ∀ (r₁ t₁ : R) (s₁ : S) (ht₁ : (s₁ : R) * t₁ ∈ S)
          (r₂ t₂ : R) (s₂ : S) (ht₂ : (s₂ : R) * t₂ ∈ S),
    P r₁ s₁ r₂ s₂ = P (r₁ * t₁) ⟨s₁ * t₁, ht₁⟩ (r₂ * t₂) ⟨s₂ * t₂, ht₂⟩) : R[S⁻¹] → R[S⁻¹] → C :=
lift_expand
  (λ r₁ s₁, lift_expand (P r₁ s₁) $ λ r₂ t₂ s₂ ht₂, by simp [hP r₁ 1 s₁ (by simp) r₂ t₂ s₂ ht₂]) $
   λ r₁ t₁ s₁ ht₁,
   begin
     ext x, induction x using ore_localization.ind with r₂ s₂,
     rw [lift_expand_of, lift_expand_of, hP r₁ t₁ s₁ ht₁ r₂ 1 s₂ (by simp)], simp,
   end

@[simp]
lemma lift₂_expand_of {C : Sort*} {P : R → S → R → S → C}
  {hP : ∀ (r₁ t₁ : R) (s₁ : S) (ht₁ : (s₁ : R) * t₁ ∈ S)
          (r₂ t₂ : R) (s₂ : S) (ht₂ : (s₂ : R) * t₂ ∈ S),
    P r₁ s₁ r₂ s₂ = P (r₁ * t₁) ⟨s₁ * t₁, ht₁⟩ (r₂ * t₂) ⟨s₂ * t₂, ht₂⟩}
  (r₁ : R) (s₁ : S) (r₂ : R) (s₂ : S) :
  lift₂_expand P hP (r₁ /ₒ s₁) (r₂ /ₒ s₂) = P r₁ s₁ r₂ s₂ :=
rfl

private def mul' (r₁ : R) (s₁ : S) (r₂ : R) (s₂ : S) : R[S⁻¹] :=
  (r₁ * ore_num r₂ s₁) /ₒ (s₂ * ore_denom r₂ s₁)

private lemma mul'_char (r₁ r₂ : R) (s₁ s₂ : S) (u : S) (v : R) (huv : r₂ * (u : R) = s₁ * v) :
  mul' r₁ s₁ r₂ s₂ = (r₁ * v) /ₒ (s₂ * u) :=
begin
  simp only [mul'],
  have h₀ := ore_eq r₂ s₁, set v₀ := ore_num r₂ s₁, set u₀ := ore_denom r₂ s₁,
  rcases ore_condition (u₀ : R) u with ⟨r₃, s₃, h₃⟩,
  have :=
  calc (s₁ : R) * (v * r₃) = r₂ * u * r₃ : by assoc_rw ←huv; symmetry; apply mul_assoc
  ...                      = r₂ * u₀ * s₃ : by assoc_rw ←h₃; refl
  ...                      = s₁ * (v₀ * s₃) : by assoc_rw h₀; apply mul_assoc,
  rcases ore_left_cancel _ _ _ this with ⟨s₄, hs₄⟩,
  symmetry, rw ore_div_eq_iff,
  use s₃ * s₄, use r₃ * s₄, simp only [submonoid.coe_mul], split,
  { assoc_rw ←hs₄, simp only [mul_assoc] },
  { assoc_rw h₃, simp only [mul_assoc] }
end

/-- The multiplication on the Ore localization of monoids. -/
protected def mul : R[S⁻¹] → R[S⁻¹] → R[S⁻¹] :=
lift₂_expand mul' $ λ r₂ p s₂ hp r₁ r s₁ hr,
begin
  have h₁ := ore_eq r₁ s₂, set r₁' := ore_num r₁ s₂, set s₂' := ore_denom r₁ s₂,
  rcases ore_condition (↑s₂ * r₁') ⟨s₂ * p, hp⟩ with ⟨p', s_star, h₂⟩, dsimp at h₂,
  rcases ore_condition r (s₂' * s_star) with ⟨p_flat, s_flat, h₃⟩, simp only [S.coe_mul] at h₃,
  have : r₁ * r * s_flat = s₂ * p * (p' * p_flat),
  { rw [←mul_assoc, ←h₂, ←h₁, mul_assoc, h₃], simp only [mul_assoc] },
  rw mul'_char (r₂ * p) (r₁ * r) ⟨↑s₂ * p, hp⟩ ⟨↑s₁ * r, hr⟩ _ _ this, clear this,
  have hsssp : ↑s₁ * ↑s₂' * ↑s_star * p_flat ∈ S,
  { rw [mul_assoc, mul_assoc, ←mul_assoc ↑s₂', ←h₃, ←mul_assoc],
    exact S.mul_mem hr (set_like.coe_mem s_flat) },
  have : (⟨↑s₁ * r, hr⟩ : S) * s_flat = ⟨s₁ * s₂' * s_star * p_flat, hsssp⟩,
  { ext, simp only [set_like.coe_mk, submonoid.coe_mul],
    rw [mul_assoc, h₃, ←mul_assoc, ←mul_assoc] },
  rw this, clear this,
  rcases ore_left_cancel (p * p') (r₁' * ↑s_star) s₂ (by simp [←mul_assoc, h₂]) with ⟨s₂'', h₂''⟩,
  rw [←mul_assoc, mul_assoc r₂, ore_localization.eq_of_num_factor_eq h₂''],
  norm_cast at ⊢ hsssp, rw [←ore_localization.expand _ _ _ hsssp, ←mul_assoc],
  apply ore_localization.expand
end

instance : has_mul R[S⁻¹] := ⟨ore_localization.mul⟩

lemma ore_div_mul_ore_div {r₁ r₂ : R} {s₁ s₂ : S} :
  (r₁ /ₒ s₁) * (r₂ /ₒ s₂) = (r₁ * ore_num r₂ s₁) /ₒ (s₂ * ore_denom r₂ s₁) := rfl

/-- A characterization lemma for the multiplication on the Ore localization, allowing for a choice
of Ore numerator and Ore denominator. -/
lemma ore_div_mul_char (r₁ r₂ : R) (s₁ s₂ : S) (r' : R) (s' : S)
  (huv : r₂ * (s' : R) = s₁ * r') : (r₁ /ₒ s₁) * (r₂ /ₒ s₂) = (r₁ * r') /ₒ (s₂ * s') :=
mul'_char r₁ r₂ s₁ s₂ s' r' huv

/-- Another characterization lemma for the multiplication on the Ore localizaion delivering
Ore witnesses and conditions bundled in a sigma type. -/
def ore_div_mul_char' (r₁ r₂ : R) (s₁ s₂ : S) :
  Σ' r' : R, Σ' s' : S, r₂ * (s' : R) = s₁ * r'
                        ∧  (r₁ /ₒ s₁) * (r₂ /ₒ s₂) = (r₁ * r') /ₒ (s₂ * s') :=
⟨ore_num r₂ s₁, ore_denom r₂ s₁, ore_eq r₂ s₁, ore_div_mul_ore_div⟩

instance : has_one R[S⁻¹] := ⟨1 /ₒ 1⟩

protected lemma one_def : (1 : R[S⁻¹]) = 1 /ₒ 1 := rfl

instance : inhabited R[S⁻¹] := ⟨1⟩

@[simp]
protected lemma div_eq_one' {r : R} (hr : r ∈ S) : r /ₒ ⟨r, hr⟩ = 1 :=
by { rw [ore_localization.one_def, ore_div_eq_iff], exact ⟨⟨r, hr⟩, 1, by simp, by simp⟩ }

@[simp]
protected lemma div_eq_one {s : S} : (s : R) /ₒ s = 1 :=
by { cases s; apply ore_localization.div_eq_one' }

protected lemma one_mul (x : R[S⁻¹]) : 1 * x = x :=
begin
  induction x using ore_localization.ind with r s,
  simp [ore_localization.one_def, ore_div_mul_char (1 : R) r (1 : S) s r 1 (by simp)]
end

protected lemma mul_one (x : R[S⁻¹]) : x * 1 = x :=
begin
  induction x using ore_localization.ind with r s,
  simp [ore_localization.one_def, ore_div_mul_char r 1 s 1 1 s (by simp)]
end

protected lemma mul_assoc (x y z : R[S⁻¹]) : x * y * z = x * (y * z) :=
begin
  induction x using ore_localization.ind with r₁ s₁,
  induction y using ore_localization.ind with r₂ s₂,
  induction z using ore_localization.ind with r₃ s₃,
  rcases ore_div_mul_char' r₁ r₂ s₁ s₂ with ⟨ra, sa, ha, ha'⟩, rw ha', clear ha',
  rcases ore_div_mul_char' r₂ r₃ s₂ s₃ with ⟨rb, sb, hb, hb'⟩, rw hb', clear hb',
  rcases ore_condition rb sa with ⟨rc, sc, hc⟩,
  rw ore_div_mul_char (r₁ * ra) r₃ (s₂ * sa) s₃ rc (sb * sc)
    (by { simp only [submonoid.coe_mul], assoc_rw [hb, hc] }),
  rw [mul_assoc, ←mul_assoc s₃],
  symmetry, apply ore_div_mul_char,
  assoc_rw [hc, ←ha], apply mul_assoc
end

instance : monoid R[S⁻¹] :=
{ one_mul := ore_localization.one_mul,
  mul_one := ore_localization.mul_one,
  mul_assoc := ore_localization.mul_assoc,
  .. ore_localization.has_mul,
  .. ore_localization.has_one }

protected lemma mul_inv (s s' : S) : ((s : R) /ₒ s') * (s' /ₒ s) = 1 :=
by simp [ore_div_mul_char (s :R) s' s' s 1 1 (by simp)]

@[simp]
protected lemma mul_one_div {r : R} {s t : S} : (r /ₒ s) * (1 /ₒ t) = r /ₒ (t * s) :=
by simp [ore_div_mul_char r 1 s t 1 s (by simp)]

@[simp]
protected lemma mul_cancel {r : R} {s t : S} : (r /ₒ s) * (s /ₒ t) = r /ₒ t :=
by simp [ore_div_mul_char r s s t 1 1 (by simp)]

@[simp]
protected lemma mul_cancel' {r₁ r₂ : R} {s t : S} : (r₁ /ₒ s) * ((s * r₂) /ₒ t) = (r₁ * r₂) /ₒ t :=
by simp [ore_div_mul_char r₁ (s * r₂) s t r₂ 1 (by simp)]

@[simp]
lemma div_one_mul {p r : R} {s : S} :
  (r /ₒ 1) * (p /ₒ s) = (r * p) /ₒ s := --TODO use coercion r ↦ r /ₒ 1
by simp [ore_div_mul_char r p 1 s p 1 (by simp)]

/-- The fraction `s /ₒ 1` as a unit in `R[S⁻¹]`, where `s : S`. -/
def numerator_unit (s : S) : units R[S⁻¹] :=
{ val := (s : R) /ₒ 1,
  inv := (1 : R) /ₒ s,
  val_inv := ore_localization.mul_inv s 1,
  inv_val := ore_localization.mul_inv 1 s }

/-- The multiplicative homomorphism from `R` to `R[S⁻¹]`, mapping `r : R` to the
fraction `r /ₒ 1`. -/
def numerator_hom : R →* R[S⁻¹] :=
{ to_fun := λ r, r /ₒ 1,
  map_one' := rfl,
  map_mul' := λ r₁ r₂, div_one_mul.symm }

lemma numerator_hom_apply {r : R} : numerator_hom r = r /ₒ (1 : S) := rfl

lemma numerator_is_unit (s : S) : is_unit ((numerator_hom (s : R)) : R[S⁻¹]) :=
⟨numerator_unit s, rfl⟩

section UMP

variables {T : Type*} [monoid T]
variables (f : R →* T) (fS : S →* units T)
variables (hf : ∀ (s : S), f s = fS s)

include f fS hf

/-- The universal lift from a morphism `R →* T`, which maps elements of `S` to units of `T`,
to a morphism `R[S⁻¹] →* T`. -/
def universal_mul_hom : R[S⁻¹] →* T :=
{ to_fun := λ x, x.lift_expand (λ r s, (f r) * ((fS s)⁻¹ : units T)) $ λ r t s ht,
  begin
    have : ((fS ⟨s * t, ht⟩) : T) = fS s * f t,
    { simp only [←hf, set_like.coe_mk, monoid_hom.map_mul] },
    conv_rhs { rw [monoid_hom.map_mul, ←mul_one (f r), ←units.coe_one, ←mul_left_inv (fS s)],
      rw [units.coe_mul, ←mul_assoc, mul_assoc _ ↑(fS s), ←this, mul_assoc] },
    simp only [mul_one, units.mul_inv]
  end,
  map_one' := by rw [ore_localization.one_def, lift_expand_of]; simp,
  map_mul' := λ x y,
  begin
    induction x using ore_localization.ind with r₁ s₁,
    induction y using ore_localization.ind with r₂ s₂,
    rcases ore_div_mul_char' r₁ r₂ s₁ s₂ with ⟨ra, sa, ha, ha'⟩, rw ha', clear ha',
    rw [lift_expand_of, lift_expand_of, lift_expand_of],
    conv_rhs { congr, skip, congr,
      rw [←mul_one (f r₂), ←(fS sa).mul_inv, ←mul_assoc, ←hf, ←f.map_mul, ha, f.map_mul] },
    rw [mul_assoc, mul_assoc, mul_assoc, ←mul_assoc _ (f s₁), hf s₁, (fS s₁).inv_mul, one_mul,
      f.map_mul, mul_assoc, fS.map_mul, ←units.coe_mul], refl
  end }

lemma universal_mul_hom_apply {r : R} {s : S} :
  universal_mul_hom f fS hf (r /ₒ s) = (f r) * ((fS s)⁻¹ : units T) :=
rfl

lemma universal_mul_hom_commutes {r : R} : universal_mul_hom f fS hf (numerator_hom r) = f r :=
by simp [numerator_hom_apply, universal_mul_hom_apply]

/-- The universal morphism `universal_mul_hom` is unique. -/
lemma universal_mul_hom_unique (φ : R[S⁻¹] →* T) (huniv : ∀ (r : R), φ (numerator_hom r) = f r) :
  φ = universal_mul_hom f fS hf :=
begin
  ext, induction x using ore_localization.ind with r s,
  rw [universal_mul_hom_apply, ←huniv r, numerator_hom_apply, ←mul_one (φ (r /ₒ s)),
    ←units.coe_one, ←mul_right_inv (fS s), units.coe_mul, ←mul_assoc,
    ←hf, ←huniv, ←φ.map_mul, numerator_hom_apply, ore_localization.mul_cancel],
end

end UMP

end monoid

section comm_monoid

variables {R : Type*} [comm_monoid R] {S : submonoid R} [ore_set S]

lemma ore_div_mul_ore_div_comm {r₁ r₂ : R} {s₁ s₂ : S} :
  (r₁ /ₒ s₁) * (r₂ /ₒ s₂) = (r₁ * r₂) /ₒ (s₁ * s₂) :=
by rw [ore_div_mul_char r₁ r₂ s₁ s₂ r₂ s₁ (by simp [mul_comm]), mul_comm s₂]

instance : comm_monoid R[S⁻¹] :=
{ mul_comm := λ x y,
  begin
    induction x using ore_localization.ind with r₁ s₁,
    induction y using ore_localization.ind with r₂ s₂,
    rw [ore_div_mul_ore_div_comm, ore_div_mul_ore_div_comm, mul_comm r₁, mul_comm s₁],
  end,
  ..ore_localization.monoid }

variables (R S)

/-- The morphism `numerator_hom` is a monoid localization map in the case of commutative `R`. -/
protected def localization_map : S.localization_map R[S⁻¹] :=
{ to_fun := numerator_hom,
  map_one' := rfl,
  map_mul' := λ r₁ r₂, by simp,
  map_units' := numerator_is_unit,
  surj' := λ z,
  begin
    induction z using ore_localization.ind with r s,
    use (r, s), dsimp,
    rw [numerator_hom_apply, numerator_hom_apply], simp
  end,
  eq_iff_exists' := λ r₁ r₂,
  begin
    dsimp, split,
    { intro h,
      rw [numerator_hom_apply, numerator_hom_apply, ore_div_eq_iff] at h,
      rcases h with ⟨u, v, h₁, h₂⟩, dsimp at h₂,
      rw [one_mul, one_mul] at h₂,
      subst h₂,
      use u,
      simpa only [mul_comm] using h₁.symm },
    { rintro ⟨s, h⟩,
      rw [numerator_hom_apply, numerator_hom_apply, ore_div_eq_iff],
      refine ⟨s, s, _, _⟩,
      { simpa [mul_comm] using h.symm },
      { simp [one_mul]} }
  end }

/-- If `R` is commutative, Ore localization and monoid localization are isomorphic. -/
protected noncomputable def equiv_monoid_localization : localization S ≃* R[S⁻¹] :=
localization.mul_equiv_of_quotient (ore_localization.localization_map R S)

end comm_monoid

section semiring

variables {R : Type*} [semiring R] {S : submonoid R} [ore_set S]

private def add'' (r₁ : R) (s₁ : S) (r₂ : R) (s₂ : S) : R[S⁻¹] :=
(r₁ * ore_denom (s₁ : R) s₂ + r₂ * ore_num s₁ s₂) /ₒ (s₁ * ore_denom s₁ s₂)

private lemma add''_char
  (r₁ : R) (s₁ : S) (r₂ : R) (s₂ : S)
  (rb : R) (sb : S) (hb : (s₁ : R) * sb = (s₂ : R) * rb) :
add'' r₁ s₁ r₂ s₂ = (r₁ * sb + r₂ * rb) /ₒ (s₁ * sb) :=
begin
  simp only [add''],
  have ha := ore_eq (s₁ : R) s₂,
  set! ra := ore_num (s₁ : R) s₂ with h, rw ←h at *, clear h, -- r tilde
  set! sa := ore_denom (s₁ : R) s₂ with h, rw ←h at *, clear h, -- s tilde
  rcases ore_condition (sa : R) sb with ⟨rc, sc, hc⟩, -- s*, r*
  have : (s₂ : R) * (rb * rc) = s₂ * (ra * sc),
  { rw [←mul_assoc, ←hb, mul_assoc, ←hc, ←mul_assoc, ←mul_assoc, ha] },
  rcases ore_left_cancel _ _ s₂ this with ⟨sd, hd⟩, -- s#
  symmetry, rw ore_div_eq_iff,
  use sc * sd, use rc * sd,
  split; simp only [submonoid.coe_mul],
  { noncomm_ring, assoc_rw [hd, hc], noncomm_ring },
  { assoc_rewrite [hc], noncomm_ring }
end

local attribute [instance] ore_localization.ore_eqv

private def add' (r₂ : R) (s₂ : S) : R[S⁻¹] → R[S⁻¹] := --plus tilde
quotient.lift (λ (r₁s₁ : R × S), add'' r₁s₁.1 r₁s₁.2 r₂ s₂) $
begin
  rintros ⟨r₁', s₁'⟩ ⟨r₁, s₁⟩ ⟨sb, rb, hb, hb'⟩, -- s*, r*
  rcases ore_condition (s₁' : R) s₂ with ⟨rc, sc, hc⟩, --s~~, r~~
  rcases ore_condition rb sc with ⟨rd, sd, hd⟩, -- s#, r#
  dsimp at *, rw add''_char _ _ _ _ rc sc hc,
  have : ↑s₁ * ↑(sb * sd) = ↑s₂ * (rc * rd),
  { simp only [submonoid.coe_mul], assoc_rewrite [hb', hd, hc], noncomm_ring },
  rw add''_char _ _ _ _ (rc * rd : R) (sb * sd : S) this,
  simp only [submonoid.coe_mul], assoc_rw [hb, hd],
  rw [←mul_assoc, ←add_mul, ore_div_eq_iff],
  use 1, use rd, split,
  { simp },
  { simp only [mul_one, submonoid.coe_one, submonoid.coe_mul] at ⊢ this, assoc_rw [hc, this] },
end

private lemma add'_comm (r₁ r₂ : R) (s₁ s₂ : S) : add' r₁ s₁ (r₂ /ₒ s₂) = add' r₂ s₂ (r₁ /ₒ s₁) :=
begin
  simp only [add', ore_div, add'', quotient.lift_mk, quotient.eq],
  have hb := ore_eq ↑s₂ s₁, set rb := ore_num ↑s₂ s₁ with h, -- r~~
    rw ←h, clear h, set sb := ore_denom ↑s₂ s₁ with h, rw ←h, clear h, -- s~~
  have ha := ore_eq ↑s₁ s₂, set ra := ore_num ↑s₁ s₂ with h, -- r~
    rw ←h, clear h, set sa := ore_denom ↑s₁ s₂ with h, rw ←h, clear h, -- s~
  rcases ore_condition ra sb with ⟨rc, sc, hc⟩, -- r#, s#
  have : (s₁ : R) * (rb * rc) = s₁ * (sa * sc),
  { rw [←mul_assoc, ←hb, mul_assoc, ←hc, ←mul_assoc, ←ha, mul_assoc] },
  rcases ore_left_cancel _ _ s₁ this with ⟨sd, hd⟩, -- s+
  use sc * sd, use rc * sd,
  dsimp, split,
  { rw [add_mul, add_mul, add_comm], assoc_rw [←hd, hc], noncomm_ring },
  { rw [mul_assoc, ←mul_assoc ↑sa, ←hd, hb], noncomm_ring }
end

/-- The addition on the Ore localization. -/
private def add : R[S⁻¹] → R[S⁻¹] → R[S⁻¹] :=
λ x,
quotient.lift (λ rs : R × S, add' rs.1 rs.2 x)
begin
  rintros ⟨r₁, s₁⟩ ⟨r₂, s₂⟩ hyz,
  induction x using ore_localization.ind with r₃ s₃,
  dsimp, rw [add'_comm, add'_comm r₂],
  simp [(/ₒ), quotient.sound hyz],
end

instance : has_add R[S⁻¹] := ⟨add⟩

lemma ore_div_add_ore_div {r r' : R} {s s' : S} :
  r /ₒ s + r' /ₒ s' = (r * ore_denom (s : R) s' + r' * ore_num s s') /ₒ (s * ore_denom s s') :=
rfl

/-- A characterization of the addition on the Ore localizaion, allowing for arbitrary Ore
numerator and Ore denominator. -/
lemma ore_div_add_char {r r' : R} (s s' : S) (rb : R) (sb : S)
  (h : (s : R) * sb = s' * rb) :
  r /ₒ s + r' /ₒ s' = (r * sb + r' * rb) /ₒ (s * sb) :=
add''_char r s r' s' rb sb h

/-- Another characterization of the addition on the Ore localization, bundling up all witnesses
and conditions into a sigma type. -/
def ore_div_add_char' (r r' : R) (s s' : S) :
  Σ' r'' : R, Σ' s'' : S, (s : R) * s'' = s' * r'' ∧
                  r /ₒ s + r' /ₒs' = (r * s'' + r' * r'') /ₒ (s * s'') :=
⟨ore_num s s', ore_denom s s', ore_eq s s', ore_div_add_ore_div⟩

@[simp] lemma add_ore_div {r r' : R} {s : S} : (r /ₒ s) + (r' /ₒ s) = (r + r') /ₒ s :=
by simp [ore_div_add_char s s 1 1 (by simp)]

protected lemma add_assoc (x y z : R[S⁻¹]) :
  (x + y) + z = x + (y + z) :=
begin
  induction x using ore_localization.ind with r₁ s₁,
  induction y using ore_localization.ind with r₂ s₂,
  induction z using ore_localization.ind with r₃ s₃,
  rcases ore_div_add_char' r₁ r₂ s₁ s₂ with ⟨ra, sa, ha, ha'⟩, rw ha', clear ha',
  rcases ore_div_add_char' r₂ r₃ s₂ s₃ with ⟨rb, sb, hb, hb'⟩, rw hb', clear hb',
  rcases ore_div_add_char' (r₁ * sa + r₂ * ra) r₃ (s₁ * sa) s₃ with ⟨rc, sc, hc, q⟩, rw q, clear q,
  rcases ore_div_add_char' r₁ (r₂ * sb + r₃ * rb) s₁ (s₂ * sb) with ⟨rd, sd, hd, q⟩, rw q, clear q,
  noncomm_ring, rw add_comm (r₂ * _),
  repeat { rw ←add_ore_div },
  congr' 1,
  { rcases ore_condition (sd : R) (sa * sc) with ⟨re, se, he⟩,
    { simp_rw ←submonoid.coe_mul at hb hc hd,
      assoc_rw [subtype.coe_eq_of_eq_mk hc],
      rw [←ore_localization.expand, subtype.coe_eq_of_eq_mk hd, ←mul_assoc,
        ←ore_localization.expand, subtype.coe_eq_of_eq_mk hb],
      apply ore_localization.expand } },
  congr' 1,
  { rw [←ore_localization.expand', ←mul_assoc, ←mul_assoc,
      ←ore_localization.expand', ←ore_localization.expand'] },
  { simp_rw [←submonoid.coe_mul] at ha hd,
    rw [subtype.coe_eq_of_eq_mk hd, ←mul_assoc, ←mul_assoc,
      ←mul_assoc, ←ore_localization.expand, ←ore_localization.expand',
      subtype.coe_eq_of_eq_mk ha, ←ore_localization.expand],
    apply ore_localization.expand' }
end

private def zero : R[S⁻¹] := 0 /ₒ 1

instance : has_zero R[S⁻¹] := ⟨zero⟩

protected lemma zero_def : (0 : R[S⁻¹]) = 0 /ₒ 1 := rfl

@[simp]
lemma zero_div_eq_zero (s : S) : 0 /ₒ s = 0 :=
by { rw [ore_localization.zero_def, ore_div_eq_iff], exact ⟨s, 1, by simp⟩ }

protected

protected lemma add_comm (x y : R[S⁻¹]) : x + y = y + x :=
begin
  induction x using ore_localization.ind,
  induction y using ore_localization.ind,
  change add' _ _ (_ /ₒ _) = _, apply add'_comm
end

instance : add_comm_monoid R[S⁻¹] :=
{ add_comm := ore_localization.add_comm,
  add_assoc := ore_localization.add_assoc,
  zero := zero,
  zero_add := ore_localization.zero_add,
  add_zero := λ x, by rw [ore_localization.add_comm, ore_localization.zero_add],
  .. ore_localization.has_add }

protected lemma zero_mul (x : R[S⁻¹]) : 0 * x = 0 :=
begin
  induction x using ore_localization.ind with r s,
  rw [ore_localization.zero_def, ore_div_mul_char 0 r 1 s r 1 (by simp)], simp
end

protected lemma mul_zero (x : R[S⁻¹]) : x * 0 = 0 :=
begin
  induction x using ore_localization.ind with r s,
  rw [ore_localization.zero_def, ore_div_mul_char r 0 s 1 0 1 (by simp)], simp
end

protected lemma left_distrib (x y z : R[S⁻¹]) : x * (y + z) = x * y + x * z :=
begin
  induction x using ore_localization.ind with r₁ s₁,
  induction y using ore_localization.ind with r₂ s₂,
  induction z using ore_localization.ind with r₃ s₃,
  rcases ore_div_add_char' r₂ r₃ s₂ s₃ with ⟨ra, sa, ha, q⟩, rw q, clear q,
  rw ore_localization.expand' r₂ s₂ sa,
  rcases ore_div_mul_char' r₁ (r₂ * sa) s₁ (s₂ * sa) with ⟨rb, sb, hb, q⟩, rw q, clear q,
  have hs₃rasb : ↑s₃ * (ra * sb) ∈ S, { rw [←mul_assoc, ←ha], norm_cast, apply set_like.coe_mem },
  rw ore_localization.expand _ _ _ hs₃rasb,
  have ha' : (↑(s₂ * sa * sb)) = ↑s₃ * (ra * sb), { simp [ha, ←mul_assoc] },
  rw ←subtype.coe_eq_of_eq_mk ha',
  rcases ore_div_mul_char' r₁ (r₃ * (ra * sb)) s₁ (s₂ * sa * sb) with ⟨rc, sc, hc, hc'⟩, rw hc',
  rw ore_div_add_char (s₂ * sa * sb) (s₂ * sa * sb * sc) 1 sc (by simp),
  rw ore_localization.expand' (r₂ * ↑sa + r₃ * ra) (s₂ * sa) (sb * sc),
  conv_lhs { congr, skip, congr,
    rw [add_mul, S.coe_mul, ←mul_assoc, hb, ←mul_assoc, mul_assoc r₃, hc, mul_assoc, ←mul_add] },
  rw ore_localization.mul_cancel', simp only [mul_one, submonoid.coe_mul, mul_add, ←mul_assoc],
end

lemma right_distrib (x y z : R[S⁻¹]) : (x + y) * z = x * z + y * z :=
begin
  induction x using ore_localization.ind with r₁ s₁,
  induction y using ore_localization.ind with r₂ s₂,
  induction z using ore_localization.ind with r₃ s₃,
  rcases ore_div_add_char' r₁ r₂ s₁ s₂ with ⟨ra, sa, ha, ha'⟩, rw ha', clear ha', norm_cast at ha,
  rw ore_localization.expand' r₁ s₁ sa,
  rw ore_localization.expand r₂ s₂ ra (by rw ←ha; apply set_like.coe_mem),
  rw ←subtype.coe_eq_of_eq_mk ha,
  repeat { rw ore_div_mul_ore_div }, simp only [add_mul, add_ore_div]
end

instance : semiring R[S⁻¹] :=
{ zero_mul := ore_localization.zero_mul,
  mul_zero := ore_localization.mul_zero,
  left_distrib := ore_localization.left_distrib,
  right_distrib := right_distrib,
  .. ore_localization.add_comm_monoid,
  .. ore_localization.monoid }

section UMP
variables {T : Type*} [semiring T]
variables (f : R →+* T) (fS : S →* units T)
variables (hf : ∀ (s : S), f s = fS s)

include f fS hf

/-- The universal lift from a ring homomorphism `f : R →+* T`, which maps elements in `S` to
units of `T`, to a ring homomorphism `R[S⁻¹] →+* T`. This extends the construction on
monoids. -/
def universal_hom : R[S⁻¹] →+* T :=
{ map_zero' :=
  begin
    rw [monoid_hom.to_fun_eq_coe, ore_localization.zero_def, universal_mul_hom_apply],
    simp
  end,
  map_add' := λ x y,
  begin
    induction x using ore_localization.ind with r₁ s₁,
    induction y using ore_localization.ind with r₂ s₂,
    rcases ore_div_add_char' r₁ r₂ s₁ s₂ with ⟨r₃, s₃, h₃, h₃'⟩, rw h₃', clear h₃',
    simp only [universal_mul_hom_apply, ring_hom.coe_monoid_hom,
      ring_hom.to_monoid_hom_eq_coe, monoid_hom.to_fun_eq_coe],
    simp only [mul_inv_rev, monoid_hom.map_mul, ring_hom.map_add, ring_hom.map_mul, units.coe_mul],
    rw [add_mul, ←mul_assoc, mul_assoc (f r₁), hf, ←units.coe_mul],
    simp only [mul_one, mul_right_inv, units.coe_one],
    congr' 1, rw [mul_assoc], congr' 1,
    norm_cast at h₃, have h₃' := subtype.coe_eq_of_eq_mk h₃,
    rw [←units.coe_mul, ←mul_inv_rev, ←fS.map_mul, h₃'],
    have hs₂r₃ : ↑s₂ * r₃ ∈ S, { rw ←h₃, exact set_like.coe_mem (s₁ * s₃)},
    apply (units.inv_mul_cancel_left (fS s₂) _).symm.trans,
    conv_lhs { congr, skip,
      rw [←units.mul_inv_cancel_left (fS ⟨s₂ * r₃, hs₂r₃⟩) (fS s₂), mul_assoc, mul_assoc],
      congr, skip, rw [←hf, ←mul_assoc (f s₂), ←f.map_mul],
      conv { congr, skip, congr, rw [←h₃] },
      rw [hf, ←mul_assoc, ←h₃', units.inv_mul] },
    rw [one_mul, ←h₃', units.mul_inv, mul_one],
  end,
  .. universal_mul_hom f.to_monoid_hom fS hf }

lemma universal_hom_apply {r : R} {s : S} :
  universal_hom f fS hf (r /ₒ s) = (f r) * ((fS s)⁻¹ : units T) := rfl

lemma universal_hom_commutes {r : R} : universal_hom f fS hf (numerator_hom r) = f r :=
by simp [numerator_hom_apply, universal_hom_apply]

lemma universal_hom_unique (φ : R[S⁻¹] →+* T) (huniv : ∀ (r : R), φ (numerator_hom r) = f r) :
  φ = universal_hom f fS hf :=
ring_hom.coe_monoid_hom_injective $
universal_mul_hom_unique (ring_hom.to_monoid_hom f) fS hf ↑φ huniv

end UMP

end semiring

section ring
variables {R : Type*} [ring R] {S : submonoid R} [ore_set S]

/-- Negation on the Ore localization is defined via negation on the numerator. -/
protected def neg : R[S⁻¹] → R[S⁻¹] :=
lift_expand (λ (r : R) (s : S), (- r) /ₒ s) $
  λ r t s ht, by rw [neg_mul_eq_neg_mul, ←ore_localization.expand]

instance : has_neg R[S⁻¹] := ⟨ore_localization.neg⟩

@[simp] protected lemma neg_def (r : R) (s : S) : - (r /ₒ s) = (- r) /ₒ s := rfl

protected lemma add_left_neg (x : R[S⁻¹]) : (- x) + x = 0 :=
by induction x using ore_localization.ind with r s; simp

instance : ring R[S⁻¹] :=
{ add_left_neg := ore_localization.add_left_neg,
  .. ore_localization.semiring,
  .. ore_localization.has_neg }

open_locale non_zero_divisors

lemma numerator_hom_inj (hS : S ≤ R⁰) : function.injective (numerator_hom : R → R[S⁻¹]) :=
λ r₁ r₂ h,
begin
  rw [numerator_hom_apply, numerator_hom_apply, ore_div_eq_iff] at h,
  rcases h with ⟨u, v, h₁, h₂⟩,
  simp only [S.coe_one, one_mul] at h₂,
  rwa [←h₂, mul_cancel_right_mem_non_zero_divisor (hS (set_like.coe_mem u)), eq_comm] at h₁,
end

lemma nontrivial_of_non_zero_divisors [nontrivial R] (hS : S ≤ R⁰) : nontrivial R[S⁻¹] :=
⟨⟨0, 1, λ h,
  begin
    rw [ore_localization.one_def, ore_localization.zero_def] at h,
    apply non_zero_divisors.coe_ne_zero 1 (numerator_hom_inj hS h).symm
  end⟩⟩

end ring

section division_ring

open_locale non_zero_divisors
open_locale classical

variables {R : Type*} [ring R] [nontrivial R] [ore_set R⁰]

instance : nontrivial R[R⁰⁻¹] := nontrivial_of_non_zero_divisors (refl R⁰)

variables [no_zero_divisors R]

noncomputable theory

/-- The inversion of Ore fractions for a ring without zero divisors, satisying `0⁻¹ = 0` and
`(r /ₒ r')⁻¹ = r' /ₒ r` for `r ≠ 0`. -/
protected def inv : R[R⁰⁻¹] → R[R⁰⁻¹] :=
lift_expand (λ r s, if hr: r = (0 : R) then (0 : R[R⁰⁻¹])
  else (s /ₒ ⟨r, λ _, eq_zero_of_ne_zero_of_mul_right_eq_zero hr⟩))
begin
  intros r t s hst,
  by_cases hr : r = 0,
  { simp [hr] },
  { by_cases ht : t = 0,
    { exfalso, apply non_zero_divisors.coe_ne_zero ⟨_, hst⟩, simp [ht, mul_zero] },
    { simp only [hr, ht, set_like.coe_mk, dif_neg, not_false_iff, or_self, mul_eq_zero],
      apply ore_localization.expand } }
end

instance : has_inv R[R⁰⁻¹] := ⟨ore_localization.inv⟩

protected lemma inv_def {r : R} {s : R⁰} :
  (r /ₒ s)⁻¹ = if hr: r = (0 : R) then (0 : R[R⁰⁻¹])
  else (s /ₒ ⟨r, λ _, eq_zero_of_ne_zero_of_mul_right_eq_zero hr⟩) := rfl

protected lemma mul_inv_cancel (x : R[R⁰⁻¹]) (h : x ≠ 0) : x * x⁻¹ = 1 :=
begin
  induction x using ore_localization.ind with r s,
  rw [ore_localization.inv_def, ore_localization.one_def],
  by_cases hr : r = 0,
  { exfalso, apply h, simp [hr] },
  { simp [hr], apply ore_localization.div_eq_one' }
end

protected lemma inv_zero : (0 : R[R⁰⁻¹])⁻¹ = 0 :=
by { rw [ore_localization.zero_def, ore_localization.inv_def], simp }

instance : division_ring R[(R⁰)⁻¹] :=
{ mul_inv_cancel := ore_localization.mul_inv_cancel,
  inv_zero := ore_localization.inv_zero,
  .. ore_localization.nontrivial,
  .. ore_localization.has_inv,
  .. ore_localization.ring }

end division_ring

end ore_localization


import set_theory.cardinal

open function lattice set
local attribute [instance] classical.prop_decidable

universes u v w x
variables {α β : Type u}

namespace cardinal

lemma mk_zero_iff_empty_set (s : set α) : cardinal.mk s = 0 ↔ s = ∅ :=
begin
  rw [←set.not_nonempty_iff_eq_empty, iff_not_comm, set.nonempty,
    ←nonempty_subtype, ←ne_zero_iff_nonempty],
  refl,
end
lemma nat_add (m n : ℕ) : ((m + n : ℕ) : cardinal) = (m + n : cardinal) := nat.cast_add _ _

lemma exists_nat_of_add_eq_nat {a b : cardinal} {n : ℕ} (h : a + b = n) :
  ∃ k l : ℕ, a = k ∧ b = l :=
begin
  rcases (@cardinal.lt_omega a).1 _ with ⟨k, hk⟩,
  rcases (@cardinal.lt_omega b).1 _ with ⟨l, hl⟩,
  { use k,
    use l,
    cc },
  { refine ((@cardinal.add_lt_omega_iff a b).1 _).2,
    rw h,
    apply cardinal.nat_lt_omega },
  { refine ((@cardinal.add_lt_omega_iff a b).1 _).1,
    rw h,
    apply cardinal.nat_lt_omega },
end

end cardinal


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.submodule
import algebra.lie.of_associative

/-!
# Quotients of Lie algebras and Lie modules

Given a Lie submodule of a Lie module, the quotient carries a natural Lie module structure. In the
special case that the Lie module is the Lie algebra itself via the adjoint action, the submodule
is a Lie ideal and the quotient carries a natural Lie algebra structure.

We define these quotient structures here. A notable omission at the time of writing (February 2021)
is a statement and proof of the universal property of these quotients.

## Main definitions

  * `lie_submodule.quotient.lie_quotient_lie_module`
  * `lie_submodule.quotient.lie_quotient_lie_algebra`

## Tags

lie algebra, quotient
-/

universes u v w w₁ w₂

namespace lie_submodule

variables {R : Type u} {L : Type v} {M : Type w}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [add_comm_group M] [module R M]
variables [lie_ring_module L M] [lie_module R L M]
variables (N N' : lie_submodule R L M) (I J : lie_ideal R L)

/-- The quotient of a Lie module by a Lie submodule. It is a Lie module. -/
abbreviation quotient := N.to_submodule.quotient

namespace quotient

variables {N I}

/-- Map sending an element of `M` to the corresponding element of `M/N`, when `N` is a
lie_submodule of the lie_module `N`. -/
abbreviation mk : M → N.quotient := submodule.quotient.mk

lemma is_quotient_mk (m : M) :
  quotient.mk' m = (mk m : N.quotient) := rfl

/-- Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M`, there
is a natural linear map from `L` to the endomorphisms of `M` leaving `N` invariant. -/
def lie_submodule_invariant : L →ₗ[R] submodule.compatible_maps N.to_submodule N.to_submodule :=
  linear_map.cod_restrict _ (lie_module.to_endomorphism R L M) N.lie_mem

variables (N)

/-- Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M`, there
is a natural Lie algebra morphism from `L` to the linear endomorphism of the quotient `M/N`. -/
def action_as_endo_map : L →ₗ⁅R⁆ module.End R N.quotient :=
{ map_lie' := λ x y, by { ext n, apply quotient.induction_on' n, intros m,
                         change mk ⁅⁅x, y⁆, m⁆ = mk (⁅x, ⁅y, m⁆⁆ - ⁅y, ⁅x, m⁆⁆),
                         congr, apply lie_lie, },
  ..linear_map.comp (submodule.mapq_linear (N : submodule R M) ↑N) lie_submodule_invariant }

/-- Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M`, there is
a natural bracket action of `L` on the quotient `M/N`. -/
def action_as_endo_map_bracket : has_bracket L N.quotient := ⟨λ x n, action_as_endo_map N x n⟩

instance lie_quotient_lie_ring_module : lie_ring_module L N.quotient :=
{ bracket     := λ x n, (action_as_endo_map N : L →ₗ[R] module.End R N.quotient) x n,
  add_lie     := λ x y n, by { simp only [linear_map.map_add, linear_map.add_apply], },
  lie_add     := λ x m n, by { simp only [linear_map.map_add, linear_map.add_apply], },
  leibniz_lie := λ x y m, show action_as_endo_map _ _ _ = _,
  { simp only [lie_hom.map_lie, lie_ring.of_associative_ring_bracket, sub_add_cancel,
      lie_hom.coe_to_linear_map, linear_map.mul_apply, linear_map.sub_apply], } }

/-- The quotient of a Lie module by a Lie submodule, is a Lie module. -/
instance lie_quotient_lie_module : lie_module R L N.quotient :=
{ smul_lie := λ t x m, show (_ : L →ₗ[R] module.End R N.quotient) _ _ = _,
  { simp only [linear_map.map_smul], refl, },
  lie_smul := λ x t m, show (_ : L →ₗ[R] module.End R N.quotient) _ _ = _,
  { simp only [linear_map.map_smul], refl, }, }

instance lie_quotient_has_bracket : has_bracket (quotient I) (quotient I) :=
⟨begin
  intros x y,
  apply quotient.lift_on₂' x y (λ x' y', mk ⁅x', y'⁆),
  intros x₁ x₂ y₁ y₂ h₁ h₂,
  apply (submodule.quotient.eq I.to_submodule).2,
  have h : ⁅x₁, x₂⁆ - ⁅y₁, y₂⁆ = ⁅x₁, x₂ - y₂⁆ + ⁅x₁ - y₁, y₂⁆,
    by simp [-lie_skew, sub_eq_add_neg, add_assoc],
  rw h,
  apply submodule.add_mem,
  { apply lie_mem_right R L I x₁ (x₂ - y₂) h₂, },
  { apply lie_mem_left R L I (x₁ - y₁) y₂ h₁, },
end⟩

@[simp] lemma mk_bracket (x y : L) :
  mk ⁅x, y⁆ = ⁅(mk x : quotient I), (mk y : quotient I)⁆ := rfl

instance lie_quotient_lie_ring : lie_ring (quotient I) :=
{ add_lie  := by { intros x' y' z', apply quotient.induction_on₃' x' y' z', intros x y z,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_add, },
                   apply congr_arg, apply add_lie, },
  lie_add  := by { intros x' y' z', apply quotient.induction_on₃' x' y' z', intros x y z,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_add, },
                   apply congr_arg, apply lie_add, },
  lie_self := by { intros x', apply quotient.induction_on' x', intros x,
                   rw [is_quotient_mk, ←mk_bracket],
                   apply congr_arg, apply lie_self, },
  leibniz_lie := by { intros x' y' z', apply quotient.induction_on₃' x' y' z', intros x y z,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_add, },
                   apply congr_arg, apply leibniz_lie, } }

instance lie_quotient_lie_algebra : lie_algebra R (quotient I) :=
{ lie_smul := by { intros t x' y', apply quotient.induction_on₂' x' y', intros x y,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_smul, },
                   apply congr_arg, apply lie_smul, } }

end quotient

end lie_submodule


import Mathlib.analysis.normed_space.inner_product
import Mathlib.algebra.quadratic_discriminant
import Mathlib.analysis.normed_space.add_torsor
import Mathlib.data.matrix.notation
import Mathlib.linear_algebra.affine_space.finite_dimensional
import Mathlib.tactic.fin_cases
import Mathlib.data.real.basic

namespace Mathlib

-- TODO: how to port locales?
notation:max "π" => real.pi

namespace inner_product_geometry

universes u
variable {V : Type u} [inner_product_space ℝ V]

noncomputable def angle (x y : V) : ℝ :=
  real.arccos (inner x y / (norm x * norm y))

@[simp] theorem angle.def (x y : V) : angle x y = real.arccos (inner x y / (norm x * norm y)) :=
  sorry

theorem cos_angle (x y : V) : real.cos (angle x y) = inner x y / (norm x * norm y) :=
  sorry

theorem angle_comm (x y : V) : angle x y = angle y x := by
  -- TODO: unfold tactic, or more controlled `simp`
  rw [angle.def, angle.def, real_inner_comm]
  -- TODO: this fails because Mul vs HMul (need to normalize somewhere)
  -- (many other similar failures throughout)
  -- rw [mul_comm]
  exact sorry

theorem angle_neg_neg (x y : V) : angle (-x) (-y) = angle x y := by
  rw [angle.def, angle.def]
  rw [inner_neg_neg, norm_neg, norm_neg]

theorem angle_nonneg (x y : V) : 0 ≤ angle x y :=
  real.arccos_nonneg _

theorem angle_le_pi (x y : V) : angle x y ≤ π :=
  real.arccos_le_pi _

theorem angle_neg_right (x y : V) : angle x (-y) = π - angle x y := by
  rw [angle.def, angle.def]
  -- TODO: why does this fail?
  -- rw [←real.arccos_neg, norm_neg, inner_neg_right, neg_div]
  exact sorry

theorem angle_neg_left (x y : V) : angle (-x) y = π - angle x y := by
  rw [←angle_neg_neg, neg_neg, angle_neg_right]

theorem angle_zero_left (x : V) : angle 0 x = π / 2 :=
  sorry

end inner_product_geometry
end Mathlib


import linear_algebra.eigenspace
import linear_algebra.tensor_product
import rnd_var
import shannon_theory

import tut3
import tut5
-- import tut13_ptrace

---- QUANTUM ENTROPY

open rnd_var

open_locale tensor_product big_operators

noncomputable theory

variables
{ℋ : Type} [complex_hilbert_space ℋ]
{ℋ₁ : Type} [complex_hilbert_space ℋ₁]
{ℋ₂ : Type} [complex_hilbert_space ℋ₂]

universe x

variables
{ι : Type x} -- indexing type
[fintype ι] -- tell Lean that the set of all elements ι is finite.

/-
Logarithm of a linear operator.
-/
def log (ρ : ℋ →ₗ[ℂ] ℋ) : ℋ →ₗ[ℂ] ℋ := sorry

notation A ` ∘ ` B := linear_map.comp A B

def entropy (ρ : module.End ℂ ℋ) : ℝ :=
( Tr ( ρ ∘ (log ρ) ) ).re

universe x

/--
If a linear operator has trace one then its eigenvalues sum to 1.
-/
lemma sum_eigenvalues_eq_one_of_trace_one (ρ : module.End ℂ ℋ)
{e : ι → ℝ} {he : ∀ i, ρ.has_eigenvalue (e i)}:
(Tr ρ = 1) → (∑ i, e i = 1) :=
begin
    sorry
end

/--
A quantum state has all nonnegative eigenvalues.
-/
lemma quantum_state_pos_semidef (ρ : module.End ℂ ℋ) [quantum_state ρ] (e : ℝ) :
ρ.has_eigenvalue e → e ≥ 0 := sorry -- This follows directly from the
-- positive semi-definite axiom (axiom 2).

/--
Quantum entropy is nonnegative
-/
theorem entropy_nonneg  {ρ : module.End ℂ ℋ}
{e : ι → ℝ} {he : ∀ i, ρ.has_eigenvalue (e i)} [quantum_state ρ] :
entropy ρ ≥ 0 :=
begin
    have : entropy ρ = - ∑ i, (e i) * real.log(e i), {sorry},
    rw this,
    clear this,
    -- All the eignevalues are nonnegative because the state is positive semidefinite
    have he_nonneg : ∀ i, (e i) ≥ 0, {
        intros,
        apply quantum_state_pos_semidef ρ,
        exact he i,
    },
    -- The eigenvalues sum to 1 because the state has trace 1.
    have he_sum_eq_one : ∑ i, (e i) = 1, {
        apply sum_eigenvalues_eq_one_of_trace_one ρ quantum_state.trace_one,
        apply he,
    },
    -- Given the available facts, the remaining term looks like Shannon
    -- entropy. So we use that Shannon entropy is nonegative to finish.
    apply Shannon_entropy_nonneg, simp,
    {exact he_nonneg},
    {exact he_sum_eq_one},
end

/--
Convacity of the entropy
-/
theorem entropy_concave  {ρ : module.End ℂ ℋ}
{e : ι → ℝ} {he : ∀ i, ρ.has_eigenvalue (e i)}
(pₓ : ι → ℝ) [hpₓ : rnd_var pₓ] (ρₓ : ι → module.End ℂ ℋ)
(hρ : ρ = ∑ i, (pₓ i) • (ρₓ i)) :
entropy ρ ≥ ∑ i, (pₓ i) * entropy (ρₓ i) :=
begin
    have : entropy ρ = - ∑ i, (e i) * real.log(e i), {sorry},
    rw this,
    clear this,
    sorry
end

def log_bp (ρ : ℋ₁ ⊗[ℂ] ℋ₂ →ₗ[ℂ] ℋ₁ ⊗[ℂ] ℋ₂) : (ℋ₁ ⊗[ℂ] ℋ₂) →ₗ[ℂ] (ℋ₁ ⊗[ℂ] ℋ₂) := sorry

/--
Joint quantum entropy
https://arxiv.org/abs/1106.1445
-/
def joint_entropy (ρ : ℋ₁ ⊗ ℋ₂ →ₗ[ℂ] (ℋ₁ ⊗ ℋ₂)) : ℝ :=
( Tr ( ρ ∘ (log_bp ρ) ) ).re


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro, Johannes Hölzl

! This file was ported from Lean 3 source module algebra.order.group.with_top
! leanprover-community/mathlib commit f178c0e25af359f6cbc72a96a243efd3b12423a3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Order.Group.Instances
import Mathlib.Algebra.Order.Monoid.WithTop

/-!
# Adjoining a top element to a `LinearOrderedAddCommGroupWithTop`.
-/

namespace WithTop

variable {α : Type _}

section LinearOrderedAddCommGroup

variable [LinearOrderedAddCommGroup α] {a b c d : α}

instance linearOrderedAddCommGroupWithTop : LinearOrderedAddCommGroupWithTop (WithTop α) where
  __ := WithTop.linearOrderedAddCommMonoidWithTop
  __ := Option.nontrivial
  neg := Option.map fun a : α => -a
  neg_top := Option.map_none
  add_neg_cancel := by
    rintro (a | a) ha
    · exact (ha rfl).elim
    · exact WithTop.coe_add.symm.trans (WithTop.coe_eq_coe.2 (add_neg_self a))
#align with_top.linear_ordered_add_comm_group_with_top WithTop.linearOrderedAddCommGroupWithTop

@[simp, norm_cast]
theorem coe_neg (a : α) : ((-a : α) : WithTop α) = -a :=
  rfl
#align with_top.coe_neg WithTop.coe_neg

end LinearOrderedAddCommGroup

end WithTop


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

! This file was ported from Lean 3 source module analysis.normed_space.extr
! leanprover-community/mathlib commit 17ef379e997badd73e5eabb4d38f11919ab3c4b3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.NormedSpace.Ray
import Mathbin.Topology.LocalExtr

/-!
# (Local) maximums in a normed space

In this file we prove the following lemma, see `is_max_filter.norm_add_same_ray`. If `f : α → E` is
a function such that `norm ∘ f` has a maximum along a filter `l` at a point `c` and `y` is a vector
on the same ray as `f c`, then the function `λ x, ‖f x + y‖` has a maximul along `l` at `c`.

Then we specialize it to the case `y = f c` and to different special cases of `is_max_filter`:
`is_max_on`, `is_local_max_on`, and `is_local_max`.

## Tags

local maximum, normed space
-/

variable {α X E : Type _} [SeminormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace X]

section

variable {f : α → E} {l : Filter α} {s : Set α} {c : α} {y : E}

/-- If `f : α → E` is a function such that `norm ∘ f` has a maximum along a filter `l` at a point
`c` and `y` is a vector on the same ray as `f c`, then the function `λ x, ‖f x + y‖` has a maximul
along `l` at `c`. -/
theorem IsMaxFilter.norm_add_sameRay (h : IsMaxFilter (norm ∘ f) l c) (hy : SameRay ℝ (f c) y) :
    IsMaxFilter (fun x => ‖f x + y‖) l c :=
  h.mono fun x hx =>
    calc
      ‖f x + y‖ ≤ ‖f x‖ + ‖y‖ := norm_add_le _ _
      _ ≤ ‖f c‖ + ‖y‖ := (add_le_add_right hx _)
      _ = ‖f c + y‖ := hy.norm_add.symm

#align is_max_filter.norm_add_same_ray IsMaxFilter.norm_add_sameRay

/-- If `f : α → E` is a function such that `norm ∘ f` has a maximum along a filter `l` at a point
`c`, then the function `λ x, ‖f x + f c‖` has a maximul along `l` at `c`. -/
theorem IsMaxFilter.norm_add_self (h : IsMaxFilter (norm ∘ f) l c) :
    IsMaxFilter (fun x => ‖f x + f c‖) l c :=
  h.norm_add_sameRay SameRay.rfl
#align is_max_filter.norm_add_self IsMaxFilter.norm_add_self

/-- If `f : α → E` is a function such that `norm ∘ f` has a maximum on a set `s` at a point `c` and
`y` is a vector on the same ray as `f c`, then the function `λ x, ‖f x + y‖` has a maximul on `s` at
`c`. -/
theorem IsMaxOn.norm_add_sameRay (h : IsMaxOn (norm ∘ f) s c) (hy : SameRay ℝ (f c) y) :
    IsMaxOn (fun x => ‖f x + y‖) s c :=
  h.norm_add_sameRay hy
#align is_max_on.norm_add_same_ray IsMaxOn.norm_add_sameRay

/-- If `f : α → E` is a function such that `norm ∘ f` has a maximum on a set `s` at a point `c`,
then the function `λ x, ‖f x + f c‖` has a maximul on `s` at `c`. -/
theorem IsMaxOn.norm_add_self (h : IsMaxOn (norm ∘ f) s c) : IsMaxOn (fun x => ‖f x + f c‖) s c :=
  h.norm_add_self
#align is_max_on.norm_add_self IsMaxOn.norm_add_self

end

variable {f : X → E} {s : Set X} {c : X} {y : E}

/-- If `f : α → E` is a function such that `norm ∘ f` has a local maximum on a set `s` at a point
`c` and `y` is a vector on the same ray as `f c`, then the function `λ x, ‖f x + y‖` has a local
maximul on `s` at `c`. -/
theorem IsLocalMaxOn.norm_add_sameRay (h : IsLocalMaxOn (norm ∘ f) s c) (hy : SameRay ℝ (f c) y) :
    IsLocalMaxOn (fun x => ‖f x + y‖) s c :=
  h.norm_add_sameRay hy
#align is_local_max_on.norm_add_same_ray IsLocalMaxOn.norm_add_sameRay

/-- If `f : α → E` is a function such that `norm ∘ f` has a local maximum on a set `s` at a point
`c`, then the function `λ x, ‖f x + f c‖` has a local maximul on `s` at `c`. -/
theorem IsLocalMaxOn.norm_add_self (h : IsLocalMaxOn (norm ∘ f) s c) :
    IsLocalMaxOn (fun x => ‖f x + f c‖) s c :=
  h.norm_add_self
#align is_local_max_on.norm_add_self IsLocalMaxOn.norm_add_self

/-- If `f : α → E` is a function such that `norm ∘ f` has a local maximum at a point `c` and `y` is
a vector on the same ray as `f c`, then the function `λ x, ‖f x + y‖` has a local maximul at `c`. -/
theorem IsLocalMax.norm_add_sameRay (h : IsLocalMax (norm ∘ f) c) (hy : SameRay ℝ (f c) y) :
    IsLocalMax (fun x => ‖f x + y‖) c :=
  h.norm_add_sameRay hy
#align is_local_max.norm_add_same_ray IsLocalMax.norm_add_sameRay

/-- If `f : α → E` is a function such that `norm ∘ f` has a local maximum at a point `c`, then the
function `λ x, ‖f x + f c‖` has a local maximul at `c`. -/
theorem IsLocalMax.norm_add_self (h : IsLocalMax (norm ∘ f) c) :
    IsLocalMax (fun x => ‖f x + f c‖) c :=
  h.norm_add_self
#align is_local_max.norm_add_self IsLocalMax.norm_add_self


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

! This file was ported from Lean 3 source module linear_algebra.charpoly.to_matrix
! leanprover-community/mathlib commit baab5d3091555838751562e6caad33c844bea15e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Charpoly.Basic
import Mathbin.LinearAlgebra.Matrix.Basis

/-!

# Characteristic polynomial

## Main result

* `linear_map.charpoly_to_matrix f` : `charpoly f` is the characteristic polynomial of the matrix
of `f` in any basis.

-/

universe u v w

variable {R : Type u} {M : Type v} [CommRing R] [Nontrivial R]

variable [AddCommGroup M] [Module R M] [Module.Free R M] [Module.Finite R M] (f : M →ₗ[R] M)

open Classical Matrix

noncomputable section

open Module.Free Polynomial Matrix

namespace LinearMap

section Basic

/-- `charpoly f` is the characteristic polynomial of the matrix of `f` in any basis. -/
@[simp]
theorem charpoly_toMatrix {ι : Type w} [Fintype ι] (b : Basis ι R M) :
    (toMatrix b b f).charpoly = f.charpoly :=
  by
  set A := to_matrix b b f
  set b' := choose_basis R M
  set ι' := choose_basis_index R M
  set A' := to_matrix b' b' f
  set e := Basis.indexEquiv b b'
  set φ := reindex_linear_equiv R R e e
  set φ₁ := reindex_linear_equiv R R e (Equiv.refl ι')
  set φ₂ := reindex_linear_equiv R R (Equiv.refl ι') (Equiv.refl ι')
  set φ₃ := reindex_linear_equiv R R (Equiv.refl ι') e
  set P := b.to_matrix b'
  set Q := b'.to_matrix b
  have hPQ : C.map_matrix (φ₁ P) ⬝ C.map_matrix (φ₃ Q) = 1 := by
    rw [RingHom.mapMatrix_apply, RingHom.mapMatrix_apply, ← Matrix.map_mul,
      @reindex_linear_equiv_mul _ ι' _ _ _ _ R R, Basis.toMatrix_mul_toMatrix_flip,
      reindex_linear_equiv_one, ← RingHom.mapMatrix_apply, RingHom.map_one]
  calc
    A.charpoly = (reindex e e A).charpoly := (charpoly_reindex _ _).symm
    _ = (scalar ι' X - C.map_matrix (φ A)).det := rfl
    _ = (scalar ι' X - C.map_matrix (φ (P ⬝ A' ⬝ Q))).det := by
      rw [basis_toMatrix_mul_linearMap_toMatrix_mul_basis_toMatrix]
    _ = (scalar ι' X - C.map_matrix (φ₁ P ⬝ φ₂ A' ⬝ φ₃ Q)).det := by
      rw [reindex_linear_equiv_mul, reindex_linear_equiv_mul]
    _ = (scalar ι' X - C.map_matrix (φ₁ P) ⬝ C.map_matrix A' ⬝ C.map_matrix (φ₃ Q)).det := by simp
    _ =
        (scalar ι' X ⬝ C.map_matrix (φ₁ P) ⬝ C.map_matrix (φ₃ Q) -
            C.map_matrix (φ₁ P) ⬝ C.map_matrix A' ⬝ C.map_matrix (φ₃ Q)).det :=
      by rw [Matrix.mul_assoc ((scalar ι') X), hPQ, Matrix.mul_one]
    _ =
        (C.map_matrix (φ₁ P) ⬝ scalar ι' X ⬝ C.map_matrix (φ₃ Q) -
            C.map_matrix (φ₁ P) ⬝ C.map_matrix A' ⬝ C.map_matrix (φ₃ Q)).det :=
      by simp
    _ = (C.map_matrix (φ₁ P) ⬝ (scalar ι' X - C.map_matrix A') ⬝ C.map_matrix (φ₃ Q)).det := by
      rw [← Matrix.sub_mul, ← Matrix.mul_sub]
    _ =
        (C.map_matrix (φ₁ P)).det * (scalar ι' X - C.map_matrix A').det *
          (C.map_matrix (φ₃ Q)).det :=
      by rw [det_mul, det_mul]
    _ =
        (C.map_matrix (φ₁ P)).det * (C.map_matrix (φ₃ Q)).det *
          (scalar ι' X - C.map_matrix A').det :=
      by ring
    _ = (scalar ι' X - C.map_matrix A').det := by rw [← det_mul, hPQ, det_one, one_mul]
    _ = f.charpoly := rfl

#align linear_map.charpoly_to_matrix LinearMap.charpoly_toMatrix

end Basic

end LinearMap


import algebra.theory
import algebra.abelian
import tactic.unirewrite

/-
 * Basic operations and relations
-/
namespace binary_module

inductive ops : ℕ → Type
| zero : ops 0
| add : ops 2

inductive rels : ℕ → Type
| left_zero : rels 1
| right_zero : rels 1
| add_self : rels 1
| add_comm : rels 2
| add_assoc : rels 3

end binary_module

--- The theory of F2-vector spaces
@[reducible]
definition binary_module : theory :=
{
  op := binary_module.ops,
  rel := binary_module.rels,
  rel_lhs :=
    @binary_module.rels.rec (λ n _, optree binary_module.ops (finord n))
      ⦃binary_module.ops.add | ⦃binary_module.ops.zero|⦄, ◎finord.fz⦄
      ⦃binary_module.ops.add | ◎finord.fz, ⦃binary_module.ops.zero|⦄⦄
      ⦃binary_module.ops.add | ◎finord.fz, ◎finord.fz⦄
      ⦃binary_module.ops.add | ◎finord.fz, ◎finord.fz.fs⦄
      ⦃binary_module.ops.add | ⦃binary_module.ops.add | ◎finord.fz, ◎finord.fz.fs⦄,◎finord.fz.fs.fs⦄,
  rel_rhs :=
    @binary_module.rels.rec (λ n _, optree binary_module.ops (finord n))
      (◎finord.fz)
      (◎finord.fz)
      ⦃binary_module.ops.zero|⦄
      ⦃binary_module.ops.add | ◎finord.fz.fs, ◎finord.fz⦄
      ⦃binary_module.ops.add | ◎finord.fz, ⦃binary_module.ops.add | ◎finord.fz.fs, ◎finord.fz.fs.fs⦄⦄
}

/-
 * Primitive operations and propositions on F2-vector spaces
-/
namespace binary_module

@[reducible,inline]
protected
definition zero (α : Type _) [hpm : premodel binary_module α] : α :=
  @premodel.act binary_module α hpm _ binary_module.ops.zero vect.nil

@[reducible,inline]
protected
definition add {α : Type _} [hm : premodel binary_module α] : α → α → α :=
  λ a b, @premodel.act binary_module α hm _ binary_module.ops.add (vect.cons a (vect.cons b vect.nil))

definition has_binary_zero (α : Type _) [premodel binary_module α] : has_zero α := has_zero.mk (binary_module.zero α)

--- Useful to define an instance of `has_add α` by `attribute [instance] has_binary_add α` if `α` is a premodel of binary_module.
definition has_binary_add (α : Type _) [premodel binary_module α] : has_add α := has_add.mk binary_module.add

definition has_binary_neg (α : Type _) [premodel binary_module α] : has_neg α := has_neg.mk id

@[simp]
protected
lemma zero_add {α : Type _} [model binary_module α] : ∀ a, binary_module.add (binary_module.zero α) a = a :=
  begin
    intro a,
    let h := model.axiom_eq binary_module α binary_module.rels.left_zero (λ _,a),
    dsimp [binary_module] at h,
    repeat { unfold optree.elim at h; try {unfold optree.elim_aux at h} },
    dunfold binary_module.add,
    dunfold binary_module.zero,
    assumption
  end

@[simp]
protected
lemma add_zero {α : Type _} [model binary_module α] : ∀ a, binary_module.add a (binary_module.zero α) = a :=
  begin
    intro a,
    let h := model.axiom_eq binary_module α binary_module.rels.right_zero (λ _,a),
    dsimp [binary_module] at h,
    repeat { unfold optree.elim at h; try {unfold optree.elim_aux at h} },
    dunfold binary_module.add,
    dunfold binary_module.zero,
    assumption
  end

@[simp]
protected
lemma add_self {α : Type _} [model binary_module α] : ∀ a, binary_module.add a a = binary_module.zero α :=
  begin
    intro a,
    let h := model.axiom_eq binary_module α binary_module.rels.add_self (λ_,a),
    dsimp [binary_module] at h,
    repeat { unfold optree.elim at h; try {unfold optree.elim_aux at h} },
    dunfold binary_module.add,
    dunfold binary_module.zero,
    assumption
  end

@[simp]
protected
lemma add_comm {α : Type _} [model binary_module α] : ∀ (a b : α), binary_module.add a b = binary_module.add b a :=
  begin
    intros a b,
    let h := model.axiom_eq binary_module α binary_module.rels.add_comm (λ (o : finord 2), @finord.cases_on (λ_ _,α) _ o (λ_, a) (λ _ _, b)),
    dsimp [binary_module] at h,
    repeat { unfold optree.elim at h; try {unfold optree.elim_aux at h} },
    dunfold binary_module.add,
    assumption
  end

@[simp]
protected
lemma add_assoc {α : Type _} [model binary_module α] : ∀ (a b c : α), binary_module.add (binary_module.add a b) c = binary_module.add a (binary_module.add b c) :=
  begin
    intros a b c,
    let h := model.axiom_eq binary_module α binary_module.rels.add_assoc (λ (o : finord 3), @finord.cases_on (λ_ _,α) _ o (λ_, a) (λ _ o', @finord.cases_on (λ _ _,α) _ o' (λ _, b) (λ _ _, c))),
    dsimp [binary_module] at h,
    repeat { unfold optree.elim at h; try {unfold optree.elim_aux at h} },
    dunfold binary_module.add,
    assumption
  end

definition binary_abelian (α : Type _) [model binary_module α] : has_add_abelian α :=
{
  to_has_add := has_binary_add α,
  to_has_zero := has_binary_zero α,
  to_has_neg := has_binary_neg α,
  add_zero := binary_module.add_zero,
  add_neg := binary_module.add_self,
  add_comm := binary_module.add_comm,
  add_assoc := binary_module.add_assoc,
}

section arithm -- arithmetic rules

local attribute [instance] binary_abelian

lemma morphism.respect_zero {α β : Type _} [model binary_module α] [model binary_module β] (f : morphism binary_module α β) : f.val 0 = 0 :=
  begin
    unirewrite @has_zero.zero α _ with binary_module.zero α,
    unirewrite @has_zero.zero β _ with binary_module.zero β,
    dsimp [binary_module.zero],
    rw [f.property ops.zero],
    refl
  end

lemma morphism.respect_add {α β : Type _} [model binary_module α] [model binary_module β] (f : morphism binary_module α β) : ∀ x y, f.val (x+y) = f.val x + f.val y :=
  begin
    intros x y,
    unirewrite @has_add.add α _ with binary_module.add,
    unirewrite @has_add.add β _ with binary_module.add,
    dsimp [binary_module.add],
    rw [f.property ops.add],
    refl
  end

end arithm

--- The constant map at `zero` yields a morphism of binary modules.
definition morphism.zero (α β : Type _) [model binary_module α] [model binary_module β] : morphism binary_module α β :=
{
  val := λ _, binary_module.zero β,
  property :=
    begin
      intros n μ as,
      rw [vect.map_const],
      dsimp *,
      cases μ,
      case binary_module.ops.zero {
        dsimp [vect.repeat],
        refl
      },
      case binary_module.ops.add {
        dunfold vect.repeat,
        have : ∀ (b : β), vect.repeat b ((1 : ℕ).add 0) = vect.cons b vect.nil := λ _,rfl,
        rw [this],
        drefold binary_module.add _ _,
        rw [binary_module.zero_add]
      }
    end
}

--- The trivial binary_module is an initial model.
definition unit_is_initial : model.is_initial binary_module unit :=
{
  elim := λ β hb, @morphism.zero unit β _ hb,
  hunique :=
    begin
      intros β mb g a,
      cases a,
      dsimp [morphism.zero],
      have : punit.star = @premodel.act binary_module unit _ 0 binary_module.ops.zero vect.nil := rfl,
      rw [this,g.property],
      refl
    end
}

--- The theory `binary_module` has a trivial initial model.
instance has_trivial_init : model.has_trivial_init binary_module :=
{
  init_unit := binary_module.unit_is_initial
}

--- The fixed element is always the zero.
theorem fixed_elem_is_zero (α : Type _) [ha : model binary_module α] : @model.fixed_element binary_module binary_module.has_trivial_init α _ = @premodel.act binary_module α _ _ binary_module.ops.zero vect.nil :=
  model.fixed_const binary_module α binary_module.ops.zero

end binary_module


/-
POINTS: Welcome to the first CS2102 exam. The exam has 12
questions. Points for each question are as indicated, for a
total of 100 points.

READ CAREFULLY: If you are unable to answer a question in
a way that Lean accepts as syntactically correct, *comment
out your malformed answer*. Otherwise an error in your answer
can cause Lean not to recognize correct answers to other
questions. If you are sure an answer is correct but Lean is
not accepting it, look for problems in the preceding logic.

Do not change or delete any of the questions.

WHAT TO DO: Complete the exam by following the instructions
for each question. Save your file then upload the completed
and saved file to Collab. You have 75 minutes from the start
of the exam to the time where it must be uploaded to Collab.

OPEN NOTES: You may use the class notes for this exam, whether
provided to you by the instructors or taken by you (or for you).

STRICTLY INDIVIDUAL EFFORT: This is a strictly individual exam,
taken under the honor system. Do not communicate with anyone except
for the instructor about the content of this exam, by any means,
until you are sure that each person you are communicating with
has already completed the test.
-/

/- 1. (5 points)
What is the type of function1 (just below)? Give you answer by
replacing the hole (underscore) in the subsequent definition
with your answer.
-/

def function1 (f: ℕ → ℕ) (g: ℕ → ℕ) :=
  λ (x: ℕ), 3

#check function1

def function1_type : Type :=
  (ℕ → ℕ) → (ℕ → ℕ) → ℕ → ℕ

/- 2. (10 points)
Define three equivalent functions, called product1,
product2, and product3. Each must take two natural
numbers as its arguments and return their product.
Define the first version using C-style notation,
the second using a lambda abstraction, and the third
using a tactic script.
-/

-- Answer below:

-- ANSWER

-- C-style here

def product1 (n m : ℕ) : ℕ := n * m

-- Lambda abstraction here
def product2: ℕ → ℕ → ℕ :=
λ n m, n * m

-- Tactic script here
def product3: ℕ → ℕ → ℕ :=
begin
intros n m,
exact n * m,
end

/- 3. (5 points)

Given the definition of product1, what function
is (product1 5)? Answer by replacing the hole in
the following definition with a lambda abstraction.
-/

def product1_5 := λ m, 5 * m

/- 4. (5 points)
Which of the following properties does "product1_5" have?
Answer by placing a Y (for yes, it has this property), or
N (for no, it doesn't have this property), BEFORE the name
of each property, just after the dash.

-- ANSWER

- Y injective
- N surjective
- N one-to-many
- N strictly partial
- N bijective
-/

/- 5. (5 points)
Complete the  proof of the following conjecture, that
(product1 4 6) = 24. Fill in the proposition to be
proved in the first hole (underscore) and a proof in
the second hole.
-/

-- ANSWER
example : (product1 4 6) = 24 := rfl

/- 6. (10 points)
State and prove the proposition that, for any natural
numbers, a, b, and c, if b = a, then if c = b, then a = c.
Fill in the holes in the following example accordingly,
replacing the underscores first with a formal statement
of the proposition, and then a proof of it, respectively.
-/

-- Complete  by replacing the hole with a proof:
example: ∀ a b c: ℕ, b = a → c = b → a = c :=
begin
intros a b c,
assume ba cb,
have ab := eq.symm ba,
have bc := eq.symm cb,
exact eq.trans ab bc
end

/- 7. (10 points)
In the context of the following assumptions, use
"example" to formally state and prove the proposition
that "Jane is nice."
-/

axiom Person : Type
axioms Jill Jane : Person
axiom IsNice : Person → Prop
axiom JillIsNice : IsNice Jill
axiom JillIsJane : Jill = Jane

-- Fill in the holes with your proposition and proof
example : IsNice Jane :=
    eq.subst JillIsJane JillIsNice

/- 8. (10 points)
Use "example" to prove that true ∧ true is true.  Give two proofs, the first using a term-style
proof, the second using a tactic script.
-/

-- Your answers here

-- either one of the following would be ok

example : true ∧ true → true :=
λ tt, tt.left

example : true ∧ true :=
and.intro true.intro true.intro

/- 9. (10 points)
Define a function, called exfalso, that takes a proof
of false as an argument, and that returns a proof of
3 = 7 as a result.
-/

-- ANSWER

def exfalse (f : false) : 3 = 7 := false.elim f

/- 10. (10 points)
Formally state and prove the proposition,
that, for any propositions, A, B, and C,
A ∧ B ∧ C → C ∧ A ∧ B. You may write the
proof in any style you wish. One way to do it
would be to define a function that takes the
propositions, A, B, and C, and a proof of the
premise as its arguments and that returns a
proof of the conclusion as a result. You
might also use a tactic script.
-/

-- ANSWER

example : ∀ A B C : Prop, A ∧ B ∧ C → C ∧ A ∧ B :=
begin
intros A B C,
assume h,
have a := h.left,
have bc := h.right,
have b := bc.left,
have c := bc.right,
have ab := and.intro a b,
exact and.intro c ab,
end

/- 11. (10 points)
Formally (in Lean), prove that if A, B, and C
are any propositions, and if C is true, then
A ∧ B ∧ C → B ∧ A.
-/

-- Complete the following by replacing _ with a proof:
example: ∀(A B C: Prop), C → (A ∧ B ∧ C → B ∧ A) :=
begin
intros A B C,
assume c,
assume abc,
have a := abc.left,
have b := abc.right.left,
exact and.intro b a,
end

/- 12. (10 points)

Define a predicate, gt5, that is true for all and only for
natural numbers greater than 5. You may use the expression,
n > 5, in your answer. Then fill in the hole in the following
definition with the type of the term (gt5 4).
-/

-- ANSWER
def gt5 : ℕ → Prop :=
λ n, n > 5

-- ANSWER
#check gt5 4

def type_of_gt5_4 := Prop

/- 13. EXTRA CREDIT 5 points

Give brief natural-language (in English) rendition
of the following formal propositions.

∃ n, m : ℕ, isPrime n ∧ isPrime m ∧ m = n + 2

Answer: There are natural numbers, n and m, such that both
n and m are prime and m is just two larger than n. (Note:
such a pair of prime numbers is called a "prime pair" in
the mathematical literature.)

If by isPrime we mean the ordinary concept of primeness
from basic arithmetic, then the second proposition is true.
Prove it by giving values for n and m that satisfy the
predicate along with a very brief argument that the two
numbers do actually satisfy the predicate.

Answer:

n = 5
m = 7

Argument: Both 5 and 7 are prime (obvious) and 7 is two larger
than 5 (also trivial).

-/


import .group_representation
universe variables u v w w' w'' w'''

open linear_map

variables {G : Type u} [group G] {R : Type v}[ring R]

namespace morphism
variables {M : Type w}  [add_comm_group M] [module R M]
          {M' : Type w'} [add_comm_group M'] [module R M']

/--
  a morphism `f : ρ ⟶ π` between representation is a linear map `f.ℓ : M(ρ) →ₗ[R] M(π)` satisfying
    `f.ℓ ∘   ρ g  = π g  ∘   f.ℓ` has function on `set`.
-/
structure morphism  (ρ : group_representation G R M) (π : group_representation G R M') : Type (max w w') :=
  (ℓ : M →ₗ[R] M')
  (commute : ∀(g : G), ℓ ∘   ρ g  = π g  ∘   ℓ) --- en terme d'élément !

variables (ρ : group_representation G R M)

infixr ` ⟶ `:25 := morphism

@[ext]lemma ext  {ρ : group_representation G R M} {ρ'  : group_representation G R M'} ( f g : ρ ⟶ ρ') :
(f.ℓ)  = g.ℓ  → f = g :=
begin
    intros,
    cases f,cases g , congr'; try {assumption},
end

variables  (ρ'  : group_representation G R M')

instance : has_coe_to_fun (morphism ρ ρ') := ⟨_,λ f, f.ℓ.to_fun⟩

lemma coersion (f : ρ ⟶ ρ') : ⇑f = (f.ℓ) := rfl

theorem commute_apply ( f : ρ ⟶  ρ') (x : M) (g : G) : f ( ρ g x) = ρ' g (f x ) := begin
      change (f.ℓ  ∘ ρ g ) x = _,
      rw f.commute, exact rfl,
  end
theorem 𝒞_o_e_r_s_i_o_n__s__ℓ( f : ρ ⟶  ρ')(g : G) : f.ℓ ∘ ρ g =  ((linear_map.comp (f.ℓ) ((ρ g): M →ₗ[R]M  ) : M → M')) := rfl

def one (ρ : group_representation G R M) : ρ ⟶ ρ :=
{ ℓ         := linear_map.id,
  commute   := λ g, rfl
}

notation `𝟙` := one
end morphism


-- ----------------------------------------------------
-- Ejercicio. Demostrar
--    p ∧ (q ∧ r) ⊢ (p ∧ q) ∧ r
-- ----------------------------------------------------

import tactic
variables (p q r : Prop)

-- 1ª demostración
example
  (Hpqr : p ∧ (q ∧ r))
  : (p ∧ q) ∧ r :=
begin
  cases Hpqr with Hp Hqr,
  cases Hqr with Hq Hr,
  split,
  { split,
    { exact Hp, },
    { exact Hq, }},
  { exact Hr, },
end

-- 2ª demostración
example
  (Hpqr : p ∧ (q ∧ r))
  : (p ∧ q) ∧ r :=
begin
  cases Hpqr with Hp Hqr,
  cases Hqr with Hq Hr,
  split,
  { exact ⟨Hp, Hq⟩, },
  { exact Hr, },
end

-- 3ª demostración
example
  (Hpqr : p ∧ (q ∧ r))
  : (p ∧ q) ∧ r :=
begin
  cases Hpqr with Hp Hqr,
  cases Hqr with Hq Hr,
  exact ⟨⟨Hp, Hq⟩, Hr⟩,
end

-- 4ª demostración
example
  (Hpqr : p ∧ (q ∧ r))
  : (p ∧ q) ∧ r :=
begin
  rcases Hpqr with ⟨Hp, ⟨Hq, Hr⟩⟩,
  exact ⟨⟨Hp, Hq⟩, Hr⟩,
end

-- 5ª demostración
example :
  p ∧ (q ∧ r) → (p ∧ q) ∧ r :=
begin
  rintros ⟨Hp, ⟨Hq, Hr⟩⟩,
  exact ⟨⟨Hp, Hq⟩, Hr⟩,
end

-- 6ª demostración
example :
  p ∧ (q ∧ r) → (p ∧ q) ∧ r :=
λ ⟨Hp, ⟨Hq, Hr⟩⟩, ⟨⟨Hp, Hq⟩, Hr⟩

-- 7ª demostración
example
  (Hpqr : p ∧ (q ∧ r))
  : (p ∧ q) ∧ r :=
have Hp : p,
  from and.left Hpqr,
have Hqr : q ∧ r,
  from and.right Hpqr,
have Hq : q,
  from and.left Hqr,
have Hr : r,
  from and.right Hqr,
have Hpq : p ∧ q,
  from and.intro Hp Hq,
show (p ∧ q) ∧ r,
  from and.intro Hpq Hr

-- 8ª demostración
example
  (Hpqr : p ∧ (q ∧ r))
  : (p ∧ q) ∧ r :=
-- by library_search
(and_assoc p q).mpr Hpqr

-- 9ª demostración
example
  (Hpqr : p ∧ (q ∧ r))
  : (p ∧ q) ∧ r :=
-- by hint
by tauto

-- 10ª demostración
example
  (Hpqr : p ∧ (q ∧ r))
  : (p ∧ q) ∧ r :=
by finish


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

/-!
# Finite equipartitions

This file defines finite equipartitions, the partitions whose parts all are the same size up to a
difference of `1`.

## Main declarations

* `finpartition.is_equipartition`: Predicate for a `finpartition` to be an equipartition.
-/

open finset fintype

namespace finpartition
variables {α : Type*} [decidable_eq α] {s t : finset α} (P : finpartition s)

/-- An equipartition is a partition whose parts are all the same size, up to a difference of `1`. -/
def is_equipartition : Prop := (P.parts : set (finset α)).equitable_on card

lemma is_equipartition_iff_card_parts_eq_average : P.is_equipartition ↔
  ∀ a : finset α, a ∈ P.parts → a.card = s.card/P.parts.card ∨ a.card = s.card/P.parts.card + 1 :=
by simp_rw [is_equipartition, finset.equitable_on_iff, P.sum_card_parts]

variables {P}

lemma _root_.set.subsingleton.is_equipartition (h : (P.parts : set (finset α)).subsingleton) :
  P.is_equipartition :=
h.equitable_on _

lemma is_equipartition.card_parts_eq_average (hP : P.is_equipartition) (ht : t ∈ P.parts) :
  t.card = s.card / P.parts.card ∨ t.card = s.card / P.parts.card + 1 :=
P.is_equipartition_iff_card_parts_eq_average.1 hP _ ht

lemma is_equipartition.card_part_le_average_add_one (hP : P.is_equipartition) (ht : t ∈ P.parts) :
  t.card ≤ s.card / P.parts.card + 1 :=
by { rw ←P.sum_card_parts, exact equitable_on.le_add_one hP ht }

/-! ### Discrete and indiscrete finpartition -/

variables (s)

lemma bot_is_equipartition : (⊥ : finpartition s).is_equipartition :=
set.equitable_on_iff_exists_eq_eq_add_one.2 ⟨1, by simp⟩

lemma top_is_equipartition : (⊤ : finpartition s).is_equipartition :=
(parts_top_subsingleton _).is_equipartition

lemma indiscrete_is_equipartition {hs : s ≠ ∅} : (indiscrete hs).is_equipartition :=
by { rw [is_equipartition, indiscrete_parts, coe_singleton], exact set.equitable_on_singleton s _ }

end finpartition