Monoid and Foldable.

category-theory/foldable.hs

@@ -0,0 +1,40 @@
+import qualified Foldable as F
+
+-- for List is the same as foldr from Prelude
+a1 = foldr (*) 1 [1,2,3]  
+a2 = F.foldr (*) 1 [1,2,3]
+
+-- example on Maybe
+b1 = F.foldl (+) 2 (Just 9)  
+b2 = F.foldr (||) False (Just True)
+
+-- bynary tree examples
+data Tree a = Empty | Node a (Tree a) (Tree a) deriving (Show, Read, Eq)
+
+-- foldMap :: (Monoid m, Foldable t) => (a -> m) -> t a -> m
+
+-- instance for Tree
+instance F.Foldable Tree where  
+    foldMap f Empty = mempty  
+    foldMap f (Node x l r) = F.foldMap f l `mappend`  
+                             f x           `mappend`  
+                             F.foldMap f r
+
+-- example on Tree
+testTree = Node 5  
+            (Node 3  
+                (Node 1 Empty Empty)  
+                (Node 6 Empty Empty)  
+            )  
+            (Node 9  
+                (Node 8 Empty Empty)  
+                (Node 10 Empty Empty)  
+            )
+
+c1 = F.foldl (+) 0 testTree  
+c2 = F.foldl (*) 1 testTree
+
+d1 = getAny $ F.foldMap (\x -> Any $ x == 3) testTree
+d2 = getAny $ F.foldMap (\x -> Any $ x > 15) testTree
+
+e1 = F.foldMap (\x -> [x]) testTree

category-theory/monoid.hs

@@ -0,0 +1,151 @@
+-- typeclass defined in Data.Monoid
+class Monoid m where  
+    mempty :: m  
+    mappend :: m -> m -> m  
+    mconcat :: [m] -> m  
+    mconcat = foldr mappend mempty
+
+-- Monoid laws
+-- Identity1: mempty `mappend` x = x
+-- Identity2: x `mappend` mempty = x
+-- Associativity: (x `mappend` y) `mappend` z = x `mappend` (y `mappend` z)
+
+-- instance for List
+instance Monoid [a] where  
+    mempty = []  
+    mappend = (++)
+
+-- examples on List
+a1 = [1,2,3] `mappend` [4,5,6]  
+a2 = ("one" `mappend` "two") `mappend` "tree"  
+a3 = "one" `mappend` ("two" `mappend` "tree")  
+a4 = "one" `mappend` "two" `mappend` "tree"  
+a5 = "pang" `mappend` mempty  
+a6 = mconcat [[1,2],[3,6],[9]]  
+a7 = mempty :: [a]
+
+-- Data.Monois defines types for Product and Sum
+newtype Product a = Product { getProduct :: a }  
+    deriving (Eq, Ord, Read, Show, Bounded)
+
+newtype Sum a = Sum { getSum :: a }  
+    deriving (Eq, Ord, Read, Show, Bounded)
+
+-- monoid instance for product
+instance Num a => Monoid (Product a) where  
+    mempty = Product 1  
+    Product x `mappend` Product y = Product (x * y)
+
+-- monoid instance for sum
+instance Num a => Monoid (Sum a) where  
+    mempty = Sum 0  
+    Sum x `mappend` Sum y = Sum (x + y)
+
+-- examples on product
+b1 = getProduct $ Product 3 `mappend` Product 9   
+b2 = getProduct $ Product 3 `mappend` mempty  
+b3 = getProduct $ Product 3 `mappend` Product 4 `mappend` Product 2  
+b4 = getProduct . mconcat . map Product $ [3,4,2]
+
+-- examples on sum
+c1 = getSum $ Sum 2 `mappend` Sum 9    
+c2 = getSum $ mempty `mappend` Sum 3    
+c3 = getSum . mconcat . map Sum $ [1,2,3]
+
+-- terrible name for defining logical OR operation
+newtype Any = Any { getAny :: Bool }  
+    deriving (Eq, Ord, Read, Show, Bounded)
+
+instance Monoid Any where  
+        mempty = Any False  
+        Any x `mappend` Any y = Any (x || y)
+
+-- examples on any
+d1 = getAny $ Any True `mappend` Any False  
+d2 = getAny $ mempty `mappend` Any True  
+d3 = getAny . mconcat . map Any $ [False, False, False, True]  
+d4 = getAny $ mempty `mappend` mempty
+
+-- yet another nice name to define logical AND operation
+newtype All = All { getAll :: Bool }  
+        deriving (Eq, Ord, Read, Show, Bounded)
+
+instance Monoid All where  
+        mempty = All True  
+        All x `mappend` All y = All (x && y)
+
+-- examples on all
+e1 = getAll $ mempty `mappend` All True  
+e2 = getAll $ mempty `mappend` All False  
+e3 = getAll . mconcat . map All $ [True, True, True]  
+e4 = getAll . mconcat . map All $ [True, True, False]
+
+-- instance for Ordering
+instance Monoid Ordering where  
+    mempty = EQ  
+    LT `mappend` _ = LT  
+    EQ `mappend` y = y  
+    GT `mappend` _ = GT
+
+-- examples on ordering
+f1 = LT `mappend` GT  
+f2 = GT `mappend` LT  
+f3 = mempty `mappend` LT  
+f4 = mempty `mappend` GT
+
+-- compare length of two words
+lengthCompare :: String -> String -> Ordering 
+lengthCompare x y = let a = length x `compare` length y   
+                        b = x `compare` y  
+                    in  if a == EQ then b else a
+
+l1 = lengthCompare "gabi" "volpe"
+l2 = lengthCompare "gabriel" "volpe"
+l3 = lengthCompare "code" "code"
+
+-- compare length of two words using the Monoid instance
+lengthCompareM :: String -> String -> Ordering  
+lengthCompareM x y = (length x `compare` length y) `mappend`  
+		     (x `compare` y)
+
+lm1 = lengthCompareM "gabi" "volpe"
+lm2 = lengthCompareM "gabriel" "volpe"
+lm3 = lengthCompareM "code" "code"
+
+-- comparing vowels too
+lengthCompareV :: String -> String -> Ordering  
+lengthCompareV x y = (length x `compare` length y) `mappend`  
+                    (vowels x `compare` vowels y) `mappend`  
+                    (x `compare` y)  
+    where vowels = length . filter (`elem` "aeiou")
+
+lv1 = lengthCompareV "gabi" "volpe"
+lv2 = lengthCompareV "gabriel" "volpe"
+lv3 = lengthCompareV "code" "code"
+
+-- monoid instance for Maybe
+instance Monoid a => Monoid (Maybe a) where  
+    mempty = Nothing  
+    Nothing `mappend` m = m  
+    m `mappend` Nothing = m  
+    Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)
+
+-- examples on Maybe
+x1 = Nothing `mappend` Just "andy"  
+x2 = Just LT `mappend` Nothing  
+x3 = Just (Sum 3) `mappend` Just (Sum 4)  
+
+-- keeping the first value on Maybe. There's a similar type called Last that keepts the second value defined in Data.Monoid
+newtype First a = First { getFirst :: Maybe a }  
+    deriving (Eq, Ord, Read, Show)
+
+instance Monoid (First a) where  
+    mempty = First Nothing  
+    First (Just x) `mappend` _ = First (Just x)  
+    First Nothing `mappend` x = x
+
+-- examples on first
+y1 = getFirst $ First (Just 'a') `mappend` First (Just 'b')  
+y2 = getFirst $ First Nothing `mappend` First (Just 'b')  
+y3 = getFirst $ First (Just 'a') `mappend` First Nothing
+y4 = getFirst . mconcat . map First $ [Nothing, Just 9, Just 10]