import tactic
import data.real.basic
-- import data.set
/-
- nom des variables dans la def de limite !
- variables muettes = variables globales : bof
- calcul avec abs : abs (l'-l) /2 >0 ??
(x ≠ 0 → |x| >0)
- ne pas ajouter l'inégalité au contexte si elle y est déjà !
- 'dsimp only at h' effectue les beta-réduction : (λ x, f x) 37 = f 37
- max : def et propriétés
- utiliser specialize ??

-/

-- dEAduction tactics
import structures2      -- hypo_analysis, targets_analysis
import utils            -- no_meta_vars
import user_notations   -- notations that can be used in deaduction UI for a new object
import compute
import push_neg_once    -- pushing negation just one step

-- dEAduction definitions
-- import set_definitions
import real_definitions

-- class real_number_subgroup (α : Type) :=
-- (subgroup : ((α = ℕ) ∨ (α = ℤ) ∨ (α = ℚ) ∨ (α = ℝ)) )

-- lemma real_number_subgroup_nat : (nat = ℕ) ∨ (nat = ℤ) ∨ (nat = ℚ) ∨ (nat = ℝ) :=
-- begin
--   left, refl,
-- end

-- instance : real_number_subgroup nat := ⟨real_number_subgroup_nat⟩

local attribute [instance] classical.prop_decidable

/-- `l` is the limit of the sequence `a` of reals -/
definition limit (u : ℕ → ℝ) (l : ℝ) : Prop :=
∀ ε > 0, ∃ N, ∀ n ≥ N, | u n - l | < ε

definition convergente (u : ℕ → ℝ) : Prop :=
∃ l, limit u l

definition limit_plus_infinity (u : ℕ → ℝ) : Prop :=
∀ M, ∃ N, ∀ n ≥ N, u n > M

definition bounded_sequence (u : ℕ → ℝ) : Prop :=
∃ M, ∀ n, | u n | ≤ M

definition even (n:ℕ) : Prop := ∃ n', n=2 * n'

definition limit_function (f : ℝ → ℝ) (a : ℝ) (l : ℝ) : Prop :=
∀ ε > 0, ∃ δ>0, ∀ x: ℝ, ( | x-a | < δ → | f x  - l | < ε )

definition continuous_at (f : ℝ → ℝ) (a : ℝ) : Prop :=
limit_function f a (f a)

definition continuous (f: ℝ → ℝ) : Prop :=
∀ a, continuous_at f a

section course
open tactic.interactive
-- notation `|` x `|` := abs x

-----------------
-- definitions --
-----------------
namespace definitions
/- dEAduction
PrettyName
  Définitions
-/

namespace generalites
/- dEAduction
PrettyName
  Généralités
-/

/-
abs_pos : 0 < |a| ↔ a ≠ 0
abs_mul x y : |x * y| = |x| * |y|
abs_add x y : |x + y| ≤ |x| + |y|
-/

/-
Max :
def
max ≥ n et n'
1) We will be using `max` a lot in this workshop. `max A B` is
the max of `A` and `B`. `max` is a definition, not a theorem, so
that means that there will be an API associated with it, i.e.
a list of little theorems which make `max` possible to use.
We just saw the two important theorems which we'll be using:
`le_max_left A B : A ≤ max A B` and
`le_max-right A B : B ≤ max A B`.
There are other cool functions in the `max` API, for example
`max_le : A ≤ C → B ≤ C → max A B ≤ C`. The easiest way to
find your way around the `max` API is to *guess* what the names
of the theorems are! For example what do you think
`max A B < C ↔ A < C ∧ B < C` is called?
-/

lemma definition.even (n:ℕ) : even n ↔ ∃ n', n = 2 * n'
:=
/- dEAduction
PrettyName
  Entier naturel pair
-/
begin
   refl
end

----------------------------------
namespace maximum
-- The name RealSubGroup will be replaced by ℝ in d∃∀duction,
-- but allows to treat the cases of integers or rationals.
variables {RealSubGroup : Type} [decidable_linear_order RealSubGroup]

lemma theorem.ppe_max_gauche :
∀ a b : RealSubGroup, a ≤ max a b :=
begin
  intros a b,
  norm_num, tautology,
  --exact le_max_left a b,
end

lemma theorem.ppe_max_droite :
∀ a b : RealSubGroup,  b ≤ max a b :=
begin
  have H := @theorem.ppe_max_gauche,
  intros a b, norm_num, tautology,
  -- exact le_max_right a b,
end

lemma theorem.max_ppe
(a b c : RealSubGroup) (Ha: a ≤ c) (Hb: b ≤ c) :
max a b ≤ c :=
begin
  norm_num, tautology,
  -- exact max_le Ha Hb,
end

lemma theorem.max_pp
(a b c : RealSubGroup) (Ha: a < c) (Hb: b < c) :
max a b < c :=
begin
  norm_num, tautology,
  -- exact max_lt Ha Hb,
end

end maximum

namespace valeur_absolue
variables {RealSubGroup : Type} [decidable_linear_ordered_comm_ring RealSubGroup]
-- [has_zero RealSubGroup]

-- A modifier : faire une classe "nombres" ?
lemma theorem.valeur_absolue
(x : RealSubGroup) :
((0:RealSubGroup) ≤ x) → (abs x = x) and ((x ≤ 0) → (abs x = -x)) :=
begin
  split, exact abs_of_nonneg, exact abs_of_nonpos,
end

lemma theorem.majoration_valeur_absolue
(x r : RealSubGroup) :
--(x : ℝ) (r : ℝ) :
(abs x < r) ↔ ((-r < x) ∧ (x < r))
:=
/- dEAduction
PrettyName
  Majoration d'une valeur absolue
-/
begin
  exact abs_lt
end

lemma theorem.inegalite_triangulaire
(x : RealSubGroup) (y : RealSubGroup) : |x + y| ≤ |x| + |y|
:=
/- dEAduction
PrettyName
  Inégalité triangulaire
-/
begin
  exact abs_add x y
end

lemma theorem.valeur_absolue_produit
(x : RealSubGroup) (y : RealSubGroup) : |x * y| = |x| * |y|
:=
/- dEAduction
PrettyName
  Valeur absolue d'un produit
-/
begin
  exact abs_mul x y
end

end valeur_absolue

end generalites
namespace suites

------------------------------
-- Définitions de la limite --
------------------------------

lemma definition.limit
{u : ℕ → ℝ} {l : ℝ} :
(limit u l) ↔
∀ ε > 0, ∃ N, ∀ n ≥ N, | u n - l | < ε
:=
/- dEAduction
PrettyName
  Limite d'une suite
ImplicitUse
  True
-/
begin
  refl
end

lemma definition.convergente
{u : ℕ → ℝ} :
(convergente u) ↔
∃ l, limit u l
:=
/- dEAduction
PrettyName
  Suite convergente
ImplicitUse
  True
-/
begin
  refl
end

lemma definition.limit_plus_infinity
{u : ℕ → ℝ} {l : ℝ} :
(limit_plus_infinity u) ↔
∀ M, ∃ N, ∀ n ≥ N, u n > M
:=
/- dEAduction
PrettyName
  Limite infinie d'une suite
ImplicitUse
  True
-/
begin
  refl
end

lemma definition.bounded
{u : ℕ → ℝ} :
(bounded_sequence u) ↔
∃ M, ∀ n, | u n | ≤ M
:=
/- dEAduction
PrettyName
  Suite bornée
ImplicitUse
  True
-/
begin
  refl
end

end suites

namespace fonctions

lemma definition.limit_function (f : ℝ → ℝ) (a : ℝ) (l : ℝ) :
limit_function f a l ↔
( ∀ ε > 0, ∃ δ>0, ∀ x: ℝ, ( | x-a | < δ → | f x  - l | < ε ) ):=
/- dEAduction
PrettyName
  Limite d'une fonction
ImplicitUse
  True
-/
begin
  refl
end

lemma definition.continuous_at (f : ℝ → ℝ) (a : ℝ) :
(continuous_at f a) ↔ (limit_function f a (f a)) :=
/- dEAduction
PrettyName
  Continuité en un point
ImplicitUse
  True
-/
begin
  refl
end

lemma definition.continuous (f: ℝ → ℝ) :
(continuous f) ↔ ∀ a, continuous_at f a :=
/- dEAduction
PrettyName
  Continuité
ImplicitUse
  True
-/
begin
  refl
end

end fonctions

end definitions

namespace tests

lemma exercise.test_compute
:
0 ≤ 1 ∧ 2+2 = 4
:=
begin
  todo
  -- split,
  -- have H : 1+1=2, rotate,
  -- compute_n 1,
  -- compute_n 1,
  -- todo
end

lemma exercise.test_compute_2
(a: ℝ) (H: a >0):
(a +1 > 1)
:=
begin
  todo
end

lemma exercise.test_compute_3
(a: ℝ) (H: 0 ≤ a) (H': a ≠ 0):
(a +1 > 1)
:=
begin
  todo
end

end tests

-----------------
--  exercices  --
-----------------
namespace exercices_suites
/- dEAduction
PrettyName
  Exercices sur les suites
-/

open definitions

--------------------------------------------------
namespace exemples

lemma exercise.ex_non_cv :
¬ (convergente (λ n, (-1)^n))
:=
/- dEAduction
PrettyName
  Un exemple de suite non convergente
-/
begin
  rw suites.definition.convergente, simp only [],
  todo
end

lemma exercise.ex_cv :
convergente (λ n, (1/n^2))
:=
/- dEAduction
PrettyName
  Un exemple de suite convergente
-/
begin
  todo
end

lemma exercise.ex_dv :
limit_plus_infinity (λ n, (real.sqrt (n+2)))
:=
/- dEAduction
PrettyName
  Un exemple de suite divergente
-/
begin
  todo
end

lemma exercise.limit_constante
(u : ℕ → ℝ) (c : ℝ) (H : ∀ n, u n = c) :
limit u c :=
/- dEAduction
PrettyName
  La limite d'une suite constante
-/
begin
--   rw definition.limit,
--   intros ε Hε,
--   use 0,
--   intros n H1,
--   rw H,
-- `[ solve1 {norm_num at * }, trace "EFFECTIVE CODE n°4.0"] <|> `[ `[ norm_num at *, trace "EFFECTIVE CODE n°5.0"] <|> `[ skip, trace "EFFECTIVE CODE n°5.1"], compute_n 10, trace "EFFECTIVE CODE n°4.1"],
  todo
end

end exemples

-------------------------------------------------
namespace premieres_proprietes
/- dEAduction
PrettyName
  Première propriétés
-/

lemma exercise.limite_unique
(u : ℕ → ℝ) (l : ℝ)(l' : ℝ) (H : limit u l) (H' : limit u l') :
l = l'
:=
/- dEAduction
PrettyName
  Unicité de la limite
-/
begin
  -- by_contradiction,
  -- wlog Hll': l < l',
  -- -- exact lt_or_gt_of_ne a,
  -- rotate,
  -- set ε := (l'-l)/2 with Heps,
  -- have Hpos: ε >0, rotate, -- by compute1,
  -- specialize H ε Hpos, rotate 2,
  -- rotate,

  -- cases H with N1,
  -- specialize H' ε Hpos, cases H' with N2,
  -- set n := max N1 N2 with Hn,
  -- have HnsuppN1: n ≥ N1, from le_max_left N1 N2,
  -- have ineq1 := H_h n HnsuppN1,
  -- have HnsuppN2: n ≥ N2, from le_max_right N1 N2,
  -- have ineq1 := H'_h n HnsuppN2,

  -- -- sorry,
  -- todo,
  -- todo,
  todo,
end

lemma exercise.def_alt
(u : ℕ → ℝ) (l : ℝ) :
(limit u l) ↔
∀ ε > 0, ∃ N, ∀ n ≥ N, | u n - l | ≤ ε
:=
/- dEAduction
PrettyName
  Définition alternative de la limite
-/
begin
  -- split,
  -- intro H1,
  -- intro ε, intro H2,
  -- rw limit at H1,
  -- have H3 := H1 ε H2,
  -- cases H3 with n H4,
  -- use n,
  -- intro n', intro H5,
  -- have H6 := H4 n' H5,
  -- -- solve1 {linarith},
  -- todo,
  todo,
end

lemma exercise.limit_infinity_alt
{u : ℕ → ℝ} {l : ℝ} :
(limit_plus_infinity u) ↔
∀ M>0, ∃ N, ∀ n ≥ N, u n > M
:=
/- dEAduction
PrettyName
  Définition alternative pour une limite infinie
-/
begin
  todo
end

end premieres_proprietes

namespace proprietes
/- dEAduction
PrettyName
  Propriétés
-/

lemma exercise.limite_somme
(u v: ℕ → ℝ) (l l' : ℝ) (H : limit u l)
(H' : limit v l') :
limit (λn, u n + v n) (l+l')
:=
/- dEAduction
PrettyName
  Limite d'une somme
-/
begin
--   rw definitions.definition.limit,
-- rw definitions.definition.limit at H H',
-- intro ε, intro H1,
-- have H2 := H _ H1,
-- have H3 := H' _ H1,
-- cases H2 with n H4,
-- cases H3 with n' H5,
-- let x2 := max n n', have H7 : x2 = max n n', refl,
-- have H9 := @definitions.maximum.theorem.ppe_max_gauche,
-- have H10 := H9 n n',
-- -- norm_num at H10,
-- rw H7 at H10,
  todo
  -- rw limit,
  -- intro ε, intro H1,
  -- rw limit at H H',
  -- have H2: ((ε/2):ℝ) > 0, rotate, have H3 := H (ε/2) H2, rotate 1, solve1 {linarith only [H1] }, rotate,
  -- have H4: ((ε/2):ℝ) > 0, rotate, have H5 := H' (ε/2) H4, rotate 1, solve1 {assumption}, rotate,
  -- cases H3 with n H6,
  -- cases H5 with n' H7,
  -- use max n n',
  -- intro n'', intro H8,
  -- have H9: (n'':ℕ) ≥ n, rotate, have H10 := H6 n'' H9, rotate 1, solve1 {norm_num at *, tautology }, rotate,
  -- have H11: (n'':ℕ) ≥ n', rotate, have H12 := H7 n'' H11, rotate 1, solve1 {norm_num at *, tautology }, rotate,

  -- rw generalites.valeur_absolue.theorem.majoration_valeur_absolue at H10 H12,
  -- rw generalites.valeur_absolue.theorem.majoration_valeur_absolue,
  -- cases H12 with Ha Hb, cases H10 with Hc Hd,
  -- split,
  -- linarith only [Ha, Hc],
  -- linarith only [Hb, Hc, Hd],
end

lemma exercise.limite_inegalites
(u v: ℕ → ℝ) (l l' : ℝ) (H : limit u l)
(H' : limit v l')
(H'' : ∀n, u n ≤ v n ) :
l ≤ l'
:=
/- dEAduction
PrettyName
  Passage à la limite dans une inégalité
-/
begin
  todo
  -- contrapose H'' with H1,
  -- push_neg,
  -- push_neg at H1,
  -- let e := (l-l')/2, have H2 : e = (l-l')/2, refl, no_meta_vars,
  -- rw limit at H H',
  -- have H3: (e:ℝ) > 0, rotate, have H4 := H e H3, rotate 1, rotate, rotate,
  -- solve1 {norm_num at *, apply mul_pos, linarith only [H1], apply inv_pos.mpr, linarith},
  -- have H5 := H' e H3,
  -- cases H4 with n H6,
  -- cases H5 with n' H7,
  -- let n'' := max n n', have H8 : n'' = max n n', refl, no_meta_vars,
  -- have H9: (n'':ℕ) ≥ n, rotate, have H10 := H6 n'' H9, rotate 1, solve1 {norm_num at *, tautology }, rotate,
  -- have H11: (n'':ℕ) ≥ n', rotate, have H12 := H7 n'' H11, rotate 1, solve1 {norm_num at *, tautology }, rotate,
  -- use n'',
  -- rw generalites.valeur_absolue.theorem.majoration_valeur_absolue at H10,
  -- cases H10 with H14 H15,
  -- rw generalites.valeur_absolue.theorem.majoration_valeur_absolue at H12,
  -- cases H12 with H17 H18,
  -- linarith only [H18, H14, H2],
end

lemma exercise.gendarmes
(u v w  : ℕ → ℝ) (l : ℝ)
(H : limit u l) (H' : limit w l)
(H'' : ∀n, (((u n) ≤ v n) and ((v n) ≤ w n))) :
limit v l
:=
/- dEAduction
PrettyName
  Théorème des gendarmes
-/
begin
  todo
end

-- Let's make a new definition.
definition is_bounded (a : ℕ → ℝ) := ∃ B, ∀ n, |a n| ≤ B

-- Now try this:
lemma tendsto_bounded_mul_zero {a : ℕ → ℝ} {b : ℕ → ℝ}
  (hA : is_bounded a) (hB : limit b 0)
  : limit (λ n, (a n) * (b n)) 0 :=
begin
  todo,
end

/-
A essayer : appliquer somme, CV implique borné, borné x 0
-/
lemma exercise.limite_produit
(u u': ℕ → ℝ) (l l' : ℝ) (H : limit u l)
(H' : limit u' l') :
limit (λn, (u n) * (u' n)) (l*l')
:=
/- dEAduction
PrettyName
  Limite d'un produit
-/
begin
  todo
end

end proprietes

end exercices_suites

namespace exercices_fonctions
/- dEAduction
PrettyName
  Exercices sur les fonctions
-/

open definitions

lemma exercise.image_convergente (u: ℕ → ℝ) (l : ℝ) (f: ℝ → ℝ)
(H: limit u l) (H': continuous f):
limit (λ n, f (u n)) (f l) :=
/- dEAduction
PrettyName
  Image d'une suite convergente
-/
begin
  todo
end

end exercices_fonctions

example (X: Type) (A: set X) (a:X) (P: X → Prop) : ∃ x ∈ A, P(x) :=
begin
  todo
end

end course


import GMLInit.Data.Basic
import GMLInit.Data.Ord
import GMLInit.Data.Nat
import GMLInit.Data.Int
import GMLInit.Logic.Ordering
import GMLInit.Logic.Relation

open Relation
open Ordering (lt eq gt)

def compareOfLE {α} [LE α] [DecidableRel (α:=α) (.≤.)] (x y : α) : Ordering :=
  if x ≤ y then if y ≤ x then eq else lt else gt

namespace compareOfLE
variable {α} [LE α] [DecidableRel (α:=α) (.≤.)]

theorem symm [Total (α:=α) (.≤.)] (x y : α) : (compareOfLE x y).swap = compareOfLE y x := by
  unfold compareOfLE
  by_cases x ≤ y, y ≤ x with
  | isTrue _, isTrue _ => split <;> rfl
  | isTrue _, isFalse _ => split <;> rfl
  | isFalse _, isTrue _ => split <;> rfl
  | isFalse _, isFalse _ =>
    cases Total.total (r:=(.≤.)) x y with
    | inl hxy => absurd hxy; assumption
    | inr hyx => absurd hyx; assumption

theorem le_trans [Transitive (α:=α) (.≤.)] {x y z : α} : compareOfLE x y ≠ gt → compareOfLE y z ≠ gt → compareOfLE x z ≠ gt := by
  unfold compareOfLE
  intro cxy cyz
  have : x ≤ y := by by_contradiction | assuming h => split at cxy <;> contradiction
  have : y ≤ z := by by_contradiction | assuming h => split at cyz <;> contradiction
  have : x ≤ z := by transitivity y <;> assumption
  split <;> split <;> (intro; contradiction)

theorem eq_strict [Antisymmetric (α:=α) (.≤.)] {x y : α} : compareOfLE x y = eq → x = y := by
  unfold compareOfLE
  intro cxy
  split at cxy
  next hxy =>
    split at cxy
    next hyx =>
      antisymmetry using (.≤.)
      · exact hxy
      · exact hyx
    next => contradiction
  next => contradiction

variable (α) [LE α] [DecidableRel (α:=α) (.≤.)]

scoped instance instOrd : Ord α := ⟨compareOfLE⟩

scoped instance instOrientedOrd [Total (α:=α) (.≤.)] : OrientedOrd α where
  symm := symm

scoped instance instTransOrd [Total (α:=α) (.≤.)] [Transitive (α:=α) (.≤.)] : TransOrd α where
  symm := symm
  le_trans := le_trans

scoped instance instLinearOrd [Total (α:=α) (.≤.)] [Transitive (α:=α) (.≤.)] [Antisymmetric (α:=α) (.≤.)] : LinearOrd α where
  symm := symm
  le_trans := le_trans
  eq_strict := eq_strict

end compareOfLE

def compareOfLT {α} [LT α] [DecidableRel (α:=α) (.<.)] (x y : α) : Ordering :=
  if x < y then lt else if y < x then gt else eq

namespace compareOfLT
variable {α} [inst : LT α] [DecidableRel (α:=α) (.<.)]

theorem symm [Asymmetric (α:=α) (.<.)] (x y : α) : (compareOfLT x y).swap = compareOfLT y x := by
  unfold compareOfLT
  split
  next hxy =>
    split
    next hyx  =>
      absurd hxy
      exact Asymmetric.asymm hyx
    next => rfl
  next =>
    split
    next => rfl
    next => rfl

theorem le_trans {x y z : α} [Transitive (α:=α) (.<.)] [Comparison (α:=α) (.<.)] : compareOfLT x y ≠ gt → compareOfLT y z ≠ gt → compareOfLT x z ≠ gt := by
  unfold compareOfLT
  intro cxy cyz
  split
  next => intro; contradiction
  next nxz =>
    split
    next hzx =>
      split at cxy
      next =>
        split at cyz
        next =>
          absurd nxz
          transitivity y
          · assumption
          · assumption
        next =>
          split at cyz
          next => contradiction
          next nzy =>
            absurd nzy
            transitivity x
            · assumption
            . assumption
      next =>
        split at cxy
        next => contradiction
        next nyx =>
          split at cyz
          next =>
            absurd nyx
            transitivity z
            · assumption
            . assumption
          next =>
            split at cyz
            next => contradiction
            next =>
              cases Comparison.compare hzx y with
              | inl _ => contradiction
              | inr _ => contradiction
    next => intro; contradiction

theorem eq_strict {x y : α} [StableEq α] [Connex (α:=α) (.<.)] : compareOfLT x y = eq → x = y := by
  unfold compareOfLT
  intro cxy
  split at cxy
  next => contradiction
  next =>
    split at cxy
    next => contradiction
    next =>
      by_contradiction
      | assuming hne =>
        cases Connex.connex (r:=(.<.)) hne with
        | inl _ => contradiction
        | inr _ => contradiction

variable (α) [LT α] [DecidableRel (α:=α) (.<.)]

scoped instance instOrd : Ord α := ⟨compareOfLT⟩

scoped instance instOrientedOrd [Asymmetric (α:=α) (.<.)] : OrientedOrd α where
  symm := symm

scoped instance instTransOrd [Asymmetric (α:=α) (.<.)] [Transitive (α:=α) (.<.)] [Comparison (α:=α) (.<.)] : TransOrd α where
  symm := symm
  le_trans := le_trans

scoped instance instLinearOrd [StableEq α] [Asymmetric (α:=α) (.<.)] [Transitive (α:=α) (.<.)] [Comparison (α:=α) (.<.)] [Connex (α:=α) (.<.)] : LinearOrd α where
  symm := symm
  le_trans := le_trans
  eq_strict := eq_strict

end compareOfLT

namespace compareOfLessAndEq
variable {α} [LT α] [DecidableRel (α:=α) (.<.)] [DecidableEq α]

theorem symm [Irreflexive (α:=α) (.<.)] [Transitive (α:=α) (.<.)] [Connex (α:=α) (.<.)] (x y : α) : (compareOfLessAndEq x y).swap = compareOfLessAndEq y x := by
  unfold compareOfLessAndEq
  split
  next hlt =>
    split
    next =>
      absurd Irreflexive.irrefl (r:=(.<.)) x
      transitivity y
      · assumption
      · assumption
    next =>
      split
      next heq =>
        absurd hlt
        rw [heq]
        exact Irreflexive.irrfl
      next => rfl
  next =>
    split
    next heq =>
      split
      next hlt =>
        absurd hlt
        rw [heq]
        exact Irreflexive.irrfl
      next =>
        split
        next => rfl
        next hne =>
          absurd hne
          symmetry
          assumption
    next hne =>
      split
      next => rfl
      next =>
        split
        next =>
          absurd hne
          symmetry
          assumption
        next =>
          cases Connex.connex (r:=(.<.)) hne with
          | inl _ => contradiction
          | inr _ => contradiction

theorem le_trans [Transitive (α:=α) (.<.)] [Connex (α:=α) (.<.)]  {x y z : α} : compareOfLessAndEq x y ≠ gt → compareOfLessAndEq y z ≠ gt → compareOfLessAndEq x z ≠ gt := by
  unfold compareOfLessAndEq
  intro cxy cyz
  split
  next => intro; contradiction
  next nxz =>
    split
    next => intro; contradiction
    next hne =>
      split at cxy
      next =>
        split at cyz
        next =>
          absurd nxz
          transitivity y
          · assumption
          · assumption
        next =>
          split at cyz
          next heq =>
            absurd nxz
            rw [←heq]
            assumption
          next => contradiction
      next =>
        split at cxy
        next heq =>
          split at cyz
          next =>
            absurd nxz
            rw [heq]
            assumption
          next =>
            split at cyz
            next =>
              absurd hne
              transitivity y
              · assumption
              · assumption
            next =>
              cases Connex.connex (r:=(.<.)) hne with
              | inl _ => contradiction
              | inr _ => contradiction
        next => contradiction

theorem eq_strict {x y : α} : compareOfLessAndEq x y = eq → x = y := by
  unfold compareOfLessAndEq
  intro cxy
  split at cxy
  next => contradiction
  next =>
    split at cxy
    next => assumption
    next => contradiction

variable (α) [LT α] [DecidableRel (α:=α) (.<.)] [DecidableEq α]

scoped instance instOrd : Ord α := ⟨fun x y => compareOfLessAndEq x y⟩

scoped instance instOrientedOrd [Irreflexive (α:=α) (.<.)] [Transitive (α:=α) (.<.)] [Connex (α:=α) (.<.)] : OrientedOrd α where
  symm := symm

scoped instance instTransOrd [Irreflexive (α:=α) (.<.)] [Transitive (α:=α) (.<.)] [Connex (α:=α) (.<.)] : TransOrd α where
  symm := symm
  le_trans := le_trans

scoped instance instLinearOrd [Irreflexive (α:=α) (.<.)] [Transitive (α:=α) (.<.)] [Connex (α:=α) (.<.)] : LinearOrd α where
  symm := symm
  le_trans := le_trans
  eq_strict := eq_strict

end compareOfLessAndEq


import group_theory.subgroup

namespace add_subgroup

variables {G : Type*} [add_group G]

instance sup_normal (N K : add_subgroup G) [hN : N.normal] [hK : K.normal] : normal (N ⊔ K) :=
⟨λ h (hh : h ∈ ↑(N ⊔ K)) g, show g + h + -g ∈ ↑(N ⊔ K), begin
  rw add_normal at *, rcases hh with ⟨n, k, hn, hk, rfl⟩,
  use [g + n + -g, g + k + -g, hN.conj_mem n hn g, hK.conj_mem k hk g],
  simp [add_assoc, sub_eq_add_neg],
end⟩

end add_subgroup

namespace subgroup

variables {G H K : Type*} [group G] [group H] [group K]

@[simp, to_additive]
lemma coe_inj {H : subgroup G} (x y : H) : (x : G) = y ↔ x = y := set_coe.ext_iff

@[simp, to_additive]
lemma range_subtype (H : subgroup G) : H.subtype.range = H :=
set_like.ext' $ H.subtype.coe_range.trans subtype.range_coe

variable (G)
@[to_additive]
def equiv_top : G ≃* (⊤ : subgroup G):=
{ to_fun := λ x, ⟨x, mem_top x⟩,
  inv_fun := λ x, x.val,
  left_inv := λ x, rfl,
  right_inv := λ x, subtype.ext_iff_val.mpr rfl,
  map_mul' := λ x y, rfl }

variable {G}
@[simp, to_additive]
lemma equiv_top_symm_apply : (equiv_top G).symm.to_monoid_hom = subgroup.subtype ⊤ :=
monoid_hom.ext $ λ x, rfl

@[to_additive]
instance sup_normal (N K : subgroup G) [hN : N.normal] [hK : K.normal] : normal (N ⊔ K) :=
⟨λ h (hh : h ∈ ↑(N ⊔ K)) g, show g * h * g⁻¹ ∈ ↑(N ⊔ K), begin
  rw mul_normal at *, rcases hh with ⟨n, k, hn, hk, rfl⟩,
  use [g * n * g⁻¹, g * k * g⁻¹, hN.conj_mem n hn g, hK.conj_mem k hk g],
  simp,
end⟩

@[to_additive]
instance inf_normal (N K : subgroup G) [hN : N.normal] [hK : K.normal] : normal (N ⊓ K) :=
⟨λ h hh g, mem_inf.mpr ⟨hN.conj_mem _ (mem_inf.mp hh).1 _, hK.conj_mem _ (mem_inf.mp hh).2 _⟩⟩

open monoid_hom

@[to_additive]
lemma comap_mono {f : G →* H} {K K' : subgroup H} : K ≤ K' → comap f K ≤ comap f K' :=
set.preimage_mono

@[to_additive]
lemma map_mono {f : G →* H} {K K' : subgroup G} : K ≤ K' → map f K ≤ map f K' :=
set.image_subset _

@[to_additive]
lemma range_comp (f : G →* H) (g : H →* K) : (g.comp f).range = map g f.range :=
set_like.ext' $ set.range_comp g f

variables {f : G →* H} {g : H →* K}

@[to_additive]
lemma map_eq_comap_of_inverse {g : H →* G} (hl : function.left_inverse g f)
  (hr : function.right_inverse g f) (K : subgroup G) : map f K = comap g K :=
set_like.ext' $ by rw [coe_map, coe_comap, set.image_eq_preimage_of_inverse hl hr]

@[to_additive]
lemma map_comap_eq (hf : function.surjective f) (K : subgroup H) :
  map f (comap f K) = K :=
set_like.ext' $ by rw [coe_map, coe_comap, set.image_preimage_eq ↑K hf]

@[to_additive]
lemma comap_map_eq (hf : function.injective f) (K : subgroup G) :
  comap f (map f K) = K :=
set_like.ext' $ by rw [coe_comap, coe_map, set.preimage_image_eq ↑K hf]

@[to_additive]
lemma comap_injective (h : function.surjective f) : function.injective (comap f) :=
λ K L hKL, by { apply_fun map f at hKL, simpa [map_comap_eq h] using hKL }

@[to_additive]
lemma map_injective (h : function.injective f) : function.injective (map f) :=
λ K L hKL, by { apply_fun comap f at hKL, simpa [comap_map_eq h] using hKL }

@[to_additive]
lemma ker_le_comap {K : subgroup H} : f.ker ≤ comap f K :=
(gc_map_comap f).monotone_u bot_le

@[to_additive]
lemma le_ker_iff_map {K : subgroup G} : K ≤ f.ker ↔ map f K = ⊥ :=
by rw [ker, eq_bot_iff, gc_map_comap]

@[to_additive]
lemma range_inclusion {H K : subgroup G} (h : H ≤ K) :
  (inclusion h).range = comap K.subtype H :=
begin
  ext, split,
  { intro hx, simp [inclusion] at *, rcases hx with ⟨x', rfl⟩, exact x'.prop },
  intro hx, simp [inclusion] at *, use ⟨x.val, hx⟩, rw subtype.ext_iff_val, refl,
end

@[to_additive]
lemma comap_subtype (H K : subgroup G) : comap K.subtype H = comap K.subtype (K ⊓ H) :=
le_antisymm (λ x hx, by simpa) ((gc_map_comap K.subtype).monotone_u inf_le_right)

@[to_additive]
lemma inclusion_injective {H K : subgroup G} {h : H ≤ K} : function.injective (inclusion h)
| ⟨_, _⟩ ⟨_, _⟩ := subtype.ext_iff_val.2 ∘ subtype.ext_iff_val.1

@[to_additive]
lemma subsingleton_subgroup_iff {H : subgroup G} : subsingleton H ↔ H = ⊥ :=
⟨λ h, le_antisymm (λ a ha, mem_bot.mpr $ subtype.mk_eq_mk.mp $
  @subsingleton.elim _ h ⟨a, ha⟩ ⟨1, one_mem H⟩) bot_le,
λ h, subsingleton.intro $ λ ⟨a, ha⟩ ⟨b, hb⟩, by { rw h at *, congr, rw [mem_bot.mp ha, mem_bot.mp hb] }⟩

@[to_additive]
lemma comap_subtype_top : comap (subgroup.subtype ⊤) = map (equiv_top G).to_monoid_hom :=
funext $ λ H, by rw [@map_eq_comap_of_inverse _ _ _ _ (equiv_top G).to_monoid_hom
  (equiv_top G).symm.to_monoid_hom (equiv_top G).left_inv (equiv_top G).right_inv,
  equiv_top_symm_apply]

@[to_additive]
lemma normal.mul_equiv_map {N : subgroup G} (hN : N.normal) (e : G ≃* H) :
  normal (map e.to_monoid_hom N) :=
by rw @map_eq_comap_of_inverse _ _ _ _
  e.to_monoid_hom e.symm.to_monoid_hom e.left_inv e.right_inv;
  apply_instance

@[to_additive]
instance (N : subgroup G) [hN : N.normal] (e : G ≃* H) :
  normal (map e.to_monoid_hom N) :=
normal.mul_equiv_map hN e

end subgroup

namespace monoid_hom

open subgroup

variables {G H : Type*} [group G] [group H]

@[simp, to_additive] lemma range_one : (1 : G →* H).range = ⊥ :=
subgroup.ext $ λ x, ⟨
  λ ⟨y, hy⟩, mem_bot.mpr (hy ▸ one_apply _),
  λ hx, ⟨1, (mem_bot.mp hx).symm ▸ one_apply _⟩
⟩

lemma injective_iff_ker_eq_bot (f : G →* H) : function.injective f ↔ f.ker = ⊥ :=
iff.trans (injective_iff f)
  ⟨λ h, le_antisymm (λ x hx, subgroup.mem_bot.mpr $ h x $ (mem_ker f).mp hx) bot_le,
  λ h x hx, by { rwa [←mem_ker, h, subgroup.mem_bot] at hx }⟩

instance range_subsingleton {f : G →* H} [subsingleton G] : subsingleton f.range :=
⟨λ ⟨a, x, hx⟩ ⟨b, y, hy⟩, by simp only [←hx, ←hy, subsingleton.elim x y]⟩

lemma range_subsingleton_eq_bot (f : G →* H) [subsingleton G] : f.range = ⊥ :=
by rw ←subsingleton_subgroup_iff.mp monoid_hom.range_subsingleton; apply_instance

@[to_additive]
lemma mem_range_self (f : G →* H) (x : G) : f x ∈ f.range := mem_range.mpr ⟨x, rfl⟩

@[to_additive]
def range_restrict (f : G →* H) : G →* f.range :=
f.cod_restrict f.range f.mem_range_self

end monoid_hom

namespace mul_equiv

variables {G H : Type*} [group G] [group H]
variables {f : G →* H}

@[to_additive]
def of_left_inverse {g : H → G} (h : function.left_inverse g f) : G ≃* f.range :=
{ to_fun := f.range_restrict,
  inv_fun := g ∘ f.range.subtype,
  left_inv := h,
  right_inv := λ x, subtype.ext $
    let ⟨x', hx'⟩ := monoid_hom.mem_range.mp x.prop in
    show f (g x) = x, by rw [←hx', h x'],
  .. f.range_restrict }

@[to_additive]
noncomputable def of_injective (h : function.injective f) : G ≃* f.range :=
of_left_inverse $ classical.some_spec h.has_left_inverse

@[to_additive]
def of_subsingleton (hG : subsingleton G) (hH : subsingleton H) : G ≃* H :=
{ to_fun := λ _, 1,
  inv_fun := λ _, 1,
  left_inv := λ x, @subsingleton.elim _ hG _ _,
  right_inv := λ y, @subsingleton.elim _ hH _ _,
  map_mul' := λ x y, (one_mul 1).symm }

end mul_equiv

namespace subgroup

section maximal_normal_subgroup

variables {G : Type*} [group G]

/-- A maximal normal subgroup `N` of `G` is a normal proper subgroup that is not properly
contained in any other normal subgroups, except for `G` itself. -/
@[to_additive]
def maximal_normal_subgroup (N : subgroup G) : Prop :=
  N.normal ∧ N ≠ ⊤ ∧ ∀ (K : subgroup G) [K.normal], N ≤ K → K = N ∨ K = ⊤

@[to_additive]
lemma sup_maximal_normal_subgroup {N K : subgroup G} (hN : maximal_normal_subgroup N)
  (hK : maximal_normal_subgroup K) (h : N ≠ K) : N ⊔ K = ⊤ :=
begin
  haveI := hN.1, haveI := hK.1,
  have h1 := hN.2.2 (N ⊔ K) le_sup_left,
  have h2 := hK.2.2 (N ⊔ K) le_sup_right,
  cases h1, swap, { exact h1 },
  exfalso, apply h (le_antisymm _ (h1 ▸ le_sup_right)),
  cases h2, swap, { apply absurd _ hN.2.1, rw [←h1, h2] },
  exact h2 ▸ le_sup_left,
end

end maximal_normal_subgroup

end subgroup


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Kevin Buzzard, Jujian Zhang
-/

import algebra.algebra.operations
import algebra.algebra.subalgebra.basic
import algebra.direct_sum.algebra

/-!
# Internally graded rings and algebras

This module provides `gsemiring` and `gcomm_semiring` instances for a collection of subobjects `A`
when a `set_like.graded_monoid` instance is available:

* on `add_submonoid R`s: `add_submonoid.gsemiring`, `add_submonoid.gcomm_semiring`.
* on `add_subgroup R`s: `add_subgroup.gsemiring`, `add_subgroup.gcomm_semiring`.
* on `submodule S R`s: `submodule.gsemiring`, `submodule.gcomm_semiring`.

With these instances in place, it provides the bundled canonical maps out of a direct sum of
subobjects into their carrier type:

* `direct_sum.add_submonoid_coe_ring_hom` (a `ring_hom` version of `direct_sum.add_submonoid_coe`)
* `direct_sum.add_subgroup_coe_ring_hom` (a `ring_hom` version of `direct_sum.add_subgroup_coe`)
* `direct_sum.submodule_coe_alg_hom` (an `alg_hom` version of `direct_sum.submodule_coe`)

Strictly the definitions in this file are not sufficient to fully define an "internal" direct sum;
to represent this case, `(h : direct_sum.submodule_is_internal A) [set_like.graded_monoid A]` is
needed. In the future there will likely be a data-carrying, constructive, typeclass version of
`direct_sum.submodule_is_internal` for providing an explicit decomposition function.

When `complete_lattice.independent (set.range A)` (a weaker condition than
`direct_sum.submodule_is_internal A`), these provide a grading of `⨆ i, A i`, and the
mapping `⨁ i, A i →+ ⨆ i, A i` can be obtained as
`direct_sum.to_monoid (λ i, add_submonoid.inclusion $ le_supr A i)`.

## tags

internally graded ring
-/

open_locale direct_sum big_operators

variables {ι : Type*} {S R : Type*}

lemma set_like.has_graded_one.algebra_map_mem [has_zero ι]
  [comm_semiring S] [semiring R] [algebra S R]
  (A : ι → submodule S R) [set_like.has_graded_one A] (s : S) : algebra_map S R s ∈ A 0 :=
begin
  rw algebra.algebra_map_eq_smul_one,
  exact ((A 0).smul_mem s set_like.has_graded_one.one_mem),
end

section direct_sum
variables [decidable_eq ι]

/-! #### From `add_submonoid`s -/

namespace add_submonoid

/-- Build a `gsemiring` instance for a collection of `add_submonoid`s. -/
instance gsemiring [add_monoid ι] [semiring R]
  (A : ι → add_submonoid R) [set_like.graded_monoid A] :
  direct_sum.gsemiring (λ i, A i) :=
{ mul_zero := λ i j _, subtype.ext (mul_zero _),
  zero_mul := λ i j _, subtype.ext (zero_mul _),
  mul_add := λ i j _ _ _, subtype.ext (mul_add _ _ _),
  add_mul := λ i j _ _ _, subtype.ext (add_mul _ _ _),
  ..set_like.gmonoid A }

/-- Build a `gcomm_semiring` instance for a collection of `add_submonoid`s. -/
instance gcomm_semiring [add_comm_monoid ι] [comm_semiring R]
  (A : ι → add_submonoid R) [set_like.graded_monoid A] :
  direct_sum.gcomm_semiring (λ i, A i) :=
{ ..set_like.gcomm_monoid A,
  ..add_submonoid.gsemiring A, }

end add_submonoid

/-- The canonical ring isomorphism between `⨁ i, A i` and `R`-/
def direct_sum.submonoid_coe_ring_hom [add_monoid ι] [semiring R]
  (A : ι → add_submonoid R) [h : set_like.graded_monoid A] : (⨁ i, A i) →+* R :=
direct_sum.to_semiring (λ i, (A i).subtype) rfl (λ _ _ _ _, rfl)

/-- The canonical ring isomorphism between `⨁ i, A i` and `R`-/
@[simp] lemma direct_sum.submonoid_coe_ring_hom_of [add_monoid ι] [semiring R]
  (A : ι → add_submonoid R) [h : set_like.graded_monoid A] (i : ι) (x : A i) :
  direct_sum.submonoid_coe_ring_hom A (direct_sum.of (λ i, A i) i x) = x :=
direct_sum.to_semiring_of _ _ _ _ _

lemma direct_sum.coe_mul_apply_add_submonoid [add_monoid ι] [semiring R]
  (A : ι → add_submonoid R) [set_like.graded_monoid A]
  [Π (i : ι) (x : A i), decidable (x ≠ 0)] (r r' : ⨁ i, A i) (i : ι) :
  ((r * r') i : R) =
    ∑ ij in finset.filter (λ ij : ι × ι, ij.1 + ij.2 = i) (r.support.product r'.support),
      r ij.1 * r' ij.2 :=
begin
  rw [direct_sum.mul_eq_sum_support_ghas_mul, dfinsupp.finset_sum_apply,
    add_submonoid.coe_finset_sum],
  simp_rw [direct_sum.coe_of_add_submonoid_apply, ←finset.sum_filter, set_like.coe_ghas_mul],
end

/-! #### From `add_subgroup`s -/

namespace add_subgroup

/-- Build a `gsemiring` instance for a collection of `add_subgroup`s. -/
instance gsemiring [add_monoid ι] [ring R]
  (A : ι → add_subgroup R) [h : set_like.graded_monoid A] :
  direct_sum.gsemiring (λ i, A i) :=
have i' : set_like.graded_monoid (λ i, (A i).to_add_submonoid) := {..h},
by exactI add_submonoid.gsemiring (λ i, (A i).to_add_submonoid)

/-- Build a `gcomm_semiring` instance for a collection of `add_subgroup`s. -/
instance gcomm_semiring [add_comm_group ι] [comm_ring R]
  (A : ι → add_subgroup R) [h : set_like.graded_monoid A] :
  direct_sum.gsemiring (λ i, A i) :=
have i' : set_like.graded_monoid (λ i, (A i).to_add_submonoid) := {..h},
by exactI add_submonoid.gsemiring (λ i, (A i).to_add_submonoid)

end add_subgroup

/-- The canonical ring isomorphism between `⨁ i, A i` and `R`. -/
def direct_sum.subgroup_coe_ring_hom [add_monoid ι] [ring R]
  (A : ι → add_subgroup R) [set_like.graded_monoid A] : (⨁ i, A i) →+* R :=
direct_sum.to_semiring (λ i, (A i).subtype) rfl (λ _ _ _ _, rfl)

@[simp] lemma direct_sum.subgroup_coe_ring_hom_of [add_monoid ι] [ring R]
  (A : ι → add_subgroup R) [set_like.graded_monoid A] (i : ι) (x : A i) :
  direct_sum.subgroup_coe_ring_hom A (direct_sum.of (λ i, A i) i x) = x :=
direct_sum.to_semiring_of _ _ _ _ _

lemma direct_sum.coe_mul_apply_add_subgroup [add_monoid ι] [ring R]
  (A : ι → add_subgroup R) [set_like.graded_monoid A] [Π (i : ι) (x : A i), decidable (x ≠ 0)]
  (r r' : ⨁ i, A i) (i : ι) :
  ((r * r') i : R) =
    ∑ ij in finset.filter (λ ij : ι × ι, ij.1 + ij.2 = i) (r.support.product r'.support),
      r ij.1 * r' ij.2 :=
begin
  rw [direct_sum.mul_eq_sum_support_ghas_mul, dfinsupp.finset_sum_apply,
    add_subgroup.coe_finset_sum],
  simp_rw [direct_sum.coe_of_add_subgroup_apply, ←finset.sum_filter, set_like.coe_ghas_mul],
end

/-! #### From `submodules`s -/

namespace submodule

/-- Build a `gsemiring` instance for a collection of `submodule`s. -/
instance gsemiring [add_monoid ι]
  [comm_semiring S] [semiring R] [algebra S R]
  (A : ι → submodule S R) [h : set_like.graded_monoid A] :
  direct_sum.gsemiring (λ i, A i) :=
have i' : set_like.graded_monoid (λ i, (A i).to_add_submonoid) := {..h},
by exactI add_submonoid.gsemiring (λ i, (A i).to_add_submonoid)

/-- Build a `gsemiring` instance for a collection of `submodule`s. -/
instance gcomm_semiring [add_comm_monoid ι]
  [comm_semiring S] [comm_semiring R] [algebra S R]
  (A : ι → submodule S R) [h : set_like.graded_monoid A] :
  direct_sum.gcomm_semiring (λ i, A i) :=
have i' : set_like.graded_monoid (λ i, (A i).to_add_submonoid) := {..h},
by exactI add_submonoid.gcomm_semiring (λ i, (A i).to_add_submonoid)

/-- Build a `galgebra` instance for a collection of `submodule`s. -/
instance galgebra [add_monoid ι]
  [comm_semiring S] [semiring R] [algebra S R]
  (A : ι → submodule S R) [h : set_like.graded_monoid A] :
  direct_sum.galgebra S (λ i, A i) :=
{ to_fun := ((algebra.linear_map S R).cod_restrict (A 0) $
    set_like.has_graded_one.algebra_map_mem A).to_add_monoid_hom,
  map_one := subtype.ext $ by exact (algebra_map S R).map_one,
  map_mul := λ x y, sigma.subtype_ext (add_zero 0).symm $ (algebra_map S R).map_mul _ _,
  commutes := λ r ⟨i, xi⟩,
    sigma.subtype_ext ((zero_add i).trans (add_zero i).symm) $ algebra.commutes _ _,
  smul_def := λ r ⟨i, xi⟩, sigma.subtype_ext (zero_add i).symm $ algebra.smul_def _ _ }

@[simp] lemma set_like.coe_galgebra_to_fun [add_monoid ι]
  [comm_semiring S] [semiring R] [algebra S R]
  (A : ι → submodule S R) [h : set_like.graded_monoid A] (s : S) :
    ↑(@direct_sum.galgebra.to_fun _ S (λ i, A i) _ _ _ _ _ _ _ s) = (algebra_map S R s : R) := rfl

/-- A direct sum of powers of a submodule of an algebra has a multiplicative structure. -/
instance nat_power_graded_monoid
  [comm_semiring S] [semiring R] [algebra S R] (p : submodule S R) :
  set_like.graded_monoid (λ i : ℕ, p ^ i) :=
{ one_mem := by { rw [←one_le, pow_zero], exact le_rfl },
  mul_mem := λ i j p q hp hq, by { rw pow_add, exact submodule.mul_mem_mul hp hq } }

end submodule

/-- The canonical algebra isomorphism between `⨁ i, A i` and `R`. -/
def direct_sum.submodule_coe_alg_hom [add_monoid ι]
  [comm_semiring S] [semiring R] [algebra S R]
  (A : ι → submodule S R) [h : set_like.graded_monoid A] : (⨁ i, A i) →ₐ[S] R :=
direct_sum.to_algebra S _ (λ i, (A i).subtype) rfl (λ _ _ _ _, rfl) (λ _, rfl)

/-- The supremum of submodules that form a graded monoid is a subalgebra, and equal to the range of
`direct_sum.submodule_coe_alg_hom`. -/
lemma submodule.supr_eq_to_submodule_range [add_monoid ι]
  [comm_semiring S] [semiring R] [algebra S R] (A : ι → submodule S R) [set_like.graded_monoid A] :
  (⨆ i, A i) = (direct_sum.submodule_coe_alg_hom A).range.to_submodule :=
(submodule.supr_eq_range_dfinsupp_lsum A).trans $ set_like.coe_injective rfl

@[simp] lemma direct_sum.submodule_coe_alg_hom_of [add_monoid ι]
  [comm_semiring S] [semiring R] [algebra S R]
  (A : ι → submodule S R) [h : set_like.graded_monoid A] (i : ι) (x : A i) :
  direct_sum.submodule_coe_alg_hom A (direct_sum.of (λ i, A i) i x) = x :=
direct_sum.to_semiring_of _ rfl (λ _ _ _ _, rfl) _ _

lemma direct_sum.coe_mul_apply_submodule [add_monoid ι]
  [comm_semiring S] [semiring R] [algebra S R]
  (A : ι → submodule S R) [Π (i : ι) (x : A i), decidable (x ≠ 0)]
  [set_like.graded_monoid A] (r r' : ⨁ i, A i) (i : ι) :
  ((r * r') i : R) =
    ∑ ij in finset.filter (λ ij : ι × ι, ij.1 + ij.2 = i) (r.support.product r'.support),
      r ij.1 * r' ij.2 :=
begin
  rw [direct_sum.mul_eq_sum_support_ghas_mul, dfinsupp.finset_sum_apply, submodule.coe_sum],
  simp_rw [direct_sum.coe_of_submodule_apply, ←finset.sum_filter, set_like.coe_ghas_mul],
end

end direct_sum

section homogeneous_element

lemma set_like.is_homogeneous_zero_submodule [has_zero ι]
  [semiring S] [add_comm_monoid R] [module S R]
  (A : ι → submodule S R) : set_like.is_homogeneous A (0 : R) :=
⟨0, submodule.zero_mem _⟩

lemma set_like.is_homogeneous.smul [comm_semiring S] [semiring R] [algebra S R]
  {A : ι → submodule S R} {s : S}
  {r : R} (hr : set_like.is_homogeneous A r) : set_like.is_homogeneous A (s • r) :=
let ⟨i, hi⟩ := hr in ⟨i, submodule.smul_mem _ _ hi⟩

end homogeneous_element


/-
Copyright © 2022 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth, Floris van Doorn
-/

import topology.vector_bundle.basic
import analysis.normed_space.operator_norm

/-!
# The topological vector bundle of continuous (semi)linear maps

We define the topological vector bundle of continuous (semi)linear maps between two
vector bundles over the same base.
Given bundles `E₁ E₂ : B → Type*`, we define
`bundle.continuous_linear_map 𝕜 E₁ E₂ := λ x, E₁ x →SL[𝕜] E₂ x`.
If the `E₁` and `E₂` are topological vector bundles with fibers `F₁` and `F₂`, then this will
be a topological vector bundle with fiber `F₁ →SL[𝕜] F₂`.
The topology is inherited from the norm-topology on, without the need to define the strong
topology on continuous linear maps between general topological vector spaces.

## Main Definitions

* `bundle.continuous_linear_map.topological_vector_bundle`: continuous semilinear maps between
  vector bundles form a vector bundle.

-/

noncomputable theory

open bundle set continuous_linear_map

section defs
variables {𝕜₁ 𝕜₂ : Type*} [normed_field 𝕜₁] [normed_field 𝕜₂]
variables (σ : 𝕜₁ →+* 𝕜₂)
variables {B : Type*}
variables (F₁ : Type*) (E₁ : B → Type*) [Π x, add_comm_monoid (E₁ x)] [Π x, module 𝕜₁ (E₁ x)]
variables [Π x : B, topological_space (E₁ x)]
variables (F₂ : Type*) (E₂ : B → Type*) [Π x, add_comm_monoid (E₂ x)] [Π x, module 𝕜₂ (E₂ x)]
variables [Π x : B, topological_space (E₂ x)]

include F₁ F₂

-- In this definition we require the scalar rings `𝕜₁` and `𝕜₂` to be normed fields, although
-- something much weaker (maybe `comm_semiring`) would suffice mathematically -- this is because of
-- a typeclass inference bug with pi-types:
-- https://leanprover.zulipchat.com/#narrow/stream/116395-maths/topic/vector.20bundles.20--.20typeclass.20inference.20issue
/-- The bundle of continuous `σ`-semilinear maps between the topological vector bundles `E₁` and
`E₂`. This is a type synonym for `λ x, E₁ x →SL[σ] E₂ x`.

We intentionally add `F₁` and `F₂` as arguments to this type, so that instances on this type
(that depend on `F₁` and `F₂`) actually refer to `F₁` and `F₂`. -/
@[derive inhabited, nolint unused_arguments]
def bundle.continuous_linear_map (x : B) : Type* :=
E₁ x →SL[σ] E₂ x

instance bundle.continuous_linear_map.add_monoid_hom_class (x : B) :
  add_monoid_hom_class (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂ x) (E₁ x) (E₂ x) :=
by delta_instance bundle.continuous_linear_map

variables [Π x, has_continuous_add (E₂ x)]

instance (x : B) : add_comm_monoid (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂ x) :=
by delta_instance bundle.continuous_linear_map

variables [∀ x, has_continuous_smul 𝕜₂ (E₂ x)]

instance (x : B) : module 𝕜₂ (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂ x) :=
by delta_instance bundle.continuous_linear_map

end defs

variables {𝕜₁ : Type*} [nondiscrete_normed_field 𝕜₁] {𝕜₂ : Type*} [nondiscrete_normed_field 𝕜₂]
  (σ : 𝕜₁ →+* 𝕜₂)

variables {B : Type*} [topological_space B]

variables (F₁ : Type*) [normed_group F₁] [normed_space 𝕜₁ F₁]
  (E₁ : B → Type*) [Π x, add_comm_monoid (E₁ x)] [Π x, module 𝕜₁ (E₁ x)]
  [topological_space (total_space E₁)]
variables (F₂ : Type*) [normed_group F₂][normed_space 𝕜₂ F₂]
  (E₂ : B → Type*) [Π x, add_comm_monoid (E₂ x)] [Π x, module 𝕜₂ (E₂ x)]
  [topological_space (total_space E₂)]

namespace topological_vector_bundle

variables {F₁ E₁ F₂ E₂} (e₁ e₁' : trivialization 𝕜₁ F₁ E₁) (e₂ e₂' : trivialization 𝕜₂ F₂ E₂)
variables [ring_hom_isometric σ]

namespace pretrivialization

/-- Assume `eᵢ` and `eᵢ'` are trivializations of the bundles `Eᵢ` over base `B` with fiber `Fᵢ`
(`i ∈ {1,2}`), then `continuous_linear_map_coord_change σ e₁ e₁' e₂ e₂'` is the coordinate change
function between the two induced (pre)trivializations
`pretrivialization.continuous_linear_map σ e₁ e₂` and
`pretrivialization.continuous_linear_map σ e₁' e₂'` of `bundle.continuous_linear_map`. -/
def continuous_linear_map_coord_change (b : B) : (F₁ →SL[σ] F₂) →L[𝕜₂] F₁ →SL[σ] F₂ :=
((e₁'.coord_change e₁ b).symm.arrow_congrSL (e₂.coord_change e₂' b) :
  (F₁ →SL[σ] F₂) ≃L[𝕜₂] F₁ →SL[σ] F₂)

variables {σ e₁ e₁' e₂ e₂'}
variables [Π x : B, topological_space (E₁ x)] [topological_vector_bundle 𝕜₁ F₁ E₁]
variables [Π x : B, topological_space (E₂ x)] [topological_vector_bundle 𝕜₂ F₂ E₂]

lemma continuous_on_continuous_linear_map_coord_change
  (he₁ : e₁ ∈ trivialization_atlas 𝕜₁ F₁ E₁) (he₁' : e₁' ∈ trivialization_atlas 𝕜₁ F₁ E₁)
  (he₂ : e₂ ∈ trivialization_atlas 𝕜₂ F₂ E₂) (he₂' : e₂' ∈ trivialization_atlas 𝕜₂ F₂ E₂) :
  continuous_on (continuous_linear_map_coord_change σ e₁ e₁' e₂ e₂')
    ((e₁.base_set ∩ e₂.base_set) ∩ (e₁'.base_set ∩ e₂'.base_set)) :=
begin
  have h₁ := (compSL F₁ F₂ F₂ σ (ring_hom.id 𝕜₂)).continuous,
  have h₂ := (continuous_linear_map.flip (compSL F₁ F₁ F₂ (ring_hom.id 𝕜₁) σ)).continuous,
  have h₃ := (continuous_on_coord_change e₁' he₁' e₁ he₁),
  have h₄ := (continuous_on_coord_change e₂ he₂ e₂' he₂'),
  refine ((h₁.comp_continuous_on (h₄.mono _)).clm_comp (h₂.comp_continuous_on (h₃.mono _))).congr _,
  { mfld_set_tac },
  { mfld_set_tac },
  { intros b hb, ext L v,
    simp only [continuous_linear_map_coord_change, continuous_linear_equiv.coe_coe,
      continuous_linear_equiv.arrow_congrSL_apply, comp_apply, function.comp, compSL_apply,
      flip_apply, continuous_linear_equiv.symm_symm] },
end

variables (σ e₁ e₁' e₂ e₂')
variables [Π x, has_continuous_add (E₂ x)] [Π x, has_continuous_smul 𝕜₂ (E₂ x)]

/-- Given trivializations `e₁`, `e₂` for vector bundles `E₁`, `E₂` over a base `B`,
`pretrivialization.continuous_linear_map σ e₁ e₂` is the induced pretrivialization for the
continuous `σ`-semilinear maps from `E₁` to `E₂`. That is, the map which will later become a
trivialization, after the bundle of continuous semilinear maps is equipped with the right
topological vector bundle structure. -/
def continuous_linear_map :
  pretrivialization 𝕜₂ (F₁ →SL[σ] F₂) (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂) :=
{ to_fun := λ p, ⟨p.1, (e₂.continuous_linear_map_at p.1).comp $ p.2.comp $ e₁.symmL p.1⟩,
  inv_fun := λ p, ⟨p.1, (e₂.symmL p.1).comp $ p.2.comp $ e₁.continuous_linear_map_at p.1⟩,
  source := (bundle.total_space.proj) ⁻¹' (e₁.base_set ∩ e₂.base_set),
  target := (e₁.base_set ∩ e₂.base_set) ×ˢ (set.univ : set (F₁ →SL[σ] F₂)),
  map_source' := λ ⟨x, L⟩ h, ⟨h, set.mem_univ _⟩,
  map_target' := λ ⟨x, f⟩ h, h.1,
  left_inv' := λ ⟨x, L⟩ ⟨h₁, h₂⟩,
  begin
    simp_rw [sigma.mk.inj_iff, eq_self_iff_true, heq_iff_eq, true_and],
    ext v,
    simp only [comp_apply, trivialization.symmL_continuous_linear_map_at, h₁, h₂]
  end,
  right_inv' := λ ⟨x, f⟩ ⟨⟨h₁, h₂⟩, _⟩,
  begin
    simp_rw [prod.mk.inj_iff, eq_self_iff_true, true_and],
    ext v,
    simp only [comp_apply, trivialization.continuous_linear_map_at_symmL, h₁, h₂]
  end,
  open_target := (e₁.open_base_set.inter e₂.open_base_set).prod is_open_univ,
  base_set := e₁.base_set ∩ e₂.base_set,
  open_base_set := e₁.open_base_set.inter e₂.open_base_set,
  source_eq := rfl,
  target_eq := rfl,
  proj_to_fun := λ ⟨x, f⟩ h, rfl,
  linear' := λ x h,
  { map_add := λ L L', by simp_rw [add_comp, comp_add],
    map_smul := λ c L, by simp_rw [smul_comp, comp_smulₛₗ, ring_hom.id_apply] } }

lemma continuous_linear_map_apply
  (p : total_space (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂)) :
  (continuous_linear_map σ e₁ e₂) p =
  ⟨p.1, (e₂.continuous_linear_map_at p.1).comp $ p.2.comp $ e₁.symmL p.1⟩ :=
rfl

lemma continuous_linear_map_symm_apply (p : B × (F₁ →SL[σ] F₂)) :
  (continuous_linear_map σ e₁ e₂).to_local_equiv.symm p =
  ⟨p.1, (e₂.symmL p.1).comp $ p.2.comp $ e₁.continuous_linear_map_at p.1⟩ :=
rfl

lemma continuous_linear_map_symm_apply' {b : B} (hb : b ∈ e₁.base_set ∩ e₂.base_set)
  (L : F₁ →SL[σ] F₂) :
  (continuous_linear_map σ e₁ e₂).symm b L =
  (e₂.symmL b).comp (L.comp $ e₁.continuous_linear_map_at b) :=
begin
  rw [symm_apply], refl, exact hb
end

lemma continuous_linear_map_coord_change_apply (b : B)
  (hb : b ∈ (e₁.base_set ∩ e₂.base_set) ∩ (e₁'.base_set ∩ e₂'.base_set)) (L : F₁ →SL[σ] F₂) :
  continuous_linear_map_coord_change σ e₁ e₁' e₂ e₂' b L =
  (continuous_linear_map σ e₁' e₂'
    (total_space_mk b ((continuous_linear_map σ e₁ e₂).symm b L))).2 :=
begin
  ext v,
  simp_rw [continuous_linear_map_coord_change, continuous_linear_equiv.coe_coe,
    continuous_linear_equiv.arrow_congrSL_apply,
    continuous_linear_map_apply, continuous_linear_map_symm_apply' σ e₁ e₂ hb.1,
    comp_apply, continuous_linear_equiv.coe_coe, continuous_linear_equiv.symm_symm,
    trivialization.continuous_linear_map_at_apply, trivialization.symmL_apply],
  dsimp only [total_space_mk],
  rw [e₂.coord_change_apply e₂', e₁'.coord_change_apply e₁, e₁.coe_linear_map_at_of_mem hb.1.1,
    e₂'.coe_linear_map_at_of_mem hb.2.2],
  exacts [⟨hb.2.1, hb.1.1⟩, ⟨hb.1.2, hb.2.2⟩]
end

end pretrivialization

open pretrivialization
variables (F₁ E₁ F₂ E₂)
variables [Π x : B, topological_space (E₁ x)] [topological_vector_bundle 𝕜₁ F₁ E₁]
variables [Π x : B, topological_space (E₂ x)] [topological_vector_bundle 𝕜₂ F₂ E₂]
variables [Π x, has_continuous_add (E₂ x)] [Π x, has_continuous_smul 𝕜₂ (E₂ x)]

/-- The continuous `σ`-semilinear maps between two topological vector bundles form a
`topological_vector_prebundle` (this is an auxiliary construction for the
`topological_vector_bundle` instance, in which the pretrivializations are collated but no topology
on the total space is yet provided). -/
def _root_.bundle.continuous_linear_map.topological_vector_prebundle :
  topological_vector_prebundle 𝕜₂ (F₁ →SL[σ] F₂)
  (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂) :=
{ pretrivialization_atlas :=
  image2 (λ e₁ e₂, pretrivialization.continuous_linear_map σ e₁ e₂) (trivialization_atlas 𝕜₁ F₁ E₁)
    (trivialization_atlas 𝕜₂ F₂ E₂),
  pretrivialization_at := λ x, pretrivialization.continuous_linear_map σ
    (trivialization_at 𝕜₁ F₁ E₁ x) (trivialization_at 𝕜₂ F₂ E₂ x),
  mem_base_pretrivialization_at := λ x,
    ⟨mem_base_set_trivialization_at 𝕜₁ F₁ E₁ x, mem_base_set_trivialization_at 𝕜₂ F₂ E₂ x⟩,
  pretrivialization_mem_atlas := λ x,
    ⟨_, _, trivialization_mem_atlas 𝕜₁ F₁ E₁ x, trivialization_mem_atlas 𝕜₂ F₂ E₂ x, rfl⟩,
  exists_coord_change := by { rintro _ ⟨e₁, e₂, he₁, he₂, rfl⟩ _ ⟨e₁', e₂', he₁', he₂', rfl⟩,
    exact ⟨continuous_linear_map_coord_change σ e₁ e₁' e₂ e₂',
    continuous_on_continuous_linear_map_coord_change he₁ he₁' he₂ he₂',
    continuous_linear_map_coord_change_apply σ e₁ e₁' e₂ e₂'⟩ } }

/-- Topology on the continuous `σ`-semilinear_maps between the respective fibers at a point of two
"normable" vector bundles over the same base. Here "normable" means that the bundles have fibers
modelled on normed spaces `F₁`, `F₂` respectively.  The topology we put on the continuous
`σ`-semilinear_maps is the topology coming from the operator norm on maps from `F₁` to `F₂`. -/
instance (x : B) : topological_space (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂ x) :=
(bundle.continuous_linear_map.topological_vector_prebundle σ F₁ E₁ F₂ E₂).fiber_topology x

/-- Topology on the total space of the continuous `σ`-semilinear_maps between two "normable" vector
bundles over the same base. -/
instance : topological_space (total_space (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂)) :=
(bundle.continuous_linear_map.topological_vector_prebundle
  σ F₁ E₁ F₂ E₂).total_space_topology

/-- The continuous `σ`-semilinear_maps between two vector bundles form a vector bundle. -/
instance _root_.bundle.continuous_linear_map.topological_vector_bundle :
  topological_vector_bundle 𝕜₂ (F₁ →SL[σ] F₂) (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂) :=
(bundle.continuous_linear_map.topological_vector_prebundle
  σ F₁ E₁ F₂ E₂).to_topological_vector_bundle

variables {F₁ E₁ F₂ E₂}

/-- Given trivializations `e₁`, `e₂` in the atlas for vector bundles `E₁`, `E₂` over a base `B`,
the induced trivialization for the continuous `σ`-semilinear maps from `E₁` to `E₂`,
whose base set is `e₁.base_set ∩ e₂.base_set`. -/
def trivialization.continuous_linear_map
  (he₁ : e₁ ∈ trivialization_atlas 𝕜₁ F₁ E₁) (he₂ : e₂ ∈ trivialization_atlas 𝕜₂ F₂ E₂) :
  trivialization 𝕜₂ (F₁ →SL[σ] F₂) (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂) :=
(bundle.continuous_linear_map.topological_vector_prebundle σ F₁ E₁ F₂ E₂)
  .trivialization_of_mem_pretrivialization_atlas (mem_image2_of_mem he₁ he₂)

variables {e₁ e₂}

@[simp] lemma trivialization.base_set_continuous_linear_map
  (he₁ : e₁ ∈ trivialization_atlas 𝕜₁ F₁ E₁) (he₂ : e₂ ∈ trivialization_atlas 𝕜₂ F₂ E₂) :
  (e₁.continuous_linear_map σ e₂ he₁ he₂).base_set = e₁.base_set ∩ e₂.base_set :=
rfl

lemma trivialization.continuous_linear_map_apply
  (he₁ : e₁ ∈ trivialization_atlas 𝕜₁ F₁ E₁) (he₂ : e₂ ∈ trivialization_atlas 𝕜₂ F₂ E₂)
  (p : total_space (bundle.continuous_linear_map σ F₁ E₁ F₂ E₂)) :
  e₁.continuous_linear_map σ e₂ he₁ he₂ p =
  ⟨p.1, (e₂.continuous_linear_map_at p.1).comp $ p.2.comp $ e₁.symmL p.1⟩ :=
rfl

end topological_vector_bundle


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

! This file was ported from Lean 3 source module category_theory.limits.shapes.normal_mono.equalizers
! leanprover-community/mathlib commit 3a061790136d13594ec10c7c90d202335ac5d854
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.Shapes.NormalMono.Basic
import Mathlib.CategoryTheory.Limits.Shapes.FiniteProducts

/-!
# Normal mono categories with finite products and kernels have all equalizers.

This, and the dual result, are used in the development of abelian categories.
-/

noncomputable section

open CategoryTheory

open CategoryTheory.Limits

variable {C : Type _} [Category C] [HasZeroMorphisms C]

namespace CategoryTheory.NormalMonoCategory

variable [HasFiniteProducts C] [HasKernels C] [NormalMonoCategory C]

/-- The pullback of two monomorphisms exists. -/
@[irreducible, nolint defLemma] -- Porting note: changed to irreducible and a def
def pullback_of_mono {X Y Z : C} (a : X ⟶ Z) (b : Y ⟶ Z) [Mono a] [Mono b] :
  HasLimit (cospan a b) :=
  let ⟨P, f, haf, i⟩ := normalMonoOfMono a
  let ⟨Q, g, hbg, i'⟩ := normalMonoOfMono b
  let ⟨a', ha'⟩ :=
    KernelFork.IsLimit.lift' i (kernel.ι (prod.lift f g)) <|
      calc
        kernel.ι (prod.lift f g) ≫ f = kernel.ι (prod.lift f g) ≫ prod.lift f g ≫ Limits.prod.fst :=
          by rw [prod.lift_fst]
        _ = (0 : kernel (prod.lift f g) ⟶ P ⨯ Q) ≫ Limits.prod.fst := by rw [kernel.condition_assoc]
        _ = 0 := zero_comp

  let ⟨b', hb'⟩ :=
    KernelFork.IsLimit.lift' i' (kernel.ι (prod.lift f g)) <|
      calc
        kernel.ι (prod.lift f g) ≫ g = kernel.ι (prod.lift f g) ≫ prod.lift f g ≫ Limits.prod.snd :=
          by rw [prod.lift_snd]
        _ = (0 : kernel (prod.lift f g) ⟶ P ⨯ Q) ≫ Limits.prod.snd := by rw [kernel.condition_assoc]
        _ = 0 := zero_comp

  HasLimit.mk
    { cone :=
        PullbackCone.mk a' b' <| by
          simp at ha' hb'
          rw [ha', hb']
      isLimit :=
        PullbackCone.IsLimit.mk _
          (fun s =>
            kernel.lift (prod.lift f g) (PullbackCone.snd s ≫ b) <|
              prod.hom_ext
                (calc
                  ((PullbackCone.snd s ≫ b) ≫ prod.lift f g) ≫ Limits.prod.fst =
                      PullbackCone.snd s ≫ b ≫ f :=
                    by simp only [prod.lift_fst, Category.assoc]
                  _ = PullbackCone.fst s ≫ a ≫ f := by rw [PullbackCone.condition_assoc]
                  _ = PullbackCone.fst s ≫ 0 := by rw [haf]
                  _ = 0 ≫ Limits.prod.fst := by rw [comp_zero, zero_comp]
                  )
                (calc
                  ((PullbackCone.snd s ≫ b) ≫ prod.lift f g) ≫ Limits.prod.snd =
                      PullbackCone.snd s ≫ b ≫ g :=
                    by simp only [prod.lift_snd, Category.assoc]
                  _ = PullbackCone.snd s ≫ 0 := by rw [hbg]
                  _ = 0 ≫ Limits.prod.snd := by rw [comp_zero, zero_comp]
                  ))
          (fun s =>
            (cancel_mono a).1 <| by
              rw [KernelFork.ι_ofι] at ha'
              simp [ha', PullbackCone.condition s])
          (fun s =>
            (cancel_mono b).1 <| by
              rw [KernelFork.ι_ofι] at hb'
              simp [hb'])
          fun s m h₁ _ =>
          (cancel_mono (kernel.ι (prod.lift f g))).1 <|
            calc
              m ≫ kernel.ι (prod.lift f g) = m ≫ a' ≫ a :=
                by
                congr
                exact ha'.symm
              _ = PullbackCone.fst s ≫ a := by rw [← Category.assoc, h₁]
              _ = PullbackCone.snd s ≫ b := (PullbackCone.condition s)
              _ =
                  kernel.lift (prod.lift f g) (PullbackCone.snd s ≫ b) _ ≫
                    kernel.ι (prod.lift f g) :=
                by rw [kernel.lift_ι]
               }
#align category_theory.normal_mono_category.pullback_of_mono CategoryTheory.NormalMonoCategory.pullback_of_mono

section

attribute [local instance] pullback_of_mono

/-- The pullback of `(𝟙 X, f)` and `(𝟙 X, g)` -/
private abbrev P {X Y : C} (f g : X ⟶ Y) [Mono (prod.lift (𝟙 X) f)] [Mono (prod.lift (𝟙 X) g)] :
    C :=
  pullback (prod.lift (𝟙 X) f) (prod.lift (𝟙 X) g)

/-- The equalizer of `f` and `g` exists. -/
 -- Porting note: changed to irreducible def since irreducible_def was breaking things
@[irreducible, nolint defLemma]
def hasLimit_parallelPair {X Y : C} (f g : X ⟶ Y) : HasLimit (parallelPair f g) :=
  have huv : (pullback.fst : P f g ⟶ X) = pullback.snd :=
    calc
      (pullback.fst : P f g ⟶ X) = pullback.fst ≫ 𝟙 _ := Eq.symm <| Category.comp_id _
      _ = pullback.fst ≫ prod.lift (𝟙 X) f ≫ Limits.prod.fst := by rw [prod.lift_fst]
      _ = pullback.snd ≫ prod.lift (𝟙 X) g ≫ Limits.prod.fst := by rw [pullback.condition_assoc]
      _ = pullback.snd := by rw [prod.lift_fst, Category.comp_id]

  have hvu : (pullback.fst : P f g ⟶ X) ≫ f = pullback.snd ≫ g :=
    calc
      (pullback.fst : P f g ⟶ X) ≫ f = pullback.fst ≫ prod.lift (𝟙 X) f ≫ Limits.prod.snd := by
        rw [prod.lift_snd]
      _ = pullback.snd ≫ prod.lift (𝟙 X) g ≫ Limits.prod.snd := by rw [pullback.condition_assoc]
      _ = pullback.snd ≫ g := by rw [prod.lift_snd]

  have huu : (pullback.fst : P f g ⟶ X) ≫ f = pullback.fst ≫ g := by rw [hvu, ← huv]
  HasLimit.mk
    { cone := Fork.ofι pullback.fst huu
      isLimit :=
        Fork.IsLimit.mk _
          (fun s =>
            pullback.lift (Fork.ι s) (Fork.ι s) <|
              prod.hom_ext (by simp only [prod.lift_fst, Category.assoc])
                (by simp only [prod.comp_lift, Fork.condition s]))
          (fun s => by simp) fun s m h =>
          pullback.hom_ext (by simpa only [pullback.lift_fst] using h)
            (by simpa only [huv.symm, pullback.lift_fst] using h) }
#align category_theory.normal_mono_category.has_limit_parallel_pair CategoryTheory.NormalMonoCategory.hasLimit_parallelPair

end

section

attribute [local instance] hasLimit_parallelPair

/-- A `NormalMonoCategory` category with finite products and kernels has all equalizers. -/
instance (priority := 100) hasEqualizers : HasEqualizers C :=
  hasEqualizers_of_hasLimit_parallelPair _
#align category_theory.normal_mono_category.has_equalizers CategoryTheory.NormalMonoCategory.hasEqualizers

end

/-- If a zero morphism is a cokernel of `f`, then `f` is an epimorphism. -/
theorem epi_of_zero_cokernel {X Y : C} (f : X ⟶ Y) (Z : C)
    (l : IsColimit (CokernelCofork.ofπ (0 : Y ⟶ Z) (show f ≫ 0 = 0 by simp))) : Epi f :=
  ⟨fun u v huv => by
    obtain ⟨W, w, hw, hl⟩ := normalMonoOfMono (equalizer.ι u v)
    obtain ⟨m, hm⟩ := equalizer.lift' f huv
    have hwf : f ≫ w = 0 := by rw [← hm, Category.assoc, hw, comp_zero]
    obtain ⟨n, hn⟩ := CokernelCofork.IsColimit.desc' l _ hwf
    rw [Cofork.π_ofπ, zero_comp] at hn
    have : IsIso (equalizer.ι u v) := by apply isIso_limit_cone_parallelPair_of_eq hn.symm hl
    apply (cancel_epi (equalizer.ι u v)).1
    exact equalizer.condition _ _⟩
#align category_theory.normal_mono_category.epi_of_zero_cokernel CategoryTheory.NormalMonoCategory.epi_of_zero_cokernel

section

variable [HasZeroObject C]

open ZeroObject

/-- If `f ≫ g = 0` implies `g = 0` for all `g`, then `g` is a monomorphism. -/
theorem epi_of_zero_cancel {X Y : C} (f : X ⟶ Y)
    (hf : ∀ (Z : C) (g : Y ⟶ Z) (_ : f ≫ g = 0), g = 0) : Epi f :=
  epi_of_zero_cokernel f 0 <| zeroCokernelOfZeroCancel f hf
#align category_theory.normal_mono_category.epi_of_zero_cancel CategoryTheory.NormalMonoCategory.epi_of_zero_cancel

end

end CategoryTheory.NormalMonoCategory

namespace CategoryTheory.NormalEpiCategory

variable [HasFiniteCoproducts C] [HasCokernels C] [NormalEpiCategory C]

/-- The pushout of two epimorphisms exists. -/
@[irreducible, nolint defLemma] -- Porting note: made a def and re-added irreducible
def pushout_of_epi {X Y Z : C} (a : X ⟶ Y) (b : X ⟶ Z) [Epi a] [Epi b] :
  HasColimit (span a b) :=
  let ⟨P, f, hfa, i⟩ := normalEpiOfEpi a
  let ⟨Q, g, hgb, i'⟩ := normalEpiOfEpi b
  let ⟨a', ha'⟩ :=
    CokernelCofork.IsColimit.desc' i (cokernel.π (coprod.desc f g)) <|
      calc
        f ≫ cokernel.π (coprod.desc f g) =
            coprod.inl ≫ coprod.desc f g ≫ cokernel.π (coprod.desc f g) :=
          by rw [coprod.inl_desc_assoc]
        _ = coprod.inl ≫ (0 : P ⨿ Q ⟶ cokernel (coprod.desc f g)) := by rw [cokernel.condition]
        _ = 0 := HasZeroMorphisms.comp_zero _ _

  let ⟨b', hb'⟩ :=
    CokernelCofork.IsColimit.desc' i' (cokernel.π (coprod.desc f g)) <|
      calc
        g ≫ cokernel.π (coprod.desc f g) =
            coprod.inr ≫ coprod.desc f g ≫ cokernel.π (coprod.desc f g) :=
          by rw [coprod.inr_desc_assoc]
        _ = coprod.inr ≫ (0 : P ⨿ Q ⟶ cokernel (coprod.desc f g)) := by rw [cokernel.condition]
        _ = 0 := HasZeroMorphisms.comp_zero _ _

  HasColimit.mk
    { cocone :=
        PushoutCocone.mk a' b' <| by
          simp only [Cofork.π_ofπ] at ha' hb'
          rw [ha', hb']
      isColimit :=
        PushoutCocone.IsColimit.mk _
          (fun s =>
            cokernel.desc (coprod.desc f g) (b ≫ PushoutCocone.inr s) <|
              coprod.hom_ext
                (calc
                  coprod.inl ≫ coprod.desc f g ≫ b ≫ PushoutCocone.inr s =
                      f ≫ b ≫ PushoutCocone.inr s :=
                    by rw [coprod.inl_desc_assoc]
                  _ = f ≫ a ≫ PushoutCocone.inl s := by rw [PushoutCocone.condition]
                  _ = 0 ≫ PushoutCocone.inl s := by rw [← Category.assoc, eq_whisker hfa]
                  _ = coprod.inl ≫ 0 := by rw [comp_zero, zero_comp]
                  )
                (calc
                  coprod.inr ≫ coprod.desc f g ≫ b ≫ PushoutCocone.inr s =
                      g ≫ b ≫ PushoutCocone.inr s :=
                    by rw [coprod.inr_desc_assoc]
                  _ = 0 ≫ PushoutCocone.inr s := by rw [← Category.assoc, eq_whisker hgb]
                  _ = coprod.inr ≫ 0 := by rw [comp_zero, zero_comp]
                  ))
          (fun s =>
            (cancel_epi a).1 <| by
              rw [CokernelCofork.π_ofπ] at ha'
              have reassoced {W : C} (h : cokernel (coprod.desc f g) ⟶  W) : a ≫ a' ≫ h
                = cokernel.π (coprod.desc f g) ≫ h := by rw [← Category.assoc, eq_whisker ha']
              simp [reassoced , PushoutCocone.condition s])
          (fun s =>
            (cancel_epi b).1 <| by
              rw [CokernelCofork.π_ofπ] at hb'
              have reassoced' {W : C} (h : cokernel (coprod.desc f g) ⟶  W) : b ≫ b' ≫ h
                = cokernel.π (coprod.desc f g) ≫ h := by rw [← Category.assoc, eq_whisker hb']
              simp [reassoced'])
          fun s m h₁ _ =>
          (cancel_epi (cokernel.π (coprod.desc f g))).1 <|
            calc
              cokernel.π (coprod.desc f g) ≫ m = (a ≫ a') ≫ m := by
                congr
                exact ha'.symm
              _ = a ≫ PushoutCocone.inl s := by rw [Category.assoc, h₁]
              _ = b ≫ PushoutCocone.inr s := (PushoutCocone.condition s)
              _ =
                  cokernel.π (coprod.desc f g) ≫
                    cokernel.desc (coprod.desc f g) (b ≫ PushoutCocone.inr s) _ :=
                by rw [cokernel.π_desc]
               }
#align category_theory.normal_epi_category.pushout_of_epi CategoryTheory.NormalEpiCategory.pushout_of_epi

section

attribute [local instance] pushout_of_epi

/-- The pushout of `(𝟙 Y, f)` and `(𝟙 Y, g)`. -/
private abbrev Q {X Y : C} (f g : X ⟶ Y) [Epi (coprod.desc (𝟙 Y) f)] [Epi (coprod.desc (𝟙 Y) g)] :
    C :=
  pushout (coprod.desc (𝟙 Y) f) (coprod.desc (𝟙 Y) g)

/-- The coequalizer of `f` and `g` exists. -/
@[irreducible, nolint defLemma] -- Porting note: changed to def and restored irreducible
def hasColimit_parallelPair {X Y : C} (f g : X ⟶ Y) : HasColimit (parallelPair f g) :=
  have huv : (pushout.inl : Y ⟶ Q f g) = pushout.inr :=
    calc
      (pushout.inl : Y ⟶ Q f g) = 𝟙 _ ≫ pushout.inl := Eq.symm <| Category.id_comp _
      _ = (coprod.inl ≫ coprod.desc (𝟙 Y) f) ≫ pushout.inl := by rw [coprod.inl_desc]
      _ = (coprod.inl ≫ coprod.desc (𝟙 Y) g) ≫ pushout.inr := by
        simp only [Category.assoc, pushout.condition]
      _ = pushout.inr := by rw [coprod.inl_desc, Category.id_comp]

  have hvu : f ≫ (pushout.inl : Y ⟶ Q f g) = g ≫ pushout.inr :=
    calc
      f ≫ (pushout.inl : Y ⟶ Q f g) = (coprod.inr ≫ coprod.desc (𝟙 Y) f) ≫ pushout.inl := by
        rw [coprod.inr_desc]
      _ = (coprod.inr ≫ coprod.desc (𝟙 Y) g) ≫ pushout.inr := by
        simp only [Category.assoc, pushout.condition]
      _ = g ≫ pushout.inr := by rw [coprod.inr_desc]

  have huu : f ≫ (pushout.inl : Y ⟶ Q f g) = g ≫ pushout.inl := by rw [hvu, huv]
  HasColimit.mk
    { cocone := Cofork.ofπ pushout.inl huu
      isColimit :=
        Cofork.IsColimit.mk _
          (fun s =>
            pushout.desc (Cofork.π s) (Cofork.π s) <|
              coprod.hom_ext (by simp only [coprod.inl_desc_assoc])
                (by simp only [coprod.desc_comp, Cofork.condition s]))
          (fun s => by simp only [pushout.inl_desc, Cofork.π_ofπ]) fun s m h =>
          pushout.hom_ext (by simpa only [pushout.inl_desc] using h)
            (by simpa only [huv.symm, pushout.inl_desc] using h) }
#align category_theory.normal_epi_category.has_colimit_parallel_pair CategoryTheory.NormalEpiCategory.hasColimit_parallelPair

end

section

attribute [local instance] hasColimit_parallelPair

/-- A `NormalEpiCategory` category with finite coproducts and cokernels has all coequalizers. -/
instance (priority := 100) hasCoequalizers : HasCoequalizers C :=
  hasCoequalizers_of_hasColimit_parallelPair _
#align category_theory.normal_epi_category.has_coequalizers CategoryTheory.NormalEpiCategory.hasCoequalizers

end

/-- If a zero morphism is a kernel of `f`, then `f` is a monomorphism. -/
theorem mono_of_zero_kernel {X Y : C} (f : X ⟶ Y) (Z : C)
    (l : IsLimit (KernelFork.ofι (0 : Z ⟶ X) (show 0 ≫ f = 0 by simp))) : Mono f :=
  ⟨fun u v huv =>
    by
    obtain ⟨W, w, hw, hl⟩ := normalEpiOfEpi (coequalizer.π u v)
    obtain ⟨m, hm⟩ := coequalizer.desc' f huv
    have reassoced {W : C} (h : coequalizer u v ⟶  W) : w ≫ coequalizer.π u v ≫ h = 0 ≫ h := by
      rw [← Category.assoc, eq_whisker hw]
    have hwf : w ≫ f = 0 := by rw [← hm, reassoced, zero_comp]
    obtain ⟨n, hn⟩ := KernelFork.IsLimit.lift' l _ hwf
    rw [Fork.ι_ofι, HasZeroMorphisms.comp_zero] at hn
    have : IsIso (coequalizer.π u v) := by
      apply isIso_colimit_cocone_parallelPair_of_eq hn.symm hl
    apply (cancel_mono (coequalizer.π u v)).1
    exact coequalizer.condition _ _⟩
#align category_theory.normal_epi_category.mono_of_zero_kernel CategoryTheory.NormalEpiCategory.mono_of_zero_kernel

section

variable [HasZeroObject C]

open ZeroObject

/-- If `g ≫ f = 0` implies `g = 0` for all `g`, then `f` is a monomorphism. -/

end

end CategoryTheory.NormalEpiCategory