├── .gitignore ├── LICENSE ├── README.md ├── homework-01 ├── CreditCard.hs ├── Hanoi.hs ├── README.md └── assignment.pdf ├── homework-02 ├── Log.hs ├── LogAnalysis.hs ├── README.md ├── assignment.pdf ├── error.log └── sample.log ├── homework-03 ├── Golf.hs ├── README.md └── assignment.pdf ├── homework-04 ├── HigherOrder.hs ├── README.md └── assignment.pdf ├── homework-05 ├── Calc.hs ├── ExprT.hs ├── Parser.hs ├── README.md ├── StackVM.hs └── assignment.pdf ├── homework-06 ├── Fibonacci.hs ├── README.md └── assignment.pdf ├── homework-07 ├── Buffer.hs ├── Editor.hs ├── JoinList.hs ├── README.md ├── Scrabble.hs ├── Sized.hs ├── StringBufEditor.hs ├── StringBuffer.hs ├── assignment.pdf └── carol.txt ├── homework-08 ├── Employee.hs ├── Party.hs ├── README.md ├── assignment.pdf └── company.txt ├── homework-09 ├── README.md └── assignment.pdf ├── homework-10 ├── AParser.hs ├── README.md └── assignment.pdf ├── homework-11 ├── AParser.hs ├── README.md ├── SExpr.hs └── assignment.pdf └── homework-12 ├── README.md ├── Risk.hs └── assignment.pdf /.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 | .HTF/ 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Octavi Pascual 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CIS 194: Introduction to Haskell (Spring 2013) 2 | 3 | In order to learn Haskell I took the [CIS 194: Introduction to Haskell (Spring 2013) 4 | ](http://www.seas.upenn.edu/~cis194/spring13) course. 5 | 6 | This repository contains the solutions of each assignment of the course. 7 | 8 | Apart from the material of the course, I also checked the following materials: 9 | * [Real World Haskell](http://book.realworldhaskell.org) 10 | * [Introduction to Functional Programming - TU Delft - edX](https://www.edx.org/course/introduction-functional-programming-delftx-fp101x-0) 11 | * [Learn You a Haskell for Great Good!](http://learnyouahaskell.com) 12 | 13 | In addition, since I took the course in an autonomous way, I used some resources to check whether my solutions were correct or not. I always try to solve the problems on my own and I only may take a look if I am really stuck with an exercise. However, when I have already solved the whole assignment, I like to see in detail how others solved it and that makes me learn a lot! 14 | * [bschwb cis194-solutions repository](https://github.com/bschwb/cis194-solutions) 15 | * [baugarten CIS-194 repository](https://github.com/baugarten/CIS-194) 16 | * [surganov cis914 repository](https://github.com/surganov/cis194) 17 | 18 | Finally, I tried to explain how I solved each exercise of the homework to remember how I came to the final solution. Moreover, it may also help the reader to understand the reasoning behind each solution. 19 | 20 | ## [Homework 1: Introduction to Haskell](homework-01) 21 | 22 | ## [Homework 2: Algebraic Data Types](homework-02) 23 | 24 | ## [Homework 3: Recursion patterns, polymorphism, and the Prelude](homework-03) 25 | 26 | ## [Homework 4: Higher-order programming and type inference](homework-04) 27 | 28 | ## [Homework 5: More polymorphism and type classes](homework-05) 29 | 30 | ## [Homework 6: Lazy evaluation](homework-06) 31 | 32 | ## [Homework 7: Folds and monoids](homework-07) 33 | 34 | ## [Homework 8: IO](homework-08) 35 | 36 | ## [Homework 9: Functors](homework-09) 37 | 38 | ## [Homework 10: Applicative Functors (part 1)](homework-10) 39 | 40 | ## [Homework 11: Applicative Functors (part 2)](homework-11) 41 | 42 | ## [Homework 12: Monads](homework-12) 43 | -------------------------------------------------------------------------------- /homework-01/CreditCard.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | 4 | module CreditCard where 5 | 6 | ---------------------------------- Exercise 1 ---------------------------------- 7 | 8 | -- Convert an integer to a list of digits 9 | toDigits:: Integer -> [Integer] 10 | toDigits n 11 | | n <= 0 = [] 12 | | otherwise = toDigits (n `div` 10) ++ [n `mod` 10] 13 | 14 | -- Same as toDigits but with the digits reversed 15 | toDigitsRev :: Integer -> [Integer] 16 | toDigitsRev n 17 | | n <= 0 = [] 18 | | otherwise = n `mod` 10 : toDigitsRev (n `div` 10) 19 | 20 | 21 | toDigitsTest :: Bool 22 | toDigitsTest = and 23 | [ 24 | [1] == toDigits 1, 25 | [1, 2, 3, 4] == toDigits 1234, 26 | [] == toDigits 0, 27 | [] == toDigits (-17) 28 | ] 29 | 30 | toDigitsRevTest :: Bool 31 | toDigitsRevTest = and 32 | [ 33 | [1] == toDigitsRev 1, 34 | [4, 3, 2, 1] == toDigitsRev 1234, 35 | [] == toDigitsRev 0, 36 | [] == toDigitsRev (-17) 37 | ] 38 | 39 | 40 | ---------------------------------- Exercise 2 ---------------------------------- 41 | 42 | -- Double every other number beginning from the right 43 | doubleEveryOther :: [Integer] -> [Integer] 44 | doubleEveryOther = reverse . zipWith (*) (cycle [1,2]) . reverse 45 | 46 | 47 | doubleEveryOtherTest :: Bool 48 | doubleEveryOtherTest = and 49 | [ 50 | [5] == doubleEveryOther [5], 51 | [10, 5] == doubleEveryOther [5, 5], 52 | [1, 4, 3] == doubleEveryOther [1, 2, 3], 53 | [16, 7, 12, 5] == doubleEveryOther [8, 7, 6, 5] 54 | ] 55 | 56 | 57 | ---------------------------------- Exercise 3 ---------------------------------- 58 | 59 | -- Returns the sum of all digits of each number of the list 60 | sumDigits :: [Integer] -> Integer 61 | sumDigits = sum . concat . map toDigits 62 | 63 | 64 | sumDigitsTest :: Bool 65 | sumDigitsTest = and 66 | [ 67 | 5 == sumDigits [5], 68 | 10 == sumDigits [5, 5], 69 | 22 == sumDigits [16, 7, 12, 5] 70 | ] 71 | 72 | 73 | ---------------------------------- Exercise 4 ---------------------------------- 74 | 75 | -- Indicates whether or not a credit card number is valid 76 | validate :: Integer -> Bool 77 | validate x = (sumDigits . doubleEveryOther . toDigits $ x) `mod` 10 == 0 78 | 79 | 80 | validateTest :: Bool 81 | validateTest = and 82 | [ 83 | True == validate 4012888888881881, 84 | False == validate 4012888888881882 85 | ] 86 | -------------------------------------------------------------------------------- /homework-01/Hanoi.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | 4 | module Hanoi where 5 | 6 | 7 | type Peg = String 8 | type Move = (Peg, Peg) 9 | 10 | 11 | ---------------------------------- Exercise 5 ---------------------------------- 12 | 13 | -- Return the list of moves to be performed to move n discs from the source 14 | -- peg to the destination peg using one auxiliary peg: 15 | -- 1. move n−1 discs from src to aux using dst as temporary storage 16 | -- 2. move the top disc from src to dst 17 | -- 3. move n−1 discs from aux to dst using src as temporary storage 18 | hanoi :: Integer -> Peg -> Peg -> Peg -> [Move] 19 | hanoi 0 _ _ _ = [] 20 | hanoi n src dst aux = 21 | moveFromSrcToAux ++ moveFromSrcToDst ++ moveFromAuxToDst 22 | where 23 | moveFromSrcToAux = hanoi (n-1) src aux dst 24 | moveFromSrcToDst = [(src, dst)] 25 | moveFromAuxToDst = hanoi (n-1) aux dst src 26 | 27 | hanoiTest :: Bool 28 | hanoiTest = and 29 | [ 30 | [("a","c"), ("a","b"), ("c","b")] == hanoi 2 "a" "b" "c", 31 | 32767 == (length $ hanoi 15 "a" "b" "c") 32 | ] 33 | 34 | 35 | ---------------------------------- Exercise 6 ---------------------------------- 36 | 37 | -- Return the list of moves to be performed to move n discs from the source 38 | -- peg to the destination peg using two auxiliary pegs. 39 | -- We use the Frame-Stewart algorithm: 40 | -- 1. for some k (1 <= k < n), move k discs from src to aux1 41 | -- 2. move the remaining n-k discs from src to dst without using aux1 42 | -- 3. move k discs from aux1 to dst 43 | -- It has been proved that for 4 pegs, the value of k that minimizes 44 | -- the number of moves is the one that we have used here. 45 | -- https://en.wikipedia.org/wiki/Tower_of_Hanoi#Frame%E2%80%93Stewart_algorithm 46 | hanoi4 :: Integer -> Peg -> Peg -> Peg -> Peg -> [Move] 47 | hanoi4 0 _ _ _ _ = [] 48 | hanoi4 n src dst aux1 aux2 = 49 | moveFromSrcToAux1 ++ moveFromSrcToDst ++ moveFromAux1ToDst 50 | where 51 | moveFromSrcToAux1 = hanoi4 k src aux1 aux2 dst 52 | moveFromSrcToDst = hanoi (n-k) src dst aux2 53 | moveFromAux1ToDst = hanoi4 k aux1 dst aux2 src 54 | n' = fromIntegral n :: Double 55 | k = n - round (sqrt (2*n' + 1)) + 1 56 | 57 | hanoi4Test :: Bool 58 | hanoi4Test = and 59 | [ 60 | [("a","c"), ("a","b"), ("c","b")] == hanoi4 2 "a" "b" "c" "d", 61 | 129 == (length $ hanoi4 15 "a" "b" "c" "d"), 62 | 289 == (length $ hanoi4 20 "a" "b" "c" "d") 63 | ] 64 | -------------------------------------------------------------------------------- /homework-01/README.md: -------------------------------------------------------------------------------- 1 | # Homework 1 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [CreditCard.hs (file to submit)](CreditCard.hs) 6 | * [Hanoi.hs (file to submit)](Hanoi.hs) 7 | 8 | ## Exercise 1 9 | 10 | The function `toDigits :: Integer -> [Integer]` converts a positive integer to a list of digits. If the integer is less or equal than 0, it should return the empty list. We can use guards to check whether the integer is positive or not. If the integer `n` is positive, we can easily access its last digit using ``n `mod` 10``. To maintain the digits in order, we must concatenate that digit to the right of ``toDigits (n `div` 10)``. This recursive call returns the list of digits of the number without its last digit. Note that we will eventually hit the case `n <= 0` as an integer has a finite amount of digits. 11 | 12 | ```haskell 13 | toDigits:: Integer -> [Integer] 14 | toDigits n 15 | | n <= 0 = [] 16 | | otherwise = toDigits (n `div` 10) ++ [n `mod` 10] 17 | ``` 18 | 19 | The function `toDigitsRev :: Integer -> [Integer]` does exactly the same as `toDigits` except that the digits are reversed. A trivial solution would be to call the `toDigits` function and then reverse its result. However, implementing `toDigitsRev` from scratch is also easy. The only difference with the previous function is that instead of concatenating the last digit to the right, we use the cons `:` operator to prepend the element: 20 | 21 | ```haskell 22 | toDigitsRev :: Integer -> [Integer] 23 | toDigitsRev n 24 | | n <= 0 = [] 25 | | otherwise = n `mod` 10 : toDigitsRev (n `div` 10) 26 | ``` 27 | 28 | ## Exercise 2 29 | 30 | The function `doubleEveryOther :: [Integer] -> [Integer]` doubles every other number beginning from the right. For example, `doubleEveryOther [8,7,6,5]` must double the second-to-last and fourth-to-last numbers and return `[16,7,12,5]`. 31 | 32 | My first implementation was the following: 33 | 34 | ```haskell 35 | doubleEveryOther :: [Integer] -> [Integer] 36 | doubleEveryOther [] = [] 37 | doubleEveryOther (x:[]) = [x] 38 | doubleEveryOther (x:y:zs) | even (length zs) = 2*x : y : doubleEveryOther zs 39 | doubleEveryOther (x:y:zs) = x : 2*y : doubleEveryOther zs 40 | ``` 41 | 42 | This implementation is pretty verbose as it matches four patterns. Since I am taking the first two elements of the list, depending on whether the length of the list is even or not I might end with zero or one element. Moreover, I also have to check the length of the list in the recursive cases. 43 | 44 | I realised there is a much cleaner solution. The complexity of this function is that we must begin from the right, and in Haskell we usually traverse lists from left to right. Thus, what if we reverse the list? If we reverse the list, we just have to double every other number beginning from the left. Then we can use the `zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]` function which takes a function and two lists and applies that function to each pair generated by zipping `[a]` and `[b]`. The list `[a]` will be the original list reversed, while `[b]` will be `cycle [1,2]`. That way, every second element will be doubled, provided that we use `(*)` as function in `zipWith`. 45 | 46 | ```haskell 47 | doubleEveryOther :: [Integer] -> [Integer] 48 | doubleEveryOther xs = reverse $ zipWith (*) (cycle [1,2]) (reverse xs) 49 | ``` 50 | 51 | An better version where we directly return a function: 52 | 53 | ```haskell 54 | doubleEveryOther :: [Integer] -> [Integer] 55 | doubleEveryOther = reverse . zipWith (*) (cycle [1,2]) . reverse 56 | ``` 57 | 58 | ## Exercise 3 59 | 60 | The function `sumDigits :: [Integer] -> Integer` returns the sum of all digits of each number of the list. For that, we must apply the function `toDigits` to each number of the list: 61 | 62 | ```haskell 63 | sumDigits :: [Integer] -> Integer 64 | sumDigits [] = 0 65 | sumDigits (x:xs) = sum (toDigits x) + sumDigits xs 66 | ``` 67 | 68 | A cleaner solution, without using explicit recursion and using `concat :: [[a]] -> [a]` is: 69 | 70 | ```haskell 71 | sumDigits :: [Integer] -> Integer 72 | sumDigits = sum . concat . map toDigits 73 | ``` 74 | 75 | Note that here the approach varies a bit since we do not sum the digits after the call to `toDigits`, instead we flatten the list of digits and we sum them all at the end. 76 | 77 | ## Exercise 4 78 | 79 | The function `validate :: Integer -> Bool` returns whether or not a credit card number is valid. Here we just had to reuse the functions that were implemented in previous exercises: 80 | 81 | ```haskell 82 | validate :: Integer -> Bool 83 | validate x = (sumDigits . doubleEveryOther . toDigits $ x) `mod` 10 == 0 84 | ``` 85 | 86 | ## Exercise 5 87 | 88 | The [Tower of Hanoi](https://en.wikipedia.org/wiki/Tower_of_Hanoi) is a mathematical puzzle that is usually metioned when introducing recursion. The function `hanoi :: Integer -> Peg -> Peg -> Peg -> [Move]` takes an integer and three pegs and returns the list of moves needed to move the stack of discs from the first peg to the second using one auxiliary peg. 89 | 90 | The problem can be solved as follows: 91 | * move n−1 discs from src to aux using dst as temporary storage 92 | * move the top disc from src to dst 93 | * move n−1 discs from aux to dst using src as temporary storage 94 | 95 | 96 | ```haskell 97 | hanoi :: Integer -> Peg -> Peg -> Peg -> [Move] 98 | hanoi 0 _ _ _ = [] 99 | hanoi n src dst aux = 100 | moveFromSrcToAux ++ moveFromSrcToDst ++ moveFromAuxToDst 101 | where 102 | moveFromSrcToAux = hanoi (n-1) src aux dst 103 | moveFromSrcToDst = [(src, dst)] 104 | moveFromAuxToDst = hanoi (n-1) aux dst src 105 | ``` 106 | 107 | ## Exercise 6 108 | 109 | The final exercise was pretty challenging as it introduced a variant of the previous puzzle. Here, instead of three towers, we have four, that is, we have two auxiliary pegs instead of one. A trivial implementation is to simply ignore one of the two auxiliary pegs and then the solution is exactly the same as the previous one. However, using two auxiliary pegs allows us to go much faster! For example, moving 15 discs with 3 pegs takes 32767 moves while it only takes 129 moves with 4 pegs. 110 | 111 | It turns out that this problem is not trivial at all, I had to research a bit to come up with the solution. After reading some papers about that, I ended up implementing the [Frame-Stewart](https://en.wikipedia.org/wiki/Tower_of_Hanoi#Frame%E2%80%93Stewart_algorithm) algorithm, which ensures that the number of steps is optimum for 4 pegs: 112 | * for some k (1 <= k < n), move k discs from src to aux1 113 | * move the remaining n-k discs from src to dst without using aux1 114 | * move k discs from aux1 to dst 115 | 116 | Note that for this solution we use the `hanoi` function that we implemented in the previous exercise. 117 | 118 | ```haskell 119 | hanoi4 :: Integer -> Peg -> Peg -> Peg -> Peg -> [Move] 120 | hanoi4 0 _ _ _ _ = [] 121 | hanoi4 n src dst aux1 aux2 = 122 | moveFromSrcToAux1 ++ moveFromSrcToDst ++ moveFromAux1ToDst 123 | where 124 | moveFromSrcToAux1 = hanoi4 k src aux1 aux2 dst 125 | moveFromSrcToDst = hanoi (n-k) src dst aux2 126 | moveFromAux1ToDst = hanoi4 k aux1 dst aux2 src 127 | n' = fromIntegral n :: Double 128 | k = n - round (sqrt (2*n' + 1)) + 1 129 | ``` 130 | -------------------------------------------------------------------------------- /homework-01/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-01/assignment.pdf -------------------------------------------------------------------------------- /homework-02/Log.hs: -------------------------------------------------------------------------------- 1 | -- CIS 194 Homework 2 2 | 3 | module Log where 4 | 5 | import Control.Applicative 6 | 7 | data MessageType = Info 8 | | Warning 9 | | Error Int 10 | deriving (Show, Eq) 11 | 12 | type TimeStamp = Int 13 | 14 | data LogMessage = LogMessage MessageType TimeStamp String 15 | | Unknown String 16 | deriving (Show, Eq) 17 | 18 | data MessageTree = Leaf 19 | | Node MessageTree LogMessage MessageTree 20 | deriving (Show, Eq) 21 | 22 | -- | @testParse p n f@ tests the log file parser @p@ by running it 23 | -- on the first @n@ lines of file @f@. 24 | testParse :: (String -> [LogMessage]) 25 | -> Int 26 | -> FilePath 27 | -> IO [LogMessage] 28 | testParse parse n file = take n . parse <$> readFile file 29 | 30 | -- | @testWhatWentWrong p w f@ tests the log file parser @p@ and 31 | -- warning message extractor @w@ by running them on the log file 32 | -- @f@. 33 | testWhatWentWrong :: (String -> [LogMessage]) 34 | -> ([LogMessage] -> [String]) 35 | -> FilePath 36 | -> IO [String] 37 | testWhatWentWrong parse whatWentWrong file 38 | = whatWentWrong . parse <$> readFile file 39 | -------------------------------------------------------------------------------- /homework-02/LogAnalysis.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module LogAnalysis where 4 | 5 | import Log 6 | 7 | 8 | ---------------------------------- Exercise 1 ---------------------------------- 9 | 10 | createInfoMessage :: [String] -> LogMessage 11 | createInfoMessage (timestamp:content) = 12 | LogMessage Info (read timestamp) (unwords content) 13 | createInfoMessage msg = error ("Invalid Info message: " ++ unwords msg) 14 | 15 | createWarningMessage :: [String] -> LogMessage 16 | createWarningMessage (timestamp:content) = 17 | LogMessage Warning (read timestamp) (unwords content) 18 | createWarningMessage msg = error ("Invalid Warning message: " ++ unwords msg) 19 | 20 | createErrorMessage :: [String] -> LogMessage 21 | createErrorMessage (severity:timestamp:content) = 22 | LogMessage (Error (read severity)) (read timestamp) (unwords content) 23 | createErrorMessage msg = error ("Invalid Error message: " ++ unwords msg) 24 | 25 | createUnknownMessage :: [String] -> LogMessage 26 | createUnknownMessage message = Unknown (unwords message) 27 | 28 | -- Parse an individual message from the log file 29 | parseMessage :: String -> LogMessage 30 | parseMessage ('I':message) = createInfoMessage $ words $ message 31 | parseMessage ('W':message) = createWarningMessage $ words $ message 32 | parseMessage ('E':message) = createErrorMessage $ words $ message 33 | parseMessage message = createUnknownMessage $ words $ message 34 | 35 | parseMessageTest :: Bool 36 | parseMessageTest = and 37 | [ 38 | LogMessage Info 29 "la la la" == parseMessage "I 29 la la la", 39 | LogMessage Warning 19 "le le le" == parseMessage "W 19 le le le", 40 | LogMessage (Error 2) 562 "help help" == parseMessage "E 2 562 help help", 41 | Unknown "Not in the right format" == parseMessage "Not in the right format" 42 | ] 43 | 44 | -- Parse a whole log file 45 | parse :: String -> [LogMessage] 46 | parse file = parseMessage <$> lines file 47 | 48 | 49 | ---------------------------------- Exercise 2 ---------------------------------- 50 | 51 | -- Insert a new LogMessage into an existing MessageTree 52 | insert :: LogMessage -> MessageTree -> MessageTree 53 | insert (Unknown _) tree = tree 54 | insert msg Leaf = Node Leaf msg Leaf 55 | insert msg@(LogMessage _ ts1 _) (Node left msg2@(LogMessage _ ts2 _) right) 56 | | ts1 < ts2 = Node (insert msg left) msg2 right 57 | | otherwise = Node left msg2 (insert msg right) 58 | insert _ (Node _ (Unknown _) _) = 59 | error "Unknown messages are not allowed in MessageTree" 60 | 61 | insertTest :: Bool 62 | insertTest = and 63 | [ 64 | Node Leaf info Leaf == insert info Leaf, 65 | Node Leaf info (Node Leaf warning Leaf) == insert warning infoTree, 66 | Node (Node Leaf info Leaf) warning Leaf == insert info warningTree 67 | ] 68 | where info = LogMessage Info 30 "doesn't matter" 69 | infoTree = Node Leaf info Leaf 70 | warning = LogMessage Warning 50 "doesn't matter" 71 | warningTree = Node Leaf warning Leaf 72 | 73 | 74 | ---------------------------------- Exercise 3 ---------------------------------- 75 | 76 | -- Build a complete MessageTree from a list of LogMessage 77 | -- Note that we must use foldr and not foldl due to insert type signature 78 | build :: [LogMessage] -> MessageTree 79 | build = foldr insert Leaf 80 | 81 | buildTest :: Bool 82 | buildTest = and 83 | [ 84 | Node Leaf info Leaf == build [info], 85 | Node (Node Leaf info Leaf) warning Leaf == build [info, warning], 86 | Node Leaf info (Node Leaf warning Leaf) == build [warning, info, unknown] 87 | ] 88 | where info = LogMessage Info 10 "doesn't matter" 89 | warning = LogMessage Warning 20 "doesn't matter" 90 | unknown = Unknown "doesn't matter" 91 | 92 | 93 | ---------------------------------- Exercise 4 ---------------------------------- 94 | 95 | -- Traverses a MessageTree in inorder: 96 | -- 1) Traverse the left subtree 97 | -- 2) Visit the root 98 | -- 3) Traverse the right subtree 99 | inOrder :: MessageTree -> [LogMessage] 100 | inOrder Leaf = [] 101 | inOrder (Node left root right) = (inOrder left) ++ [root] ++ (inOrder right) 102 | 103 | inOrderTest :: Bool 104 | inOrderTest = and 105 | [ 106 | [info] == inOrder (Node Leaf info Leaf), 107 | [info, warning] == inOrder (Node (Node Leaf info Leaf) warning Leaf) 108 | ] 109 | where info = LogMessage Info 10 "doesn't matter" 110 | warning = LogMessage Warning 20 "doesn't matter" 111 | 112 | 113 | ---------------------------------- Exercise 5 ---------------------------------- 114 | 115 | isRelevant :: LogMessage -> Bool 116 | isRelevant (LogMessage (Error severity) _ _) = severity >= 50 117 | isRelevant _ = False 118 | 119 | getContent :: LogMessage -> String 120 | getContent (LogMessage _ _ content) = content 121 | getContent (Unknown content) = content 122 | 123 | -- Return the content of relevant error messages sorted by timestamp 124 | whatWentWrong :: [LogMessage] -> [String] 125 | whatWentWrong xs = getContent <$> filter isRelevant (inOrder . build $ xs) 126 | 127 | whatWentWrongTest :: Bool 128 | whatWentWrongTest = and 129 | [ 130 | [] == whatWentWrong [info, warning, error1], 131 | ["second error"] == whatWentWrong [info, warning, error2], 132 | ["second error", "third error"] == whatWentWrong [error1, error2, error3] 133 | ] 134 | where info = LogMessage Info 10 "doesn't matter" 135 | warning = LogMessage Warning 20 "doesn't matter" 136 | error1 = LogMessage (Error 20) 1 "first error" 137 | error2 = LogMessage (Error 60) 2 "second error" 138 | error3 = LogMessage (Error 80) 3 "third error" 139 | -------------------------------------------------------------------------------- /homework-02/README.md: -------------------------------------------------------------------------------- 1 | # Homework 2 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [Log.hs (provided)](Log.hs) 6 | * [error.log (provided)](error.log) 7 | * [sample.log (provided)](sample.log) 8 | * [LogAnalysis.hs (file to submit)](LogAnalysis.hs) 9 | 10 | ## Exercise 1 11 | 12 | The function `parseMessage :: String -> LogMessage` parses an individual line from the log file. First of all we use pattern matching to figure out what type of log message we are dealing with. Then we simply use the `words :: String -> [String]` function to transform the remaining line into a `[String]`. Finally we use helper functions to pattern match the fields that we need for each type of message. Note that we use `unwords :: [String] -> String` function, which is the inverse of `words`, to get back the content of the message as a `String`. 13 | 14 | ```haskell 15 | parseMessage :: String -> LogMessage 16 | parseMessage ('I':message) = createInfoMessage $ words $ message 17 | parseMessage ('W':message) = createWarningMessage $ words $ message 18 | parseMessage ('E':message) = createErrorMessage $ words $ message 19 | parseMessage message = createUnknownMessage $ words $ message 20 | ``` 21 | 22 | The function `parse :: String -> [LogMessage]` parses the whole log file. To do that we just have to apply the previous `parseMessage` function to each line. The more elegant solution uses the operator `<$>` which is the infix version of `fmap`. 23 | 24 | ```haskell 25 | parse :: String -> [LogMessage] 26 | parse file = parseMessage <$> lines file 27 | ``` 28 | 29 | ## Exercise 2 30 | 31 | The function `insert :: LogMessage -> MessageTree -> MessageTree` inserts a log message into a binary search tree sorted by timestamp. If the message is unknown, it is not stored in the tree. 32 | 33 | ```haskell 34 | insert :: LogMessage -> MessageTree -> MessageTree 35 | insert (Unknown _) tree = tree 36 | insert msg Leaf = Node Leaf msg Leaf 37 | insert msg@(LogMessage _ ts1 _) (Node left msg2@(LogMessage _ ts2 _) right) 38 | | ts1 < ts2 = Node (insert msg left) msg2 right 39 | | otherwise = Node left msg2 (insert msg right) 40 | insert _ (Node _ (Unknown _) _) = 41 | error "Unknown messages are not allowed in MessageTree" 42 | ``` 43 | 44 | At first I thought that with the guard `insert (Unknown _) tree = tree` I had already dealt with unknown messages. Nonetheless, a `-Wincomplete-patterns` warning message appeared. Indeed, the type signature of the `insert` function does not ensure that the tree is free of unknown messages. For example, the following expression is valid `insert (LogMessage Info 30 "doesn't matter") (Node Leaf (Unknown "doesn't matter") Leaf)` and would make the function crash. Since trees with unknown messages can be represented, we must deal with that case. All in all, Haskell did the work for us and found an edge case that we missed! 45 | 46 | ## Exercise 3 47 | 48 | The function `build :: [LogMessage] -> MessageTree` just builds a tree from a list of messages. My first implementation used recursion. 49 | 50 | ```haskell 51 | build :: [LogMessage] -> MessageTree 52 | build [] = Leaf 53 | build (x:xs) = insert x (build xs) 54 | ``` 55 | 56 | However, we can get a more elegant solution using `foldr`. Usually, we can use either `foldr` or `foldl` to avoid recursion on lists. [Here](https://gist.github.com/CMCDragonkai/9f5f75118dda10131764) you can find a more detailed explanation on how they work. In this case we must use `foldr` due to the type signature of the `insert` function. Had it been defined like `insert :: MessageTree -> LogMessage -> MessageTree` and we would have used `foldl`. 57 | 58 | ```haskell 59 | build :: [LogMessage] -> MessageTree 60 | build = foldr insert Leaf 61 | ``` 62 | 63 | Note that `fold` is evaluated from the right to the left, so the first message that will be inserted to the tree is the last one in the list, while the last message to be inserted will be the first in the list. 64 | 65 | ### Exercise 4 66 | 67 | The function `inOrder :: MessageTree -> [LogMessage]` just traverses the tree in inorder. That's pretty simple to do in Haskell! 68 | 69 | ```haskell 70 | inOrder :: MessageTree -> [LogMessage] 71 | inOrder Leaf = [] 72 | inOrder (Node left root right) = (inOrder left) ++ [root] ++ (inOrder right) 73 | ``` 74 | 75 | ### Exercise 5 76 | 77 | The function `whatWentWrong :: [LogMessage] -> [String]` returns a list of the content of the error messages that are relevant, sorted by timestamp. To do that, we build and traverse in inorder the sorted message tree, then we filter the relevant messages. Finally we just get the content of those messages. 78 | 79 | ```haskell 80 | whatWentWrong :: [LogMessage] -> [String] 81 | whatWentWrong xs = getContent <$> filter isRelevant (inOrder . build $ xs) 82 | ``` 83 | -------------------------------------------------------------------------------- /homework-02/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-02/assignment.pdf -------------------------------------------------------------------------------- /homework-02/sample.log: -------------------------------------------------------------------------------- 1 | I 6 Completed armadillo processing 2 | I 1 Nothing to report 3 | I 4 Everything normal 4 | I 11 Initiating self-destruct sequence 5 | E 70 3 Way too many pickles 6 | E 65 8 Bad pickle-flange interaction detected 7 | W 5 Flange is due for a check-up 8 | I 7 Out for lunch, back in two time steps 9 | E 20 2 Too many pickles 10 | I 9 Back from lunch 11 | E 99 10 Flange failed! 12 | -------------------------------------------------------------------------------- /homework-03/Golf.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Golf where 4 | 5 | import Data.List (transpose) 6 | 7 | 8 | ---------------------------------- Exercise 1 ---------------------------------- 9 | 10 | -- Return every n-th element of a list starting at the first element 11 | skipEvery :: Int -> [a] -> [a] 12 | skipEvery _ [] = [] 13 | skipEvery n (x:xs) = x : skipEvery n (drop n xs) 14 | 15 | -- Return every n-th element of a list starting at the n-th element 16 | every :: Int -> [a] -> [a] 17 | every n = skipEvery n . drop n 18 | 19 | -- Return a list of lists where the n-th list in the output contains every 20 | -- n-th element from the input list 21 | -- For example, the second list in the output contains every second element 22 | -- from the input list 23 | skips :: [a] -> [[a]] 24 | skips xs = [every i xs | i <- [0..n]] 25 | where n = length xs - 1 26 | 27 | 28 | skipsTest :: Bool 29 | skipsTest = and 30 | [ 31 | ["ABCD", "BD", "C", "D"] == skips "ABCD", 32 | ["hello!", "el!", "l!", "l", "o", "!"] == skips "hello!", 33 | [[True, False], [False]] == skips [True, False] 34 | ] 35 | 36 | 37 | ---------------------------------- Exercise 2 ---------------------------------- 38 | 39 | -- Return all the local maxima in the input list in order 40 | -- A local maximum of a list is an element of the list which is strictly 41 | -- greater than both the elements immediately before and after it 42 | localMaxima :: [Integer] -> [Integer] 43 | localMaxima l@(x:y:z:_) 44 | | y > x && y > z = y : localMaxima (tail l) 45 | | otherwise = localMaxima $ tail l 46 | localMaxima _ = [] 47 | 48 | 49 | localMaximaTest :: Bool 50 | localMaximaTest = and 51 | [ 52 | [] == localMaxima [1, 2], 53 | [9, 6] == localMaxima [2, 9, 5, 6, 1], 54 | [4] == localMaxima [2, 3, 4, 1, 5], 55 | [] == localMaxima [1, 2, 3, 4, 5] 56 | ] 57 | 58 | 59 | ---------------------------------- Exercise 3 ---------------------------------- 60 | 61 | -- Return the number of occurrences of an element in a list 62 | count :: Eq a => a -> [a] -> Int 63 | count x = length . filter (== x) 64 | 65 | -- Return a string of length maxF having f * 66 | bar :: Int -> Int -> String 67 | bar f maxF = take maxF $ replicate f '*' ++ repeat ' ' 68 | 69 | -- Takes as input a list of integers between 0 and 9 and returns a textual 70 | -- representation of a vertical histogram showing how many of each number 71 | -- were in the input list (use putStr $ histogram [3, 5] to visualize) 72 | histogram :: [Integer] -> String 73 | histogram xs = unlines $ rotate bars ++ legend 74 | where 75 | frequencies = [count i xs | i <- [0..9]] 76 | maxF = maximum frequencies 77 | bars = [bar f maxF | f <- frequencies] 78 | rotate = reverse . transpose 79 | legend = ["==========", "0123456789"] 80 | 81 | 82 | histogramTest :: Bool 83 | histogramTest = and 84 | [ 85 | " * * " ++ legend == h1, 86 | " * \n * \n * * " ++ legend == h2, 87 | " * \n * \n * * \n ****** *" ++ legend == h3 88 | ] 89 | where 90 | h1 = histogram [3, 5] 91 | h2 = histogram [1, 1, 1, 5] 92 | h3 = histogram [1, 4, 5, 4, 6, 6, 3, 4, 2, 4, 9] 93 | legend = "\n==========\n0123456789\n" 94 | -------------------------------------------------------------------------------- /homework-03/README.md: -------------------------------------------------------------------------------- 1 | # Homework 3 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [Golf.hs (file to submit)](Golf.hs) 6 | 7 | ## Exercise 1 8 | 9 | The function `skips :: [a] -> [[a]]` returns a list of lists where the *n*th list in the output contains every n*th* element from the input. 10 | 11 | First we must implement a helper function that, given a list, returns a list of its *n*th elements. This is what `skipEvery :: Int -> [a] -> [a]` does. This function skips every *n*th element of a list starting at the first element. 12 | 13 | ```haskell 14 | skipEvery :: Int -> [a] -> [a] 15 | skipEvery _ [] = [] 16 | skipEvery n (x:xs) = x : skipEvery n (drop n xs) 17 | ``` 18 | 19 | The problem of `skipEvery` is that no matter what the value of n is, it will include the first element of the list. In `skips` we don't start at the begining of the list but at the *n*th element. That's why we have defined `every :: Int -> [a] -> [a]` function that drops the first n elements of the list before calling `skipEvery`. Doing that we start at the *n*th element. We have defined `every` function using [pointfree style](https://wiki.haskell.org/Pointfree). 20 | 21 | ```haskell 22 | every :: Int -> [a] -> [a] 23 | every n = skipEvery n . drop n 24 | ``` 25 | 26 | Once we have `every` function, we just have to call it `n` times with the right parameters, where `n` is the length of the input list. First, we must take every 0 elements, as we want the same list as the input. Second, we want to take every 1 element, and so on. That corresponds to the following calls: `every 0 xs`, `every 1 xs` and so on. To accomplish that we can use `zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]` function. 27 | 28 | ```haskell 29 | skips :: [a] -> [[a]] 30 | skips [] = [] 31 | skips xs = zipWith every [0..n] $ repeat xs 32 | where n = length xs - 1 33 | ``` 34 | 35 | Note that we can use `repeat`, which generates an infinite sequence, since `zipWith` discards elements of the longer list. I think this is more elegant than doing `replicate (length xs) xs`. 36 | 37 | Finally, I realised that there was a much simpler way to implement `skips`. We can use comprehension lists to avoid having to use `zipWith` and replicating the list. 38 | 39 | ```haskell 40 | skips :: [a] -> [[a]] 41 | skips xs = [every i xs | i <- [0..n]] 42 | where n = length xs - 1 43 | ``` 44 | 45 | ## Exercise 2 46 | 47 | The function `localMaxima :: [Integer] -> [Integer]` must return all the local maxima of the input list in the same order as they appear. A *local maximum* of a list is an element of the list which is strictly greater than both the elements immediately before and after it. 48 | 49 | To implement this function we just need to take advantage of pattern matching. We can take the first three elements of the list, named `x`, `y` and `z`, and check whether or not `y` is a local maxmimum. If yes, just prepend this element to the resulting list, which is obtained by calling `localMaxima`recursively. If not, we just call `localMaxima` without prepending any element. 50 | 51 | ```haskell 52 | localMaxima :: [Integer] -> [Integer] 53 | localMaxima l@(x:y:z:_) 54 | | y > x && y > z = y : localMaxima (tail l) 55 | | otherwise = localMaxima $ tail l 56 | localMaxima _ = [] 57 | ``` 58 | 59 | Note that we call `localMaxima` without `x` to avoid infinite recursion and that `tail` will never be called on an empty list `l` as we know that it contains at least two elements, `y` and `z`. 60 | 61 | ## Exercise 3 62 | 63 | The function `histogram :: [Integer] -> String` takes a list of integers between 0 and 9 and outputs a vertical histogram showing how many of each number were in the input list. 64 | 65 | First of all, we need a way of counting how many occurrences of integers between 0 and 9 appear in the list. The function `count :: Eq a => a -> [a] -> Int` does that job. Then we can call this function for each integer: `frequencies = [count i xs | i <- [0..9]]`. 66 | 67 | ```haskell 68 | count :: Eq a => a -> [a] -> Int 69 | count x = length . filter (== x) 70 | ``` 71 | 72 | Once we know the frequency of each number, we must print as many stars as occurrences that number has. Note that when we do not print a star, we must print a blank space. The first problem we encounter is that we must print the stars vertically, so each line must take into account the results of the ten numbers at the same time, which is not very convenient for us. 73 | 74 | For now, let's think of a similar problem that would be easier. Imagine that, instead of printing the histogram vertically, we should print it horizontally. Something like this: 75 | 76 | ```text 77 | 0=** 78 | 1=* 79 | 2=*** 80 | 3= 81 | 4=* 82 | 5= 83 | 6=* 84 | 7=** 85 | 8=** 86 | 9=** 87 | ``` 88 | 89 | It is easy to generate each bar in this case. We just have to print as many stars as occurrences and fill the rest of the bar with blanks, until the bar has the same length as the maximum frequency. In order to generate that bar we use `bar :: Int -> Int -> String` function. 90 | 91 | ```haskell 92 | bar :: Int -> Int -> String 93 | bar f maxF = take maxF $ replicate f '*' ++ repeat ' ' 94 | ``` 95 | 96 | To obtain those bars vertically instead of horizontally, we just have to rotate 90 degrees counterclockwise the horizontal bars. If you aren't convinced, take a look at the following two histograms, where legends have been removed. The second one to corresponds to a 90 degree counterclockwise rotation of the first one. 97 | 98 | ```text 99 | ** 100 | * 101 | *** 102 | 103 | * 104 | 105 | * 106 | ** 107 | ** 108 | ** 109 | ``` 110 | 111 | ```text 112 | * 113 | * * *** 114 | *** * **** 115 | ``` 116 | 117 | To perform that rotation we can represent the bars as a list of lists (a matrix), where the first element of the list is the bar corresponding to the number 0, the second to the number 1, and so on. Now we can use the `transpose` function followed by the `reverse` to rotate 90 degrees counterclockwise the horizontal bars. That might sound like magic but try it and you will see that indeed it works. So now, after this rotation, we already have vertical bars and we just have to add the legend to obtain the full histogram. 118 | 119 | ```haskell 120 | histogram :: [Integer] -> String 121 | histogram xs = unlines $ rotate bars ++ legend 122 | where 123 | frequencies = [count i xs | i <- [0..9]] 124 | maxF = maximum frequencies 125 | bars = [bar f maxF | f <- frequencies] 126 | rotate = reverse . transpose 127 | legend = ["==========", "0123456789"] 128 | ``` 129 | 130 | Remember that if you want to visualize the histogram you should use `putStr` function, for example `putStr histogram [3,5]`. 131 | -------------------------------------------------------------------------------- /homework-03/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-03/assignment.pdf -------------------------------------------------------------------------------- /homework-04/HigherOrder.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module HigherOrder where 4 | 5 | import Data.List ((\\)) 6 | 7 | 8 | ---------------------------------- Exercise 1 ---------------------------------- 9 | 10 | fun1 :: [Integer] -> Integer 11 | fun1 [] = 1 12 | fun1 (x:xs) 13 | | even x = (x - 2) * fun1 xs 14 | | otherwise = fun1 xs 15 | 16 | fun1' :: [Integer] -> Integer 17 | fun1' = product . map (subtract 2) . filter even 18 | 19 | 20 | fun2 :: Integer -> Integer 21 | fun2 1 = 0 22 | fun2 n 23 | | even n = n + fun2 (n `div` 2) 24 | | otherwise = fun2 (3*n + 1) 25 | 26 | fun2' :: Integer -> Integer 27 | fun2' = sum . filter even . takeWhile (>1) . iterate hailstone 28 | where hailstone n = if even n then n `div` 2 else 3*n + 1 29 | 30 | 31 | fun1'Test :: Bool 32 | fun1'Test = and 33 | [ 34 | fun1 [] == fun1' [], 35 | fun1 [1,2,3] == fun1' [1,2,3], 36 | fun1 [1..100] == fun1' [1..100] 37 | ] 38 | 39 | fun2'Test :: Bool 40 | fun2'Test = and [fun2 i == fun2' i | i <- [1..1000]] 41 | 42 | 43 | ---------------------------------- Exercise 2 ---------------------------------- 44 | 45 | data Tree a = Leaf 46 | | Node Integer (Tree a) a (Tree a) 47 | deriving (Show, Eq) 48 | 49 | -- Generate a balanced binary tree from a list of values 50 | foldTree :: [a] -> Tree a 51 | foldTree = foldr insert Leaf 52 | 53 | -- Return the height of a tree 54 | -- Note that since the height of a tree with a single node is defined as 0, we 55 | -- define the height of a Leaf as -1 to be able to distinguish those two cases 56 | height :: Tree a -> Integer 57 | height Leaf = -1 58 | height (Node h _ _ _) = h 59 | 60 | -- Insert a new node into an existing balanced binary tree 61 | insert :: a -> Tree a -> Tree a 62 | insert x Leaf = Node 0 Leaf x Leaf 63 | insert x (Node h left root right) 64 | | h1 < h2 = Node h (insert x left) root right 65 | | h1 > h2 = Node h left root (insert x right) 66 | | otherwise = Node (h3 + 1) left' root right 67 | where h1 = height left 68 | h2 = height right 69 | h3 = height left' 70 | left' = insert x left 71 | 72 | 73 | foldTreeTest :: Bool 74 | foldTreeTest = and 75 | [ 76 | Leaf == foldTree "", 77 | Node 0 Leaf 'A' Leaf == foldTree "A", 78 | Node 1 (Node 0 Leaf 'B' Leaf) 'C' (Node 0 Leaf 'A' Leaf) == foldTree "ABC", 79 | Node 3 80 | (Node 2 81 | (Node 1 (Node 0 Leaf 'D' Leaf) 'G' Leaf) 82 | 'I' 83 | (Node 1 (Node 0 Leaf 'A' Leaf) 'E' Leaf)) 84 | 'J' 85 | (Node 2 86 | (Node 1 (Node 0 Leaf 'B' Leaf) 'F' Leaf) 87 | 'H' 88 | (Node 0 Leaf 'C' Leaf)) == foldTree "ABCDEFGHIJ" 89 | ] 90 | 91 | 92 | ---------------------------------- Exercise 3 ---------------------------------- 93 | 94 | -- Returns True if and only if there are an odd number of True values 95 | xor :: [Bool] -> Bool 96 | xor = foldr (/=) False 97 | 98 | -- Behaves identically to the standard map function 99 | map' :: (a -> b) -> [a] -> [b] 100 | map' f = foldr ((:) . f) [] 101 | 102 | -- Behaves identically to the standard foldl function 103 | myFoldl :: (a -> b -> a) -> a -> [b] -> a 104 | myFoldl = foldr . flip 105 | 106 | 107 | xorTest :: Bool 108 | xorTest = and 109 | [ 110 | True == xor [True], 111 | False == xor [False], 112 | True == xor [False, True, False], 113 | False == xor [False, True, False, False, True] 114 | ] 115 | 116 | map'Test :: Bool 117 | map'Test = and 118 | [ 119 | map (&& True) [True, False] == map' (&& True) [True, False], 120 | map (++ "!") ["hello", "world"] == map' (++ "!") ["hello", "world"] 121 | ] 122 | 123 | myFoldlTest :: Bool 124 | myFoldlTest = and 125 | [ 126 | foldl (*) 1 [1..10] == myFoldl (*) (1 :: Int) [1..10], 127 | foldl (-) 0 [1..100] == myFoldl (-) (0 :: Int) [1..100], 128 | foldl (+) 1 [1..100] == myFoldl (+) (1 :: Int) [1..100], 129 | foldl (||) False [False,True] == myFoldl (||) False [False,True] 130 | ] 131 | 132 | 133 | ---------------------------------- Exercise 4 ---------------------------------- 134 | 135 | -- Generate all the odd prime numbers up to 2*n + 2 136 | sieveSundaram :: Integer -> [Integer] 137 | sieveSundaram n = (\x -> 2*x + 1) <$> [1..n] \\ crossOut 138 | where crossOut = [x | i <- [1..n], j <- [i..n], let x = i + j + 2*i*j, x <= n] 139 | 140 | 141 | sieveSundaramTest :: Bool 142 | sieveSundaramTest = and 143 | [ 144 | [3] == sieveSundaram 1, 145 | [3,5,7,11,13,17,19,23,29] == sieveSundaram 14, 146 | [3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71] == sieveSundaram 35 147 | ] 148 | -------------------------------------------------------------------------------- /homework-04/README.md: -------------------------------------------------------------------------------- 1 | # Homework 4 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [HigherOrder.hs (file to submit)](HigherOrder.hs) 6 | 7 | ## Exercise 1 8 | 9 | In this exercise we had to reimplement functions using *wholemeal programming* practices. 10 | 11 | The first function is `fun1 :: [Integer] -> Integer` which takes a list of integers and returns a single one. This is pretty straightforward to rewrite since we only need to filter even integers, subtract 2 to each of them, and then compute their product. 12 | 13 | ```haskell 14 | fun1' :: [Integer] -> Integer 15 | fun1' = product . map (subtract 2) . filter even 16 | ``` 17 | 18 | The second function is `fun2 :: Integer -> Integer` which computes the hailstone sequence of a number and sums the even numbers of the sequence. We use `iterate :: (a -> a) -> a -> [a]` to produce the whole sequence and `takeWhile :: (a -> Bool) -> [a] -> [a]` to take the values that are greatest than 1 (when 1 is reached, the hailstone sequence ends). Then we just have to filter even numbers and compute their sum. 19 | 20 | ```haskell 21 | fun2' :: Integer -> Integer 22 | fun2' = sum . filter even . takeWhile (>1) . iterate hailstone 23 | where hailstone n = if even n then n `div` 2 else 3*n + 1 24 | ``` 25 | 26 | ## Exercise 2 27 | 28 | Here we had to implement a function `foldTree :: [a] -> Tree a` which generates a balanced binary tree from a list of values using `foldr`. To represent binary trees we use the following data type, where `Integer` is the height at that node (height is defined as the length of a path from the root to the deepest node): 29 | 30 | ```haskell 31 | data Tree a = Leaf 32 | | Node Integer (Tree a) a (Tree a) 33 | deriving (Show, Eq) 34 | ``` 35 | 36 | This is similar to one exercise that we completed in a [previous homework](../homework-02/README.md#exercise-3). The idea is to create a function which inserts a node into a balanced tree and returns a new balanced tree containing that node. If we have that function, we can just generate the whole tree like this: 37 | 38 | ```haskell 39 | foldTree :: [a] -> Tree a 40 | foldTree = foldr insert Leaf 41 | ``` 42 | 43 | The hard part is to implement `insert :: a -> Tree a -> Tree a` function. Note that we can always maintain the tree balanced by replacing a `Leaf` by the node that we are trying to insert. That means that we won't need rebalancing the tree, so any node that is already in the tree will never be moved. However, we might have to update the height of the nodes. 44 | 45 | The base case is easy: if the tree is a `Leaf`, we just return a new node with height 0. If the tree is not a leaf, we must decide whether we want to insert the node into the left subtree or into the right subtree. To make that decision we can check the heights of the left and the right subtrees. Three cases may happen: 46 | * If the left subtree's height is smaller than the right one, then we insert the node into the left subtree. Note that the height of the current node does not need an update since the length of the path to the deepest node of the left subtree will not overcome the one of the right subtree. 47 | * If the right subtree's height is smaller than the left one, we proceed exactly as above, only swap left by right and right by left. Indeed, those two cases are symmetrical. 48 | * Finally, if both heights are equal, we arbitrarily chose to insert the node into the left subtree. However, here the height of the current node might change. How much can it change? Well, the new height of the node will be the height of the left subtree with the new element inserted (`left'`) plus one. This is because `left'`s height will be the length of the path to the deepest node, and the current node is just one position further from that node than `left'`. 49 | 50 | ```haskell 51 | insert :: a -> Tree a -> Tree a 52 | insert x Leaf = Node 0 Leaf x Leaf 53 | insert x (Node h left root right) 54 | | h1 < h2 = Node h (insert x left) root right 55 | | h1 > h2 = Node h left root (insert x right) 56 | | otherwise = Node (h3+1) left' root right 57 | where h1 = height left 58 | h2 = height right 59 | h3 = height left' 60 | left' = insert x left 61 | ``` 62 | 63 | Finally, note that we have defined a helper `height :: Tree a -> Integer` function which returns the height of a tree. This function is trivial as we already store the height in the node but has the particularity that we return -1 instead of 0 if the tree is a `Leaf`. We must do that in order to distinguish between a node with height 0 and a Leaf. That way, when the left subtree is a node with height 0 and the right one is a `Leaf`, we will insert the node into the right subtree and not into the left one since 0 > -1. 64 | 65 | ```haskell 66 | height :: Tree a -> Integer 67 | height Leaf = -1 68 | height (Node h _ _ _) = h 69 | ``` 70 | 71 | ## Exercise 3 72 | 73 | The function `xor :: [Bool] -> Bool` returns `True` if and only if there are an odd number of `True` 74 | values contained in the input list. We must use a fold function. Since xor logical operation is associative, we can just use xor as the function to fold with. It is funny how, in Haskell, xor can be implemented the following way: 75 | 76 | ```haskell 77 | xor :: Bool -> Bool -> Bool 78 | xor = (/=) 79 | ``` 80 | 81 | In this case, it does not matter whether we use `foldl` or `foldr`. The final solution is: 82 | 83 | ```haskell 84 | xor :: [Bool] -> Bool 85 | xor = foldr (/=) False 86 | ``` 87 | 88 | The function `map' :: (a -> b) -> [a] -> [b]` must act exactly as the standard `map` function, but we must use `foldr`. Let's remember its signature: `foldr :: (a -> b -> b) -> b -> [a] -> b`. If we want to implement map, we realise that the type `b` that `foldr` returns must be the list `[b]` that `map'` returns. So in our case the signature is `foldr :: (a -> [b] -> [b]) -> [b] -> [a] -> [b]`. Thus, we accumulate the results in a list. The function that we feed `foldr` with takes an element of type `a` and a list `[b]` and returns a list `[b]`. To act as `map`, we just have to take the element `a`, apply the mapping function `f` to that element to obtain a `b`, and add it to the list of `[b]`. 89 | 90 | My first implementation was: 91 | 92 | ```haskell 93 | map' :: (a -> b) -> [a] -> [b] 94 | map' f = foldr (\x xs -> f x : xs) [] 95 | ``` 96 | 97 | But probably a more elegant (and probably harder to understand) solution is: 98 | 99 | ```haskell 100 | map' :: (a -> b) -> [a] -> [b] 101 | map' f = foldr ((:) . f) [] 102 | ``` 103 | 104 | Finally, the function `myFoldl :: (a -> b -> a) -> a -> [b] -> a` must behave identically to the standard `foldl` function and must use `foldr`. If we take a look at both signatures, were we have renamed the types to easily spot where the differences are: `foldl :: (a -> b -> a) -> a -> [b] -> a` and `foldr :: (b -> a -> a) -> a -> [b] -> a`. We see that we just have to transform the `(a -> b -> a)` function into `(b -> a -> a)`, since that's what `foldr` needs. The `flip :: (a -> b -> c) -> b -> a -> c` function does exactly what we need. Actually that looked too easy, so I [researched](https://wiki.haskell.org/Foldl_as_foldr) to check whether or not it was correct and I couldn't find my answer. So probably this solution fails for some cases but I haven't been able to find them. 105 | 106 | ```haskell 107 | myFoldl :: (a -> b -> a) -> a -> [b] -> a 108 | myFoldl = foldr . flip 109 | ``` 110 | 111 | ## Exercise 4 112 | 113 | In this exercise we implemented the [sieve of Sundaram](https://en.wikipedia.org/wiki/Sieve_of_Sundaram) which is an algorithm for finding all the prime numbers up to a specific integer. The algorithm is somewhat similar to the sieve of Eratosthenes in the sense that we will also cross out numbers. The function `sieveSundaram :: Integer -> [Integer]` generates all the odd prime numbers up to 2*n* + 2. 114 | 115 | First of all we have to generate a list of integers from 1 to n, in Haskell `[1..n]`. Then we must cross out (remove) from this list all numbers of the form *i* + *j* + 2*ij* where 1 <= *i* <= *j* and *i* + *j* + 2*ij* <= *n*. In order to remove elements from a list, we can use the difference operator: `(\\) :: Eq a => [a] -> [a] -> [a]`. 116 | 117 | To generate all the numbers to cross out, we can use comprehension lists. Indeed, the algorithm that we defined above perfectly fits for that: `[x | i <- [1..n], j <- [i..n], let x = i + j + 2*i*j, x <= n]`. Yes, this is valid Haskell code, maybe it is even easier to understand than the explanation in simple words! 118 | 119 | Finally, we have to work with the numbers that are left in the `[1..n]` list. They must be doubled and incremented by one, and that is the list of odd prime numbers below 2*n* + 2. We just have to map the lambda function `\x -> 2*x + 1` to those numbers and that's all. Note that we also could have used function composition like this `((+1) . (*2))`, but I feel it is less readable than the lambda function. Instead of using `map` I used its infix notation `<$>`. 120 | 121 | ```haskell 122 | sieveSundaram :: Integer -> [Integer] 123 | sieveSundaram n = (\x -> 2*x + 1) <$> [1..n] \\ crossOut 124 | where crossOut = [x | i <- [1..n], j <- [i..n], let x = i + j + 2*i*j, x <= n] 125 | ``` 126 | -------------------------------------------------------------------------------- /homework-04/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-04/assignment.pdf -------------------------------------------------------------------------------- /homework-05/Calc.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | 6 | module Calc where 7 | 8 | import ExprT 9 | import Parser 10 | import StackVM 11 | import qualified Data.Map as M 12 | 13 | ---------------------------------- Exercise 1 ---------------------------------- 14 | 15 | -- Evaluates an expression ExprT 16 | eval :: ExprT -> Integer 17 | eval (ExprT.Lit x) = x 18 | eval (ExprT.Add x y) = eval x + eval y 19 | eval (ExprT.Mul x y) = eval x * eval y 20 | 21 | 22 | evalTest :: Bool 23 | evalTest = and 24 | [ 25 | 10 == eval (ExprT.Lit 10), 26 | 10 == eval (ExprT.Add (ExprT.Lit (-10)) (ExprT.Lit 20)), 27 | 20 == eval (ExprT.Mul (ExprT.Lit 5) (ExprT.Lit 4)), 28 | 20 == eval (ExprT.Mul (ExprT.Add (ExprT.Lit 2) (ExprT.Lit 3)) (ExprT.Lit 4)) 29 | ] 30 | 31 | 32 | ---------------------------------- Exercise 2 ---------------------------------- 33 | 34 | -- Evaluates an expression given as a String 35 | -- Returns Nothing if the expression is not well-formed 36 | -- Otherwise, it returns Just n if the expression evaluates to n 37 | evalStr :: String -> Maybe Integer 38 | evalStr = fmap eval . parseExp ExprT.Lit ExprT.Add ExprT.Mul 39 | 40 | 41 | evalStrTest :: Bool 42 | evalStrTest = and 43 | [ 44 | Just 10 == evalStr "10", 45 | Just 20 == evalStr "15 + 5", 46 | Just 20 == evalStr "5*4", 47 | Nothing == evalStr "2+*3" 48 | ] 49 | 50 | 51 | ---------------------------------- Exercise 3 ---------------------------------- 52 | 53 | class Expr a where 54 | lit :: Integer -> a 55 | add :: a -> a -> a 56 | mul :: a -> a -> a 57 | 58 | instance Expr ExprT where 59 | lit = ExprT.Lit 60 | add = ExprT.Add 61 | mul = ExprT.Mul 62 | 63 | -- Constrain the type of its argument to ExprT 64 | reify :: ExprT -> ExprT 65 | reify = id 66 | 67 | 68 | reifyTest :: Bool 69 | reifyTest = and 70 | [ 71 | ExprT.Lit 2 == (reify $ lit 2), 72 | ExprT.Add (ExprT.Lit 2) (ExprT.Lit 3) == (reify $ add (lit 2) (lit 3)), 73 | ExprT.Mul (ExprT.Lit 5) (ExprT.Lit 6) == (reify $ mul (lit 5) (lit 6)) 74 | ] 75 | 76 | 77 | ---------------------------------- Exercise 4 ---------------------------------- 78 | 79 | instance Expr Integer where 80 | lit = id 81 | add = (+) 82 | mul = (*) 83 | 84 | 85 | instance Expr Bool where 86 | lit = (<= 0) 87 | add = (||) 88 | mul = (&&) 89 | 90 | 91 | newtype MinMax = MinMax Integer deriving (Eq, Show) 92 | 93 | instance Expr MinMax where 94 | lit = MinMax 95 | add (MinMax x) (MinMax y) = MinMax $ max x y 96 | mul (MinMax x) (MinMax y) = MinMax $ min x y 97 | 98 | 99 | newtype Mod7 = Mod7 Integer deriving (Eq, Show) 100 | 101 | instance Expr Mod7 where 102 | lit x = Mod7 $ x `mod` 7 103 | add (Mod7 x) (Mod7 y) = Mod7 $ (x+y) `mod` 7 104 | mul (Mod7 x) (Mod7 y) = Mod7 $ (x*y) `mod` 7 105 | 106 | 107 | instancesTest :: Bool 108 | instancesTest = and 109 | [ 110 | Just (-7) == (parseExp lit add mul "(3 * -4) + 5" :: Maybe Integer), 111 | Just False == (parseExp lit add mul "(3 * -4) + 5" :: Maybe Bool), 112 | Just (MinMax 5) == (parseExp lit add mul "(3 * -4) + 5" :: Maybe MinMax), 113 | Just (Mod7 0) == (parseExp lit add mul "(3 * -4) + 5" :: Maybe Mod7) 114 | ] 115 | 116 | 117 | ---------------------------------- Exercise 5 ---------------------------------- 118 | 119 | instance Expr Program where 120 | lit a = [StackVM.PushI a] 121 | add a b = a ++ b ++ [StackVM.Add] 122 | mul a b = a ++ b ++ [StackVM.Mul] 123 | 124 | compile :: String -> Maybe Program 125 | compile = parseExp lit add mul 126 | 127 | run :: String -> Either String StackVal 128 | run = execute . compile 129 | where execute Nothing = Left "The program does not compile." 130 | execute (Just p) = stackVM p 131 | 132 | 133 | compileTest :: Bool 134 | compileTest = and 135 | [ 136 | Nothing == compile "5+*2", 137 | Just [PushI 5] == compile "5", 138 | Just [PushI 5,PushI 6,StackVM.Add] == compile "5+6", 139 | Just [PushI 5,PushI 6,StackVM.Mul] == compile "5*6", 140 | Just [PushI 4,PushI 2,PushI 3,StackVM.Mul,StackVM.Add] == compile "4+2*3", 141 | Just [PushI 4,PushI 2,StackVM.Add,PushI 3,StackVM.Mul] == compile "(4+2)*3" 142 | ] 143 | 144 | runTest :: Bool 145 | runTest = and 146 | [ 147 | Left "The program does not compile." == run "5+*2", 148 | Right (IVal 5) == run "5", 149 | Right (IVal 11) == run "5+6", 150 | Right (IVal 30) == run "5*6", 151 | Right (IVal 10) == run "4+2*3", 152 | Right (IVal 18) == run "(4+2)*3" 153 | ] 154 | 155 | 156 | ---------------------------------- Exercise 6 ---------------------------------- 157 | 158 | class HasVars a where 159 | var :: String -> a 160 | 161 | data VarExprT = Lit Integer 162 | | Var String 163 | | Add VarExprT VarExprT 164 | | Mul VarExprT VarExprT 165 | deriving (Show, Eq) 166 | 167 | instance Expr VarExprT where 168 | lit = Calc.Lit 169 | add = Calc.Add 170 | mul = Calc.Mul 171 | 172 | instance HasVars VarExprT where 173 | var = Calc.Var 174 | 175 | type MapSI = M.Map String Integer 176 | 177 | instance HasVars (MapSI -> Maybe Integer) where 178 | var = M.lookup 179 | 180 | instance Expr (MapSI -> Maybe Integer) where 181 | lit a _ = Just a 182 | add a b m = (+) <$> a m <*> b m 183 | mul a b m = (*) <$> a m <*> b m 184 | 185 | withVars :: [(String, Integer)] -> (MapSI -> Maybe Integer) -> Maybe Integer 186 | withVars vars expr = expr $ M.fromList vars 187 | 188 | 189 | instanceTest :: Bool 190 | instanceTest = and 191 | [ 192 | Calc.Lit 5 == (lit 5 :: VarExprT), 193 | Calc.Var "x" == (var "x" :: VarExprT), 194 | Calc.Mul (Calc.Var "x") (Calc.Lit 5) == (mul (var "x") (lit 5) :: VarExprT), 195 | Calc.Add (Calc.Lit 3) (Calc.Var "x") == (add (lit 3) (var "x") :: VarExprT) 196 | ] 197 | 198 | withVarsTest :: Bool 199 | withVarsTest = and 200 | [ 201 | Nothing == (withVars [] $ var "x"), 202 | Just 6 == (withVars [("x",6)] $ add (lit 3) (lit 3)), 203 | Just 9 == (withVars [("x",6)] $ add (lit 3) (var "x")), 204 | Just 9 == (withVars [("y",3)] $ mul (lit 3) (var "y")), 205 | Just 15 == (withVars [("x", 5), ("y", 3)] $ mul (var "x") (var "y")) 206 | ] 207 | -------------------------------------------------------------------------------- /homework-05/ExprT.hs: -------------------------------------------------------------------------------- 1 | module ExprT where 2 | 3 | data ExprT = Lit Integer 4 | | Add ExprT ExprT 5 | | Mul ExprT ExprT 6 | deriving (Show, Eq) 7 | -------------------------------------------------------------------------------- /homework-05/Parser.hs: -------------------------------------------------------------------------------- 1 | -- Applicative parser for infix arithmetic expressions without any 2 | -- dependency on hackage. Builds an explicit representation of the 3 | -- syntax tree to fold over using client-supplied semantics. 4 | module Parser (parseExp) where 5 | import Control.Applicative hiding (Const) 6 | import Control.Arrow 7 | import Data.Char 8 | import Data.Monoid 9 | import Data.List (foldl') 10 | 11 | -- Building block of a computation with some state of type @s@ 12 | -- threaded through it, possibly resulting in a value of type @r@ 13 | -- along with some updated state. 14 | newtype State s r = State (s -> Maybe (r, s)) 15 | 16 | -- Expressions 17 | data Expr = Const Integer 18 | | Add Expr Expr 19 | | Mul Expr Expr 20 | deriving Show 21 | 22 | instance Functor (State s) where 23 | fmap f (State g) = State $ fmap (first f) . g 24 | 25 | instance Applicative (State s) where 26 | pure x = State $ \s -> Just (x, s) 27 | State f <*> State g = State $ \s -> 28 | case f s of 29 | Nothing -> Nothing 30 | Just (r, s') -> fmap (first r) . g $ s' 31 | 32 | instance Alternative (State s) where 33 | empty = State $ const Nothing 34 | State f <|> State g = State $ \s -> maybe (g s) Just (f s) 35 | 36 | -- A parser threads some 'String' state through a computation that 37 | -- produces some value of type @a@. 38 | type Parser a = State String a 39 | 40 | -- Parse one numerical digit. 41 | digit :: Parser Integer 42 | digit = State $ parseDigit 43 | where parseDigit [] = Nothing 44 | parseDigit s@(c:cs) 45 | | isDigit c = Just (fromIntegral $ digitToInt c, cs) 46 | | otherwise = Nothing 47 | 48 | -- Parse an integer. The integer may be prefixed with a negative sign. 49 | num :: Parser Integer 50 | num = maybe id (const negate) <$> optional (char '-') <*> (toInteger <$> some digit) 51 | where toInteger = foldl' ((+) . (* 10)) 0 52 | 53 | -- Parse a single white space character. 54 | space :: Parser () 55 | space = State $ parseSpace 56 | where parseSpace [] = Nothing 57 | parseSpace s@(c:cs) 58 | | isSpace c = Just ((), cs) 59 | | otherwise = Nothing 60 | 61 | -- Consume zero or more white space characters. 62 | eatSpace :: Parser () 63 | eatSpace = const () <$> many space 64 | 65 | -- Parse a specific character. 66 | char :: Char -> Parser Char 67 | char c = State parseChar 68 | where parseChar [] = Nothing 69 | parseChar (x:xs) | x == c = Just (c, xs) 70 | | otherwise = Nothing 71 | 72 | -- Parse one of our two supported operator symbols. 73 | op :: Parser (Expr -> Expr -> Expr) 74 | op = const Add <$> (char '+') <|> const Mul <$> (char '*') 75 | 76 | -- Succeed only if the end of the input has been reached. 77 | eof :: Parser () 78 | eof = State parseEof 79 | where parseEof [] = Just ((),[]) 80 | parseEof _ = Nothing 81 | 82 | -- Parse an infix arithmetic expression consisting of integers, plus 83 | -- signs, multiplication signs, and parentheses. 84 | parseExpr :: Parser Expr 85 | parseExpr = eatSpace *> 86 | ((buildOp <$> nonOp <*> (eatSpace *> op) <*> parseExpr) <|> nonOp) 87 | where buildOp x op y = x `op` y 88 | nonOp = char '(' *> parseExpr <* char ')' <|> Const <$> num 89 | 90 | -- Run a parser over a 'String' returning the parsed value and the 91 | -- remaining 'String' data. 92 | execParser :: Parser a -> String -> Maybe (a, String) 93 | execParser (State f) = f 94 | 95 | -- Run a parser over a 'String' returning the parsed value. 96 | evalParser :: Parser a -> String -> Maybe a 97 | evalParser = (fmap fst .) . execParser 98 | 99 | -- Parse an arithmetic expression using the supplied semantics for 100 | -- integral constants, addition, and multiplication. 101 | parseExp :: (Integer -> a) -> (a -> a -> a) -> (a -> a -> a) -> String -> Maybe a 102 | parseExp con add mul = (convert <$>) . evalParser (parseExpr <* eof) 103 | where convert (Const x) = con x 104 | convert (Add x y) = add (convert x) (convert y) 105 | convert (Mul x y) = mul (convert x) (convert y) 106 | -------------------------------------------------------------------------------- /homework-05/README.md: -------------------------------------------------------------------------------- 1 | # Homework 5 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [ExprT.hs](ExprT.hs) 6 | * [Parser.hs](Parser.hs) 7 | * [StackVM.hs](StackVM.hs) 8 | * [Calc.hs (file to submit)](Calc.hs) 9 | 10 | In this homework we implement a simple calculator using a domain-specific language (DSL). For arithmetic expressions, we are going to work with the following data type `ExprT`: 11 | 12 | ```haskell 13 | data ExprT = Lit Integer 14 | | Add ExprT ExprT 15 | | Mul ExprT ExprT 16 | deriving (Show, Eq) 17 | ``` 18 | 19 | ## Exercise 1 20 | 21 | In this exercise we implement a function `eval :: ExprT -> Integer` which takes an expression and evaluates it. This is trivial to do using pattern matching: 22 | 23 | ```haskell 24 | eval :: ExprT -> Integer 25 | eval (ExprT.Lit x) = x 26 | eval (ExprT.Add x y) = eval x + eval y 27 | eval (ExprT.Mul x y) = eval x * eval y 28 | ``` 29 | 30 | ## Exercise 2 31 | 32 | The function `evalStr :: String -> Maybe Integer` evaluates an expression given as a `String` such as `(2+3)*4`. If the expression is not well-formed, it should return `Nothing` whereas it should return `Just n` if the expression evaluates to `n`. We are provided with a helper function named `parseExp` which does the hard job, that is parsing the `String` to `ExprT`. The only obstacle is that we have to deal with `Maybe` since `parseExp` might not be able to successfully parse the expression. 33 | 34 | My first approach was the following: 35 | 36 | ```haskell 37 | evalStr :: String -> Maybe Integer 38 | evalStr = (maybe Nothing $ Just . eval) . parseExp ExprT.Lit ExprT.Add ExprT.Mul 39 | ``` 40 | 41 | However, I was not satisfied with this solution since I felt that using the `maybe :: b -> (a -> b) -> Maybe a -> b` function just to forward the `Nothing` and to reconstruct the `Just` was too verbose. So I researched and indeed there was a much more elegant solution: 42 | 43 | ```haskell 44 | evalStr :: String -> Maybe Integer 45 | evalStr = fmap eval . parseExp ExprT.Lit ExprT.Add ExprT.Mul 46 | ``` 47 | 48 | Actually it took me a while to understand why this worked. Let's take a look at the `fmap :: Functor f => (a -> b) -> f a -> f b` function. It takes a function `a -> b` and applies it to `a` to return a `b`, as long as `a` and `b` are instances of the `Functor f`. The function `eval :: ExprT -> Integer` implies that `fmap eval :: Functor f => f ExprT -> f Integer`. So it is a function that takes an `ExprT` and returns an `Integer`. But those two elements must be an instance of the `Functor` type class! Well, in fact `Maybe` type is an instance of `Functor`. For example, `fmap (*2) Nothing` is equal to `Nothing` while `fmap (*2) $ Just 5` is equal to `Just 10`. So, in the same way we can apply `fmap` to `[a]`, we can apply `fmap` to `Maybe`. 49 | 50 | ## Exercise 3 51 | 52 | We had to create a type class named `Expr` to parallel the constructors of `ExprT`. We see that the types of `ExprT` constructors are the following: 53 | * `Lit :: Integer -> ExprT` 54 | * `Add :: ExprT -> ExprT -> ExprT` 55 | * `Mul :: ExprT -> ExprT -> ExprT` 56 | 57 | Thus, the `Expr` is defined as follows: 58 | 59 | ```haskell 60 | class Expr a where 61 | lit :: Integer -> a 62 | add :: a -> a -> a 63 | mul :: a -> a -> a 64 | ``` 65 | 66 | Then we have to make `ExprT` an instance of `Expr`. This is also straightforward: 67 | 68 | ```haskell 69 | instance Expr ExprT where 70 | lit = ExprT.Lit 71 | add = ExprT.Add 72 | mul = ExprT.Mul 73 | ``` 74 | 75 | Finally, note that an expression such as `lit 5` has type `Expr a => a`, that is any type which is instance of `Expr` type class. If we want to give an explicit type to such an expression, we can explicitly do it like this `lit 5 :: ExprT` or we can use an expression which context helps determining the type. A trivial function that does this is the following one: 76 | 77 | ```haskell 78 | reify :: ExprT -> ExprT 79 | reify = id 80 | ``` 81 | 82 | Now the expression `reify $ lit 5` has type `ExprT`, since the function `reify` takes an `ExprT` as first argument. 83 | 84 | ## Exercise 4 85 | 86 | Here we had to keep making instances of `Expr`. The first two ones are `Integer` and `Bool`. So we have to define how they will implement the type class `Expr`. We can use point-free notation and sections to simplify the code. Note that we use the `id :: a -> a` function since the signature of lit is `lit :: Integer -> a`, so in the `Integer` instance signature is `lit :: Integer -> Integer`. 87 | 88 | ```haskell 89 | instance Expr Integer where 90 | lit = id 91 | add = (+) 92 | mul = (*) 93 | 94 | instance Expr Bool where 95 | lit = (<= 0) 96 | add = (||) 97 | mul = (&&) 98 | ``` 99 | 100 | The following two instances are `MinMax` and `Mod7`. Here we also define wrappers with `newType` to work with `Integers` internally. Here we cannot be as concise as the previous ones as we have to pattern match the `MinMax` and `Mod7` types. 101 | 102 | ```haskell 103 | newtype MinMax = MinMax Integer deriving (Eq, Show) 104 | 105 | instance Expr MinMax where 106 | lit = MinMax 107 | add (MinMax x) (MinMax y) = MinMax $ max x y 108 | mul (MinMax x) (MinMax y) = MinMax $ min x y 109 | 110 | 111 | newtype Mod7 = Mod7 Integer deriving (Eq, Show) 112 | 113 | instance Expr Mod7 where 114 | lit x = Mod7 $ x `mod` 7 115 | add (Mod7 x) (Mod7 y) = Mod7 $ (x+y) `mod` 7 116 | mul (Mod7 x) (Mod7 y) = Mod7 $ (x*y) `mod` 7 117 | ``` 118 | 119 | Finally, this led me to wonder what was the difference between `data` and `newtype` when defining new data structures. Basically `newtype` is limited to a single constructor. For example, we cannot use algebraic data types with `newtype`. Meanwhile, `data` declares a new data structure at runtime. For more info, read [this](https://stackoverflow.com/questions/5889696/difference-between-data-and-newtype-in-haskell). 120 | 121 | ## Exercise 5 122 | 123 | I think the complexity of this exercise resided in understanding what we had to do. We have to implement another calculator using a custom stack-based CPU. I highly recommend reading and understanding the statement and taking a look at [StackVM.hs](StackVM.hs) file. I took the license of changing the file a little bit, such as adding the `Eq` type class to both `StackVal` and `StackExp` types in order to be able to test the functions. 124 | 125 | The task is to implement a compiler for arithmetic expressions only. That means that we are not going to use some operations that the custom CPU supports such as boolean operations. First we have to create an instance of `Expr` type class for `Program` which is simply a list of `StackExp`. For example, `[PushI 3, PushI 5, Add]` is a program. We have to implement `lit`, `add` and `mul` functions: 126 | 127 | * `lit :: Integer -> Program`: We just have to push the `Integer` to the stack 128 | * `add :: Program -> Program -> Program`: We have to append the first program, the second program and the `add` operation 129 | * `mul :: Program -> Program -> Program`: We have to append the first program, the second program and the `mul` operation 130 | 131 | ```haskell 132 | instance Expr Program where 133 | lit a = [StackVM.PushI a] 134 | add a b = a ++ b ++ [StackVM.Add] 135 | mul a b = a ++ b ++ [StackVM.Mul] 136 | ``` 137 | 138 | Let's take a closer look at what we did here. Suppose we have the following expression: `add (lit 5) (lit 7) :: Program`. The correct program is `[PushI 5,PushI 7,Add]` and indeed the instance we just defined does that. 139 | 140 | Then we had to create a function `compile :: String -> Maybe Program` which takes an arithmetic expression and transforms it into a `Program` ready to be run on the custom CPU. To do that we will use again the helper function `parseExp :: (Integer -> a) -> (a -> a -> a) -> (a -> a -> a) -> String -> Maybe a`. The signature of `compile` forces the type variable `a` to be bound `Program`, so the function is as simple as follows: 141 | 142 | ```haskell 143 | compile :: String -> Maybe Program 144 | compile = parseExp lit add mul 145 | ``` 146 | 147 | Finally, I wanted to try that indeed the `compile` function produced a program that was executable by the custom CPU, so I implemented the function `run :: String -> Either String StackVal` which compiles and executes an arithmetic expression: 148 | 149 | ```haskell 150 | run :: String -> Either String StackVal 151 | run = execute . compile 152 | where execute Nothing = Left "The program does not compile." 153 | execute (Just p) = stackVM p 154 | ``` 155 | 156 | ## Exercise 6 157 | 158 | The last exercise was the most challenging one, but also the one that made me learn the most! The objective of this exercise was to allow variables in our arithmetic expressions. 159 | 160 | First of all, we had to create a new type class named `HasVars` with the method `var :: String -> a`. Then a new data type `VarExprT`, similar to `ExprT` but with an additional constructor for variables. For now, nothing too fancy: 161 | 162 | ```haskell 163 | class HasVars a where 164 | var :: String -> a 165 | 166 | data VarExprT = Lit Integer 167 | | Var String 168 | | Add VarExprT VarExprT 169 | | Mul VarExprT VarExprT 170 | deriving (Show, Eq) 171 | ``` 172 | 173 | Next, we had to make `VarExprT` an instance of both `Expr` and `HasVars`. We have already done this previously, so again, this is straightforward: 174 | 175 | ```haskell 176 | instance Expr VarExprT where 177 | lit = Calc.Lit 178 | add = Calc.Add 179 | mul = Calc.Mul 180 | 181 | instance HasVars VarExprT where 182 | var = Calc.Var 183 | ``` 184 | 185 | Now, we are done with `VarExprT` and the interesting part begins! We will use the `Data.Map` module to deal with maps since we need to store mappings from variables to values. If this is the first time you are dealing with maps, it is worth checking [here](http://learnyouahaskell.com/modules#data-map) how they work. We will use a map from `String` to `Integer` and define the following type for convenience: `type MapSI = M.Map String Integer`. 186 | 187 | We must implement two instances: `instance HasVars (MapSI -> Maybe Integer)` and `instance Expr (MapSI -> Maybe Integer)`. I will just drop the code here, which is pretty concise, and then I will explain what happens under the hoods: 188 | 189 | ```haskell 190 | instance HasVars (MapSI -> Maybe Integer) where 191 | var = M.lookup 192 | 193 | instance Expr (MapSI -> Maybe Integer) where 194 | lit a _ = Just a 195 | add a b m = (+) <$> a m <*> b m 196 | mul a b m = (*) <$> a m <*> b m 197 | ``` 198 | 199 | So... it seems pretty easy right? Well, it took me a while to get there. The first remarkable thing is that `(MapSI -> Maybe Integer)` is not a regular data type such as `VarExprT`, it is a function. So yes, we are implementing two instances of a function. When we say we Haskell has higher-order functions, we take it very seriously! 200 | 201 | For the `HasVars` type class we have to implement `var :: String -> MapSI -> Maybe Integer`. If we take a look at `M.lookup :: Ord k => k -> M.Map k a -> Maybe a` we see that it has exactly the same signature, so it is as easy as `var = M.lookup`. 202 | 203 | For the `Expr` type class I had a lot of troubles understanding how `add` and `mul` signatures worked. They are `a -> a -> a` thus `(MapSI -> Maybe Integer) -> (MapSI -> Maybe Integer) -> (MapSI -> Maybe Integer)`. But in Haskell this is equivalent to `(MapSI -> Maybe Integer) -> (MapSI -> Maybe Integer) -> MapSI -> Maybe Integer`, since `->` is right associative. That means that when we do `add a b m`, `m` is bound to `MapSI` and not to `(MapSI -> Maybe Integer)`. Similarly, for the `lit` function the signature is `Integer -> (MapSI -> Maybe Integer)`. By the way, when we write `a m` and `b m` we are working with the types `a :: (MapSI -> Maybe Integer)` and `m :: MapSI`. So if we do `a m` we have the signature: `(MapSI -> Maybe Integer) -> MapSI -> Maybe Integer`. Taking all of that into account, this was my first approach: 204 | 205 | ```haskell 206 | instance Expr (MapSI -> Maybe Integer) where 207 | lit a = (\_ -> Just a) 208 | add a b m = case (isNothing (a m) || isNothing (b m)) of 209 | True -> Nothing 210 | _ -> Just (fromJust (a m) + fromJust (b m)) 211 | mul a b m = case (isNothing (a m) || isNothing (b m)) of 212 | True -> Nothing 213 | _ -> Just (fromJust (a m) * fromJust (b m)) 214 | ``` 215 | 216 | As you can see, it is pretty verbose and tedious to extract the values from `Maybe` only to wrap them again in `add` and `mul` while the `lit` function is also strange. For the latter, it is just as easy as realising that `Integer -> (MapSI -> Maybe Integer)` is the same as `Integer -> MapSI -> Maybe Integer` so `lit a _ = Just a` makes more sense. For the former, I was lucky enough to find a nice explanation of what [applicative style](https://en.wikibooks.org/wiki/Haskell/Applicative_functors#Application_in_functors) is. It is based on the problem of suming `Just 2` and `Just 3` so it is perfectly suited for this example. 217 | 218 | Finally, I take the license to show again my final version, just in case you missed it: 219 | 220 | ```haskell 221 | instance HasVars (MapSI -> Maybe Integer) where 222 | var = M.lookup 223 | 224 | instance Expr (MapSI -> Maybe Integer) where 225 | lit a _ = Just a 226 | add a b m = (+) <$> a m <*> b m 227 | mul a b m = (*) <$> a m <*> b m 228 | ``` 229 | -------------------------------------------------------------------------------- /homework-05/StackVM.hs: -------------------------------------------------------------------------------- 1 | module StackVM (StackVal(..), StackExp(..), Stack, Program, stackVM) where 2 | 3 | -- Values that may appear in the stack. Such a value will also be 4 | -- returned by the stackVM program execution function. 5 | data StackVal = IVal Integer | BVal Bool | Void deriving (Show, Eq) 6 | 7 | -- The various expressions our VM understands. 8 | data StackExp = PushI Integer 9 | | PushB Bool 10 | | Add 11 | | Mul 12 | | And 13 | | Or 14 | deriving (Show, Eq) 15 | 16 | type Stack = [StackVal] 17 | type Program = [StackExp] 18 | 19 | -- Execute the given program. Returns either an error message or the 20 | -- value on top of the stack after execution. 21 | stackVM :: Program -> Either String StackVal 22 | stackVM = execute [] 23 | 24 | errType :: String -> Either String a 25 | errType op = Left $ "Encountered '" ++ op ++ "' opcode with ill-typed stack." 26 | 27 | errUnderflow :: String -> Either String a 28 | errUnderflow op = Left $ "Stack underflow with '" ++ op ++ "' opcode." 29 | 30 | -- Execute a program against a given stack. 31 | execute :: Stack -> Program -> Either String StackVal 32 | execute [] [] = Right Void 33 | execute (s:_) [] = Right s 34 | 35 | execute s (PushI x : xs) = execute (IVal x : s) xs 36 | execute s (PushB x : xs) = execute (BVal x : s) xs 37 | 38 | execute (IVal s1 : IVal s2 : ss) (Add : xs) = execute (IVal (s1 + s2) : ss) xs 39 | execute (_:_:_) (Add:_) = errType "Add" 40 | execute _ (Add:_) = errUnderflow "Add" 41 | 42 | execute (IVal s1 : IVal s2 : ss) (Mul : xs) = execute (IVal (s1 * s2) : ss) xs 43 | execute (_:_:_) (Mul:_) = errType "Mul" 44 | execute _ (Mul:_) = errUnderflow "Mul" 45 | 46 | execute (BVal s1 : BVal s2 : ss) (And : xs) = execute (BVal (s1 && s2) : ss) xs 47 | execute (_:_:_) (And:_) = errType "And" 48 | execute _ (And:_) = errUnderflow "And" 49 | 50 | execute (BVal s1 : BVal s2 : ss) (Or : xs) = execute (BVal (s1 || s2) : ss) xs 51 | execute (_:_:_) (Or:_) = errType "Or" 52 | execute _ (Or:_) = errUnderflow "Or" 53 | 54 | test = stackVM [PushI 3, PushI 5, Add] 55 | -------------------------------------------------------------------------------- /homework-05/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-05/assignment.pdf -------------------------------------------------------------------------------- /homework-06/Fibonacci.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-missing-methods -fno-warn-name-shadowing #-} 2 | 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | module Fibonacci where 6 | 7 | 8 | ---------------------------------- Exercise 1 ---------------------------------- 9 | 10 | -- Return the nth Fibonacci number 11 | fib :: Integer -> Integer 12 | fib 0 = 0 13 | fib 1 = 1 14 | fib n = fib (n-1) + fib (n-2) 15 | 16 | -- Infinte list of all Fibonacci numbers (this is very slow!) 17 | fibs1 :: [Integer] 18 | fibs1 = fib <$> [0..] 19 | 20 | 21 | fibTest :: Bool 22 | fibTest = and 23 | [ 24 | 0 == fib 0, 25 | 1 == fib 1, 26 | 5 == fib 5, 27 | 89 == fib 11, 28 | 610 == fib 15 29 | ] 30 | 31 | fibs1Test :: Bool 32 | fibs1Test = [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987] == take 17 fibs1 33 | 34 | 35 | ---------------------------------- Exercise 2 ---------------------------------- 36 | 37 | -- Infinte list of all Fibonacci numbers (efficiently computed) 38 | fibs2 :: [Integer] 39 | fibs2 = 0 : 1 : zipWith (+) fibs2 (tail fibs2) 40 | 41 | 42 | fibs2Test :: Bool 43 | fibs2Test = take 25 fibs1 == take 25 fibs2 44 | 45 | 46 | ---------------------------------- Exercise 3 ---------------------------------- 47 | 48 | data Stream a = Stream a (Stream a) 49 | 50 | -- Convert a stream into an infinte list 51 | streamToList :: Stream a -> [a] 52 | streamToList (Stream x xs) = x : streamToList xs 53 | 54 | instance Show a => Show (Stream a) where 55 | show = show . take 20 . streamToList 56 | 57 | 58 | ---------------------------------- Exercise 4 ---------------------------------- 59 | 60 | -- Generates a stream containing infinitely many copies of the given element 61 | streamRepeat :: a -> Stream a 62 | streamRepeat x = Stream x (streamRepeat x) 63 | 64 | -- Applies a function to every element of a stream 65 | streamMap :: (a -> b) -> Stream a -> Stream b 66 | streamMap f (Stream x xs) = Stream (f x) (streamMap f xs) 67 | 68 | -- Generates a stream from a seed and a rule which specifies how to transform 69 | -- the seed into a new seed which is used for generating the rest of the stream 70 | streamFromSeed :: (a -> a) -> a -> Stream a 71 | streamFromSeed f x = Stream x (streamFromSeed f (f x)) 72 | 73 | 74 | streamRepeatTest :: Bool 75 | streamRepeatTest = and 76 | [ 77 | (show . take 20 $ repeat 'a') == show (streamRepeat 'a'), 78 | (show . take 20 $ repeat True) == show (streamRepeat True), 79 | (show . take 20 $ repeat "Haskell") == show (streamRepeat "Haskell") 80 | ] 81 | 82 | streamMapTest :: Bool 83 | streamMapTest = and 84 | [ 85 | (show . take 20 $ repeat 'a') == (show . streamMap id $ streamRepeat 'a'), 86 | (show . take 20 $ repeat False) == (show . streamMap not $ streamRepeat True) 87 | ] 88 | 89 | streamFromSeedTest :: Bool 90 | streamFromSeedTest = and 91 | [ 92 | (show . take 20 $ repeat 'a') == show (streamFromSeed id 'a'), 93 | (show . take 20 $ ([0..] :: [Int])) == show (streamFromSeed (+1) (0 :: Int)) 94 | ] 95 | 96 | 97 | ---------------------------------- Exercise 5 ---------------------------------- 98 | 99 | -- Infinte list of natural numbers starting from 0 100 | nats :: Stream Integer 101 | nats = streamFromSeed (+1) 0 102 | 103 | -- Generates the ruler function 104 | ruler :: Stream Integer 105 | ruler = foldr1 interleaveStreams (streamRepeat <$> [0..]) 106 | 107 | -- Alternates the elements from two streams 108 | interleaveStreams :: Stream a -> Stream a -> Stream a 109 | interleaveStreams (Stream x xs) ys = Stream x (interleaveStreams ys xs) 110 | 111 | 112 | natsTest :: Bool 113 | natsTest = (show . take 20 $ ([0..] :: [Integer])) == show nats 114 | 115 | rulerTest :: Bool 116 | rulerTest = "[0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2]" == show ruler 117 | 118 | interleaveStreamsTest :: Bool 119 | interleaveStreamsTest = (show . take 20 $ cycle [True,False]) == show streams 120 | where streams = interleaveStreams (streamRepeat True) (streamRepeat False) 121 | 122 | 123 | ---------------------------------- Exercise 6 ---------------------------------- 124 | 125 | -- Generates the polynomial: 0 + 1*x + 0*x^2 + 0*x^3 + .. 126 | x :: Stream Integer 127 | x = Stream 0 . Stream 1 $ streamRepeat 0 128 | 129 | instance Num (Stream Integer) where 130 | (Stream x xs) + (Stream y ys) = Stream (x+y) (xs + ys) 131 | (Stream x xs) * s@(Stream y ys) = Stream (x*y) (streamMap (*x) ys + (xs * s)) 132 | negate = streamMap negate 133 | fromInteger n = Stream n $ streamRepeat 0 134 | 135 | instance Fractional (Stream Integer) where 136 | (Stream x xs) / (Stream y ys) = q 137 | where q = Stream (x `div` y) (streamMap (`div` y) (xs - q * ys)) 138 | 139 | -- Infinte list of all Fibonacci numbers (computed using polynomials) 140 | fibs3 :: Stream Integer 141 | fibs3 = x / (1 - x - x*x) 142 | 143 | 144 | xTest :: Bool 145 | xTest = (show $ take 20 $ [0,1] ++ zeros) == show x 146 | where zeros = repeat (0 :: Integer) 147 | 148 | instanceNumTest :: Bool 149 | instanceNumTest = and 150 | [ 151 | (show . take 20 $ [0,2] ++ zeros) == show (x + x), 152 | (show . take 20 $ [0,0,1] ++ zeros) == show (x * x), 153 | (show . take 20 $ [0,-1] ++ zeros) == show (negate x), 154 | (show . take 20 $ [5] ++ zeros) == show fromInteger5 155 | ] 156 | where zeros = repeat (0 :: Integer) 157 | fromInteger5 = (fromInteger 5) :: Stream Integer 158 | 159 | instanceFractionalTest :: Bool 160 | instanceFractionalTest = and 161 | [ 162 | (show . take 20 $ [0,1] ++ zeros) == (show $ x / 1), 163 | (show . take 20 $ [3,1] ++ zeros) == (show $ (x-3)*(x+3) / (x-3)) 164 | ] 165 | where zeros = repeat (0 :: Integer) 166 | 167 | fibs3Test :: Bool 168 | fibs3Test = (show $ take 20 fibs1) == show fibs3 169 | 170 | 171 | 172 | ---------------------------------- Exercise 7 ---------------------------------- 173 | 174 | data Matrix = Matrix { a00 :: Integer 175 | , a10 :: Integer 176 | , a01 :: Integer 177 | , a11 :: Integer 178 | } deriving (Show, Eq) 179 | 180 | instance Num Matrix where 181 | (Matrix a00 a10 a01 a11) + (Matrix a00' a10' a01' a11') = 182 | Matrix (a00 + a00') (a10 + a10') 183 | (a01 + a01') (a11 + a11') 184 | (Matrix a00 a10 a01 a11) * (Matrix a00' a10' a01' a11') = 185 | Matrix (a00*a00' + a10*a01') (a00*a10' + a10*a11') 186 | (a01*a00' + a11*a01') (a01*a10' + a11*a11') 187 | negate (Matrix a00 a10 a01 a11) = 188 | Matrix (-a00) (-a10) 189 | (-a01) (-a11) 190 | fromInteger n = Matrix n n n n 191 | 192 | fib4 :: Integer -> Integer 193 | fib4 0 = 0 194 | fib4 n = a01 (f^n) 195 | where f = Matrix 1 1 196 | 1 0 197 | 198 | 199 | instanceMatrixTest :: Bool 200 | instanceMatrixTest = and 201 | [ 202 | Matrix 2 4 6 8 == a + a, 203 | Matrix 7 10 15 22 == a * a, 204 | Matrix (-1) (-2) (-3) (-4) == -a, 205 | Matrix 5 5 5 5 == b 206 | ] 207 | where a = Matrix 1 2 208 | 3 4 209 | b = (fromInteger 5) :: Matrix 210 | 211 | fib4Test :: Bool 212 | fib4Test = take 20 fibs1 == (take 20 $ fib4 <$> [0..]) 213 | -------------------------------------------------------------------------------- /homework-06/README.md: -------------------------------------------------------------------------------- 1 | # Homework 6 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [Fibonacci.hs (file to submit)](Fibonacci.hs) 6 | 7 | In this homework we work with [Fibonacci numbers](https://en.wikipedia.org/wiki/Fibonacci_number). 8 | 9 | ## Exercise 1 10 | 11 | Usually, the first approach we take when dealing with Fibonacci numbers is to translate its definition directly into a recursive (and very inefficient) function, and this homework is not an exception. The function `fib :: Integer -> Integer` returns the *n*-th Fibonacci number: 12 | 13 | ```haskell 14 | fib :: Integer -> Integer 15 | fib 0 = 0 16 | fib 1 = 1 17 | fib n = fib (n-1) + fib (n-2) 18 | ``` 19 | 20 | The function `fibs1 :: [Integer]` generates the infinite list of Fibonacci numbers: 21 | 22 | ```haskell 23 | fibs1 :: [Integer] 24 | fibs1 = fib <$> [0..] 25 | ``` 26 | 27 | By the way, by evaluating `fibs1` on the GHCi you can actually see how slow `fib` is. Usually, when printing an infinite list you quickly interrupt the execution. On the contrary, here you have plenty of time to do it! 28 | 29 | ## Exercise 2 30 | 31 | Obviously the next step to take is to implement a more efficient solution. The function `fibs2 :: [Integer]` generates the same list as `fibs1` but it requires only *O(n)* operations to compute the first *n* elements. By taking advantage of Haskell's lazy evaluation, we can come up with the following solution: 32 | 33 | ```haskell 34 | fibs2 :: [Integer] 35 | fibs2 = 0 : 1 : zipWith (+) fibs2 (tail fibs2) 36 | ``` 37 | 38 | `fibs2` starts being `[0,1]` and to obtain the following element we call `fibs2` recursively, and we do it twice. Let's think about how the third element is generated. Initially, `fibs2` is `[0,1]` and `tail fibs2` is `[1]`, so we can already start computing the `zipWith` function with those two lists to generate `0+1 = 1`. Now, `fibs2` is the list `[0,1,1]`. `zipWith` continues with `[0,1,1]` and `[0,1]` to generate `[0,1,1,2]`, and so on. 39 | 40 | In summary, this definition can be read as: start with `[0,1]` and, to generate the rest of the Fibonacci sequence, take the Fibonacci sequence up to now (which represents F*n-1*) and sum it with the Fibonacci sequence up to now shifted one position to the left (which represents F*n-2*). 41 | 42 | Probably this is not the best explanation ever, so visit [this](https://stackoverflow.com/questions/6273621/understanding-a-recursively-defined-list-fibs-in-terms-of-zipwith) if you want a more detailed explanation. 43 | 44 | ## Exercise 3 45 | 46 | We are asked to design a polymorphic data type named `Stream`. It represents an infinite list, so a stream can be seen as an element followed by a stream. 47 | 48 | First we must create the `Stream` data type. In Haskell we can define recursive data structures, so it is as easy as that: 49 | 50 | ```haskell 51 | data Stream a = Stream a (Stream a) 52 | ``` 53 | 54 | Note that the `Stream` right after the equals is the value constructor (in green), which can be different from the data type, but in this case I couldn't figure a better name. 55 | 56 | The function `streamToList :: Stream a -> [a]` converts a stream into an infinite list: 57 | 58 | ```haskell 59 | streamToList :: Stream a -> [a] 60 | streamToList (Stream x xs) = x : streamToList xs 61 | ``` 62 | 63 | Finally, we must make `Stream` instance of `Show` type class in order to visualize it. But how can we visualize an infinite structure? Well, we can just print a prefix of the stream, for example its 20 first elements. For convenience, we transform the stream into a list: 64 | 65 | ```haskell 66 | instance Show a => Show (Stream a) where 67 | show = show . take 20 . streamToList 68 | ``` 69 | 70 | ## Exercise 4 71 | 72 | Now we can start working with streams. To do that, in the first place we must create a function that generates a stream. The function `streamRepeat :: a -> Stream a` generates a stream containing infinitely many copies of the given element: 73 | 74 | ```haskell 75 | streamRepeat :: a -> Stream a 76 | streamRepeat x = Stream x (streamRepeat x) 77 | ``` 78 | 79 | The function `streamMap :: (a -> b) -> Stream a -> Stream b` applies a function to every element of the stream, acting like `map :: (a -> b) -> [a] -> [b]` for lists: 80 | 81 | ```haskell 82 | streamMap :: (a -> b) -> Stream a -> Stream b 83 | streamMap f (Stream x xs) = Stream (f x) (streamMap f xs) 84 | ``` 85 | 86 | The function `streamFromSeed :: (a -> a) -> a -> Stream a` generates a stream from a seed and a rule which specifies how to transform the seed into a new seed which is used for generating the rest of the stream. In other words, this is similar to the `iterate :: (a -> a) -> a -> [a]` function for lists: 87 | 88 | ```haskell 89 | streamFromSeed :: (a -> a) -> a -> Stream a 90 | streamFromSeed f x = Stream x (streamFromSeed f (f x)) 91 | ``` 92 | 93 | ## Exercise 5 94 | 95 | The function `nats :: Stream Integer` generates an infinite list of natural numbers starting from 0: 96 | 97 | ```haskell 98 | nats :: Stream Integer 99 | nats = streamFromSeed (+1) 0 100 | ``` 101 | 102 | The function `ruler :: Stream Integer` generates the [ruler function](http://oeis.org/A007814). The real challenge was to do it without using any kind of divisibility testing and I ended up searching how to do it. I managed to find an [answer](https://codereview.stackexchange.com/a/66811) which is worth reading. 103 | 104 | First of all we define a function `interleaveStreams :: Stream a -> Stream a -> Stream a` which alternates the elements from two streams. My first implementation was the following: 105 | 106 | ```haskell 107 | interleaveStreams :: Stream a -> Stream a -> Stream a 108 | interleaveStreams (Stream x xs) (Stream y ys) = Stream x (Stream y $ interleaveStreams xs ys) 109 | ``` 110 | 111 | I tried it and it worked, so I moved on to the `ruler :: Stream Integer` function. But when I implemented `ruler` the following way, it never ended (read the [answer](https://codereview.stackexchange.com/a/66811) I previously mentioned to why this works): 112 | 113 | ```haskell 114 | ruler :: Stream Integer 115 | ruler = foldr1 interleaveStreams1 (streamRepeat <$> [0..]) 116 | ``` 117 | 118 | I thought that the problem was in the `foldr1` (which is just a `foldr` that uses the last element of the list as initial element) but in reality the problem ended up being in `interleaveStreams`. The problem is that with the above implementation, both streams are evaluated which breaks Haskell's lazyness. We can reimplement `interleaveStreams` by only evaluating the element of the first stream, and we can just get the following element later: 119 | 120 | ```haskell 121 | interleaveStreams :: Stream a -> Stream a -> Stream a 122 | interleaveStreams (Stream x xs) ys = Stream x (interleaveStreams ys xs) 123 | ``` 124 | 125 | With that change, `ruler` works as intended! Indeed, the `foldr1` will look like this: `interleave (streamRepeat 0) (interleave (streamRepeat 1) (interleave (streamRepeat 2) ...))`. Then, `interleave (streamRepeat 0) X` can be evaluated since `X` will just be a [thunk](https://wiki.haskell.org/Thunk), so we can continue with our computation. Next, we can evaluate `interleave (streamRepeat 1) Y` and so on. 126 | 127 | It is definitely worth it to stop here and fully understand this exercise, it took me a while to do it but it made me learn a lot. 128 | 129 | ## Exercise 6 130 | 131 | The idea of this exercise is to work with polynomials. We will store the coefficients in a `Stream Integer`. 132 | 133 | The function `x :: Stream Integer` returns the monomial of degree 1 and coefficient 1, that is, *x*. Since the function is named `x`, I had to add the `-fno-warn-name-shadowing` to turn off `-Wname-shadowing` warning. To generate the coefficients of `x`, we just have to start with zero, then one, and fill the rest of the stream with zeros: 134 | 135 | ```haskell 136 | x :: Stream Integer 137 | x = Stream 0 . Stream 1 $ streamRepeat 0 138 | ``` 139 | 140 | Next we had to make `Stream Integer` an instance of `Num` type class. For that, we must implement the functions that `Num` defines. We can take a look at what those functions look like: 141 | 142 | ```haskell 143 | class Num a where 144 | (+) :: a -> a -> a 145 | (-) :: a -> a -> a 146 | (*) :: a -> a -> a 147 | negate :: a -> a 148 | abs :: a -> a 149 | signum :: a -> a 150 | fromInteger :: Integer -> a 151 | ``` 152 | 153 | Since we will not implement all of them, we will add the `-fno-warn-missing-methods` at the beginning of the file. The implementation is the following: 154 | 155 | ```haskell 156 | instance Num (Stream Integer) where 157 | (Stream x xs) + (Stream y ys) = Stream (x+y) (xs + ys) 158 | (Stream x xs) * s@(Stream y ys) = Stream (x*y) (streamMap (*x) ys + (xs * s)) 159 | negate = streamMap negate 160 | fromInteger n = Stream n $ streamRepeat 0 161 | ``` 162 | 163 | Note that when we define `(+)`, we use both the `(+) :: Integer -> Integer -> Integer` and the `(+) :: Stream Integer -> Stream Integer -> Stream Integer` functions. The `x+y` corresponds to the first one whereas the `(xs + ys)` to the second one. Thus, we define `(+)` recursively. The same case happens for `(*)`. Finally, note that the signature of the `negate` that is on the left side is `negate :: Stream Integer -> Stream Integer` while the one that is on the right side is `negate :: Integer -> Integer`. 164 | 165 | The next step is to declare `Stream Integer` an instance of `Fractional` in order to define how `(/)` works for polynomials. We just have to implement the formula that is given to us (note that *q* variable is defined recursively): 166 | 167 | ```haskell 168 | instance Fractional (Stream Integer) where 169 | (Stream x xs) / (Stream y ys) = q 170 | where q = Stream (x `div` y) (streamMap (`div` y) (xs - q * ys)) 171 | ``` 172 | 173 | Finally, with the previous operations we have defined for polynomials, we can define Fibonacci sequence the following way: 174 | 175 | ```haskell 176 | fibs3 :: Stream Integer 177 | fibs3 = x / (1 - x - x*x) 178 | ``` 179 | 180 | ## Exercise 7 181 | 182 | In the last exercise we create a `Matrix` data type in order to represent 2 x 2 matrices of integers. We will use matrix binary exponentiation to compute the *n*th Fibonacci number in *O*(log n). 183 | 184 | First of all we define the `Matrix` data type using record syntax in order to easily lookup its fields: 185 | 186 | ```haskell 187 | data Matrix = Matrix { a00 :: Integer 188 | , a10 :: Integer 189 | , a01 :: Integer 190 | , a11 :: Integer 191 | } deriving (Show, Eq) 192 | ``` 193 | 194 | Next we must make `Matrix` an instance of `Num` which is easy for 2 x 2 matrices: 195 | 196 | ```haskell 197 | instance Num Matrix where 198 | (Matrix a00 a10 a01 a11) + (Matrix a00' a10' a01' a11') = 199 | Matrix (a00 + a00') (a10 + a10') 200 | (a01 + a01') (a11 + a11') 201 | (Matrix a00 a10 a01 a11) * (Matrix a00' a10' a01' a11') = 202 | Matrix (a00*a00' + a10*a01') (a00*a10' + a10*a11') 203 | (a01*a00' + a11*a01') (a01*a10' + a11*a11') 204 | negate (Matrix a00 a10 a01 a11) = 205 | Matrix (-a00) (-a10) 206 | (-a01) (-a11) 207 | fromInteger n = Matrix n n n n 208 | ``` 209 | 210 | Finally we can compute the *n*th Fibonacci number just by raising a matrix: 211 | 212 | ```haskell 213 | fib4 :: Integer -> Integer 214 | fib4 0 = 0 215 | fib4 n = a01 (f^n) 216 | where f = Matrix 1 1 217 | 1 0 218 | ``` 219 | -------------------------------------------------------------------------------- /homework-06/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-06/assignment.pdf -------------------------------------------------------------------------------- /homework-07/Buffer.hs: -------------------------------------------------------------------------------- 1 | module Buffer where 2 | 3 | -- Type class for data structures that can represent the text buffer 4 | -- of an editor. 5 | 6 | class Buffer b where 7 | 8 | -- | Convert a buffer to a String. 9 | toString :: b -> String 10 | 11 | -- | Create a buffer from a String. 12 | fromString :: String -> b 13 | 14 | -- | Extract the nth line (0-indexed) from a buffer. Return Nothing 15 | -- for out-of-bounds indices. 16 | line :: Int -> b -> Maybe String 17 | 18 | -- | @replaceLine n ln buf@ returns a modified version of @buf@, 19 | -- with the @n@th line replaced by @ln@. If the index is 20 | -- out-of-bounds, the buffer should be returned unmodified. 21 | replaceLine :: Int -> String -> b -> b 22 | 23 | -- | Compute the number of lines in the buffer. 24 | numLines :: b -> Int 25 | 26 | -- | Compute the value of the buffer, i.e. the amount someone would 27 | -- be paid for publishing the contents of the buffer. 28 | value :: b -> Int 29 | -------------------------------------------------------------------------------- /homework-07/Editor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving 2 | , ScopedTypeVariables 3 | #-} 4 | module Editor where 5 | 6 | import System.IO 7 | 8 | import Buffer 9 | 10 | import Control.Exception 11 | import Control.Monad.State 12 | 13 | import Control.Applicative 14 | import Control.Arrow (first, second) 15 | 16 | import Data.Char 17 | import Data.List 18 | 19 | -- Editor commands 20 | 21 | data Command = View 22 | | Edit 23 | | Load String 24 | | Line Int 25 | | Next 26 | | Prev 27 | | Quit 28 | | Help 29 | | Noop 30 | deriving (Eq, Show, Read) 31 | 32 | commands :: [String] 33 | commands = map show [View, Edit, Next, Prev, Quit] 34 | 35 | -- Editor monad 36 | 37 | newtype Editor b a = Editor (StateT (b,Int) IO a) 38 | deriving (Functor, Applicative, Monad, MonadIO, MonadState (b,Int)) 39 | 40 | runEditor :: Buffer b => Editor b a -> b -> IO a 41 | runEditor (Editor e) b = evalStateT e (b,0) 42 | 43 | getCurLine :: Editor b Int 44 | getCurLine = gets snd 45 | 46 | setCurLine :: Int -> Editor b () 47 | setCurLine = modify . second . const 48 | 49 | onBuffer :: (b -> a) -> Editor b a 50 | onBuffer f = gets (f . fst) 51 | 52 | getBuffer :: Editor b b 53 | getBuffer = onBuffer id 54 | 55 | modBuffer :: (b -> b) -> Editor b () 56 | modBuffer = modify . first 57 | 58 | io :: MonadIO m => IO a -> m a 59 | io = liftIO 60 | 61 | -- Utility functions 62 | 63 | readMay :: Read a => String -> Maybe a 64 | readMay s = case reads s of 65 | [(r,_)] -> Just r 66 | _ -> Nothing 67 | 68 | -- Main editor loop 69 | 70 | editor :: Buffer b => Editor b () 71 | editor = io (hSetBuffering stdout NoBuffering) >> loop 72 | where loop = do prompt 73 | cmd <- getCommand 74 | when (cmd /= Quit) (doCommand cmd >> loop) 75 | 76 | prompt :: Buffer b => Editor b () 77 | prompt = do 78 | s <- onBuffer value 79 | io $ putStr (show s ++ "> ") 80 | 81 | getCommand :: Editor b Command 82 | getCommand = io $ readCom <$> getLine 83 | where 84 | readCom "" = Noop 85 | readCom inp@(c:cs) | isDigit c = maybe Noop Line (readMay inp) 86 | | toUpper c == 'L' = Load (unwords $ words cs) 87 | | c == '?' = Help 88 | | otherwise = maybe Noop read $ 89 | find ((== toUpper c) . head) commands 90 | 91 | doCommand :: Buffer b => Command -> Editor b () 92 | doCommand View = do 93 | cur <- getCurLine 94 | let ls = [(cur - 2) .. (cur + 2)] 95 | ss <- mapM (\l -> onBuffer $ line l) ls 96 | zipWithM_ (showL cur) ls ss 97 | where 98 | showL _ _ Nothing = return () 99 | showL l n (Just s) = io $ putStrLn (m ++ show n ++ ": " ++ s) 100 | where m | n == l = "*" 101 | | otherwise = " " 102 | 103 | doCommand Edit = do 104 | l <- getCurLine 105 | io $ putStr $ "Replace line " ++ show l ++ ": " 106 | new <- io getLine 107 | modBuffer $ replaceLine l new 108 | 109 | doCommand (Load filename) = do 110 | mstr <- io $ handle (\(_ :: IOException) -> 111 | putStrLn "File not found." >> return Nothing 112 | ) $ do 113 | h <- openFile filename ReadMode 114 | hSetEncoding h utf8 115 | Just <$> hGetContents h 116 | maybe (return ()) (modBuffer . const . fromString) mstr 117 | 118 | doCommand (Line n) = modCurLine (const n) >> doCommand View 119 | 120 | doCommand Next = modCurLine (+1) >> doCommand View 121 | doCommand Prev = modCurLine (subtract 1) >> doCommand View 122 | 123 | doCommand Quit = return () -- do nothing, main loop notices this and quits 124 | 125 | doCommand Help = io . putStr . unlines $ 126 | [ "v --- view the current location in the document" 127 | , "n --- move to the next line" 128 | , "p --- move to the previous line" 129 | , "l --- load a file into the editor" 130 | , "e --- edit the current line" 131 | , "q --- quit" 132 | , "? --- show this list of commands" 133 | ] 134 | 135 | doCommand Noop = return () 136 | 137 | inBuffer :: Buffer b => Int -> Editor b Bool 138 | inBuffer n = do 139 | nl <- onBuffer numLines 140 | return (n >= 0 && n < nl) 141 | 142 | modCurLine :: Buffer b => (Int -> Int) -> Editor b () 143 | modCurLine f = do 144 | l <- getCurLine 145 | nl <- onBuffer numLines 146 | setCurLine . max 0 . min (nl - 1) $ f l 147 | -------------------------------------------------------------------------------- /homework-07/JoinList.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} 4 | 5 | module JoinList where 6 | 7 | import Data.Monoid 8 | import Buffer 9 | import Sized 10 | import Scrabble 11 | import Editor 12 | 13 | 14 | data JoinList m a = Empty 15 | | Single m a 16 | | Append m (JoinList m a) (JoinList m a) 17 | deriving (Eq, Show) 18 | 19 | 20 | ---------------------------------- Exercise 1 ---------------------------------- 21 | 22 | -- Append two JoinLists 23 | (+++) :: Monoid m => JoinList m a -> JoinList m a -> JoinList m a 24 | jl1 +++ jl2 = Append (tag jl1 <> tag jl2) jl1 jl2 25 | 26 | -- Get the annotation at the root of a JoinList 27 | tag :: Monoid m => JoinList m a -> m 28 | tag Empty = mempty 29 | tag (Single m _) = m 30 | tag (Append m _ _) = m 31 | 32 | 33 | appendTest :: Bool 34 | appendTest = and 35 | [ 36 | Append mempty empty empty == empty +++ empty, 37 | Append "a" singleA empty == singleA +++ empty, 38 | Append "ab" appendAB empty == appendAB +++ empty, 39 | Append "aba" appendAB singleA == appendAB +++ singleA, 40 | Append "ab" singleA singleB == singleA +++ singleB, 41 | Append "abba" appendAB appendBA == appendAB +++ appendBA 42 | ] 43 | where empty = (Empty :: JoinList String Char) 44 | singleA = Single "a" 'a' 45 | singleB = Single "b" 'b' 46 | appendAB = Append "ab" singleA singleB 47 | appendBA = Append "ba" singleB singleA 48 | 49 | tagTest :: Bool 50 | tagTest = and 51 | [ 52 | "" == tag Empty, 53 | "a" == tag (Single "a" 'a'), 54 | "ab" == tag (Append "ab" (Single "a" 'a') (Single "b" 'b')) 55 | ] 56 | 57 | 58 | ---------------------------------- Exercise 2 ---------------------------------- 59 | 60 | 61 | -- Get the Int value of a Sized tag 62 | getSizeTag :: (Monoid b, Sized b) => JoinList b a -> Int 63 | getSizeTag = getSize . size . tag 64 | 65 | -- Finds the JoinList element at the specified index 66 | indexJ :: (Sized b, Monoid b) => Int -> JoinList b a -> Maybe a 67 | indexJ _ Empty = Nothing 68 | indexJ i _ | i < 0 = Nothing 69 | indexJ i jl | i >= getSizeTag jl = Nothing 70 | indexJ _ (Single _ a) = Just a 71 | indexJ i (Append _ jl1 jl2) 72 | | i < left = indexJ i jl1 73 | | otherwise = indexJ (i - left) jl2 74 | where left = getSizeTag jl1 75 | 76 | -- Drops the first n elements from a JoinList 77 | dropJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a 78 | dropJ _ Empty = Empty 79 | dropJ n jl | n <= 0 = jl 80 | dropJ n jl | n >= getSizeTag jl = Empty 81 | dropJ _ (Single _ _) = Empty 82 | dropJ n (Append _ jl1 jl2) 83 | | n < left = dropJ n jl1 +++ jl2 84 | | otherwise = dropJ (n - left) jl2 85 | where left = getSizeTag jl1 86 | 87 | -- Returns the first n elements from a JoinList 88 | takeJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a 89 | takeJ _ Empty = Empty 90 | takeJ n _ | n <= 0 = Empty 91 | takeJ n jl | n >= getSizeTag jl = jl 92 | takeJ _ jl@(Single _ _) = jl 93 | takeJ n (Append _ jl1 jl2) 94 | | n < left = takeJ n jl1 95 | | otherwise = jl1 +++ takeJ (n - left) jl2 96 | where left = getSizeTag jl1 97 | 98 | -- Safe list indexing function (provided) 99 | (!!?) :: [a] -> Int -> Maybe a 100 | [] !!? _ = Nothing 101 | _ !!? i | i < 0 = Nothing 102 | (x:_) !!? 0 = Just x 103 | (_:xs) !!? i = xs !!? (i-1) 104 | 105 | -- Convert a JoinList into a list ignoring monoidal annotations (provided) 106 | jlToList :: JoinList m a -> [a] 107 | jlToList Empty = [] 108 | jlToList (Single _ a) = [a] 109 | jlToList (Append _ l1 l2) = jlToList l1 ++ jlToList l2 110 | 111 | 112 | indexJTest :: Bool 113 | indexJTest = and 114 | [ 115 | jlToList jl !!? i == indexJ i jl | 116 | i <- [(-10)..10], 117 | jl <- [empty, singleA, appendAB, appendABC] 118 | ] 119 | where empty = (Empty :: JoinList Size Char) 120 | singleA = Single (Size 1) 'a' 121 | singleB = Single (Size 1) 'b' 122 | singleC = Single (Size 1) 'c' 123 | appendAB = Append (Size 2) singleA singleB 124 | appendABC = Append (Size 3) appendAB singleC 125 | 126 | dropJTest :: Bool 127 | dropJTest = and 128 | [ 129 | drop i (jlToList jl) == jlToList (dropJ i jl) | 130 | i <- [(-10)..10], 131 | jl <- [empty, singleA, appendAB, appendABC] 132 | ] 133 | where empty = (Empty :: JoinList Size Char) 134 | singleA = Single (Size 1) 'a' 135 | singleB = Single (Size 1) 'b' 136 | singleC = Single (Size 1) 'c' 137 | appendAB = Append (Size 2) singleA singleB 138 | appendABC = Append (Size 3) appendAB singleC 139 | 140 | takeJTest :: Bool 141 | takeJTest = and 142 | [ 143 | take i (jlToList jl) == jlToList (takeJ i jl) | 144 | i <- [(-10)..10], 145 | jl <- [empty, singleA, appendAB, appendABC] 146 | ] 147 | where empty = (Empty :: JoinList Size Char) 148 | singleA = Single (Size 1) 'a' 149 | singleB = Single (Size 1) 'b' 150 | singleC = Single (Size 1) 'c' 151 | appendAB = Append (Size 2) singleA singleB 152 | appendABC = Append (Size 3) appendAB singleC 153 | 154 | 155 | ---------------------------------- Exercise 3 ---------------------------------- 156 | 157 | -- Return a JoinList with the score of the string as annotation 158 | scoreLine :: String -> JoinList Score String 159 | scoreLine s = Single (scoreString s) s 160 | 161 | 162 | scoreLineTest :: Bool 163 | scoreLineTest = and 164 | [ 165 | Single (Score 0) "" == scoreLine "", 166 | Single (Score 9) "yay " == scoreLine "yay " 167 | ] 168 | 169 | 170 | ---------------------------------- Exercise 4 ---------------------------------- 171 | 172 | instance Monoid m => Monoid (JoinList m a) where 173 | mempty = Empty 174 | mappend = (+++) 175 | 176 | instance Buffer (JoinList (Score, Size) String) where 177 | toString = unlines . jlToList 178 | fromString = mconcat . fmap createJoinList . lines 179 | where createJoinList s = Single (scoreString s, Size 1) s 180 | line = indexJ 181 | replaceLine n l b = takeJ n b +++ fromString l +++ dropJ (n+1) b 182 | numLines = getSizeTag 183 | value = getScore . fst . tag 184 | 185 | reify :: JoinList (Score, Size) String -> JoinList (Score, Size) String 186 | reify = id 187 | 188 | main :: IO() 189 | main = runEditor editor . reify . fromString $ unlines 190 | [ "This buffer is for notes you don't want to save, and for" 191 | , "evaluation of steam valve coefficients." 192 | , "To load a different file, type the character L followed" 193 | , "by the name of the file." 194 | ] 195 | -------------------------------------------------------------------------------- /homework-07/README.md: -------------------------------------------------------------------------------- 1 | # Homework 7 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [Editor.hs (provided)](Editor.hs) 6 | * [Buffer.hs (provided)](Buffer.hs) 7 | * [Sized.hs (provided)](Sized.hs) 8 | * [StringBuffer.hs (provided)](StringBuffer.hs) 9 | * [StringBufEditor.hs (provided)](StringBufEditor.hs) 10 | * [carol.txt (provided)](carol.txt) 11 | * [JoinList.hs (file to submit)](JoinList.hs) 12 | * [Scrabble.hs (file to submit)](Scrabble.hs) 13 | 14 | The set up of this homework is extensive, so I highly recommend to take a look at it if you need more context on how to solve each exercise. 15 | 16 | I will only show how `JoinList` is defined: 17 | 18 | ```haskell 19 | data JoinList m a = Empty 20 | | Single m a 21 | | Append m (JoinList m a) (JoinList m a) 22 | deriving (Eq, Show) 23 | ``` 24 | 25 | ## Exercise 1 26 | 27 | The first function we will implement is `(+++) :: Monoid m => JoinList m a -> JoinList m a -> JoinList m a` which appends two join-lists. The monoidal annotation of the new join-list is derived from the annotations of the two original join-lists. 28 | 29 | Note that we use the `Monoid` type class (if you are starting to worry, monoid is not the same as monad, so don't panic yet!). To understand in detail what a monoid is, visit [this](http://learnyouahaskell.com/functors-applicative-functors-and-monoids#monoids). 30 | 31 | Before implementing the append function, we are advised to implement a helper function `tag :: Monoid m => JoinList m a -> m` which justs gets the annotation of a `JoinList`. This is pretty easy: 32 | 33 | ```haskell 34 | tag :: Monoid m => JoinList m a -> m 35 | tag Empty = mempty 36 | tag (Single m _) = m 37 | tag (Append m _ _) = m 38 | ``` 39 | 40 | We can use the `mempty :: Monoid a => a` function since `m` is a `Monoid`. `mempty` is just a polymorphic constant that represents the identity value for a particular monoid. 41 | 42 | Now we are ready to implement the append function: 43 | 44 | ```haskell 45 | (+++) :: Monoid m => JoinList m a -> JoinList m a -> JoinList m a 46 | jl1 +++ jl2 = Append (tag jl1 <> tag jl2) jl1 jl2 47 | ``` 48 | 49 | Here we use the `(<>) :: Monoid m => m -> m -> m` function, which is just the infix form of `mappend`. This function takes two values from the same type and produces a new value. 50 | 51 | 52 | ## Exercise 2 53 | 54 | ### Initial solution 55 | 56 | The `indexJ :: (Sized b, Monoid b) => Int -> JoinList b a -> Maybe a` function finds the `JoinList` element at the specified index. We must implement this taking advantage of the annotations, which are instace of `Sized` typeclass. The structure of the function is similar to a search in a binary tree, except that here, apart from deciding whether the index we are looking for is in the left or the right join-list, we must update the index value if we visit the right one: 57 | 58 | ```haskell 59 | indexJ :: (Sized b, Monoid b) => Int -> JoinList b a -> Maybe a 60 | indexJ _ Empty = Nothing 61 | 62 | indexJ 0 (Single _ a) = Just a 63 | indexJ _ (Single _ _) = Nothing 64 | 65 | indexJ i (Append m jl1 jl2) 66 | | i < 0 || i >= root = Nothing 67 | | i < left = indexJ i jl1 68 | | otherwise = indexJ (i - left) jl2 69 | where root = getSize . size $ m 70 | left = getSize . size . tag $ jl1 71 | ``` 72 | 73 | Note that we assume that the join-list is well constructed, that is, the sizes in the annotations are consistent. Also, to transform an annotation into an `Int` we compose the functions `getSize :: Size -> Int` and `size :: Sized a => a -> Size`. 74 | 75 | The second function is `dropJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a` which drops the first *n* elements of the `JoinList`. It is similar to the `drop :: Int -> [a] -> [a]` function for lists. The difficulty here is that we cannot just remove the elements from the `JoinList`, we must also keep the annotations up to date. So, when we remove something, we must make sure that annotations keep being consistent. Before showing the solution, let's refresh how `drop` for lists could be implemented: 76 | 77 | ```haskell 78 | drop :: Int -> [a] -> [a] 79 | drop n xs | n <= 0 = xs 80 | drop _ [] = [] 81 | drop n (_:xs) = drop (n-1) xs 82 | ``` 83 | 84 | We can use the same idea for our `dropJ` implementation: 85 | 86 | ```haskell 87 | dropJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a 88 | dropJ n jl | n <= 0 = jl 89 | 90 | dropJ _ Empty = Empty 91 | 92 | dropJ _ (Single _ _) = Empty 93 | 94 | dropJ n (Append m jl1 jl2) 95 | | n >= root = Empty 96 | | n < left = dropJ n jl1 +++ jl2 97 | | otherwise = dropJ n jl1 +++ dropJ (n - left) jl2 98 | where root = getSize . size $ m 99 | left = getSize . size . tag $ jl1 100 | ``` 101 | 102 | Now you might wonder how do we make sure that the annotations are kept up to date. Well, the magic happens in `dropJ n jl1 +++ jl2` and `dropJ n jl1 +++ dropJ (n - left) jl2` expressions. We use the append operator that we have defined before in order to update the annotations. By the way, we compare `n` with `left`, which is the annotation on the left join-list, in order to know if we will have to modify or not the right join-list. If the answer is yes (which means that all the elements from the left list have been droppped), we cannot just use `n` as it is, we must subtract all the elements from the left. That's why we do `n - left`. 103 | 104 | Finally, the last function is `takeJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a` which returns the first *n* elements of the `JoinList`. In this case, it is similar to the `take :: Int -> [a] -> [a]` function: 105 | 106 | ```haskell 107 | take :: Int -> [a] -> [a] 108 | take n _ | n <= 0 = [] 109 | take _ [] = [] 110 | take n (x:xs) = x : take (n-1) xs 111 | ``` 112 | 113 | The implementation of `takeJ` has the same structure and the same ideas as `dropJ`: 114 | 115 | ```haskell 116 | takeJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a 117 | takeJ n _ | n <= 0 = Empty 118 | 119 | takeJ _ Empty = Empty 120 | 121 | takeJ _ jl@(Single _ _) = jl 122 | 123 | takeJ n jl@(Append m jl1 jl2) 124 | | n >= root = jl 125 | | n < left = takeJ n jl1 126 | | otherwise = takeJ n jl1 +++ takeJ (n - left) jl2 127 | where root = getSize . size $ m 128 | left = getSize . size . tag $ jl1 129 | ``` 130 | 131 | ### Reviewed solution 132 | 133 | After finishing the whole assignment, I checked [this](https://github.com/baugarten/CIS-194) repository and realised there was a more elegant and efficient solution. 134 | 135 | The first thing we notice is that I have used the same `where` clause in `indexJ`, `dropJ` and `takeJ`. We can define a function that does that: 136 | 137 | ```haskell 138 | getSizeTag :: (Monoid b, Sized b) => JoinList b a -> Int 139 | getSizeTag = getSize . size . tag 140 | ``` 141 | 142 | Next, in `dropJ` and `takeJ` we find the following expressions: `otherwise = dropJ n jl1 +++ dropJ (n - left) jl2` and `otherwise = takeJ n jl1 +++ takeJ (n - left) jl2`. When we end up in the otherwise guard, it means that `n >= left` in both cases. That means that we want to drop/take more elements than the size of the left join-list. But do we really need to make the recursive call? Not really, because we already know that we will end up dropping all the elements from the left join-list, so we could already write `otherwise = dropJ (n - left) jl2`. The same idea can be applied for take: we already know we will take all the elements from the left join-list, so we can write `otherwise = jl1 +++ takeJ (n - left) jl2`. 143 | 144 | Taking all of the previous considerations into account, let's see the reviewed versions of the functions. In `indexJ` we check the edge cases before pattern matching `Single` and `Append`. Note that when we pattern match `Single`, we are certain that the value of the index will be 0. 145 | 146 | ```haskell 147 | indexJ :: (Sized b, Monoid b) => Int -> JoinList b a -> Maybe a 148 | indexJ _ Empty = Nothing 149 | indexJ i _ | i < 0 = Nothing 150 | indexJ i jl | i >= getSizeTag jl = Nothing 151 | indexJ _ (Single _ a) = Just a 152 | indexJ i (Append _ jl1 jl2) 153 | | i < left = indexJ i jl1 154 | | otherwise = indexJ (i - left) jl2 155 | where left = getSizeTag jl1 156 | ``` 157 | 158 | In `dropJ`, we already discard the whole left join-list in `otherwise` clause. The structure is similar to `indexJ`: 159 | 160 | ```haskell 161 | dropJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a 162 | dropJ _ Empty = Empty 163 | dropJ n jl | n <= 0 = jl 164 | dropJ n jl | n >= getSizeTag jl = Empty 165 | dropJ _ (Single _ _) = Empty 166 | dropJ n (Append _ jl1 jl2) 167 | | n < left = dropJ n jl1 +++ jl2 168 | | otherwise = dropJ (n - left) jl2 169 | where left = getSizeTag jl1 170 | ``` 171 | 172 | Finally, `takeJ`: 173 | 174 | ```haskell 175 | takeJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a 176 | takeJ _ Empty = Empty 177 | takeJ n _ | n <= 0 = Empty 178 | takeJ n jl | n >= getSizeTag jl = jl 179 | takeJ _ jl@(Single _ _) = jl 180 | takeJ n (Append _ jl1 jl2) 181 | | n < left = takeJ n jl1 182 | | otherwise = jl1 +++ takeJ (n - left) jl2 183 | where left = getSizeTag jl1 184 | ``` 185 | 186 | By the way, having tests has made it really easy to refactor those methods, I'm glad I wrote them :) 187 | 188 | ## Exercise 3 189 | 190 | In this exercise we define a new type to represent the Scrabble score. The type is named `Score` and here is how it is implemented: 191 | 192 | ```haskell 193 | newtype Score = Score Int 194 | deriving (Eq, Ord, Show, Num) 195 | ``` 196 | 197 | Next we have to make `Score` an instance of Monoid: 198 | 199 | ```haskell 200 | instance Monoid Score where 201 | mempty = Score 0 202 | mappend = (+) 203 | ``` 204 | 205 | The function `score :: Char -> Score` returns the score of a character. Since characters have different scores, we define the score of each one in `scores :: [(Char,Int)]` which is just a constant. This format is appropriate as we can use the already defined function `lookup :: Eq a => a -> [(a, b)] -> Maybe b` to get the score associated with each character. 206 | 207 | ```haskell 208 | score :: Char -> Score 209 | score c = maybe 0 Score $ lookup (toUpper c) scores 210 | ``` 211 | 212 | Remember that the type signature of `maybe` is `b -> (a -> b) -> Maybe a -> b` so the type constructor `Score` is used as the `(a -> b)` function (the signature of `Score` is `Int -> Score`). 213 | 214 | Next we must define a function `scoreString :: String -> Score` which returns the score of a string. It is tempting to just do the following, since it works: 215 | 216 | ```haskell 217 | scoreString :: String -> Score 218 | scoreString = sum . fmap score 219 | ``` 220 | 221 | But that works because `Score` derives from `Num` and we know that to combine two scores we must add them. But at the beginning of this exercise we have made `Score` an instance of `Monoid` and we have already defined there how to combine two scores. So it is redundant to redefine this behaviour here. Instead, we can use the `mconcat :: Monoid a => [a] -> a` which will reduce all the scores into a single one, using the `mappend` operation that is defined inside `Score`. It is defined like this: `mconcat = foldr mappend mempty`. So the final solution is: 222 | 223 | ```haskell 224 | scoreString :: String -> Score 225 | scoreString = mconcat . fmap score 226 | ``` 227 | 228 | All in all, it looks almost the same but the meaning is totally different! Here we are just delegating the responsability to `Score`, taking advantage of the fact that it is a `Monoid`. For example, imagine that instead of adding the scores we want to multiply them, then we would just change `mappend = (+)` for `mappend = (*)` in the instance definition and we wouldn't have to change `scoreString`. 229 | 230 | To end the exercise, we must define `scoreLine :: String -> JoinList Score String` which returns a `JoinList` with the score of the string as annotation: 231 | 232 | ```haskell 233 | scoreLine :: String -> JoinList Score String 234 | scoreLine s = Single (scoreString s) s 235 | ``` 236 | 237 | ## Exercise 4 238 | 239 | The last exercise was to make the type `JoinList (Score, Size) String` an instance of `Buffer`. It was more challenging than it seems, but in the end the solution is pretty short since all the functions that were defined in previous exercises could be reused here: 240 | 241 | ```haskell 242 | instance Monoid m => Monoid (JoinList m a) where 243 | mempty = Empty 244 | mappend = (+++) 245 | 246 | instance Buffer (JoinList (Score, Size) String) where 247 | toString = unlines . jlToList 248 | fromString = mconcat . fmap createJoinList . lines 249 | where createJoinList s = Single (scoreString s, Size 1) s 250 | line = indexJ 251 | replaceLine n l b = takeJ n b +++ fromString l +++ dropJ (n+1) b 252 | numLines = getSize . snd . tag 253 | value = getScore . fst . tag 254 | ``` 255 | 256 | First off, we have also made `JoinList` an instance of `Monoid` in order to use `mconcat` in `fromString`. If you think about this, this makes sense since we have defined the concept of an empty element and the append operator for join-lists. Making use of `mconcat`, the solution of `fromString` is pretty consice. However, I think it is not the most efficient way to build the structure since we end up with an unbalanced tree. We set `Size 1` since each join-list we are creating is a line, and the second element of the annotation tracks the number of lines of the text. The other functions are pretty self-explanatory. 257 | 258 | To end the homework we must implement a `main` function. We can just take a look at how it is implemented in the provided [StringBufEditor.hs](StringBufEditor.hs) file and adapt it. In order to let the compiler know that we will work with the type `JoinList (Score, Size) String`, we create a helper function named `reify`. 259 | 260 | ```haskell 261 | reify :: JoinList (Score, Size) String -> JoinList (Score, Size) String 262 | reify = id 263 | 264 | main :: IO() 265 | main = runEditor editor . reify . fromString $ unlines 266 | [ "This buffer is for notes you don't want to save, and for" 267 | , "evaluation of steam valve coefficients." 268 | , "To load a different file, type the character L followed" 269 | , "by the name of the file." 270 | ] 271 | ``` 272 | -------------------------------------------------------------------------------- /homework-07/Scrabble.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | module Scrabble where 6 | 7 | import Data.Char 8 | 9 | 10 | ---------------------------------- Exercise 3 ---------------------------------- 11 | 12 | newtype Score = Score Int 13 | deriving (Eq, Ord, Show, Num) 14 | 15 | instance Monoid Score where 16 | mempty = Score 0 17 | mappend = (+) 18 | 19 | scores :: [(Char,Int)] 20 | scores = 21 | [ 22 | ('A',1),('E',1),('I',1),('L',1),('N',1),('O',1),('R',1),('S',1),('T',1),('U',1), 23 | ('D',2),('G',2), 24 | ('B',3),('C',3),('M',3),('P',3), 25 | ('F',4),('H',4),('V',4),('W',4),('Y',4), 26 | ('K',5), 27 | ('J',8),('X',8), 28 | ('Q',10),('Z',10) 29 | ] 30 | 31 | -- Return the score of a character 32 | score :: Char -> Score 33 | score c = maybe 0 Score $ lookup (toUpper c) scores 34 | 35 | -- Return the score of a string 36 | scoreString :: String -> Score 37 | scoreString = mconcat . fmap score 38 | 39 | getScore :: Score -> Int 40 | getScore (Score n) = n 41 | 42 | 43 | scoreTest :: Bool 44 | scoreTest = and 45 | [ 46 | Score 0 == score ' ', 47 | Score 0 == score '!', 48 | Score 1 == score 'a', 49 | Score 2 == score 'G', 50 | Score 8 == score 'x' 51 | ] 52 | 53 | scoreStringTest :: Bool 54 | scoreStringTest = and 55 | [ 56 | Score 0 == scoreString "", 57 | Score 9 == scoreString "yay ", 58 | Score 14 == scoreString "haskell!" 59 | ] 60 | -------------------------------------------------------------------------------- /homework-07/Sized.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-} 2 | module Sized where 3 | 4 | import Data.Monoid 5 | 6 | newtype Size = Size Int 7 | deriving (Eq, Ord, Show, Num) 8 | 9 | getSize :: Size -> Int 10 | getSize (Size i) = i 11 | 12 | class Sized a where 13 | size :: a -> Size 14 | 15 | instance Sized Size where 16 | size = id 17 | 18 | -- This instance means that things like 19 | -- (Foo, Size) 20 | -- (Foo, (Bar, Size)) 21 | -- ... 22 | -- are all instances of Sized. 23 | instance Sized b => Sized (a,b) where 24 | size = size . snd 25 | 26 | instance Monoid Size where 27 | mempty = Size 0 28 | mappend = (+) 29 | -------------------------------------------------------------------------------- /homework-07/StringBufEditor.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import StringBuffer 4 | import Editor 5 | 6 | main = runEditor editor $ unlines 7 | [ "This buffer is for notes you don't want to save, and for" 8 | , "evaluation of steam valve coefficients." 9 | , "To load a different file, type the character L followed" 10 | , "by the name of the file." 11 | ] 12 | -------------------------------------------------------------------------------- /homework-07/StringBuffer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} 2 | module StringBuffer where 3 | 4 | import Data.Monoid 5 | 6 | import Buffer 7 | 8 | instance Buffer String where 9 | toString = id 10 | fromString = id 11 | line n b = safeIndex n (lines b) 12 | replaceLine n l b = unlines . uncurry replaceLine' . splitAt n . lines $ b 13 | where replaceLine' pre [] = pre 14 | replaceLine' pre (_:ls) = pre ++ l:ls 15 | numLines = length . lines 16 | value = length . words 17 | 18 | safeIndex :: Int -> [a] -> Maybe a 19 | safeIndex n _ | n < 0 = Nothing 20 | safeIndex _ [] = Nothing 21 | safeIndex 0 (x:_) = Just x 22 | safeIndex n (_:xs) = safeIndex (n-1) xs -------------------------------------------------------------------------------- /homework-07/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-07/assignment.pdf -------------------------------------------------------------------------------- /homework-08/Employee.hs: -------------------------------------------------------------------------------- 1 | module Employee where 2 | 3 | import Data.Tree 4 | 5 | -- Employee names are represented by Strings. 6 | type Name = String 7 | 8 | -- The amount of fun an employee would have at the party, represented 9 | -- by an Integer 10 | type Fun = Integer 11 | 12 | -- An Employee consists of a name and a fun score. 13 | data Employee = Emp { empName :: Name, empFun :: Fun } 14 | deriving (Show, Read, Eq) 15 | 16 | -- A small company hierarchy to use for testing purposes. 17 | testCompany :: Tree Employee 18 | testCompany 19 | = Node (Emp "Stan" 9) 20 | [ Node (Emp "Bob" 2) 21 | [ Node (Emp "Joe" 5) 22 | [ Node (Emp "John" 1) [] 23 | , Node (Emp "Sue" 5) [] 24 | ] 25 | , Node (Emp "Fred" 3) [] 26 | ] 27 | , Node (Emp "Sarah" 17) 28 | [ Node (Emp "Sam" 4) [] 29 | ] 30 | ] 31 | 32 | testCompany2 :: Tree Employee 33 | testCompany2 34 | = Node (Emp "Stan" 9) 35 | [ Node (Emp "Bob" 3) -- (8, 8) 36 | [ Node (Emp "Joe" 5) -- (5, 6) 37 | [ Node (Emp "John" 1) [] -- (1, 0) 38 | , Node (Emp "Sue" 5) [] -- (5, 0) 39 | ] 40 | , Node (Emp "Fred" 3) [] -- (3, 0) 41 | ] 42 | , Node (Emp "Sarah" 17) -- (17, 4) 43 | [ Node (Emp "Sam" 4) [] -- (4, 0) 44 | ] 45 | ] 46 | 47 | -- A type to store a list of guests and their total fun score. 48 | data GuestList = GL [Employee] Fun 49 | deriving (Show, Eq) 50 | 51 | instance Ord GuestList where 52 | compare (GL _ f1) (GL _ f2) = compare f1 f2 53 | -------------------------------------------------------------------------------- /homework-08/Party.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} 2 | 3 | module Party where 4 | 5 | import Data.List 6 | import Data.Monoid 7 | import Data.Tree 8 | import Employee 9 | 10 | 11 | ---------------------------------- Exercise 1 ---------------------------------- 12 | 13 | -- Adds an employee to the guest list ignoring constraints 14 | glCons :: Employee -> GuestList -> GuestList 15 | glCons x (GL xs f) = GL (x:xs) (f + empFun x) 16 | 17 | instance Monoid GuestList where 18 | mempty = GL [] 0 19 | GL xs f1 `mappend` GL ys f2 = GL (xs ++ ys) (f1 + f2) 20 | 21 | -- Returns the guest list which has the higher fun score 22 | moreFun :: GuestList -> GuestList -> GuestList 23 | moreFun = max 24 | 25 | 26 | glConsTest :: Bool 27 | glConsTest = and 28 | [ 29 | GL [joe] 3 == glCons joe (GL [] 0), 30 | GL [sam,joe] 7 == glCons sam (GL [joe] 3), 31 | GL [sue,sam,joe] 8 == glCons sue (GL [sam,joe] 7) 32 | ] 33 | where joe = Emp "Joe" 3 34 | sam = Emp "Sam" 4 35 | sue = Emp "Sue" 1 36 | 37 | instanceTest :: Bool 38 | instanceTest = and 39 | [ 40 | GL [] 0 == mempty, 41 | GL [joe,sam] 7 == glCons joe mempty <> glCons sam mempty 42 | ] 43 | where joe = Emp "Joe" 3 44 | sam = Emp "Sam" 4 45 | 46 | moreFunTest :: Bool 47 | moreFunTest = and 48 | [ 49 | mempty == moreFun mempty mempty, 50 | GL [joe] 7 == moreFun (glCons joe mempty) (glCons joe mempty), 51 | GL [joe] 7 == moreFun (glCons joe mempty) (glCons sam mempty) 52 | ] 53 | where joe = Emp "Joe" 7 54 | sam = Emp "Sam" 4 55 | 56 | 57 | ---------------------------------- Exercise 2 ---------------------------------- 58 | 59 | -- Fold a Tree from the leaves to the root 60 | treeFold :: (a -> [b] -> b) -> Tree a -> b 61 | treeFold f (Node a sf) = f a (treeFold f <$> sf) 62 | 63 | 64 | treeFoldTest :: Bool 65 | treeFoldTest = and 66 | [ 67 | 8 == (treeFold (\_ xs -> 1 + sum xs) testCompany :: Integer), 68 | 17 == treeFold (\x xs -> max (empFun x) (myMaximum xs)) testCompany, 69 | 46 == treeFold (\x xs -> empFun x + sum xs) testCompany 70 | ] 71 | where myMaximum [] = 0 72 | myMaximum xs = maximum xs 73 | 74 | 75 | ---------------------------------- Exercise 3 ---------------------------------- 76 | 77 | -- Returns a pair of guest lists: 78 | -- * the first is the best list including the current boss 79 | -- * the second is the best list wihout including the current boss 80 | nextLevel :: Employee -> [(GuestList, GuestList)] -> (GuestList, GuestList) 81 | nextLevel boss gls = (glCons boss withoutBosses, withBosses) 82 | where withBosses = foldMap fst gls 83 | withoutBosses = foldMap snd gls 84 | 85 | 86 | nextLevelTest :: Bool 87 | nextLevelTest = (GL [joe] 5, gl) == nextLevel joe [(gl, mempty)] 88 | where joe = Emp "Joe" 5 89 | sam = Emp "Sam" 2 90 | sue = Emp "Sue" 2 91 | gl = GL [sam,sue] 4 92 | 93 | ---------------------------------- Exercise 4 ---------------------------------- 94 | 95 | -- Returns a guest list that maximizes the fun for the given tree 96 | maxFun :: Tree Employee -> GuestList 97 | maxFun = uncurry moreFun . treeFold nextLevel 98 | 99 | 100 | maxFunTest :: Bool 101 | maxFunTest = and 102 | [ 103 | GL [joe] 5 == maxFun (Node joe []), 104 | GL [sam,sue] 6 == maxFun (Node joe [Node sam [], Node sue []]) 105 | ] 106 | where joe = Emp "Joe" 5 107 | sam = Emp "Sam" 3 108 | sue = Emp "Joe" 3 109 | 110 | ---------------------------------- Exercise 5 ---------------------------------- 111 | 112 | formatEmp :: [Employee] -> String 113 | formatEmp = unlines . sort . fmap empName 114 | 115 | formatGL :: GuestList -> String 116 | formatGL (GL xs fun) = "Total fun: " ++ show fun ++ "\n" ++ formatEmp xs 117 | 118 | main :: IO() 119 | main = do 120 | contents <- readFile "company.txt" 121 | putStr . formatGL . maxFun . read $ contents 122 | -------------------------------------------------------------------------------- /homework-08/README.md: -------------------------------------------------------------------------------- 1 | # Homework 8 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [Employee.hs (provided)](Employee.hs) 6 | * [company.txt (provided)](company.txt) 7 | * [Party.hs (file to submit)](Party.hs) 8 | 9 | In this homework we work with the following definitions: 10 | 11 | ```haskell 12 | type Name = String 13 | 14 | type Fun = Integer 15 | 16 | data Employee = Emp { empName :: Name, empFun :: Fun } 17 | deriving (Show, Read, Eq) 18 | 19 | data GuestList = GL [Employee] Fun 20 | deriving (Show, Eq) 21 | ``` 22 | 23 | For a more detailed explanation on what those types represent, read the [assignment](assignment.pdf). 24 | 25 | ## Exercise 1 26 | 27 | The function `glCons :: Employee -> GuestList -> GuestList` adds an employee to a guest list ignoring any constraints. We just have to pattern match the `GuestList` and add the employee. Note that we cons the new employee since it is more efficient than doing `xs ++ [x]`. We also use `empFun :: Employee -> Fun` to get the amout of fun of an employee: 28 | 29 | ```haskell 30 | glCons :: Employee -> GuestList -> GuestList 31 | glCons x (GL xs f) = GL (x:xs) (f + empFun x) 32 | ``` 33 | 34 | The second function is just about defining a `Monoid` instance for `GuestList`: 35 | 36 | ```haskell 37 | instance Monoid GuestList where 38 | mempty = GL [] 0 39 | GL xs f1 `mappend` GL ys f2 = GL (xs ++ ys) (f1 + f2) 40 | ``` 41 | 42 | The third function is `moreFun :: GuestList -> GuestList -> GuestList` which returns the guest list which has the higher fun score. If we take a look at [Employee.hs](Employee.hs) file, we see that the following instance is already defined: 43 | 44 | ```haskell 45 | instance Ord GuestList where 46 | compare (GL _ f1) (GL _ f2) = compare f1 f2 47 | ``` 48 | 49 | So we can just use `max :: Ord a => a -> a -> a` to do the job: 50 | 51 | ```haskell 52 | moreFun :: GuestList -> GuestList -> GuestList 53 | moreFun = max 54 | ``` 55 | 56 | ## Exercise 2 57 | 58 | In this exercise we had to implement a fold for the type `Tree` which is defined as follows in `Data.Tree` module: 59 | 60 | ```haskell 61 | data Tree a = Node {rootLabel :: a, subForest :: Forest a} 62 | type Forest a = [Tree a] 63 | ``` 64 | 65 | The signature of the function is not given to us, so we can take a look at how it was defined in the previous lecture: 66 | 67 | ```haskell 68 | data Tree a = Empty 69 | | Node (Tree a) a (Tree a) 70 | deriving (Show, Eq) 71 | 72 | treeFold :: b -> (b -> a -> b -> b) -> Tree a -> b 73 | treeFold e _ Empty = e 74 | treeFold e f (Node l x r) = f (treeFold e f l) x (treeFold e f r) 75 | ``` 76 | 77 | First of all we realise that the data types for `Tree` are different. In the former we can't represent an empty tree, since the smallest tree that can be represented is `Node a []`, which is a leaf. So we do not need a base element in the fold function, since we will always start with the leaves. From that we can deduce that in our case the signature will be: `treeFold :: (a -> [b] -> b) -> Tree a -> b` and its implementation is: 78 | 79 | ```haskell 80 | treeFold :: (a -> [b] -> b) -> Tree a -> b 81 | treeFold f (Node a sf) = f a (treeFold f <$> sf) 82 | ``` 83 | 84 | Note that in order to fold a node, we fold each sub forest of that node and then we combine the results with the function `a -> [b] -> b`, where `a` is the root label of the current node and `[b]` are the results of folding each sub forest. So we are folding from the leaves to the root. 85 | 86 | ## Exercise 3 87 | 88 | The function `nextLevel :: Employee -> [(GuestList, GuestList)] -> (GuestList, GuestList)` looks intimidating at first but at the end of the day it is not that difficult to implement: 89 | 90 | ```haskell 91 | nextLevel :: Employee -> [(GuestList, GuestList)] -> (GuestList, GuestList) 92 | nextLevel boss gls = (glCons boss withoutBosses, withBosses) 93 | where withBosses = mconcat $ fst <$> gls 94 | withoutBosses = mconcat $ snd <$> gls 95 | ``` 96 | 97 | We merge all the first elements from `gls`, which are subtrees with bosses, into one guest list and we just let it go through as the second element of the result. Indeed, if we decide to take all the bosses from the subtree, we can't pick the boss of the current node. Meanwhile, we also merge all the second elements from `gls`, which are subtrees without bosses, and we add the boss of the current node. Finally, I realised that the following function exists: 98 | 99 | ```haskell 100 | foldMap :: Monoid m => (a -> m) -> [a] -> m 101 | foldMap g = mconcat . fmap g 102 | ``` 103 | 104 | So there is a more elegant solution: 105 | 106 | ```haskell 107 | nextLevel :: Employee -> [(GuestList, GuestList)] -> (GuestList, GuestList) 108 | nextLevel boss gls = (glCons boss withoutBosses, withBosses) 109 | where withBosses = foldMap fst gls 110 | withoutBosses = foldMap snd gls 111 | ``` 112 | 113 | ## Exercise 4 114 | 115 | We now have to define `maxFun :: Tree Employee -> GuestList` which takes a tree and returns the guest list which maximizes the fun of the employees. It is kinda obvious that we have to make use of the `treeFold` function implemented before. It has the following signature if we use `maxFun` as fold function: `treeFold :: (Employee -> [(GuestList, GuestList)] -> (GuestList, GuestList)) -> Tree Employee -> (GuestList, GuestList)`. So it is pretty obvious that we can just use `nextLevel` as it is. 116 | 117 | The problem is that `treeFold nextLevel` returns a pair of guest lists, and `maxFun` needs to return a single one. Which one of the two should we take? Well, the one that maximizes the fun! We already have implemented `moreFun :: GuestList -> GuestList -> GuestList` and we want to apply it to `(GuestList, GuestList)`. We can use `uncurry :: (a -> b -> c) -> (a, b) -> c` which is already defined to help us to write a one-liner solution: 118 | 119 | ```haskell 120 | maxFun :: Tree Employee -> GuestList 121 | maxFun = uncurry moreFun . treeFold nextLevel 122 | ``` 123 | 124 | ## Exercise 5 125 | 126 | In this last exercise we had to read a company's hierarchy from [company.txt](company.txt) file and print a formatted list of the employees that should be invited to the party in order to maximize the amount of fun. Moreover, the output list must contain the names of the employees sorted by first name and one employee per line. 127 | 128 | This is the first time that we will use `IO` but it is pretty easy: we only have to read a file using `readFile :: FilePath -> IO String` and then print the result using `putStr :: String -> IO ()`. We will build a single `String` with all the result, so we will call `putStr` once. 129 | 130 | We have defined two functions to format `GuestList` and `[Employee]` as we want: 131 | 132 | ```haskell 133 | formatEmp :: [Employee] -> String 134 | formatEmp = unlines . sort . fmap empName 135 | 136 | formatGL :: GuestList -> String 137 | formatGL (GL xs fun) = "Total fun: " ++ show fun ++ "\n" ++ formatEmp xs 138 | ``` 139 | 140 | Then, the main function is pretty short: 141 | 142 | ```haskell 143 | main :: IO() 144 | main = do 145 | contents <- readFile "company.txt" 146 | putStr . formatGL . maxFun . read $ contents 147 | ``` 148 | 149 | Note that I have used a more readable way of dealing with `IO` than the one that was explained in the notes, but I had already read [this](http://learnyouahaskell.com/input-and-output) so for me it made more sense that way. 150 | 151 | Finally and for the record, at first I sorted `[Employee]` in those two alternative ways (then I realised it was simpler to project the name first and then sort, since we don't need to print the amount of fun of each employee in the result): 152 | 153 | ```haskell 154 | formatEmp :: [Employee] -> String 155 | formatEmp = unlines . fmap empName . sortOn empName 156 | 157 | formatEmp :: [Employee] -> String 158 | formatEmp = unlines . fmap empName . sortBy (compare `on` empName) 159 | ``` 160 | -------------------------------------------------------------------------------- /homework-08/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-08/assignment.pdf -------------------------------------------------------------------------------- /homework-09/README.md: -------------------------------------------------------------------------------- 1 | # Homework 9 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | 6 | No homework this week :bowtie: 7 | 8 | I took the opportunity to read [The Typeclassopedia](https://wiki.haskell.org/Typeclassopedia). 9 | -------------------------------------------------------------------------------- /homework-09/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-09/assignment.pdf -------------------------------------------------------------------------------- /homework-10/AParser.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module AParser where 4 | 5 | 6 | import Control.Applicative 7 | import Data.Char 8 | 9 | -- A parser for a value of type a is a function which takes a String 10 | -- represnting the input to be parsed, and succeeds or fails; if it 11 | -- succeeds, it returns the parsed value along with the remainder of 12 | -- the input. 13 | newtype Parser a = Parser { runParser :: String -> Maybe (a, String) } 14 | 15 | -- For example, 'satisfy' takes a predicate on Char, and constructs a 16 | -- parser which succeeds only if it sees a Char that satisfies the 17 | -- predicate (which it then returns). If it encounters a Char that 18 | -- does not satisfy the predicate (or an empty input), it fails. 19 | satisfy :: (Char -> Bool) -> Parser Char 20 | satisfy p = Parser f 21 | where 22 | f [] = Nothing -- fail on the empty input 23 | f (x:xs) -- check if x satisfies the predicate 24 | -- if so, return x along with the remainder 25 | -- of the input (that is, xs) 26 | | p x = Just (x, xs) 27 | | otherwise = Nothing -- otherwise, fail 28 | 29 | -- Using satisfy, we can define the parser 'char c' which expects to 30 | -- see exactly the character c, and fails otherwise. 31 | char :: Char -> Parser Char 32 | char c = satisfy (== c) 33 | 34 | {- For example: 35 | 36 | *Parser> runParser (satisfy isUpper) "ABC" 37 | Just ('A',"BC") 38 | *Parser> runParser (satisfy isUpper) "abc" 39 | Nothing 40 | *Parser> runParser (char 'x') "xyz" 41 | Just ('x',"yz") 42 | 43 | -} 44 | 45 | -- For convenience, we've also provided a parser for positive 46 | -- integers. 47 | posInt :: Parser Integer 48 | posInt = Parser f 49 | where 50 | f xs 51 | | null ns = Nothing 52 | | otherwise = Just (read ns, rest) 53 | where (ns, rest) = span isDigit xs 54 | 55 | 56 | ---------------------------------- Exercise 1 ---------------------------------- 57 | 58 | -- Applies a function to the first component of a tuple 59 | first :: (a -> b) -> (a, c) -> (b, c) 60 | first f (a, c) = (f a, c) 61 | 62 | instance Functor Parser where 63 | fmap f p = Parser $ fmap (first f) . runParser p 64 | 65 | 66 | ---------------------------------- Exercise 2 ---------------------------------- 67 | 68 | instance Applicative Parser where 69 | pure a = Parser $ \s -> Just (a, s) 70 | 71 | p1 <*> p2 = Parser p 72 | where p s = runParser p1 s >>= g 73 | g (f, r) = runParser (f <$> p2) r 74 | 75 | 76 | ---------------------------------- Exercise 3 ---------------------------------- 77 | 78 | -- A parser that expects the characters 'a' and 'b' 79 | abParser :: Parser (Char, Char) 80 | abParser = (,) <$> char 'a' <*> char 'b' 81 | 82 | -- Same as abParser excepts it returns () instead of characters 'a' and 'b' 83 | abParser_ :: Parser () 84 | abParser_ = const () <$> abParser 85 | 86 | -- A parser that expects two integers separated by a space 87 | intPair :: Parser [Integer] 88 | intPair = (\a _ b -> [a, b]) <$> posInt <*> char ' ' <*> posInt 89 | 90 | 91 | abParserTest :: Bool 92 | abParserTest = and 93 | [ 94 | Just (('a','b'), "cd") == runParser abParser "abcd", 95 | Nothing == runParser abParser "acbb" 96 | ] 97 | 98 | abParser_Test :: Bool 99 | abParser_Test = and 100 | [ 101 | Just ((),"cd") == runParser abParser_ "abcd", 102 | Nothing == runParser abParser_ "acbb" 103 | ] 104 | 105 | intPairTest :: Bool 106 | intPairTest = and 107 | [ 108 | Just ([123, 456], "") == runParser intPair "123 456", 109 | Just ([1, 2], " abc") == runParser intPair "1 2 abc", 110 | Nothing == runParser intPair "123,456", 111 | Nothing == runParser intPair "abc cde" 112 | ] 113 | 114 | 115 | ---------------------------------- Exercise 4 ---------------------------------- 116 | 117 | instance Alternative Parser where 118 | empty = Parser $ const Nothing 119 | 120 | p1 <|> p2 = Parser p 121 | where p s = runParser p1 s <|> runParser p2 s 122 | 123 | 124 | ---------------------------------- Exercise 5 ---------------------------------- 125 | 126 | -- A parser that expects either an integer or an uppercase character 127 | intOrUppercase :: Parser () 128 | intOrUppercase = const () <$> posInt <|> const () <$> satisfy isUpper 129 | 130 | 131 | intOrUppercaseTest :: Bool 132 | intOrUppercaseTest = and 133 | [ 134 | Just ((),"ab") == runParser intOrUppercase "123ab", 135 | Just ((),"b1") == runParser intOrUppercase "Ab1", 136 | Just ((),"AB") == runParser intOrUppercase "12AB", 137 | Nothing == runParser intOrUppercase "a123b" 138 | ] 139 | -------------------------------------------------------------------------------- /homework-10/README.md: -------------------------------------------------------------------------------- 1 | # Homework 10 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [AParser.hs (file to submit)](AParser.hs) 6 | 7 | In this assignment we work with [parsers](https://en.wikipedia.org/wiki/Parsing). We represent a parser the following way: 8 | 9 | ```haskell 10 | newtype Parser a = Parser { runParser :: String -> Maybe (a, String) } 11 | ``` 12 | 13 | Note that the field `runParser` is a function, which may be surprising at first. In previous exercises, fields where things like `String` or `Int`. Its type signature is `runParser :: Parser a -> String -> Maybe (a, String)` which means that given a parser it returns a function instead of a value. 14 | 15 | 16 | ## Exercise 1 17 | 18 | In this exercise we start by implementing the function `first :: (a -> b) -> (a, c) -> (b, c)`. What I love about this function is that the assignment doesn't tell us what it should do, but from the type signature we can already figure out how it should work: it takes a function `a -> b`, a tuple `(a, c)` and returns a new tuple with the function applied to its first component. It doesn't leave a room for alternative implementations. 19 | 20 | ```haskell 21 | first :: (a -> b) -> (a, c) -> (b, c) 22 | first f (a, c) = (f a, c) 23 | ``` 24 | 25 | Now, we have to make `Parser` an instance of `Functor` type class. I couldn't figure out how to do it and I ended up looking at [this solution](https://github.com/bschwb/cis194-solutions/blob/master/10-applicative-functors-part1/AParser.hs). 26 | 27 | ```haskell 28 | instance Functor Parser where 29 | fmap f p = Parser $ fmap (first f) . runParser p 30 | ``` 31 | 32 | Since I couldn't figure out the solution by myself, at least I made the effort to understand it. 33 | 34 | Let's start with the type signature of the function we must implement: `fmap :: (a -> b) -> Parser a -> Parser b`. In `fmap f p`, we bind `f` to `a -> b` and `p` to `Parser a` with field `runParser` of type `String -> Maybe (a, String)`. Now we have to return a `Parser b`, in other words, a parser with field `runParser` of type `String -> Maybe (b, String)`. So we only have to transform `Maybe (a, String)` into `Maybe (b, String)`. 35 | 36 | The signature of `first` is `(a -> b) -> (a, c) -> (b, c)` so we have `first f :: (a, c) -> (b, c)` which is a function that takes a tuple and returns a new one, with another first component. As it is, this function doesn't help that much. However, it it was `Maybe (a, c) -> Maybe (b, c)` it would be different. If we partially apply `fmap` to `first f`, we accomplish that: `fmap (first f) :: Maybe (a, c) -> Maybe (b, c)`. 37 | 38 | Finally, by doing `runParser p` we obtain `String -> Maybe (a, String)`. We have all the functions we need and we just need to glue them together. To do that, we use function composition: we take the output of `runParser p` and we feed it into `fmap (first f)`. So the final solution is: `fmap (first f) . runParser p`. 39 | 40 | I don't know if this exercise was indeed complicated or I got stuck, but usually the first exercise is simple and this one took me a while... 41 | 42 | ## Exercise 2 43 | 44 | ### Initial version 45 | 46 | In the second exercise we implement an `Applicative` instance for `Parser`. The functions we have to implement are `pure :: a -> f a` and `(<*>) :: f (a -> b) -> f a -> f b` where `f` is a `Functor`. In the previous exercise we made `Parser` an instance of `Functor`, so we are ready to start! 47 | 48 | Let's begin with the easiest function, which is `pure :: a -> Parser a`. This parser consumes no input and successfully produces a result of `a`: 49 | 50 | ```haskell 51 | instance Applicative Parser where 52 | pure a = Parser $ \s -> Just (a, s) 53 | ``` 54 | 55 | Nothing too fancy here: since we always succeed, we return a `Just` producing the result of `a` and we leave the input untouched. 56 | 57 | Now comes the hard part. It was kinda frustrating needing to take a look again at a [solution](https://github.com/bschwb/cis194-solutions/blob/master/10-applicative-functors-part1/AParser.hs). At least this time I only took a quick look and wrote the function by myself. 58 | 59 | ```haskell 60 | instance Applicative Parser where 61 | pure a = Parser $ \s -> Just (a, s) 62 | 63 | p1 <*> p2 = Parser p 64 | where p str = case runParser p1 str of 65 | Nothing -> Nothing 66 | Just (f, s) -> runParser (f <$> p2) s 67 | ``` 68 | 69 | Again, let's make sure that we fully understand the solution. First, the signature is `(<*>) :: Parser (a -> b) -> Parser a -> Parser b` which means that the first parser produces a function. I had to read many times the assignment to understand that! Probably it is clearer to look at the definition of a parser that produces a function: `Parser (a -> b) = Parser { runParser :: String -> Maybe ((a -> b), String) }`. It is just a regular parser that wraps a function, not that complicated at the end of the day! 70 | 71 | The second parameter is `Parser a = Parser { runParser :: String -> Maybe (a, String) }` and we want to apply the function `a -> b` to `a` in order to return the parser `Parser b = Parser { runParser :: String -> Maybe (b, String) }`. By the way, if either p1 or p2 fail, `p1 <*> p2` also should fail. 72 | 73 | Now we look at the implementation. First we define the function `p :: String -> Maybe (b, String)` which is the one that will have the parser we return. For convenience, we put the first argument `str` on the left. Then we run p1, which can either fail or consume some input and produce a function. If it fails, we just return `Nothing`. If not, we bind the function it produced to `f` and the remaining input to `s`. If we do `runParser p2 s` we get `Maybe (a, String)`. 74 | 75 | The final step is to take that `Maybe (a, String)` and transform it into `Maybe (b, String)`. Well, remember previous exercise? We can use the fact that `Parser` is a `Functor` to apply `fmap` to the parser. We call `runParser :: Parser a -> String -> Maybe (a, String)` with `f <$> p2` as first argument and `s` as second. That way, we run the transformed parser with the remaining input of the first one. 76 | 77 | ### Improved solution 78 | 79 | Even if the initial solution is already pretty clean, I wanted to get rid of the case clause. I was kinda convinced it was possible and thanks to that I learned how to use the operator `(>>=) :: Monad m => m a -> (a -> m b) -> m b` (Actually shame on me, because this was explained in the IO lecture, and I directly used `do` notation without understanding how `>>=` exactly worked. I guess I was put off by the `Monad` of the type signature...). 80 | 81 | So, I started to build a solution without using the case clause. My first approach was: 82 | 83 | ```haskell 84 | p1 <*> p2 = Parser p 85 | where p str = let res = runParser p1 str 86 | in fmap (\r -> runParser (fst r <$> p2) (snd r)) res 87 | ``` 88 | 89 | Obviously this doesn't work. The problem is that the expected type of `p` is `String -> Maybe (b, String)` and the actual type is `String -> Maybe (Maybe (b, String))`. A `Maybe` inside a `Maybe`, how annoying is that! I tried to make it work but there was no easy way of getting rid of that. The problem is that `res` is of type `Maybe ((a -> b), String)` and the function in `fmap` is `Maybe ((a -> b), String) -> Maybe (b, String)`. So indeed, the whole signature of `fmap` is `(Maybe ((a -> b), String) -> Maybe (b, String)) -> Maybe (Maybe ((a -> b), String)) -> Maybe (Maybe (b, String))`. 90 | 91 | Here is where `>>=` comes to the recue! The signature is `Maybe ((a -> b), String) -> (((a -> b), String) -> Maybe (b, String)) -> Maybe (b, String)`. So we just have to write a function of type `((a -> b), String) -> Maybe (b, String)`, which we called `g` in the solution: 92 | 93 | ```haskell 94 | p1 <*> p2 = Parser p 95 | where p s = runParser p1 s >>= g 96 | g (f, r) = runParser (f <$> p2) r 97 | ``` 98 | 99 | Finally, I just leave this [post](https://pbrisbin.com/posts/maybe_is_just_awesome/) which helped me to understand why `Maybe` is a `Monad` and how it can be used. 100 | 101 | ## Exercise 3 102 | 103 | After having completed the second exercise, we can start creating parsers in a more convenient way. 104 | 105 | The first parser we will create is `abParser :: Parser (Char, Char)` which expects the characters 'a' and 'b' and returns them as a pair, and it fails otherwise. There is a cool function to create tuples: `(,) :: a -> b -> (a, b)` (by adding commas, you add additional elements). Then, the solution is: 106 | 107 | ```haskell 108 | abParser :: Parser (Char, Char) 109 | abParser = (,) <$> char 'a' <*> char 'b' 110 | ``` 111 | 112 | Note that the expression `(,) <$> char 'a' <*> char 'b'` is equivalent to `((,) <$> char 'a') <*> char 'b'`. We first compute `(,) <$> char 'a'` which has type `Parser (Char -> (Char, Char))`. Then we apply `char 'b'` to that function and we obtain `Parser (Char, Char)`, which is what we want. 113 | 114 | Next we have to implement `abParser_ :: Parser ()` which acts the same way as the previous one except it returns `()` instead of the characters 'a' and 'b'. We have to transform `Parser (Char, Char)` into `Parser ()` so we can just use `fmap`. Note that we use `const :: a -> b -> a` to always return `()`: 115 | 116 | ```haskell 117 | abParser_ :: Parser () 118 | abParser_ = const () <$> abParser 119 | ``` 120 | 121 | The last parser to implement is `intPair :: Parser [Integer]` which expects two integers separated by a space and returns them as a list: 122 | 123 | ```haskell 124 | intPair :: Parser [Integer] 125 | intPair = (\a _ b -> [a, b]) <$> posInt <*> char ' ' <*> posInt 126 | ``` 127 | 128 | ## Exercise 4 129 | 130 | In this exercise we make `Parser` an instance of `Alternative` type class. We can take advantage of `Maybe` already having defined the `Alternative` type class: 131 | 132 | ```haskell 133 | instance Alternative Parser where 134 | empty = Parser $ const Nothing 135 | 136 | p1 <|> p2 = Parser p 137 | where p s = runParser p1 s <|> runParser p2 s 138 | ``` 139 | 140 | Note that instead of writing `\_ -> Nothing` we can write `const Nothing`. 141 | 142 | ## Exercise 5 143 | 144 | In the last exercise we implement a parser `intOrUppercase :: Parser ()` that expects either an integer or an uppercase character. It's easy using the `<|>` operator. By the way, note that the priority of `<|>` is lower than `<$>`, so we don't even need parentheses: 145 | 146 | ```haskell 147 | intOrUppercase :: Parser () 148 | intOrUppercase = const () <$> posInt <|> const () <$> satisfy isUpper 149 | ``` 150 | -------------------------------------------------------------------------------- /homework-10/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-10/assignment.pdf -------------------------------------------------------------------------------- /homework-11/AParser.hs: -------------------------------------------------------------------------------- 1 | module AParser (Parser, runParser, satisfy, char, posInt) where 2 | 3 | import Control.Applicative 4 | import Data.Char 5 | 6 | newtype Parser a = Parser { runParser :: String -> Maybe (a, String) } 7 | 8 | satisfy :: (Char -> Bool) -> Parser Char 9 | satisfy p = Parser f 10 | where 11 | f [] = Nothing 12 | f (x:xs) 13 | | p x = Just (x, xs) 14 | | otherwise = Nothing 15 | 16 | char :: Char -> Parser Char 17 | char c = satisfy (== c) 18 | 19 | posInt :: Parser Integer 20 | posInt = Parser f 21 | where 22 | f xs 23 | | null ns = Nothing 24 | | otherwise = Just (read ns, rest) 25 | where (ns, rest) = span isDigit xs 26 | 27 | inParser f = Parser . f . runParser 28 | 29 | first :: (a -> b) -> (a,c) -> (b,c) 30 | first f (x,y) = (f x, y) 31 | 32 | instance Functor Parser where 33 | fmap = inParser . fmap . fmap . first 34 | 35 | instance Applicative Parser where 36 | pure a = Parser (\s -> Just (a, s)) 37 | (Parser fp) <*> xp = Parser $ \s -> 38 | case fp s of 39 | Nothing -> Nothing 40 | Just (f,s') -> runParser (f <$> xp) s' 41 | 42 | instance Alternative Parser where 43 | empty = Parser (const Nothing) 44 | Parser p1 <|> Parser p2 = Parser $ liftA2 (<|>) p1 p2 45 | -------------------------------------------------------------------------------- /homework-11/README.md: -------------------------------------------------------------------------------- 1 | # Homework 11 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [AParser.hs](AParser.hs) 6 | * [SExpr.hs (file to submit)](SExpr.hs) 7 | 8 | In this assignment we extend the previous homework so make sure you understood everything we did there. Just remember that `Parser` is an instance of `Functor`, `Applicative` and `Alternative` type classes. With that we can write code that does not need to know the `Parser` implementation details. 9 | 10 | ## Exercise 1 11 | 12 | We have to implement the parsers `zeroOrMore :: Parser a -> Parser [a]` and `oneOrMore :: Parser a -> Parser [a]`. The hint that they give us is kinda important since it tells us how to do it. Indeed, we can define `zerOrMore` and `oneOrMore` in terms of each other. The key is that the latter will always consume some input so we will eventually exhaust it. 13 | 14 | Even if the solution looks short and simple, it took me a while to get it, so don't assume that a solution is obvious and effortless just because it's short. 15 | 16 | ```haskell 17 | zeroOrMore :: Parser a -> Parser [a] 18 | zeroOrMore p = oneOrMore p <|> pure [] 19 | 20 | oneOrMore :: Parser a -> Parser [a] 21 | oneOrMore p = (:) <$> p <*> zeroOrMore p 22 | ``` 23 | 24 | In `oneOrMore` we run the parser *p* once and then we parse zero or more occurrences of *p*. Since *p* has type `Parser a` and `zeroOrMore p` has type `Parser [a]`, we have to combine them somehow. We can just cons the former to the latter by lifting the `:` operator which is defined for lists. 25 | 26 | In `zeroOrMore` we try to parse one or more occurrences of *p* and if it fails we return an empty list. Since we need to return a `Parser [a]`, we can't just return an empty list as it is, we have to wrap it in a `Parser`. This is what `pure does`. Remember that the `p1 <|> p2` tries to parse using `p1` and if it fails, uses `p2`. 27 | 28 | 29 | ## Exercise 2 30 | 31 | The parser `spaces :: Parser String` parses a consecutive list of zero or more whitespace characters. This is easy to implement using the `zeroOrMore` function we defined in the previous exercise: 32 | 33 | ```haskell 34 | spaces :: Parser String 35 | spaces = zeroOrMore $ satisfy isSpace 36 | ``` 37 | 38 | The parser `ident :: Parser String` parses an identifer which is an alphabetic character followed by zero or more alphanumeric characters. The implementation is straightforward: 39 | 40 | ```haskell 41 | ident :: Parser String 42 | ident = (:) <$> satisfy isAlpha <*> zeroOrMore (satisfy isAlphaNum) 43 | ``` 44 | 45 | To combine the results of the two parsers, we lift the cons operator. 46 | 47 | ## Exercise 3 48 | 49 | The last exercise consisted on parsing *S-expressions*. We are already given the representation of those kind of expresions: 50 | 51 | ```haskell 52 | type Ident = String 53 | 54 | data Atom = N Integer | I Ident 55 | deriving Show 56 | 57 | data SExpr = A Atom 58 | | Comb [SExpr] 59 | deriving Show 60 | ``` 61 | 62 | We must take into account that S-expressions may begin or end with any number of spaces, so we have to ignore them. In order to that we can use `(*>) :: Applicative f => f a -> f b -> f b` and `(<*) :: Applicative f => f a -> f b -> f a` (even if we ignore spaces, we first have to parse them). Moreover we also have to take into consideration that an S-expression is either an atom or an open parenthesis followed by one or more S-expressions followed by a close parenthesis. We can directly translate that construction into code: 63 | 64 | ```haskell 65 | parseAtom :: Parser SExpr 66 | parseAtom = fmap A $ N <$> posInt <|> I <$> ident 67 | 68 | parseComb :: Parser SExpr 69 | parseComb = char '(' *> (Comb <$> oneOrMore parseSExpr) <* char ')' 70 | 71 | parseSExpr :: Parser SExpr 72 | parseSExpr = spaces *> (parseAtom <|> parseComb) <* spaces 73 | ``` 74 | 75 | I loved this assignment because by writing very few lines of code (all the functions are one-liners!) we were able to create a powerful parser. In addition, it is quite readable as it mirrors the way the language is defined and I feel like there was only one way of implementing those functions, which is nice since you do not have to wonder about which solution is more adequate. 76 | -------------------------------------------------------------------------------- /homework-11/SExpr.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module SExpr where 4 | 5 | 6 | import AParser 7 | import Control.Applicative 8 | import Data.Char 9 | 10 | 11 | ---------------------------------- Exercise 1 ---------------------------------- 12 | 13 | ------------------------------------------------------------ 14 | -- 1. Parsing repetitions 15 | ------------------------------------------------------------ 16 | 17 | -- Runs consecutively the input parser as many times as possible and returns 18 | -- a list of the results (always succeeds) 19 | zeroOrMore :: Parser a -> Parser [a] 20 | zeroOrMore p = oneOrMore p <|> pure [] 21 | 22 | -- Runs consecutively the input parser as many times as possible and returns 23 | -- a list of the results (fails if it doesn't succeed at least once) 24 | oneOrMore :: Parser a -> Parser [a] 25 | oneOrMore p = (:) <$> p <*> zeroOrMore p 26 | 27 | 28 | zeroOrMoreTest :: Bool 29 | zeroOrMoreTest = and 30 | [ 31 | Just ("ABCDE","") == runParser (zeroOrMore (satisfy isUpper)) "ABCDE", 32 | Just ("ABC","dE") == runParser (zeroOrMore (satisfy isUpper)) "ABCdE", 33 | Just ("","abcde") == runParser (zeroOrMore (satisfy isUpper)) "abcde" 34 | ] 35 | 36 | oneOrMoreTest :: Bool 37 | oneOrMoreTest = and 38 | [ 39 | Just ("ABCDE","") == runParser (oneOrMore (satisfy isUpper)) "ABCDE", 40 | Just ("ABC","dE") == runParser (oneOrMore (satisfy isUpper)) "ABCdE", 41 | Just ("A","bcde") == runParser (oneOrMore (satisfy isUpper)) "Abcde", 42 | Nothing == runParser (oneOrMore (satisfy isUpper)) "abcde" 43 | ] 44 | 45 | 46 | ---------------------------------- Exercise 2 ---------------------------------- 47 | 48 | ------------------------------------------------------------ 49 | -- 2. Utilities 50 | ------------------------------------------------------------ 51 | 52 | -- Parser which parses a consecutive list of zero or more whitespace characters 53 | spaces :: Parser String 54 | spaces = zeroOrMore $ satisfy isSpace 55 | 56 | -- Parser which parses an identifer (alphabetic character followed by zero or 57 | -- more alphanumeric characters) 58 | ident :: Parser String 59 | ident = (:) <$> satisfy isAlpha <*> zeroOrMore (satisfy isAlphaNum) 60 | 61 | 62 | spacesTest :: Bool 63 | spacesTest = and 64 | [ 65 | Just ("","ABCDE") == runParser spaces "ABCDE", 66 | Just (" ","ABCDE") == runParser spaces " ABCDE", 67 | Just (" ","A BCDE") == runParser spaces " A BCDE" 68 | ] 69 | 70 | identTest :: Bool 71 | identTest = and 72 | [ 73 | Just ("foobar"," baz") == runParser ident "foobar baz", 74 | Just ("foo33fA","") == runParser ident "foo33fA", 75 | Nothing == runParser ident "2bad", 76 | Nothing == runParser ident " ", 77 | Nothing == runParser ident "" 78 | ] 79 | 80 | ------------------------------------------------------------ 81 | -- 3. Parsing S-expressions 82 | ------------------------------------------------------------ 83 | 84 | -- An "identifier" is represented as just a String; however, only 85 | -- those Strings consisting of a letter followed by any number of 86 | -- letters and digits are valid identifiers. 87 | type Ident = String 88 | 89 | -- An "atom" is either an integer value or an identifier. 90 | data Atom = N Integer | I Ident 91 | deriving Show 92 | 93 | -- An S-expression is either an atom, or a list of S-expressions. 94 | data SExpr = A Atom 95 | | Comb [SExpr] 96 | deriving Show 97 | 98 | 99 | ---------------------------------- Exercise 3 ---------------------------------- 100 | 101 | -- Parser which parses an atom (either an integer or an identifier) 102 | parseAtom :: Parser SExpr 103 | parseAtom = fmap A $ N <$> posInt <|> I <$> ident 104 | 105 | -- Parser which parses an open parenthesis followed by one or more 106 | -- S-expressions followed by a close parenthesis 107 | parseComb :: Parser SExpr 108 | parseComb = char '(' *> (Comb <$> oneOrMore parseSExpr) <* char ')' 109 | 110 | -- Parser which parses a whole S-expression 111 | parseSExpr :: Parser SExpr 112 | parseSExpr = spaces *> (parseAtom <|> parseComb) <* spaces 113 | -------------------------------------------------------------------------------- /homework-11/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-11/assignment.pdf -------------------------------------------------------------------------------- /homework-12/README.md: -------------------------------------------------------------------------------- 1 | # Homework 12 2 | 3 | This homework contains the following files: 4 | * [Assignment](assignment.pdf) 5 | * [Risk.hs (file to submit)](Risk.hs) 6 | 7 | In this homework we build a simulator of the game of *Risk*. We define the following data types to represent the game: 8 | 9 | ```haskell 10 | newtype DieValue = DV { unDV :: Int } 11 | deriving (Eq, Ord, Show, Num) 12 | 13 | type Army = Int 14 | 15 | data Battlefield = Battlefield { attackers :: Army, defenders :: Army } 16 | deriving (Eq, Show) 17 | ``` 18 | 19 | If you want to be able to run the code in [Risk.hs](Risk.hs), you must install [MonadRandom](http://hackage.haskell.org/package/MonadRandom) and [monad-loops](http://hackage.haskell.org/package/monad-loops) packages. To do that, run in the terminal: 20 | 21 | ```bash 22 | cabal install MonadRandom 23 | cabal install monad-loops 24 | ``` 25 | 26 | By the way, I found a very good [post](https://pbrisbin.com/posts/applicative_functors/) about when to use Applicative Functors and when to use Monads. 27 | 28 | ## Exercise 1 29 | 30 | In this exercise we don't have to implement anything, just understand the rules of the game of *Risk*. It is important to read them thoroughly in order to comprehend what we will do next. 31 | 32 | ## Exercise 2 33 | 34 | We implement the function `invade :: Battlefield -> Rand StdGen Battlefield` which simulates a single battle between two opposing armies. We have to do randomly roll dices, interpret the results and update the armies if there are casualties. Since there are many things to do, we will break this problem into many auxiliary functions. 35 | 36 | First of all, we assume that each players always attacks or defends with the maximum number of units there are allowed. So we must write two functions that, given an `Army`, return what is the maximum number of units: 37 | 38 | ```haskell 39 | maxAttackers :: Army -> Int 40 | maxAttackers n = min 3 (n-1) 41 | 42 | maxDefenders :: Army -> Int 43 | maxDefenders = min 2 44 | ``` 45 | 46 | Next we have to simulate dice rolls. Since the number of dice rolls depends on the number of units, we pass that as a parameter. We use `replicateM :: Applicative m => Int -> m a -> m [a]` to execute an arbitrary number of dices: 47 | 48 | ```haskell 49 | diceRolls :: Int -> Rand StdGen [DieValue] 50 | diceRolls n = replicateM n die 51 | ``` 52 | 53 | Now we have to interpret the results. That means that we have to sort the dice rolls in decreasing order, match and compare them: 54 | 55 | ```haskell 56 | sortDiceRolls :: [DieValue] -> [DieValue] 57 | sortDiceRolls = sortBy (flip compare) 58 | 59 | matchDiceRolls :: [DieValue] -> [DieValue] -> [Ordering] 60 | matchDiceRolls = zipWith compare 61 | ``` 62 | 63 | The last step is to update both armies by reflecting their casualties. It is easy to count how many deaths each army has with the `[Ordering]` we have build in the previous function. 64 | 65 | ```haskell 66 | update :: Battlefield -> [Ordering] -> Battlefield 67 | update (Battlefield as ds) xs = Battlefield (as - as_deaths) (ds - ds_deaths) 68 | where as_deaths = length . filter (/= GT) $ xs 69 | ds_deaths = length . filter (== GT) $ xs 70 | ``` 71 | 72 | Finally, we use all the previous functions to build `battle`. It ends up being pretty readable using `do` notation. Note that it is easy to identify each of the steps that we described at the beginning (namely computing the number of units of each army, dicing rolls, sorting and matching them and updating both armies): 73 | 74 | ```haskell 75 | battle :: Battlefield -> Rand StdGen Battlefield 76 | battle b = do 77 | as_rolls <- sortDiceRolls <$> diceRolls (maxAttackers . attackers $ b) 78 | ds_rolls <- sortDiceRolls <$> diceRolls (maxDefenders . defenders $ b) 79 | return $ update b (matchDiceRolls as_rolls ds_rolls) 80 | ``` 81 | 82 | By the way, note that we now we can use the `>>=` (bind) operator to execute `battle` as many times as we want (both examples are equivalent): 83 | 84 | ```ghci 85 | *Risk> evalRandIO $ return (Battlefield 5 5) >>= battle >>= battle >>= battle 86 | Battlefield {attackers = 4, defenders = 1} 87 | *Risk> evalRandIO $ battle (Battlefield 5 5) >>= battle >>= battle 88 | Battlefield {attackers = 4, defenders = 1} 89 | ``` 90 | 91 | ## Exercise 3 92 | 93 | We have to implement `invade :: Battlefield -> Rand StdGen Battlefield` which simulates an entire invasion attempt, that is, it runs multiple battles until there are no defenders remaining or fewer than two attackers. This is similar to the `until :: (a -> Bool) -> (a -> a) -> a -> a` function for lists, so I looked if there was something equivalent for Monads and indeed there is. The function `iterateUntilM :: Monad m => (a -> Bool) -> (a -> m a) -> a -> m a`does exactly the same. Note that I had to install the package `monad-loops` to import `import Control.Monad.Loops`. I think it is worth it to take a look at the source code to see how it works: 94 | 95 | ```haskell 96 | -- | Analogue of @('Prelude.until')@ 97 | -- Yields the result of applying f until p holds. 98 | iterateUntilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a 99 | iterateUntilM p f v 100 | | p v = return v 101 | | otherwise = f v >>= iterateUntilM p f 102 | ``` 103 | 104 | Now, we just have to write a function `hasInvasionEnded :: Battlefield -> Bool` which tells us whether an invasion has ended or not and then the `invade :: Battlefield -> Rand StdGen Battlefield` implementation is obvious: 105 | 106 | ```haskell 107 | hasInvasionEnded :: Battlefield -> Bool 108 | hasInvasionEnded (Battlefield as ds) = ds == 0 || as < 2 109 | 110 | invade :: Battlefield -> Rand StdGen Battlefield 111 | invade = iterateUntilM hasInvasionEnded battle 112 | ``` 113 | 114 | ## Exercise 4 115 | 116 | We have to implement the function `successProb :: Battlefield -> Rand StdGen Double` which simulates many invasions to compute the estimated probabilty that the attacking army will destroy the defending army. To solve this problem we must call `invade :: Battlefield -> Rand StdGen Battlefield` 1000 times and interpret the results. 117 | 118 | First let's write two helpers functions: one to easily change the number of runs if we want to and another one to know whether or not the attacker has won: 119 | 120 | ```haskell 121 | runs :: Int 122 | runs = 1000 123 | 124 | hasAttackerWon :: Battlefield -> Bool 125 | hasAttackerWon (Battlefield _ ds) = ds == 0 126 | ``` 127 | 128 | Now we can easily implement `successProb`: 129 | 130 | ```haskell 131 | successProb :: Battlefield -> Rand StdGen Double 132 | successProb b = do 133 | simulations <- replicateM runs $ invade b 134 | let wins = length . filter hasAttackerWon $ simulations 135 | return $ fromIntegral wins / fromIntegral runs 136 | ``` 137 | 138 | By the way, if you want to try this function in the GHCi, use the following command: 139 | 140 | ```ghci 141 | *Risk> evalRandIO . successProb $ Battlefield 20 20 142 | ``` 143 | 144 | ## Exercise 5 145 | 146 | This exercise was optional and it ended up being pretty time consuming but it's been totally worth it! I ended up learning a way of memoizing using Haskell's lazy evaluation which is something I did not expect to do at the beginning of this exercise. 147 | 148 | The first challenge was the probability theory required to solve this problem. My knowledge of probabilty theory is rusty and I struggled a bit. I started by listing all the possible battles that may happen (1vs1, 2vs1, 3vs1, 1vs2, 2vs2, 3vs2) and computing the probabilities that the attacker had to succeed. 1vs1 was easy since there are only 36 possible outcomes, 2vs1 was harder but doable. 149 | 150 | Using [this post](https://www.quora.com/Roll-two-fair-dice-Let-X-be-the-largest-of-the-two-faces-What-is-the-distribution-of-X) I managed to compute the 3vs1 case but when I reached the 3vs2 I was totally lost. There are five dice rolls (65 = 7776 possible outcomes) and you must take the two higher rolls of the attacker and match them against the two rolls of the defender. I had no clue of solving that in a theoretical way so I just ended up using the computer (and Haskell, obviously) to simulate all those possible outcomes and count how many times the attacker won. 151 | 152 | Before continuing, note that in battles, there is always one or two deaths. If there is one death either one attacker or one defender will die, whereas if there are two deats two attackers, two defenders or one attacker and one defender die. Finally, don't get confused by the fact that a battle 1 vs 1 is represented by `Battlefield 2 1` since attackers must always leave at least one unit behind. 153 | 154 | To represent the possible outcomes in terms of casualties that a battle can have, we create the `Casualties` data type: 155 | 156 | ```haskell 157 | data Casualties = OneA | TwoAs | OneD | TwoDs | OneA_OneD 158 | ``` 159 | 160 | `OneA` means that one attacker dies, `TwoAs` that two attackers die, `OneD` that one defender dies, `TwoD` that two defenders die and `OneA_OneD` that one attacker and one defender die. 161 | 162 | Next I will explain how I get the probabilities of each battle configuration. In the first battle I will explain in detail the process whereas in the remaining ones I will just paste the code that led me there. 163 | 164 | ### Battle 1 vs 1 165 | 166 | In this battle there is one attacker and one defender. There are two dice rolls so 62 = 36 possible outcomes. 167 | 168 | ```haskell 169 | simulateDiceRolls :: [[Ordering]] 170 | simulateDiceRolls = do 171 | a1 <- DV <$> [1..6] 172 | d1 <- DV <$> [1..6] 173 | let sortedAs = sortDiceRolls [a1] 174 | let sortedDs = sortDiceRolls [d1] 175 | return $ matchDiceRolls sortedAs sortedDs 176 | ``` 177 | 178 | If we execute the function `simulateDiceRolls` we get the list of lists `[[EQ],[LT],[LT],[LT],[LT],[LT],[GT],[EQ],[LT],[LT],[LT],[LT],[GT],[GT],[EQ],[LT],[LT],[LT],[GT],[GT],[GT],[EQ],[LT],[LT],[GT],[GT],[GT],[GT],[EQ],[LT],[GT],[GT],[GT],[GT],[GT],[EQ]]` which contains 36 lists. `GT` means that the die value of the attacker is greater than the one of the defender (so the defender dies), `EQ` means they are equal (so the attacker dies) and `LT` that the die value of the attacker is less than the defender (so the attacker dies). 179 | 180 | From the result of `simulateDiceRolls` it is easy to deduce the number of times each success happened. From *GHCi* we can run the following two expressions to compute how many times attackers and defenders died. 181 | 182 | ```ghci 183 | *Risk> length . filter (== 1) $ length . filter (/= GT) <$> simulateDiceRolls 184 | 21 185 | *Risk> length . filter (== 1) $ length . filter (== GT) <$> simulateDiceRolls 186 | 15 187 | ``` 188 | 189 | That means that out of the 36 possible outcomes of the two dice rolls, 21 times the attacker will die and 15 times the defender will die. 190 | 191 | ```haskell 192 | battle1vs1Prob :: Casualties -> Double 193 | battle1vs1Prob OneA = 21/36 194 | battle1vs1Prob TwoAs = 0 195 | battle1vs1Prob OneD = 15/36 196 | battle1vs1Prob TwoDs = 0 197 | battle1vs1Prob OneA_OneD = 0 198 | ``` 199 | 200 | ### Battle 2 vs 1 201 | 202 | In this battle there are two attackers and one defender. There are three dice rolls so 63 = 216 possible outcomes. 203 | 204 | ```haskell 205 | simulateDiceRolls :: [[Ordering]] 206 | simulateDiceRolls = do 207 | a1 <- DV <$> [1..6] 208 | a2 <- DV <$> [1..6] 209 | d1 <- DV <$> [1..6] 210 | let sortedAs = sortDiceRolls [a1,a2] 211 | let sortedDs = sortDiceRolls [d1] 212 | return $ matchDiceRolls sortedAs sortedDs 213 | ``` 214 | 215 | ```ghci 216 | *Risk> length . filter (== 1) $ length . filter (/= GT) <$> simulateDiceRolls 217 | 91 218 | *Risk> length . filter (== 1) $ length . filter (== GT) <$> simulateDiceRolls 219 | 125 220 | ``` 221 | 222 | ```haskell 223 | battle2vs1Prob :: Casualties -> Double 224 | battle2vs1Prob OneA = 91/216 225 | battle2vs1Prob TwoAs = 0 226 | battle2vs1Prob OneD = 125/216 227 | battle2vs1Prob TwoDs = 0 228 | battle2vs1Prob OneA_OneD = 0 229 | ``` 230 | 231 | ### Battle 3 vs 1 232 | 233 | In this battle there are three attackers and one defender. There are four dice rolls so 64 = 1296 possible outcomes. 234 | 235 | ```haskell 236 | simulateDiceRolls :: [[Ordering]] 237 | simulateDiceRolls = do 238 | a1 <- DV <$> [1..6] 239 | a2 <- DV <$> [1..6] 240 | a3 <- DV <$> [1..6] 241 | d1 <- DV <$> [1..6] 242 | let sortedAs = sortDiceRolls [a1,a2,a3] 243 | let sortedDs = sortDiceRolls [d1] 244 | return $ matchDiceRolls sortedAs sortedDs 245 | ``` 246 | 247 | ```ghci 248 | *Risk> length . filter (== 1) $ length . filter (/= GT) <$> simulateDiceRolls 249 | 441 250 | *Risk> length . filter (== 1) $ length . filter (== GT) <$> simulateDiceRolls 251 | 855 252 | ``` 253 | 254 | ```haskell 255 | battle3vs1Prob :: Casualties -> Double 256 | battle3vs1Prob OneA = 441/1296 257 | battle3vs1Prob TwoAs = 0 258 | battle3vs1Prob OneD = 855/1296 259 | battle3vs1Prob TwoDs = 0 260 | battle3vs1Prob OneA_OneD = 0 261 | ``` 262 | 263 | ### Battle 1 vs 2 264 | 265 | In this battle there is one attacker and two defenders. There are three dice rolls so 63 = 216 possible outcomes. 266 | 267 | ```haskell 268 | simulateDiceRolls :: [[Ordering]] 269 | simulateDiceRolls = do 270 | a1 <- DV <$> [1..6] 271 | d1 <- DV <$> [1..6] 272 | d2 <- DV <$> [1..6] 273 | let sortedAs = sortDiceRolls [a1] 274 | let sortedDs = sortDiceRolls [d1,d2] 275 | return $ matchDiceRolls sortedAs sortedDs 276 | ``` 277 | 278 | ```ghci 279 | *Risk> length . filter (== 1) $ length . filter (/= GT) <$> simulateDiceRolls 280 | 161 281 | *Risk> length . filter (== 1) $ length . filter (== GT) <$> simulateDiceRolls 282 | 55 283 | ``` 284 | 285 | ```haskell 286 | battle1vs2Prob :: Casualties -> Double 287 | battle1vs2Prob OneA = 161/216 288 | battle1vs2Prob TwoAs = 0 289 | battle1vs2Prob OneD = 55/216 290 | battle1vs2Prob TwoDs = 0 291 | battle1vs2Prob OneA_OneD = 0 292 | ``` 293 | 294 | ### Battle 2 vs 2 295 | 296 | In this battle there are two attackers and two defenders. There are four dice rolls so 64 = 1296 possible outcomes. Note that there will be two casualties in this battle: two attackers, two defenders or one attacker and one defender. For that reason, the *GHCi* code has an additional expression to compute how many times an attacker and defender die. Moreover, we use `filter (== 2)` for the cases where two units of the same army die. 297 | 298 | ```haskell 299 | simulateDiceRolls :: [[Ordering]] 300 | simulateDiceRolls = do 301 | a1 <- DV <$> [1..6] 302 | a2 <- DV <$> [1..6] 303 | d1 <- DV <$> [1..6] 304 | d2 <- DV <$> [1..6] 305 | let sortedAs = sortDiceRolls [a1,a2] 306 | let sortedDs = sortDiceRolls [d1,d2] 307 | return $ matchDiceRolls sortedAs sortedDs 308 | ``` 309 | 310 | ```ghci 311 | *Risk> length . filter (== 2) $ length . filter (/= GT) <$> simulateDiceRolls 312 | 581 313 | *Risk> length . filter (== 2) $ length . filter (== GT) <$> simulateDiceRolls 314 | 295 315 | *Risk> length . filter (== 1) $ length . filter (== GT) <$> simulateDiceRolls 316 | 420 317 | ``` 318 | 319 | ```haskell 320 | battle2vs2Prob :: Casualties -> Double 321 | battle2vs2Prob OneA = 0 322 | battle2vs2Prob TwoAs = 581/1296 323 | battle2vs2Prob OneD = 0 324 | battle2vs2Prob TwoDs = 295/1296 325 | battle2vs2Prob OneA_OneD = 420/1296 326 | ``` 327 | 328 | ### Battle 3 vs 2 329 | 330 | In this battle there are three attackers and two defenders. There are five dice rolls so 65 = 7776 possible outcomes. Again, in this battle there are two casualties. 331 | 332 | ```haskell 333 | simulateDiceRolls :: [[Ordering]] 334 | simulateDiceRolls = do 335 | a1 <- DV <$> [1..6] 336 | a2 <- DV <$> [1..6] 337 | a3 <- DV <$> [1..6] 338 | d1 <- DV <$> [1..6] 339 | d2 <- DV <$> [1..6] 340 | let sortedAs = sortDiceRolls [a1,a2,a3] 341 | let sortedDs = sortDiceRolls [d1,d2] 342 | return $ matchDiceRolls sortedAs sortedDs 343 | ``` 344 | 345 | ```ghci 346 | *Risk> length . filter (== 2) $ length . filter (/= GT) <$> simulateDiceRolls 347 | 2275 348 | *Risk> length . filter (== 2) $ length . filter (== GT) <$> simulateDiceRolls 349 | 2890 350 | *Risk> length . filter (== 1) $ length . filter (== GT) <$> simulateDiceRolls 351 | 2611 352 | ``` 353 | 354 | ```haskell 355 | battle3vs2Prob :: Casualties -> Double 356 | battle3vs2Prob OneA = 0 357 | battle3vs2Prob TwoAs = 2275/7776 358 | battle3vs2Prob OneD = 0 359 | battle3vs2Prob TwoDs = 2890/7776 360 | battle3vs2Prob OneA_OneD = 2611/7776 361 | ``` 362 | 363 | Now that we have all the probabilites, we must build a function that given two armies, returns the probability of each outcome: 364 | 365 | ```haskell 366 | battleProb :: Army -> Army -> Casualties -> Double 367 | battleProb 1 1 = battle1vs1Prob 368 | battleProb 2 1 = battle2vs1Prob 369 | battleProb 3 1 = battle3vs1Prob 370 | battleProb 1 2 = battle1vs2Prob 371 | battleProb 2 2 = battle2vs2Prob 372 | battleProb _ _ = battle3vs2Prob 373 | ``` 374 | 375 | Then we have to write a function that updates a battlefield given an outcome. For example, if the outcome is `OneA`, which means that an attacker died, we have to decrement the number of attackers by one. The same applies for the other outcomes: 376 | 377 | ```haskell 378 | updateCasualties :: Battlefield -> Casualties -> Battlefield 379 | updateCasualties (Battlefield as ds) OneA = Battlefield (as-1) ds 380 | updateCasualties (Battlefield as ds) TwoAs = Battlefield (as-2) ds 381 | updateCasualties (Battlefield as ds) OneD = Battlefield as (ds-1) 382 | updateCasualties (Battlefield as ds) TwoDs = Battlefield as (ds-2) 383 | updateCasualties (Battlefield as ds) OneA_OneD = Battlefield (as-1) (ds-1) 384 | ``` 385 | 386 | Now, we are ready to implement `exactSuccessProb :: Battlefield -> Double`. I think it's a good idea to think in terms of search spaces. Since in a battle there are attackers and defenders, we are in a 2D-space. We start with `Battlefield X Y` and after each battle we transition into others battlefields. Each of those successors has associated a probability of happening. 387 | 388 | 389 | To compute the `exactSuccessProb` of a battlefield, we must compute the `exactSuccessProb` of each successor and multiply that by the probabilty of transitioning into that successor. In Haskell we would write: `successorProb * (exactSuccessProb successor)`. Note that this is a recursive definition, but it always ends since in each battle there is always one or two casualties. When there less than two attackers the attacker looses whereas when there are no defenders the attacker wins. Now we are ready to display the solution: 390 | 391 | ```haskell 392 | (.*) :: Double -> Double -> Double 393 | 0 .* _ = 0 394 | x .* y = x * y 395 | 396 | exactSuccessProb :: Battlefield -> Double 397 | exactSuccessProb (Battlefield _ 0) = 1 398 | exactSuccessProb (Battlefield 0 _) = 0 399 | exactSuccessProb (Battlefield 1 _) = 0 400 | exactSuccessProb b@(Battlefield as ds) = sum probs 401 | where probs = do 402 | c <- [OneA, TwoAs, OneD, TwoDs, OneA_OneD] 403 | let nextBattlefieldProb = battleProb (maxAttackers as) (maxDefenders ds) c 404 | let nextBattlefield = updateCasualties b c 405 | return $ nextBattlefieldProb .* exactSuccessProb nextBattlefield 406 | ``` 407 | 408 | Note that we have implemented a lazy multiplication operation to avoid making recursive calls when we multiply by 0 on the first argument. It makes no sense to keep computing a product that has a 0 inside! As we said, in base cases either the attacker won or lost, so the probabalities are 1 and 0. We use `do` notation instead of a comprehension list to iterate over all the possible outcomes in terms of casualties. 409 | 410 | ### Problems 411 | 412 | After implementing this solution I used the simulation version to compare results. Instead of 1000 runs, I run it 100000 times and indeed they converged. So I was pretty certain it was well implemented. However, I realised the `exactSuccessProb` function was slow. 413 | 414 | At first, I thought that it was intrinsic to the problem since we took into account all possible outcomes, including highly unlikely ones. For example, if there are 20 attackers and one defender, the defender might be a hero and kill all the attackers. This is highly unlikely, but if we want to compute the exact probability we must take that possibility into account. For that reason, the search space is huge and it's long to compute that. In fact, the [branching factor](https://en.wikipedia.org/wiki/Branching_factor) is either two or three so if we compute `Battlefield 20 20` we will generate about 320 calls. 415 | 416 | Nevertheless, if you think about it, when we start with `Battlefield 20 20` there are not as many different battlefields as 320. There is `Battlefield 20 19`, `Battlefied 19 20`, `Battlefield 19 19` up to a winning or losing battlefield. So there are only around 20*20 = 400 distinct battlefields! We can reuse the previous results to avoid making so many recursive calls. 417 | 418 | ### Memoization 419 | 420 | To speed up the program we need to use [memoization](https://en.wikipedia.org/wiki/Memoization). In imperative languages we usually build a map and check whether or not we have already computed the result of the current state. However in Haskell we can use lazyness to implement a neat and unique way of doing memoization. 421 | 422 | I used this [post](https://stackoverflow.com/a/5553390) to implement memoization with a lists of lists. The nice thing about doing it this way is that we don't have to think about how to construct the table: lazy evaluation ensures that values will be computed as needed. Note that this is not the most efficient way of implementing memoization since accessing elements in a list is linear in time. However, for this exercise it was not a problem. 423 | 424 | The `exactSuccessProb` function looks almost the same as before, except we have changed `exactSuccessProb nextBattlefield` for `memoizedProb nextBattlefield`. Obviously we have also added the functions that allow us to memoize the results: 425 | 426 | ```haskell 427 | exactSuccessProb :: Battlefield -> Double 428 | exactSuccessProb (Battlefield _ 0) = 1 429 | exactSuccessProb (Battlefield 0 _) = 0 430 | exactSuccessProb (Battlefield 1 _) = 0 431 | exactSuccessProb b@(Battlefield as ds) = sum probs 432 | where probs = do 433 | c <- [OneA, TwoAs, OneD, TwoDs, OneA_OneD] 434 | let nextBattleProb = battleProb (maxAttackers as) (maxDefenders ds) c 435 | let nextBattlefield = updateCasualties b c 436 | return $ nextBattleProb .* memoizedProb nextBattlefield 437 | 438 | memoize :: (Army -> Army -> Double) -> [[Double]] 439 | memoize f = map (\x -> map (f x) [0..]) [0..] 440 | 441 | table :: [[Double]] 442 | table = memoize . curry $ exactSuccessProb . uncurry Battlefield 443 | 444 | memoizedProb :: Battlefield -> Double 445 | memoizedProb (Battlefield as ds) = table !! as !! ds 446 | ``` 447 | 448 | `table :: [[Double]]` can be seen as a matrix storing all the results we are memoizing. We access to the results by index, so for example `table !! 1 !! 1` stores the probability of success for `Battlefield 1 1`. What is nice about this solution is that we only computed what we need and that we don't have to build the whole matrix by ourselves. Building that matrix bottom-up is not obvious since we would have to think about how to build the graph of the recurrence. 449 | 450 | 451 | Well, I guess it's time to finish this exercise, and also the course since that was the last exercise. I hope that you also had fun doing those assignments :) 452 | -------------------------------------------------------------------------------- /homework-12/Risk.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | module Risk where 6 | 7 | import Control.Monad.Random 8 | import Control.Monad.Loops (iterateUntilM) 9 | import Data.List (sortBy) 10 | 11 | 12 | ---------------------------------- Exercise 1 ---------------------------------- 13 | 14 | ------------------------------------------------------------ 15 | -- Die values 16 | 17 | newtype DieValue = DV { unDV :: Int } 18 | deriving (Eq, Ord, Show, Num) 19 | 20 | first :: (a -> b) -> (a, c) -> (b, c) 21 | first f (a, c) = (f a, c) 22 | 23 | instance Random DieValue where 24 | random = first DV . randomR (1,6) 25 | randomR (low,hi) = first DV . randomR (max 1 (unDV low), min 6 (unDV hi)) 26 | 27 | die :: Rand StdGen DieValue 28 | die = getRandom 29 | 30 | ------------------------------------------------------------ 31 | -- Risk 32 | 33 | type Army = Int 34 | 35 | data Battlefield = Battlefield { attackers :: Army, defenders :: Army } 36 | deriving (Eq, Show) 37 | 38 | 39 | ---------------------------------- Exercise 2 ---------------------------------- 40 | 41 | -- Returns the maximum number of attackers for a given army 42 | maxAttackers :: Army -> Int 43 | maxAttackers n = min 3 (n-1) 44 | 45 | -- Returns the maximum number of defenders for a given army 46 | maxDefenders :: Army -> Int 47 | maxDefenders = min 2 48 | 49 | -- Simulates n dice rolls 50 | diceRolls :: Int -> Rand StdGen [DieValue] 51 | diceRolls n = replicateM n die 52 | 53 | -- Sorts a list of die values in decreasing order 54 | sortDiceRolls :: [DieValue] -> [DieValue] 55 | sortDiceRolls = sortBy (flip compare) 56 | 57 | -- Returns the ordering for each die value matched in pairs 58 | matchDiceRolls :: [DieValue] -> [DieValue] -> [Ordering] 59 | matchDiceRolls = zipWith compare 60 | 61 | -- Updates armies to reflect casualties 62 | update :: Battlefield -> [Ordering] -> Battlefield 63 | update (Battlefield as ds) xs = Battlefield (as - as_deaths) (ds - ds_deaths) 64 | where as_deaths = length . filter (/= GT) $ xs 65 | ds_deaths = length . filter (== GT) $ xs 66 | 67 | -- Simulates a single battle between two opposing armies 68 | battle :: Battlefield -> Rand StdGen Battlefield 69 | battle b = do 70 | as_rolls <- sortDiceRolls <$> diceRolls (maxAttackers . attackers $ b) 71 | ds_rolls <- sortDiceRolls <$> diceRolls (maxDefenders . defenders $ b) 72 | return $ update b (matchDiceRolls as_rolls ds_rolls) 73 | 74 | 75 | maxAttackersTest :: Bool 76 | maxAttackersTest = and 77 | [ 78 | 0 == maxAttackers 1, 79 | 1 == maxAttackers 2, 80 | 2 == maxAttackers 3, 81 | 3 == maxAttackers 4, 82 | 3 == maxAttackers 10 83 | ] 84 | 85 | maxDefendersTest :: Bool 86 | maxDefendersTest = and 87 | [ 88 | 0 == maxDefenders 0, 89 | 1 == maxDefenders 1, 90 | 2 == maxDefenders 2, 91 | 2 == maxDefenders 3 92 | ] 93 | 94 | sortDiceRollsTest :: Bool 95 | sortDiceRollsTest = and 96 | [ 97 | [] == sortDiceRolls [], 98 | [DV 1] == sortDiceRolls [DV 1], 99 | fmap DV [6,5,4,3,2,1] == sortDiceRolls (fmap DV [1,2,3,4,5,6]), 100 | fmap DV [6,5,4,3,2,2] == sortDiceRolls (fmap DV [2,5,4,3,2,6]) 101 | ] 102 | 103 | matchDiceRollsTest :: Bool 104 | matchDiceRollsTest = and 105 | [ 106 | [] == matchDiceRolls [DV 1] [], 107 | [LT] == matchDiceRolls [DV 1] [DV 5], 108 | [EQ] == matchDiceRolls [DV 1] [DV 1, DV 4], 109 | [GT] == matchDiceRolls [DV 5, DV 4] [DV 3], 110 | [EQ,GT,LT] == matchDiceRolls (fmap DV [1,4,3]) (fmap DV [1,2,6]) 111 | ] 112 | 113 | 114 | ---------------------------------- Exercise 3 ---------------------------------- 115 | 116 | -- Returns whether or not an invasion has ended 117 | hasInvasionEnded :: Battlefield -> Bool 118 | hasInvasionEnded (Battlefield as ds) = ds == 0 || as < 2 119 | 120 | -- Simulates an entire invasion attempt 121 | invade :: Battlefield -> Rand StdGen Battlefield 122 | invade = iterateUntilM hasInvasionEnded battle 123 | 124 | 125 | hasInvasionEndedTest :: Bool 126 | hasInvasionEndedTest = and 127 | [ 128 | False == hasInvasionEnded (Battlefield 5 9), 129 | False == hasInvasionEnded (Battlefield 2 8), 130 | True == hasInvasionEnded (Battlefield 7 0), 131 | True == hasInvasionEnded (Battlefield 0 0), 132 | True == hasInvasionEnded (Battlefield 1 9) 133 | ] 134 | 135 | 136 | ---------------------------------- Exercise 4 ---------------------------------- 137 | 138 | -- Number of runs we want to simulate 139 | runs :: Int 140 | runs = 1000 141 | 142 | -- Returns whether or not the attacker has won 143 | hasAttackerWon :: Battlefield -> Bool 144 | hasAttackerWon (Battlefield _ ds) = ds == 0 145 | 146 | -- Simulates many invasions to compute the estimated probabilty that the 147 | -- attacking army will destroy the defending army 148 | successProb :: Battlefield -> Rand StdGen Double 149 | successProb b = do 150 | simulations <- replicateM runs $ invade b 151 | let wins = length . filter hasAttackerWon $ simulations 152 | return $ fromIntegral wins / fromIntegral runs 153 | 154 | 155 | ---------------------------------- Exercise 5 ---------------------------------- 156 | 157 | data Casualties = OneA | TwoAs | OneD | TwoDs | OneA_OneD 158 | 159 | -- Template to simulate all the possible outcomes of rolling dices 160 | -- (To understand how to use it read README.md in this same directory) 161 | simulateDiceRolls :: [[Ordering]] 162 | simulateDiceRolls = do 163 | a1 <- DV <$> [1..6] 164 | a2 <- DV <$> [1..6] 165 | a3 <- DV <$> [1..6] 166 | d1 <- DV <$> [1..6] 167 | d2 <- DV <$> [1..6] 168 | let sortedAs = sortDiceRolls [a1,a2,a3] 169 | let sortedDs = sortDiceRolls [d1,d2] 170 | return $ matchDiceRolls sortedAs sortedDs 171 | 172 | -- Returns the probability of a given outcome in a battle 1vs1 173 | battle1vs1Prob :: Casualties -> Double 174 | battle1vs1Prob OneA = 21/36 175 | battle1vs1Prob TwoAs = 0 176 | battle1vs1Prob OneD = 15/36 177 | battle1vs1Prob TwoDs = 0 178 | battle1vs1Prob OneA_OneD = 0 179 | 180 | -- Returns the probability of a given outcome in a battle 2vs1 181 | battle2vs1Prob :: Casualties -> Double 182 | battle2vs1Prob OneA = 91/216 183 | battle2vs1Prob TwoAs = 0 184 | battle2vs1Prob OneD = 125/216 185 | battle2vs1Prob TwoDs = 0 186 | battle2vs1Prob OneA_OneD = 0 187 | 188 | -- Returns the probability of a given outcome in a battle 3vs1 189 | battle3vs1Prob :: Casualties -> Double 190 | battle3vs1Prob OneA = 441/1296 191 | battle3vs1Prob TwoAs = 0 192 | battle3vs1Prob OneD = 855/1296 193 | battle3vs1Prob TwoDs = 0 194 | battle3vs1Prob OneA_OneD = 0 195 | 196 | -- Returns the probability of a given outcome in a battle 1vs2 197 | battle1vs2Prob :: Casualties -> Double 198 | battle1vs2Prob OneA = 161/216 199 | battle1vs2Prob TwoAs = 0 200 | battle1vs2Prob OneD = 55/216 201 | battle1vs2Prob TwoDs = 0 202 | battle1vs2Prob OneA_OneD = 0 203 | 204 | -- Returns the probability of a given outcome in a battle 2vs2 205 | battle2vs2Prob :: Casualties -> Double 206 | battle2vs2Prob OneA = 0 207 | battle2vs2Prob TwoAs = 581/1296 208 | battle2vs2Prob OneD = 0 209 | battle2vs2Prob TwoDs = 295/1296 210 | battle2vs2Prob OneA_OneD = 420/1296 211 | 212 | -- Returns the probability of a given outcome in a battle 3vs2 213 | battle3vs2Prob :: Casualties -> Double 214 | battle3vs2Prob OneA = 0 215 | battle3vs2Prob TwoAs = 2275/7776 216 | battle3vs2Prob OneD = 0 217 | battle3vs2Prob TwoDs = 2890/7776 218 | battle3vs2Prob OneA_OneD = 2611/7776 219 | 220 | -- Returns the probability of a given outcome in a battle 221 | battleProb :: Army -> Army -> Casualties -> Double 222 | battleProb 1 1 = battle1vs1Prob 223 | battleProb 2 1 = battle2vs1Prob 224 | battleProb 3 1 = battle3vs1Prob 225 | battleProb 1 2 = battle1vs2Prob 226 | battleProb 2 2 = battle2vs2Prob 227 | battleProb _ _ = battle3vs2Prob 228 | 229 | -- Given a battlefield, returns another one with casualties taken into account 230 | updateCasualties :: Battlefield -> Casualties -> Battlefield 231 | updateCasualties (Battlefield as ds) OneA = Battlefield (as-1) ds 232 | updateCasualties (Battlefield as ds) TwoAs = Battlefield (as-2) ds 233 | updateCasualties (Battlefield as ds) OneD = Battlefield as (ds-1) 234 | updateCasualties (Battlefield as ds) TwoDs = Battlefield as (ds-2) 235 | updateCasualties (Battlefield as ds) OneA_OneD = Battlefield (as-1) (ds-1) 236 | 237 | -- Lazy multiplication (do not evaluate second argument if first one is 0) 238 | (.*) :: Double -> Double -> Double 239 | 0 .* _ = 0 240 | x .* y = x * y 241 | 242 | -- Returns the exact probability of success based on principles of probability 243 | -- We use memoization in order to speed-up the computations 244 | exactSuccessProb :: Battlefield -> Double 245 | exactSuccessProb (Battlefield _ 0) = 1 246 | exactSuccessProb (Battlefield 0 _) = 0 247 | exactSuccessProb (Battlefield 1 _) = 0 248 | exactSuccessProb b@(Battlefield as ds) = sum probs 249 | where probs = do 250 | c <- [OneA, TwoAs, OneD, TwoDs, OneA_OneD] 251 | let nextBattleProb = battleProb (maxAttackers as) (maxDefenders ds) c 252 | let nextBattlefield = updateCasualties b c 253 | return $ nextBattleProb .* memoizedProb nextBattlefield 254 | 255 | -- Builds a table which is lazily computed using the function given as input 256 | -- to compute the result of each entry 257 | memoize :: (Army -> Army -> Double) -> [[Double]] 258 | memoize f = map (\x -> map (f x) [0..]) [0..] 259 | 260 | -- List of lists where the content is computed on demand (lazily) 261 | -- It acts like a matrix where we access by index to obtain a result 262 | table :: [[Double]] 263 | table = memoize . curry $ exactSuccessProb . uncurry Battlefield 264 | 265 | -- Given a battlefield, return the probability of success for the attacker 266 | -- This function just retrieves the result from the memoization table 267 | memoizedProb :: Battlefield -> Double 268 | memoizedProb (Battlefield as ds) = table !! as !! ds 269 | -------------------------------------------------------------------------------- /homework-12/assignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OctaviPascual/cis194-IntroductionToHaskell/771c9c72d10744dd6593a7478698de640106bb90/homework-12/assignment.pdf --------------------------------------------------------------------------------