Mercurial > hg > Members > kono > Proof > category
diff free-monoid.agda @ 168:a9b4132d619b
fix
author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
---|---|
date | Tue, 20 Aug 2013 17:57:22 +0900 |
parents | c3863043c4a3 |
children | 44bf6e78f891 |
line wrap: on
line diff
--- a/free-monoid.agda Mon Aug 19 18:14:19 2013 +0900 +++ b/free-monoid.agda Tue Aug 20 17:57:22 2013 +0900 @@ -68,7 +68,7 @@ field morph : Carrier a -> Carrier b identity : morph (ε a) ≡ ε b - mdistr : ∀{x y} -> morph ( _∙_ a x y ) ≡ ( _∙_ b (morph x ) (morph y) ) + homo : ∀{x y} -> morph ( _∙_ a x y ) ≡ ( _∙_ b (morph x ) (morph y) ) open Monomorph @@ -76,25 +76,26 @@ _+_ {a} {b} {c} f g = record { morph = \x -> morph f ( morph g x ) ; identity = identity1 ; - mdistr = mdistr1 + homo = homo1 } where identity1 : morph f ( morph g (ε a) ) ≡ ε c -- morph f (ε b) = ε c , morph g (ε a) ) ≡ ε b -- morph f morph g (ε a) ) ≡ morph f (ε b) = ε c identity1 = trans ( ≡-cong (morph f ) ( identity g ) ) ( identity f ) - mdistr1 : ∀{x y} -> morph f ( morph g ( _∙_ a x y )) ≡ ( _∙_ c (morph f (morph g x )) (morph f (morph g y) ) ) + homo1 : ∀{x y} -> morph f ( morph g ( _∙_ a x y )) ≡ ( _∙_ c (morph f (morph g x )) (morph f (morph g y) ) ) -- ∀{x y} -> morph f ( morph g ( _∙_ a x y )) ≡ morph f ( ( _∙_ c (morph g x )) (morph g y) ) - -- ∀{x y} -> morph f ( ( _∙_ c (morph g x )) (morph g y) ) ≡ ( _∙_ c (morph f (morph g x )) (morph f (morph g y) ) ) - mdistr1 = trans (≡-cong (morph f ) ( mdistr g) ) ( mdistr f ) + -- ∀{x y} -> morph f ( ( _∙_ c (morph g x )) (morph g y) ) + -- ≡ ( _∙_ c (morph f (morph g x )) (morph f (morph g y) ) ) + homo1 = trans (≡-cong (morph f ) ( homo g) ) ( homo f ) M-id : { a : ≡-Monoid } -> Monomorph a a -M-id = record { morph = \x -> x ; identity = refl ; mdistr = refl } +M-id = record { morph = \x -> x ; identity = refl ; homo = refl } _==_ : { a b : ≡-Monoid } -> Monomorph a b -> Monomorph a b -> Set c _==_ f g = morph f ≡ morph g -isMonoidCategory : IsCategory ≡-Monoid Monomorph _==_ _+_ (M-id) -isMonoidCategory = record { isEquivalence = isEquivalence1 +isMonoids : IsCategory ≡-Monoid Monomorph _==_ _+_ (M-id) +isMonoids = record { isEquivalence = isEquivalence1 ; identityL = refl ; identityR = refl ; associative = refl @@ -110,18 +111,18 @@ ; sym = sym ; trans = trans } -MonoidCategory : Category _ _ _ -MonoidCategory = +Monoids : Category _ _ _ +Monoids = record { Obj = ≡-Monoid ; Hom = Monomorph ; _o_ = _+_ ; _≈_ = _==_ ; Id = M-id - ; isCategory = isMonoidCategory + ; isCategory = isMonoids } A = Sets {c} -B = MonoidCategory +B = Monoids open Functor @@ -167,20 +168,20 @@ solution a b f = record { morph = \(l : List a) -> Φ l ; identity = refl ; - mdistr = \{x y} -> mdistr1 x y + homo = \{x y} -> homo1 x y } where _*_ : Carrier b -> Carrier b -> Carrier b _*_ f g = _∙_ b f g - mdistr1 : (x y : Carrier (Generator a)) → Φ ((Generator a ∙ x) y) ≡ (b ∙ Φ x) (Φ y) - mdistr1 [] y = sym (proj₁ ( IsMonoid.identity ( isMonoid b) ) (Φ y)) - mdistr1 (x :: xs) y = let open ≡-Reasoning in + homo1 : (x y : Carrier (Generator a)) → Φ ((Generator a ∙ x) y) ≡ (b ∙ Φ x) (Φ y) + homo1 [] y = sym (proj₁ ( IsMonoid.identity ( isMonoid b) ) (Φ y)) + homo1 (x :: xs) y = let open ≡-Reasoning in sym ( begin (Φ {a} {b} {f} (x :: xs)) * (Φ {a} {b} {f} y) ≡⟨⟩ ((f x) * (Φ {a} {b} {f} xs)) * (Φ {a} {b} {f} y) ≡⟨ ( IsMonoid.assoc ( isMonoid b )) _ _ _ ⟩ (f x) * ( (Φ {a} {b} {f} xs) * (Φ {a} {b} {f} y) ) - ≡⟨ sym ( (IsMonoid.∙-cong (isMonoid b)) refl (mdistr1 xs y )) ⟩ + ≡⟨ sym ( (IsMonoid.∙-cong (isMonoid b)) refl (homo1 xs y )) ⟩ (f x) * ( Φ {a} {b} {f} ( xs ++ y ) ) ≡⟨⟩ Φ {a} {b} {f} ( x :: ( xs ++ y ) ) @@ -193,8 +194,8 @@ eta : (a : Obj A) → Hom A a ( FObj U (Generator a) ) eta a = \( x : a ) -> x :: [] --- Functional Extensionarity Axiom (We cannot prove this in Agda / Coq, just assumming ) -postulate Extensionarity : { a b : Obj A } {f g : Hom A a b } → (∀ {x} → (f x ≡ g x)) → ( f ≡ g ) +-- Functional Extensionality Axiom (We cannot prove this in Agda / Coq, just assumming ) +postulate Extensionality : { a b : Obj A } {f g : Hom A a b } → (∀ {x} → (f x ≡ g x)) → ( f ≡ g ) FreeMonoidUniveralMapping : UniversalMapping A B U Generator eta FreeMonoidUniveralMapping = @@ -217,7 +218,7 @@ ( λ (x : a ) → _∙_ b ( f x ) (Φ {a} {b} {f} [] ) ) ≡⟨⟩ ( λ (x : a ) → _∙_ b ( f x ) ( ε b ) ) - ≡⟨ ≡-cong ( \ g -> ( ( λ (x : a ) → g x ) )) (Extensionarity lemma-ext1) ⟩ + ≡⟨ ≡-cong ( \ g -> ( ( λ (x : a ) → g x ) )) (Extensionality lemma-ext1) ⟩ ( λ (x : a ) → f x ) ≡⟨⟩ f @@ -227,7 +228,7 @@ uniquness : {a : Obj A } {b : Obj B} { f : Hom A a (FObj U b) } → { g : Hom B (Generator a) b } → (FMap U g) o (eta a ) ≡ f → B [ solution a b f ≈ g ] uniquness {a} {b} {f} {g} eq = - Extensionarity ( lemma-ext2 ) where + Extensionality ( lemma-ext2 ) where lemma-ext2 : ( ∀{ x : List a } -> (morph ( solution a b f)) x ≡ (morph g) x ) -- (morph ( solution a b f)) [] ≡ (morph g) [] ) lemma-ext2 {[]} = let open ≡-Reasoning in @@ -241,19 +242,19 @@ lemma-ext2 {x :: xs} = let open ≡-Reasoning in begin (morph ( solution a b f)) ( x :: xs ) - ≡⟨ mdistr ( solution a b f) {x :: []} {xs} ⟩ + ≡⟨ homo ( solution a b f) {x :: []} {xs} ⟩ _∙_ b ((morph ( solution a b f)) ( x :: []) ) ((morph ( solution a b f)) xs ) ≡⟨ ≡-cong ( \ k -> (_∙_ b ((morph ( solution a b f)) ( x :: []) ) k )) (lemma-ext2 {xs} ) ⟩ _∙_ b ((morph ( solution a b f)) ( x :: []) ) ((morph g) ( xs )) ≡⟨ ≡-cong ( \k -> ( _∙_ b ( k x ) ((morph g) ( xs )) )) ( begin ( \x -> (morph ( solution a b f)) ( x :: [] ) ) - ≡⟨ Extensionarity lemma-ext3 ⟩ + ≡⟨ Extensionality lemma-ext3 ⟩ ( \x -> (morph g) ( x :: [] ) ) ∎ ) ⟩ _∙_ b ((morph g) ( x :: [] )) ((morph g) ( xs )) - ≡⟨ sym ( mdistr g ) ⟩ + ≡⟨ sym ( homo g ) ⟩ (morph g) ( x :: xs ) ∎ where lemma-ext3 : ∀{ x : a } -> (morph ( solution a b f)) (x :: []) ≡ (morph g) ( x :: [] )