Use EqReasoning and clean up some stuff

This commit is contained in:
Frederik Hanghøj Iversen 2018-01-21 01:03:40 +01:00
parent b379c3fed0
commit 0990a3778f

View file

@ -44,7 +44,7 @@ record Category { '} : Set (lsuc (' ⊔ )) where
open Category public open Category public
module _ { ' : Level} { : Category {} {'}} { A B : Object } where module _ { ' : Level} { : Category {} {'}} { A B : .Object } where
private private
open module = Category open module = Category
_+_ = ._⊕_ _+_ = ._⊕_
@ -59,36 +59,28 @@ module _ { ' : Level} { : Category {} {'}} { A B : Object } w
Monomorphism {X} f = ( g₀ g₁ : .Arrow X A ) f + g₀ f + g₁ g₀ g₁ Monomorphism {X} f = ( g₀ g₁ : .Arrow X A ) f + g₀ f + g₁ g₀ g₁
iso-is-epi : {X} (f : .Arrow A B) Isomorphism f Epimorphism {X = X} f iso-is-epi : {X} (f : .Arrow A B) Isomorphism f Epimorphism {X = X} f
-- Idea: Pre-compose with f- on both sides of the equality of eq to get
-- g₀ + f + f- ≡ g₁ + f + f-
-- which by left-inv reduces to the goal.
iso-is-epi f (f- , left-inv , right-inv) g₀ g₁ eq = iso-is-epi f (f- , left-inv , right-inv) g₀ g₁ eq =
trans (sym (fst .ident)) begin
( trans (cong (_+_ g₀) (sym right-inv)) g₀ ≡⟨ sym (fst .ident)
( trans .assoc g₀ + .𝟙 ≡⟨ cong (_+_ g₀) (sym right-inv)
( trans (cong (λ x x + f-) eq) g₀ + (f + f-) ≡⟨ .assoc
( trans (sym .assoc) (g₀ + f) + f- ≡⟨ cong (λ x x + f-) eq
( trans (cong (_+_ g₁) right-inv) (fst .ident)) (g₁ + f) + f- ≡⟨ sym .assoc
) g₁ + (f + f-) ≡⟨ cong (_+_ g₁) right-inv
) g₁ + .𝟙 ≡⟨ fst .ident
) g₁
)
iso-is-mono : {X} (f : .Arrow A B ) Isomorphism f Monomorphism {X = X} f iso-is-mono : {X} (f : .Arrow A B ) Isomorphism f Monomorphism {X = X} f
-- For the next goal we do something similar: Post-compose with f- and use
-- right-inv to get the goal.
iso-is-mono f (f- , (left-inv , right-inv)) g₀ g₁ eq = iso-is-mono f (f- , (left-inv , right-inv)) g₀ g₁ eq =
trans (sym (snd .ident)) begin
( trans (cong (λ x x + g₀) (sym left-inv)) g₀ ≡⟨ sym (snd .ident)
( trans (sym .assoc) .𝟙 + g₀ ≡⟨ cong (λ x x + g₀) (sym left-inv)
( trans (cong (_+_ f-) eq) (f- + f) + g₀ ≡⟨ sym .assoc
( trans .assoc f- + (f + g₀) ≡⟨ cong (_+_ f-) eq
( trans (cong (λ x x + g₁) left-inv) (snd .ident) f- + (f + g₁) ≡⟨ .assoc
) (f- + f) + g₁ ≡⟨ cong (λ x x + g₁) left-inv
) .𝟙 + g₁ ≡⟨ snd .ident
) g₁
)
)
iso-is-epi-mono : {X} (f : .Arrow A B ) Isomorphism f Epimorphism {X = X} f × Monomorphism {X = X} f iso-is-epi-mono : {X} (f : .Arrow A B ) Isomorphism f Epimorphism {X = X} f × Monomorphism {X = X} f
iso-is-epi-mono f iso = iso-is-epi f iso , iso-is-mono f iso iso-is-epi-mono f iso = iso-is-epi f iso , iso-is-mono f iso
@ -103,8 +95,6 @@ epi-mono-is-not-iso f =
-- Isomorphism of objects -- Isomorphism of objects
_≅_ : { ' : Level } { : Category {} {'} } ( A B : Object ) Set ' _≅_ : { ' : Level } { : Category {} {'} } ( A B : Object ) Set '
_≅_ { = } A B = Σ[ f .Arrow A B ] (Isomorphism { = } f) _≅_ { = } A B = Σ[ f .Arrow A B ] (Isomorphism { = } f)
where
open module = Category
IsProduct : { '} ( : Category {} {'}) {A B obj : Object } (π₁ : Arrow obj A) (π₂ : Arrow obj B) Set ( ') IsProduct : { '} ( : Category {} {'}) {A B obj : Object } (π₁ : Arrow obj A) (π₂ : Arrow obj B) Set ( ')
IsProduct {A = A} {B = B} π₁ π₂ IsProduct {A = A} {B = B} π₁ π₂
@ -113,17 +103,19 @@ IsProduct {A = A} {B = B} π₁ π₂
where where
open module = Category open module = Category
-- Consider this style for efficiency: -- Tip from Andrea; Consider this style for efficiency:
-- record R : Set where -- record IsProduct { ' : Level} ( : Category {} {'})
-- {A B obj : Object } (π₁ : Arrow obj A) (π₂ : Arrow obj B) : Set (') where
-- field -- field
-- isP : IsProduct {!!} {!!} {!!} -- isProduct : ∀ {X : .Object} (x₁ : .Arrow X A) (x₂ : .Arrow X B)
-- → ∃![ x ] ( ._⊕_ π₁ x ≡ x₁ × . _⊕_ π₂ x ≡ x₂)
record Product { ' : Level} { : Category {} {'}} (A B : Category.Object ) : Set ( ') where record Product { ' : Level} { : Category {} {'}} (A B : .Object) : Set ( ') where
no-eta-equality no-eta-equality
field field
obj : Category.Object obj : .Object
proj₁ : Category.Arrow obj A proj₁ : .Arrow obj A
proj₂ : Category.Arrow obj B proj₂ : .Arrow obj B
{{isProduct}} : IsProduct proj₁ proj₂ {{isProduct}} : IsProduct proj₁ proj₂
mutual mutual
@ -145,8 +137,9 @@ mutual
open module C = Category C open module C = Category C
open module D = Category D open module D = Category D
-- Two pairs are equal if their components are equal. -- Two pairs are equal if their components are equal.
eqpair : { : Level} { A : Set } { B : Set } { a a' : A } { b b' : B } a a' b b' (a , b) (a' , b') eqpair : {a b} {A : Set a} {B : Set b} {a a' : A} {b b' : B}
eqpair {a = a} {b = b} eqa eqb = subst eqa (subst eqb (refl {x = (a , b)})) a a' b b' (a , b) (a' , b')
eqpair eqa eqb i = eqa i , eqb i
-- arrowProduct : ∀ {} {C D : Category {} {}} → (Object C) × (Object D) → (Object C) × (Object D) → Set -- arrowProduct : ∀ {} {C D : Category {} {}} → (Object C) × (Object D) → (Object C) × (Object D) → Set