import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Notation
import Mathlib.Tactic.Linarith

set_option linter.unusedVariables false

class CatSystem (Cat : Type) :=
  [ decEq : DecidableEq Cat ]
  ( Func : Cat → Cat → Type )
  ( HasLAdj : ∀ {C D : Cat}, Func C D → Prop )
  [ decidableLAdj : ∀ (C D : Cat) (F : Func C D), Decidable (HasLAdj F) ]
  ( HasRAdj : ∀ {C D : Cat}, Func C D → Prop )
  [ decidableRAdj : ∀ (C D : Cat) (F : Func C D), Decidable (HasRAdj F) ]

/- We have a system of Categories -/
variable {Cat : Type} [CatSystem Cat]

attribute [instance] CatSystem.decEq CatSystem.decidableLAdj CatSystem.decidableRAdj

open CatSystem

--TODO : think about how adjoint preserve products.

mutual

inductive CoreprObj : Cat → Type
  | Coprod {C : Cat} (X Y : Obj C) : CoreprObj C
  | LAdj {C D : Cat} (F : Func C D) : HasLAdj F → Obj D → CoreprObj C
  | Bot : (C : Cat) → CoreprObj C

inductive ReprObj : Cat → Type
  | Prod {C : Cat} : Obj C → Obj C → ReprObj C
  | RAdj {C D : Cat} (F : Func C D) : HasRAdj F → Obj D → ReprObj C
  | Top : (C : Cat) → ReprObj C

inductive Obj : Cat → Type
  | Corepr : ∀ {C : Cat}, CoreprObj C → Obj C
  | Var : (C : Cat) → ℕ → Obj C
  | App : ∀ {C D : Cat}, Func C D → Obj C → Obj D
  | Repr : ∀ {C : Cat}, ReprObj C → Obj C

end

@[simp]
def Obj.size : ∀ {C : Cat} (X : Obj C), ℕ
  | _, Obj.Corepr (CoreprObj.Coprod X Y) => 1 + Obj.size X + Obj.size Y
  | _, Obj.Corepr (CoreprObj.LAdj F H X) => 2 + Obj.size X
  | _, Obj.Corepr (CoreprObj.Bot C) => 1
  | _, Obj.Var C n => 1
  | _, Obj.App F X => 1 + Obj.size X
  | _, Obj.Repr (ReprObj.Prod X Y) => 1 + Obj.size X + Obj.size Y
  | _, Obj.Repr (ReprObj.RAdj F H X) => 2 + Obj.size X
  | _, Obj.Repr (ReprObj.Top C) => 1

open Obj

@[match_pattern, simp]
nonrec def Obj.Coprod {C : Cat} (X Y : Obj C) : Obj C :=
  Corepr (CoreprObj.Coprod X Y)

@[match_pattern, simp]
nonrec def Obj.Prod {C : Cat} (X Y : Obj C) : Obj C :=
  Obj.Repr (ReprObj.Prod X Y)

@[match_pattern, simp]
nonrec def Obj.LAdj {C D : Cat} (F : Func C D) (H : HasLAdj F) (X : Obj D) : Obj C :=
  Corepr (CoreprObj.LAdj F H X)

@[match_pattern, simp]
nonrec def Obj.RAdj {C D : Cat} (F : Func C D) (H : HasRAdj F) (X : Obj D) : Obj C :=
  Obj.Repr (ReprObj.RAdj F H X)

@[match_pattern]
nonrec def Obj.Bot (C : Cat) : Obj C :=
  Corepr (CoreprObj.Bot C)

@[match_pattern]
nonrec def Obj.Top (C : Cat) : Obj C :=
  Obj.Repr (ReprObj.Top C)

inductive HomVar (C : Cat) : (X Y : ℕ) → Type
  | id : ∀ (X : ℕ), HomVar C X X
  | varComp {X Y Z : ℕ} (n : ℕ) (f : HomVar C Y Z) : HomVar C X Z
  deriving DecidableEq

def HomVar.comp {C : Cat} : ∀ {X Y Z : ℕ} (f : HomVar C X Y) (g : HomVar C Y Z), HomVar C X Z
  | _, _, _, HomVar.id _, f => f
  | _, _, _, HomVar.varComp n f, g => HomVar.varComp n (HomVar.comp f g)

inductive Emb : ∀ {C : Cat}, Obj C → Obj C → Type
  | inl : ∀ {X Y : Obj C}, Emb X (Coprod X Y)
  | inr : ∀ {X Y : Obj C}, Emb Y (Coprod X Y)
  | unit : ∀ {D : Cat} (F : Func D C) (H : HasLAdj F) {X : Obj C}, Emb X (App F (LAdj F H X))
  deriving DecidableEq

inductive Proj : ∀ {C : Cat}, Obj C → Obj C → Type
  | fst : ∀ {X Y : Obj C}, Proj (Prod X Y) X
  | snd : ∀ {X Y : Obj C}, Proj (Prod X Y) Y
  | counit : ∀ {D : Cat} (F : Func D C) (H : HasRAdj F) {X : Obj C},
      Proj (App F (RAdj F H X)) X
  deriving DecidableEq

theorem size_lt_of_emb {C : Cat} {X Y : Obj C} (f : Emb X Y) : Obj.size X < Obj.size Y := by
  cases f <;> simp [add_comm] <;> linarith

theorem size_lt_of_proj {C : Cat} {X Y : Obj C} (f : Proj X Y) : Obj.size Y < Obj.size X := by
  cases f <;> simp <;> linarith

mutual

/- Currently have no way of writing certain homs.
-- map F (corepr anything) ; counit : App F (Corepr _) -> App F (Radj F _ _)
-- map F (projComp (fst or snd)) ; counit : App F (X × _) -> App F (Radj F _ X) -/

inductive HomCorepr : {C : Cat} → CoreprObj C → Obj C → Type
  | coprod {C : Cat} {X Y Z : Obj C} (f : Hom X Z) (g : Hom Y Z) : HomCorepr (CoreprObj.Coprod X Y) Z
  | ladj {C D : Cat} (F : Func C D) (H : HasLAdj F) {X : Obj D} {Y : Obj C}
      (f : Hom X (App F Y)) : HomCorepr (CoreprObj.LAdj F H X) Y
  | botMk {C : Cat} {X : Obj C} : HomCorepr (CoreprObj.Bot C) X

inductive HomRepr : ∀ {C : Cat}, Obj C → ReprObj C → Type
  | prod {C : Cat} {X : Obj C} {Y Z : Obj C}
    (f : Hom X Y) (g : Hom X Z) : HomRepr X (ReprObj.Prod Y Z)
  | radj {C D : Cat} (F : Func C D) (H : HasRAdj F) {X : Obj C} {Y : Obj D}
    (f : Hom (App F X) Y) : HomRepr X (ReprObj.RAdj F H Y)
  | topMk {C : Cat} {X : Obj C} : HomRepr X (ReprObj.Top C)

inductive Hom : ∀ {C : Cat}, Obj C → Obj C → Type
  | projComp : ∀ {C : Cat} {X Y Z : Obj C} (f : Proj X Y) (g : Hom Y Z), Hom X Z
  | compEmb : ∀ {C : Cat} {X : Obj C} {Y Z : Obj C} (f : Hom X Y) (g : Emb Y Z), Hom X Z
  | corepr : ∀ {C : Cat} {X : CoreprObj C} {Y : Obj C} (f : HomCorepr X Y), Hom (Corepr X) Y
  | repr : ∀ {C : Cat} {X : Obj C} {Y : ReprObj C} (f : HomRepr X Y), Hom X (Repr Y)
  | map : ∀ {C D : Cat} {X Y : Obj C} (F : Func C D) (f : Hom X Y), Hom (App F X) (App F Y)
  | var : ∀ {C : Cat} {X Y : ℕ}, HomVar C X Y → Hom (Var C X) (Var C Y)

/-Provided LAdj is bigger than map, every Hom constructor make homs from homs between smaller objects.
By smaller I mean that -/

end

namespace Hom

def id : ∀ {C : Cat} {X : Obj C}, Hom X X
  | _, Obj.Var C X => Hom.var (HomVar.id _)
  | _, Obj.App F X => Hom.map F Hom.id
  | _, Obj.Repr (ReprObj.Prod X Y) => repr (HomRepr.prod (Hom.projComp Proj.fst Hom.id) (Hom.projComp Proj.snd Hom.id))
  | _, Obj.Repr (ReprObj.RAdj F H Y) => repr (HomRepr.radj F H (Hom.projComp (Proj.counit F H) Hom.id))
  | _, Obj.Repr (ReprObj.Top C) => repr HomRepr.topMk
  | _, Obj.Corepr (CoreprObj.Coprod X Y) => corepr (HomCorepr.coprod (Hom.compEmb Hom.id Emb.inl) (Hom.compEmb Hom.id Emb.inr))
  | _, Obj.Corepr (CoreprObj.LAdj F H X) => corepr (HomCorepr.ladj F H (Hom.compEmb Hom.id (Emb.unit F H)))
  | _, Obj.Corepr (CoreprObj.Bot C) => corepr HomCorepr.botMk

def ofEmb {C : Cat} {X Y : Obj C} (f : Emb X Y) : Hom X Y :=
  compEmb Hom.id f

def ofProj {C : Cat} {X Y : Obj C} (f : Proj X Y) : Hom X Y :=
  projComp f Hom.id

def inl {C : Cat} {X Y : Obj C} : Hom X (Coprod X Y) :=
  ofEmb Emb.inl

def inr {C : Cat} {X Y : Obj C} : Hom Y (Coprod X Y) :=
  ofEmb Emb.inr

def unit {C : Cat} {D : Cat} (F : Func C D) (H : HasLAdj F) {X : Obj D} : Hom X (App F (LAdj F H X)) :=
  ofEmb (Emb.unit F H)

def fst {C : Cat} {X Y : Obj C} : Hom (Prod X Y) X :=
  ofProj Proj.fst

def snd {C : Cat} {X Y : Obj C} : Hom (Prod X Y) Y :=
  ofProj Proj.snd

def counit {C : Cat} {D : Cat} (F : Func C D) (H : HasRAdj F) {X : Obj D} : Hom (App F (RAdj F H X)) X :=
  ofProj (Proj.counit F H)

@[match_pattern]
def botMk {C : Cat} {X : Obj C} : Hom (Bot C) X :=
  corepr HomCorepr.botMk

@[match_pattern]
def topMk {C : Cat} {X : Obj C} : Hom X (Top C) :=
  repr HomRepr.topMk

@[match_pattern]
def coprod {C : Cat} {X Y Z : Obj C} (f : Hom X Z) (g : Hom Y Z) : Hom (Coprod X Y) Z :=
  corepr (HomCorepr.coprod f g)

@[match_pattern]
def prod {C : Cat} {X Y Z : Obj C} (f : Hom X Y) (g : Hom X Z) : Hom X (Prod Y Z) :=
  repr (HomRepr.prod f g)

@[match_pattern]
def radj {C : Cat} {D : Cat} (F : Func C D) (H : HasRAdj F) {X : Obj C} {Y : Obj D} (f : Hom (App F X) Y) : Hom X (RAdj F H Y) :=
  repr (HomRepr.radj F H f)

@[match_pattern]
def ladj {C : Cat} {D : Cat} (F : Func C D) (H : HasLAdj F) {X : Obj C} {Y : Obj D} (f : Hom Y (App F X)) : Hom (LAdj F H Y) X :=
  corepr (HomCorepr.ladj F H f)

mutual

def coreprComp : ∀ {C : Cat} {X : CoreprObj C} {Y Z : Obj C}, HomCorepr X Y → Hom Y Z → HomCorepr X Z
  | _, _, _, _, HomCorepr.coprod f g, h => HomCorepr.coprod (comp f h) (comp g h)
  | _, _, _, _, HomCorepr.ladj F H f, g => HomCorepr.ladj _ _ (comp f (Hom.map F g))
  | _, _, _, _, HomCorepr.botMk, _ => HomCorepr.botMk

def compRepr : ∀ {C : Cat} {X Y : Obj C} {Z : ReprObj C}, Hom X Y → HomRepr Y Z → HomRepr X Z
  | _, _, _, _, f, HomRepr.prod g h => HomRepr.prod (comp f g) (comp f h)
  | _, _, _, _, f, HomRepr.radj F H g => HomRepr.radj _ _ (comp (Hom.map F f) g)
  | _, _, _, _, _, HomRepr.topMk => HomRepr.topMk

def comp : ∀ {C : Cat} {X Y Z : Obj C}, Hom X Y → Hom Y Z → Hom X Z
  | _, _, _, _, Hom.corepr f, g => corepr (coreprComp f g)
  | _, _, _, _, f, Hom.repr g => repr (compRepr f g)
  | _, W, Y, Z, Hom.projComp (Y := X) f g, h =>
    have : size X + size Z < size W + size Z :=
      by linarith [size_lt_of_proj f]
    Hom.projComp f (comp g h)
  | _, W, X, Z, f, Hom.compEmb (Y := Y) g h =>
    have : size W + size Y < size W + size Z :=
      by linarith [size_lt_of_emb h]
    compEmb (f.comp g) h
  | _, _, _, _, prod f g, projComp Proj.fst h => comp f h
  | _, W, Obj.Prod X Y, Z, prod f g, projComp Proj.snd h =>
    have : size Y < 1 + size X + size Y := by linarith
    comp g h
  | _, _, _, _, compEmb f Emb.inl, coprod g h => f.comp g
  | _, W, Obj.Coprod X Y, Z, compEmb f Emb.inr, coprod g h =>
    have : size Y < 1 + size X + size Y := by linarith
    f.comp h
  | _, _, _, _, var f, var g => var (HomVar.comp f g)
  | _, _, _, _, map F f, map _ g => map _ (comp f g)
  | _, _, _, _, map _ (projComp _ _), projComp (Proj.counit _ _) _ => sorry  --New constructor
  | _, _, _, _, map _ (Hom.repr (HomRepr.radj _ _ f)), projComp (Proj.counit _ _) g => f.comp g
  | _, _, _, _, map _ (Hom.corepr HomCorepr.botMk), projComp (Proj.counit _ _) _ => sorry --Things must preserve coproducts in a stronger way.
  | _, _, _, _, map G (Hom.corepr (HomCorepr.ladj F H f)), projComp (Proj.counit _ _) g => sorry --New constructor
  | _, _, _, _, _, _ => sorry

end
termination_by comp C X Y Z f g => (size X + size Z, size Y, 1)
               coreprComp C X Y Z f g => (size (Corepr X) + size Z, size Y, 0)
               compRepr C X Y Z f g => (size X + size (Repr Z), size Y, 0)

def LAdjSymm {C D : Cat} (F : Func C D) (H : HasLAdj F) {X : Obj D} {Y : Obj C}
    (f : Hom (Obj.LAdj F H X) Y) : Hom X (App F Y) :=
  Hom.comp (Hom.compEmb Hom.id (Emb.unit _ H)) (map F f)

def RAdjSymm {C D : Cat} (F : Func C D) (H : HasRAdj F) {X : Obj C} {Y : Obj D}
    (f : Hom X (Obj.RAdj F H Y)) : Hom (App F X) Y :=
  Hom.comp (map F f) (Hom.projComp (Proj.counit _ H) Hom.id)

def ladjMap {C D : Cat} (F : Func C D) (H : HasLAdj F) {X Y : Obj D} (f : Hom X Y) :
    Hom (LAdj F H X) (LAdj F H Y) :=
  ladj _ _ (comp f (unit _ _))

def radjMap {C D : Cat} (F : Func C D) (H : HasRAdj F) {X Y : Obj D} (f : Hom X Y) :
    Hom (RAdj F H X) (RAdj F H Y) :=
  radj _ _ (comp (counit _ _) f)

def ladjPreserveBot {C D : Cat} (F : Func C D) (H : HasLAdj F) : Hom (LAdj F H (Obj.Bot _)) (Obj.Bot _) :=
  ladj _ _ botMk

def radjPreserveTop {C D : Cat} (F : Func C D) (H : HasRAdj F) : Hom (Obj.Top _) (RAdj F H (Obj.Top _)) :=
  radj _ _ topMk

def ladjPreserveCoprod {C D : Cat} (F : Func C D) (H : HasLAdj F) {X Y : Obj D} :
    Hom (LAdj F H (Obj.Coprod X Y)) (Obj.Coprod (LAdj F H X) (LAdj F H Y)) :=
  ladj _ _ (coprod (LAdjSymm _ H inl) (LAdjSymm _ H inr))

def ladjPreserveCoprodSymm {C D : Cat} (F : Func C D) (H : HasLAdj F) {X Y : Obj D} :
    Hom (Obj.Coprod (LAdj F H X) (LAdj F H Y)) (LAdj F H (Obj.Coprod X Y)) :=
  coprod (ladj _ _ (comp (unit F H) (map F (ladjMap _ _ inl))))
         (ladj _ _ (comp (unit F H) (map F (ladjMap _ _ inr))))

def radjPreserveProd {C D : Cat} (F : Func C D) (H : HasRAdj F) {X Y : Obj D} :
    Hom (Obj.Prod (RAdj F H X) (RAdj F H Y)) (RAdj F H (Obj.Prod X Y)) :=
  radj _ _ (prod (RAdjSymm _ H fst) (RAdjSymm _ H snd))

def radjPreserveProdSymm {C D : Cat} (F : Func C D) (H : HasRAdj F) {X Y : Obj D} :
    Hom (RAdj F H (Obj.Prod X Y)) (Obj.Prod (RAdj F H X) (RAdj F H Y)) :=
  prod (radj _ _ (comp (map F (radjMap _ _ fst)) (counit F H)))
       (radj _ _ (comp (map F (radjMap _ _ snd)) (counit F H)))

def preserveBotOfHasRAdj {C D : Cat} (F : Func C D) (H : HasRAdj F) :
    Hom (App F (Obj.Bot _)) (Obj.Bot _):=
  RAdjSymm _ H botMk

def preserveTopOfHasLAdj {C D : Cat} (F : Func C D) (H : HasLAdj F) :
    Hom (Obj.Top _) (App F (Obj.Top _)) :=
  LAdjSymm _ H topMk

def preserveCoprodOfHasRAdj {C D : Cat} (F : Func C D) (H : HasRAdj F) {X Y : Obj C} :
    Hom (App F (Obj.Coprod X Y)) (Obj.Coprod (App F X) (App F Y)) :=
  RAdjSymm _ H (coprod (radj _ _ inl) (radj _ _ inr))

def preserveCoprodOfHasRAdjSymm {C D : Cat} (F : Func C D) (H : HasRAdj F) {X Y : Obj C} :
    Hom (Obj.Coprod (App F X) (App F Y)) (App F (Obj.Coprod X Y)) :=
  coprod (map F inl) (map F inr)

def preserveProdOfHasLAdj {C D : Cat} (F : Func C D) (H : HasLAdj F) {X Y : Obj C} :
    Hom (Obj.Prod (App F X) (App F Y)) (App F (Obj.Prod X Y)) :=
  LAdjSymm _ H (prod (ladj _ _ fst) (ladj _ _ snd))

def preserveProdOfHasLAdjSymm {C D : Cat} (F : Func C D) (H : HasLAdj F) {X Y : Obj C} :
    Hom (App F (Obj.Prod X Y)) (Obj.Prod (App F X) (App F Y)) :=
  prod (map F fst) (map F snd)

section

def asCorepr : ∀ {C : Cat} {X : CoreprObj C} {Y : Obj C}, Hom (Corepr X) Y → HomCorepr X Y
  | _, _, _, Hom.corepr f => f
  | _, CoreprObj.Bot _, _, _ => HomCorepr.botMk
  | _, CoreprObj.Coprod X Y, _, f => HomCorepr.coprod (comp (ofEmb Emb.inl) f) (comp (ofEmb Emb.inr) f)
  | _, CoreprObj.LAdj F H X, _, f => HomCorepr.ladj _ _ (comp (ofEmb (Emb.unit F H)) (map F f))

def asRepr : ∀ {C : Cat} {X : Obj C} {Y : ReprObj C}, Hom X (Repr Y) → HomRepr X Y
  | _, _, _, Hom.repr f => f
  | _, _, ReprObj.Prod X Y, f => HomRepr.prod (comp f (ofProj Proj.fst)) (comp f (ofProj Proj.snd))
  | _, _, ReprObj.RAdj F H X, f => HomRepr.radj _ _ (comp (map F f) (ofProj (Proj.counit F H)))
  | _, _, ReprObj.Top _, _ => HomRepr.topMk

end

instance : ∀ C : Cat, DecidableEq (Obj C) := sorry
instance : ∀ C : Cat, DecidableEq (CoreprObj C) := sorry
instance : ∀ C : Cat, DecidableEq (ReprObj C) := sorry
instance : ∀ C : Cat, ∀ X Y : Obj C, DecidableEq (Hom X Y) := sorry
instance : ∀ C : Cat, ∀ X : CoreprObj C, ∀ Y : Obj C, DecidableEq (HomCorepr X Y) := sorry
instance : ∀ C : Cat, ∀ X : Obj C, ∀ Y : ReprObj C, DecidableEq (HomRepr X Y) := sorry

mutual

/-
Normal forms
- If it can be written as `f ; corepr g` then it is unless the first rule applies. What if there are two different ways of doing this?,
    Try to make sure `f` is not of that form
    Also `corepr g` should remain a subterm after `f` and `corepr g` are composed and cut eliminated.
- If it can be written as `repr_mk ; f` then it is unless the first rule applies.
- Not sure what else there is, just associativity of `projComp` and `compEmb`
-/

/-
Questions: What is shrinking? I have to make sure that everything splits into smaller homs.
I decided to do products before LAdj. Why? I don't think this applies if I insist on objects shrinking.

-/

open Hom

def getCompCorepr :
    ∀ {C : Cat} {X Y : Obj C} (f : Hom X Y),
      Option (Σ R : CoreprObj C, Hom X (Corepr R) × HomCorepr R Y × Bool)
      --Bool is true if the `Hom X (Corepr R)` is the identity
  | _, Corepr R, _, f => some ⟨_, Hom.id, asCorepr f, true⟩
  | _, _, _, var _ => none
  | _, _, _, topMk => none
  | _, _, _, Hom.repr (HomRepr.radj F H f) => none
  | _, _, _, map F f => none
  | _, _, _, projComp f g =>
    match getCompCorepr g with
    | none => none
    | some ⟨R, g, h, _⟩ => some ⟨R, projComp f g , h, false⟩
  | _, _, _, compEmb f h =>
    match getCompCorepr f with
    | none => none
    | some ⟨R, f, g, _⟩ => some ⟨R, f, coreprComp g (ofEmb h), false⟩
  | _, _, _, Hom.repr (HomRepr.prod f g) =>
    match getCompCorepr f, getCompCorepr g with
    | some ⟨R₁, f₁, f₂, _⟩, some ⟨R₂, g₁, g₂, _⟩ =>
        let nf := normalize f₁
        let ng := normalize g₁
        if hr : R₁ = R₂
          then if (hr ▸ nf) = ng
            then by
              subst R₁
              match R₂, nf, f₂, g₂ with
              | _, nf, HomCorepr.coprod f₂ f₃, HomCorepr.coprod g₂ g₃ =>
                exact some ⟨_, nf, HomCorepr.coprod (prod f₂ g₂) (prod f₃ g₃), false⟩
              | _, nf, HomCorepr.botMk, HomCorepr.botMk => exact some ⟨_, nf, HomCorepr.botMk, false⟩
              | _, nf, HomCorepr.ladj _ _ _, _ => exact none
            else none
        else none
    | _, _ => none

def getReprComp :
    ∀ {C : Cat} {X Y : Obj C} (f : Hom X Y), Option (Σ R : ReprObj C, HomRepr X R × Hom (Repr R) Y × Bool)
  | _, Corepr R, _, f => none
  | _, _, Obj.Repr R, f => some ⟨_, asRepr f, Hom.id, true⟩
  | _, _, _, var _ => none
  | _, _, _, map F f => none
  | _, _, _, projComp f g =>
    match getReprComp g with
    | none => none
    | some ⟨R, g, h, _⟩ => some ⟨R, compRepr (ofProj f) g, h, false⟩
  | _, _, _, compEmb f h =>
    match getReprComp f with
    | none => none
    | some ⟨R, f, g, _⟩ => some ⟨R, f, compEmb g h, false⟩

def normalizeCorepr : ∀ {C : Cat} {X : CoreprObj C} {Y : Obj C} (f : HomCorepr X Y),
    HomCorepr X Y
  | _, _, _, HomCorepr.coprod f g => HomCorepr.coprod (normalize f) (normalize g)
  | _, _, _, HomCorepr.botMk => HomCorepr.botMk
  | _, _, _, HomCorepr.ladj F H f => HomCorepr.ladj F H (normalize f)

def normalizeRepr : ∀ {C : Cat} {X : Obj C} {Y : ReprObj C} (f : HomRepr X Y),
    HomRepr X Y
  | _, _, _, HomRepr.radj F H f => HomRepr.radj F H (normalize f)
  | _, _, _, HomRepr.prod f g => HomRepr.prod (normalize f) (normalize g)
  | _, _, _, HomRepr.topMk => HomRepr.topMk

def normalize {C : Cat} {X Y : Obj C} (f : Hom X Y) : Hom X Y :=
  match getCompCorepr f with
  | none =>
    match getReprComp f with
    | none =>

end

end Hom


namespace ex
open tactic

constant typ : Type

constant subtype : typ → typ → Prop

constant subtype_refl : ∀ T, subtype T T

constant subtype_trans : ∀ S T U, subtype S T → subtype T U → subtype S U

attribute [intro] subtype_refl subtype_trans

lemma L1 : ∀ T1 T2 T3 T4, subtype T1 T2 → subtype T2 T3 → subtype T3 T4 → subtype T1 T4 :=
by (intros >> back_chaining_using_hs)

lemma L2 : ∀ T1 T2 T3 T4, subtype T1 T2 → subtype T2 T3 → subtype T3 T4 → subtype T1 T4 :=
by do
  intros,
  ctx ← local_context,
  -- using pre tactic to trace execution
  back_chaining_core (trace "pre tac:" >> trace_state >> trace "-------") failed ctx

set_option back_chaining.max_depth 10
set_option trace.tactic.back_chaining true

lemma L3 : ∀ T1 T2 T3 T4 T5 T6 (H1 :subtype T1 T2) (H2 : subtype T2 T3) (H3 : subtype T3 T4) (H3 : subtype T4 T5) (H4 : subtype T5 T6), subtype T1 T6 :=
by (intros >> back_chaining_using_hs)

end ex


import data.int.basic

namespace tactic.interactive

open tactic

lemma translate_nat (P : ℤ → Sort*) (h : ∀ i : ℤ, i ≥ 0 → P i) :
  ∀ i : ℕ, P i :=
assume i,
h i (int.coe_nat_nonneg i)

run_cmd mk_simp_attr `to_int

@[to_int]
lemma coe_nat_inj {m n : ℕ} : m = n ↔ (↑m : ℤ) = ↑n := by rw int.coe_nat_inj'

@[to_int]
lemma coe_nat_le {m n : ℕ} : m ≤ n ↔ (↑m : ℤ) ≤ ↑n := by rw int.coe_nat_le

@[to_int]
lemma coe_nat_lt {m n : ℕ} : m < n ↔ (↑m : ℤ) < ↑n := by rw int.coe_nat_lt

@[to_int]
lemma coe_nat_ge {m n : ℕ} : m ≥ n ↔ (↑m : ℤ) ≥ ↑n := coe_nat_le

@[to_int]
lemma coe_nat_gt {m n : ℕ} : m > n ↔ (↑m : ℤ) > ↑n := coe_nat_lt

@[to_int]
theorem coe_nat_dvd {m n : ℕ} : m ∣ n ↔ (↑m : ℤ) ∣ ↑n := by rw int.coe_nat_dvd

@[to_int]
theorem coe_bit0 {m : ℕ} : ↑ (bit0 m) = bit0 (↑m : ℤ) := by simp [bit0]

@[to_int]
theorem coe_bit1 {m : ℕ} : ↑ (bit1 m) = bit1 (↑m : ℤ) := by simp [bit1,bit0]

attribute [to_int] int.coe_nat_mod
  int.bit_coe_nat
  int.coe_nat_add int.coe_nat_mul
  int.coe_nat_sub
  int.coe_nat_zero
  int.coe_nat_one

meta def to_int : tactic unit :=
do `[simp only with to_int at *],
   ls ← local_context,
   ls ← ls.mfilter $ λ a,
     succeeds $ infer_type a >>= is_def_eq `(nat),
   ls ← ls.mmap $ λ v,
     do { tactic.revert v <*
          do e ← target,
             ((p,l),_) ← solve_aux e $ do {
               v ← intro1,
               p ← to_expr ``(↑ %%v : int),
               tactic.generalize p,
               (expr.pi n bi b d) ← target,
               pure (p,expr.lam n bi b d) } ,
             refine ``(translate_nat %%l _),
             intro v.local_pp_name,
             target >>= head_beta >>= unsafe_change,
             tactic.intro $ mk_simple_name $ to_string v.local_pp_name ++ "_nneg" },
   ls.reverse.mmap' $ λ i,
     do intron (i - 1),
        pure ()

end tactic.interactive


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

import number_theory.cyclotomic.primitive_roots
import ring_theory.polynomial.cyclotomic.eval

noncomputable theory

open_locale big_operators non_zero_divisors number_field
open number_field polynomial finset module units submodule

universe variables u v w z

variables (n : ℕ+) (K : Type u) (L : Type v) (A : Type w) (B : Type z)
variables [comm_ring A] [comm_ring B] [algebra A B]
variables [field K] [field L] [algebra K L]

namespace is_primitive_root

variable {B}

variable (B)

end is_primitive_root

namespace is_cyclotomic_extension

variables [is_cyclotomic_extension {n} A B]

variables [is_domain A] [algebra A K] [is_fraction_ring A K]

open is_cyclotomic_extension

open is_cyclotomic_extension

section cyclotomic_unit

variable {n}

namespace cyclotomic_unit

-- I don't want to bother Leo, but I wonder if this can be automated in Lean4
-- (if they were 0 < n → 1 < n, it would work already!)
lemma _root_.nat.one_lt_of_ne : ∀ n : ℕ, n ≠ 0 → n ≠ 1 → 1 < n
| 0 h _ := absurd rfl h
| 1 _ h := absurd rfl h
| (n+2) _ _ := n.one_lt_succ_succ

-- this result holds for all primitive roots; dah.
lemma associated_one_sub_pow_primitive_root_of_coprime {n j k : ℕ} {ζ : A}
  (hζ : is_primitive_root ζ n) (hk : k.coprime n) (hj : j.coprime n) :
  associated (1 - ζ ^ j) (1 - ζ ^ k) :=
begin
  suffices : ∀ {j : ℕ}, j.coprime n → associated (1 - ζ) (1 - ζ ^ j),
  { exact (this hj).symm.trans (this hk) },
  clear' k j hk hj,
  refine λ j hj, associated_of_dvd_dvd ⟨∑ i in range j, ζ ^ i,
    by rw [← geom_sum_mul_neg, mul_comm]⟩ _,
  -- is there an easier way to do this?
  rcases eq_or_ne n 0 with rfl | hn',
  { simp [j.coprime_zero_right.mp hj] },
  rcases eq_or_ne n 1 with rfl | hn,
  { simp [is_primitive_root.one_right_iff.mp hζ] },
  replace hn := n.one_lt_of_ne hn' hn,
  obtain ⟨m, hm⟩ := nat.exists_mul_mod_eq_one_of_coprime hj hn,
  use (∑ i in range m, (ζ ^ j) ^ i),
  have : ζ = (ζ ^ j) ^ m,
  { rw [←pow_mul, pow_eq_mod_order_of, ←hζ.eq_order_of, hm, pow_one] },
  nth_rewrite 0 this,
  rw [← geom_sum_mul_neg, mul_comm]
end

lemma is_primitive_root.sum_pow_unit {n k : ℕ} {ζ : A} (hn : 2 ≤ n) (hk : k.coprime n)
(hζ : is_primitive_root ζ n) : is_unit (∑ (i : ℕ) in range k, ζ^(i : ℕ)) :=
begin
  have h1 : (1 : ℕ).coprime n, by {exact nat.coprime_one_left n, },
  have := associated_one_sub_pow_primitive_root_of_coprime _ hζ hk h1,
  simp at this,
  rw associated at this,
  have h2 := mul_neg_geom_sum ζ k,
  obtain ⟨u, hu⟩ := this,
  have := u.is_unit,
  convert this,
  rw ←hu at h2,
  simp at h2,
  cases h2,
  exact h2,
  exfalso,
  have hn1 : 1 < n, by {linarith},
  have  hp := is_primitive_root.pow_ne_one_of_pos_of_lt hζ one_pos hn1,
  simp at *,
  rw sub_eq_zero at h2,
  rw ←h2 at hp,
  simp only [eq_self_iff_true, not_true] at hp,
  exact hp,
end

lemma is_primitive_root.zeta_pow_sub_eq_unit_zeta_sub_one {p i j : ℕ} {ζ : A} (hn : 2 ≤ p) (hp : p.prime )
  (hi : i < p) (hj : j < p) (hij : i ≠ j) (hζ : is_primitive_root ζ p) :
  ∃ (u : Aˣ), (ζ^i - ζ^j ) = u * (1- ζ) :=
begin
  by_cases hilj : j < i,
  have h1 : (ζ^i - ζ^j) = ζ^j * (ζ^(i-j)-1), by {ring_exp, rw pow_mul_pow_sub _ hilj.le,
    rw add_comm,},
  rw h1,
  have h2 := mul_neg_geom_sum ζ (i-j),
  have hic : (i-j).coprime p, by {rw nat.coprime_comm, apply nat.coprime_of_lt_prime _ _ hp,
    apply nat.sub_pos_of_lt hilj,
    by_cases hj : 0 < j,
    apply lt_trans _ hi,
    apply nat.sub_lt_of_pos_le _ _ hj hilj.le,
    simp only [not_lt, _root_.le_zero_iff] at hj,
    rw hj,
    simp only [tsub_zero],
    exact hi,},
  have h3 : is_unit (-(ζ^(j))*(∑ (k : ℕ) in range (i-j), ζ^(k : ℕ))),
    by {apply is_unit.mul _ (is_primitive_root.sum_pow_unit _ hn hic hζ), apply is_unit.neg,
      apply is_unit.pow, apply hζ.is_unit hp.pos,  },
  obtain ⟨v, hv⟩ := h3,
  use v,
  rw hv,
  rw mul_comm at h2,
  rw mul_assoc,
  rw h2,
  ring,
  simp at *,
  have h1 : (ζ^i - ζ^j) = ζ^i * (1-ζ^(j-i)), by {ring_exp, simp, rw pow_mul_pow_sub _ hilj,},
  rw h1,
  have h2 := mul_neg_geom_sum ζ (j-i),
  have hjc : (j-i).coprime p, by {rw nat.coprime_comm,
    apply nat.coprime_of_lt_prime _ _ hp,
    have hilj' : i < j, by {rw lt_iff_le_and_ne, simp [hij, hilj], },
    apply nat.sub_pos_of_lt hilj',
    by_cases hii : 0 < i,
    apply lt_trans _ hj,
    apply nat.sub_lt_of_pos_le _ _ hii hilj,
    simp only [not_lt, _root_.le_zero_iff] at hii,
    rw hii,
    simp only [tsub_zero],
    exact hj,
  },
  have h3 : is_unit ((ζ^(i))*(∑ (k : ℕ) in range (j-i), ζ^(k : ℕ))), by {
    apply is_unit.mul _ (is_primitive_root.sum_pow_unit _ hn hjc hζ), apply is_unit.pow,
    apply hζ.is_unit hp.pos,},
   obtain ⟨v, hv⟩ := h3,
  use v,
  rw hv,
  rw mul_comm at h2,
  rw mul_assoc,
  rw h2,

end

/-
def unitlem2 {n k : ℕ} {ζ : A} (hk : nat.coprime n k)
(hζ : is_primitive_root ζ n) : Aˣ :=
{ val := (∑ (i : finset.range k), ζ^(i : ℕ)),
  inv := (ζ-1)  ,
  val_inv := admit,
  inv_val := admit,

}

variable (n)

instance : is_localization ((ring_of_integers (cyclotomic_field n K)))⁰ (cyclotomic_field n K) :=
admit

lemma prime_ideal_eq_pow_cyclotomic [hn : fact ((n : ℕ).prime)] :
  (span_singleton _ n : fractional_ideal RR⁰ L) =
  (span_singleton _ (1 - (zeta_runity n K L)) ^ ((n : ℕ) - 1) : fractional_ideal RR⁰ L) :=
  --(mk0 (p : cyclotomic_field p) (by norm_num [hn.ne_zero]))
begin
  rw fractional_ideal.span_singleton_pow,
  apply coe_to_submodule_injective,
  simp only [coe_span_singleton, coe_coe],
  -- rw ideal.span_singleton_eq_span_singleton,
  simp only [submodule.span_singleton_eq_span_singleton],
  rw ← eval_one_cyclotomic_prime,
  --rw calc
  --  eval 1 (cyclotomic n (cyclotomic_field n)) = _ : by simp_rw
  --    cyclotomic_eq_prod_X_sub_primitive_roots (zeta_primitive_root n _)
  --                      ... = _ : by simp only [polynomial.eval_sub, polynomial.eval_C,
  --                                  polynomial.eval_prod, polynomial.eval_X],

  -- apply span_singleton_eq_span_singleton_,
  admit,
end -/

end cyclotomic_unit

end cyclotomic_unit

end is_cyclotomic_extension


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

Instances for identity and composition functors
-/
import control.functor
import algebra.group.basic

universe variables u v w

section lemmas

open function

variables {F : Type u → Type v}
variables [applicative F] [is_lawful_applicative F]
variables {α β γ σ : Type u}

lemma applicative.map_seq_map (f : α → β → γ) (g : σ → β) (x : F α) (y : F σ) :
  (f <$> x) <*> (g <$> y) = (flip (∘) g ∘ f) <$> x <*> y :=
by simp [flip] with functor_norm

lemma applicative.pure_seq_eq_map' (f : α → β) :
  (<*>) (pure f : F (α → β)) = (<$>) f :=
by ext; simp with functor_norm

theorem applicative.ext {F} : ∀ {A1 : applicative F} {A2 : applicative F}
  [@is_lawful_applicative F A1] [@is_lawful_applicative F A2]
  (H1 : ∀ {α : Type u} (x : α),
    @has_pure.pure _ A1.to_has_pure _ x = @has_pure.pure _ A2.to_has_pure _ x)
  (H2 : ∀ {α β : Type u} (f : F (α → β)) (x : F α),
    @has_seq.seq _ A1.to_has_seq _ _ f x = @has_seq.seq _ A2.to_has_seq _ _ f x),
  A1 = A2
| {to_functor := F1, seq := s1, pure := p1, seq_left := sl1, seq_right := sr1}
  {to_functor := F2, seq := s2, pure := p2, seq_left := sl2, seq_right := sr2} L1 L2 H1 H2 :=
begin
  have : @p1 = @p2, {funext α x, apply H1}, subst this,
  have : @s1 = @s2, {funext α β f x, apply H2}, subst this,
  cases L1, cases L2,
  have : F1 = F2,
  { resetI, apply functor.ext, intros,
    exact (L1_pure_seq_eq_map _ _).symm.trans (L2_pure_seq_eq_map _ _) },
  subst this,
  congr; funext α β x y,
  { exact (L1_seq_left_eq _ _).trans (L2_seq_left_eq _ _).symm },
  { exact (L1_seq_right_eq _ _).trans (L2_seq_right_eq _ _).symm }
end

end lemmas

instance : is_comm_applicative id :=
by refine { .. }; intros; refl

namespace functor
namespace comp

open function (hiding comp)
open functor

variables {F : Type u → Type w} {G : Type v → Type u}

variables [applicative F] [applicative G]

variables [is_lawful_applicative F] [is_lawful_applicative G]
variables {α β γ : Type v}

lemma map_pure (f : α → β) (x : α) : (f <$> pure x : comp F G β) = pure (f x) :=
comp.ext $ by simp

lemma seq_pure (f : comp F G (α → β)) (x : α) :
  f <*> pure x = (λ g : α → β, g x) <$> f :=
comp.ext $ by simp [(∘)] with functor_norm

lemma pure_seq_eq_map (f : α → β) (x : comp F G α) :
  pure f <*> x = f <$> x :=
comp.ext $ by simp [applicative.pure_seq_eq_map'] with functor_norm

instance : is_lawful_applicative (comp F G) :=
{ pure_seq_eq_map := @comp.pure_seq_eq_map F G _ _ _ _,
  map_pure := @comp.map_pure F G _ _ _ _,
  seq_pure := @comp.seq_pure F G _ _ _ _,
  seq_assoc := @comp.seq_assoc F G _ _ _ _ }

theorem applicative_id_comp {F} [AF : applicative F] [LF : is_lawful_applicative F] :
  @comp.applicative id F _ _ = AF :=
@applicative.ext F _ _ (@comp.is_lawful_applicative id F _ _ _ _) _
  (λ α x, rfl) (λ α β f x, rfl)

theorem applicative_comp_id {F} [AF : applicative F] [LF : is_lawful_applicative F] :
  @comp.applicative F id _ _ = AF :=
@applicative.ext F _ _ (@comp.is_lawful_applicative F id _ _ _ _) _
  (λ α x, rfl) (λ α β f x, show id <$> f <*> x = f <*> x, by rw id_map)

open is_comm_applicative

instance {f : Type u → Type w} {g : Type v → Type u}
  [applicative f] [applicative g]
  [is_comm_applicative f] [is_comm_applicative g] :
  is_comm_applicative (comp f g) :=
by { refine { .. @comp.is_lawful_applicative f g _ _ _ _, .. },
     intros, casesm* comp _ _ _, simp! [map,has_seq.seq] with functor_norm,
     rw [commutative_map],
     simp [comp.mk,flip,(∘)] with functor_norm,
     congr, funext, rw [commutative_map], congr }

end comp
end functor

open functor

@[functor_norm]
lemma comp.seq_mk {α β : Type w}
  {f : Type u → Type v} {g : Type w → Type u}
  [applicative f] [applicative g]
  (h : f (g (α → β))) (x : f (g α)) :
  comp.mk h <*> comp.mk x = comp.mk (has_seq.seq <$> h <*> x) := rfl

instance {α} [has_one α] [has_mul α] : applicative (const α) :=
{ pure := λ β x, (1 : α),
  seq := λ β γ f x, (f * x : α) }

instance {α} [monoid α] : is_lawful_applicative (const α) :=
by refine { .. }; intros; simp [mul_assoc, (<$>), (<*>), pure]

instance {α} [has_zero α] [has_add α] : applicative (add_const α) :=
{ pure := λ β x, (0 : α),
  seq := λ β γ f x, (f + x : α) }

instance {α} [add_monoid α] : is_lawful_applicative (add_const α) :=
by refine { .. }; intros; simp [add_assoc, (<$>), (<*>), pure]


import .pair
import .precofibration_category

noncomputable theory

namespace homotopy_theory.topological_spaces
open homotopy_theory.cylinder

-- (Provisional?) inductive definition of the disk/sphere pair using cubes.
def unit_pair : pair := pair.mk (*) ∅
def disk_sphere_pair (n : ℕ) : pair := nat.rec unit_pair (λ _ P, pair.prod P I_01) n

def disk (n : ℕ) : Top := (disk_sphere_pair n).space
def sphere_minus_one (n : ℕ) : Top := (disk_sphere_pair n).subspace
notation `D[` n `]` := disk n
notation `S[` n `-1]` := sphere_minus_one n
def sphere_disk_incl (n : ℕ) : S[n-1] ⟶ D[n] := pair.incl _

-- It's a cofibration.
lemma sphere_disk_closed : ∀ n, is_closed (disk_sphere_pair n).subset
| 0 := is_closed_empty
| (n+1) := pair.prod.is_closed (sphere_disk_closed n) I_01.is_closed

lemma sphere_disk_cofibered : ∀ n, (disk_sphere_pair n).cofibered
| 0 := pair.empty_cofibered _
| (n+1) := prod_I_01_cofibered _ (sphere_disk_closed n) (sphere_disk_cofibered n)

lemma sphere_disk_cofibration (n : ℕ) : closed_cofibration (sphere_disk_incl n) :=
closed_cofibration_incl_iff.mpr ⟨sphere_disk_cofibered n, sphere_disk_closed n⟩

end homotopy_theory.topological_spaces


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

The Kleisli construction on the Type category
-/
import category_theory.category

universes u v

namespace category_theory

def Kleisli (m) [monad.{u v} m] := Type u

def Kleisli.mk (m) [monad.{u v} m] (α : Type u) : Kleisli m := α

instance Kleisli.category_struct {m} [monad m] : category_struct (Kleisli m) :=
{ hom := λ α β, α → m β,
  id := λ α x, (pure x : m α),
  comp := λ X Y Z f g, f >=> g }

instance Kleisli.category {m} [monad m] [is_lawful_monad m] : category (Kleisli m) :=
by refine { hom := λ α β, α → m β,
            id := λ α x, (pure x : m α),
            comp := λ X Y Z f g, f >=> g,
            id_comp' := _, comp_id' := _, assoc' := _ };
   intros; ext; simp only [(>=>)] with functor_norm

@[simp] lemma Kleisli.id_def {m} [monad m] [is_lawful_monad m] (α : Kleisli m) :
  𝟙 α = @pure m _ α := rfl

lemma Kleisli.comp_def {m} [monad m] [is_lawful_monad m] (α β γ : Kleisli m)
  (xs : α ⟶ β) (ys : β ⟶ γ) (a : α) :
  (xs ≫ ys) a = xs a >>= ys := rfl

end category_theory


import topology.discrete_quotient
import topology.category.Profinite
import category_theory.arrow
import data.setoid.partition

import for_mathlib.Profinite.quotient_map

open category_theory

namespace discrete_quotient

universe u
variables {X Y : Profinite.{u}} (f : X ⟶ Y) (surj : function.surjective f)

/-- The relation defining the largest quotient of f.right compatible with S. -/
inductive make_rel (S : discrete_quotient X) : Y → Y → Prop
| of (x y : X) (h : S.rel x y) : make_rel (f x) (f y)
| trans {x y z : Y} : make_rel x y → make_rel y z → make_rel x z

lemma make_rel_impl (S : discrete_quotient X) (x y : X) :
  S.rel x y → S.make_rel f (f x) (f y) := make_rel.of _ _

include surj

lemma make_rel_equiv (S : discrete_quotient X) : equivalence (S.make_rel f) :=
begin
  refine ⟨λ x, _, λ x y h, _, λ x y z h1 h2, make_rel.trans h1 h2⟩,
  { obtain ⟨x,rfl⟩ := surj x,
    exact make_rel.of _ _ (S.refl _) },
  { induction h with x y h1 x y z h1 h2 h3 h4,
    exact make_rel.of y x (S.symm x y h1),
    exact make_rel.trans h4 h3 },
end

/-- The setoid assoc. to make_rel. -/
def make_setoid (S : discrete_quotient X) : _root_.setoid Y :=
⟨S.make_rel f, S.make_rel_equiv f surj⟩

/-- The quotient of make_rel. -/
@[nolint has_inhabited_instance]
def make_quotient (S : discrete_quotient X) : Type* := quotient (S.make_setoid f surj)

/-- The projection onto make_rel. -/
def make_proj (S : discrete_quotient X) : Y → S.make_quotient f surj :=
  quotient.mk'

lemma make_proj_comm (S : discrete_quotient X) :
  S.make_proj f surj ∘ f = (quotient.map' f $ by exact make_rel_impl _ _) ∘ S.proj :=
by {ext, refl}

variable (f)

/-- Given a discrete quotient S of f.left, this is the compatible quotient
 of f where f.right is as large as possible. -/
def make (S : discrete_quotient X) : discrete_quotient Y :=
{ rel := S.make_rel f,
  equiv := S.make_rel_equiv f surj,
  clopen := begin
    intros x,
    have : set_of (S.make_rel f x) = S.make_proj f surj ⁻¹' {S.make_proj f surj x},
    { dsimp [make_proj],
      ext,
      simp only [set.mem_preimage, set.mem_singleton_iff, quotient.eq', set.mem_set_of_eq],
      refine ⟨λ h, setoid.symm' _ h, λ h, setoid.symm' _ h⟩ },
    rw this,
    letI : topological_space (S.make_quotient f surj) := ⊥,
    haveI : discrete_topology (S.make_quotient f surj) := ⟨rfl⟩,
    suffices : continuous (S.make_proj f surj),
    { refine ⟨is_open.preimage this trivial, is_closed.preimage this ⟨trivial⟩⟩ },
    rw [(Profinite.quotient_map f surj).continuous_iff, S.make_proj_comm f surj],
    exact continuous_bot.comp (proj_continuous S),
  end }

lemma make_le_comap (S : discrete_quotient X) : le_comap f.continuous S (S.make f surj) :=
make_rel_impl _ _

lemma make_right_le (S : discrete_quotient X) (T : discrete_quotient Y)
  (compat : le_comap f.continuous S T) :
  (S.make f surj) ≤ T :=
begin
  intros x y h,
  induction h with a b hab a b c _ _ h1 h2,
  { exact compat a b hab },
  { exact trans T a b c h1 h2 },
end

lemma make_right_mono (S1 S2 : discrete_quotient X) (h : S1 ≤ S2) :
  S1.make f surj ≤ S2.make f surj :=
begin
  intros x y h,
  induction h,
  { refine make_rel.of _ _ (h _ _ _),
  assumption },
  { apply make_rel.trans,
    assumption' },
end

end discrete_quotient


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.algebra.subalgebra.basic
import algebra.free_algebra
import algebra.category.CommRing.basic
import algebra.category.Module.basic

/-!
# Category instance for algebras over a commutative ring

We introduce the bundled category `Algebra` of algebras over a fixed commutative ring `R ` along
with the forgetful functors to `Ring` and `Module`. We furthermore show that the functor associating
to a type the free `R`-algebra on that type is left adjoint to the forgetful functor.
-/

open category_theory
open category_theory.limits

universes v u

variables (R : Type u) [comm_ring R]

/-- The category of R-algebras and their morphisms. -/
structure Algebra :=
(carrier : Type v)
[is_ring : ring carrier]
[is_algebra : algebra R carrier]

attribute [instance] Algebra.is_ring Algebra.is_algebra

namespace Algebra

instance : has_coe_to_sort (Algebra R) (Type v) := ⟨Algebra.carrier⟩

instance : category (Algebra.{v} R) :=
{ hom   := λ A B, A →ₐ[R] B,
  id    := λ A, alg_hom.id R A,
  comp  := λ A B C f g, g.comp f }

instance : concrete_category.{v} (Algebra.{v} R) :=
{ forget := { obj := λ R, R, map := λ R S f, (f : R → S) },
  forget_faithful := { } }

instance has_forget_to_Ring : has_forget₂ (Algebra.{v} R) Ring.{v} :=
{ forget₂ :=
  { obj := λ A, Ring.of A,
    map := λ A₁ A₂ f, alg_hom.to_ring_hom f, } }

instance has_forget_to_Module : has_forget₂ (Algebra.{v} R) (Module.{v} R) :=
{ forget₂ :=
  { obj := λ M, Module.of R M,
    map := λ M₁ M₂ f, alg_hom.to_linear_map f, } }

/-- The object in the category of R-algebras associated to a type equipped with the appropriate
typeclasses. -/
def of (X : Type v) [ring X] [algebra R X] : Algebra.{v} R := ⟨X⟩

/-- Typecheck a `alg_hom` as a morphism in `Algebra R`. -/
def of_hom {R : Type u} [comm_ring R] {X Y : Type v} [ring X] [algebra R X] [ring Y] [algebra R Y]
  (f : X →ₐ[R] Y) : of R X ⟶ of R Y := f

@[simp] lemma of_hom_apply {R : Type u} [comm_ring R]
  {X Y : Type v} [ring X] [algebra R X] [ring Y] [algebra R Y] (f : X →ₐ[R] Y) (x : X) :
  of_hom f x = f x := rfl

instance : inhabited (Algebra R) := ⟨of R R⟩

@[simp]
lemma coe_of (X : Type u) [ring X] [algebra R X] : (of R X : Type u) = X := rfl

variables {R}

/-- Forgetting to the underlying type and then building the bundled object returns the original
algebra. -/
@[simps]
def of_self_iso (M : Algebra.{v} R) : Algebra.of R M ≅ M :=
{ hom := 𝟙 M, inv := 𝟙 M }

variables {R} {M N U : Module.{v} R}

@[simp]

@[simp] lemma coe_comp (f : M ⟶ N) (g : N ⟶ U) :
  ((f ≫ g) : M → U) = g ∘ f := rfl

variables (R)
/-- The "free algebra" functor, sending a type `S` to the free algebra on `S`. -/
@[simps]
def free : Type u ⥤ Algebra.{u} R :=
{ obj := λ S,
  { carrier := free_algebra R S,
    is_ring := algebra.semiring_to_ring R },
  map := λ S T f, free_algebra.lift _ $ (free_algebra.ι _) ∘ f,
  -- obviously can fill the next two goals, but it is slow
  map_id' := by { intros X, ext1, simp only [free_algebra.ι_comp_lift], refl },
  map_comp' := by { intros, ext1, simp only [free_algebra.ι_comp_lift], ext1,
    simp only [free_algebra.lift_ι_apply, category_theory.coe_comp, function.comp_app,
      types_comp_apply] } }

/-- The free/forget adjunction for `R`-algebras. -/
def adj : free.{u} R ⊣ forget (Algebra.{u} R) :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X A, (free_algebra.lift _).symm,
  -- Relying on `obviously` to fill out these proofs is very slow :(
  hom_equiv_naturality_left_symm' := by { intros, ext,
    simp only [free_map, equiv.symm_symm, free_algebra.lift_ι_apply, category_theory.coe_comp,
      function.comp_app, types_comp_apply] },
  hom_equiv_naturality_right' := by { intros, ext,
    simp only [forget_map_eq_coe, category_theory.coe_comp, function.comp_app,
      free_algebra.lift_symm_apply, types_comp_apply] } }

instance : is_right_adjoint (forget (Algebra.{u} R)) := ⟨_, adj R⟩

end Algebra

variables {R}
variables {X₁ X₂ : Type u}

/-- Build an isomorphism in the category `Algebra R` from a `alg_equiv` between `algebra`s. -/
@[simps]
def alg_equiv.to_Algebra_iso
  {g₁ : ring X₁} {g₂ : ring X₂} {m₁ : algebra R X₁} {m₂ : algebra R X₂} (e : X₁ ≃ₐ[R] X₂) :
  Algebra.of R X₁ ≅ Algebra.of R X₂ :=
{ hom := (e : X₁ →ₐ[R] X₂),
  inv := (e.symm : X₂ →ₐ[R] X₁),
  hom_inv_id' := begin ext, exact e.left_inv x, end,
  inv_hom_id' := begin ext, exact e.right_inv x, end, }

namespace category_theory.iso

/-- Build a `alg_equiv` from an isomorphism in the category `Algebra R`. -/
@[simps]
def to_alg_equiv {X Y : Algebra R} (i : X ≅ Y) : X ≃ₐ[R] Y :=
{ to_fun    := i.hom,
  inv_fun   := i.inv,
  left_inv  := by tidy,
  right_inv := by tidy,
  map_add'  := by tidy,
  map_mul'  := by tidy,
  commutes' := by tidy, }.

end category_theory.iso

/-- Algebra equivalences between `algebras`s are the same as (isomorphic to) isomorphisms in
`Algebra`. -/
@[simps]
def alg_equiv_iso_Algebra_iso {X Y : Type u}
  [ring X] [ring Y] [algebra R X] [algebra R Y] :
  (X ≃ₐ[R] Y) ≅ (Algebra.of R X ≅ Algebra.of R Y) :=
{ hom := λ e, e.to_Algebra_iso,
  inv := λ i, i.to_alg_equiv, }

instance (X : Type u) [ring X] [algebra R X] : has_coe (subalgebra R X) (Algebra R) :=
⟨ λ N, Algebra.of R N ⟩

instance Algebra.forget_reflects_isos : reflects_isomorphisms (forget (Algebra.{u} R)) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget (Algebra.{u} R)).map f),
    let e : X ≃ₐ[R] Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Algebra_iso).1⟩,
  end }


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Shing Tak Lam, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.int.modeq
import Mathlib.tactic.interval_cases
import Mathlib.tactic.linarith.default
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Digits of a natural number

This provides a basic API for extracting the digits of a natural number in a given base,
and reconstructing numbers from their digits.

We also prove some divisibility tests based on digits, in particular completing
Theorem #85 from https://www.cs.ru.nl/~freek/100/.

A basic `norm_digits` tactic is also provided for proving goals of the form
`nat.digits a b = l` where `a` and `b` are numerals.
-/

namespace nat

/-- (Impl.) An auxiliary definition for `digits`, to help get the desired definitional unfolding. -/
def digits_aux_0 : ℕ → List ℕ :=
  sorry

/-- (Impl.) An auxiliary definition for `digits`, to help get the desired definitional unfolding. -/
def digits_aux_1 (n : ℕ) : List ℕ :=
  list.repeat 1 n

/-- (Impl.) An auxiliary definition for `digits`, to help get the desired definitional unfolding. -/
def digits_aux (b : ℕ) (h : bit0 1 ≤ b) : ℕ → List ℕ :=
  sorry

@[simp] theorem digits_aux_zero (b : ℕ) (h : bit0 1 ≤ b) : digits_aux b h 0 = [] :=
  rfl

theorem digits_aux_def (b : ℕ) (h : bit0 1 ≤ b) (n : ℕ) (w : 0 < n) : digits_aux b h n = n % b :: digits_aux b h (n / b) := sorry

/--
`digits b n` gives the digits, in little-endian order,
of a natural number `n` in a specified base `b`.

In any base, we have `of_digits b L = L.foldr (λ x y, x + b * y) 0`.
* For any `2 ≤ b`, we have `l < b` for any `l ∈ digits b n`,
  and the last digit is not zero.
  This uniquely specifies the behaviour of `digits b`.
* For `b = 1`, we define `digits 1 n = list.repeat 1 n`.
* For `b = 0`, we define `digits 0 n = [n]`, except `digits 0 0 = []`.

Note this differs from the existing `nat.to_digits` in core, which is used for printing numerals.
In particular, `nat.to_digits b 0 = [0]`, while `digits b 0 = []`.
-/
def digits : ℕ → ℕ → List ℕ :=
  sorry

@[simp] theorem digits_zero (b : ℕ) : digits b 0 = [] :=
  nat.cases_on b (Eq.refl (digits 0 0))
    fun (b : ℕ) => nat.cases_on b (Eq.refl (digits 1 0)) fun (b : ℕ) => Eq.refl (digits (Nat.succ (Nat.succ b)) 0)

@[simp] theorem digits_zero_zero : digits 0 0 = [] :=
  rfl

@[simp] theorem digits_zero_succ (n : ℕ) : digits 0 (Nat.succ n) = [n + 1] :=
  rfl

theorem digits_zero_succ' {n : ℕ} (w : 0 < n) : digits 0 n = [n] :=
  nat.cases_on n (fun (w : 0 < 0) => idRhs (digits 0 0 = [0]) (absurd w (of_as_true trivial)))
    (fun (n : ℕ) (w : 0 < Nat.succ n) => idRhs (digits 0 (n + 1) = digits 0 (n + 1)) rfl) w

@[simp] theorem digits_one (n : ℕ) : digits 1 n = list.repeat 1 n :=
  rfl

@[simp] theorem digits_one_succ (n : ℕ) : digits 1 (n + 1) = 1 :: digits 1 n :=
  rfl

@[simp] theorem digits_add_two_add_one (b : ℕ) (n : ℕ) : digits (b + bit0 1) (n + 1) = (n + 1) % (b + bit0 1) :: digits (b + bit0 1) ((n + 1) / (b + bit0 1)) :=
  rfl

theorem digits_def' {b : ℕ} (h : bit0 1 ≤ b) {n : ℕ} (w : 0 < n) : digits b n = n % b :: digits b (n / b) := sorry

@[simp] theorem digits_of_lt (b : ℕ) (x : ℕ) (w₁ : 0 < x) (w₂ : x < b) : digits b x = [x] := sorry

theorem digits_add (b : ℕ) (h : bit0 1 ≤ b) (x : ℕ) (y : ℕ) (w : x < b) (w' : 0 < x ∨ 0 < y) : digits b (x + b * y) = x :: digits b y := sorry

/--
`of_digits b L` takes a list `L` of natural numbers, and interprets them
as a number in semiring, as the little-endian digits in base `b`.
-/
-- If we had a function converting a list into a polynomial,

-- and appropriate lemmas about that function,

-- we could rewrite this in terms of that.

def of_digits {α : Type u_1} [semiring α] (b : α) : List ℕ → α :=
  sorry

theorem of_digits_eq_foldr {α : Type u_1} [semiring α] (b : α) (L : List ℕ) : of_digits b L = list.foldr (fun (x : ℕ) (y : α) => ↑x + b * y) 0 L := sorry

@[simp] theorem of_digits_singleton {b : ℕ} {n : ℕ} : of_digits b [n] = n := sorry

@[simp] theorem of_digits_one_cons {α : Type u_1} [semiring α] (h : ℕ) (L : List ℕ) : of_digits 1 (h :: L) = ↑h + of_digits 1 L := sorry

theorem of_digits_append {b : ℕ} {l1 : List ℕ} {l2 : List ℕ} : of_digits b (l1 ++ l2) = of_digits b l1 + b ^ list.length l1 * of_digits b l2 := sorry

theorem coe_of_digits (α : Type u_1) [semiring α] (b : ℕ) (L : List ℕ) : ↑(of_digits b L) = of_digits (↑b) L := sorry

theorem coe_int_of_digits (b : ℕ) (L : List ℕ) : ↑(of_digits b L) = of_digits (↑b) L := sorry

theorem digits_zero_of_eq_zero {b : ℕ} (h : 1 ≤ b) {L : List ℕ} (w : of_digits b L = 0) (l : ℕ) (H : l ∈ L) : l = 0 := sorry

theorem digits_of_digits (b : ℕ) (h : bit0 1 ≤ b) (L : List ℕ) (w₁ : ∀ (l : ℕ), l ∈ L → l < b) (w₂ : ∀ (h : L ≠ []), list.last L h ≠ 0) : digits b (of_digits b L) = L := sorry

theorem of_digits_digits (b : ℕ) (n : ℕ) : of_digits b (digits b n) = n := sorry

theorem of_digits_one (L : List ℕ) : of_digits 1 L = list.sum L := sorry

/-!
### Properties

This section contains various lemmas of properties relating to `digits` and `of_digits`.
-/

theorem digits_eq_nil_iff_eq_zero {b : ℕ} {n : ℕ} : digits b n = [] ↔ n = 0 := sorry

theorem digits_ne_nil_iff_ne_zero {b : ℕ} {n : ℕ} : digits b n ≠ [] ↔ n ≠ 0 :=
  not_congr digits_eq_nil_iff_eq_zero

theorem digits_last {b : ℕ} {m : ℕ} (h : bit0 1 ≤ b) (hm : 0 < m) (p : digits b m ≠ []) (q : digits b (m / b) ≠ []) : list.last (digits b m) p = list.last (digits b (m / b)) q := sorry

theorem last_digit_ne_zero (b : ℕ) {m : ℕ} (hm : m ≠ 0) : list.last (digits b m) (iff.mpr digits_ne_nil_iff_ne_zero hm) ≠ 0 := sorry

/-- The digits in the base b+2 expansion of n are all less than b+2 -/
theorem digits_lt_base' {b : ℕ} {m : ℕ} {d : ℕ} : d ∈ digits (b + bit0 1) m → d < b + bit0 1 := sorry

/-- The digits in the base b expansion of n are all less than b, if b ≥ 2 -/
theorem digits_lt_base {b : ℕ} {m : ℕ} {d : ℕ} (hb : bit0 1 ≤ b) (hd : d ∈ digits b m) : d < b := sorry

/-- an n-digit number in base b + 2 is less than (b + 2)^n -/
theorem of_digits_lt_base_pow_length' {b : ℕ} {l : List ℕ} (hl : ∀ (x : ℕ), x ∈ l → x < b + bit0 1) : of_digits (b + bit0 1) l < (b + bit0 1) ^ list.length l := sorry

/-- an n-digit number in base b is less than b^n if b ≥ 2 -/
theorem of_digits_lt_base_pow_length {b : ℕ} {l : List ℕ} (hb : bit0 1 ≤ b) (hl : ∀ (x : ℕ), x ∈ l → x < b) : of_digits b l < b ^ list.length l := sorry

/-- Any number m is less than (b+2)^(number of digits in the base b + 2 representation of m) -/
theorem lt_base_pow_length_digits' {b : ℕ} {m : ℕ} : m < (b + bit0 1) ^ list.length (digits (b + bit0 1) m) := sorry

/-- Any number m is less than b^(number of digits in the base b representation of m) -/
theorem lt_base_pow_length_digits {b : ℕ} {m : ℕ} (hb : bit0 1 ≤ b) : m < b ^ list.length (digits b m) := sorry

theorem of_digits_digits_append_digits {b : ℕ} {m : ℕ} {n : ℕ} : of_digits b (digits b n ++ digits b m) = n + b ^ list.length (digits b n) * m := sorry

theorem digits_len_le_digits_len_succ (b : ℕ) (n : ℕ) : list.length (digits b n) ≤ list.length (digits b (n + 1)) := sorry

theorem le_digits_len_le (b : ℕ) (n : ℕ) (m : ℕ) (h : n ≤ m) : list.length (digits b n) ≤ list.length (digits b m) :=
  monotone_of_monotone_nat (digits_len_le_digits_len_succ b) h

theorem pow_length_le_mul_of_digits {b : ℕ} {l : List ℕ} (hl : l ≠ []) (hl2 : list.last l hl ≠ 0) : (b + bit0 1) ^ list.length l ≤ (b + bit0 1) * of_digits (b + bit0 1) l := sorry

/--
Any non-zero natural number `m` is greater than
(b+2)^((number of digits in the base (b+2) representation of m) - 1)
-/
theorem base_pow_length_digits_le' (b : ℕ) (m : ℕ) (hm : m ≠ 0) : (b + bit0 1) ^ list.length (digits (b + bit0 1) m) ≤ (b + bit0 1) * m := sorry

/--
Any non-zero natural number `m` is greater than
b^((number of digits in the base b representation of m) - 1)
-/
theorem base_pow_length_digits_le (b : ℕ) (m : ℕ) (hb : bit0 1 ≤ b) : m ≠ 0 → b ^ list.length (digits b m) ≤ b * m := sorry

/-! ### Modular Arithmetic -/

-- This is really a theorem about polynomials.

theorem dvd_of_digits_sub_of_digits {α : Type u_1} [comm_ring α] {a : α} {b : α} {k : α} (h : k ∣ a - b) (L : List ℕ) : k ∣ of_digits a L - of_digits b L := sorry

theorem of_digits_modeq' (b : ℕ) (b' : ℕ) (k : ℕ) (h : modeq k b b') (L : List ℕ) : modeq k (of_digits b L) (of_digits b' L) := sorry

theorem of_digits_modeq (b : ℕ) (k : ℕ) (L : List ℕ) : modeq k (of_digits b L) (of_digits (b % k) L) :=
  of_digits_modeq' b (b % k) k (modeq.symm (modeq.mod_modeq b k)) L

theorem of_digits_mod (b : ℕ) (k : ℕ) (L : List ℕ) : of_digits b L % k = of_digits (b % k) L % k :=
  of_digits_modeq b k L

theorem of_digits_zmodeq' (b : ℤ) (b' : ℤ) (k : ℕ) (h : int.modeq (↑k) b b') (L : List ℕ) : int.modeq (↑k) (of_digits b L) (of_digits b' L) := sorry

theorem of_digits_zmodeq (b : ℤ) (k : ℕ) (L : List ℕ) : int.modeq (↑k) (of_digits b L) (of_digits (b % ↑k) L) :=
  of_digits_zmodeq' b (b % ↑k) k (int.modeq.symm (int.modeq.mod_modeq b ↑k)) L

theorem of_digits_zmod (b : ℤ) (k : ℕ) (L : List ℕ) : of_digits b L % ↑k = of_digits (b % ↑k) L % ↑k :=
  of_digits_zmodeq b k L

theorem modeq_digits_sum (b : ℕ) (b' : ℕ) (h : b' % b = 1) (n : ℕ) : modeq b n (list.sum (digits b' n)) := sorry

theorem modeq_three_digits_sum (n : ℕ) : modeq (bit1 1) n (list.sum (digits (bit0 (bit1 (bit0 1))) n)) := sorry

theorem modeq_nine_digits_sum (n : ℕ) : modeq (bit1 (bit0 (bit0 1))) n (list.sum (digits (bit0 (bit1 (bit0 1))) n)) := sorry

theorem zmodeq_of_digits_digits (b : ℕ) (b' : ℕ) (c : ℤ) (h : int.modeq (↑b) (↑b') c) (n : ℕ) : int.modeq (↑b) (↑n) (of_digits c (digits b' n)) := sorry

theorem of_digits_neg_one (L : List ℕ) : of_digits (-1) L = list.alternating_sum (list.map (fun (n : ℕ) => ↑n) L) := sorry

theorem modeq_eleven_digits_sum (n : ℕ) : int.modeq (bit1 (bit1 (bit0 1))) (↑n)
  (list.alternating_sum (list.map (fun (n : ℕ) => ↑n) (digits (bit0 (bit1 (bit0 1))) n))) := sorry

/-! ## Divisibility  -/

theorem dvd_iff_dvd_digits_sum (b : ℕ) (b' : ℕ) (h : b' % b = 1) (n : ℕ) : b ∣ n ↔ b ∣ list.sum (digits b' n) := sorry

theorem three_dvd_iff (n : ℕ) : bit1 1 ∣ n ↔ bit1 1 ∣ list.sum (digits (bit0 (bit1 (bit0 1))) n) := sorry

theorem nine_dvd_iff (n : ℕ) : bit1 (bit0 (bit0 1)) ∣ n ↔ bit1 (bit0 (bit0 1)) ∣ list.sum (digits (bit0 (bit1 (bit0 1))) n) := sorry

theorem dvd_iff_dvd_of_digits (b : ℕ) (b' : ℕ) (c : ℤ) (h : ↑b ∣ ↑b' - c) (n : ℕ) : b ∣ n ↔ ↑b ∣ of_digits c (digits b' n) := sorry

theorem eleven_dvd_iff (n : ℕ) : bit1 (bit1 (bit0 1)) ∣ n ↔
  bit1 (bit1 (bit0 1)) ∣ list.alternating_sum (list.map (fun (n : ℕ) => ↑n) (digits (bit0 (bit1 (bit0 1))) n)) := sorry

/-! ### `norm_digits` tactic -/

namespace norm_digits

theorem digits_succ (b : ℕ) (n : ℕ) (m : ℕ) (r : ℕ) (l : List ℕ) (e : r + b * m = n) (hr : r < b) (h : digits b m = l ∧ bit0 1 ≤ b ∧ 0 < m) : digits b n = r :: l ∧ bit0 1 ≤ b ∧ 0 < n := sorry

theorem digits_one (b : ℕ) (n : ℕ) (n0 : 0 < n) (nb : n < b) : digits b n = [n] ∧ bit0 1 ≤ b ∧ 0 < n := sorry


import for_mathlib.homological_complex_op
import for_mathlib.split_exact
import for_mathlib.AddCommGroup.exact

import pseudo_normed_group.FP2
import pseudo_normed_group.system_of_complexes

import system_of_complexes.rescale

import prop_92.prop_92

noncomputable theory

open_locale nnreal

universes u v

open category_theory breen_deligne

variables (r r' : ℝ≥0)
variables (BD : breen_deligne.data)
variables (M : ProFiltPseuNormGrpWithTinv.{u} r')
variables (V : SemiNormedGroup.{v})

set_option pp.universes true

def aux_system (κ : ℝ≥0 → ℕ → ℝ≥0) [∀ c, BD.suitable (κ c)] [∀ (n : ℕ), fact (monotone (function.swap κ n))] :
  system_of_complexes :=
(FPsystem r' BD M κ).op ⋙
  (((CLC.{v u} V).right_op.map_FreeAb ⋙ FreeAb.eval _).map_homological_complex _).op ⋙
  homological_complex.unop_functor

namespace aux_system

variables [fact (0 < r)] [fact (0 < r')] [fact (r' ≤ 1)]

open system_of_complexes opposite

variables (κ₁ κ₂ : ℝ≥0 → ℕ → ℝ≥0) [∀ c, BD.suitable (κ₁ c)] [∀ c, BD.suitable (κ₂ c)]

def Tinv [hκ₁ : ∀ n, fact (monotone (function.swap κ₁ n))] [hκ₂ : ∀ n, fact (monotone (function.swap κ₂ n))]
  [∀ c n, fact (κ₁ c n ≤ r' * κ₂ c n)] :
  aux_system r' BD M V κ₂ ⟶ aux_system r' BD M V κ₁ :=
whisker_right (nat_trans.op $ FPsystem.Tinv r' BD M κ₁ κ₂)
  ((((CLC.{v u} V).right_op.map_FreeAb ⋙ FreeAb.eval _).map_homological_complex _).op ⋙
    homological_complex.unop_functor)

lemma Tinv_eq [hκ₁ : ∀ n, fact (monotone (function.swap κ₁ n))] [hκ₂ : ∀ n, fact (monotone (function.swap κ₂ n))]
  [∀ c n, fact (κ₁ c n ≤ r' * κ₂ c n)] (c : ℝ≥0ᵒᵖ) (n : ℕ) :
  ((Tinv r' BD M V κ₁ κ₂).app c).f n =
  ((CLCFP.Tinv V r' _ _ (BD.X n)).app (op M) : _) :=
begin
  dsimp only [Tinv, CLCFP.Tinv, FPsystem.Tinv, FP2.Tinv,
    homological_complex.comp_f, aux_system, functor.comp_map, homological_complex.unop_functor,
    homological_complex.unop_d, functor.op_obj, functor.map_homological_complex_obj_d,
    unop_op, CLC, functor.op_map, quiver.hom.unop_op, functor.map_homological_complex_map_f,
    functor.map_FreeAb, FreeAb.eval, free_abelian_group.map_of_apply,
    FPsystem, FP2.res_app, FreeAb.of_functor, functor.right_op_map,
    whisker_right_app, nat_trans.op_app],
  erw [free_abelian_group.lift.of],
  refl,
end

def T_inv [normed_with_aut r V]
  (κ : ℝ≥0 → ℕ → ℝ≥0) [∀ c, BD.suitable (κ c)] [∀ (n : ℕ), fact (monotone (function.swap κ n))] :
  aux_system r' BD M V κ ⟶ aux_system r' BD M V κ :=
{ app := λ c,
  { f := λ i, normed_add_group_hom.completion $ (SemiNormedGroup.LocallyConstant.map $ normed_with_aut.T.inv).app _,
    comm' := begin
      rintro i j (rfl : i + 1 = j),
      dsimp only [aux_system, functor.comp_obj, homological_complex.unop_functor,
        homological_complex.unop_d, functor.op_obj, functor.map_homological_complex_obj_d,
        unop_op],
      erw [← SemiNormedGroup.Completion_map, ← SemiNormedGroup.Completion_map, chain_complex.of_d],
      dsimp only [FPsystem.d, universal_map.eval_FP2, universal_map.eval_CLCFP,
        universal_map.eval_LCFP, CLC],
      simp only [nat_trans.app_sum, functor.map_sum, preadditive.comp_sum, preadditive.sum_comp,
        category_theory.unop_sum, nat_trans.app_zsmul, functor.map_zsmul,
        preadditive.comp_zsmul, preadditive.zsmul_comp, category_theory.unop_zsmul],
      refine finset.sum_congr rfl _,
      rintro ⟨g, hg⟩ -,
      dsimp only [basic_universal_map.eval_FP2, basic_universal_map.eval_LCFP,
        whisker_right_app, nat_trans.op_app, unop_op, FreeAb.of_functor,
        free_abelian_group.map_of_apply, functor.right_op_map, LC,
        functor.comp_map, functor.map_FreeAb, FreeAb.eval],
      rw [free_abelian_group.lift.of, _root_.id, quiver.hom.unop_op,
        ← SemiNormedGroup.Completion.map_comp, ← SemiNormedGroup.Completion.map_comp,
        nat_trans.naturality],
    end },
  naturality' := λ c₁ c₂ h, begin
    ext n : 2,
    dsimp only [homological_complex.comp_f, aux_system, functor.comp_map, homological_complex.unop_functor,
      homological_complex.unop_d, functor.op_obj, functor.map_homological_complex_obj_d,
      unop_op, CLC, functor.op_map, quiver.hom.unop_op, functor.map_homological_complex_map_f,
      functor.map_FreeAb, FreeAb.eval, free_abelian_group.map_of_apply,
      FPsystem, FP2.res_app, FreeAb.of_functor, functor.right_op_map],
    rw [← SemiNormedGroup.Completion_map, ← SemiNormedGroup.Completion_map,
      free_abelian_group.lift.of, _root_.id, quiver.hom.unop_op,
      ← SemiNormedGroup.Completion.map_comp, ← SemiNormedGroup.Completion.map_comp,
        nat_trans.naturality],
    refl,
  end }
.

variables [normed_with_aut r V]

lemma T_inv_eq
  (κ : ℝ≥0 → ℕ → ℝ≥0) [∀ c, BD.suitable (κ c)] [∀ (n : ℕ), fact (monotone (function.swap κ n))]
  (c : ℝ≥0ᵒᵖ) (n : ℕ) : ((T_inv r r' BD M V κ).app c).f n =
  ((CLCFP.T_inv r V r' _ (BD.X n)).app (op M) : _) :=
begin
  dsimp only [T_inv, CLCFP.T_inv, FPsystem, chain_complex.of_X, FPsystem.X,
    homological_complex.comp_f, aux_system, functor.comp_map, homological_complex.unop_functor,
    homological_complex.unop_d, functor.op_obj, functor.map_homological_complex_obj_d,
    functor.map_homological_complex_map_f, functor.map_FreeAb,
    unop_op, CLC, functor.op_map, functor.op_obj, quiver.hom.unop_op,
    FreeAb.eval, free_abelian_group.map_of_apply, FPsystem, FP2.res_app, FreeAb.of_functor,
    functor.right_op_map, whisker_right_app, nat_trans.op_app, whisker_left_app],
  refl,
end

def res [hκ₁ : ∀ n, fact (monotone (function.swap κ₁ n))] [hκ₂ : ∀ n, fact (monotone (function.swap κ₂ n))]
  [∀ c n, fact (κ₁ c n ≤ κ₂ c n)] :
  aux_system r' BD M V κ₂ ⟶ aux_system r' BD M V κ₁ :=
whisker_right (nat_trans.op $ FPsystem.res r' BD M κ₁ κ₂)
  ((((CLC.{v u} V).right_op.map_FreeAb ⋙ FreeAb.eval _).map_homological_complex _).op ⋙
    homological_complex.unop_functor)

lemma res_eq [hκ₁ : ∀ n, fact (monotone (function.swap κ₁ n))] [hκ₂ : ∀ n, fact (monotone (function.swap κ₂ n))]
  [∀ c n, fact (κ₁ c n ≤ r' * κ₂ c n)] [∀ c n, fact (κ₁ c n ≤ κ₂ c n)] (c : ℝ≥0ᵒᵖ) (n : ℕ) :
  ((res r' BD M V κ₁ κ₂).app c).f n =
  ((CLCFP.res V r' _ _ (BD.X n)).app (op M) : _) :=
begin
  dsimp only [res, CLCFP.res, FPsystem.res, FP2.res,
    homological_complex.comp_f, aux_system, functor.comp_map, homological_complex.unop_functor,
    homological_complex.unop_d, functor.op_obj, functor.map_homological_complex_obj_d,
    unop_op, CLC, functor.op_map, quiver.hom.unop_op, functor.map_homological_complex_map_f,
    functor.map_FreeAb, FreeAb.eval, free_abelian_group.map_of_apply,
    FPsystem, FP2.res_app, FreeAb.of_functor, functor.right_op_map,
    whisker_right_app, nat_trans.op_app],
  rw [free_abelian_group.lift.of],
  refl,
end

def Tinv2 [hκ₁ : ∀ n, fact (monotone (function.swap κ₁ n))] [hκ₂ : ∀ n, fact (monotone (function.swap κ₂ n))]
  [∀ c n, fact (κ₁ c n ≤ r' * κ₂ c n)] [∀ c n, fact (κ₁ c n ≤ κ₂ c n)] :
  aux_system r' BD M V κ₂ ⟶ aux_system r' BD M V κ₁ :=
Tinv r' BD M V κ₁ κ₂ - T_inv r r' BD M V κ₂ ≫ res r' BD M V κ₁ κ₂
.

lemma Tinv2_eq [hκ₁ : ∀ n, fact (monotone (function.swap κ₁ n))] [hκ₂ : ∀ n, fact (monotone (function.swap κ₂ n))]
  [∀ c n, fact (κ₁ c n ≤ r' * κ₂ c n)] [∀ c n, fact (κ₁ c n ≤ κ₂ c n)] (c : ℝ≥0ᵒᵖ) (n : ℕ) :
  ((Tinv2 r r' BD M V κ₁ κ₂).app c).f n =
  ((CLCFP.Tinv V r' _ _ (BD.X n)).app (op M) : _) -
  ((CLCFP.T_inv r V r' _ (BD.X n)).app (op M) : _) ≫ ((CLCFP.res V r' _ _ (BD.X n)).app (op M) : _) :=
by rw [Tinv2, nat_trans.app_sub, homological_complex.sub_f_apply, Tinv_eq,
    nat_trans.comp_app, homological_complex.comp_f, T_inv_eq, res_eq]

lemma aux_system_d_eq
  (κ : ℝ≥0 → ℕ → ℝ≥0) [∀ c, BD.suitable (κ c)] [∀ (n : ℕ), fact (monotone (function.swap κ n))]
  (c : ℝ≥0ᵒᵖ) (i : ℕ) :
  arrow.mk (((aux_system r' BD M V κ).obj c).d i (i + 1)) =
  arrow.mk ((universal_map.eval_CLCFP V r' (κ (unop c) i) (κ (unop c) (i + 1)) (BD.d (i + 1) i) : _).app (op M)) :=
begin
  dsimp [aux_system, FPsystem],
  rw [chain_complex.of_d],
  dsimp [FreeAb.eval, functor.map_FreeAb, functor.right_op_map, FPsystem.d,
    universal_map.eval_FP2, universal_map.eval_CLCFP, universal_map.eval_LCFP],
  simp only [nat_trans.app_sum, map_sum, ← normed_add_group_hom_completion_hom_apply,
    category_theory.unop_sum],
  congr' 1,
  refine finset.sum_congr rfl _,
  rintro ⟨g, hg⟩ -,
  simp only [nat_trans.app_zsmul, map_zsmul, category_theory.unop_zsmul],
  dsimp only [basic_universal_map.eval_FP2, basic_universal_map.eval_LCFP,
    whisker_right_app, nat_trans.op_app, unop_op, FreeAb.of_functor,
    free_abelian_group.map_of_apply],
  rw [free_abelian_group.lift.of],
  refl,
end

section

variables (κ : ℕ → ℝ≥0) [BD.suitable κ]

instance mul_left_mono (n : ℕ) :
  fact (monotone (function.swap (λ (c : ℝ≥0) (n : ℕ), c * κ n) n)) :=
⟨λ c₁ c₂ h, mul_le_mul' h le_rfl⟩

def incl_f (c : ℝ≥0ᵒᵖ) (n : ℕ) :
  ((BD.complex κ r V r' (unop c)).obj (op M)).X n ⟶ ((aux_system r' BD M V (λ c n, c * κ n)).obj c).X n :=
begin
  dsimp [breen_deligne.data.complex, breen_deligne.data.complex₂, breen_deligne.data.complex₂_X,
    CLCTinv, aux_system, FPsystem, FPsystem.X, functor.map_FreeAb, FreeAb.eval],
  exact (SemiNormedGroup.equalizer.ι _ _ : _),
end

lemma incl_comm (c : ℝ≥0ᵒᵖ) (i : ℕ) :
  incl_f.{u v} r r' BD M V κ c i ≫ ((aux_system.{u v} r' BD M V (λ c n, c * κ n)).obj c).d i (i + 1) =
  ((BD.complex κ r V r' (unop c)).obj (op.{u+2} M)).d i (i + 1) ≫ incl_f.{u v} r r' BD M V κ c (i + 1) :=
begin
  dsimp [aux_system],
  erw [chain_complex.of_d, breen_deligne.data.complex_obj_d],
  dsimp [breen_deligne.data.complex, breen_deligne.data.complex₂, breen_deligne.data.complex₂_X,
    CLCTinv, FPsystem, FPsystem.X, functor.map_FreeAb, FreeAb.eval,
    universal_map.eval_CLCFPTinv, universal_map.eval_CLCFPTinv₂,
    SemiNormedGroup.equalizer.map_nat, incl_f],
  delta id, dsimp only [], symmetry,
  convert SemiNormedGroup.equalizer.map_comp_ι _ _ _ _ using 2,
  apply arrow.mk_injective,
  rw ← aux_system_d_eq r' BD M V (λ c n, c * κ n),
  dsimp [aux_system],
  erw [chain_complex.of_d],
  refl,
end

def incl : (BD.system κ r V r').obj (op M) ⟶ aux_system r' BD M V (λ c n, c * κ n) :=
{ app := λ c,
  { f := incl_f r r' BD M V κ c,
    comm' := by { rintro i j (rfl : i + 1 = j), apply incl_comm } },
  naturality' := λ c₁ c₂ h, begin
    ext n : 2,
    dsimp [aux_system],
    dsimp [breen_deligne.data.complex, breen_deligne.data.complex₂, breen_deligne.data.complex₂_X,
      CLCTinv, FPsystem, FPsystem.X, functor.map_FreeAb, FreeAb.eval, FreeAb.of_functor,
      universal_map.eval_CLCFPTinv, universal_map.eval_CLCFPTinv₂,
      SemiNormedGroup.equalizer.map_nat, incl_f, CLCFPTinv₂.res, CLCTinv.map_nat, CLCTinv.map],
    delta id,
    erw [free_abelian_group.lift.of],
    convert SemiNormedGroup.equalizer.map_comp_ι _ _ _ _ using 1,
  end }

def incl' := whisker_right (incl r r' BD M V κ) (functor.map_homological_complex (forget₂ _ Ab.{max u v}) _)

end

def Tinv2' [hκ₁ : ∀ n, fact (monotone (function.swap κ₁ n))] [hκ₂ : ∀ n, fact (monotone (function.swap κ₂ n))]
  [∀ c n, fact (κ₁ c n ≤ r' * κ₂ c n)] [∀ c n, fact (κ₁ c n ≤ κ₂ c n)] :=
whisker_right (Tinv2 r r' BD M V κ₁ κ₂)
(functor.map_homological_complex (forget₂ _ Ab.{max u v}) _)

lemma _root_.SemiNormedGroup.equalizer.ι_injective {V W : SemiNormedGroup} (f g : V ⟶ W) :
  function.injective (SemiNormedGroup.equalizer.ι f g) :=
subtype.val_injective

lemma _root_.SemiNormedGroup.equalizer.forget₂_ι {V W : SemiNormedGroup} (f g : V ⟶ W) :
  (forget₂ _ Ab).map (SemiNormedGroup.equalizer.ι f g) =
  add_subgroup.subtype (add_monoid_hom.ker ((forget₂ _ Ab).map (f - g))) :=
rfl

instance mul_left_mono' (κ : ℕ → ℝ≥0) (n : ℕ) :
  fact (monotone (function.swap (λ (c : ℝ≥0) (n : ℕ), r' * (c * κ n)) n)) :=
⟨λ c₁ c₂ h, mul_le_mul' le_rfl $ mul_le_mul' h le_rfl⟩

lemma neg_surjective {A B : Ab} (f : A ⟶ B) (hf : function.surjective f) :
  function.surjective (-f) :=
begin
  intro y, obtain ⟨x, rfl⟩ := hf y, use -x, simp only [pi.neg_apply, map_neg, neg_neg],
end

lemma short_exact [fact (r < 1)] (κ : ℕ → ℝ≥0) [BD.suitable κ]
  [∀ c n, fact (κ₁ c n ≤ r' * (c * κ n))] (c : ℝ≥0ᵒᵖ) (n : ℕ) :
  short_exact (((incl' r r' BD M V κ).app c).f n)
    (((Tinv2' r r' BD M V (λ c n, r' * (c * κ n)) (λ c n, c * κ n)).app c).f n) :=
begin
  apply_with @short_exact.mk {instances := ff},
  { rw AddCommGroup.mono_iff_injective,
    dsimp [incl', incl, incl_f,
      breen_deligne.data.complex, breen_deligne.data.complex₂, breen_deligne.data.complex₂_X],
    exact SemiNormedGroup.equalizer.ι_injective _ _, },
  { rw [Tinv2', whisker_right_app, functor.map_homological_complex_map_f, Tinv2_eq,
      ← nat_trans.comp_app, ← CLCFP.res_comp_T_inv, nat_trans.comp_app,
      ← neg_sub, functor.map_neg, functor.map_sub, category_theory.functor.map_comp,
      AddCommGroup.epi_iff_surjective],
    apply neg_surjective,
    have := CLCFP.T_inv_sub_Tinv_surjective r r' V (unop c * κ n) (BD.X n) (op M),
    rw [CLCFP.T_inv_sub_Tinv, nat_trans.app_sub, nat_trans.comp_app] at this,
    exact this, },
  { rw AddCommGroup.exact_iff,
    dsimp [incl', incl, incl_f, Tinv2',
      breen_deligne.data.complex, breen_deligne.data.complex₂, breen_deligne.data.complex₂_X],
    rw [SemiNormedGroup.equalizer.forget₂_ι, add_subgroup.subtype_range, Tinv2_eq,
      ← nat_trans.comp_app, ← CLCFP.res_comp_T_inv],
    refl, }
end

end aux_system


inductive Trie (α : Type _) (β : Type _)
  | mk : α → Option β → List (Trie α β) → Trie α β
  deriving Inhabited, BEq

namespace Trie

partial def isWellFormed : Trie α β → Bool
  | mk _ none [] => false
  | mk _  _ l => l.all isWellFormed

def isTerminus : Trie α β → Bool
  | mk _ (some _) _ => true
  | mk _ none _ => false

def label : Trie α β → α
  | mk a _ _ => a

def data? : Trie α β → Option β
  | mk _ b? _ => b?

def data : (tr : Trie α β) → tr.isTerminus → β
  | mk _ (some b) _, _ => b
  | mk _ none _, h => by
    dsimp [isTerminus] at h
    contradiction

def find? [DecidableEq α] : Trie α β → α → Option (Trie α β)
  | mk _ _ l, a => l.find? (·.label = a)

instance [DecidableEq α] : GetElem (Trie α β) α (Trie α β) (Option.toBool <| ·.find? ·) where
  getElem := λ tr a h =>
    match tr.find? a, h with
      | some tr', _ => tr'
      | none, h => by
        dsimp [Option.toBool] at h
        contradiction

def fromList [DecidableEq α] : List ((List α) × β) → Trie α β := fun l =>
  let lg := l.groupBy (λ ⟨l₁, _⟩ ⟨l₂, _⟩ => l₁.head? = l₂.head?)
  sorry

def keyword? [DecidableEq α] (tr : Trie α β) (p : List α) : List α → (List α × List α × Option β)
  | [] => (p, [], tr.data?)
  | w :: ws =>
    match tr.find? w with
      | some tr' => keyword? tr' (p.concat w) ws
      | none => (p, w :: ws, tr.data?)

theorem keyword?.decompose [DecidableEq α] (tr : Trie α β) (p l : List α) :
  let (k, l', _) := keyword? tr p l
  p ++ l = k ++ l' :=
    match l with
      | [] => rfl
      | w :: ws => by
        simp [keyword?]
        cases tr.find? w
        · rfl
        · have : p ++ w :: ws = (p.concat w) ++ ws := by rw [List.concat_eq_append, List.append_assoc]; rfl
          rw [this]
          apply keyword?.decompose

def keyword?.length [DecidableEq α] (tr : Trie α β) (p : List α) : List α → Nat
    | [] => .zero
    | w :: ws =>
      match tr.find? w with
        | some tr' => .succ $ keyword?.length tr' (p.concat w) ws
        | none => .zero

theorem keyword?.eq_drop_length [DecidableEq α] (tr : Trie α β) (p l : List α) :
  let (_, l', _) := keyword? tr p l
  l' = l.drop (keyword?.length tr p l) :=
  match l with
    | [] => rfl
    | w :: ws => by
      simp [keyword?, keyword?.length]
      cases tr.find? w
      · rfl
      · dsimp [List.drop]
        apply keyword?.eq_drop_length

def keywords [DecidableEq α] (tr : Trie α β) (l : List α) : List ((List α) × β) :=
  match tr.keyword? [] l with
    | (kw, l', some b) => (kw, b) :: keywords tr l'
    | (_, l', none) => keywords tr l'
decreasing_by sorry

end Trie


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

import order.omega_complete_partial_order
import order.category.Preorder
import category_theory.limits.shapes.products
import category_theory.limits.shapes.equalizers
import category_theory.limits.constructions.limits_of_products_and_equalizers

/-!
# Category of types with a omega complete partial order

In this file, we bundle the class `omega_complete_partial_order` into a
concrete category and prove that continuous functions also form
a `omega_complete_partial_order`.

## Main definitions

 * `ωCPO`
   * an instance of `category` and `concrete_category`

 -/

open category_theory

universes u v

/-- The category of types with a omega complete partial order. -/
def ωCPO : Type (u+1) := bundled omega_complete_partial_order

namespace ωCPO

open omega_complete_partial_order

instance : bundled_hom @continuous_hom :=
{ to_fun := @continuous_hom.simps.apply,
  id := @continuous_hom.id,
  comp := @continuous_hom.comp,
  hom_ext := @continuous_hom.coe_inj }

attribute [derive [large_category, concrete_category]] ωCPO

instance : has_coe_to_sort ωCPO Type* := bundled.has_coe_to_sort

/-- Construct a bundled ωCPO from the underlying type and typeclass. -/
def of (α : Type*) [omega_complete_partial_order α] : ωCPO := bundled.of α

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

instance : inhabited ωCPO := ⟨of punit⟩

instance (α : ωCPO) : omega_complete_partial_order α := α.str

section

open category_theory.limits

namespace has_products

/-- The pi-type gives a cone for a product. -/
def product {J : Type v} (f : J → ωCPO.{v}) : fan f :=
fan.mk (of (Π j, f j)) (λ j, continuous_hom.of_mono (pi.eval_order_hom j) (λ c, rfl))

/-- The pi-type is a limit cone for the product. -/
def is_product (J : Type v) (f : J → ωCPO) : is_limit (product f) :=
{ lift := λ s,
    ⟨⟨λ t j, s.π.app j t, λ x y h j, (s.π.app j).monotone h⟩,
     λ x, funext (λ j, (s.π.app j).continuous x)⟩,
  uniq' := λ s m w,
  begin
    ext t j,
    change m t j = s.π.app j t,
    rw ← w j,
    refl,
  end }.

instance (J : Type v) (f : J → ωCPO.{v}) : has_product f :=
has_limit.mk ⟨_, is_product _ f⟩

end has_products

instance omega_complete_partial_order_equalizer
  {α β : Type*} [omega_complete_partial_order α] [omega_complete_partial_order β]
  (f g : α →𝒄 β) : omega_complete_partial_order {a : α // f a = g a} :=
omega_complete_partial_order.subtype _ $ λ c hc,
begin
  rw [f.continuous, g.continuous],
  congr' 1,
  ext,
  apply hc _ ⟨_, rfl⟩,
end

namespace has_equalizers

/-- The equalizer inclusion function as a `continuous_hom`. -/
def equalizer_ι {α β : Type*} [omega_complete_partial_order α] [omega_complete_partial_order β]
  (f g : α →𝒄 β) :
  {a : α // f a = g a} →𝒄 α :=
continuous_hom.of_mono (order_hom.subtype.val _) (λ c, rfl)

/-- A construction of the equalizer fork. -/
def equalizer {X Y : ωCPO.{v}} (f g : X ⟶ Y) :
  fork f g :=
@fork.of_ι _ _ _ _ _ _ (ωCPO.of {a // f a = g a}) (equalizer_ι f g)
  (continuous_hom.ext _ _ (λ x, x.2))

/-- The equalizer fork is a limit. -/
def is_equalizer {X Y : ωCPO.{v}} (f g : X ⟶ Y) : is_limit (equalizer f g) :=
fork.is_limit.mk' _ $ λ s,
⟨{ to_fun := λ x, ⟨s.ι x, by apply continuous_hom.congr_fun s.condition⟩,
    monotone' := λ x y h, s.ι.monotone h,
    cont := λ x, subtype.ext (s.ι.continuous x) },
  by { ext, refl },
  λ m hm,
  begin
    ext,
    apply continuous_hom.congr_fun hm,
  end⟩

end has_equalizers

instance : has_products ωCPO.{v} :=
λ J, { has_limit := λ F, has_limit_of_iso discrete.nat_iso_functor.symm }

instance {X Y : ωCPO.{v}} (f g : X ⟶ Y) : has_limit (parallel_pair f g) :=
has_limit.mk ⟨_, has_equalizers.is_equalizer f g⟩

instance : has_equalizers ωCPO.{v} := has_equalizers_of_has_limit_parallel_pair _

instance : has_limits ωCPO.{v} := limits_from_equalizers_and_products

end

end ωCPO


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.monoidal.functor
import category_theory.adjunction.limits
import category_theory.adjunction.mates
import category_theory.functor.inv_isos

/-!
# Closed monoidal categories

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

Define (right) closed objects and (right) closed monoidal categories.

## TODO
Some of the theorems proved about cartesian closed categories
should be generalised and moved to this file.
-/
universes v u u₂ v₂

namespace category_theory

open category monoidal_category

/-- An object `X` is (right) closed if `(X ⊗ -)` is a left adjoint. -/
-- Note that this class carries a particular choice of right adjoint,
-- (which is only unique up to isomorphism),
-- not merely the existence of such, and
-- so definitional properties of instances may be important.
class closed {C : Type u} [category.{v} C] [monoidal_category.{v} C] (X : C) :=
(is_adj : is_left_adjoint (tensor_left X))

/-- A monoidal category `C` is (right) monoidal closed if every object is (right) closed. -/
class monoidal_closed (C : Type u) [category.{v} C] [monoidal_category.{v} C] :=
(closed' : Π (X : C), closed X)

attribute [instance, priority 100] monoidal_closed.closed'

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

/--
If `X` and `Y` are closed then `X ⊗ Y` is.
This isn't an instance because it's not usually how we want to construct internal homs,
we'll usually prove all objects are closed uniformly.
-/
def tensor_closed {X Y : C}
  (hX : closed X) (hY : closed Y) : closed (X ⊗ Y) :=
{ is_adj :=
  begin
    haveI := hX.is_adj,
    haveI := hY.is_adj,
    exact adjunction.left_adjoint_of_nat_iso (monoidal_category.tensor_left_tensor _ _).symm
  end }

/--
The unit object is always closed.
This isn't an instance because most of the time we'll prove closedness for all objects at once,
rather than just for this one.
-/
def unit_closed : closed (𝟙_ C) :=
{ is_adj :=
  { right := 𝟭 C,
    adj := adjunction.mk_of_hom_equiv
    { hom_equiv := λ X _,
      { to_fun := λ a, (left_unitor X).inv ≫ a,
        inv_fun := λ a, (left_unitor X).hom ≫ a,
        left_inv := by tidy,
        right_inv := by tidy },
      hom_equiv_naturality_left_symm' := λ X' X Y f g,
      by { dsimp, rw left_unitor_naturality_assoc } } } }

variables (A B : C) {X X' Y Y' Z : C}

variables [closed A]

/--
This is the internal hom `A ⟶[C] -`.
-/
def ihom : C ⥤ C :=
(@closed.is_adj _ _ _ A _).right

namespace ihom

/-- The adjunction between `A ⊗ -` and `A ⟹ -`. -/
def adjunction : tensor_left A ⊣ ihom A :=
closed.is_adj.adj

/-- The evaluation natural transformation. -/
def ev : ihom A ⋙ tensor_left A ⟶ 𝟭 C :=
(ihom.adjunction A).counit

/-- The coevaluation natural transformation. -/
def coev : 𝟭 C ⟶ tensor_left A ⋙ ihom A :=
(ihom.adjunction A).unit

@[simp] lemma ihom_adjunction_counit : (ihom.adjunction A).counit = ev A := rfl
@[simp] lemma ihom_adjunction_unit : (ihom.adjunction A).unit = coev A := rfl

@[simp, reassoc]
lemma ev_naturality {X Y : C} (f : X ⟶ Y) :
  ((𝟙 A) ⊗ ((ihom A).map f)) ≫ (ev A).app Y = (ev A).app X ≫ f :=
(ev A).naturality f

@[simp, reassoc]
lemma coev_naturality {X Y : C} (f : X ⟶ Y) :
  f ≫ (coev A).app Y = (coev A).app X ≫ (ihom A).map ((𝟙 A) ⊗ f) :=
(coev A).naturality f

notation (name := ihom) A ` ⟶[`C`] ` B:10 := (@ihom C _ _ A _).obj B

@[simp, reassoc] lemma ev_coev :
  ((𝟙 A) ⊗ ((coev A).app B)) ≫ (ev A).app (A ⊗ B) = 𝟙 (A ⊗ B) :=
adjunction.left_triangle_components (ihom.adjunction A)

@[simp, reassoc] lemma coev_ev :
  (coev A).app (A ⟶[C] B) ≫ (ihom A).map ((ev A).app B) = 𝟙 (A ⟶[C] B) :=
adjunction.right_triangle_components (ihom.adjunction A)

end ihom

open category_theory.limits

instance : preserves_colimits (tensor_left A) :=
(ihom.adjunction A).left_adjoint_preserves_colimits

variables {A}

-- Wrap these in a namespace so we don't clash with the core versions.
namespace monoidal_closed

/-- Currying in a monoidal closed category. -/
def curry : (A ⊗ Y ⟶ X) → (Y ⟶ (A ⟶[C] X)) :=
(ihom.adjunction A).hom_equiv _ _
/-- Uncurrying in a monoidal closed category. -/
def uncurry : (Y ⟶ (A ⟶[C] X)) → (A ⊗ Y ⟶ X) :=
((ihom.adjunction A).hom_equiv _ _).symm

@[simp] lemma hom_equiv_apply_eq (f : A ⊗ Y ⟶ X) :
  (ihom.adjunction A).hom_equiv _ _ f = curry f := rfl
@[simp] lemma hom_equiv_symm_apply_eq (f : Y ⟶ (A ⟶[C] X)) :
  ((ihom.adjunction A).hom_equiv _ _).symm f = uncurry f := rfl

@[reassoc]
lemma curry_natural_left (f : X ⟶ X') (g : A ⊗ X' ⟶ Y) :
  curry (((𝟙 _) ⊗ f) ≫ g) = f ≫ curry g :=
adjunction.hom_equiv_naturality_left _ _ _

@[reassoc]
lemma curry_natural_right (f : A ⊗ X ⟶ Y) (g : Y ⟶ Y') :
  curry (f ≫ g) = curry f ≫ (ihom _).map g :=
adjunction.hom_equiv_naturality_right _ _ _

@[reassoc]
lemma uncurry_natural_right  (f : X ⟶ (A ⟶[C] Y)) (g : Y ⟶ Y') :
  uncurry (f ≫ (ihom _).map g) = uncurry f ≫ g :=
adjunction.hom_equiv_naturality_right_symm _ _ _

@[reassoc]
lemma uncurry_natural_left  (f : X ⟶ X') (g : X' ⟶ (A ⟶[C] Y)) :
  uncurry (f ≫ g) = ((𝟙 _) ⊗ f) ≫ uncurry g :=
adjunction.hom_equiv_naturality_left_symm _ _ _

@[simp]
lemma uncurry_curry (f : A ⊗ X ⟶ Y) : uncurry (curry f) = f :=
(closed.is_adj.adj.hom_equiv _ _).left_inv f

@[simp]
lemma curry_uncurry (f : X ⟶ (A ⟶[C] Y)) : curry (uncurry f) = f :=
(closed.is_adj.adj.hom_equiv _ _).right_inv f

lemma curry_eq_iff (f : A ⊗ Y ⟶ X) (g : Y ⟶ (A ⟶[C] X)) :
  curry f = g ↔ f = uncurry g :=
adjunction.hom_equiv_apply_eq _ f g

lemma eq_curry_iff (f : A ⊗ Y ⟶ X) (g : Y ⟶ (A ⟶[C] X)) :
  g = curry f ↔ uncurry g = f :=
adjunction.eq_hom_equiv_apply _ f g

-- I don't think these two should be simp.
lemma uncurry_eq (g : Y ⟶ (A ⟶[C] X)) : uncurry g = ((𝟙 A) ⊗ g) ≫ (ihom.ev A).app X :=
adjunction.hom_equiv_counit _

lemma curry_eq (g : A ⊗ Y ⟶ X) : curry g = (ihom.coev A).app Y ≫ (ihom A).map g :=
adjunction.hom_equiv_unit _

lemma curry_injective : function.injective (curry : (A ⊗ Y ⟶ X) → (Y ⟶ (A ⟶[C] X))) :=
(closed.is_adj.adj.hom_equiv _ _).injective

lemma uncurry_injective : function.injective (uncurry : (Y ⟶ (A ⟶[C] X)) → (A ⊗ Y ⟶ X)) :=
(closed.is_adj.adj.hom_equiv _ _).symm.injective

variables (A X)

lemma uncurry_id_eq_ev : uncurry (𝟙 (A ⟶[C] X)) = (ihom.ev A).app X :=
by rw [uncurry_eq, tensor_id, id_comp]

lemma curry_id_eq_coev : curry (𝟙 _) = (ihom.coev A).app X :=
by { rw [curry_eq, (ihom A).map_id (A ⊗ _)], apply comp_id }

section pre

variables {A B} [closed B]

/-- Pre-compose an internal hom with an external hom. -/
def pre (f : B ⟶ A) : ihom A ⟶ ihom B :=
transfer_nat_trans_self (ihom.adjunction _) (ihom.adjunction _) ((tensoring_left C).map f)

@[simp, reassoc]

@[simp]
lemma uncurry_pre (f : B ⟶ A) (X : C) :
  monoidal_closed.uncurry ((pre f).app X) = (f ⊗ 𝟙 _) ≫ (ihom.ev A).app X :=
by rw [uncurry_eq, id_tensor_pre_app_comp_ev]

@[simp, reassoc]
lemma coev_app_comp_pre_app (f : B ⟶ A) :
  (ihom.coev A).app X ≫ (pre f).app (A ⊗ X) =
    (ihom.coev B).app X ≫ (ihom B).map (f ⊗ (𝟙 _)) :=
unit_transfer_nat_trans_self _ _ ((tensoring_left C).map f) X

@[simp]
lemma pre_id (A : C) [closed A] : pre (𝟙 A) = 𝟙 _ :=
by { simp only [pre, functor.map_id], dsimp, simp, }

@[simp]
lemma pre_map {A₁ A₂ A₃ : C} [closed A₁] [closed A₂] [closed A₃]
  (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃) :
  pre (f ≫ g) = pre g ≫ pre f :=
by rw [pre, pre, pre, transfer_nat_trans_self_comp, (tensoring_left C).map_comp]

lemma pre_comm_ihom_map {W X Y Z : C} [closed W] [closed X]
  (f : W ⟶ X) (g : Y ⟶ Z) :
  (pre f).app Y ≫ (ihom W).map g = (ihom X).map g ≫ (pre f).app Z := by simp

end pre

/-- The internal hom functor given by the monoidal closed structure. -/
@[simps]
def internal_hom [monoidal_closed C] : Cᵒᵖ ⥤ C ⥤ C :=
{ obj := λ X, ihom X.unop,
  map := λ X Y f, pre f.unop }

section of_equiv

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

/-- Transport the property of being monoidal closed across a monoidal equivalence of categories -/
noncomputable
def of_equiv (F : monoidal_functor C D) [is_equivalence F.to_functor] [h : monoidal_closed D] :
  monoidal_closed C :=
{ closed' := λ X,
  { is_adj := begin
      haveI q : closed (F.to_functor.obj X) := infer_instance,
      haveI : is_left_adjoint (tensor_left (F.to_functor.obj X)) := q.is_adj,
      have i := comp_inv_iso (monoidal_functor.comm_tensor_left F X),
      exact adjunction.left_adjoint_of_nat_iso i,
    end } }

/-- Suppose we have a monoidal equivalence `F : C ≌ D`, with `D` monoidal closed. We can pull the
monoidal closed instance back along the equivalence. For `X, Y, Z : C`, this lemma describes the
resulting currying map `Hom(X ⊗ Y, Z) → Hom(Y, (X ⟶[C] Z))`. (`X ⟶[C] Z` is defined to be
`F⁻¹(F(X) ⟶[D] F(Z))`, so currying in `C` is given by essentially conjugating currying in
`D` by `F.`) -/
lemma of_equiv_curry_def (F : monoidal_functor C D) [is_equivalence F.to_functor]
  [h : monoidal_closed D] {X Y Z : C} (f : X ⊗ Y ⟶ Z) :
  @monoidal_closed.curry _ _ _ _ _ _ ((monoidal_closed.of_equiv F).1 _) f =
  (F.1.1.adjunction.hom_equiv Y ((ihom _).obj _)) (monoidal_closed.curry
  (F.1.1.inv.adjunction.hom_equiv (F.1.1.obj X ⊗ F.1.1.obj Y) Z
  ((comp_inv_iso (F.comm_tensor_left X)).hom.app Y ≫ f))) := rfl

/-- Suppose we have a monoidal equivalence `F : C ≌ D`, with `D` monoidal closed. We can pull the
monoidal closed instance back along the equivalence. For `X, Y, Z : C`, this lemma describes the
resulting uncurrying map `Hom(Y, (X ⟶[C] Z)) → Hom(X ⊗ Y ⟶ Z)`. (`X ⟶[C] Z` is
defined to be `F⁻¹(F(X) ⟶[D] F(Z))`, so uncurrying in `C` is given by essentially conjugating
uncurrying in `D` by `F.`) -/
lemma of_equiv_uncurry_def
  (F : monoidal_functor C D) [is_equivalence F.to_functor] [h : monoidal_closed D] {X Y Z : C}
  (f : Y ⟶ (@ihom _ _ _ X $ (monoidal_closed.of_equiv F).1 X).obj Z) :
  @monoidal_closed.uncurry _ _ _ _ _ _ ((monoidal_closed.of_equiv F).1 _) f =
  (comp_inv_iso (F.comm_tensor_left X)).inv.app Y ≫ (F.1.1.inv.adjunction.hom_equiv
  (F.1.1.obj X ⊗ F.1.1.obj Y) Z).symm (monoidal_closed.uncurry
  ((F.1.1.adjunction.hom_equiv Y ((ihom (F.1.1.obj X)).obj (F.1.1.obj Z))).symm f)) :=
rfl

end of_equiv

end monoidal_closed

end category_theory


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude

universes u v w

@[inline] def id {α : Sort u} (a : α) : α := a

/-
The kernel definitional equality test (t =?= s) has special support for idDelta applications.
It implements the following rules

   1)   (idDelta t) =?= t
   2)   t =?= (idDelta t)
   3)   (idDelta t) =?= s  IF (unfoldOf t) =?= s
   4)   t =?= idDelta s    IF t =?= (unfoldOf s)

This is mechanism for controlling the delta reduction (aka unfolding) used in the kernel.

We use idDelta applications to address performance problems when Type checking
theorems generated by the equation Compiler.
-/
@[inline] def idDelta {α : Sort u} (a : α) : α := a

/- `idRhs` is an auxiliary declaration used to implement "smart unfolding". It is used as a marker. -/
@[macroInline, reducible] def idRhs (α : Sort u) (a : α) : α := a

abbrev Function.comp {α : Sort u} {β : Sort v} {δ : Sort w} (f : β → δ) (g : α → β) : α → δ :=
  fun x => f (g x)

abbrev Function.const {α : Sort u} (β : Sort v) (a : α) : β → α :=
  fun x => a

@[reducible] def inferInstance {α : Type u} [i : α] : α := i
@[reducible] def inferInstanceAs (α : Type u) [i : α] : α := i

set_option bootstrap.inductiveCheckResultingUniverse false in
inductive PUnit : Sort u
  | unit : PUnit

/-- An abbreviation for `PUnit.{0}`, its most common instantiation.
    This Type should be preferred over `PUnit` where possible to avoid
    unnecessary universe parameters. -/
abbrev Unit : Type := PUnit

@[matchPattern] abbrev Unit.unit : Unit := PUnit.unit

/-- Auxiliary unsafe constant used by the Compiler when erasing proofs from code. -/
unsafe axiom lcProof {α : Prop} : α

/-- Auxiliary unsafe constant used by the Compiler to mark unreachable code. -/
unsafe axiom lcUnreachable {α : Sort u} : α

inductive True : Prop
  | intro : True

inductive False : Prop

inductive Empty : Type

def Not (a : Prop) : Prop := a → False

@[macroInline] def False.elim {C : Sort u} (h : False) : C :=
  False.rec (fun _ => C) h

@[macroInline] def absurd {a : Prop} {b : Sort v} (h₁ : a) (h₂ : Not a) : b :=
  False.elim (h₂ h₁)

inductive Eq {α : Sort u} (a : α) : α → Prop
  | refl {} : Eq a a

abbrev Eq.ndrec.{u1, u2} {α : Sort u2} {a : α} {motive : α → Sort u1} (m : motive a) {b : α} (h : Eq a b) : motive b :=
  Eq.rec (motive := fun α _ => motive α) m h

@[matchPattern] def rfl {α : Sort u} {a : α} : Eq a a := Eq.refl a

theorem Eq.subst {α : Sort u} {motive : α → Prop} {a b : α} (h₁ : Eq a b) (h₂ : motive a) : motive b :=
  Eq.ndrec h₂ h₁

theorem Eq.symm {α : Sort u} {a b : α} (h : Eq a b) : Eq b a :=
  h ▸ rfl

@[macroInline] def cast {α β : Sort u} (h : Eq α β) (a : α) : β :=
  Eq.rec (motive := fun α _ => α) a h

theorem congrArg {α : Sort u} {β : Sort v} {a₁ a₂ : α} (f : α → β) (h : Eq a₁ a₂) : Eq (f a₁) (f a₂) :=
  h ▸ rfl

/-
Initialize the Quotient Module, which effectively adds the following definitions:

constant Quot {α : Sort u} (r : α → α → Prop) : Sort u

constant Quot.mk {α : Sort u} (r : α → α → Prop) (a : α) : Quot r

constant Quot.lift {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) :
  (∀ a b : α, r a b → Eq (f a) (f b)) → Quot r → β

constant Quot.ind {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} :
  (∀ a : α, β (Quot.mk r a)) → ∀ q : Quot r, β q
-/
init_quot

inductive HEq {α : Sort u} (a : α) : {β : Sort u} → β → Prop
  | refl {} : HEq a a

@[matchPattern] def HEq.rfl {α : Sort u} {a : α} : HEq a a :=
  HEq.refl a

theorem eqOfHEq {α : Sort u} {a a' : α} (h : HEq a a') : Eq a a' :=
  have : (α β : Sort u) → (a : α) → (b : β) → HEq a b → (h : Eq α β) → Eq (cast h a) b :=
    fun α β a b h₁ =>
      HEq.rec (motive := fun {β} (b : β) (h : HEq a b) => (h₂ : Eq α β) → Eq (cast h₂ a) b)
        (fun (h₂ : Eq α α) => rfl)
        h₁
  this α α a a' h rfl

structure Prod (α : Type u) (β : Type v) :=
  (fst : α) (snd : β)

attribute [unbox] Prod

/-- Similar to `Prod`, but `α` and `β` can be propositions.
   We use this Type internally to automatically generate the brecOn recursor. -/
structure PProd (α : Sort u) (β : Sort v) :=
  (fst : α) (snd : β)

/-- Similar to `Prod`, but `α` and `β` are in the same universe. -/
structure MProd (α β : Type u) :=
  (fst : α) (snd : β)

structure And (a b : Prop) : Prop :=
  intro :: (left : a) (right : b)

inductive Or (a b : Prop) : Prop
  | inl (h : a) : Or a b
  | inr (h : b) : Or a b

inductive Bool : Type
  | false : Bool
  | true : Bool

export Bool (false true)

/- Remark: Subtype must take a Sort instead of Type because of the axiom strongIndefiniteDescription. -/
structure Subtype {α : Sort u} (p : α → Prop) :=
  (val : α) (property : p val)

/-- Gadget for optional parameter support. -/
@[reducible] def optParam (α : Sort u) (default : α) : Sort u := α

/-- Gadget for marking output parameters in type classes. -/
@[reducible] def outParam (α : Sort u) : Sort u := α

/-- Auxiliary Declaration used to implement the notation (a : α) -/
@[reducible] def typedExpr (α : Sort u) (a : α) : α := a

/-- Auxiliary Declaration used to implement the named patterns `x@p` -/
@[reducible] def namedPattern {α : Sort u} (x a : α) : α := a

/- Auxiliary axiom used to implement `sorry`. -/
axiom sorryAx (α : Sort u) (synthetic := true) : α

theorem eqFalseOfNeTrue : {b : Bool} → Not (Eq b true) → Eq b false
  | true, h => False.elim (h rfl)
  | false, h => rfl

theorem eqTrueOfNeFalse : {b : Bool} → Not (Eq b false) → Eq b true
  | true, h => rfl
  | false, h => False.elim (h rfl)

theorem neFalseOfEqTrue : {b : Bool} → Eq b true → Not (Eq b false)
  | true, _  => fun h => Bool.noConfusion h
  | false, h => Bool.noConfusion h

theorem neTrueOfEqFalse : {b : Bool} → Eq b false → Not (Eq b true)
  | true, h  => Bool.noConfusion h
  | false, _ => fun h => Bool.noConfusion h

class Inhabited (α : Sort u) :=
  mk {} :: (default : α)

constant arbitrary (α : Sort u) [s : Inhabited α] : α :=
  @Inhabited.default α s

instance (α : Sort u) {β : Sort v} [Inhabited β] : Inhabited (α → β) := {
  default := fun _ => arbitrary β
}

instance (α : Sort u) {β : α → Sort v} [(a : α) → Inhabited (β a)] : Inhabited ((a : α) → β a) := {
  default := fun a => arbitrary (β a)
}

/-- Universe lifting operation from Sort to Type -/
structure PLift (α : Sort u) : Type u :=
  up :: (down : α)

/- Bijection between α and PLift α -/
theorem PLift.upDown {α : Sort u} : ∀ (b : PLift α), Eq (up (down b)) b
  | up a => rfl

theorem PLift.downUp {α : Sort u} (a : α) : Eq (down (up a)) a :=
  rfl

/- Pointed types -/
structure PointedType :=
  (type : Type u)
  (val : type)

instance : Inhabited PointedType.{u} := {
  default := { type := PUnit.{u+1}, val := ⟨⟩ }
}

/-- Universe lifting operation -/
structure ULift.{r, s} (α : Type s) : Type (max s r) :=
  up :: (down : α)

/- Bijection between α and ULift.{v} α -/
theorem ULift.upDown {α : Type u} : ∀ (b : ULift.{v} α), Eq (up (down b)) b
  | up a => rfl

theorem ULift.downUp {α : Type u} (a : α) : Eq (down (up.{v} a)) a :=
  rfl

class inductive Decidable (p : Prop)
  | isFalse (h : Not p) : Decidable p
  | isTrue  (h : p) : Decidable p

@[inlineIfReduce, nospecialize] def Decidable.decide (p : Prop) [h : Decidable p] : Bool :=
  Decidable.casesOn (motive := fun _ => Bool) h (fun _ => false) (fun _ => true)

export Decidable (isTrue isFalse decide)

abbrev DecidablePred {α : Sort u} (r : α → Prop) :=
  (a : α) → Decidable (r a)

abbrev DecidableRel {α : Sort u} (r : α → α → Prop) :=
  (a b : α) → Decidable (r a b)

abbrev DecidableEq (α : Sort u) :=
  (a b : α) → Decidable (Eq a b)

def decEq {α : Sort u} [s : DecidableEq α] (a b : α) : Decidable (Eq a b) :=
  s a b

theorem decideEqTrue : {p : Prop} → [s : Decidable p] → p → Eq (decide p) true
  | _, isTrue  _, _   => rfl
  | _, isFalse h₁, h₂ => absurd h₂ h₁

theorem decideEqTrue' : [s : Decidable p] → p → Eq (decide p) true
  | isTrue  _, _   => rfl
  | isFalse h₁, h₂ => absurd h₂ h₁

theorem decideEqFalse : {p : Prop} → [s : Decidable p] → Not p → Eq (decide p) false
  | _, isTrue  h₁, h₂ => absurd h₁ h₂
  | _, isFalse h, _   => rfl

theorem ofDecideEqTrue {p : Prop} [s : Decidable p] : Eq (decide p) true → p := fun h =>
  match s with
  | isTrue  h₁ => h₁
  | isFalse h₁ => absurd h (neTrueOfEqFalse (decideEqFalse h₁))

theorem ofDecideEqFalse {p : Prop} [s : Decidable p] : Eq (decide p) false → Not p := fun h =>
  match s with
  | isTrue  h₁ => absurd h (neFalseOfEqTrue (decideEqTrue h₁))
  | isFalse h₁ => h₁

@[inline] instance : DecidableEq Bool :=
  fun a b => match a, b with
   | false, false => isTrue rfl
   | false, true  => isFalse (fun h => Bool.noConfusion h)
   | true, false  => isFalse (fun h => Bool.noConfusion h)
   | true, true   => isTrue rfl

class BEq      (α : Type u) := (beq : α → α → Bool)

open BEq (beq)

instance {α : Type u} [DecidableEq α] : BEq α :=
  ⟨fun a b => decide (Eq a b)⟩

-- We use "dependent" if-then-else to be able to communicate the if-then-else condition
-- to the branches
@[macroInline] def dite {α : Sort u} (c : Prop) [h : Decidable c] (t : c → α) (e : Not c → α) : α :=
  Decidable.casesOn (motive := fun _ => α) h e t