plp/haskell/haskell5.hs

import Control.Applicative
import Control.Monad
import Control.Monad.State

-- Logger
type Log = [String]
newtype Logger a = Logger {runLogger :: (a, Log)}

--Let's define Log an instance of Show
instance (Show a) => Show (Logger a ) where
    show (Logger a) = show a

--Define an instance of Functor for Logger
loggerMap :: (a -> b) -> Logger a -> Logger b
loggerMap f lg =
    let (v, l) = runLogger lg
        n = f v
    in Logger (n, l)

instance Functor Logger  where
    fmap = loggerMap

loggerApp :: Logger (a -> b) -> Logger a -> Logger b
loggerApp lf lg =
    let (f, s) = runLogger lf
        nl = loggerMap f lg
        (n, l) = runLogger nl
    in Logger (n, l ++ s)

instance Applicative Logger where
    pure x = Logger (x, [])
    (<*>) = loggerApp

--Define the Logger Monad

instance Monad Logger where
    m >>= f = let (a, w) = runLogger m
                  n = f a
                  (b, x) = runLogger n
              in Logger (b, w ++ x)

--Define a function that takes a number, add one and log the operation
logPlusOne :: (Num a) => a -> Logger a
logPlusOne a = Logger (a+1, ["added one"])

--Define a function that takes a number, doubles it and log the operation
logMultiplyTwo :: (Num a) => a -> Logger a
logMultiplyTwo a = Logger (a*2, ["Multiplied by two"])

--Define a function that takes a logger, adds one, double the value and logs all the operations
logOps :: (Num a) => a -> Logger a
logOps a = pure a >>= logPlusOne >>= logMultiplyTwo

logOps' :: (Num a) => Logger a -> Logger a
logOps' a = do
    v <- a
    s1 <- logPlusOne v
    p2 <- logMultiplyTwo s1
    return p2

--Define a record function to record things in the logPlusOne
record :: String -> Logger ()
record s = Logger ((), [s])

--Define a binary Tree
data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show, Eq, Read)

treeFoldr :: (b -> a -> a) -> a -> Tree b -> a
treeFoldr f acc EmptyTree = acc
treeFoldr f acc (Node a left right) = treeFoldr f (f a (treeFoldr f acc right)) left

singletonM :: (Show a) => a -> Logger (Tree a)
singletonM x = do
    record ("Created singleton" ++ show x)
    return (Node x EmptyTree EmptyTree)

treeInsertM :: (Ord a, Show a) => Tree a -> a -> Logger (Tree a)
treeInsertM EmptyTree x = singletonM x
treeInsertM (Node a left right) x
    | x == a = do
        record("Inserted " ++ show x)
        return (Node x left right)
    | x < a = do
        l <- treeInsertM left x
        return (Node a l right)
    | x > a = do
        r <- treeInsertM right x
        return (Node a left r)
treeSumM :: (Num a) => Logger (Tree a) -> Logger a
treeSumM t = fmap (treeFoldr (+) 0) t

andM :: Logger Bool -> Logger Bool -> Logger Bool
andM log1 log2 = do
    c1 <- log1
    c2 <- log2
    return (c1 && c2)

treeBalancedM :: Tree a -> Logger Bool
treeBalancedM EmptyTree = do
    record "an empty tree is always balanced"
    return True
treeBalancedM (Node _ EmptyTree EmptyTree) = do
    record "A single node tree is always balanced"
    return True
treeBalancedM (Node _ EmptyTree _) = do
    record "Unbalanced"
    return False
treeBalancedM (Node _ _ EmptyTree) = do
    record "Unbalanced"
    return False
treeBalancedM (Node _ left right) = andM (treeBalancedM left) (treeBalancedM right)

type Stack = [Int]

--Define the pop function
pop :: Stack -> (Int, Stack)
pop (x:xs) = (x, xs)

--Define the push function
push :: Int -> Stack -> ((), Stack)
push x xs = ((), x:xs)

stackManip :: Stack -> (Int, Stack)
stackManip stack = let
    (a, stack1) = pop stack
    (b, stack2) = pop stack1
    ((), stack3) = push 100 stack2
    (c, stack4) = pop stack3
    in pop stack4

popM :: State Stack Int
popM = do
    x:xs <- get
    put xs
    return x