├── .gitignore ├── 01-calling-functions ├── pyth1.hs ├── pyth2.hs ├── pyth3.hs ├── sq1.hs ├── sq2.hs ├── sq_dollar.hs ├── sq_dot.hs └── sq_id.hs ├── 02-my-first-program ├── center.hs ├── flop.hs ├── lenseg.hs ├── pattern.hs ├── segment.hs └── wildcard.hs ├── 03-pure-functions-laziness-io ├── getline.hs ├── lazy1.hs ├── putqstr.hs └── putstr.hs ├── 04-symbolic-calculator-recursion ├── factorial.hs ├── factorial2.hs ├── fibonacci.hs ├── loop.hs ├── loop_sq.hs └── recursion.hs ├── 05-tokenizer-data-types ├── builtinlist.hs ├── decimate.hs ├── decimate2.hs ├── genericlist.hs ├── list1.hs ├── match1.hs ├── norm.hs ├── operator1.hs ├── point1.hs ├── point2.hs ├── showcontent.hs ├── sumlist.hs └── ziplist.hs ├── 06-tokenizer-function-types ├── cat.hs ├── elem.hs ├── fib.hs ├── guards1.hs ├── is3elem.hs ├── iselem.hs ├── pig.hs ├── sumdig.hs ├── toints.hs ├── token1.hs └── tokenize.hs ├── 07-tokenizer-higher-order-functions ├── alnums.hs ├── alnumsfoldl.hs ├── foldl1.hs ├── foldl2.hs ├── incircle.hs ├── myalnums.hs ├── myfilter.hs ├── mymap.hs ├── rev.hs ├── span1.hs ├── squares.hs ├── toints.hs ├── tokenize2.hs ├── tokenize3.hs └── tokenize4.hs ├── 08-parser ├── ex1.hs ├── ex2.hs ├── ex2_span.hs ├── ex3.hs └── tokenize5.hs ├── 09-evaluator ├── evaluate1.hs ├── evaluate2 │ ├── Evaluator.hs │ ├── Lexer.hs │ ├── Main.hs │ └── Parser.hs ├── moby.txt ├── paren.hs ├── translate.hs └── words.hs ├── 10-error-handling ├── evaluate3.hs ├── evaluate4 │ ├── Evaluator.hs │ ├── Lexer.hs │ ├── Main.hs │ └── Parser.hs ├── expression_problem.hs ├── pawn.hs ├── show.hs ├── trace.hs ├── type_classes.hs └── whynot.hs ├── 11-state-monad ├── bindS.hs ├── evaluate5.hs ├── reader.hs └── state.hs ├── 12-the-list-monad ├── ex1.hs ├── ex2.hs ├── ex3.hs ├── ex4.hs ├── ex5.hs ├── kleisli.hs ├── list_monad.hs ├── list_pairs.hs ├── list_squares.hs ├── quicksort.hs └── triples.hs ├── README.md └── evaluate6.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | -------------------------------------------------------------------------------- /01-calling-functions/pyth1.hs: -------------------------------------------------------------------------------- 1 | -- Add parentheses to the code below to make it compile 2 | pyth a b = a * a + b * b 3 | 4 | -- main = print $ pyth 3 * 2 pyth -1 8 5 | 6 | main = print $ pyth (3 * 2) (pyth (-1) 8) 7 | -------------------------------------------------------------------------------- /01-calling-functions/pyth2.hs: -------------------------------------------------------------------------------- 1 | -- Add parentheses and commas to code below to make it compile. You may reduce the number of parentheses if you take into account that the comma inside a tuple has lower precedence than arithmetic operators. 2 | -- 3 | pyth' (a, b) = a * a + b * b 4 | 5 | -- main = print $ pyth' 3 * 2 pyth' -1 8 6 | main = print $ pyth' (3 * 2, pyth' (-1, 8)) 7 | -------------------------------------------------------------------------------- /01-calling-functions/pyth3.hs: -------------------------------------------------------------------------------- 1 | -- Try to remove as many parentheses as you can using $ signs 2 | pyth a b = a * a + b * b 3 | 4 | --main = do print (sqrt (pyth 3 ((-1) - 3))) 5 | main = do print $ sqrt $ pyth 3 $ -1 - 3 6 | -------------------------------------------------------------------------------- /01-calling-functions/sq1.hs: -------------------------------------------------------------------------------- 1 | sq b = b * b 2 | 3 | main = print $ sq 3+1 4 | -------------------------------------------------------------------------------- /01-calling-functions/sq2.hs: -------------------------------------------------------------------------------- 1 | sq x = x * x 2 | main = print $ sq (sqrt (7 + 9)) 3 | -------------------------------------------------------------------------------- /01-calling-functions/sq_dollar.hs: -------------------------------------------------------------------------------- 1 | sq x = x * x 2 | main = print $ sq $ sqrt $ 7 + 9 3 | -------------------------------------------------------------------------------- /01-calling-functions/sq_dot.hs: -------------------------------------------------------------------------------- 1 | sq x = x * x 2 | main = print $ (sq . sqrt ) $ 7 + 9 3 | -------------------------------------------------------------------------------- /01-calling-functions/sq_id.hs: -------------------------------------------------------------------------------- 1 | sq x = x * x 2 | main = print $ (sq . sqrt . id) 256 3 | -------------------------------------------------------------------------------- /02-my-first-program/center.hs: -------------------------------------------------------------------------------- 1 | center ((x, y), (x', y')) = ((x + x')/2, (y + y')/2) 2 | main = print $ center ((1,2), (3, 4)) 3 | -------------------------------------------------------------------------------- /02-my-first-program/flop.hs: -------------------------------------------------------------------------------- 1 | flop (a, b) = (b, a) 2 | main = print $ flop (1, "one") 3 | -------------------------------------------------------------------------------- /02-my-first-program/lenseg.hs: -------------------------------------------------------------------------------- 1 | pyth (a, b) = a * a + b * b 2 | lenSeg ((x, y), (x', y')) = sqrt $ pyth (x' - x, y' - y) 3 | main = print $ lenSeg ((1, 0.5), (-1, -0.5)) 4 | -------------------------------------------------------------------------------- /02-my-first-program/pattern.hs: -------------------------------------------------------------------------------- 1 | pyth (a, b) = a * a + b * b 2 | len vec = sqrt (pyth vec) 3 | main = print $ len (12.6, -3.21) 4 | -------------------------------------------------------------------------------- /02-my-first-program/segment.hs: -------------------------------------------------------------------------------- 1 | makeSegment p1 p2 = (p1, p2) 2 | main = print $ makeSegment (1, 2) (3, 4) 3 | -------------------------------------------------------------------------------- /02-my-first-program/wildcard.hs: -------------------------------------------------------------------------------- 1 | getThePoint (_, pt, _) = pt 2 | main = print $ getThePoint (2 * 3.14 * 10, (1, 0.5), "Hello!") 3 | -------------------------------------------------------------------------------- /03-pure-functions-laziness-io/getline.hs: -------------------------------------------------------------------------------- 1 | -- exercise to take the input string from the user 2 | putQStrLn str = do 3 | putChar '"' 4 | putStr str 5 | putChar '"' 6 | putChar '\n' 7 | 8 | main = do 9 | putStrLn "Enter text:" 10 | str <- getLine 11 | putQStrLn str 12 | -------------------------------------------------------------------------------- /03-pure-functions-laziness-io/lazy1.hs: -------------------------------------------------------------------------------- 1 | foo x = 1 2 | main = print $ (foo undefined) + 1 3 | -------------------------------------------------------------------------------- /03-pure-functions-laziness-io/putqstr.hs: -------------------------------------------------------------------------------- 1 | -- Define a function putQStrLn that outputs a string surrounded by quotes, '"' 2 | putQStrLn str = do 3 | putChar '"' 4 | putStr str 5 | putChar '"' 6 | putChar '\n' 7 | 8 | main = putQStrLn "You can quote me." 9 | -------------------------------------------------------------------------------- /03-pure-functions-laziness-io/putstr.hs: -------------------------------------------------------------------------------- 1 | putStrLn' str = do 2 | putStr str 3 | putChar '\n' 4 | 5 | main = do 6 | putStrLn' "First line" 7 | putStrLn' "Second line" 8 | -------------------------------------------------------------------------------- /04-symbolic-calculator-recursion/factorial.hs: -------------------------------------------------------------------------------- 1 | fact :: Int -> Int 2 | fact n = if n == 0 then 1 else n * fact (n - 1) 3 | 4 | main = print (fact 6) 5 | -------------------------------------------------------------------------------- /04-symbolic-calculator-recursion/factorial2.hs: -------------------------------------------------------------------------------- 1 | -- The evaluation of factorial starts returning incorrect results right about n = 21 because of the Int overflow. Try implementing a version that uses the infinite precision Integer instead of Int. 2 | -- 3 | fact :: Int -> Int 4 | fact n = if n > 0 then n * fact (n - 1) else 1 5 | 6 | fullFact :: Integer -> Integer 7 | fullFact n = if n > 0 then n * fullFact (n - 1) else 1 8 | 9 | main = do 10 | print (fact 23) 11 | print (fullFact 23) 12 | -------------------------------------------------------------------------------- /04-symbolic-calculator-recursion/fibonacci.hs: -------------------------------------------------------------------------------- 1 | fib :: Int -> Int 2 | fib n = if n > 2 then fib (n - 1) + fib (n - 2) else 1 3 | 4 | main = print (fib 8) 5 | -------------------------------------------------------------------------------- /04-symbolic-calculator-recursion/loop.hs: -------------------------------------------------------------------------------- 1 | loop :: Int -> IO () 2 | loop n = do 3 | if n < 5 4 | then do 5 | putStrLn (show n) 6 | loop (n + 1) 7 | else 8 | return () 9 | 10 | main :: IO () 11 | main = loop 0 12 | -------------------------------------------------------------------------------- /04-symbolic-calculator-recursion/loop_sq.hs: -------------------------------------------------------------------------------- 1 | -- Print squares of numbers from 1 to 10 2 | 3 | loop :: Int -> IO () 4 | loop n = do 5 | if n <= 10 6 | then do 7 | putStrLn (show (n * n)) 8 | loop (n + 1) 9 | else 10 | return () 11 | 12 | main :: IO () 13 | main = loop 1 14 | -------------------------------------------------------------------------------- /04-symbolic-calculator-recursion/recursion.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = do 3 | line <- getLine 4 | putStrLn line 5 | main 6 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/builtinlist.hs: -------------------------------------------------------------------------------- 1 | sumLst :: [Int] -> Int 2 | sumLst (i : rest) = i + sumLst rest 3 | sumLst [] = 0 4 | 5 | lst = [2, 4, 6] 6 | 7 | main = do 8 | print (sumLst lst) 9 | print (sumLst []) 10 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/decimate.hs: -------------------------------------------------------------------------------- 1 | -- Implement the function decimate that skips every other element of a list. 2 | 3 | decimate :: [a] -> [a] 4 | decimate (i : j : rest) = i : decimate rest 5 | decimate (i : j) = [i] 6 | decimate [] = [] 7 | 8 | main = do 9 | print (decimate [1, 2, 3, 4, 5]) 10 | print (decimate [1, 2, 3, 4]) 11 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/decimate2.hs: -------------------------------------------------------------------------------- 1 | decimate :: [a] -> [a] 2 | decimate (a:_:rest) = a : decimate rest 3 | decimate (a:_) = [a] 4 | decimate _ = [] 5 | 6 | main = do 7 | print (decimate [1, 2, 3, 4, 5]) 8 | print (decimate [1, 2, 3, 4]) 9 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/genericlist.hs: -------------------------------------------------------------------------------- 1 | data List a = Cons a (List a) | Empty 2 | 3 | sumLst :: (List Int) -> Int 4 | sumLst (Cons i rest) = i + sumLst rest 5 | sumLst Empty = 0 6 | 7 | sumDoubles :: (List Double) -> Double 8 | sumDoubles (Cons i rest) = i + sumDoubles rest 9 | sumDoubles Empty = 0 10 | 11 | lst = Cons 2 (Cons 4 (Cons 6 Empty)) 12 | lst2 = Cons 2.0 (Cons 4 (Cons 6 Empty)) 13 | 14 | main = do 15 | print (sumLst lst) 16 | print (sumLst Empty) 17 | print (sumDoubles lst2) 18 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/list1.hs: -------------------------------------------------------------------------------- 1 | data List = Cons Int List | Empty 2 | 3 | singleton :: List -> Bool 4 | singleton (Cons _ Empty) = True 5 | singleton _ = False 6 | 7 | main = do 8 | print $ singleton Empty 9 | print $ singleton $ Cons 2 Empty 10 | print $ singleton $ Cons 3 $ Cons 4 Empty 11 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/match1.hs: -------------------------------------------------------------------------------- 1 | boolToInt :: Bool -> Int 2 | boolToInt True = 1 3 | boolToInt False = 0 4 | 5 | main = print $ boolToInt False 6 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/norm.hs: -------------------------------------------------------------------------------- 1 | --Implement norm that takes a list of Doubles and returns the square root (sqrt) of the sum of squares of its elements. 2 | 3 | norm :: [Double] -> Double 4 | norm lst = sqrt $ doublessum lst 5 | 6 | doublessum :: [Double] -> Double 7 | doublessum (i : rest) = i * i + doublessum rest 8 | doublessum [] = 0.0 9 | 10 | main = do 11 | print (norm [1.1, 2.2, 3.3]) 12 | print (norm [3.0, 4.0]) 13 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/operator1.hs: -------------------------------------------------------------------------------- 1 | data Operator = Sum | Minus | Mul | Div 2 | 3 | optochar :: Operator -> Char 4 | optochar Sum = '+' 5 | optochar Minus = '-' 6 | optochar Mul = '*' 7 | optochar Div = '/' 8 | 9 | main = print $ optochar Div 10 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/point1.hs: -------------------------------------------------------------------------------- 1 | --Define a data type Point with one constructor Pt that takes two Doubles, corresponding to the x and y coordinates of a point. Write a function inc that takes a Point and returns a new Point whose coordinates are one more than the original coordinates. Use pattern matching. 2 | 3 | data Point = Pt Double Double 4 | deriving Show 5 | 6 | inc :: Point -> Point 7 | inc (Pt x y) = Pt (x + 1) (y + 1) 8 | 9 | p :: Point 10 | p = Pt (-1) 3 11 | 12 | main = print $ inc p 13 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/point2.hs: -------------------------------------------------------------------------------- 1 | --Solve the previous exercise using pairs rather than Points. 2 | 3 | inc :: (Int, Int) -> (Int, Int) 4 | inc (x, y) = (x +1, y + 1) 5 | 6 | p :: (Int, Int) 7 | p = (-1, 4) 8 | 9 | main = print $ inc p 10 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/showcontent.hs: -------------------------------------------------------------------------------- 1 | data Operator = Plus | Minus | Times | Div 2 | deriving (Show, Eq) 3 | 4 | opToStr :: Operator -> String 5 | opToStr Plus = "+" 6 | opToStr Minus = "-" 7 | opToStr Times = "*" 8 | opToStr Div = "/" 9 | 10 | data Token = TokOp Operator 11 | | TokIdent String 12 | | TokNum Int 13 | deriving (Show, Eq) 14 | 15 | showContent :: Token -> String 16 | showContent (TokOp op) = opToStr op 17 | showContent (TokIdent str) = str 18 | showContent (TokNum i) = show i 19 | 20 | token :: Token 21 | token = TokIdent "x" 22 | 23 | token2 :: Token 24 | token2 = TokOp Plus 25 | 26 | main = do 27 | putStrLn $ showContent token 28 | print token 29 | putStrLn $ showContent token2 30 | print token2 31 | putStrLn $ showContent (TokNum 5) 32 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/sumlist.hs: -------------------------------------------------------------------------------- 1 | data List = Cons Int List | Empty 2 | 3 | sumLst :: List -> Int 4 | sumLst (Cons i rest) = i + sumLst rest 5 | sumLst Empty = 0 6 | 7 | lst = Cons 2 (Cons 4 (Cons 6 Empty)) 8 | 9 | main = do 10 | print (sumLst lst) 11 | print (sumLst Empty) 12 | -------------------------------------------------------------------------------- /05-tokenizer-data-types/ziplist.hs: -------------------------------------------------------------------------------- 1 | --Implement a function that takes a pair of lists and returns a list of pairs. For instance ([1, 2, 3, 4], [1, 4, 9]) should produce [(1, 1), (2, 4), (3, 9)]. Notice that the longer of the two lists is truncated if necessary. Use nested patterns. 2 | zipLst :: ([a], [b]) -> [(a, b)] 3 | zipLst ((x : xs), (y: ys)) = (x, y) : zipLst (xs, ys) 4 | zipLst (_, _) = [] 5 | 6 | main = print $ zipLst ([1, 2, 3, 4], "Hello") 7 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/cat.hs: -------------------------------------------------------------------------------- 1 | --Implement function cat that concatenates two lists. 2 | 3 | cat :: [a] -> [a] -> [a] 4 | cat [] j = j 5 | cat (i : rest) j = i : cat rest j 6 | 7 | main = putStrLn $ cat "Hello " "World!" 8 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/elem.hs: -------------------------------------------------------------------------------- 1 | isDigit :: Char -> Bool 2 | isDigit c = elem c "0123456789" 3 | 4 | main = print $ isDigit '3' 5 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/fib.hs: -------------------------------------------------------------------------------- 1 | --Rewrite the implementation of Fibonacci numbers using guards instead of the if statement 2 | fib :: Int -> Int 3 | fib n | n == 1 = 1 4 | | n == 2 = 1 5 | | otherwise = fib (n-1) + fib (n-2) 6 | 7 | main = print (fib 20) 8 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/guards1.hs: -------------------------------------------------------------------------------- 1 | data Operator = Plus | Minus | Times | Div 2 | deriving (Show, Eq) 3 | 4 | operator :: Char -> Operator 5 | operator c | c == '+' = Plus 6 | | c == '-' = Minus 7 | | c == '*' = Times 8 | | c == '/' = Div 9 | 10 | main = do 11 | print $ operator '*' 12 | print $ operator '+' 13 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/is3elem.hs: -------------------------------------------------------------------------------- 1 | isElem c (d : rest) = if c == d 2 | then True 3 | else isElem c rest 4 | isElem _ [] = False 5 | 6 | is3elem = isElem '3' 7 | 8 | main = print $ is3elem "123" 9 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/iselem.hs: -------------------------------------------------------------------------------- 1 | isElem c (d : rest) = if c == d 2 | then True 3 | else isElem c rest 4 | isElem _ [] = False 5 | 6 | main = do 7 | print $ isElem '3' "abc" 8 | print $ isElem '3' "123" 9 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/pig.hs: -------------------------------------------------------------------------------- 1 | --Use cat from previous exercise and currying to define a function pig that prepends "pig" to any string. 2 | 3 | cat :: [a] -> [a] -> [a] 4 | cat [] j = j 5 | cat (i : rest) j = i : cat rest j 6 | 7 | pig :: String -> String 8 | pig = cat "pig" 9 | 10 | main = putStrLn $ pig "sty" 11 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/sumdig.hs: -------------------------------------------------------------------------------- 1 | -- Implement function sumDig that takes a number in the form of a string and calculates the sum of its digits. 2 | 3 | import Data.Char 4 | 5 | toInts :: String -> [Int] 6 | toInts [] = [] 7 | toInts (c : cs) = digitToInt c : toInts cs 8 | 9 | sumDig :: String -> Int 10 | sumDig s = acc 0 (toInts s) 11 | 12 | acc :: Int -> [Int] -> Int 13 | acc x [] = x 14 | acc x (i : rest) = acc (x + i) rest 15 | 16 | main = print $ sumDig "30750" 17 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/toints.hs: -------------------------------------------------------------------------------- 1 | --Implement function toInts that takes a number in the form of a string and returns a list of its digits as integers. 2 | 3 | import Data.Char 4 | 5 | toInts :: String -> [Int] 6 | toInts (i : rest) = digitToInt i : toInts rest 7 | toInts [] = [] 8 | 9 | main = print $ toInts "2013" 10 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/token1.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | data Token = Digit | Alpha 4 | deriving (Show, Eq) 5 | 6 | tokenize :: String -> [Token] 7 | tokenize (c : rest) = 8 | if isDigit c 9 | then Digit : tokenize rest 10 | else Alpha : tokenize rest 11 | tokenize [] = [] 12 | 13 | main = print $ tokenize "passwd123" 14 | -------------------------------------------------------------------------------- /06-tokenizer-function-types/tokenize.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | data Operator = Plus | Minus | Times | Div 4 | deriving (Show, Eq) 5 | 6 | data Token = TokOp Operator 7 | | TokIdent String 8 | | TokNum Int 9 | deriving (Show, Eq) 10 | 11 | operator :: Char -> Operator 12 | operator c | c == '+' = Plus 13 | | c == '-' = Minus 14 | | c == '*' = Times 15 | | c == '/' = Div 16 | 17 | tokenize :: String -> [Token] 18 | tokenize [] = [] 19 | tokenize (c : cs) 20 | | elem c "+-*/" = TokOp (operator c) : tokenize cs 21 | | isDigit c = TokNum (digitToInt c) : tokenize cs 22 | | isAlpha c = TokIdent [c] : tokenize cs 23 | | isSpace c = tokenize cs 24 | | otherwise = error $ "Cannot tokenize " ++ [c] 25 | 26 | main = print $ tokenize " 1 + 4 / x " 27 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/alnums.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | alnums :: String -> (String, String) 4 | alnums str = als "" str 5 | where 6 | als acc [] = (acc, []) 7 | als acc (c : cs) | isAlphaNum c = 8 | let (acc', cs') = als acc cs 9 | in (c:acc', cs') 10 | | otherwise = (acc, c:cs) 11 | 12 | main = print $ alnums "R2D2+C3Po" 13 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/alnumsfoldl.hs: -------------------------------------------------------------------------------- 1 | -- Just as a proof of concept, implement a version of alnums using foldl 2 | import Data.Char 3 | 4 | type Accum = (Bool, String, String) 5 | 6 | alnums :: String -> (String, String) 7 | alnums str = let (_, als, rest) = foldl f (True, [], []) str 8 | in (als, rest) 9 | where 10 | f (True, als, rest) c | isAlphaNum c = (True, als ++ [c], rest) 11 | | otherwise = (False, als, [c]) 12 | f (False, als, rest) c = (False, als, rest ++ [c]) 13 | 14 | main = do 15 | print $ alnums "R2D2+C3Po" 16 | print $ alnums "a14" 17 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/foldl1.hs: -------------------------------------------------------------------------------- 1 | -- Use foldl to calculate the sum of squares given a list of doubles. 2 | 3 | squares :: [Int] -> Int 4 | squares = foldl (\acc x -> acc + x * x) 0 5 | 6 | main = print $ squares [3, 4, 5] 7 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/foldl2.hs: -------------------------------------------------------------------------------- 1 | -- Use foldl to calculate the sum of squares given a list of doubles. 2 | 3 | accf :: Int -> Int -> Int 4 | accf a b = a + b * b 5 | 6 | main = print $ foldl accf 0 [3, 4, 5] 7 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/incircle.hs: -------------------------------------------------------------------------------- 1 | -- Implement function inCircle2 that takes a list of 2-D points and returns only those that fit inside the circle of radius 2. 2 | type Point = (Double, Double) 3 | inCircle2 :: [Point] -> [Point] 4 | inCircle2 = filter (\(x, y) -> sqrt (x*x + y*y) <= 2.0) 5 | 6 | main = print $ inCircle2 [(0, 0), (2, -2), (1, -1), (1.9, 0.1), (10, 1)] 7 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/myalnums.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | alnums :: String -> (String, String) 4 | alnums x = als "" x 5 | 6 | als :: String -> String -> (String, String) 7 | als i [] = (i, []) 8 | als i (j : rest) = if isAlphaNum j 9 | then als (i ++ [j]) rest 10 | else (i, j : rest) 11 | 12 | main = print $ alnums "R2D2+C3Po" 13 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/myfilter.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import Prelude hiding (filter) 3 | 4 | filter :: (a -> Bool) -> [a] -> [a] 5 | filter _ [] = [] 6 | filter f (a: rest) = if f a 7 | then a : filter f rest 8 | else filter f rest 9 | 10 | main = print $ filter isDigit "a1b2c3" 11 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/mymap.hs: -------------------------------------------------------------------------------- 1 | import Data.Char -- for the example 2 | import Prelude hiding (map) 3 | -- show 4 | map :: (a -> b) -> [a] -> [b] 5 | map _ [] = [] 6 | map f (a : as) = f a : map f as 7 | 8 | main = print $ map toUpper "hello world!" 9 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/rev.hs: -------------------------------------------------------------------------------- 1 | -- The accumulator in foldl can also be a list. With this in mind, implement function rev that reverses a list. 2 | rev :: [a] -> [a] 3 | rev = foldl (\acc a -> a : acc) [] 4 | 5 | main = print $ rev "spot on" 6 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/span1.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import Prelude hiding (span) 3 | -- show 4 | span :: (a -> Bool) -> [a] -> ([a], [a]) 5 | span pred str = 6 | let -- define a helper function 'spanAcc' 7 | spanAcc acc [] = (acc, []) 8 | spanAcc acc (c : cs) | pred c = 9 | let (acc', cs') = spanAcc acc cs 10 | in (c:acc', cs') 11 | | otherwise = (acc, c:cs) 12 | in 13 | spanAcc [] str 14 | 15 | main = do 16 | print $ span isAlphaNum "R2D2 + C3Po" 17 | print $ span isDigit "Y22D + C3Po" 18 | print $ span isDigit "22D + C3Po" 19 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/squares.hs: -------------------------------------------------------------------------------- 1 | -- Implement function squares that takes a list of integers and returns the list of their squares. Use higher order functions and lambdas. 2 | squares :: [Int] -> [Int] 3 | squares = map (\x -> x * x) 4 | 5 | main = print $ squares [1..10] 6 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/toints.hs: -------------------------------------------------------------------------------- 1 | -- Implement the function toInts from the previous tutorial using map. This function takes a string of digits and creates a list of Ints corresponding to these digits. 2 | import Data.Char 3 | 4 | toInts :: String -> [Int] 5 | toInts = map digitToInt 6 | 7 | main = print $ toInts "30750" 8 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/tokenize2.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | data Operator = Plus | Minus | Times | Div 4 | deriving (Show, Eq) 5 | 6 | data Token = TokOp Operator 7 | | TokIdent String 8 | | TokNum Int 9 | | TokSpace 10 | deriving (Show, Eq) 11 | 12 | operator :: Char -> Operator 13 | operator c | c == '+' = Plus 14 | | c == '-' = Minus 15 | | c == '*' = Times 16 | | c == '/' = Div 17 | 18 | tokenize :: String -> [Token] 19 | tokenize = map tokenizeChar 20 | 21 | tokenizeChar :: Char -> Token 22 | tokenizeChar c | elem c "+-*/" = TokOp (operator c) 23 | | isDigit c = TokNum (digitToInt c) 24 | | isAlpha c = TokIdent [c] 25 | | isSpace c = TokSpace 26 | | otherwise = error $ "Cannot tokenize " ++ [c] 27 | 28 | deSpace :: [Token] -> [Token] 29 | deSpace = filter (\t -> t /= TokSpace) 30 | 31 | main = print $ deSpace $ tokenize " 1 + 4 / x " 32 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/tokenize3.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | data Operator = Plus | Minus | Times | Div 4 | deriving (Show, Eq) 5 | 6 | data Token = TokOp Operator 7 | | TokIdent String 8 | | TokNum Int 9 | deriving (Show, Eq) 10 | 11 | operator :: Char -> Operator 12 | operator c | c == '+' = Plus 13 | | c == '-' = Minus 14 | | c == '*' = Times 15 | | c == '/' = Div 16 | 17 | tokenize :: String -> [Token] 18 | tokenize [] = [] 19 | tokenize (c : cs) 20 | | elem c "+-*/" = TokOp (operator c) : tokenize cs 21 | | isDigit c = number c cs 22 | | isAlpha c = identifier c cs 23 | | isSpace c = tokenize cs 24 | | otherwise = error $ "Cannot tokenize " ++ [c] 25 | 26 | identifier c cs = let (str, cs') = span isAlphaNum cs in 27 | TokIdent (c:str) : tokenize cs' 28 | 29 | number c cs = 30 | let (digs, cs') = span isDigit cs in 31 | TokNum (read (c : digs)) : tokenize cs' 32 | 33 | main = do 34 | print $ tokenize "12 + 24 / x1" 35 | -------------------------------------------------------------------------------- /07-tokenizer-higher-order-functions/tokenize4.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | data Operator = Plus | Minus | Times | Div 4 | deriving (Show, Eq) 5 | 6 | data Token = TokOp Operator 7 | | TokAssign 8 | | TokLParen 9 | | TokRParen 10 | | TokIdent String 11 | | TokNum Int 12 | deriving (Show, Eq) 13 | 14 | operator :: Char -> Operator 15 | operator c | c == '+' = Plus 16 | | c == '-' = Minus 17 | | c == '*' = Times 18 | | c == '/' = Div 19 | 20 | tokenize :: String -> [Token] 21 | tokenize [] = [] 22 | tokenize (c : cs) 23 | | elem c "+-*/" = TokOp (operator c) : tokenize cs 24 | | c == '=' = TokAssign : tokenize cs 25 | | c == '(' = TokLParen : tokenize cs 26 | | c == ')' = TokRParen : tokenize cs 27 | | isDigit c = number c cs 28 | | isAlpha c = identifier c cs 29 | | isSpace c = tokenize cs 30 | | otherwise = error $ "Cannot tokenize " ++ [c] 31 | 32 | identifier c cs = let (str, cs') = span isAlphaNum cs in 33 | TokIdent (c:str) : tokenize cs' 34 | 35 | number c cs = 36 | let (digs, cs') = span isDigit cs in 37 | TokNum (read (c : digs)) : tokenize cs' 38 | 39 | main = do 40 | print $ tokenize " y = (12 + 24) / x1" 41 | -------------------------------------------------------------------------------- /08-parser/ex1.hs: -------------------------------------------------------------------------------- 1 | -- The shape of a binary tree may be encoded using matching pairs of parentheses. The string of parentheses obtained this way matches the following grammar: 2 | -- 3 | -- Root <- Par 4 | -- Expr <- Par Par 5 | -- Par <- '(' Expr ')' 6 | -- | '(' ')' 7 | -- 8 | 9 | data Token = TokLParen | TokRParen | TokEnd 10 | deriving (Show, Eq) 11 | 12 | lookAhead :: [Char] -> Token 13 | lookAhead [] = TokEnd 14 | lookAhead (c:cs)| c == '(' = TokLParen 15 | | c == ')' = TokRParen 16 | | otherwise = error $ "Bad input: " ++ (c:cs) 17 | 18 | accept :: [Char] -> [Char] 19 | accept [] = error "Nothing to accept" 20 | accept (c:cs) = cs 21 | 22 | data Tree = Node Tree Tree | Leaf 23 | deriving Show 24 | 25 | root, expr, par :: [Char] -> (Tree, [Char]) 26 | 27 | root = par 28 | 29 | expr toks = 30 | let (p, toks') = par toks 31 | (p', toks'') = par toks' 32 | in (Node p p', toks'') 33 | 34 | par toks = 35 | case lookAhead toks of 36 | TokLParen -> 37 | case lookAhead (accept toks) of 38 | TokRParen -> (Leaf, accept (accept toks)) 39 | _ -> let (e, toks') = expr (accept toks) 40 | in if lookAhead toks' == TokRParen 41 | then (e, accept toks') 42 | else error $ "Missing closing paren in: " ++ show toks' 43 | _ -> error $ "Bad expression: " ++ show toks 44 | 45 | parse str = let (tree, str') = root str 46 | in 47 | if null str' 48 | then tree 49 | else error $ "Unconsumed string " ++ str' 50 | 51 | main = print $ parse "(()(()()))" 52 | 53 | -------------------------------------------------------------------------------- /08-parser/ex2.hs: -------------------------------------------------------------------------------- 1 | -- Write a parser that splits a string into a list of words using space characters as separators (use function isSpace). 2 | 3 | import Data.Char 4 | import Prelude hiding (Word) 5 | 6 | type Word = String 7 | 8 | sentence :: String -> [Word] 9 | sentence "" = [] 10 | sentence str = let (w, str') = word str 11 | in w : sentence str' 12 | 13 | -- returns a word and the rest of input 14 | word :: String -> (Word, String) 15 | word "" = ("", "") 16 | word (c:cs) | isSpace c = ("", cs) 17 | | otherwise = let (w, cs') = word cs 18 | in (c:w, cs') 19 | 20 | main = print $ sentence "Ceci n'est pas une phrase" 21 | -------------------------------------------------------------------------------- /08-parser/ex2_span.hs: -------------------------------------------------------------------------------- 1 | -- Write a parser that splits a string into a list of words using space characters as separators (use function isSpace). 2 | 3 | import Data.Char 4 | import Prelude hiding (Word) 5 | 6 | type Word = String 7 | 8 | sentence :: String -> [Word] 9 | sentence "" = [] 10 | sentence str = let (w, str') = word str 11 | in w : sentence str' 12 | 13 | -- returns a word and the rest of input 14 | word :: String -> (Word, String) 15 | word str = let (w, str') = span (not . isSpace) str 16 | (_, str'') = span isSpace str' 17 | in (w, str'') 18 | 19 | main = print $ sentence "Ceci n'est pas une phrase" 20 | -------------------------------------------------------------------------------- /08-parser/ex3.hs: -------------------------------------------------------------------------------- 1 | -- Generalize the sentence parser from (Ex 2) to take a pluggable parser. The new function is called several and takes as an argument a generic function String->(a, String), which is supposed to parse a string and return the result of type a together with the leftover string. Use it to split a string into a list of numbers. 2 | 3 | import Data.Char 4 | 5 | type Parser a = String -> (a, String) 6 | 7 | several :: Parser a -> String -> [a] 8 | several p "" = [] 9 | several p str = let (a, str') = p str 10 | as = several p str' 11 | in a:as 12 | 13 | num :: Parser Int 14 | num str = 15 | let (digs, str') = span isDigit str 16 | (_, str'') = span isSpace str' 17 | in (read digs, str'') 18 | 19 | 20 | word :: Parser String 21 | word str = let (w, str') = span (not . isSpace) str 22 | (_, str'') = span isSpace str' 23 | in (w, str'') 24 | 25 | main = do 26 | print $ several num "12 4 128" 27 | print $ several word "Ceci n'est pas une phrase" 28 | -------------------------------------------------------------------------------- /08-parser/tokenize5.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | data Operator = Plus | Minus | Times | Div 4 | deriving (Show, Eq) 5 | 6 | data Token = TokOp Operator 7 | | TokAssign 8 | | TokLParen 9 | | TokRParen 10 | | TokIdent String 11 | | TokNum Double 12 | | TokEnd 13 | deriving (Show, Eq) 14 | 15 | operator :: Char -> Operator 16 | operator c | c == '+' = Plus 17 | | c == '-' = Minus 18 | | c == '*' = Times 19 | | c == '/' = Div 20 | 21 | tokenize :: String -> [Token] 22 | tokenize [] = [] 23 | tokenize (c : cs) 24 | | elem c "+-*/" = TokOp (operator c) : tokenize cs 25 | | c == '=' = TokAssign : tokenize cs 26 | | c == '(' = TokLParen : tokenize cs 27 | | c == ')' = TokRParen : tokenize cs 28 | | isDigit c = number c cs 29 | | isAlpha c = identifier c cs 30 | | isSpace c = tokenize cs 31 | | otherwise = error $ "Cannot tokenize " ++ [c] 32 | 33 | identifier :: Char -> String -> [Token] 34 | identifier c cs = let (name, cs') = span isAlphaNum cs in 35 | TokIdent (c:name) : tokenize cs' 36 | 37 | number :: Char -> String -> [Token] 38 | number c cs = 39 | let (digs, cs') = span isDigit cs in 40 | TokNum (read (c : digs)) : tokenize cs' 41 | 42 | ---- parser ---- 43 | 44 | data Tree = SumNode Operator Tree Tree 45 | | ProdNode Operator Tree Tree 46 | | AssignNode String Tree 47 | | UnaryNode Operator Tree 48 | | NumNode Double 49 | | VarNode String 50 | deriving Show 51 | 52 | lookAhead :: [Token] -> Token 53 | lookAhead [] = TokEnd 54 | lookAhead (t:ts) = t 55 | 56 | accept :: [Token] -> [Token] 57 | accept [] = error "Nothing to accept" 58 | accept (t:ts) = ts 59 | 60 | expression :: [Token] -> (Tree, [Token]) 61 | expression toks = 62 | let (termTree, toks') = term toks 63 | in 64 | case lookAhead toks' of 65 | (TokOp op) | elem op [Plus, Minus] -> 66 | let (exTree, toks'') = expression (accept toks') 67 | in (SumNode op termTree exTree, toks'') 68 | TokAssign -> 69 | case termTree of 70 | VarNode str -> 71 | let (exTree, toks'') = expression (accept toks') 72 | in (AssignNode str exTree, toks'') 73 | _ -> error "Only variables can be assigned to" 74 | _ -> (termTree, toks') 75 | 76 | term :: [Token] -> (Tree, [Token]) 77 | term toks = 78 | let (facTree, toks') = factor toks 79 | in 80 | case lookAhead toks' of 81 | (TokOp op) | elem op [Times, Div] -> 82 | let (termTree, toks'') = term (accept toks') 83 | in (ProdNode op facTree termTree, toks'') 84 | _ -> (facTree, toks') 85 | 86 | factor :: [Token] -> (Tree, [Token]) 87 | factor toks = 88 | case lookAhead toks of 89 | (TokNum x) -> (NumNode x, accept toks) 90 | (TokIdent str) -> (VarNode str, accept toks) 91 | (TokOp op) | elem op [Plus, Minus] -> 92 | let (facTree, toks') = factor (accept toks) 93 | in (UnaryNode op facTree, toks') 94 | TokLParen -> 95 | let (expTree, toks') = expression (accept toks) 96 | in 97 | if lookAhead toks' /= TokRParen 98 | then error "Missing right parenthesis" 99 | else (expTree, accept toks') 100 | _ -> error $ "Parse error on token: " ++ show toks 101 | 102 | parse :: [Token] -> Tree 103 | parse toks = let (tree, toks') = expression toks 104 | in 105 | if null toks' 106 | then tree 107 | else error $ "Leftover tokens: " ++ show toks' 108 | 109 | main = (print . parse . tokenize) "x1 = -15 / (2 + x2)" 110 | -------------------------------------------------------------------------------- /09-evaluator/evaluate1.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | data Operator = Plus | Minus | Times | Div 4 | deriving (Show, Eq) 5 | 6 | data Token = TokOp Operator 7 | | TokAssign 8 | | TokLParen 9 | | TokRParen 10 | | TokIdent String 11 | | TokNum Double 12 | | TokEnd 13 | deriving (Show, Eq) 14 | 15 | operator :: Char -> Operator 16 | operator c | c == '+' = Plus 17 | | c == '-' = Minus 18 | | c == '*' = Times 19 | | c == '/' = Div 20 | 21 | tokenize :: String -> [Token] 22 | tokenize [] = [] 23 | tokenize (c : cs) 24 | | elem c "+-*/" = TokOp (operator c) : tokenize cs 25 | | c == '=' = TokAssign : tokenize cs 26 | | c == '(' = TokLParen : tokenize cs 27 | | c == ')' = TokRParen : tokenize cs 28 | | isDigit c = number c cs 29 | | isAlpha c = identifier c cs 30 | | isSpace c = tokenize cs 31 | | otherwise = error $ "Cannot tokenize " ++ [c] 32 | 33 | identifier :: Char -> String -> [Token] 34 | identifier c cs = let (name, cs') = span isAlphaNum cs in 35 | TokIdent (c:name) : tokenize cs' 36 | 37 | number :: Char -> String -> [Token] 38 | number c cs = 39 | let (digs, cs') = span isDigit cs in 40 | TokNum (read (c : digs)) : tokenize cs' 41 | 42 | ---- parser ---- 43 | 44 | data Tree = SumNode Operator Tree Tree 45 | | ProdNode Operator Tree Tree 46 | | AssignNode String Tree 47 | | UnaryNode Operator Tree 48 | | NumNode Double 49 | | VarNode String 50 | deriving Show 51 | 52 | lookAhead :: [Token] -> Token 53 | lookAhead [] = TokEnd 54 | lookAhead (t:ts) = t 55 | 56 | accept :: [Token] -> [Token] 57 | accept [] = error "Nothing to accept" 58 | accept (t:ts) = ts 59 | 60 | expression :: [Token] -> (Tree, [Token]) 61 | expression toks = 62 | let (termTree, toks') = term toks 63 | in 64 | case lookAhead toks' of 65 | (TokOp op) | elem op [Plus, Minus] -> 66 | let (exTree, toks'') = expression (accept toks') 67 | in (SumNode op termTree exTree, toks'') 68 | TokAssign -> 69 | case termTree of 70 | VarNode str -> 71 | let (exTree, toks'') = expression (accept toks') 72 | in (AssignNode str exTree, toks'') 73 | _ -> error "Only variables can be assigned to" 74 | _ -> (termTree, toks') 75 | 76 | term :: [Token] -> (Tree, [Token]) 77 | term toks = 78 | let (facTree, toks') = factor toks 79 | in 80 | case lookAhead toks' of 81 | (TokOp op) | elem op [Times, Div] -> 82 | let (termTree, toks'') = term (accept toks') 83 | in (ProdNode op facTree termTree, toks'') 84 | _ -> (facTree, toks') 85 | 86 | factor :: [Token] -> (Tree, [Token]) 87 | factor toks = 88 | case lookAhead toks of 89 | (TokNum x) -> (NumNode x, accept toks) 90 | (TokIdent str) -> (VarNode str, accept toks) 91 | (TokOp op) | elem op [Plus, Minus] -> 92 | let (facTree, toks') = factor (accept toks) 93 | in (UnaryNode op facTree, toks') 94 | TokLParen -> 95 | let (expTree, toks') = expression (accept toks) 96 | in 97 | if lookAhead toks' /= TokRParen 98 | then error "Missing right parenthesis" 99 | else (expTree, accept toks') 100 | _ -> error $ "Parse error on token: " ++ show toks 101 | 102 | parse :: [Token] -> Tree 103 | parse toks = let (tree, toks') = expression toks 104 | in 105 | if null toks' 106 | then tree 107 | else error $ "Leftover tokens: " ++ show toks' 108 | 109 | ---- evaluator ---- 110 | -- show 111 | 112 | evaluate :: Tree -> Double 113 | evaluate (SumNode op left right) = 114 | let lft = evaluate left 115 | rgt = evaluate right 116 | in 117 | case op of 118 | Plus -> lft + rgt 119 | Minus -> lft - rgt 120 | 121 | evaluate (ProdNode op left right) = 122 | let lft = evaluate left 123 | rgt = evaluate right 124 | in 125 | case op of 126 | Times -> lft * rgt 127 | Div -> lft / rgt 128 | 129 | evaluate (UnaryNode op tree) = 130 | let x = evaluate tree 131 | in case op of 132 | Plus -> x 133 | Minus -> -x 134 | 135 | evaluate (NumNode x) = x 136 | 137 | -- dummy implementation 138 | evaluate (AssignNode str tree) = evaluate tree 139 | 140 | -- dummy implementation 141 | evaluate (VarNode str) = 0 142 | 143 | main = (print . evaluate . parse . tokenize) "x1 = -15 / (2 + x2)" 144 | -------------------------------------------------------------------------------- /09-evaluator/evaluate2/Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Evaluator (evaluate) where 2 | 3 | import Lexer 4 | import Parser 5 | import qualified Data.Map as M 6 | 7 | type SymTab = M.Map String Double 8 | 9 | evaluate :: Tree -> SymTab -> (Double, SymTab) 10 | 11 | evaluate (SumNode op left right) symTab = 12 | let (lft, symTab') = evaluate left symTab 13 | (rgt, symTab'') = evaluate right symTab' 14 | in 15 | case op of 16 | Plus -> (lft + rgt, symTab'') 17 | Minus -> (lft - rgt, symTab'') 18 | 19 | evaluate (ProdNode op left right) symTab = 20 | let (lft, symTab') = evaluate left symTab 21 | (rgt, symTab'') = evaluate right symTab' 22 | in 23 | case op of 24 | Times -> (lft * rgt, symTab) 25 | Div -> (lft / rgt, symTab) 26 | 27 | evaluate (UnaryNode op tree) symTab = 28 | let (x, symTab') = evaluate tree symTab 29 | in case op of 30 | Plus -> (x, symTab') 31 | Minus -> (-x, symTab') 32 | 33 | evaluate (NumNode x) symTab = (x, symTab) 34 | 35 | evaluate (VarNode str) symTab = lookUp str symTab 36 | 37 | evaluate (AssignNode str tree) symTab = 38 | let (v, symTab') = evaluate tree symTab 39 | (_, symTab'') = addSymbol str v symTab' 40 | in (v, symTab'') 41 | 42 | lookUp :: String -> SymTab -> (Double, SymTab) 43 | lookUp str symTab = 44 | case M.lookup str symTab of 45 | Just v -> (v, symTab) 46 | Nothing -> error $ "Undefined variable " ++ str 47 | 48 | addSymbol :: String -> Double -> SymTab -> ((), SymTab) 49 | addSymbol str val symTab = 50 | let symTab' = M.insert str val symTab 51 | in ((), symTab') 52 | -------------------------------------------------------------------------------- /09-evaluator/evaluate2/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lexer (Operator(..), Token(..), tokenize, lookAhead, accept) where 2 | 3 | import Data.Char 4 | 5 | data Operator = Plus | Minus | Times | Div 6 | deriving (Show, Eq) 7 | 8 | data Token = TokOp Operator 9 | | TokAssign 10 | | TokLParen 11 | | TokRParen 12 | | TokIdent String 13 | | TokNum Double 14 | | TokEnd 15 | deriving (Show, Eq) 16 | 17 | lookAhead :: [Token] -> Token 18 | lookAhead [] = TokEnd 19 | lookAhead (t:ts) = t 20 | 21 | accept :: [Token] -> [Token] 22 | accept [] = error "Nothing to accept" 23 | accept (t:ts) = ts 24 | 25 | tokenize :: String -> [Token] 26 | tokenize [] = [] 27 | tokenize (c : cs) 28 | | elem c "+-*/" = TokOp (operator c) : tokenize cs 29 | | c == '=' = TokAssign : tokenize cs 30 | | c == '(' = TokLParen : tokenize cs 31 | | c == ')' = TokRParen : tokenize cs 32 | | isDigit c = number c cs 33 | | isAlpha c = identifier c cs 34 | | isSpace c = tokenize cs 35 | | otherwise = error $ "Cannot tokenize " ++ [c] 36 | 37 | identifier :: Char -> String -> [Token] 38 | identifier c cs = let (name, cs') = span isAlphaNum cs in 39 | TokIdent (c:name) : tokenize cs' 40 | 41 | number :: Char -> String -> [Token] 42 | number c cs = 43 | let (digs, cs') = span isDigit cs in 44 | TokNum (read (c : digs)) : tokenize cs' 45 | 46 | operator :: Char -> Operator 47 | operator c | c == '+' = Plus 48 | | c == '-' = Minus 49 | | c == '*' = Times 50 | | c == '/' = Div 51 | -------------------------------------------------------------------------------- /09-evaluator/evaluate2/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Map as M 4 | import Lexer (tokenize) 5 | import Parser (parse) 6 | import Evaluator (evaluate) 7 | 8 | main = do 9 | loop (M.fromList [("pi", pi), ("e", exp 1.0)]) 10 | 11 | loop symTab = do 12 | str <- getLine 13 | if null str 14 | then 15 | return () 16 | else 17 | let toks = tokenize str 18 | tree = parse toks 19 | (val, symTab') = evaluate tree symTab 20 | in do 21 | print val 22 | loop symTab' 23 | -------------------------------------------------------------------------------- /09-evaluator/evaluate2/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser (Tree(..), parse) where 2 | 3 | import Lexer 4 | 5 | data Tree = SumNode Operator Tree Tree 6 | | ProdNode Operator Tree Tree 7 | | AssignNode String Tree 8 | | UnaryNode Operator Tree 9 | | NumNode Double 10 | | VarNode String 11 | deriving Show 12 | 13 | parse :: [Token] -> Tree 14 | parse toks = let (tree, toks') = expression toks 15 | in 16 | if null toks' 17 | then tree 18 | else error $ "Leftover tokens: " ++ show toks' 19 | 20 | expression :: [Token] -> (Tree, [Token]) 21 | expression toks = 22 | let (termTree, toks') = term toks 23 | in 24 | case lookAhead toks' of 25 | (TokOp op) | elem op [Plus, Minus] -> 26 | let (exTree, toks'') = expression (accept toks') 27 | in (SumNode op termTree exTree, toks'') 28 | TokAssign -> 29 | case termTree of 30 | VarNode str -> 31 | let (exTree, toks'') = expression (accept toks') 32 | in (AssignNode str exTree, toks'') 33 | _ -> error "Only variables can be assigned to" 34 | _ -> (termTree, toks') 35 | 36 | term :: [Token] -> (Tree, [Token]) 37 | term toks = 38 | let (facTree, toks') = factor toks 39 | in 40 | case lookAhead toks' of 41 | (TokOp op) | elem op [Times, Div] -> 42 | let (termTree, toks'') = term (accept toks') 43 | in (ProdNode op facTree termTree, toks'') 44 | _ -> (facTree, toks') 45 | 46 | factor :: [Token] -> (Tree, [Token]) 47 | factor toks = 48 | case lookAhead toks of 49 | (TokNum x) -> (NumNode x, accept toks) 50 | (TokIdent str) -> (VarNode str, accept toks) 51 | (TokOp op) | elem op [Plus, Minus] -> 52 | let (facTree, toks') = factor (accept toks) 53 | in (UnaryNode op facTree, toks') 54 | TokLParen -> 55 | let (expTree, toks') = expression (accept toks) 56 | in 57 | if lookAhead toks' /= TokRParen 58 | then error "Missing right parenthesis" 59 | else (expTree, accept toks') 60 | _ -> error $ "Parse error on token: " ++ show toks 61 | -------------------------------------------------------------------------------- /09-evaluator/moby.txt: -------------------------------------------------------------------------------- 1 | Call me Ishmael. Some years ago - never mind how long precisely - having little 2 | or no money in my purse, and nothing particular to interest me on shore, I thought 3 | I would sail about a little and see the watery part of the world. It is a way 4 | I have of driving off the spleen, and regulating the circulation. Whenever I find 5 | myself growing grim about the mouth; whenever it is a damp, drizzly November 6 | in my soul; whenever I find myself involuntarily pausing before coffin warehouses, 7 | and bringing up the rear of every funeral I meet; and especially whenever 8 | my hypos get such an upper hand of me, that it requires a strong moral principle 9 | to prevent me from deliberately stepping into the street, and methodically 10 | knocking people's hats off - then, I account it high time to get to sea as soon as I can. 11 | -------------------------------------------------------------------------------- /09-evaluator/paren.hs: -------------------------------------------------------------------------------- 1 | -- Implement function paren that takes an expression tree and turns it into a string with fully parenthesized expression. For instance, when acting on testExpr it should produce the string (x = ((2.0 * (y = 5.0)) + 3.0)) 2 | 3 | data Operator = Plus | Minus | Times | Div 4 | deriving (Show, Eq) 5 | 6 | data Tree = SumNode Operator Tree Tree 7 | | ProdNode Operator Tree Tree 8 | | AssignNode String Tree 9 | | UnaryNode Operator Tree 10 | | NumNode Double 11 | | VarNode String 12 | deriving Show 13 | 14 | paren :: Tree -> String 15 | paren (SumNode op left right) = 16 | case op of 17 | Plus -> bin " + " left right 18 | Minus -> bin " - " left right 19 | 20 | paren (ProdNode op left right) = 21 | case op of 22 | Times -> bin " * " left right 23 | Div -> bin " / " left right 24 | 25 | paren (AssignNode var tree) = 26 | let treeS = paren tree 27 | in "(" ++ var ++ " = " ++ treeS ++ ")" 28 | 29 | paren (UnaryNode op tree) = 30 | let treeS = paren tree 31 | opS = case op of 32 | Plus -> " +" 33 | Minus -> " -" 34 | in "(" ++ opS ++ treeS ++ ")" 35 | 36 | paren (NumNode x) = show x 37 | 38 | paren (VarNode var) = var 39 | 40 | bin :: String -> Tree -> Tree -> String 41 | bin op left right = 42 | let leftS = paren left 43 | rightS = paren right 44 | in 45 | "(" ++ leftS ++ op ++ rightS ++ ")" 46 | 47 | -- x = 2 * (y = 5) + 3 48 | testExpr = AssignNode "x" (SumNode Plus 49 | (ProdNode Times 50 | (NumNode 2.0) 51 | (AssignNode "y" (NumNode 5))) 52 | (NumNode 3)) 53 | 54 | main = print $ paren testExpr 55 | 56 | -------------------------------------------------------------------------------- /09-evaluator/translate.hs: -------------------------------------------------------------------------------- 1 | -- Implement function translate, which takes a dictionary and a list of strings and returns a list of translated strigs. If a string is not in a dictionary, it should be replaced with "whatchamacallit". For bonus points, try using the higher order map function from the Prelude, and the where clause. Remember that a function defined inside where has access to the arguments of the outer function. 2 | 3 | import qualified Data.Map as M 4 | 5 | type Dict = M.Map String String 6 | 7 | translate :: Dict -> [String] -> [String] 8 | translate dict words = map trans words 9 | where 10 | trans :: String -> String 11 | trans w = 12 | case M.lookup w dict of 13 | (Just w') -> w' 14 | Nothing -> "whatchamacallit" 15 | 16 | testTranslation :: Dict -> IO () 17 | testTranslation dict = do 18 | print $ translate dict ["where", "is", "the", "colosseum"] 19 | 20 | testInsertion :: Dict -> IO Dict 21 | testInsertion dict = do 22 | return $ M.insert "colosseum" "colosseo" dict 23 | 24 | main = 25 | let dict = M.fromList [("where", "dove"), ("is", "e"), ("the", "il")] 26 | in do 27 | testTranslation dict 28 | dict' <- testInsertion dict 29 | testTranslation dict' 30 | putStrLn "The original dictionary is unchanged:" 31 | testTranslation dict 32 | -------------------------------------------------------------------------------- /09-evaluator/words.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Map as M 2 | import Data.Char (toLower) 3 | import Data.List (sortBy) 4 | 5 | type Index = M.Map String Int 6 | 7 | indexWords :: Index -> [String] -> Index 8 | indexWords index = 9 | foldl acc index 10 | where 11 | acc :: Index -> String -> Index 12 | acc ind word = 13 | let n = M.findWithDefault 0 word ind in 14 | M.insert word (n + 1) ind 15 | 16 | splitWords :: String -> [String] 17 | splitWords = words . map (\c -> if elem c ".,;-\n" then ' ' else toLower c) 18 | 19 | mostFrequent :: [String] -> [(String, Int)] 20 | mostFrequent wrds = 21 | let index = indexWords M.empty wrds 22 | in take 9 (sortBy cmpFreq (M.toList index)) 23 | where 24 | cmpFreq :: (String, Int) -> (String, Int) -> Ordering 25 | cmpFreq (w1, n1) (w2, n2) = compare n2 n1 26 | 27 | main = do 28 | text <- readFile "moby.txt" 29 | print $ mostFrequent (splitWords text) 30 | -------------------------------------------------------------------------------- /10-error-handling/evaluate3.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import qualified Data.Map as M 3 | 4 | data Operator = Plus | Minus | Times | Div 5 | deriving (Show, Eq) 6 | 7 | data Token = TokOp Operator 8 | | TokAssign 9 | | TokLParen 10 | | TokRParen 11 | | TokIdent String 12 | | TokNum Double 13 | | TokEnd 14 | deriving (Show, Eq) 15 | 16 | operator :: Char -> Operator 17 | operator c | c == '+' = Plus 18 | | c == '-' = Minus 19 | | c == '*' = Times 20 | | c == '/' = Div 21 | 22 | tokenize :: String -> [Token] 23 | tokenize [] = [] 24 | tokenize (c : cs) 25 | | elem c "+-*/" = TokOp (operator c) : tokenize cs 26 | | c == '=' = TokAssign : tokenize cs 27 | | c == '(' = TokLParen : tokenize cs 28 | | c == ')' = TokRParen : tokenize cs 29 | | isDigit c = number c cs 30 | | isAlpha c = identifier c cs 31 | | isSpace c = tokenize cs 32 | | otherwise = error $ "Cannot tokenize " ++ [c] 33 | 34 | identifier :: Char -> String -> [Token] 35 | identifier c cs = let (name, cs') = span isAlphaNum cs in 36 | TokIdent (c:name) : tokenize cs' 37 | 38 | number :: Char -> String -> [Token] 39 | number c cs = 40 | let (digs, cs') = span isDigit cs in 41 | TokNum (read (c : digs)) : tokenize cs' 42 | 43 | ---- parser ---- 44 | 45 | data Tree = SumNode Operator Tree Tree 46 | | ProdNode Operator Tree Tree 47 | | AssignNode String Tree 48 | | UnaryNode Operator Tree 49 | | NumNode Double 50 | | VarNode String 51 | deriving Show 52 | 53 | lookAhead :: [Token] -> Token 54 | lookAhead [] = TokEnd 55 | lookAhead (t:ts) = t 56 | 57 | accept :: [Token] -> [Token] 58 | accept [] = error "Nothing to accept" 59 | accept (t:ts) = ts 60 | 61 | expression :: [Token] -> (Tree, [Token]) 62 | expression toks = 63 | let (termTree, toks') = term toks 64 | in 65 | case lookAhead toks' of 66 | (TokOp op) | elem op [Plus, Minus] -> 67 | let (exTree, toks'') = expression (accept toks') 68 | in (SumNode op termTree exTree, toks'') 69 | TokAssign -> 70 | case termTree of 71 | VarNode str -> 72 | let (exTree, toks'') = expression (accept toks') 73 | in (AssignNode str exTree, toks'') 74 | _ -> error "Only variables can be assigned to" 75 | _ -> (termTree, toks') 76 | 77 | term :: [Token] -> (Tree, [Token]) 78 | term toks = 79 | let (facTree, toks') = factor toks 80 | in 81 | case lookAhead toks' of 82 | (TokOp op) | elem op [Times, Div] -> 83 | let (termTree, toks'') = term (accept toks') 84 | in (ProdNode op facTree termTree, toks'') 85 | _ -> (facTree, toks') 86 | 87 | factor :: [Token] -> (Tree, [Token]) 88 | factor toks = 89 | case lookAhead toks of 90 | (TokNum x) -> (NumNode x, accept toks) 91 | (TokIdent str) -> (VarNode str, accept toks) 92 | (TokOp op) | elem op [Plus, Minus] -> 93 | let (facTree, toks') = factor (accept toks) 94 | in (UnaryNode op facTree, toks') 95 | TokLParen -> 96 | let (expTree, toks') = expression (accept toks) 97 | in 98 | if lookAhead toks' /= TokRParen 99 | then error "Missing right parenthesis" 100 | else (expTree, accept toks') 101 | _ -> error $ "Parse error on token: " ++ show toks 102 | 103 | parse :: [Token] -> Tree 104 | parse toks = let (tree, toks') = expression toks 105 | in 106 | if null toks' 107 | then tree 108 | else error $ "Leftover tokens: " ++ show toks' 109 | 110 | ---- evaluator ---- 111 | -- show 112 | 113 | type SymTab = M.Map String Double 114 | 115 | lookUp :: String -> SymTab -> Either String (Double, SymTab) 116 | lookUp str symTab = 117 | case M.lookup str symTab of 118 | Just v -> Right (v, symTab) 119 | Nothing -> Left ("Undefined variable " ++ str) 120 | 121 | addSymbol :: String -> Double -> SymTab -> Either String ((), SymTab) 122 | addSymbol str val symTab = 123 | let symTab' = M.insert str val symTab 124 | in Right ((), symTab') 125 | 126 | evaluate :: Tree -> SymTab -> Either String (Double, SymTab) 127 | 128 | evaluate (SumNode op left right) symTab = 129 | case evaluate left symTab of 130 | Left msg -> Left msg 131 | Right (lft, symTab') -> 132 | case evaluate right symTab' of 133 | Left msg -> Left msg 134 | Right (rgt, symTab'') -> 135 | case op of 136 | Plus -> Right (lft + rgt, symTab'') 137 | Minus -> Right (lft - rgt, symTab'') 138 | 139 | evaluate (ProdNode op left right) symTab = 140 | case evaluate left symTab of 141 | Left msg -> Left msg 142 | Right (lft, symTab') -> 143 | case evaluate right symTab' of 144 | Left msg -> Left msg 145 | Right (rgt, symTab'') -> 146 | case op of 147 | Times -> Right (lft * rgt, symTab) 148 | Div -> Right (lft / rgt, symTab) 149 | 150 | evaluate (UnaryNode op tree) symTab = 151 | case evaluate tree symTab of 152 | Left msg -> Left msg 153 | Right (x, symTab') -> 154 | case op of 155 | Plus -> Right ( x, symTab') 156 | Minus -> Right (-x, symTab') 157 | 158 | evaluate (NumNode x) symTab = Right (x, symTab) 159 | 160 | evaluate (VarNode str) symTab = lookUp str symTab 161 | 162 | evaluate (AssignNode str tree) symTab = 163 | case evaluate tree symTab of 164 | Left msg -> Left msg 165 | Right (v, symTab') -> 166 | case addSymbol str v symTab' of 167 | Left msg -> Left msg 168 | Right (_, symTab'') -> Right (v, symTab'') 169 | 170 | main = do 171 | loop (M.fromList [("pi", pi)]) 172 | 173 | loop symTab = do 174 | str <- getLine 175 | if null str 176 | then 177 | return () 178 | else 179 | let toks = tokenize str 180 | tree = parse toks 181 | in 182 | case evaluate tree symTab of 183 | Left msg -> do 184 | putStrLn $ "Error: " ++ msg 185 | loop symTab -- use old symTab 186 | Right (v, symTab') -> do 187 | print v 188 | loop symTab' 189 | -------------------------------------------------------------------------------- /10-error-handling/evaluate4/Evaluator.hs: -------------------------------------------------------------------------------- 1 | module Evaluator (evaluate, Evaluator(..)) where 2 | 3 | import Lexer 4 | import Parser 5 | import qualified Data.Map as M 6 | 7 | import Control.Applicative 8 | import Control.Monad (liftM, ap) 9 | 10 | newtype Evaluator a = Ev (Either String a) 11 | 12 | instance Functor Evaluator where 13 | fmap = liftM 14 | 15 | instance Applicative Evaluator where 16 | pure = return 17 | (<*>) = ap 18 | 19 | instance Monad Evaluator where 20 | (Ev ev) >>= k = 21 | case ev of 22 | Left msg -> Ev (Left msg) 23 | Right v -> k v 24 | return v = Ev (Right v) 25 | fail msg = Ev (Left msg) 26 | 27 | type SymTab = M.Map String Double 28 | 29 | evaluate :: Tree -> SymTab -> Evaluator (Double, SymTab) 30 | 31 | evaluate (SumNode op left right) symTab = do 32 | (lft, symTab') <- evaluate left symTab 33 | (rgt, symTab'') <- evaluate right symTab' 34 | case op of 35 | Plus -> return (lft + rgt, symTab'') 36 | Minus -> return (lft - rgt, symTab'') 37 | 38 | evaluate (ProdNode op left right) symTab = do 39 | (lft, symTab') <- evaluate left symTab 40 | (rgt, symTab'') <- evaluate right symTab' 41 | case op of 42 | Times -> return (lft * rgt, symTab) 43 | Div -> return (lft / rgt, symTab) 44 | 45 | evaluate (UnaryNode op tree) symTab = do 46 | (x, symTab') <- evaluate tree symTab 47 | case op of 48 | Plus -> return ( x, symTab') 49 | Minus -> return (-x, symTab') 50 | 51 | evaluate (NumNode x) symTab = return (x, symTab) 52 | 53 | evaluate (VarNode str) symTab = lookUp str symTab 54 | 55 | evaluate (AssignNode str tree) symTab = do 56 | (v, symTab') <- evaluate tree symTab 57 | (_, symTab'') <- addSymbol str v symTab' 58 | return (v, symTab'') 59 | 60 | lookUp :: String -> SymTab -> Evaluator (Double, SymTab) 61 | lookUp str symTab = 62 | case M.lookup str symTab of 63 | Just v -> return (v, symTab) 64 | Nothing -> fail ("Undefined variable " ++ str) 65 | 66 | addSymbol :: String -> Double -> SymTab -> Evaluator ((), SymTab) 67 | addSymbol str val symTab = 68 | let symTab' = M.insert str val symTab 69 | in return ((), symTab') 70 | -------------------------------------------------------------------------------- /10-error-handling/evaluate4/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lexer (Operator(..), Token(..), tokenize, lookAhead, accept) where 2 | 3 | import Data.Char 4 | 5 | data Operator = Plus | Minus | Times | Div 6 | deriving (Show, Eq) 7 | 8 | data Token = TokOp Operator 9 | | TokAssign 10 | | TokLParen 11 | | TokRParen 12 | | TokIdent String 13 | | TokNum Double 14 | | TokEnd 15 | deriving (Show, Eq) 16 | 17 | lookAhead :: [Token] -> Token 18 | lookAhead [] = TokEnd 19 | lookAhead (t:ts) = t 20 | 21 | accept :: [Token] -> [Token] 22 | accept [] = error "Nothing to accept" 23 | accept (t:ts) = ts 24 | 25 | tokenize :: String -> [Token] 26 | tokenize [] = [] 27 | tokenize (c : cs) 28 | | elem c "+-*/" = TokOp (operator c) : tokenize cs 29 | | c == '=' = TokAssign : tokenize cs 30 | | c == '(' = TokLParen : tokenize cs 31 | | c == ')' = TokRParen : tokenize cs 32 | | isDigit c = number c cs 33 | | isAlpha c = identifier c cs 34 | | isSpace c = tokenize cs 35 | | otherwise = error $ "Cannot tokenize " ++ [c] 36 | 37 | identifier :: Char -> String -> [Token] 38 | identifier c cs = let (name, cs') = span isAlphaNum cs in 39 | TokIdent (c:name) : tokenize cs' 40 | 41 | number :: Char -> String -> [Token] 42 | number c cs = 43 | let (digs, cs') = span isDigit cs in 44 | TokNum (read (c : digs)) : tokenize cs' 45 | 46 | operator :: Char -> Operator 47 | operator c | c == '+' = Plus 48 | | c == '-' = Minus 49 | | c == '*' = Times 50 | | c == '/' = Div 51 | -------------------------------------------------------------------------------- /10-error-handling/evaluate4/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Map as M 4 | import Lexer (tokenize) 5 | import Parser (parse) 6 | import Evaluator 7 | 8 | main = do 9 | loop (M.fromList [("pi", pi), ("e", exp 1.0)]) 10 | 11 | loop symTab = do 12 | str <- getLine 13 | if null str 14 | then 15 | return () 16 | else 17 | let toks = tokenize str 18 | tree = parse toks 19 | Ev ev = evaluate tree symTab 20 | in 21 | case ev of 22 | Left msg -> do 23 | putStrLn $ "Error: " ++ msg 24 | loop symTab -- use old symTab 25 | Right (v, symTab') -> do 26 | print v 27 | loop symTab' 28 | -------------------------------------------------------------------------------- /10-error-handling/evaluate4/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser (Tree(..), parse) where 2 | 3 | import Lexer 4 | 5 | data Tree = SumNode Operator Tree Tree 6 | | ProdNode Operator Tree Tree 7 | | AssignNode String Tree 8 | | UnaryNode Operator Tree 9 | | NumNode Double 10 | | VarNode String 11 | deriving Show 12 | 13 | parse :: [Token] -> Tree 14 | parse toks = let (tree, toks') = expression toks 15 | in 16 | if null toks' 17 | then tree 18 | else error $ "Leftover tokens: " ++ show toks' 19 | 20 | expression :: [Token] -> (Tree, [Token]) 21 | expression toks = 22 | let (termTree, toks') = term toks 23 | in 24 | case lookAhead toks' of 25 | (TokOp op) | elem op [Plus, Minus] -> 26 | let (exTree, toks'') = expression (accept toks') 27 | in (SumNode op termTree exTree, toks'') 28 | TokAssign -> 29 | case termTree of 30 | VarNode str -> 31 | let (exTree, toks'') = expression (accept toks') 32 | in (AssignNode str exTree, toks'') 33 | _ -> error "Only variables can be assigned to" 34 | _ -> (termTree, toks') 35 | 36 | term :: [Token] -> (Tree, [Token]) 37 | term toks = 38 | let (facTree, toks') = factor toks 39 | in 40 | case lookAhead toks' of 41 | (TokOp op) | elem op [Times, Div] -> 42 | let (termTree, toks'') = term (accept toks') 43 | in (ProdNode op facTree termTree, toks'') 44 | _ -> (facTree, toks') 45 | 46 | factor :: [Token] -> (Tree, [Token]) 47 | factor toks = 48 | case lookAhead toks of 49 | (TokNum x) -> (NumNode x, accept toks) 50 | (TokIdent str) -> (VarNode str, accept toks) 51 | (TokOp op) | elem op [Plus, Minus] -> 52 | let (facTree, toks') = factor (accept toks) 53 | in (UnaryNode op facTree, toks') 54 | TokLParen -> 55 | let (expTree, toks') = expression (accept toks) 56 | in 57 | if lookAhead toks' /= TokRParen 58 | then error "Missing right parenthesis" 59 | else (expTree, accept toks') 60 | _ -> error $ "Parse error on token: " ++ show toks 61 | -------------------------------------------------------------------------------- /10-error-handling/expression_problem.hs: -------------------------------------------------------------------------------- 1 | class Expr a 2 | 3 | data Const = Const Double 4 | data Add a b = Add a b 5 | 6 | instance Expr Const 7 | instance (Expr a, Expr b) => Expr (Add a b) 8 | 9 | class (Expr e) => Valuable e where 10 | evaluate :: e -> Double 11 | 12 | instance Valuable Const where 13 | evaluate (Const x) = x 14 | instance (Valuable a, Valuable b) => Valuable (Add a b) where 15 | evaluate (Add lft rgt) = evaluate lft + evaluate rgt 16 | 17 | -- client code 18 | 19 | data Mul a b = Mul a b 20 | 21 | instance (Expr a, Expr b) => Expr (Mul a b) 22 | instance (Valuable a, Valuable b) => Valuable (Mul a b) where 23 | evaluate (Mul lft rgt) = evaluate lft * evaluate rgt 24 | 25 | class (Expr e) => Pretty e where 26 | pretty :: e -> String 27 | 28 | instance Pretty Const where 29 | pretty (Const x) = show x 30 | instance (Pretty a, Pretty b) => Pretty (Add a b) where 31 | pretty (Add x y) = "(" ++ pretty x ++ " + " ++ pretty y ++ ")" 32 | instance (Pretty a, Pretty b) => Pretty (Mul a b) where 33 | pretty (Mul x y) = pretty x ++ " * " ++ pretty y 34 | 35 | expr = Mul (Const 2) (Add (Const 1.5) (Const 2.5)) 36 | 37 | main = do 38 | putStrLn $ pretty expr 39 | print $ evaluate expr 40 | -------------------------------------------------------------------------------- /10-error-handling/pawn.hs: -------------------------------------------------------------------------------- 1 | -- Ex 4 This is an example that mimics elements of OO programming. Chess pieces are implemented as separate data types: here, for simplicity, just one, Pawn. The constructor of Pawn takes the Color of the piece and its position on the board (0-7 in both dimensions). Pieces are instances of the class Piece, which declares the following functions: color, pos, and moves. The moves function takes a piece and returns a list of possible future positions after one move (without regard to other pieces, but respecting the boundaries of the board). Define both the typeclass and the instance, so that the following program works. 2 | 3 | data Color = White | Black 4 | deriving (Show, Eq) 5 | 6 | data Pawn = Pawn Color (Int, Int) 7 | 8 | class Piece a where 9 | color :: a -> Color 10 | pos :: a -> (Int, Int) 11 | moves :: a -> [(Int, Int)] 12 | 13 | instance Piece Pawn where 14 | color (Pawn c _) = c 15 | pos (Pawn _ pos) = pos 16 | moves pwn = if color pwn == White 17 | then mvs (pos pwn) 18 | else map refl (mvs $ refl (pos pwn)) 19 | where 20 | refl (x, y) = (x, 7 - y) 21 | mvs (x, y) = if y == 1 22 | then [(x, y + 1), (x, y + 2)] 23 | else if y == 7 24 | then [] 25 | else [(x, y + 1)] 26 | pieces = [Pawn White (3, 1), Pawn Black (4, 1), Pawn White (0, 7), Pawn Black (5, 0)] 27 | main = do 28 | print $ map moves pieces 29 | -------------------------------------------------------------------------------- /10-error-handling/show.hs: -------------------------------------------------------------------------------- 1 | -- Ex 3. Instead of deriving Show, define explicit instances of the Show typeclass for Operator and Tree such that expr is displayed as: 2 | -- 3 | -- x = (13.0 - 1.0) / y 4 | -- It's enough that you provide the implementation of the show function in the instance declaration. This function should take an Operator (or a Tree) and return a string. 5 | 6 | data Operator = Plus | Minus | Times | Div 7 | 8 | data Tree = SumNode Operator Tree Tree 9 | | ProdNode Operator Tree Tree 10 | | AssignNode String Tree 11 | | UnaryNode Operator Tree 12 | | NumNode Double 13 | | VarNode String 14 | 15 | instance Show Operator where 16 | show Plus = " + " 17 | show Minus = " - " 18 | show Times = " * " 19 | show Div = " / " 20 | 21 | instance Show Tree where 22 | show (SumNode op lft rgt) = "(" ++ show lft ++ show op ++ show rgt ++ ")" 23 | show (ProdNode op lft rgt) = show lft ++ show op ++ show rgt 24 | show (AssignNode str tree) = str ++ " = " ++ show tree 25 | show (UnaryNode op tree) = show op ++ show tree 26 | show (NumNode x) = show x 27 | show (VarNode str) = str 28 | 29 | expr = AssignNode "x" (ProdNode Div (SumNode Minus (NumNode 13) (NumNode 1)) (VarNode "y")) 30 | 31 | main = print expr 32 | -------------------------------------------------------------------------------- /10-error-handling/trace.hs: -------------------------------------------------------------------------------- 1 | -- Ex 2. Define a monad instance for Trace (no need to override fail). The idea is to create a trace of execution by sprinkling you code with calls to put. The result of executing this code should look something like this: 2 | -- 3 | -- ["fact 3","fact 2","fact 1","fact 0"] 4 | -- 6 5 | -- Hint: List concatenation is done using ++ (we've seen it used for string concatenation, because String is just a list of Char). 6 | 7 | import Control.Applicative 8 | import Control.Monad (liftM, ap) 9 | 10 | newtype Trace a = Trace ([String], a) 11 | 12 | instance Functor Trace where 13 | fmap = liftM 14 | 15 | instance Applicative Trace where 16 | pure = return 17 | (<*>) = ap 18 | 19 | instance Monad Trace where 20 | return x = Trace ([], x) 21 | (Trace (lst, x)) >>= k = 22 | let Trace (lst', y) = k x 23 | in Trace (lst ++ lst', y) 24 | 25 | put :: Show a => String -> a -> Trace () 26 | put msg v = Trace ([msg ++ " " ++ show v], ()) 27 | 28 | fact :: Integer -> Trace Integer 29 | fact n = do 30 | put "fact" n 31 | if n == 0 32 | then return 1 33 | else do 34 | m <- fact (n - 1) 35 | return (n * m) 36 | 37 | main = let Trace (lst, m) = fact 3 38 | in do 39 | print lst 40 | print m 41 | -------------------------------------------------------------------------------- /10-error-handling/type_classes.hs: -------------------------------------------------------------------------------- 1 | class Valuable a where 2 | evaluate :: a -> Double 3 | 4 | data Expr = Const Double | Add Expr Expr 5 | 6 | instance Valuable Expr where 7 | evaluate (Const x) = x 8 | evaluate (Add lft rgt) = evaluate lft + evaluate rgt 9 | 10 | instance Valuable Bool where 11 | evaluate True = 1 12 | evaluate False = 0 13 | 14 | test :: Valuable a => a -> IO () 15 | test v = print $ evaluate v 16 | 17 | expr :: Expr 18 | expr = Add (Const 2) (Add (Const 1.5) (Const 2.5)) 19 | 20 | main = do 21 | test expr 22 | test True 23 | test False 24 | 25 | -------------------------------------------------------------------------------- /10-error-handling/whynot.hs: -------------------------------------------------------------------------------- 1 | -- Ex 1. Define the whynot monad 2 | 3 | import Control.Applicative 4 | import Control.Monad (liftM, ap) 5 | 6 | instance Functor WhyNot where 7 | fmap = liftM 8 | 9 | instance Applicative WhyNot where 10 | pure = return 11 | (<*>) = ap 12 | 13 | data WhyNot a = Nah | Sure a 14 | deriving Show 15 | 16 | instance Monad WhyNot where 17 | Sure x >>= k = k x 18 | Nah >>= _ = Nah 19 | return x = Sure x 20 | fail _ = Nah 21 | 22 | safeRoot :: Double -> WhyNot Double 23 | safeRoot x = 24 | if x >= 0 then 25 | return (sqrt x) 26 | else 27 | fail "Boo!" 28 | 29 | test :: Double -> WhyNot Double 30 | test x = do 31 | y <- safeRoot x 32 | z <- safeRoot (y - 4) 33 | w <- safeRoot z 34 | return w 35 | 36 | 37 | main = do 38 | print $ test 9 39 | print $ test 400 40 | -------------------------------------------------------------------------------- /11-state-monad/bindS.hs: -------------------------------------------------------------------------------- 1 | data Operator = Plus | Minus 2 | data Tree = UnaryNode Operator Tree 3 | type SymTab = () 4 | -- show 5 | type Evaluator a = SymTab -> (a, SymTab) 6 | 7 | returnS :: a -> Evaluator a 8 | returnS x = \symTab -> (x, symTab) 9 | 10 | bindS :: Evaluator a 11 | -> (a -> Evaluator b) 12 | -> Evaluator b 13 | bindS act k = 14 | \symTab -> 15 | let (x, symTab') = act symTab 16 | act' = k x 17 | in 18 | act' symTab' 19 | 20 | evaluate :: Tree -> (SymTab -> (Double, SymTab)) 21 | evaluate (UnaryNode op tree) = 22 | bindS (evaluate tree) 23 | (\x -> case op of 24 | Plus -> returnS x 25 | Minus -> returnS (-x)) 26 | 27 | main = putStrLn "It type checks!" 28 | -------------------------------------------------------------------------------- /11-state-monad/evaluate5.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import qualified Data.Map as M 3 | 4 | import Control.Applicative 5 | import Control.Monad (liftM, ap) 6 | 7 | data Operator = Plus | Minus | Times | Div 8 | deriving (Show, Eq) 9 | 10 | data Token = TokOp Operator 11 | | TokAssign 12 | | TokLParen 13 | | TokRParen 14 | | TokIdent String 15 | | TokNum Double 16 | | TokEnd 17 | deriving (Show, Eq) 18 | 19 | operator :: Char -> Operator 20 | operator c | c == '+' = Plus 21 | | c == '-' = Minus 22 | | c == '*' = Times 23 | | c == '/' = Div 24 | 25 | tokenize :: String -> [Token] 26 | tokenize [] = [] 27 | tokenize (c : cs) 28 | | elem c "+-*/" = TokOp (operator c) : tokenize cs 29 | | c == '=' = TokAssign : tokenize cs 30 | | c == '(' = TokLParen : tokenize cs 31 | | c == ')' = TokRParen : tokenize cs 32 | | isDigit c = number c cs 33 | | isAlpha c = identifier c cs 34 | | isSpace c = tokenize cs 35 | | otherwise = error $ "Cannot tokenize " ++ [c] 36 | 37 | identifier :: Char -> String -> [Token] 38 | identifier c cs = let (name, cs') = span isAlphaNum cs in 39 | TokIdent (c:name) : tokenize cs' 40 | 41 | number :: Char -> String -> [Token] 42 | number c cs = 43 | let (digs, cs') = span isDigit cs in 44 | TokNum (read (c : digs)) : tokenize cs' 45 | 46 | ---- parser ---- 47 | 48 | data Tree = SumNode Operator Tree Tree 49 | | ProdNode Operator Tree Tree 50 | | AssignNode String Tree 51 | | UnaryNode Operator Tree 52 | | NumNode Double 53 | | VarNode String 54 | deriving Show 55 | 56 | lookAhead :: [Token] -> Token 57 | lookAhead [] = TokEnd 58 | lookAhead (t:ts) = t 59 | 60 | accept :: [Token] -> [Token] 61 | accept [] = error "Nothing to accept" 62 | accept (t:ts) = ts 63 | 64 | expression :: [Token] -> (Tree, [Token]) 65 | expression toks = 66 | let (termTree, toks') = term toks 67 | in 68 | case lookAhead toks' of 69 | (TokOp op) | elem op [Plus, Minus] -> 70 | let (exTree, toks'') = expression (accept toks') 71 | in (SumNode op termTree exTree, toks'') 72 | TokAssign -> 73 | case termTree of 74 | VarNode str -> 75 | let (exTree, toks'') = expression (accept toks') 76 | in (AssignNode str exTree, toks'') 77 | _ -> error "Only variables can be assigned to" 78 | _ -> (termTree, toks') 79 | 80 | term :: [Token] -> (Tree, [Token]) 81 | term toks = 82 | let (facTree, toks') = factor toks 83 | in 84 | case lookAhead toks' of 85 | (TokOp op) | elem op [Times, Div] -> 86 | let (termTree, toks'') = term (accept toks') 87 | in (ProdNode op facTree termTree, toks'') 88 | _ -> (facTree, toks') 89 | 90 | factor :: [Token] -> (Tree, [Token]) 91 | factor toks = 92 | case lookAhead toks of 93 | (TokNum x) -> (NumNode x, accept toks) 94 | (TokIdent str) -> (VarNode str, accept toks) 95 | (TokOp op) | elem op [Plus, Minus] -> 96 | let (facTree, toks') = factor (accept toks) 97 | in (UnaryNode op facTree, toks') 98 | TokLParen -> 99 | let (expTree, toks') = expression (accept toks) 100 | in 101 | if lookAhead toks' /= TokRParen 102 | then error "Missing right parenthesis" 103 | else (expTree, accept toks') 104 | _ -> error $ "Parse error on token: " ++ show toks 105 | 106 | parse :: [Token] -> Tree 107 | parse toks = let (tree, toks') = expression toks 108 | in 109 | if null toks' 110 | then tree 111 | else error $ "Leftover tokens: " ++ show toks' 112 | 113 | ---- evaluator ---- 114 | -- show 115 | 116 | type SymTab = M.Map String Double 117 | 118 | newtype Evaluator a = Ev (SymTab -> (a, SymTab)) 119 | 120 | instance Functor Evaluator where 121 | fmap = liftM 122 | 123 | instance Applicative Evaluator where 124 | pure = return 125 | (<*>) = ap 126 | 127 | instance Monad Evaluator where 128 | (Ev act) >>= k = Ev $ 129 | \symTab -> 130 | let (x, symTab') = act symTab 131 | (Ev act') = k x 132 | in act' symTab' 133 | return x = Ev (\symTab -> (x, symTab)) 134 | 135 | lookUp :: String -> Evaluator Double 136 | lookUp str = Ev $ \symTab -> 137 | case M.lookup str symTab of 138 | Just v -> (v, symTab) 139 | Nothing -> error $ "Undefined variable " ++ str 140 | 141 | addSymbol :: String -> Double -> Evaluator Double 142 | addSymbol str val = Ev $ \symTab -> 143 | let symTab' = M.insert str val symTab 144 | in (val, symTab') 145 | 146 | evaluate :: Tree -> Evaluator Double 147 | 148 | evaluate (SumNode op left right) = do 149 | lft <- evaluate left 150 | rgt <- evaluate right 151 | case op of 152 | Plus -> return $ lft + rgt 153 | Minus -> return $ lft - rgt 154 | 155 | evaluate (ProdNode op left right) = do 156 | lft <- evaluate left 157 | rgt <- evaluate right 158 | case op of 159 | Times -> return $ lft * rgt 160 | Div -> return $ lft / rgt 161 | 162 | evaluate (UnaryNode op tree) = do 163 | x <- evaluate tree 164 | case op of 165 | Plus -> return x 166 | Minus -> return (-x) 167 | 168 | evaluate (NumNode x) = return x 169 | 170 | evaluate (VarNode str) = lookUp str 171 | 172 | evaluate (AssignNode str tree) = do 173 | v <- evaluate tree 174 | addSymbol str v 175 | 176 | main = do 177 | loop (M.fromList [("pi", pi)]) 178 | 179 | loop symTab = do 180 | str <- getLine 181 | if null str 182 | then 183 | return () 184 | else 185 | let toks = tokenize str 186 | tree = parse toks 187 | Ev act = evaluate tree 188 | (val, symTab') = act symTab 189 | in do 190 | print val 191 | loop symTab' 192 | -------------------------------------------------------------------------------- /11-state-monad/reader.hs: -------------------------------------------------------------------------------- 1 | -- Ex 1. Define the reader monad. It's supposed to model computations that have access to some read-only environment. In imperative code such environment is often implemented as a global object. In functional languages we need to pass it as an argument to every function that might potentially need access to it. The reader monad hides this process. 2 | 3 | import Control.Applicative 4 | import Control.Monad (liftM, ap) 5 | 6 | instance Functor (Reader e) where 7 | fmap = liftM 8 | 9 | instance Applicative (Reader e) where 10 | pure = return 11 | (<*>) = ap 12 | 13 | newtype Reader e a = Reader (e -> a) 14 | 15 | reader :: (e -> a) -> Reader e a 16 | reader f = Reader f 17 | 18 | runReader :: Reader e a -> e -> a 19 | runReader (Reader act) env = act env 20 | 21 | ask :: Reader e e 22 | ask = reader (\e -> e) 23 | 24 | instance Monad (Reader e) where 25 | return x = reader (\_ -> x) 26 | rd >>= k = reader $ \env -> 27 | let x = runReader rd env 28 | act' = k x 29 | in runReader act' env 30 | 31 | type Env = Reader String 32 | -- curried version of 33 | -- type Env a = Reader String a 34 | 35 | test :: Env Int 36 | test = do 37 | s <- ask 38 | return $ read s + 5 39 | 40 | main = print $ runReader test "13" 41 | -------------------------------------------------------------------------------- /11-state-monad/state.hs: -------------------------------------------------------------------------------- 1 | -- Ex 2. Use the State monad from Control.Monad.State to re-implement the evaluator. 2 | 3 | import Data.Char 4 | import qualified Data.Map as M 5 | import Control.Monad.State 6 | 7 | data Operator = Plus | Minus | Times | Div 8 | deriving (Show, Eq) 9 | 10 | data Tree = SumNode Operator Tree Tree 11 | | ProdNode Operator Tree Tree 12 | | AssignNode String Tree 13 | | UnaryNode Operator Tree 14 | | NumNode Double 15 | | VarNode String 16 | deriving Show 17 | 18 | type SymTab = M.Map String Double 19 | 20 | type Evaluator a = State SymTab a 21 | 22 | lookUp :: String -> Evaluator Double 23 | lookUp str = do 24 | symTab <- get 25 | case M.lookup str symTab of 26 | Just v -> return v 27 | Nothing -> error $ "Undefined variable " ++ str 28 | 29 | addSymbol :: String -> Double -> Evaluator () 30 | addSymbol str val = do 31 | symTab <- get 32 | put $ M.insert str val symTab 33 | return () 34 | 35 | evaluate :: Tree -> Evaluator Double 36 | 37 | evaluate (SumNode op left right) = do 38 | lft <- evaluate left 39 | rgt <- evaluate right 40 | case op of 41 | Plus -> return $ lft + rgt 42 | Minus -> return $ lft - rgt 43 | 44 | evaluate (ProdNode op left right) = do 45 | lft <- evaluate left 46 | rgt <- evaluate right 47 | case op of 48 | Times -> return $ lft * rgt 49 | Div -> return $ lft / rgt 50 | 51 | evaluate (UnaryNode op tree) = do 52 | x <- evaluate tree 53 | case op of 54 | Plus -> return x 55 | Minus -> return (-x) 56 | 57 | evaluate (NumNode x) = return x 58 | 59 | evaluate (VarNode str) = lookUp str 60 | 61 | evaluate (AssignNode str tree) = do 62 | v <- evaluate tree 63 | addSymbol str v 64 | return v 65 | 66 | expr = AssignNode "x" (ProdNode Times (VarNode "pi") 67 | (ProdNode Times (NumNode 4) (NumNode 6))) 68 | 69 | main = print $ runState (evaluate expr) (M.fromList [("pi", pi)]) 70 | -------------------------------------------------------------------------------- /12-the-list-monad/ex1.hs: -------------------------------------------------------------------------------- 1 | -- Ex 1. Define join for Maybe (don't be surprised how simple it is): 2 | 3 | join :: Maybe (Maybe a) -> Maybe a 4 | join Nothing = Nothing 5 | join (Just mb) = mb 6 | 7 | test1, test2, test3 :: Maybe (Maybe String) 8 | test1 = Nothing 9 | test2 = Just Nothing 10 | test3 = Just (Just "a little something") 11 | 12 | main = do 13 | print $ join test1 14 | print $ join test2 15 | print $ join test3 16 | -------------------------------------------------------------------------------- /12-the-list-monad/ex2.hs: -------------------------------------------------------------------------------- 1 | -- Ex 2. Define functions listBind and listReturn for regular lists in a way analogous to >>= and return for our private lists (again, it's pretty simple): 2 | 3 | import Data.Char 4 | 5 | listBind :: [a] -> (a -> [b]) -> [b] 6 | listBind xs k = concat (map k xs) 7 | 8 | listReturn :: a -> [a] 9 | listReturn x = [x] 10 | 11 | neighbors x = [x - 1, x, x + 1] 12 | 13 | main = do 14 | print $ listBind [10, 20, 30] neighbors 15 | print $ listBind "string" (listReturn . ord) 16 | -------------------------------------------------------------------------------- /12-the-list-monad/ex3.hs: -------------------------------------------------------------------------------- 1 | -- Ex 3. Implement the other fish operator that composes from left to right: 2 | 3 | (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) 4 | f >=> g = \x -> f x >>= g 5 | 6 | f x = [x, x + 1] 7 | g x = [x * x] 8 | 9 | test1 = f >=> g 10 | test2 = f >=> g >=> g 11 | test3 = g >=> f >=> f 12 | 13 | main = do 14 | print $ test1 3 15 | print $ test2 3 16 | print $ test3 3 17 | -------------------------------------------------------------------------------- /12-the-list-monad/ex4.hs: -------------------------------------------------------------------------------- 1 | -- Ex 4. Express the fish operator for standard lists considering the non-deterministic function interpretation (the solution is totally unsurprising) 2 | 3 | import Data.Char 4 | 5 | (>=>) :: (a -> [b]) -> (b -> [c]) -> (a -> [c]) 6 | f >=> g = \x -> concat (map g (f x)) 7 | 8 | modCase c = [toLower c, toUpper c] 9 | camelize = modCase >=> modCase 10 | 11 | main = print $ fmap camelize "Hump" 12 | -------------------------------------------------------------------------------- /12-the-list-monad/ex5.hs: -------------------------------------------------------------------------------- 1 | -- Ex 5. Each card in a deck has a rank between 1 (Ace) and 13 (King) and a Suit (Club, Diamond, Heart, Spade). Write a list comprehension that generates all cards in a deck. Hint: You can encode suit as an enumeration deriving Show and Enum. The Enum type class will let you create ranges like [Club .. Spade] (put space before .. or the parser will be confused). 2 | 3 | data Suit = Club | Diamond | Heart | Spade 4 | deriving (Show, Enum) 5 | 6 | data Rank = Rank Int 7 | 8 | instance Show Rank where 9 | show (Rank 1) = "Ace" 10 | show (Rank 11) = "Jack" 11 | show (Rank 12) = "Queen" 12 | show (Rank 13) = "King" 13 | show (Rank i) = show i 14 | 15 | deck = [(Rank r, s) | s <- [Club .. Spade] 16 | , r <- [1..13]] 17 | 18 | main = print deck 19 | -------------------------------------------------------------------------------- /12-the-list-monad/kleisli.hs: -------------------------------------------------------------------------------- 1 | (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) 2 | g <=< f = \x -> f x >>= g 3 | 4 | f x = [x, x + 1] 5 | g x = [x * x] 6 | 7 | test = g <=< f 8 | 9 | main = print $ test 7 10 | -------------------------------------------------------------------------------- /12-the-list-monad/list_monad.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | import Control.Monad (liftM, ap) 3 | 4 | data List a = Nil | Cons a (List a) 5 | 6 | instance (Show a) => Show (List a) where 7 | show Nil = "" 8 | show (Cons x xs) = show x ++ ", " ++ show xs 9 | 10 | instance Functor List where 11 | fmap f Nil = Nil 12 | fmap f (Cons x xs) = Cons (f x) (fmap f xs) 13 | 14 | instance Applicative List where 15 | pure = return 16 | (<*>) = ap 17 | 18 | instance Monad List where 19 | return x = Cons x Nil 20 | xs >>= k = join $ fmap k xs 21 | 22 | join :: List (List a) -> List a 23 | join Nil = Nil 24 | join (Cons xs xss) = cat xs (join xss) 25 | 26 | cat :: List a -> List a -> List a 27 | cat Nil ys = ys 28 | cat (Cons x xs) ys = Cons x (cat xs ys) 29 | 30 | neighbors :: (Num a) => a -> a -> List a 31 | neighbors x dx = Cons (x - dx) (Cons x (Cons (x + dx) Nil)) 32 | 33 | 34 | test = do 35 | x <- neighbors 0 100 36 | y <- neighbors x 1 37 | return y 38 | 39 | main = print $ test 40 | -------------------------------------------------------------------------------- /12-the-list-monad/list_pairs.hs: -------------------------------------------------------------------------------- 1 | pairs l1 l2 = do 2 | x <- l1 3 | y <- l2 4 | return (x, y) 5 | 6 | main = do 7 | print $ pairs [1, 2, 3] "abc" 8 | print $ [(x, y) | x <- [1..3], y <- "abc"] 9 | 10 | -------------------------------------------------------------------------------- /12-the-list-monad/list_squares.hs: -------------------------------------------------------------------------------- 1 | squares lst = do 2 | x <- lst 3 | return (x * x) 4 | 5 | squares2 lst = lst >>= \x -> return (x * x) 6 | 7 | squares3 lst = 8 | concat $ fmap k lst 9 | where 10 | k = \x -> [x * x] 11 | 12 | squares4 = fmap sq 13 | where sq x = x * x 14 | 15 | main = do 16 | print $ squares [1, 2, 3] 17 | print $ squares2 [1, 2, 3] 18 | print $ squares3 [1, 2, 3] 19 | print $ squares4 [1, 2, 3] 20 | -------------------------------------------------------------------------------- /12-the-list-monad/quicksort.hs: -------------------------------------------------------------------------------- 1 | f [] = [] 2 | f (p:xs) = f [x | x <- xs, x < p] 3 | ++ [p] 4 | ++ f [x | x <- xs, x >= p] 5 | 6 | main = print $ f [2, 5, 1, 3, 4] 7 | -------------------------------------------------------------------------------- /12-the-list-monad/triples.hs: -------------------------------------------------------------------------------- 1 | triples = 2 | [(x, y, z) | z <- [1..] 3 | , x <- [1..z] 4 | , y <- [x..z] 5 | , x * x + y * y == z * z] 6 | 7 | main = print $ take 4 triples 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # bartosz-basics-of-haskell 2 | Code and exercises from Bartosz Milewski's Basics of Haskell [Tutorial] 3 | 4 | ## run 5 | 6 | ```shell 7 | $ ghc --version 8 | The Glorious Glasgow Haskell Compilation System, version 8.0.2 9 | 10 | $ ghc sq1.hs 11 | [1 of 1] Compiling Main ( sq1.hs, sq1.o ) 12 | Linking sq1 ... 13 | 14 | $ ./sq1 15 | 10 16 | ``` 17 | 18 | [Tutorial]: https://www.schoolofhaskell.com/user/bartosz/basics-of-haskell 19 | -------------------------------------------------------------------------------- /evaluate6.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import qualified Data.Map as M 3 | 4 | import Control.Applicative 5 | import Control.Monad (liftM, ap) 6 | 7 | data Operator = Plus | Minus | Times | Div 8 | deriving (Show, Eq) 9 | 10 | data Token = TokOp Operator 11 | | TokAssign 12 | | TokLParen 13 | | TokRParen 14 | | TokIdent String 15 | | TokNum Double 16 | | TokEnd 17 | deriving (Show, Eq) 18 | 19 | operator :: Char -> Operator 20 | operator c | c == '+' = Plus 21 | | c == '-' = Minus 22 | | c == '*' = Times 23 | | c == '/' = Div 24 | 25 | tokenize [] = [] 26 | tokenize (c : cs) 27 | | elem c "+-*/" = TokOp (operator c) : tokenize cs 28 | | c == '=' = TokAssign : tokenize cs 29 | | c == '(' = TokLParen : tokenize cs 30 | | c == ')' = TokRParen : tokenize cs 31 | | isDigit c = number c cs 32 | | isAlpha c = identifier c cs 33 | | isSpace c = tokenize cs 34 | | otherwise = error $ "Cannot tokenize " ++ [c] 35 | 36 | identifier :: Char -> String -> [Token] 37 | identifier c cs = let (name, cs') = span isAlphaNum cs in 38 | TokIdent (c:name) : tokenize cs' 39 | 40 | number :: Char -> String -> [Token] 41 | number c cs = 42 | let (digs, cs') = span isDigit cs in 43 | TokNum (read (c : digs)) : tokenize cs' 44 | 45 | ---- parser ---- 46 | -- show 47 | data Tree = SumNode Operator Tree Tree 48 | | ProdNode Operator Tree Tree 49 | | AssignNode String Tree 50 | | UnaryNode Operator Tree 51 | | NumNode Double 52 | | VarNode String 53 | deriving Show 54 | 55 | newtype Parser a = P ([Token] -> Either String (a, [Token])) 56 | 57 | instance Functor Parser where 58 | fmap = liftM 59 | 60 | instance Applicative Parser where 61 | pure = return 62 | (<*>) = ap 63 | 64 | instance Monad Parser where 65 | (P act) >>= k = P $ 66 | \toks -> 67 | case act toks of 68 | Left str -> Left str 69 | Right (x, toks') -> 70 | let P act' = k x 71 | in act' toks' 72 | return x = P (\toks -> Right (x, toks)) 73 | fail str = P (\_ -> Left str) 74 | 75 | lookAhead :: Parser Token 76 | lookAhead = P $ \toks -> 77 | case toks of 78 | [] -> Right (TokEnd, []) 79 | (t:ts) -> Right (t, t:ts) 80 | 81 | accept :: Parser () 82 | accept = P $ \toks -> 83 | case toks of 84 | [] -> Left "Nothing to accept" 85 | (t:ts) -> Right ((), ts) 86 | 87 | expression :: Parser Tree 88 | expression = do 89 | termTree <- term 90 | tok <- lookAhead 91 | case tok of 92 | (TokOp op) | elem op [Plus, Minus] -> do 93 | accept 94 | exTree <- expression 95 | return $ SumNode op termTree exTree 96 | TokAssign -> 97 | case termTree of 98 | VarNode str -> do 99 | accept 100 | exTree <- expression 101 | return $ AssignNode str exTree 102 | _ -> fail "Only variables can be assigned to" 103 | _ -> return termTree 104 | 105 | term :: Parser Tree 106 | term = do 107 | facTree <- factor 108 | tok <- lookAhead 109 | case tok of 110 | (TokOp op) | elem op [Times, Div] -> do 111 | accept 112 | termTree <- term 113 | return $ ProdNode op facTree termTree 114 | _ -> return facTree 115 | 116 | factor :: Parser Tree 117 | factor = do 118 | tok <- lookAhead 119 | case tok of 120 | (TokNum x) -> do 121 | accept 122 | return $ NumNode x 123 | (TokIdent str) -> do 124 | accept 125 | return $ VarNode str 126 | (TokOp op) | elem op [Plus, Minus] -> do 127 | accept 128 | facTree <- factor 129 | return $ UnaryNode op facTree 130 | TokLParen -> do 131 | accept 132 | expTree <- expression 133 | tok' <- lookAhead 134 | if tok' /= TokRParen 135 | then fail "Missing right parenthesis" 136 | else do 137 | accept 138 | return expTree 139 | _ -> fail $ "Token: " ++ show tok 140 | 141 | parse :: [Token] -> Either String Tree 142 | parse toks = 143 | let P act = expression 144 | result = act toks 145 | in 146 | case result of 147 | Left msg -> Left msg 148 | Right (tree, toks') -> 149 | if null toks' 150 | then Right tree 151 | else Left $ "Leftover tokens: " ++ show toks' 152 | -- /show 153 | ---- evaluator ---- 154 | 155 | type SymTab = M.Map String Double 156 | 157 | newtype Evaluator a = Ev (SymTab -> Either String (a, SymTab)) 158 | 159 | instance Functor Evaluator where 160 | fmap = liftM 161 | 162 | instance Applicative Evaluator where 163 | pure = return 164 | (<*>) = ap 165 | 166 | -- k : a -> Ev (SymTab -> Either String (b, SymTab)) 167 | instance Monad Evaluator where 168 | (Ev act) >>= k = Ev $ 169 | \symTab -> 170 | case act symTab of 171 | Left str -> Left str 172 | Right (x, symTab') -> 173 | let Ev act' = k x 174 | in act' symTab' 175 | return x = Ev (\symTab -> Right (x, symTab)) 176 | fail str = Ev (\_ -> Left str) 177 | 178 | lookUp :: String -> Evaluator Double 179 | lookUp str = Ev $ \symTab -> 180 | case M.lookup str symTab of 181 | Just v -> Right (v, symTab) 182 | Nothing -> Left $ "Undefined variable: " ++ str 183 | 184 | addSymbol :: String -> Double -> Evaluator Double 185 | addSymbol str val = Ev $ \symTab -> 186 | let symTab' = M.insert str val symTab 187 | in Right (val, symTab') 188 | 189 | evaluate :: Tree -> Evaluator Double 190 | 191 | evaluate (SumNode op left right) = do 192 | lft <- evaluate left 193 | rgt <- evaluate right 194 | case op of 195 | Plus -> return $ lft + rgt 196 | Minus -> return $ lft - rgt 197 | 198 | evaluate (ProdNode op left right) = do 199 | lft <- evaluate left 200 | rgt <- evaluate right 201 | case op of 202 | Times -> return $ lft * rgt 203 | Div -> return $ lft / rgt 204 | 205 | evaluate (UnaryNode op tree) = do 206 | x <- evaluate tree 207 | case op of 208 | Plus -> return x 209 | Minus -> return (-x) 210 | 211 | evaluate (NumNode x) = return x 212 | 213 | evaluate (VarNode str) = lookUp str 214 | 215 | evaluate (AssignNode str tree) = do 216 | v <- evaluate tree 217 | addSymbol str v 218 | -- show 219 | main = do 220 | loop (M.fromList [("pi", pi)]) 221 | -- /show 222 | loop symTab = do 223 | str <- getLine 224 | if null str 225 | then 226 | return () 227 | else 228 | let toks = tokenize str 229 | eTree = parse toks 230 | in 231 | case eTree of 232 | Left msg -> do 233 | print $ "Parse error: " ++ msg 234 | loop symTab 235 | Right tree -> 236 | let Ev act = evaluate tree 237 | in 238 | case act symTab of 239 | Left str -> do 240 | putStrLn $ "Error: " ++ str 241 | loop symTab 242 | Right (val, symTab') -> do 243 | print val 244 | loop symTab' 245 | --------------------------------------------------------------------------------