import .basic
import function.misc function.bijection

universe u

@[reducible]
definition is_free (th : theory) {α : Sort _} {β : Type _} [mb : model th β] (j : α → β) : Prop :=
  ∀ {γ : Type u} [mc : model th γ] (f : α → γ), ∃! (g : @morphism th β γ mb.to_premodel mc.to_premodel), ∀ (a : α), g.val (j a) = f a

lemma free_on_bijective_bases (th : theory) {α β : Sort _} {φ : Type _} [mb : model th φ] (u : bijection α β) (j : β → φ) : is_free.{u} th j → is_free.{u} th (j∘ u.to_fun) :=
  begin
    intros hfree,
    intros ψ mpsi g,
    cases @hfree ψ mpsi (g∘ u.inv) with g₁ hg₁,
    existsi g₁,
    dsimp [function.comp] at *,
    split,
    show ∀ (a : α), g₁.val (j (u.to_fun a)) = g a, {
      intros a,
      by calc
        g₁.val (j (u.to_fun a))
            = g (u.inv (u.to_fun a)) : hg₁.left (u.to_fun a)
        ... = g a : by rw [u.left_inverse a]
    },
    show ∀ (g' : @morphism th φ ψ _ mpsi.to_premodel), (∀ a, g'.val (j (u.to_fun a)) = g a) → g' = g₁, {
      intros g' hg',
      apply hg₁.right g',
      intros b,
      by calc
        g'.val (j b)
            = g'.val (j (u.to_fun (u.inv b))) : by rw [u.right_inverse b]
        ... = g (u.inv b) : hg' (u.inv b)
    }
  end

#print axioms free_on_bijective_bases

-- TO DO: define the free algebraic model using optree


import ECTate.Algebra.EllipticCurve.TateInt

open Int Model ValidModel SurjVal

/-! Following Shankar-Shankar-Wang, Large families of elliptic curves ordered by conductor
-/
variable {p : ℕ} (hp : Nat.Prime p) (hn23 : p ≠ 2 ∧ p ≠ 3) (a b c : ℤ) (habc)

lemma c4_abc : Model.c4 ⟨0, a, 0, b, c⟩ = 16 * a ^ 2 - 48 * b :=
by
  simp [c4, b2, b4]
  ring

lemma discr_abc :
  Model.discr ⟨0, a, 0, b, c⟩ = -16*a^2*(4*a*c - b^2) + 288*a*b*c - 64*b^3 - 432*c^2 :=
by
  simp [discr, b8, b6, b2, b4]
  ring

lemma val_discr_abc :
  val_discr_to_nat (primeEVR hp).valtn ⟨⟨0, a, 0, b, c⟩, habc⟩ =
    nat_of_val (primeEVR hp).valtn (fun h => habc (by rwa [discr_abc]) : (-16*a^2*(4*a*c - b^2) + 288*a*b*c - 64*b^3 - 432*c^2) ≠ 0) :=
by
  rw [Enat.eq_ofN, ofN_val_discr_to_nat]
  conv =>
    lhs
    rw [discr_abc]
  simp [nat_of_val]

-- lemma kodaira_I0 (hcon : (primeEVR hp).valtn (Model.discr ⟨0, a, 0, b, c⟩) = 0) :
--   (tate_algorithm p hp ⟨⟨0, a, 0, b, c⟩, habc⟩).1 = .I 0 :=
-- by
--   rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
--   generalize h : (⟨⟨0,a,0,b,c⟩, _⟩ : ValidModel ℤ) = e
--   have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_abc]
--   sorry
--   have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 0
--   . simp [← h, val_discr_abc hp a b c habc, nat_of_val, c4_abc]
--     sorry
--   simp [valdisc']

-- lemma kodaira_In (n : ℕ) (hn : n ≥ 1)
--   (hcona : (primeEVR hp).valtn a = 0)
--   (hconb : (primeEVR hp).valtn b ≥ ((n + 1)/2 : ℕ))
--   (hconc : (primeEVR hp).valtn c = n) :
--   (tate_algorithm p hp ⟨⟨0, a, 0, b, c⟩, habc⟩).1 = .I n :=
-- by
--   rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
--   generalize h : (⟨⟨0,a,0,b,c⟩, _⟩ : ValidModel ℤ) = e
--   have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_abc]
--   have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 8
--   . simp [← h, val_discr_abc hp a b c habc, nat_of_val, c4_abc]
--   simp [valc4, valdisc']

-- lemma kodaira_II
--   (hcona : (primeEVR hp).valtn a ≥ 1)
--   (hconb : (primeEVR hp).valtn b ≥ 1)
--   (hconc : (primeEVR hp).valtn c = 1) :
--   (tate_algorithm p hp ⟨⟨0, a, 0, b, c⟩, habc⟩).1 = .II :=
-- by
--   rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
--   generalize h : (⟨⟨0,a,0,b,c⟩, _⟩ : ValidModel ℤ) = e
--   have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_abc]
--   have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 8
--   . simp [← h, val_discr_abc hp a b c habc, nat_of_val, c4_abc]
--   simp [valc4, valdisc']

-- lemma kodaira_III
--   (hcona : (primeEVR hp).valtn a ≥ 1)
--   (hconb : (primeEVR hp).valtn b = 1)
--   (hconc : (primeEVR hp).valtn c ≥ 2) :
--   (tate_algorithm p hp ⟨⟨0, a, 0, b, c⟩, habc⟩).1 = .III :=
-- by
--   rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
--   generalize h : (⟨⟨0,a,0,b,c⟩, _⟩ : ValidModel ℤ) = e
--   have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_abc]
--   have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 8
--   . simp [← h, val_discr_abc hp a b c habc, nat_of_val, c4_abc]
--   simp [valc4, valdisc']

-- lemma kodaira_IV
--   (hcona : (primeEVR hp).valtn a ≥ 1)
--   (hconb : (primeEVR hp).valtn b ≥ 2)
--   (hconc : (primeEVR hp).valtn c = 2) :
--   (tate_algorithm p hp ⟨⟨0, a, 0, b, c⟩, habc⟩).1 = .IV :=
-- by
--   rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
--   generalize h : (⟨⟨0,a,0,b,c⟩, _⟩ : ValidModel ℤ) = e
--   have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_abc]
--   have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 8
--   . simp [← h, val_discr_abc hp a b c habc, nat_of_val, c4_abc]
--   simp [valc4, valdisc']

-- lemma kodaira_Is0 (hcon : (primeEVR hp).valtn (Model.discr ⟨0, a, 0, b, c⟩) < 7)
--   (hcona : (primeEVR hp).valtn a ≥ 1)
--   (hconb : (primeEVR hp).valtn b ≥ 2)
--   (hconc : (primeEVR hp).valtn c ≥ 3) :
--   (tate_algorithm p hp ⟨⟨0, a, 0, b, c⟩, habc⟩).1 = .Is 0 :=
-- by
--   rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
--   generalize h : (⟨⟨0,a,0,b,c⟩, _⟩ : ValidModel ℤ) = e
--   have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_abc]
--   have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 8
--   . simp [← h, val_discr_abc hp a b c habc, nat_of_val, c4_abc]
--   simp [valc4, valdisc']

-- lemma kodaira_Is {n : ℕ} (hn : n ≥ 1)
--   (hcona : (primeEVR hp).valtn a = 1)
--   (hconb : (primeEVR hp).valtn b ≥ ((n + 1)/2 + 2 : ℕ))
--   (hconc : (primeEVR hp).valtn c ≥ n + 3) :
--   (tate_algorithm p hp ⟨⟨0, a, 0, b, c⟩, habc⟩).1 = .Is n :=
-- by
--   rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
--   generalize h : (⟨⟨0,a,0,b,c⟩, _⟩ : ValidModel ℤ) = e
--   have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_abc]
--   have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 8
--   . simp [← h, val_discr_abc hp a b c habc, nat_of_val, c4_abc]
--   simp [valc4, valdisc']

-- lemma kodaira_IVs
--   (hcona : (primeEVR hp).valtn a ≥ 2)
--   (hconb : (primeEVR hp).valtn b ≥ 3)
--   (hconc : (primeEVR hp).valtn c = 4) :
--   (tate_algorithm p hp ⟨⟨0, a, 0, b, c⟩, habc⟩).1 = .IVs :=
-- by
--   rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
--   generalize h : (⟨⟨0,a,0,b,c⟩, _⟩ : ValidModel ℤ) = e
--   have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_abc]
--   have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 8
--   . simp [← h, val_discr_abc hp a b c habc, nat_of_val, c4_abc]
--   simp [valc4, valdisc']

-- lemma kodaira_IIIs
--   (hcona : (primeEVR hp).valtn a ≥ 2)
--   (hconb : (primeEVR hp).valtn b ≥ 3)
--   (hconc : (primeEVR hp).valtn c ≥ 5) :
--   (tate_algorithm p hp ⟨⟨0, a, 0, b, c⟩, habc⟩).1 = .IIIs :=
-- by
--   rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
--   generalize h : (⟨⟨0,a,0,b,c⟩, _⟩ : ValidModel ℤ) = e
--   have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_abc]
--   have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 8
--   . simp [← h, val_discr_abc hp a b c habc, nat_of_val, c4_abc]
--   simp [valc4, valdisc']

-- lemma kodaira_IIs
--   (hcona : (primeEVR hp).valtn a ≥ 2)
--   (hconb : (primeEVR hp).valtn b ≥ 4)
--   (hconc : (primeEVR hp).valtn c = 5) :
--   (tate_algorithm p hp ⟨⟨0, a, 0, b, c⟩, habc⟩).1 = .IIs :=
-- by
--   rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
--   generalize h : (⟨⟨0,a,0,b,c⟩, _⟩ : ValidModel ℤ) = e
--   have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_abc]
--   have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 8
--   . simp [← h, val_discr_abc hp a b c habc, nat_of_val, c4_abc]
--   simp [valc4, valdisc']


/-!
# Basic Types and Helpers
-/

section NoMathlib
  --- Commutativity.
  @[simp, inline]
  def commutes (op : α → α → α) : Prop :=
    ∀ a₁ a₂,
      op a₁ a₂ = op a₂ a₁

  class Zero (α : Type u) :=
    zero : α
  instance : Zero Nat := ⟨0⟩
  instance : Zero Int := ⟨0⟩

  open Zero (zero)

  class One (α : Type u) :=
    one : α
  instance : One Nat := ⟨1⟩
  instance : One Int := ⟨1⟩

  open One (one)
end NoMathlib

section Range
  --- A range, inclusive on both ends.
  abbrev Range α := α × α

  infix:min "··" => (fun lb ub => ((lb, ub) : Range _))

  --- Conversion from regular products to ranges.
  instance : Coe (α × α) (Range α) where
    coe := id
  --- Conversion from ranges to regular products.
  instance : Coe (Range α) (α × α) where
    coe := id

  --- Length of a range.
  def Prod.len [Sub α] (self : Range α) : α :=
    self.1 - self.2

  --- `True` if the range is empty.
  def Prod.isEmpty [LT α] (self : Range α) : Prop :=
    self.2 < self.1
  --- `Prod.isEmpty` is decidable.
  instance
    [inst : LT α] [decLt : DecidableRel inst.lt]
    {self : Range α}
    : Decidable self.isEmpty
  :=
    by apply decLt

  --- Inclusive range over naturals.
  partial def Prod.fold
    (range : Range Int)
    (acc : α)
    (fld : α → Int → α)
    : α
  :=
    if range.1 ≤ range.2 then
      let acc := fld acc range.1
      let range := range.1 + 1 ·· range.2
      range.fold acc fld
    else
      acc
end Range

section Conv
  --- Total conversion from `src` to `tgt`.
  class Of (src: Type s) (tgt : Type t)where
    of : src → tgt

  postfix:55 " :>" => Of.of

  --- Conversion to self.
  instance : Of α α where
    of := id

  --- `OfNat → Of Nat`
  instance {conv : (n : Nat) → OfNat α n} : Of Nat α where
    of val :=
      conv val
      |>.ofNat

  --- `Of` is transitive.
  instance instTransOf [ofαβ : Of α β] [ofβγ : Of β γ] : Of α γ where
    of a :=
      ofαβ.of a
      |> ofβγ.of
end Conv

namespace Int
  /-!
# Lemmas for `Int`

`Int` is lacking in lemmas in that it has basically none.

The lemmas in this section are going to be useful
  -/

  --- Addition is commutative.
  theorem add_comm :
    ∀ (i₁ i₂ : Int), i₁ + i₂ = i₂ + i₁
  := by
    intros i₁ i₂
    cases i₁
    <;> cases i₂
    <;> simp [HAdd.hAdd, Add.add, Int.add]
    <;> rw [Nat.add_comm]

  --- Multiplication is commutative.
  theorem mul_comm :
    ∀ (i₁ i₂ : Int), i₁ * i₂ = i₂ * i₁
  := by
    intros i₁ i₂
    cases i₁
    <;> cases i₂
    <;> simp [HMul.hMul, Mul.mul, Int.mul, Nat.mul_comm]
    <;> rw [Nat.mul_comm]

  --- Zero is left-neutral for `+`.
  theorem zero_add (i : Int) : 0 + i = i := by
      simp [HAdd.hAdd, Add.add, Int.add]
      cases i
      <;> simp [subNatNat]

  --- Zero is right-neutral for `+`.
  theorem add_zero (i : Int) : i + 0 = i := by
      rw [add_comm]
      exact zero_add i

  --- One is left-neutral for `*`.
  theorem one_mul (i : Int) : 1 * i = i := by
      simp [HMul.hMul, Mul.mul, Int.mul]
      cases i
      <;> simp [negOfNat]

  --- One is right-neutral for `*`.
  theorem mul_one (i : Int) : i * 1 = i := by
      rw [mul_comm]
      exact one_mul i
end Int


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.subtype.basic
import Mathlib.Lean3Lib.init.funext

universes u v

namespace Mathlib

namespace classical

/- the axiom -/

axiom choice {α : Sort u} : Nonempty α → α

theorem indefinite_description {α : Sort u} (p : α → Prop) (h : ∃ (x : α), p x) :
    Subtype fun (x : α) => p x :=
  sorry

def some {α : Sort u} {p : α → Prop} (h : ∃ (x : α), p x) : α :=
  subtype.val (indefinite_description p h)

theorem some_spec {α : Sort u} {p : α → Prop} (h : ∃ (x : α), p x) : p (some h) :=
  subtype.property (indefinite_description p h)

/- Diaconescu's theorem: using function extensionality and propositional extensionality,
   we can get excluded middle from this. -/

/- TODO(Leo): check why the code generator is not ignoring (some exU)
   when we mark u as def. -/

theorem em (p : Prop) : p ∨ ¬p :=
  or.elim (not_uv_or_p p) (fun (hne : u p ≠ v p) => Or.inr (mt (p_implies_uv p) hne)) Or.inl

theorem exists_true_of_nonempty {α : Sort u} : Nonempty α → ∃ (x : α), True :=
  fun (ᾰ : Nonempty α) =>
    nonempty.dcases_on ᾰ fun (ᾰ : α) => idRhs (∃ (x : α), True) (Exists.intro ᾰ trivial)

def inhabited_of_nonempty {α : Sort u} (h : Nonempty α) : Inhabited α :=
  { default := Classical.choice h }

def inhabited_of_exists {α : Sort u} {p : α → Prop} (h : ∃ (x : α), p x) : Inhabited α :=
  inhabited_of_nonempty sorry

/- all propositions are decidable -/

def prop_decidable (a : Prop) : Decidable a := Classical.choice sorry

def decidable_inhabited (a : Prop) : Inhabited (Decidable a) := { default := prop_decidable a }

def type_decidable_eq (α : Sort u) : DecidableEq α := fun (x y : α) => prop_decidable (x = y)

def type_decidable (α : Sort u) : psum α (α → False) := sorry

theorem strong_indefinite_description {α : Sort u} (p : α → Prop) (h : Nonempty α) :
    Subtype fun (x : α) => (∃ (y : α), p y) → p x :=
  sorry

/- the Hilbert epsilon function -/

def epsilon {α : Sort u} [h : Nonempty α] (p : α → Prop) : α :=
  subtype.val (strong_indefinite_description p h)

theorem epsilon_spec_aux {α : Sort u} (h : Nonempty α) (p : α → Prop) :
    (∃ (y : α), p y) → p (epsilon p) :=
  subtype.property (strong_indefinite_description p h)

theorem epsilon_spec {α : Sort u} {p : α → Prop} (hex : ∃ (y : α), p y) : p (epsilon p) :=
  epsilon_spec_aux (nonempty_of_exists hex) p hex

theorem epsilon_singleton {α : Sort u} (x : α) : (epsilon fun (y : α) => y = x) = x :=
  epsilon_spec (Exists.intro x rfl)

/- the axiom of choice -/

theorem axiom_of_choice {α : Sort u} {β : α → Sort v} {r : (x : α) → β x → Prop}
    (h : ∀ (x : α), ∃ (y : β x), r x y) : ∃ (f : (x : α) → β x), ∀ (x : α), r x (f x) :=
  Exists.intro (fun (x : α) => some (h x)) fun (x : α) => some_spec (h x)

theorem skolem {α : Sort u} {b : α → Sort v} {p : (x : α) → b x → Prop} :
    (∀ (x : α), ∃ (y : b x), p x y) ↔ ∃ (f : (x : α) → b x), ∀ (x : α), p x (f x) :=
  sorry

theorem prop_complete (a : Prop) : a = True ∨ a = False :=
  or.elim (em a) (fun (t : a) => Or.inl (eq_true_intro t)) fun (f : ¬a) => Or.inr (eq_false_intro f)

def eq_true_or_eq_false (a : Prop) : a = True ∨ a = False := prop_complete

theorem cases_true_false (p : Prop → Prop) (h1 : p True) (h2 : p False) (a : Prop) : p a :=
  or.elim (prop_complete a) (fun (ht : a = True) => Eq.symm ht ▸ h1)
    fun (hf : a = False) => Eq.symm hf ▸ h2

theorem cases_on (a : Prop) {p : Prop → Prop} (h1 : p True) (h2 : p False) : p a :=
  cases_true_false p h1 h2 a

-- this supercedes by_cases in decidable

def by_cases {p : Prop} {q : Prop} (hpq : p → q) (hnpq : ¬p → q) : q := decidable.by_cases hpq hnpq

-- this supercedes by_contradiction in decidable

theorem by_contradiction {p : Prop} (h : ¬p → False) : p := decidable.by_contradiction h

theorem eq_false_or_eq_true (a : Prop) : a = False ∨ a = True := or.symm (prop_complete a)

end Mathlib


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.finite_products
import category_theory.limits.preserves.shapes.products
import category_theory.limits.preserves.shapes.equalizers
import category_theory.limits.preserves.finite

/-!
# Constructing limits from products and equalizers.

If a category has all products, and all equalizers, then it has all limits.
Similarly, if it has all finite products, and all equalizers, then it has all finite limits.

If a functor preserves all products and equalizers, then it preserves all limits.
Similarly, if it preserves all finite products and equalizers, then it preserves all finite limits.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

open category_theory
open opposite

namespace category_theory.limits

universes w v v₂ u u₂
variables {C : Type u} [category.{v} C]

variables {J : Type w} [small_category J]

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

variables {F : J ⥤ C}
          {c₁ : fan F.obj}
          {c₂ : fan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2)}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), s ≫ c₂.π.app ⟨f⟩ = c₁.π.app ⟨f.1.1⟩ ≫ F.map f.2)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), t ≫ c₂.π.app ⟨f⟩ = c₁.π.app ⟨f.1.2⟩)
          (i : fork s t)

include hs ht
/--
(Implementation) Given the appropriate product and equalizer cones, build the cone for `F` which is
limiting if the given cones are also.
-/
@[simps]
def build_limit : cone F :=
{ X := i.X,
  π :=
  { app := λ j, i.ι ≫ c₁.π.app ⟨_⟩,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.id_comp, category.assoc, ← hs ⟨⟨_, _⟩, f⟩, i.condition_assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cone constructed in `build_limit` is limiting, provided the cones used in
its construction are.
-/
def build_is_limit (t₁ : is_limit c₁) (t₂ : is_limit c₂) (hi : is_limit i) :
  is_limit (build_limit s t hs ht i) :=
{ lift := λ q,
  begin
    refine hi.lift (fork.of_ι _ _),
    { refine t₁.lift (fan.mk _ (λ j, _)),
      apply q.π.app j },
    { apply t₂.hom_ext,
      intro j, discrete_cases,
      simp [hs, ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.equalizer_ext (t₁.hom_ext
    (λ j, by { cases j, simpa using w j }))) }

end has_limit_of_has_products_of_has_equalizers

open has_limit_of_has_products_of_has_equalizers

/--
Given the existence of the appropriate (possibly finite) products and equalizers,
we can construct a limit cone for `F`.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
noncomputable
def limit_cone_of_equalizer_and_product (F : J ⥤ C)
  [has_limit (discrete.functor F.obj)]
  [has_limit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2))]
  [has_equalizers C] : limit_cone F :=
{ cone := _,
  is_limit :=
    build_is_limit
      (pi.lift (λ f, limit.π (discrete.functor F.obj) ⟨_⟩ ≫ F.map f.2))
      (pi.lift (λ f, limit.π (discrete.functor F.obj) ⟨f.1.2⟩))
      (by simp)
      (by simp)
      (limit.is_limit _)
      (limit.is_limit _)
      (limit.is_limit _) }

/--
Given the existence of the appropriate (possibly finite) products and equalizers, we know a limit of
`F` exists.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
lemma has_limit_of_equalizer_and_product (F : J ⥤ C)
  [has_limit (discrete.functor F.obj)]
  [has_limit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2))]
  [has_equalizers C] : has_limit F :=
has_limit.mk (limit_cone_of_equalizer_and_product F)

/-- A limit can be realised as a subobject of a product. -/
noncomputable
def limit_subobject_product [has_limits_of_size.{w w} C] (F : J ⥤ C) :
  limit F ⟶ ∏ (λ j, F.obj j) :=
(limit.iso_limit_cone (limit_cone_of_equalizer_and_product F)).hom ≫ equalizer.ι _ _

instance limit_subobject_product_mono [has_limits_of_size.{w w} C] (F : J ⥤ C) :
  mono (limit_subobject_product F) :=
mono_comp _ _

/--
Any category with products and equalizers has all limits.

See <https://stacks.math.columbia.edu/tag/002N>.
-/
lemma limits_from_equalizers_and_products
  [has_products.{w} C] [has_equalizers C] : has_limits_of_size.{w w} C :=
{ has_limits_of_shape := λ J 𝒥,
  { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F } }

/--
Any category with finite products and equalizers has all finite limits.

See <https://stacks.math.columbia.edu/tag/002O>.
-/
lemma finite_limits_from_equalizers_and_finite_products
  [has_finite_products C] [has_equalizers C] : has_finite_limits C :=
⟨λ J _ _, { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F }⟩

variables {D : Type u₂} [category.{v₂} D]
noncomputable theory

section

variables [has_limits_of_shape (discrete J) C]
          [has_limits_of_shape (discrete (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_equalizers C]
variables (G : C ⥤ D)
          [preserves_limits_of_shape walking_parallel_pair G]
          [preserves_limits_of_shape (discrete.{w} J) G]
          [preserves_limits_of_shape (discrete.{w} (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves equalizers and the appropriate products, it preserves limits. -/
def preserves_limit_of_preserves_equalizers_and_product :
  preserves_limits_of_shape J G :=
{ preserves_limit := λ K,
  begin
    let P := ∏ K.obj,
    let Q := ∏ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.2),
    let s : P ⟶ Q := pi.lift (λ f, limit.π (discrete.functor K.obj) ⟨_⟩ ≫ K.map f.2),
    let t : P ⟶ Q := pi.lift (λ f, limit.π (discrete.functor K.obj) ⟨f.1.2⟩),
    let I := equalizer s t,
    let i : I ⟶ P := equalizer.ι s t,
    apply preserves_limit_of_preserves_limit_cone
      (build_is_limit s t (by simp) (by simp)
        (limit.is_limit _)
        (limit.is_limit _)
        (limit.is_limit _)),
    refine is_limit.of_iso_limit (build_is_limit _ _ _ _ _ _ _) _,
    { exact fan.mk _ (λ j, G.map (pi.π _ j)) },
    { exact fan.mk (G.obj Q) (λ f, G.map (pi.π _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { apply fork.of_ι (G.map i) _,
      simp only [← G.map_comp, equalizer.condition] },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_fork_map_of_is_limit,
      apply equalizer_is_equalizer },
    refine cones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves equalizers and finite products, it preserves finite limits. -/
def preserves_finite_limits_of_preserves_equalizers_and_finite_products
  [has_equalizers C] [has_finite_products C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G]
  [∀ (J : Type) [fintype J], preserves_limits_of_shape (discrete J) G] :
  preserves_finite_limits G :=
⟨λ _ _ _, by exactI preserves_limit_of_preserves_equalizers_and_product G⟩

/-- If G preserves equalizers and products, it preserves all limits. -/
def preserves_limits_of_preserves_equalizers_and_products
  [has_equalizers C] [has_products.{w} C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G]
  [∀ J, preserves_limits_of_shape (discrete.{w} J) G] :
preserves_limits_of_size.{w w} G :=
{ preserves_limits_of_shape := λ J 𝒥,
  by exactI preserves_limit_of_preserves_equalizers_and_product G }

/-!
We now dualize the above constructions, resorting to copy-paste.
-/

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

variables {F : J ⥤ C}
          {c₁ : cofan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1)}
          {c₂ : cofan F.obj}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app ⟨f⟩ ≫ s = F.map f.2 ≫ c₂.ι.app ⟨f.1.2⟩)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app ⟨f⟩ ≫ t = c₂.ι.app ⟨f.1.1⟩)
          (i : cofork s t)

include hs ht
/--
(Implementation) Given the appropriate coproduct and coequalizer cocones,
build the cocone for `F` which is colimiting if the given cocones are also.
-/
@[simps]
def build_colimit : cocone F :=
{ X := i.X,
  ι :=
  { app := λ j, c₂.ι.app ⟨_⟩ ≫ i.π,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.comp_id, ←reassoc_of (hs ⟨⟨_, _⟩, f⟩), i.condition, ←category.assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cocone constructed in `build_colimit` is colimiting,
provided the cocones used in its construction are.
-/
def build_is_colimit (t₁ : is_colimit c₁) (t₂ : is_colimit c₂) (hi : is_colimit i) :
  is_colimit (build_colimit s t hs ht i) :=
{ desc := λ q,
  begin
    refine hi.desc (cofork.of_π _ _),
    { refine t₂.desc (cofan.mk _ (λ j, _)),
      apply q.ι.app j },
    { apply t₁.hom_ext,
      intro j, discrete_cases,
      simp [reassoc_of hs, reassoc_of ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.coequalizer_ext (t₂.hom_ext
    (λ j, by { cases j, simpa using w j }))) }

end has_colimit_of_has_coproducts_of_has_coequalizers

open has_colimit_of_has_coproducts_of_has_coequalizers

/--
Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we can construct a colimit cocone for `F`.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
noncomputable
def colimit_cocone_of_coequalizer_and_coproduct (F : J ⥤ C)
  [has_colimit (discrete.functor F.obj)]
  [has_colimit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1))]
  [has_coequalizers C] : colimit_cocone F :=
{ cocone := _,
  is_colimit :=
    build_is_colimit
      (sigma.desc (λ f, F.map f.2 ≫ colimit.ι (discrete.functor F.obj) ⟨f.1.2⟩))
      (sigma.desc (λ f, colimit.ι (discrete.functor F.obj) ⟨f.1.1⟩))
      (by simp)
      (by simp)
      (colimit.is_colimit _)
      (colimit.is_colimit _)
      (colimit.is_colimit _) }

/--
Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we know a colimit of `F` exists.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
lemma has_colimit_of_coequalizer_and_coproduct (F : J ⥤ C)
  [has_colimit (discrete.functor F.obj)]
  [has_colimit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1))]
  [has_coequalizers C] : has_colimit F :=
has_colimit.mk (colimit_cocone_of_coequalizer_and_coproduct F)

/-- A colimit can be realised as a quotient of a coproduct. -/
noncomputable
def colimit_quotient_coproduct [has_colimits_of_size.{w w} C] (F : J ⥤ C) :
  ∐ (λ j, F.obj j) ⟶ colimit F :=
coequalizer.π _ _ ≫ (colimit.iso_colimit_cocone (colimit_cocone_of_coequalizer_and_coproduct F)).inv

instance colimit_quotient_coproduct_epi [has_colimits_of_size.{w w} C] (F : J ⥤ C) :
  epi (colimit_quotient_coproduct F) :=
epi_comp _ _

/--
Any category with coproducts and coequalizers has all colimits.

See <https://stacks.math.columbia.edu/tag/002P>.
-/
lemma colimits_from_coequalizers_and_coproducts
  [has_coproducts.{w} C] [has_coequalizers C] : has_colimits_of_size.{w w} C :=
{ has_colimits_of_shape := λ J 𝒥,
  { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F } }

/--
Any category with finite coproducts and coequalizers has all finite colimits.

See <https://stacks.math.columbia.edu/tag/002Q>.
-/
lemma finite_colimits_from_coequalizers_and_finite_coproducts
  [has_finite_coproducts C] [has_coequalizers C] : has_finite_colimits C :=
⟨λ J _ _, { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F }⟩

noncomputable theory

section

variables [has_colimits_of_shape (discrete.{w} J) C]
          [has_colimits_of_shape (discrete.{w} (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_coequalizers C]
variables (G : C ⥤ D)
          [preserves_colimits_of_shape walking_parallel_pair G]
          [preserves_colimits_of_shape (discrete.{w} J) G]
          [preserves_colimits_of_shape (discrete.{w} (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves coequalizers and the appropriate coproducts, it preserves colimits. -/
def preserves_colimit_of_preserves_coequalizers_and_coproduct :
  preserves_colimits_of_shape J G :=
{ preserves_colimit := λ K,
  begin
    let P := ∐ K.obj,
    let Q := ∐ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.1),
    let s : Q ⟶ P := sigma.desc (λ f, K.map f.2 ≫ colimit.ι (discrete.functor K.obj) ⟨_⟩),
    let t : Q ⟶ P := sigma.desc (λ f, colimit.ι (discrete.functor K.obj) ⟨f.1.1⟩),
    let I := coequalizer s t,
    let i : P ⟶ I := coequalizer.π s t,
    apply preserves_colimit_of_preserves_colimit_cocone
      (build_is_colimit s t (by simp) (by simp)
        (colimit.is_colimit _)
        (colimit.is_colimit _)
        (colimit.is_colimit _)),
    refine is_colimit.of_iso_colimit (build_is_colimit _ _ _ _ _ _ _) _,
    { exact cofan.mk (G.obj Q) (λ j, G.map (sigma.ι _ j)) },
    { exact cofan.mk _ (λ f, G.map (sigma.ι _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { apply cofork.of_π (G.map i) _,
      simp only [← G.map_comp, coequalizer.condition] },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_cofork_map_of_is_colimit,
      apply coequalizer_is_coequalizer },
    refine cocones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves coequalizers and finite coproducts, it preserves finite colimits. -/
def preserves_finite_colimits_of_preserves_coequalizers_and_finite_coproducts
  [has_coequalizers C] [has_finite_coproducts C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair G]
  [∀ J [fintype J], preserves_colimits_of_shape (discrete.{0} J) G] :
  preserves_finite_colimits G :=
⟨λ _ _ _, by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G⟩

/-- If G preserves coequalizers and coproducts, it preserves all colimits. -/
def preserves_colimits_of_preserves_coequalizers_and_coproducts
  [has_coequalizers C] [has_coproducts.{w} C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair G]
  [∀ J, preserves_colimits_of_shape (discrete.{w} J) G] :
preserves_colimits_of_size.{w} G :=
{ preserves_colimits_of_shape := λ J 𝒥,
  by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G }

end category_theory.limits


import Kenny_comm_alg.ideal_lattice

noncomputable theory
local attribute [instance] classical.prop_decidable

universe u

namespace is_ideal

section avoid_powers

parameters {α : Type u} [comm_ring α]
parameters (f : α) (P : set α) [hp : is_ideal P]
parameters (hf : ∀ n : ℕ, f^n ∉ P)
include hp hf

private def avoid_powers_aux :
  ∃ (M : {S : set α // is_ideal S ∧ P ⊆ S ∧ ∀ n, f ^ n ∉ S}),
  ∀ x, M ≤ x → x = M :=
@@zorn.zorn' {S // is_ideal S ∧ P ⊆ S ∧ ∀ n, f^n ∉ S} _ ⟨⟨P, hp, set.subset.refl P, hf⟩⟩ $
λ c x hx hc, ⟨⟨{y | ∃ S : {S // is_ideal S ∧ P ⊆ S ∧ ∀ n, f^n ∉ S}, S ∈ c ∧ y ∈ S.val},
  { zero_ := ⟨x, hx, @@is_ideal.zero _ x.1 x.2.1⟩,
    add_  := λ x y ⟨Sx, hxc, hx⟩ ⟨Sy, hyc, hy⟩,
      or.cases_on (hc Sx Sy hxc hyc)
        (λ hxy, ⟨Sy, hyc, @@is_ideal.add _ Sy.2.1 (hxy hx) hy⟩)
        (λ hyx, ⟨Sx, hxc, @@is_ideal.add _ Sx.2.1 hx (hyx hy)⟩),
    smul  := λ x y ⟨Sy, hyc, hy⟩,
      ⟨Sy, hyc, @@is_ideal.mul_left _ Sy.2.1 hy⟩ },
  λ z hz, ⟨x, hx, x.2.2.1 hz⟩,
  λ n ⟨S, hsc, hfns⟩, S.2.2.2 n hfns⟩,
λ S hsc z hzs, ⟨S, hsc, hzs⟩⟩

def avoid_powers : set α :=
(classical.some avoid_powers_aux).1

theorem avoid_powers.contains : P ⊆ avoid_powers :=
(classical.some avoid_powers_aux).2.2.1

theorem avoid_powers.avoid_powers : ∀ n : ℕ, f^n ∉ avoid_powers :=
(classical.some avoid_powers_aux).2.2.2

def avoid_powers.is_prime_ideal : is_prime_ideal avoid_powers :=
{ ne_univ := λ h,
    have h1 : (1:α) ∈ (set.univ:set α), from show true, by trivial,
    have h2 : (1:α) ∈ avoid_powers, by rwa h,
    avoid_powers.avoid_powers 0 h2,
  mem_or_mem_of_mul_mem := λ x y hxy,
    have h1 : ∀ x, classical.some avoid_powers_aux ≤ x → x = classical.some avoid_powers_aux,
      from classical.some_spec avoid_powers_aux,
    have hax : avoid_powers ⊆ span (insert x avoid_powers),
      from set.subset.trans (set.subset_insert x _) subset_span,
    have hay : avoid_powers ⊆ span (insert y avoid_powers),
      from set.subset.trans (set.subset_insert y _) subset_span,
    have hax2 : P ⊆ span (insert x avoid_powers),
      from set.subset.trans avoid_powers.contains hax,
    have hay2 : P ⊆ span (insert y avoid_powers),
      from set.subset.trans avoid_powers.contains hay,
    have hnx : (¬∃ n, f^n ∈ span (insert x avoid_powers)) → x ∈ avoid_powers,
      from λ h,
      have h2 : _ := h1 ⟨_, is_ideal_span, hax2, λ n hnfs, h ⟨n, hnfs⟩⟩ hax,
      suffices x ∈ span (insert x avoid_powers),
        by unfold avoid_powers; rw ← h2; exact this,
      subset_span $ set.mem_insert x _,
    have hny : (¬∃ n, f^n ∈ span (insert y avoid_powers)) → y ∈ avoid_powers,
      from λ h,
      have h2 : _ := h1 ⟨_, is_ideal_span, hay2, λ n hnfs, h ⟨n, hnfs⟩⟩ hay,
      suffices y ∈ span (insert y avoid_powers),
        by unfold avoid_powers; rw ← h2; exact this,
      subset_span $ set.mem_insert y _,
    begin
      haveI ha : is_submodule (avoid_powers f P hf) :=
        (classical.some (avoid_powers_aux f P hf)).2.1.to_is_submodule,
      by_cases hx : ∃ m : ℕ, f^m ∈ span (insert x (avoid_powers f P hf)),
      { by_cases hy : ∃ n : ℕ, f^n ∈ span (insert y (avoid_powers f P hf)),
        { exfalso,
          cases hx with m hx,
          cases hy with n hy,
          rw span_insert at hx hy,
          rcases hx with ⟨x1, x2, hx2, hx⟩,
          rcases hy with ⟨y1, y2, hy2, hy⟩,
          haveI ha : is_submodule (avoid_powers f P hf) :=
            (classical.some (avoid_powers_aux f P hf)).2.1.to_is_submodule,
          rw span_eq_of_is_submodule ha at hx2 hy2,
          apply avoid_powers.avoid_powers f P hf (m+n),
          exact calc
          f ^ (m + n) = (x1 • x + x2) * (y1 • y + y2) : by rw [pow_add, hx, hy]
                  ... = (x1 * x + x2) * (y1 * y + y2) : rfl
                  ... = (x1 * y1) * (x * y) + (x1 * x) * y2 + (y1 * y) * x2 + x2 * y2 : by ring
                  ... ∈ avoid_powers f P hf :
            is_submodule.add
              (is_submodule.add
                 (is_submodule.add
                    (is_submodule.smul _ hxy)
                    (is_submodule.smul _ hy2))
                 (is_submodule.smul _ hx2))
              (is_submodule.smul _ hy2) },
        { right,
          exact hny hy } },
      { left,
        exact hnx hx }
    end,
  .. (classical.some avoid_powers_aux).2.1 }

end avoid_powers

end is_ideal


/-
Copyright (c) 2021 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 .chunk
import .energy

/-!
# Increment
-/

universes u v

open finset fintype simple_graph
open_locale big_operators classical

variables {α : Type*} [fintype α] {P : finpartition (univ : finset α)} (hP : P.is_equipartition)
  (G : simple_graph α) (ε : ℝ)

local notation `m` := (card α/exp_bound P.parts.card : ℕ)

namespace finpartition

/-- The work-horse of SRL. This says that if we have an equipartition which is *not* uniform, then
we can make a (much bigger) equipartition with a slightly higher energy. This is helpful since the
energy is bounded by a constant (see `energy_le_one`), so this process eventually terminates and
yields a not-too-big uniform equipartition. -/
noncomputable def is_equipartition.increment : finpartition (univ : finset α) :=
P.bind (λ U, hP.chunk_increment G ε)

open finpartition finpartition.is_equipartition

variables {hP G ε}

lemma card_increment (hPα : P.parts.card * 16^P.parts.card ≤ card α) (hPG : ¬P.is_uniform G ε) :
  (hP.increment G ε).parts.card = exp_bound P.parts.card :=
begin
  have hPα' : exp_bound P.parts.card ≤ card α :=
    (nat.mul_le_mul_of_nonneg_left $ nat.pow_le_pow_of_le_left (by norm_num) _).trans hPα,
  have hPpos : 0 < exp_bound P.parts.card :=
    exp_bound_pos.2 (nonempty_of_not_uniform hPG).card_pos,
  rw [is_equipartition, finset.equitable_on_iff] at hP,
  rw [increment, card_bind],
  simp_rw [finpartition.is_equipartition.chunk_increment, apply_dite finpartition.parts,
    apply_dite card],
  rw [sum_dite, sum_const_nat, sum_const_nat, card_attach, card_attach], rotate,
  exact λ x hx, finpartition.equitabilise.parts_card (nat.div_pos hPα' hPpos) _,
  exact λ x hx, finpartition.equitabilise.parts_card (nat.div_pos hPα' hPpos) _,
  rw [nat.sub_add_cancel a_add_one_le_four_pow_parts_card, nat.sub_add_cancel ((nat.le_succ _).trans
    a_add_one_le_four_pow_parts_card), ←add_mul],
  congr,
  rw [filter_card_add_filter_neg_card_eq_card, card_attach],
end

lemma increment_is_equipartition (hP : P.is_equipartition) (G : simple_graph α) (ε : ℝ) :
  (hP.increment G ε).is_equipartition :=
begin
  rw [is_equipartition, set.equitable_on_iff_exists_eq_eq_add_one],
  refine ⟨m, λ A hA, _⟩,
  rw [mem_coe, increment, mem_bind] at hA,
  obtain ⟨U, hU, hA⟩ := hA,
  exact card_eq_of_mem_parts_chunk_increment hA,
end

lemma distinct_pairs_increment :
  P.parts.off_diag.attach.bUnion
    (λ UV, (hP.chunk_increment G ε ((mem_off_diag _ _).1 UV.2).1).parts.product
      (hP.chunk_increment G ε ((mem_off_diag _ _).1 UV.2).2.1).parts)
  ⊆ (hP.increment G ε).parts.off_diag :=
begin
  rintro ⟨Ui, Vj⟩,
  simp only [finpartition.is_equipartition.increment, mem_off_diag, bind_parts, mem_bUnion,
    prod.exists, exists_and_distrib_left, exists_prop, mem_product, mem_attach, true_and,
    subtype.exists, and_imp, mem_off_diag, forall_exists_index, bex_imp_distrib, ne.def],
  rintro U V hUV hUi hVj,
  refine ⟨⟨_, hUV.1, hUi⟩, ⟨_, hUV.2.1, hVj⟩, _⟩,
  rintro rfl,
  obtain ⟨i, hi⟩ := nonempty_of_mem_parts _ hUi,
  apply hUV.2.2 (P.disjoint.elim_finset hUV.1 hUV.2.1 i (finpartition.le _ hUi hi)
    (finpartition.le _ hVj hi)),
end

/-- The contribution to `energy` of a pair of distinct parts of a finpartition. -/
noncomputable def pair_contrib (G : simple_graph α) (ε : ℝ) (hP : P.is_equipartition)
  (x : {x // x ∈ P.parts.off_diag}) :=
(∑ i in
  (hP.chunk_increment G ε ((mem_off_diag _ _).1 x.2).1).parts.product
    (hP.chunk_increment G ε ((mem_off_diag _ _).1 x.2).2.1).parts,
  G.edge_density i.fst i.snd ^ 2)

lemma off_diag_pairs_le_increment_energy :
  ∑ x in P.parts.off_diag.attach, pair_contrib G ε hP x / (hP.increment G ε).parts.card ^ 2 ≤
    (hP.increment G ε).energy G :=
begin
  simp_rw [pair_contrib, ←sum_div],
  refine div_le_div_of_le_of_nonneg _ (sq_nonneg _),
  rw ←sum_bUnion,
  { exact sum_le_sum_of_subset_of_nonneg distinct_pairs_increment (λ i _ _, sq_nonneg _) },
  rintro ⟨⟨s₁, s₂⟩, hs⟩ _ ⟨⟨t₁, t₂⟩, ht⟩ _ hst ⟨u, v⟩ huv,
  simp only [inf_eq_inter, mem_inter, mem_product] at huv,
  rw mem_off_diag at hs ht,
  obtain ⟨a, ha⟩ := finpartition.nonempty_of_mem_parts _ huv.1.1,
  obtain ⟨b, hb⟩ := finpartition.nonempty_of_mem_parts _ huv.1.2,
  exact hst (subtype.ext_val $ prod.ext
    (P.disjoint.elim_finset hs.1 ht.1 a
      (finpartition.le _ huv.1.1 ha) (finpartition.le _ huv.2.1 ha))
    (P.disjoint.elim_finset hs.2.1 ht.2.1 b
      (finpartition.le _ huv.1.2 hb) (finpartition.le _ huv.2.2 hb))),
end

lemma pair_contrib_lower_bound [nonempty α] (x : {i // i ∈ P.parts.off_diag}) (hε₁ : ε ≤ 1)
  (hPα : P.parts.card * 16^P.parts.card ≤ card α) (hPε : 100 ≤ 4^P.parts.card * ε^5) :
  G.edge_density x.1.1 x.1.2^2 - ε^5/25 + (if G.is_uniform ε x.1.1 x.1.2 then 0 else ε^4/3) ≤
    pair_contrib G ε hP x / (16^P.parts.card) :=
begin
  split_ifs,
  { rw add_zero,
    exact sq_density_sub_eps_le_sum_sq_density_div_card hPα hPε _ _ },
  { apply sq_density_sub_eps_le_sum_sq_density_div_card_of_nonuniform hPα hPε hε₁ _ h,
    exact ((mem_off_diag _ _).1 x.2).2.2 }
end

lemma uniform_add_nonuniform_eq_off_diag_pairs [nonempty α] (hε₁ : ε ≤ 1) (hP₇ : 7 ≤ P.parts.card)
  (hPα : P.parts.card * 16^P.parts.card ≤ card α) (hPε : 100 ≤ 4^P.parts.card * ε^5)
  (hPG : ¬P.is_uniform G ε) :
  (∑ x in P.parts.off_diag, G.edge_density x.1 x.2 ^ 2 + P.parts.card^2 * (ε ^ 5 / 4))
    / P.parts.card ^ 2
      ≤ ∑ x in P.parts.off_diag.attach, pair_contrib G ε hP x / (hP.increment G ε).parts.card ^ 2 :=
begin
  conv_rhs
  { rw [←sum_div, card_increment hPα hPG, exp_bound, ←nat.cast_pow, mul_pow, pow_right_comm,
      nat.cast_mul, mul_comm, ←div_div_eq_div_mul, (show 4^2 = 16, by norm_num), sum_div] },
  rw [←nat.cast_pow, nat.cast_pow 16],
  refine div_le_div_of_le_of_nonneg _ (nat.cast_nonneg _),
  norm_num,
  suffices : _ ≤ ∑ x in P.parts.off_diag.attach,
      (G.edge_density x.1.1 x.1.2^2 - ε^5/25 + if G.is_uniform ε x.1.1 x.1.2 then 0 else ε^4/3),
  { apply le_trans this (sum_le_sum (λ i hi, pair_contrib_lower_bound i hε₁ hPα hPε)) },
  have : ∑ x in P.parts.off_diag.attach,
    (G.edge_density x.1.1 x.1.2^2 - ε^5/25 + if G.is_uniform ε x.1.1 x.1.2 then 0 else ε^4/3) =
    ∑ x in P.parts.off_diag,
      (G.edge_density x.1 x.2^2 - ε^5/25 + if G.is_uniform ε x.1 x.2 then 0 else ε^4/3),
  { convert sum_attach, refl },
  rw [this, sum_add_distrib, sum_sub_distrib, sum_const, nsmul_eq_mul, sum_ite, sum_const_zero,
    zero_add, sum_const, nsmul_eq_mul, ←finpartition.non_uniform_pairs],
  rw finpartition.is_uniform at hPG,
  simp only [not_le] at hPG,
  apply le_trans _ (add_le_add_left (mul_le_mul_of_nonneg_right hPG.le _) _),
  { conv_rhs { congr, congr, skip, rw [off_diag_card], congr, congr,
      conv { congr, skip, rw ←mul_one P.parts.card }, rw ←nat.mul_sub_left_distrib },
    simp_rw [mul_assoc, sub_add_eq_add_sub, add_sub_assoc, ←mul_sub_left_distrib, mul_div_assoc' ε,
      ←pow_succ, div_eq_mul_one_div (ε^5), ←mul_sub_left_distrib],
    rw [mul_left_comm, mul_left_comm _ (ε^5), sq, mul_assoc, nat.cast_mul, mul_assoc],
    apply add_le_add_left,
    apply mul_le_mul_of_nonneg_left _ (eps_pow_five_pos hPε).le,
    apply mul_le_mul_of_nonneg_left _ (nat.cast_nonneg _),
    rw [nat.cast_sub (P.parts_nonempty $ univ_nonempty.ne_empty).card_pos, mul_sub_right_distrib,
      nat.cast_one, one_mul, le_sub, ←mul_sub_left_distrib,
      ←div_le_iff (show (0:ℝ) < 1/3 - 1/25 - 1/4, by norm_num)],
    refine le_trans (show _ ≤ (7:ℝ), by norm_num) (by exact_mod_cast hP₇) },
  exact div_nonneg (pow_bit0_nonneg _ _) (by norm_num),
end

lemma energy_increment [nonempty α] (hP : P.is_equipartition) (hP₇ : 7 ≤ P.parts.card)
  (hε : 100 < 4^P.parts.card * ε^5) (hPα : P.parts.card * 16^P.parts.card ≤ card α)
  (hPG : ¬P.is_uniform G ε) (hε₁ : ε ≤ 1) :
  P.energy G + ε^5 / 4 ≤ (hP.increment G ε).energy G :=
begin
  have h := uniform_add_nonuniform_eq_off_diag_pairs hε₁ hP₇ hPα hε.le hPG,
  rw [add_div, mul_div_cancel_left] at h,
  exact h.trans off_diag_pairs_le_increment_energy,
  refine (sq_pos_of_ne_zero _ $ _).ne',
  norm_cast,
  linarith,
end

end finpartition


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Fabian Glöckle
-/
import linear_algebra.finite_dimensional
import linear_algebra.projection
import linear_algebra.sesquilinear_form
import ring_theory.finiteness
import linear_algebra.free_module.finite.rank

/-!
# Dual vector spaces

The dual space of an R-module M is the R-module of linear maps `M → R`.

## Main definitions

* `dual R M` defines the dual space of M over R.
* Given a basis for an `R`-module `M`, `basis.to_dual` produces a map from `M` to `dual R M`.
* Given families of vectors `e` and `ε`, `dual_pair e ε` states that these families have the
  characteristic properties of a basis and a dual.
* `dual_annihilator W` is the submodule of `dual R M` where every element annihilates `W`.

## Main results

* `to_dual_equiv` : the linear equivalence between the dual module and primal module,
  given a finite basis.
* `dual_pair.basis` and `dual_pair.eq_dual`: if `e` and `ε` form a dual pair, `e` is a basis and
  `ε` is its dual basis.
* `quot_equiv_annihilator`: the quotient by a subspace is isomorphic to its dual annihilator.

## Notation

We sometimes use `V'` as local notation for `dual K V`.

## TODO

Erdös-Kaplansky theorem about the dimension of a dual vector space in case of infinite dimension.
-/

noncomputable theory

namespace module

variables (R : Type*) (M : Type*)
variables [comm_semiring R] [add_comm_monoid M] [module R M]

/-- The dual space of an R-module M is the R-module of linear maps `M → R`. -/
@[derive [add_comm_monoid, module R]] def dual := M →ₗ[R] R

instance {S : Type*} [comm_ring S] {N : Type*} [add_comm_group N] [module S N] :
  add_comm_group (dual S N) := linear_map.add_comm_group

instance : linear_map_class (dual R M) R M R :=
linear_map.semilinear_map_class

/-- The canonical pairing of a vector space and its algebraic dual. -/
def dual_pairing (R M) [comm_semiring R] [add_comm_monoid M] [module R M] :
  module.dual R M →ₗ[R] M →ₗ[R] R := linear_map.id

@[simp] lemma dual_pairing_apply (v x) : dual_pairing R M v x = v x := rfl

namespace dual

instance : inhabited (dual R M) := linear_map.inhabited

instance : has_coe_to_fun (dual R M) (λ _, M → R) := ⟨linear_map.to_fun⟩

/-- Maps a module M to the dual of the dual of M. See `module.erange_coe` and
`module.eval_equiv`. -/
def eval : M →ₗ[R] (dual R (dual R M)) := linear_map.flip linear_map.id

@[simp] lemma eval_apply (v : M) (a : dual R M) : eval R M v a = a v :=
begin
  dunfold eval,
  rw [linear_map.flip_apply, linear_map.id_apply]
end

variables {R M} {M' : Type*} [add_comm_monoid M'] [module R M']

/-- The transposition of linear maps, as a linear map from `M →ₗ[R] M'` to
`dual R M' →ₗ[R] dual R M`. -/
def transpose : (M →ₗ[R] M') →ₗ[R] (dual R M' →ₗ[R] dual R M) :=
(linear_map.llcomp R M M' R).flip

lemma transpose_apply (u : M →ₗ[R] M') (l : dual R M') : transpose u l = l.comp u := rfl

variables {M'' : Type*} [add_comm_monoid M''] [module R M'']

lemma transpose_comp (u : M' →ₗ[R] M'') (v : M →ₗ[R] M') :
  transpose (u.comp v) = (transpose v).comp (transpose u) := rfl

end dual

end module

namespace basis

universes u v w

open module module.dual submodule linear_map cardinal function
open_locale big_operators

variables {R M K V ι : Type*}

section comm_semiring

variables [comm_semiring R] [add_comm_monoid M] [module R M] [decidable_eq ι]
variables (b : basis ι R M)

/-- The linear map from a vector space equipped with basis to its dual vector space,
taking basis elements to corresponding dual basis elements. -/
def to_dual : M →ₗ[R] module.dual R M :=
b.constr ℕ $ λ v, b.constr ℕ $ λ w, if w = v then (1 : R) else 0

lemma to_dual_apply (i j : ι) :
  b.to_dual (b i) (b j) = if i = j then 1 else 0 :=
by { erw [constr_basis b, constr_basis b], ac_refl }

@[simp] lemma to_dual_total_left (f : ι →₀ R) (i : ι) :
  b.to_dual (finsupp.total ι M R b f) (b i) = f i :=
begin
  rw [finsupp.total_apply, finsupp.sum, linear_map.map_sum, linear_map.sum_apply],
  simp_rw [linear_map.map_smul, linear_map.smul_apply, to_dual_apply, smul_eq_mul,
           mul_boole, finset.sum_ite_eq'],
  split_ifs with h,
  { refl },
  { rw finsupp.not_mem_support_iff.mp h }
end

@[simp] lemma to_dual_total_right (f : ι →₀ R) (i : ι) :
  b.to_dual (b i) (finsupp.total ι M R b f) = f i :=
begin
  rw [finsupp.total_apply, finsupp.sum, linear_map.map_sum],
  simp_rw [linear_map.map_smul, to_dual_apply, smul_eq_mul, mul_boole, finset.sum_ite_eq],
  split_ifs with h,
  { refl },
  { rw finsupp.not_mem_support_iff.mp h }
end

lemma to_dual_apply_left (m : M) (i : ι) : b.to_dual m (b i) = b.repr m i :=
by rw [← b.to_dual_total_left, b.total_repr]

lemma to_dual_apply_right (i : ι) (m : M) : b.to_dual (b i) m = b.repr m i :=
by rw [← b.to_dual_total_right, b.total_repr]

lemma coe_to_dual_self (i : ι) : b.to_dual (b i) = b.coord i :=
by { ext, apply to_dual_apply_right }

/-- `h.to_dual_flip v` is the linear map sending `w` to `h.to_dual w v`. -/
def to_dual_flip (m : M) : (M →ₗ[R] R) := b.to_dual.flip m

lemma to_dual_flip_apply (m₁ m₂ : M) : b.to_dual_flip m₁ m₂ = b.to_dual m₂ m₁ := rfl

lemma to_dual_eq_repr (m : M) (i : ι) : b.to_dual m (b i) = b.repr m i :=
b.to_dual_apply_left m i

lemma to_dual_eq_equiv_fun [fintype ι] (m : M) (i : ι) : b.to_dual m (b i) = b.equiv_fun m i :=
by rw [b.equiv_fun_apply, to_dual_eq_repr]

lemma to_dual_inj (m : M) (a : b.to_dual m = 0) : m = 0 :=
begin
  rw [← mem_bot R, ← b.repr.ker, mem_ker, linear_equiv.coe_coe],
  apply finsupp.ext,
  intro b,
  rw [← to_dual_eq_repr, a],
  refl
end

theorem to_dual_ker : b.to_dual.ker = ⊥ :=
ker_eq_bot'.mpr b.to_dual_inj

theorem to_dual_range [fin : fintype ι] : b.to_dual.range = ⊤ :=
begin
  rw eq_top_iff',
  intro f,
  rw linear_map.mem_range,
  let lin_comb : ι →₀ R := finsupp.on_finset fin.elems (λ i, f.to_fun (b i)) _,
  { use finsupp.total ι M R b lin_comb,
    apply b.ext,
    { intros i,
      rw [b.to_dual_eq_repr _ i, repr_total b],
      { refl } } },
  { intros a _,
    apply fin.complete }
end

end comm_semiring

section

variables [comm_semiring R] [add_comm_monoid M] [module R M] [fintype ι]
variables (b : basis ι R M)

@[simp] lemma sum_dual_apply_smul_coord (f : module.dual R M) : ∑ x, f (b x) • b.coord x = f :=
begin
  ext m,
  simp_rw [linear_map.sum_apply, linear_map.smul_apply, smul_eq_mul, mul_comm (f _), ←smul_eq_mul,
    ←f.map_smul, ←f.map_sum, basis.coord_apply, basis.sum_repr],
end

end

section comm_ring

variables [comm_ring R] [add_comm_group M] [module R M] [decidable_eq ι]
variables (b : basis ι R M)

/-- A vector space is linearly equivalent to its dual space. -/
@[simps]
def to_dual_equiv [fintype ι] : M ≃ₗ[R] (dual R M) :=
linear_equiv.of_bijective b.to_dual
  (ker_eq_bot.mp b.to_dual_ker) (range_eq_top.mp b.to_dual_range)

/-- Maps a basis for `V` to a basis for the dual space. -/
def dual_basis [fintype ι] : basis ι R (dual R M) :=
b.map b.to_dual_equiv

-- We use `j = i` to match `basis.repr_self`
lemma dual_basis_apply_self [fintype ι] (i j : ι) :
  b.dual_basis i (b j) = if j = i then 1 else 0 :=
by { convert b.to_dual_apply i j using 2, rw @eq_comm _ j i }

lemma total_dual_basis [fintype ι] (f : ι →₀ R) (i : ι) :
  finsupp.total ι (dual R M) R b.dual_basis f (b i) = f i :=
begin
  rw [finsupp.total_apply, finsupp.sum_fintype, linear_map.sum_apply],
  { simp_rw [linear_map.smul_apply, smul_eq_mul, dual_basis_apply_self, mul_boole,
      finset.sum_ite_eq, if_pos (finset.mem_univ i)] },
  { intro, rw zero_smul },
end

lemma dual_basis_repr [fintype ι] (l : dual R M) (i : ι) :
  b.dual_basis.repr l i = l (b i) :=
by rw [← total_dual_basis b, basis.total_repr b.dual_basis l]

lemma dual_basis_equiv_fun [fintype ι] (l : dual R M) (i : ι) :
  b.dual_basis.equiv_fun l i = l (b i) :=
by rw [basis.equiv_fun_apply, dual_basis_repr]

lemma dual_basis_apply [fintype ι] (i : ι) (m : M) : b.dual_basis i m = b.repr m i :=
b.to_dual_apply_right i m

@[simp] lemma coe_dual_basis [fintype ι] :
  ⇑b.dual_basis = b.coord :=
by { ext i x, apply dual_basis_apply }

@[simp] lemma to_dual_to_dual [fintype ι] :
  b.dual_basis.to_dual.comp b.to_dual = dual.eval R M :=
begin
  refine b.ext (λ i, b.dual_basis.ext (λ j, _)),
  rw [linear_map.comp_apply, to_dual_apply_left, coe_to_dual_self, ← coe_dual_basis,
      dual.eval_apply, basis.repr_self, finsupp.single_apply, dual_basis_apply_self]
end

theorem eval_ker {ι : Type*} (b : basis ι R M) :
  (dual.eval R M).ker = ⊥ :=
begin
  rw ker_eq_bot',
  intros m hm,
  simp_rw [linear_map.ext_iff, dual.eval_apply, zero_apply] at hm,
  exact (basis.forall_coord_eq_zero_iff _).mp (λ i, hm (b.coord i))
end

lemma eval_range {ι : Type*} [fintype ι] (b : basis ι R M) :
  (eval R M).range = ⊤ :=
begin
  classical,
  rw [← b.to_dual_to_dual, range_comp, b.to_dual_range, map_top, to_dual_range _],
  apply_instance
end

/-- A module with a basis is linearly equivalent to the dual of its dual space. -/
def eval_equiv  {ι : Type*} [fintype ι] (b : basis ι R M) : M ≃ₗ[R] dual R (dual R M) :=
linear_equiv.of_bijective (eval R M)
  (ker_eq_bot.mp b.eval_ker) (range_eq_top.mp b.eval_range)

@[simp] lemma eval_equiv_to_linear_map {ι : Type*} [fintype ι] (b : basis ι R M) :
  (b.eval_equiv).to_linear_map = dual.eval R M := rfl

section

open_locale classical

variables [finite R M] [free R M] [nontrivial R]

instance dual_free : free R (dual R M) := free.of_basis (free.choose_basis R M).dual_basis

instance dual_finite : finite R (dual R M) := finite.of_basis (free.choose_basis R M).dual_basis

end

end comm_ring

/-- `simp` normal form version of `total_dual_basis` -/
@[simp] lemma total_coord [comm_ring R] [add_comm_group M] [module R M] [fintype ι]
  (b : basis ι R M) (f : ι →₀ R) (i : ι) :
  finsupp.total ι (dual R M) R b.coord f (b i) = f i :=
by { haveI := classical.dec_eq ι, rw [← coe_dual_basis, total_dual_basis] }

-- TODO(jmc): generalize to rings, once `module.rank` is generalized
theorem dual_dim_eq [field K] [add_comm_group V] [module K V] [fintype ι] (b : basis ι K V) :
  cardinal.lift (module.rank K V) = module.rank K (dual K V) :=
begin
  classical,
  have := linear_equiv.lift_dim_eq b.to_dual_equiv,
  simp only [cardinal.lift_umax] at this,
  rw [this, ← cardinal.lift_umax],
  apply cardinal.lift_id,
end

end basis

namespace module

variables {K V : Type*}
variables [field K] [add_comm_group V] [module K V]
open module module.dual submodule linear_map cardinal basis finite_dimensional

theorem eval_ker : (eval K V).ker = ⊥ :=
by { classical, exact (basis.of_vector_space K V).eval_ker }

-- TODO(jmc): generalize to rings, once `module.rank` is generalized
theorem dual_dim_eq [finite_dimensional K V] :
  cardinal.lift (module.rank K V) = module.rank K (dual K V) :=
(basis.of_vector_space K V).dual_dim_eq

lemma erange_coe [finite_dimensional K V] : (eval K V).range = ⊤ :=
begin
  letI : is_noetherian K V := is_noetherian.iff_fg.2 infer_instance,
  exact (basis.of_vector_space K V).eval_range
end

variables (K V)

/-- A vector space is linearly equivalent to the dual of its dual space. -/
def eval_equiv [finite_dimensional K V] : V ≃ₗ[K] dual K (dual K V) :=
linear_equiv.of_bijective (eval K V)
  (ker_eq_bot.mp eval_ker) (range_eq_top.mp erange_coe)

variables {K V}

@[simp] lemma eval_equiv_to_linear_map [finite_dimensional K V] :
  (eval_equiv K V).to_linear_map = dual.eval K V := rfl

end module

section dual_pair

open module

variables {R M ι : Type*}
variables [comm_semiring R] [add_comm_monoid M] [module R M] [decidable_eq ι]

/-- `e` and `ε` have characteristic properties of a basis and its dual -/
@[nolint has_inhabited_instance]
structure dual_pair (e : ι → M) (ε : ι → (dual R M)) :=
(eval : ∀ i j : ι, ε i (e j) = if i = j then 1 else 0)
(total : ∀ {m : M}, (∀ i, ε i m = 0) → m = 0)
[finite : ∀ m : M, fintype {i | ε i m ≠ 0}]

end dual_pair

namespace dual_pair

open module module.dual linear_map function

variables {R M ι : Type*}
variables [comm_ring R] [add_comm_group M] [module R M]
variables {e : ι → M} {ε : ι → dual R M}

/-- The coefficients of `v` on the basis `e` -/
def coeffs [decidable_eq ι] (h : dual_pair e ε) (m : M) : ι →₀ R :=
{ to_fun := λ i, ε i m,
  support := by { haveI := h.finite m, exact {i : ι | ε i m ≠ 0}.to_finset },
  mem_support_to_fun := by {intro i, rw set.mem_to_finset, exact iff.rfl } }

@[simp]

/-- linear combinations of elements of `e`.
This is a convenient abbreviation for `finsupp.total _ M R e l` -/
def lc {ι} (e : ι → M) (l : ι →₀ R) : M := l.sum (λ (i : ι) (a : R), a • (e i))

lemma lc_def (e : ι → M) (l : ι →₀ R) : lc e l = finsupp.total _ _ _ e l := rfl

variables [decidable_eq ι] (h : dual_pair e ε)
include h

lemma dual_lc (l : ι →₀ R) (i : ι) : ε i (dual_pair.lc e l) = l i :=
begin
  erw linear_map.map_sum,
  simp only [h.eval, map_smul, smul_eq_mul],
  rw finset.sum_eq_single i,
  { simp },
  { intros q q_in q_ne,
    simp [q_ne.symm] },
  { intro p_not_in,
    simp [finsupp.not_mem_support_iff.1 p_not_in] },
end

@[simp]
lemma coeffs_lc (l : ι →₀ R) : h.coeffs (dual_pair.lc e l) = l :=
by { ext i, rw [h.coeffs_apply, h.dual_lc] }

/-- For any m : M n, \sum_{p ∈ Q n} (ε p m) • e p = m -/
@[simp]
lemma lc_coeffs (m : M) : dual_pair.lc e (h.coeffs m) = m :=
begin
  refine eq_of_sub_eq_zero (h.total _),
  intros i,
  simp [-sub_eq_add_neg, linear_map.map_sub, h.dual_lc, sub_eq_zero]
end

/-- `(h : dual_pair e ε).basis` shows the family of vectors `e` forms a basis. -/
@[simps]
def basis : basis ι R M :=
basis.of_repr
{ to_fun := coeffs h,
  inv_fun := lc e,
  left_inv := lc_coeffs h,
  right_inv := coeffs_lc h,
  map_add' := λ v w, by { ext i, exact (ε i).map_add v w },
  map_smul' := λ c v, by { ext i, exact (ε i).map_smul c v } }

@[simp] lemma coe_basis : ⇑h.basis = e :=
by { ext i, rw basis.apply_eq_iff, ext j,
     rw [h.basis_repr_apply, coeffs_apply, h.eval, finsupp.single_apply],
     convert if_congr eq_comm rfl rfl } -- `convert` to get rid of a `decidable_eq` mismatch

lemma mem_of_mem_span {H : set ι} {x : M} (hmem : x ∈ submodule.span R (e '' H)) :
  ∀ i : ι, ε i x ≠ 0 → i ∈ H :=
begin
  intros i hi,
  rcases (finsupp.mem_span_image_iff_total _).mp hmem with ⟨l, supp_l, rfl⟩,
  apply not_imp_comm.mp ((finsupp.mem_supported' _ _).mp supp_l i),
  rwa [← lc_def, h.dual_lc] at hi
end

lemma coe_dual_basis [fintype ι] : ⇑h.basis.dual_basis = ε :=
funext (λ i, h.basis.ext (λ j, by rw [h.basis.dual_basis_apply_self, h.coe_basis, h.eval,
                                      if_congr eq_comm rfl rfl]))

end dual_pair

namespace submodule

universes u v w

variables {R : Type u} {M : Type v} [comm_semiring R] [add_comm_monoid M] [module R M]
variable {W : submodule R M}

/-- The `dual_restrict` of a submodule `W` of `M` is the linear map from the
  dual of `M` to the dual of `W` such that the domain of each linear map is
  restricted to `W`. -/
def dual_restrict (W : submodule R M) :
  module.dual R M →ₗ[R] module.dual R W :=
linear_map.dom_restrict' W

@[simp] lemma dual_restrict_apply
  (W : submodule R M) (φ : module.dual R M) (x : W) :
  W.dual_restrict φ x = φ (x : M) := rfl

/-- The `dual_annihilator` of a submodule `W` is the set of linear maps `φ` such
  that `φ w = 0` for all `w ∈ W`. -/
def dual_annihilator {R : Type u} {M : Type v} [comm_semiring R] [add_comm_monoid M]
  [module R M] (W : submodule R M) : submodule R $ module.dual R M :=
W.dual_restrict.ker

@[simp] lemma mem_dual_annihilator (φ : module.dual R M) :
  φ ∈ W.dual_annihilator ↔ ∀ w ∈ W, φ w = 0 :=
begin
  refine linear_map.mem_ker.trans _,
  simp_rw [linear_map.ext_iff, dual_restrict_apply],
  exact ⟨λ h w hw, h ⟨w, hw⟩, λ h w, h w.1 w.2⟩
end

lemma dual_restrict_ker_eq_dual_annihilator (W : submodule R M) :
  W.dual_restrict.ker = W.dual_annihilator :=
rfl

lemma dual_annihilator_sup_eq_inf_dual_annihilator (U V : submodule R M) :
  (U ⊔ V).dual_annihilator = U.dual_annihilator ⊓ V.dual_annihilator :=
begin
  ext φ,
  rw [mem_inf, mem_dual_annihilator, mem_dual_annihilator, mem_dual_annihilator],
  split; intro h,
  { refine ⟨_, _⟩;
    intros x hx,
    exact h x (mem_sup.2 ⟨x, hx, 0, zero_mem _, add_zero _⟩),
    exact h x (mem_sup.2 ⟨0, zero_mem _, x, hx, zero_add _⟩) },
  { simp_rw mem_sup,
    rintro _ ⟨x, hx, y, hy, rfl⟩,
    rw [linear_map.map_add, h.1 _ hx, h.2 _ hy, add_zero] }
end

/-- The pullback of a submodule in the dual space along the evaluation map. -/
def dual_annihilator_comap (Φ : submodule R (module.dual R M)) : submodule R M :=
Φ.dual_annihilator.comap (module.dual.eval R M)

lemma mem_dual_annihilator_comap_iff {Φ : submodule R (module.dual R M)} (x : M) :
  x ∈ Φ.dual_annihilator_comap ↔ ∀ φ ∈ Φ, (φ x : R) = 0 :=
by simp_rw [dual_annihilator_comap, mem_comap, mem_dual_annihilator, module.dual.eval_apply]

end submodule

namespace subspace

open submodule linear_map

universes u v w

-- We work in vector spaces because `exists_is_compl` only hold for vector spaces
variables {K : Type u} {V : Type v} [field K] [add_comm_group V] [module K V]

/-- Given a subspace `W` of `V` and an element of its dual `φ`, `dual_lift W φ` is
the natural extension of `φ` to an element of the dual of `V`.
That is, `dual_lift W φ` sends `w ∈ W` to `φ x` and `x` in the complement of `W` to `0`. -/
noncomputable def dual_lift (W : subspace K V) :
  module.dual K W →ₗ[K] module.dual K V :=
let h := classical.indefinite_description _ W.exists_is_compl in
  (linear_map.of_is_compl_prod h.2).comp (linear_map.inl _ _ _)

variable {W : subspace K V}

@[simp] lemma dual_lift_of_subtype {φ : module.dual K W} (w : W) :
  W.dual_lift φ (w : V) = φ w :=
by { erw of_is_compl_left_apply _ w, refl }

lemma dual_lift_of_mem {φ : module.dual K W} {w : V} (hw : w ∈ W) :
  W.dual_lift φ w = φ ⟨w, hw⟩ :=
by convert dual_lift_of_subtype ⟨w, hw⟩

@[simp] lemma dual_restrict_comp_dual_lift (W : subspace K V) :
  W.dual_restrict.comp W.dual_lift = 1 :=
by { ext φ x, simp }

lemma dual_restrict_left_inverse (W : subspace K V) :
  function.left_inverse W.dual_restrict W.dual_lift :=
λ x, show W.dual_restrict.comp W.dual_lift x = x,
  by { rw [dual_restrict_comp_dual_lift], refl }

lemma dual_lift_right_inverse (W : subspace K V) :
  function.right_inverse W.dual_lift W.dual_restrict :=
W.dual_restrict_left_inverse

lemma dual_restrict_surjective :
  function.surjective W.dual_restrict :=
W.dual_lift_right_inverse.surjective

lemma dual_lift_injective : function.injective W.dual_lift :=
W.dual_restrict_left_inverse.injective

/-- The quotient by the `dual_annihilator` of a subspace is isomorphic to the
  dual of that subspace. -/
noncomputable def quot_annihilator_equiv (W : subspace K V) :
  (module.dual K V ⧸ W.dual_annihilator) ≃ₗ[K] module.dual K W :=
(quot_equiv_of_eq _ _ W.dual_restrict_ker_eq_dual_annihilator).symm.trans $
  W.dual_restrict.quot_ker_equiv_of_surjective dual_restrict_surjective

/-- The natural isomorphism forom the dual of a subspace `W` to `W.dual_lift.range`. -/
noncomputable def dual_equiv_dual (W : subspace K V) :
  module.dual K W ≃ₗ[K] W.dual_lift.range :=
linear_equiv.of_injective _ dual_lift_injective

lemma dual_equiv_dual_def (W : subspace K V) :
  W.dual_equiv_dual.to_linear_map = W.dual_lift.range_restrict := rfl

@[simp] lemma dual_equiv_dual_apply (φ : module.dual K W) :
  W.dual_equiv_dual φ = ⟨W.dual_lift φ, mem_range.2 ⟨φ, rfl⟩⟩ := rfl

section

open_locale classical

open finite_dimensional

variables {V₁ : Type*} [add_comm_group V₁] [module K V₁]

instance [H : finite_dimensional K V] : finite_dimensional K (module.dual K V) :=
by apply_instance

variables [finite_dimensional K V] [finite_dimensional K V₁]

@[simp] lemma dual_finrank_eq :
  finrank K (module.dual K V) = finrank K V :=
linear_equiv.finrank_eq (basis.of_vector_space K V).to_dual_equiv.symm

/-- The quotient by the dual is isomorphic to its dual annihilator.  -/
noncomputable def quot_dual_equiv_annihilator (W : subspace K V) :
  (module.dual K V ⧸ W.dual_lift.range) ≃ₗ[K] W.dual_annihilator :=
linear_equiv.quot_equiv_of_quot_equiv $
  linear_equiv.trans W.quot_annihilator_equiv W.dual_equiv_dual

/-- The quotient by a subspace is isomorphic to its dual annihilator. -/
noncomputable def quot_equiv_annihilator (W : subspace K V) :
  (V ⧸ W) ≃ₗ[K] W.dual_annihilator :=
begin
  refine _ ≪≫ₗ W.quot_dual_equiv_annihilator,
  refine linear_equiv.quot_equiv_of_equiv _ (basis.of_vector_space K V).to_dual_equiv,
  exact (basis.of_vector_space K W).to_dual_equiv.trans W.dual_equiv_dual
end

open finite_dimensional

@[simp]
lemma finrank_dual_annihilator_comap_eq {Φ : subspace K (module.dual K V)} :
  finrank K Φ.dual_annihilator_comap = finrank K Φ.dual_annihilator :=
begin
  rw [submodule.dual_annihilator_comap, ← module.eval_equiv_to_linear_map],
  exact linear_equiv.finrank_eq (linear_equiv.of_submodule' _ _),
end

lemma finrank_add_finrank_dual_annihilator_comap_eq
  (W : subspace K (module.dual K V)) :
  finrank K W + finrank K W.dual_annihilator_comap = finrank K V :=
begin
  rw [finrank_dual_annihilator_comap_eq, W.quot_equiv_annihilator.finrank_eq.symm, add_comm,
      submodule.finrank_quotient_add_finrank, subspace.dual_finrank_eq],
end

end

end subspace

open module

section dual_map
variables {R : Type*} [comm_semiring R] {M₁ : Type*} {M₂ : Type*}
variables [add_comm_monoid M₁] [module R M₁] [add_comm_monoid M₂] [module R M₂]

/-- Given a linear map `f : M₁ →ₗ[R] M₂`, `f.dual_map` is the linear map between the dual of
`M₂` and `M₁` such that it maps the functional `φ` to `φ ∘ f`. -/
def linear_map.dual_map (f : M₁ →ₗ[R] M₂) : dual R M₂ →ₗ[R] dual R M₁ :=
linear_map.lcomp R R f

@[simp] lemma linear_map.dual_map_apply (f : M₁ →ₗ[R] M₂) (g : dual R M₂) (x : M₁) :
  f.dual_map g x = g (f x) :=
linear_map.lcomp_apply f g x

@[simp] lemma linear_map.dual_map_id :
  (linear_map.id : M₁ →ₗ[R] M₁).dual_map = linear_map.id :=
by { ext, refl }

lemma linear_map.dual_map_comp_dual_map {M₃ : Type*} [add_comm_group M₃] [module R M₃]
  (f : M₁ →ₗ[R] M₂) (g : M₂ →ₗ[R] M₃) :
  f.dual_map.comp g.dual_map = (g.comp f).dual_map :=
rfl

/-- The `linear_equiv` version of `linear_map.dual_map`. -/
def linear_equiv.dual_map (f : M₁ ≃ₗ[R] M₂) : dual R M₂ ≃ₗ[R] dual R M₁ :=
{ inv_fun := f.symm.to_linear_map.dual_map,
  left_inv :=
    begin
      intro φ, ext x,
      simp only [linear_map.dual_map_apply, linear_equiv.coe_to_linear_map,
                 linear_map.to_fun_eq_coe, linear_equiv.apply_symm_apply]
    end,
  right_inv :=
    begin
      intro φ, ext x,
      simp only [linear_map.dual_map_apply, linear_equiv.coe_to_linear_map,
                 linear_map.to_fun_eq_coe, linear_equiv.symm_apply_apply]
    end,
  .. f.to_linear_map.dual_map }

@[simp] lemma linear_equiv.dual_map_apply (f : M₁ ≃ₗ[R] M₂) (g : dual R M₂) (x : M₁) :
  f.dual_map g x = g (f x) :=
linear_map.lcomp_apply f g x

@[simp] lemma linear_equiv.dual_map_refl :
  (linear_equiv.refl R M₁).dual_map = linear_equiv.refl R (dual R M₁) :=
by { ext, refl }

@[simp] lemma linear_equiv.dual_map_symm {f : M₁ ≃ₗ[R] M₂} :
  (linear_equiv.dual_map f).symm = linear_equiv.dual_map f.symm := rfl

lemma linear_equiv.dual_map_trans {M₃ : Type*} [add_comm_group M₃] [module R M₃]
  (f : M₁ ≃ₗ[R] M₂) (g : M₂ ≃ₗ[R] M₃) :
  g.dual_map.trans f.dual_map = (f.trans g).dual_map :=
rfl

end dual_map

namespace linear_map
variables {R : Type*} [comm_semiring R] {M₁ : Type*} {M₂ : Type*}
variables [add_comm_monoid M₁] [module R M₁] [add_comm_monoid M₂] [module R M₂]

variable (f : M₁ →ₗ[R] M₂)

lemma ker_dual_map_eq_dual_annihilator_range :
  f.dual_map.ker = f.range.dual_annihilator :=
begin
  ext φ, split; intro hφ,
  { rw mem_ker at hφ,
    rw submodule.mem_dual_annihilator,
    rintro y ⟨x, rfl⟩,
    rw [← dual_map_apply, hφ, zero_apply] },
  { ext x,
    rw dual_map_apply,
    rw submodule.mem_dual_annihilator at hφ,
    exact hφ (f x) ⟨x, rfl⟩ }
end

lemma range_dual_map_le_dual_annihilator_ker :
  f.dual_map.range ≤ f.ker.dual_annihilator :=
begin
  rintro _ ⟨ψ, rfl⟩,
  simp_rw [submodule.mem_dual_annihilator, mem_ker],
  rintro x hx,
  rw [dual_map_apply, hx, map_zero]
end

section finite_dimensional

variables {K : Type*} [field K] {V₁ : Type*} {V₂ : Type*}
variables [add_comm_group V₁] [module K V₁] [add_comm_group V₂] [module K V₂]

open finite_dimensional

variable [finite_dimensional K V₂]

@[simp] lemma finrank_range_dual_map_eq_finrank_range (f : V₁ →ₗ[K] V₂) :
  finrank K f.dual_map.range = finrank K f.range :=
begin
  have := submodule.finrank_quotient_add_finrank f.range,
  rw [(subspace.quot_equiv_annihilator f.range).finrank_eq,
      ← ker_dual_map_eq_dual_annihilator_range] at this,
  conv_rhs at this { rw ← subspace.dual_finrank_eq },
  refine add_left_injective (finrank K f.dual_map.ker) _,
  change _ + _ = _ + _,
  rw [finrank_range_add_finrank_ker f.dual_map, add_comm, this],
end

lemma range_dual_map_eq_dual_annihilator_ker [finite_dimensional K V₁] (f : V₁ →ₗ[K] V₂) :
  f.dual_map.range = f.ker.dual_annihilator :=
begin
  refine eq_of_le_of_finrank_eq f.range_dual_map_le_dual_annihilator_ker _,
  have := submodule.finrank_quotient_add_finrank f.ker,
  rw (subspace.quot_equiv_annihilator f.ker).finrank_eq at this,
  refine add_left_injective (finrank K f.ker) _,
  simp_rw [this, finrank_range_dual_map_eq_finrank_range],
  exact finrank_range_add_finrank_ker f,
end

end finite_dimensional

section field

variables {K V : Type*}
variables [field K] [add_comm_group V] [module K V]

lemma dual_pairing_nondegenerate : (dual_pairing K V).nondegenerate :=
begin
  refine ⟨separating_left_iff_ker_eq_bot.mpr ker_id, _⟩,
  intros x,
  contrapose,
  rintros hx : x ≠ 0,
  rw [not_forall],
  let f : V →ₗ[K] K := classical.some (linear_pmap.mk_span_singleton x 1 hx).to_fun.exists_extend,
  use [f],
  refine ne_zero_of_eq_one _,
  have h : f.comp (K ∙ x).subtype = (linear_pmap.mk_span_singleton x 1 hx).to_fun :=
    classical.some_spec (linear_pmap.mk_span_singleton x (1 : K) hx).to_fun.exists_extend,
  exact (fun_like.congr_fun h _).trans (linear_pmap.mk_span_singleton_apply _ hx _),
end

end field

end linear_map

namespace tensor_product

variables (R : Type*) (M : Type*) (N : Type*)

variables {ι κ : Type*}
variables [decidable_eq ι] [decidable_eq κ]
variables [fintype ι] [fintype κ]

open_locale big_operators
open_locale tensor_product

local attribute [ext] tensor_product.ext

open tensor_product
open linear_map

section
variables [comm_semiring R] [add_comm_monoid M] [add_comm_monoid N]
variables [module R M] [module R N]

/--
The canonical linear map from `dual M ⊗ dual N` to `dual (M ⊗ N)`,
sending `f ⊗ g` to the composition of `tensor_product.map f g` with
the natural isomorphism `R ⊗ R ≃ R`.
-/
def dual_distrib : (dual R M) ⊗[R] (dual R N) →ₗ[R] dual R (M ⊗[R] N) :=
(comp_right ↑(tensor_product.lid R R)) ∘ₗ hom_tensor_hom_map R M N R R

variables {R M N}

@[simp]
lemma dual_distrib_apply (f : dual R M) (g : dual R N) (m : M) (n : N) :
  dual_distrib R M N (f ⊗ₜ g) (m ⊗ₜ n) = f m * g n :=
by simp only [dual_distrib, coe_comp, function.comp_app, hom_tensor_hom_map_apply,
  comp_right_apply, linear_equiv.coe_coe, map_tmul, lid_tmul, algebra.id.smul_eq_mul]

end

variables {R M N}
variables [comm_ring R] [add_comm_group M] [add_comm_group N]
variables [module R M] [module R N]

/--
An inverse to `dual_tensor_dual_map` given bases.
-/
noncomputable
def dual_distrib_inv_of_basis (b : basis ι R M) (c : basis κ R N) :
  dual R (M ⊗[R] N) →ₗ[R] (dual R M) ⊗[R] (dual R N) :=
∑ i j, (ring_lmap_equiv_self R ℕ _).symm (b.dual_basis i ⊗ₜ c.dual_basis j)
    ∘ₗ applyₗ (c j) ∘ₗ applyₗ (b i) ∘ₗ (lcurry R M N R)

@[simp]
lemma dual_distrib_inv_of_basis_apply (b : basis ι R M) (c : basis κ R N)
  (f : dual R (M ⊗[R] N)) : dual_distrib_inv_of_basis b c f =
  ∑ i j, (f (b i ⊗ₜ c j)) • (b.dual_basis i ⊗ₜ c.dual_basis j) :=
by simp [dual_distrib_inv_of_basis]

/--
A linear equivalence between `dual M ⊗ dual N` and `dual (M ⊗ N)` given bases for `M` and `N`.
It sends `f ⊗ g` to the composition of `tensor_product.map f g` with the natural
isomorphism `R ⊗ R ≃ R`.
-/
@[simps]
noncomputable def dual_distrib_equiv_of_basis (b : basis ι R M) (c : basis κ R N) :
  (dual R M) ⊗[R] (dual R N) ≃ₗ[R] dual R (M ⊗[R] N) :=
begin
  refine linear_equiv.of_linear
    (dual_distrib R M N) (dual_distrib_inv_of_basis b c) _ _,
  { ext f m n,
    have h : ∀ (r s : R), r • s = s • r := is_commutative.comm,
    simp only [compr₂_apply, mk_apply, comp_apply, id_apply, dual_distrib_inv_of_basis_apply,
      linear_map.map_sum, map_smul, sum_apply, smul_apply, dual_distrib_apply, h (f _) _,
      ← f.map_smul, ←f.map_sum, ←smul_tmul_smul, ←tmul_sum, ←sum_tmul, basis.coe_dual_basis,
      basis.coord_apply, basis.sum_repr] },
  { ext f g,
    simp only [compr₂_apply, mk_apply, comp_apply, id_apply, dual_distrib_inv_of_basis_apply,
      dual_distrib_apply, ←smul_tmul_smul, ←tmul_sum, ←sum_tmul, basis.coe_dual_basis,
      basis.sum_dual_apply_smul_coord] }
end

variables (R M N)
variables [module.finite R M] [module.finite R N] [module.free R M] [module.free R N]
variables [nontrivial R]

open_locale classical

/--
A linear equivalence between `dual M ⊗ dual N` and `dual (M ⊗ N)` when `M` and `N` are finite free
modules. It sends `f ⊗ g` to the composition of `tensor_product.map f g` with the natural
isomorphism `R ⊗ R ≃ R`.
-/
@[simp]
noncomputable
def dual_distrib_equiv : (dual R M) ⊗[R] (dual R N) ≃ₗ[R] dual R (M ⊗[R] N) :=
dual_distrib_equiv_of_basis (module.free.choose_basis R M) (module.free.choose_basis R N)

end tensor_product


import category_theory.limits.shapes.comm_sq

namespace category_theory

open limits

variables {C : Type*} [category C]
variables {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}

lemma is_pullback.is_iso_right (H : is_pullback f g h i) [is_iso h] : is_iso g :=
begin
  have : _ ≫ 𝟙 _ = g := H.is_limit.cone_point_unique_up_to_iso_hom_comp
    (pullback_cone_of_left_iso_is_limit h i) walking_cospan.right,
  rw ← this,
  apply_instance
end

lemma is_pullback.is_iso_left (H : is_pullback f g h i) [is_iso i] : is_iso f :=
H.flip.is_iso_right

lemma is_pullback.mono_left (H : is_pullback f g h i) [mono i] : mono f :=
pullback_cone.mono_fst_of_is_pullback_of_mono H.is_limit

lemma is_pullback.mono_right (H : is_pullback f g h i) [mono h] : mono g :=
pullback_cone.mono_snd_of_is_pullback_of_mono H.is_limit

end category_theory


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Jakob von Raumer
-/
import algebra.big_operators.basic
import algebra.hom.group
import algebra.module.basic
import category_theory.endomorphism
import category_theory.limits.shapes.kernels

/-!
# Preadditive categories

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

A preadditive category is a category in which `X ⟶ Y` is an abelian group in such a way that
composition of morphisms is linear in both variables.

This file contains a definition of preadditive category that directly encodes the definition given
above. The definition could also be phrased as follows: A preadditive category is a category
enriched over the category of Abelian groups. Once the general framework to state this in Lean is
available, the contents of this file should become obsolete.

## Main results

* Definition of preadditive categories and basic properties
* In a preadditive category, `f : Q ⟶ R` is mono if and only if `g ≫ f = 0 → g = 0` for all
  composable `g`.
* A preadditive category with kernels has equalizers.

## Implementation notes

The simp normal form for negation and composition is to push negations as far as possible to
the outside. For example, `f ≫ (-g)` and `(-f) ≫ g` both become `-(f ≫ g)`, and `(-f) ≫ (-g)`
is simplified to `f ≫ g`.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]

## Tags

additive, preadditive, Hom group, Ab-category, Ab-enriched
-/

universes v u

open category_theory.limits

open_locale big_operators

namespace category_theory

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

/-- A category is called preadditive if `P ⟶ Q` is an abelian group such that composition is
    linear in both variables. -/
class preadditive :=
(hom_group : Π P Q : C, add_comm_group (P ⟶ Q) . tactic.apply_instance)
(add_comp' : ∀ (P Q R : C) (f f' : P ⟶ Q) (g : Q ⟶ R),
  (f + f') ≫ g = f ≫ g + f' ≫ g . obviously)
(comp_add' : ∀ (P Q R : C) (f : P ⟶ Q) (g g' : Q ⟶ R),
  f ≫ (g + g') = f ≫ g + f ≫ g' . obviously)

attribute [instance] preadditive.hom_group
restate_axiom preadditive.add_comp'
restate_axiom preadditive.comp_add'
attribute [simp,reassoc] preadditive.add_comp
attribute [reassoc] preadditive.comp_add -- (the linter doesn't like `simp` on this lemma)
attribute [simp] preadditive.comp_add

end category_theory

open category_theory

namespace category_theory
namespace preadditive

section preadditive
open add_monoid_hom
variables {C : Type u} [category.{v} C] [preadditive C]

section induced_category
universes u'
variables {C} {D : Type u'} (F : D → C)

instance induced_category : preadditive.{v} (induced_category C F) :=
{ hom_group := λ P Q, @preadditive.hom_group C _ _ (F P) (F Q),
  add_comp' := λ P Q R f f' g, add_comp' _ _ _ _ _ _,
  comp_add' := λ P Q R f g g', comp_add' _ _ _ _ _ _, }

end induced_category

instance full_subcategory (Z : C → Prop) : preadditive.{v} (full_subcategory Z) :=
{ hom_group := λ P Q, @preadditive.hom_group C _ _ P.obj Q.obj,
  add_comp' := λ P Q R f f' g, add_comp' _ _ _ _ _ _,
  comp_add' := λ P Q R f g g', comp_add' _ _ _ _ _ _, }

instance (X : C) : add_comm_group (End X) := by { dsimp [End], apply_instance, }

instance (X : C) : ring (End X) :=
{ left_distrib := λ f g h, preadditive.add_comp X X X g h f,
  right_distrib := λ f g h, preadditive.comp_add X X X h f g,
  ..(infer_instance : add_comm_group (End X)),
  ..(infer_instance : monoid (End X)) }

/-- Composition by a fixed left argument as a group homomorphism -/
def left_comp {P Q : C} (R : C) (f : P ⟶ Q) : (Q ⟶ R) →+ (P ⟶ R) :=
mk' (λ g, f ≫ g) $ λ g g', by simp

/-- Composition by a fixed right argument as a group homomorphism -/
def right_comp (P : C) {Q R : C} (g : Q ⟶ R) : (P ⟶ Q) →+ (P ⟶ R) :=
mk' (λ f, f ≫ g) $ λ f f', by simp

variables {P Q R : C} (f f' : P ⟶ Q) (g g' : Q ⟶ R)

/-- Composition as a bilinear group homomorphism -/
def comp_hom : (P ⟶ Q) →+ (Q ⟶ R) →+ (P ⟶ R) :=
add_monoid_hom.mk' (λ f, left_comp _ f) $
  λ f₁ f₂, add_monoid_hom.ext $ λ g, (right_comp _ g).map_add f₁ f₂

@[simp, reassoc] lemma sub_comp :
  (f - f') ≫ g = f ≫ g - f' ≫ g :=
map_sub (right_comp P g) f f'

-- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma.
@[reassoc, simp] lemma comp_sub :
  f ≫ (g - g') = f ≫ g - f ≫ g' :=
map_sub (left_comp R f) g g'

@[simp, reassoc] lemma neg_comp : (-f) ≫ g = -(f ≫ g) :=
map_neg (right_comp P g) f

/- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma. -/
@[reassoc, simp] lemma comp_neg : f ≫ (-g) = -(f ≫ g) :=
map_neg (left_comp R f) g

@[reassoc] lemma neg_comp_neg : (-f) ≫ (-g) = f ≫ g :=
by simp

lemma nsmul_comp (n : ℕ) : (n • f) ≫ g = n • (f ≫ g) :=
map_nsmul (right_comp P g) n f

lemma comp_nsmul (n : ℕ) : f ≫ (n • g) = n • (f ≫ g) :=
map_nsmul (left_comp R f) n g

lemma zsmul_comp (n : ℤ) : (n • f) ≫ g = n • (f ≫ g) :=
map_zsmul (right_comp P g) n f

lemma comp_zsmul (n : ℤ) : f ≫ (n • g) = n • (f ≫ g) :=
map_zsmul (left_comp R f) n g

@[reassoc] lemma comp_sum {P Q R : C} {J : Type*} (s : finset J) (f : P ⟶ Q) (g : J → (Q ⟶ R)) :
  f ≫ ∑ j in s, g j = ∑ j in s, f ≫ g j :=
map_sum (left_comp R f) _ _

@[reassoc] lemma sum_comp {P Q R : C} {J : Type*} (s : finset J) (f : J → (P ⟶ Q)) (g : Q ⟶ R) :
  (∑ j in s, f j) ≫ g  = ∑ j in s, f j ≫ g :=
map_sum (right_comp P g) _ _

instance {P Q : C} {f : P ⟶ Q} [epi f] : epi (-f) :=
⟨λ R g g' H, by rwa [neg_comp, neg_comp, ←comp_neg, ←comp_neg, cancel_epi, neg_inj] at H⟩

instance {P Q : C} {f : P ⟶ Q} [mono f] : mono (-f) :=
⟨λ R g g' H, by rwa [comp_neg, comp_neg, ←neg_comp, ←neg_comp, cancel_mono, neg_inj] at H⟩

@[priority 100]
instance preadditive_has_zero_morphisms : has_zero_morphisms C :=
{ has_zero := infer_instance,
  comp_zero' := λ P Q f R, show left_comp R f 0 = 0, from map_zero _,
  zero_comp' := λ P Q R f, show right_comp P f 0 = 0, from map_zero _ }

instance module_End_right {X Y : C} : module (End Y) (X ⟶ Y) :=
{ smul_add := λ r f g, add_comp _ _ _ _ _ _,
  smul_zero := λ r, zero_comp,
  add_smul := λ r s f, comp_add _ _ _ _ _ _,
  zero_smul := λ r, comp_zero }

lemma mono_of_cancel_zero {Q R : C} (f : Q ⟶ R) (h : ∀ {P : C} (g : P ⟶ Q), g ≫ f = 0 → g = 0) :
  mono f :=
⟨λ P g g' hg, sub_eq_zero.1 $ h _ $ (map_sub (right_comp P f) g g').trans $ sub_eq_zero.2 hg⟩

lemma mono_iff_cancel_zero {Q R : C} (f : Q ⟶ R) :
  mono f ↔ ∀ (P : C) (g : P ⟶ Q), g ≫ f = 0 → g = 0 :=
⟨λ m P g, by exactI zero_of_comp_mono _, mono_of_cancel_zero f⟩

lemma mono_of_kernel_zero {X Y : C} {f : X ⟶ Y} [has_limit (parallel_pair f 0)]
  (w : kernel.ι f = 0) : mono f :=
mono_of_cancel_zero f (λ P g h, by rw [←kernel.lift_ι f g h, w, limits.comp_zero])

lemma epi_of_cancel_zero {P Q : C} (f : P ⟶ Q) (h : ∀ {R : C} (g : Q ⟶ R), f ≫ g = 0 → g = 0) :
  epi f :=
⟨λ R g g' hg, sub_eq_zero.1 $ h _ $ (map_sub (left_comp R f) g g').trans $ sub_eq_zero.2 hg⟩

lemma epi_iff_cancel_zero {P Q : C} (f : P ⟶ Q) :
  epi f ↔ ∀ (R : C) (g : Q ⟶ R), f ≫ g = 0 → g = 0 :=
⟨λ e R g, by exactI zero_of_epi_comp _, epi_of_cancel_zero f⟩

namespace is_iso

@[simp] lemma comp_left_eq_zero [is_iso f] :
  f ≫ g = 0 ↔ g = 0 :=
by rw [← is_iso.eq_inv_comp, limits.comp_zero]

@[simp] lemma comp_right_eq_zero [is_iso g] :
  f ≫ g = 0 ↔ f = 0 :=
by rw [← is_iso.eq_comp_inv, limits.zero_comp]

end is_iso

open_locale zero_object
variables [has_zero_object C]

lemma mono_of_kernel_iso_zero {X Y : C} {f : X ⟶ Y} [has_limit (parallel_pair f 0)]
  (w : kernel f ≅ 0) : mono f :=
mono_of_kernel_zero (zero_of_source_iso_zero _ w)

lemma epi_of_cokernel_iso_zero {X Y : C} {f : X ⟶ Y} [has_colimit (parallel_pair f 0)]
  (w : cokernel f ≅ 0) : epi f :=
epi_of_cokernel_zero (zero_of_target_iso_zero _ w)

end preadditive

section equalizers
variables {C : Type u} [category.{v} C] [preadditive C]

section
variables {X Y : C} {f : X ⟶ Y} {g : X ⟶ Y}

/-- Map a kernel cone on the difference of two morphisms to the equalizer fork. -/
@[simps X]
def fork_of_kernel_fork (c : kernel_fork (f - g)) : fork f g :=
fork.of_ι c.ι $ by rw [← sub_eq_zero, ← comp_sub, c.condition]

@[simp] lemma fork_of_kernel_fork_ι (c : kernel_fork (f - g)) :
  (fork_of_kernel_fork c).ι = c.ι := rfl

/-- Map any equalizer fork to a cone on the difference of the two morphisms. -/
def kernel_fork_of_fork (c : fork f g) : kernel_fork (f - g) :=
fork.of_ι c.ι $ by rw [comp_sub, comp_zero, sub_eq_zero, c.condition]

@[simp] lemma kernel_fork_of_fork_ι (c : fork f g) : (kernel_fork_of_fork c).ι = c.ι := rfl

@[simp] lemma kernel_fork_of_fork_of_ι {P : C} (ι : P ⟶ X) (w : ι ≫ f = ι ≫ g) :
  (kernel_fork_of_fork (fork.of_ι ι w)) = kernel_fork.of_ι ι (by simp [w]) := rfl

/-- A kernel of `f - g` is an equalizer of `f` and `g`. -/
def is_limit_fork_of_kernel_fork {c : kernel_fork (f - g)} (i : is_limit c) :
  is_limit (fork_of_kernel_fork c) :=
fork.is_limit.mk' _ $ λ s,
  ⟨i.lift (kernel_fork_of_fork s), i.fac _ _,
   λ m h, by apply fork.is_limit.hom_ext i; tidy⟩

@[simp]
lemma is_limit_fork_of_kernel_fork_lift {c : kernel_fork (f - g)} (i : is_limit c) (s : fork f g) :
  (is_limit_fork_of_kernel_fork i).lift s = i.lift (kernel_fork_of_fork s) := rfl

/-- An equalizer of `f` and `g` is a kernel of `f - g`. -/
def is_limit_kernel_fork_of_fork {c : fork f g} (i : is_limit c) :
  is_limit (kernel_fork_of_fork c) :=
fork.is_limit.mk' _ $ λ s,
  ⟨i.lift (fork_of_kernel_fork s), i.fac _ _,
    λ m h, by apply fork.is_limit.hom_ext i; tidy⟩

variables (f g)

/-- A preadditive category has an equalizer for `f` and `g` if it has a kernel for `f - g`. -/
lemma has_equalizer_of_has_kernel [has_kernel (f - g)] : has_equalizer f g :=
has_limit.mk { cone := fork_of_kernel_fork _,
  is_limit := is_limit_fork_of_kernel_fork (equalizer_is_equalizer (f - g) 0) }

/-- A preadditive category has a kernel for `f - g` if it has an equalizer for `f` and `g`. -/
lemma has_kernel_of_has_equalizer [has_equalizer f g] : has_kernel (f - g) :=
has_limit.mk { cone := kernel_fork_of_fork (equalizer.fork f g),
  is_limit := is_limit_kernel_fork_of_fork (limit.is_limit (parallel_pair f g)) }

variables {f g}

/-- Map a cokernel cocone on the difference of two morphisms to the coequalizer cofork. -/
@[simps X]
def cofork_of_cokernel_cofork (c : cokernel_cofork (f - g)) : cofork f g :=
cofork.of_π c.π $ by rw [← sub_eq_zero, ← sub_comp, c.condition]

@[simp] lemma cofork_of_cokernel_cofork_π (c : cokernel_cofork (f - g)) :
  (cofork_of_cokernel_cofork c).π = c.π := rfl

/-- Map any coequalizer cofork to a cocone on the difference of the two morphisms. -/
def cokernel_cofork_of_cofork (c : cofork f g) : cokernel_cofork (f - g) :=
cofork.of_π c.π $ by rw [sub_comp, zero_comp, sub_eq_zero, c.condition]

@[simp] lemma cokernel_cofork_of_cofork_π (c : cofork f g) :
  (cokernel_cofork_of_cofork c).π = c.π := rfl

@[simp] lemma cokernel_cofork_of_cofork_of_π {P : C} (π : Y ⟶ P) (w : f ≫ π = g ≫ π) :
  (cokernel_cofork_of_cofork (cofork.of_π π w)) = cokernel_cofork.of_π π (by simp [w]) := rfl

/-- A cokernel of `f - g` is a coequalizer of `f` and `g`. -/
def is_colimit_cofork_of_cokernel_cofork {c : cokernel_cofork (f - g)} (i : is_colimit c) :
  is_colimit (cofork_of_cokernel_cofork c) :=
cofork.is_colimit.mk' _ $ λ s,
  ⟨i.desc (cokernel_cofork_of_cofork s), i.fac _ _,
    λ m h, by apply cofork.is_colimit.hom_ext i; tidy⟩

@[simp]
lemma is_colimit_cofork_of_cokernel_cofork_desc {c : cokernel_cofork (f - g)}
  (i : is_colimit c) (s : cofork f g) :
  (is_colimit_cofork_of_cokernel_cofork i).desc s = i.desc (cokernel_cofork_of_cofork s) := rfl

/-- A coequalizer of `f` and `g` is a cokernel of `f - g`. -/
def is_colimit_cokernel_cofork_of_cofork {c : cofork f g} (i : is_colimit c) :
  is_colimit (cokernel_cofork_of_cofork c) :=
cofork.is_colimit.mk' _ $ λ s,
  ⟨i.desc (cofork_of_cokernel_cofork s), i.fac _ _,
    λ m h, by apply cofork.is_colimit.hom_ext i; tidy⟩

variables (f g)

/-- A preadditive category has a coequalizer for `f` and `g` if it has a cokernel for `f - g`. -/
lemma has_coequalizer_of_has_cokernel [has_cokernel (f - g)] : has_coequalizer f g :=
has_colimit.mk { cocone := cofork_of_cokernel_cofork _,
  is_colimit := is_colimit_cofork_of_cokernel_cofork (coequalizer_is_coequalizer (f - g) 0) }

/-- A preadditive category has a cokernel for `f - g` if it has a coequalizer for `f` and `g`. -/
lemma has_cokernel_of_has_coequalizer [has_coequalizer f g] : has_cokernel (f - g) :=
has_colimit.mk { cocone := cokernel_cofork_of_cofork (coequalizer.cofork f g),
  is_colimit := is_colimit_cokernel_cofork_of_cofork (colimit.is_colimit (parallel_pair f g)) }

end

/-- If a preadditive category has all kernels, then it also has all equalizers. -/
lemma has_equalizers_of_has_kernels [has_kernels C] : has_equalizers C :=
@has_equalizers_of_has_limit_parallel_pair _ _ (λ _ _ f g, has_equalizer_of_has_kernel f g)

/-- If a preadditive category has all cokernels, then it also has all coequalizers. -/
lemma has_coequalizers_of_has_cokernels [has_cokernels C] : has_coequalizers C :=
@has_coequalizers_of_has_colimit_parallel_pair _ _ (λ _ _ f g, has_coequalizer_of_has_cokernel f g)

end equalizers

end preadditive

end category_theory


example (p q r : Prop) (hp : p) : q ∨ p ∨ r :=
  by repeat (first |apply Or.inl; assumption | apply Or.inr | assumption)
 example (p q r : Prop) (hp : p)
         : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) := by
  repeat(any_goals (first | apply And.intro | apply Or.inl; assumption | apply Or.inr | assumption))

variable (x y : Nat)

def double := x + x
#eval Lean.versionString

#check double y
#check Nat.succ_ne_zero

inductive Weekday where
  | sunday
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  deriving Repr

open Weekday

#eval sunday

def next (d : Weekday) : Weekday :=
  match d with
  | sunday    => monday
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => saturday
  | saturday  => sunday

def previous (d : Weekday) : Weekday :=
  match d with
  | sunday    => saturday
  | monday    => sunday
  | tuesday   => monday
  | wednesday => tuesday
  | thursday  => wednesday
  | friday    => thursday
  | saturday  => friday

#eval next (next tuesday)      -- Weekday.thursday
#eval next (previous tuesday)  -- Weekday.tuesday

example : next (previous tuesday) = tuesday :=
  rfl
def next_previous (d : Weekday) : next (previous d) = d := by
  cases d <;> rfl

def and1 ( a b : Bool) : Bool :=
  match a with
  | true => b
  | false => false

def prod_example (p : Bool × Nat) : Nat :=
  Prod.casesOn (motive := fun _ => Nat ) p (fun b n => cond b (2 * n) (2*n + 1))

#eval prod_example (true, 3)
#eval prod_example (false, 3)

def fst {α : Type u} {β : Type v} {p : Prod α β} : α :=
  match p with
  | Prod.mk a b => a

def snd {α : Type u} {β : Type v} (p : Prod α β ) : β :=
  match p with
  | Prod.mk a b => b

def sum_example (s : Sum Nat Nat) : Nat :=
Sum.casesOn (motive := fun _ => Nat) s
    (fun n => 2 * n)
    (fun n => 2 * n + 1)

#eval sum_example (Sum.inl 3)
#eval sum_example (Sum.inr 3)
namespace Hidden
structure Prod (α : Type u) (β : Type v) where
  mk :: (fst : α) (snd : β)
inductive Sigma {α : Type u} ( β : α → Type v) where
  | mk : (a : α) → β a → Sigma β
inductive Option (α : Type u) where
  | none : Option α
  | some : α → Option α

inductive False : Prop
end Hidden

structure Color where
  (red : Nat) (green : Nat) (blue : Nat)
  deriving Repr

def yellow := Color.mk 255 255 0
#eval Color.red yellow

structure semigroup where
  carrier : Type u
  mul : carrier → carrier → carrier
  mul_assoc : ∀ a b c, mul (mul a b) c = mul a (mul b c)

namespace Hidden
open Nat

theorem zero_add (n : Nat) : 0 + n = n :=
  Nat.recOn (motive := fun x => 0 + x = x)
   n
   (show 0 + 0 = 0 from rfl)
   (fun (n : Nat) (ih : 0 + n = n) =>
    show 0 + succ n = succ n from
    calc
       0 + succ n = succ (0 + n) := rfl
                _ = succ n       := by rw [ih])
theorem add_assoc ( m n k : Nat) : m + n + k = m + (n + k) :=
  Nat.recOn (motive := fun k => m + n + k = m + (n + k) ) k
    rfl
    (fun k ih => by simp [Nat.add_succ, ih])

end Hidden

open Nat
theorem zero_add (n : Nat) : 0 + n = n :=
  Nat.recOn (motive := fun x => 0 + x = x) n
  rfl
  (fun n ih => by simp [add_succ, ih])
namespace hidden
theorem succ_add (m n : Nat) : succ n + m = succ (n + m) :=
  Nat.recOn (motive := fun x => succ n + x = succ (n + x)) m
    rfl
    (fun m ih => by simp only [add_succ, ih])

theorem add_comm (m n : Nat) : m + n = n + m :=
  Nat.recOn (motive := fun x => m + x = x + m) n
    (by simp)
    (fun m ih => by simp only [add_succ, succ_add, ih])
end hidden

namespace Hidden
inductive List (α : Type u) where
| nil : List α
| cons : α → List α → List α

namespace List
def append (as bs : List α) : List α :=
  match as with
  | nil => bs
  | cons a as => cons a (append as bs)
theorem nil_append (as : List α) : append nil as = as :=
  rfl

theorem cons_append (a : α) (as bs : List α)
          : append (cons a as) bs = cons a (append as bs) :=
          rfl
#check @List.recOn
theorem append_nil (as : List α) : append as nil = as :=
  List.recOn  (motive := fun x => append x nil = x) as
    rfl
    (fun a as ih => by simp [cons_append, ih]
    )
#print append_nil
theorem append_assoc (as bs cs : List α)
        : append (append as bs) cs = append as (append bs cs) :=
  List.recOn (motive := fun as => append (append as bs) cs = append as (append bs cs)) as
    rfl
    (fun a as ih => by simp [cons_append, ih])
def length (as : List α) : Nat :=
  match as with
  | nil => 0
  | cons a as => 1 + length as

attribute [simp] append_nil
attribute [simp] append_assoc
attribute [simp] cons_append

theorem length_sum (as bs : List α) : length (append as bs) = length as + length bs :=
  List.recOn (motive := fun as => length (append as bs) = length as + length bs) as
    (show length (append nil bs) = length nil + length bs from
      calc length (append nil bs) = length bs := rfl
              _ = 0 + length bs := by rw[ Nat.zero_add]
              _ = length nil + length bs := rfl
    )
    (fun a as ih =>
    calc length (append (cons a as) bs) = length (cons a (append as bs)) := by rw[cons_append]
          _ = 1 + length ( append as bs) := rfl
          _ = 1 + (length as + length bs) := by simp[ih]
          _ = (1 + length as) + length bs := by simp[Nat.add_assoc]
          _ = length (cons a as) + length bs := rfl
    )
inductive BinaryTree where
  | leaf : BinaryTree
  | node : BinaryTree → BinaryTree → BinaryTree

inductive CBTree where
end List
end Hidden

example (p : Nat → Prop) (hz : p 0) (hs : ∀ n, p (Nat.succ n)) : ∀ n, p n := by
  intro n
  cases n
  . exact hz  -- goal is p 0
  . apply hs  -- goal is a : ℕ ⊢ p (succ a)

example (n : Nat) (h : n ≠  0) : succ (pred n) = n := by
  cases n with
  | zero =>
    apply absurd rfl h
  | succ m =>
  rfl

def f (n : Nat) : Nat := by
  cases n; exact 3; exact 7

example : f 0 = 3 := rfl
example : f 5 = 7 := rfl

def Tuple (α : Type) (n : Nat) :=
{ as : List α // as.length = n}
def fr {n :Nat} {t : Tuple α n} : Nat := by
  cases n ; exact 3; exact 7

def myTuple : Tuple Nat 3 :=
⟨ [0,1,2], rfl ⟩

inductive Foo where
| bar1 : Nat → Nat → Foo
| bar2 : Nat → Nat → Nat → Foo

def silly (x : Foo) : Nat := by
  cases x with
  | bar2 c d e => exact e
  | bar1 a b => exact b

open Nat
example (p : Nat → Prop) (hz : p 0) (hs : ∀ n , p (succ n)) (m k : Nat) : p (m + 3 * k) := by
  generalize m + 3 * k = n
  cases n
  exact hz
  apply hs

example (p : Prop) (m n : Nat) (h₁ : m < n → p) (h₂ : m ≥ n → p) : p := by
  cases Nat.lt_or_ge m n
  case inl hlt => exact h₁ hlt
  case inr glt => exact h₂ glt

  #check Nat.sub_self
  example (m n : Nat) : m - n = 0 ∨ m ≠ n := by
    cases Decidable.em (m = n) with
    | inl heq => rw [heq] ; apply Or.inl; exact Nat.sub_self n
    | inr hne => apply Or.inr; exact hne
namespace Hidden1
theorem zero_add (n : Nat) : 0 + n = n := by
  induction n
  case zero => rfl
  case succ n ih => rw [Nat.add_succ, ih]
end Hidden1

example (x : Nat) {y : Nat} (h : y > 0) : x % y < y := by
  induction x, y using Nat.mod.inductionOn with
  | ind x y h₁ ih =>
    rw [Nat.mod_eq_sub_mod h₁.2]
    exact ih h
  | base x y h₁ =>
    have : ¬ 0 < y ∨ ¬ y ≤ x := Iff.mp (Decidable.not_and_iff_or_not ..) h₁
    match this with
    | Or.inl h₁ => exact absurd h h₁
    | Or.inr h₁ =>
      have hgt : y > x := Nat.gt_of_not_le h₁
      rw [← Nat.mod_eq_of_lt hgt] at hgt
      assumption