├── .gitignore
├── 03-types-and-classes
└── 03.11-exercises.hs
├── 04-defining-functions
└── 04.8-exercises.hs
├── 05-list-comprehensions
├── 05.5-the-caesar-cipher.hs
└── 05.7-exercises.hs
├── 06-recursive-functions
└── 06.8-exercises.hs
├── 07-higher-order-functions
├── 07.6-binary-string-transmitter.hs
└── 07.9-exercises.hs
├── 08-declaring-types-and-classes
├── 08.6-tautology-checker.hs
├── 08.7-abstract-machine.hs
└── 08.9-exercises.hs
├── 09-the-countdown-problem
└── 09.11-exercises.hs
├── 10-interactive-programming
├── 10.6-hangman.hs
└── 10.8-nim.hs
├── 12-monads-and-more
├── 12.03-monads.hs
└── 12.05-exercises.hs
├── 13-monadic-parsing
├── 13.03-basic-definitions.hs
├── 13.04-sequencing-parsers.hs
├── 13.05-making-choices.hs
├── 13.06-derived-primitives.hs
├── 13.07-handling-space.hs
├── 13.08-arithmetic-expressions.hs
├── 13.09-calculator.hs
└── 13.11-exercises.hs
├── 14-foldable-and-friends
└── 14.5-exercises.hs
└── README.md
/.gitignore:
--------------------------------------------------------------------------------
1 | *
2 | !/**/
3 | !*.*
4 | *.hi
5 | *.o
6 | *.ex
7 | !*.hs
8 | .DS_Store
9 |
--------------------------------------------------------------------------------
/03-types-and-classes/03.11-exercises.hs:
--------------------------------------------------------------------------------
1 | -- 1.
2 | -- What are the types of the following values?
3 |
4 | -- [Char]
5 | -- ['a', 'b', 'c']
6 |
7 | -- [(Bool, Char]
8 | -- [(False, '0'), (True '1')]
9 |
10 | -- ([Bool], [Char])
11 | -- ([False, True], ['0', '1'])
12 |
13 | -- [[a] -> [a]]
14 | -- [tail, init, reverse]
15 |
16 | -- 2.
17 | bools :: [Bool]
18 | bools = [False, True, True]
19 |
20 | nums :: [[Int]]
21 | nums = [[1..10]]
22 |
23 | add :: Int -> Int -> Int -> Int
24 | add w x y z = w + x + y + z
25 |
26 | copy :: a -> (a, a)
27 | copy x = (x, x)
28 |
29 | apply :: (a -> b) -> a -> b
30 | apply f x = f x
31 |
32 | -- 3.
33 | -- What are the types of the following functions?
34 |
35 | second :: [a] -> a
36 | second xs = head (tail xs)
37 |
38 | swap :: (a, b) -> (b, a)
39 | swap (x, y) = (y, x)
40 |
41 | pair :: a -> b -> (a, b)
42 | pair x y = (x, y)
43 |
44 | double :: Num a => a -> a
45 | double x = x*2
46 |
47 | palindrome :: Eq a => [a] -> Bool
48 | palindrome xs = reverse xs == xs
49 |
50 | twice :: (a -> a) -> a -> a
51 | twice f x = f (f x)
52 |
53 | -- 4.
54 | -- 👌
55 |
56 | -- 5.
57 | -- Why is it not feasible in general for function types to be instances of the Eq class?
58 | -- It is not feasible in general to compare two functions for equality.
59 |
60 | -- When is it feasible?
61 | -- It is feasible for all basic types which are instances of the Eq class.
62 |
--------------------------------------------------------------------------------
/04-defining-functions/04.8-exercises.hs:
--------------------------------------------------------------------------------
1 | -- Exercises 4.8
2 |
3 | -- 1.
4 | firstHalf :: [a] -> [a]
5 | firstHalf xs = (take $ (length xs) `div` 2) xs
6 |
7 | secondHalf :: [a] -> [a]
8 | secondHalf xs = (drop $ (length xs) `div` 2) xs
9 |
10 | halve :: [a] -> ([a], [a])
11 | halve xs = (firstHalf xs, secondHalf xs)
12 |
13 | -- 2.
14 | -- a.
15 | thirdA :: [a] -> a
16 | thirdA xs = head $ tail $ tail xs
17 |
18 | -- b.
19 | thirdB :: [a] -> a
20 | thirdB xs = xs !! 2
21 |
22 | -- c.
23 | thirdC :: [a] -> a
24 | thirdC (_:_:z:xs) = z
25 |
26 | -- 3.
27 | -- a.
28 | safetailA :: [a] -> [a]
29 | safetailA xs = if null xs then [] else tail xs
30 |
31 | -- b.
32 | safetailB :: [a] -> [a]
33 | safetailB xs | null xs = []
34 | | otherwise = tail xs
35 | -- c.
36 | safetailC :: [a] -> [a]
37 | safetailC [] = []
38 | safetailC xs = tail xs
39 |
40 | -- 8.
41 | -- Luhn algorithm
42 |
43 | luhnDouble :: Int -> Int
44 | luhnDouble x | x * 2 > 9 = (x * 2) - 9
45 | | otherwise = x * 2
46 |
47 | luhn :: Int -> Int -> Int -> Int -> Bool
48 | luhn w x y z = (((luhnDouble w) + x + (luhnDouble y) + z) `mod` 10) == 0
49 |
50 |
--------------------------------------------------------------------------------
/05-list-comprehensions/05.5-the-caesar-cipher.hs:
--------------------------------------------------------------------------------
1 | import Data.Char
2 |
3 | let2int :: Char -> Int
4 | let2int c = ord c - ord 'a'
5 |
6 | int2let :: Int -> Char
7 | int2let n = chr (ord 'a' + n)
8 |
9 | shift :: Int -> Char -> Char
10 | shift n c
11 | | isLower c = int2let ((let2int c + n) `mod` 26)
12 | | otherwise = c
13 |
14 | encode :: Int -> String -> String
15 | encode n xs = [shift n x | x <- xs]
16 |
17 |
18 | -- a Frequency table by analyzing a large volume of such text, one can derive the
19 | -- following percentage frequencies of the twenty-six letters of the alphabet.
20 | table :: [Float]
21 | table = [8.1, 1.5, 2.8, 4.5, 12.7, 2.2, 2.0, 6.1, 7.0,
22 | 0.2, 0.8, 4.0, 2.4, 6.7, 7.5, 1.9, 0.1, 6.0,
23 | 6.3, 9.0, 2.8, 1.0, 2.4, 0.2, 2.0, 0.1]
24 |
25 | percent :: Int -> Int -> Float
26 | percent n m = (fromIntegral n / fromIntegral m) * 100
27 |
28 | lowers :: String -> Int
29 | lowers xs = length [x | x <- xs, x >= 'a' && x <= 'z']
30 |
31 | count :: Char -> String -> Int
32 | count x xs = length [x' | x' <- xs, x == x']
33 |
34 | -- using `percent` within a list comprehension, together with `lowers` and `count`
35 | -- a function can be defined that returns a frequency table for any given string.
36 | freqs :: String -> [Float]
37 | freqs xs = [percent (count x xs) n | x <- ['a'..'z']]
38 | where
39 | n = lowers xs
40 |
41 | -- the chi-square statistic compares a list of observed frequencies with a
42 | -- list of expected frequencies.
43 | chisqr :: [Float] -> [Float] -> Float
44 | chisqr os es = sum [((o - e) ^ 2) / e | (o, e) <- zip os es]
45 |
46 | -- a function that rotates the elements of a list n places to the left, wrapping
47 | -- around at the start of the list (assuming that n is between zero and the length
48 | -- of the list.
49 | rotate :: Int -> [a] -> [a]
50 | rotate n xs = drop n xs ++ take n xs
51 |
52 | positions :: Eq a => a -> [a] -> [Int]
53 | positions x xs = [i | (x', i) <- zip xs [0..], x == x']
54 |
55 | -- a function that can decode most strings produced using the Caesar cipher by
56 | -- producing a frequency table of the encoded string, calculating the chi-square
57 | -- statistic for each possible rotation of this table alongside the table of
58 | -- expected frequencies, and using the position of the minimum chi-square value
59 | -- as the shift factor to then decode the string.
60 | crack :: String -> String
61 | crack xs = encode (-factor) xs
62 | where
63 | factor = head (positions (minimum chitab) chitab)
64 | chitab = [chisqr (rotate n table') table | n <- [0..25]]
65 | table' = freqs xs
66 |
--------------------------------------------------------------------------------
/05-list-comprehensions/05.7-exercises.hs:
--------------------------------------------------------------------------------
1 | -- Exercises 5.7
2 |
3 | -- 1.
4 | sumOfHundredSquareIntegers = sum [x^2 | x <- [1..100]]
5 |
6 | -- 2.
7 | grid :: Int -> Int -> [(Int, Int)]
8 | grid m n = [(x, y) | x <- [0..m], y <- [0..n]]
9 |
10 | -- 3.
11 | square' :: Int -> [(Int, Int)]
12 | square' n = [(x, y) | (x, y) <- grid n n, x /= y]
13 |
14 | -- 4.
15 | replicate' :: Int -> a -> [a]
16 | replicate' n x = [x | _ <- [0..n]]
17 |
18 | -- 5.
19 | pyths :: Int -> [(Int, Int ,Int)]
20 | pyths n = [(x, y, z) | x <- [1..n],
21 | y <- [1..n],
22 | z <- [1..n],
23 | (x^2) + (y^2) == (z^2)]
24 |
25 | -- 6.
26 | factors :: Int -> [Int]
27 | factors n = [x | x <- [1..n], n `mod` x == 0]
28 |
29 | perfects :: Int -> [Int]
30 | perfects n = [x | x <- [1..n], sum (factors x) - x == x]
31 |
32 | -- 7.
33 | -- Show how the list comprehension [(x, y) | x <- [1, 2], y <- [3, 4]] with two generators can be
34 | -- expressed using two comprehensions with a single generator
35 |
36 | nestedComprehension xs ys = concat [[(x, y) | y <- ys] | x <- xs]
37 |
38 | -- 8.
39 | -- Redefine the function `positions` using the function `find`
40 |
41 | positions :: Eq a => a -> [a] -> [Int]
42 | positions x xs = [i | (x', i) <- zip xs [0..], x == x']
43 |
44 | find :: Eq a => a -> [(a, b)] -> [b]
45 | find k t = [v | (k', v) <- t, k == k']
46 |
47 | findPositions :: Eq a => a -> [a] -> [Int]
48 | findPositions x xs = find x (zip xs [0..])
49 |
50 | -- 9.
51 | -- The scalar product of two lists of integers `xs` and `ys` of length `n` is given
52 | -- by the sum of the products of cooresponding integers.
53 |
54 | scalarproduct :: [Int] -> [Int] -> Int
55 | scalarproduct xs ys = sum [x * y | (x, y) <- zip xs ys]
56 |
--------------------------------------------------------------------------------
/06-recursive-functions/06.8-exercises.hs:
--------------------------------------------------------------------------------
1 | -- Exercises 6.8
2 |
3 | -- 1.
4 | -- Modify the factorial function to prohibit negative arguments by adding a guard
5 | -- to the recursive case.
6 | factorial :: Int -> Int
7 | factorial n
8 | | n < 0 = 0
9 | | n == 0 = 1
10 | | n > 0 = n * factorial (n - 1)
11 |
12 | -- 2.
13 | -- Define a recursive function that returns the sum of non-negative numbers from a
14 | -- given value down to zero.
15 | sumdown :: Int -> Int
16 | sumdown 0 = 0
17 | sumdown n = n + sumdown (n - 1)
18 |
19 | -- 3.
20 | -- Define the exponentiation operator `^` for non-negative integers using the same
21 | -- pattern of recursion as the multiplication operator `*`.
22 | (<^>) :: Int -> Int -> Int
23 | 0 <^> _ = 0
24 | n <^> 0 = 1
25 | n <^> 1 = n
26 | n <^> m = n * (n <^> (m - 1))
27 |
28 | -- 4.
29 | -- Euclid's algorithm is used for calculating the greatest common divisor of two
30 | -- non-negative integers
31 | euclid :: Int -> Int -> Int
32 | euclid n 0 = n
33 | euclid n m = euclid m (n `mod` m)
34 |
35 | -- 5.
36 | -- Show how `length [1,2,3]`, `drop 3 [1,2,3,4,5]`, and `init [1,2,3]` are evaluated
37 | length' :: [a] -> Int
38 | length' [] = 0
39 | length' (_:xs) = 1 + length' xs
40 | -- length' [1,2,3]
41 | -- 1 + (length' [2,3])
42 | -- 1 + 1 + (length' [3])
43 | -- 1 + 1 + 1 + (length' [])
44 | -- 1 + 1 + 1 + 0
45 |
46 | drop' :: Int -> [a] -> [a]
47 | drop' 0 xs = xs
48 | drop' _ [] = []
49 | drop' n (_:xs) = drop' (n - 1) xs
50 | -- drop' 3 [1,2,3,4.5]
51 | -- drop' 2 [2,3,4,5]
52 | -- drop' 1 [3,4,5]
53 | -- drop' 0 [4,5]
54 | -- [4,5]
55 |
56 | init' :: [a] -> [a]
57 | init' [_] = []
58 | init' (x:xs) = x : init' xs
59 | -- init' [1,2,3]
60 | -- 1 : init' [2,3]
61 | -- 1 : 2 : init' [3]
62 | -- 1 : 2 : []
63 | -- [1,2]
64 |
65 | -- 6.
66 | -- Define the following library functions on lists using recursion.
67 | -- a.
68 | and' :: [Bool] -> Bool
69 | and' [] = True
70 | and' (x:xs) =
71 | if x == False
72 | then False
73 | else and' xs
74 |
75 | -- b.
76 | concat' :: [[a]] -> [a]
77 | concat' [] = []
78 | concat' (xs:xss) = xs ++ concat' xss
79 |
80 | -- c.
81 | replicate' :: Int -> a -> [a]
82 | replicate' 0 _ = []
83 | replicate' n x = x : replicate' (n-1) x
84 |
85 | -- d.
86 | () :: [a] -> Int -> a
87 | () (x:xs) 0 = x
88 | () (x:xs) n = () xs (n-1)
89 |
90 | -- e.
91 | elem' :: Eq a => a -> [a] -> Bool
92 | elem' _ [] = False
93 | elem' a (x:xs) =
94 | if a == x
95 | then True
96 | else elem' a xs
97 |
98 | -- 7.
99 | -- Define a recursive function hat merges two lists to give a single sorted list.
100 | merge :: Ord a => [a] -> [a] -> [a]
101 | merge xs [] = xs
102 | merge [] ys = ys
103 | merge (x:xs) (y:ys)
104 | | x < y = x : merge xs (y : ys)
105 | | otherwise = y : merge (x : xs) ys
106 |
107 | -- 8.
108 | -- Define a function using merge that implements merge sort, in which the empty
109 | -- list and singleton lists are already sorted, and any other list is sorted by
110 | -- merging together the two lists that result from sorting the two halves.
111 | halve :: [a] -> ([a], [a])
112 | halve xs = ((take n xs), (drop n xs))
113 | where
114 | n = length xs `div` 2
115 |
116 | msort :: Ord a => [a] -> [a]
117 | msort [] = []
118 | msort [x] = [x]
119 | msort xs = merge (msort first) (msort second)
120 | where
121 | (first, second) = halve xs
122 |
123 | -- 9.
124 | -- Construct the library functions that:
125 | -- a. calculate the sum of a list of numbers;
126 | sum' :: [Int] -> Int
127 | sum' [] = 0
128 | sum' (x:xs) = x + (sum' xs)
129 |
130 | -- b. take a given number of elements from the start of a list;
131 | take' :: Int -> [a] -> [a]
132 | take' 0 _ = []
133 | take' _ [] = []
134 | take' n (x:xs) = x : take' (n-1) xs
135 |
136 | -- c. select the last element of a non-empty list.
137 | last' :: [a] -> a
138 | last' [x] = x
139 | last' (x:xs) = last' xs
140 |
--------------------------------------------------------------------------------
/07-higher-order-functions/07.6-binary-string-transmitter.hs:
--------------------------------------------------------------------------------
1 | import Data.Char
2 |
3 | type Bit = Int
4 | type Bits = [Bit]
5 |
6 | bin2int :: Bits -> Int
7 | bin2int = foldr (\x y -> x + 2*y) 0
8 |
9 | -- bin2int [1,0,1,1]
10 | -- 13
11 |
12 | int2bin :: Int -> Bits
13 | int2bin 0 = []
14 | int2bin n = n `mod` 2 : int2bin (n `div` 2)
15 |
16 | -- int2bin 13
17 | -- [1,0,1,1]
18 |
19 | make8 :: Bits -> Bits
20 | make8 bits = take 8 (bits ++ repeat 0)
21 |
22 | -- make8 [1,0,1,1]
23 | -- [1,0,1,1,0,0,0]
24 |
25 | encode :: String -> Bits
26 | encode = concat . map (make8 . int2bin . ord)
27 |
28 | -- encode "sup"
29 | -- [1,1,0,0,1,1,1,0,1,0,1,0,1,1,1,0,0,0,0,0,1,1,1,0]
30 |
31 | chop8 :: Bits -> [Bits]
32 | chop8 [] = []
33 | chop8 bits = take 8 bits : chop8 (drop 8 bits)
34 |
35 | decode :: Bits -> String
36 | decode = map (chr . bin2int) . chop8
37 |
38 | -- decode [1,1,0,0,1,1,1,0,1,0,1,0,1,1,1,0,0,0,0,0,1,1,1,0]
39 | -- "sup"
40 |
41 | channel :: Bits -> Bits
42 | channel = id
43 |
44 | transmit :: String -> String
45 | transmit = decode . channel . encode
46 |
--------------------------------------------------------------------------------
/07-higher-order-functions/07.9-exercises.hs:
--------------------------------------------------------------------------------
1 | -- Exercises 7.9
2 |
3 | import Prelude hiding (all, any, takeWhile, dropWhile, map, filter, iterate)
4 | -- 1.
5 | -- Show how the list comprehension [f x | x <- xs, p x] can be re-expressed using the higher-order
6 | -- functions map and filter.
7 | f1 :: (a -> Bool) -> (a -> b) -> [a] -> [b]
8 | f1 p f xs = map f $ filter p xs
9 |
10 | -- 2.
11 | -- Without looking at the definitions from the standard prelude, define the following higher-order
12 | -- library functions on lists.
13 | -- a.
14 | -- Decide if all elements of a list satisfy a predicate:
15 | all :: (Int -> Bool) -> [Int] -> Bool
16 | all f = foldr (\x y -> f x && y) True
17 |
18 | -- b.
19 | -- Decide if any element of a list satisfies a predicate:
20 | any :: (Int -> Bool) -> [Int] -> Bool
21 | any f = foldr (\x y -> f x || y) False
22 |
23 | -- c.
24 | -- Select elements from a list while they satisfy a predicate:
25 | takeWhile :: (a -> Bool) -> [a] -> [a]
26 | takeWhile f [] = []
27 | takeWhile f (x:xs)
28 | | f x = x : takeWhile f xs
29 | | otherwise = []
30 |
31 | -- d.
32 | -- Remove elements from a list wile they satisfy a predicate:
33 | dropWhile :: (a -> Bool) -> [a] -> [a]
34 | dropWhile f [] = []
35 | dropWhile f (x:xs)
36 | | f x = dropWhile f xs
37 | | otherwise = x : xs
38 |
39 | -- 3.
40 | -- Redefine the functions map f and filter p using foldr.
41 | map f = foldr (\x y -> f x : y) []
42 |
43 | filter :: (a -> Bool) -> [a] -> [a]
44 | filter p = foldr (\x y -> if p x then x : y else y) []
45 |
46 | -- 4. Using foldl, define a function dec2int :: [Int] -> Int that converts a decimal number into an
47 | -- integer. For example:
48 | -- dec2int [2,3,4,5]
49 | -- 2345
50 | --
51 | dec2int :: [Int] -> Int
52 | dec2int = foldl (\ys x -> ys * 10 + x) 0
53 |
54 | -- 5. Define the higher-order library function curry that converts a function on pairs into a
55 | -- curried function, and, conversely, the function uncurry that converts a curried function
56 | -- with two arguments into a function on pairs.
57 |
58 | -- currry :: ((a, b) -> c) -> (a -> b -> c)
59 | currry f = \x y -> f (x, y)
60 |
61 | uncurrry :: (a -> b -> c) -> ((a, b) -> c)
62 | uncurrry f = \(x, y) -> f x y
63 |
64 | -- 6.
65 | -- Redefine the functions chop8, map f, and iterate f using unfold:
66 | unfold p h t x
67 | | p x = []
68 | | otherwise = h x : unfold p h t (t x)
69 |
70 | chop8 :: [Int] -> [[Int]]
71 | chop8 [] = []
72 | chop8 xs = take 8 xs : chop8 (drop 8 xs)
73 |
74 | iterate :: (a -> a) -> a -> [a]
75 | iterate f n = n : iterate f (f n)
76 |
77 | chop8' = unfold (\x -> length x < 9) (take 8) (drop 8)
78 |
79 | map' p f xs = unfold p f f xs
80 |
81 | iterate' f = unfold (const False) id f
82 |
--------------------------------------------------------------------------------
/08-declaring-types-and-classes/08.6-tautology-checker.hs:
--------------------------------------------------------------------------------
1 | data Prop = Const Bool
2 | | Var Char
3 | | Not Prop
4 | | And Prop Prop
5 | | Imply Prop Prop
6 |
7 | type Assoc k v = [(k, v)]
8 |
9 | type Subst = Assoc Char Bool
10 |
11 | find :: Eq k => k -> Assoc k v -> v
12 | find k t = head [v | (k', v) <- t, k == k']
13 |
14 | rmdups :: Eq a => [a] -> [a]
15 | rmdups [] = []
16 | rmdups (x:xs) = x : filter (/= x) (rmdups xs)
17 |
18 | -- | A function that evaluates a proposition given a substitution for its variables
19 | -- defined by pattern matching on the five possible forms that the proposition can
20 | -- have.
21 | eval :: Subst -> Prop -> Bool
22 | -- | The value of a constant proposition is simply the constant itself.
23 | eval _ (Const b) = b
24 | -- | The value of a variable is obtained by looking up its value in the
25 | -- substitution.
26 | eval s (Var x) = find x s
27 | -- | The value of a conjunction is given by taking the conjunction of the values of
28 | -- the two argument propositions.
29 | eval s (Not p) = not (eval s p)
30 | eval s (And p q) = eval s p && eval s q
31 | -- | The value of an implication is obtained by the `<=` ordering on logical values.
32 | eval s (Imply p q) = eval s p <= eval s q
33 |
34 | -- | A function that returns a list of all the variables in a proposition.
35 | vars :: Prop -> [Char]
36 | vars (Const _) = []
37 | vars (Var x) = [x]
38 | vars (Not p) = vars p
39 | vars (And p q) = vars p ++ vars q
40 | vars (Imply p q) = vars p ++ vars q
41 |
42 | -- | A function that produces a list of logical values of a given length.
43 | bools :: Int -> [[Bool]]
44 | bools 0 = [[]]
45 | -- | Append the results of taking two copies of the recursively produced lists
46 | bools n = nah bss ++ yes bss
47 | where
48 | -- | Place `False` in front of each list in the first copy.
49 | nah = map (False:)
50 | -- | Place `True` in front of each list in the second copy.
51 | yes = map (True:)
52 | bss = bools (n-1)
53 |
54 | -- | A function that generates all possible substitutions for a proposition.
55 | substs :: Prop -> [Subst]
56 | -- | Zipping the list of variables with each of the resulting lists.
57 | substs p = map (zip vs) (bools (length vs))
58 | where
59 | -- | Extracting the variables and removing duplicates form the list.
60 | vs = rmdups $ vars p
61 |
62 | -- | A function that decides if a proposition is a tautology.
63 | isTaut :: Prop -> Bool
64 | -- | Check if it evaluates to `True` for all possible substitutions.
65 | isTaut p = and [eval s p | s <- substs p]
66 |
67 | -- Proposition variables
68 | p1 :: Prop
69 | p1 = And (Var 'A') (Not (Var 'A'))
70 |
71 | p2 :: Prop
72 | p2 = Imply (And (Var 'A') (Var 'B')) (Var 'A')
73 |
74 | p3 :: Prop
75 | p3 = Imply (Var 'A') (And (Var 'A') (Var 'B'))
76 |
77 | p4 :: Prop
78 | p4 = Imply (And (Var 'A') (Imply
79 | (Var 'A') (Var 'B'))) (Var 'B')
80 |
--------------------------------------------------------------------------------
/08-declaring-types-and-classes/08.7-abstract-machine.hs:
--------------------------------------------------------------------------------
1 | data Expr =
2 | Val Int
3 | | Add Expr Expr
4 |
5 | data Op =
6 | EVAL Expr
7 | | ADD Int
8 |
9 | type Cont = [Op]
10 |
11 | -- | A function that evaluates an expression in the context
12 | -- of a control stack.
13 | eval :: Expr -> Cont -> Int
14 | -- | If the expression is an integer, it is already
15 | -- evaluated and we begin executing the control stack.
16 | eval (Val n) c = exec c n
17 | -- | If the expression is an addition, we evaluate the
18 | -- first argument, placing the operation `EVAL y` on
19 | -- top of the control stack to indicate that the second
20 | -- argument should be evaluated after the first argument.
21 | eval (Add x y) c = eval x (EVAL y : c)
22 |
23 | -- | A function that executes a control stack in the context
24 | -- of an integer argument.
25 | exec :: Cont -> Int -> Int
26 | -- | If the control stack is empty, we return the integer.
27 | exec [] n = n
28 | -- | If the top of the stack is an operation `EVAL y` then
29 | -- evaluate the expression, placing the operation `ADD n` on
30 | -- top of the remaining stack to indicate that the current
31 | -- integer argument should be added together with result of
32 | -- `EVAL y`.
33 | exec (EVAL y : c) n = eval y (ADD n : c)
34 | -- | If the top of the stack is an operation `ADD n` then
35 | -- evaluation of the two arguments of an addition expression
36 | -- is complete and we execute the remaining control stack in
37 | -- the context of the sum of the two resulting integer
38 | -- values.
39 | exec (ADD n : c) m = exec c (n + m)
40 |
41 | -- | A function that evaluates an expression to an integer
42 | -- by invoking `eval` with the given expression and the
43 | -- empty control stack.
44 | value :: Expr -> Int
45 | value e = eval e []
46 |
--------------------------------------------------------------------------------
/08-declaring-types-and-classes/08.9-exercises.hs:
--------------------------------------------------------------------------------
1 | -- 1.
2 | -- Define a recursive multiplication function for the recursive type of natural
3 | -- numbers.
4 | data Nat = Zero | Succ Nat deriving Show
5 |
6 | nat2int :: Nat -> Int
7 | nat2int Zero = 0
8 | nat2int (Succ n) = 1 + nat2int n
9 |
10 | int2nat :: Int -> Nat
11 | int2nat 0 = Zero
12 | int2nat n = Succ (int2nat (n-1))
13 |
14 | add :: Nat -> Nat -> Nat
15 | add Zero n = n
16 | add (Succ m) n = Succ (add m n)
17 |
18 | mult :: Nat -> Nat -> Nat
19 | mult Zero _ = Zero
20 | mult _ Zero = Zero
21 | mult (Succ m) n = add (Succ m) (mult m n)
22 |
23 | -- 2.
24 | -- Together with `compare`, define the function `occurs` for search trees.
25 | -- compare :: Ord a => a -> a -> Ordering
26 | data Tree a = Leaf a | Node (Tree a) a (Tree a) deriving Show
27 |
28 | flatten :: Tree a -> [a]
29 | flatten (Leaf x) = [x]
30 | flatten (Node l x r) = flatten l ++ [x] ++ flatten r
31 |
32 | occurs :: Ord a => a -> Tree a -> Bool
33 | occurs x (Leaf y) = x == y
34 | occurs x (Node l y r) | x == y = True
35 | | x < y = occurs x l
36 | | otherwise = occurs x r
37 |
38 | occurs' :: Ord a => a -> Tree a -> Bool
39 | occurs' x (Leaf y) = x == y
40 | occurs' x (Node l y r) = case compare x y of
41 | LT -> occurs' x l
42 | EQ -> True
43 | GT -> occurs' x r
44 |
45 | -- 3.
46 | -- Define a function that decides if the number of leaves in
47 | -- the left and right subtree of every node differs by at
48 | -- at most one, with leaves themselves being trivially
49 | -- balanced.
50 | data BTree a = BLeaf a | BNode (BTree a) (BTree a) deriving Show
51 |
52 | leafLen :: BTree a -> Int
53 | leafLen (BLeaf x) = 1
54 | leafLen (BNode l r) = leafLen l + leafLen r
55 |
56 | balanced :: BTree a -> Bool
57 | balanced (BLeaf x) = True
58 | balanced (BNode l r) =
59 | abs (leafLen l - leafLen r) <= 1 && balanced l && balanced r
60 |
61 | -- 4.
62 | -- Define a function that converts a non-empty list into a
63 | -- balanced tree.
64 | splitList :: [a] -> ([a], [a])
65 | splitList xs = ((take n xs), (drop n xs))
66 | where
67 | n = length xs `div` 2
68 |
69 | balance :: [a] -> BTree a
70 | balance [x] = BLeaf x
71 | balance xs =
72 | BNode
73 | (balance (fst (splitList xs)))
74 | (balance (snd (splitList xs)))
75 |
76 | -- 5.
77 | -- Define a higher-order function such that replaces each
78 | -- `Val` constructor in an expression by the function `f`,
79 | -- and each `Add` constructor by the function `g`.
80 | data Expr' = Val' Int | Add' Expr' Expr' deriving Show
81 |
82 | folde :: (Int -> a) -> (a -> a -> a) -> Expr' -> a
83 | folde f g (Val' x) = f x
84 | folde f g (Add' x y) = g (folde f g x) (folde f g y)
85 |
86 | -- 6.
87 | -- Using `folde` define a function `eval` that evaluates an
88 | -- expression to an integer value, and a function `size`
89 | -- that calculates the number of values in an expression.
90 | eval' :: Expr' -> Int
91 | eval' = folde (+0) (+)
92 |
93 | size :: Expr' -> Int
94 | size = folde (\_ -> 1) (+)
95 |
96 | -- 7.
97 | -- Complete the following instance declarations:
98 | --
99 | -- instance Eq a => Eq (Maybe a) where
100 | -- (==) Nothing Nothing = True
101 | -- (==) (Just x) (Just y) = x == y
102 | -- (==) _ _ = False
103 | --
104 | -- instance Eq a => Eq [a] where
105 | -- (==) [] [] = True
106 | -- (==) (x:xs) (y:ys) = x == y && xs == ys
107 | -- (==) _ _ = False
108 | --
109 |
110 | -- 8.
111 | -- Extend the tautology checker to support logical
112 | -- disjunction and equivalence in propositions.
113 | data Prop = Const Bool
114 | | Var Char
115 | | Not Prop
116 | | And Prop Prop
117 | | Imply Prop Prop
118 | -- extension for ∨ and ⇔
119 | | Or Prop Prop
120 | | Eqiv Prop Prop
121 | deriving Show
122 |
123 | type Assoc k v = [(k, v)]
124 | type Subst = Assoc Char Bool
125 |
126 | find :: Eq k => k -> Assoc k v -> v
127 | find k t = head [v | (k', v) <- t, k == k']
128 |
129 | eval :: Subst -> Prop -> Bool
130 | eval _ (Const b) = b
131 | eval s (Var x) = find x s
132 | eval s (Not p) = not (eval s p)
133 | eval s (And p q) = eval s p && eval s q
134 | eval s (Imply p q) = eval s p <= eval s q
135 | -- extension for ∨ and ⇔
136 | eval s (Or p q) = eval s p || eval s q
137 | eval s (Eqiv p q) = eval s p == eval s q
138 |
139 | vars :: Prop -> [Char]
140 | vars (Const _) = []
141 | vars (Var x) = [x]
142 | vars (Not p) = vars p
143 | vars (And p q) = vars p ++ vars q
144 | vars (Imply p q) = vars p ++ vars q
145 | -- extension for ∨ and ⇔
146 | vars (Or p q) = vars p ++ vars q
147 | vars (Eqiv p q) = vars p ++ vars q
148 |
149 | -- 9.
150 | -- Extend the abstract machine to support the use
151 | -- of multiplication.
152 | data Expr =
153 | Val Int
154 | | Add Expr Expr
155 | | Mult Expr Expr
156 |
157 | data Op =
158 | ADD Expr
159 | | MULT Expr
160 | | PLUS Int
161 | | TIMES Int
162 |
163 | type Cont = [Op]
164 |
165 | eval'' :: Expr -> Cont -> Int
166 | eval'' (Val n) c = exec c n
167 | eval'' (Add x y) c = eval'' x (ADD y : c)
168 | eval'' (Mult x y) c = eval'' x (MULT y : c)
169 |
170 | exec :: Cont -> Int -> Int
171 | exec [] n = n
172 | exec (ADD y : c) n = eval'' y (PLUS n : c)
173 | exec (MULT y : c) n = eval'' y (TIMES n : c)
174 | exec (PLUS n : c) m = exec c (n + m)
175 | exec (TIMES n : c) m = exec c (n * m)
176 |
177 | value :: Expr -> Int
178 | value e = eval'' e []
179 |
--------------------------------------------------------------------------------
/09-the-countdown-problem/09.11-exercises.hs:
--------------------------------------------------------------------------------
1 | -- 1.
2 | -- Redefine the combinatorial function `choices` using a list comprehension.
3 | choices' :: [a] -> [[a]]
4 | choices' xs = [ys | yss <- subs xs,
5 | ys <- perms yss]
6 |
7 | -- 2.
8 | -- Define a recursive function that decides if one list is chosen from another
9 | -- without using the combinatorial functions `perms` and `subs`.
10 | removeFirst :: Eq a => a -> [a] -> [a]
11 | removeFirst x [] = []
12 | removeFirst x (y:ys) | x == y = ys
13 | | otherwise = y : removeFirst x ys
14 |
15 | isChoice :: Eq a => [a] -> [a] -> Bool
16 | isChoice [] _ = True
17 | isChoice (x:xs) [] = False
18 | isChoice (x:xs) ys = elem x ys && isChoice xs (removeFirst x ys)
19 |
20 | -- 3.
21 | -- What effect on the function `solutions` would the function `split` have
22 | -- if it was modified to also return pairs of containing the empty list.
23 | --
24 | -- It would never terminate.
25 |
26 | -- 4.
27 | -- Using the functions `choices`, `exprs`, and `eval`, verify that there are
28 | -- 33,665,406 possible expressions over the numbers 1, 3, 7, 10, 25, 50,
29 | -- and that only 4,672,540 of these expressions evaluate successfully.
30 | possibleExprs :: [Int] -> [Expr]
31 | possibleExprs = concat . map exprs . choices
32 |
33 | successfulExprs :: [Int] -> [[Int]]
34 | successfulExprs = filter (not . null) . map eval . possibleExprs
35 |
36 | totalPossible :: [Int] -> Int
37 | totalPossible = length . possibleExprs
38 |
39 | totalSuccessful :: [Int] -> Int
40 | totalSuccessful = length . successfulExprs
41 |
42 | -- 5.
43 | -- Verify that the number of expressions that evaluate successfully increases
44 | -- to 10,839,369 if the numeric domain is generalized to arbitrary integers.
45 | --
46 | -- valid :: Op -> Int -> Int -> Bool
47 | -- valid Add _ _ = True
48 | -- valid Sub x y = True
49 | -- valid Mul _ _ = True
50 | -- valid Div x y = y /= 0 && x `mod` y == 0
51 | --
52 | -- Replacing `valid` with the definition above when running `totalSuccessful`
53 | -- verifies that the number of expressions that evaluate successfully
54 | -- increases to 10,839,369.
55 |
56 | -- 6.
57 | -- Modify the final program to:
58 | -- a. allow the use of exponentiation in expressions.
59 | -- b. produce the nearest solutions if no exact solution is possible.
60 | -- c. order the solutions using a suitable measure of simplicity.
61 |
62 | ---------------------------------------
63 | -- The coundown problem
64 | --
65 | -- Given a sequence of numbers and a target number, attempt to construct an
66 | -- expression whose value is the target, by combining one or more numbers from
67 | -- the sequence using addition, subtraction, multiplication, division and
68 | -- parentheses. Each number in the sequence can only be used at most once and
69 | -- all of the involved, including intermediate values must be positive natural
70 | -- numbers.
71 |
72 | data Op =
73 | Add
74 | | Sub
75 | | Mul
76 | | Div
77 | -- added for exercise 6a.
78 | | Pow
79 |
80 | instance Show Op where
81 | show Add = "+"
82 | show Sub = "-"
83 | show Mul = "*"
84 | show Div = "/"
85 | -- added for exercise 6a.
86 | show Pow = "^"
87 |
88 | valid :: Op -> Int -> Int -> Bool
89 | valid Add x y = x <= y
90 | valid Sub x y = x > y
91 | valid Mul x y = x /= 1 && y /= 1 && x <= y
92 | valid Div x y = y /= 1 && x `mod` y == 0
93 | -- added for exercise 6a.
94 | valid Pow x y = x <- y && y >= 0
95 |
96 | apply :: Op -> Int -> Int -> Int
97 | apply Add x y = x + y
98 | apply Sub x y = x - y
99 | apply Mul x y = x * y
100 | apply Div x y = x `div` y
101 | -- added for exercise 6a.
102 | apply Pow x y = x ^ x
103 |
104 | data Expr = Val Int | App Op Expr Expr
105 |
106 | instance Show Expr where
107 | show (Val n) = show n
108 | show (App o l r) = brak l ++ show o ++ brak r
109 | where
110 | brak (Val n) = show n
111 | brak e = "(" ++ show e ++ ")"
112 |
113 | values :: Expr -> [Int]
114 | values (Val n) = [n]
115 | values (App _ l r) = values l ++ values r
116 |
117 | eval :: Expr -> [Int]
118 | eval (Val n) = [n | n > 0]
119 | eval (App o l r) = [apply o x y | x <- eval l,
120 | y <- eval r,
121 | valid o x y]
122 |
123 | -- | This returns all subsequences of a list, which are given by all possible
124 | -- combinations of excluding or including each element of the list.
125 | subs :: [a] -> [[a]]
126 | subs [] = [[]]
127 | subs (x:xs) = yss ++ map (x:) yss
128 | where
129 | yss = subs xs
130 |
131 | -- | This returns all possible ways of inserting a new element into a list.
132 | interleave :: a -> [a] -> [[a]]
133 | interleave x [] = [[x]]
134 | interleave x (y:ys) = (x:y:ys) : map (y:) (interleave x ys)
135 |
136 | -- | This returns all permutations of a list, which are given by all possible
137 | -- reorderings of the elements.
138 | perms :: [a] -> [[a]]
139 | perms [] = [[]]
140 | perms (x:xs) = concat (map (interleave x) (perms xs))
141 |
142 | -- | This returns all choices from a list, which are given by all possible
143 | -- ways of selecting zero or more elemenets in any order by considering all
144 | -- permutations of all subsequences.
145 | choices :: [a] -> [[a]]
146 | choices = concat . map perms . subs
147 |
148 | -- | This defines what it means to solve an instance of the countdown
149 | -- problem.
150 | --
151 | -- Given a list of numbers and a target, an expression is a solution if:
152 | --
153 | -- * The list of values in the expression is chosen from the list of numbers.
154 | -- * The expression successfully evaluates to give the target.
155 | solution :: Expr -> [Int] -> Int -> Bool
156 | solution e ns n =
157 | elem (values e) (choices ns) && eval e == [n]
158 |
159 | -- | Returns all possible ways of splitting a list into two non-empty lists
160 | -- that append to give the original list.
161 | split :: [a] -> [([a], [a])]
162 | split [] = []
163 | split [_] = []
164 | split (x:xs) = ([x], xs) : [(x:ls, rs) | (ls, rs) <- split xs]
165 |
166 | -- | Returns all possible expressions whose list of values is precisely a
167 | -- given list.
168 | -- For an empty list of numbers there are no possible expressions.
169 | -- For a single number there is a single expression comprising that number.
170 | -- Otherwise, for a list of two or more numbers first produce all splittings
171 | -- of the list, then recursively calculate all possible expressions for each
172 | -- of these lists.
173 | -- Finally, combine each pair of expressions using each of the four numeric
174 | -- operators.
175 | exprs :: [Int] -> [Expr]
176 | exprs [] = []
177 | exprs [n] = [Val n]
178 | exprs ns = [e | (ls, rs) <- split ns,
179 | l <- exprs ls,
180 | r <- exprs rs,
181 | e <- combine l r]
182 |
183 | combine :: Expr -> Expr -> [Expr]
184 | combine l r = [App o l r | o <- ops]
185 |
186 | ops :: [Op]
187 | ops = [Add, Sub, Mul, Div, Pow]
188 |
189 | -- | Returns all possible expressions that solve an instance of the countdown
190 | -- problem by first generating all expressions over each choice from the given
191 | -- list of numbers, and selecting those expressions that successfully evaluate
192 | -- the target.
193 | solutions :: [Int] -> Int -> [Expr]
194 | solutions ns n =
195 | [e | ns' <- choices ns, e <- exprs ns', eval e == [n]]
196 |
197 | main :: IO ()
198 | main = print (solutions [1,3,7,10,25,50] 765)
199 |
200 | type Result = (Expr, Int)
201 |
202 | -- | Returns all possible results comprising expressions whose list of values
203 | -- is precisely a given list.
204 | --
205 | -- For the empty list there are no possible results.
206 | -- For a single number there is a single result formed from that number.
207 | -- Otherwise, for two or more numbers we first produce all splittings of the
208 | -- list, then recursively calculate all possible results for each of these
209 | -- lists
210 | -- Finally, combine each of the four numeric operators that are valid.
211 | results :: [Int] -> [Result]
212 | results [] = []
213 | results [n] = [(Val n, n) | n > 0]
214 | results ns = [res | (ls, rs) <- split ns,
215 | lx <- results ls,
216 | ry <- results rs,
217 | res <- combine' lx ry]
218 |
219 | combine' :: Result -> Result -> [Result]
220 | combine' (l,x) (r,y) =
221 | [(App o l r, apply o x y) | o <- ops, valid o x y]
222 |
223 | solutions' :: [Int] -> Int -> [Expr]
224 | solutions' ns n =
225 | [e | ns' <- choices ns, (e, m) <- results ns', m == n]
226 |
--------------------------------------------------------------------------------
/10-interactive-programming/10.6-hangman.hs:
--------------------------------------------------------------------------------
1 | import System.IO
2 |
3 | hangman :: IO ()
4 | hangman = do
5 | putStrLn "Think of a word:"
6 | word <- sgetLine
7 | putStrLn "Try to guess it:"
8 | play word
9 |
10 | sgetLine :: IO String
11 | sgetLine = do x <- getCh
12 | if x == '\n' then
13 | do putChar x
14 | return []
15 | else
16 | do putChar '_'
17 | xs <- sgetLine
18 | return (x:xs)
19 |
20 | getCh :: IO Char
21 | getCh = do hSetEcho stdin False
22 | x <- getChar
23 | hSetEcho stdin True
24 | return x
25 |
26 | play :: String -> IO ()
27 | play word = do putStr "? "
28 | guess <- getLine
29 | if guess == word then
30 | putStrLn "You did it."
31 | else
32 | do putStrLn (match word guess)
33 | play word
34 |
35 | match :: String -> String -> String
36 | match xs ys = [if elem x ys then x else '-' | x <- xs]
37 |
--------------------------------------------------------------------------------
/10-interactive-programming/10.8-nim.hs:
--------------------------------------------------------------------------------
1 | import Data.Char
2 |
3 | next :: Int -> Int
4 | next 1 = 2
5 | next 2 = 1
6 |
7 | type Board = [Int]
8 |
9 | initial :: Board
10 | initial = [5,4,3,2,1]
11 |
12 | finished :: Board -> Bool
13 | finished = all (== 0)
14 |
15 | valid :: Board -> Int -> Int -> Bool
16 | valid board row num = board !! (row-1) >= num
17 |
18 | move :: Board -> Int -> Int -> Board
19 | move board row num = [update r n | (r, n) <- zip [1..] board]
20 | where
21 | update r n = if r == row then n - num else n
22 |
23 | putRow :: Int -> Int -> IO ()
24 | putRow row num = do putStr (show row)
25 | putStr ": "
26 | putStrLn (concat (replicate num "* "))
27 |
28 | putBoard :: Board -> IO ()
29 | putBoard [a,b,c,d,e] = do putRow 1 a
30 | putRow 2 b
31 | putRow 3 c
32 | putRow 4 d
33 | putRow 5 e
34 |
35 | getDigit :: String -> IO Int
36 | getDigit prompt = do putStr prompt
37 | x <- getChar
38 | newline
39 | if isDigit x then
40 | return (digitToInt x)
41 | else
42 | do putStrLn "ERROR: Invalid digit"
43 | getDigit prompt
44 |
45 | newline :: IO ()
46 | newline = putChar '\n'
47 |
48 | play :: Board -> Int -> IO ()
49 | play board player =
50 | do newline
51 | putBoard board
52 | if finished board then
53 | do newline
54 | putStr "Player "
55 | putStr (show (next player))
56 | putStrLn " wins!"
57 | else
58 | do newline
59 | putStr "Player "
60 | putStrLn (show player)
61 | row <- getDigit "Enter a row number: "
62 | num <- getDigit "Stars to remove: "
63 | if valid board row num then
64 | play (move board row num) (next player)
65 | else
66 | do newline
67 | putStrLn "ERROR: Invalid move"
68 | play board player
69 |
70 | nim :: IO ()
71 | nim = play initial 1
72 |
--------------------------------------------------------------------------------
/12-monads-and-more/12.03-monads.hs:
--------------------------------------------------------------------------------
1 | type State = Int
2 |
3 | newtype ST a = S (State -> (a, State))
4 |
5 | apState :: ST a -> State -> (a, State)
6 | apState (S st) x = st x
7 |
8 | mkState :: a -> ST a
9 | mkState x = S (\y -> (x, y))
10 |
11 | instance Functor ST where
12 | fmap f (S st) = S $ \s ->
13 | let (x, s') = st s
14 | in (f x, s')
15 |
16 | instance Applicative ST where
17 | pure x = S $ \s -> (x, s)
18 | (S fx) <*> (S gx) = S $ \s ->
19 | let (f, s') = fx s
20 | (x, s'') = gx s'
21 | in (f x, s'')
22 |
23 | instance Monad ST where
24 | (S st) >>= f = S $ \s ->
25 | let (x, s') = st s
26 | (S st') = f x
27 | in st' s'
28 |
29 | data Tree a = Leaf a
30 | | Node (Tree a) (Tree a)
31 | deriving Show
32 |
33 | tree :: Tree Char
34 | tree = Node (Node (Leaf 'a') (Leaf 'b')) (Leaf 'c')
35 |
36 | rlabel :: Tree a -> Int -> (Tree Int, Int)
37 | rlabel (Leaf _) n = (Leaf n, n + 1)
38 | rlabel (Node l r) n = (Node l' r', n'')
39 | where
40 | (l', n') = rlabel l n
41 | (r', n'') = rlabel r n'
42 |
43 | fresh :: ST Int
44 | fresh = S (\n -> (n, n + 1))
45 |
46 | alabel :: Tree a -> ST (Tree Int)
47 | alabel (Leaf _) = Leaf <$> fresh
48 | alabel (Node l r) = Node <$> alabel l <*> alabel r
49 |
50 | mlabel :: Tree a -> ST (Tree Int)
51 | mlabel (Leaf _) = do n <- fresh
52 | return (Leaf n)
53 | mlabel (Node l r) = do l' <- mlabel l
54 | r' <- mlabel r
55 | return (Node l' r')
56 |
57 | mlabel' :: Tree a -> ST (Tree Int)
58 | mlabel' (Leaf _) = fresh >>= \n ->
59 | return (Leaf n)
60 | mlabel' (Node l r) = mlabel' l >>= \l' ->
61 | mlabel' r >>= \r' ->
62 | return (Node l' r')
63 |
64 |
65 |
--------------------------------------------------------------------------------
/12-monads-and-more/12.05-exercises.hs:
--------------------------------------------------------------------------------
1 | -- 1.
2 | data Tree a = Leaf
3 | | Node (Tree a) a (Tree a)
4 | deriving Show
5 |
6 | instance Functor Tree where
7 | fmap f (Node l x r) = Node (fmap f l) (f x) (fmap f r)
8 | fmap _ Leaf = Leaf
9 |
10 | -----------------------------------------------------------------------------
11 | -- 2.
12 | instance Functor ((->) a) where
13 | fmap = (.)
14 |
15 | -----------------------------------------------------------------------------
16 | -- 3.
17 | instance Applicative ((->) a) where
18 | pure x = \_ -> x
19 | f <*> g = \x -> f x $ g x
20 |
21 | -----------------------------------------------------------------------------
22 | -- 4.
23 | newtype ZipList a = Z [a]
24 | deriving Show
25 |
26 | instance Functor ZipList where
27 | fmap f (Z xs) = Z (fmap f xs)
28 |
29 | instance Applicative ZipList where
30 | pure x = Z $ repeat x
31 | Z fs <*> Z xs = Z [f x | (f, x) <- zip fs xs]
32 |
33 | -----------------------------------------------------------------------------
34 | -- 5.
35 | -- What?
36 |
37 | -----------------------------------------------------------------------------
38 | -- 6.
39 | instance Monad ((->) a) where
40 | return = pure
41 | mx >>= f = \x -> f (mx x) x
42 |
43 | -----------------------------------------------------------------------------
44 | -- 7.
45 | data Expr a = Var a
46 | | Val Int
47 | | Add (Expr a) (Expr a)
48 | deriving Show
49 |
50 | instance Functor Expr where
51 | fmap f (Var x) = Var (f x)
52 | fmap _ (Val x) = Val x
53 | fmap f (Add x y) = Add (fmap f x) (fmap f y)
54 |
55 | instance Applicative Expr where
56 | pure = Var
57 | _ <*> Val x = Val x
58 | Val x <*> _ = Val x
59 | Var f <*> Var x = Var (f x)
60 | Var f <*> Add x y = Add (fmap f x) (fmap f y)
61 | Add f g <*> x = Add (f <*> x) (g <*> x)
62 |
63 | instance Monad Expr where
64 | return = pure
65 | Val x >>= _ = Val x
66 | Var x >>= f = f x
67 | Add x y >>= f = Add (x >>= f) (y >>= f)
68 |
69 | -----------------------------------------------------------------------------
70 | -- 8.
71 | type State = Int
72 |
73 | newtype ST a = S (State -> (a, State))
74 |
75 | instance Functor ST where
76 | fmap f st = do
77 | x <- st
78 | S $ \s -> (f x, s)
79 |
80 | instance Applicative ST where
81 | pure x = S $ \s -> (x, s)
82 | stf <*> stx = do
83 | f <- stf
84 | x <- stx
85 | return $ f x
86 |
87 | instance Monad ST where
88 | S st >>= f = S $ \s ->
89 | let (x, s') = st s
90 | (S st') = f x
91 | in st' s'
92 |
--------------------------------------------------------------------------------
/13-monadic-parsing/13.03-basic-definitions.hs:
--------------------------------------------------------------------------------
1 | import Control.Applicative
2 | import Data.Char
3 |
4 | newtype Parser a = P (String -> [(a, String)])
5 |
6 | -- | Removes the `P` dummy constructor from the `Parser` type and applies it to
7 | -- an input string.
8 | parse :: Parser a -> String -> [(a, String)]
9 | parse (P p) inp = p inp
10 |
11 | -- | Fails if the input string is empty, otherwise succeeds with the first
12 | -- character as the result value.
13 | item :: Parser Char
14 | item = P $ \inp ->
15 | case inp of
16 | [] -> []
17 | (x:xs) -> [(x, xs)]
18 |
--------------------------------------------------------------------------------
/13-monadic-parsing/13.04-sequencing-parsers.hs:
--------------------------------------------------------------------------------
1 | import Control.Applicative
2 | import Data.Char
3 |
4 | newtype Parser a = P (String -> [(a, String)])
5 |
6 | -- | Removes the `P` dummy constructor from the `Parser` type and applies it to
7 | -- an input string.
8 | parse :: Parser a -> String -> [(a, String)]
9 | parse (P p) inp = p inp
10 |
11 | -- | Fails if the input string is empty, otherwise succeeds with the first
12 | -- character as the result value.
13 | item :: Parser Char
14 | item = P $ \inp ->
15 | case inp of
16 | [] -> []
17 | (x:xs) -> [(x, xs)]
18 |
19 | -- | Applies a function to the result value of a parser if the parser succeeds,
20 | -- and propagates the failure otherwise.
21 | instance Functor Parser where
22 | fmap f p = P $ \str ->
23 | case parse p str of
24 | [] -> []
25 | [(x, xs)] -> [(f x, xs)]
26 |
27 | -- | The `pure` function transforms a value into a parser that always succeeds
28 | -- with this value as its result without consuming any of the input string.
29 | -- | The `<*>` function applies a parser `pf` that returns a function `f` and
30 | -- an argument `xs` to a parser `px` that returns the result of applying
31 | -- the function `fmap f px` to the argument `xs`, and only succeeds if all the
32 | -- components succeed.
33 | instance Applicative Parser where
34 | pure x = P $ \str -> [(x, str)]
35 |
36 | pf <*> px = P $ \str ->
37 | case parse pf str of
38 | [] -> []
39 | [(f, xs)] -> parse (fmap f px) xs
40 |
41 | -- | Applies the function `f` to the result value `x` from applying the parser
42 | -- `p` to the input string `str`, which when `f x` is applied returns a parser
43 | -- which is then applied with the output string `xs`.
44 | instance Monad Parser where
45 | return = pure
46 |
47 | p >>= f = P $ \str ->
48 | case parse p str of
49 | [] -> []
50 | [(x, xs)] -> parse (f x) xs
51 |
--------------------------------------------------------------------------------
/13-monadic-parsing/13.05-making-choices.hs:
--------------------------------------------------------------------------------
1 | import Control.Applicative
2 |
3 | newtype Parser a = P (String -> [(a, String)])
4 |
5 | parse :: Parser a -> String -> [(a, String)]
6 | parse (P p) inp = p inp
7 |
8 | item :: Parser Char
9 | item = P $ \inp ->
10 | case inp of
11 | [] -> []
12 | (x:xs) -> [(x, xs)]
13 |
14 | instance Functor Parser where
15 | fmap f p = P $ \str ->
16 | case parse p str of
17 | [] -> []
18 | [(x, xs)] -> [(f x, xs)]
19 |
20 | instance Applicative Parser where
21 | pure x = P $ \str -> [(x, str)]
22 |
23 | pf <*> px = P $ \str ->
24 | case parse pf str of
25 | [] -> []
26 | [(f, xs)] -> parse (fmap f px) xs
27 |
28 | instance Monad Parser where
29 | return = pure
30 |
31 | p >>= f = P $ \str ->
32 | case parse p str of
33 | [] -> []
34 | [(x, xs)] -> parse (f x) xs
35 |
36 | instance Alternative Parser where
37 | empty = P $ \x -> []
38 |
39 | p <|> q = P $ \x ->
40 | case parse p x of
41 | [] -> parse q x
42 | [(v, y)] -> [(v, y)]
43 |
--------------------------------------------------------------------------------
/13-monadic-parsing/13.06-derived-primitives.hs:
--------------------------------------------------------------------------------
1 | import Control.Applicative
2 | import Data.Char
3 |
4 | newtype Parser a = P (String -> [(a, String)])
5 |
6 | parse :: Parser a -> String -> [(a, String)]
7 | parse (P p) inp = p inp
8 |
9 | item :: Parser Char
10 | item = P $ \inp ->
11 | case inp of
12 | [] -> []
13 | (x:xs) -> [(x, xs)]
14 |
15 | -- | Three basic parsers: `item`, `return v`, and `empty`.
16 |
17 | -- | Succeeds for Single characters that satify the predicate function `p`.
18 | sat :: (Char -> Bool) -> Parser Char
19 | sat p = do
20 | x <- item
21 | if p x
22 | then return x
23 | else empty
24 |
25 | -- | The `digit` parser is defined for single digits.
26 | digit :: Parser Char
27 | digit = sat isDigit
28 |
29 | -- | The `lower` parser is defined for lower-case letters.
30 | lower :: Parser Char
31 | lower = sat isLower
32 |
33 | -- | The `upper` parser is defined for upper-case letters.
34 | upper :: Parser Char
35 | upper = sat isUpper
36 |
37 | -- | The `letter` parser is defined for arbitrary letters.
38 | letter :: Parser Char
39 | letter = sat isAlpha
40 |
41 | -- | The `alphaum` parser is defined for alphanumerica characters.
42 | alphanum :: Parser Char
43 | alphanum = sat isAlphaNum
44 |
45 | -- | The `char` parser is defined for specific characters.
46 | char :: Char -> Parser Char
47 | char x = sat (== x)
48 |
49 | -- | The `string` parser is defined for the string of characters `xs`
50 | -- with the string itself returned as the result value and succeeds only if the
51 | -- entire target string is consumed from the input to the parser.
52 | string :: String -> Parser String
53 | string [] = return []
54 | string (x:xs) = do
55 | char x
56 | string xs
57 | return (x:xs)
58 |
59 | -- | The `ident` parser is defined for strings comprising a lower-case letter
60 | -- followed by zero or more alphanueric characters
61 | ident :: Parser String
62 | ident = do
63 | x <- lower
64 | xs <- many alphanum
65 | return (x:xs)
66 |
67 | -- | The `nat` parser is defined for natural numbers comprising one or more
68 | -- digits.
69 | nat :: Parser Int
70 | nat = do
71 | xs <- some digit
72 | return (read xs)
73 |
74 | -- | The `space` parser is defined for spacing comprising zero or more space,
75 | -- tab, and newline characters.
76 | space :: Parser ()
77 | space = do
78 | many (sat isSpace)
79 | return ()
80 |
81 | -- | The `int` parser is defined for integer values.
82 | int :: Parser Int
83 | int = do
84 | char '-'
85 | n <- nat
86 | return (-n) <|> nat
87 |
88 | instance Functor Parser where
89 | fmap f p = P $ \inp ->
90 | case parse p inp of
91 | [] -> []
92 | [(v, out)] -> [(f v, out)]
93 |
94 | instance Applicative Parser where
95 | pure v = P $ \inp -> [(v, inp)]
96 |
97 | pf <*> px = P $ \inp ->
98 | case parse pf inp of
99 | [] -> []
100 | [(f, out)] -> parse (fmap f px) out
101 |
102 | instance Monad Parser where
103 | p >>= f = P $ \inp ->
104 | case parse p inp of
105 | [] -> []
106 | [(v, out)] -> parse (f v) out
107 |
108 | instance Alternative Parser where
109 | empty = P $ \inp -> []
110 |
111 | p <|> q = P $ \inp ->
112 | case parse p inp of
113 | [] -> parse q inp
114 | [(v, out)] -> [(v, out)]
115 |
--------------------------------------------------------------------------------
/13-monadic-parsing/13.07-handling-space.hs:
--------------------------------------------------------------------------------
1 | import Control.Applicative
2 | import Data.Char
3 |
4 | newtype Parser a = P (String -> [(a, String)])
5 |
6 | parse :: Parser a -> String -> [(a, String)]
7 | parse (P p) inp = p inp
8 |
9 | item :: Parser Char
10 | item = P $ \inp ->
11 | case inp of
12 | [] -> []
13 | (x:xs) -> [(x, xs)]
14 |
15 | sat :: (Char -> Bool) -> Parser Char
16 | sat p = do
17 | x <- item
18 | if p x
19 | then return x
20 | else empty
21 |
22 | digit :: Parser Char
23 | digit = sat isDigit
24 |
25 | lower :: Parser Char
26 | lower = sat isLower
27 |
28 | upper :: Parser Char
29 | upper = sat isUpper
30 |
31 | letter :: Parser Char
32 | letter = sat isAlpha
33 |
34 | alphanum :: Parser Char
35 | alphanum = sat isAlphaNum
36 |
37 | char :: Char -> Parser Char
38 | char x = sat (== x)
39 |
40 | string :: String -> Parser String
41 | string [] = return []
42 | string (x:xs) = do
43 | char x
44 | string xs
45 | return (x:xs)
46 |
47 | ident :: Parser String
48 | ident = do
49 | x <- lower
50 | xs <- many alphanum
51 | return (x:xs)
52 |
53 | nat :: Parser Int
54 | nat = do
55 | xs <- some digit
56 | return (read xs)
57 |
58 | space :: Parser ()
59 | space = do
60 | many (sat isSpace)
61 | return ()
62 |
63 | int :: Parser Int
64 | int = do
65 | char '-'
66 | n <- nat
67 | return (-n) <|> nat
68 |
69 | -- | The `token` function defines a new primitive that ignores any space before
70 | -- and after applying a parser for a token.
71 | token :: Parser a -> Parser a
72 | token p = do
73 | space
74 | v <- p
75 | space
76 | return v
77 |
78 | identifier :: Parser String
79 | identifier = token ident
80 |
81 | natural :: Parser Int
82 | natural = token nat
83 |
84 | integer :: Parser Int
85 | integer = token int
86 |
87 | symbol :: String -> Parser String
88 | symbol xs = token (string xs)
89 |
90 | -- | The `nats` parser is defined for a non-empty list of natural numbers that
91 | -- ignores spacing around tokens.
92 | nats :: Parser [Int]
93 | nats = do
94 | symbol "["
95 | n <- natural
96 | ns <- many $ do
97 | symbol ","
98 | natural
99 | symbol "]"
100 | return (n:ns)
101 |
102 | instance Functor Parser where
103 | fmap f p = P $ \inp ->
104 | case parse p inp of
105 | [] -> []
106 | [(v, out)] -> [(f v, out)]
107 |
108 | instance Applicative Parser where
109 | pure v = P $ \inp -> [(v, inp)]
110 |
111 | pf <*> px = P $ \inp ->
112 | case parse pf inp of
113 | [] -> []
114 | [(f, out)] -> parse (fmap f px) out
115 |
116 | instance Monad Parser where
117 | p >>= f = P $ \inp ->
118 | case parse p inp of
119 | [] -> []
120 | [(v, out)] -> parse (f v) out
121 |
122 | instance Alternative Parser where
123 | empty = P $ \inp -> []
124 |
125 | p <|> q = P $ \inp ->
126 | case parse p inp of
127 | [] -> parse q inp
128 | [(v, out)] -> [(v, out)]
129 |
--------------------------------------------------------------------------------
/13-monadic-parsing/13.08-arithmetic-expressions.hs:
--------------------------------------------------------------------------------
1 | import Control.Applicative
2 | import Data.Char
3 |
4 | newtype Parser a = P (String -> [(a, String)])
5 |
6 | -----------------------------------------------------------------------------
7 | -- expr ::= term (+ expr | ∊)
8 | -- term ::= factor (* term | ∊)
9 | -- factor ::= ( expr ) | nat
10 | -- nat ::= 0 | 1 | 2 | ...
11 | -----------------------------------------------------------------------------
12 |
13 | expr :: Parser Int
14 | expr = do
15 | t <- term
16 | do
17 | symbol "+"
18 | e <- expr
19 | return (t + e) <|> return t
20 |
21 | term :: Parser Int
22 | term = do
23 | f <- factor
24 | do
25 | symbol "*"
26 | t <- term
27 | return (f * t) <|> return f
28 |
29 | factor :: Parser Int
30 | factor = do
31 | symbol "("
32 | e <- expr
33 | symbol ")"
34 | return e <|> natural
35 |
36 | eval :: String -> Int
37 | eval xs = case (parse expr xs) of
38 | [(n, [])] -> n
39 | [(_, out)] -> error ("Unused input " ++ out)
40 | [] -> error "Invalid input"
41 |
42 | parse :: Parser a -> String -> [(a, String)]
43 | parse (P p) inp = p inp
44 |
45 | item :: Parser Char
46 | item = P $ \inp ->
47 | case inp of
48 | [] -> []
49 | (x:xs) -> [(x, xs)]
50 |
51 | sat :: (Char -> Bool) -> Parser Char
52 | sat p = do
53 | x <- item
54 | if p x
55 | then return x
56 | else empty
57 |
58 | digit :: Parser Char
59 | digit = sat isDigit
60 |
61 | lower :: Parser Char
62 | lower = sat isLower
63 |
64 | upper :: Parser Char
65 | upper = sat isUpper
66 |
67 | letter :: Parser Char
68 | letter = sat isAlpha
69 |
70 | alphanum :: Parser Char
71 | alphanum = sat isAlphaNum
72 |
73 | char :: Char -> Parser Char
74 | char x = sat (== x)
75 |
76 | string :: String -> Parser String
77 | string [] = return []
78 | string (x:xs) = do
79 | char x
80 | string xs
81 | return (x:xs)
82 |
83 | ident :: Parser String
84 | ident = do
85 | x <- lower
86 | xs <- many alphanum
87 | return (x:xs)
88 |
89 | nat :: Parser Int
90 | nat = do
91 | xs <- some digit
92 | return (read xs)
93 |
94 | space :: Parser ()
95 | space = do
96 | many (sat isSpace)
97 | return ()
98 |
99 | int :: Parser Int
100 | int = do
101 | char '-'
102 | n <- nat
103 | return (-n) <|> nat
104 |
105 | token :: Parser a -> Parser a
106 | token p = do
107 | space
108 | v <- p
109 | space
110 | return v
111 |
112 | identifier :: Parser String
113 | identifier = token ident
114 |
115 | natural :: Parser Int
116 | natural = token nat
117 |
118 | integer :: Parser Int
119 | integer = token int
120 |
121 | symbol :: String -> Parser String
122 | symbol xs = token (string xs)
123 |
124 | nats :: Parser [Int]
125 | nats = do
126 | symbol "["
127 | n <- natural
128 | ns <- many $ do
129 | symbol ","
130 | natural
131 | symbol "]"
132 | return (n:ns)
133 |
134 | instance Functor Parser where
135 | fmap f p = P $ \inp ->
136 | case parse p inp of
137 | [] -> []
138 | [(v, out)] -> [(f v, out)]
139 |
140 | instance Applicative Parser where
141 | pure v = P $ \inp -> [(v, inp)]
142 |
143 | pf <*> px = P $ \inp ->
144 | case parse pf inp of
145 | [] -> []
146 | [(f, out)] -> parse (fmap f px) out
147 |
148 | instance Monad Parser where
149 | p >>= f = P $ \inp ->
150 | case parse p inp of
151 | [] -> []
152 | [(v, out)] -> parse (f v) out
153 |
154 | instance Alternative Parser where
155 | empty = P $ \inp -> []
156 |
157 | p <|> q = P $ \inp ->
158 | case parse p inp of
159 | [] -> parse q inp
160 | [(v, out)] -> [(v, out)]
161 |
--------------------------------------------------------------------------------
/13-monadic-parsing/13.09-calculator.hs:
--------------------------------------------------------------------------------
1 | import Control.Applicative
2 | import Data.Char
3 | import System.IO
4 |
5 | box :: [String]
6 | box = ["+---------------+",
7 | "| |",
8 | "+---+---+---+---+",
9 | "| q | c | d | = |",
10 | "+---+---+---+---+",
11 | "| 1 | 2 | 3 | + |",
12 | "+---+---+---+---+",
13 | "| 4 | 5 | 6 | - |",
14 | "+---+---+---+---+",
15 | "| 7 | 8 | 9 | * |",
16 | "+---+---+---+---+",
17 | "| 0 | ( | ) | / |",
18 | "+---+---+---+---+"]
19 |
20 | buttons :: String
21 | buttons = standard ++ extra
22 | where
23 | standard = "qcd=123+456-789*0()/"
24 | extra = "QCD \ESC\BS\DEL\n"
25 |
26 | cls :: IO ()
27 | cls = putStr "\ESC[2J"
28 |
29 | writeat :: (Int, Int) -> String -> IO ()
30 | writeat p xs = do
31 | goto p
32 | putStr xs
33 |
34 | goto :: (Int, Int) -> IO ()
35 | goto (x, y) = putStr ("\ESC[" ++ show y ++ ";" ++ show x ++ "H")
36 |
37 | getCh :: IO Char
38 | getCh = do
39 | hSetEcho stdin False
40 | x <- getChar
41 | hSetEcho stdin True
42 | return x
43 |
44 | showbox :: IO ()
45 | showbox = sequence_ [writeat (1,y) b | (y,b) <- zip [1..] box]
46 |
47 | display :: [Char] -> IO ()
48 | display xs = do
49 | writeat (3,2) (replicate 13 ' ')
50 | writeat (3,2) (reverse (take 13 (reverse xs)))
51 |
52 | calc :: String -> IO ()
53 | calc xs = do
54 | display xs
55 | c <- getCh
56 | if elem c buttons
57 | then process c xs
58 | else do beep
59 | calc xs
60 |
61 | process :: Char -> String -> IO ()
62 | process c xs | elem c "qQ\ESC" = quit
63 | | elem c "dD\BS\DEL" = delete xs
64 | | elem c "=\n" = eval xs
65 | | elem c "cC" = clear
66 | | otherwise = press c xs
67 |
68 | quit :: IO ()
69 | quit = goto (1, 14)
70 |
71 | delete :: String -> IO ()
72 | delete [] = calc []
73 | delete xs = calc (init xs)
74 |
75 | eval :: String -> IO ()
76 | eval xs = case parse expr xs of
77 | [(n, [])] -> calc (show n)
78 | _ -> do beep
79 | calc xs
80 |
81 | beep :: IO ()
82 | beep = putStr "\BEL"
83 |
84 | clear :: IO ()
85 | clear = calc []
86 |
87 | press :: Char -> String -> IO ()
88 | press c xs = calc (xs ++ [c])
89 |
90 | run :: IO ()
91 | run = do
92 | cls
93 | showbox
94 | clear
95 |
96 |
97 | newtype Parser a = P (String -> [(a, String)])
98 |
99 | -----------------------------------------------------------------------------
100 | -- expr ::= term (+ expr | ∊)
101 | -- term ::= factor (* term | ∊)
102 | -- factor ::= ( expr ) | nat
103 | -- nat ::= 0 | 1 | 2 | ...
104 | -----------------------------------------------------------------------------
105 |
106 | expr :: Parser Int
107 | expr = do
108 | t <- term
109 | do symbol "+"
110 | e <- expr
111 | return (t + e)
112 | <|> do symbol "-"
113 | e <- expr
114 | return (t - e)
115 | <|> return t
116 |
117 | term :: Parser Int
118 | term = do
119 | f <- factor
120 | do symbol "*"
121 | t <- term
122 | return (f * t)
123 | <|> do symbol "/"
124 | t <- term
125 | return (f `div` t)
126 | <|> return f
127 |
128 | factor :: Parser Int
129 | factor = do symbol "("
130 | e <- expr
131 | symbol ")"
132 | return e
133 | <|> nat
134 |
135 | parse :: Parser a -> String -> [(a, String)]
136 | parse (P p) inp = p inp
137 |
138 | item :: Parser Char
139 | item = P $ \inp ->
140 | case inp of
141 | [] -> []
142 | (x:xs) -> [(x, xs)]
143 |
144 | sat :: (Char -> Bool) -> Parser Char
145 | sat p = do
146 | x <- item
147 | if p x
148 | then return x
149 | else empty
150 |
151 | digit :: Parser Char
152 | digit = sat isDigit
153 |
154 | lower :: Parser Char
155 | lower = sat isLower
156 |
157 | upper :: Parser Char
158 | upper = sat isUpper
159 |
160 | letter :: Parser Char
161 | letter = sat isAlpha
162 |
163 | alphanum :: Parser Char
164 | alphanum = sat isAlphaNum
165 |
166 | char :: Char -> Parser Char
167 | char x = sat (== x)
168 |
169 | string :: String -> Parser String
170 | string [] = return []
171 | string (x:xs) = do
172 | char x
173 | string xs
174 | return (x:xs)
175 |
176 | ident :: Parser String
177 | ident = do
178 | x <- lower
179 | xs <- many alphanum
180 | return (x:xs)
181 |
182 | nat :: Parser Int
183 | nat = do
184 | xs <- some digit
185 | return (read xs)
186 |
187 | space :: Parser ()
188 | space = do
189 | many (sat isSpace)
190 | return ()
191 |
192 | int :: Parser Int
193 | int = do char '-'
194 | n <- nat
195 | return (-n)
196 | <|> nat
197 |
198 | token :: Parser a -> Parser a
199 | token p = do
200 | space
201 | v <- p
202 | space
203 | return v
204 |
205 | identifier :: Parser String
206 | identifier = token ident
207 |
208 | natural :: Parser Int
209 | natural = token nat
210 |
211 | integer :: Parser Int
212 | integer = token int
213 |
214 | symbol :: String -> Parser String
215 | symbol xs = token (string xs)
216 |
217 | nats :: Parser [Int]
218 | nats = do
219 | symbol "["
220 | n <- natural
221 | ns <- many $ do
222 | symbol ","
223 | natural
224 | symbol "]"
225 | return (n:ns)
226 |
227 | instance Functor Parser where
228 | fmap f p = P $ \inp ->
229 | case parse p inp of
230 | [] -> []
231 | [(v, out)] -> [(f v, out)]
232 |
233 | instance Applicative Parser where
234 | pure v = P $ \inp -> [(v, inp)]
235 |
236 | pf <*> px = P $ \inp ->
237 | case parse pf inp of
238 | [] -> []
239 | [(f, out)] -> parse (fmap f px) out
240 |
241 | instance Monad Parser where
242 | p >>= f = P $ \inp ->
243 | case parse p inp of
244 | [] -> []
245 | [(v, out)] -> parse (f v) out
246 |
247 | instance Alternative Parser where
248 | empty = P $ \inp -> []
249 |
250 | p <|> q = P $ \inp ->
251 | case parse p inp of
252 | [] -> parse q inp
253 | [(v, out)] -> [(v, out)]
254 |
--------------------------------------------------------------------------------
/13-monadic-parsing/13.11-exercises.hs:
--------------------------------------------------------------------------------
1 | import Control.Applicative
2 | import Data.Char
3 |
4 | -----------------------------------------------------------------------------
5 | -- 1.
6 | comment :: Parser ()
7 | comment = do
8 | string "--"
9 | many $ sat (/= '\n')
10 | return ()
11 |
12 | -----------------------------------------------------------------------------
13 | -- 2.
14 | -- expr
15 | -- / | \
16 | -- / + \
17 | -- expr expr
18 | -- / | \ \
19 | -- / + \ \
20 | -- expr expr term
21 | -- | | |
22 | -- term term factor
23 | -- | | |
24 | -- factor factor nat
25 | -- | | |
26 | -- nat nat 4
27 | -- | |
28 | -- 2 3
29 |
30 | -----------------------------------------------------------------------------
31 | -- 3.
32 | -- expr
33 | -- / | \
34 | -- / + \
35 | -- term expr
36 | -- | |
37 | -- factor term
38 | -- | |
39 | -- nat factor
40 | -- | |
41 | -- 2 nat
42 | -- |
43 | -- 3
44 |
45 | -----------------------------------------------------------------------------
46 | -- 4.
47 | -- Answer: Each number would end up being parsed multiple times before
48 | -- recognizing that it could be an expression.
49 |
50 | -----------------------------------------------------------------------------
51 | -- 5.
52 | data Expr = Val Int
53 | | Add Expr Expr
54 | | Sub Expr Expr
55 | deriving Show
56 |
57 | expr' :: Parser Expr
58 | expr' = do
59 | t <- term
60 | do symbol "+"
61 | e <- expr'
62 | return (Add (Val t) e)
63 | <|> do symbol "-"
64 | e <- expr'
65 | return (Sub (Val t) e)
66 | <|> return (Val t)
67 |
68 | -----------------------------------------------------------------------------
69 |
70 | expr :: Parser Int
71 | expr = do
72 | t <- term
73 | do symbol "+"
74 | e <- expr
75 | return (t + e)
76 | <|> do symbol "-"
77 | e <- expr
78 | return (t - e)
79 | <|> return t
80 |
81 | term :: Parser Int
82 | term = do
83 | f <- factor
84 | do symbol "*"
85 | t <- term
86 | return (f * t)
87 | <|> do symbol "/"
88 | t <- term
89 | return (f `div` t)
90 | <|> return f
91 |
92 | factor :: Parser Int
93 | factor = do symbol "("
94 | e <- expr
95 | symbol ")"
96 | return e
97 | <|> nat
98 | -----------------------------------------------------------------------------
99 | newtype Parser a = P (String -> [(a, String)])
100 |
101 | parse :: Parser a -> String -> [(a, String)]
102 | parse (P p) inp = p inp
103 |
104 | item :: Parser Char
105 | item = P $ \inp ->
106 | case inp of
107 | [] -> []
108 | (x:xs) -> [(x, xs)]
109 |
110 | sat :: (Char -> Bool) -> Parser Char
111 | sat p = do
112 | x <- item
113 | if p x
114 | then return x
115 | else empty
116 |
117 | symbol :: String -> Parser String
118 | symbol xs = token (string xs)
119 |
120 | token :: Parser a -> Parser a
121 | token p = do
122 | space
123 | v <- p
124 | space
125 | return v
126 |
127 | space :: Parser ()
128 | space = do
129 | many (sat isSpace)
130 | return ()
131 |
132 | nat :: Parser Int
133 | nat = do
134 | xs <- some digit
135 | return (read xs)
136 |
137 | digit :: Parser Char
138 | digit = sat isDigit
139 |
140 | string :: String -> Parser String
141 | string [] = return []
142 | string (x:xs) = do
143 | char x
144 | string xs
145 | return (x:xs)
146 |
147 | char :: Char -> Parser Char
148 | char x = sat (== x)
149 |
150 | instance Functor Parser where
151 | fmap f p = P $ \inp ->
152 | case parse p inp of
153 | [] -> []
154 | [(v, out)] -> [(f v, out)]
155 |
156 | instance Applicative Parser where
157 | pure v = P $ \inp -> [(v, inp)]
158 |
159 | pf <*> px = P $ \inp ->
160 | case parse pf inp of
161 | [] -> []
162 | [(f, out)] -> parse (fmap f px) out
163 |
164 | instance Monad Parser where
165 | p >>= f = P $ \inp ->
166 | case parse p inp of
167 | [] -> []
168 | [(v, out)] -> parse (f v) out
169 |
170 | instance Alternative Parser where
171 | empty = P $ \inp -> []
172 |
173 | p <|> q = P $ \inp ->
174 | case parse p inp of
175 | [] -> parse q inp
176 | [(v, out)] -> [(v, out)]
177 |
--------------------------------------------------------------------------------
/14-foldable-and-friends/14.5-exercises.hs:
--------------------------------------------------------------------------------
1 | -- Exercise 14.5
2 |
3 | -- 1.
4 | instance (Monoid a, Monoid b) => Monoid (a, b) where
5 | mempty = (mempty, mempty)
6 | (x1, y1) <> (x2, y2) = (x1 <> x2, y1 <> y2)
7 |
8 | -- 2.
9 | instance Monoid b => Monoid (a -> b) where
10 | mempty = \_ -> mempty
11 | f <> g = \x -> f x <> g x
12 |
13 | -- 3.
14 | instance Traversable Maybe where
15 | foldr _ _ Nothing = Nothing
16 | foldr f x (Just y) = Just (f (x `mappend` y))
17 |
18 | -- 4.
19 | data Tree a =
20 | Leaf
21 | | Node (Tree a) a (Tree a)
22 | deriving (Eq, Show)
23 |
24 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 |
2 | 
3 |
4 | Presented by Hyundai®
5 |
--------------------------------------------------------------------------------