From e5294d23bff2837e2fda215a57846246cddb15d2 Mon Sep 17 00:00:00 2001 From: "U-COLORZ-STRIX\\Crazycolorz5" Date: Tue, 12 Sep 2017 13:53:27 -0400 Subject: [PATCH] Added tuple data, added instances for tuple as bifunctor, cleaned up Categories. --- Categories.hs | 88 +++++++++++++++++++++++++++++++++++---------------- DataTypes.hs | 53 +++++++++++++++++++++++++++++-- Scrap.hs | 18 +++++++++++ 3 files changed, 129 insertions(+), 30 deletions(-) diff --git a/Categories.hs b/Categories.hs index 8084186..65c4584 100644 --- a/Categories.hs +++ b/Categories.hs @@ -10,7 +10,8 @@ {-# LANGUAGE ConstraintKinds #-} module Categories (Empty, Category (..), Functor (..), Composition (..), liftComp, - Id, unId, NaturalTransformation (..), MonoidalCategory (..), + Id, IdentityFunctor (..), NaturalTransformation (..), MonoidalCategory (..), + Unitary (..), CMonoid (..), Monad (..), Endobifunctor (..)) where @@ -18,22 +19,23 @@ where class Category (cat :: k -> k -> *) obj | cat -> obj where (.) :: (obj c, obj d, obj b) => cat c d -> cat b c -> cat b d id :: (obj a) => cat a a + {- class (Category cat) => CartesianClosed cat where evaluationMap :: cat (a->b, a) b --Functor for exponentials? -} ---The empty constraint. -class Empty a -instance Empty a - -instance Category (->) Empty where - f . g = \x -> f (g x) - id = \x -> x class Functor f where fmap :: (a -> b) -> (f a -> f b) +class ContravariantFunctor f where + contramap :: (a -> b) -> (f b -> f a) + +class IdentityFunctor f where + appId :: a -> f a + unId :: f a -> a + --class Endofunctor f where -- endoMap :: c a b -> c (f a) (f b) @@ -45,42 +47,42 @@ instance (Functor f, Functor g) => Functor (Composition f g) where fmap f = Compose . fmap (fmap f) . unCompose data Id a = Id a -unId :: Id a -> a -unId (Id x) = x +instance IdentityFunctor Id where + appId = Id + unId (Id x) = x instance Functor Id where - fmap f (Id x) = Id (f x) - ---https://github.com/ku-fpg/natural-transformation/blob/master/src/Control/Natural.hs -data NaturalTransformation (f :: * -> *) (g :: * -> *) = (Functor f, Functor g) => NaturalTransformation { getNT :: forall x . f x -> g x } - -instance Category NaturalTransformation Functor where - (NaturalTransformation a) . (NaturalTransformation b) = NaturalTransformation (a . b) - id = NaturalTransformation id + fmap f = appId . f . unId class (Category cat obj) => Endobifunctor cat obj bf where appBF :: (obj a, obj b, obj c, obj d, obj (bf a c), obj (bf b d)) => cat a b -> cat c d -> cat (bf a c) (bf b d) -class (Category cat obj, Unitary cat obj o, Endobifunctor cat obj bi) => MonoidalCategory cat obj bi o | bi o -> cat --where --- assoc :: (obj (bi (bi a b) c), obj (bi a (bi b c))) => cat (bi (bi a b) c) (bi a (bi b c)) --- lunit :: (obj (bi o a), obj a) => cat (bi o a) a --- runit :: (obj (bi a o), obj a) => cat (bi a o) a +class (Category cat obj, Unitary cat obj o, Endobifunctor cat obj bi) => MonoidalCategory cat obj bi o | bi o -> cat where + assoc :: (obj (bi (bi a b) c), obj (bi a (bi b c)), obj a, obj b, obj c) => cat (bi (bi a b) c) (bi a (bi b c)) + lunit :: (obj (bi o a), obj o, obj a) => cat (bi o a) a + runit :: (obj (bi a o), obj o, obj a) => cat (bi a o) a class (Category c obj) => Unitary c obj o where unitId :: (obj o) => c o o -class (MonoidalCategory c obj bi o) => CMonoid c obj bi o (m :: k) | m -> c bi o where +class (MonoidalCategory c obj bi o) => CMonoid c obj bi o (m :: k) | m -> c obj bi o where mult :: (obj (bi m m), obj m) => c (bi m m) m unit :: (obj o, obj m) => c o m +--Category of Endofunctors with NaturalTransformations as arrows: +--https://github.com/ku-fpg/natural-transformation/blob/master/src/Control/Natural.hs +data NaturalTransformation (f :: * -> *) (g :: * -> *) = (Functor f, Functor g) => NaturalTransformation { getNT :: forall x . f x -> g x } +instance Category NaturalTransformation Functor where + (NaturalTransformation a) . (NaturalTransformation b) = NaturalTransformation (a . b) + id = NaturalTransformation id instance Unitary NaturalTransformation Functor Id where unitId = id - instance Endobifunctor NaturalTransformation Functor Composition where appBF (NaturalTransformation f) (NaturalTransformation g) = NaturalTransformation (Compose . f . fmap g . unCompose) - -instance MonoidalCategory NaturalTransformation Functor Composition Id - +instance MonoidalCategory NaturalTransformation Functor Composition Id where + assoc = NaturalTransformation (Compose . fmap Compose . unCompose . unCompose) + lunit = NaturalTransformation (unId . unCompose) + runit = NaturalTransformation (fmap unId . unCompose) class (Functor m, CMonoid NaturalTransformation Functor Composition Id m) => Monad m where --Literally just the monoid operations for a monoid in the category of endofunctors under composition eta :: NaturalTransformation Id m @@ -90,3 +92,35 @@ class (Functor m, CMonoid NaturalTransformation Functor Composition Id m) => Mon --Map to the inside then apply the mu transformation (>>=) :: m a -> (a -> m b) -> m b m >>= f = (getNT mu) (Compose (fmap f m)) + +--Category of Types with Functions as arrows: +--The empty constraint. +class Empty a +instance Empty a +instance Category (->) Empty where + f . g = \x -> f (g x) + id = \x -> x +data Unit = Unit +newtype Monoidal a = Monoidal a +instance IdentityFunctor Monoidal where + appId = Monoidal + unId (Monoidal a) = a +instance Unitary (->) Empty Unit where + unitId = id +instance Endobifunctor (->) Empty (,) where + appBF f g = \(a,b) -> (f a, g b) +instance MonoidalCategory (->) Empty (,) Unit where + assoc ((a,b),c) = (a,(b,c)) + lunit (Unit, a) = a + runit (a, Unit) = a +{- +instance (CMonoid (->) Empty (,) Unit a) => Monoid (Monoidal a) where + (*) (Monoidal a) (Monoidal b) = Monoidal (mult (a,b)) + one = Monoidal (unit Unit) +-} +instance Monoid a => CMonoid (->) Empty (,) Unit (Monoidal a) where + mult (Monoidal a, Monoidal b) = Monoidal (a*b) + unit _ = Monoidal one +instance Monoid a => Monoid (Monoidal a) where + (*) (Monoidal a) (Monoidal b) = Monoidal (a*b) + one = Monoidal one diff --git a/DataTypes.hs b/DataTypes.hs index 7dc4ab0..87afb04 100644 --- a/DataTypes.hs +++ b/DataTypes.hs @@ -1,12 +1,18 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} module DataTypes where import Categories import Groups import Data.List (foldl') --TODO: Use catamorphisms -import GHC.Base (Eq (..)) +import Data.Foldable (Foldable) +import GHC.Base (Eq (..), (&&)) +import GHC.Show (Show (..)) instance Functor [] where fmap f [] = [] @@ -18,8 +24,10 @@ instance Monoid [a] where (x:xs) -> x : xs * b one = [] -product :: (Monoid a) => [a] -> a +product :: (Foldable t, Monoid a) => t a -> a product = foldl' (*) one +sum :: (Foldable t, AbelianMonoid a) => t a -> a +sum = foldl' (+) zero instance CMonoid NaturalTransformation Functor Composition Id [] where mult = NaturalTransformation (liftComp product) @@ -28,7 +36,7 @@ instance CMonoid NaturalTransformation Functor Composition Id [] where instance Monad [] -data Maybe a = Just a | Nothing deriving Eq +data Maybe a = Just a | Nothing deriving (Eq, Show) instance Functor Maybe where fmap f Nothing = Nothing fmap f (Just a) = Just (f a) @@ -56,3 +64,42 @@ instance Monad Maybe GHCi> do a <- [1,2,3]; [a*2] [2,4,6] -} + +instance (Monoid a, Monoid b) => Monoid (a, b) where + (a,b) * (c,d) = (a*c, b*d) + one = (one, one) +instance (AbelianMonoid a, AbelianMonoid b) => AbelianMonoid (a, b) where + (a,b) + (c,d) = (a+c, b+d) + zero = (zero, zero) +instance (AbelianGroup a, AbelianGroup b) => AbelianGroup (a, b) where + neg (a, b) = (neg a, neg b) +instance (Ring a, Ring b) => Ring (a, b) +--(a, b) does not form a field because, for example, (1, 0)^-1 does not exist. +instance Functor ((,) b) where + fmap f (a, b) = (a, f b) +instance Functor ((->) s) where + fmap f g = f . g + +type State s a = Composition ((->) s) ((,) s) a +instance CMonoid NaturalTransformation Functor Composition Id (Composition ((->) s) ((,) s)) where --state monad + mult = NaturalTransformation (Compose . liftComp flattenState) where + flattenState :: State s (State s a) -> s -> (s, a) + flattenState f = \state -> let (st, a) = unCompose f state in unCompose a st + unit = NaturalTransformation (Compose . makeState . unId) where + makeState a = \s -> (s, a) +instance Monad (Composition ((->) s) ((,) s)) + +data Vector2 a = V2 !a !a + +instance (Eq a) => Eq (Vector2 a) where + (V2 a b) == (V2 c d) = (a == c) && (b == d) +instance (AbelianMonoid m) => AbelianMonoid (Vector2 m) where + (V2 a b) + (V2 c d) = V2 (a+c) (b+d) + zero = V2 zero zero +instance (AbelianGroup g) => AbelianGroup (Vector2 g) where + neg (V2 a b) = V2 (neg a) (neg b) +instance Functor Vector2 where + fmap f (V2 a b) = V2 (f a) (f b) + + +data Vector3 a = V3 !a !a !a diff --git a/Scrap.hs b/Scrap.hs index 4ea6e5c..e0d5330 100644 --- a/Scrap.hs +++ b/Scrap.hs @@ -1,5 +1,23 @@ +--class (Category cat, obj) => TwoCategory cat obj where +-- (.+) :: cat (cat a b) (cat a b) -> + +class (Category c obj) => TwoCategory c obj homset where --The homset must be equaitable + (.+) :: (homset (c a b) (c a b)) -> (homset (c a b) (c a b)) -> (homset (c a b) (c a b)) + +instance TwoCategory (->) Empty (->) where + (.+) :: ((a->b) -> (a->b)) -> ((a->b) -> (a->b)) -> ((a->b) -> (a->b)) + + +{- +class (Category cat obj) => EnrichedCategory (cat :: k -> k -> *) (obj :: * -> Constraint) (morph :: * -> Constraint) where + (.+) :: (obj a, obj b, obj c, morph (cat a b), morph (cat b c), morph (cat a c)) => cat b c -> cat a b -> cat a c + id' :: (obj a, morph (cat a a)) => cat a a + +instance (Category cat obj) => EnrichedCategory cat obj Category +-} + class (Category c Empty) => Arrow c where arr :: (a -> b) -> c a b