├── .gitignore ├── README.md ├── ch1 └── note.md ├── ch10 └── exercises.hs ├── ch11 ├── exercises.hs ├── jammin.hs ├── phone.hs └── vigenere.hs ├── ch12 └── exercises.hs ├── ch13 ├── caesar.hs ├── exercises.hs ├── hangman │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── data │ │ └── dict.txt │ ├── hangman.cabal │ ├── src │ │ └── Main.hs │ └── stack.yaml ├── hello │ ├── .gitignore │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── exe │ │ └── Main.hs │ ├── hello.cabal │ ├── src │ │ ├── DogsRule.hs │ │ └── Hello.hs │ └── stack.yaml └── vigenere.hs ├── ch14 ├── Addition.hs ├── LICENSE ├── ShortExercise.hs ├── UsingQuickCheck.hs ├── WordNumber.hs ├── WordNumberTest.hs ├── addition.cabal ├── ciphers │ ├── Caesar.hs │ ├── Main.hs │ └── Vigenere.hs ├── exercises.hs ├── morse │ ├── .gitignore │ ├── LICENSE │ ├── Setup.hs │ ├── morse.cabal │ ├── src │ │ ├── Main.hs │ │ └── Morse.hs │ ├── stack.yaml │ └── tests │ │ └── tests.hs └── stack.yaml ├── ch2 ├── exercises.hs ├── practice.hs ├── test.hs └── wax_on.hs ├── ch3 ├── building_functions.hs ├── exercises.hs ├── foo.hs ├── global.hs ├── print1.hs ├── print2.hs ├── print3.hs ├── print3flipped.hs ├── print4broken.hs ├── print4fixed.hs └── reverse.hs ├── ch4 ├── change_mood.hs └── exercises.hs ├── ch5 ├── arith3broken.hs ├── exercises.hs ├── sing.hs ├── sing2.hs ├── typeInference1.hs └── typeInference2.hs ├── ch6 ├── .ghci └── exercises.hs ├── ch7 ├── arith2.hs ├── arith4.hs ├── exercises.hs ├── greetIfCool3.hs ├── matchingTuples1.hs ├── registeredUser1.hs └── registeredUser2.hs ├── ch8 ├── exercises.hs └── wordnumber.hs └── ch9 ├── cipher.hs └── exercises.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .scratch*.hs 2 | 3 | dist 4 | dist-* 5 | cabal-dev 6 | *.o 7 | *.hi 8 | *.chi 9 | *.chs.h 10 | *.dyn_o 11 | *.dyn_hi 12 | .hpc 13 | .hsenv 14 | .cabal-sandbox/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | *.eventlog 20 | .stack-work/ 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | My crappy solutions to the [Haskell Programming from First Principles][haskell-programming] book. 2 | 3 | [haskell-programming]: http://haskellbook.com/ 4 | -------------------------------------------------------------------------------- /ch1/note.md: -------------------------------------------------------------------------------- 1 | I did Chapter 1 exercises on pencil and paper in order to work out the problems. 2 | -------------------------------------------------------------------------------- /ch10/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 10.5 2 | 3 | -- Undertanding Folds 4 | 5 | -- 1) b and c 6 | 7 | -- 2) 8 | 9 | --(flip (*) (flip (*) (flip (*) 1 1) 2) 3) 10 | --(flip (*) (flip (*) 1 2) 3) 11 | --(flip (*) 2 3) 12 | --6 13 | 14 | -- 3) c 15 | 16 | -- 4) a 17 | 18 | -- 5) a) 19 | foldr (++) "" ["woot", "WOOT", "woot"] 20 | 21 | -- 5) b) 22 | -- note: '\NUL' == (chr 0) 23 | foldr max '\NUL' "fear is the little death" 24 | 25 | -- 5) c) 26 | foldr (&&) True [False, True] 27 | 28 | -- 5) d) 29 | -- No, the zero/identity being True will always short-circuit (||) to 30 | -- return True regardless of other arguments. Replace with False to fix: 31 | foldr (||) False [False, True] 32 | 33 | -- 5) e) 34 | foldr ((++) . show) "" [1..5] 35 | -- or 36 | foldl (flip $ (++) . show) "" [1..5] 37 | 38 | -- 5) f) 39 | foldl const 'a' [1..5] 40 | -- or 41 | foldr (flip const) 'a' [1..5] 42 | -- or 43 | foldr const 'a' ['1'..'5'] 44 | 45 | -- 5) g) 46 | foldl const 0 "tacos" 47 | -- or 48 | foldr (flip const) 0 "tacos" 49 | -- or 50 | foldr const '0' "tacos" 51 | 52 | -- 5) h) 53 | foldl const 0 "burritos" 54 | -- or 55 | foldr (flip const) 0 "burritos" 56 | -- or 57 | foldl (flip const) '0' "burritos" 58 | 59 | -- 5) i) 60 | foldr (flip const) 'z' [1..5] 61 | -- or 62 | foldl const 'z' [1..5] 63 | 64 | 65 | -- 10.6 66 | 67 | -- Exercises: Database Processing 68 | 69 | -- 1) 70 | filterDbDate :: [DatabaseItem] -> [UTCTime] 71 | filterDbDate = foldr (\ a b -> case a of {DbDate x -> x : b; _ -> b}) [] 72 | 73 | -- 2) 74 | filterDbNumber :: [DatabaseItem] -> [Integer] 75 | filterDbNumber = foldr (\ a b -> case a of {DbNumber x -> x : b; _ -> b}) [] 76 | 77 | -- 3) 78 | mostRecent :: [DatabaseItem] -> UTCTime 79 | mostRecent = foldr (\ a b -> case a of {DbDate x -> if x > b then x else b; _ -> b}) (UTCTime (fromGregorian 0 1 1) (secondsToDiffTime 0)) 80 | 81 | -- 4) 82 | sumDb :: [DatabaseItem] -> Integer 83 | sumDb = foldr (\ a b -> case a of {DbNumber x -> x + b; _ -> b}) 0 84 | 85 | -- 5) 86 | avgDb :: [DatabaseItem] -> Double 87 | avgDb = (\x -> (fst x) / (snd x)) . (foldr (\ a b -> case a of {DbNumber x -> ((fromIntegral x) + (fst b), (snd b) + 1); _ -> b}) (0 :: Double, 0)) 88 | 89 | 90 | -- 10.9 91 | 92 | -- Scans Exercises 93 | 94 | -- 1) 95 | fibs' = take 20 $ 1 : scanl (+) 1 fibs' 96 | 97 | -- 2) 98 | fibs'' = takeWhile (<100) $ 1 : scanl (+) 1 fibs'' 99 | 100 | -- 3) 101 | factorial' = scanl (*) 1 [1..] 102 | 103 | 104 | -- 10.10 105 | 106 | -- Warm-up and review 107 | 108 | -- 1) a) 109 | [(x,y,z) | x <- stops, y <- vowels, z <- stops] 110 | 111 | -- 1) b) 112 | [(x,y,z) | x <- stops, y <- vowels, z <- stops, x == 'p'] 113 | 114 | -- 1) c) 115 | nouns = ["den", "expansionism", "extent", "handlebar", "opportunist", "parallelogram", "swamp", "tanker"] 116 | verbs = ["stay", "paint", "look", "soak", "nod", "retire", "confuse", "kiss"] 117 | [(x,y,z) | x <- nouns, y <- verbs, z <- nouns] 118 | 119 | -- 2) 120 | -- It calculates the average word length of an input string. Its type is: 121 | -- seekritFunc :: String -> Int 122 | 123 | -- 3) 124 | seekritFunc :: Fractional a => String -> a 125 | seekritFunc x = 126 | (/) (fromIntegral (sum (map length (words x)))) 127 | (fromIntegral (length (words x))) 128 | 129 | -- Rewriting functions using folds 130 | 131 | -- 1) 132 | myOr :: [Bool] -> Bool 133 | myOr = foldr (||) False 134 | 135 | -- 2) 136 | myAny :: (a -> Bool) -> [a] -> Bool 137 | myAny f = foldr (\ a b -> (f a) || b) False 138 | 139 | -- 3) 140 | myElem :: Eq a => a -> [a] -> Bool 141 | myElem x = foldr (\ a b -> (a == x) || b) False 142 | -- I already wrote a version that uses `any` for chapter 9 143 | 144 | -- 4) 145 | myReverse :: [a] -> [a] 146 | myReverse = foldl (flip (:)) [] 147 | 148 | -- 5) 149 | myMap :: (a -> b) -> [a] -> [b] 150 | myMap f = foldr (\ a b -> (f a) : b) [] 151 | 152 | -- 6) 153 | myFilter :: (a -> Bool) -> [a] -> [a] 154 | myFilter f = foldr (\ a b -> if (f a) then a : b else b) [] 155 | 156 | -- 7) 157 | squish :: [[a]] -> [a] 158 | squish = foldr (++) [] 159 | 160 | -- 8) 161 | squishMap :: (a -> [b]) -> [a] -> [b] 162 | squishMap f = foldr (\ a b -> (f a) ++ b) [] 163 | 164 | -- 9) 165 | squishAgain :: [[a]] -> [a] 166 | squishAgain = squishMap id 167 | 168 | -- 10) 169 | myMaximumBy :: (a -> a -> Ordering) -> [a] -> a 170 | myMaximumBy f xs = foldl (\a b -> if (f a b) == GT then a else b) (head xs) xs 171 | 172 | -- 11) 173 | myMinimumBy :: (a -> a -> Ordering) -> [a] -> a 174 | myMinimumBy f xs = foldl (\a b -> if (f a b) == LT then a else b) (head xs) xs 175 | -------------------------------------------------------------------------------- /ch11/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 11.5 2 | 3 | -- Exercises: Dog Types 4 | 5 | -- 1) Type constructor 6 | 7 | -- 2) Doggies :: * -> * 8 | 9 | -- 3) Doggies String :: * 10 | 11 | -- 4) Husky 10 :: Num a => Doggies a 12 | 13 | -- 5) Husky (10 :: Integer) :: Doggies Integer 14 | 15 | -- 6) Mastiff "Scooby Doo" :: Doggies String 16 | 17 | -- 7) Both - the name is used for both purposes. GHC will understand which is 18 | -- which based on context. 19 | 20 | -- 8) DogueDeBordeaux :: doge -> DogueDeBordeaux doge 21 | 22 | -- 9) DogueDeBordeaux "doggie!" :: DogueDeBordeaux String 23 | 24 | 25 | -- 11.6 26 | 27 | -- Exercises: Vehicles 28 | 29 | -- 1) 30 | myCar :: Vehicle 31 | 32 | -- 2) 33 | isCar :: Vehicle -> Bool 34 | isCar (Car _ _) = True 35 | isCar _ = False 36 | 37 | isPlane :: Vehicle -> Bool 38 | isPlane (Plane _) = True 39 | isPlane _ = False 40 | 41 | areCars :: [Vehicle] -> [Bool] 42 | areCars = map isCar 43 | 44 | -- 3) 45 | getManu :: Vehicle -> Manufacturer 46 | getManu (Car m _) = m 47 | getManu _ = error "only cars have manufacturers" 48 | 49 | -- 4) It will raise a runtime error (bottom). The return type should 50 | -- be changed to Maybe Manufacturer so we can return Nothing instead. 51 | 52 | -- 5) Updated types and functions: 53 | 54 | data Size = Length Integer 55 | deriving (Eq, Show) 56 | 57 | data Vehicle = Car Manufacturer Price 58 | | Plane Airline Size 59 | deriving (Eq, Show) 60 | 61 | isPlane :: Vehicle -> Bool 62 | isPlane (Plane _ _) = True 63 | isPlane _ = False 64 | 65 | 66 | -- 11.8 67 | 68 | -- Exercises: Cardinality 69 | 70 | -- 1) 1 71 | 72 | -- 2) 3 73 | 74 | -- 3) 65536 75 | 76 | -- 4) (maxBound :: Int) is 9223372036854775807 and (minBound :: Int) is 77 | -- -9223372036854775808 on my machine. Those values correspond to the max and 78 | -- min values of a 64-bit signed integer, so I believe the cardinality is 79 | -- 2^64 for Int. (maxBound :: Integer) errors out, and `:i Integer` shows 80 | -- that it doesn't implement the Bounded typeclass, so so I'm thinking that 81 | -- Integer's cardinality is infinite. 82 | 83 | -- 5) 8 corresponds to a number of bits. A bit can hold 2 values, and when you 84 | -- string 8 of them together, that allows 2^8, i.e. 256, different possible 85 | -- combinations (values). 86 | 87 | 88 | -- Exercises: For Example 89 | 90 | -- 1) 91 | -- Q: What is the type of data constructor MakeExample? 92 | -- A: MakeExample :: Example 93 | -- Q: What happens when you request the type of Example? 94 | -- A: It errors out with "Not in scope: data constructor ‘Example’" because 95 | -- Example is a type constructor 96 | 97 | -- 2) 98 | -- Q: What if you try :info on Example in GHCi? 99 | -- A: It works! 100 | -- Q: Can you determine what typeclass instances are defined for the Example 101 | -- type using :info in GHCi? 102 | -- A: Yep, it shows the Show typeclass instance being defined: 103 | -- > :i Example 104 | -- data Example = MakeExample -- Defined at :49:1 105 | -- instance Show Example -- Defined at :49:37 106 | 107 | -- 3) 108 | data Foo = MakeExample Int deriving Show 109 | -- Q: What has changed when you query MakeExample with :type in GHCi? 110 | -- A: It shows the updated signature reflecting it being a unary data 111 | -- constructor: 112 | -- > :t MakeExample 113 | -- MakeExample :: Int -> Foo 114 | -- 115 | -- However this only works because GHCI lets you reassign things. If you 116 | -- put both data declarations into the same file, you get an error: 117 | -- 118 | -- Multiple declarations of ‘MakeExample’ 119 | -- Declared at: /tmp/foo.hs:1:16 120 | -- /tmp/foo.hs:3:12 121 | -- Failed, modules loaded: none. 122 | 123 | 124 | -- 11.9 125 | 126 | -- Exercises: Logic Goats 127 | 128 | -- 1) 129 | {-# LANGUAGE FlexibleInstances #-} 130 | instance TooMany (Int, String) where 131 | tooMany x = (fst x) > 42 132 | 133 | -- 2) 134 | {-# LANGUAGE FlexibleInstances #-} 135 | instance TooMany (Int, Int) where 136 | tooMany x = (fst x) + (snd x) > 42 137 | 138 | -- 3) 139 | {-# LANGUAGE FlexibleInstances #-} 140 | instance (Num a, TooMany a) => TooMany (a, a) where 141 | tooMany x = tooMany (fst x) || tooMany (snd x) 142 | 143 | 144 | -- 11.10 145 | 146 | -- Exercises: Pity the Bool 147 | 148 | -- 1) Big Bool | Small Bool 149 | -- = Big (2) + Small (2) 150 | -- Big and Small are unary data constructors, so they have the cardinality 151 | -- of the type they contain, which for Bool is 2 152 | -- = 2 + 2 153 | -- = 4 154 | 155 | -- 2) 156 | -- Q: What is the cardinality of NumberOrBool? 157 | -- A: Numba Int8 | BoolyBool Bool 158 | -- = Numba (256) + BoolyBool (2) 159 | -- = 256 + 2 160 | -- = 258 161 | -- Q: What happens if you try to create a Numba with a numeric literal larger 162 | -- than 127? 163 | -- A: It gives a warning that "Literal 129 is out of the Int8 range -128..127" 164 | -- however it still creates it, but the Int8 value has overflowed the 8 bits 165 | -- so that the actual value is less than what you requested. 166 | -- Q: And with a numeric literal smaller than (-128)? 167 | -- A: Same warning as before, except the value underflows the 8-bits so you end 168 | -- up with a value that is more than you requested. 169 | 170 | 171 | -- 11.12 172 | 173 | -- Exercises: How Does Your Garden Grow? 174 | 175 | -- 1) 176 | data Garden = 177 | Gardenia Gardener 178 | | Daisy Gardener 179 | | Rose Gardener 180 | | Lilac Gardener 181 | deriving Show 182 | 183 | 184 | -- 11.13 185 | 186 | -- Exercise: Programmers 187 | 188 | allProgrammers :: [Programmer] 189 | allProgrammers = [ Programmer{lang = x, os = y} | x <- allLanguages, y <- allOperatingSystems ] 190 | 191 | 192 | -- 11.14 193 | 194 | -- Exponentiation in what order? 195 | 196 | -- Yes, it holds. 197 | -- Note: this can help list the possible return value enumerations: 198 | -- [(x, y, z) | x <- [True, False], y <- [True, False], z <- [True, False]] 199 | 200 | convert1 :: Quantum -> Bool 201 | convert1 Yes = True 202 | convert1 No = True 203 | convert1 Both = True 204 | 205 | convert2 :: Quantum -> Bool 206 | convert2 Yes = True 207 | convert2 No = True 208 | convert2 Both = False 209 | 210 | convert3 :: Quantum -> Bool 211 | convert3 Yes = True 212 | convert3 No = False 213 | convert3 Both = True 214 | 215 | convert4 :: Quantum -> Bool 216 | convert4 Yes = True 217 | convert4 No = False 218 | convert4 Both = False 219 | 220 | convert5 :: Quantum -> Bool 221 | convert5 Yes = False 222 | convert5 No = True 223 | convert5 Both = True 224 | 225 | convert6 :: Quantum -> Bool 226 | convert6 Yes = False 227 | convert6 No = True 228 | convert6 Both = False 229 | 230 | convert7 :: Quantum -> Bool 231 | convert7 Yes = False 232 | convert7 No = False 233 | convert7 Both = True 234 | 235 | convert8 :: Quantum -> Bool 236 | convert8 Yes = False 237 | convert8 No = False 238 | convert8 Both = False 239 | 240 | -- Exercises: The Quad 241 | 242 | -- 1) Quad has 4 inhabitants. eQuad can take on 8 different forms. 243 | 244 | -- 2) 16 245 | 246 | -- 3) 256 247 | 248 | -- 4) 8 249 | 250 | -- 5) 16 251 | 252 | -- 6) 65536 because (c ^ b) ^ a = c ^ (b * a) = 4 ^ (4 * 2) = 65536 253 | 254 | 255 | -- 11.17 256 | 257 | -- Write map for BinaryTree 258 | 259 | mapTree :: (a -> b) -> BinaryTree a -> BinaryTree b 260 | mapTree _ Leaf = Leaf 261 | mapTree f (Node left a right) = 262 | Node (mapTree f left) (f a) (mapTree f right) 263 | 264 | -- Convert binary trees to lists 265 | 266 | preorder :: BinaryTree a -> [a] 267 | preorder Leaf = [] 268 | preorder (Node left a right) = [a] ++ (preorder left) ++ (preorder right) 269 | 270 | inorder :: BinaryTree a -> [a] 271 | inorder Leaf = [] 272 | inorder (Node left a right) = (preorder left) ++ [a] ++ (preorder right) 273 | 274 | postorder :: BinaryTree a -> [a] 275 | postorder Leaf = [] 276 | postorder (Node left a right) = (preorder left) ++ (preorder right) ++ [a] 277 | 278 | -- Write foldr for BinaryTree 279 | foldTree :: (a -> b -> b) -> b -> BinaryTree a -> b 280 | foldTree f b tree = foldr f b (inorder tree) 281 | 282 | 283 | -- 11.18 284 | 285 | -- Multiple choice 286 | 287 | -- 1) a 288 | 289 | -- 2) c 290 | 291 | -- 3) b 292 | 293 | -- 4) c 294 | 295 | -- Ciphers 296 | 297 | -- See vigenere.hs 298 | -- encode "MEET AT DAWN" "ALLY" = "MPPR AE OYWY" 299 | -- decode "MPPR AE OYWY" "ALLY" = "MEET AT DAWN" 300 | 301 | -- As-patterns 302 | 303 | -- 1) 304 | isSubseqOf :: (Eq a) => [a] -> [a] -> Bool 305 | isSubseqOf [] _ = True 306 | isSubseqOf _ [] = False 307 | isSubseqOf xs'@(x:xs) (y:ys) 308 | | x == y = isSubseqOf xs ys 309 | | otherwise = isSubseqOf xs' ys 310 | 311 | -- 2) 312 | import Data.Char 313 | 314 | capitalizeWords :: String -> [(String, String)] 315 | capitalizeWords [] = [] 316 | capitalizeWords x = concat $ map capitalizeWords' (words x) where 317 | capitalizeWords' :: String -> [(String, String)] 318 | capitalizeWords' [] = [] 319 | capitalizeWords' orig@(x:xs) = [(toUpper x : xs, orig)] 320 | 321 | -- Language exercises 322 | 323 | -- 1) 324 | import Data.Char 325 | capitalizeWord :: String -> String 326 | capitalizeWord "" = "" 327 | capitalizeWord (x:xs) = toUpper x : xs 328 | 329 | -- 2) 330 | capitalizeParagraph :: String -> String 331 | capitalizeParagraph x = unwords $ go (words x) True where 332 | go :: [String] -> Bool -> [String] 333 | go [] _ = [] 334 | go (x:xs) capWord 335 | | capWord = (capitalizeWord x) : (go xs capNextWord) 336 | | otherwise = x : (go xs capNextWord) 337 | where 338 | capNextWord = (last x == '.') 339 | 340 | -- Phone exercise 341 | 342 | -- 1) See phone.hs 343 | 344 | -- 2) 345 | 346 | cellPhonesDead :: DaPhone -> String -> [(Digit, Presses)] 347 | cellPhonesDead x y = concat $ map (reverseTaps x) y 348 | 349 | -- 3) 350 | 351 | fingerTaps :: [(Digit, Presses)] -> Presses 352 | fingerTaps x = sum (map snd x) 353 | 354 | -- 4) 355 | 356 | mostPopularLetter :: String -> Char 357 | mostPopularLetter x = fst (maximumBy (comparing snd) letterCounts) where 358 | letterCounts = map (\x' -> (head x', length x')) $ group $ sort x 359 | 360 | mostPopularLetterCosts = map (\x -> (x, (fingerTaps $ (reverseTaps defaultPhone x)))) (map mostPopularLetter convo) 361 | 362 | -- 5) 363 | 364 | coolestLtr :: [String] -> Char 365 | coolestLtr = mostPopularLetter . concat 366 | 367 | -- > coolestLtr convo 368 | -- ' ' 369 | 370 | coolestWord :: [String] -> String 371 | coolestWord x = fst (maximumBy (comparing snd) wordCounts) where 372 | allWords = concat (map words x) 373 | wordCounts = map (\x' -> (head x', length x')) $ group $ sort allWords 374 | 375 | -- > coolestWord convo 376 | -- "Lol" 377 | 378 | -- Hutton’s Razor 379 | 380 | -- 1) 381 | 382 | eval :: Expr -> Integer 383 | eval (Lit x) = x 384 | eval (Add x y) = (eval x) + (eval y) 385 | 386 | -- 2) 387 | 388 | printExpr :: Expr -> String 389 | printExpr (Lit x) = show x 390 | printExpr (Add x y) = (printExpr x) ++ " + " ++ (printExpr y) 391 | 392 | 393 | -- DEPRECATED 394 | -- These exercises appeared in previous versions of the book, but no longer 395 | -- seem to be in the latest version. 396 | 397 | -- 11.9 398 | 399 | -- 1) Done - see jammin.hs 400 | 401 | -- 2) 402 | data JamJars = 403 | Jam { fruit :: Fruit 404 | , count :: Int } 405 | deriving (Eq, Show) 406 | 407 | -- 3) Jam Fruit Int 408 | -- = (4) * (2^64) 409 | -- = 73786976294838206464 410 | 411 | -- 4) (okay) 412 | 413 | -- 5) 414 | row1 = Jam Plum 8 415 | row2 = Jam Blackberry 5 416 | row3 = Jam Apple 3 417 | row4 = Jam Peach 10 418 | row5 = Jam Apple 9 419 | row6 = Jam Peach 3 420 | allJam = [row1, row2, row3, row4, row5, row6] 421 | 422 | -- 6) 423 | totalJars :: [JamJars] -> Int 424 | totalJars = sum . (map count) 425 | -- or 426 | totalJars' :: [JamJars] -> Int 427 | totalJars' = foldr (\a b -> count a + b) 0 428 | 429 | -- 7) 430 | import Data.List 431 | mostRow :: [JamJars] -> JamJars 432 | mostRow xs = maximumBy (\x y -> compare (count x) (count y)) xs 433 | 434 | -- 8) okay: 435 | -- > import Data.List 436 | -- > :t sortBy 437 | -- sortBy :: (a -> a -> Ordering) -> [a] -> [a] 438 | -- > :t groupBy 439 | -- groupBy :: (a -> a -> Bool) -> [a] -> [[a]] 440 | 441 | -- 9) 442 | -- > sortBy compareKind allJam 443 | -- [Jam {fruit = Peach, count = 10},Jam {fruit = Peach, count = 3},Jam {fruit = Plum, count = 8},Jam {fruit = Apple, count = 3},Jam {fruit = Apple, count = 9},Jam {fruit = Blackberry, count = 5}] 444 | 445 | -- 10) 446 | compareCount :: JamJars -> JamJars -> Ordering 447 | compareCount (Jam _ c) (Jam _ c') = compare c' c 448 | 449 | sameKind :: JamJars -> JamJars -> Bool 450 | sameKind (Jam k _) (Jam k' _) = k == k' 451 | 452 | groupJam :: [JamJars] -> [[JamJars]] 453 | groupJam = groupBy sameKind . (sortBy compareKind) . (sortBy compareCount) 454 | 455 | -- *Jammin> groupJam allJam 456 | -- [[Jam {fruit = Peach, count = 10},Jam {fruit = Peach, count = 3}],[Jam {fruit = Plum, count = 8}],[Jam {fruit = Apple, count = 9},Jam {fruit = Apple, count = 3}],[Jam {fruit = Blackberry, count = 5}]] 457 | -------------------------------------------------------------------------------- /ch11/jammin.hs: -------------------------------------------------------------------------------- 1 | module Jammin where 2 | import Data.List 3 | 4 | data Fruit = 5 | Peach 6 | | Plum 7 | | Apple 8 | | Blackberry 9 | deriving (Eq, Show, Ord) 10 | 11 | data JamJars = 12 | Jam { fruit :: Fruit 13 | , count :: Int } 14 | deriving (Eq, Show, Ord) 15 | 16 | row1 = Jam Plum 8 17 | row2 = Jam Blackberry 5 18 | row3 = Jam Apple 3 19 | row4 = Jam Peach 10 20 | row5 = Jam Apple 9 21 | row6 = Jam Peach 3 22 | allJam = [row1, row2, row3, row4, row5, row6] 23 | 24 | totalJars :: [JamJars] -> Int 25 | totalJars = sum . (map count) 26 | 27 | totalJars' :: [JamJars] -> Int 28 | totalJars' = foldr (\a b -> count a + b) 0 29 | 30 | mostRow :: [JamJars] -> JamJars 31 | mostRow xs = maximumBy (\x y -> compare (count x) (count y)) xs 32 | 33 | compareKind :: JamJars -> JamJars -> Ordering 34 | compareKind (Jam k _) (Jam k' _) = compare k k' 35 | 36 | compareCount :: JamJars -> JamJars -> Ordering 37 | compareCount (Jam _ c) (Jam _ c') = compare c' c 38 | 39 | sameKind :: JamJars -> JamJars -> Bool 40 | sameKind (Jam k _) (Jam k' _) = k == k' 41 | 42 | groupJam :: [JamJars] -> [[JamJars]] 43 | groupJam = groupBy sameKind . (sortBy compareKind) . (sortBy compareCount) 44 | -------------------------------------------------------------------------------- /ch11/phone.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | import Data.Char 3 | import Data.List 4 | import Data.Maybe 5 | import Data.Ord 6 | 7 | convo :: [String] 8 | convo = 9 | ["Wanna play 20 questions", 10 | "Ya", 11 | "U 1st haha", 12 | "Lol ok. Have u ever tasted alcohol", 13 | "Lol ya", 14 | "Wow ur cool haha. Ur turn", 15 | "Ok. Do u think I am pretty Lol", 16 | "Lol ya", 17 | "Just making sure rofl ur turn"] 18 | 19 | type Digit = Char 20 | type Presses = Int 21 | 22 | data PhoneButton = 23 | PhoneButton { idDigit :: Digit 24 | , extraDigits :: [Digit] } 25 | deriving (Eq, Show) 26 | 27 | --type VanillaPhoneButton = PhoneButton 28 | --type CapitalizePhoneButton = PhoneButton 29 | 30 | class BtnPress a where 31 | btnPress :: a -> Char -> [(Digit, Presses)] 32 | getIdDigit :: a -> Digit 33 | getExtraDigits :: a -> [Digit] 34 | 35 | instance BtnPress PhoneButton where 36 | getIdDigit x = idDigit x 37 | getExtraDigits x = extraDigits x 38 | btnPress x y = go x y 1 ((extraDigits x) ++ [idDigit x]) where 39 | go x y i [] = [] 40 | go x y i (z:zs) = if (z == y) then [(getIdDigit x, i)] else go x y (i + 1) zs 41 | 42 | newtype VanillaPhoneButton = VanillaPhoneButton PhoneButton 43 | deriving (Eq,Show,BtnPress) 44 | newtype CapitalizePhoneButton = CapitalizePhoneButton PhoneButton 45 | deriving (Eq,Show) 46 | 47 | -- capitalize button requires one extra press to go past uppercase 48 | -- modification mode and into the available digits 49 | instance BtnPress CapitalizePhoneButton where 50 | getIdDigit (CapitalizePhoneButton x) = idDigit x 51 | getExtraDigits (CapitalizePhoneButton x) = extraDigits x 52 | btnPress (CapitalizePhoneButton x) y = go x y 2 ((extraDigits x) ++ [idDigit x]) where 53 | go x y i [] = [] 54 | go x y i (z:zs) = if (z == y) then [(z, i)] else go x y (i + 1) zs 55 | 56 | data DaPhone = 57 | DaPhone CapitalizePhoneButton [VanillaPhoneButton] 58 | deriving (Eq, Show) 59 | 60 | defaultPhone = DaPhone 61 | (CapitalizePhoneButton PhoneButton { idDigit = '*', extraDigits = ['^'] }) 62 | [ VanillaPhoneButton PhoneButton { idDigit = '1', extraDigits = [] }, 63 | VanillaPhoneButton PhoneButton { idDigit = '2', extraDigits = ['a'..'c'] }, 64 | VanillaPhoneButton PhoneButton { idDigit = '3', extraDigits = ['d'..'f'] }, 65 | VanillaPhoneButton PhoneButton { idDigit = '4', extraDigits = ['g'..'i'] }, 66 | VanillaPhoneButton PhoneButton { idDigit = '5', extraDigits = ['j'..'l'] }, 67 | VanillaPhoneButton PhoneButton { idDigit = '6', extraDigits = ['m'..'o'] }, 68 | VanillaPhoneButton PhoneButton { idDigit = '7', extraDigits = ['p'..'s'] }, 69 | VanillaPhoneButton PhoneButton { idDigit = '8', extraDigits = ['t'..'v'] }, 70 | VanillaPhoneButton PhoneButton { idDigit = '9', extraDigits = ['w'..'z'] }, 71 | VanillaPhoneButton PhoneButton { idDigit = '0', extraDigits = [' ', '+', '_'] }, 72 | VanillaPhoneButton PhoneButton { idDigit = '#', extraDigits = ['.', ','] } ] 73 | 74 | --allDigits :: PhoneButton 75 | --allDigits x = (extraDigits x) ++ [idDigit x] 76 | 77 | --getBtnPress :: PhoneButton -> Char -> [(Digit, Presses)] 78 | --getBtnPress (CapitalizePhoneButton x) = undefined 79 | 80 | getCapitalizeBtn :: DaPhone -> CapitalizePhoneButton 81 | getCapitalizeBtn (DaPhone x _) = x 82 | 83 | --getIdDigit :: CapitalizePhoneButton -> Digit 84 | --getIdDigit (CapitalizePhoneButton x) = idDigit x 85 | 86 | reverseTaps :: DaPhone -> Char -> [(Digit, Presses)] 87 | reverseTaps x@(DaPhone capBtn vanBtns) y 88 | | isUpper y = (getIdDigit capBtn, 1) : (reverseTaps x (toLower y)) 89 | | length (btnPress capBtn y) > 0 = btnPress capBtn y 90 | | otherwise = btnPress (fromJust (find (\x' -> length (btnPress x' y) > 0) vanBtns)) y 91 | 92 | cellPhonesDead :: DaPhone -> String -> [(Digit, Presses)] 93 | cellPhonesDead x y = concat $ map (reverseTaps x) y 94 | 95 | fingerTaps :: [(Digit, Presses)] -> Presses 96 | fingerTaps x = sum (map snd x) 97 | 98 | mostPopularLetter :: String -> Char 99 | mostPopularLetter x = fst (maximumBy (comparing snd) letterCounts) where 100 | letterCounts = map (\x' -> (head x', length x')) $ group $ sort x 101 | 102 | mostPopularLetterCosts = map (\x -> (x, (fingerTaps $ (reverseTaps defaultPhone x)))) (map mostPopularLetter convo) 103 | 104 | coolestLtr :: [String] -> Char 105 | coolestLtr = mostPopularLetter . concat 106 | 107 | coolestWord :: [String] -> String 108 | coolestWord x = fst (maximumBy (comparing snd) wordCounts) where 109 | allWords = concat (map words x) 110 | wordCounts = map (\x' -> (head x', length x')) $ group $ sort allWords 111 | 112 | 113 | -- keeping the very first attempt for posterity, written before thinking much 114 | -- about how to design data structures to store the phone digits 115 | {- 116 | reverseTaps :: DaPhone -> Char -> [(Digit, Presses)] 117 | reverseTaps x y 118 | | y `elem` ['A'..'Z'] = ('*', 1) : reverseTaps x (toLower y) 119 | | isJust idxBtn1 = [('1' :: Digit, (fromJust idxBtn1) + 1 :: Presses)] 120 | | isJust idxBtn2 = [('2' :: Digit, (fromJust idxBtn2) + 1 :: Presses)] 121 | | isJust idxBtn3 = [('3' :: Digit, (fromJust idxBtn3) + 1 :: Presses)] 122 | | isJust idxBtn4 = [('4' :: Digit, (fromJust idxBtn4) + 1 :: Presses)] 123 | | isJust idxBtn5 = [('5' :: Digit, (fromJust idxBtn5) + 1 :: Presses)] 124 | | isJust idxBtn6 = [('6' :: Digit, (fromJust idxBtn6) + 1 :: Presses)] 125 | | isJust idxBtn7 = [('7' :: Digit, (fromJust idxBtn7) + 1 :: Presses)] 126 | | isJust idxBtn8 = [('8' :: Digit, (fromJust idxBtn8) + 1 :: Presses)] 127 | | isJust idxBtn9 = [('9' :: Digit, (fromJust idxBtn9) + 1 :: Presses)] 128 | | isJust idxBtn0 = [('0' :: Digit, (fromJust idxBtn0) + 1 :: Presses)] 129 | | isJust idxBtnStar = [('*' :: Digit, (fromJust idxBtnStar) + 1 :: Presses)] 130 | | isJust idxBtnPound = [('#' :: Digit, (fromJust idxBtnPound) + 1 :: Presses)] 131 | | otherwise = [] 132 | where 133 | idxBtn1 = y `elemIndex` ['1'] 134 | idxBtn2 = y `elemIndex` (['a'..'c'] ++ ['2']) 135 | idxBtn3 = y `elemIndex` (['d'..'f'] ++ ['3']) 136 | idxBtn4 = y `elemIndex` (['g'..'i'] ++ ['4']) 137 | idxBtn5 = y `elemIndex` (['j'..'l'] ++ ['5']) 138 | idxBtn6 = y `elemIndex` (['m'..'o'] ++ ['6']) 139 | idxBtn7 = y `elemIndex` (['p'..'s'] ++ ['7']) 140 | idxBtn8 = y `elemIndex` (['t'..'v'] ++ ['8']) 141 | idxBtn9 = y `elemIndex` (['w'..'z'] ++ ['9']) 142 | idxBtn0 = y `elemIndex` (['+', '_'] ++ ['0']) 143 | idxBtnStar = y `elemIndex` ['^', '*'] 144 | idxBtnPound = y `elemIndex` ['.', ',', '#'] 145 | -} 146 | -------------------------------------------------------------------------------- /ch11/vigenere.hs: -------------------------------------------------------------------------------- 1 | module Vigenere where 2 | import Data.Char 3 | 4 | infiniteUpper :: String 5 | infiniteUpper = concat $ (repeat ['A'..'Z']) 6 | 7 | infiniteLower :: String 8 | infiniteLower = concat $ (repeat ['a'..'z']) 9 | 10 | -- charIdx 'A' = 0 11 | -- charIdx 'B' = 1 12 | charIdx :: Char -> Int 13 | charIdx x 14 | | elem x ['A'..'Z'] = (ord x) - (ord 'A') 15 | | elem x ['a'..'z'] = (ord x) - (ord 'a') 16 | | otherwise = 0 17 | 18 | -- charShift 'Y' 2 = 'A' 19 | -- charShift 'y' 2 = 'a' 20 | charShift :: Char -> Int -> Char 21 | charShift x y 22 | | elem x ['A'..'Z'] = infiniteUpper !! ((charIdx x) + y + 26) 23 | | elem x ['a'..'z'] = infiniteLower !! ((charIdx x) + y + 26) 24 | | otherwise = x 25 | 26 | encodeChar :: Char -> [Int] -> (Char, [Int]) 27 | encodeChar x encodeList 28 | | elem x (['A'..'Z'] ++ ['a'..'z']) = ((charShift x (head encodeList)), tail encodeList) 29 | | otherwise = (x, encodeList) 30 | 31 | encodeString :: String -> [Int] -> String 32 | encodeString "" _ = [] 33 | encodeString x y = (fst charRes) : (encodeString (tail x) (snd charRes)) where 34 | charRes = encodeChar (head x) y 35 | 36 | -- encode "MEET AT DAWN" "ALLY" = "MPPR AE OYWY" 37 | encode :: String -> String -> String 38 | encode plaintext codeword = encodeString plaintext encodeOffsets 39 | where codeword' = concat $ (repeat codeword) 40 | encodeOffsets = (map charIdx codeword') 41 | 42 | -- decode "MPPR AE OYWY" "ALLY" = "MEET AT DAWN" 43 | decode :: String -> String -> String 44 | decode ciphertext codeword = encodeString ciphertext decodeOffsets 45 | where codeword' = concat $ (repeat codeword) 46 | negativeNum = (\x -> x * (-1)) 47 | decodeOffsets = (map (negativeNum . charIdx) codeword') 48 | -------------------------------------------------------------------------------- /ch12/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 12.5 2 | 3 | -- Determine the kinds 4 | 5 | -- 1) 6 | -- a :: * 7 | 8 | -- 2) 9 | -- a :: * 10 | -- f :: * -> * 11 | 12 | -- String processing 13 | 14 | -- 1) 15 | 16 | notThe :: String -> Maybe String 17 | notThe x 18 | | x == "the" = Nothing 19 | | otherwise = Just x 20 | 21 | replaceThe :: String -> String 22 | replaceThe x = unwords $ map (replaceThe' . notThe) $ words x 23 | 24 | replaceThe' :: Maybe String -> String 25 | replaceThe' Nothing = "a" 26 | replaceThe' (Just x) = x 27 | 28 | -- 2) 29 | 30 | countTheBeforeVowel :: String -> Integer 31 | countTheBeforeVowel x = go (words x) False where 32 | go :: [String] -> Bool -> Integer 33 | go [] _ = 0 34 | go (x:xs) lastWordWasThe = wordValue + (go xs (x == "the")) where 35 | wordValue = if (lastWordWasThe && isVowel (head x)) then 1 else 0 36 | 37 | isVowel :: Char -> Bool 38 | isVowel x = x `elem` "aeiouAEIOU" 39 | 40 | -- 3) 41 | 42 | countVowels :: String -> Integer 43 | countVowels = length (filter . isVowel) 44 | 45 | -- Validate the word 46 | 47 | newtype Word' = 48 | Word' String 49 | deriving (Eq, Show) 50 | 51 | consonants = [x | x <- ['a'..'z'] ++ ['A'..'Z'], (not . isVowel) x] 52 | isConsonant :: Char -> Bool 53 | isConsonant x = x `elem` consonants 54 | 55 | countConsonantsVowels :: String -> (Integer, Integer) 56 | countConsonantsVowels x = go x (0,0) where 57 | go [] y = y 58 | go (x:xs) y@(cs,vs) 59 | | isConsonant x = go xs (cs + 1, vs) 60 | | isVowel x = go xs (cs, vs + 1) 61 | | otherwise = go xs y 62 | 63 | mkWord :: String -> Maybe Word' 64 | mkWord x = if (vowels > consonants) then Nothing else (Just $ Word' x) where 65 | consonants = fst (countConsonantsVowels x) 66 | vowels = snd (countConsonantsVowels x) 67 | 68 | -- It’s only Natural 69 | 70 | data Nat = 71 | Zero 72 | | Succ Nat 73 | deriving (Eq, Show) 74 | 75 | natToInteger :: Nat -> Integer 76 | natToInteger Zero = 0 77 | natToInteger (Succ x) = 1 + (natToInteger x) 78 | 79 | integerToNat :: Integer -> Maybe Nat 80 | integerToNat x 81 | | x < 0 = Nothing 82 | | otherwise = Just (go x) 83 | where 84 | go x' 85 | | x' == 0 = Zero 86 | | otherwise = Succ (go (x' - 1)) 87 | 88 | -- Small library for Maybe 89 | 90 | -- 1) 91 | 92 | isJust :: Maybe a -> Bool 93 | isJust Nothing = False 94 | isJust (Just _) = True 95 | 96 | isNothing :: Maybe a -> Bool 97 | isNothing Nothing = True 98 | isNothing (Just _) = False 99 | 100 | -- 2) 101 | 102 | mayybee :: b -> (a -> b) -> Maybe a -> b 103 | mayybee x _ Nothing = x 104 | mayybee _ f (Just y) = (f y) 105 | 106 | -- 3) 107 | 108 | fromMaybe :: a -> Maybe a -> a 109 | fromMaybe x Nothing = x 110 | fromMaybe _ (Just y) = y 111 | 112 | -- 4) 113 | 114 | listToMaybe :: [a] -> Maybe a 115 | listToMaybe [] = Nothing 116 | listToMaybe (x:_) = Just x 117 | 118 | maybeToList :: Maybe a -> [a] 119 | maybeToList Nothing = [] 120 | maybeToList (Just x) = [x] 121 | 122 | -- 5) 123 | 124 | catMaybes :: [Maybe a] -> [a] 125 | catMaybes [] = [] 126 | catMaybes (x:xs) = case x of 127 | Nothing -> catMaybes(xs) 128 | (Just x') -> x' : catMaybes(xs) 129 | 130 | -- 6) 131 | 132 | flipMaybe :: [Maybe a] -> Maybe [a] 133 | flipMaybe x = if (length $ catMaybes x) == (length x) then Just(catMaybes x) else Nothing 134 | 135 | {- 136 | flipMaybe :: [Maybe a] -> Maybe [a] 137 | flipMaybe x = if (fst result) then Nothing else (Just snd result) where 138 | go' True _ = (True, undefined) 139 | go' x [] = (x,[]) 140 | go' x (y:ys) = go' (x, ) 141 | result = go' (False, []) 142 | -} 143 | 144 | -- Small library for Either 145 | 146 | -- 1) 147 | 148 | -- initial solution: 149 | lefts' :: [Either a b] -> [a] 150 | lefts' [] = [] 151 | lefts' (x:xs) = case x of 152 | (Left x') -> x' : lefts'(xs) 153 | (Right x') -> lefts'(xs) 154 | 155 | -- rewritten to use foldr: 156 | leftToList :: Either a b -> [a] 157 | leftToList (Left a) = [a] 158 | leftToList _ = [] 159 | 160 | lefts'' :: [Either a b] -> [a] 161 | lefts'' = foldr ((++) . leftToList) [] 162 | 163 | -- 2) 164 | rightToList :: Either a b -> [b] 165 | rightToList (Right b) = [b] 166 | rightToList _ = [] 167 | 168 | rights' :: [Either a b] -> [b] 169 | rights' = foldr ((++) . rightToList) [] 170 | 171 | -- 3) 172 | partitionEithers' :: [Either a b] -> ([a], [b]) 173 | partitionEithers' x = ((lefts' x), (rights' x)) 174 | 175 | -- 4) 176 | eitherMaybe' :: (b -> c) -> Either a b -> Maybe c 177 | eitherMaybe' f (Right x) = Just (f x) 178 | eitherMaybe' _ (Left _) = Nothing 179 | 180 | -- 5) 181 | either' :: (a -> c) -> (b -> c) -> Either a b -> c 182 | either' f _ (Left x) = f x 183 | either' _ g (Right y) = g y 184 | 185 | -- 6) 186 | eitherMaybe'' :: (b -> c) -> Either a b -> Maybe c 187 | eitherMaybe'' _ (Left x) = Nothing 188 | eitherMaybe'' f (Right y) = Just(f y) 189 | 190 | -- Write your own iterate and unfoldr 191 | 192 | -- 1) 193 | myIterate :: (a -> a) -> a -> [a] 194 | myIterate f x = x : myIterate f (f x) 195 | 196 | -- 2) 197 | myUnfoldr :: (b -> Maybe (a, b)) -> b -> [a] 198 | myUnfoldr f x = case (f x) of 199 | Nothing -> [] 200 | (Just (x',y')) -> x' : (myUnfoldr f y') 201 | 202 | -- 3) 203 | betterIterate :: (a -> a) -> a -> [a] 204 | betterIterate f x = myUnfoldr (\x' -> Just(x', (f x'))) x 205 | 206 | -- Finally something other than a list! 207 | 208 | -- 1) 209 | 210 | data BinaryTree a = 211 | Leaf 212 | | Node (BinaryTree a) a (BinaryTree a) 213 | deriving (Eq, Ord, Show) 214 | 215 | unfold :: (a -> Maybe (a,b,a)) -> a -> BinaryTree b 216 | unfold f x = case (f x) of 217 | Nothing -> Leaf 218 | Just (x',y,z) -> Node (unfold f x') y (unfold f z) 219 | 220 | -- 2) 221 | 222 | treeBuild :: Integer -> BinaryTree Integer 223 | treeBuild x = unfold go 0 where 224 | go x' 225 | | x' == x = Nothing 226 | | otherwise = Just( (x' + 1, x', x' + 1) ) 227 | -------------------------------------------------------------------------------- /ch13/caesar.hs: -------------------------------------------------------------------------------- 1 | module Cipher where 2 | import Data.Char 3 | import Data.List 4 | 5 | caesarDigits = ['a'..'z'] 6 | 7 | caesarChar :: Int -> Char 8 | caesarChar x = caesarDigits !! (x `mod` (length caesarDigits)) 9 | 10 | caesarChars :: Int -> String 11 | caesarChars x 12 | | i < 0 = take i caesarDigits ++ drop i caesarDigits 13 | | otherwise = drop i caesarDigits ++ take i caesarDigits 14 | where 15 | i = x `mod` (length caesarDigits) 16 | 17 | caesarCharCipher :: Char -> Int -> Char 18 | caesarCharCipher x y = case elemIndex x caesarDigits of 19 | Just i -> (caesarChars y) !! i 20 | Nothing -> x 21 | 22 | caesarCharDecipher :: Char -> Int -> Char 23 | caesarCharDecipher x y = case elemIndex x (caesarChars y) of 24 | Just i -> caesarDigits !! i 25 | Nothing -> x 26 | 27 | caesar :: String -> Int -> String 28 | caesar [] _ = [] 29 | caesar (x:xs) i = (caesarCharCipher x i) : (caesar xs i) 30 | 31 | unCaesar :: String -> Int -> String 32 | unCaesar [] _ = [] 33 | unCaesar (x:xs) i = (caesarCharDecipher x i) : (unCaesar xs i) 34 | 35 | encodeInput :: IO () 36 | encodeInput = do 37 | putStrLn "Input plaintext to encode:" 38 | plaintext <- getLine 39 | putStrLn "Input shift" 40 | shift <- getLine 41 | let shift' = (read shift) :: Int 42 | putStrLn $ caesar plaintext shift' 43 | 44 | decodeInput :: IO () 45 | decodeInput = do 46 | putStrLn "Input ciphertext to decode:" 47 | ciphertext <- getLine 48 | putStrLn "Input shift" 49 | shift <- getLine 50 | let shift' = (read shift) :: Int 51 | putStrLn $ unCaesar ciphertext shift' 52 | -------------------------------------------------------------------------------- /ch13/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 13.6 2 | 3 | -- Intermission: Check your understanding 4 | 5 | -- 1) 6 | -- forever and when 7 | 8 | -- 2) 9 | -- import Data.Bits 10 | -- import Database.Blacktip.Types 11 | 12 | -- 3) 13 | -- I would guess it imports type definitions 14 | 15 | -- 4a) 16 | -- MV = Control.Concurrent.MVar 17 | -- FPC = Filesystem.Path.CurrentOS 18 | -- CC = Control.Concurrent 19 | 20 | -- 4b) 21 | -- import qualified Filesystem as FS 22 | 23 | -- 4c) 24 | -- import Control.Monad (forever, when) 25 | 26 | -- 13.14 27 | 28 | -- Modifying code 29 | 30 | -- 1) 31 | -- see vigenere.hs and caesar.hs `encodeInput` and `decodeInput` functions 32 | 33 | -- 2) 34 | 35 | import Control.Monad 36 | import System.Exit (exitSuccess) 37 | 38 | palindrome :: IO () 39 | palindrome = forever $ do 40 | line1 <- getLine 41 | case (line1 == reverse line1) of 42 | True -> putStrLn "It's a palindrome!" 43 | False -> do 44 | putStrLn "Nope!" 45 | exitSuccess 46 | 47 | -- 3) 48 | 49 | import Control.Monad 50 | import Data.Char (toLower) 51 | import System.Exit (exitSuccess) 52 | 53 | palindrome :: IO () 54 | palindrome = forever $ do 55 | line1 <- getLine 56 | let line1' = filter (\x -> x `elem` ['a'..'z']) (map toLower line1) 57 | case (line1' == reverse line1') of 58 | True -> putStrLn "It's a palindrome!" 59 | False -> do 60 | putStrLn "Nope!" 61 | exitSuccess 62 | 63 | -- 4) 64 | 65 | type Name = String 66 | type Age = Integer 67 | 68 | data Person = Person Name Age deriving Show 69 | 70 | data PersonInvalid = 71 | NameEmpty 72 | | AgeTooLow 73 | | PersonInvalidUnknown String 74 | deriving (Eq, Show) 75 | 76 | mkPerson :: Name 77 | -> Age 78 | -> Either PersonInvalid Person 79 | mkPerson name age 80 | | name /= "" && age > 0 = 81 | Right $ Person name age 82 | | name == "" = Left NameEmpty 83 | | not (age > 0) = Left AgeTooLow 84 | | otherwise = 85 | Left $ PersonInvalidUnknown $ 86 | "Name was: " ++ show name ++ 87 | " Age was: " ++ show age 88 | 89 | gimmePerson :: IO () 90 | gimmePerson = do 91 | putStrLn "Enter your name:" 92 | name <- getLine 93 | putStrLn "Enter your age:" 94 | age <- getLine 95 | let age' = (read age) :: Integer 96 | case (mkPerson name age') of 97 | (Right x) -> do 98 | putStrLn "Yay! Successfully got a person:" 99 | putStrLn (show x) 100 | (Left x) -> do 101 | putStrLn "Error creating person:" 102 | putStrLn (show x) 103 | -------------------------------------------------------------------------------- /ch13/hangman/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /ch13/hangman/README.md: -------------------------------------------------------------------------------- 1 | # hangman 2 | -------------------------------------------------------------------------------- /ch13/hangman/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch13/hangman/hangman.cabal: -------------------------------------------------------------------------------- 1 | name: hangman 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/hangman#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2019 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: data/dict.txt 15 | 16 | executable hangman 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | default-language: Haskell2010 20 | build-depends: base >= 4.7 && < 5 21 | , random 22 | , split 23 | -------------------------------------------------------------------------------- /ch13/hangman/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (forever) 4 | import Data.Char (toLower) 5 | import Data.Maybe (isJust) 6 | import Data.List (intersperse) 7 | import System.Exit (exitSuccess) 8 | import System.Random (randomRIO) 9 | import System.IO 10 | 11 | type WordList = [String] 12 | 13 | allWords :: IO WordList 14 | allWords = do 15 | dict <- readFile "data/dict.txt" 16 | return (lines dict) 17 | 18 | minWordLength :: Int 19 | minWordLength = 5 20 | 21 | maxWordLength :: Int 22 | maxWordLength = 9 23 | 24 | gameWords :: IO WordList 25 | gameWords = do 26 | aw <- allWords 27 | return (filter gameLength aw) 28 | where gameLength w = 29 | let l = length (w :: String) 30 | in l >= minWordLength 31 | && l < maxWordLength 32 | 33 | randomWord :: WordList -> IO String 34 | randomWord wl = do 35 | randomIndex <- randomRIO (0, (length wl) - 1) 36 | return $ wl !! randomIndex 37 | 38 | randomWord' :: IO String 39 | randomWord' = gameWords >>= randomWord 40 | 41 | data Puzzle = 42 | Puzzle String [Maybe Char] [Char] 43 | 44 | instance Show Puzzle where 45 | show (Puzzle _ discovered guessed) = 46 | (intersperse ' ' $ 47 | fmap renderPuzzleChar discovered) 48 | ++ " Guessed so far: " ++ guessed 49 | 50 | freshPuzzle :: String -> Puzzle 51 | freshPuzzle x = Puzzle x (map (const Nothing) x) [] 52 | 53 | charInWord :: Puzzle -> Char -> Bool 54 | charInWord (Puzzle word _ _) x = elem x word 55 | 56 | alreadyGuessed :: Puzzle -> Char -> Bool 57 | alreadyGuessed (Puzzle _ _ alreadyGuessed) x = elem x alreadyGuessed 58 | 59 | renderPuzzleChar :: Maybe Char -> Char 60 | renderPuzzleChar Nothing = '_' 61 | renderPuzzleChar (Just x) = x 62 | 63 | 64 | fillInCharacter :: Puzzle -> Char -> Puzzle 65 | fillInCharacter (Puzzle word 66 | filledInSoFar s) c = 67 | Puzzle word newFilledInSoFar (c : s) 68 | where zipper guessed wordChar guessChar = 69 | if wordChar == guessed 70 | then Just wordChar 71 | else guessChar 72 | newFilledInSoFar = 73 | zipWith (zipper c) 74 | word filledInSoFar 75 | 76 | handleGuess :: Puzzle -> Char -> IO Puzzle 77 | handleGuess puzzle guess = do 78 | putStrLn $ "Your guess was: " ++ [guess] 79 | case (charInWord puzzle guess 80 | , alreadyGuessed puzzle guess) of 81 | (_, True) -> do 82 | putStrLn "You already guessed that\ 83 | \ character, pick \ 84 | \ something else!" 85 | return puzzle 86 | (True, _) -> do 87 | putStrLn "This character was in the\ 88 | \ word, filling in the word\ 89 | \ accordingly" 90 | return (fillInCharacter puzzle guess) 91 | (False, _) -> do 92 | putStrLn "This character wasn't in\ 93 | \ the word, try again." 94 | return (fillInCharacter puzzle guess) 95 | 96 | gameOver :: Puzzle -> IO () 97 | gameOver (Puzzle wordToGuess _ guessed) = 98 | if (length guessed) > 7 then 99 | do putStrLn "You lose!" 100 | putStrLn $ 101 | "The word was: " ++ wordToGuess 102 | exitSuccess 103 | else return () 104 | 105 | gameWin :: Puzzle -> IO () 106 | gameWin (Puzzle _ filledInSoFar _) = 107 | if all isJust filledInSoFar then 108 | do putStrLn "You win!" 109 | exitSuccess 110 | else return () 111 | 112 | runGame :: Puzzle -> IO () 113 | runGame puzzle = forever $ do 114 | gameOver puzzle 115 | gameWin puzzle 116 | putStrLn $ 117 | "Current puzzle is: " ++ show puzzle 118 | putStr "Guess a letter: " 119 | guess <- getLine 120 | case guess of 121 | [c] -> handleGuess puzzle c >>= runGame 122 | _ -> 123 | putStrLn "Your guess must\ 124 | \ be a single character" 125 | 126 | main :: IO () 127 | main = do 128 | hSetBuffering stdout NoBuffering 129 | word <- randomWord' 130 | let puzzle = 131 | freshPuzzle (fmap toLower word) 132 | runGame puzzle 133 | -------------------------------------------------------------------------------- /ch13/hangman/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.14 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | -------------------------------------------------------------------------------- /ch13/hello/.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | -------------------------------------------------------------------------------- /ch13/hello/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Chris Allen (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Chris Allen nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /ch13/hello/README.md: -------------------------------------------------------------------------------- 1 | # hello 2 | 3 | Example project for the [Haskell](http://haskellbook.com) book. 4 | -------------------------------------------------------------------------------- /ch13/hello/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch13/hello/exe/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import DogsRule 4 | import Hello 5 | import System.IO 6 | 7 | main :: IO () 8 | main = do 9 | hSetBuffering stdout NoBuffering 10 | putStr "Please input your name: " 11 | name <- getLine 12 | sayHello name 13 | dogs 14 | -------------------------------------------------------------------------------- /ch13/hello/hello.cabal: -------------------------------------------------------------------------------- 1 | name: hello 2 | version: 0.1.0.0 3 | synopsis: Simple project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/bitemyapp/hello#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Your Name Here 9 | maintainer: example@email.com 10 | copyright: 2016, Your Name Here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | executable hello 16 | hs-source-dirs: exe 17 | main-is: Main.hs 18 | default-language: Haskell2010 19 | build-depends: base >= 4.7 && < 5 20 | , hello 21 | 22 | library 23 | hs-source-dirs: src 24 | exposed-modules: DogsRule 25 | , Hello 26 | build-depends: base >= 4.7 && < 5 27 | default-language: Haskell2010 28 | -------------------------------------------------------------------------------- /ch13/hello/src/DogsRule.hs: -------------------------------------------------------------------------------- 1 | module DogsRule 2 | ( dogs ) 3 | where 4 | 5 | dogs :: IO () 6 | dogs = do 7 | putStrLn "Who's a good puppy?!" 8 | putStrLn "YOU ARE!!!!!" 9 | -------------------------------------------------------------------------------- /ch13/hello/src/Hello.hs: -------------------------------------------------------------------------------- 1 | module Hello 2 | ( sayHello ) 3 | where 4 | 5 | sayHello :: String -> IO () 6 | sayHello name = do 7 | putStrLn ("Hi " ++ name ++ "!") 8 | -------------------------------------------------------------------------------- /ch13/hello/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by stack init 2 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 5 | resolver: lts-5.14 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | -------------------------------------------------------------------------------- /ch13/vigenere.hs: -------------------------------------------------------------------------------- 1 | module Vigenere where 2 | import Control.Monad 3 | import Data.Char 4 | import System.Exit (exitSuccess) 5 | 6 | infiniteUpper :: String 7 | infiniteUpper = concat $ (repeat ['A'..'Z']) 8 | 9 | infiniteLower :: String 10 | infiniteLower = concat $ (repeat ['a'..'z']) 11 | 12 | -- charIdx 'A' = 0 13 | -- charIdx 'B' = 1 14 | charIdx :: Char -> Int 15 | charIdx x 16 | | elem x ['A'..'Z'] = (ord x) - (ord 'A') 17 | | elem x ['a'..'z'] = (ord x) - (ord 'a') 18 | | otherwise = 0 19 | 20 | -- charShift 'Y' 2 = 'A' 21 | -- charShift 'y' 2 = 'a' 22 | charShift :: Char -> Int -> Char 23 | charShift x y 24 | | elem x ['A'..'Z'] = infiniteUpper !! ((charIdx x) + y + 26) 25 | | elem x ['a'..'z'] = infiniteLower !! ((charIdx x) + y + 26) 26 | | otherwise = x 27 | 28 | encodeChar :: Char -> [Int] -> (Char, [Int]) 29 | encodeChar x encodeList 30 | | elem x (['A'..'Z'] ++ ['a'..'z']) = ((charShift x (head encodeList)), tail encodeList) 31 | | otherwise = (x, encodeList) 32 | 33 | encodeString :: String -> [Int] -> String 34 | encodeString "" _ = [] 35 | encodeString x y = (fst charRes) : (encodeString (tail x) (snd charRes)) where 36 | charRes = encodeChar (head x) y 37 | 38 | -- encode "MEET AT DAWN" "ALLY" = "MPPR AE OYWY" 39 | encode :: String -> String -> String 40 | encode plaintext codeword = encodeString plaintext encodeOffsets 41 | where codeword' = concat $ (repeat codeword) 42 | encodeOffsets = (map charIdx codeword') 43 | 44 | -- decode "MPPR AE OYWY" "ALLY" = "MEET AT DAWN" 45 | decode :: String -> String -> String 46 | decode ciphertext codeword = encodeString ciphertext decodeOffsets 47 | where codeword' = concat $ (repeat codeword) 48 | negativeNum = (\x -> x * (-1)) 49 | decodeOffsets = (map (negativeNum . charIdx) codeword') 50 | 51 | encodeInput :: IO () 52 | encodeInput = do 53 | putStrLn "Input plaintext to encode:" 54 | plaintext <- getLine 55 | putStrLn "Input codeword" 56 | codeword <- getLine 57 | putStrLn $ encode plaintext codeword 58 | 59 | decodeInput :: IO () 60 | decodeInput = do 61 | putStrLn "Input ciphertext to decode:" 62 | ciphertext <- getLine 63 | putStrLn "Input codeword" 64 | codeword <- getLine 65 | putStrLn $ decode ciphertext codeword 66 | -------------------------------------------------------------------------------- /ch14/Addition.hs: -------------------------------------------------------------------------------- 1 | module Addition where 2 | 3 | import Test.Hspec 4 | import Test.QuickCheck 5 | 6 | sayHello :: IO () 7 | sayHello = putStrLn "hello!" 8 | 9 | dividedBy :: Integral a => a -> a -> (a, a) 10 | dividedBy num denom = go num denom 0 11 | where go n d count 12 | | n < d = (count, n) 13 | | otherwise = 14 | go (n - d) d (count + 1) 15 | main :: IO () 16 | main = hspec $ do 17 | describe "Addition" $ do 18 | it "1 + 1 is greater than 1" $ do 19 | (1 + 1) > 1 `shouldBe` True 20 | it "2 + 2 is equal to 4" $ do 21 | 2 + 2 `shouldBe` 4 22 | it "15 divided by 3 is 5" $ do 23 | dividedBy 15 3 `shouldBe` (5, 0) 24 | it "22 divided by 5 is\ 25 | \ 4 remainder 2" $ do 26 | dividedBy 22 5 `shouldBe` (4, 2) 27 | it "x + 1 is always\ 28 | \ greater than x" $ do 29 | property $ \x -> x + 1 > (x :: Int) 30 | 31 | trivialInt :: Gen Int 32 | trivialInt = return 1 33 | 34 | oneThroughThree :: Gen Int 35 | oneThroughThree = elements [1, 2, 3] 36 | 37 | genBool :: Gen Bool 38 | genBool = choose (False, True) 39 | 40 | genBool' :: Gen Bool 41 | genBool' = elements [False, True] 42 | 43 | genOrdering :: Gen Ordering 44 | genOrdering = elements [LT, EQ, GT] 45 | 46 | genChar :: Gen Char 47 | genChar = elements ['a'..'z'] 48 | 49 | genTuple :: (Arbitrary a, Arbitrary b) 50 | => Gen (a, b) 51 | genTuple = do 52 | a <- arbitrary 53 | b <- arbitrary 54 | return (a, b) 55 | 56 | genThreeple :: (Arbitrary a, Arbitrary b, 57 | Arbitrary c) 58 | => Gen (a, b, c) 59 | genThreeple = do 60 | a <- arbitrary 61 | b <- arbitrary 62 | c <- arbitrary 63 | return (a, b, c) 64 | 65 | genEither :: (Arbitrary a, Arbitrary b) 66 | => Gen (Either a b) 67 | genEither = do 68 | a <- arbitrary 69 | b <- arbitrary 70 | elements [Left a, Right b] 71 | 72 | genMaybe :: Arbitrary a => Gen (Maybe a) 73 | genMaybe = do 74 | a <- arbitrary 75 | elements [Nothing, Just a] 76 | 77 | genMaybe' :: Arbitrary a => Gen (Maybe a) 78 | genMaybe' = do 79 | a <- arbitrary 80 | frequency [ (1, return Nothing) 81 | , (3, return (Just a))] 82 | 83 | prop_additionGreater :: Int -> Bool 84 | prop_additionGreater x = x + 1 > x 85 | 86 | runQc :: IO () 87 | runQc = quickCheck prop_additionGreater 88 | -------------------------------------------------------------------------------- /ch14/LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/abevoelker/haskellbook-solutions/9e2804940b3b45bdc1b04cfa5d536097629c9498/ch14/LICENSE -------------------------------------------------------------------------------- /ch14/ShortExercise.hs: -------------------------------------------------------------------------------- 1 | module ShortExercise where 2 | 3 | import Test.Hspec 4 | 5 | -- resurrected from chapter 8 exercises 6 | mult :: (Integral a) => a -> a -> a 7 | mult x y = go x y 0 where 8 | go x' remainingCount accum 9 | | remainingCount == 0 = accum 10 | | otherwise = go x' (remainingCount - 1) (accum + x') 11 | 12 | -- Intermission: Short Exercise 13 | main :: IO () 14 | main = hspec $ do 15 | describe "Addition" $ do 16 | it "1 * 1 is 1" $ do 17 | mult 1 1 `shouldBe` 1 18 | it "2 * 5 is 10" $ do 19 | mult 2 5 `shouldBe` 10 20 | -------------------------------------------------------------------------------- /ch14/UsingQuickCheck.hs: -------------------------------------------------------------------------------- 1 | module UsingQuickCheck where 2 | 3 | -- 1) 4 | 5 | import Test.QuickCheck 6 | 7 | half x = x / 2 8 | halfIdentity = (*2) . half 9 | 10 | prop_half :: Double -> Bool 11 | prop_half x = x == halfIdentity x 12 | 13 | main :: IO () 14 | main = quickCheck prop_half 15 | -------------------------------------------------------------------------------- /ch14/WordNumber.hs: -------------------------------------------------------------------------------- 1 | module WordNumber where 2 | 3 | import Data.List (intersperse) 4 | 5 | digitToWord :: Int -> String 6 | digitToWord n = case n of 7 | 0 -> "zero" 8 | 1 -> "one" 9 | 2 -> "two" 10 | 3 -> "three" 11 | 4 -> "four" 12 | 5 -> "five" 13 | 6 -> "six" 14 | 7 -> "seven" 15 | 8 -> "eight" 16 | _ -> "nine" 17 | 18 | digits :: Int -> [Int] 19 | digits n 20 | | (n < 10) = [n] 21 | | otherwise = digits(n `div` 10) ++ [n `mod` 10] 22 | 23 | wordNumber :: Int -> String 24 | wordNumber = concat . (intersperse "-") . (map digitToWord) . digits 25 | -------------------------------------------------------------------------------- /ch14/WordNumberTest.hs: -------------------------------------------------------------------------------- 1 | module WordNumberTest where 2 | 3 | import Test.Hspec 4 | import WordNumber 5 | (digitToWord, digits, wordNumber) 6 | 7 | main :: IO () 8 | main = hspec $ do 9 | describe "digitToWord" $ do 10 | it "returns zero for 0" $ do 11 | digitToWord 0 `shouldBe` "zero" 12 | it "returns one for 1" $ do 13 | digitToWord 1 `shouldBe` "one" 14 | 15 | describe "digits" $ do 16 | it "returns [1] for 1" $ do 17 | digits 1 `shouldBe` [1] 18 | it "returns [1, 0, 0] for 100" $ do 19 | digits 100 `shouldBe` [1, 0, 0] 20 | 21 | describe "wordNumber" $ do 22 | it "one-zero-zero given 100" $ do 23 | wordNumber 100 24 | `shouldBe` "one-zero-zero" 25 | it "nine-zero-zero-one for 9001" $ do 26 | wordNumber 9001 27 | `shouldBe` "nine-zero-zero-one" 28 | -------------------------------------------------------------------------------- /ch14/addition.cabal: -------------------------------------------------------------------------------- 1 | -- addition.cabal 2 | name: addition 3 | version: 0.1.0.0 4 | license-file: LICENSE 5 | author: Chicken Little 6 | maintainer: sky@isfalling.example.org 7 | category: Text 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | 11 | library 12 | exposed-modules: Addition 13 | ghc-options: -Wall -fwarn-tabs 14 | build-depends: base >=4.7 && <5 15 | , hspec 16 | , QuickCheck 17 | hs-source-dirs: . 18 | default-language: Haskell2010 19 | -------------------------------------------------------------------------------- /ch14/ciphers/Caesar.hs: -------------------------------------------------------------------------------- 1 | module Caesar where 2 | import Data.Char 3 | import Data.List 4 | 5 | caesarDigits = ['a'..'z'] 6 | 7 | caesarChar :: Int -> Char 8 | caesarChar x = caesarDigits !! (x `mod` (length caesarDigits)) 9 | 10 | caesarChars :: Int -> String 11 | caesarChars x 12 | | i < 0 = take i caesarDigits ++ drop i caesarDigits 13 | | otherwise = drop i caesarDigits ++ take i caesarDigits 14 | where 15 | i = x `mod` (length caesarDigits) 16 | 17 | caesarCharCipher :: Char -> Int -> Char 18 | caesarCharCipher x y = case elemIndex x caesarDigits of 19 | Just i -> (caesarChars y) !! i 20 | Nothing -> x 21 | 22 | caesarCharDecipher :: Char -> Int -> Char 23 | caesarCharDecipher x y = case elemIndex x (caesarChars y) of 24 | Just i -> caesarDigits !! i 25 | Nothing -> x 26 | 27 | caesar :: String -> Int -> String 28 | caesar [] _ = [] 29 | caesar (x:xs) i = (caesarCharCipher x i) : (caesar xs i) 30 | 31 | unCaesar :: String -> Int -> String 32 | unCaesar [] _ = [] 33 | unCaesar (x:xs) i = (caesarCharDecipher x i) : (unCaesar xs i) 34 | 35 | encodeInput :: IO () 36 | encodeInput = do 37 | putStrLn "Input plaintext to encode:" 38 | plaintext <- getLine 39 | putStrLn "Input shift" 40 | shift <- getLine 41 | let shift' = (read shift) :: Int 42 | putStrLn $ caesar plaintext shift' 43 | 44 | decodeInput :: IO () 45 | decodeInput = do 46 | putStrLn "Input ciphertext to decode:" 47 | ciphertext <- getLine 48 | putStrLn "Input shift" 49 | shift <- getLine 50 | let shift' = (read shift) :: Int 51 | putStrLn $ unCaesar ciphertext shift' 52 | -------------------------------------------------------------------------------- /ch14/ciphers/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Caesar as C 4 | import qualified Vigenere as V 5 | import Test.QuickCheck 6 | 7 | caesarIdentity :: String -> Int -> Bool 8 | caesarIdentity plaintext i = (C.unCaesar (C.caesar plaintext i) i) == plaintext 9 | 10 | vigIdentity :: String -> String -> Bool 11 | vigIdentity plaintext codeword = (V.decode (V.encode plaintext codeword) codeword) == plaintext 12 | 13 | main :: IO () 14 | main = do 15 | quickCheck caesarIdentity 16 | quickCheck vigIdentity 17 | -------------------------------------------------------------------------------- /ch14/ciphers/Vigenere.hs: -------------------------------------------------------------------------------- 1 | module Vigenere where 2 | import Control.Monad 3 | import Data.Char 4 | import System.Exit (exitSuccess) 5 | 6 | infiniteUpper :: String 7 | infiniteUpper = concat $ (repeat ['A'..'Z']) 8 | 9 | infiniteLower :: String 10 | infiniteLower = concat $ (repeat ['a'..'z']) 11 | 12 | -- charIdx 'A' = 0 13 | -- charIdx 'B' = 1 14 | charIdx :: Char -> Int 15 | charIdx x 16 | | elem x ['A'..'Z'] = (ord x) - (ord 'A') 17 | | elem x ['a'..'z'] = (ord x) - (ord 'a') 18 | | otherwise = 0 19 | 20 | -- charShift 'Y' 2 = 'A' 21 | -- charShift 'y' 2 = 'a' 22 | charShift :: Char -> Int -> Char 23 | charShift x y 24 | | elem x ['A'..'Z'] = infiniteUpper !! ((charIdx x) + y + 26) 25 | | elem x ['a'..'z'] = infiniteLower !! ((charIdx x) + y + 26) 26 | | otherwise = x 27 | 28 | encodeChar :: Char -> [Int] -> (Char, [Int]) 29 | encodeChar x encodeList 30 | | elem x (['A'..'Z'] ++ ['a'..'z']) = ((charShift x (head encodeList)), tail encodeList) 31 | | otherwise = (x, encodeList) 32 | 33 | encodeString :: String -> [Int] -> String 34 | encodeString "" _ = [] 35 | encodeString x y = (fst charRes) : (encodeString (tail x) (snd charRes)) where 36 | charRes = encodeChar (head x) y 37 | 38 | -- encode "MEET AT DAWN" "ALLY" = "MPPR AE OYWY" 39 | encode :: String -> String -> String 40 | encode plaintext codeword = encodeString plaintext encodeOffsets 41 | where codeword' = concat $ (repeat codeword) 42 | encodeOffsets = (map charIdx codeword') 43 | 44 | -- decode "MPPR AE OYWY" "ALLY" = "MEET AT DAWN" 45 | decode :: String -> String -> String 46 | decode ciphertext codeword = encodeString ciphertext decodeOffsets 47 | where codeword' = concat $ (repeat codeword) 48 | negativeNum = (\x -> x * (-1)) 49 | decodeOffsets = (map (negativeNum . charIdx) codeword') 50 | 51 | encodeInput :: IO () 52 | encodeInput = do 53 | putStrLn "Input plaintext to encode:" 54 | plaintext <- getLine 55 | putStrLn "Input codeword" 56 | codeword <- getLine 57 | putStrLn $ encode plaintext codeword 58 | 59 | decodeInput :: IO () 60 | decodeInput = do 61 | putStrLn "Input ciphertext to decode:" 62 | ciphertext <- getLine 63 | putStrLn "Input codeword" 64 | codeword <- getLine 65 | putStrLn $ decode ciphertext codeword 66 | -------------------------------------------------------------------------------- /ch14/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 14.3 2 | 3 | -- Intermission: Short Exercise 4 | 5 | -- see ShortExercise.hs 6 | 7 | 8 | -- 14.7 9 | 10 | -- Validating numbers into words 11 | 12 | -- see WordNumberTest.hs 13 | 14 | -- Using QuickCheck 15 | 16 | -- 1) 17 | import Test.QuickCheck 18 | 19 | half x = x / 2 20 | halfIdentity = (*2) . half 21 | 22 | prop_half :: Double -> Bool 23 | prop_half x = x == halfIdentity x 24 | 25 | main :: IO () 26 | main = quickCheck prop_half 27 | 28 | -- 2) 29 | import Data.List (sort) 30 | import Test.QuickCheck 31 | 32 | listOrdered :: (Ord a) => [a] -> Bool 33 | listOrdered xs = 34 | snd $ foldr go (Nothing, True) xs 35 | where go _ status@(_, False) = status 36 | go y (Nothing, t) = (Just y, t) 37 | go y (Just x, t) = (Just y, x >= y) 38 | 39 | prop_sort :: (Ord a) => [a] -> Bool 40 | prop_sort xs = listOrdered (sort xs) 41 | 42 | main :: IO () 43 | main = quickCheck (prop_sort :: [Int] -> Bool) 44 | 45 | -- 3) 46 | import Test.QuickCheck 47 | 48 | plusAssociative x y z = 49 | x + (y + z) == (x + y) + z 50 | 51 | plusCommutative x y = 52 | x + y == y + x 53 | 54 | prop_plusAssociative :: (Eq a, Num a) => a -> a -> a -> Bool 55 | prop_plusAssociative x y z = plusAssociative x y z 56 | 57 | prop_plusCommutative :: (Eq a, Num a) => a -> a -> Bool 58 | prop_plusCommutative x y = plusCommutative x y 59 | 60 | main :: IO () 61 | main = do 62 | quickCheck (prop_plusAssociative :: Int -> Int -> Int -> Bool) 63 | quickCheck (prop_plusAssociative :: Integer -> Integer -> Integer -> Bool) 64 | quickCheck (prop_plusCommutative :: Int -> Int -> Bool) 65 | quickCheck (prop_plusCommutative :: Integer -> Integer -> Bool) 66 | 67 | -- 4) 68 | import Test.QuickCheck 69 | 70 | multAssociative x y z = 71 | x * (y * z) == (x * y) * z 72 | 73 | multCommutative x y = 74 | x * y == y * x 75 | 76 | prop_multAssociative :: (Eq a, Num a) => a -> a -> a -> Bool 77 | prop_multAssociative x y z = multAssociative x y z 78 | 79 | prop_multCommutative :: (Eq a, Num a) => a -> a -> Bool 80 | prop_multCommutative x y = multCommutative x y 81 | 82 | main :: IO () 83 | main = do 84 | quickCheck (prop_multAssociative :: Int -> Int -> Int -> Bool) 85 | quickCheck (prop_multAssociative :: Integer -> Integer -> Integer -> Bool) 86 | quickCheck (prop_multCommutative :: Int -> Int -> Bool) 87 | quickCheck (prop_multCommutative :: Integer -> Integer -> Bool) 88 | 89 | -- 5) 90 | import Test.QuickCheck 91 | 92 | prop_quotRem :: Integral a => a -> a -> Bool 93 | prop_quotRem x y = (quot x y)*y + (rem x y) == x 94 | 95 | prop_divMod :: Integral a => a -> a -> Bool 96 | prop_divMod x y = (div x y)*y + (mod x y) == x 97 | 98 | genNonZero :: Gen Integer 99 | genNonZero = (arbitrary :: Gen Integer) `suchThat` (/= 0) 100 | 101 | genTuple :: Gen (Integer, Integer) 102 | genTuple = do 103 | a <- (arbitrary :: Gen Integer) 104 | b <- (arbitrary :: Gen Integer) `suchThat` (/= 0) 105 | return (a,b) 106 | 107 | main :: IO () 108 | main = do 109 | quickCheck $ forAll genTuple (\(x,y) -> prop_quotRem x y) 110 | quickCheck $ forAll genTuple (\(x,y) -> prop_divMod x y) 111 | 112 | -- 6) 113 | -- (^) appears to be neither associative nor commutative, 114 | -- as all tests failed (associativity falsified with 0 0 0, 115 | -- commutativity falsified with 0 1) 116 | import Test.QuickCheck 117 | 118 | expAssociative x y z = 119 | x ^ (y ^ z) == (x ^ y) ^ z 120 | 121 | expCommutative x y = 122 | x ^ y == y ^ x 123 | 124 | prop_expAssociative :: (Eq a, Integral a, Num a) => a -> a -> a -> Bool 125 | prop_expAssociative x y z = expAssociative x y z 126 | 127 | prop_expCommutative :: (Eq a, Integral a, Num a) => a -> a -> Bool 128 | prop_expCommutative x y = expCommutative x y 129 | 130 | main :: IO () 131 | main = do 132 | quickCheck (prop_expAssociative :: Int -> Int -> Int -> Bool) 133 | quickCheck (prop_expAssociative :: Integer -> Integer -> Integer -> Bool) 134 | quickCheck (prop_expCommutative :: Int -> Int -> Bool) 135 | quickCheck (prop_expCommutative :: Integer -> Integer -> Bool) 136 | 137 | -- 7) 138 | -- All tests pass 139 | import Test.QuickCheck 140 | 141 | prop_reverseTwiceId :: (Eq a) => [a] -> Bool 142 | prop_reverseTwiceId x = (reverse . reverse) x == x 143 | 144 | main :: IO () 145 | main = do 146 | quickCheck (prop_reverseTwiceId :: [Integer] -> Bool) 147 | quickCheck (prop_reverseTwiceId :: [Char] -> Bool) 148 | 149 | -- 8) 150 | -- All tests pass 151 | import Data.List 152 | import Test.QuickCheck 153 | 154 | -- This SO answer was helpful for puzzling this one out: 155 | -- https://stackoverflow.com/a/2017664/215168 156 | prop_dollarCompose f g x = ((f . g) x) == ((\x' -> f $ g x') x) 157 | 158 | main :: IO () 159 | main = do 160 | quickCheck ((prop_dollarCompose reverse sort) ::[Integer] -> Bool) 161 | quickCheck ((prop_dollarCompose reverse sort) ::[Int] -> Bool) 162 | quickCheck ((prop_dollarCompose reverse sort) ::[Char] -> Bool) 163 | quickCheck ((prop_dollarCompose reverse sort) ::[Double] -> Bool) 164 | quickCheck ((prop_dollarCompose reverse sort) ::[Float] -> Bool) 165 | quickCheck ((prop_dollarCompose reverse sort) ::[Bool] -> Bool) 166 | 167 | -- 9) 168 | -- The first property is falsified with [0] [1] however all tests 169 | -- pass with the second property test. 170 | import Test.QuickCheck 171 | 172 | prop_foldrConsPlusPlus :: Eq a => [a] -> [a] -> Bool 173 | prop_foldrConsPlusPlus x y = (foldr (:) x y) == ((++) x y) 174 | 175 | prop_foldrPlusPlusConcat :: (Eq a, Foldable t) => t [a] -> Bool 176 | prop_foldrPlusPlusConcat x = (foldr (++) [] x) == concat x 177 | 178 | main :: IO () 179 | main = do 180 | quickCheck (prop_foldrConsPlusPlus :: [Integer] -> [Integer] -> Bool) 181 | quickCheck (prop_foldrPlusPlusConcat :: [String] -> Bool) 182 | quickCheck (prop_foldrPlusPlusConcat :: [[Integer]] -> Bool) 183 | quickCheck (prop_foldrPlusPlusConcat :: [[Int]] -> Bool) 184 | quickCheck (prop_foldrPlusPlusConcat :: [[Double]] -> Bool) 185 | 186 | -- 10) 187 | -- Nope, doesn't work for n greater than the length of the 188 | -- list. QuickCheck falsified it with 1 [] 189 | import Test.QuickCheck 190 | 191 | prop_length :: Int -> [a] -> Bool 192 | prop_length n xs = length (take n xs) == n 193 | 194 | main :: IO () 195 | main = do 196 | quickCheck (prop_length :: Int -> [Integer] -> Bool) 197 | 198 | -- 11) 199 | -- All tests pass 200 | import Test.QuickCheck 201 | 202 | prop_readShow :: (Eq a, Read a, Show a) => a -> Bool 203 | prop_readShow x = (read (show x)) == x 204 | 205 | main :: IO () 206 | main = do 207 | quickCheck (prop_readShow :: Integer -> Bool) 208 | quickCheck (prop_readShow :: Int -> Bool) 209 | quickCheck (prop_readShow :: Double -> Bool) 210 | quickCheck (prop_readShow :: Char -> Bool) 211 | quickCheck (prop_readShow :: String -> Bool) 212 | quickCheck (prop_readShow :: [Integer] -> Bool) 213 | quickCheck (prop_readShow :: [Int] -> Bool) 214 | quickCheck (prop_readShow :: [Double] -> Bool) 215 | 216 | -- Failure 217 | 218 | -- It fails because of loss of precision when carrying 219 | -- out floating point operations. 220 | import Test.QuickCheck 221 | 222 | square :: Num a => a -> a 223 | square x = x * x 224 | 225 | squareIdentity :: (Eq a, Floating a) => a -> Bool 226 | squareIdentity x = (square . sqrt) x == id x 227 | 228 | main :: IO () 229 | main = do 230 | quickCheck (squareIdentity :: Double -> Bool) 231 | quickCheck (squareIdentity :: Float -> Bool) 232 | 233 | -- Idempotence 234 | 235 | import Data.Char 236 | import Data.List 237 | import Test.QuickCheck 238 | 239 | twice f = f . f 240 | fourTimes = twice . twice 241 | 242 | capitalizeWord :: String -> String 243 | capitalizeWord "" = "" 244 | capitalizeWord (x:xs) = toUpper x : xs 245 | 246 | f :: String -> Bool 247 | f x = 248 | (capitalizeWord x 249 | == twice capitalizeWord x) 250 | && 251 | (capitalizeWord x 252 | == fourTimes capitalizeWord x) 253 | 254 | f' :: Ord a => [a] -> Bool 255 | f' x = 256 | (sort x 257 | == twice sort x) 258 | && 259 | (sort x 260 | == fourTimes sort x) 261 | 262 | main :: IO () 263 | main = do 264 | quickCheck f 265 | quickCheck (f' :: [Integer] -> Bool) 266 | quickCheck (f' :: [Int] -> Bool) 267 | quickCheck (f' :: [Double] -> Bool) 268 | quickCheck (f' :: [Float] -> Bool) 269 | quickCheck (f' :: [Char] -> Bool) 270 | quickCheck (f' :: [Bool] -> Bool) 271 | 272 | -- Make a Gen random generator for the datatype 273 | 274 | import Test.QuickCheck 275 | 276 | data Fool = 277 | Fulse 278 | | Frue 279 | deriving (Eq, Show) 280 | 281 | -- 1) 282 | genFool :: Gen Fool 283 | genFool = do 284 | oneof [return $ Fulse, 285 | return $ Frue] 286 | 287 | -- 2) 288 | genFool' :: Gen Fool 289 | genFool' = 290 | frequency [(2, return Fulse), 291 | (1, return Frue)] 292 | 293 | -- Hangman testing 294 | 295 | -- First, had to add `deriving (Eq)` to Puzzle: 296 | data Puzzle = 297 | Puzzle String [Maybe Char] [Char] 298 | deriving (Eq) 299 | 300 | -- To test, worked in existing ch13 project directory. Added 301 | -- hspec to hangman.cabal build-depends, then added this to Main.hs 302 | -- (replacing existing main function): 303 | import Test.Hspec 304 | 305 | main :: IO () 306 | main = hspec $ do 307 | describe "fillInCharacter" $ do 308 | context "a puzzle where the guessed char is in the puzzle" $ do 309 | it "fills in the character in the puzzle and adds char to guesses" $ do 310 | (fillInCharacter (freshPuzzle "foo") 'o') `shouldBe` 311 | Puzzle "foo" [Nothing, Just 'o', Just 'o'] "o" 312 | context "a puzzle where the guessed char is not in the puzzle" $ do 313 | it "doesn't fill in the puzzle but adds char to guesses" $ do 314 | (fillInCharacter (freshPuzzle "foo") 'z') `shouldBe` 315 | Puzzle "foo" [Nothing, Nothing, Nothing] "z" 316 | describe "handleGuess" $ do 317 | context "a puzzle with an existing guess" $ do 318 | let puzzle = (Puzzle "foo" [Nothing, Nothing, Nothing] "z") 319 | context "re-guessing the same char" $ do 320 | it "doesn't change the puzzle" $ do 321 | puzzle' <- handleGuess puzzle 'z' 322 | puzzle' `shouldBe` puzzle 323 | context "guessing a new char where the char is in the puzzle" $ do 324 | it "updates the puzzle and guesses" $ do 325 | puzzle' <- handleGuess puzzle 'f' 326 | puzzle' `shouldBe` (Puzzle "foo" [Just 'f', Nothing, Nothing] "fz") 327 | context "guessing a new char where the char is not in the puzzle" $ do 328 | it "updates the guesses but not the puzzle" $ do 329 | puzzle' <- handleGuess puzzle 'x' 330 | puzzle' `shouldBe` (Puzzle "foo" [Nothing, Nothing, Nothing] "xz") 331 | context "a puzzle without existing guesses" $ do 332 | let puzzle = (Puzzle "foo" [Nothing, Nothing, Nothing] "") 333 | context "guessing a new char where the char is in the puzzle" $ do 334 | it "updates the puzzle and guesses" $ do 335 | puzzle' <- handleGuess puzzle 'f' 336 | puzzle' `shouldBe` (Puzzle "foo" [Just 'f', Nothing, Nothing] "f") 337 | context "guessing a new char where the char is not in the puzzle" $ do 338 | it "updates the guesses but not the puzzle" $ do 339 | puzzle' <- handleGuess puzzle 'x' 340 | puzzle' `shouldBe` (Puzzle "foo" [Nothing, Nothing, Nothing] "x") 341 | 342 | -- Validating ciphers 343 | 344 | -- See "ciphers" directory: 345 | -- cd ciphers 346 | -- stack ghci Main.hs 347 | -- > main 348 | -------------------------------------------------------------------------------- /ch14/morse/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /ch14/morse/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /ch14/morse/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch14/morse/morse.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 6ab42d9205797692755b7c927802047938e226fa378739e913775101fbfe2155 8 | 9 | name: morse 10 | version: 0.1.0.0 11 | license-file: LICENSE 12 | author: Abe Voelker 13 | maintainer: abe@abevoelker.com 14 | category: Text 15 | build-type: Simple 16 | 17 | library 18 | exposed-modules: 19 | Morse 20 | ghc-options: 21 | -Wall -fwarn-tabs 22 | build-depends: 23 | base >=4.7 && <5 24 | , containers 25 | , QuickCheck 26 | hs-source-dirs: 27 | src 28 | default-language: Haskell2010 29 | 30 | executable morse 31 | main-is: Main.hs 32 | ghc-options: -Wall -fwarn-tabs 33 | hs-source-dirs: src 34 | build-depends: 35 | base >=4.7 && <5 36 | , containers 37 | , morse 38 | , QuickCheck 39 | default-language: Haskell2010 40 | 41 | test-suite tests 42 | ghc-options: -Wall -fno-warn-orphans 43 | type: exitcode-stdio-1.0 44 | main-is: tests.hs 45 | hs-source-dirs: tests 46 | build-depends: 47 | base 48 | , containers 49 | , morse 50 | , QuickCheck 51 | default-language: Haskell2010 52 | -------------------------------------------------------------------------------- /ch14/morse/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (forever, when) 4 | import Data.List (intercalate) 5 | import Data.Traversable (traverse) 6 | import Morse (stringToMorse, morseToChar) 7 | import System.Environment (getArgs) 8 | import System.Exit (exitFailure, 9 | exitSuccess) 10 | import System.IO (hGetLine, hIsEOF, stdin) 11 | 12 | convertToMorse :: IO () 13 | convertToMorse = forever $ do 14 | weAreDone <- hIsEOF stdin 15 | when weAreDone exitSuccess 16 | 17 | -- otherwise, proceed 18 | line <- hGetLine stdin 19 | convertLine line 20 | 21 | where 22 | convertLine line = do 23 | let morse = stringToMorse line 24 | case morse of 25 | (Just str) 26 | -> putStrLn 27 | (intercalate " " str) 28 | Nothing 29 | -> do 30 | putStrLn $ "ERROR: " ++ line 31 | exitFailure 32 | 33 | convertFromMorse :: IO () 34 | convertFromMorse = forever $ do 35 | weAreDone <- hIsEOF stdin 36 | when weAreDone exitSuccess 37 | 38 | -- otherwise, proceed. 39 | line <- hGetLine stdin 40 | convertLine line 41 | 42 | where 43 | convertLine line = do 44 | let decoded :: Maybe String 45 | decoded = 46 | traverse morseToChar 47 | (words line) 48 | case decoded of 49 | (Just s) -> putStrLn s 50 | Nothing -> do 51 | putStrLn $ "ERROR: " ++ line 52 | exitFailure 53 | 54 | main :: IO () 55 | main = do 56 | mode <- getArgs 57 | case mode of 58 | [arg] -> 59 | case arg of 60 | "from" -> convertFromMorse 61 | "to" -> convertToMorse 62 | _ -> argError 63 | _ -> argError 64 | 65 | where argError = do 66 | putStrLn "Please specify the\ 67 | \ first argument\ 68 | \ as being 'from' or\ 69 | \ 'to' morse,\ 70 | \ such as: morse to" 71 | exitFailure -------------------------------------------------------------------------------- /ch14/morse/src/Morse.hs: -------------------------------------------------------------------------------- 1 | module Morse 2 | ( Morse 3 | , charToMorse 4 | , morseToChar 5 | , stringToMorse 6 | , letterToMorse 7 | , morseToLetter 8 | ) where 9 | 10 | import qualified Data.Map as M 11 | 12 | type Morse = String 13 | 14 | letterToMorse :: (M.Map Char Morse) 15 | letterToMorse = M.fromList [ 16 | ('a', ".-") 17 | , ('b', "-...") 18 | , ('c', "-.-.") 19 | , ('d', "-..") 20 | , ('e', ".") 21 | , ('f', "..-.") 22 | , ('g', "--.") 23 | , ('h', "....") 24 | , ('i', "..") 25 | , ('j', ".---") 26 | , ('k', "-.-") 27 | , ('l', ".-..") 28 | , ('m', "--") 29 | , ('n', "-.") 30 | , ('o', "---") 31 | , ('p', ".--.") 32 | , ('q', "--.-") 33 | , ('r', ".-.") 34 | , ('s', "...") 35 | , ('t', "-") 36 | , ('u', "..-") 37 | , ('v', "...-") 38 | , ('w', ".--") 39 | , ('x', "-..-") 40 | , ('y', "-.--") 41 | , ('z', "--..") 42 | , ('1', ".----") 43 | , ('2', "..---") 44 | , ('3', "...--") 45 | , ('4', "....-") 46 | , ('5', ".....") 47 | , ('6', "-....") 48 | , ('7', "--...") 49 | , ('8', "---..") 50 | , ('9', "----.") 51 | , ('0', "-----") 52 | ] 53 | 54 | morseToLetter :: M.Map Morse Char 55 | morseToLetter = 56 | M.foldrWithKey (flip M.insert) M.empty 57 | letterToMorse 58 | 59 | charToMorse :: Char -> Maybe Morse 60 | charToMorse c = 61 | M.lookup c letterToMorse 62 | 63 | stringToMorse :: String -> Maybe [Morse] 64 | stringToMorse s = 65 | sequence $ fmap charToMorse s 66 | 67 | morseToChar :: Morse -> Maybe Char 68 | morseToChar m = 69 | M.lookup m morseToLetter 70 | -------------------------------------------------------------------------------- /ch14/morse/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.16 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | -------------------------------------------------------------------------------- /ch14/morse/tests/tests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Map as M 4 | import Morse 5 | import Test.QuickCheck 6 | 7 | allowedChars :: [Char] 8 | allowedChars = M.keys letterToMorse 9 | 10 | allowedMorse :: [Morse] 11 | allowedMorse = M.elems letterToMorse 12 | 13 | charGen :: Gen Char 14 | charGen = elements allowedChars 15 | 16 | morseGen :: Gen Morse 17 | morseGen = elements allowedMorse 18 | 19 | prop_thereAndBackAgain :: Property 20 | prop_thereAndBackAgain = 21 | forAll charGen 22 | (\c -> ((charToMorse c) 23 | >>= morseToChar) == Just c) 24 | 25 | main :: IO () 26 | main = quickCheck prop_thereAndBackAgain 27 | -------------------------------------------------------------------------------- /ch14/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.16 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | -------------------------------------------------------------------------------- /ch2/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 2.4 2 | 3 | -- 1. 4 | let half x = x / 2 5 | let square x = x * x 6 | 7 | -- 2. 8 | let ex242 x = 3.14 * (x * x) 9 | 10 | 11 | -- 2.5 12 | 13 | -- 1. 14 | -- yes 15 | 16 | -- 2. 17 | -- no 18 | 19 | -- 3. 20 | -- yes 21 | 22 | 23 | -- 2.6 24 | 25 | -- 1. 26 | let area x = 3.14 * (x * x) 27 | 28 | -- 2. 29 | let double x = x * 2 30 | 31 | -- 3. 32 | x = 7 33 | y = 10 34 | f = x + y 35 | 36 | 37 | -- 2.12 38 | 39 | ex1 = x * 3 + y 40 | where x = 3 41 | y = 1000 42 | 43 | ex2 = x * 5 44 | where x = 10 * 5 + y 45 | y = 10 46 | 47 | ex3 = z / x + y 48 | where x = 7 49 | y = negate x 50 | z = y * 10 51 | 52 | 53 | -- 2.13 54 | 55 | -- Parenthesization 56 | 57 | -- 2 + 2 * 3 - 1 58 | 2 + (2 * 3) - 1 59 | 60 | -- (^) 10 $ 1 + 1 61 | (^) 10 (1 + 1) 62 | 63 | -- 2 ^ 2 * 4 ^ 5 + 1 64 | (2 ^ 2) * (4 ^ 5) + 1 65 | 66 | -- Equivalent expressions 67 | 68 | -- 1. 69 | -- same 70 | 71 | -- 2. 72 | -- same 73 | 74 | -- 3. 75 | -- different 76 | 77 | -- 4. 78 | -- different (integer vs. fractional division) 79 | 80 | -- 5. 81 | -- different 82 | 83 | -- More fun with functions 84 | 85 | -- 0. 86 | let z = 7 87 | let y = z + 8 88 | let x = y ^ 2 89 | let waxOn = x * 5 90 | -- waxOn = 1125 91 | 92 | -- 1. 93 | 94 | -- 10 + waxOn 95 | -- 1135 96 | 97 | -- (+10) waxOn 98 | -- 1135 99 | 100 | -- (-) 15 waxOn 101 | -- -1110 102 | 103 | -- (-) waxOn 15 104 | -- 1110 105 | 106 | -- 2. 107 | -- (okay) 108 | 109 | -- 3. 110 | -- the x in the triple function is local to it, so it will evaluate (1125 * 3) 111 | -- which is 3375 112 | 113 | -- 4. 114 | -- see wax_on.hs 115 | 116 | -- 5. 117 | -- yep, still works 118 | 119 | -- 6. 120 | -- (okay) 121 | 122 | -- 7. 123 | -- What is the result of waxOff 10 or waxOff (-50)? 124 | -- 30 and -150 125 | -------------------------------------------------------------------------------- /ch2/practice.hs: -------------------------------------------------------------------------------- 1 | mult1 = x * y 2 | where x = 5 3 | y = 6 4 | -------------------------------------------------------------------------------- /ch2/test.hs: -------------------------------------------------------------------------------- 1 | sayHello :: String -> IO () 2 | sayHello x = putStrLn ("Hello, " ++ x ++ "!") 3 | -------------------------------------------------------------------------------- /ch2/wax_on.hs: -------------------------------------------------------------------------------- 1 | waxOn = x * 5 2 | where x = y ^ 2 3 | y = z + 8 4 | z = 7 5 | 6 | triple x = x * 3 7 | 8 | waxOff x = triple x 9 | -------------------------------------------------------------------------------- /ch3/building_functions.hs: -------------------------------------------------------------------------------- 1 | module BuildingFunctions where 2 | 3 | ex1a :: String -> String 4 | ex1a x = x ++ "!" 5 | 6 | ex1b :: String -> String 7 | ex1b x = [x !! 4] 8 | 9 | ex1c :: String -> String 10 | ex1c x = drop 9 x 11 | -------------------------------------------------------------------------------- /ch3/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 3.3 2 | 3 | -- 1. 4 | -- yes 5 | 6 | -- 2. 7 | -- no 8 | 9 | -- 3. 10 | -- no (d out of scope in 2nd line) 11 | 12 | -- 4. 13 | -- yes 14 | 15 | 16 | -- 3.4 17 | 18 | -- 1. 19 | -- no, incorrect use of infix notation. fix w/ prefix notation: 20 | (++) [1, 2, 3] [4, 5, 6] 21 | 22 | -- 2. 23 | -- no, single quotes are used for chars, not strings. fixed: 24 | "<3" ++ " Haskell" 25 | 26 | -- 3. 27 | -- yes, String is a list of Chars, so a list of Strings type checks `concat` 28 | 29 | 30 | -- 3.5 31 | -- (see print4fixed.hs) 32 | 33 | 34 | -- 3.7 35 | 36 | -- Reading syntax 37 | 38 | -- 1.a) 39 | -- correct 40 | 41 | -- 1.b) 42 | -- incorrect. fixed: 43 | [1, 2, 3] ++ [4, 5, 6] 44 | -- or 45 | (++) [1, 2, 3] [4, 5, 6] 46 | 47 | -- 1.c) 48 | -- correct 49 | 50 | -- 1.d) 51 | -- incorrect. fixed: 52 | ["hello" ++ " world"] 53 | 54 | -- 1.e) 55 | -- incorrect. fixed: 56 | "hello" !! 4 57 | 58 | -- 1.f) 59 | -- correct 60 | 61 | -- 1.g) 62 | -- incorrect. fixed: 63 | take 4 "lovely" 64 | 65 | -- 1.h) 66 | -- correct 67 | 68 | -- 2.a) 69 | -- d 70 | 71 | -- 2.b) 72 | -- c 73 | 74 | -- 2.c) 75 | -- e 76 | 77 | -- 2.d) 78 | -- a 79 | 80 | -- 2.e) 81 | -- b 82 | 83 | -- Building functions 84 | 85 | -- 1.a) 86 | "Curry is awesome" ++ "!" 87 | 88 | -- 1.b) 89 | ["Curry is awesome!" !! 4] 90 | -- or 91 | take 1 $ drop 4 "Curry is awesome!" 92 | 93 | -- 1.c) 94 | drop 9 "Curry is awesome!" 95 | 96 | -- 2. 97 | -- see building_functions.hs 98 | -- ex1a "Curry is awesome" 99 | -- ex1b "Curry is awesome!" 100 | -- ex1c "Curry is awesome!" 101 | 102 | -- 3. 103 | thirdLetter :: String -> Char 104 | thirdLetter x = x !! 2 105 | 106 | -- 4. 107 | letterIndex :: Int -> Char 108 | letterIndex x = "Curry is awesome!" !! x 109 | 110 | -- 5. 111 | rvrs :: String -> String 112 | rvrs x = (drop 9 x) ++ " " ++ (take 2 $ drop 6 x) ++ " " ++ (take 5 x) 113 | -------------------------------------------------------------------------------- /ch3/foo.hs: -------------------------------------------------------------------------------- 1 | area d = pi * (r * r) 2 | where r = d / 2 3 | -------------------------------------------------------------------------------- /ch3/global.hs: -------------------------------------------------------------------------------- 1 | module GlobalLocal where 2 | 3 | topLevelFunction :: Integer -> Integer 4 | topLevelFunction x = x + woot + topLevelValue 5 | where woot :: Integer 6 | woot = 10 7 | 8 | topLevelValue :: Integer 9 | topLevelValue = 5 10 | -------------------------------------------------------------------------------- /ch3/print1.hs: -------------------------------------------------------------------------------- 1 | module Print1 where 2 | 3 | main :: IO () 4 | main = putStrLn "hello world!" 5 | -------------------------------------------------------------------------------- /ch3/print2.hs: -------------------------------------------------------------------------------- 1 | module Print2 where 2 | 3 | main :: IO () 4 | main = do 5 | putStrLn "Count to four for me:" 6 | putStr "one, two" 7 | putStr ", three, and" 8 | putStrLn " four!" 9 | -------------------------------------------------------------------------------- /ch3/print3.hs: -------------------------------------------------------------------------------- 1 | module Print3 where 2 | 3 | myGreeting :: String 4 | 5 | myGreeting = "hello" ++ " world!" 6 | 7 | hello :: String 8 | hello = "hello" 9 | 10 | world :: String 11 | world = "world!" 12 | 13 | main :: IO () 14 | main = do 15 | putStrLn myGreeting 16 | putStrLn secondGreeting 17 | where secondGreeting = concat [hello, " ", world] 18 | -------------------------------------------------------------------------------- /ch3/print3flipped.hs: -------------------------------------------------------------------------------- 1 | module Print3Flipped where 2 | 3 | myGreeting :: String 4 | myGreeting = (++) "hello" " world!" 5 | 6 | hello :: String 7 | hello = "hello" 8 | 9 | world :: String 10 | world = "world!" 11 | 12 | main :: IO () 13 | main = do 14 | putStrLn myGreeting 15 | putStrLn secondGreeting 16 | where secondGreeting = (++) hello ((++) " " world) 17 | -------------------------------------------------------------------------------- /ch3/print4broken.hs: -------------------------------------------------------------------------------- 1 | module Print4Broken where 2 | 3 | printSecond :: IO () 4 | printSecond = do 5 | putStrLn greeting 6 | 7 | main :: IO () 8 | main = do 9 | putStrLn greeting 10 | printSecond 11 | where greeting = "Yarrrrr" 12 | -------------------------------------------------------------------------------- /ch3/print4fixed.hs: -------------------------------------------------------------------------------- 1 | module Print4Fixed where 2 | 3 | greeting :: String 4 | greeting = "Yarrrrr" 5 | 6 | printSecond :: IO () 7 | printSecond = do 8 | putStrLn greeting 9 | 10 | main :: IO () 11 | main = do 12 | putStrLn greeting 13 | printSecond 14 | -------------------------------------------------------------------------------- /ch3/reverse.hs: -------------------------------------------------------------------------------- 1 | module Reverse where 2 | 3 | rvrs :: String -> String 4 | rvrs x = (drop 9 x) ++ " " ++ (take 2 $ drop 6 x) ++ " " ++ (take 5 x) 5 | 6 | main :: IO () 7 | main = print $ rvrs "Curry is awesome" 8 | -------------------------------------------------------------------------------- /ch4/change_mood.hs: -------------------------------------------------------------------------------- 1 | module ChangeMood where 2 | 3 | data Mood = Blah | Woot deriving Show 4 | 5 | changeMood :: Mood -> Mood 6 | changeMood Blah = Woot 7 | changeMood Woot = Blah 8 | -------------------------------------------------------------------------------- /ch4/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 4.2 2 | 3 | -- 1. 4 | -- Mood 5 | 6 | -- 2. 7 | -- either Blah or Woot 8 | 9 | -- 3. 10 | -- you can't use a data constructor (Woot) in the type signature. should be 11 | -- changeMood :: Mood -> Mood 12 | 13 | -- 4. 14 | changeMood :: Mood -> Mood 15 | changeMood Blah = Woot 16 | changeMood Woot = Blah 17 | 18 | -- 5. 19 | -- see change_mood.hs 20 | 21 | 22 | -- 4.4 23 | 24 | -- 1. 25 | not True && True 26 | 27 | -- 2. 28 | not (x == 6) 29 | 30 | -- 3. 31 | -- no mistake 32 | 33 | -- 4. 34 | ["Merry"] > ["Happy"] 35 | 36 | -- 5. 37 | -- not sure what the intent of this code was? best guess: 38 | ['1', '2', '3'] ++ "look at me!" 39 | 40 | 41 | -- 4.7 42 | 43 | -- 1. 44 | length :: [a] -> Integer 45 | -- it takes one argument of type List, returning an Integer 46 | 47 | -- 2.a) 48 | -- 5 49 | 50 | -- 2.b) 51 | -- 3 52 | 53 | -- 2.c) 54 | -- 2 55 | 56 | -- 2.d) 57 | -- 5 58 | 59 | -- 3. 60 | -- `length` returns an Int, which isn't compatible w/ `(/)`'s type signature 61 | 62 | -- 4. 63 | 6 `div` length [1, 2, 3] 64 | 65 | -- 5. 66 | -- Bool, True 67 | 68 | -- 6. 69 | -- Bool, False 70 | 71 | -- 7. 72 | -- length allAwesome == 2 73 | -- ^ will work, because Int is an instance of Num (which is what 2 is). result 74 | -- will be True 75 | -- 76 | -- length [1, 'a', 3, 'b'] 77 | -- ^ will not compile because not all elements of the list have the same type 78 | -- 79 | -- length allAwesome + length awesome 80 | -- ^ will work, answer will be 5 81 | -- 82 | -- (8 == 8) && ('b' < 'a') 83 | -- ^ will work since both expressions passed to `(&&)` are Bools. result: False 84 | -- 85 | -- (8 == 8) && 9 86 | -- ^ will not compile since `(&&)` expects Bool arguments 87 | 88 | -- 8. 89 | isPalindrome :: (Eq a) => [a] -> Bool 90 | isPalindrome x = x == reverse x 91 | 92 | -- 9. 93 | myAbs :: Integer -> Integer 94 | myAbs x = if x < 0 then x * (-1) else x 95 | 96 | -- 10. 97 | f :: (a, b) -> (c, d) -> ((b, d), (a, c)) 98 | f x y = ((snd x, snd y), (fst x, fst y)) 99 | 100 | -- Reading syntax 101 | 102 | -- 1. 103 | x = (+) 104 | f xs = w `x` 1 105 | where w = length xs 106 | 107 | -- 2. 108 | (\x -> x) 109 | 110 | -- 3. 111 | (\(x:xs) -> x) 112 | 113 | -- 4. 114 | f (a, b) = a 115 | 116 | -- Match the function names to their types 117 | 118 | -- 1. 119 | -- c) 120 | 121 | -- 2. 122 | -- b) 123 | 124 | -- 3. 125 | -- a) 126 | 127 | -- 4. 128 | -- d) 129 | 130 | -------------------------------------------------------------------------------- /ch5/arith3broken.hs: -------------------------------------------------------------------------------- 1 | module Arith3Broken where 2 | 3 | main :: IO () 4 | main = do 5 | print (1 + 2) 6 | putStrLn "10" 7 | print (negate (-1)) 8 | print ((+) 0 blah) 9 | where blah = negate 1 10 | -------------------------------------------------------------------------------- /ch5/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 5.4 2 | 3 | -- 1.a) 4 | -- c) 5 | 6 | -- 1.b) 7 | -- d) 8 | 9 | -- 1.c) 10 | -- b) 11 | 12 | -- 1.d) 13 | -- a) 14 | 15 | -- 1.e) 16 | -- e) 17 | 18 | 19 | -- 5.5 20 | 21 | -- 1 22 | -- a) 23 | 24 | -- 2. 25 | -- d) 26 | 27 | -- 3. 28 | -- d) 29 | 30 | -- 4. 31 | -- c) 32 | 33 | -- 5. 34 | -- a) 35 | 36 | -- 6. 37 | -- e) 38 | 39 | -- 7. 40 | -- d) 41 | 42 | -- 8. 43 | -- a) 44 | 45 | -- 9. 46 | -- c) 47 | 48 | 49 | -- 5.6 50 | 51 | -- 1. 52 | -- (ok) 53 | 54 | -- 2. 55 | ex2a :: a -> a -> a 56 | ex2a x y = x 57 | 58 | ex2b :: a -> a -> a 59 | ex2b x y = y 60 | 61 | -- 3. 62 | ex3 :: a -> b -> b 63 | ex3 x y = y 64 | -- only one implementation because we have to assume a != b 65 | 66 | 67 | -- 5.7 68 | 69 | -- 1. 70 | myConcat :: [Char] -> [Char] 71 | 72 | -- 2. 73 | myMult :: Fractional a => a -> a 74 | 75 | -- 3. 76 | myTake :: Int -> [Char] 77 | 78 | -- 4. 79 | myCom :: Int -> Bool 80 | 81 | -- 5. 82 | myAlph :: Char -> Bool 83 | 84 | 85 | -- 5.9 86 | 87 | -- Multiple choice 88 | 89 | -- 1. 90 | -- c) 91 | 92 | -- 2. 93 | -- a) 94 | 95 | -- 3. 96 | -- b), but also a) if you consider currying and it returning a function (Int -> a) 97 | 98 | -- 4. 99 | -- c) 100 | 101 | -- Determine the type 102 | 103 | -- 1.a) 104 | 54 :: Num a => a 105 | 106 | -- 1.b) 107 | (0,"doge") :: Num a => (a, [Char]) 108 | 109 | -- 1.c) 110 | (0 :: Integer, "doge") :: (Integer, [Char]) 111 | 112 | -- 1.d) 113 | False :: Bool 114 | 115 | -- 1.e) 116 | 5 :: Int 117 | 118 | -- 1.f) 119 | False :: Bool 120 | 121 | -- 2. 122 | 100 :: Num a => a 123 | 124 | -- 3. 125 | Num a => a -> a 126 | 127 | -- 4. 128 | 0.4 :: Fractional a => a 129 | 130 | -- 5. 131 | "Julie <3 Haskell" :: [Char] 132 | 133 | -- Does it compile? 134 | 135 | -- 1. 136 | bigNum = (^) 5 $ 10 137 | wahoo = bigNum ^ 10 138 | 139 | -- 2. 140 | y = print "woohoo!" 141 | z = x "hello world" 142 | 143 | -- 3. 144 | c = a b 10 145 | d = a c 200 146 | 147 | -- 4. 148 | c = 5 -- does adding an add'tl expression count as fixing? 149 | 150 | -- Type variable or specific type constructor? 151 | 152 | -- 1. 153 | -- (answer provided) 154 | 155 | -- 2. 156 | -- f :: zed -> Zed -> Blah 157 | -- [1] [2] [3] 158 | -- 1 = fully polymorphic 159 | -- 2 = concrete 160 | -- 3 = concrete 161 | 162 | -- 3. 163 | -- f :: Enum b => a -> b -> C 164 | -- [1] [2] [3] 165 | -- 1 = fully polymorphic 166 | -- 2 = constrained polymorphic 167 | -- 3 = concrete 168 | 169 | -- 4. 170 | -- f :: f -> g -> C 171 | -- [1] [2] [3] 172 | -- 1 = fully polymorphic 173 | -- 2 = fully polymorphic 174 | -- 3 = concrete 175 | 176 | -- Write a type signature 177 | 178 | -- 1. 179 | functionH :: [a] -> a 180 | 181 | -- 2. 182 | functionC :: Ord a => a -> a -> Bool 183 | 184 | -- 3. 185 | functionS :: (a, b) -> b 186 | 187 | -- Given a type, write the function 188 | 189 | -- 1. 190 | i x = x 191 | 192 | -- 2. 193 | c x y = x 194 | 195 | -- 3. 196 | -- yes: 197 | c'' x y = x 198 | 199 | -- 4. 200 | c' x y = y 201 | 202 | -- 5. 203 | r xs = reverse xs 204 | 205 | -- 6. 206 | co f g = \x -> f (g x) 207 | -- or 208 | co f g = f . g 209 | 210 | -- 7. 211 | a :: (a -> c) -> a -> a 212 | a f x = x 213 | 214 | -- 8. 215 | a' :: (a -> b) -> a -> b 216 | a' f x = f x 217 | 218 | -- Fix it 219 | 220 | -- 1. 221 | -- see sing.hs 222 | 223 | -- 2. 224 | -- see sing2.hs 225 | 226 | -- Type-Kwon-Do 227 | 228 | -- 1. 229 | h x = g(f(x)) 230 | -- or 231 | h x = g $ f $ x 232 | 233 | -- 2. 234 | e x = w(q(x)) 235 | -- or 236 | e x = w $ q $ x 237 | 238 | -- 3. 239 | xform x = (xz(fst x), yz(snd x)) 240 | 241 | -- 4. 242 | munge f g x = fst(g(f(x))) 243 | -- or 244 | munge f g x = fst $ g $ f $ x 245 | -------------------------------------------------------------------------------- /ch5/sing.hs: -------------------------------------------------------------------------------- 1 | module Sing where 2 | 3 | fstString :: [Char] -> [Char] 4 | fstString x = x ++ " in the rain" 5 | 6 | sndString :: [Char] -> [Char] 7 | sndString x = x ++ " over the rainbow" 8 | 9 | sing = if (x > y) then fstString x else sndString y 10 | where x = "Singin" 11 | y = "Somewhere" 12 | -------------------------------------------------------------------------------- /ch5/sing2.hs: -------------------------------------------------------------------------------- 1 | module Sing where 2 | 3 | fstString :: [Char] -> [Char] 4 | fstString x = x ++ " in the rain" 5 | 6 | sndString :: [Char] -> [Char] 7 | sndString x = x ++ " over the rainbow" 8 | 9 | sing = if (x < y) then fstString x else sndString y 10 | where x = "Singin" 11 | y = "Somewhere" 12 | -------------------------------------------------------------------------------- /ch5/typeInference1.hs: -------------------------------------------------------------------------------- 1 | module TypeInference1 where 2 | 3 | f :: Num a => a -> a -> a 4 | f x y = x + y + 3 5 | -------------------------------------------------------------------------------- /ch5/typeInference2.hs: -------------------------------------------------------------------------------- 1 | module TypeInference2 where 2 | 3 | f x y = x + y + 3 4 | -------------------------------------------------------------------------------- /ch6/.ghci: -------------------------------------------------------------------------------- 1 | :set -Wall 2 | -------------------------------------------------------------------------------- /ch6/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 6.5 2 | 3 | -- Exercises: Eq Instances 4 | 5 | -- 1. 6 | 7 | data TisAnInteger = 8 | TisAn Integer 9 | 10 | instance Eq TisAnInteger where 11 | (==) (TisAn x) (TisAn x') = x == x' 12 | 13 | -- 2. 14 | 15 | data TwoIntegers = 16 | Two Integer Integer 17 | 18 | instance Eq TwoIntegers where 19 | (==) (Two x y) (Two x' y') = (x == x') && (y == y') 20 | 21 | -- 3. 22 | 23 | data StringOrInt = 24 | TisAnInt Int 25 | | TisAString String 26 | 27 | instance Eq StringOrInt where 28 | (==) (TisAnInt x) (TisAnInt x') = x == x' 29 | (==) (TisAString x) (TisAString x') = x == x' 30 | (==) _ _ = False 31 | 32 | -- 4. 33 | 34 | data Pair a = 35 | Pair a a 36 | 37 | instance Eq a => Eq (Pair a) where 38 | (==) (Pair x y) (Pair x' y') = (x == x') && (y == y') 39 | 40 | -- 5. 41 | 42 | data Tuple a b = 43 | Tuple a b 44 | 45 | instance (Eq a, Eq b) => Eq (Tuple a b) where 46 | (==) (Tuple x y) (Tuple x' y') = (x == x') && (y == y') 47 | 48 | -- 6. 49 | 50 | data Which a = 51 | ThisOne a 52 | | ThatOne a 53 | 54 | instance Eq a => Eq (Which a) where 55 | (==) (ThisOne x) (ThisOne x') = x == x' 56 | 57 | -- 7. 58 | 59 | data EitherOr a b = 60 | Hello a 61 | | Goodbye b 62 | 63 | instance (Eq a, Eq b) => Eq (EitherOr a b) where 64 | (==) (Hello x) (Hello x') = x == x' 65 | (==) (Goodbye x) (Goodbye x') = x == x' 66 | (==) _ _ = False 67 | 68 | 69 | -- 6.6 70 | 71 | -- Exercises: Tuple Experiment 72 | 73 | -- I'm guessing `quotRem` combines `quot` and `rem`, combining the results into 74 | -- a single pair. Same with `divMod` but combining `div` and `mod`. REPL 75 | -- experimentation seems to confirm the hypothesis. 76 | 77 | -- Put on your thinking cap 78 | 79 | -- Because Fractional is a subclass of Num, so Num is implicitly required. 80 | 81 | 82 | -- 6.8 83 | 84 | -- Exercises: Will They Work? 85 | 86 | -- 1. 87 | -- will work; returns 5 88 | 89 | -- 2. 90 | -- will work; returns LT 91 | 92 | -- 3. 93 | -- will not work; `compare` expects same types as args, but given [Char] and Bool 94 | 95 | -- 4. 96 | -- will work; returns False 97 | 98 | 99 | -- 6.14 100 | 101 | -- Multiple choice 102 | 103 | -- 1. 104 | -- c) 105 | 106 | -- 2. 107 | -- b) 108 | 109 | -- 3. 110 | -- a) 111 | 112 | -- 4. 113 | -- c) 114 | 115 | -- 5. 116 | -- a) 117 | 118 | -- Does it typecheck? 119 | 120 | -- 1. 121 | -- no, use of putStrLn means Person needs an instance of Show. fix with: 122 | data Person = Person Bool deriving Show 123 | 124 | -- 2. 125 | -- no, use of (==) means Mood needs an Eq instance. fix with: 126 | data Mood = Blah 127 | | Woot deriving (Show, Eq) 128 | 129 | -- 3.a) 130 | -- only Mood types 131 | 132 | -- 3.b) 133 | -- it won't compile, since only Mood input types are acceptable 134 | 135 | -- 3.c) 136 | -- it will err because there is no Ord instance for Mood 137 | 138 | -- 4. 139 | -- I wasn't sure about s1, but apparently yes, data constructors can be 140 | -- partially applied. So it typechecks. 141 | 142 | -- Given a datatype declaration, what can we do? 143 | 144 | -- 1. 145 | -- Won't typecheck. Rocks and Yeah aren't type aliases, they're custom types 146 | -- of their own so you need to use their data constructors. Fix with: 147 | phew = Papu (Rocks "chases") (Yeah True) 148 | 149 | -- 2. 150 | -- Will typecheck 151 | 152 | -- 3. 153 | -- Will typecheck 154 | 155 | -- 4. 156 | -- Won't typecheck. Papu doesn't have an Ord instance. 157 | 158 | 159 | -- Match the types 160 | 161 | -- 1. 162 | -- No, because 1 :: Num a => a, so it is not parametrically polymorphic 163 | 164 | -- 2. 165 | -- No, the maximally polymorphic type of 1.0 is Fractional a => a. 166 | -- Fractional is a subclass of Num, so you can't go up the ladder and make 167 | -- it more general. 168 | 169 | -- 3. 170 | -- Yes, Fractional a => a is maximally polymorphic for 1.0 so that's fine. 171 | 172 | -- 4. 173 | -- Yes, this should work because RealFrac is a subclass of Fractional, so it's 174 | -- okay to constrain the type further. 175 | 176 | -- 5. 177 | -- Yes, you can constrain the identity function. 178 | 179 | -- 6. 180 | -- Yes, you can constrain the identity function. 181 | 182 | -- 7. 183 | -- No, myX is a concrete type (Int), so at best you can do sigmund :: a -> Int 184 | 185 | -- 8. 186 | -- No, same answer as #7. The Num a constraint on the argument is okay but the 187 | -- result must be Int (i.e. sigmund' :: Num a => a -> Int would be okay) 188 | 189 | -- 9. 190 | -- Yes, Int has an Ord instance so that's fine to constrain it 191 | 192 | -- 10. 193 | -- Yes, head :: [a] -> a and sort :: Ord a => [a] -> [a] so 194 | -- young :: Ord a => [a] -> [a] is the maximally polymorphic type 195 | 196 | -- 11. 197 | -- No, mySort is constrained to concrete types ([Char] -> [Char]) 198 | 199 | 200 | -- Type-Kwon-Do 201 | 202 | -- 1. 203 | chk :: Eq b => (a -> b) -> a -> b -> Bool 204 | chk f x y = f(x) == y 205 | 206 | -- 2. 207 | arith :: Num b => (a -> b) -> Integer -> a -> b 208 | arith f x y = fromInteger(x) + f(y) 209 | -------------------------------------------------------------------------------- /ch7/arith2.hs: -------------------------------------------------------------------------------- 1 | module Arith2 where 2 | 3 | add :: Int -> Int -> Int 4 | add x y = x + y 5 | 6 | addPF :: Int -> Int -> Int 7 | addPF = (+) 8 | 9 | addOne :: Int -> Int 10 | addOne = \x -> x + 1 11 | 12 | addOnePF :: Int -> Int 13 | addOnePF = (+1) 14 | 15 | main :: IO () 16 | main = do 17 | print (0 :: Int) -- 0 18 | print (add 1 0) -- 1 19 | print (addOne 0) -- 1 20 | print (addOnePF 0) -- 1 21 | print ((addOne . addOne) 0) -- 2 22 | print ((addOnePF . addOne) 0) -- 2 23 | print ((addOne . addOnePF) 0) -- 2 24 | print ((addOnePF . addOnePF) 0) -- 2 25 | print (negate (addOne 0)) -- -1 26 | print ((negate . addOne) 0) -- -1 27 | print ((addOne . addOne . addOne . negate . addOne) 0) -- 2 28 | -------------------------------------------------------------------------------- /ch7/arith4.hs: -------------------------------------------------------------------------------- 1 | module Arith4 where 2 | 3 | -- id :: a -> a 4 | -- id x = x 5 | 6 | roundTrip :: (Show a, Read a) => a -> a 7 | roundTrip a = read (show a) 8 | 9 | main = do 10 | print (roundTrip 4) 11 | print (id 4) 12 | -------------------------------------------------------------------------------- /ch7/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 7.4 2 | 3 | -- Exercises: Grab Bag 4 | 5 | -- 1. 6 | -- they are all equivalent thanks to Haskell's automatic currying! 7 | 8 | -- 2. 9 | -- d) 10 | 11 | -- 3.a) 12 | addOneIfOdd' n = case odd n of 13 | True -> f n 14 | False -> n 15 | where f = \n -> n + 1 16 | 17 | -- 3.b) 18 | addFive' = \x -> \y -> (if x > y then y else x) + 5 19 | 20 | -- 3.c) 21 | mflip' f x y = f y x 22 | 23 | 24 | -- 7.4 25 | 26 | -- Exercises: Variety Pack 27 | 28 | -- 1.a) 29 | k :: (a, b) -> a 30 | 31 | -- 1.b) 32 | k2 :: [Char] 33 | -- no, k1 and k3 can be reduced to Num a => a 34 | 35 | -- 1.c) 36 | -- k1 and k3 37 | 38 | -- 2. 39 | f :: (a, b, c) -> (d, e, f) -> ((a, d), (c, f)) 40 | f (a, b, c) (d, e, f) = ((a, d), (c, f)) 41 | 42 | 43 | -- 7.5 44 | 45 | -- Exercises: Case Practice 46 | 47 | -- 1. 48 | functionC' x y = 49 | case x > y of 50 | True -> x 51 | False -> y 52 | 53 | -- 2. 54 | ifEvenAdd2' n = 55 | case even n of 56 | True -> (n + 2) 57 | False -> n 58 | 59 | -- 3. 60 | nums x = 61 | case compare x 0 of 62 | LT -> -1 63 | GT -> 1 64 | EQ -> 0 65 | 66 | 67 | -- 7.6 68 | 69 | -- Exercises: Artful Dodgy 70 | 71 | -- 1. 72 | dodgy :: Num a => a -> a -> a 73 | oneIsOne :: Num a => a -> a 74 | oneIsTwo :: Num a => a -> a 75 | -- it evaluates to 1 76 | 77 | -- 2. 78 | -- 11 79 | 80 | -- 3. 81 | -- 22 82 | 83 | -- 4. 84 | -- 21 85 | 86 | -- 5. 87 | -- 12 88 | 89 | -- 6. 90 | -- 11 91 | 92 | -- 7. 93 | -- 21 94 | 95 | -- 8. 96 | -- 21 97 | 98 | -- 9. 99 | -- 22 100 | 101 | -- 10. 102 | -- 31 103 | 104 | -- 11. 105 | -- 23 106 | 107 | 108 | -- 7.7 109 | 110 | -- Exercises: Guard Duty 111 | 112 | -- 1. 113 | -- the otherwise clause matches anything, so if you put it first, it always 114 | -- matches and in this case avgGrade always returns 'F' 115 | 116 | -- 2. 117 | -- it still typechecks, but returns incorrect result since the 'C' clause 118 | -- matches earlier than it should, and now 'A' and 'B' will never match. 119 | 120 | -- 3. 121 | -- b) 122 | 123 | -- 4. 124 | -- Eq a => [a] 125 | 126 | -- 5. 127 | pal :: Eq a => [a] -> Bool 128 | 129 | -- 6. 130 | -- c) 131 | 132 | -- 7. 133 | -- (Num a, Ord a) => a 134 | 135 | -- 8. 136 | numbers :: (Num a, Ord a, Num b) => a -> b 137 | 138 | 139 | -- 7.11 140 | 141 | -- Multiple choice 142 | 143 | -- 1. 144 | -- d) 145 | 146 | -- 2. 147 | -- b) 148 | 149 | -- 3. 150 | -- d) 151 | 152 | -- 4. 153 | -- b) 154 | 155 | -- 5. 156 | -- a) 157 | 158 | -- Let’s write code 159 | 160 | -- 1.a) 161 | tensDigit :: Integral a => a -> a 162 | tensDigit x = d 163 | where (xLast, _) = x `divMod` 10 164 | (_, d) = xLast `divMod` 10 165 | 166 | -- 1.b) 167 | -- Yes 168 | 169 | -- 1.c) 170 | hunsD :: Integral a => a -> a 171 | hunsD x = d 172 | where d = (x `div` 100) `mod` 10 173 | -- or, pointfree: 174 | hunsD = (`mod` 10) . (`div` 100) 175 | 176 | -- 2. 177 | foldBool :: a -> a -> Bool -> a 178 | -- case: 179 | foldBool x y z = 180 | case z of 181 | True -> x 182 | False -> y 183 | -- guard: 184 | foldBool x y z 185 | | z == True = x 186 | | otherwise = y 187 | 188 | -- 3. 189 | g :: (a -> b) -> (a, c) -> (b, c) 190 | g f (a, c) = (f(a), c) 191 | 192 | -- 4. 193 | -- (okay) 194 | 195 | -- 5. 196 | roundTrip :: (Show a, Read a) => a -> a 197 | roundTrip = read . show 198 | 199 | -- 6. 200 | -- I think you just need to use :: when calling the function (to be explicit): 201 | -- roundTrip 5 :: Int 202 | -- roundTrip 5 :: Integer 203 | -- etc. 204 | -------------------------------------------------------------------------------- /ch7/greetIfCool3.hs: -------------------------------------------------------------------------------- 1 | module GreetIfCool3 where 2 | 3 | greetIfCool :: String -> IO () 4 | greetIfCool coolness = 5 | case cool of 6 | True -> putStrLn "eyyyyy. What's shakin'?" 7 | False -> putStrLn "pshhhh." 8 | where cool = coolness == "downright frosty yo" 9 | -------------------------------------------------------------------------------- /ch7/matchingTuples1.hs: -------------------------------------------------------------------------------- 1 | -- matchingTuples1.hs 2 | module TupleFunctions where 3 | 4 | -- These have to be the same type because 5 | -- (+) is a -> a -> a 6 | addEmUp2 :: Num a => (a, a) -> a 7 | addEmUp2 (x, y) = x + y 8 | 9 | -- addEmUp2 could also be written like so 10 | addEmUp2Alt :: Num a => (a, a) -> a 11 | addEmUp2Alt tup = (fst tup) + (snd tup) 12 | 13 | fst3 :: (a, b, c) -> a 14 | fst3 (x, _, _) = x 15 | 16 | third3 :: (a, b, c) -> c 17 | third3 (_, _, x) = x 18 | -------------------------------------------------------------------------------- /ch7/registeredUser1.hs: -------------------------------------------------------------------------------- 1 | module RegisteredUser where 2 | 3 | newtype Username = Username String 4 | newtype AccountNumber = AccountNumber Integer 5 | 6 | data User = UnregisteredUser 7 | | RegisteredUser Username AccountNumber 8 | -------------------------------------------------------------------------------- /ch7/registeredUser2.hs: -------------------------------------------------------------------------------- 1 | module RegisteredUser where 2 | 3 | newtype Username = Username String 4 | newtype AccountNumber = AccountNumber Integer 5 | 6 | data User = UnregisteredUser 7 | | RegisteredUser Username AccountNumber 8 | 9 | printUser :: User -> IO () 10 | printUser UnregisteredUser = putStrLn "UnregisteredUser" 11 | printUser (RegisteredUser (Username name) 12 | (AccountNumber acctNum)) 13 | = putStrLn $ name ++ " " ++ show acctNum 14 | -------------------------------------------------------------------------------- /ch8/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 8.2 2 | 3 | -- Intermission: Exercise 4 | 5 | -- applyTimes 5 (+1) 5 6 | -- = (+1) (applyTimes 4 (+1) 5) 7 | -- = (+1) ((+1) (applyTimes 3 (+1) 5)) 8 | -- = (+1) ((+1) ((+1) (applyTimes 2 (+1) 5))) 9 | -- = (+1) ((+1) ((+1) ((+1) (applyTimes 1 (+1) 5)))) 10 | -- = (+1) ((+1) ((+1) ((+1) ((+1) (5))))) 11 | -- = 10 12 | 13 | 14 | -- 8.6 15 | 16 | -- Review of types 17 | 18 | -- 1. 19 | -- d) 20 | 21 | -- 2. 22 | -- b) 23 | 24 | -- 3. 25 | -- d) 26 | 27 | -- 4. 28 | -- b) 29 | 30 | -- Reviewing currying 31 | 32 | flippy :: String -> String -> String 33 | appedCatty :: String -> String 34 | frappe :: String -> String 35 | 36 | -- 1. 37 | -- "woops mrow woohoo!" 38 | 39 | -- 2. 40 | -- "1 mrow haha" 41 | 42 | -- 3. 43 | -- "woops mrow 2 mrow haha" 44 | 45 | -- 4. 46 | -- "woops mrow blue mrow haha" 47 | 48 | -- 5. 49 | -- "pink mrow haha mrow green mrow woops mrow blue" 50 | 51 | -- 6. 52 | -- "are mrow Pugs mrow awesome" 53 | 54 | -- Recursion 55 | 56 | -- 1. 57 | -- dividedBy 15 2 58 | -- = go 15 2 0 59 | -- = go 13 2 1 60 | -- = go 11 2 2 61 | -- = go 9 2 3 62 | -- = go 7 2 4 63 | -- = go 5 2 5 64 | -- = go 3 2 6 65 | -- = go 1 2 7 66 | -- = (7, 1) 67 | 68 | -- 2. 69 | sumUpTo :: (Eq a, Num a) => a -> a 70 | sumUpTo max = go max 0 0 where 71 | go m carry i 72 | | i == (m + 1) = carry 73 | | otherwise = go m (carry + i) (i + 1) 74 | 75 | -- 3. 76 | mult :: (Integral a) => a -> a -> a 77 | mult x y = go x y 0 where 78 | go x' remainingCount accum 79 | | remainingCount == 0 = accum 80 | | otherwise = go x' (remainingCount - 1) (accum + x') 81 | 82 | -- Fixing dividedBy 83 | 84 | data DividedResult = 85 | Result Integer 86 | | DividedByZero 87 | deriving Show 88 | 89 | xor :: Bool -> Bool -> Bool 90 | xor True True = False 91 | xor True False = True 92 | xor False True = True 93 | xor False False = False 94 | 95 | dividedBy' :: Integer -> Integer -> DividedResult 96 | dividedBy' num denom 97 | | denom == 0 = DividedByZero 98 | | otherwise = go num' denom' 0 where 99 | num' = abs(num) 100 | denom' = abs(denom) 101 | negativeResult = (num < 0) `xor` (denom < 0) 102 | go n d count 103 | | n < d = Result (if negativeResult then (-count) else count) 104 | | otherwise = go (n - d) d (count + 1) 105 | 106 | 107 | -- McCarthy 91 function 108 | 109 | mc91 :: (Num a, Ord a) => a -> a 110 | mc91 x = if (x > 100) then (x - 10) else mc91(mc91(x + 11)) 111 | 112 | -- or, with guards: 113 | 114 | mc91 x 115 | | x > 100 = x - 10 116 | | otherwise = (mc91 . mc91 . (+ 11)) x 117 | 118 | -- Numbers into words 119 | -- see wordnumber.hs 120 | -------------------------------------------------------------------------------- /ch8/wordnumber.hs: -------------------------------------------------------------------------------- 1 | module WordNumber where 2 | 3 | import Data.List (intersperse) 4 | 5 | digitToWord :: Int -> String 6 | digitToWord n = case n of 7 | 1 -> "one" 8 | 2 -> "two" 9 | 3 -> "three" 10 | 4 -> "four" 11 | 5 -> "five" 12 | 6 -> "six" 13 | 7 -> "seven" 14 | 8 -> "eight" 15 | _ -> "nine" 16 | 17 | digits :: Int -> [Int] 18 | digits n 19 | | (n < 10) = [n] 20 | | otherwise = digits(n `div` 10) ++ [n `mod` 10] 21 | 22 | wordNumber :: Int -> String 23 | wordNumber = concat . (intersperse "-") . (map digitToWord) . digits 24 | -------------------------------------------------------------------------------- /ch9/cipher.hs: -------------------------------------------------------------------------------- 1 | module Cipher where 2 | import Data.Char 3 | import Data.List 4 | 5 | caesarDigits = ['a'..'z'] 6 | 7 | caesarChar :: Int -> Char 8 | caesarChar x = caesarDigits !! (x `mod` (length caesarDigits)) 9 | 10 | caesarChars :: Int -> String 11 | caesarChars x 12 | | i < 0 = take i caesarDigits ++ drop i caesarDigits 13 | | otherwise = drop i caesarDigits ++ take i caesarDigits 14 | where 15 | i = x `mod` (length caesarDigits) 16 | 17 | caesarCharCipher :: Char -> Int -> Char 18 | caesarCharCipher x y = case elemIndex x caesarDigits of 19 | Just i -> (caesarChars y) !! i 20 | Nothing -> x 21 | 22 | caesarCharDecipher :: Char -> Int -> Char 23 | caesarCharDecipher x y = case elemIndex x (caesarChars y) of 24 | Just i -> caesarDigits !! i 25 | Nothing -> x 26 | 27 | caesar :: String -> Int -> String 28 | caesar [] _ = [] 29 | caesar (x:xs) i = (caesarCharCipher x i) : (caesar xs i) 30 | 31 | unCaesar :: String -> Int -> String 32 | unCaesar [] _ = [] 33 | unCaesar (x:xs) i = (caesarCharDecipher x i) : (unCaesar xs i) 34 | -------------------------------------------------------------------------------- /ch9/exercises.hs: -------------------------------------------------------------------------------- 1 | -- 9.3 2 | 3 | safeHead :: [a] -> Maybe a 4 | safeHead [] = Nothing 5 | safeHead (x:_) = Just x 6 | 7 | -- 9.5 8 | 9 | 10 | -- Exercise: EnumFromTo 11 | 12 | eftBool :: Bool -> Bool -> [Bool] 13 | eftBool x y 14 | | x > y = [] 15 | | x == y = [x] 16 | | otherwise = x : (eftBool (succ x) y) 17 | 18 | eftOrd :: Ordering -> Ordering -> [Ordering] 19 | eftOrd x y 20 | | x > y = [] 21 | | x == y = [x] 22 | | otherwise = x : (eftOrd (succ x) y) 23 | 24 | eftInt :: Int -> Int -> [Int] 25 | eftInt x y 26 | | x > y = [] 27 | | x == y = [x] 28 | | otherwise = x : (eftInt (succ x) y) 29 | 30 | eftChar :: Char -> Char -> [Char] 31 | eftChar x y 32 | | x > y = [] 33 | | x == y = [x] 34 | | otherwise = x : (eftChar (succ x) y) 35 | 36 | 37 | -- 9.6 38 | 39 | -- Q: In the final example above, why does it only return a single a? 40 | -- A: It actually returns a list, ['a'], but that is equivalent to "a" 41 | 42 | -- Exercises: Thy Fearful Symmetry 43 | 44 | -- 1) 45 | 46 | myWords :: String -> [String] 47 | myWords "" = [] 48 | myWords x 49 | | dropWhile (/=' ') x == "" = [x] 50 | | otherwise = (takeWhile (/=' ') x) : myWords(dropWhile (==' ') (dropWhile (/=' ') x)) 51 | 52 | -- 2) 53 | 54 | myLines :: String -> [String] 55 | myLines "" = [] 56 | myLines x 57 | | dropWhile (/='\n') x == "" = [x] 58 | | otherwise = (takeWhile (/='\n') x) : myLines(dropWhile (=='\n') (dropWhile (/='\n') x)) 59 | 60 | -- 3) 61 | 62 | mySplit :: Char -> String -> [String] 63 | mySplit _ "" = [] 64 | mySplit c str 65 | | dropWhile (/=c) str == "" = [str] 66 | | otherwise = (takeWhile (/=c) str) : (mySplit c (dropWhile (==c) (dropWhile (/=c) str))) 67 | 68 | myWords' :: String -> [String] 69 | myWords' x = mySplit ' ' x 70 | 71 | myLines' :: String -> [String] 72 | myLines' x = mySplit '\n' x 73 | 74 | 75 | -- 9.7 76 | 77 | -- Exercises: Comprehend Thy Lists 78 | 79 | -- It will output all even mySqr numbers: 80 | -- Prelude> [x | x <- mySqr, rem x 2 == 0] 81 | -- [4,16,36,64,100] 82 | 83 | -- Prelude> :{ 84 | -- Prelude| [(x, y) | x <- mySqr, 85 | -- Prelude| y <- mySqr, 86 | -- Prelude| x < 50, y > 50] 87 | -- Prelude| :} 88 | -- [(1,64),(1,81),(1,100),(4,64),(4,81),(4,100),(9,64),(9,81),(9,100),(16,64),(16,81),(16,100),(25,64),(25,81),(25,100),(36,64),(36,81),(36,100),(49,64),(49,81),(49,100)] 89 | 90 | -- Prelude> :{ 91 | -- Prelude| take 5 [ (x, y) | x <- mySqr, 92 | -- Prelude| y <- mySqr, 93 | -- Prelude| x < 50, y > 50] 94 | -- Prelude| :} 95 | -- [(1,64),(1,81),(1,100),(4,64),(4,81)] 96 | 97 | -- List comprehensions with Strings 98 | 99 | -- Q: Given the above, what do you think this function would do: 100 | -- Prelude> let myString xs = [x | x <- xs, elem x "aeiou"] 101 | -- A: It returns only the lowercase vowels in the string it's applied to 102 | 103 | -- Exercises: Square Cube 104 | 105 | -- 1) 106 | [(x,y) | x <- mySqr, y <- myCube] 107 | 108 | -- 2) 109 | [(x,y) | x <- mySqr, y <- myCube, x < 50, y < 50] 110 | 111 | -- 3) 112 | length [(x,y) | x <- mySqr, y <- myCube, x < 50, y < 50] 113 | 114 | 115 | -- 9.8 116 | 117 | -- Exercises: Bottom Madness 118 | 119 | -- Will it blow up? 120 | 121 | -- 1) Returns a value (it only blows up if you try to print it) 122 | 123 | -- 2) Returns a value: [1] 124 | 125 | -- 3) Blows up since sum forces values 126 | 127 | -- 4) Returns a value since length only walks the spine 128 | 129 | -- 5) Blows up since length forces evaluation of ++, which will error out due 130 | -- to undefined not being a list type 131 | 132 | -- 6) Returns a value ([2]) since `take 1 $ filter` stops after finding the 133 | -- first match, and 2 occurs before undefined in the list 134 | 135 | -- 7) Errors out since no even values occur before undefined in the list 136 | 137 | -- 8) Returns a value ([1]) for the same reason as #6 138 | 139 | -- 9) Returns a value ([1, 3]) 140 | 141 | -- 10) Errors out since `take 3` will be looking for one more match, causing 142 | -- undefined to get evaluated 143 | 144 | -- Intermission: Is it in normal form? 145 | 146 | -- 1) NF 147 | 148 | -- 2) WHNF 149 | 150 | -- 3) WHNF 151 | 152 | -- 4) WHNF 153 | 154 | -- 5) WHNF 155 | 156 | -- 6) Neither 157 | 158 | -- 7) WHNF 159 | 160 | 161 | -- 9.9 162 | 163 | -- Exercises: More Bottoms 164 | 165 | -- 1) Bottom 166 | 167 | -- 2) [2] 168 | 169 | -- 3) Bottom 170 | 171 | -- 4) The inner lambda returns True or False if the given Char is in the list "aeiou". 172 | -- Applying it with `map` to a String gives you a list of Bool corresponding to 173 | -- whether each Char in the String is a vowel ("aeiou") or not 174 | -- Its type is: itIsMystery :: String -> [Bool] 175 | 176 | -- 5a) 177 | -- [1, 4, 9, 16, 25, 36, 49, 64, 81, 100] 178 | 179 | -- 5b) 180 | -- [1, 10, 20] 181 | 182 | -- 5c) 183 | -- [15, 15, 15] 184 | 185 | -- 6) 186 | import Data.Bool 187 | map (\x -> bool x (-x) (x == 3)) [1..10] 188 | 189 | 190 | -- 9.10 191 | 192 | -- 1) 193 | filter (\x -> (rem x 3) == 0) [1..30] 194 | -- or 195 | [x | x <- [1..30], (rem x 3) == 0] 196 | 197 | -- 2) 198 | length $ filter (\x -> (rem x 3) == 0) [1..30] 199 | 200 | -- 3) 201 | myFilter :: String -> [String] 202 | myFilter str = filter (\x -> not (elem x ["the", "a", "an"])) (words str) 203 | 204 | 205 | -- 9.11 206 | 207 | -- 1) 208 | zip' :: [a] -> [b] -> [(a, b)] 209 | zip' _ [] = [] 210 | zip' [] _ = [] 211 | zip' (x:xs) (y:ys) = (x,y) : zip xs ys 212 | 213 | -- 2) 214 | zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c] 215 | zipWith' _ _ [] = [] 216 | zipWith' _ [] _ = [] 217 | zipWith' f (x:xs) (y:ys) = f x y : zipWith' f xs ys 218 | 219 | -- 3) 220 | zip'' :: [a] -> [b] -> [(a, b)] 221 | zip'' = zipWith' (,) 222 | 223 | 224 | -- 9.12 225 | 226 | -- Data.Char 227 | 228 | -- 1) 229 | isUpper :: Char -> Bool 230 | toUpper :: Char -> Char 231 | 232 | -- 2) 233 | import Data.Char 234 | onlyUpper :: String -> String 235 | onlyUpper str = filter isUpper str 236 | 237 | -- 3) 238 | capitalize :: String -> String 239 | capitalize "" = "" 240 | capitalize (x:xs) = (toUpper x) : xs 241 | 242 | -- 4) 243 | allCaps :: String -> String 244 | allCaps "" = "" 245 | allCaps (x:xs) = (toUpper x) : allCaps xs 246 | 247 | -- although a simpler version using HOFs would just be: 248 | allCaps = map toUpper 249 | 250 | -- 5) 251 | firstLetterUpper :: String -> Char 252 | firstLetterUpper str = toUpper (head str) 253 | 254 | -- 6) 255 | firstLetterUpper' :: String -> Char 256 | firstLetterUpper' str = (toUpper . head) str 257 | 258 | firstLetterUpper'' :: String -> Char 259 | firstLetterUpper'' = toUpper . head 260 | 261 | -- Ciphers 262 | 263 | -- See cipher.hs 264 | 265 | -- Writing your own standard functions 266 | 267 | -- 1) 268 | myOr :: [Bool] -> Bool 269 | myOr [] = False 270 | myOr (x:xs) = x || myOr xs 271 | 272 | -- 2) 273 | myAny :: (a -> Bool) -> [a] -> Bool 274 | myAny _ [] = False 275 | myAny f (x:xs) = f x || myAny f xs 276 | 277 | -- 3) 278 | myElem :: Eq a => a -> [a] -> Bool 279 | myElem _ [] = False 280 | myElem x (y:ys) = x == y || myElem x ys 281 | 282 | myElem' :: Eq a => a -> [a] -> Bool 283 | myElem' x ys = any (==x) ys 284 | 285 | -- 4) 286 | myReverse :: [a] -> [a] 287 | myReverse [] = [] 288 | myReverse (x:xs) = (myReverse xs) ++ [x] 289 | 290 | -- 5) 291 | squish :: [[a]] -> [a] 292 | squish [] = [] 293 | squish (x:xs) = x ++ squish xs 294 | 295 | -- 6) 296 | squishMap :: (a -> [b]) -> [a] -> [b] 297 | squishMap _ [] = [] 298 | squishMap f (x:xs) = (f x) ++ (squishMap f xs) 299 | 300 | -- 7) 301 | squishAgain :: [[a]] -> [a] 302 | squishAgain x = squishMap (\x -> x) x 303 | 304 | -- 8) 305 | myMaximumBy :: (a -> a -> Ordering) -> [a] -> a 306 | myMaximumBy _ (x:[]) = x 307 | myMaximumBy f (x:xs) = if (f x (myMaximumBy f xs)) == GT then x else (myMaximumBy f xs) 308 | 309 | -- 9) 310 | myMinimumBy :: (a -> a -> Ordering) -> [a] -> a 311 | myMinimumBy _ (x:[]) = x 312 | myMinimumBy f (x:xs) = if (f x (myMinimumBy f xs)) == LT then x else (myMinimumBy f xs) 313 | 314 | myMaximum :: (Ord a) => [a] -> a 315 | myMaximum xs = myMaximumBy compare xs 316 | 317 | myMinimum :: (Ord a) => [a] -> a 318 | myMinimum xs = myMinimumBy compare xs 319 | --------------------------------------------------------------------------------