Mercurial > hg > Members > kono > Proof > category
changeset 891:2685eaaa8763
return to Sets and SM
author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
---|---|
date | Mon, 13 Apr 2020 08:52:35 +0900 |
parents | f52d21eaada4 |
children | ad0732c51d38 |
files | CCCGraph.agda |
diffstat | 1 files changed, 23 insertions(+), 27 deletions(-) [+] |
line wrap: on
line diff
--- a/CCCGraph.agda Mon Apr 13 08:10:40 2020 +0900 +++ b/CCCGraph.agda Mon Apr 13 08:52:35 2020 +0900 @@ -165,31 +165,27 @@ -- open import Category.Sets -- postulate extensionality : { c₁ c₂ ℓ : Level} ( A : Category c₁ c₂ ℓ ) → Relation.Binary.PropositionalEquality.Extensionality c₂ c₂ - data SL : (t : Objs ) → Set (c₁ ⊔ c₂) where - term : SL ⊤ - value : (x : vertex G) → SL (atom x) - _::_ : {a b : vertex G} → (f : edge G a b ) → (prev : SL (atom a)) → SL (atom b) - _,_ : {a b : Objs } → (f : SL a ) → (g : SL b) → SL (a ∧ b) - func : {a b : Objs } → ( f : SL a → SL b) → SL (b <= a ) -- tail of f should be a SL a - - _+_ : { a b c : Objs } → ( SL b → SL c ) → ( SL a → SL b ) → SL a → SL c - _+_ f g x = f ( g x ) + record SM : Set (suc (c₁ ⊔ c₂)) where + field + sobj : vertex G → Set (c₁ ⊔ c₂) + smap : { a b : vertex G } → edge G a b → sobj a → sobj b + open SM - append : { a b : Objs } → SL a → SL b → SL a - append f g = {!!} + fobj : {G : SM} ( a : Objs ) → Set (c₁ ⊔ c₂) + fobj {G} (atom x) = sobj G x + fobj ⊤ = One + fobj {G} (a ∧ b) = ( fobj {G} a /\ fobj {G} b) + fobj {G} (a <= b) = fobj {G} b → fobj {G} a - fobj : ( a : Objs ) → Set (c₁ ⊔ c₂) - fobj a = SL a - - fmap : { a b : Objs } → Hom PL a b → fobj a → fobj b - amap : { a b : Objs } → Arrow a b → fobj a → fobj b - amap (arrow x) a = x :: a + fmap : {G : SM } { a b : Objs } → Hom PL a b → fobj {G} a → fobj {G} b + amap : {G : SM } { a b : Objs } → Arrow a b → fobj {G} a → fobj {G} b + amap {G} (arrow x) = smap G x amap π ( x , y ) = x amap π' ( x , y ) = y - amap ε (func f , x ) = f x - amap (f *) x = func (λ y → fmap f ( x , y ) ) + amap ε (f , x ) = f x + amap (f *) x = λ y → fmap f ( x , y ) fmap (id a) x = x - fmap (○ a) x = term + fmap (○ a) x = OneObj fmap < f , g > x = ( fmap f x , fmap g x ) fmap (iv x f) a = amap x ( fmap f a ) @@ -197,19 +193,19 @@ -- Sets is CCC, so we have a cartesian closed category generated by a graph -- as a sub category of Sets - CS : Functor PL (Sets {c₁ ⊔ c₂}) - FObj CS a = fobj a - FMap CS {a} {b} f = fmap {a} {b} f + CS : {G : SM} → Functor PL (Sets {c₁ ⊔ c₂}) + FObj (CS {G}) a = fobj {G} a + FMap (CS {G}) {a} {b} f = fmap {G} {a} {b} f isFunctor CS = isf where - _++_ = Category._o_ PL + _+_ = Category._o_ PL ++idR = IsCategory.identityR ( Category.isCategory PL ) - distr : {a b c : Obj PL} { f : Hom PL a b } { g : Hom PL b c } → (z : fobj a ) → fmap (g ++ f) z ≡ fmap g (fmap f z) + distr : {a b c : Obj PL} { f : Hom PL a b } { g : Hom PL b c } → (z : fobj a ) → fmap (g + f) z ≡ fmap g (fmap f z) distr {a} {a₁} {a₁} {f} {id a₁} z = refl distr {a} {a₁} {⊤} {f} {○ a₁} z = refl distr {a} {b} {c ∧ d} {f} {< g , g₁ >} z = cong₂ (λ j k → j , k ) (distr {a} {b} {c} {f} {g} z) (distr {a} {b} {d} {f} {g₁} z) distr {a} {b} {c} {f} {iv {_} {_} {d} x g} z = adistr (distr {a} {b} {d} {f} {g} z) x where - adistr : fmap (g ++ f) z ≡ fmap g (fmap f z) → - ( x : Arrow d c ) → fmap ( iv x (g ++ f) ) z ≡ fmap ( iv x g ) (fmap f z ) + adistr : fmap (g + f) z ≡ fmap g (fmap f z) → + ( x : Arrow d c ) → fmap ( iv x (g + f) ) z ≡ fmap ( iv x g ) (fmap f z ) adistr eq x = cong ( λ k → amap x k ) eq isf : IsFunctor PL Sets fobj fmap IsFunctor.identity isf = extensionality Sets ( λ x → refl )