Added tuple data, added instances for tuple as bifunctor, cleaned up …

…Categories.

Categories.hs

@@ -10,30 +10,32 @@
 {-# LANGUAGE ConstraintKinds #-}
 
 module Categories (Empty, Category (..), Functor (..), Composition (..), liftComp,
-                   Id, unId, NaturalTransformation (..), MonoidalCategory (..),
+                   Id, IdentityFunctor (..), NaturalTransformation (..), MonoidalCategory (..),
+                   Unitary (..),
                    CMonoid (..), Monad (..), Endobifunctor (..))
 
 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

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

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