misc/monoids.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 module Monoids where
   3
   4 import Data.Monoid
   5
   6 data Tree a = Empty
   7             | Node (Tree a) a (Tree a)
   8               deriving (Eq, Show)
   9
  10 leaf :: a -> Tree a
  11 leaf x = Node Empty x Empty
  12
  13 treeSize :: Tree a -> Integer
  14 treeSize Empty = 0
  15 treeSize (Node l _ r) = 1 + treeSize l + treeSize r
  16
  17 treeSum :: Tree Integer -> Integer
  18 treeSum Empty = 0
  19 treeSum (Node l x r) = x + treeSum l + treeSum r
  20
  21 treeDepth :: Tree a -> Integer
  22 treeDepth Empty = 0
  23 treeDepth (Node l _ r) = 1 + max (treeDepth l) (treeDepth r)
  24
  25 flatten :: Tree a -> [a]
  26 flatten Empty = []
  27 flatten (Node l x r) = flatten l ++ [x] ++ flatten r
  28
  29 -- treeFold
  30 -- 0. empty case value
  31 -- 1. type of the return value.
  32 -- 2. how to combine the recursive calls.
  33
  34 treeFold :: b -> (b -> a -> b -> b) -> Tree a -> b
  35 treeFold e _ Empty = e
  36 treeFold e f (Node l x r) = f (treeFold e f l) x (treeFold e f r)
  37
  38 treeSize' :: Tree a -> Integer
  39 treeSize' = treeFold 0 (\l _ r -> 1 + l + r)
  40
  41 treeSum' :: Tree Integer -> Integer
  42 treeSum' = treeFold 0 (\l x r -> x + l + r)
  43
  44 treeDepth' :: Tree a -> Integer
  45 treeDepth' = treeFold 0 (\l _ r -> 1 + max l r)
  46
  47 flatten' :: Tree a -> [a]
  48 flatten' = treeFold [] (\l x r -> l ++ [x] ++ r)
  49
  50 -- monoids
  51 newtype Sum' a = Sum' a
  52     deriving (Eq, Num, Ord, Show)
  53
  54 getSum :: Sum' a -> a
  55 getSum (Sum' x) = x
  56
  57 instance Num a => Monoid (Sum' a) where
  58   mempty = 0
  59   mappend = (+)
  60
  61 newtype Prod' a = Prod' a
  62     deriving (Eq, Num, Ord, Show)
  63
  64 getProd :: Prod' a -> a
  65 getProd (Prod' x) = x
  66
  67 instance Num a => Monoid (Prod' a) where
  68   mempty = 1
  69   mappend = (*)
  70
  71 lst :: [Integer]
  72 lst = [1,5,8,23,423,99]
  73
  74 prod :: Integer
  75 prod = getProd $ mconcat $ map Prod' lst