diff discrete.agda @ 803:984d20c10c87

simpler graph to category
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Thu, 25 Apr 2019 10:37:27 +0900
parents 82a8c1ab4ef5
children 2716d2945730
line wrap: on
line diff
--- a/discrete.agda	Thu Apr 25 03:50:30 2019 +0900
+++ b/discrete.agda	Thu Apr 25 10:37:27 2019 +0900
@@ -6,71 +6,54 @@
 open import Relation.Binary.Core
 open import Relation.Binary.PropositionalEquality hiding ( [_] ; sym )
 
-
+record Graph : Set (Level.suc Level.zero ) where
+  field
+    obj : Set
+    hom : obj  → obj → Set
 
 module graphtocat where
 
-  data Arrow { obj : Set } { hom : obj → obj → Set } : ( a b : obj ) → Set where
-    id : ( a : obj ) → Arrow a a
-    mono : { a b : obj } → hom a b → Arrow a b
-    connected : {a b : obj } → {c : obj} → hom b c →  Arrow {obj} {hom} a b → Arrow a c
+  open import Relation.Binary.PropositionalEquality 
 
-  _+_ : { obj : Set } { hom : obj → obj → Set } {a b c : obj   } (f : (Arrow {obj} {hom} b c )) → (g : (Arrow {obj} {hom} a b )) → Arrow {obj} {hom} a c
-  id a + id .a = id a
-  id b + mono x = mono x
-  id a + connected x y = connected x y
-  mono x + id a = mono x
-  mono x + mono y = connected x (mono y)
-  mono x + connected y z = connected x ( connected y z )
-  connected x y + z = connected x ( y + z )
+  data Chain { g : Graph } : ( a b : Graph.obj g ) → Set where
+       id : ( a : Graph.obj g ) → Chain a a
+       next : { a b c : Graph.obj g } → (Graph.hom g b c ) → Chain {g} a b → Chain  a c
 
-  assoc-+ : { obj : Set } { hom : obj → obj → Set }  {a b c d : obj   }
-       (f : (Arrow  {obj} {hom} c d )) → (g : (Arrow {obj} {hom} b c )) → (h : (Arrow {obj} {hom} a b )) →
-       ( f + (g + h)) ≡  ((f + g) + h )
-  assoc-+ (id a) (id .a) (id .a) = refl
-  assoc-+ (id a) (id .a) (mono x) = refl
-  assoc-+ (id a) (id .a) (connected h h₁) = refl
-  assoc-+ (id a) (mono x) (id a₁) = refl
-  assoc-+ (id a) (mono x) (mono x₁) = refl
-  assoc-+ (id a) (mono x) (connected h h₁) = refl
-  assoc-+ (id a) (connected g h) _ = refl
-  assoc-+ (mono x) (id a) (id .a) = refl
-  assoc-+ (mono x) (id a) (mono x₁) = refl
-  assoc-+ (mono x) (id a) (connected h h₁) = refl
-  assoc-+ (mono x) (mono x₁) (id a) = refl
-  assoc-+ (mono x) (mono x₁) (mono x₂) = refl
-  assoc-+ (mono x) (mono x₁) (connected h h₁) = refl
-  assoc-+ (mono x) (connected g g₁) _ = refl
-  assoc-+ (connected f g) (x) (y) = cong (λ k → connected f k) (assoc-+ g x y )
-
-  open import Relation.Binary.PropositionalEquality renaming ( cong to ≡-cong )
-
-  GraphtoCat : ( obj : Set ) ( hom : obj → obj → Set ) →  Category  Level.zero Level.zero Level.zero   
-  GraphtoCat  obj hom  = record {
-            Obj  = obj ;
-            Hom = λ a b →   Arrow a b  ;
-            _o_ =  λ{a} {b} {c} x y → _+_  x y ;
+  GraphtoCat : (G : Graph )  →  Category  Level.zero Level.zero Level.zero   
+  GraphtoCat G = record {
+            Obj  = Graph.obj G ;
+            Hom = λ a b →  Chain {G} a b ;
+            _o_ =  λ{a} {b} {c} x y → x ++ y ;
             _≈_ =  λ x y → x  ≡ y ;
             Id  =  λ{a} → id a ;
             isCategory  = record {
                     isEquivalence =  record {refl = refl ; trans = trans ; sym = sym } ;
-                    identityL  = λ{a b f} → identityL    {a} {b} {f} ;
-                    identityR  = λ{a b f} → identityR    {a} {b} {f} ;
-                    o-resp-≈  = λ{a b c f g h i} →  o-resp-≈     {a} {b} {c} {f} {g} {h} {i} ;
-                    associative  = λ{a b c d f g h } → assoc-+  f g h
+                    identityL  = identityL; 
+                    identityR  = identityR ; 
+                    o-resp-≈  = o-resp-≈  ; 
+                    associative  = λ{a b c d f g h } → associative  f g h
                }
            }  where
-                identityL :   {A B : obj } {f : ( Arrow    A B) } →  ((id B)  + f)  ≡ f
-                identityL {_} {_} {id a} = refl
-                identityL {_} {_} {mono x} = refl
-                identityL {_} {_} {connected x f} = refl
-                identityR :   {A B : obj } {f : ( Arrow {obj} {hom}  A B) } →   ( f + id A )  ≡ f
-                identityR {_} {_} {id a} = refl
-                identityR {_} {_} {mono x} = refl
-                identityR {_} {_} {connected x f} =  cong (λ k → connected x k) ( identityR {_} {_} {f} )
-                o-resp-≈ :   {A B C : obj   } {f g :  ( Arrow    A B)} {h i : ( Arrow B C)} →
-                    f  ≡ g → h  ≡ i → ( h + f )  ≡ ( i + g )
-                o-resp-≈     {a} {b} {c} {f} {.f} {h} {.h}  refl refl = refl
+               open Chain
+               obj = Graph.obj G
+               hom = Graph.hom G
+               _++_ : {a b c : obj } (f : Chain {G} b c ) → (g : Chain {G} a b) → Chain {G} a c
+               id _ ++ f = f
+               (next x f) ++ g = next x ( f ++ g )
+
+               identityL : {A B : Graph.obj G} {f : Chain A B} → (id B ++ f) ≡ f
+               identityL = refl
+               identityR : {A B : Graph.obj G} {f : Chain A B} → (f ++ id A) ≡ f
+               identityR {a} {_} {id a} = refl
+               identityR {a} {b} {next x f} = cong ( λ k → next x k ) ( identityR {_} {_} {f} )
+               o-resp-≈  : {A B C : Graph.obj G} {f g : Chain A B} {h i : Chain B C} →
+                            f ≡ g → h ≡ i → (h ++ f) ≡ (i ++ g)
+               o-resp-≈  refl refl = refl
+               associative : {a b c d : Graph.obj G} (f : Chain c d) (g : Chain b c) (h : Chain a b) →
+                            (f ++ (g ++ h)) ≡ ((f ++ g) ++ h)
+               associative (id a) g h = refl
+               associative (next x f) g h = cong ( λ k → next x k ) ( associative f g h )
+
 
 
 data  TwoObject   : Set  where
@@ -95,7 +78,7 @@
    arrow-g :  TwoHom t0 t1
 
 TwoCat' : Category  Level.zero Level.zero Level.zero
-TwoCat'  = GraphtoCat TwoObject TwoHom 
+TwoCat'  = GraphtoCat ( record { obj = TwoObject ; hom = TwoHom } )
    where open graphtocat
 
 _×_ :  {a b c : TwoObject } →  TwoHom   b c  →  TwoHom   a b   →  TwoHom   a c 
@@ -167,7 +150,7 @@
 open import Data.Empty
 
 DiscreteCat' : (S : Set) → Category  Level.zero Level.zero Level.zero
-DiscreteCat'  S = GraphtoCat S ( λ _ _ →  ⊥  )
+DiscreteCat'  S = GraphtoCat ( record { obj = S ; hom = ( λ _ _ →  ⊥  ) } )
    where open graphtocat 
 
 record DiscreteHom { c₁ : Level} { S : Set c₁} (a : S) (b : S)