├── .gitignore ├── README.md ├── ch10 ├── intermission.hs └── warmup.hs ├── ch11 ├── AsPatterns.hs ├── BinaryTreeFold.hs ├── BinaryTreeList.hs ├── BinaryTreeMap.hs ├── Cipher.hs ├── HuttonsRazor.hs ├── LanguageExercises.hs ├── Phone.hs ├── chapterExercises.hs ├── exercises.hs ├── intermission.hs └── jammin.hs ├── ch12 ├── BinaryTree.hs ├── ChapterExercises.hs ├── NaturalNumbers.hs ├── SmallEitherLib.hs ├── SmallMaybeLib.hs └── Unfolds.hs ├── ch13 ├── Cipher │ ├── Cipher.cabal │ ├── LICENSE │ ├── Setup.hs │ ├── app │ │ └── Main.hs │ ├── src │ │ ├── Cipher.hs │ │ └── Lib.hs │ ├── stack.yaml │ └── test │ │ └── Spec.hs ├── hangman │ ├── LICENSE │ ├── Setup.hs │ ├── data │ │ └── .gitignore │ ├── 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 ├── intermission.hs ├── makePerson.hs └── palindrome.hs ├── ch14 ├── Addition │ ├── Addition.cabal │ ├── Addition.hs │ ├── LICENSE │ └── stack.yaml ├── Arbitrary.hs ├── ArithmeticTests │ ├── LICENSE │ ├── Setup.hs │ ├── arithmetic.cabal │ ├── src │ │ └── Arithmetic.hs │ ├── stack.yaml │ └── tests │ │ └── ArithmeticTests.hs ├── Cipher │ ├── Cipher.cabal │ ├── LICENSE │ ├── Setup.hs │ ├── app │ │ └── Main.hs │ ├── src │ │ └── Cipher.hs │ ├── stack.yaml │ └── tests │ │ └── CipherTests.hs ├── CoArbitrary.hs ├── WordNumber │ ├── LICENSE │ ├── Setup.hs │ ├── WordNumber.cabal │ ├── src │ │ └── WordNumber.hs │ ├── stack.yaml │ └── tests │ │ └── WordNumberTest.hs ├── hangman │ ├── LICENSE │ ├── Setup.hs │ ├── data │ │ └── .gitignore │ ├── hangman.cabal │ ├── src │ │ ├── Hangman.hs │ │ └── Main.hs │ ├── stack.yaml │ └── tests │ │ └── HangmanTests.hs ├── morse │ ├── LICENSE │ ├── Setup.hs │ ├── morse.cabal │ ├── src │ │ ├── Main.hs │ │ └── Morse.hs │ ├── stack.yaml │ └── tests │ │ └── tests.hs └── randomGenerator.hs ├── ch15 ├── First.hs ├── MadLibbin.hs ├── Optional.hs ├── chapterExercises │ ├── Monoid.hs │ └── SemiGroup.hs └── orphan-instance │ ├── Listy.hs │ └── ListyInstances.hs ├── ch16 ├── chapterExercises.hs └── exercises.hs ├── ch17 ├── ChapterExercises.hs ├── Constant.hs ├── Identity.hs ├── List.hs ├── LookUps.hs ├── Validation.hs ├── VowelsStops.hs └── ZipList.hs ├── ch18 ├── ChapterExercises.hs ├── Either.hs └── MonadFunctorFunctions.hs ├── ch19 └── shawty-prime │ ├── LICENSE │ ├── Setup.hs │ ├── app │ └── Main.hs │ ├── shawty.cabal │ └── stack.yaml ├── ch20 ├── ChapterExercises.hs └── LibraryFunctions.hs ├── ch21 └── ChapterExercises.hs ├── ch22 ├── ShortExercise.hs └── WarmUp.hs ├── ch23 ├── ChapterExercises.hs ├── FizzBuzz.hs ├── Moi.hs └── ThrowDown.hs ├── ch3 └── exc03.hs ├── ch4 ├── exc04.hs └── intermission04.hs ├── ch5 ├── arith3broken.hs ├── exc05.hs ├── fixit.hs └── typekwondo.hs ├── ch6 ├── DoesItTypecheck.hs ├── GivenDeclaration.hs ├── MatchTheTypes.hs ├── MultipleChoice.txt ├── TypeKwonDo.hs └── intermission.hs ├── ch7 ├── arith4.hs ├── intermission.hs ├── lets_write_code.hs └── multiple_choice.hs ├── ch8 ├── currying.hs ├── intermission.hs ├── multiplechoice.txt ├── numberintowords.hs └── recursion.hs └── ch9 ├── Cipher.hs ├── PoemLines.hs ├── chapterexc.hs ├── exercise.hs └── intermission.hs /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | # Created by https://www.gitignore.io/api/haskell 3 | 4 | ### Haskell ### 5 | dist 6 | cabal-dev 7 | *.o 8 | *.hi 9 | *.chi 10 | *.chs.h 11 | *.dyn_o 12 | *.dyn_hi 13 | .hpc 14 | .hsenv 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | *.prof 18 | *.aux 19 | *.hp 20 | .stack-work/ 21 | 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # HaskellBook 2 | 3 | My solutions to the exercises from Chris Allen's "Haskell Programming From First Principles". I put them here only as a means of comparing your own solutions to gain some insights. I suggest you only consult this after finishing the exercises yourself. Suggestions, bugs and potential improvements are more then welcome (opening an issue is probably the easiest). 4 | Copyright 2016 Dorus Leliveld 5 | 6 | Licensed under the "THE BEER-WARE LICENSE" (Revision 42): 7 | Dorus Leliveld wrote this file. As long as you retain this notice you 8 | can do whatever you want with this stuff. If we meet some day, and you think 9 | this stuff is worth it, you can buy me a beer or coffee in return 10 | -------------------------------------------------------------------------------- /ch10/intermission.hs: -------------------------------------------------------------------------------- 1 | import Data.Time 2 | import Data.Scientific 3 | -- 1 b c 4 | -- 2 ( 3 * ( 2 * ( 1 * 1 ))) 5 | -- 3 c 6 | -- 4 a 7 | -- 5 8 | a = foldr (++) "" ["woot", "WOOT", "woot"] 9 | b = foldr max ' ' "fear is the little death" 10 | c = foldr (&&) True [False, True] 11 | d = foldr (||) False [False, True] 12 | e = foldr ((++) . show ) "" [1..5] 13 | f = foldl const 'a' [1..5] 14 | g = foldr (flip const) 0 "tacos" 15 | h = foldl const 0 "burritos" 16 | i = foldr (flip const) 'z' [1..5] 17 | 18 | 19 | data DatabaseItem = DbString String 20 | | DbNumber Integer 21 | | DbDate UTCTime 22 | deriving (Eq, Ord, Show) 23 | 24 | theDatabase :: [DatabaseItem] 25 | theDatabase = 26 | [ DbDate (UTCTime 27 | (fromGregorian 1911 5 1) 28 | (secondsToDiffTime 34123)) 29 | , DbString "Hello world!" 30 | , DbDate (UTCTime 31 | (fromGregorian 1921 5 1) 32 | (secondsToDiffTime 34123)) 33 | ] 34 | 35 | filterDbDate :: [DatabaseItem] -> [UTCTime] 36 | filterDbDate = foldr ifTimeAppend [] 37 | where 38 | ifTimeAppend (DbDate time) acc = time : acc 39 | ifTimeAppend _ acc = acc 40 | 41 | filterDbNumber :: [DatabaseItem] -> [Integer] 42 | filterDbNumber = foldr ifNumAppend [] 43 | where 44 | ifNumAppend (DbNumber x) acc = x : acc 45 | ifNumAppend _ acc = acc 46 | 47 | mostRecent :: [DatabaseItem] -> UTCTime 48 | mostRecent = maximum . filterDbDate 49 | 50 | sumDb :: [DatabaseItem] -> Integer 51 | sumDb = sum . filterDbNumber 52 | 53 | avgDb :: [DatabaseItem] -> Double 54 | avgDb xs = fromIntegral (sum numbers) / len 55 | where numbers = filterDbNumber xs 56 | len = fromIntegral $ length numbers 57 | 58 | fibs :: [Integer] 59 | fibs = 1 : scanl (+) 1 fibs 60 | 61 | fibsTakeTwe = take 20 fibs 62 | 63 | fibsSmallHun = takeWhile (<100) fibs 64 | 65 | fact = scanl1 (*) [1..] 66 | -------------------------------------------------------------------------------- /ch10/warmup.hs: -------------------------------------------------------------------------------- 1 | stops = "pbtdkg" 2 | vowels = "aeiou" 3 | 4 | 5 | svs = [(a, b, c) | a <- stops, b <- vowels, c <- stops, a == 'p'] 6 | 7 | 8 | seekritFunc :: String -> Double 9 | seekritFunc x = fromIntegral (sum (map length (words x))) / fromIntegral (length (words x)) 10 | 11 | myOr :: [Bool] -> Bool 12 | myOr = foldr (||) False 13 | 14 | myAny :: (a -> Bool) -> [a] -> Bool 15 | myAny f = foldr ((||) . f) False 16 | 17 | myElem :: Eq a => a -> [a] -> Bool 18 | myElem x = foldr ((||) . (==) x) False 19 | 20 | myReverse :: [a] -> [a] 21 | myReverse = foldl (flip (:)) [] 22 | 23 | myMap :: (a -> b) -> [a] -> [b] 24 | myMap f = foldr ((:) . f) [] 25 | 26 | myFilter :: (a -> Bool) -> [a] -> [a] 27 | myFilter f = foldr (\ x acc -> if f x then x : acc else acc) [] 28 | 29 | squish :: [[a]] -> [a] 30 | squish = foldr (++) [] 31 | 32 | squishMap :: (a -> [b]) -> [a] -> [b] 33 | squishMap f = foldr ((++) . f) [] 34 | 35 | squishAgain :: [[a]] -> [a] 36 | squishAgain = squishMap id 37 | 38 | myMaximumBy :: (a -> a -> Ordering) -> [a] -> a 39 | myMaximumBy cmp = foldr1 (\ x acc -> if acc `cmp` x == GT then acc else x) 40 | 41 | myMinimumBy :: (a -> a -> Ordering) -> [a] -> a 42 | myMinimumBy cmp = foldr1 (\ x acc -> if acc `cmp` x == LT then acc else x) 43 | -------------------------------------------------------------------------------- /ch11/AsPatterns.hs: -------------------------------------------------------------------------------- 1 | module AsPatterns where 2 | 3 | -- elementsOf 4 | -- isSubsequenceOf :: (Eq a) => [a] -> [a] -> Bool 5 | -- isSubsequenceOf xs ys = foldr ((&&) . inSequence) True xs 6 | -- where 7 | -- inSequence = flip elem $ ys 8 | 9 | isSubsequenceOf :: (Eq a) => [a] -> [a] -> Bool 10 | isSubsequenceOf [] _ = True 11 | isSubsequenceOf _ [] = False 12 | isSubsequenceOf xss@(x:xs) (y:ys) 13 | | x == y = isSubsequenceOf xs ys 14 | | otherwise = isSubsequenceOf xss ys 15 | -------------------------------------------------------------------------------- /ch11/BinaryTreeFold.hs: -------------------------------------------------------------------------------- 1 | module BTFold where 2 | 3 | data BT a = 4 | Leaf 5 | | Node (BT a) a (BT a) 6 | deriving (Eq, Show, Ord) 7 | 8 | 9 | foldTree :: (a -> b -> b) -> b -> BT a -> b 10 | foldTree _ acc Leaf = acc 11 | foldTree f acc (Node left a right) = accRight 12 | where 13 | accNode = f a acc 14 | accLeft = foldTree f accNode left 15 | accRight = foldTree f accLeft right 16 | 17 | 18 | testTree :: BT Integer 19 | testTree = Node (Node Leaf 1 Leaf) 2 (Node Leaf 3 Leaf) 20 | 21 | mapTree' :: (a -> b) -> BT a -> BT b 22 | mapTree' = undefined -- https://www.reddit.com/r/HaskellBook/comments/4czzpp/haskellbookch_11_problems_implementing_maptree_in/ 23 | 24 | 25 | -------------------------------------------------------------------------------- /ch11/BinaryTreeList.hs: -------------------------------------------------------------------------------- 1 | module BinaryTreeList where 2 | 3 | data BinaryTree a = 4 | Leaf 5 | | Node (BinaryTree a) a (BinaryTree a) 6 | deriving (Show, Eq, Ord) 7 | 8 | preorder :: BinaryTree a -> [a] 9 | preorder Leaf = [] 10 | preorder (Node left a right) = a : preorder left ++ preorder right 11 | 12 | inorder :: BinaryTree a -> [a] 13 | inorder Leaf = [] 14 | inorder (Node left a right) = preorder left ++ [a] ++ preorder right 15 | 16 | postorder :: BinaryTree a -> [a] 17 | postorder Leaf = [] 18 | postorder (Node left a right) = postorder left ++ postorder right ++ [a] 19 | 20 | testTree :: BinaryTree Integer 21 | testTree = Node (Node Leaf 1 Leaf) 2 (Node Leaf 3 Leaf) 22 | 23 | testPreorder :: IO () 24 | testPreorder = 25 | if preorder testTree == [2, 1, 3] 26 | then putStrLn "Preorder fine!" 27 | else putStrLn "Bad news bears." 28 | 29 | testInorder :: IO () 30 | testInorder = 31 | if inorder testTree == [1, 2, 3] 32 | then putStrLn "inorder fine!" 33 | else putStrLn "Bad news bears." 34 | 35 | testPostorder :: IO () 36 | testPostorder = 37 | if postorder testTree == [1, 3, 2] 38 | then putStrLn "postorder fine!" 39 | else putStrLn "Bad news bears." 40 | 41 | main :: IO () 42 | main = do 43 | testPreorder 44 | testInorder 45 | testPostorder 46 | -------------------------------------------------------------------------------- /ch11/BinaryTreeMap.hs: -------------------------------------------------------------------------------- 1 | module BinaryTreeMap where 2 | 3 | data BinaryTree a = 4 | Leaf 5 | | Node (BinaryTree a) a (BinaryTree a) 6 | deriving (Eq, Ord, Show) 7 | 8 | mapTree :: (a -> b) -> BinaryTree a -> BinaryTree b 9 | mapTree _ Leaf = Leaf 10 | mapTree f (Node left a right) = Node newLeft b newRight 11 | where 12 | b = f a 13 | newLeft = mapTree f left 14 | newRight = mapTree f right 15 | 16 | 17 | testTree' :: BinaryTree Integer 18 | testTree' = Node (Node Leaf 3 Leaf) 1 (Node Leaf 4 Leaf) 19 | 20 | mapExpected :: BinaryTree Integer 21 | mapExpected = Node (Node Leaf 4 Leaf) 2 (Node Leaf 5 Leaf) 22 | 23 | mapOkay :: IO () 24 | mapOkay = 25 | if mapTree (+1) testTree' == mapExpected 26 | then print "yup okay!" 27 | else error "test failed" 28 | 29 | main :: IO () 30 | main = mapOkay 31 | 32 | 33 | -------------------------------------------------------------------------------- /ch11/Cipher.hs: -------------------------------------------------------------------------------- 1 | module Cipher (caesar, unCaesar, vignere, unVignere) where 2 | 3 | import Data.Char 4 | 5 | type Keyphrase = String 6 | 7 | shiftChar :: Int -> Char -> Char 8 | shiftChar 0 x = x 9 | shiftChar shift x 10 | | ord x + shift > ord 'Z' = shiftChar (shift - 26) x 11 | | ord x + shift < ord 'A' = shiftChar (shift + 26) x 12 | | otherwise = chr $ ord x + shift 13 | 14 | caesar :: Int -> String -> String 15 | caesar shift code = map (shiftChar shift) code 16 | 17 | unCaesar :: Int -> String -> String 18 | unCaesar shift code = map (shiftChar $ negate shift) code 19 | 20 | vignere :: Keyphrase -> String -> String 21 | vignere key inp = map (uncurry shiftChar) encodeAmounts 22 | where 23 | upperInp = map toUpper inp 24 | upperKey = map toUpper key 25 | encodeAmounts = shiftAmounts (cycle upperKey) upperInp 26 | 27 | shiftAmounts :: Keyphrase -> String -> [(Int, Char)] 28 | shiftAmounts _ [] = [] 29 | shiftAmounts [] _ = [] 30 | shiftAmounts key@(x:xs) (y:ys) 31 | | isAsciiUpper y = (ord x - ord 'A', y) : shiftAmounts xs ys 32 | | otherwise = (0, y) : shiftAmounts key ys 33 | 34 | unVignere :: Keyphrase -> String -> String 35 | unVignere key code = map (uncurry shiftChar) negShiftAmounts 36 | where 37 | upperCode = map toUpper code 38 | upperKey = map toUpper key 39 | encodeAmounts = shiftAmounts (cycle upperKey) upperCode 40 | negShiftAmounts = map negShiftFunction encodeAmounts 41 | negShiftFunction (a,b) = (negate a, b) 42 | -------------------------------------------------------------------------------- /ch11/HuttonsRazor.hs: -------------------------------------------------------------------------------- 1 | module HuttonsRazor where 2 | 3 | data Expr 4 | = Lit Integer 5 | | Add Expr Expr 6 | 7 | eval :: Expr -> Integer 8 | eval (Lit num) = num 9 | eval (Add a b) = (eval a) + (eval b) 10 | 11 | printExpr :: Expr -> String 12 | printExpr (Lit num) = show num 13 | printExpr (Add a b) = (printExpr a) ++ " + " ++ (printExpr b) 14 | 15 | -------------------------------------------------------------------------------- /ch11/LanguageExercises.hs: -------------------------------------------------------------------------------- 1 | module LanguageExercises where 2 | 3 | import Data.Char 4 | import Data.List 5 | import Data.List.Split 6 | 7 | capitalizeWords :: String -> [(String, String)] 8 | capitalizeWords = map (\x -> (x, capitalizeWord x)) . words 9 | 10 | capitalizeWord :: String -> String 11 | capitalizeWord [] = [] 12 | capitalizeWord (x:xs) = toUpper x : xs 13 | 14 | capitalizeParagraph :: String -> String 15 | capitalizeParagraph = unparagraph . map capitalizeWord . paragraph 16 | where 17 | paragraph = splitOn ". " 18 | unparagraph = intercalate ". " 19 | 20 | -------------------------------------------------------------------------------- /ch11/Phone.hs: -------------------------------------------------------------------------------- 1 | module Phone where 2 | 3 | import Data.Char 4 | 5 | data Option = Digit Char | Capitalize deriving (Eq, Show) 6 | 7 | data Button = Button ButtonIdentifier [Option] deriving (Eq, Show) 8 | 9 | data ButtonIdentifier = One | Two | Three | Four 10 | | Five | Six | Seven | Eight 11 | | Nine | Star | Zero | Bracket 12 | deriving (Eq, Show) 13 | 14 | type Presses = Int 15 | 16 | newtype PhonePad = PhonePad [Button] deriving (Eq, Show) 17 | 18 | phonePad :: PhonePad 19 | phonePad = PhonePad [one, two, three 20 | ,four, five, six 21 | ,seven, eight, nine 22 | ,star, zero, bracket] 23 | where 24 | one = Button One (buildDigitList ['1']) 25 | two = Button Two (buildDigitList ['a', 'b', 'c', '2']) 26 | three = Button Three (buildDigitList ['d', 'e', 'f', '3']) 27 | four = Button Four (buildDigitList ['g', 'h', 'i', '4']) 28 | five = Button Five (buildDigitList ['j', 'k', 'l', '5']) 29 | six = Button Six (buildDigitList ['m', 'n', 'o', '6']) 30 | seven = Button Seven (buildDigitList ['p', 'q', 'r', 's', '7']) 31 | eight = Button Eight (buildDigitList ['t', 'u', 'v', '8']) 32 | nine = Button Nine (buildDigitList ['w', 'x', 'y', 'z', '9']) 33 | star = Button Star [Capitalize] 34 | zero = Button Zero (buildDigitList ['+', ' ', '0']) 35 | bracket = Button Bracket (buildDigitList ['.', ',', '\n']) 36 | 37 | reversePhonePad (PhonePad buttons) = lookUpify buildList 38 | where 39 | lookUpify = map (\(x, y, z) -> (x, (y, z))) 40 | buildList = concat $ map (\(Button btype options) -> zip3 options (repeat btype) [1..]) buttons 41 | 42 | buildDigitList :: [Char] -> [Option] 43 | buildDigitList = map Digit 44 | 45 | 46 | charToTaps :: PhonePad -> Char -> Maybe [(ButtonIdentifier, Presses)] 47 | charToTaps phonePad x = sequence $ map (flip lookup $ revPad) options 48 | where 49 | options = charToOption x 50 | revPad = reversePhonePad phonePad 51 | 52 | 53 | stringToTaps :: PhonePad -> [Char] -> Maybe [(ButtonIdentifier, Presses)] 54 | stringToTaps phonepad x = fmap concat $ sequence $ map (charToTaps phonePad) x 55 | 56 | 57 | charToOption :: Char -> [Option] 58 | charToOption x 59 | | isUpper x = Capitalize : Digit (toLower x) : [] 60 | | otherwise = Digit x : [] 61 | 62 | convo :: [String] 63 | convo = ["Wanna play 20 questions", 64 | "Ya", 65 | "U 1st haha", 66 | "Lol ok. Have u ever tasted alcohol lol", 67 | "Lol ya", 68 | "Wow ur cool haha. Ur turn", 69 | "Ok. Do u think I am pretty Lol", 70 | "Lol ya", 71 | "Haha thanks just making sure rofl ur turn"] 72 | -------------------------------------------------------------------------------- /ch11/chapterExercises.hs: -------------------------------------------------------------------------------- 1 | -- 1. a 2 | -- 2. c 3 | -- 3. b 4 | -- 4. c 5 | -- 6 | -- 7 | -------------------------------------------------------------------------------- /ch11/exercises.hs: -------------------------------------------------------------------------------- 1 | data FlowerType = Gardenia 2 | | Daisy 3 | | Rose 4 | | Lilac 5 | deriving Show 6 | 7 | type Gardener = String 8 | 9 | data Garden = 10 | Garden Gardener FlowerType 11 | deriving Show 12 | -- Cant distribute over tabes as this is simply (a * b) 13 | 14 | -- Generate all programmer possibilities 15 | 16 | data OperatingSystem = 17 | GnuPlusLinux 18 | | OpenBSDPlusNevermindJustBSDStill 19 | | Mac 20 | | Windows 21 | deriving (Eq, Show) 22 | 23 | data ProgrammingLanguage = 24 | Haskell 25 | | Agda 26 | | Idris 27 | | PureScript 28 | deriving (Eq, Show) 29 | 30 | data Programmer = 31 | Programmer { os :: OperatingSystem 32 | , lang :: ProgrammingLanguage } 33 | deriving (Eq, Show) 34 | 35 | allOperatingSystems :: [OperatingSystem] 36 | allOperatingSystems = [ GnuPlusLinux 37 | , OpenBSDPlusNevermindJustBSDStill 38 | , Mac 39 | , Windows 40 | ] 41 | allLanguages :: [ProgrammingLanguage] 42 | allLanguages = [Haskell, Agda, Idris, PureScript] 43 | 44 | 45 | allProgrammers :: [Programmer] 46 | allProgrammers = [Programmer x y | x <- allOperatingSystems, y <- allLanguages] 47 | -------------------------------------------------------------------------------- /ch11/intermission.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | data DogueDeBordeaux doge = DogueDeBordeaux doge 4 | 5 | data Doggies a = 6 | Husky a 7 | | Mastiff a 8 | deriving (Eq, Show) 9 | -- 1 Type constructor 10 | -- 2 * -> * 11 | -- 3 * 12 | -- 4 Num a => Doggies a 13 | -- 5 Doggies Integer 14 | -- 6 Doggies String 15 | -- 7 both 16 | -- 8 DogueDeBordeaux a 17 | -- 9 DogueDeBordeaux String 18 | 19 | data Price = Price Integer deriving (Eq, Show) 20 | 21 | -- 5 22 | data Size = Size Integer deriving (Eq, Show) 23 | 24 | data Manufacturer = Mini | Mazda | Tata deriving (Eq, Show) 25 | 26 | data Airline = PapuAir 27 | | CapaltusR'Us 28 | | TakeYourCHanceUnited 29 | deriving (Eq, Show) 30 | 31 | data Vehicle = Car Manufacturer Price 32 | | Plane Airline Size 33 | deriving (Eq, Show) 34 | 35 | myCar = Car Mini (Price 14000) 36 | urCar = Car Mazda (Price 20000) 37 | clownCar = Car Tata (Price 7000) 38 | doge = Plane PapuAir (Size 200) 39 | 40 | -- 1 myCar :: Vehicle 41 | -- 2: 42 | isCar :: Vehicle -> Bool 43 | isCar (Car _ _) = True 44 | isCar _ = False 45 | 46 | -- 5 (Plane _) -> (Plane _ _) 47 | isPlane :: Vehicle -> Bool 48 | isPlane (Plane _ _) = True 49 | isPlane _ = False 50 | 51 | areCars :: [Vehicle] -> [Bool] 52 | areCars = map isCar 53 | 54 | -- 3: 55 | getManu :: Vehicle -> Manufacturer 56 | getManu (Car a _) = a 57 | 58 | -- 4 Partial function, because of the non-exhaustive pattern. 59 | -- Will raise an exception if a Plane is feeded. 60 | -- 61 | -- 5 62 | 63 | 64 | -- 1 |PugType| = 1 65 | -- 2 |Airline| = 3 66 | -- 3 |Int16| -> [-32768, 32767] = 65536 67 | -- 4 Cardinality of Int is big!, Integer has infinite cardinality as its unbounded 68 | -- 5 2 ^ 8 69 | 70 | data Example = MakeExample deriving Show 71 | 72 | -- 1 MakeExample :: Example 73 | -- 2 Yes we can see the instances defined in GHCi 74 | -- 3 75 | data Container a = MakeContainer a deriving (Show, Eq) 76 | -- :t MakeContainer :: a -> Container a 77 | 78 | 79 | 80 | class TooMany a where 81 | tooMany :: a -> Bool 82 | 83 | instance TooMany Int where 84 | tooMany n = n > 42 85 | 86 | newtype Goats = Goats Int deriving (Eq, Show, TooMany) 87 | 88 | newtype Cow = Cow (Int, String) deriving (Eq, Show) 89 | 90 | data Herd = Herd (Int, String) deriving (Eq, Show) 91 | 92 | instance TooMany Herd where 93 | tooMany (Herd (a, b)) = a > 42 94 | 95 | newtype DoubleGoat = DoubleGoat (Int, Int) deriving (Eq, Show) 96 | 97 | instance TooMany Cow where 98 | tooMany (Cow (a, b)) = a > 42 99 | 100 | instance TooMany DoubleGoat where 101 | tooMany (DoubleGoat (a, b)) = (a * b) > 42 102 | 103 | instance (Num a, Ord a) => TooMany (a, a) where 104 | tooMany (a, b) = (a * b) > 42 105 | 106 | -- 1 |BigSmall| = 2 107 | -- 2 |NumberOrBool| = 2 + |Int8| = 258 108 | 109 | -- Unique inhabitants from all possible implementations 110 | -- 1 4 + 4 = 8 111 | -- 2 4 * 4 = 16 112 | -- 3 4 ^ 4 = 256 113 | -- 4 4 * 4 * 4 = 64 114 | -- 5 (2 ^ 2) ^ 2 = 16 115 | -- 6 (4 ^ 4) ^ 2 = 65536 116 | -------------------------------------------------------------------------------- /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 | , jars :: Int } 14 | deriving (Eq, Show, Ord) 15 | 16 | 17 | -- 3 |JamJars| = 3 * |Int| = muchos 18 | -- 5 19 | 20 | row1 :: JamJars 21 | row1 = Jam Peach 5 22 | row2 :: JamJars 23 | row2 = Jam Plum 3 24 | row3 :: JamJars 25 | row3 = Jam Blackberry 4 26 | row4 :: JamJars 27 | row4 = Jam Plum 1 28 | row5 :: JamJars 29 | row5 = Jam Apple 6 30 | row6 :: JamJars 31 | row6 = Jam Peach 2 32 | 33 | allJam :: [JamJars] 34 | allJam = [row1, row2, row3, row4, row5, row6] 35 | 36 | -- 6 37 | numberOfJars :: [JamJars] -> Int 38 | numberOfJars = sum . map jars 39 | 40 | -- 7 41 | mostRow :: [JamJars] -> JamJars 42 | mostRow = maximumBy (\x y -> compare (jars x) (jars y)) 43 | 44 | compareKind :: JamJars -> JamJars -> Ordering 45 | compareKind (Jam k _) (Jam k' _) = compare k k' 46 | 47 | sortAllJams :: [JamJars] -> [JamJars] 48 | sortAllJams = sortBy compareKind 49 | 50 | groupJams :: [JamJars] -> [[JamJars]] 51 | groupJams = groupBy (\x y -> compareKind x y == EQ) . sortAllJams 52 | 53 | -------------------------------------------------------------------------------- /ch12/BinaryTree.hs: -------------------------------------------------------------------------------- 1 | module BinaryTree where 2 | 3 | data BinaryTree a = 4 | Leaf 5 | | Node (BinaryTree a) a (BinaryTree a) 6 | deriving (Eq, Ord, Show) 7 | 8 | unfold :: (a -> Maybe (a, b, a)) -> a -> BinaryTree b 9 | unfold f state = case f state of 10 | Just (stateLeft, nodeVal, stateRight) -> Node (unfold f stateLeft) nodeVal (unfold f stateRight) 11 | Nothing -> Leaf 12 | 13 | treeBuild :: Integer -> BinaryTree Integer 14 | treeBuild x = unfold buildCond 0 15 | where 16 | buildCond b = if b < x then Just (b + 1, b, b + 1) else Nothing 17 | -------------------------------------------------------------------------------- /ch12/ChapterExercises.hs: -------------------------------------------------------------------------------- 1 | newtype Word' = Word' String deriving (Eq, Show) 2 | 3 | 4 | vowels :: [Char] 5 | vowels = ['a', 'e', 'u', 'i', 'o'] 6 | 7 | consonants :: [Char] 8 | consonants = "bcdfghjklmnpqrstvwxyz" 9 | 10 | 11 | 12 | notThe :: String -> Maybe String 13 | notThe a 14 | | a == "the" = Nothing 15 | | otherwise = Just a 16 | 17 | replaceThe :: String -> String 18 | replaceThe = unwords . map replacer . words 19 | where 20 | replacer "the" = "a" 21 | replacer a = a 22 | 23 | countTheBeforeVowel :: String -> Integer 24 | countTheBeforeVowel = counter . words 25 | where 26 | counter (s1:s2:ss) 27 | | s1 == "the" && head s2 `elem` vowels = 1 + counter (s2:ss) 28 | | otherwise = 0 + counter (s2:ss) 29 | counter _ = 0 30 | 31 | countVowels :: String -> Integer 32 | countVowels = fromIntegral . length . filter isVowel 33 | where 34 | isVowel = (flip elem) vowels 35 | 36 | countConsonants :: String -> Integer 37 | countConsonants = fromIntegral . length . filter isConsonant 38 | where 39 | isConsonant = (flip elem) consonants 40 | 41 | 42 | mkWord :: String -> Maybe Word' 43 | mkWord word 44 | | countVowels word > countConsonants word = Nothing 45 | | otherwise = Just (Word' word) 46 | -------------------------------------------------------------------------------- /ch12/NaturalNumbers.hs: -------------------------------------------------------------------------------- 1 | module NaturalNumbers where 2 | 3 | import Data.Maybe 4 | 5 | data Nat = 6 | Zero 7 | | Succ Nat 8 | deriving (Eq, Show) 9 | 10 | natToInteger :: Nat -> Integer 11 | natToInteger (Succ x) = 1 + natToInteger x 12 | natToInteger Zero = 0 13 | 14 | integerToNat :: Integer -> Maybe Nat 15 | integerToNat x 16 | | x < 0 = Nothing 17 | | x == 0 = Just Zero 18 | | otherwise = insertSucc $ integerToNat (x - 1) 19 | where 20 | insertSucc :: Maybe Nat -> Maybe Nat 21 | insertSucc (Just x') = Just (Succ x') 22 | insertSucc Nothing = Nothing 23 | -------------------------------------------------------------------------------- /ch12/SmallEitherLib.hs: -------------------------------------------------------------------------------- 1 | module SmallEitherLib where 2 | 3 | lefts' :: [Either a b] -> [a] 4 | lefts' = foldr appendLeft [] 5 | where 6 | appendLeft (Left x) list = x : list 7 | appendLeft _ list = list 8 | 9 | rights' :: [Either a b] -> [b] 10 | rights' = foldr appendRight [] 11 | where 12 | appendRight (Right x) list = x : list 13 | appendRight _ list = list 14 | 15 | partitionEithers' :: [Either a b] -> ([a], [b]) 16 | partitionEithers' = foldr append ([], []) 17 | where 18 | append (Left x) (leftL, rightL) = (x : leftL, rightL) 19 | append (Right x) (leftL, rightL) = (leftL, x : rightL) 20 | 21 | eitherMaybe' :: (b -> c) -> Either a b -> Maybe c 22 | eitherMaybe' _ (Left _ ) = Nothing 23 | eitherMaybe' f (Right x) = Just $ f x 24 | 25 | either' :: (a -> c) -> (b -> c) -> Either a b -> c 26 | either' f _ (Left x) = f x 27 | either' _ f (Right x) = f x 28 | 29 | eitherMaybe'' :: (b -> c) -> Either a b -> Maybe c 30 | eitherMaybe'' f x = either' (const Nothing) (Just . f) x 31 | 32 | -------------------------------------------------------------------------------- /ch12/SmallMaybeLib.hs: -------------------------------------------------------------------------------- 1 | module SmallMaybeLib where 2 | 3 | isJust :: Maybe a -> Bool 4 | isJust Nothing = False 5 | isJust _ = True 6 | 7 | isNothing :: Maybe a -> Bool 8 | isNothing Nothing = True 9 | isNothing _ = False 10 | 11 | mayybee :: b -> (a -> b) -> Maybe a -> b 12 | mayybee defVal _ Nothing = defVal 13 | mayybee _ f (Just x) = f x 14 | 15 | fromMaybe :: a -> Maybe a -> a 16 | fromMaybe defVal Nothing = defVal 17 | fromMaybe _ (Just x) = x 18 | 19 | listToMaybe :: [a] -> Maybe a 20 | listToMaybe (x:_) = Just x 21 | listToMaybe [] = Nothing 22 | 23 | maybeToList :: Maybe a -> [a] 24 | maybeToList (Just x) = [x] 25 | maybeToList Nothing = [] 26 | 27 | catMaybes :: [Maybe a] -> [a] 28 | catMaybes = foldr appJust [] 29 | where 30 | appJust (Just x) acc = x : acc 31 | appJust _ acc = acc 32 | 33 | flipMaybe :: [Maybe a] -> Maybe [a] 34 | flipMaybe = foldr appendOrNothing (Just []) 35 | where 36 | appendOrNothing (Just x) (Just acc) = Just (x : acc) 37 | appendOrNothing _ _ = Nothing 38 | 39 | -------------------------------------------------------------------------------- /ch12/Unfolds.hs: -------------------------------------------------------------------------------- 1 | module Unfolds where 2 | 3 | myIterate :: (a -> a) -> a -> [a] 4 | myIterate f cur = cur : myIterate f (f cur) 5 | 6 | myUnfoldr :: (b -> Maybe (a, b)) -> b -> [a] 7 | myUnfoldr f state = case f state of 8 | Just (val, newState) -> val : myUnfoldr f newState 9 | Nothing -> [] 10 | 11 | betterIterate :: (a -> a) -> a -> [a] 12 | betterIterate f x = myUnfoldr (\x' -> Just (x', f x')) x 13 | -------------------------------------------------------------------------------- /ch13/Cipher/Cipher.cabal: -------------------------------------------------------------------------------- 1 | name: Cipher 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/Cipher#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author Dorus Leliveld 9 | maintainer: example@example.com 10 | copyright: 2016 Dorus Leliveld 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: Cipher 18 | build-depends: base >= 4.7 && < 5 19 | default-language: Haskell2010 20 | 21 | executable Cipher 22 | hs-source-dirs: app 23 | main-is: Main.hs 24 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 25 | build-depends: base 26 | , Cipher 27 | default-language: Haskell2010 28 | 29 | -------------------------------------------------------------------------------- /ch13/Cipher/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (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 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/Cipher/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch13/Cipher/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Cipher 4 | 5 | import Data.Char 6 | 7 | 8 | 9 | main :: IO () 10 | main = do 11 | putStrLn "Write c, for Caeser and v for vignere" 12 | method <- getLine 13 | putStrLn "Write d for decode or c for code" 14 | mode <- getLine 15 | putStrLn "Present key" 16 | key <- getLine 17 | putStrLn "Present line to be coded/decoded" 18 | phrase <- getLine 19 | putStrLn $ case (method, mode) of 20 | ("c", "c") -> caesar (read key) phrase 21 | ("c", "d") -> unCaesar (read key) phrase 22 | ("v", "c") -> vignere key phrase 23 | ("v", "d") -> unVignere key phrase 24 | _ -> error ("Incorrect input arguments") 25 | 26 | 27 | -------------------------------------------------------------------------------- /ch13/Cipher/src/Cipher.hs: -------------------------------------------------------------------------------- 1 | module Cipher (caesar, unCaesar, vignere, unVignere) where 2 | 3 | import Data.Char 4 | 5 | type Keyphrase = String 6 | 7 | shiftChar :: Int -> Char -> Char 8 | shiftChar 0 x = x 9 | shiftChar shift x 10 | | ord x + shift > ord 'Z' = shiftChar (shift - 26) x 11 | | ord x + shift < ord 'A' = shiftChar (shift + 26) x 12 | | otherwise = chr $ ord x + shift 13 | 14 | caesar :: Int -> String -> String 15 | caesar shift code = map (shiftChar shift) code 16 | 17 | unCaesar :: Int -> String -> String 18 | unCaesar shift code = map (shiftChar $ negate shift) code 19 | 20 | vignere :: Keyphrase -> String -> String 21 | vignere key inp = map (uncurry shiftChar) encodeAmounts 22 | where 23 | upperInp = map toUpper inp 24 | upperKey = map toUpper key 25 | encodeAmounts = shiftAmounts (cycle upperKey) upperInp 26 | 27 | shiftAmounts :: Keyphrase -> String -> [(Int, Char)] 28 | shiftAmounts _ [] = [] 29 | shiftAmounts [] _ = [] 30 | shiftAmounts key@(x:xs) (y:ys) 31 | | isAsciiUpper y = (ord x - ord 'A', y) : shiftAmounts xs ys 32 | | otherwise = (0, y) : shiftAmounts key ys 33 | 34 | unVignere :: Keyphrase -> String -> String 35 | unVignere key code = map (uncurry shiftChar) negShiftAmounts 36 | where 37 | upperCode = map toUpper code 38 | upperKey = map toUpper key 39 | encodeAmounts = shiftAmounts (cycle upperKey) upperCode 40 | negShiftAmounts = map negShiftFunction encodeAmounts 41 | negShiftFunction (a,b) = (negate a, b) 42 | -------------------------------------------------------------------------------- /ch13/Cipher/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /ch13/Cipher/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 | # http://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 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.7 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /ch13/Cipher/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /ch13/hangman/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (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 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/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch13/hangman/data/.gitignore: -------------------------------------------------------------------------------- 1 | words 2 | -------------------------------------------------------------------------------- /ch13/hangman/hangman.cabal: -------------------------------------------------------------------------------- 1 | name: hangman 2 | version: 0.1.0.0 3 | synopsis: Playing Hangman 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/hangman#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Dorus Leliveld 9 | maintainer: example@example.com 10 | copyright: 2016 Dorus Leliveld 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | executable hangman 16 | main-is: Main.hs 17 | hs-source-dirs: src 18 | build-depends: base >= 4.7 && < 5 19 | , random 20 | , split 21 | default-language: Haskell2010 22 | -------------------------------------------------------------------------------- /ch13/hangman/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | 4 | import Control.Monad (forever) 5 | import Data.Char (toLower) 6 | import Data.Maybe (isJust) 7 | import Data.List (intersperse) 8 | import System.Exit (exitSuccess) 9 | import System.Random (randomRIO) 10 | 11 | -- type WordList = [String] 12 | newtype WordList = 13 | WordList [String] 14 | deriving (Eq, Show) 15 | 16 | 17 | 18 | allWords :: IO WordList 19 | allWords = do 20 | dict <- readFile "data/words" 21 | return $ WordList (lines dict) 22 | 23 | minWordLength :: Int 24 | minWordLength = 5 25 | 26 | maxWordLength :: Int 27 | maxWordLength = 9 28 | 29 | numberOfGuesses :: Int 30 | numberOfGuesses = 7 31 | 32 | gameWords :: IO WordList 33 | gameWords = do 34 | (WordList aw) <- allWords 35 | return $ WordList (filter gameLength aw) 36 | where gameLength w = 37 | let l = length w 38 | in l > minWordLength && l < maxWordLength 39 | 40 | randomWord :: WordList -> IO String 41 | randomWord (WordList wl) = do 42 | randomIndex <- randomRIO (0, length wl - 1) 43 | return $ wl !! randomIndex 44 | 45 | randomWord' :: IO String 46 | randomWord' = gameWords >>= randomWord 47 | 48 | data Puzzle = Puzzle String [Maybe Char] [Char] Int 49 | 50 | instance Show Puzzle where 51 | show (Puzzle _ discovered guessed guessesLeft) = 52 | (intersperse ' ' $ fmap renderPuzzleChar discovered) 53 | ++ " Guessed so far: " ++ guessed ++ " Guesses left: " ++ show guessesLeft 54 | 55 | freshPuzzle :: String -> Puzzle 56 | freshPuzzle word = Puzzle word (map (const Nothing) word) [] numberOfGuesses 57 | 58 | charInWord :: Puzzle -> Char -> Bool 59 | charInWord (Puzzle word _ _ _) guess = guess `elem` word 60 | 61 | alreadyGuessed :: Puzzle -> Char -> Bool 62 | alreadyGuessed (Puzzle _ _ guessedSoFar _) guess = guess `elem` guessedSoFar 63 | 64 | renderPuzzleChar :: Maybe Char -> Char 65 | renderPuzzleChar Nothing = '_' 66 | renderPuzzleChar (Just a) = a 67 | 68 | fillInCharacter :: Puzzle -> Char -> Puzzle 69 | fillInCharacter (Puzzle word filledInSoFar s noG) c = 70 | Puzzle word newFilledInSoFar (c : s) noG 71 | where 72 | zipper guessed wordChar guessChar = 73 | if wordChar == guessed 74 | then Just wordChar 75 | else guessChar 76 | newFilledInSoFar = zipWith (zipper c) word filledInSoFar 77 | 78 | missedGuess :: Puzzle -> Char -> Puzzle 79 | missedGuess puzzle guess = Puzzle w f m (noG - 1) 80 | where 81 | (Puzzle w f m noG) = fillInCharacter puzzle guess 82 | 83 | handleGuess :: Puzzle -> Char -> IO Puzzle 84 | handleGuess puzzle guess = do 85 | putStrLn $ "Your guess was: " ++ [guess] 86 | case (charInWord puzzle guess, alreadyGuessed puzzle guess) of 87 | (_, True) -> do 88 | putStrLn "Your already guessed that character, pick something else" 89 | return puzzle 90 | (True, _) -> do 91 | putStrLn "This character was in the word, filling in the word accordingly" 92 | return (fillInCharacter puzzle guess) 93 | (False, _) -> do 94 | putStrLn "This character wasn't in the word, try again" 95 | return (missedGuess puzzle guess) 96 | 97 | gameOver :: Puzzle -> IO () 98 | gameOver (Puzzle wordToGuess _ guessed noGuesses) = 99 | if (noGuesses) <= 0 then 100 | do putStrLn "You lose!" 101 | putStrLn $ "The word was: " ++ wordToGuess 102 | exitSuccess 103 | else 104 | return () 105 | 106 | gameWin :: Puzzle -> IO () 107 | gameWin (Puzzle _ filledInSoFar _ _) = 108 | if all isJust filledInSoFar then 109 | do putStrLn "You win!" 110 | exitSuccess 111 | else return () 112 | 113 | runGame :: Puzzle -> IO () 114 | runGame puzzle = forever $ do 115 | gameWin puzzle 116 | gameOver puzzle 117 | putStrLn $ "Current puzzle is " ++ show puzzle 118 | putStr "Guess a letter: " 119 | guess <- getLine 120 | case guess of 121 | [c] -> handleGuess puzzle c >>= runGame 122 | _ -> putStrLn "Your guess must be a single character" 123 | 124 | main :: IO () 125 | main = do 126 | word <- randomWord' 127 | let puzzle = freshPuzzle (fmap toLower word) 128 | runGame puzzle 129 | 130 | 131 | -------------------------------------------------------------------------------- /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 | # http://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 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.7 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /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 Hello 4 | import DogsRule 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 | 15 | -------------------------------------------------------------------------------- /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: Dorus Leliveld 9 | maintainer: example@email.com 10 | copyright: 2016, Dorus Leliveld 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 | 29 | -------------------------------------------------------------------------------- /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 | 10 | -------------------------------------------------------------------------------- /ch13/hello/src/Hello.hs: -------------------------------------------------------------------------------- 1 | module Hello (sayHello) where 2 | 3 | sayHello :: String -> IO () 4 | sayHello name = do 5 | putStrLn $ "Hi " ++ name ++ "!" 6 | -------------------------------------------------------------------------------- /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/intermission.hs: -------------------------------------------------------------------------------- 1 | -- 1. forever, when 2 | -- 2. Data.Bits, Database.Blacktip.Types 3 | -- 3. Custom data types from the library 4 | -- 4. a. MV -> Control.Concurrent.MVar, FPC -> Filesystem.Path.CurrentOS, CC -> Control.Concurrent 5 | -- b. FS -> Filesystem. 6 | -- c. Control.Monad 7 | -------------------------------------------------------------------------------- /ch13/makePerson.hs: -------------------------------------------------------------------------------- 1 | type Name = String 2 | type Age = Integer 3 | 4 | data Person = Person Name Age deriving (Show) 5 | 6 | data PersonInvalid = NameEmpty 7 | | AgeTooLow 8 | | PersonInvalidUnknown String 9 | deriving (Eq, Show) 10 | 11 | mkPerson :: Name -> Age -> Either PersonInvalid Person 12 | mkPerson name age 13 | | name /= "" && age > 0 = Right $ Person name age 14 | | name == "" = Left NameEmpty 15 | module Cipher (caesar, unCaesar, vignere, unVignere) where 16 | 17 | import Data.Char 18 | 19 | type Keyphrase = String 20 | 21 | shiftChar :: Int -> Char -> Char 22 | shiftChar 0 x = x 23 | shiftChar shift x 24 | | ord x + shift > ord 'Z' = shiftChar (shift - 26) x 25 | | ord x + shift < ord 'A' = shiftChar (shift + 26) x 26 | | otherwise = chr $ ord x + shift 27 | 28 | caesar :: Int -> String -> String 29 | caesar shift code = map (shiftChar shift) code 30 | 31 | unCaesar :: Int -> String -> String 32 | unCaesar shift code = map (shiftChar $ negate shift) code 33 | 34 | vignere :: Keyphrase -> String -> String 35 | vignere key inp = map (uncurry shiftChar) encodeAmounts 36 | where 37 | upperInp = map toUpper inp 38 | upperKey = map toUpper key 39 | encodeAmounts = shiftAmounts (cycle upperKey) upperInp 40 | 41 | shiftAmounts :: Keyphrase -> String -> [(Int, Char)] 42 | shiftAmounts _ [] = [] 43 | shiftAmounts [] _ = [] 44 | shiftAmounts key@(x:xs) (y:ys) 45 | | isAsciiUpper y = (ord x - ord 'A', y) : shiftAmounts xs ys 46 | | otherwise = (0, y) : shiftAmounts key ys 47 | 48 | unVignere :: Keyphrase -> String -> String 49 | unVignere key code = map (uncurry shiftChar) negShiftAmounts 50 | where 51 | upperCode = map toUpper code 52 | upperKey = map toUpper key 53 | encodeAmounts = shiftAmounts (cycle upperKey) upperCode 54 | negShiftAmounts = map negShiftFunction encodeAmounts 55 | negShiftFunction (a,b) = (negate a, b) 56 | | not (age > 0) = Left AgeTooLow 57 | | otherwise = Left $ PersonInvalidUnknown $ "Name: " ++ show name ++ " Age: " ++ show age 58 | 59 | splitInput :: String -> (Name, Age) 60 | splitInput inp = (unwords $ init split, (read $ last split)) 61 | where 62 | split = words inp 63 | 64 | 65 | gimmePerson :: IO () 66 | gimmePerson = do 67 | putStrLn "Enter person with following format [name age]" 68 | nameAndAge <- splitInput <$> getLine 69 | case (uncurry mkPerson) nameAndAge of 70 | Right p -> putStrLn $ "Yay! " ++ show p 71 | Left e -> putStrLn $ "Error! " ++ show e 72 | 73 | main :: IO () 74 | main = gimmePerson 75 | -------------------------------------------------------------------------------- /ch13/palindrome.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Data.Char 3 | import System.Exit (exitSuccess) 4 | 5 | 6 | palindrome :: IO () 7 | palindrome = forever $ do 8 | line1 <- cleanInput <$> getLine 9 | case (line1 == reverse line1) of 10 | True -> putStrLn "It's a palindrome!" 11 | False -> putStrLn "Nope!" >> exitSuccess 12 | 13 | cleanInput :: String -> String 14 | cleanInput = filter isLetter . map toLower 15 | 16 | main :: IO () 17 | main = palindrome 18 | -------------------------------------------------------------------------------- /ch14/Addition/Addition.cabal: -------------------------------------------------------------------------------- 1 | name: Addition 2 | version: 0.1.0.0 3 | synopsis: Simple project template from stack 4 | description: Please see README.md 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Dorus Leliveld 8 | maintainer: dorusleliveld@gmail.com 9 | copyright: 2016 Dorus Leliveld 10 | category: Education 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | 14 | library 15 | exposed-modules: Addition 16 | ghc-options: -Wall -fwarn-tabs 17 | build-depends: base >= 4.7 && < 5 18 | , hspec 19 | , QuickCheck 20 | hs-source-dirs: . 21 | default-language: Haskell2010 22 | -------------------------------------------------------------------------------- /ch14/Addition/Addition.hs: -------------------------------------------------------------------------------- 1 | module Addition where 2 | 3 | import Test.Hspec 4 | import Test.QuickCheck 5 | 6 | dividedBy :: Integral a => a -> a -> (a, a) 7 | dividedBy num denom = go num denom 0 8 | where go n d count 9 | | n < d = (count, n) 10 | | otherwise = go (n - d) d (count + 1) 11 | 12 | main :: IO () 13 | main = hspec $ do 14 | describe "Addition" $ do 15 | it "1 + 1 is greater than 1" $ do 16 | (1 + (1 :: Integer)) > 1 `shouldBe` True 17 | it "2 + 2 is equal to 4" $ do 18 | 2 + (2 :: Integer) `shouldBe` 4 19 | it "x + 1 is always greater than x" $ do 20 | property $ \x -> x + 1 > (x :: Int) 21 | 22 | recursion :: IO () 23 | recursion = hspec $ do 24 | describe "Division" $ do 25 | it "15 divided by 3 is 5" $ do 26 | dividedBy (15 :: Integer) 3 `shouldBe` (5, 0) 27 | it "22 divided by 5 is 4 remainder 2" $ do 28 | dividedBy (22 :: Integer) 5 `shouldBe` (4, 2) 29 | describe "Multiplication" $ do 30 | it "5 times 3 is 15" $ do 31 | multRecursive (5 :: Integer) 3 `shouldBe` 15 32 | it "-4 times 2 is -8" $ do 33 | multRecursive (-4 :: Integer) 2 `shouldBe` (-8) 34 | 35 | sayHello :: IO () 36 | sayHello = putStrLn "hello" 37 | 38 | multRecursive :: (Integral a) => a -> a -> a 39 | multRecursive a b 40 | | a > 0 = b + multRecursive (a - 1) b 41 | | a < 0 = (negate b) + multRecursive (a + 1) b 42 | | otherwise = 0 43 | 44 | trivialInt :: Gen Int 45 | trivialInt = return 1 46 | 47 | oneThroughThree :: Gen Int 48 | oneThroughThree = elements [1, 2, 2, 2, 2, 3] 49 | 50 | genBool :: Gen Bool 51 | genBool = choose (False, True) 52 | 53 | genBool' :: Gen Bool 54 | genBool' = elements [False, True] 55 | 56 | genOrdering :: Gen Ordering 57 | genOrdering = elements [LT, EQ, GT] 58 | 59 | genChar :: Gen Char 60 | genChar = elements ['a'..'z'] 61 | 62 | genTuple :: (Arbitrary a, Arbitrary b) => Gen (a, b) 63 | genTuple = do 64 | a <- arbitrary 65 | b <- arbitrary 66 | return (a, b) 67 | 68 | genThreeple :: (Arbitrary a, Arbitrary b, Arbitrary c) => Gen (a, b, c) 69 | genThreeple = do 70 | a <- arbitrary 71 | b <- arbitrary 72 | c <- arbitrary 73 | return (a, b, c) 74 | 75 | genEither :: (Arbitrary a, Arbitrary b) => Gen (Either a b) 76 | genEither = do 77 | a <- arbitrary 78 | b <- arbitrary 79 | elements [Left a, Right b] 80 | 81 | genMaybe :: Arbitrary a => Gen (Maybe a) 82 | genMaybe = do 83 | a <- arbitrary 84 | elements [Nothing, Just a] 85 | 86 | genMaybe' :: Arbitrary a => Gen (Maybe a) 87 | genMaybe' = do 88 | a <- arbitrary 89 | frequency [ (1, return Nothing) 90 | , (3, return (Just a))] 91 | 92 | prop_additionGreater :: Int -> Bool 93 | prop_additionGreater x = x + 1 > x 94 | 95 | runQc :: IO () 96 | runQc = quickCheck prop_additionGreater 97 | -------------------------------------------------------------------------------- /ch14/Addition/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Dorus Leliveld (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 Dorus Leliveld 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. -------------------------------------------------------------------------------- /ch14/Addition/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 | # http://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 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.9 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /ch14/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | module Arbitrary where 2 | 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Gen (oneof) 5 | 6 | data Trivial = 7 | Trivial 8 | deriving (Eq, Show) 9 | 10 | trivialGen :: Gen Trivial 11 | trivialGen = return Trivial 12 | 13 | instance Arbitrary Trivial where 14 | arbitrary = trivialGen 15 | 16 | data Identity a = 17 | Identity a 18 | deriving (Eq, Show) 19 | 20 | identityGen :: Arbitrary a => Gen (Identity a) 21 | identityGen = do 22 | a <- arbitrary 23 | return (Identity a) 24 | 25 | instance Arbitrary a => Arbitrary (Identity a) where 26 | arbitrary = identityGen 27 | 28 | identityGenInt :: Gen (Identity Int) 29 | identityGenInt = identityGen -- equivalent to arbitrary 30 | 31 | data Pair a b = 32 | Pair a b 33 | deriving (Eq, Show) 34 | 35 | pairGen :: (Arbitrary a, Arbitrary b) => Gen (Pair a b) 36 | pairGen = do 37 | a <- arbitrary 38 | b <- arbitrary 39 | return (Pair a b) 40 | 41 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Pair a b) where 42 | arbitrary = pairGen 43 | 44 | pairGenIntString :: Gen (Pair Int String) 45 | pairGenIntString = arbitrary 46 | 47 | data Sum a b = 48 | First a 49 | | Second b 50 | deriving (Eq, Show) 51 | 52 | sumGenEqual :: (Arbitrary a, Arbitrary b) => Gen (Sum a b) 53 | sumGenEqual = do 54 | a <- arbitrary 55 | b <- arbitrary 56 | oneof [return $ First a, return $ Second b] 57 | 58 | sumGenCharInt :: Gen (Sum Char Int) 59 | sumGenCharInt = sumGenEqual 60 | 61 | sumGenFirstPls :: (Arbitrary a, Arbitrary b) => Gen (Sum a b) 62 | sumGenFirstPls = do 63 | a <- arbitrary 64 | b <- arbitrary 65 | frequency [(10, return $ First a), 66 | (1, return $ Second b)] 67 | 68 | 69 | -------------------------------------------------------------------------------- /ch14/ArithmeticTests/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Dorus Leliveld (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 Dorus Leliveld 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. -------------------------------------------------------------------------------- /ch14/ArithmeticTests/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch14/ArithmeticTests/arithmetic.cabal: -------------------------------------------------------------------------------- 1 | name: arithmetic 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Dorus Leliveld 8 | maintainer: dorusleliveld@gmail.com 9 | copyright: 2016 Dorus Leliveld 10 | category: Education 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: Arithmetic 18 | ghc-options: -Wall -fwarn-tabs 19 | build-depends: base 20 | default-language: Haskell2010 21 | 22 | 23 | 24 | test-suite tests 25 | type: exitcode-stdio-1.0 26 | hs-source-dirs: tests 27 | main-is: ArithmeticTests.hs 28 | build-depends: base 29 | , arithmetic 30 | , QuickCheck 31 | ghc-options: -Wall -fwarn-tabs 32 | default-language: Haskell2010 33 | 34 | -------------------------------------------------------------------------------- /ch14/ArithmeticTests/src/Arithmetic.hs: -------------------------------------------------------------------------------- 1 | module Arithmetic where 2 | 3 | 4 | import Data.Char (toUpper) 5 | 6 | 7 | half :: Fractional a => a -> a 8 | half x = x / 2 9 | 10 | halfIdentity :: Fractional a => a -> a 11 | halfIdentity = (*2) . half 12 | 13 | listOrdered :: (Ord a) => [a] -> Bool 14 | listOrdered xs = snd $ foldr go (Nothing, True) xs 15 | where go _ status@(_, False) = status 16 | go y (Nothing, t) = (Just y, t) 17 | go y (Just x, _) = (Just y, x >= y) 18 | 19 | 20 | plusAssociative :: (Eq a, Num a) => a -> a -> a -> Bool 21 | plusAssociative x y z = x + (y + z) == (x + y) + z 22 | 23 | plusCommutative :: (Eq a, Num a) => a -> a -> Bool 24 | plusCommutative x y = x + y == y + x 25 | 26 | multAssociative :: (Eq a, Num a) => a -> a -> a -> Bool 27 | multAssociative x y z = x * (y * z) == (x * y) * z 28 | 29 | multCommutative :: (Eq a, Num a) => a -> a -> Bool 30 | multCommutative x y = x * y == y * x 31 | 32 | powerAssociative :: (Eq a, Integral a) => a -> a -> a -> Bool 33 | powerAssociative x y z = (x ^ y) ^ z == x ^ (y ^ z) 34 | 35 | powerCommutative :: Integral b => b -> b -> Bool 36 | powerCommutative x y = x ^ y == y ^ x 37 | 38 | reverseIdentity :: Eq a => [a] -> Bool 39 | reverseIdentity x = (reverse . reverse) x == x 40 | 41 | dollarSignLaw :: Eq b => (a -> b) -> a -> Bool 42 | dollarSignLaw f a = ($) f a == f a 43 | 44 | takeLength :: Int -> [a] -> Bool 45 | takeLength n xs = length (take n xs) == n 46 | 47 | square :: Double -> Double 48 | square x = x * x 49 | 50 | squareIdentity :: Double -> Double 51 | squareIdentity = square . sqrt 52 | 53 | twice :: (a -> a) -> a -> a 54 | twice f = f . f 55 | 56 | fourTimes :: (a -> a) -> a -> a 57 | fourTimes = twice . twice 58 | 59 | capitalizeWord :: [Char] -> [Char] 60 | capitalizeWord = map toUpper 61 | -------------------------------------------------------------------------------- /ch14/ArithmeticTests/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 | # http://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 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.9 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /ch14/ArithmeticTests/tests/ArithmeticTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Main where 3 | 4 | import Data.List (sort) 5 | import Test.QuickCheck 6 | import Arithmetic 7 | import Text.Show.Functions 8 | 9 | 10 | 11 | prop_halfIdentity :: Property 12 | prop_halfIdentity = forAll 13 | (arbitrary :: Gen Double) 14 | (\x -> halfIdentity x == x) 15 | 16 | prop_listOrdered :: Property 17 | prop_listOrdered = forAll 18 | (arbitrary :: Gen ([Int])) 19 | (listOrdered . sort) 20 | 21 | prop_plusAssociative :: Property 22 | prop_plusAssociative = forAll 23 | (arbitrary :: Gen Int) 24 | plusAssociative 25 | 26 | prop_plusCommutative :: Property 27 | prop_plusCommutative = forAll 28 | (arbitrary :: Gen Int) 29 | plusCommutative 30 | 31 | prop_multAssociative :: Property 32 | prop_multAssociative = forAll 33 | (arbitrary :: Gen Int) 34 | multAssociative 35 | 36 | prop_multCommutative :: Property 37 | prop_multCommutative = forAll 38 | (arbitrary :: Gen Int) 39 | multCommutative 40 | 41 | prop_quotRemLaws :: Property 42 | prop_quotRemLaws = 43 | forAll nonZeroInt $ \x -> 44 | forAll nonZeroInt $ \y -> 45 | (quot x y) * y + (rem x y) == x 46 | 47 | prop_divModLaws :: Property 48 | prop_divModLaws = 49 | forAll nonZeroInt $ \x -> 50 | forAll nonZeroInt $ \y -> 51 | (div x y) * y + (mod x y) == x 52 | 53 | prop_powerAssociative :: Property 54 | prop_powerAssociative = forAll 55 | (arbitrary :: Gen Int) 56 | powerAssociative 57 | 58 | prop_powerCommutative :: Property 59 | prop_powerCommutative = forAll 60 | (arbitrary :: Gen Int) 61 | powerCommutative 62 | 63 | prop_reverseIdentity :: Property 64 | prop_reverseIdentity = forAll 65 | (arbitrary :: Gen [Int]) 66 | reverseIdentity 67 | 68 | -- Taken from QuickCheck Documentation 69 | prop_ComposeAssoc :: (Int -> Int) -> (Int -> Int) -> (Int -> Int) -> Int -> Bool 70 | prop_ComposeAssoc f g h x = 71 | ((f . g) . h) x == (f . (g . h)) x 72 | 73 | -- Analogous to quickCheck compose example 74 | prop_dollarSignLaw :: (Int -> Char) -> Int -> Bool 75 | prop_dollarSignLaw f a = dollarSignLaw f a 76 | 77 | prop_foldrCons :: Property 78 | prop_foldrCons = forAll 79 | (arbitrary :: Gen [Int]) $ 80 | \ x y -> foldr (:) x y == (flip (++)) x y 81 | 82 | prop_foldrConcat :: Property 83 | prop_foldrConcat = forAll 84 | (arbitrary :: Gen [[Int]]) $ 85 | \ x -> foldr (++) [] x == concat x 86 | 87 | prop_takeLength :: Property 88 | prop_takeLength = 89 | forAll (positiveInt) $ \ x -> 90 | forAll (arbitrary :: Gen [Char]) $ \ y -> 91 | takeLength x y 92 | 93 | prop_readShowIsomorphism :: Property 94 | prop_readShowIsomorphism = forAll 95 | (arbitrary :: Gen Int) $ 96 | \ x -> (read . show) x == x 97 | 98 | -- sqrt(-3 * -3) = 3 != 3 99 | -- besides this, floating point is not an exact representation due to the shifting for addition of numbers with different exponents. Guard digits help, for small differences 100 | prop_squreIdentity :: Property 101 | prop_squreIdentity = forAll 102 | (arbitrary :: Gen Double) $ 103 | \ x -> squareIdentity x == id x 104 | 105 | prop_capitalizeIdemPot :: Property 106 | prop_capitalizeIdemPot = forAll 107 | (arbitrary :: Gen String) $ 108 | \x -> 109 | let onceApl = capitalizeWord x 110 | twiceApl = twice capitalizeWord x 111 | friceApl = fourTimes capitalizeWord x 112 | in (onceApl == twiceApl) && (twiceApl == friceApl) 113 | -- once, twice, thrice, frice?? 114 | 115 | prop_sortIdemPot :: Property 116 | prop_sortIdemPot = forAll 117 | (arbitrary :: Gen [Int]) $ 118 | \x -> 119 | let onceApl = sort x 120 | twiceApl = twice sort x 121 | friceApl = fourTimes sort x 122 | in (onceApl == twiceApl) && (twiceApl == friceApl) 123 | 124 | nonZeroInt :: Gen Int 125 | nonZeroInt = (arbitrary :: Gen Int) `suchThat` nonZero 126 | where 127 | nonZero = (/=) 0 128 | 129 | positiveInt :: Gen Int 130 | positiveInt = (arbitrary :: Gen Int) `suchThat` ((flip (>)) 0) 131 | 132 | return [] 133 | runTests :: IO Bool 134 | runTests = $quickCheckAll 135 | 136 | main :: IO () 137 | main = do 138 | _ <- runTests 139 | return () 140 | 141 | 142 | -------------------------------------------------------------------------------- /ch14/Cipher/Cipher.cabal: -------------------------------------------------------------------------------- 1 | name: Cipher 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/Cipher#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author Dorus Leliveld 9 | maintainer: example@example.com 10 | copyright: 2016 Dorus Leliveld 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: Cipher 18 | build-depends: base >= 4.7 && < 5 19 | default-language: Haskell2010 20 | 21 | executable Cipher 22 | hs-source-dirs: app 23 | main-is: Main.hs 24 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 25 | build-depends: base 26 | , Cipher 27 | default-language: Haskell2010 28 | 29 | test-suite tests 30 | hs-source-dirs: tests 31 | main-is: CipherTests.hs 32 | ghc-options: -Wall -fwarn-tabs 33 | build-depends: base 34 | , QuickCheck 35 | , Cipher 36 | type: exitcode-stdio-1.0 37 | -------------------------------------------------------------------------------- /ch14/Cipher/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (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 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. -------------------------------------------------------------------------------- /ch14/Cipher/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch14/Cipher/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Cipher 4 | 5 | import Data.Char 6 | 7 | 8 | 9 | main :: IO () 10 | main = do 11 | putStrLn "Write c, for Caeser and v for vignere" 12 | method <- getLine 13 | putStrLn "Write d for decode or c for code" 14 | mode <- getLine 15 | putStrLn "Present key" 16 | key <- getLine 17 | putStrLn "Present line to be coded/decoded" 18 | phrase <- getLine 19 | putStrLn $ case (method, mode) of 20 | ("c", "c") -> caesar (read key) phrase 21 | ("c", "d") -> unCaesar (read key) phrase 22 | ("v", "c") -> vignere key phrase 23 | ("v", "d") -> unVignere key phrase 24 | _ -> error ("Incorrect input arguments") 25 | 26 | 27 | -------------------------------------------------------------------------------- /ch14/Cipher/src/Cipher.hs: -------------------------------------------------------------------------------- 1 | module Cipher (caesar, unCaesar, vignere, unVignere, Keyphrase) where 2 | 3 | import Data.Char 4 | 5 | type Keyphrase = String 6 | 7 | shiftChar :: Int -> Char -> Char 8 | shiftChar 0 x = x 9 | shiftChar shift x 10 | | ord x + shift > ord 'Z' = shiftChar (shift - 26) x 11 | | ord x + shift < ord 'A' = shiftChar (shift + 26) x 12 | | otherwise = chr $ ord x + shift 13 | 14 | caesar :: Int -> String -> String 15 | caesar shift code = map (shiftChar shift) codeUp 16 | where 17 | codeUp = map toUpper code 18 | 19 | unCaesar :: Int -> String -> String 20 | unCaesar shift code = map (shiftChar $ negate shift) code 21 | 22 | vignere :: Keyphrase -> String -> String 23 | vignere key inp = map (uncurry shiftChar) encodeAmounts 24 | where 25 | upperInp = map toUpper inp 26 | upperKey = map toUpper key 27 | encodeAmounts = shiftAmounts (cycle upperKey) upperInp 28 | 29 | shiftAmounts :: Keyphrase -> String -> [(Int, Char)] 30 | shiftAmounts _ [] = [] 31 | shiftAmounts [] _ = [] 32 | shiftAmounts key@(x:xs) (y:ys) 33 | | isAsciiUpper y = (ord x - ord 'A', y) : shiftAmounts xs ys 34 | | otherwise = (0, y) : shiftAmounts key ys 35 | 36 | unVignere :: Keyphrase -> String -> String 37 | unVignere key code = map (uncurry shiftChar) negShiftAmounts 38 | where 39 | upperCode = map toUpper code 40 | upperKey = map toUpper key 41 | encodeAmounts = shiftAmounts (cycle upperKey) upperCode 42 | negShiftAmounts = map negShiftFunction encodeAmounts 43 | negShiftFunction (a,b) = (negate a, b) 44 | -------------------------------------------------------------------------------- /ch14/Cipher/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 | # http://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 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.7 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /ch14/Cipher/tests/CipherTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Main where 3 | 4 | import Test.QuickCheck 5 | import Cipher 6 | import Data.Char (toUpper) 7 | 8 | genLetter :: Gen Char 9 | genLetter = elements ['a' .. 'z'] 10 | 11 | genLetters :: Gen String 12 | genLetters = listOf genLetter 13 | 14 | prop_caesarIsomorphism :: Property 15 | prop_caesarIsomorphism = 16 | forAll (arbitrary :: Gen Int) $ \ shift -> 17 | forAll (genLetters) $ \ phrase -> 18 | (caesarIdentity shift) phrase == map toUpper phrase 19 | 20 | prop_vignereIsomorphism :: Property 21 | prop_vignereIsomorphism = 22 | forAll (genLetters `suchThat` (not . null)) $ \ key -> 23 | forAll (genLetters) $ \ phrase -> 24 | vignereIdentity key phrase == map toUpper phrase 25 | 26 | caesarIdentity :: Int -> String -> String 27 | caesarIdentity shift = unCaesar shift . caesar shift 28 | 29 | vignereIdentity :: Keyphrase -> String -> String 30 | vignereIdentity key = unVignere key . vignere key 31 | 32 | 33 | return [] 34 | main :: IO () 35 | main = do 36 | _ <- $quickCheckAll 37 | return () 38 | 39 | -------------------------------------------------------------------------------- /ch14/CoArbitrary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module CoArbitrary where 4 | 5 | import GHC.Generics 6 | import Test.QuickCheck 7 | 8 | 9 | data Bool' = 10 | True' 11 | | False' 12 | deriving (Generic) 13 | 14 | instance CoArbitrary Bool' 15 | 16 | 17 | trueGen :: Gen Int 18 | trueGen = coarbitrary True' arbitrary 19 | 20 | falseGen :: Gen Int 21 | falseGen = coarbitrary False' arbitrary 22 | -------------------------------------------------------------------------------- /ch14/WordNumber/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Dorus Leliveld (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 Dorus Leliveld 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. -------------------------------------------------------------------------------- /ch14/WordNumber/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch14/WordNumber/WordNumber.cabal: -------------------------------------------------------------------------------- 1 | name: WordNumber 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/tclv/WordNumber#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Dorus Leliveld 9 | maintainer: dorusleliveld@gmail.com 10 | copyright: 2016 Dorus Leliveld 11 | category: Education 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: WordNumber 19 | build-depends: base >= 4.7 && < 5 20 | default-language: Haskell2010 21 | 22 | test-suite WordNumberTest 23 | type: exitcode-stdio-1.0 24 | hs-source-dirs: tests 25 | main-is: WordNumberTest.hs 26 | build-depends: base 27 | , hspec 28 | , WordNumber 29 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 30 | default-language: Haskell2010 31 | 32 | -------------------------------------------------------------------------------- /ch14/WordNumber/src/WordNumber.hs: -------------------------------------------------------------------------------- 1 | module WordNumber where 2 | 3 | import Data.Char 4 | import Data.List (intersperse) 5 | 6 | digitToWord :: Int -> String 7 | digitToWord 0 = "zero" 8 | digitToWord 1 = "one" 9 | digitToWord 2 = "two" 10 | digitToWord 3 = "three" 11 | digitToWord 4 = "four" 12 | digitToWord 5 = "five" 13 | digitToWord 6 = "six" 14 | digitToWord 7 = "seven" 15 | digitToWord 8 = "eight" 16 | digitToWord 9 = "nine" 17 | 18 | 19 | 20 | digits :: Int -> [Int] 21 | digits n 22 | | n < 10 = [n] 23 | | otherwise = (digits quot) ++ [rem] 24 | where (quot, rem) = quotRem n 10 25 | 26 | wordNumber :: Int -> String 27 | wordNumber n = concat $ intersperse "-" $ map digitToWord $ digits n 28 | 29 | 30 | -------------------------------------------------------------------------------- /ch14/WordNumber/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 | # http://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 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.9 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /ch14/WordNumber/tests/WordNumberTest.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | import WordNumber (digits, digitToWord, wordNumber) 5 | 6 | main :: IO () 7 | main = hspec $ do 8 | describe "digitToWord does what we want" $ do 9 | it "returns zero for 0" $ do 10 | digitToWord 0 `shouldBe` "zero" 11 | it "returns one for 1" $ do 12 | digitToWord 1 `shouldBe` "one" 13 | 14 | describe "digits does what we want" $ do 15 | it "returns [1] for 1" $ do 16 | digits 1 `shouldBe` [1] 17 | it "returns [1, 0 ,0] for 100" $ do 18 | digits 100 `shouldBe` [1, 0, 0] 19 | 20 | describe "wordNumber does what we want" $ do 21 | it "returns one-zero-zero for 100" $ do 22 | wordNumber 100 `shouldBe` "one-zero-zero" 23 | it "returns nine-zero-zero-one for 9001" $ do 24 | wordNumber 9001 `shouldBe` "nine-zero-zero-one" 25 | -------------------------------------------------------------------------------- /ch14/hangman/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (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 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. -------------------------------------------------------------------------------- /ch14/hangman/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch14/hangman/data/.gitignore: -------------------------------------------------------------------------------- 1 | words 2 | -------------------------------------------------------------------------------- /ch14/hangman/hangman.cabal: -------------------------------------------------------------------------------- 1 | name: hangman 2 | version: 0.1.0.0 3 | synopsis: Playing Hangman 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/hangman#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Dorus Leliveld 9 | maintainer: example@example.com 10 | copyright: 2016 Dorus Leliveld 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | executable hangman 16 | main-is: Main.hs 17 | hs-source-dirs: src 18 | build-depends: base >= 4.7 && < 5 19 | , random 20 | , hangman 21 | , split 22 | default-language: Haskell2010 23 | 24 | library 25 | exposed-modules: Hangman 26 | hs-source-dirs: src 27 | build-depends: base >= 4.7 && < 5 28 | default-language: Haskell2010 29 | 30 | test-suite tests 31 | main-is: HangmanTests.hs 32 | hs-source-dirs: tests 33 | build-depends: base 34 | , QuickCheck 35 | , hspec 36 | , hangman 37 | type: exitcode-stdio-1.0 38 | default-language: Haskell2010 39 | -------------------------------------------------------------------------------- /ch14/hangman/src/Hangman.hs: -------------------------------------------------------------------------------- 1 | module Hangman where 2 | 3 | import Data.List (intersperse) 4 | data Puzzle = Puzzle String [Maybe Char] [Char] Int 5 | 6 | instance Show Puzzle where 7 | show (Puzzle _ discovered guessed guessesLeft) = 8 | (intersperse ' ' $ fmap renderPuzzleChar discovered) 9 | ++ " Guessed so far: " ++ guessed ++ " Guesses left: " ++ show guessesLeft 10 | 11 | numberOfGuessesInit :: Int 12 | numberOfGuessesInit = 7 13 | 14 | renderPuzzleChar :: Maybe Char -> Char 15 | renderPuzzleChar Nothing = '_' 16 | renderPuzzleChar (Just a) = a 17 | 18 | charInWord :: Puzzle -> Char -> Bool 19 | charInWord (Puzzle word _ _ _) guess = guess `elem` word 20 | 21 | missedGuess :: Puzzle -> Char -> Puzzle 22 | missedGuess puzzle guess = Puzzle w f m (noG - 1) 23 | where 24 | (Puzzle w f m noG) = fillInCharacter puzzle guess 25 | 26 | alreadyGuessed :: Puzzle -> Char -> Bool 27 | alreadyGuessed (Puzzle _ _ guessedSoFar _) guess = guess `elem` guessedSoFar 28 | 29 | freshPuzzle :: String -> Puzzle 30 | freshPuzzle word = Puzzle word (map (const Nothing) word) [] numberOfGuessesInit 31 | 32 | fillInCharacter :: Puzzle -> Char -> Puzzle 33 | fillInCharacter (Puzzle word filledInSoFar s noG) c = 34 | Puzzle word newFilledInSoFar (c : s) noG 35 | where 36 | zipper guessed wordChar guessChar = 37 | if wordChar == guessed 38 | then Just wordChar 39 | else guessChar 40 | newFilledInSoFar = zipWith (zipper c) word filledInSoFar 41 | 42 | handleGuess :: Puzzle -> Char -> IO Puzzle 43 | handleGuess puzzle guess = do 44 | putStrLn $ "Your guess was: " ++ [guess] 45 | case (charInWord puzzle guess, alreadyGuessed puzzle guess) of 46 | (_, True) -> do 47 | putStrLn "Your already guessed that character, pick something else" 48 | return puzzle 49 | (True, _) -> do 50 | putStrLn "This character was in the word, filling in the word accordingly" 51 | return (fillInCharacter puzzle guess) 52 | (False, _) -> do 53 | putStrLn "This character wasn't in the word, try again" 54 | return (missedGuess puzzle guess) 55 | -------------------------------------------------------------------------------- /ch14/hangman/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | 4 | import Control.Monad (forever) 5 | import Data.Char (toLower) 6 | import Data.Maybe (isJust) 7 | import System.Exit (exitSuccess) 8 | import System.Random (randomRIO) 9 | import Hangman 10 | 11 | -- type WordList = [String] 12 | newtype WordList = 13 | WordList [String] 14 | deriving (Eq, Show) 15 | 16 | 17 | 18 | allWords :: IO WordList 19 | allWords = do 20 | dict <- readFile "data/words" 21 | return $ WordList (lines dict) 22 | 23 | minWordLength :: Int 24 | minWordLength = 5 25 | 26 | maxWordLength :: Int 27 | maxWordLength = 9 28 | 29 | 30 | gameWords :: IO WordList 31 | gameWords = do 32 | (WordList aw) <- allWords 33 | return $ WordList (filter gameLength aw) 34 | where gameLength w = 35 | let l = length w 36 | in l > minWordLength && l < maxWordLength 37 | 38 | randomWord :: WordList -> IO String 39 | randomWord (WordList wl) = do 40 | randomIndex <- randomRIO (0, length wl - 1) 41 | return $ wl !! randomIndex 42 | 43 | randomWord' :: IO String 44 | randomWord' = gameWords >>= randomWord 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | gameOver :: Puzzle -> IO () 54 | gameOver (Puzzle wordToGuess _ guessed noGuesses) = 55 | if (noGuesses) <= 0 then 56 | do putStrLn "You lose!" 57 | putStrLn $ "The word was: " ++ wordToGuess 58 | exitSuccess 59 | else 60 | return () 61 | 62 | gameWin :: Puzzle -> IO () 63 | gameWin (Puzzle _ filledInSoFar _ _) = 64 | if all isJust filledInSoFar then 65 | do putStrLn "You win!" 66 | exitSuccess 67 | else return () 68 | 69 | runGame :: Puzzle -> IO () 70 | runGame puzzle = forever $ do 71 | gameWin puzzle 72 | gameOver puzzle 73 | putStrLn $ "Current puzzle is " ++ show puzzle 74 | putStr "Guess a letter: " 75 | guess <- getLine 76 | case guess of 77 | [c] -> handleGuess puzzle c >>= runGame 78 | _ -> putStrLn "Your guess must be a single character" 79 | 80 | main :: IO () 81 | main = do 82 | word <- randomWord' 83 | let puzzle = freshPuzzle (fmap toLower word) 84 | runGame puzzle 85 | 86 | 87 | -------------------------------------------------------------------------------- /ch14/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 | # http://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 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.7 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /ch14/hangman/tests/HangmanTests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | import Hangman 5 | import Data.List (repeat) 6 | 7 | testPuzzle@(Puzzle word freshGuess emptyCharLog freshNoGuess) = freshPuzzle "haskell" 8 | missCharPuzzle@(Puzzle _ missGuess missCharLog missNoGuess) = fillInCharacter testPuzzle 'x' 9 | 10 | hitCharPuzzle@(Puzzle _ hitGuess hitCharLog hitNoGuess) = fillInCharacter testPuzzle 'a' 11 | 12 | 13 | main :: IO () 14 | main = hspec $ do 15 | describe "HangmanMiss" $ do 16 | it "Should add a letter to played letter list if letter not in word" $ do 17 | missCharLog `shouldBe` ['x'] 18 | it "Should not update filled in list on miss" $ do 19 | missGuess `shouldBe` freshGuess 20 | describe "HangmanHit" $ do 21 | it "Should add a letter to played letter list if letter in word" $ do 22 | hitCharLog `shouldBe` ['a'] 23 | it "Should update filled in list on hit" $ do 24 | hitGuess `shouldBe` [Nothing, Just 'a'] ++ take 5 (repeat Nothing) 25 | 26 | -------------------------------------------------------------------------------- /ch14/morse/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Dorus Leliveld (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 Dorus Leliveld 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. -------------------------------------------------------------------------------- /ch14/morse/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch14/morse/morse.cabal: -------------------------------------------------------------------------------- 1 | name: morse 2 | version: 0.1.0.0 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Dorus Leliveld 6 | maintainer: dorusleliveld@gmail.com 7 | copyright: 2016 Dorus Leliveld 8 | category: Education 9 | build-type: Simple 10 | -- extra-source-files: 11 | cabal-version: >=1.10 12 | 13 | library 14 | hs-source-dirs: src 15 | exposed-modules: Morse 16 | ghc-options: -Wall -fwarn-tabs 17 | build-depends: base >= 4.7 && < 5 18 | , containers 19 | , QuickCheck 20 | default-language: Haskell2010 21 | 22 | executable morse 23 | hs-source-dirs: src 24 | main-is: Main.hs 25 | ghc-options: -Wall -fwarn-tabs 26 | build-depends: base >= 4.7 && < 5 27 | , morse 28 | , containers 29 | , QuickCheck 30 | default-language: Haskell2010 31 | 32 | test-suite tests 33 | ghc-options: -Wall -fno-warn-orphans 34 | type: exitcode-stdio-1.0 35 | main-is: tests.hs 36 | hs-source-dirs: tests 37 | build-depends: base 38 | , containers 39 | , morse 40 | , QuickCheck 41 | default-language: Haskell2010 42 | 43 | -------------------------------------------------------------------------------- /ch14/morse/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (forever, when) 4 | import Data.List (intercalate) 5 | import Morse (stringToMorse, morseToChar) 6 | import System.Environment (getArgs) 7 | import System.Exit (exitFailure, exitSuccess) 8 | import System.IO (hGetLine, hIsEOF, stdin) 9 | 10 | convertToMorse :: IO () 11 | convertToMorse = forever $ do 12 | weAreDone <- hIsEOF stdin 13 | when weAreDone exitSuccess 14 | line <- hGetLine stdin 15 | convertLine line 16 | where 17 | convertLine line = do 18 | let morse = stringToMorse line 19 | case morse of 20 | (Just str) -> putStrLn $ intercalate " " str 21 | Nothing -> do 22 | putStrLn $ "ERROR: " ++ line 23 | exitFailure 24 | 25 | convertFromMorse :: IO () 26 | convertFromMorse = forever $ do 27 | weAreDone <- hIsEOF stdin 28 | when weAreDone exitSuccess 29 | line <- hGetLine stdin 30 | convertLine line 31 | where 32 | convertLine line = do 33 | let decoded :: Maybe String 34 | decoded = traverse morseToChar (words line) 35 | case decoded of 36 | (Just s) -> putStrLn s 37 | Nothing -> do putStrLn $ "ERROR: " ++ line 38 | exitFailure 39 | 40 | 41 | main :: IO () 42 | main = do 43 | mode <- getArgs 44 | case mode of 45 | [arg] -> 46 | case arg of 47 | "from" -> convertFromMorse 48 | "to" -> convertToMorse 49 | _ -> argError 50 | _ -> argError 51 | where argError = do 52 | putStrLn "Please specify the first argument \ 53 | \as being 'from' or 'to' morse,\ 54 | \ such as: morse to" 55 | exitFailure 56 | -------------------------------------------------------------------------------- /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 = M.foldWithKey (flip M.insert) M.empty letterToMorse 56 | 57 | charToMorse :: Char -> Maybe Morse 58 | charToMorse c = M.lookup c letterToMorse 59 | 60 | morseToChar :: Morse -> Maybe Char 61 | morseToChar m = M.lookup m morseToLetter 62 | 63 | stringToMorse :: String -> Maybe [Morse] 64 | stringToMorse s = sequence $ fmap charToMorse s 65 | -------------------------------------------------------------------------------- /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 | # http://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 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.9 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /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 | 8 | allowedChars :: [Char] 9 | allowedChars = M.keys letterToMorse 10 | 11 | allowedMorse :: [Morse] 12 | allowedMorse = M.elems letterToMorse 13 | 14 | charGen :: Gen Char 15 | charGen = elements allowedChars 16 | 17 | morseGen :: Gen Morse 18 | morseGen = elements allowedMorse 19 | 20 | prop_thereAndBackAgain :: Property 21 | prop_thereAndBackAgain = forAll charGen (\c -> ((charToMorse c) >>= morseToChar) == Just c) 22 | 23 | main :: IO () 24 | main = quickCheck prop_thereAndBackAgain 25 | -------------------------------------------------------------------------------- /ch14/randomGenerator.hs: -------------------------------------------------------------------------------- 1 | module RandomGenerator where 2 | 3 | import Test.QuickCheck 4 | 5 | 6 | data Fool = 7 | Fulse 8 | | Frue 9 | deriving (Eq, Show) 10 | 11 | equalProbability :: Gen Fool 12 | equalProbability = do 13 | elements [Fulse, Frue] 14 | 15 | twoThirdProb :: Gen Fool 16 | twoThirdProb = do 17 | frequency [ (1, return $ Frue) 18 | , (2, return $ Fulse) ] 19 | 20 | instance Arbitrary Fool where 21 | arbitrary = twoThirdProb 22 | -- arbitrary = equalProbability 23 | -- depending on which as default 24 | -------------------------------------------------------------------------------- /ch15/First.hs: -------------------------------------------------------------------------------- 1 | module First where 2 | 3 | import Optional 4 | import Data.Monoid 5 | import Test.QuickCheck 6 | 7 | newtype First' a = 8 | First' { getFirst' :: Optional a } 9 | deriving (Eq, Show) 10 | 11 | 12 | instance Arbitrary a => Arbitrary (First' a) where 13 | arbitrary = do 14 | a <- arbitrary 15 | return (First' a) 16 | 17 | instance Monoid (First' a) where 18 | mempty = First' Nada 19 | mappend (First' (Only a)) _ = First' (Only a) 20 | mappend (First' Nada) b = b 21 | 22 | firstMappend :: First' a 23 | -> First' a 24 | -> First' a 25 | firstMappend = mappend 26 | 27 | type FirstMappend = 28 | First' String 29 | -> First' String 30 | -> First' String 31 | -> Bool 32 | 33 | type FstId = 34 | First' String -> Bool 35 | 36 | monoidLeftIdentity :: (Eq a, Monoid a) => a -> Bool 37 | monoidLeftIdentity a = (mempty <> a ) == a 38 | 39 | monoidRightIdentity :: (Eq a, Monoid a) => a -> Bool 40 | monoidRightIdentity a = (a <> mempty) == a 41 | 42 | monoidAssoc :: (Eq a, Monoid a) => a -> a -> a -> Bool 43 | monoidAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c) 44 | 45 | 46 | main :: IO () 47 | main = do 48 | quickCheck (monoidAssoc :: FirstMappend) 49 | quickCheck (monoidLeftIdentity :: FstId) 50 | quickCheck (monoidRightIdentity :: FstId) 51 | -------------------------------------------------------------------------------- /ch15/MadLibbin.hs: -------------------------------------------------------------------------------- 1 | module Madlibbin' where 2 | 3 | 4 | type Verb = String 5 | type Adjective = String 6 | type Adverb = String 7 | type Noun = String 8 | type Exclamation = String 9 | 10 | madlibbin' :: Exclamation 11 | -> Adverb 12 | -> Noun 13 | -> Adjective 14 | -> String 15 | madlibbin' e adv noun adj = mconcat 16 | [e, "! he said ", 17 | adv, " as he jumped into his car ", 18 | noun, " and drove off with his ", 19 | adj, " wife."] 20 | -------------------------------------------------------------------------------- /ch15/Optional.hs: -------------------------------------------------------------------------------- 1 | module Optional where 2 | 3 | import Test.QuickCheck 4 | import Data.Monoid 5 | 6 | data Optional a = 7 | Nada 8 | | Only a 9 | deriving (Eq, Show) 10 | 11 | instance Monoid a => Monoid (Optional a) where 12 | mempty = Nada 13 | mappend Nada (Only a) = Only a 14 | mappend (Only a) (Only b) = Only (a <> b) 15 | mappend (Only a) Nada = Only a 16 | mappend Nada Nada = Nada 17 | 18 | instance Arbitrary a => Arbitrary (Optional a) where 19 | arbitrary = arbitrary >>= \a -> frequency [(1, return Nada), (1, return (Only a))] 20 | -------------------------------------------------------------------------------- /ch15/chapterExercises/Monoid.hs: -------------------------------------------------------------------------------- 1 | module Mon where 2 | 3 | import SG 4 | import Test.QuickCheck 5 | import Data.Monoid hiding ((<>)) 6 | import Data.Semigroup hiding (mappend) 7 | import Text.Show.Functions 8 | 9 | 10 | type LeftIdentity x = x -> Bool 11 | type RightIdentity x = x -> Bool 12 | type FunctionIdentity x a = x -> a -> Bool 13 | 14 | monoidLeftIdentity :: (Monoid m, Semigroup m, Eq m) => LeftIdentity m 15 | monoidLeftIdentity x = mempty <> x == x 16 | 17 | monoidRightIdentity :: (Monoid m, Semigroup m, Eq m) => RightIdentity m 18 | monoidRightIdentity x = x <> mempty == x 19 | 20 | monoidLeftIdentityCombine :: (Eq b, Semigroup b, Monoid b) => FunctionIdentity (Combine a b) a 21 | monoidLeftIdentityCombine f c = unCombine (mempty <> f) c == unCombine f c 22 | 23 | monoidRightIdentityCombine :: (Eq b, Semigroup b, Monoid b) => FunctionIdentity (Combine a b) a 24 | monoidRightIdentityCombine f c = unCombine (f <> mempty) c == unCombine f c 25 | 26 | monoidLeftIdentityComp :: (Eq a, Semigroup a, Monoid a) => FunctionIdentity (Comp a) a 27 | monoidLeftIdentityComp f c = unComp (mempty <> f) c == unComp f c 28 | 29 | monoidRightIdentityComp :: (Eq a, Semigroup a, Monoid a) => FunctionIdentity (Comp a) a 30 | monoidRightIdentityComp f c = unComp (f <> mempty) c == unComp f c 31 | 32 | monoidMemAssoc :: (Eq a, Eq s, Monoid a) => FunctionAssociativity (Mem s a) s 33 | monoidMemAssoc f g h c = runMem ((f `mappend` g) `mappend` h) c == runMem (f `mappend` (g `mappend` h)) c 34 | 35 | monoidLeftIdentityMem :: (Eq a, Eq s, Monoid a) => FunctionIdentity (Mem s a) s 36 | monoidLeftIdentityMem f c = runMem (mempty `mappend` f) c == runMem f c 37 | 38 | monoidRightIdentityMem :: (Eq a, Eq s, Monoid a) => FunctionIdentity (Mem s a) s 39 | monoidRightIdentityMem f c = runMem (f `mappend` mempty) c == runMem f c 40 | 41 | main :: IO () 42 | main = do 43 | quickCheck (semigroupAssoc :: Associativity (Identity String)) 44 | quickCheck (monoidLeftIdentity :: LeftIdentity (Identity String)) 45 | quickCheck (monoidRightIdentity :: RightIdentity (Identity String)) 46 | 47 | quickCheck (semigroupAssoc :: Associativity (Two String String)) 48 | quickCheck (monoidLeftIdentity :: LeftIdentity (Two String String)) 49 | quickCheck (monoidRightIdentity :: RightIdentity (Two String String)) 50 | 51 | quickCheck (semigroupAssoc :: Associativity BoolConj) 52 | quickCheck (monoidLeftIdentity :: LeftIdentity BoolConj) 53 | quickCheck (monoidRightIdentity :: RightIdentity BoolConj) 54 | 55 | quickCheck (semigroupAssoc :: Associativity BoolDisj) 56 | quickCheck (monoidLeftIdentity :: LeftIdentity BoolDisj) 57 | quickCheck (monoidRightIdentity :: RightIdentity BoolDisj) 58 | 59 | quickCheck (semigroupCombineAssoc :: FunctionAssociativity (Combine String String) String) 60 | quickCheck (monoidLeftIdentityCombine :: FunctionIdentity (Combine String String) String) 61 | quickCheck (monoidRightIdentityCombine :: FunctionIdentity (Combine String String) String) 62 | 63 | quickCheck (semigroupCompAssoc :: FunctionAssociativity (Comp String) String) 64 | quickCheck (monoidLeftIdentityComp :: FunctionIdentity (Comp String) String) 65 | quickCheck (monoidRightIdentityComp :: FunctionIdentity (Comp String) String) 66 | 67 | quickCheck (monoidMemAssoc :: FunctionAssociativity (Mem Int String) Int) 68 | quickCheck (monoidLeftIdentityMem :: FunctionIdentity (Mem Int String) Int) 69 | quickCheck (monoidRightIdentityMem :: FunctionIdentity (Mem Int String) Int) 70 | 71 | instance (Monoid a, Semigroup a) => Monoid (Identity a) where 72 | mempty = Identity mempty 73 | mappend = (<>) 74 | 75 | instance (Monoid a, Semigroup a, Monoid b, Semigroup b) => Monoid (Two a b) where 76 | mempty = Two mempty mempty 77 | mappend = (<>) 78 | 79 | instance Monoid BoolConj where 80 | mempty = BoolConj True 81 | mappend = (<>) 82 | 83 | instance Monoid BoolDisj where 84 | mempty = BoolDisj False 85 | mappend = (<>) 86 | 87 | instance (Monoid b, Semigroup b) => Monoid (Combine a b) where 88 | mempty = Combine (const mempty) 89 | mappend = (<>) 90 | 91 | instance (Monoid a, Semigroup a) => Monoid (Comp a) where 92 | mempty = Comp id 93 | mappend = (<>) 94 | 95 | newtype Mem s a = 96 | Mem { runMem :: s -> (a, s) } 97 | 98 | instance (CoArbitrary s, Arbitrary s, Arbitrary a) => Arbitrary (Mem s a) where 99 | arbitrary = do 100 | s <- arbitrary 101 | return $ Mem s 102 | 103 | instance Show (Mem a b) where 104 | show (Mem f) = "Mem " ++ show f 105 | 106 | instance Monoid a => Monoid (Mem s a) where 107 | mappend (Mem f1) (Mem f2) = Mem $ \s -> 108 | let (a', s') = f1 s 109 | (a'', s'') = f2 s' 110 | in (a' `mappend` a'', s'') 111 | mempty = Mem $ \s -> (mempty, s) 112 | -------------------------------------------------------------------------------- /ch15/chapterExercises/SemiGroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module SG where 5 | 6 | import Data.Semigroup 7 | import Test.QuickCheck hiding (Success, Failure) 8 | import Test.QuickCheck.Function 9 | import Text.Show.Functions () 10 | 11 | type Associativity x = x -> x -> x -> Bool 12 | type FunctionAssociativity x c = x -> x -> x -> c -> Bool 13 | 14 | semigroupAssoc :: (Eq m, Semigroup m) => Associativity m 15 | semigroupAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c) 16 | 17 | semigroupCombineAssoc :: (Eq b, Semigroup b) => FunctionAssociativity (Combine a b) a 18 | semigroupCombineAssoc f g h c = unCombine ((f <> g) <> h) c == unCombine (f <> (g <> h)) c 19 | 20 | semigroupCompAssoc :: Eq a => FunctionAssociativity (Comp a) a 21 | semigroupCompAssoc f g h c = unComp ((f <> g) <> h) c == unComp (f <> (g <> h)) c 22 | 23 | 24 | main :: IO () 25 | main = do 26 | quickCheck (semigroupAssoc :: Associativity (Identity String)) 27 | quickCheck (semigroupAssoc :: Associativity (Two String String)) 28 | quickCheck (semigroupAssoc :: Associativity (Three String String String)) 29 | quickCheck (semigroupAssoc :: Associativity (Four String String String String)) 30 | quickCheck (semigroupAssoc :: Associativity BoolConj) 31 | quickCheck (semigroupAssoc :: Associativity BoolDisj) 32 | quickCheck (semigroupAssoc :: Associativity (Or String String)) 33 | quickCheck (semigroupCombineAssoc :: FunctionAssociativity (Combine Int String) Int) 34 | quickCheck (semigroupCompAssoc :: FunctionAssociativity (Comp String) String) 35 | quickCheck (semigroupAssoc :: Associativity (Validation String String)) 36 | quickCheck (semigroupAssoc :: Associativity (AccumulateRight String String)) 37 | quickCheck (semigroupAssoc :: Associativity (AccumulateBoth String String)) 38 | 39 | newtype Identity a = Identity a deriving (Eq, Show, Arbitrary) 40 | 41 | instance Semigroup a => Semigroup (Identity a) where 42 | Identity x <> Identity y = Identity $ x <> y 43 | 44 | data Two a b = Two a b deriving (Eq, Show) 45 | 46 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where 47 | arbitrary = do 48 | x <- arbitrary 49 | y <- arbitrary 50 | return $ Two x y 51 | 52 | instance (Semigroup a, Semigroup b) => Semigroup (Two a b) where 53 | Two x y <> Two w z = Two (x <> w) (y <> z) 54 | 55 | data Three a b c = Three a b c deriving (Eq, Show) 56 | 57 | instance (Arbitrary a, 58 | Arbitrary b, 59 | Arbitrary c) => Arbitrary (Three a b c) where 60 | arbitrary = do 61 | x <- arbitrary 62 | y <- arbitrary 63 | z <- arbitrary 64 | return $ Three x y z 65 | 66 | instance (Semigroup a, 67 | Semigroup b, 68 | Semigroup c) => Semigroup (Three a b c) where 69 | (Three x1 y1 z1) <> (Three x2 y2 z2) = Three (x1 <> x2) (y1 <> y2) (z1 <> z2) 70 | 71 | data Four a b c d = Four a b c d deriving (Eq, Show) 72 | 73 | 74 | instance (Arbitrary a, 75 | Arbitrary b, 76 | Arbitrary c, 77 | Arbitrary d) => Arbitrary (Four a b c d) where 78 | arbitrary = do 79 | Three x y z <- arbitrary 80 | w <- arbitrary 81 | return $ Four x y z w 82 | 83 | instance (Semigroup a, 84 | Semigroup b, 85 | Semigroup c, 86 | Semigroup d) => Semigroup (Four a b c d) where 87 | (Four a b c d) <> (Four e f g h) = Four (a <> e) (b <> f) (c <> g) (d <> h) 88 | 89 | 90 | newtype BoolConj = BoolConj Bool deriving (Eq, Show, Arbitrary) 91 | 92 | instance Semigroup BoolConj where 93 | BoolConj False <> BoolConj _ = BoolConj False 94 | BoolConj True <> BoolConj a = BoolConj a 95 | 96 | newtype BoolDisj = BoolDisj Bool deriving (Eq, Show, Arbitrary) 97 | 98 | instance Semigroup BoolDisj where 99 | BoolDisj True <> BoolDisj _ = BoolDisj True 100 | BoolDisj False <> BoolDisj a = BoolDisj a 101 | 102 | data Or a b = 103 | Fst a 104 | | Snd b deriving (Eq, Show) 105 | 106 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Or a b) where 107 | arbitrary = do 108 | x <- arbitrary 109 | y <- arbitrary 110 | oneof $ map return [Fst x, Snd y] 111 | 112 | instance Semigroup (Or a b) where 113 | Fst _ <> z = z 114 | Snd a <> _ = Snd a 115 | 116 | newtype Combine a b = 117 | Combine { unCombine :: a -> b } 118 | 119 | instance (CoArbitrary a, Arbitrary b) => Arbitrary (Combine a b) where 120 | arbitrary = do 121 | f <- arbitrary 122 | return $ Combine f 123 | 124 | a x = fmap ((flip ($) x ). unCombine) $ generate (arbitrary :: Gen (Combine Int Int)) 125 | 126 | instance (Semigroup b) => Semigroup (Combine a b) where 127 | (Combine f) <> (Combine g) = Combine $ \ x -> f x <> g x 128 | 129 | instance Show (Combine a b) where 130 | show (Combine f) = "Combine " ++ show f 131 | 132 | newtype Comp a = 133 | Comp { unComp :: a -> a } 134 | 135 | instance (CoArbitrary a, Arbitrary a) => Arbitrary (Comp a) where 136 | arbitrary = do 137 | a <- arbitrary 138 | return $ Comp a 139 | 140 | instance Semigroup (Comp a) where 141 | (Comp f) <> (Comp g) = Comp $ f . g 142 | 143 | instance Show (Comp a) where 144 | show (Comp f) = "Comp " ++ show f 145 | 146 | data Validation a b = 147 | Failure a | Success b 148 | deriving (Eq, Show) 149 | 150 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Validation a b) where 151 | arbitrary = do 152 | a <- arbitrary 153 | b <- arbitrary 154 | oneof $ map return [Failure a, Success b] 155 | 156 | instance Semigroup a => Semigroup (Validation a b) where 157 | Failure x <> Failure y = Failure $ x <> y 158 | Failure x <> Success _ = Failure x 159 | Success _ <> y = y 160 | 161 | newtype AccumulateRight a b = 162 | AccumulateRight (Validation a b) 163 | deriving (Eq, Show, Arbitrary) 164 | 165 | instance Semigroup b => Semigroup (AccumulateRight a b) where 166 | AccumulateRight acc <> AccumulateRight acc' = 167 | let res = 168 | case (acc, acc') of 169 | (Success x, Success y) -> Success $ x <> y 170 | (Success _, Failure y) -> Failure y 171 | (Failure x, _) -> Failure x 172 | in AccumulateRight res 173 | 174 | newtype AccumulateBoth a b = 175 | AccumulateBoth (Validation a b) 176 | deriving (Eq, Show, Arbitrary) 177 | 178 | instance (Semigroup a, Semigroup b) => Semigroup (AccumulateBoth a b) where 179 | AccumulateBoth acc <> AccumulateBoth acc' = 180 | let res = 181 | case (acc, acc') of 182 | (Success x, Success y) -> Success $ x <> y 183 | (Failure x, Failure y) -> Failure $ x <> y 184 | (Failure x, _) -> Failure x 185 | (_, Failure y) -> Failure y 186 | in AccumulateBoth res 187 | -------------------------------------------------------------------------------- /ch15/orphan-instance/Listy.hs: -------------------------------------------------------------------------------- 1 | module Listy where 2 | 3 | 4 | newtype Listy a = 5 | Listy [a] 6 | deriving (Eq, Show) 7 | 8 | 9 | instance Monoid (Listy a) where 10 | mempty = Listy [] 11 | mappend (Listy l) (Listy l') = Listy $ mappend l l' 12 | -------------------------------------------------------------------------------- /ch15/orphan-instance/ListyInstances.hs: -------------------------------------------------------------------------------- 1 | module ListyInstances where 2 | 3 | import Data.Monoid 4 | import Listy 5 | 6 | instance Monoid (Listy a) where 7 | mempty = Listy [] 8 | mappend (Listy l) (Listy l') = Listy $ mappend l l' 9 | -------------------------------------------------------------------------------- /ch16/chapterExercises.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | import GHC.Arr 4 | 5 | -- Determine if valid functor 6 | --1. No (need * -> *) 7 | --2. Yes 8 | --3. Yes 9 | --4. 10 | newtype Mu f = InF { outF :: f (Mu f) } -- Some kind of catamorphism, review later 11 | --4. :k Mu = (* -> *) -> * 12 | --no instance available 13 | 14 | -- instance Functor Mu where -- Won't compile 15 | -- fmap = undefined 16 | 17 | data D = -- kind * 18 | D (Array Word Word) Int Int 19 | 20 | -- no instance functor possible due to kind * 21 | 22 | -- Rearrange argument to type constructor for functor to work 23 | -- 1. 24 | 25 | data Sum b a = 26 | First a 27 | | Second b 28 | 29 | instance Functor (Sum e) where 30 | fmap f (First a) = First ( f a) 31 | fmap f (Second b) = Second b 32 | 33 | -- 2. 34 | 35 | data Company a c b = 36 | DeepBlue a c 37 | | Something b 38 | 39 | instance Functor (Company e e') where 40 | fmap f (Something b) = Something (f b) 41 | fmap _ (DeepBlue a c) = DeepBlue a c 42 | 43 | -- 3. 44 | 45 | data More b a = 46 | L a b a 47 | | R b a b 48 | deriving (Eq, Show) 49 | 50 | instance Functor (More x) where 51 | fmap f (L a b a') = L (f a) b (f a') 52 | fmap f (R b a b') = R b (f a) b' 53 | 54 | -- Write down functor instances for the following datatypes: 55 | -- 1. 56 | 57 | data Quant a b = 58 | Finance 59 | | Desk a 60 | | Bloor b 61 | 62 | instance Functor (Quant a) where 63 | fmap f (Bloor b) = Bloor (f b) 64 | fmap _ Finance = Finance 65 | fmap _ (Desk a) = Desk a 66 | {-fmap _ x = x -- Doesnt work, cant deduce the change in the b of Quant a b-} 67 | 68 | -- 2. 69 | 70 | data K a b 71 | = K a 72 | 73 | instance Functor (K a) where 74 | fmap _ (K a) = K a 75 | 76 | -- 3. 77 | 78 | newtype Flip f a b = 79 | Flip (f b a) 80 | deriving (Eq, Show) 81 | 82 | instance Functor (Flip K a) where 83 | fmap f (Flip (K x)) = Flip $ K $ f x 84 | 85 | -- 4. 86 | 87 | data EvilGoateeConst a b = 88 | GoatyConst b 89 | 90 | instance Functor (EvilGoateeConst a) where 91 | fmap f (GoatyConst x) = GoatyConst $ f x 92 | 93 | -- 5. 94 | 95 | data LiftItOut f a = 96 | LiftItOut (f a) 97 | 98 | instance Functor f => Functor (LiftItOut f) where 99 | fmap g (LiftItOut x) = LiftItOut $ fmap g x 100 | 101 | -- 6. 102 | 103 | data Parappa f g a = 104 | DaWrappa (f a) (g a) 105 | 106 | instance (Functor f, Functor g) => Functor (Parappa f g) where 107 | fmap f (DaWrappa x y) = DaWrappa (fmap f x) (fmap f y) 108 | 109 | -- 7. 110 | 111 | data IgnoreOne f g a b = 112 | IgnoreSomething (f a) (g b) 113 | 114 | instance Functor g => Functor (IgnoreOne f g a) where 115 | fmap f (IgnoreSomething x y) = IgnoreSomething x $ fmap f y 116 | 117 | -- 8. 118 | 119 | data Notorious g o a t = 120 | Notorious (g o) (g a) (g t) 121 | 122 | instance Functor g => Functor (Notorious g o a) where 123 | fmap f (Notorious x y z) = Notorious x y $ fmap f z 124 | 125 | -- 9. 126 | 127 | data List a = 128 | Nil 129 | | Cons a (List a) 130 | deriving (Eq, Show) 131 | 132 | instance Functor List where 133 | fmap f Nil = Nil 134 | fmap f (Cons x xs) = Cons (f x) $ fmap f xs 135 | 136 | -- 10. 137 | 138 | data GoatLord a = 139 | NoGoat 140 | | OneGoat a 141 | | MoreGoats (GoatLord a) (GoatLord a) (GoatLord a) 142 | 143 | instance Functor GoatLord where 144 | fmap _ NoGoat = NoGoat 145 | fmap f (OneGoat x) = OneGoat $ f x 146 | fmap f (MoreGoats x y z) = MoreGoats (fmap f x) (fmap f y) (fmap f z) 147 | 148 | -- 11. 149 | 150 | data TalkToMe a = 151 | Halt 152 | | Print String a 153 | | Read (String -> a) 154 | 155 | instance Functor TalkToMe where 156 | fmap _ Halt = Halt 157 | fmap f (Print x a) = Print x $ f a 158 | fmap f (Read g) = Read $ fmap f g 159 | 160 | 161 | -------------------------------------------------------------------------------- /ch16/exercises.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | import Test.QuickCheck.Function 3 | import Control.Applicative 4 | -- Kind exercises 5 | -- 1. a is * 6 | -- 2. b is * -> *, T = * -> * 7 | -- 3. c is * -> * -> * 8 | 9 | 10 | -- fmap1 :: Functor f => (m -> n) -> f m -> f n 11 | -- fmap1 = undefind 12 | -- 13 | -- fmap2 :: Functor g => (x -> y) -> g x -> g y 14 | -- fmap2 = undefined 15 | 16 | -- (.) :: (b -> c) -> (a -> b) -> a -> c 17 | 18 | -- ((f x -> f y) -> f g x -> f g y) -> ((x -> y) -> f x -> f y) -> (x -> y) -> f g x -> f g y 19 | 20 | a_ = fmap (+1) $ read "[1]" :: [Int] 21 | b_ = (fmap . fmap) (++ "lol") (Just ["Hi,", "Hello"]) 22 | c_ = fmap (*2) (\x -> x -2) 23 | d_ = fmap ((return '1' ++) . show) (\x -> [x, 1..3]) 24 | 25 | e_ :: IO Integer 26 | e_ = let ioi = readIO "1" :: IO Integer 27 | changed = fmap (fmap read (fmap ("123" ++) show)) ioi 28 | in fmap (*3) changed 29 | 30 | 31 | type ComposeLaw f a b c = f a -> Fun a b -> Fun b c -> Bool 32 | 33 | functorCompose :: (Eq (f c), Functor f) => ComposeLaw f a b c 34 | functorCompose x (Fun _ f) (Fun _ g) = 35 | (fmap (g . f) x ) == (fmap g . fmap f $ x) 36 | 37 | 38 | main = do 39 | quickCheck (functorCompose :: ComposeLaw Identity Int String Char) 40 | quickCheck (functorCompose :: ComposeLaw Pair Int String Char) 41 | quickCheck (functorCompose :: ComposeLaw (Two Int) Int String Char) 42 | quickCheck (functorCompose :: ComposeLaw (Three Int Int) Int String Char) 43 | quickCheck (functorCompose :: ComposeLaw (Three' Int) Int String Char) 44 | quickCheck (functorCompose :: ComposeLaw (Four Int Int Int) Int String Char) 45 | quickCheck (functorCompose :: ComposeLaw (Four' Int) Int String Char) 46 | quickCheck (functorCompose :: ComposeLaw Possibly Int String Char) 47 | quickCheck (functorCompose :: ComposeLaw (Sum Int) Int String Char) 48 | 49 | newtype Identity a = Identity a deriving (Eq, Show) 50 | 51 | instance Arbitrary a => Arbitrary (Identity a) where 52 | arbitrary = fmap Identity arbitrary 53 | 54 | instance Functor Identity where 55 | fmap f (Identity a) = Identity $ f a 56 | 57 | data Pair a = Pair a a deriving (Eq, Show) 58 | 59 | instance Arbitrary a => Arbitrary (Pair a) where 60 | arbitrary = Pair <$> arbitrary <*> arbitrary 61 | 62 | instance Functor Pair where 63 | fmap f (Pair x y) = Pair (f x) (f y) 64 | 65 | data Two a b = Two a b deriving (Eq, Show) 66 | 67 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where 68 | arbitrary = Two <$> arbitrary <*> arbitrary 69 | 70 | instance Functor (Two a) where 71 | fmap f (Two y x) = Two y (f x) 72 | 73 | data Three a b c = Three a b c deriving (Eq, Show) 74 | 75 | instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (Three a b c) where 76 | arbitrary = liftA3 Three arbitrary arbitrary arbitrary 77 | 78 | instance Functor (Three a b) where 79 | fmap f (Three a b x) = Three a b (f x) 80 | 81 | data Three' a b = Three' a b b deriving (Eq, Show) 82 | 83 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Three' a b) where 84 | arbitrary = liftA3 Three' arbitrary arbitrary arbitrary 85 | 86 | instance Functor (Three' a) where 87 | fmap f (Three' a x y) = Three' a (f x) (f y) 88 | 89 | data Four a b c d = Four a b c d deriving (Eq, Show) 90 | 91 | instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (Four a b c d) where 92 | arbitrary = Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 93 | 94 | instance Functor (Four a b c) where 95 | fmap f (Four a b c x) = Four a b c (f x) 96 | 97 | data Four' a b = Four' a a a b deriving (Eq, Show) 98 | 99 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Four' a b) where 100 | arbitrary = Four' <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 101 | 102 | instance Functor (Four' a) where 103 | fmap f (Four' a b c x) = Four' a b c (f x) 104 | 105 | data Possibly a = 106 | LolNope 107 | | Yeppers a deriving (Eq, Show) 108 | 109 | instance Arbitrary a => Arbitrary (Possibly a) where 110 | arbitrary = frequency [(8, fmap Yeppers arbitrary), (2, return LolNope)] 111 | 112 | instance Functor Possibly where 113 | fmap f (Yeppers a) = Yeppers $ f a 114 | fmap _ LolNope = LolNope 115 | 116 | data Sum a b = First a | Second b deriving (Eq, Show) 117 | 118 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Sum a b) where 119 | arbitrary = oneof [fmap First arbitrary, fmap Second arbitrary] 120 | 121 | instance Functor (Sum a) where 122 | fmap _ (First a) = First a 123 | fmap f (Second b) = Second $ f b 124 | -------------------------------------------------------------------------------- /ch17/ChapterExercises.hs: -------------------------------------------------------------------------------- 1 | module ChapterExercises where 2 | 3 | import Data.Monoid 4 | import Control.Applicative 5 | import Test.QuickCheck 6 | import Test.QuickCheck.Checkers 7 | import Test.QuickCheck.Classes 8 | 9 | {- 10 | - 1. 11 | - 12 | -pure :: a -> [a] 13 | -(<*>) :: [(a -> b)] -> [a] -> [b] 14 | - 15 | - 2. 16 | - 17 | -pure :: a -> IO a 18 | -(<*>) :: IO (a -> b) -> IO a -> IO b 19 | - 20 | - 3. 21 | - 22 | -pure :: Monoid a => b -> (a, b) 23 | -(<*>) :: Monoid c => (c, a -> b) -> (c, a) -> (c, b) 24 | - 25 | - 4. 26 | - 27 | -pure :: a -> (->) e a == a -> (e -> a) == a -> e -> a 28 | -(<*>) :: ((->) e (a -> b)) -> ((->) e a) -> ((->) e b) 29 | -(<*>) :: (e -> (a -> b)) -> (e -> a) -> (e -> b) 30 | -f (<*>) g = \x -> f x $ g x 31 | -} 32 | 33 | 34 | main = do 35 | quickBatch $ functor $ (Pair (1, 2, 3) (1, 2, 3) :: Pair (Int, Int, Int)) 36 | quickBatch $ applicative $ (Pair (1, 2, 3) (1, 2, 3) :: Pair (Int, Int, Int)) 37 | 38 | quickBatch $ functor $ (Two "a" (1, 2, 3) :: Two String (Int, Int, Int)) 39 | quickBatch $ applicative $ (Two "a" (1, 2, 3) :: Two String (Int, Int, Int)) 40 | 41 | quickBatch $ functor $ (Three "a" 1 (1, 2, 3) :: Three String (Sum Int) (Int, Int, Int)) 42 | quickBatch $ applicative $ (Three "a" 2 (1, 2, 3) :: Three String (Sum Int) (Int, Int, Int)) 43 | 44 | quickBatch $ functor $ (Three' "a" (1, 2, 3) (1, 2, 3) :: Three' String (Int, Int, Int)) 45 | quickBatch $ applicative $ (Three' "a" (1, 2, 3) (1, 2, 3) :: Three' String (Int, Int, Int)) 46 | 47 | quickBatch $ functor $ (Four "a" "a" 1 (1, 2, 3) :: Four String String (Sum Int) (Int, Int, Int)) 48 | quickBatch $ applicative $ (Four "a" "a" 2 (1, 2, 3) :: Four String String (Sum Int) (Int, Int, Int)) 49 | 50 | quickBatch $ functor $ (Four' "a" "a" (1, 2, 3) (1, 2, 3) :: Four' String (Int, Int, Int)) 51 | quickBatch $ applicative $ (Four' "a" "a"(1, 2, 3) (1, 2, 3) :: Four' String (Int, Int, Int)) 52 | 53 | instance Arbitrary a => Arbitrary (Sum a) where 54 | arbitrary = fmap Sum arbitrary 55 | 56 | data Pair a = Pair a a deriving (Eq, Show) 57 | 58 | instance Arbitrary a => Arbitrary (Pair a) where 59 | arbitrary = liftA2 Pair arbitrary arbitrary 60 | 61 | instance Eq a => EqProp (Pair a) where 62 | (=-=) = eq 63 | 64 | instance Functor Pair where 65 | fmap f (Pair a b) = Pair (f a) (f b) 66 | 67 | instance Applicative Pair where 68 | pure x = Pair x x 69 | Pair f g <*> Pair x y = Pair (f x) (g y) 70 | 71 | data Two a b = Two a b deriving (Eq, Show) 72 | 73 | instance Functor (Two a) where 74 | fmap f (Two x y) = Two x $ f y 75 | 76 | instance (Eq a, Eq b) => EqProp (Two a b) where 77 | (=-=) = eq 78 | 79 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where 80 | arbitrary = liftA2 Two arbitrary arbitrary 81 | 82 | instance Monoid a => Applicative (Two a) where 83 | pure = Two mempty 84 | Two a f <*> Two a' x = Two (a `mappend` a') $ f x 85 | 86 | data Three a b c = Three a b c deriving (Eq, Show) 87 | 88 | instance Functor (Three a b) where 89 | fmap f (Three a b x) = Three a b $ f x 90 | 91 | instance (Eq a, Eq b, Eq c) => EqProp (Three a b c) where 92 | (=-=) = eq 93 | 94 | instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (Three a b c) where 95 | arbitrary = liftA3 Three arbitrary arbitrary arbitrary 96 | 97 | instance (Monoid a, Monoid b) => Applicative (Three a b) where 98 | pure = Three mempty mempty 99 | Three a b f <*> Three a' b' x = Three (a `mappend` a') (b `mappend` b') $ f x 100 | 101 | data Three' a b = Three' a b b deriving (Eq, Show) 102 | 103 | instance Functor (Three' a) where 104 | fmap f (Three' a x x') = Three' a (f x) (f x') 105 | 106 | instance (Eq a, Eq b) => EqProp (Three' a b) where 107 | (=-=) = eq 108 | 109 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Three' a b) where 110 | arbitrary = liftA3 Three' arbitrary arbitrary arbitrary 111 | 112 | instance (Monoid a) => Applicative (Three' a) where 113 | pure x = Three' mempty x x 114 | Three' a f g <*> Three' a' x y = Three' (a `mappend` a') (f x) (g y) 115 | 116 | data Four a b c d = Four a b c d deriving (Eq, Show) 117 | 118 | instance Functor (Four a b c) where 119 | fmap f (Four a b c x) = Four a b c $ f x 120 | 121 | instance (Eq a, Eq b, Eq c, Eq d) => EqProp (Four a b c d) where 122 | (=-=) = eq 123 | 124 | instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (Four a b c d) where 125 | arbitrary = Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 126 | 127 | instance (Monoid a, Monoid b, Monoid c) => Applicative (Four a b c) where 128 | pure = Four mempty mempty mempty 129 | Four a b c f <*> Four a' b' c' x = Four (a `mappend` a') (b `mappend` b') (c `mappend` c') $ f x 130 | 131 | data Four' a b = Four' a a b b deriving (Eq, Show) 132 | 133 | instance Functor (Four' a) where 134 | fmap f (Four' a a' x x') = Four' a a' (f x) (f x') 135 | 136 | instance (Eq a, Eq b) => EqProp (Four' a b) where 137 | (=-=) = eq 138 | 139 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Four' a b) where 140 | arbitrary = Four' <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 141 | 142 | instance (Monoid a) => Applicative (Four' a) where 143 | pure x = Four' mempty mempty x x 144 | Four' a b f g <*> Four' a' b' x y = Four' (a `mappend` a') (b `mappend` b') (f x) (g y) 145 | -------------------------------------------------------------------------------- /ch17/Constant.hs: -------------------------------------------------------------------------------- 1 | module Constant where 2 | 3 | import Data.Monoid 4 | import Test.QuickCheck 5 | import Test.QuickCheck.Checkers 6 | import Test.QuickCheck.Classes 7 | 8 | newtype Constant a b = 9 | Constant { getConstant :: a } 10 | deriving (Eq, Ord, Show) 11 | 12 | instance Functor (Constant a) where 13 | fmap _ (Constant a) = Constant a 14 | 15 | instance Monoid a => Applicative (Constant a) where 16 | pure = const $ Constant mempty 17 | Constant x <*> Constant y = Constant $ x <> y 18 | 19 | main :: IO () 20 | main = quickBatch $ applicative $ (Constant "b" :: Constant String (String, String, String)) 21 | 22 | instance Arbitrary a => Arbitrary (Constant a b) where 23 | arbitrary = fmap Constant arbitrary 24 | 25 | instance Eq a => EqProp (Constant a b) where 26 | (=-=) = eq 27 | -------------------------------------------------------------------------------- /ch17/Identity.hs: -------------------------------------------------------------------------------- 1 | module Identity where 2 | 3 | newtype Identity a = Identity a 4 | deriving (Eq, Ord, Show) 5 | 6 | instance Functor Identity where 7 | fmap f (Identity a) = Identity $ f a 8 | 9 | instance Applicative Identity where 10 | pure = Identity 11 | Identity f <*> Identity x = Identity $ f x 12 | -------------------------------------------------------------------------------- /ch17/List.hs: -------------------------------------------------------------------------------- 1 | module List where 2 | 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Checkers 5 | import Test.QuickCheck.Classes 6 | 7 | data List a = 8 | Nil 9 | | Cons a (List a) 10 | deriving (Eq, Show) 11 | 12 | instance Arbitrary a => Arbitrary (List a) where 13 | arbitrary = oneof [Cons <$> arbitrary <*> arbitrary, return Nil] 14 | 15 | instance (Eq a) => EqProp (List a) where 16 | (=-=) = eq 17 | 18 | instance Functor List where 19 | fmap _ Nil = Nil 20 | fmap f (Cons x xs) = Cons (f x) $ fmap f xs 21 | 22 | instance Applicative List where 23 | pure = flip Cons Nil 24 | fs <*> xs = flatMap (<$> xs) fs 25 | 26 | append :: List a -> List a -> List a 27 | append Nil ys = ys 28 | append (Cons x xs) ys = Cons x $ xs `append` ys 29 | 30 | fold :: (a -> b -> b) -> b -> List a -> b 31 | fold _ b Nil = b 32 | fold f b (Cons h t) = f h (fold f b t) 33 | 34 | concat' :: List (List a) -> List a 35 | concat' = fold append Nil 36 | 37 | flatMap :: (a -> List b) -> List a -> List b 38 | flatMap f = concat' . fmap f 39 | 40 | main :: IO () 41 | main = do 42 | quickBatch $ functor $ Cons ('a', 'b', 'c') Nil 43 | quickBatch $ applicative $ Cons ('a', 'b', 'c') Nil 44 | 45 | quickBatch $ functor $ ZipList' $ Cons ('a', 'b', 'c') Nil 46 | quickBatch $ applicative $ ZipList' $ Cons ('a', 'b', 'c') Nil 47 | 48 | 49 | take' :: Int -> List a -> List a 50 | take' n xs 51 | | n <= 0 = Nil 52 | | otherwise = case (xs) of 53 | Cons x xs -> Cons x $ take' (n - 1) xs 54 | Nil -> Nil 55 | 56 | newtype ZipList' a = 57 | ZipList' (List a) 58 | deriving (Eq, Show) 59 | 60 | instance Arbitrary a => Arbitrary (ZipList' a) where 61 | arbitrary = fmap ZipList' arbitrary 62 | 63 | instance Eq a => EqProp (ZipList' a) where 64 | xs =-= ys = xs' `eq` ys' 65 | where xs' = let (ZipList' l) = xs 66 | in take' 3000 l 67 | ys' = let (ZipList' l) = ys 68 | in take' 3000 l 69 | 70 | instance Functor ZipList' where 71 | fmap f (ZipList' xs) = ZipList' $ fmap f xs 72 | 73 | instance Applicative ZipList' where 74 | pure = ZipList' . repeat' 75 | ZipList' a <*> ZipList' b = ZipList' $ zipWith' ($) a b 76 | 77 | repeat' :: a -> List a 78 | repeat' x = Cons x $ repeat' x 79 | 80 | zipWith' :: (a -> b -> c) -> List a -> List b -> List c 81 | zipWith' f (Cons x xs) (Cons y ys) = Cons (f x y) $ zipWith' f xs ys 82 | zipWith' _ _ _ = Nil 83 | 84 | zip' :: List a -> List b -> List (a, b) 85 | zip' = zipWith' (,) 86 | -------------------------------------------------------------------------------- /ch17/LookUps.hs: -------------------------------------------------------------------------------- 1 | module LookUps where 2 | 3 | import Control.Applicative 4 | import Data.List (elemIndex) 5 | 6 | -- 1. 7 | 8 | added :: Maybe Integer 9 | added = fmap (+3) (lookup 3 $ zip [1, 2, 3] [4, 5, 6]) 10 | 11 | -- 2. 12 | 13 | y :: Maybe Integer 14 | y = lookup 3 $ zip [1, 2, 3] [4, 5, 6] 15 | 16 | z :: Maybe Integer 17 | z = lookup 2 $ zip [1, 2, 3] [4, 5, 6] 18 | 19 | tupled :: Maybe (Integer, Integer) 20 | tupled = (,) <$> y <*> z 21 | 22 | -- 3. 23 | 24 | x3 :: Maybe Int 25 | x3 = elemIndex 3 [1 .. 5] 26 | 27 | y3 :: Maybe Int 28 | y3 = elemIndex 4 [1 .. 5] 29 | 30 | max' :: Int -> Int -> Int 31 | max' = max 32 | 33 | maxed :: Maybe Int 34 | maxed = max' <$> x3 <*> y3 35 | 36 | -- 4. 37 | 38 | xs, ys :: [Integer] 39 | xs = [1, 2, 3] 40 | ys = [4, 5, 6] 41 | 42 | x4 :: Maybe Integer 43 | x4 = lookup 3 $ zip xs ys 44 | 45 | y4 :: Maybe Integer 46 | y4 = lookup 2 $ zip xs ys 47 | 48 | summed :: Maybe Integer 49 | summed = fmap sum $ (,) <$> x4 <*> y4 50 | -------------------------------------------------------------------------------- /ch17/Validation.hs: -------------------------------------------------------------------------------- 1 | module Validation where 2 | 3 | import Test.QuickCheck hiding (Failure, Success) 4 | import Test.QuickCheck.Checkers 5 | import Test.QuickCheck.Classes 6 | 7 | data Validation e a = 8 | Failure e 9 | | Success a 10 | deriving (Eq, Show) 11 | 12 | instance Functor (Validation e) where 13 | fmap _ (Failure e) = Failure e 14 | fmap f (Success a) = Success $ f a 15 | 16 | instance Monoid e => Applicative (Validation e) where 17 | pure x = Success x 18 | Failure a <*> Failure b = Failure $ a `mappend` b 19 | Success f <*> Success a = Success $ f a 20 | Failure a <*> _ = Failure a 21 | _ <*> Failure a = Failure a 22 | 23 | 24 | instance (Arbitrary e, Arbitrary a) => Arbitrary (Validation e a) where 25 | arbitrary = oneof [Success <$> arbitrary, Failure <$> arbitrary] 26 | 27 | instance (Eq a, Eq e) => EqProp (Validation e a) where 28 | (=-=) = eq 29 | 30 | main = do 31 | quickBatch $ applicative $ (Success ("a", "b", "c") :: Validation String (String, String, String)) 32 | 33 | -------------------------------------------------------------------------------- /ch17/VowelsStops.hs: -------------------------------------------------------------------------------- 1 | module VowelsStops where 2 | 3 | import Control.Applicative (liftA3) 4 | 5 | stops :: String 6 | stops = "pbtdkg" 7 | 8 | vowels :: String 9 | vowels = "aeiou" 10 | 11 | combos :: [a] -> [b] -> [c] -> [(a, b, c)] 12 | combos = liftA3 (,,) 13 | -------------------------------------------------------------------------------- /ch17/ZipList.hs: -------------------------------------------------------------------------------- 1 | module ZipList where 2 | 3 | import Control.Applicative 4 | import Data.Monoid 5 | import Test.QuickCheck 6 | import Test.QuickCheck.Checkers 7 | import Test.QuickCheck.Classes 8 | 9 | instance Monoid a => Monoid (ZipList a) where 10 | mempty = pure mempty 11 | mappend = liftA2 mappend 12 | 13 | instance Arbitrary a => Arbitrary (ZipList a) where 14 | arbitrary = ZipList <$> arbitrary 15 | 16 | instance Arbitrary a => Arbitrary (Sum a) where 17 | arbitrary = Sum <$> arbitrary 18 | 19 | instance Eq a => EqProp (ZipList a) where 20 | (=-=) = eq 21 | 22 | main = quickBatch $ monoid $ (ZipList [1 :: Sum Int]) 23 | -------------------------------------------------------------------------------- /ch18/ChapterExercises.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | import Test.QuickCheck.Classes 3 | import Test.QuickCheck.Checkers 4 | 5 | main :: IO () 6 | main = do 7 | quickBatch $ functor $ (NopeDotJpg :: Nope (Int, String, Int)) 8 | quickBatch $ applicative $ (NopeDotJpg :: Nope (Int, String, Int)) 9 | quickBatch $ monad $ (NopeDotJpg :: Nope (Int, String, Int)) 10 | 11 | quickBatch $ functor $ (L "a" :: E String (Int, Int, Int)) 12 | quickBatch $ applicative $ (L "a" :: E String (Int, Int, Int)) 13 | quickBatch $ monad $ (L "a" :: E String (Int, Int, Int)) 14 | 15 | quickBatch $ functor $ (Identity (1, 2, 3) :: Identity (Int, Int, Int)) 16 | quickBatch $ applicative $ (Identity (1, 2, 3) :: Identity (Int, Int, Int)) 17 | quickBatch $ monad $ (Identity (1, 2, 3) :: Identity (Int, Int, Int)) 18 | 19 | quickBatch $ functor $ Cons ('a', 'b', 'c') Nil 20 | quickBatch $ applicative $ Cons ('a', 'b', 'c') Nil 21 | quickBatch $ monad $ Cons ('a', 'b', 'c') Nil 22 | 23 | data Nope a = 24 | NopeDotJpg 25 | deriving (Eq, Show) 26 | 27 | instance Arbitrary (Nope a) where 28 | arbitrary = pure NopeDotJpg 29 | 30 | instance EqProp (Nope a) where 31 | (=-=) = eq 32 | 33 | instance Functor Nope where 34 | fmap _ NopeDotJpg = NopeDotJpg 35 | 36 | instance Applicative Nope where 37 | pure = const NopeDotJpg 38 | NopeDotJpg <*> NopeDotJpg = NopeDotJpg 39 | 40 | instance Monad Nope where 41 | NopeDotJpg >>= _ = NopeDotJpg 42 | 43 | data E e a = 44 | L e 45 | | R a 46 | deriving (Eq, Show) 47 | 48 | instance (Arbitrary a, Arbitrary e) => Arbitrary (E e a) where 49 | arbitrary = oneof [L <$> arbitrary, R <$> arbitrary] 50 | 51 | instance (Eq a, Eq e) => EqProp (E e a) where 52 | (=-=) = eq 53 | 54 | instance Functor (E e) where 55 | fmap _ (L e) = L e 56 | fmap f (R x) = R $ f x 57 | 58 | instance Applicative (E e) where 59 | pure = R 60 | R f <*> R x = R $ f x 61 | L e <*> _ = L e 62 | _ <*> L e = L e 63 | 64 | instance Monad (E e) where 65 | -- return = pure -- Not required for min. compl. def. 66 | R x >>= f = f x 67 | L e >>= _ = L e 68 | 69 | newtype Identity a = Identity a 70 | deriving (Eq, Show) 71 | 72 | instance Arbitrary a => Arbitrary (Identity a) where 73 | arbitrary = fmap Identity arbitrary 74 | 75 | instance (Eq a) => EqProp (Identity a) where 76 | (=-=) = eq 77 | 78 | instance Functor Identity where 79 | fmap f (Identity x) = Identity $ f x 80 | 81 | instance Applicative Identity where 82 | pure = Identity 83 | Identity f <*> Identity x = Identity $ f x 84 | 85 | instance Monad Identity where 86 | Identity x >>= f = f x 87 | 88 | data List a = 89 | Nil 90 | | Cons a (List a) 91 | deriving (Eq, Show) 92 | 93 | instance Arbitrary a => Arbitrary (List a) where 94 | arbitrary = oneof [Cons <$> arbitrary <*> arbitrary, return Nil] 95 | 96 | instance (Eq a) => EqProp (List a) where 97 | (=-=) = eq 98 | 99 | instance Functor List where 100 | fmap _ Nil = Nil 101 | fmap f (Cons x xs) = Cons (f x) $ fmap f xs 102 | 103 | instance Applicative List where 104 | pure = flip Cons Nil 105 | fs <*> xs = flatMap (<$> xs) fs 106 | 107 | instance Monad List where 108 | xs >>= f = flatMap f xs 109 | 110 | append :: List a -> List a -> List a 111 | append Nil ys = ys 112 | append (Cons x xs) ys = Cons x $ xs `append` ys 113 | 114 | fold :: (a -> b -> b) -> b -> List a -> b 115 | fold _ b Nil = b 116 | fold f b (Cons h t) = f h (fold f b t) 117 | 118 | concat' :: List (List a) -> List a 119 | concat' = fold append Nil 120 | 121 | flatMap :: (a -> List b) -> List a -> List b 122 | flatMap f = concat' . fmap f 123 | -------------------------------------------------------------------------------- /ch18/Either.hs: -------------------------------------------------------------------------------- 1 | module Either where 2 | 3 | data E e a = 4 | L e 5 | | R a 6 | deriving (Eq, Show) 7 | 8 | instance Functor (E e) where 9 | fmap _ (L e) = L e 10 | fmap f (R x) = R $ f x 11 | 12 | instance Applicative (E e) where 13 | pure = R 14 | R f <*> R x = R $ f x 15 | L e <*> _ = L e 16 | _ <*> L e = L e 17 | 18 | instance Monad (E e) where 19 | -- return = pure -- Not required for min. compl. def. 20 | R x >>= f = f x 21 | L e >>= _ = L e 22 | -------------------------------------------------------------------------------- /ch18/MonadFunctorFunctions.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | j :: Monad m => m (m a) -> m a 4 | j = (>>= id) -- equivalent to join 5 | -- j = join -- definition 6 | 7 | l1 :: Monad m => (a -> b) -> m a -> m b 8 | l1 f = (>>= return . f) -- equivalent fmap 9 | 10 | ap' :: Monad m => m (a -> b) -> m a -> m b 11 | ap' f x = x >>= (\x -> f >>= (\f -> (return . f) x)) 12 | -- equivalent to ap/<*> 13 | 14 | l2 :: Monad m => (a -> b -> c) -> m a -> m b -> m c 15 | l2 f x y = l1 f x `ap` y 16 | 17 | a :: Monad m => m a -> m (a -> b) -> m b 18 | a = flip ap 19 | 20 | meh :: Monad m => [a] -> (a -> m b) -> m [b] 21 | meh xs f = foldr ap' (pure []) $ (l1 . l1) (:) (l1 f xs) 22 | 23 | -- Does not require Monad 24 | mehA :: Applicative f => [a] -> (a -> f b) -> f [b] 25 | mehA xs f = foldr (<*>) (pure []) $ (fmap . fmap) (:) (fmap f xs) 26 | 27 | flipType :: (Monad m) => [m a] -> m [a] 28 | flipType = flip meh id 29 | -------------------------------------------------------------------------------- /ch19/shawty-prime/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Chris Allen (c) 2015 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. -------------------------------------------------------------------------------- /ch19/shawty-prime/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ch19/shawty-prime/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad (replicateM) 6 | import Control.Monad.IO.Class (liftIO) 7 | import qualified Data.ByteString.Char8 as BC 8 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 9 | import qualified Data.Text.Lazy as TL 10 | import qualified Database.Redis as R 11 | import Network.URI (URI, parseURI) 12 | import qualified System.Random as SR 13 | import Web.Scotty 14 | 15 | alphaNum :: String 16 | alphaNum = ['A'..'Z'] ++ ['0'..'9'] 17 | 18 | randomElement :: String -> IO Char 19 | randomElement xs = do 20 | let maxIndex :: Int 21 | maxIndex = length xs - 1 22 | -- Right of arrow is IO Int, so randomDigit is Int 23 | randomDigit <- SR.randomRIO (0, maxIndex) :: IO Int 24 | return (xs !! randomDigit) 25 | 26 | shortyGen :: R.Connection -> IO (Either R.Reply (String)) 27 | shortyGen conn = do 28 | hash <- replicateM 7 (randomElement alphaNum) 29 | existance <- R.runRedis conn $ R.exists (BC.pack hash) 30 | case existance of 31 | Left error -> return $ Left error 32 | Right existance' -> 33 | if existance' 34 | then shortyGen conn 35 | else return $ Right hash 36 | 37 | 38 | 39 | saveURI :: R.Connection 40 | -> BC.ByteString 41 | -> BC.ByteString 42 | -> IO (Either R.Reply R.Status) 43 | saveURI conn shortURI uri = 44 | R.runRedis conn $ R.set shortURI uri 45 | 46 | getURI :: R.Connection 47 | -> BC.ByteString 48 | -> IO (Either R.Reply (Maybe BC.ByteString)) 49 | getURI conn shortURI = R.runRedis conn $ R.get shortURI 50 | 51 | linkShorty :: String -> String 52 | linkShorty shorty = 53 | concat [ "Copy and paste your short URL" 56 | ] 57 | 58 | shortyCreated :: Show a => a -> String -> TL.Text 59 | shortyCreated resp shawty = 60 | TL.concat [ TL.pack (show resp) 61 | , " shorty is: ", TL.pack (linkShorty shawty) 62 | ] 63 | 64 | shortyAintUri :: TL.Text -> TL.Text 65 | shortyAintUri uri = 66 | TL.concat [ uri 67 | , " wasn't a url, did you forget http://?" 68 | ] 69 | 70 | shortyFound :: TL.Text -> TL.Text 71 | shortyFound tbs = 72 | TL.concat ["", tbs, ""] 73 | 74 | app :: R.Connection 75 | -> ScottyM () 76 | app rConn = do 77 | get "/" $ do 78 | uri <- param "uri" 79 | let parsedUri :: Maybe URI 80 | parsedUri = parseURI (TL.unpack uri) 81 | case parsedUri of 82 | Just _ -> do 83 | gen <- liftIO $ shortyGen rConn 84 | case gen of 85 | Right shawty -> do 86 | let shorty = BC.pack shawty 87 | uri' = encodeUtf8 (TL.toStrict uri) 88 | resp <- liftIO (saveURI rConn shorty uri') 89 | html (shortyCreated resp shawty) 90 | Left error -> 91 | text (TL.pack (show error)) 92 | Nothing -> text (shortyAintUri uri) 93 | get "/:short" $ do 94 | short <- param "short" 95 | uri <- liftIO (getURI rConn short) 96 | case uri of 97 | Left reply -> text (TL.pack (show reply)) 98 | Right mbBS -> case mbBS of 99 | Nothing -> text "uri not found" 100 | Just bs -> html (shortyFound tbs) 101 | where tbs :: TL.Text 102 | tbs = TL.fromStrict (decodeUtf8 bs) 103 | 104 | main :: IO () 105 | main = do 106 | rConn <- R.connect R.defaultConnectInfo 107 | scotty 3000 (app rConn) 108 | -------------------------------------------------------------------------------- /ch19/shawty-prime/shawty.cabal: -------------------------------------------------------------------------------- 1 | name: shawty 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: http://github.com/bitemyapp/shawty#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Chris Allen 9 | maintainer: cma@bitemyapp.com 10 | copyright: 2015, Chris Allen 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | executable shawty 16 | hs-source-dirs: app 17 | main-is: Main.hs 18 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 19 | build-depends: base 20 | , bytestring 21 | , hedis 22 | , mtl 23 | , network-uri 24 | , random 25 | , scotty 26 | , semigroups 27 | , text 28 | , transformers 29 | default-language: Haskell2010 30 | 31 | source-repository head 32 | type: git 33 | location: https://github.com/bitemyapp/shawty-prime 34 | -------------------------------------------------------------------------------- /ch19/shawty-prime/stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-3.7 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 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: >= 0.1.4.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 | -------------------------------------------------------------------------------- /ch20/ChapterExercises.hs: -------------------------------------------------------------------------------- 1 | module ChapterExercises where 2 | 3 | import Data.Monoid 4 | import Data.Foldable 5 | 6 | data Constant a b = 7 | Constant a 8 | deriving (Eq, Show) 9 | 10 | 11 | -- (Monoid m, Foldable (Constant a)) => (a -> m) -> ((Constant a) b) -> m 12 | instance Foldable (Constant a) where 13 | foldMap f (Constant a) = mempty 14 | 15 | data Two a b = 16 | Two a b 17 | deriving (Eq, Show) 18 | 19 | instance Foldable (Two a) where 20 | foldMap f (Two a b) = f b 21 | 22 | data Three a b c = 23 | Three a b c 24 | deriving (Eq, Show) 25 | 26 | instance Foldable (Three a b) where 27 | foldMap f (Three a b c) = f c 28 | 29 | data Three' a b = 30 | Three' a b b 31 | deriving (Eq, Show) 32 | 33 | instance Foldable (Three' a) where 34 | foldMap f (Three' a b b') = f b <> f b' 35 | 36 | data Four' a b = 37 | Four' a b b b 38 | deriving (Eq, Show) 39 | 40 | instance Foldable (Four' a) where 41 | foldMap f (Four' a b b' b'') = f b <> f b' <> f b'' 42 | 43 | filterF :: (Applicative f, Foldable t, Monoid (f a)) => (a -> Bool) -> t a -> f a 44 | filterF f = foldMap pure . filter f . toList 45 | -------------------------------------------------------------------------------- /ch20/LibraryFunctions.hs: -------------------------------------------------------------------------------- 1 | module LibraryFunctions where 2 | 3 | import Prelude hiding (maximum, minimum, sum, product, null, length) 4 | 5 | import Data.Monoid 6 | import Data.Semigroup hiding (First, getFirst, (<>)) 7 | 8 | 9 | sum :: (Foldable t, Num a) => t a -> a 10 | sum = getSum . foldMap Sum 11 | 12 | product :: (Foldable t, Num a) => t a -> a 13 | product = getProduct . foldMap Product 14 | 15 | elem :: (Foldable t, Eq a) => a -> t a -> Bool 16 | elem x = getAny . foldMap (Any . (x ==)) 17 | 18 | minimum :: (Foldable t, Ord a) => t a -> Maybe a 19 | minimum = fmap getMin . getOption . foldMap (Option . Just . Min) 20 | 21 | maximum :: (Foldable t, Ord a) => t a -> Maybe a 22 | maximum = fmap getMax . getOption . foldMap (Option . Just . Max) 23 | 24 | null :: (Foldable t) => t a -> Bool 25 | null = getAll . foldMap (const (All False)) 26 | 27 | length :: (Foldable t) => t a -> Int 28 | length = getSum . foldMap (const (Sum 1)) 29 | 30 | toList :: (Foldable t) => t a -> [a] 31 | -- toList = foldMap (: []) 32 | toList = foldr (:) [] -- probably better 33 | 34 | fold :: (Foldable t, Monoid m) => t m -> m 35 | fold = foldMap id 36 | 37 | foldMap' :: (Monoid m, Foldable t) => (a -> m) -> t a -> m 38 | foldMap' f = foldr ((<>) . f) mempty 39 | -------------------------------------------------------------------------------- /ch21/ChapterExercises.hs: -------------------------------------------------------------------------------- 1 | module ChapterExercises where 2 | 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Classes 5 | import Test.QuickCheck.Checkers 6 | 7 | import Control.Applicative 8 | import Data.Monoid 9 | 10 | type T1 = Identity 11 | type T2 = Constant Int 12 | type T3 = Optional 13 | type T4 = List 14 | type T5 = Three Int Int 15 | type T6 = Three' Int 16 | type T7 = S Maybe 17 | type T8 = Tree 18 | 19 | main = do 20 | quickBatch $ traversable $ (undefined :: T1 (Int, Int, [Int])) 21 | quickBatch $ traversable $ (undefined :: T2 (Int, Int, [Int])) 22 | quickBatch $ traversable $ (undefined :: T3 (Int, Int, [Int])) 23 | quickBatch $ traversable $ (undefined :: T4 (Int, Int, [Int])) 24 | quickBatch $ traversable $ (undefined :: T5 (Int, Int, [Int])) 25 | quickBatch $ traversable $ (undefined :: T6 (Int, Int, [Int])) 26 | quickBatch $ traversable $ (undefined :: T7 (Int, Int, [Int])) 27 | quickBatch $ traversable $ (undefined :: T8 (Int, Int, [Int])) 28 | 29 | newtype Identity a = Identity a 30 | deriving (Eq, Ord, Show) 31 | 32 | instance Arbitrary a => Arbitrary (Identity a) where 33 | arbitrary = fmap Identity arbitrary 34 | 35 | instance Eq a => EqProp (Identity a) where 36 | (=-=) = eq 37 | 38 | instance Functor Identity where 39 | fmap f (Identity a) = Identity $ f a 40 | 41 | instance Foldable Identity where 42 | foldMap f (Identity a) = f a 43 | 44 | instance Traversable (Identity) where 45 | traverse f (Identity a) = fmap Identity $ f a 46 | 47 | newtype Constant a b = 48 | Constant { getConstant :: a } 49 | deriving (Eq, Show) 50 | 51 | instance Arbitrary a => Arbitrary (Constant a b) where 52 | arbitrary = fmap Constant arbitrary 53 | 54 | instance Eq a => EqProp (Constant a b) where 55 | (=-=) = eq 56 | 57 | instance Functor (Constant a) where 58 | fmap _ (Constant a) = Constant a 59 | 60 | instance Foldable (Constant a) where 61 | foldMap _ _ = mempty 62 | 63 | instance Traversable (Constant a) where 64 | traverse _ (Constant a) = pure (Constant a) 65 | 66 | data Optional a = 67 | Nada 68 | | Yep a 69 | deriving (Eq, Show) 70 | 71 | instance Arbitrary a => Arbitrary (Optional a) where 72 | arbitrary = oneof [fmap Yep arbitrary, return Nada] 73 | 74 | instance Eq a => EqProp (Optional a) where 75 | (=-=) = eq 76 | 77 | instance Functor Optional where 78 | fmap _ Nada = Nada 79 | fmap f (Yep x) = Yep $ f x 80 | 81 | instance Foldable Optional where 82 | foldMap f (Yep x) = f x 83 | foldMap _ Nada = mempty 84 | 85 | instance Traversable Optional where 86 | traverse f (Yep x) = Yep <$> f x 87 | traverse _ Nada = pure Nada 88 | 89 | data List a = 90 | Nil 91 | | Cons a (List a) 92 | deriving (Eq, Show) 93 | 94 | instance Arbitrary a => Arbitrary (List a) where 95 | arbitrary = oneof [liftA2 Cons arbitrary arbitrary, return Nil] 96 | 97 | instance Eq a => EqProp (List a) where 98 | (=-=) = eq 99 | 100 | instance Functor List where 101 | fmap f (Cons x xs) = f x `Cons` fmap f xs 102 | fmap _ Nil = Nil 103 | 104 | instance Foldable List where 105 | foldMap f (Cons x xs) = f x <> foldMap f xs 106 | foldMap _ Nil = mempty 107 | 108 | instance Traversable List where 109 | traverse f = foldr (liftA2 Cons) (pure Nil) . fmap f 110 | 111 | data Three a b c = 112 | Three a b c 113 | deriving (Eq, Show) 114 | 115 | instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (Three a b c) where 116 | arbitrary = liftA3 Three arbitrary arbitrary arbitrary 117 | 118 | instance (Eq a, Eq b, Eq c) => EqProp (Three a b c) where 119 | (=-=) = eq 120 | 121 | instance Functor (Three a b) where 122 | fmap f (Three a b x) = Three a b $ f x 123 | 124 | instance Foldable (Three a b) where 125 | foldMap f (Three a b x) = f x 126 | 127 | instance Traversable (Three a b) where 128 | traverse f (Three a b x) = (Three a b) <$> f x 129 | 130 | data Three' a b = 131 | Three' a b b 132 | deriving (Eq, Show) 133 | 134 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Three' a b) where 135 | arbitrary = liftA3 Three' arbitrary arbitrary arbitrary 136 | 137 | instance (Eq a, Eq b) => EqProp (Three' a b) where 138 | (=-=) = eq 139 | 140 | instance Functor (Three' a) where 141 | fmap f (Three' a x x') = Three' a (f x) (f x') 142 | 143 | instance Foldable (Three' a) where 144 | foldMap f (Three' a x x') = f x <> f x' 145 | 146 | instance Traversable (Three' a) where 147 | traverse f (Three' a x x') = Three' a <$> f x <*> f x' 148 | 149 | data S n a = S (n a) a 150 | deriving (Eq, Show) 151 | 152 | instance (Arbitrary (n a), Arbitrary a) => Arbitrary (S n a) where 153 | arbitrary = liftA2 S arbitrary arbitrary 154 | 155 | instance (Eq (n a), Eq a) => EqProp (S n a) where 156 | (=-=) = eq 157 | 158 | instance Functor n => Functor (S n) where 159 | fmap f (S n a) = S (fmap f n) $ (f a) 160 | 161 | instance Foldable n => Foldable (S n) where 162 | foldMap f (S n a) = foldMap f n <> f a 163 | 164 | instance Traversable n => Traversable (S n) where 165 | traverse f (S n a) = S <$> traverse f n <*> f a 166 | 167 | data Tree a = 168 | Empty 169 | | Leaf a 170 | | Node (Tree a) a (Tree a) 171 | deriving (Eq, Show) 172 | 173 | instance Arbitrary a => Arbitrary (Tree a) where 174 | arbitrary = oneof [return $ Empty, Leaf <$> arbitrary, liftA3 Node arbitrary arbitrary arbitrary] 175 | 176 | instance Eq a => EqProp (Tree a) where 177 | (=-=) = eq 178 | 179 | instance Functor Tree where 180 | fmap f Empty = Empty 181 | fmap f (Leaf a) = Leaf $ f a 182 | fmap f (Node t a t') = Node (fmap f t) (f a) (fmap f t') 183 | 184 | instance Foldable Tree where 185 | foldMap f Empty = mempty 186 | foldMap f (Leaf a) = f a 187 | foldMap f (Node t a t') = foldMap f t <> f a <> foldMap f t' 188 | 189 | instance Traversable Tree where 190 | traverse f Empty = pure Empty 191 | traverse f (Leaf a) = Leaf <$> f a 192 | traverse f (Node n x n') = Node <$> traverse f n <*> f x <*> traverse f n' 193 | -------------------------------------------------------------------------------- /ch22/ShortExercise.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | import Control.Applicative 4 | 5 | cap :: String -> String 6 | cap = map toUpper 7 | 8 | rev :: String -> String 9 | rev = reverse 10 | 11 | composed :: String -> String 12 | composed = cap . rev 13 | 14 | fmapped :: String -> String 15 | fmapped = fmap cap rev 16 | 17 | tupled :: String -> (String, String) 18 | tupled = liftA2 (,) id composed 19 | 20 | tupledM :: String -> (String, String) 21 | tupledM = do 22 | a <- id 23 | b <- composed 24 | return (a, b) 25 | 26 | tupledM' :: String -> (String, String) 27 | tupledM' = id >>= (\x -> composed >>= (\y -> return $ (x, y))) 28 | 29 | newtype Reader r a = 30 | Reader { getReader :: r -> a } 31 | 32 | asksid :: Reader a a 33 | asksid = Reader id 34 | 35 | liftA2' :: Applicative f => (a -> b -> c) -> (f a) -> (f b) -> (f c) 36 | liftA2' x y z = x <$> y <*> z 37 | 38 | asks :: (r -> a) -> Reader r a 39 | asks = Reader 40 | 41 | instance Functor (Reader r) where 42 | fmap f (Reader r) = Reader $ f . r 43 | 44 | instance Applicative (Reader r) where 45 | pure = Reader . const 46 | Reader rab <*> Reader ra = Reader $ \x -> rab x (ra x) 47 | 48 | instance Monad (Reader r) where 49 | Reader ra >>= f = Reader $ \x -> getReader (f (ra x)) x 50 | 51 | newtype HumanName = HumanName String deriving (Eq, Show) 52 | newtype DogName = DogName String deriving (Eq, Show) 53 | newtype Address = Address String deriving (Eq, Show) 54 | 55 | data Person = Person { humanName :: HumanName 56 | , dogName :: DogName 57 | , address :: Address 58 | } deriving (Eq, Show) 59 | 60 | data Dog = Dog { dogsName :: DogName 61 | , dogsAddress :: Address 62 | } deriving (Eq, Show) 63 | 64 | pers :: Person 65 | pers = 66 | Person (HumanName "Big Bird") 67 | (DogName "Barkley") 68 | (Address "Sesame Street") 69 | 70 | chris :: Person 71 | chris = Person (HumanName "Chris Allen") 72 | (DogName "Papu") 73 | (Address "Austin") 74 | 75 | getDogRm :: Reader Person Dog 76 | getDogRm = do 77 | dog' <- Reader dogName 78 | add <- Reader address 79 | return $ Dog dog' add 80 | 81 | 82 | -------------------------------------------------------------------------------- /ch22/WarmUp.hs: -------------------------------------------------------------------------------- 1 | module WarmUp where 2 | 3 | import Prelude hiding (lookup) 4 | import Control.Applicative 5 | import Data.Maybe 6 | import Data.Monoid 7 | 8 | x, y, z :: [Integer] 9 | x = [1 .. 3] 10 | y = [4 .. 6] 11 | z = [7 .. 9] 12 | 13 | lookup :: Eq a => a -> [(a, b)] -> Maybe b 14 | lookup f = getFirst . foldMap (First . checkEq f) 15 | where 16 | checkEq a (x, y) = if a == x then Just y else Nothing 17 | 18 | xs :: Maybe Integer 19 | xs = lookup 3 $ zip x y 20 | 21 | ys :: Maybe Integer 22 | ys = lookup 6 $ zip y z 23 | 24 | zs :: Maybe Integer 25 | zs = lookup 4 $ zip x y 26 | 27 | z' :: Integer -> Maybe Integer 28 | z' = flip lookup $ zip x z 29 | 30 | x1 :: Maybe (Integer, Integer) 31 | x1 = (,) <$> xs <*> ys 32 | 33 | x2 :: Maybe (Integer, Integer) 34 | x2 = liftA2 (,) ys zs 35 | 36 | x3 :: Integer -> (Maybe Integer, Maybe Integer) 37 | x3 = liftA2 (,) z' z' 38 | 39 | summed :: Num c => (c, c) -> c 40 | summed = (uncurry (+)) 41 | 42 | bolt :: Integer -> Bool 43 | bolt = liftA2 (&&) (>3) (<8) 44 | 45 | sequA :: Integral a => a -> [Bool] 46 | sequA m = sequenceA [(>3), (<8), even] m 47 | 48 | s' = summed <$> ((,) <$> xs <*> ys) 49 | 50 | main :: IO () 51 | main = do 52 | -- print $ sequenceA [Just 3, Just 2, Just 1] 53 | -- print $ sequenceA [x, y] 54 | -- print $ sequenceA [xs, ys] 55 | -- print $ summed <$> ((,) <$> xs <*> ys) 56 | -- print $ fmap summed ((,) <$> xs <*> zs) 57 | -- print $ bolt 7 58 | -- print $ fmap bolt z 59 | -- 60 | -- print $ sequenceA [(>3), (<8), even] 7 61 | print $ getAll . foldMap All $ sequA 22 62 | print $ sequA $ fromMaybe 2 s' 63 | print $ bolt $ fromMaybe 2 ys 64 | -------------------------------------------------------------------------------- /ch23/ChapterExercises.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | newtype State s a = 4 | State { runState :: s -> (a, s) } 5 | 6 | instance Functor (State s) where 7 | fmap f (State g) = State $ \s -> let (a, s') = g s 8 | in (f a, s') 9 | 10 | instance Applicative (State s) where 11 | (State f) <*> (State g) = State $ \s -> let (h, s') = f s 12 | (a, s'') = g s' 13 | in (h a, s'') 14 | 15 | pure a = State $ \ s -> (a, s) 16 | 17 | instance Monad (State s) where 18 | (State f) >>= g = State $ \s -> let (a, s') = f s 19 | State h = g a 20 | in h s' 21 | 22 | return = pure 23 | 24 | 25 | get :: State s s 26 | get = State $ \ s -> (s, s) 27 | 28 | put :: s -> State s () 29 | put s = State $ const ((), s) 30 | 31 | exec :: State s a -> s -> s 32 | exec s = snd . runState s 33 | 34 | eval :: State s a -> s -> a 35 | eval s = fst . runState s 36 | 37 | modify :: (s -> s) -> State s () 38 | modify f = f <$> get >>= put 39 | -------------------------------------------------------------------------------- /ch23/FizzBuzz.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad 3 | import Control.Monad.Trans.State 4 | 5 | import qualified Data.DList as DL 6 | 7 | import Data.Foldable 8 | 9 | fizzBuzz :: Integer -> String 10 | fizzBuzz n | n `mod` 15 == 0 = "FizzBuzz" 11 | | n `mod` 5 == 0 = "Buzz" 12 | | n `mod` 3 == 0 = "Fizz" 13 | | otherwise = show n 14 | 15 | 16 | 17 | 18 | fizzbuzzList :: [Integer] -> DL.DList String 19 | fizzbuzzList list = execState (mapM_ addResult list) DL.empty 20 | 21 | addResult :: Integer -> State (DL.DList String) () 22 | addResult n = do 23 | xs <- get 24 | let result = fizzBuzz n 25 | put (DL.snoc xs result) 26 | 27 | fizzbuzzFromTo :: Integer -> Integer -> [String] 28 | fizzbuzzFromTo from to = execState (mapM_ addR' [to, to-1 .. from]) [] 29 | 30 | addR' :: Integer -> State ([String]) () 31 | addR' n = do 32 | xs <- get 33 | let result = fizzBuzz n 34 | put (result : xs) 35 | 36 | main :: IO () 37 | main = do 38 | let a = toList $ fizzbuzzList $ [1 .. 100] 39 | b = fizzbuzzFromTo 1 100 40 | 41 | print $ a == b 42 | 43 | {-main :: IO ()-} 44 | {-main = traverse_ (putStrLn . fizzBuzz) [1..100]-} 45 | -------------------------------------------------------------------------------- /ch23/Moi.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | newtype Moi s a = 4 | Moi { runMoi :: s -> (a, s) } 5 | 6 | instance Functor (Moi s) where 7 | fmap f (Moi g) = Moi $ \s -> let (a, s') = g s 8 | in (f a, s') 9 | 10 | instance Applicative (Moi s) where 11 | (Moi f) <*> (Moi g) = Moi $ \s -> let (h, s') = f s 12 | (a, s'') = g s' 13 | in (h a, s'') 14 | 15 | pure a = Moi $ \ s -> (a, s) 16 | 17 | instance Monad (Moi s) where 18 | (Moi f) >>= g = Moi $ \s -> let (a, s') = f s 19 | Moi h = g a 20 | in h s' 21 | 22 | return = pure 23 | -------------------------------------------------------------------------------- /ch23/ThrowDown.hs: -------------------------------------------------------------------------------- 1 | import System.Random 2 | 3 | import Data.Monoid 4 | import Control.Monad.Trans.State 5 | import Control.Monad (replicateM) 6 | import Control.Applicative (liftA2, liftA3) 7 | 8 | data Die = 9 | DieOne 10 | | DieTwo 11 | | DieThree 12 | | DieFour 13 | | DieFive 14 | | DieSix 15 | deriving (Eq, Show) 16 | 17 | intToDie :: Int -> Die 18 | intToDie n = 19 | case n of 20 | 1 -> DieOne 21 | 2 -> DieTwo 22 | 3 -> DieThree 23 | 4 -> DieFour 24 | 5 -> DieFive 25 | 6 -> DieSix 26 | x -> error $ "intToDie got non 1-6 integer: " ++ show x 27 | 28 | rollDieThreeTimes :: (Die, Die, Die) 29 | rollDieThreeTimes = 30 | let s = mkStdGen 0 31 | (d1, s1) = randomR (1, 6) s 32 | (d2, s2) = randomR (1, 6) s1 33 | (d3, _) = randomR (1, 6) s2 34 | in (intToDie d1, intToDie d2, intToDie d3) 35 | 36 | rollDie :: State StdGen Die 37 | rollDie = state $ do 38 | (n, s) <- randomR (1, 6) 39 | return (intToDie n, s) 40 | 41 | rollDie' :: State StdGen Die 42 | rollDie' = intToDie <$> state (randomR (1, 6)) 43 | 44 | rollDieThreeTimes' :: State StdGen (Die, Die, Die) 45 | rollDieThreeTimes' = 46 | liftA3 (,,) rollDie' rollDie' rollDie' 47 | 48 | 49 | -- Repeats a single value 50 | infiniteDie :: State StdGen [Die] 51 | infiniteDie = repeat <$> rollDie 52 | 53 | -- What you actually want 54 | nDie :: Int -> State StdGen [Die] 55 | nDie n = replicateM n rollDie 56 | 57 | rollsToGetTwenty :: StdGen -> Int 58 | rollsToGetTwenty g = go 0 0 g 59 | where go :: Int -> Int -> StdGen -> Int 60 | go sum count gen 61 | | sum >= 20 = count 62 | | otherwise = 63 | let (die, nextGen) = randomR (1, 6) gen 64 | in go (sum + die) (count + 1) nextGen 65 | 66 | rollDieT :: State StdGen (Sum Int, [Die]) 67 | rollDieT = liftA2 (,) Sum (pure . intToDie) <$> state (randomR (1, 6)) 68 | 69 | rollsToGetN :: Int -> StdGen -> (Int, [Die]) 70 | rollsToGetN n g = go (Sum 0, []) g 71 | where 72 | go :: (Sum Int, [Die]) -> StdGen -> (Int, [Die]) 73 | go s@(Sum sum, dies) gen 74 | | sum >= n = (length dies, dies) 75 | | otherwise = 76 | let (die, nextGen) = runState rollDieT gen 77 | in go (s <> die) nextGen 78 | 79 | rollsToGetN' :: Int -> IO (Int, [Die]) 80 | rollsToGetN' n = (rollsToGetN n) . mkStdGen <$> randomIO 81 | -------------------------------------------------------------------------------- /ch3/exc03.hs: -------------------------------------------------------------------------------- 1 | module Reverse where 2 | 3 | area d = pi * (r * r) 4 | where r = d / 2 5 | 6 | 7 | exclamate :: String -> String 8 | exclamate xs = xs ++ "!" 9 | 10 | fifthLetter :: String -> String 11 | fifthLetter = drop 4 . take 5 12 | 13 | lastEight :: String -> String 14 | lastEight xs = drop n xs 15 | where n = length xs - 8 16 | 17 | 18 | thirdLetter :: String -> Char 19 | thirdLetter xs = xs !! 3 20 | 21 | getOffset :: Int -> Char 22 | getOffset offset = str !! offset 23 | where str = "Curry is awesome!" 24 | 25 | rvrs :: String -> String 26 | rvrs = unwords . reverse . words 27 | 28 | main :: IO () 29 | main = print $ rvrs "Curry is awesome" 30 | -------------------------------------------------------------------------------- /ch4/exc04.hs: -------------------------------------------------------------------------------- 1 | awesome = ["Papuchon", "curry", "Haskell"] 2 | alsoAwesome = ["Quake", "The Simons"] 3 | allAwesome = [awesome, alsoAwesome] 4 | 5 | isPalindrome :: (Eq a) => [a] -> Bool 6 | isPalindrome x = x == reverse x 7 | 8 | myAbs :: Integer -> Integer 9 | myAbs x = if x < 0 then (negate x) else x 10 | 11 | f :: (a, b) -> (c, d) -> ((b, d), (a, c)) 12 | f x y = ((snd x, snd y), (fst x, fst y)) 13 | 14 | 15 | x = (+) 16 | reading xs = w `x` 1 17 | where w = length xs 18 | 19 | z = \ x -> x 20 | 21 | first = \ (x:xs) -> x 22 | 23 | fst' (a,b) = a 24 | -------------------------------------------------------------------------------- /ch4/intermission04.hs: -------------------------------------------------------------------------------- 1 | data Mood = Blah | Woot deriving Show 2 | 3 | changeMood :: Mood -> Mood 4 | changeMood Blah = Woot 5 | changeMood _ = Blah 6 | -------------------------------------------------------------------------------- /ch5/arith3broken.hs: -------------------------------------------------------------------------------- 1 | module Arith3Broken where 2 | 3 | main :: IO () 4 | main = do 5 | print (1 + 2) 6 | print 10 7 | print (negate 1) 8 | print ((+) 0 blah) 9 | where blah = negate 1 10 | -------------------------------------------------------------------------------- /ch5/exc05.hs: -------------------------------------------------------------------------------- 1 | a = (* 9) 6 2 | b = head [(0, "doge"), (1, "Kitteh")] 3 | c = head [(0 :: Integer, "doge"), (1, "Kitteh")] 4 | d = if False then True else False 5 | e = length [1,2,3,4,5] 6 | f = (length [1,2,3,4]) > (length "Tacocat") 7 | 8 | 9 | x = 5 10 | y = x + 5 11 | w = y * 10 12 | 13 | z y = y * 10 14 | 15 | f' = 4 / y 16 | 17 | x' = "Julie" 18 | y' = " <3 " 19 | z' = "Haskell" 20 | f'' = x' ++ y' ++ z' 21 | 22 | 23 | bigNum = (^) 5 $ 10 24 | wahoo = bigNum 25 | 26 | xpr = print 27 | ypr = print "woohoo!" 28 | zpr = xpr "hello world" 29 | 30 | aaa = (+) 31 | bbb = 5 32 | ccc = aaa 10 33 | ddd = ccc 200 34 | 35 | aaaa = 12 + bbbb 36 | bbbb = 10000 * aaaa 37 | 38 | 39 | functionH :: [a] -> a 40 | functionH (x:_) = x 41 | 42 | functionC :: Ord a => a -> a -> Bool 43 | functionC x y = if (x > y) then True else False 44 | 45 | functionS :: (a, b) -> b 46 | functionS (x, y) = y 47 | 48 | i :: a -> a 49 | i x = x 50 | 51 | cfunc :: a -> b -> a 52 | cfunc x y = x 53 | 54 | cfunc' :: a -> b -> b 55 | cfunc' x y = y 56 | 57 | r :: [a] -> [a] 58 | r (_:xs) = xs 59 | 60 | co :: (b -> c) -> (a -> b) -> (a -> c) 61 | co f g = f . g 62 | 63 | a'' :: (a -> c) -> a -> a 64 | a'' f x = x 65 | 66 | a''' :: (a -> b) -> a -> b 67 | a''' f x = f x 68 | -------------------------------------------------------------------------------- /ch5/fixit.hs: -------------------------------------------------------------------------------- 1 | module Sing where 2 | 3 | fstString :: String -> String 4 | fstString x = x ++ " in the rain" 5 | 6 | sndString :: String -> String 7 | sndString x = x ++ " over the rainbow" 8 | 9 | sing = if (x > y) then fstString x else sndString y 10 | where x = "Singing" 11 | y = "Saturday" 12 | 13 | 14 | -------------------------------------------------------------------------------- /ch5/typekwondo.hs: -------------------------------------------------------------------------------- 1 | data Woot 2 | 3 | data Blah 4 | 5 | f :: Woot -> Blah 6 | f = undefined 7 | 8 | g :: (Blah, Woot) -> (Blah, Blah) 9 | g (b, w) = (b, f w) 10 | 11 | 12 | f' :: Int -> String 13 | f' = undefined 14 | 15 | g' :: String -> Char 16 | g' = undefined 17 | 18 | h' :: Int -> Char 19 | h' = g' . f' 20 | 21 | data A 22 | data B 23 | data C 24 | 25 | q :: A -> B 26 | q = undefined 27 | 28 | w :: B -> C 29 | w = undefined 30 | 31 | e :: A -> C 32 | e = w . q 33 | 34 | data X 35 | data Y 36 | data Z 37 | 38 | xz :: X -> Z 39 | xz = undefined 40 | 41 | yz :: Y -> Z 42 | yz = undefined 43 | 44 | xform :: (X, Y) -> (Z, Z) 45 | xform (x,y) = (xz x, yz y) 46 | 47 | munge :: (x -> y) -> (y -> (w, z)) -> x -> w 48 | munge f g = (fst . g . f) 49 | 50 | -------------------------------------------------------------------------------- /ch6/DoesItTypecheck.hs: -------------------------------------------------------------------------------- 1 | -- 1 2 | data Person = Person Bool deriving Show --Did not derive show 3 | 4 | printPerson :: Person -> IO () 5 | printPerson person = putStrLn (show person) 6 | 7 | -- 2 8 | data Mood = Blah | Woot deriving (Show, Eq) -- Did not derive Eq 9 | 10 | settleDown :: Mood -> Mood -- No type signature 11 | settleDown x = if x == Woot then Blah else x 12 | 13 | -- 3 14 | -- a) Values of the type Mood due to the equality check with `Woot`. 15 | -- b) Type error 16 | -- c) Type error that Mood is not an instance of Ord typeclass. 17 | 18 | -- 4 19 | type Subject = String 20 | type Verb = String 21 | type Object = String 22 | 23 | data Sentence = Sentence Subject Verb Object deriving (Eq, Show) 24 | 25 | s1 :: Object -> Sentence 26 | s1 = Sentence "dogs" "drool" -- This is; curried data constructor 27 | 28 | s2 :: Sentence 29 | s2 = Sentence "Julie" "loves" "dogs" 30 | -------------------------------------------------------------------------------- /ch6/GivenDeclaration.hs: -------------------------------------------------------------------------------- 1 | -- Given 2 | data Rocks = Rocks String deriving (Eq, Show, Ord) 3 | 4 | data Yeah = Yeah Bool deriving (Eq, Show, Ord) 5 | 6 | data Papu = Papu Rocks Yeah deriving (Eq, Show, Ord) 7 | 8 | 9 | -- 1 10 | 11 | phew :: Papu 12 | phew = Papu (Rocks "chases") (Yeah True) -- Need to add explicit 13 | -- data constructors 14 | -- arguments 15 | 16 | -- 2 17 | 18 | truth :: Papu 19 | truth = Papu (Rocks "chomskydoz") (Yeah True) -- compiles 20 | 21 | -- 3 22 | 23 | equalityForAll :: Papu -> Papu -> Bool 24 | equalityForAll p p' = p == p' -- compiles 25 | 26 | -- 4 27 | 28 | comparePapus :: Papu -> Papu -> Bool 29 | comparePapus p p' = p > p' -- Does not compile need to be member 30 | -- of Ord typeclass (fixed above) 31 | -------------------------------------------------------------------------------- /ch6/MatchTheTypes.hs: -------------------------------------------------------------------------------- 1 | import Data.List (sort) 2 | -- 1 3 | 4 | -- a) 5 | i :: Num a => a 6 | i = 1 7 | 8 | -- b) Needs to be Num, no instance arising from literal 9 | -- i' :: a 10 | -- i' = 1 11 | -- GHC defaults to Integer (Haskell Report) 12 | 13 | -- 2 14 | -- a) 15 | f :: Float 16 | f = 1.0 17 | 18 | -- b) Does not compile. Highest class is Fractional. 19 | -- Defaults to Double 20 | -- f' :: Num a => a 21 | -- f' = 1.0 22 | 23 | -- 3 24 | -- a) 25 | g :: Float 26 | g = 1.0 27 | 28 | -- b) Double Default. Compiles because 1.0 is instance of fractional. 29 | g' :: Fractional a => a 30 | g' = 1.0 31 | 32 | -- 4 33 | -- a) 34 | h :: Float 35 | h = 1.0 36 | 37 | -- b) 1/1 is a real fraction. Default Double 38 | h' :: RealFrac a => a 39 | h' = 1.0 40 | 41 | -- 5 42 | -- a) 43 | freud :: a -> a 44 | freud x = x 45 | 46 | -- b) typechecks (highest possible sign: a -> a) 47 | freudcheck :: Ord a => a -> a 48 | freudcheck x = x 49 | 50 | -- 6 51 | -- a) 52 | freud' :: a -> a 53 | freud' x = x 54 | 55 | --b) Typechecks (more specific than a -> a again) 56 | freudcheck' :: Int -> Int 57 | freudcheck' x = x 58 | 59 | -- 7 60 | -- a) 61 | myX :: Int 62 | myX = 1 :: Int 63 | 64 | sigmund :: Int -> Int 65 | sigmund x = myX 66 | 67 | -- b) Does not typecheck as return is Int so input also 68 | -- sigmund' :: a -> a 69 | -- sigmund' x = myX 70 | 71 | -- 8 72 | -- a) idem 7a 73 | -- b) Does not typecheck as myX is defined as an Int 74 | -- sigmund' :: Num a => a -> a 75 | -- sigmund' x = myX 76 | 77 | -- 9 78 | -- a) 79 | jung :: Ord a => [a] -> a 80 | jung xs = head (sort xs) 81 | 82 | -- b) Typechecks Int implements Ord. Normally implements Ord 83 | jung' :: [Int] -> Int 84 | jung' xs = head (sort xs) 85 | 86 | -- 10 87 | -- a) 88 | young :: [Char] -> Char 89 | young xs = head (sort xs) 90 | 91 | -- b) Typechecks. 92 | young' :: Ord a => [a] -> a 93 | young' xs = head (sort xs) 94 | 95 | -- 11 96 | -- a) 97 | mySort :: [Char] -> [Char] 98 | mySort = sort 99 | 100 | signifier :: [Char] -> Char 101 | signifier xs = head (mySort xs) 102 | 103 | -- b) Fails as sort typechecks for Char and Ord is too broad 104 | -- signifier' :: Ord a => [a] -> a 105 | -- signifier' xs = head (mySort xs) 106 | 107 | 108 | -------------------------------------------------------------------------------- /ch6/MultipleChoice.txt: -------------------------------------------------------------------------------- 1 | 1) c 2 | 2) b 3 | 3) a 4 | 4) a (Haskell report) 5 | 5) a (What about Word though) 6 | 7 | -------------------------------------------------------------------------------- /ch6/TypeKwonDo.hs: -------------------------------------------------------------------------------- 1 | chk :: Eq b => (a -> b) -> a -> b -> Bool 2 | chk f a b = b == f a 3 | 4 | arith :: Num b => (a -> b) -> Integer -> a -> b 5 | arith f x a = (fromIntegral x) + f a 6 | -------------------------------------------------------------------------------- /ch6/intermission.hs: -------------------------------------------------------------------------------- 1 | data TisAnInteger = TisAn Integer deriving Show 2 | 3 | instance Eq TisAnInteger where 4 | (==) (TisAn b) (TisAn a) = a == b 5 | 6 | data TwoIntegers = Two Integer Integer deriving Show 7 | 8 | instance Eq TwoIntegers where 9 | (==) (Two a1 b1) (Two a2 b2) = a1 == a2 && b1 == b2 10 | 11 | data Pair a = Pair a a deriving Show 12 | 13 | instance Eq a => Eq (Pair a) where 14 | (==) (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2 15 | 16 | data Tuple a b = Tuple a b 17 | 18 | instance (Eq a, Eq b) => Eq (Tuple a b) where 19 | (==) (Tuple a1 b1) (Tuple a2 b2) = a1 == a2 && b1 == b2 20 | 21 | data Which a = ThisOne a | ThatOne a deriving Show 22 | 23 | instance Eq a => Eq (Which a) where 24 | (==) (ThisOne x) (ThisOne y) = x == y 25 | (==) (ThatOne x) (ThatOne y) = x == y 26 | (==) _ _ = False 27 | 28 | data EitherOr a b = Hello a | Goodbye b deriving Show 29 | 30 | instance (Eq a, Eq b) => Eq (EitherOr a b) where 31 | (==) (Hello x) (Hello y) = x == y 32 | (==) (Goodbye x) (Goodbye y) = x == y 33 | (==) _ _ = False 34 | -------------------------------------------------------------------------------- /ch7/arith4.hs: -------------------------------------------------------------------------------- 1 | module Arith4 where 2 | 3 | roundTrip :: (Show a, Read b) => a -> b 4 | roundTrip = read . show 5 | 6 | main :: IO () 7 | main = do 8 | print (roundTrip 4 :: Int) 9 | print (id 4 :: Int) 10 | -------------------------------------------------------------------------------- /ch7/intermission.hs: -------------------------------------------------------------------------------- 1 | -- 1) a, b, c, d 2 | -- 2) d 3 | 4 | -- 3 5 | -- a) 6 | 7 | addOneIfOdd :: Integral a => a -> a 8 | addOneIfOdd n = case odd n of 9 | True -> f n 10 | False -> n 11 | where f = \z -> z + 1 12 | 13 | -- b) 14 | addFive :: (Num a, Ord a) => a -> a -> a 15 | addFive = \x -> \y -> (if x > y then y else x) + 5 16 | 17 | -- c) 18 | mflip :: (a -> b -> c) -> b -> a -> c 19 | mflip f x y = f y x 20 | 21 | 22 | -- 1 23 | -- a) 24 | -- b) k1 and k3 have same type 25 | -- c) k3 26 | k :: (a, b) -> a 27 | k (x, y) = x 28 | 29 | k1 :: Num a => a 30 | k1 = k ((4 - 1), 10) 31 | 32 | k2 :: String 33 | k2 = k ("three", (1 + 2)) 34 | 35 | k3 :: Num a => a 36 | k3 = k (3, True) 37 | 38 | f :: (a, b, c) -> (d, e, f) -> ((a, d), (c, f)) 39 | f (a, b, c) (d, e, f) = ((a, d), (c, f)) 40 | 41 | dodgy :: Num a => a -> a -> a 42 | dodgy x y = x + y * 10 43 | 44 | oneIsOne :: Num a => a -> a 45 | oneIsOne = dodgy 1 46 | 47 | oneIsTwo :: Num a => a -> a 48 | oneIsTwo = (flip dodgy) 2 49 | 50 | a1 = dodgy 1 0 == 1 51 | a2 = dodgy 1 1 == 11 52 | a3 = dodgy 2 2 == 22 53 | a4 = dodgy 1 2 == 21 54 | a5 = dodgy 2 1 == 12 55 | a6 = oneIsOne 1 == 11 56 | a7 = oneIsOne 2 == 21 57 | a8 = oneIsTwo 1 == 21 58 | a9 = oneIsTwo 2 == 22 59 | a10 = oneIsOne 3 == 31 60 | a11 = oneIsTwo 3 == 23 61 | 62 | -- 1, 2 63 | avgGrade :: (Fractional a, Ord a) => a -> Char 64 | avgGrade x 65 | | y >= 0.9 = 'A' 66 | | y >= 0.8 = 'B' 67 | | y >= 0.7 = 'C' 68 | | y >= 0.59 = 'D' 69 | | y < 0.59 = 'F' 70 | | otherwise = 'F' 71 | where y = x / 100 72 | 73 | -- 3 74 | -- a) no, b) yes, c) no, d) no 75 | pal :: Eq a => [a] -> Bool 76 | pal xs 77 | | xs == reverse xs = True 78 | | otherwise = False 79 | 80 | -- 4 Equivalent typeclass in list form 81 | -- 5 82 | -- 6 a) no, b) no, c) yes, d) no 83 | -- 7) Ordering typeclass, number typeclass 84 | numbers :: (Num a, Ord a, Num b) => a -> a 85 | numbers x 86 | | x < 0 = -1 87 | | x == 0 = 0 88 | | x > 0 = 1 89 | 90 | -------------------------------------------------------------------------------- /ch7/lets_write_code.hs: -------------------------------------------------------------------------------- 1 | tensDigit :: Integral a => a -> a 2 | tensDigit x = d 3 | where (_, d) = x `divMod` 10 4 | 5 | hunsD :: Integral a => a -> a 6 | hunsD x = d2 7 | where (_, d2) = x `divMod` 10 8 | 9 | -- b) yes 10 | 11 | foldBool :: a -> a -> Bool -> a 12 | foldBool left right switch = case switch of 13 | True -> left 14 | False -> right 15 | 16 | foldBool2 :: a -> a -> Bool -> a 17 | foldBool2 left right switch 18 | | switch == True = left 19 | | otherwise = right 20 | 21 | g :: (a -> b) -> (a, c) -> (b, c) 22 | g f (x, y) = (f x, y) 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /ch7/multiple_choice.hs: -------------------------------------------------------------------------------- 1 | --1) d 2 | --2) b 3 | --3) d 4 | --4) b 5 | --5) a 6 | 7 | -------------------------------------------------------------------------------- /ch8/currying.hs: -------------------------------------------------------------------------------- 1 | cattyConny :: String -> String -> String 2 | cattyConny x y = x ++ " mrow " ++ y 3 | 4 | flippy :: String -> String -> String 5 | flippy = flip cattyConny 6 | 7 | apedCatty :: String -> String 8 | apedCatty = cattyConny "woops" 9 | 10 | frappe :: String -> String 11 | frappe = flippy "haha" 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /ch8/intermission.hs: -------------------------------------------------------------------------------- 1 | applyTimes :: (Eq a, Num a) => a -> (b -> b) -> b -> b 2 | applyTimes 0 _ b = b 3 | applyTimes n f b = f . applyTimes (n - 1) f $ b 4 | 5 | q1 :: Int 6 | q1 = applyTimes (5 :: Int) (+1) (5 :: Int) 7 | 8 | q1' :: Int 9 | q1' = (+1) $ (+1) $ (+1) $ (+1) $ (+1) $ 5 10 | -- 11 | -- at(5 f 5) 12 | -- f . at 4 f 5 13 | -- f . f . at 3 f 5 14 | -- f . f . f at 2 f 5 15 | -- f . f . f . f at 1 f 5 16 | -- f . f . f . f . f at f 0 5 17 | -- f . f . f . f . f $ b 18 | 19 | -- z = applyTimes 5 (\ x -> "(1 + " ++ x ++ ")") "5" 20 | 21 | 22 | -------------------------------------------------------------------------------- /ch8/multiplechoice.txt: -------------------------------------------------------------------------------- 1 | -- 1) d 2 | -- 2) b 3 | -- 3) d 4 | -- 4) b 5 | -------------------------------------------------------------------------------- /ch8/numberintowords.hs: -------------------------------------------------------------------------------- 1 | module WordNumber where 2 | 3 | import Data.List (intersperse) 4 | import Data.Char 5 | 6 | digitToWord :: Int -> String 7 | digitToWord n 8 | | n >= 0 && n < 10 = (chr ((ord '0') + n)) : [] 9 | 10 | 11 | digits :: Int -> [Int] 12 | digits n 13 | | n < 10 = [n] 14 | | otherwise = (digits quot) ++ [rem] 15 | where (quot, rem) = quotRem n 10 16 | 17 | wordNumber :: Int -> String 18 | wordNumber n = concat $ map digitToWord $ digits n 19 | 20 | 21 | -------------------------------------------------------------------------------- /ch8/recursion.hs: -------------------------------------------------------------------------------- 1 | divideBy :: (Num a, Ord a) => a -> a -> a 2 | divideBy num denom 3 | | num >= denom = 1 + divideBy (num - denom) denom 4 | | otherwise = 0 5 | 6 | 7 | sumToN :: (Num a, Eq a) => a -> a 8 | sumToN n 9 | | n /= 0 = n + sumToN (n - 1) 10 | | otherwise = 0 11 | 12 | multRecursive :: (Integral a) => a -> a -> a 13 | multRecursive a b 14 | | a > 0 = b + multRecursive (a - 1) b 15 | | a < 0 = (negate b) + multRecursive (a + 1) b 16 | | otherwise = 0 17 | 18 | 19 | mc91 :: (Num a, Ord a) => a -> a 20 | mc91 n 21 | | n > 100 = n - 10 22 | | otherwise = mc91 $ mc91 (n + 11) 23 | -------------------------------------------------------------------------------- /ch9/Cipher.hs: -------------------------------------------------------------------------------- 1 | module Cipher where 2 | 3 | import Data.Char 4 | 5 | shiftChar :: Int -> Char -> Char 6 | shiftChar shift x 7 | | ord x + shiftMod > ord 'z' = shiftChar shiftMod (chr $ ord x - 26) 8 | | ord x + shiftMod < ord 'a' = shiftChar shiftMod (chr $ ord x + 26) 9 | | otherwise = chr $ ord x + shiftMod 10 | where 11 | shiftMod = shift `mod` 26 12 | 13 | 14 | 15 | caesar :: Int -> String -> String 16 | caesar shift code = map (shiftChar shift) code 17 | 18 | unCaesar :: Int -> String -> String 19 | unCaesar shift code = map (shiftChar $ negate shift) code 20 | -------------------------------------------------------------------------------- /ch9/PoemLines.hs: -------------------------------------------------------------------------------- 1 | module PoemLines where 2 | 3 | firstSen = "Tyger Tyger, burning bright\n" 4 | secondSen = "In the forests of the night\n" 5 | thirdSen = "What immortal hand or eye\n" 6 | fourthSen = "Could frame thy fearful symmetry?" 7 | 8 | sentences = firstSen ++ secondSen ++ thirdSen ++ fourthSen 9 | 10 | 11 | myLines :: String -> [String] 12 | myLines "" = [] 13 | myLines inp = beforeSpace : afterSpace 14 | where notEndl = \x -> x /= '\n' 15 | stillEndl = \x -> x == '\n' 16 | beforeSpace = takeWhile notEndl inp 17 | afterSpace = myLines . dropWhile stillEndl . dropWhile notEndl $ inp 18 | 19 | shouldEqual = [ "Tyger Tyger, burning bright" 20 | , "In the forests of the night" 21 | , "What immortal hand or eye" 22 | , "Could frame thy fearful symmetry?" 23 | ] 24 | 25 | main :: IO () 26 | main = print $ "Are they equal? " 27 | ++ show (myLines sentences == shouldEqual) 28 | 29 | -------------------------------------------------------------------------------- /ch9/chapterexc.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | 4 | -------------------------------------------------------------------------------- /ch9/exercise.hs: -------------------------------------------------------------------------------- 1 | myEnumFromTo :: (Enum a) => a -> a -> [a] 2 | myEnumFromTo beg end 3 | | begInd > endInd = [] 4 | | begInd == endInd = beg : [] 5 | | otherwise = beg : myEnumFromTo (succ beg) end 6 | where begInd = fromEnum beg 7 | endInd = fromEnum end 8 | 9 | eftBool :: Bool -> Bool -> [Bool] 10 | eftBool beg end = myEnumFromTo beg end 11 | 12 | eftOrd :: Ordering -> Ordering -> [Ordering] 13 | eftOrd beg end = myEnumFromTo beg end 14 | 15 | eftInt :: Int -> Int -> [Int] 16 | eftInt beg end = myEnumFromTo beg end 17 | 18 | eftChar :: Char -> Char -> [Char] 19 | eftChar beg end = myEnumFromTo beg end 20 | 21 | myOr :: [Bool] -> Bool 22 | myOr [] = False 23 | myOr (x:xs) = x || myOr xs 24 | 25 | myAny :: (a -> Bool) -> [a] -> Bool 26 | myAny f = myOr . map f 27 | 28 | myElem :: Eq a => a -> [a] -> Bool 29 | myElem _ [] = False 30 | myElem y (x:xs) = x == y || myElem y xs 31 | 32 | myReverse :: [a] -> [a] 33 | myReverse [] = [] 34 | myReverse (x:xs) = myReverse xs ++ [x] 35 | 36 | squish :: [[a]] -> [a] 37 | squish [] = [] 38 | squish (xs:xss) = xs ++ squish xss 39 | 40 | squishMap :: (a -> [b]) -> [a] -> [b] 41 | squishMap _ [] = [] 42 | squishMap f (x:xs) = f x ++ squishMap f xs 43 | 44 | squishAgain :: [[a]] -> [a] 45 | squishAgain = squishMap id 46 | 47 | myMaximumBy :: (a -> a -> Ordering) -> [a] -> a 48 | myMaximumBy cmp (x : xs) = go cmp xs x 49 | where go _ [] acc = acc 50 | go cmp (x:xs) acc 51 | | acc `cmp` x == GT = go cmp xs acc 52 | | acc `cmp` x /= GT = go cmp xs x 53 | 54 | myMinimumBy :: (a -> a -> Ordering) -> [a] -> a 55 | myMinimumBy cmp (x : xs) = go cmp xs x 56 | where go _ [] acc = acc 57 | go cmp (x:xs) acc 58 | | acc `cmp` x == LT = go cmp xs acc 59 | | acc `cmp` x /= LT = go cmp xs x 60 | 61 | myMaximum :: (Ord a) => [a] -> a 62 | myMaximum = myMaximumBy compare 63 | 64 | myMinimum :: (Ord a) => [a] -> a 65 | myMinimum = myMinimumBy compare 66 | -------------------------------------------------------------------------------- /ch9/intermission.hs: -------------------------------------------------------------------------------- 1 | myWords :: String -> [String] 2 | myWords "" = [] 3 | myWords inp = beforeSpace : afterSpace 4 | where notSpace = \x -> x /= ' ' 5 | stillSpace = \x -> x == ' ' 6 | beforeSpace = takeWhile notSpace inp 7 | afterSpace = myWords . (dropWhile stillSpace) . dropWhile notSpace $ inp 8 | 9 | 10 | partitioner :: Eq a => a -> [a] -> [[a]] 11 | partitioner sep [] = [] 12 | partitioner sep inp = beforeSpace : afterSpace 13 | where notSep = \x -> x /= sep 14 | isSep = \x -> x == sep 15 | beforeSpace = takeWhile notSep inp 16 | afterSpace = partitioner sep . dropWhile isSep . dropWhile notSep $ inp 17 | 18 | 19 | mySqr = [x^2 | x <- [1..5]] 20 | myCube = [y^3 | y <- [1..5]] 21 | 22 | len = length [(x,y) | (x, y) <- zip mySqr myCube, x < 50 && y < 50] 23 | 24 | 25 | -- normal form 26 | -- 1 1 27 | -- 2 2 28 | -- 3 3 29 | -- 4 3 30 | -- 5 3 31 | -- 6 3 32 | -- 7 2 33 | --------------------------------------------------------------------------------