diff --git a/part2_chapter12_state_monad_practice_relabelling_trees/Main.hs b/part2_chapter12_state_monad_practice_relabelling_trees/Main.hs index 7ae4525..32faeb1 100644 --- a/part2_chapter12_state_monad_practice_relabelling_trees/Main.hs +++ b/part2_chapter12_state_monad_practice_relabelling_trees/Main.hs @@ -6,11 +6,20 @@ -- ghci -- -- :load Main +<<<<<<< HEAD +======= +import Control.Applicative + +-- State and StateTransformer types and orbiting code copied from the state monad exercise. +>>>>>>> Part 2, Chapter 12, state monad practice, part 3. type State = Int newtype StateTransformer a = S (State -> (a, State)) +<<<<<<< HEAD -- Is this weird/clever or am I just tired? +======= +>>>>>>> Part 2, Chapter 12, state monad practice, part 3. apply :: StateTransformer a -> State -> (a, State) apply (S transformer) state = transformer state @@ -29,23 +38,47 @@ instance Applicative StateTransformer where let (f, state2) = apply functionStateTransformer state1 (x, state3) = apply valueStateTransformer state2 in (f x, state3)) +<<<<<<< HEAD +======= +-- monad +instance Monad StateTransformer where + -- return :: a -> StateTransformer a + return = pure + -- (>>=) :: (StateTransformer a) -> (a -> StateTransformer b) -> (StateTransformer b) + valueStateTransformer >>= function = S (\state1 -> + let (value, state2) = apply valueStateTransformer state1 in apply (function value) state2) + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving Show + +>>>>>>> Part 2, Chapter 12, state monad practice, part 3. main = do putStrLn "New tree:" putStrLn . show $ newTree putStrLn "" - putStrLn "Relabelled new tree:" - putStrLn . show $ relabel newTree 0 + putStrLn "Relabelled new tree - basic approach:" + putStrLn . show . fst $ relabel newTree 0 putStrLn "" +<<<<<<< HEAD putStrLn "Relabelled new tree, applicative style:" putStrLn . show $ apply (applicativeRelabel newTree) 0 data Tree a = Leaf a | Node (Tree a) (Tree a) deriving Show +======= + putStrLn "Relabelled new tree - applicative approach:" + putStrLn . show . fst $ apply (relabelApplicativeStyle newTree) 0 + + putStrLn "" + putStrLn "Relabelled new tree - monadic approach:" + putStrLn . show . fst $ apply (relabelMonadicStyle newTree) 0 +>>>>>>> Part 2, Chapter 12, state monad practice, part 3. newTree :: Tree Char newTree = Node (Node (Leaf 'a') (Leaf 'b')) (Leaf 'c') +-- "traditional" approach --> + -- I feel this function is not perfectly described in the book, -- so will try to do a better job here. -- The function: @@ -60,10 +93,39 @@ relabel (Node left right) n = (relabelledLeftTree, nLeft) = relabel left n (relabelledRightTree, nRight) = relabel right nLeft +<<<<<<< HEAD -- applicative relabel version fresh :: StateTransformer Int fresh = S (\x -> (x, x + 1)) applicativeRelabel :: Tree a -> StateTransformer (Tree Int) applicativeRelabel (Leaf _) = Leaf <$> fresh -applicativeRelabel (Node left right) = Node <$> applicativeRelabel left <*> applicativeRelabel right \ No newline at end of file +applicativeRelabel (Node left right) = Node <$> applicativeRelabel left <*> applicativeRelabel right +======= +-- <-- "traditional" approach + +freshLabel :: StateTransformer Int +freshLabel = S (\n -> (n, n + 1)) + +-- applicative approach --> + +relabelApplicativeStyle :: Tree a -> StateTransformer (Tree Int) +relabelApplicativeStyle (Leaf _) = Leaf <$> freshLabel +relabelApplicativeStyle (Node left right) = + Node <$> (relabelApplicativeStyle left) <*> (relabelApplicativeStyle right) + +-- <-- applicative approach + +-- monadic approach --> + +relabelMonadicStyle :: Tree a -> StateTransformer (Tree Int) +relabelMonadicStyle (Leaf _) = do + label <- freshLabel + return (Leaf label) +relabelMonadicStyle (Node left right) = do + left' <- relabelMonadicStyle left + right' <- relabelMonadicStyle right + return (Node left' right') + +-- <-- monadic approach +>>>>>>> Part 2, Chapter 12, state monad practice, part 3.