├── 13-jolly-holiday.hs ├── playground.hs ├── 04-list-comprehensions.hs ├── 01-first-steps.hs ├── 05-recursive-functions.hs ├── 03-define-functions.hs ├── lab3.hs ├── 06-higher-order-functions.hs ├── 09-declaring-types-and-classes.hs ├── lab4.hs ├── lab5-pmc.hs ├── json-parser.hs ├── lab6.hs ├── 07-functional-parsers-and-monads.lhs ├── 08-interactive-programs.hs ├── lab2.hs └── 10-countdown-problem.lhs /13-jolly-holiday.hs: -------------------------------------------------------------------------------- 1 | foldl1 f a bs = foldr (\b -> \g -> (\a -> g (f a b))) id bs a 2 | foldl2 f a bs = foldr (\a b -> f b a) a bs 3 | foldl3 f = flip $ foldr (\a b g -> b (f g a)) id 4 | foldl4 = foldr . flip 5 | -------------------------------------------------------------------------------- /playground.hs: -------------------------------------------------------------------------------- 1 | swap (x, y) = (y, x) 2 | 3 | double x = x * 2 4 | 5 | plaindrome xs = reverse xs == xs 6 | 7 | twice f x = f (f x) 8 | 9 | revTake xs = take 3 (reverse xs) 10 | 11 | -- Doesn't need to have an 'otherwise' here. 12 | sneaky x | x > 0 = x 13 | | otherwise = -x 14 | 15 | 16 | -- A small exercise 17 | zipMe :: [a] -> [b] -> [(a, b)] 18 | zipMe (x:xs) (y:ys) = (x, y):(zipMe xs ys) 19 | zipMe _ _ = [] 20 | 21 | 22 | const x = \_ -> x 23 | 24 | e9 [x, y] = (x, True) 25 | 26 | e10 (x, y) = [x, y] 27 | 28 | -- e13 :: Int -> Int -> Int 29 | e13 x y = x + y * y 30 | 31 | -- For fun: defining reduce with recursion 32 | -- reduce' :: (a -> b -> a) -> a -> [b] -> a 33 | reduce' _ n [] = n 34 | reduce' f n (x:xs) = reduce' f (f n x) xs 35 | 36 | ones = 1 : ones 37 | -------------------------------------------------------------------------------- /04-list-comprehensions.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | 4 | pyths n 5 | = [(x,y,z) | x <- [1 .. n], y <- [1 .. n], z <- [1 .. n], 6 | x ^ 2 + y ^ 2 == z ^ 2] 7 | 8 | factors n = [x | x <- [1 .. n], n `mod` x == 0] 9 | 10 | perfects n = [x | x <- [1 .. n], sum (init (factors x)) == x] 11 | 12 | find k t = [v | (k', v) <- t, k == k'] 13 | 14 | positions x xs = find x (zip xs [0 .. n]) 15 | where n = length xs -1 16 | 17 | scalarproduct xs ys = sum [x * y | (x, y) <- xs `zip` ys] 18 | 19 | scalarproduct' xs ys = sum $ zipWith (*) xs ys 20 | 21 | -- Caesar cipher 22 | let2int b c = ord c - ord b 23 | int2let b n = chr (ord b + n) 24 | 25 | shift n c 26 | | isLower c = int2let 'a' ((let2int 'a' c + n) `mod` 26) 27 | | isUpper c = int2let 'A' ((let2int 'A' c + n) `mod` 26) 28 | | otherwise = c 29 | 30 | encode n xs = [shift n x | x <- xs] 31 | 32 | pos_numbers = 1 : [x + 1 | x <- pos_numbers] 33 | 34 | riffle xs ys = concat [[x, y] | (x, y) <- xs `zip` ys] 35 | 36 | divides x y = x `mod` y == 0 37 | 38 | divisors n = [x | x <- [1..n], n `divides` x] 39 | -------------------------------------------------------------------------------- /01-first-steps.hs: -------------------------------------------------------------------------------- 1 | -- nth 2 | -- [1, 2, 3, 4, 5] !! 2 3 | 4 | -- init/last, like head/tail, but from the end of the list. 5 | 6 | double x = x * x 7 | 8 | -- proper indentation 9 | foo = x + y 10 | where 11 | x = 3 12 | y = 4 13 | 14 | -- type inference fun 15 | sumOfAll xss = sum (map sum xss) 16 | 17 | -- type of [] (a really good question of which I dunno the answer): [a] 18 | 19 | -- Main> :t [] 20 | -- [] :: [a] 21 | -- Main> :t [length] 22 | -- [length] :: [[a] -> Int] 23 | -- Main> :t [head] 24 | -- [head] :: [[a] -> a] 25 | -- Main> :t [length, head] 26 | -- [length,head] :: [[Int] -> Int] 27 | 28 | -- This is very interesting: 29 | -- Main> (head (tail [length, head])) "Hello" 30 | -- ERROR - Type error in application 31 | -- *** Expression : head (tail [length,head]) "Hello" 32 | -- *** Term : tail [length,head] 33 | -- *** Type : [[Int] -> Int] 34 | -- *** Does not match : [[Char] -> Int] 35 | 36 | n = a `div` length xs 37 | where a = 10 38 | xs = [1, 2, 3, 4, 5] 39 | 40 | -- The following are all wrong 41 | -- n1 = a `div` length xs 42 | -- where 43 | -- a = 10 44 | -- xs = [1, 2, 3, 4, 5] 45 | 46 | xs = [1, 2, 3] 47 | -------------------------------------------------------------------------------- /05-recursive-functions.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding ((^), (!!), and, concat, replicate, elem) 2 | 3 | -- m ^ 0 = 1 4 | -- m ^ n = m * m ^ (n - 1) 5 | 6 | m ^ 0 = 1 7 | m ^ n = m * (^) m (n - 1) 8 | 9 | -- and [] = True 10 | -- and (b : bs) = b && and bs 11 | 12 | -- and [] = True 13 | -- and (b : bs) 14 | -- | b = and bs 15 | -- | otherwise = False 16 | 17 | -- and [] = True 18 | -- and (b : bs) 19 | -- | b == False = False 20 | -- | otherwise = and bs 21 | 22 | and [] = True 23 | and (b : bs) = and bs && b 24 | 25 | concat [] = [] 26 | concat (xs : xss) = xs ++ concat xss 27 | 28 | replicate 0 _ = [] 29 | replicate n x = x : replicate (n - 1) x 30 | 31 | (x : _) !! 0 = x 32 | (_ : xs) !! n = xs !! (n - 1) 33 | 34 | elem _ [] = False 35 | elem x (y : ys) 36 | | x == y = True 37 | | otherwise = elem x ys 38 | 39 | merge :: Ord a => [a] -> [a] -> [a] 40 | merge [] ys = ys 41 | merge xs [] = xs 42 | merge (x:xs) (y:ys) = if x < y then x : merge xs (y:ys) else y : merge (x:xs) ys 43 | 44 | halve :: [a] -> ([a], [a]) 45 | halve xs = splitAt (length xs `div` 2) xs 46 | 47 | msort :: Ord a => [a] -> [a] 48 | msort [] = [] 49 | msort [x] = [x] 50 | msort xs = merge (msort left) (msort right) 51 | where (left, right) = halve xs 52 | -------------------------------------------------------------------------------- /03-define-functions.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding ((||)) 2 | 3 | -- halve1 xs = (take n xs, drop n xs) 4 | -- where n = length xs / 2 5 | 6 | halve1 xs = splitAt (length xs `div` 2) xs 7 | halve2 xs = (take (n `div` 2) xs, drop (n `div` 2) xs) 8 | where n = length xs 9 | 10 | -- halve xs = splitAt (length xs `div` 2) xs 11 | halve = splitAt =<< (`div` 2) . length 12 | 13 | halve3 xs = splitAt (div (length xs) 2) xs 14 | halve4 xs = (take n xs, drop n xs) 15 | where n = length xs `div` 2 16 | 17 | safetail1 xs = if null xs then [] else tail xs 18 | 19 | safetail2 [] = [] 20 | safetail2 (_ : xs) = xs 21 | 22 | safetail3 xs 23 | | null xs = [] 24 | | otherwise = tail xs 25 | 26 | safetail4 [] = [] 27 | safetail4 xs = tail xs 28 | 29 | -- Pattern match failure 30 | -- safetail5 [x] = [x] 31 | -- safetail5 (_ : xs) = xs 32 | 33 | safetail6 34 | = \ xs -> 35 | case xs of 36 | [] -> [] 37 | (_ : xs) -> xs 38 | 39 | -- False || False = False 40 | -- _ || _ = True 41 | 42 | -- Wrong 43 | -- b || c 44 | -- | b == c = True 45 | -- | otherwise = False 46 | 47 | -- b || c 48 | -- | b == c =b 49 | -- | otherwise = True 50 | 51 | False || False = False 52 | False || True = True 53 | True || False = True 54 | True || True = True 55 | -------------------------------------------------------------------------------- /lab3.hs: -------------------------------------------------------------------------------- 1 | module Lab3 where 2 | 3 | ----------------------------------------------------------------------------------------------------------------------------- 4 | -- LIST COMPREHENSIONS 5 | ------------------------------------------------------------------------------------------------------------------------------ 6 | 7 | -- =================================== 8 | -- Ex. 0 - 2 9 | -- =================================== 10 | 11 | evens :: [Integer] -> [Integer] 12 | evens xs = [x | x <- xs, even x] 13 | 14 | -- =================================== 15 | -- Ex. 3 - 4 16 | -- =================================== 17 | 18 | -- complete the following line with the correct type signature for this function 19 | -- squares :: ... 20 | squares :: Integer -> [Integer] 21 | 22 | squares n = [x * x | x <- [1..n]] 23 | 24 | sumSquares :: Integer -> Integer 25 | sumSquares n = sum (squares n) 26 | 27 | -- =================================== 28 | -- Ex. 5 - 7 29 | -- =================================== 30 | 31 | -- complete the following line with the correct type signature for this function 32 | -- squares' :: ... 33 | squares' m n = [x * x | x <- [(n+1)..(n+m)]] 34 | 35 | sumSquares' :: Integer -> Integer 36 | sumSquares' x = sum . uncurry squares' $ (x, x) 37 | 38 | -- =================================== 39 | -- Ex. 8 40 | -- =================================== 41 | 42 | coords :: Integer -> Integer -> [(Integer,Integer)] 43 | coords m n = [(x, y) | x <- [0..m], y <- [0..n]] 44 | -------------------------------------------------------------------------------- /06-higher-order-functions.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (takeWhile, dropWhile, map, filter) 2 | 3 | all1 p xs = and (map p xs) 4 | all2 p = and . map p 5 | all3 p = not . any (not . p) 6 | all4 p xs = foldl (&&) True (map p xs) 7 | all5 p = foldr (&&) True . map p 8 | 9 | any1 p = or . map p 10 | any2 p xs = length (filter p xs) > 0 11 | any3 p = not . null . dropWhile (not . p) 12 | any4 p xs = not (all (\x -> not (p x)) xs) 13 | any5 p xs = foldr (\x acc -> (p x) || acc) False xs 14 | 15 | takeWhile _ [] = [] 16 | takeWhile p (x:xs) 17 | |p x = x : takeWhile p xs 18 | |otherwise = [] 19 | 20 | dropWhile _ [] = [] 21 | dropWhile p (x:xs) 22 | | p x = dropWhile p xs 23 | | otherwise = x:xs 24 | 25 | -- The order is wrong 26 | -- dropWhile p = foldl add [] 27 | -- where add [] x = if p x then [] else [x] 28 | -- add acc x = x : acc 29 | 30 | map f = foldl (\ xs x -> xs ++ [f x]) [] 31 | 32 | filter p = foldr (\x xs -> if p x then x : xs else xs) [] 33 | 34 | -- The following doesn't compile because the position of the function parameters needs to be swapped 35 | -- filter' p = foldl (\x xs -> if p x then xs ++ [x] else xs) [] 36 | filter' p = foldl (\xs x -> if p x then xs ++ [x] else xs) [] 37 | 38 | dec2int = foldl (\ x y -> 10 * x + y) 0 39 | 40 | foo (x, y) = x + y 41 | 42 | mycurry :: ((a, b) -> c) -> a -> b -> c 43 | mycurry f a b = f (a, b) 44 | 45 | unfold p h t x 46 | | p x = [] 47 | | otherwise = h x : unfold p h t (t x) 48 | 49 | type Bit = Int 50 | int2bin = unfold (== 0) (`mod` 2) (`div` 2) 51 | 52 | chop8 = unfold null (take 8) (drop 8) 53 | 54 | map' f = unfold null (f . head) tail 55 | 56 | iterate' f = unfold (const False) id f 57 | -------------------------------------------------------------------------------- /09-declaring-types-and-classes.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | import Data.Char 3 | import Hugs.IOExts (unsafeCoerce) 4 | 5 | data Nat = Zero | Succ Nat deriving Show 6 | 7 | natToInteger (Succ n) = 1 + natToInteger n 8 | natToInteger Zero = 0 9 | 10 | natToInteger1 = head . m 11 | where m Zero = [0] 12 | m (Succ n) = [sum [x | x <- (1 : m n)]] 13 | 14 | natToInteger2 :: Nat -> Integer 15 | natToInteger2 = \n -> genericLength [c | c <- show n, c == 'S'] 16 | 17 | -- Compilation error: a -> Int does not match Nat -> Integer 18 | -- natToInteger3 :: Nat -> Integer 19 | -- natToInteger3 = \n -> length [c | c <- show n, c == 'S'] 20 | 21 | integerToNat (n+1) = Succ (integerToNat n) 22 | integerToNat 0 = Zero 23 | 24 | -- integerToNat n 25 | -- = product [(unsafeCoerce c) :: Integer | c <- show n] 26 | 27 | integerToNat1 (n+1) = let m = integerToNat1 n in Succ m 28 | integerToNat1 0 = Zero 29 | 30 | -- integerToNat2 = head . m 31 | -- where { 32 | -- ; m 0 = [0] 33 | -- ; m (n + 1) = [sum [x | x <- (1 : m n)]] 34 | -- } 35 | 36 | -- Doesn't compile 37 | -- integerToNat3 :: Integer -> Nat 38 | -- integerToNat3 = \n -> genericLength [c | c <- show n, isDigit c] 39 | 40 | add Zero n = n 41 | add (Succ m) n = Succ (add n m) 42 | 43 | add1 Zero n = n 44 | add1 (Succ m) n = Succ (add m n) 45 | 46 | add2 n Zero = n 47 | add2 n (Succ m) = Succ (add n m) 48 | 49 | mult m Zero = Zero 50 | mult m (Succ n) = add m (mult m n) 51 | 52 | 53 | data Tree = Leaf Integer | Node Tree Integer Tree 54 | 55 | occurs m (Leaf n) = m == n 56 | occurs m (Node l n r) 57 | = case compare m n of 58 | LT -> occurs m l 59 | EQ -> True 60 | GT -> occurs m r 61 | 62 | -- Getting tired of typing all the code manually from this point. So going to solve the problems by reasoning about the program ... 63 | -- ;-) 64 | -------------------------------------------------------------------------------- /lab4.hs: -------------------------------------------------------------------------------- 1 | module Lab4 where 2 | 3 | ------------------------------------------------------------------------------------------------------------------------------ 4 | -- RECURSIVE FUNCTIONS 5 | ------------------------------------------------------------------------------------------------------------------------------ 6 | 7 | import Data.Char 8 | 9 | -- =================================== 10 | -- Ex. 0 11 | -- =================================== 12 | 13 | triangle :: Integer -> Integer 14 | triangle 0 = 0 15 | triangle n = n + triangle (n - 1) 16 | 17 | -- =================================== 18 | -- Ex. 1 19 | -- =================================== 20 | 21 | count :: Eq a => a -> [a] -> Int 22 | count _ [] = 0 23 | count a (x:xs) = (if a == x then 1 else 0) + count a xs 24 | 25 | xs = [1,2,35,2,3,4,8,2,9,0,5,2,8,4,9,1,9,7,3,9,2,0,5,2,7,6,92,8,3,6,1,9,2,4,8,7,1,2,8,0,4,5,2,3,6,2,3,9,8,4,7,1,4,0,1,8,4,1,2,4,56,7,2,98,3,5,28,4,0,12,4,6,8,1,9,4,8,62,3,71,0,3,8,10,2,4,7,12,9,0,3,47,1,0,23,4,8,1,20,5,7,29,3,5,68,23,5,6,3,4,98,1,0,2,3,8,1] 26 | ys = map (\x -> ((x + 1) * 3) ^ 3 - 7) xs 27 | 28 | poem = [ "Three Types for the Lisp-kings under the parentheses," 29 | , "Seven for the Web-lords in their halls of XML," 30 | , "Nine for C Developers doomed to segfault," 31 | , "One for the Dark Lord on his dark throne" 32 | , "In the Land of Haskell where the Monads lie." 33 | , "One Type to rule them all, One Type to find them," 34 | , "One Type to bring them all and in the Lambda >>= them" 35 | , "In the Land of Haskell where the Monads lie." 36 | ] 37 | 38 | -- =================================== 39 | -- Ex. 2 40 | -- =================================== 41 | 42 | euclid :: (Int, Int) -> Int 43 | euclid (x, y) 44 | | x == y = x 45 | | x > y = euclid (x - y, y) 46 | | x < y = euclid (x, y - x) 47 | 48 | 49 | -- =================================== 50 | -- Ex. 3 51 | -- =================================== 52 | 53 | funkyMap :: (a -> b) -> (a -> b) -> [a] -> [b] 54 | funkyMap f g xs = map (\(i, x) -> if i `mod` 2 == 0 then f x else g x) (zip [0..] xs) 55 | 56 | dup a = (a, a) 57 | 58 | h g f = (f . g) $ f 59 | 60 | fix = h fix 61 | 62 | f = \f n -> if (n == 0) then 1 else n * f (n - 1) 63 | 64 | k = fix $ f 65 | -------------------------------------------------------------------------------- /lab5-pmc.hs: -------------------------------------------------------------------------------- 1 | module Lab5 where 2 | 3 | import Control.Monad 4 | 5 | data Concurrent a = Concurrent ((a -> Action) -> Action) 6 | 7 | data Action 8 | = Atom (IO Action) 9 | | Fork Action Action 10 | | Stop 11 | 12 | instance Show Action where 13 | show (Atom x) = "atom" 14 | show (Fork x y) = "fork " ++ show x ++ " " ++ show y 15 | show Stop = "stop" 16 | 17 | -- =================================== 18 | -- Ex. 0 19 | -- =================================== 20 | 21 | action :: Concurrent a -> Action 22 | action (Concurrent f) = f $ const Stop 23 | 24 | 25 | -- =================================== 26 | -- Ex. 1 27 | -- =================================== 28 | 29 | stop :: Concurrent a 30 | stop = Concurrent $ const Stop 31 | 32 | 33 | -- =================================== 34 | -- Ex. 2 35 | -- =================================== 36 | 37 | atom :: IO a -> Concurrent a 38 | atom io = Concurrent $ \f -> 39 | Atom $ do x <- io 40 | return $ f x 41 | 42 | 43 | -- =================================== 44 | -- Ex. 3 45 | -- =================================== 46 | 47 | fork :: Concurrent a -> Concurrent () 48 | fork x = Concurrent $ \g -> 49 | Fork (action x) (g ()) 50 | 51 | 52 | par :: Concurrent a -> Concurrent a -> Concurrent a 53 | par (Concurrent f) (Concurrent g) = Concurrent $ \h -> Fork (f h) (g h) 54 | 55 | 56 | -- =================================== 57 | -- Ex. 4 58 | -- =================================== 59 | 60 | instance Monad Concurrent where 61 | (Concurrent f) >>= g = 62 | Concurrent $ \b -> 63 | f $ \a -> action $ g a 64 | return x = Concurrent (\c -> c x) 65 | 66 | 67 | -- =================================== 68 | -- Ex. 5 69 | -- =================================== 70 | 71 | roundRobin :: [Action] -> IO () 72 | roundRobin [] = return () 73 | roundRobin (x:xs) = case x of 74 | Atom x -> x >>= \y -> roundRobin (xs ++ [y]) 75 | Stop -> roundRobin xs 76 | Fork x y -> roundRobin (xs ++ [x, y]) 77 | 78 | 79 | -- =================================== 80 | -- Tests 81 | -- =================================== 82 | 83 | ex0 :: Concurrent () 84 | ex0 = par (loop (genRandom 1337)) (loop (genRandom 2600) >> atom (putStrLn "")) 85 | 86 | ex1 :: Concurrent () 87 | ex1 = do atom (putStr "Haskell") 88 | fork (loop $ genRandom 7331) 89 | loop $ genRandom 42 90 | atom (putStrLn "") 91 | 92 | 93 | -- =================================== 94 | -- Helper Functions 95 | -- =================================== 96 | 97 | run :: Concurrent a -> IO () 98 | run x = roundRobin [action x] 99 | 100 | genRandom :: Int -> [Int] 101 | genRandom 1337 = [1, 96, 36, 11, 42, 47, 9, 1, 62, 73] 102 | genRandom 7331 = [17, 73, 92, 36, 22, 72, 19, 35, 6, 74] 103 | genRandom 2600 = [83, 98, 35, 84, 44, 61, 54, 35, 83, 9] 104 | genRandom 42 = [71, 71, 17, 14, 16, 91, 18, 71, 58, 75] 105 | 106 | loop :: [Int] -> Concurrent () 107 | loop xs = mapM_ (atom . putStr . show) xs 108 | 109 | -------------------------------------------------------------------------------- /json-parser.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | -- Parser data type and monad implementation 4 | data Parser a = Parser (String -> [(a, String)]) 5 | 6 | instance Monad Parser where 7 | Parser f >>= k = Parser $ \inp -> 8 | [(v2, out2) | (v1, out1) <- f inp, (v2, out2) <- parse (k v1) out1] 9 | 10 | return v = Parser $ \inp -> [(v,inp)] 11 | 12 | 13 | item :: Parser Char 14 | item = Parser $ \inp -> case inp of 15 | [] -> [] 16 | (x:xs) -> [(x,xs)] 17 | 18 | failure :: Parser a 19 | failure = Parser $ \inp -> [] 20 | 21 | (+++) :: Parser a -> Parser a -> Parser a 22 | Parser p +++ Parser q = Parser $ \inp -> case p inp of 23 | [] -> q inp 24 | [(v,out)] -> [(v,out)] 25 | 26 | parse :: Parser a -> String -> [(a, String)] 27 | parse (Parser p) inp = p inp 28 | 29 | sat :: (Char -> Bool) -> Parser Char 30 | sat p = do x <- item 31 | if p x then return x else failure 32 | 33 | digit :: Parser Char 34 | digit = sat isDigit 35 | 36 | char :: Char -> Parser Char 37 | char x = sat (x ==) 38 | 39 | many :: Parser a -> Parser [a] 40 | many p = many1 p +++ return [] 41 | 42 | many1 :: Parser a -> Parser [a] 43 | many1 p = do v <- p 44 | vs <- many p 45 | return (v:vs) 46 | 47 | string :: String -> Parser String 48 | string [] = return [] 49 | string (x:xs) = do char x 50 | string xs 51 | return (x:xs) 52 | 53 | -- My JSON parser starts here -- 54 | data JsVal = JsObject [(String, JsVal)] 55 | | JsArray [JsVal] 56 | | JsString String 57 | | JsInteger Int 58 | | JsBoolean Bool 59 | | JsNull 60 | deriving Show 61 | 62 | skipSpace :: Parser String 63 | skipSpace = many $ sat isSpace 64 | 65 | escapeChar :: Parser Char 66 | escapeChar = do char '\\' 67 | c <- item 68 | return $ case c of 69 | 'n' -> '\n' 70 | 'r' -> '\r' 71 | 'b' -> '\b' 72 | 't' -> '\t' 73 | '\\' -> '\\' 74 | _ -> c 75 | 76 | commaSeparated :: Parser a -> Parser [a] 77 | commaSeparated p = do skipSpace 78 | elems <- (do e <- p 79 | es <- many (do skipSpace 80 | char ',' 81 | skipSpace 82 | p) 83 | return $ e:es) +++ return [] 84 | skipSpace 85 | return elems 86 | 87 | keyValuePair :: Parser a -> Parser (String, a) 88 | keyValuePair p = do skipSpace 89 | JsString key <- jsString 90 | skipSpace 91 | char ':' 92 | skipSpace 93 | val <- p 94 | return (key, val) 95 | 96 | json :: Parser JsVal 97 | json = jsInt +++ jsString +++ jsArray +++ jsObject +++ jsBoolean +++ jsNull 98 | 99 | jsNull :: Parser JsVal 100 | jsNull = do string "null" 101 | return JsNull 102 | 103 | jsBoolean :: Parser JsVal 104 | jsBoolean = (do string "true" 105 | return $ JsBoolean True) +++ 106 | (do string "false" 107 | return $ JsBoolean False) 108 | 109 | jsString :: Parser JsVal 110 | jsString = do char '"' 111 | s <- (many $ escapeChar +++ sat ('"' /=)) 112 | char '"' 113 | return $ JsString s 114 | 115 | jsInt :: Parser JsVal 116 | jsInt = do s <- digit 117 | ss <- (many digit) 118 | return $ JsInteger (read (s:ss)::Int) 119 | 120 | jsArray :: Parser JsVal 121 | jsArray = do char '[' 122 | elems <- commaSeparated json 123 | char ']' 124 | return $ JsArray elems 125 | 126 | jsObject :: Parser JsVal 127 | jsObject = do char '{' 128 | kvs <- commaSeparated $ keyValuePair json 129 | char '}' 130 | return $ JsObject kvs 131 | -------------------------------------------------------------------------------- /lab6.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------------------------------------------------------ 2 | -- ROSE TREES, FUNCTORS, MONOIDS, FOLDABLES 3 | ------------------------------------------------------------------------------------------------------------------------------ 4 | 5 | data Rose a = a :> [Rose a] deriving Show 6 | 7 | -- =================================== 8 | -- Ex. 0-2 9 | -- =================================== 10 | 11 | root :: Rose a -> a 12 | root (r :> _) = r 13 | 14 | children :: Rose a -> [Rose a] 15 | children (_ :> c) = c 16 | 17 | ex0 = length $ children tree 18 | where tree = 'x' :> map (flip (:>) []) ['a'..'x'] 19 | 20 | ex1 = length (children tree) 21 | where tree = 'x' :> map (\c -> c :> []) ['a'..'A'] 22 | 23 | xs = 0 :> [1 :> [2 :> [3 :> [4 :> [], 5 :> []]]], 6 :> [], 7 :> [8 :> [9 :> [10 :> []], 11 :> []], 12 :> [13 :> []]]] 24 | 25 | ex2 = root . head . children . head . children . head . drop 2 $ children xs 26 | 27 | -- =================================== 28 | -- Ex. 3-7 29 | -- =================================== 30 | 31 | size :: Rose a -> Int 32 | size (_ :> []) = 1 33 | size (_ :> xs) = 1 + sum (map size xs) 34 | 35 | leaves :: Rose a -> Int 36 | leaves (_ :> []) = 1 37 | leaves (_ :> xs) = sum (map leaves xs) 38 | 39 | ex3 = size tree 40 | where tree = 1 :> map (\c -> c :> []) [1..5] 41 | 42 | ex4 = size . head . children $ tree 43 | where tree = 1 :> map (\c -> c :> []) [1..5] 44 | 45 | ex5 = leaves tree 46 | where tree = 1 :> map (\c -> c :> []) [1..5] 47 | 48 | ex6 = product (map leaves (children tree)) 49 | where tree = 1 :> map (\c -> c :> []) [1..5] 50 | 51 | ex7 = (*) (leaves . head . children . head . children $ xs) (product . map size . children . head . drop 2 . children $ xs) 52 | 53 | -- =================================== 54 | -- Ex. 8-10 55 | -- =================================== 56 | 57 | instance Functor Rose where 58 | fmap f (r :> xs) = f r :> map (fmap f) xs 59 | 60 | ex8 = size (fmap leaves (fmap (:> []) tree)) 61 | where tree = 1 :> map (\c -> c :> []) [1..5] 62 | 63 | -- f r = fmap head $ fmap (\x -> [x]) r 64 | 65 | ex10 = round . root . head . children . fmap (\x -> if x > 0.5 then x else 0) $ fmap (\x -> sin(fromIntegral x)) xs 66 | 67 | -- =================================== 68 | -- Ex. 11-13 69 | -- =================================== 70 | 71 | class Monoid m where 72 | mempty :: m 73 | mappend :: m -> m -> m 74 | 75 | newtype Sum a = Sum a 76 | newtype Product a = Product a 77 | 78 | instance Num a => Monoid (Sum a) where 79 | mempty = Sum 0 80 | mappend (Sum x) (Sum y) = Sum $ x + y 81 | 82 | instance Num a => Monoid (Product a) where 83 | mempty = Product 1 84 | mappend (Product x) (Product y) = Product $ x * y 85 | 86 | unSum :: Sum a -> a 87 | unSum (Sum a) = a 88 | unProduct :: Product a -> a 89 | unProduct (Product a) = a 90 | 91 | num1 = mappend (mappend (Sum 2) (mappend (mappend mempty (Sum 1)) mempty)) (mappend (Sum 2) (Sum 1)) 92 | 93 | num2 = mappend (Sum 3) (mappend mempty (mappend (mappend (mappend (Sum 2) mempty) (Sum (-1))) (Sum 3))) 94 | 95 | ex13 = unSum (mappend (Sum 5) (Sum (unProduct (mappend (Product (unSum num2)) (mappend (Product (unSum num1)) (mappend mempty (mappend (Product 2) (Product 3)))))))) 96 | 97 | -- =================================== 98 | -- Ex. 14-15 99 | -- =================================== 100 | 101 | class Functor f => Foldable f where 102 | fold :: Monoid m => f m -> m 103 | foldMap :: Monoid m => (a -> m) -> (f a -> m) 104 | foldMap f x = fold $ fmap f x 105 | 106 | instance Foldable Rose where 107 | fold (r :> []) = mappend r mempty 108 | fold (r :> xs) = foldr (mappend) r (map fold xs) 109 | 110 | sumxs = Sum 0 :> [Sum 13 :> [Sum 26 :> [Sum (-31) :> [Sum (-45) :> [], Sum 23 :> []]]], Sum 27 :> [], Sum 9 :> [Sum 15 :> [Sum 3 :> [Sum (-113) :> []], Sum 1 :> []], Sum 71 :> [Sum 55 :> []]]] 111 | 112 | ex14 = unProduct $ fold tree' 113 | where tree = 1 :> [2 :> [], 3 :> [4 :> []]] 114 | tree' = fmap Product tree 115 | 116 | ex15 = unSum (mappend (mappend (fold sumxs) (mappend (fold . head . drop 2 . children $ sumxs) (Sum 30))) (fold . head . children $ sumxs)) 117 | 118 | -- =================================== 119 | -- Ex. 16-18 120 | -- =================================== 121 | 122 | ex16 = unSum $ foldMap Sum tree 123 | where tree = 42 :> [3 :> [2:> [], 1 :> [0 :> []]]] 124 | 125 | ex17 = unSum (mappend (mappend (foldMap (\x -> Sum x) xs) (mappend (foldMap (\x -> Sum x) . head . drop 2 . children $ xs) (Sum 30))) (foldMap (\x -> Sum x) . head . children $ xs)) 126 | 127 | ex18 = unSum (mappend (mappend (foldMap (\x -> Sum x) xs) (Sum (unProduct (mappend (foldMap (\x -> Product x) . head . drop 2 . children $ xs) (Product 3))))) (foldMap (\x -> Sum x) . head . children $ xs)) 128 | 129 | -- =================================== 130 | -- Ex. 19-21 131 | -- =================================== 132 | 133 | fproduct, fsum :: (Foldable f, Num a) => f a -> a 134 | fsum x = unSum $ foldMap Sum x 135 | fproduct x = unProduct $ foldMap Product x 136 | 137 | ex19 = fsum xs 138 | 139 | ex20 = fproduct xs 140 | 141 | ex21 = ((fsum . head . drop 1 . children $ xs) + (fproduct . head . children . head . children . head . drop 2 . children $ xs)) - (fsum . head . children . head . children $ xs) 142 | 143 | -------------------------------------------------------------------------------- /07-functional-parsers-and-monads.lhs: -------------------------------------------------------------------------------- 1 | > module Parsing where 2 | > 3 | > 4 | > import Data.Char 5 | > import Control.Monad 6 | > 7 | > infixr 5 +++ 8 | 9 | The monad of parsers 10 | -------------------- 11 | 12 | > newtype Parser a = P (String -> [(a,String)]) 13 | > 14 | > instance Monad Parser where 15 | > return v = P (\inp -> [(v,inp)]) 16 | > p >>= f = P (\inp -> 17 | > case parse p inp of 18 | > [(v, out)] -> parse (f v) out 19 | > [] -> []) 20 | > 21 | > instance MonadPlus Parser where 22 | > mzero = P (\inp -> []) 23 | > p `mplus` q = P (\inp -> case parse p inp of 24 | > [] -> parse q inp 25 | > [(v,out)] -> [(v,out)]) 26 | 27 | Basic parsers 28 | ------------- 29 | 30 | > failure :: Parser a 31 | > failure = mzero 32 | > 33 | > item :: Parser Char 34 | > item = P (\inp -> case inp of 35 | > [] -> [] 36 | > (x:xs) -> [(x,xs)]) 37 | > 38 | > parse :: Parser a -> String -> [(a,String)] 39 | > parse (P p) inp = p inp 40 | 41 | Choice 42 | ------ 43 | 44 | > (+++) :: Parser a -> Parser a -> Parser a 45 | > p +++ q = p `mplus` q 46 | 47 | Derived primitives 48 | ------------------ 49 | 50 | > sat :: (Char -> Bool) -> Parser Char 51 | > sat p = do x <- item 52 | > if p x then return x else failure 53 | > 54 | > digit :: Parser Char 55 | > digit = sat isDigit 56 | > 57 | > lower :: Parser Char 58 | > lower = sat isLower 59 | > 60 | > upper :: Parser Char 61 | > upper = sat isUpper 62 | > 63 | > letter :: Parser Char 64 | > letter = sat isAlpha 65 | > 66 | > alphanum :: Parser Char 67 | > alphanum = sat isAlphaNum 68 | > 69 | > char :: Char -> Parser Char 70 | > char x = sat (== x) 71 | > 72 | > string :: String -> Parser String 73 | > string [] = return [] 74 | > string (x:xs) = do char x 75 | > string xs 76 | > return (x:xs) 77 | > 78 | > many :: Parser a -> Parser [a] 79 | > many p = many1 p +++ return [] 80 | > 81 | > many1 :: Parser a -> Parser [a] 82 | > many1 p = do v <- p 83 | > vs <- many p 84 | > return (v:vs) 85 | > 86 | > ident :: Parser String 87 | > ident = do x <- lower 88 | > xs <- many alphanum 89 | > return (x:xs) 90 | > 91 | > nat :: Parser Int 92 | > nat = do xs <- many1 digit 93 | > return (read xs) 94 | > 95 | > int :: Parser Int 96 | > int = (do char '-' 97 | > n <- nat 98 | > return (-n)) 99 | > +++ nat 100 | > 101 | 102 | My Implementation: 103 | 104 | int = do x <- (char '-' +++ return '0') 105 | xs <- many1 digit 106 | return (read (x:xs)::Int) 107 | 108 | > space :: Parser () 109 | > space = do many (sat isSpace) 110 | > return () 111 | > 112 | > comment :: Parser () 113 | > comment = do string "--" 114 | > many (sat (/= '\n')) 115 | > return () 116 | > 117 | > expr :: Parser Int 118 | > expr = do n <- natural 119 | > ns <- many (do symbol "-" 120 | > natural) 121 | > return (foldl (-) n ns) 122 | 123 | Ignoring spacing 124 | ---------------- 125 | 126 | > token :: Parser a -> Parser a 127 | > token p = do space 128 | > v <- p 129 | > space 130 | > return v 131 | > 132 | > identifier :: Parser String 133 | > identifier = token ident 134 | > 135 | > natural :: Parser Int 136 | > natural = token nat 137 | > 138 | > integer :: Parser Int 139 | > integer = token int 140 | > 141 | > symbol :: String -> Parser String 142 | > symbol xs = token (string xs) 143 | -------------------------------------------------------------------------------- /08-interactive-programs.hs: -------------------------------------------------------------------------------- 1 | putStr' :: String -> IO () 2 | putStr' [] = return () 3 | putStr' (x:xs) = putChar x >> putStr' xs 4 | 5 | putStrLn' [] = putChar '\n' 6 | putStrLn' xs = putStr' xs >> putStrLn' "" 7 | 8 | putStrLn1 [] = putChar '\n' -- This isn't really needed. 9 | putStrLn1 xs = putStr' xs >> putChar '\n' 10 | 11 | putStrLn2 [] = putChar '\n' -- This isn't really needed. 12 | putStrLn2 xs = putStr' xs >>= \ x -> putChar '\n' 13 | 14 | putStrLn3 [] = putChar '\n' 15 | putStrLn3 xs = putStr' xs >> putStr' "\n" 16 | 17 | -- This is wrong 18 | putStrLn4 [] = putChar '\n' 19 | putStrLn4 xs = putStr' xs >> putStrLn' "\n" 20 | 21 | getLine' = get [] 22 | 23 | get :: String -> IO String 24 | get xs = do x <- getChar 25 | case x of 26 | '\n' -> return xs 27 | _ -> get (xs ++ [x]) 28 | 29 | 30 | interact' f = do input <- getLine' 31 | putStrLn' (f input) 32 | 33 | 34 | 35 | --- Some more monad fun 36 | 37 | sequence_' :: Monad m => [m a] -> m () 38 | 39 | -- Doesn't compile 40 | -- sequence_' [] = return [] 41 | -- sequence_' (m:ms) = m >> \_ -> sequence_' ms 42 | 43 | -- Works but gets unresolved overloading for [] 44 | --sequence_' [] = return () 45 | --sequence_' (m:ms) = (foldl (>>) m ms) >> return () 46 | 47 | -- Doesn't compile: Inferred type is not general enough 48 | -- sequence_' ms = foldl (>>) (return ()) ms 49 | 50 | -- Works but gets unresolved overloading for [] 51 | -- sequence_' [] = return () 52 | -- sequence_' (m:ms) = m >> sequence_' ms 53 | 54 | -- Works but gets unresolved overloading for [] 55 | -- sequence_' [] = return () 56 | -- sequence_' (m:ms) = m >>= \_ -> sequence_' ms 57 | 58 | -- Doesn't compile 59 | -- sequence_' ms = foldr (>>=) (return ()) ms 60 | 61 | -- Works but gets unresolved overloading for [] 62 | sequence_' ms = foldr (>>) (return ()) ms 63 | 64 | -- Doesn't compile 65 | -- sequence_' ms = foldr (>>) (return []) ms 66 | 67 | 68 | sequence' :: Monad m => [m a] -> m [a] 69 | 70 | -- Try writing one myself 71 | sequence' = foldr (\m ms -> do x <- m 72 | xs <- ms 73 | return $ x:xs) 74 | (return []) 75 | 76 | -- Works 77 | -- sequence' [] = return [] 78 | -- sequence' (m:ms) 79 | -- = m >>= 80 | -- \ a -> 81 | -- do as <- sequence' ms 82 | -- return (a:as) 83 | 84 | -- Doesn't compile, should replace `return ()` with `return []` 85 | -- sequence' ms = foldr func (return ()) ms 86 | -- where func :: (Monad m) => m a -> m [a] -> m [a] 87 | -- func m acc 88 | -- = do x <- m 89 | -- xs <- acc 90 | -- return (x:xs) 91 | 92 | -- Doesn't compile 93 | -- sequence' ms = foldr func (return []) ms 94 | -- where func :: (Monad m) => m a -> m [a] -> m [a] 95 | -- func m acc = m : acc 96 | 97 | -- Doesn't compile: syntax error 98 | -- sequence' [] = return [] 99 | -- sequence' (m:ms) = return (a:as) 100 | -- where a <- m 101 | -- as <- sequence' ms 102 | 103 | -- Doesn't compile: should replace `>>` with `>>=` 104 | -- sequence' [] = return [] 105 | -- sequence' (m:ms) 106 | -- = m >> 107 | -- \a -> 108 | -- do as <- sequence' ms 109 | -- return (a:as) 110 | 111 | -- Doesn't compile: syntax error 112 | -- sequence' [] = return [] 113 | -- sequence' (m:ms) = m >>= \a -> 114 | -- as <- sequence' ms 115 | -- return (a:as) 116 | 117 | -- Works 118 | -- sequence' [] = return [] 119 | -- sequence' (m:ms) 120 | -- = do a <- m 121 | -- as <- sequence' ms 122 | -- return (a:as) 123 | 124 | 125 | mapM' :: Monad m => (a -> m b) -> [a] -> m [b] 126 | 127 | -- Try implementing one myself 128 | mapM' f = foldr (\x acc -> do a <- f x 129 | as <- acc 130 | return $ a:as) 131 | (return []) 132 | 133 | -- Works 134 | -- mapM' f as = sequence' (map f as) 135 | 136 | -- Works 137 | -- mapM' f [] = return [] 138 | -- mapM' f (a:as) 139 | -- = f a >>= \b -> mapM' f as >>= \ bs -> return (b:bs) 140 | 141 | -- Doesn't compile 142 | -- mapM' f as = sequence_' (map f as) 143 | 144 | -- Works 145 | -- mapM' f [] = return [] 146 | -- mapM' f (a:as) 147 | -- = do b <- f a 148 | -- bs <- mapM' f as 149 | -- return (b:bs) 150 | 151 | -- Works 152 | -- mapM' f [] = return [] 153 | -- mapM' f (a:as) 154 | -- = f a >>= 155 | -- \ b -> 156 | -- do bs <- mapM' f as 157 | -- return (b:bs) 158 | 159 | -- The order of the result is wrong 160 | -- mapM' f [] = return [] 161 | -- mapM' f (a:as) 162 | -- = f a >>= 163 | -- \ b -> 164 | -- do bs <- mapM' f as 165 | -- return (bs ++ [b]) 166 | 167 | filterM' :: Monad m => (a -> m Bool) -> [a] -> m [a] 168 | 169 | -- Try implementing one myself 170 | filterM' p = foldr (\x acc -> do y <- p x 171 | xs <- acc 172 | return $ if y then (x:xs) else xs) 173 | (return []) 174 | 175 | -- filterM' _ [] = return [] 176 | -- filterM' p (x:xs) 177 | -- = do flag <- p x 178 | -- ys <- filterM' p xs 179 | -- if flag then return (x:ys) else return ys 180 | 181 | foldLeftM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a 182 | foldLeftM _ a [] = return a 183 | foldLeftM f a (x:xs) = f a x >>= \v -> foldLeftM f v xs 184 | 185 | foldRightM :: Monad m => (a -> b -> m b) -> b -> [a] -> m b 186 | foldRightM _ b [] = return b 187 | foldRightM f b (x:xs) = foldRightM f b xs >>= f x 188 | 189 | liftM :: Monad m => (a -> b) -> m a -> m b 190 | 191 | -- works 192 | liftM f m = m >>= \a -> return $ f a 193 | 194 | -- Doesn't compile 195 | -- liftM f m = mapM f [m] 196 | 197 | -- Could run the monad twice, which is wrong for IO monads (should've tested it with IO rather than Maybe) 198 | --liftM f m = m >>= \a -> m >>= \b -> return (f a) 199 | --liftM f m = m >>= \a -> m >>= \b -> return (f b) 200 | -------------------------------------------------------------------------------- /lab2.hs: -------------------------------------------------------------------------------- 1 | module Lab2 where 2 | 3 | ------------------------------------------------------------------------------------------------------------------------------ 4 | -- Lab 2: Validating Credit Card Numbers 5 | ------------------------------------------------------------------------------------------------------------------------------ 6 | 7 | -- =================================== 8 | -- Ex. 0 9 | -- =================================== 10 | 11 | toDigits :: Integer -> [Integer] 12 | toDigits 0 = [] 13 | toDigits n 14 | | n < 10 = [n] 15 | | otherwise = toDigits (n `div` 10) ++ [n `mod` 10] 16 | 17 | -- import Data.Char 18 | -- toDigits' :: Integer -> [Integer] 19 | -- toDigits' n = [ ord c - ord '0' | c <- show n ] 20 | 21 | -- =================================== 22 | -- Ex. 1 23 | -- =================================== 24 | 25 | toDigitsRev :: Integer -> [Integer] 26 | toDigitsRev = reverse . toDigits 27 | 28 | -- =================================== 29 | -- Ex. 2 30 | -- =================================== 31 | 32 | doubleSecond :: [Integer] -> [Integer] 33 | doubleSecond xs = [if i `mod` 2 == 0 then x * 2 else x | (x, i) <- xs `zip` [1..]] 34 | 35 | 36 | -- =================================== 37 | -- Ex. 3 38 | -- =================================== 39 | 40 | sumDigits :: [Integer] -> Integer 41 | sumDigits = sum . concat . map toDigits 42 | 43 | 44 | -- =================================== 45 | -- Ex. 4 46 | -- =================================== 47 | 48 | isValid :: Integer -> Bool 49 | isValid n = checkSum n `mod` 10 == 0 50 | where checkSum = sumDigits . doubleSecond . toDigitsRev 51 | 52 | -- This has made question 22 fail. I was feeling like an idiot. 53 | isValid' n 54 | | n >= 0 = checkSum n `mod` 10 == 0 55 | | otherwise = False 56 | where checkSum = sumDigits . doubleSecond . toDigitsRev 57 | 58 | 59 | -- =================================== 60 | -- Ex. 5 61 | -- =================================== 62 | 63 | numValid :: [Integer] -> Integer 64 | numValid xs = sum . map (\_ -> 1) $ filter isValid xs 65 | 66 | 67 | creditcards :: [Integer] 68 | creditcards = [ 4716347184862961, 69 | 4532899082537349, 70 | 4485429517622493, 71 | 4320635998241421, 72 | 4929778869082405, 73 | 5256283618614517, 74 | 5507514403575522, 75 | 5191806267524120, 76 | 5396452857080331, 77 | 5567798501168013, 78 | 6011798764103720, 79 | 6011970953092861, 80 | 6011486447384806, 81 | 6011337752144550, 82 | 6011442159205994, 83 | 4916188093226163, 84 | 4916699537435624, 85 | 4024607115319476, 86 | 4556945538735693, 87 | 4532818294886666, 88 | 5349308918130507, 89 | 5156469512589415, 90 | 5210896944802939, 91 | 5442782486960998, 92 | 5385907818416901, 93 | 6011920409800508, 94 | 6011978316213975, 95 | 6011221666280064, 96 | 6011285399268094, 97 | 6011111757787451, 98 | 4024007106747875, 99 | 4916148692391990, 100 | 4916918116659358, 101 | 4024007109091313, 102 | 4716815014741522, 103 | 5370975221279675, 104 | 5586822747605880, 105 | 5446122675080587, 106 | 5361718970369004, 107 | 5543878863367027, 108 | 6011996932510178, 109 | 6011475323876084, 110 | 6011358905586117, 111 | 6011672107152563, 112 | 6011660634944997, 113 | 4532917110736356, 114 | 4485548499291791, 115 | 4532098581822262, 116 | 4018626753711468, 117 | 4454290525773941, 118 | 5593710059099297, 119 | 5275213041261476, 120 | 5244162726358685, 121 | 5583726743957726, 122 | 5108718020905086, 123 | 6011887079002610, 124 | 6011119104045333, 125 | 6011296087222376, 126 | 6011183539053619, 127 | 6011067418196187, 128 | 4532462702719400, 129 | 4420029044272063, 130 | 4716494048062261, 131 | 4916853817750471, 132 | 4327554795485824, 133 | 5138477489321723, 134 | 5452898762612993, 135 | 5246310677063212, 136 | 5211257116158320, 137 | 5230793016257272, 138 | 6011265295282522, 139 | 6011034443437754, 140 | 6011582769987164, 141 | 6011821695998586, 142 | 6011420220198992, 143 | 4716625186530516, 144 | 4485290399115271, 145 | 4556449305907296, 146 | 4532036228186543, 147 | 4916950537496300, 148 | 5188481717181072, 149 | 5535021441100707, 150 | 5331217916806887, 151 | 5212754109160056, 152 | 5580039541241472, 153 | 6011450326200252, 154 | 6011141461689343, 155 | 6011886911067144, 156 | 6011835735645726, 157 | 6011063209139742, 158 | 379517444387209, 159 | 377250784667541, 160 | 347171902952673, 161 | 379852678889749, 162 | 345449316207827, 163 | 349968440887576, 164 | 347727987370269, 165 | 370147776002793, 166 | 374465794689268, 167 | 340860752032008, 168 | 349569393937707, 169 | 379610201376008, 170 | 346590844560212, 171 | 376638943222680, 172 | 378753384029375, 173 | 348159548355291, 174 | 345714137642682, 175 | 347556554119626, 176 | 370919740116903, 177 | 375059255910682, 178 | 373129538038460, 179 | 346734548488728, 180 | 370697814213115, 181 | 377968192654740, 182 | 379127496780069, 183 | 375213257576161, 184 | 379055805946370, 185 | 345835454524671, 186 | 377851536227201, 187 | 345763240913232 188 | ] 189 | -------------------------------------------------------------------------------- /10-countdown-problem.lhs: -------------------------------------------------------------------------------- 1 | Countdown example from chapter 11 of Programming in Haskell, 2 | Graham Hutton, Cambridge University Press, 2007. 3 | 4 | 5 | > import System.CPUTime 6 | > import Numeric 7 | > import System.IO 8 | 9 | Expressions 10 | ----------- 11 | 12 | > data Op = Add | Sub | Mul | Div 13 | > 14 | > valid :: Op -> Int -> Int -> Bool 15 | > valid Add _ _ = True 16 | > valid Sub x y = x > y 17 | > valid Mul _ _ = True 18 | > valid Div x y = x `mod` y == 0 19 | > 20 | > apply :: Op -> Int -> Int -> Int 21 | > apply Add x y = x + y 22 | > apply Sub x y = x - y 23 | > apply Mul x y = x * y 24 | > apply Div x y = x `div` y 25 | > 26 | > data Expr = Val Int | App Op Expr Expr 27 | > 28 | > values :: Expr -> [Int] 29 | > values (Val n) = [n] 30 | > values (App _ l r) = values l ++ values r 31 | > 32 | > eval :: Expr -> [Int] 33 | > eval (Val n) = [n | n > 0] 34 | > eval (App o l r) = [apply o x y | x <- eval l 35 | > , y <- eval r 36 | > , valid o x y] 37 | 38 | Combinatorial functions 39 | ----------------------- 40 | 41 | > subs :: [a] -> [[a]] 42 | > subs [] = [[]] 43 | > subs (x:xs) = yss ++ map (x:) yss 44 | > where yss = subs xs 45 | > 46 | > interleave :: a -> [a] -> [[a]] 47 | > interleave x [] = [[x]] 48 | > interleave x (y:ys) = (x:y:ys) : map (y:) (interleave x ys) 49 | > 50 | > perms :: [a] -> [[a]] 51 | > perms [] = [[]] 52 | > perms (x:xs) = concat (map (interleave x) (perms xs)) 53 | > 54 | > choices :: [a] -> [[a]] 55 | > choices xs = [zs | ys <- subs xs, zs <- perms ys] 56 | 57 | Formalising the problem 58 | ----------------------- 59 | 60 | > solution :: Expr -> [Int] -> Int -> Bool 61 | > solution e ns n = elem (values e) (choices ns) && eval e == [n] 62 | 63 | Brute force solution 64 | -------------------- 65 | 66 | > split :: [a] -> [([a],[a])] 67 | > split xs = [splitAt n xs | n <- [1 .. (length xs - 1)]] 68 | > 69 | > exprs :: [Int] -> [Expr] 70 | > exprs [] = [] 71 | > exprs [n] = [Val n] 72 | > exprs ns = [e | (ls,rs) <- split ns 73 | > , l <- exprs ls 74 | > , r <- exprs rs 75 | > , e <- combine l r] 76 | > 77 | > combine :: Expr -> Expr -> [Expr] 78 | > combine l r = [App o l r | o <- ops] 79 | > 80 | > ops :: [Op] 81 | > ops = [Add,Sub,Mul,Div] 82 | > 83 | > solutions :: [Int] -> Int -> [Expr] 84 | > solutions ns n = [e | ns' <- choices ns 85 | > , e <- exprs ns' 86 | > , eval e == [n]] 87 | 88 | Combining generation and evaluation 89 | ----------------------------------- 90 | 91 | > type Result = (Expr,Int) 92 | > 93 | > results :: [Int] -> [Result] 94 | > results [] = [] 95 | > results [n] = [(Val n,n) | n > 0] 96 | > results ns = [res | (ls,rs) <- split ns 97 | > , lx <- results ls 98 | > , ry <- results rs 99 | > , res <- combine' lx ry] 100 | > 101 | > combine' :: Result -> Result -> [Result] 102 | > combine' (l,x) (r,y) = [(App o l r, apply o x y) | o <- ops 103 | > , valid o x y] 104 | > 105 | > solutions' :: [Int] -> Int -> [Expr] 106 | > solutions' ns n = [e | ns' <- choices ns 107 | > , (e,m) <- results ns' 108 | > , m == n] 109 | 110 | Exploiting numeric properties 111 | ----------------------------- 112 | 113 | > valid' :: Op -> Int -> Int -> Bool 114 | > valid' Add x y = x <= y 115 | > valid' Sub x y = x > y 116 | > valid' Mul x y = x /= 1 && y /= 1 && x <= y 117 | > valid' Div x y = y /= 1 && x `mod` y == 0 118 | > 119 | > results' :: [Int] -> [Result] 120 | > results' [] = [] 121 | > results' [n] = [(Val n,n) | n > 0] 122 | > results' ns = [res | (ls,rs) <- split ns 123 | > , lx <- results' ls 124 | > , ry <- results' rs 125 | > , res <- combine'' lx ry] 126 | > 127 | > combine'' :: Result -> Result -> [Result] 128 | > combine'' (l,x) (r,y) = [(App o l r, apply o x y) | o <- ops 129 | > , valid' o x y] 130 | > 131 | > solutions'' :: [Int] -> Int -> [Expr] 132 | > solutions'' ns n = [e | ns' <- choices ns 133 | > , (e,m) <- results' ns' 134 | > , m == n] 135 | 136 | Interactive version for testing 137 | ------------------------------- 138 | 139 | > instance Show Op where 140 | > show Add = "+" 141 | > show Sub = "-" 142 | > show Mul = "*" 143 | > show Div = "/" 144 | > 145 | > instance Show Expr where 146 | > show (Val n) = show n 147 | > show (App o l r) = bracket l ++ show o ++ bracket r 148 | > where 149 | > bracket (Val n) = show n 150 | > bracket e = "(" ++ show e ++ ")" 151 | > 152 | > showtime :: Integer -> String 153 | > showtime t = showFFloat (Just 3) 154 | > (fromIntegral t / (10^12)) " seconds" 155 | > 156 | > display :: [Expr] -> IO () 157 | > display es = do t0 <- getCPUTime 158 | > if null es then 159 | > do t1 <- getCPUTime 160 | > putStr "\nThere are no solutions, verified in " 161 | > putStr (showtime (t1 - t0)) 162 | > else 163 | > do t1 <- getCPUTime 164 | > putStr "\nOne possible solution is " 165 | > putStr (show (head es)) 166 | > putStr ", found in " 167 | > putStr (showtime (t1 - t0)) 168 | > putStr "\n\nPress return to continue searching..." 169 | > getLine 170 | > putStr "\n" 171 | > t2 <- getCPUTime 172 | > if null (tail es) then 173 | > putStr "There are no more solutions" 174 | > else 175 | > do sequence [print e | e <- tail es] 176 | > putStr "\nThere were " 177 | > putStr (show (length es)) 178 | > putStr " solutions in total, found in " 179 | > t3 <- getCPUTime 180 | > putStr (showtime ((t1 - t0) + (t3 - t2))) 181 | > putStr ".\n\n" 182 | > 183 | > main :: IO () 184 | > main = do hSetBuffering stdout NoBuffering 185 | > putStrLn "\nCOUNTDOWN NUMBERS GAME SOLVER" 186 | > putStrLn "-----------------------------\n" 187 | > putStr "Enter the given numbers : " 188 | > ns <- readLn 189 | > putStr "Enter the target number : " 190 | > n <- readLn 191 | > display (solutions'' ns n) 192 | 193 | 194 | Other Stuff 195 | ----------- 196 | 197 | > removeone :: Eq a => a -> [a] -> [a] 198 | > removeone x [] = [] 199 | > removeone x (y:ys) 200 | > | x == y = ys 201 | > | otherwise = y : removeone x ys 202 | > 203 | > isChoice :: Eq a => [a] -> [a] -> Bool 204 | > isChoice [] _ = True 205 | > isChoice (x:xs) [] = False 206 | > isChoice (x:xs) ys = elem x ys && isChoice xs (removeone x ys) 207 | 208 | --------------------------------------------------------------------------------