From d25e2547ace4c122c224f4aa7a266d2dd5263450 Mon Sep 17 00:00:00 2001 From: Gabi Volpe Date: Fri, 19 Aug 2016 10:49:11 +0100 Subject: [PATCH] Monoid and Foldable. --- category-theory/foldable.hs | 40 ++++++++++ category-theory/monoid.hs | 151 ++++++++++++++++++++++++++++++++++++ 2 files changed, 191 insertions(+) create mode 100644 category-theory/foldable.hs create mode 100644 category-theory/monoid.hs diff --git a/category-theory/foldable.hs b/category-theory/foldable.hs new file mode 100644 index 0000000..9d3357c --- /dev/null +++ b/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 diff --git a/category-theory/monoid.hs b/category-theory/monoid.hs new file mode 100644 index 0000000..41c9c8a --- /dev/null +++ b/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]