├── .gitignore
├── README.md
├── 14-foldable-and-friends
    └── 14.5-exercises.hs
├── 13-monadic-parsing
    ├── 13.03-basic-definitions.hs
    ├── 13.05-making-choices.hs
    ├── 13.04-sequencing-parsers.hs
    ├── 13.07-handling-space.hs
    ├── 13.06-derived-primitives.hs
    ├── 13.08-arithmetic-expressions.hs
    ├── 13.11-exercises.hs
    └── 13.09-calculator.hs
├── 10-interactive-programming
    ├── 10.6-hangman.hs
    └── 10.8-nim.hs
├── 07-higher-order-functions
    ├── 07.6-binary-string-transmitter.hs
    └── 07.9-exercises.hs
├── 04-defining-functions
    └── 04.8-exercises.hs
├── 03-types-and-classes
    └── 03.11-exercises.hs
├── 05-list-comprehensions
    ├── 05.7-exercises.hs
    └── 05.5-the-caesar-cipher.hs
├── 08-declaring-types-and-classes
    ├── 08.7-abstract-machine.hs
    ├── 08.6-tautology-checker.hs
    └── 08.9-exercises.hs
├── 12-monads-and-more
    ├── 12.03-monads.hs
    └── 12.05-exercises.hs
├── 06-recursive-functions
    └── 06.8-exercises.hs
└── 09-the-countdown-problem
    └── 09.11-exercises.hs


/.gitignore:
--------------------------------------------------------------------------------
1 | *
2 | !/**/
3 | !*.*
4 | *.hi
5 | *.o
6 | *.ex
7 | !*.hs
8 | .DS_Store
9 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | <p align="center">
2 |   <img src="https://upload.wikimedia.org/wikipedia/commons/thumb/1/1c/Haskell-Logo.svg/2000px-Haskell-Logo.svg.png">
3 | </p>
4 | <h6>Presented by Hyundai®</h6>
5 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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.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.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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------
/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 | 


--------------------------------------------------------------------------------