Complete chapter 12

12-signaling-adversity/src/binarytree.hs

@@ -0,0 +1,17 @@
+module BinaryTree where
+
+    data BinaryTree a = Leaf | Node (BinaryTree a) a (BinaryTree a)
+                        deriving (Eq, Ord, Show)
+
+    unfold :: (a -> Maybe (a,b,a)) -> a -> BinaryTree b
+    unfold f a = 
+        case (f a) of
+            Nothing -> Leaf
+            Just (a',b,a'') -> Node (unfold f a') b (unfold f a'')
+
+    treeBuild :: Integer -> BinaryTree Integer
+    treeBuild l = unfold f (0 :: Integer)
+                    where f n
+                            | n < 0  = Nothing
+                            | n >= l = Nothing
+                            | otherwise = Just (n+1, n, n+1)

12-signaling-adversity/src/itunfold.hs

@@ -0,0 +1,12 @@
+module ItUnfold where
+
+    myIterate :: (a -> a) -> a -> [a]
+    myIterate f a = a : myIterate f (f a)
+
+    myUnfoldr :: (b -> Maybe (a,b)) -> b -> [a]
+    myUnfoldr f b = case (f b) of
+                        Nothing     -> []
+                        Just (a,b') -> a : myUnfoldr f b'
+
+    betterIterate :: (a -> a) -> a -> [a]
+    betterIterate f a = myUnfoldr (\x -> Just(x, f x)) a

12-signaling-adversity/src/libeither.hs

@@ -0,0 +1,27 @@
+module LibEither where
+
+    lefts' :: [Either a b] -> [a]
+    lefts' = foldr f []
+        where f (Right _) xs = xs
+              f (Left a) xs = a : xs
+    
+    rights' :: [Either a b] -> [b]
+    rights' = foldr f []
+        where f (Left _) xs = xs
+              f (Right a) xs = a : xs
+
+    partitionEithers' :: [Either a b] -> ([a],[b])
+    partitionEithers' = foldr f ([],[])
+        where f (Left a) (xs,ys) = (a:xs, ys)
+              f (Right b) (xs,ys) = (xs, b:ys)
+
+    eitherMaybe' :: (b -> c) -> Either a b -> Maybe c
+    eitherMaybe' _ (Left _) = Nothing
+    eitherMaybe' f (Right b) = Just $ f b
+
+    either' :: (a -> c) -> (b -> c) -> Either a b -> c
+    either' f _ (Left a) = f a
+    either' _ g (Right b) = g b
+
+    eitherMaybe'' :: (b -> c) -> Either a b -> Maybe c
+    eitherMaybe'' g = either' (\_ -> Nothing) (Just . g)

12-signaling-adversity/src/libmaybe.hs

@@ -0,0 +1,36 @@
+module LibMaybe where
+
+    isJust :: Maybe a -> Bool
+    isJust (Just _) = True
+    isJust _        = False
+
+    isNothing :: Maybe a -> Bool
+    isNothing Nothing = True
+    isNothing _       = False
+
+    mayybee :: b -> (a -> b) -> Maybe a -> b
+    mayybee b _ Nothing = b
+    mayybee _ f (Just a) = f a
+
+    fromMaybe :: a -> Maybe a -> a
+    fromMaybe a Nothing = a
+    fromMaybe _ (Just a) = a
+
+    listToMaybe :: [a] -> Maybe a
+    listToMaybe [] = Nothing
+    listToMaybe (x:_) = Just x
+
+    maybeToList :: Maybe a -> [a]
+    maybeToList Nothing = []
+    maybeToList (Just a) = a:[]
+
+    catMaybes :: [Maybe a] -> [a]
+    catMaybes [] = []
+    catMaybes (Nothing:xs) = catMaybes xs
+    catMaybes (Just a:xs) = a : catMaybes xs
+
+    flipMaybe :: [Maybe a] -> Maybe [a]
+    flipMaybe = foldr f (Just [])
+        where f Nothing _ = Nothing
+              f _ Nothing = Nothing
+              f (Just a) (Just xs) = Just $ a : xs

12-signaling-adversity/src/naturals.hs

@@ -0,0 +1,13 @@
+module Naturals where
+
+    data Nat = Zero | Succ Nat deriving (Eq, Show)
+
+    natToInteger :: Nat -> Integer
+    natToInteger Zero = 0
+    natToInteger (Succ n) = 1 + natToInteger n
+
+    integerToNat :: Integer -> Maybe Nat
+    integerToNat n
+        | n < 0     = Nothing
+        | n == 0    = Just Zero
+        | otherwise = fmap Succ $ integerToNat (n-1)

12-signaling-adversity/src/stringproc.hs

@@ -0,0 +1,38 @@
+module StringProc where
+
+    -- 1
+    notThe :: String -> Maybe String
+    notThe "the" = Nothing
+    notThe s = Just s
+
+    replaceThe :: String -> String
+    replaceThe = unwords . fmap rep . fmap notThe . words
+        where rep Nothing = "a"
+              rep (Just t) = t
+
+    -- 2
+    startsWithVowel :: String -> Bool
+    startsWithVowel "" = False
+    startsWithVowel (c:_) = elem c "aeiou"
+
+    -- Probably better ways of doing this
+    -- but wanted to see if this was actually
+    -- possible!
+    countTheBeforeVowel :: String -> Integer
+    countTheBeforeVowel = 
+        toInteger . length . f .
+        (fmap .fmap) startsWithVowel . 
+        fmap notThe . words
+        where f [] = []
+              f (_:[]) = []
+              f ((Just _):xs) = f xs
+              f (Nothing:Nothing:xs) = f (Nothing:xs)
+              f (Nothing:Just False:xs) = f xs
+              f (Nothing:Just True:xs) = [True] ++ f xs
+              
+    -- 3
+    isVowel :: Char -> Bool
+    isVowel = (flip elem) "aeiou"
+
+    countVowels :: String -> Integer
+    countVowels = toInteger . length . filter isVowel

12-signaling-adversity/src/validateword.hs

@@ -0,0 +1,17 @@
+module ValidateWord where
+
+    import Data.List
+
+    newtype Word' = Word' String deriving (Eq, Show)
+
+    vowels :: String
+    vowels = "aeiou"
+
+    isVowel :: Char -> Bool
+    isVowel = (flip elem) vowels
+
+    mkWord :: String -> Maybe Word'
+    mkWord s = check $ partition isVowel s
+        where check (xs,ys)
+                | length xs >= length ys = Nothing
+                | otherwise = Just $ Word' s

12.5-chapter-exercises.md

@@ -0,0 +1,25 @@
+# Chapter Exercises
+## Determine the kinds
+1. `*`
+2. `* -> *`
+
+## String processing
+see src/stringproc.hs
+
+## Validate the words
+see src/validateword.hs
+
+## It's only Natural
+see src/naturals.hs
+
+## Small library for Maybe
+see src/libmaybe.hs
+
+## Small library for Either
+see src/libeither.hs
+
+## Write your own iterate and unfoldr
+see src/itunfold.hs
+
+## Finally something other than a list!
+see src/binarytree.hs