/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import control.equiv_functor
import logic.equiv.basic

/-!
# Equivalences for `option α`

We define
* `equiv.option_congr`: the `option α ≃ option β` constructed from `e : α ≃ β` by sending `none` to
  `none`, and applying a `e` elsewhere.
* `equiv.remove_none`: the `α ≃ β` constructed from `option α ≃ option β` by removing `none` from
  both sides.
-/

namespace equiv

variables {α β γ : Type*}

section option_congr

/-- A universe-polymorphic version of `equiv_functor.map_equiv option e`. -/
@[simps apply]
def option_congr (e : α ≃ β) : option α ≃ option β :=
{ to_fun := option.map e,
  inv_fun := option.map e.symm,
  left_inv := λ x, (option.map_map _ _ _).trans $
    e.symm_comp_self.symm ▸ congr_fun option.map_id x,
  right_inv := λ x, (option.map_map _ _ _).trans $
    e.self_comp_symm.symm ▸ congr_fun option.map_id x }

@[simp] lemma option_congr_refl : option_congr (equiv.refl α) = equiv.refl _ :=
ext $ congr_fun option.map_id

@[simp] lemma option_congr_symm (e : α ≃ β) : (option_congr e).symm = option_congr e.symm := rfl

@[simp] lemma option_congr_trans (e₁ : α ≃ β) (e₂ : β ≃ γ) :
  (option_congr e₁).trans (option_congr e₂) = option_congr (e₁.trans e₂) :=
ext $ option.map_map _ _

/-- When `α` and `β` are in the same universe, this is the same as the result of
`equiv_functor.map_equiv`. -/
lemma option_congr_eq_equiv_function_map_equiv {α β : Type*} (e : α ≃ β) :
  option_congr e = equiv_functor.map_equiv option e := rfl

end option_congr

section remove_none
variables (e : option α ≃ option β)

private def remove_none_aux (x : α) : β :=
if h : (e (some x)).is_some
  then option.get h
  else option.get $ show (e none).is_some, from
  begin
    rw ←option.ne_none_iff_is_some,
    intro hn,
    rw [option.not_is_some_iff_eq_none, ←hn] at h,
    simpa only using e.injective h,
  end

private lemma remove_none_aux_some {x : α} (h : ∃ x', e (some x) = some x') :
  some (remove_none_aux e x) = e (some x) :=
by simp [remove_none_aux, option.is_some_iff_exists.mpr h]

private lemma remove_none_aux_none {x : α} (h : e (some x) = none) :
  some (remove_none_aux e x) = e none :=
by simp [remove_none_aux, option.not_is_some_iff_eq_none.mpr h]

private lemma remove_none_aux_inv (x : α) : remove_none_aux e.symm (remove_none_aux e x) = x :=
option.some_injective _ begin
  cases h1 : e.symm (some (remove_none_aux e x)); cases h2 : (e (some x)),
  { rw remove_none_aux_none _ h1,
    exact (e.eq_symm_apply.mpr h2).symm },
  { rw remove_none_aux_some _ ⟨_, h2⟩ at h1,
    simpa using h1, },
  { rw remove_none_aux_none _ h2 at h1,
    simpa using h1, },
  { rw remove_none_aux_some _ ⟨_, h1⟩,
    rw remove_none_aux_some _ ⟨_, h2⟩,
    simp },
end

/-- Given an equivalence between two `option` types, eliminate `none` from that equivalence by
mapping `e.symm none` to `e none`. -/
def remove_none : α ≃ β :=
{ to_fun := remove_none_aux e,
  inv_fun := remove_none_aux e.symm,
  left_inv := remove_none_aux_inv e,
  right_inv := remove_none_aux_inv e.symm, }

@[simp]
lemma remove_none_symm : (remove_none e).symm = remove_none e.symm := rfl

lemma remove_none_some {x : α} (h : ∃ x', e (some x) = some x') :
  some (remove_none e x) = e (some x) := remove_none_aux_some e h

@[simp] lemma option_symm_apply_none_iff : e.symm none = none ↔ e none = none :=
⟨λ h, by simpa using (congr_arg e h).symm, λ h, by simpa using (congr_arg e.symm h).symm⟩

lemma some_remove_none_iff {x : α} :
  some (remove_none e x) = e none ↔ e.symm none = some x :=
begin
  cases h : e (some x) with a,
  { rw remove_none_none _ h,
    simpa using (congr_arg e.symm h).symm },
  { rw remove_none_some _ ⟨a, h⟩,
    have := (congr_arg e.symm h),
    rw [symm_apply_apply] at this,
    simp only [false_iff, apply_eq_iff_eq],
    simp [this] }
end

@[simp]
lemma remove_none_option_congr (e : α ≃ β) : remove_none e.option_congr = e :=
equiv.ext $ λ x, option.some_injective _ $ remove_none_some _ ⟨e x, by simp [equiv_functor.map]⟩

end remove_none

lemma option_congr_injective : function.injective (option_congr : α ≃ β → option α ≃ option β) :=
function.left_inverse.injective remove_none_option_congr

end equiv


import data.rat.basic tactic

-- prove one and delete the other

theorem some_reciprocal_is_zero : ∃ x : ℚ, 1 / x = 0 :=
begin
  use 0,
  norm_num -- exact dec_trivial would also work
end

--theorem no_reciprocal_is_zero : ¬ (∃ x : ℚ, 1 / x = 0) :=
--begin
--  sorry
--end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.instances.ennreal
import Mathlib.PostPort

universes u u_1 u_2 u_3

namespace Mathlib

/-!
# Probability mass functions

This file is about probability mass functions or discrete probability measures:
a function `α → ℝ≥0` such that the values have (infinite) sum `1`.

This file features the monadic structure of `pmf` and the Bernoulli distribution

## Implementation Notes

This file is not yet connected to the `measure_theory` library in any way.
At some point we need to define a `measure` from a `pmf` and prove the appropriate lemmas about
that.

## Tags

probability mass function, discrete probability measure, bernoulli distribution
-/

/-- A probability mass function, or discrete probability measures is a function `α → ℝ≥0` such that
  the values have (infinite) sum `1`. -/
def pmf (α : Type u) :=
  Subtype fun (f : α → nnreal) => has_sum f 1

namespace pmf

protected instance has_coe_to_fun {α : Type u_1} : has_coe_to_fun (pmf α) :=
  has_coe_to_fun.mk (fun (p : pmf α) => α → nnreal) fun (p : pmf α) (a : α) => subtype.val p a

protected theorem ext {α : Type u_1} {p : pmf α} {q : pmf α} : (∀ (a : α), coe_fn p a = coe_fn q a) → p = q := sorry

theorem has_sum_coe_one {α : Type u_1} (p : pmf α) : has_sum (⇑p) 1 :=
  subtype.property p

theorem summable_coe {α : Type u_1} (p : pmf α) : summable ⇑p :=
  has_sum.summable (has_sum_coe_one p)

@[simp] theorem tsum_coe {α : Type u_1} (p : pmf α) : (tsum fun (a : α) => coe_fn p a) = 1 :=
  has_sum.tsum_eq (has_sum_coe_one p)

/-- The support of a `pmf` is the set where it is nonzero. -/
def support {α : Type u_1} (p : pmf α) : set α :=
  set_of fun (a : α) => subtype.val p a ≠ 0

/-- The pure `pmf` is the `pmf` where all the mass lies in one point.
  The value of `pure a` is `1` at `a` and `0` elsewhere. -/
def pure {α : Type u_1} (a : α) : pmf α :=
  { val := fun (a' : α) => ite (a' = a) 1 0, property := sorry }

@[simp] theorem pure_apply {α : Type u_1} (a : α) (a' : α) : coe_fn (pure a) a' = ite (a' = a) 1 0 :=
  rfl

protected instance inhabited {α : Type u_1} [Inhabited α] : Inhabited (pmf α) :=
  { default := pure Inhabited.default }

theorem coe_le_one {α : Type u_1} (p : pmf α) (a : α) : coe_fn p a ≤ 1 := sorry

protected theorem bind.summable {α : Type u_1} {β : Type u_2} (p : pmf α) (f : α → pmf β) (b : β) : summable fun (a : α) => coe_fn p a * coe_fn (f a) b := sorry

/-- The monadic bind operation for `pmf`. -/
def bind {α : Type u_1} {β : Type u_2} (p : pmf α) (f : α → pmf β) : pmf β :=
  { val := fun (b : β) => tsum fun (a : α) => coe_fn p a * coe_fn (f a) b, property := sorry }

@[simp] theorem bind_apply {α : Type u_1} {β : Type u_2} (p : pmf α) (f : α → pmf β) (b : β) : coe_fn (bind p f) b = tsum fun (a : α) => coe_fn p a * coe_fn (f a) b :=
  rfl

theorem coe_bind_apply {α : Type u_1} {β : Type u_2} (p : pmf α) (f : α → pmf β) (b : β) : ↑(coe_fn (bind p f) b) = tsum fun (a : α) => ↑(coe_fn p a) * ↑(coe_fn (f a) b) := sorry

@[simp] theorem pure_bind {α : Type u_1} {β : Type u_2} (a : α) (f : α → pmf β) : bind (pure a) f = f a := sorry

@[simp] theorem bind_pure {α : Type u_1} (p : pmf α) : bind p pure = p := sorry

@[simp] theorem bind_bind {α : Type u_1} {β : Type u_2} {γ : Type u_3} (p : pmf α) (f : α → pmf β) (g : β → pmf γ) : bind (bind p f) g = bind p fun (a : α) => bind (f a) g := sorry

theorem bind_comm {α : Type u_1} {β : Type u_2} {γ : Type u_3} (p : pmf α) (q : pmf β) (f : α → β → pmf γ) : (bind p fun (a : α) => bind q (f a)) = bind q fun (b : β) => bind p fun (a : α) => f a b := sorry

/-- The functorial action of a function on a `pmf`. -/
def map {α : Type u_1} {β : Type u_2} (f : α → β) (p : pmf α) : pmf β :=
  bind p (pure ∘ f)

theorem bind_pure_comp {α : Type u_1} {β : Type u_2} (f : α → β) (p : pmf α) : bind p (pure ∘ f) = map f p :=
  rfl

theorem map_id {α : Type u_1} (p : pmf α) : map id p = p := sorry

theorem map_comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} (p : pmf α) (f : α → β) (g : β → γ) : map g (map f p) = map (g ∘ f) p := sorry

theorem pure_map {α : Type u_1} {β : Type u_2} (a : α) (f : α → β) : map f (pure a) = pure (f a) := sorry

/-- The monadic sequencing operation for `pmf`. -/
def seq {α : Type u_1} {β : Type u_2} (f : pmf (α → β)) (p : pmf α) : pmf β :=
  bind f fun (m : α → β) => bind p fun (a : α) => pure (m a)

/-- Given a non-empty multiset `s` we construct the `pmf` which sends `a` to the fraction of
  elements in `s` that are `a`. -/
def of_multiset {α : Type u_1} (s : multiset α) (hs : s ≠ 0) : pmf α :=
  { val := fun (a : α) => ↑(multiset.count a s) / ↑(coe_fn multiset.card s), property := sorry }

/-- Given a finite type `α` and a function `f : α → ℝ≥0` with sum 1, we get a `pmf`. -/
def of_fintype {α : Type u_1} [fintype α] (f : α → nnreal) (h : (finset.sum finset.univ fun (x : α) => f x) = 1) : pmf α :=
  { val := f, property := sorry }

/-- A `pmf` which assigns probability `p` to `tt` and `1 - p` to `ff`. -/
def bernoulli (p : nnreal) (h : p ≤ 1) : pmf Bool :=
  of_fintype (fun (b : Bool) => cond b p (1 - p)) sorry


/- In this file we define the general linear group as an affine group over a discrete field `K`-/
import .affine_variety group_theory.perm.sign ..to_mathlib category_theory.instances.groups

open topological_space function sum finsupp category_theory tensor_product category_theory.limits
universe u

local attribute [instance, priority 1] limits.category_theory.limits.has_limit
  limits.category_theory.limits.has_colimit limits.category_theory.limits.has_colimits
  limits.category_theory.limits.has_limits limits.category_theory.limits.has_limits_of_shape
  limits.category_theory.limits.has_colimits_of_shape
variables (K : Type u) [discrete_field K] {n : ℕ}

noncomputable theory

namespace algebraic_geometry
namespace GL
open mv_polynomial

/-- The `K`-algebra `K[x₀,xᵢⱼ]` for `i,j ∈ {1, ... n}` -/
def GL_aux1 (n : ℕ) : FRAlgebra K :=
FRAlgebra_mv_polynomial.{u 0} K (fin n × fin n ⊕ unit)

/-- Auxiliary definition for the determinant: the graph of a map out of a finite type -/
def det_aux {α β : Type*} [fintype α] [decidable_eq β] (f : α → β) : α × β →₀ ℕ :=
on_finset (finset.univ.product $ finset.univ.image f)
  (λ⟨a, b⟩, if f a = b then 1 else 0)
  (by { rintro ⟨a, b⟩ h, dsimp [det_aux._match_1] at h, cases ite_ne_neg h, simp })

/-- Auxiliary definition for the determinant:
  the graph of a map out of a finite type as an embedding -/
def det_aux2 {α β : Type*} [fintype α] [decidable_eq β] : (α → β) ↪ α × β →₀ ℕ :=
⟨det_aux, omitted⟩

/-- Auxiliary definition for the determinant: the function that turns an equivalence into
  a monomial in a polynomial ring over one extra variable. -/
def det_aux3 {α β : Type*} [fintype α] [decidable_eq α] [decidable_eq β] :
  (α ≃ β) ↪ α × β ⊕ unit →₀ ℕ :=
equiv.equiv_embedding_fun.trans $ det_aux2.trans $ finsupp_embedding_finsupp_left sum.embedding_inl

/-- We define the determinant as a multivariate polynomial follows:
* We can embed permutations `fin n ≃ fin n` into `fin n × fin n →₀ ℕ` using the
  characteristic map of the graph of the function.
* If a monomial corresponds to a permutation, then its coefficient is the sign of the permutation,
  otherwise it is `0`. -/
def det (n : ℕ) : GL_aux1 K n :=
emb_domain det_aux3 $ equiv_fun_on_fintype.inv_fun $ λ e, int.cast $ equiv.perm.sign e

/-- The element `x₀ * det(xᵢⱼ) - 1` in `K[x₀,xᵢⱼ]` by which we quotient to obtain `GL(n)` -/
def GL_element (n : ℕ) : GL_aux1 K n :=
X (inr ⟨⟩) * det K n - 1

/-- The ideal spanned by `x₀ * det(xᵢⱼ) - 1` is radical -/
lemma radical_ideal_span_det (n : ℕ) :
  (ideal.span ({ GL_element K n } : set (GL_aux1 K n))).is_radical :=
omitted

/-- The ideal spanned by `x₀ * det(xᵢⱼ) - 1` as a radical ideal -/
def GL_aux (n : ℕ) : ideal.radical_ideal (GL_aux1 K n) :=
⟨(ideal.span ({ GL_element K n } : set (GL_aux1 K n))), by apply radical_ideal_span_det K n⟩

/-- The general linear group is defined as `K[x₀,xᵢⱼ]/(x₀ * det(xᵢⱼ) - 1)` -/
def GL_op (n : ℕ) : FRAlgebra K :=
⟨K, (GL_aux K n).val.quotient⟩

/-- The general linear group as an affine variety -/
def GL_var (n : ℕ) : affine_variety K :=
op (GL_op K n)

variable {K}
section
set_option class.instance_max_depth 80
/-- The (opposite of the) multiplication on `GL(n)`. It uses the formula for matrix multiplcation,
  sending `xᵢⱼ` to `Σₖ xᵢₖ ⊗ xₖⱼ`. It sends `x₀` to `x₀ ⊗ x₀` -/
def GL_mul_op : GL_op K n ⟶ FRAlgebra_tensor (GL_op K n) (GL_op K n) :=
algebra.quotient.lift
  begin
    refine alg_hom.comp (tensor_functor (algebra.quotient.mk _) (algebra.quotient.mk _)) _,
    refine aeval₂ _,
    rintro (⟨i,j⟩|⟨⟩),
    { refine (finset.univ : finset (fin n)).sum _, intro k,
      exact tmul K (X $ inl ⟨i, k⟩) (X $ inl ⟨k, j⟩) },
    { exact tmul K (X $ inr ⟨⟩) (X $ inr ⟨⟩) }
  end
 omitted
end

/-- The `(i,j)`-minor is the polynomial that is obtained by taking the formula for the determinant,
  but skipping row `i` and column `j`. -/
def minor (i j : fin n) : GL_aux1 K n :=
begin
  cases n with n, apply fin_zero_elim i,
  exact rename (sum.map (prod.map (fin.succ_above i) (fin.succ_above j)) id) (det K n)
end

/-- The (opposite of the) inversion on `GL(n)`. The inverse sends `xᵢⱼ` to
  `(-1) ^ (i + j)` times the transpose of the `(i,j)`-minor. It sends `x₀` to `det(xᵢⱼ)` -/
def GL_inv_op : GL_op K n ⟶ GL_op K n :=
algebra.quotient.functor
  begin
    refine aeval₂ _,
    rintro (⟨i,j⟩|⟨⟩),
    { exact (-1) ^ (i.val + j.val) * minor j i },
    { exact det K n }
  end
 omitted

/-- The (opposite of the) unit in `GL(n)` -/
def GL_one_op : GL_op K n ⟶ FRAlgebra_id K :=
algebra.quotient.lift
  begin
    refine aeval₂ _,
    rintro (⟨i,j⟩|⟨⟩),
    { exact if i = j then 1 else 0 },
    { exact 1 }
  end
 omitted

variable (K)
/-- The general linear group as an affine group -/
def GL (n : ℕ) : affine_group K :=
{ obj := GL_var K n,
  mul := GL_mul_op.op,
  mul_assoc := omitted,
  one := GL_one_op.op,
  one_mul := omitted,
  mul_one := omitted,
  inv := GL_inv_op.op,
  mul_left_inv := omitted }

/-- A torus is an `r`-fold product of `GL(1)` -/
def torus (r : ℕ) : affine_group K := category.pow (GL K 1) r

/-- The multiplicative affine group is `torus K 1` -/
@[reducible] def Gm : affine_group K := torus K 1

variable {K}

/- The map `n ↦ X ^ n`. It sends `(-n)` to `(X⁻¹)^n` for a natural number n -/
def X_pow : ℤ → (unop (Gm K).1).β
| (int.of_nat n) := ideal.quotient.mk _ (monomial (single (inl ⟨0, 0⟩) n) 1)
| -[1+n]         := ideal.quotient.mk _ (monomial (single (inr ⟨⟩) (n+1)) 1)

/-- Every group morphism `Gm ⟶ Gm` sends the variable `X` to `X^n` for some integer `n`. -/
def deg_aux (ϕ : Gm K ⟶ Gm K) :
  ∃!(n : ℤ), ϕ.map.unop.to_fun (ideal.quotient.mk _ $ X $ inl ⟨0, 0⟩) = X_pow n :=
omitted

/-- The degree of a group morphism `Gm K ⟶ Gm K` is the unique number `n` such that it sends
`X` to `X^n` -/
def deg (ϕ : Gm K ⟶ Gm K) : ℤ :=
classical.the _ (deg_aux ϕ)

instance torus1.is_abelian : (Gm K).is_abelian := omitted

lemma nonzero_determinant (p : (GL_var K n).type) :
  p.to_fun (ideal.quotient.mk _ (det K n)) ≠ (0 : K) :=
omitted

/-- The torus is an abelian group -/
instance is_abelian_torus (r : ℕ) : (torus K r).is_abelian := omitted

variable {G : affine_group K}

/-- A maximal torus is a closed subgroup of `G` that is isomorphic to `torus K r`
  with `r` maximal. -/
class is_maximal_torus (T : set G.obj.type) extends is_closed_subgroup T : Prop :=
(max_torus : ∃(n : ℕ), nonempty (sub T ≅ torus K n) ∧
  is_maximal { m : ℕ | ∃(s : set G.obj.type) (h : is_closed_subgroup s),
  by exactI nonempty (sub s ≅ torus K m) } n)

def is_maximal_torus.elim {T : set G.obj.type} (h₂ : is_maximal_torus T) :=
is_maximal_torus.max_torus T

instance is_maximal_torus.is_abelian (T : set G.obj.type) [is_maximal_torus T] :
  (sub T).is_abelian := omitted

/- The rank of a maximal torus -/
def is_maximal_torus.rank (T : set G.obj.type) [h : is_maximal_torus T] : ℕ :=
classical.take_arbitrary_such_that (λ n, n) h.elim omitted

/-- Every group has a maximal torus -/
lemma has_maximal_torus (G : affine_group K) : ∃(T : set G.obj.type), is_maximal_torus T :=
omitted

/-- The rank of `G` is the number `n` such that `T ≅ torus n`
  where `T` is any maximal torus of `G`. -/
def rank (G : affine_group K) : ℕ :=
classical.take_arbitrary (λ ⟨T, hT⟩, by exactI is_maximal_torus.rank T :
  { T : set (G.obj.type) // is_maximal_torus T} → ℕ)
  (subtype.nonempty $ has_maximal_torus G) omitted

/-- The character group `X^*(T)` of `T` consists of group morphisms into `Gm K` -/
@[reducible] def character_group (T : set G.obj.type) [is_closed_subgroup T] : Type* :=
sub T ⟶ Gm K

/-- The character group froms an abelian group -/
example (T : set G.obj.type) [is_closed_subgroup T] : comm_group (character_group T) :=
infer_instance

open category_theory.instances
/-- The character group is a free group on `rank G` variables -/
lemma free_character_group (T : set G.obj.type) [is_maximal_torus T] :
  nonempty $ (mk_ob $ character_group T : Group) ≅
    mk_ob (multiplicative $ free_abelian_group $ ulift $ fin $ rank G) :=
omitted

/-- As a more concrete example, we give the underlying functions of the isomorphism between
 `Gm K ⟶ Gm K` and the free abelian group on a single generator -/
def hom_torus1 : (mk_ob $ (Gm K) ⟶ Gm K : Group) ≅
  mk_ob (multiplicative $ free_abelian_group punit) :=
{ hom := ⟨λ ϕ, free_abelian_group.of ⟨⟩ ^ deg ϕ, omitted⟩,
  inv := ⟨λ n, show additive $ Gm K ⟶ Gm K, from n.lift (λ x, 𝟙 _), omitted⟩,
  hom_inv_id' := omitted,
  inv_hom_id' := omitted }

/-- The cocharacter group `X_*(T)` of `T` consists of group morphisms from `Gm K` -/
@[reducible] def cocharacter_group (T : set G.obj.type) [is_closed_subgroup T] : Type* :=
Gm K ⟶ sub T

example (T : set G.obj.type) [is_maximal_torus T] : comm_group (cocharacter_group T) :=
infer_instance

/-- The cocharacter group is a free group on `rank G` variables -/
lemma free_cocharacter_group (T : set G.obj.type) [is_maximal_torus T] :
  nonempty $ (mk_ob $ cocharacter_group T : Group) ≅
    mk_ob (multiplicative $ free_abelian_group $ ulift $ fin $ rank G) :=
omitted

/-- There is a pairing between the character group and the cocharacter group of `T`. -/
def pair {T : set G.obj.type} [is_closed_subgroup T]
  (l : character_group T) (r : cocharacter_group T) : ℤ :=
deg $ r ≫ l

end GL
-- TODO: pair is nondegenerate and bilinear

variables (K)
namespace Ga
open polynomial GL
/-- The underlying affine variety of the additive affine group is the variety whose coordinate ring
  is `K[x]` -/
def Ga_var : affine_variety K :=
op $ FRAlgebra_polynomial K

variables {K}
/-- The (opposite of the) multiplication on `Ga`. It sends `x` to `x ⊗ 1 + 1 ⊗ x` -/
def Ga_mul_op :
  FRAlgebra_polynomial K ⟶ FRAlgebra_tensor (FRAlgebra_polynomial K) (FRAlgebra_polynomial K) :=
aeval _ _ $ tmul K X 1 + tmul K 1 X

/-- The (opposite of the) inversion on `Ga`. It sends `x` to `-x` -/
def Ga_inv_op : FRAlgebra_polynomial K ⟶ FRAlgebra_polynomial K :=
aeval _ _ $ -X

/-- The (opposite of the) unit in `Ga` -/
def Ga_one_op : FRAlgebra_polynomial K ⟶ FRAlgebra_id K :=
aeval _ _ 0

variables (K)
/-- The additive affine group -/
def Ga : affine_group K :=
{ obj := Ga_var K,
  mul := Ga_mul_op.op,
  mul_assoc := omitted,
  one := Ga_one_op.op,
  one_mul := omitted,
  mul_one := omitted,
  inv := Ga_inv_op.op,
  mul_left_inv := omitted }

local infix ` × `:60 := limits.binary_product
/-- The group `Gm` acts on `Ga`. -/
def mul_add_action : group_action (Gm K) (Ga K).obj :=
⟨(show FRAlgebra_polynomial K ⟶ FRAlgebra_tensor (GL_op K 1) (FRAlgebra_polynomial K),
  from aeval _ _ $ tmul _ (ideal.quotient.mk _ $ mv_polynomial.X $ inl $ ⟨0, 0⟩) X).op,
  omitted, omitted⟩

end Ga
open GL Ga
variables {K}

variables {G : affine_group K} (B T : set G.obj.type) [is_closed_subgroup B] [is_maximal_torus T]

local infix ` × `:60 := limits.binary_product
local infix ` ×.map `:90 := binary_product.map

structure positive_root_space :=
(X : set G.obj.type)
(hX : is_closed_subgroup X)
(hXU : X ⊆ closed_derived_subgroup B)
(f : sub X ≅ Ga K)
(hTX : normalizes T X)

attribute [instance] positive_root_space.hX

variables {B T}
def is_positive_root (X : positive_root_space B T) (l : character_group T) : Prop :=
(conjugation_action X.hTX).map = l.map ×.map X.f.hom.map ≫ (mul_add_action K).map ≫ X.f.inv.map

-- def positive_root (X : positive_root_space B T) : Type* :=
-- { l : character_group T // is_positive_root X l }

lemma unique_positive_root (hG : almost_simple G) (hB : is_Borel_subgroup B) (hTB : T ⊆ B)
  (X : positive_root_space B T) : ∃!(l : character_group T), is_positive_root X l :=
omitted

variables (B T)
def Phi_plus : set (character_group T) :=
{ l : character_group T | ∃(X : positive_root_space B T), is_positive_root X l }

notation `Φ⁺` := Phi_plus

lemma finite_Phi_plus (hG : almost_simple G) (hB : is_Borel_subgroup B) (hTB : T ⊆ B) :
  set.finite (Φ⁺ B T) := omitted

variables {B T}
variables (α : character_group T)
local notation `M'` := closed_derived_subgroup $ centralizer $ kernel $ α

lemma almost_simple_M' (hG : almost_simple G) (hB : is_Borel_subgroup B) (hTB : T ⊆ B)
  (hα : α ∈ Φ⁺ B T) : almost_simple $ sub M' :=
omitted

def is_positive_coroot (αv : cocharacter_group T) : Prop :=
∃(S : set (sub M').obj.type) (hS₁ : is_maximal_torus S),
  by exactI factors_through αv.map ((sub T).incl $ set_sub_incl S).map ∧ GL.pair α αv = 2

lemma unique_positive_coroot (hG : almost_simple G) (hB : is_Borel_subgroup B) (hTB : T ⊆ B)
  (hα : α ∈ Φ⁺ B T) : ∃!(αv : cocharacter_group T), is_positive_coroot α αv :=
omitted

variables (B T)
def positive_coroots : set (cocharacter_group T) :=
{ αv : cocharacter_group T | ∃(α ∈ Φ⁺ B T), is_positive_coroot α αv }

-- todo: move
def cone {α} [comm_monoid α] [decidable_eq α] (s : set α) : set α :=
{ x : α | ∃(t : finset α) (a : α → ℕ), ↑t ⊆ s ∧ t.prod (λ(y : α), y ^ a y) = x }

variables {B T}

section
local attribute [instance, priority 0] classical.prop_decidable
lemma unique_simple_roots (hG : almost_simple G) (hB : is_Borel_subgroup B) (hTB : T ⊆ B) :
  ∃!(Δ : set (character_group T)), Δ ⊆ Φ⁺ B T ∧ Φ⁺ B T ⊆ cone Δ :=
omitted
end

def simple_roots (hG : almost_simple G) (hB : is_Borel_subgroup B) (hTB : T ⊆ B) :
  set (character_group T) :=
classical.the _ $ unique_simple_roots hG hB hTB

end algebraic_geometry


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.eval
import Mathlib.algebra.algebra.tower
import Mathlib.PostPort

universes u z u_1 u_2 u_3 v

namespace Mathlib

/-!
# Theory of univariate polynomials

We show that `polynomial A` is an R-algebra when `A` is an R-algebra.
We promote `eval₂` to an algebra hom in `aeval`.
-/

namespace polynomial

/-- Note that this instance also provides `algebra R (polynomial R)`. -/
protected instance algebra_of_algebra {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] : algebra R (polynomial A) :=
  add_monoid_algebra.algebra

theorem algebra_map_apply {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (r : R) : coe_fn (algebra_map R (polynomial A)) r = coe_fn C (coe_fn (algebra_map R A) r) :=
  rfl

/--
When we have `[comm_ring R]`, the function `C` is the same as `algebra_map R (polynomial R)`.

(But note that `C` is defined when `R` is not necessarily commutative, in which case
`algebra_map` is not available.)
-/
theorem C_eq_algebra_map {R : Type u_1} [comm_ring R] (r : R) : coe_fn C r = coe_fn (algebra_map R (polynomial R)) r :=
  rfl

@[simp] theorem alg_hom_eval₂_algebra_map {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [ring A] [ring B] [algebra R A] [algebra R B] (p : polynomial R) (f : alg_hom R A B) (a : A) : coe_fn f (eval₂ (algebra_map R A) a p) = eval₂ (algebra_map R B) (coe_fn f a) p := sorry

@[simp] theorem eval₂_algebra_map_X {R : Type u_1} {A : Type u_2} [comm_ring R] [ring A] [algebra R A] (p : polynomial R) (f : alg_hom R (polynomial R) A) : eval₂ (algebra_map R A) (coe_fn f X) p = coe_fn f p := sorry

@[simp] theorem ring_hom_eval₂_algebra_map_int {R : Type u_1} {S : Type u_2} [ring R] [ring S] (p : polynomial ℤ) (f : R →+* S) (r : R) : coe_fn f (eval₂ (algebra_map ℤ R) r p) = eval₂ (algebra_map ℤ S) (coe_fn f r) p :=
  alg_hom_eval₂_algebra_map p (ring_hom.to_int_alg_hom f) r

@[simp] theorem eval₂_algebra_map_int_X {R : Type u_1} [ring R] (p : polynomial ℤ) (f : polynomial ℤ →+* R) : eval₂ (algebra_map ℤ R) (coe_fn f X) p = coe_fn f p := sorry

-- Unfortunately `f.to_int_alg_hom` doesn't work here, as typeclasses don't match up correctly.

theorem eval₂_comp {R : Type u} {S : Type v} [comm_semiring R] {p : polynomial R} {q : polynomial R} [comm_semiring S] (f : R →+* S) {x : S} : eval₂ f x (comp p q) = eval₂ f (eval₂ f x q) p := sorry

theorem eval_comp {R : Type u} {a : R} [comm_semiring R] {p : polynomial R} {q : polynomial R} : eval a (comp p q) = eval (eval a q) p :=
  eval₂_comp (ring_hom.id R)

protected instance comp.is_semiring_hom {R : Type u} [comm_semiring R] {p : polynomial R} : is_semiring_hom fun (q : polynomial R) => comp q p :=
  eq.mpr
    (id
      ((fun (f f_1 : polynomial R → polynomial R) (e_3 : f = f_1) => congr_arg is_semiring_hom e_3)
        (fun (q : polynomial R) => comp q p) (fun (q : polynomial R) => eval₂ C p q)
        (funext fun (q : polynomial R) => comp.equations._eqn_1 q p)))
    (eval₂.is_semiring_hom C p)

/-- Given a valuation `x` of the variable in an `R`-algebra `A`, `aeval R A x` is
the unique `R`-algebra homomorphism from `R[X]` to `A` sending `X` to `x`. -/
def aeval {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (x : A) : alg_hom R (polynomial R) A :=
  alg_hom.mk (ring_hom.to_fun (eval₂_ring_hom' (algebra_map R A) x sorry)) sorry sorry sorry sorry sorry

theorem alg_hom_ext {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] {f : alg_hom R (polynomial R) A} {g : alg_hom R (polynomial R) A} (h : coe_fn f X = coe_fn g X) : f = g :=
  add_monoid_algebra.alg_hom_ext' (monoid_hom.ext_mnat h)

theorem aeval_def {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (x : A) (p : polynomial R) : coe_fn (aeval x) p = eval₂ (algebra_map R A) x p :=
  rfl

@[simp] theorem aeval_zero {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (x : A) : coe_fn (aeval x) 0 = 0 :=
  alg_hom.map_zero (aeval x)

@[simp] theorem aeval_X {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (x : A) : coe_fn (aeval x) X = x :=
  eval₂_X (algebra_map R A) x

@[simp] theorem aeval_C {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (x : A) (r : R) : coe_fn (aeval x) (coe_fn C r) = coe_fn (algebra_map R A) r :=
  eval₂_C (algebra_map R A) x

theorem aeval_monomial {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (x : A) {n : ℕ} {r : R} : coe_fn (aeval x) (coe_fn (monomial n) r) = coe_fn (algebra_map R A) r * x ^ n :=
  eval₂_monomial (algebra_map R A) x

@[simp] theorem aeval_X_pow {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (x : A) {n : ℕ} : coe_fn (aeval x) (X ^ n) = x ^ n :=
  eval₂_X_pow (algebra_map R A) x

@[simp] theorem aeval_add {R : Type u} {A : Type z} [comm_semiring R] {p : polynomial R} {q : polynomial R} [semiring A] [algebra R A] (x : A) : coe_fn (aeval x) (p + q) = coe_fn (aeval x) p + coe_fn (aeval x) q :=
  alg_hom.map_add (aeval x) p q

@[simp] theorem aeval_one {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (x : A) : coe_fn (aeval x) 1 = 1 :=
  alg_hom.map_one (aeval x)

@[simp] theorem aeval_bit0 {R : Type u} {A : Type z} [comm_semiring R] {p : polynomial R} [semiring A] [algebra R A] (x : A) : coe_fn (aeval x) (bit0 p) = bit0 (coe_fn (aeval x) p) :=
  alg_hom.map_bit0 (aeval x) p

@[simp] theorem aeval_bit1 {R : Type u} {A : Type z} [comm_semiring R] {p : polynomial R} [semiring A] [algebra R A] (x : A) : coe_fn (aeval x) (bit1 p) = bit1 (coe_fn (aeval x) p) :=
  alg_hom.map_bit1 (aeval x) p

@[simp] theorem aeval_nat_cast {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (x : A) (n : ℕ) : coe_fn (aeval x) ↑n = ↑n :=
  alg_hom.map_nat_cast (aeval x) n

theorem aeval_mul {R : Type u} {A : Type z} [comm_semiring R] {p : polynomial R} {q : polynomial R} [semiring A] [algebra R A] (x : A) : coe_fn (aeval x) (p * q) = coe_fn (aeval x) p * coe_fn (aeval x) q :=
  alg_hom.map_mul (aeval x) p q

theorem aeval_comp {R : Type u} [comm_semiring R] {p : polynomial R} {q : polynomial R} {A : Type u_1} [comm_semiring A] [algebra R A] (x : A) : coe_fn (aeval x) (comp p q) = coe_fn (aeval (coe_fn (aeval x) q)) p :=
  eval₂_comp (algebra_map R A)

@[simp] theorem aeval_map {R : Type u} [comm_semiring R] {B : Type u_1} [semiring B] [algebra R B] {A : Type u_2} [comm_semiring A] [algebra R A] [algebra A B] [is_scalar_tower R A B] (b : B) (p : polynomial R) : coe_fn (aeval b) (map (algebra_map R A) p) = coe_fn (aeval b) p := sorry

theorem eval_unique {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] (φ : alg_hom R (polynomial R) A) (p : polynomial R) : coe_fn φ p = eval₂ (algebra_map R A) (coe_fn φ X) p := sorry

theorem aeval_alg_hom {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] {B : Type u_1} [semiring B] [algebra R B] (f : alg_hom R A B) (x : A) : aeval (coe_fn f x) = alg_hom.comp f (aeval x) := sorry

theorem aeval_alg_hom_apply {R : Type u} {A : Type z} [comm_semiring R] [semiring A] [algebra R A] {B : Type u_1} [semiring B] [algebra R B] (f : alg_hom R A B) (x : A) (p : polynomial R) : coe_fn (aeval (coe_fn f x)) p = coe_fn f (coe_fn (aeval x) p) :=
  iff.mp alg_hom.ext_iff (aeval_alg_hom f x) p

@[simp] theorem coe_aeval_eq_eval {R : Type u} [comm_semiring R] (r : R) : ⇑(aeval r) = eval r :=
  rfl

theorem coeff_zero_eq_aeval_zero {R : Type u} [comm_semiring R] (p : polynomial R) : coeff p 0 = coe_fn (aeval 0) p := sorry

theorem pow_comp {R : Type u} [comm_semiring R] (p : polynomial R) (q : polynomial R) (k : ℕ) : comp (p ^ k) q = comp p q ^ k := sorry

theorem is_root_of_eval₂_map_eq_zero {R : Type u} {S : Type v} [comm_semiring R] {p : polynomial R} [comm_ring S] {f : R →+* S} (hf : function.injective ⇑f) {r : R} : eval₂ f (coe_fn f r) p = 0 → is_root p r := sorry

theorem is_root_of_aeval_algebra_map_eq_zero {R : Type u} {S : Type v} [comm_semiring R] [comm_ring S] [algebra R S] {p : polynomial R} (inj : function.injective ⇑(algebra_map R S)) {r : R} (hr : coe_fn (aeval (coe_fn (algebra_map R S) r)) p = 0) : is_root p r :=
  is_root_of_eval₂_map_eq_zero inj hr

theorem dvd_term_of_dvd_eval_of_dvd_terms {S : Type v} [comm_ring S] {z : S} {p : S} {f : polynomial S} (i : ℕ) (dvd_eval : p ∣ eval z f) (dvd_terms : ∀ (j : ℕ), j ≠ i → p ∣ coeff f j * z ^ j) : p ∣ coeff f i * z ^ i := sorry

theorem dvd_term_of_is_root_of_dvd_terms {S : Type v} [comm_ring S] {r : S} {p : S} {f : polynomial S} (i : ℕ) (hr : is_root f r) (h : ∀ (j : ℕ), j ≠ i → p ∣ coeff f j * r ^ j) : p ∣ coeff f i * r ^ i :=
  dvd_term_of_dvd_eval_of_dvd_terms i (Eq.symm hr ▸ dvd_zero p) h

theorem aeval_eq_sum_range {R : Type u} {S : Type v} [comm_semiring R] [comm_ring S] [algebra R S] {p : polynomial R} (x : S) : coe_fn (aeval x) p = finset.sum (finset.range (nat_degree p + 1)) fun (i : ℕ) => coeff p i • x ^ i := sorry

theorem aeval_eq_sum_range' {R : Type u} {S : Type v} [comm_semiring R] [comm_ring S] [algebra R S] {p : polynomial R} {n : ℕ} (hn : nat_degree p < n) (x : S) : coe_fn (aeval x) p = finset.sum (finset.range n) fun (i : ℕ) => coeff p i • x ^ i := sorry

/--
The evaluation map is not generally multiplicative when the coefficient ring is noncommutative,
but nevertheless any polynomial of the form `p * (X - monomial 0 r)` is sent to zero
when evaluated at `r`.

This is the key step in our proof of the Cayley-Hamilton theorem.
-/
theorem eval_mul_X_sub_C {R : Type u} [ring R] {p : polynomial R} (r : R) : eval r (p * (X - coe_fn C r)) = 0 := sorry

theorem not_is_unit_X_sub_C {R : Type u} [ring R] [nontrivial R] {r : R} : ¬is_unit (X - coe_fn C r) := sorry

theorem aeval_endomorphism {R : Type u} {M : Type u_1} [comm_ring R] [add_comm_group M] [module R M] (f : linear_map R M M) (v : M) (p : polynomial R) : coe_fn (coe_fn (aeval f) p) v = finsupp.sum p fun (n : ℕ) (b : R) => b • coe_fn (f ^ n) v := sorry


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.morphisms.basic
import topology.local_at_target

/-!
# Universally closed morphism

A morphism of schemes `f : X ⟶ Y` is universally closed if `X ×[Y] Y' ⟶ Y'` is a closed map
for all base change `Y' ⟶ Y`.

We show that being universally closed is local at the target, and is stable under compositions and
base changes.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universes v u

namespace algebraic_geometry

variables {X Y : Scheme.{u}} (f : X ⟶ Y)

open category_theory.morphism_property
open algebraic_geometry.morphism_property (topologically)

/--
A morphism of schemes `f : X ⟶ Y` is universally closed if the base change `X ×[Y] Y' ⟶ Y'`
along any morphism `Y' ⟶ Y` is (topologically) a closed map.
-/
@[mk_iff]
class universally_closed (f : X ⟶ Y) : Prop :=
(out : universally (topologically @is_closed_map) f)

lemma universally_closed_eq :
  @universally_closed = universally (topologically @is_closed_map) :=
begin
  ext X Y f, rw universally_closed_iff
end

lemma universally_closed_respects_iso :
  respects_iso @universally_closed :=
universally_closed_eq.symm ▸ universally_respects_iso (topologically @is_closed_map)

lemma universally_closed_stable_under_base_change :
  stable_under_base_change @universally_closed :=
universally_closed_eq.symm ▸ universally_stable_under_base_change (topologically @is_closed_map)

lemma universally_closed_stable_under_composition :
  stable_under_composition @universally_closed :=
begin
  rw universally_closed_eq,
  exact stable_under_composition.universally (λ X Y Z f g hf hg, is_closed_map.comp hg hf),
end

instance universally_closed_type_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [hf : universally_closed f] [hg : universally_closed g] :
  universally_closed (f ≫ g) :=
universally_closed_stable_under_composition f g hf hg

instance universally_closed_fst {X Y Z : Scheme} (f : X ⟶ Z) (g : Y ⟶ Z)
  [hg : universally_closed g] :
  universally_closed (pullback.fst : pullback f g ⟶ _) :=
universally_closed_stable_under_base_change.fst f g hg

instance universally_closed_snd {X Y Z : Scheme} (f : X ⟶ Z) (g : Y ⟶ Z)
  [hf : universally_closed f] :
  universally_closed (pullback.snd : pullback f g ⟶ _) :=
universally_closed_stable_under_base_change.snd f g hf

lemma morphism_restrict_base {X Y : Scheme} (f : X ⟶ Y) (U : opens Y.carrier) :
  ⇑(f ∣_ U).1.base = U.1.restrict_preimage f.1 :=
funext (λ x, subtype.ext $ morphism_restrict_base_coe f U x)

lemma universally_closed_is_local_at_target :
  property_is_local_at_target @universally_closed :=
begin
  rw universally_closed_eq,
  apply universally_is_local_at_target_of_morphism_restrict,
  { exact stable_under_composition.respects_iso (λ X Y Z f g hf hg, is_closed_map.comp hg hf)
      (λ X Y f, (Top.homeo_of_iso (Scheme.forget_to_Top.map_iso f)).is_closed_map) },
  { intros X Y f ι U hU H,
    simp_rw [topologically, morphism_restrict_base] at H,
    exact (is_closed_map_iff_is_closed_map_of_supr_eq_top hU).mpr H }
end

lemma universally_closed.open_cover_iff {X Y : Scheme.{u}} (f : X ⟶ Y)
  (𝒰 : Scheme.open_cover.{u} Y) :
  universally_closed f ↔
    (∀ i, universally_closed (pullback.snd : pullback f (𝒰.map i) ⟶ _)) :=
universally_closed_is_local_at_target.open_cover_iff f 𝒰

end algebraic_geometry


import Lean.Data.Parsec
import Aoc2022.Utils

open System Lean Parsec

namespace Day4

def input : FilePath := "/home/fred/lean/aoc2022/input_04"

/-
PART 1:
Space needs to be cleared before the last supplies can be unloaded from the ships, and so several Elves have been assigned the job of cleaning up sections of the camp. Every section has a unique ID number, and each Elf is assigned a range of section IDs.

However, as some of the Elves compare their section assignments with each other, they've noticed that many of the assignments overlap. To try to quickly find overlaps and reduce duplicated effort, the Elves pair up and make a big list of the section assignments for each pair (your puzzle input).

For example, consider the following list of section assignment pairs:

2-4,6-8
2-3,4-5
5-7,7-9
2-8,3-7
6-6,4-6
2-6,4-8

For the first few pairs, this list means:

    Within the first pair of Elves, the first Elf was assigned sections 2-4 (sections 2, 3, and 4), while the second Elf was assigned sections 6-8 (sections 6, 7, 8).
    The Elves in the second pair were each assigned two sections.
    The Elves in the third pair were each assigned three sections: one got sections 5, 6, and 7, while the other also got 7, plus 8 and 9.

This example list uses single-digit section IDs to make it easier to draw; your actual list might contain larger numbers. Visually, these pairs of section assignments look like this:

.234.....  2-4
.....678.  6-8

.23......  2-3
...45....  4-5

....567..  5-7
......789  7-9

.2345678.  2-8
..34567..  3-7

.....6...  6-6
...456...  4-6

.23456...  2-6
...45678.  4-8

Some of the pairs have noticed that one of their assignments fully contains the other. For example, 2-8 fully contains 3-7, and 6-6 is fully contained by 4-6. In pairs where one assignment fully contains the other, one Elf in the pair would be exclusively cleaning sections their partner will already be cleaning, so these seem like the most in need of reconsideration. In this example, there are 2 such pairs.

In how many assignment pairs does one range fully contain the other?
-/

def entryline : Parsec (Nat × Nat × Nat × Nat) := do
  let l₁ ← natNum
  skipChar '-'
  let r₁ ← natNum
  skipChar ','
  let l₂ ← natNum
  skipChar '-'
  let r₂ ← natNum
  return (l₁, r₁, l₂, r₂)

def fully_contains (l₁ r₁ l₂ r₂ : Nat) : Nat := Id.run do
  if l₁ ≤ l₂ ∧ r₁ ≥ r₂ then return 1
  if l₂ ≤ l₁ ∧ r₂ ≥ r₁ then return 1
  return 0

def first_part : IO Nat := do
  let rawdata ← IO.FS.lines input
  let f (n : Nat) (s : String) : Option Nat :=
    match entryline s.iter with
    | Parsec.ParseResult.success _ res =>
        let (l₁, r₁, l₂, r₂) := res
        some (n + fully_contains l₁ r₁ l₂ r₂)
    | Parsec.ParseResult.error _ _ => none
  let out := Array.foldlM f 0 rawdata
  match out with
  | some n => return n
  | none => return 0

/-
PART 2:
It seems like there is still quite a bit of duplicate work planned. Instead, the Elves would like to know the number of pairs that overlap at all.

In the above example, the first two pairs (2-4,6-8 and 2-3,4-5) don't overlap, while the remaining four pairs (5-7,7-9, 2-8,3-7, 6-6,4-6, and 2-6,4-8) do overlap:

    5-7,7-9 overlaps in a single section, 7.
    2-8,3-7 overlaps all of the sections 3 through 7.
    6-6,4-6 overlaps in a single section, 6.
    2-6,4-8 overlaps in sections 4, 5, and 6.

So, in this example, the number of overlapping assignment pairs is 4.

In how many assignment pairs do the ranges overlap?
-/

def overlaps (l₁ r₁ l₂ r₂ : Nat) : Nat := Id.run do
  if r₁ < l₂ then return 0
  if r₂ < l₁ then return 0
  return 1

def second_part : IO Nat := do
  let rawdata ← IO.FS.lines input
  let f (n : Nat) (s : String) : Option Nat :=
    match entryline s.iter with
    | Parsec.ParseResult.success _ res =>
        let (l₁, r₁, l₂, r₂) := res
        some (n + overlaps l₁ r₁ l₂ r₂)
    | Parsec.ParseResult.error _ _ => none
  let out := Array.foldlM f 0 rawdata
  match out with
  | some n => return n
  | none => return 0

end Day4


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.sites.sheaf

/-!

# The plus construction for presheaves.

This file contains the construction of `P⁺`, for a presheaf `P : Cᵒᵖ ⥤ D`
where `C` is endowed with a grothendieck topology `J`.

See https://stacks.math.columbia.edu/tag/00W1 for details.

-/

namespace category_theory.grothendieck_topology

open category_theory
open category_theory.limits
open opposite

universes w v u
variables {C : Type u} [category.{v} C] (J : grothendieck_topology C)
variables {D : Type w} [category.{max v u} D]

noncomputable theory

variables [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]
variables (P : Cᵒᵖ ⥤ D)

/-- The diagram whose colimit defines the values of `plus`. -/
@[simps]
def diagram (X : C) : (J.cover X)ᵒᵖ ⥤ D :=
{ obj := λ S, multiequalizer (S.unop.index P),
  map := λ S T f,
    multiequalizer.lift _ _ (λ I, multiequalizer.ι (S.unop.index P) (I.map f.unop)) $
      λ I, multiequalizer.condition (S.unop.index P) (I.map f.unop),
  map_id' := λ S, by { ext I, cases I, simpa },
  map_comp' := λ S T W f g, by { ext I, simpa } }

/-- A helper definition used to define the morphisms for `plus`. -/
@[simps]
def diagram_pullback {X Y : C} (f : X ⟶ Y) :
  J.diagram P Y ⟶ (J.pullback f).op ⋙ J.diagram P X :=
{ app := λ S, multiequalizer.lift _ _
    (λ I, multiequalizer.ι (S.unop.index P) I.base) $
      λ I, multiequalizer.condition (S.unop.index P) I.base,
  naturality' := λ S T f, by { ext, dsimp, simpa } }

/-- A natural transformation `P ⟶ Q` induces a natural transformation
between diagrams whose colimits define the values of `plus`. -/
@[simps]
def diagram_nat_trans {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (X : C) :
  J.diagram P X ⟶ J.diagram Q X :=
{ app := λ W, multiequalizer.lift _ _
    (λ i, multiequalizer.ι _ i ≫ η.app _) begin
      intros i,
      erw [category.assoc, category.assoc, ← η.naturality,
        ← η.naturality, ← category.assoc, ← category.assoc, multiequalizer.condition],
      refl,
    end,
  naturality' := λ _ _ _, by { dsimp, ext, simpa } }

@[simp]
lemma diagram_nat_trans_id (X : C) (P : Cᵒᵖ ⥤ D) :
  J.diagram_nat_trans (𝟙 P) X = 𝟙 (J.diagram P X) :=
begin
  ext,
  dsimp,
  simp only [multiequalizer.lift_ι, category.id_comp],
  erw category.comp_id
end

@[simp]
lemma diagram_nat_trans_comp {P Q R : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (γ : Q ⟶ R) (X : C) :
  J.diagram_nat_trans (η ≫ γ) X = J.diagram_nat_trans η X ≫ J.diagram_nat_trans γ X :=
by { ext, dsimp, simp }

variable [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]

/-- The plus construction, associating a presheaf to any presheaf.
See `plus_functor` below for a functorial version. -/
def plus_obj : Cᵒᵖ ⥤ D :=
{ obj := λ X, colimit (J.diagram P X.unop),
  map := λ X Y f, colim_map (J.diagram_pullback P f.unop) ≫ colimit.pre _ _,
  map_id' := begin
    intros X,
    ext S,
    dsimp,
    simp only [diagram_pullback_app, colimit.ι_pre,
      ι_colim_map_assoc, category.comp_id],
    let e := S.unop.pullback_id,
    dsimp only [functor.op, pullback_obj],
    erw [← colimit.w _ e.inv.op, ← category.assoc],
    convert category.id_comp _,
    ext I,
    dsimp,
    simp only [multiequalizer.lift_ι, category.id_comp, category.assoc],
    dsimp [cover.arrow.map, cover.arrow.base],
    cases I,
    congr,
    simp,
  end,
  map_comp' := begin
    intros X Y Z f g,
    ext S,
    dsimp,
    simp only [diagram_pullback_app, colimit.ι_pre_assoc,
      colimit.ι_pre, ι_colim_map_assoc, category.assoc],
    let e := S.unop.pullback_comp g.unop f.unop,
    dsimp only [functor.op, pullback_obj],
    erw [← colimit.w _ e.inv.op, ← category.assoc, ← category.assoc],
    congr' 1,
    ext I,
    dsimp,
    simp only [multiequalizer.lift_ι, category.assoc],
    cases I,
    dsimp only [cover.arrow.base, cover.arrow.map],
    congr' 2,
    simp,
  end }

/-- An auxiliary definition used in `plus` below. -/
def plus_map {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) : J.plus_obj P ⟶ J.plus_obj Q :=
{ app := λ X, colim_map (J.diagram_nat_trans η X.unop),
  naturality' := begin
    intros X Y f,
    dsimp [plus_obj],
    ext,
    simp only [diagram_pullback_app, ι_colim_map, colimit.ι_pre_assoc,
      colimit.ι_pre, ι_colim_map_assoc, category.assoc],
    simp_rw ← category.assoc,
    congr' 1,
    ext,
    dsimp,
    simpa,
  end }

@[simp]
lemma plus_map_id (P : Cᵒᵖ ⥤ D) : J.plus_map (𝟙 P) = 𝟙 _ :=
begin
  ext x : 2,
  dsimp only [plus_map, plus_obj],
  rw [J.diagram_nat_trans_id, nat_trans.id_app],
  ext,
  dsimp,
  simp,
end

@[simp]
lemma plus_map_comp {P Q R : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (γ : Q ⟶ R) :
  J.plus_map (η ≫ γ) = J.plus_map η ≫ J.plus_map γ :=
begin
  ext : 2,
  dsimp only [plus_map],
  rw J.diagram_nat_trans_comp,
  ext,
  dsimp,
  simp,
end

variable (D)

/-- The plus construction, a functor sending `P` to `J.plus_obj P`. -/
@[simps]
def plus_functor : (Cᵒᵖ ⥤ D) ⥤ Cᵒᵖ ⥤ D :=
{ obj := λ P, J.plus_obj P,
  map := λ P Q η, J.plus_map η,
  map_id' := λ _, plus_map_id _ _,
  map_comp' := λ _ _ _ _ _, plus_map_comp _ _ _ }

variable {D}

/-- The canonical map from `P` to `J.plus.obj P`.
See `to_plus` for a functorial version. -/
def to_plus : P ⟶ J.plus_obj P :=
{ app := λ X, cover.to_multiequalizer (⊤ : J.cover X.unop) P ≫
    colimit.ι (J.diagram P X.unop) (op ⊤),
  naturality' := begin
    intros X Y f,
    dsimp [plus_obj],
    delta cover.to_multiequalizer,
    simp only [diagram_pullback_app, colimit.ι_pre, ι_colim_map_assoc, category.assoc],
    dsimp only [functor.op, unop_op],
    let e : (J.pullback f.unop).obj ⊤ ⟶ ⊤ := hom_of_le (order_top.le_top _),
    rw [← colimit.w _ e.op, ← category.assoc, ← category.assoc, ← category.assoc],
    congr' 1,
    ext,
    dsimp,
    simp only [multiequalizer.lift_ι, category.assoc],
    dsimp [cover.arrow.base],
    simp,
  end }

@[simp, reassoc]
lemma to_plus_naturality {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) :
  η ≫ J.to_plus Q = J.to_plus _ ≫ J.plus_map η :=
begin
  ext,
  dsimp [to_plus, plus_map],
  delta cover.to_multiequalizer,
  simp only [ι_colim_map, category.assoc],
  simp_rw ← category.assoc,
  congr' 1,
  ext,
  dsimp,
  simp,
end

variable (D)

/-- The natural transformation from the identity functor to `plus`. -/
@[simps]
def to_plus_nat_trans : (𝟭 (Cᵒᵖ ⥤ D)) ⟶ J.plus_functor D :=
{ app := λ P, J.to_plus P,
  naturality' := λ _ _ _, to_plus_naturality _ _ }

variable {D}

/-- `(P ⟶ P⁺)⁺ = P⁺ ⟶ P⁺⁺` -/
@[simp]
lemma plus_map_to_plus : J.plus_map (J.to_plus P) = J.to_plus (J.plus_obj P) :=
begin
  ext X S,
  dsimp [to_plus, plus_obj, plus_map],
  delta cover.to_multiequalizer,
  simp only [ι_colim_map],
  let e : S.unop ⟶ ⊤ := hom_of_le (order_top.le_top _),
  simp_rw [← colimit.w _ e.op, ← category.assoc],
  congr' 1,
  ext I,
  dsimp,
  simp only [diagram_pullback_app, colimit.ι_pre, multiequalizer.lift_ι,
    ι_colim_map_assoc, category.assoc],
  dsimp only [functor.op],
  let ee : (J.pullback (I.map e).f).obj S.unop ⟶ ⊤ := hom_of_le (order_top.le_top _),
  simp_rw [← colimit.w _ ee.op, ← category.assoc],
  congr' 1,
  ext II,
  dsimp,
  simp only [limit.lift_π, multifork.of_ι_π_app, multiequalizer.lift_ι, category.assoc],
  dsimp [multifork.of_ι],
  convert multiequalizer.condition (S.unop.index P)
    ⟨_, _, _, II.f, 𝟙 _, I.f, II.f ≫ I.f, I.hf, sieve.downward_closed _ I.hf _, by simp⟩,
  { cases I, refl },
  { dsimp [cover.index],
    erw [P.map_id, category.comp_id],
    refl }
end

lemma is_iso_to_plus_of_is_sheaf (hP : presheaf.is_sheaf J P) : is_iso (J.to_plus P) :=
begin
  rw presheaf.is_sheaf_iff_multiequalizer at hP,
  resetI,
  suffices : ∀ X, is_iso ((J.to_plus P).app X),
  { resetI, apply nat_iso.is_iso_of_is_iso_app },
  intros X, dsimp,
  suffices : is_iso (colimit.ι (J.diagram P X.unop) (op ⊤)),
  { resetI, apply is_iso.comp_is_iso },
  suffices : ∀ (S T : (J.cover X.unop)ᵒᵖ) (f : S ⟶ T), is_iso ((J.diagram P X.unop).map f),
  { resetI, apply is_iso_ι_of_is_initial (initial_op_of_terminal is_terminal_top) },
  intros S T e,
  have : S.unop.to_multiequalizer P ≫ (J.diagram P (X.unop)).map e =
    T.unop.to_multiequalizer P, by { ext, dsimp, simpa },
  have : (J.diagram P (X.unop)).map e = inv (S.unop.to_multiequalizer P) ≫
    T.unop.to_multiequalizer P, by simp [← this],
  rw this, apply_instance,
end

/-- The natural isomorphism between `P` and `P⁺` when `P` is a sheaf. -/
def iso_to_plus (hP : presheaf.is_sheaf J P) : P ≅ J.plus_obj P :=
by letI := is_iso_to_plus_of_is_sheaf J P hP; exact as_iso (J.to_plus P)

@[simp]
lemma iso_to_plus_hom (hP : presheaf.is_sheaf J P) : (J.iso_to_plus P hP).hom = J.to_plus P := rfl

/-- Lift a morphism `P ⟶ Q` to `P⁺ ⟶ Q` when `Q` is a sheaf. -/
def plus_lift {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (hQ : presheaf.is_sheaf J Q) :
  J.plus_obj P ⟶ Q :=
J.plus_map η ≫ (J.iso_to_plus Q hQ).inv

@[simp, reassoc]
lemma to_plus_plus_lift {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (hQ : presheaf.is_sheaf J Q) :
  J.to_plus P ≫ J.plus_lift η hQ = η :=
begin
  dsimp [plus_lift],
  rw ← category.assoc,
  rw iso.comp_inv_eq,
  dsimp only [iso_to_plus, as_iso],
  rw to_plus_naturality,
end

lemma plus_lift_unique {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (hQ : presheaf.is_sheaf J Q)
  (γ : J.plus_obj P ⟶ Q) (hγ : J.to_plus P ≫ γ = η) : γ = J.plus_lift η hQ :=
begin
  dsimp only [plus_lift],
  rw [iso.eq_comp_inv, ← hγ, plus_map_comp],
  dsimp,
  simp,
end

lemma plus_hom_ext {P Q : Cᵒᵖ ⥤ D} (η γ : J.plus_obj P ⟶ Q) (hQ : presheaf.is_sheaf J Q)
  (h : J.to_plus P ≫ η = J.to_plus P ≫ γ) : η = γ :=
begin
  have : γ = J.plus_lift (J.to_plus P ≫ γ) hQ,
  { apply plus_lift_unique, refl },
  rw this,
  apply plus_lift_unique, exact h
end

@[simp]
lemma iso_to_plus_inv (hP : presheaf.is_sheaf J P) : (J.iso_to_plus P hP).inv =
  J.plus_lift (𝟙 _) hP :=
begin
  apply J.plus_lift_unique,
  rw [iso.comp_inv_eq, category.id_comp],
  refl,
end

@[simp]
lemma plus_map_plus_lift {P Q R : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (γ : Q ⟶ R) (hR : presheaf.is_sheaf J R) :
  J.plus_map η ≫ J.plus_lift γ hR = J.plus_lift (η ≫ γ) hR :=
begin
  apply J.plus_lift_unique,
  rw [← category.assoc, ← J.to_plus_naturality, category.assoc, J.to_plus_plus_lift],
end

end category_theory.grothendieck_topology


import algebraic_geometry.ringed_space
import algebra.module.basic
import tactic

/-

# Sheaves of modules

-/

-- This shoudl be elsewhere
namespace category_theory.Sheaf.hom

open category_theory

attribute [simps] category_theory.quiver.hom.has_zero

end category_theory.Sheaf.hom
/-

# Let's start by making the categories we're interested in.

-/

open algebraic_geometry topological_space

abbreviation RINGED_SPACE := RingedSpace.{0}

--#check RINGED_SPACE -- -- Type 1
-- this is a LARGE CATEGORY
-- this means: it doesn't have a set of objects
-- it has a "class" of objects
-- (topological space plus a sheaf of rings)
-- but all hom sets are sets

abbreviation TOP := Top.{0}
abbreviation AB := Ab.{0}

open category_theory

@[reducible]
def TOP.sheaf := Top.sheaf.{0}

-- TOP and AB are also large categories

section examples

-- Let X be a topological space equipped with a sheaf of rings
variable (X : RINGED_SPACE)

-- There is a forgetful functor from the category of
-- ringed spaces to the cat of top spaces

-- #check (X : TOP) -- ↑X : TOP
-- the up-arrow means "I just applied a map which mathematicians
-- don't usually mention"

-- Let U be an open subset of X

variables (U V : (opens (X : TOP))ᵒᵖ) (i : U ⟶ V) -- V ⊆ U

-- #check X.presheaf.obj U -- `CommRing`

--notation `𝓞_ ` X := λ (U : (opens (X : TOP))ᵒᵖ), X.presheaf.obj U
notation `𝓞_ ` X := X.to_PresheafedSpace.presheaf.obj

-- Now we can use notation (𝓞_ X) for the function which eats
-- an open set and spits out a commutative ring

-- O_X(U) is a commutative ring
example : comm_ring ((𝓞_ X) U) := infer_instance

-- the restriction homomorphism coming from the inclusion `i : V ⊆ U`
example : (𝓞_ X) U →+* (𝓞_ X) V := X.presheaf.map i

end examples

/-- Sheaf of modules for the structure sheaf of a ringed space. -/
structure SHEAF_OF_MODULES (X : RINGED_SPACE) :=
-- What is a sheaf of modules on a ringed space?
-- Firstly we'll need a sheaf of abelian groups
(ab_sheaf : TOP.sheaf AB X)
-- And secondly we need an action of the sheaf of rings
-- on the sheaf of abelian groups
(module_structure : ∀ (U : (opens (X : TOP))ᵒᵖ),
  module ((𝓞_ X) U) (ab_sheaf.val.obj U))
-- That says "ab_sheaf(U) has the structure of a module
-- for O_X(U) for all U"
(compatibility_bit : ∀ (U V : (opens (X : TOP))ᵒᵖ) (i : U ⟶ V)
  (r : (𝓞_ X) U) (m : ab_sheaf.val.obj U),
  (ab_sheaf.val.map i) (r • m) = (X.presheaf.map i r) • (ab_sheaf.val.map i) m)
-- This says that the module structure is compatible with all restriction morphisms
-- on O_X and on M (here called ab_sheaf).

--#check SHEAF_OF_MODULES.module_structure

-- What now?

-- We could make sheaves of modules into an abelian category
-- We could define pushforward and pullback of sheaves of modules
-- We could define tensor products of sheaves of modules
-- Everything needs doing and nobody ever did this before

/-

# Sheaves of modules are a category

-/

namespace SHEAF_OF_MODULES

variable {X : RINGED_SPACE}

def obj (𝓜 : SHEAF_OF_MODULES X) (U : (opens (X : TOP))ᵒᵖ) : AB := 𝓜.ab_sheaf.val.obj U

instance (𝓜 : SHEAF_OF_MODULES X) (U : (opens (X : TOP))ᵒᵖ) :
  module ((𝓞_ X) U) (𝓜.obj U) := 𝓜.module_structure U

@[ext]
structure hom (𝓜 𝓝 : SHEAF_OF_MODULES X) : Type := -- check it's a set!
-- morphism of underlying sheaf of abelian groups
(ab_sheaf : 𝓜.ab_sheaf ⟶ 𝓝.ab_sheaf)
(map_smul : ∀ (U : (opens (X : TOP))ᵒᵖ) (r : (𝓞_ X) U) (m : 𝓜.obj U),
  ab_sheaf.val.app U (r • m : 𝓜.obj U) = (r • (ab_sheaf.val.app U m) : 𝓝.obj U))

-- we have the objects and we have the morphisms so let's make a category!

namespace hom

-- set up the notational typeclass for hom
instance : quiver (SHEAF_OF_MODULES X) :=
{ hom := λ 𝓜 𝓝, hom 𝓜 𝓝 }

variables (𝓜 𝓝 : SHEAF_OF_MODULES X)

-- zero morphism between sheaves of modules
instance : has_zero (𝓜 ⟶ 𝓝) :=
{ zero :=
  { ab_sheaf := 0,
    map_smul := begin
      intros U r m,
      simp, -- added @[simps]
    end } }

@[reducible] def id (𝓜 : SHEAF_OF_MODULES X) : 𝓜 ⟶ 𝓜 :=
{ ab_sheaf := 𝟙 𝓜.ab_sheaf,
  map_smul := begin
    intros U r m,
    simp only [category_theory.Sheaf.category_theory.category_id_val,
 category_theory.id_apply,
 eq_self_iff_true,
 category_theory.nat_trans.id_app],
  end
   }

-- @[simp] lemma id_ab_sheaf {𝓜 : SHEAF_OF_MODULES X} :
--   (hom.id 𝓜 : 𝓜 ⟶ 𝓜).ab_sheaf = 𝟙 (𝓜.ab_sheaf) := rfl

@[reducible] def comp {𝓜 𝓝 𝓟 : SHEAF_OF_MODULES X}
  (φ : 𝓜 ⟶ 𝓝) (ψ : 𝓝 ⟶ 𝓟) : 𝓜 ⟶ 𝓟 :=
{ ab_sheaf := φ.ab_sheaf ≫ ψ.ab_sheaf,
  map_smul := begin
    intros,
    simp [φ.map_smul, ψ.map_smul],
  end }

-- don't need because comp reducible
-- @[simp] lemma comp_ab_sheaf {𝓜 𝓝 𝓟 : SHEAF_OF_MODULES X}
--   (φ : 𝓜 ⟶ 𝓝) (ψ : 𝓝 ⟶ 𝓟) : (comp φ ψ).ab_sheaf = φ.ab_sheaf ≫ ψ.ab_sheaf := rfl

end hom

instance : large_category (SHEAF_OF_MODULES X) :=
{ hom := hom,
  id := hom.id,
  comp := λ 𝓜 𝓝 𝓟, hom.comp,
  id_comp' := begin
    intros 𝓜 𝓝 φ,
    ext U m,
    simp only [category.id_comp],
  end,
  comp_id' := begin
    intros,
    ext,
    simp only [category.comp_id],
  end,
  assoc' := begin
    intros,
    ext,
    simp only [category.assoc],
  end }

-- #check 𝓜 ⟶ 𝓝

end SHEAF_OF_MODULES

/-

Possible future work: sheaves are an abelian category,
pushforward and pullback of sheaves of modules,
tensor product of sheaves of modules.
Construction of a sheaf of modules on Spec(R)
from a module over a ring
-/


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Johan Commelin, Scott Morrison
-/

import category_theory.limits.constructions.pullbacks
import category_theory.preadditive.biproducts
import category_theory.limits.shapes.images
import category_theory.limits.constructions.limits_of_products_and_equalizers
import category_theory.abelian.non_preadditive

/-!
# Abelian categories

This file contains the definition and basic properties of abelian categories.

There are many definitions of abelian category. Our definition is as follows:
A category is called abelian if it is preadditive,
has a finite products, kernels and cokernels,
and if every monomorphism and epimorphism is normal.

It should be noted that if we also assume coproducts, then preadditivity is
actually a consequence of the other properties, as we show in
`non_preadditive_abelian.lean`. However, this fact is of little practical
relevance, since essentially all interesting abelian categories come with a
preadditive structure. In this way, by requiring preadditivity, we allow the
user to pass in the "native" preadditive structure for the specific category they are
working with.

## Main definitions

* `abelian` is the type class indicating that a category is abelian. It extends `preadditive`.
* `abelian.image f` is `kernel (cokernel.π f)`, and
* `abelian.coimage f` is `cokernel (kernel.ι f)`.

## Main results

* In an abelian category, mono + epi = iso.
* If `f : X ⟶ Y`, then the map `factor_thru_image f : X ⟶ image f` is an epimorphism, and the map
  `factor_thru_coimage f : coimage f ⟶ Y` is a monomorphism.
* Factoring through the image and coimage is a strong epi-mono factorisation. This means that
  * every abelian category has images. We provide the isomorphism
    `image_iso_image : abelian.image f ≅ limits.image f`.
  * the canonical morphism `coimage_image_comparison : coimage f ⟶ image f`
    is an isomorphism.
* We provide the alternate characterisation of an abelian category as a category with
  (co)kernels and finite products, and in which the canonical coimage-image comparison morphism
  is always an isomorphism.
* Every epimorphism is a cokernel of its kernel. Every monomorphism is a kernel of its cokernel.
* The pullback of an epimorphism is an epimorphism. The pushout of a monomorphism is a monomorphism.
  (This is not to be confused with the fact that the pullback of a monomorphism is a monomorphism,
  which is true in any category).

## Implementation notes

The typeclass `abelian` does not extend `non_preadditive_abelian`,
to avoid having to deal with comparing the two `has_zero_morphisms` instances
(one from `preadditive` in `abelian`, and the other a field of `non_preadditive_abelian`).
As a consequence, at the beginning of this file we trivially build
a `non_preadditive_abelian` instance from an `abelian` instance,
and use this to restate a number of theorems,
in each case just reusing the proof from `non_preadditive_abelian.lean`.

We don't show this yet, but abelian categories are finitely complete and finitely cocomplete.
However, the limits we can construct at this level of generality will most likely be less nice than
the ones that can be created in specific applications. For this reason, we adopt the following
convention:

* If the statement of a theorem involves limits, the existence of these limits should be made an
  explicit typeclass parameter.
* If a limit only appears in a proof, but not in the statement of a theorem, the limit should not
  be a typeclass parameter, but instead be created using `abelian.has_pullbacks` or a similar
  definition.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]
* [P. Aluffi, *Algebra: Chapter 0*][aluffi2016]

-/

noncomputable theory

open category_theory
open category_theory.preadditive
open category_theory.limits

universes v u

namespace category_theory

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

variables (C)

/--
A (preadditive) category `C` is called abelian if it has all finite products,
all kernels and cokernels, and if every monomorphism is the kernel of some morphism
and every epimorphism is the cokernel of some morphism.

(This definition implies the existence of zero objects:
finite products give a terminal object, and in a preadditive category
any terminal object is a zero object.)
-/
class abelian extends preadditive C, normal_mono_category C, normal_epi_category C :=
[has_finite_products : has_finite_products C]
[has_kernels : has_kernels C]
[has_cokernels : has_cokernels C]

attribute [instance, priority 100] abelian.has_finite_products
attribute [instance, priority 100] abelian.has_kernels abelian.has_cokernels

end category_theory

open category_theory

/-!
We begin by providing an alternative constructor:
a preadditive category with kernels, cokernels, and finite products,
in which the coimage-image comparison morphism is always an isomorphism,
is an abelian category.
-/
namespace category_theory.abelian

variables {C : Type u} [category.{v} C] [preadditive C]
variables [limits.has_kernels C] [limits.has_cokernels C]

namespace of_coimage_image_comparison_is_iso

/-- The factorisation of a morphism through its abelian image. -/
@[simps]
def image_mono_factorisation {X Y : C} (f : X ⟶ Y) : mono_factorisation f :=
{ I := abelian.image f,
  m := kernel.ι _,
  m_mono := infer_instance,
  e := kernel.lift _ f (cokernel.condition _),
  fac' := kernel.lift_ι _ _ _ }

lemma image_mono_factorisation_e' {X Y : C} (f : X ⟶ Y) :
  (image_mono_factorisation f).e = cokernel.π _ ≫ abelian.coimage_image_comparison f :=
begin
  ext,
  simp only [abelian.coimage_image_comparison, image_mono_factorisation_e,
    category.assoc, cokernel.π_desc_assoc],
end

/-- If the coimage-image comparison morphism for a morphism `f` is an isomorphism,
we obtain an image factorisation of `f`. -/
def image_factorisation {X Y : C} (f : X ⟶ Y) [is_iso (abelian.coimage_image_comparison f)] :
  image_factorisation f :=
{ F := image_mono_factorisation f,
  is_image :=
  { lift := λ F, inv (abelian.coimage_image_comparison f) ≫ cokernel.desc _ F.e F.kernel_ι_comp,
    lift_fac' := λ F, begin
      simp only [image_mono_factorisation_m, is_iso.inv_comp_eq, category.assoc,
        abelian.coimage_image_comparison],
      ext,
      simp only [cokernel.π_desc_assoc, mono_factorisation.fac, image.fac],
    end } }

instance [has_zero_object C] {X Y : C} (f : X ⟶ Y) [mono f]
  [is_iso (abelian.coimage_image_comparison f)] :
  is_iso (image_mono_factorisation f).e :=
by { rw image_mono_factorisation_e', exact is_iso.comp_is_iso }

instance [has_zero_object C] {X Y : C} (f : X ⟶ Y) [epi f] :
  is_iso (image_mono_factorisation f).m :=
by { dsimp, apply_instance }

variables [∀ {X Y : C} (f : X ⟶ Y), is_iso (abelian.coimage_image_comparison f)]

/-- A category in which coimage-image comparisons are all isomorphisms has images. -/
lemma has_images : has_images C :=
{ has_image := λ X Y f,
  { exists_image := ⟨image_factorisation f⟩ } }

variables [limits.has_finite_products C]
local attribute [instance] limits.has_finite_biproducts.of_has_finite_products

/--
A category with finite products in which coimage-image comparisons are all isomorphisms
is a normal mono category.
-/
def normal_mono_category : normal_mono_category C :=
{ normal_mono_of_mono := λ X Y f m,
  { Z := _,
    g := cokernel.π f,
    w := by simp,
    is_limit := begin
      haveI : limits.has_images C := has_images,
      haveI : has_equalizers C := preadditive.has_equalizers_of_has_kernels,
      haveI : has_zero_object C := limits.has_zero_object_of_has_finite_biproducts _,
      have aux : _ := _,
      refine is_limit_aux _ (λ A, limit.lift _ _ ≫ inv (image_mono_factorisation f).e) aux _,
      { intros A g hg,
        rw [kernel_fork.ι_of_ι] at hg,
        rw [← cancel_mono f, hg, ← aux, kernel_fork.ι_of_ι], },
      { intro A,
        simp only [kernel_fork.ι_of_ι, category.assoc],
        convert limit.lift_π _ _ using 2,
        rw [is_iso.inv_comp_eq, eq_comm],
        exact (image_mono_factorisation f).fac, },
    end }, }

/--
A category with finite products in which coimage-image comparisons are all isomorphisms
is a normal epi category.
-/
def normal_epi_category : normal_epi_category C :=
{ normal_epi_of_epi := λ X Y f m,
  { W := kernel f,
    g := kernel.ι _,
    w := kernel.condition _,
    is_colimit := begin
      haveI : limits.has_images C := has_images,
      haveI : has_equalizers C := preadditive.has_equalizers_of_has_kernels,
      haveI : has_zero_object C := limits.has_zero_object_of_has_finite_biproducts _,
      have aux : _ := _,
      refine is_colimit_aux _
        (λ A, inv (image_mono_factorisation f).m ≫
          inv (abelian.coimage_image_comparison f) ≫ colimit.desc _ _)
        aux _,
      { intros A g hg,
        rw [cokernel_cofork.π_of_π] at hg,
        rw [← cancel_epi f, hg, ← aux, cokernel_cofork.π_of_π], },
      { intro A,
        simp only [cokernel_cofork.π_of_π, ← category.assoc],
        convert colimit.ι_desc _ _ using 2,
        rw [is_iso.comp_inv_eq, is_iso.comp_inv_eq, eq_comm, ←image_mono_factorisation_e'],
        exact (image_mono_factorisation f).fac, }
    end }, }

end of_coimage_image_comparison_is_iso

variables [∀ {X Y : C} (f : X ⟶ Y), is_iso (abelian.coimage_image_comparison f)]
  [limits.has_finite_products C]
local attribute [instance] of_coimage_image_comparison_is_iso.normal_mono_category
local attribute [instance] of_coimage_image_comparison_is_iso.normal_epi_category

/--
A preadditive category with kernels, cokernels, and finite products,
in which the coimage-image comparison morphism is always an isomorphism,
is an abelian category.

The Stacks project uses this characterisation at the definition of an abelian category.
See <https://stacks.math.columbia.edu/tag/0109>.
-/
def of_coimage_image_comparison_is_iso : abelian C := {}

end category_theory.abelian

namespace category_theory.abelian
variables {C : Type u} [category.{v} C] [abelian C]

/-- An abelian category has finite biproducts. -/
@[priority 100]
instance has_finite_biproducts : has_finite_biproducts C :=
limits.has_finite_biproducts.of_has_finite_products

@[priority 100]
instance has_binary_biproducts : has_binary_biproducts C :=
limits.has_binary_biproducts_of_finite_biproducts _

@[priority 100]
instance has_zero_object : has_zero_object C :=
has_zero_object_of_has_initial_object

section to_non_preadditive_abelian

/-- Every abelian category is, in particular, `non_preadditive_abelian`. -/
def non_preadditive_abelian : non_preadditive_abelian C := { ..‹abelian C› }

end to_non_preadditive_abelian

section
/-! We now promote some instances that were constructed using `non_preadditive_abelian`. -/

local attribute [instance] non_preadditive_abelian

variables {P Q : C} (f : P ⟶ Q)

/-- The map `p : P ⟶ image f` is an epimorphism -/
instance : epi (abelian.factor_thru_image f) := by apply_instance

instance is_iso_factor_thru_image [mono f] : is_iso (abelian.factor_thru_image f) :=
by apply_instance

/-- The canonical morphism `i : coimage f ⟶ Q` is a monomorphism -/
instance : mono (abelian.factor_thru_coimage f) := by apply_instance

instance is_iso_factor_thru_coimage [epi f] : is_iso (abelian.factor_thru_coimage f) :=
by apply_instance

end

section factor
local attribute [instance] non_preadditive_abelian

variables {P Q : C} (f : P ⟶ Q)

section

lemma mono_of_kernel_ι_eq_zero (h : kernel.ι f = 0) : mono f :=
mono_of_kernel_zero h

lemma epi_of_cokernel_π_eq_zero (h : cokernel.π f = 0) : epi f :=
begin
  apply normal_mono_category.epi_of_zero_cokernel _ (cokernel f),
  simp_rw ←h,
  exact is_colimit.of_iso_colimit (colimit.is_colimit (parallel_pair f 0)) (iso_of_π _)
end

end

section
variables {f}

lemma image_ι_comp_eq_zero {R : C} {g : Q ⟶ R} (h : f ≫ g = 0) : abelian.image.ι f ≫ g = 0 :=
zero_of_epi_comp (abelian.factor_thru_image f) $ by simp [h]

lemma comp_coimage_π_eq_zero {R : C} {g : Q ⟶ R} (h : f ≫ g = 0) : f ≫ abelian.coimage.π g = 0 :=
zero_of_comp_mono (abelian.factor_thru_coimage g) $ by simp [h]

end

/-- Factoring through the image is a strong epi-mono factorisation. -/
@[simps] def image_strong_epi_mono_factorisation : strong_epi_mono_factorisation f :=
{ I := abelian.image f,
  m := image.ι f,
  m_mono := by apply_instance,
  e := abelian.factor_thru_image f,
  e_strong_epi := strong_epi_of_epi _ }

/-- Factoring through the coimage is a strong epi-mono factorisation. -/
@[simps] def coimage_strong_epi_mono_factorisation : strong_epi_mono_factorisation f :=
{ I := abelian.coimage f,
  m := abelian.factor_thru_coimage f,
  m_mono := by apply_instance,
  e := coimage.π f,
  e_strong_epi := strong_epi_of_epi _ }

end factor

section has_strong_epi_mono_factorisations

/-- An abelian category has strong epi-mono factorisations. -/
@[priority 100] instance : has_strong_epi_mono_factorisations C :=
has_strong_epi_mono_factorisations.mk $ λ X Y f, image_strong_epi_mono_factorisation f

/- In particular, this means that it has well-behaved images. -/
example : has_images C := by apply_instance
example : has_image_maps C := by apply_instance

end has_strong_epi_mono_factorisations

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

/--
The coimage-image comparison morphism is always an isomorphism in an abelian category.
See `category_theory.abelian.of_coimage_image_comparison_is_iso` for the converse.
-/
instance : is_iso (coimage_image_comparison f) :=
begin
  convert is_iso.of_iso (is_image.iso_ext (coimage_strong_epi_mono_factorisation f).to_mono_is_image
    (image_strong_epi_mono_factorisation f).to_mono_is_image),
  ext,
  change _ = _ ≫ (image_strong_epi_mono_factorisation f).m,
  simp [-image_strong_epi_mono_factorisation_to_mono_factorisation_m]
end

/-- There is a canonical isomorphism between the abelian coimage and the abelian image of a
    morphism. -/
abbreviation coimage_iso_image : abelian.coimage f ≅ abelian.image f :=
as_iso (coimage_image_comparison f)

/-- There is a canonical isomorphism between the abelian coimage and the categorical image of a
    morphism. -/
abbreviation coimage_iso_image' : abelian.coimage f ≅ image f :=
is_image.iso_ext (coimage_strong_epi_mono_factorisation f).to_mono_is_image
  (image.is_image f)

lemma coimage_iso_image'_hom :
  (coimage_iso_image' f).hom = cokernel.desc _ (factor_thru_image f)
    (by simp [←cancel_mono (limits.image.ι f)]) :=
begin
  ext,
  simp only [←cancel_mono (limits.image.ι f), is_image.iso_ext_hom, cokernel.π_desc, category.assoc,
    is_image.lift_ι, coimage_strong_epi_mono_factorisation_to_mono_factorisation_m,
    limits.image.fac],
end

lemma factor_thru_image_comp_coimage_iso_image'_inv :
  factor_thru_image f ≫ (coimage_iso_image' f).inv = cokernel.π _ :=
by simp only [is_image.iso_ext_inv, image.is_image_lift, image.fac_lift,
  coimage_strong_epi_mono_factorisation_to_mono_factorisation_e]

/-- There is a canonical isomorphism between the abelian image and the categorical image of a
    morphism. -/
abbreviation image_iso_image : abelian.image f ≅ image f :=
is_image.iso_ext (image_strong_epi_mono_factorisation f).to_mono_is_image (image.is_image f)

lemma image_iso_image_hom_comp_image_ι :
  (image_iso_image f).hom ≫ limits.image.ι _ = kernel.ι _ :=
by simp only [is_image.iso_ext_hom, is_image.lift_ι,
  image_strong_epi_mono_factorisation_to_mono_factorisation_m]

lemma image_iso_image_inv :
  (image_iso_image f).inv = kernel.lift _ (limits.image.ι f)
    (by simp [←cancel_epi (factor_thru_image f)]) :=
begin
  ext,
  simp only [is_image.iso_ext_inv, image.is_image_lift, limits.image.fac_lift,
    image_strong_epi_mono_factorisation_to_mono_factorisation_e, category.assoc,
    kernel.lift_ι, limits.image.fac],
end

end images

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

local attribute [instance] non_preadditive_abelian

/-- In an abelian category, an epi is the cokernel of its kernel. More precisely:
    If `f` is an epimorphism and `s` is some limit kernel cone on `f`, then `f` is a cokernel
    of `fork.ι s`. -/
def epi_is_cokernel_of_kernel [epi f] (s : fork f 0) (h : is_limit s) :
  is_colimit (cokernel_cofork.of_π f (kernel_fork.condition s)) :=
non_preadditive_abelian.epi_is_cokernel_of_kernel s h

/-- In an abelian category, a mono is the kernel of its cokernel. More precisely:
    If `f` is a monomorphism and `s` is some colimit cokernel cocone on `f`, then `f` is a kernel
    of `cofork.π s`. -/
def mono_is_kernel_of_cokernel [mono f] (s : cofork f 0) (h : is_colimit s) :
  is_limit (kernel_fork.of_ι f (cokernel_cofork.condition s)) :=
non_preadditive_abelian.mono_is_kernel_of_cokernel s h

variables (f)

/-- In an abelian category, any morphism that turns to zero when precomposed with the kernel of an
    epimorphism factors through that epimorphism. -/
def epi_desc [epi f] {T : C} (g : X ⟶ T) (hg : kernel.ι f ≫ g = 0) : Y ⟶ T :=
(epi_is_cokernel_of_kernel _ (limit.is_limit _)).desc (cokernel_cofork.of_π _ hg)

@[simp, reassoc]
lemma comp_epi_desc [epi f] {T : C} (g : X ⟶ T) (hg : kernel.ι f ≫ g = 0) :
  f ≫ epi_desc f g hg = g :=
(epi_is_cokernel_of_kernel _ (limit.is_limit _)).fac (cokernel_cofork.of_π _ hg)
  walking_parallel_pair.one

/-- In an abelian category, any morphism that turns to zero when postcomposed with the cokernel of a
    monomorphism factors through that monomorphism. -/
def mono_lift [mono f] {T : C} (g : T ⟶ Y) (hg : g ≫ cokernel.π f = 0) : T ⟶ X :=
(mono_is_kernel_of_cokernel _ (colimit.is_colimit _)).lift (kernel_fork.of_ι _ hg)

@[simp, reassoc]
lemma mono_lift_comp [mono f] {T : C} (g : T ⟶ Y) (hg : g ≫ cokernel.π f = 0) :
  mono_lift f g hg ≫ f = g :=
(mono_is_kernel_of_cokernel _ (colimit.is_colimit _)).fac (kernel_fork.of_ι _ hg)
  walking_parallel_pair.zero

end cokernel_of_kernel

section

@[priority 100]
instance has_equalizers : has_equalizers C :=
preadditive.has_equalizers_of_has_kernels

/-- Any abelian category has pullbacks -/
@[priority 100]
instance has_pullbacks : has_pullbacks C :=
has_pullbacks_of_has_binary_products_of_has_equalizers C

end

section

@[priority 100]
instance has_coequalizers : has_coequalizers C :=
preadditive.has_coequalizers_of_has_cokernels

/-- Any abelian category has pushouts -/
@[priority 100]
instance has_pushouts : has_pushouts C :=
has_pushouts_of_has_binary_coproducts_of_has_coequalizers C

@[priority 100]
instance has_finite_limits : has_finite_limits C :=
limits.has_finite_limits_of_has_equalizers_and_finite_products

@[priority 100]
instance has_finite_colimits : has_finite_colimits C :=
limits.has_finite_colimits_of_has_coequalizers_and_finite_coproducts

end

namespace pullback_to_biproduct_is_kernel
variables [limits.has_pullbacks C] {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)

/-! This section contains a slightly technical result about pullbacks and biproducts.
    We will need it in the proof that the pullback of an epimorphism is an epimorpism. -/

/-- The canonical map `pullback f g ⟶ X ⊞ Y` -/
abbreviation pullback_to_biproduct : pullback f g ⟶ X ⊞ Y :=
biprod.lift pullback.fst pullback.snd

/-- The canonical map `pullback f g ⟶ X ⊞ Y` induces a kernel cone on the map
    `biproduct X Y ⟶ Z` induced by `f` and `g`. A slightly more intuitive way to think of
    this may be that it induces an equalizer fork on the maps induced by `(f, 0)` and
    `(0, g)`. -/
abbreviation pullback_to_biproduct_fork : kernel_fork (biprod.desc f (-g)) :=
kernel_fork.of_ι (pullback_to_biproduct f g) $
by rw [biprod.lift_desc, comp_neg, pullback.condition, add_right_neg]

/-- The canonical map `pullback f g ⟶ X ⊞ Y` is a kernel of the map induced by
    `(f, -g)`. -/
def is_limit_pullback_to_biproduct : is_limit (pullback_to_biproduct_fork f g) :=
fork.is_limit.mk _
  (λ s, pullback.lift (fork.ι s ≫ biprod.fst) (fork.ι s ≫ biprod.snd) $
    sub_eq_zero.1 $ by rw [category.assoc, category.assoc, ←comp_sub, sub_eq_add_neg, ←comp_neg,
      ←biprod.desc_eq, kernel_fork.condition s])
  (λ s,
  begin
    ext; rw [fork.ι_of_ι, category.assoc],
    { rw [biprod.lift_fst, pullback.lift_fst] },
    { rw [biprod.lift_snd, pullback.lift_snd] }
  end)
  (λ s m h, by ext; simp [←h])

end pullback_to_biproduct_is_kernel

namespace biproduct_to_pushout_is_cokernel
variables [limits.has_pushouts C] {W X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z)

/-- The canonical map `Y ⊞ Z ⟶ pushout f g` -/
abbreviation biproduct_to_pushout : Y ⊞ Z ⟶ pushout f g :=
biprod.desc pushout.inl pushout.inr

/-- The canonical map `Y ⊞ Z ⟶ pushout f g` induces a cokernel cofork on the map
    `X ⟶ Y ⊞ Z` induced by `f` and `-g`. -/
abbreviation biproduct_to_pushout_cofork : cokernel_cofork (biprod.lift f (-g)) :=
cokernel_cofork.of_π (biproduct_to_pushout f g) $
by rw [biprod.lift_desc, neg_comp, pushout.condition, add_right_neg]

/-- The cofork induced by the canonical map `Y ⊞ Z ⟶ pushout f g` is in fact a colimit cokernel
    cofork. -/
def is_colimit_biproduct_to_pushout : is_colimit (biproduct_to_pushout_cofork f g) :=
cofork.is_colimit.mk _
  (λ s, pushout.desc (biprod.inl ≫ cofork.π s) (biprod.inr ≫ cofork.π s) $
    sub_eq_zero.1 $ by rw [←category.assoc, ←category.assoc, ←sub_comp, sub_eq_add_neg, ←neg_comp,
      ←biprod.lift_eq, cofork.condition s, zero_comp])
  (λ s, by ext; simp)
  (λ s m h, by ext; simp [←h] )

end biproduct_to_pushout_is_cokernel

section epi_pullback
variables [limits.has_pullbacks C] {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)

/-- In an abelian category, the pullback of an epimorphism is an epimorphism.
    Proof from [aluffi2016, IX.2.3], cf. [borceux-vol2, 1.7.6] -/
instance epi_pullback_of_epi_f [epi f] : epi (pullback.snd : pullback f g ⟶ Y) :=
-- It will suffice to consider some morphism e : Y ⟶ R such that
-- pullback.snd ≫ e = 0 and show that e = 0.
epi_of_cancel_zero _ $ λ R e h,
begin
  -- Consider the morphism u := (0, e) : X ⊞ Y⟶ R.
  let u := biprod.desc (0 : X ⟶ R) e,
  -- The composite pullback f g ⟶ X ⊞ Y ⟶ R is zero by assumption.
  have hu : pullback_to_biproduct_is_kernel.pullback_to_biproduct f g ≫ u = 0 := by simpa,
  -- pullback_to_biproduct f g is a kernel of (f, -g), so (f, -g) is a
  -- cokernel of pullback_to_biproduct f g
  have := epi_is_cokernel_of_kernel _
    (pullback_to_biproduct_is_kernel.is_limit_pullback_to_biproduct f g),
  -- We use this fact to obtain a factorization of u through (f, -g) via some d : Z ⟶ R.
  obtain ⟨d, hd⟩ := cokernel_cofork.is_colimit.desc' this u hu,
  change Z ⟶ R at d,
  change biprod.desc f (-g) ≫ d = u at hd,
  -- But then f ≫ d = 0:
  have : f ≫ d = 0, calc
    f ≫ d = (biprod.inl ≫ biprod.desc f (-g)) ≫ d : by rw biprod.inl_desc
    ... = biprod.inl ≫ u : by rw [category.assoc, hd]
    ... = 0 : biprod.inl_desc _ _,
  -- But f is an epimorphism, so d = 0...
  have : d = 0 := (cancel_epi f).1 (by simpa),
  -- ...or, in other words, e = 0.
  calc
    e = biprod.inr ≫ u : by rw biprod.inr_desc
    ... = biprod.inr ≫ biprod.desc f (-g) ≫ d : by rw ←hd
    ... = biprod.inr ≫ biprod.desc f (-g) ≫ 0 : by rw this
    ... = (biprod.inr ≫ biprod.desc f (-g)) ≫ 0 : by rw ←category.assoc
    ... = 0 : has_zero_morphisms.comp_zero _ _
end

/-- In an abelian category, the pullback of an epimorphism is an epimorphism. -/
instance epi_pullback_of_epi_g [epi g] : epi (pullback.fst : pullback f g ⟶ X) :=
-- It will suffice to consider some morphism e : X ⟶ R such that
-- pullback.fst ≫ e = 0 and show that e = 0.
epi_of_cancel_zero _ $ λ R e h,
begin
  -- Consider the morphism u := (e, 0) : X ⊞ Y ⟶ R.
  let u := biprod.desc e (0 : Y ⟶ R),
  -- The composite pullback f g ⟶ X ⊞ Y ⟶ R is zero by assumption.
  have hu : pullback_to_biproduct_is_kernel.pullback_to_biproduct f g ≫ u = 0 := by simpa,
  -- pullback_to_biproduct f g is a kernel of (f, -g), so (f, -g) is a
  -- cokernel of pullback_to_biproduct f g
  have := epi_is_cokernel_of_kernel _
    (pullback_to_biproduct_is_kernel.is_limit_pullback_to_biproduct f g),
  -- We use this fact to obtain a factorization of u through (f, -g) via some d : Z ⟶ R.
  obtain ⟨d, hd⟩ := cokernel_cofork.is_colimit.desc' this u hu,
  change Z ⟶ R at d,
  change biprod.desc f (-g) ≫ d = u at hd,
  -- But then (-g) ≫ d = 0:
  have : (-g) ≫ d = 0, calc
    (-g) ≫ d = (biprod.inr ≫ biprod.desc f (-g)) ≫ d : by rw biprod.inr_desc
    ... = biprod.inr ≫ u : by rw [category.assoc, hd]
    ... = 0 : biprod.inr_desc _ _,
  -- But g is an epimorphism, thus so is -g, so d = 0...
  have : d = 0 := (cancel_epi (-g)).1 (by simpa),
  -- ...or, in other words, e = 0.
  calc
    e = biprod.inl ≫ u : by rw biprod.inl_desc
    ... = biprod.inl ≫ biprod.desc f (-g) ≫ d : by rw ←hd
    ... = biprod.inl ≫ biprod.desc f (-g) ≫ 0 : by rw this
    ... = (biprod.inl ≫ biprod.desc f (-g)) ≫ 0 : by rw ←category.assoc
    ... = 0 : has_zero_morphisms.comp_zero _ _
end

lemma epi_snd_of_is_limit [epi f] {s : pullback_cone f g} (hs : is_limit s) : epi s.snd :=
begin
  convert epi_of_epi_fac (is_limit.cone_point_unique_up_to_iso_hom_comp (limit.is_limit _) hs _),
  { refl },
  { exact abelian.epi_pullback_of_epi_f _ _ }
end

lemma epi_fst_of_is_limit [epi g] {s : pullback_cone f g} (hs : is_limit s) : epi s.fst :=
begin
  convert epi_of_epi_fac (is_limit.cone_point_unique_up_to_iso_hom_comp (limit.is_limit _) hs _),
  { refl },
  { exact abelian.epi_pullback_of_epi_g _ _ }
end

/-- Suppose `f` and `g` are two morphisms with a common codomain and suppose we have written `g` as
    an epimorphism followed by a monomorphism. If `f` factors through the mono part of this
    factorization, then any pullback of `g` along `f` is an epimorphism. -/
lemma epi_fst_of_factor_thru_epi_mono_factorization
  (g₁ : Y ⟶ W) [epi g₁] (g₂ : W ⟶ Z) [mono g₂] (hg : g₁ ≫ g₂ = g) (f' : X ⟶ W) (hf : f' ≫ g₂ = f)
  (t : pullback_cone f g) (ht : is_limit t) : epi t.fst :=
by apply epi_fst_of_is_limit _ _ (pullback_cone.is_limit_of_factors f g g₂ f' g₁ hf hg t ht)

end epi_pullback

section mono_pushout
variables [limits.has_pushouts C] {W X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z)

instance mono_pushout_of_mono_f [mono f] : mono (pushout.inr : Z ⟶ pushout f g) :=
mono_of_cancel_zero _ $ λ R e h,
begin
  let u := biprod.lift (0 : R ⟶ Y) e,
  have hu : u ≫ biproduct_to_pushout_is_cokernel.biproduct_to_pushout f g = 0 := by simpa,
  have := mono_is_kernel_of_cokernel _
    (biproduct_to_pushout_is_cokernel.is_colimit_biproduct_to_pushout f g),
  obtain ⟨d, hd⟩ := kernel_fork.is_limit.lift' this u hu,
  change R ⟶ X at d,
  change d ≫ biprod.lift f (-g) = u at hd,
  have : d ≫ f = 0, calc
    d ≫ f = d ≫ biprod.lift f (-g) ≫ biprod.fst : by rw biprod.lift_fst
    ... = u ≫ biprod.fst : by rw [←category.assoc, hd]
    ... = 0 : biprod.lift_fst _ _,
  have : d = 0 := (cancel_mono f).1 (by simpa),
  calc
    e = u ≫ biprod.snd : by rw biprod.lift_snd
    ... = (d ≫ biprod.lift f (-g)) ≫ biprod.snd : by rw ←hd
    ... = (0 ≫ biprod.lift f (-g)) ≫ biprod.snd : by rw this
    ... = 0 ≫ biprod.lift f (-g) ≫ biprod.snd : by rw category.assoc
    ... = 0 : zero_comp
end

instance mono_pushout_of_mono_g [mono g] : mono (pushout.inl : Y ⟶ pushout f g) :=
mono_of_cancel_zero _ $ λ R e h,
begin
  let u := biprod.lift e (0 : R ⟶ Z),
  have hu : u ≫ biproduct_to_pushout_is_cokernel.biproduct_to_pushout f g = 0 := by simpa,
  have := mono_is_kernel_of_cokernel _
    (biproduct_to_pushout_is_cokernel.is_colimit_biproduct_to_pushout f g),
  obtain ⟨d, hd⟩ := kernel_fork.is_limit.lift' this u hu,
  change R ⟶ X at d,
  change d ≫ biprod.lift f (-g) = u at hd,
  have : d ≫ (-g) = 0, calc
    d ≫ (-g) = d ≫ biprod.lift f (-g) ≫ biprod.snd : by rw biprod.lift_snd
    ... = u ≫ biprod.snd : by rw [←category.assoc, hd]
    ... = 0 : biprod.lift_snd _ _,
  have : d = 0 := (cancel_mono (-g)).1 (by simpa),
  calc
    e = u ≫ biprod.fst : by rw biprod.lift_fst
    ... = (d ≫ biprod.lift f (-g)) ≫ biprod.fst : by rw ←hd
    ... = (0 ≫ biprod.lift f (-g)) ≫ biprod.fst : by rw this
    ... = 0 ≫ biprod.lift f (-g) ≫ biprod.fst : by rw category.assoc
    ... = 0 : zero_comp
end

lemma mono_inr_of_is_colimit [mono f] {s : pushout_cocone f g} (hs : is_colimit s) : mono s.inr :=
begin
  convert mono_of_mono_fac
    (is_colimit.comp_cocone_point_unique_up_to_iso_hom hs (colimit.is_colimit _) _),
  { refl },
  { exact abelian.mono_pushout_of_mono_f _ _ }
end

/-- Suppose `f` and `g` are two morphisms with a common domain and suppose we have written `g` as
    an epimorphism followed by a monomorphism. If `f` factors through the epi part of this
    factorization, then any pushout of `g` along `f` is a monomorphism. -/
lemma mono_inl_of_factor_thru_epi_mono_factorization (f : X ⟶ Y) (g : X ⟶ Z)
  (g₁ : X ⟶ W) [epi g₁] (g₂ : W ⟶ Z) [mono g₂] (hg : g₁ ≫ g₂ = g) (f' : W ⟶ Y) (hf : g₁ ≫ f' = f)
  (t : pushout_cocone f g) (ht : is_colimit t) : mono t.inl :=
by apply mono_inl_of_is_colimit _ _ (pushout_cocone.is_colimit_of_factors _ _ _ _ _ hf hg t ht)

end mono_pushout

end category_theory.abelian

namespace category_theory.non_preadditive_abelian

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

/-- Every non_preadditive_abelian category can be promoted to an abelian category. -/
def abelian : abelian C :=
{ has_finite_products := by apply_instance,
/- We need the `convert`s here because the instances we have are slightly different from the
   instances we need: `has_kernels` depends on an instance of `has_zero_morphisms`. In the
   case of `non_preadditive_abelian`, this instance is an explicit argument. However, in the case
   of `abelian`, the `has_zero_morphisms` instance is derived from `preadditive`. So we need to
   transform an instance of "has kernels with non_preadditive_abelian.has_zero_morphisms" to an
   instance of "has kernels with non_preadditive_abelian.preadditive.has_zero_morphisms". Luckily,
   we have a `subsingleton` instance for `has_zero_morphisms`, so `convert` can immediately close
   the goal it creates for the two instances of `has_zero_morphisms`, and the proof is complete. -/
  has_kernels := by convert (by apply_instance : limits.has_kernels C),
  has_cokernels := by convert (by apply_instance : limits.has_cokernels C),
  normal_mono_of_mono := by { introsI, convert normal_mono_of_mono f },
  normal_epi_of_epi := by { introsI, convert normal_epi_of_epi f },
  ..non_preadditive_abelian.preadditive }

end category_theory.non_preadditive_abelian


import pca

namespace pca

universe variable u
variables {α : Type u}
variables [pca α]

/- Minimum submodel of pca containing A -/
inductive submodel (A : set α) : set α
| rel {a} : a ∈ A → submodel a
| k : submodel k
| s : submodel s
| mul {a b c} : (↓a * ↓b) = ↓c → submodel a → submodel b → submodel c
notation `ℳ` := submodel
notation `ℳ₀` := submodel ∅

def recursive (A : set α) : set α := {x | x ∈ submodel A ∧ tot x}
notation `ℛ` := recursive
notation `ℛ₀` := recursive ∅

@[simp] lemma pr_in_univ (a : α) : a ∈ ℳ (@set.univ α) := submodel.rel (by simp)

lemma submodel_sbseq {A B : set α} (h : A ⊆ B) : ℳ A ⊆ ℳ B :=
begin
  intros x,
  assume hx : x ∈ ℳ A,
  induction hx,
  case submodel.rel : a ha
  { exact submodel.rel (h ha),},
  case submodel.k :
  { exact submodel.k, },
  case submodel.s :
  { exact submodel.s, },
  case submodel.mul : _ _ _ e _ _ iha ihb
  { exact submodel.mul e iha ihb, },
end

lemma pr0_subset {A : set α} {a : α} (ha : a ∈ (ℳ₀ : set α)) : a ∈ ℳ A :=
submodel_sbseq (by { simp, }) ha

lemma recuraive.k (A : set α) : k ∈ ℛ A := ⟨submodel.k, ktot⟩
lemma recuraive.s (A : set α) : s ∈ ℛ A := ⟨submodel.s, stot⟩

lemma submodel.const {A : set α} {a : α} : a ∈ (ℳ A : set α) → 𝚔 a ∈ (ℳ A : set α) :=
begin
  assume h : a ∈ ℳ A,
  have l0 : ↓k * ↓a = ↓𝚔 a, { simp, },
  show 𝚔 a ∈ ℳ A, from submodel.mul l0 submodel.k h,
end

lemma submodel.subst' {A : set α} {a : α} :
  a ∈ ℳ A → 𝚜' a ∈ ℳ A :=
begin
  assume h : a ∈ ℳ A,
  have l0 : ↓s * ↓a = ↓𝚜' a, { unfold subst', simp, },
  show 𝚜' a ∈ ℳ A, from submodel.mul l0 submodel.s h,
end

lemma submodel.subst {A : set α} {a b : α} :
  a ∈ ℳ A → b ∈ ℳ A → 𝚜 a b ∈ ℳ A :=
begin
  assume (ha : a ∈ ℳ A) (hb : b ∈ ℳ A),
  have l0 : 𝚜' a ∈ (ℳ A : set α), from submodel.subst' ha,
  have l1 : ↓𝚜' a * ↓b = ↓𝚜 a b, { unfold subst', simp, },
  show 𝚜 a b ∈ ℳ A, from submodel.mul l1 l0 hb,
end

@[simp] lemma submodel.i {A : set α} : i ∈ ℳ A := submodel.subst submodel.k submodel.k
@[simp] lemma recursive.i (A : set α) : i ∈ (ℛ A : set α) := ⟨submodel.i, itot⟩

inductive lambda (A : set α)
| var : ℕ → lambda
| com {a : α} : a ∈ ℳ A → lambda
| app : lambda → lambda → lambda
prefix `#`:max := lambda.var
prefix `&`:max := lambda.com

instance lambda_mul {A : set α} : has_mul (lambda A) := ⟨lambda.app⟩

def lam {A : set α} (n : ℕ) : lambda A → lambda A
| #m     := if n = m then &submodel.i else &submodel.k * #m
| &h     := &submodel.k * lambda.com h
| (l * m) := &submodel.s * (lam l) * (lam m)
notation `Λ`x`,` := lam x

def expr (A : set α): lambda A → option α
| #x := ↓k
| (@lambda.com _ _ _ e _) := ↓e
| (l * m) := (expr l) * (expr m)

lemma lambda_defined {A : set α} (n : ℕ) : ∀ (e : lambda A), defined (expr A (Λ n, e))
| #e := begin
    cases (eq.decidable n e),
    { simp[lam, expr, if_neg h], exact rfl, },
    { simp[lam, expr, if_pos h], exact rfl, },
  end
| (@lambda.com _ _ _ e _) := ktot e
| (l * m) := begin
    simp [lam, expr],
    let a := option.get (lambda_defined l),
    let b := option.get (lambda_defined m),
    have ha : expr A (Λ n, l) = ↓a, { simp },
    have hb : expr A (Λ n, m) = ↓b, { simp },
    rw [ha, hb],
    exact s_defined a b
  end

notation n` →[`A`] `l := option.get (@lambda_defined _ _ A n l)
notation n` →∅ `l := n →[∅] l
notation n` →u `l := n →[set.univ] l

lemma lambda_pr {A : set α} :
  ∀ {e : lambda A} (h : defined (expr A e) = tt), option.get h ∈ ℳ A
| #_ _ := submodel.k
| &p _ := p
| (l * m) h := begin
    have ld : defined (expr A l) = tt, from str_l h,
    have md : defined (expr A m) = tt, from str_r h,
    have lpr : option.get ld ∈ ℳ A, from lambda_pr ld,
    have mpr : option.get md ∈ ℳ A, from lambda_pr md,
    have e : ↓option.get ld * ↓option.get md = ↓option.get h, { simp [expr], },
    show option.get h ∈ ℳ A, from submodel.mul e lpr mpr,
  end

@[simp] lemma lambda_pr0 {A : set α} (n : ℕ) (e : lambda A) : (n →[A] e) ∈ ℳ A := lambda_pr _

namespace recursion

def d : α := 0 →∅ (Λ 1, (#0 * #0 * #1))
def dpr : d ∈ (ℳ₀ : set α) := lambda_pr0 _ _

def v: α := 0 →∅ (Λ 1, (#0 * (&dpr * #1)))
def vpr : v ∈ (ℳ₀ : set α) := lambda_pr0 _ _

def n : α := 0 →∅ (&dpr * (&vpr * #0))
def npr : n ∈ (ℳ₀ : set α) := lambda_pr0 _ _

theorem recursion (f : α) : n ⬝ f ≃ ↓f * (n ⬝ f) :=
begin
  intros x,
  have diagonal : ∀ g, ↓d * ↓g * ↓x = ↓g * ↓g * ↓x, { simp [d, lam, expr], },
  let vf := (0 →u &(pr_in_univ f) * (&(pr_in_univ d) * #0)),
  have hv : ↓v * ↓f = ↓vf, { simp [v, lam, expr], },
  have nf_dvf : ↓n * ↓f = ↓d * ↓vf,  { simp [n, v, lam, expr], },
  calc
    n ⬝ f * ↓x = ↓n * ↓f * ↓x         : rfl
    ...        = ↓d * ↓vf * ↓x        : by rw nf_dvf
    ...        = ↓vf * ↓vf * ↓x       : diagonal vf
    ...        = ↓f * (↓d * ↓vf) * ↓x : by simp [lam, expr]
    ...        = ↓f * (↓n * ↓f) * ↓x  : by rw nf_dvf
end

theorem ntot : tot (n : α) := by { intros f, simp [n, d, v, lam, expr], refl, }

end recursion

def fixpoint : α := recursion.n
def recursion  (f x : α) : ↓fixpoint * ↓f * ↓x = f * (↓fixpoint * ↓f) * ↓x := recursion.recursion f x
def fixpoint_of (f : α) : α := option.get (recursion.ntot f)

lemma fixpoint_pr : fixpoint ∈ (ℳ₀ : set α) := recursion.npr
lemma fixpoint_re : fixpoint ∈ (ℛ₀ : set α) := ⟨fixpoint_pr, recursion.ntot⟩

namespace nontotal

theorem submodel_infinite [nontotal α] (A : set α) : (ℳ A).infinite :=
begin
  rintros ⟨⟨M, m⟩, h : ∀ x : ℳ A, x ∈ M⟩,
  let M' := {x | ∃ y : α, y ∈ ℳ A ∧ ↓k * ↓y = ↓x},
  have e : M' ⊆ ℳ A,
  { rintros x ⟨y, ⟨hy, exy⟩⟩, show x ∈ ℳ A, from submodel.mul exy submodel.k hy, },
  sorry
end

def nontotal_in (A : set α) : Prop := ∃ p q, (↓p * ↓q = none ∧ p ∈ ℳ A ∧ q ∈ ℳ A)

theorem nontot_iff_diff (A : set α) :
  (nontotal_in A) ↔ (∃ e, (e ∈ ℳ A ∧ ∀ x, (x ∈ ℳ A → ↓e * ↓x ≠ ↓x))) :=
begin
  split,
  { rintros ⟨p, ⟨q, ⟨epq, ⟨ppr, qpr⟩⟩⟩⟩,
    let e := (0 →[A] &ppr * &qpr),
    use e,
    split,
    { show e ∈ ℳ A, simp, },
    { show ∀ x, x ∈ ℳ A → ↓e * ↓x ≠ ↓x, simp[lam, expr, epq], }, },
  { rintros ⟨e, ⟨epr, h⟩⟩,
    let f := (0 →[A] &epr * (#0 * #0)),
    have fpr : f ∈ ℳ A, { simp, },
    have hf0 : ∀ g, ↓f * ↓g = ↓e * (↓g * ↓g), { intros g, simp[lam, expr], },
    have hf1 : ↓e * (↓f * ↓f) = ↓f * ↓f, { symmetry, exact hf0 _, },
    use f, use f,
    split,
    { cases ef : ↓f * ↓f,
      case none : { refl, },
      case some : v
      { exfalso,
        have vpr : v ∈ ℳ A, from submodel.mul ef fpr fpr,
        show false, from h v vpr (by { rw ← ef, exact hf1, }), }, },
    { exact ⟨fpr, fpr⟩, }, },
end

theorem nontotal_neg_totalin_or_neg_extin [nontotal α] (A : set α) :
  ¬total_in (ℳ A) ∨ ¬extensional_in (ℳ A) :=
begin
  apply not_and_distrib.mp,
  rintros ⟨h0 : total_in (ℳ A), h1 : extensional_in (ℳ A)⟩,
  have e0 : (𝚜' k : α) = 𝚔 i,
  { apply h1,
    { show 𝚜' k ∈ ℳ A, from submodel.subst' submodel.k, },
    { show 𝚔 i ∈ ℳ A, from submodel.const submodel.i, },
    { intros x xpr,
      simp,
      apply h1,
      { show 𝚜 k x ∈ ℳ A, from submodel.subst submodel.k xpr, },
      { show i ∈ ℳ A, from submodel.i, },
      intros y ypr,
      calc
        ↓𝚜 k x * ↓y = ↓𝚔 y * ↓option.get (h0 xpr ypr) : by simp
        ...         = ↓i * ↓y : by simp only [k_simp0, i_simp], }, },
  have e1 : ↓(𝚔 div1 : α) * (↓div0 * ↓div1) = ↓div1,
  { calc
      ↓(𝚔 div1 : α) * (↓div0 * ↓div1) = ↓𝚜' k * ↓div0 * ↓div1 : by simp
      ...                             = ↓𝚔 i * ↓div0 * ↓div1  : by rw e0
      ...                             = ↓div1                 : by simp, },
  have hd : defined (↓(𝚔 div1 : α) * (↓div0 * ↓div1)) = tt, { rw e1, refl, },
  have c0 : defined (↓div0 * ↓div1 : option α) = tt, from str_r hd,
  have c1 : defined (↓div0 * ↓div1 : option α) = ff, simp,
  show false, from bool_iff_false.mpr c1 c0
end

end nontotal

end pca


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.BoundedOrder
import order.category.Lattice
import order.category.Semilattice

/-!
# The category of bounded lattices

This file defines `BoundedLattice`, the category of bounded lattices.

In literature, this is sometimes called `Lat`, the category of lattices, because being a lattice is
understood to entail having a bottom and a top element.
-/

universes u

open category_theory

/-- The category of bounded lattices with bounded lattice morphisms. -/
structure BoundedLattice :=
(to_Lattice : Lattice)
[is_bounded_order : bounded_order to_Lattice]

namespace BoundedLattice

instance : has_coe_to_sort BoundedLattice Type* := ⟨λ X, X.to_Lattice⟩
instance (X : BoundedLattice) : lattice X := X.to_Lattice.str

attribute [instance] BoundedLattice.is_bounded_order

/-- Construct a bundled `BoundedLattice` from `lattice` + `bounded_order`. -/
def of (α : Type*) [lattice α] [bounded_order α] : BoundedLattice := ⟨⟨α⟩⟩

@[simp] lemma coe_of (α : Type*) [lattice α] [bounded_order α] : ↥(of α) = α := rfl

instance : inhabited BoundedLattice := ⟨of punit⟩

instance : large_category.{u} BoundedLattice :=
{ hom := λ X Y, bounded_lattice_hom X Y,
  id := λ X, bounded_lattice_hom.id X,
  comp := λ X Y Z f g, g.comp f,
  id_comp' := λ X Y, bounded_lattice_hom.comp_id,
  comp_id' := λ X Y, bounded_lattice_hom.id_comp,
  assoc' := λ W X Y Z _ _ _, bounded_lattice_hom.comp_assoc _ _ _ }

instance : concrete_category BoundedLattice :=
{ forget := ⟨coe_sort, λ X Y, coe_fn, λ X, rfl, λ X Y Z f g, rfl⟩,
  forget_faithful := ⟨λ X Y, by convert fun_like.coe_injective⟩ }

instance has_forget_to_BoundedOrder : has_forget₂ BoundedLattice BoundedOrder :=
{ forget₂ := { obj := λ X, BoundedOrder.of X,
               map := λ X Y, bounded_lattice_hom.to_bounded_order_hom } }

instance has_forget_to_Lattice : has_forget₂ BoundedLattice Lattice :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y, bounded_lattice_hom.to_lattice_hom } }

instance has_forget_to_SemilatticeSup : has_forget₂ BoundedLattice SemilatticeSup :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y, bounded_lattice_hom.to_sup_bot_hom } }

instance has_forget_to_SemilatticeInf : has_forget₂ BoundedLattice SemilatticeInf :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y, bounded_lattice_hom.to_inf_top_hom } }

@[simp] lemma coe_forget_to_BoundedOrder (X : BoundedLattice) :
  ↥((forget₂ BoundedLattice BoundedOrder).obj X) = ↥X := rfl

@[simp] lemma coe_forget_to_Lattice (X : BoundedLattice) :
  ↥((forget₂ BoundedLattice Lattice).obj X) = ↥X := rfl

@[simp] lemma coe_forget_to_SemilatticeSup (X : BoundedLattice) :
  ↥((forget₂ BoundedLattice SemilatticeSup).obj X) = ↥X := rfl

@[simp] lemma coe_forget_to_SemilatticeInf (X : BoundedLattice) :
  ↥((forget₂ BoundedLattice SemilatticeInf).obj X) = ↥X := rfl

lemma forget_Lattice_PartialOrder_eq_forget_BoundedOrder_PartialOrder :
  forget₂ BoundedLattice Lattice ⋙ forget₂ Lattice PartialOrder =
    forget₂ BoundedLattice BoundedOrder ⋙ forget₂ BoundedOrder PartialOrder := rfl

lemma forget_SemilatticeSup_PartialOrder_eq_forget_BoundedOrder_PartialOrder :
  forget₂ BoundedLattice SemilatticeSup ⋙ forget₂ SemilatticeSup PartialOrder =
    forget₂ BoundedLattice BoundedOrder ⋙ forget₂ BoundedOrder PartialOrder := rfl

lemma forget_SemilatticeInf_PartialOrder_eq_forget_BoundedOrder_PartialOrder :
  forget₂ BoundedLattice SemilatticeInf ⋙ forget₂ SemilatticeInf PartialOrder =
    forget₂ BoundedLattice BoundedOrder ⋙ forget₂ BoundedOrder PartialOrder := rfl

/-- Constructs an equivalence between bounded lattices from an order isomorphism
between them. -/
@[simps] def iso.mk {α β : BoundedLattice.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : BoundedLattice ⥤ BoundedLattice :=
{ obj := λ X, of (order_dual X), map := λ X Y, bounded_lattice_hom.dual }

/-- The equivalence between `BoundedLattice` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : BoundedLattice ≌ BoundedLattice :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end BoundedLattice

lemma BoundedLattice_dual_comp_forget_to_BoundedOrder :
  BoundedLattice.dual ⋙ forget₂ BoundedLattice BoundedOrder =
    forget₂ BoundedLattice BoundedOrder ⋙ BoundedOrder.dual := rfl

lemma BoundedLattice_dual_comp_forget_to_Lattice :
  BoundedLattice.dual ⋙ forget₂ BoundedLattice Lattice =
    forget₂ BoundedLattice Lattice ⋙ Lattice.dual := rfl

lemma BoundedLattice_dual_comp_forget_to_SemilatticeSup :
  BoundedLattice.dual ⋙ forget₂ BoundedLattice SemilatticeSup =
    forget₂ BoundedLattice SemilatticeInf ⋙ SemilatticeInf.dual := rfl

lemma BoundedLattice_dual_comp_forget_to_SemilatticeInf :
  BoundedLattice.dual ⋙ forget₂ BoundedLattice SemilatticeInf =
    forget₂ BoundedLattice SemilatticeSup ⋙ SemilatticeSup.dual := rfl