├── .gitignore ├── CS316-FP.cabal ├── LICENSE ├── README.md ├── data ├── birth.csv └── death.csv └── lecture-notes ├── Week01.hs ├── Week01Intro.hs ├── Week01Lecture2.hs ├── Week01Problems.hs ├── Week01Solutions.hs ├── Week02.hs ├── Week02Live.hs ├── Week02Problems.hs ├── Week02Solutions.hs ├── Week03.hs ├── Week03Live.hs ├── Week03Problems.hs ├── Week03Solutions.hs ├── Week04.hs ├── Week04Live.hs ├── Week04Problems.hs ├── Week04Solutions.hs ├── Week05.hs ├── Week05Intro.hs ├── Week05Live.hs ├── Week05Problems.hs ├── Week05Solutions.hs ├── Week06.hs ├── Week06Intro.hs ├── Week06Live.hs ├── Week06Problems.hs ├── Week06Solutions.hs ├── Week07.hs ├── Week07Intro.hs ├── Week07Live.hs ├── Week07Problems.hs ├── Week07Solutions.hs ├── Week08.hs ├── Week08Live.hs ├── Week08Live2023.hs ├── Week08Problems.hs ├── Week08Solutions.hs ├── Week09.hs ├── Week09Live.hs ├── Week09Live2023.hs ├── Week10.hs ├── Week10Live.hs └── Week10Live2.hs /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | *~ 3 | -------------------------------------------------------------------------------- /CS316-FP.cabal: -------------------------------------------------------------------------------- 1 | name: CS316-FP 2 | version: 0.1.0.1 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/msp-strath/cs316-functional-programming 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Robert Atkey 9 | maintainer: robert.atkey@strath.ac.uk 10 | copyright: BSD3 11 | category: Education 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | library 17 | hs-source-dirs: lecture-notes 18 | exposed-modules: Week01, 19 | Week01Problems, 20 | Week01Solutions, 21 | Week01Intro, 22 | Week01Lecture2, 23 | Week02, 24 | Week02Problems, 25 | Week02Solutions, 26 | Week02Live, 27 | Week03, 28 | Week03Problems, 29 | Week03Solutions, 30 | Week03Live, 31 | Week04, 32 | Week04Problems, 33 | Week04Solutions, 34 | Week04Live, 35 | Week05, 36 | Week05Problems, 37 | Week05Solutions, 38 | Week05Live, 39 | Week06, 40 | Week06Problems, 41 | Week06Solutions, 42 | Week06Live, 43 | Week07, 44 | Week07Problems, 45 | Week07Solutions, 46 | Week07Live, 47 | Week08, 48 | Week08Problems, 49 | Week08Solutions, 50 | Week08Live2023, 51 | Week08Live, 52 | Week09, 53 | Week09Live2023, 54 | Week09Live, 55 | Week10, 56 | -- Week10Live, 57 | Week10Live2 58 | -- ghc-options: -fwarn-incomplete-patterns 59 | default-language: Haskell2010 60 | build-depends: base >= 4.7 && < 5, 61 | split >= 0.2.3.3, 62 | HTTP >= 4000.3.14, 63 | QuickCheck >= 2.15 64 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Robert Atkey (c) 2020-2024 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Robert Atkey nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CS316 “Functional Programming” 2 | 3 | Welcome to the source code repository for the University of Strathclyde CS316 “Functional Programming” course. 4 | 5 | This is a course designed to teach Haskell to undergraduate students. The written course materials are available from this repository. Video lectures and access to the Mattermost forum for this course are available to Strathclyde students via the course's [MyPlace page](https://classes.myplace.strath.ac.uk/course/view.php?id=15897). 6 | 7 | ## Getting Started 8 | 9 | The code in this repository is structured as a [Cabal](https://www.haskell.org/cabal/) project. You will need to install GHC (the Haskell compiler) and Cabal to get started. It is also advisable to install HLS (the Haskell Language Server) and an LSP-capable editor (e.g. Emacs or VSCode) to read and edit the code. 10 | 11 | To load the code into `ghci` for interactive exploration, you can used 12 | 13 | ``` 14 | $ cabal repl 15 | ``` 16 | 17 | which will load all the lecture notes into the interactive `ghci` repl. Use `import WeekXX` to open a particular module for experimentation. Using the command `:reload` to reload after any changes are made. 18 | 19 | ## Syllabus and Lecture Notes 20 | 21 | The lecture notes for this course are intended to accompany the video lectures (only available to Strathclyde students for now), and provide mostly the same information in a searchable, accessible and less bandwidth hungry format. 22 | 23 | The notes are Haskell files with interleaved code and commentary. You are encouraged to experiment by loading these files into `ghci` (using `cabal repl`) and editing them. Each week also has a set of tutorial questions with solutions that you should have a go at to test your knowledge. 24 | 25 | - [Week 1](lecture-notes/Week01.hs) : Data and Functions 26 | - [Tutorial Problems](lecture-notes/Week01Problems.hs) 27 | - [Tutorial Solutions](lecture-notes/Week01Solutions.hs) 28 | - [Live Lecture code (Tuesday)](lecture-notes/Week01Intro.hs) 29 | - [Live Lecture code (Friday)](lecture-notes/Week01Lecture2.hs) 30 | - [Week 2](lecture-notes/Week02.hs) : Solving Problems by Recursion 31 | - [Tutorial Problems](lecture-notes/Week02Problems.hs) 32 | - [Tutorial Solutions](lecture-notes/Week02Solutions.hs) 33 | - [Live Lecture code (Friday)](lecture-notes/Week02Live.hs) 34 | - [Week 3](lecture-notes/Week03.hs) : Higher Order Functions 35 | - [Tutorial Problems](lecture-notes/Week03Problems.hs) 36 | - [Tutorial Solutions](lecture-notes/Week03Solutions.hs) 37 | - [Live Lecture code (Tuesday)](lecture-notes/Week03Live.hs) 38 | - [Week 4](lecture-notes/Week04.hs) : Patterns of Recursion 39 | - [Tutorial Problems](lecture-notes/Week04Problems.hs) 40 | - [Tutorial Solutions](lecture-notes/Week04Solutions.hs) 41 | - [Live Lecture code (Tuesday and Friday)](lecture-notes/Week04Live.hs) 42 | - [Week 5](lecture-notes/Week05.hs) : Classes of Types 43 | - [Tutorial Problems](lecture-notes/Week05Problems.hs) 44 | - [Tutorial Solutions](lecture-notes/Week05Solutions.hs) 45 | - [Live Lecture Notes (Tuesday and Friday)](lecture-notes/Week05Live.hs) 46 | - [Week 6](lecture-notes/Week06.hs) : Simulating side-effects: Exceptions, State, and Printing 47 | - [Tutorial Problems](lecture-notes/Week06Problems.hs) 48 | - [Tutorial Solutions](lecture-notes/Week06Solutions.hs) 49 | - [Live Lecture code (Tuesday and Friday)](lecture-notes/Week06Live.hs) 50 | - [Week 7](lecture-notes/Week07.hs) : Monads 51 | - [Tutorial Problems](lecture-notes/Week07Problems.hs) 52 | - [Tutorial Solutions](lecture-notes/Week07Solutions.hs) 53 | - [Live Lecture Notes (Tuesday)](lecture-notes/Week07Live.hs) 54 | - [Week 8](lecture-notes/Week08.hs) : Real I/O and Parser Combinators 55 | - [Tutorial Problems](lecture-notes/Week08Problems.hs) 56 | - [Tutorial Solutions](lecture-notes/Week08Solutions.hs) 57 | - [Live Lecture Notes (2023)](lecture-notes/Week08Live2023.hs) 58 | - [Live Lecture Notes (2024)](lecture-notes/Week08Live.hs) 59 | - [Week 9](lecture-notes/Week09.hs) : Data Dependencies and Applicative Functors 60 | - [Live Lecture Code (2023)](lecture-notes/Week09Live.hs) 61 | - [Live Lecture Code (2024)](lecture-notes/Week09Lecture.hs) 62 | - [Week 10](lecture-notes/Week10.hs) : Lazy Evaluation and Infinite Data 63 | - [Live Lecture Code (Tuesday)](lecture-notes/Week10Live.hs) on deriving `Functor` by type-level programming. 64 | - [Live Lecture Code (Friday)](lecture-notes/Week10Live2.hs) on testing with QuickCheck. 65 | 66 | You can take a look at [last year's repository](https://github.com/bobatkey/CS316-2022) and [the one before that](https://github.com/bobatkey/CS316-2021) for similar notes and some different exercises. 67 | -------------------------------------------------------------------------------- /lecture-notes/Week01Intro.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Week01Intro where 4 | 5 | {- WELCOME TO 6 | 7 | CS316 8 | 9 | FUNCTIONAL PROGRAMMING 10 | 11 | 12 | with 13 | Guillaume Allais 14 | Robert Atkey 15 | -} 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | {- In this course, you will: 42 | 43 | - Learn more about Functional Programming (in Haskell) 44 | 45 | 46 | 47 | (Typed) Functional Programming is 48 | 49 | - Defining Datatypes To Represent Problems 50 | 51 | - Defining Functions To Create New Data From Old 52 | 53 | a.k.a "Value-oriented" programming. 54 | 55 | A "Functional Programming Language" is a programming language that 56 | is designed to make it easy to use Functional Programming ideas. -} 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | {- We use Haskell as an example Functional Programming Language. 71 | 72 | - Many languages now include ideas originally from Functional Programming. 73 | 74 | - Functions as values (a.k.a "lambdas") 75 | 76 | - "Algebraic" data types; "Make Illegal States Unrepresentable" 77 | 78 | - Immutability 79 | 80 | - Expressive Types 81 | 82 | - Errors as data, instead of Exceptions 83 | 84 | - No 'null' (the "Billion dollar mistake") 85 | 86 | - Close tracking of possible "side effects" 87 | 88 | Haskell is not perfect (I will grumble about it during the course 89 | [*]), but it does offer a place to learn about Functional 90 | Programming concepts without too many distractions. 91 | 92 | [*] "There are only two kinds of languages: the ones people 93 | complain about and the ones nobody uses.” ― Bjarne Stroustrup, 94 | The C++ Programming Language 95 | -} 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | {- Course arrangements: 104 | 105 | - Lectures: 106 | - Tuesdays at 11:00 107 | - Fridays at 11:00 108 | 109 | Tuesdays at 12:00-16:00 : Labs in Level 12 of Livingstone Tower 110 | 111 | - Holes: 112 | - No lecture on Tuesday 1st October 113 | 114 | - Video lectures, to support the in-person lectures 115 | - ~ 6 videos / week 116 | - ~ 10 minutes long 117 | 118 | - Online lecture notes in a GitHub repository 119 | - git clone https://github.com/msp-strath/cs316-functional-programming 120 | - git pull 121 | 122 | -} 123 | 124 | 125 | {- This is a programming course 126 | 127 | You will be expected to do a lot of programming in order to understand 128 | the concepts. 129 | 130 | 20 credit course : 12 hrs/week, 1 hour of videos, 2 of lectures, 2 labs. 131 | -} 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | {- YOU WILL NEED A WORKING HASKELL INSTALLATION 148 | 149 | - Suggested setup: 150 | 151 | - GHCup (GHC, Cabal, HLS) + VSCode + Haskell extension. 152 | 153 | - I use Emacs in the videos and lectures. 154 | 155 | - There are instructions on MyPlace 156 | 157 | - I (unfortunately) cannot test on Windows, so I will need the 158 | class's help to iron out Windows problems. 159 | 160 | -} 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | {- Assessment: 171 | 172 | - One class test (24 hrs) (50%) 173 | Week 6 174 | 175 | - Redemption test 176 | Week 9 177 | A second chance to do the test 178 | 179 | - One large coursework "mini-project" (50%) 180 | Specification released Week 3 181 | Submission Week 11 182 | 183 | 184 | Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072; try { & ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -Interactive -DisableCurl } catch { Write-Error $_ } 185 | 186 | -} 187 | 188 | 189 | -- Playing cards 190 | data Suit = Diamonds | Hearts | Clubs | Spades | Circle 191 | deriving (Show) 192 | 193 | exampleSuit :: Suit 194 | exampleSuit = Diamonds 195 | 196 | 197 | data Colour = Red | Black 198 | deriving (Show) 199 | 200 | colourOfSuit :: Suit -> Colour 201 | colourOfSuit Diamonds = Red 202 | colourOfSuit Hearts = Red 203 | colourOfSuit Spades = Black 204 | colourOfSuit Circle = Red 205 | colourOfSuit Clubs = Black 206 | 207 | data Value 208 | = Ace 209 | | N2 210 | | N3 211 | | N4 212 | | N5 213 | | N6 214 | | N7 215 | | N8 216 | | N9 217 | | N10 218 | | Jack 219 | | Queen 220 | | King 221 | deriving (Show) 222 | 223 | numericValue :: Value -> Int 224 | numericValue = \ x -> case x of 225 | Ace -> 1 226 | N2 -> 2 227 | N3 -> 3 228 | N4 -> 4 229 | N5 -> 5 230 | N6 -> 6 231 | N7 -> 7 232 | N8 -> 8 233 | N9 -> 9 234 | N10 -> 10 235 | Jack -> 11 236 | Queen -> 12 237 | King -> 13 238 | 239 | lessThanOrEqualValue :: Value -> Value -> Bool 240 | lessThanOrEqualValue v1 v2 = 241 | numericValue v1 <= numericValue v2 242 | 243 | 244 | data Card = MkCard Suit Value 245 | deriving (Show) 246 | 247 | suitOfCard :: Card -> Suit 248 | suitOfCard (MkCard suit _) = suit 249 | 250 | 251 | 252 | {- 253 | suitOfCard (MkCard Hearts Queen) 254 | 255 | 256 | 257 | -} 258 | -------------------------------------------------------------------------------- /lecture-notes/Week01Lecture2.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | module Week01Lecture2 where 3 | 4 | import Data.List 5 | 6 | -- Talk: In the Engine Room of LLMs 7 | -- By: Satnam Singh (Groq Inc) 8 | -- Where: RC513 Wednesday 11am 2nd October 9 | 10 | 11 | data Markup 12 | = Text String 13 | | Bold Markup 14 | | Italic Markup 15 | | Concat Markup Markup 16 | deriving (Show, Eq) 17 | 18 | -- Pandoc tool 19 | 20 | -- Example? 21 | example :: Markup 22 | example = Concat (Text "Hello") (Concat (Text " ") (Bold (Text "world"))) 23 | 24 | -- Hello **world** 25 | 26 | -- Hello world 27 | 28 | 29 | 30 | 31 | 32 | -- catMarkup 33 | catMarkup :: [Markup] -> Markup 34 | catMarkup [] = Text "" 35 | catMarkup [x] = x 36 | catMarkup (x : xs) = Concat x (catMarkup xs) 37 | 38 | 39 | -- catMarkupSpaced [Text "hello", Text "world"] 40 | -- Concat (Text "hello") (Concat (Text " ") (Text "world")) 41 | 42 | catMarkupSpaced :: [Markup] -> Markup 43 | catMarkupSpaced [] = Text "" 44 | catMarkupSpaced [x] = x 45 | catMarkupSpaced (x : xs) = Concat x (Concat (Text " ") (catMarkupSpaced xs)) 46 | 47 | catMarkupSpaced_v2 :: [Markup] -> Markup 48 | catMarkupSpaced_v2 xs = catMarkup (intersperse (Text " ") xs) 49 | -- = catMarkup . intersperse (Text " ") 50 | 51 | -- (.) :: (b -> c) -> (a -> b) -> (a -> c) 52 | -- (g . f) x = g (f x) 53 | 54 | (|>) :: (a -> b) -> (b -> c) -> (a -> c) 55 | (f |> g) x = g (f x) 56 | 57 | sepBy :: Markup -> [Markup] -> Markup 58 | sepBy separator = intersperse separator |> catMarkup 59 | 60 | list :: [Markup] -> Markup 61 | list xs = Concat (Text "[") (Concat (sepBy (Text ", ") xs) (Text "]")) 62 | 63 | between :: Markup -> Markup -> (Markup -> Markup) 64 | between l r xs = Concat l (Concat xs r) 65 | 66 | bracket = between (Text "[") (Text "]") 67 | 68 | strings :: [Markup] -> Markup 69 | strings = map (between (Text "\"") (Text "\"")) |> list 70 | 71 | 72 | -- markupToHTML 73 | 74 | -- markupToHTML :: Markup -> String 75 | -- "Bob" --; 76 | -- DROP TABLE users; 77 | 78 | -- "Little Bobby Tables" 79 | 80 | strong :: [HTML] -> HTML 81 | strong htmls = HEl "strong" htmls 82 | 83 | em htmls = HEl "em" htmls 84 | 85 | data HTML = HText String 86 | | HEl String [HTML] 87 | -- | HConcat HTML HTML 88 | deriving (Show, Eq) 89 | 90 | markupToHTML :: Markup -> [HTML] 91 | markupToHTML (Text s) = [HText s] 92 | markupToHTML (Bold m) = [strong (markupToHTML m)] 93 | markupToHTML (Italic m) = [em (markupToHTML m)] 94 | markupToHTML (Concat m1 m2) = 95 | markupToHTML m1 ++ markupToHTML m2 96 | 97 | 98 | 99 | -- escapeHTML 100 | -------------------------------------------------------------------------------- /lecture-notes/Week01Problems.hs: -------------------------------------------------------------------------------- 1 | module Week01Problems where 2 | 3 | import Week01 4 | import Prelude hiding (Left, Right, reverse) 5 | 6 | {----------------------------------------------------------------------} 7 | {- Exercises -} 8 | {----------------------------------------------------------------------} 9 | 10 | {- In the questions below, replace 'undefined' with your answers. Use 11 | GHCi to test them. -} 12 | 13 | {- 1. Write a function: -} 14 | 15 | isHorizontal :: Direction -> Bool 16 | isHorizontal = undefined 17 | 18 | {- that returns 'True' if the direction is 'Left' or 'Right', and 19 | 'False' otherwise. -} 20 | 21 | 22 | {- 2. Write a function: -} 23 | 24 | flipHorizontally :: Direction -> Direction 25 | flipHorizontally = undefined 26 | 27 | {- that flips horizontally (Left <-> Right, Up and Down stay the same). -} 28 | 29 | 30 | {- 3. Rewrite 'equalDirections' to take a 'Pair Direction Direction' as 31 | input: -} 32 | 33 | pairOfEqualDirections :: Pair Direction Direction -> Bool 34 | pairOfEqualDirections = undefined 35 | 36 | 37 | {- 4. Define a datatype 'Triple a b c' for values that have three 38 | components. Write functions 'get1of3 :: Triple a b c -> a', 39 | 'get2of3' and 'get3of3' that return the first, second and third 40 | components. You will have to come up with the type signatures 41 | for the second and third one. -} 42 | 43 | 44 | {- 5. Pattern matching on specific characters is done by writing the 45 | character to match. For example: -} 46 | 47 | isA :: Char -> Bool 48 | isA 'A' = True 49 | isA _ = False 50 | 51 | {- Write a function 'dropSpaces' :: [Char] -> [Char]' that drops 52 | spaces from the start of a list of characters. For example, we 53 | should have: 54 | 55 | *Week01Problems> dropSpaces " hello" 56 | "hello" 57 | 58 | (Strings in Haskell are really lists of 'Char's, so you can use 59 | pattern matching on them.) -} 60 | 61 | dropSpaces :: [Char] -> [Char] 62 | dropSpaces = undefined 63 | 64 | {- 6. Using 'reverse' and 'dropSpaces', write a function that removes 65 | spaces at the *end* of a list of characters. For example: 66 | 67 | *Week01Problems> dropTrailingSpaces "hello " 68 | "hello" 69 | -} 70 | 71 | dropTrailingSpaces :: [Char] -> [Char] 72 | dropTrailingSpaces = undefined 73 | 74 | {- 7. HTML escaping. When writing HTML, the characters '<', '&', and '>' 75 | are special because they are used to represent tags and 76 | entities. To have these characters display properly as 77 | themselves in HTML they need to be replaced by their entity 78 | versions: 79 | 80 | '<' becomes '<' ("less than") 81 | '>' becomes '>' ("greater than") 82 | '&' becomes '&' ("ampersand") 83 | 84 | Write a function that performs this replacement on a string. You 85 | should have, for example, 86 | 87 | Week01Problems*> htmlEscape "" 88 | "<not a tag>" 89 | -} 90 | 91 | htmlEscape :: String -> String 92 | htmlEscape = undefined 93 | 94 | {- 8. The following datatype represents a piece of text marked up with 95 | style information. -} 96 | 97 | data Markup 98 | = Text String -- ^ Some text 99 | | Bold Markup -- ^ Some markup to be styled in bold 100 | | Italic Markup -- ^ Some markup to be styled in italics 101 | | Concat Markup Markup -- ^ Two pieces of markup to be displayed in sequence 102 | deriving (Show, Eq) 103 | 104 | {- Here is an example: -} 105 | 106 | exampleMarkup :: Markup 107 | exampleMarkup = Concat (Bold (Text "Delays")) (Concat (Text " are ") (Italic (Text "possible"))) 108 | 109 | {- Writing markup like this is tedious, especially when there are 110 | lots of 'Concat's. Write a function that takes a list of 111 | 'Markup's and concatenates them all together using 'Concat'. -} 112 | 113 | catMarkup :: [Markup] -> Markup 114 | catMarkup = undefined 115 | 116 | {- Another way of making the writing of Markup easier is the 117 | automatic insertion of spaces. Write another function that 118 | concatenates a list of 'Markup's putting spaces between them: -} 119 | 120 | catMarkupSpaced :: [Markup] -> Markup 121 | catMarkupSpaced = undefined 122 | 123 | {- Sometimes we want to remove all formatting from a piece of 124 | text. Write a function that removes all 'Bold' and 'Italic' 125 | instructions from a piece of Markup, replacing them with their 126 | underlying plain markup. 127 | 128 | For example: 129 | 130 | Week01Problems*> removeStyle exampleMarkup 131 | Concat (Text "Delays") (Concat (Text " are ") (Text "possible")) 132 | -} 133 | 134 | removeStyle :: Markup -> Markup 135 | removeStyle = undefined 136 | 137 | {- Finally, we can 'render' our markup to HTML. Write a function that 138 | converts 'Markup' to its HTML string representation, using 139 | '..' for bold and '...' for 140 | italics. Use the 'htmEscape' function from above to make sure 141 | that 'Text' nodes are correctly converted to HTML. 142 | 143 | For example: 144 | 145 | Week01Problems*> markupToHTML exampleMarkup 146 | "Delays are possible" 147 | 148 | and 149 | 150 | Week01Problems*> markupToHTML (Bold (Text "<&>")) 151 | "<&>" 152 | -} 153 | 154 | markupToHTML :: Markup -> String 155 | markupToHTML = undefined 156 | -------------------------------------------------------------------------------- /lecture-notes/Week01Solutions.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | module Week01Solutions where 3 | 4 | import Week01 5 | import Prelude hiding (take, drop, Left, Right, Maybe (..), reverse, length) 6 | 7 | {----------------------------------------------------------------------} 8 | {- Tutorial Questions -} 9 | {----------------------------------------------------------------------} 10 | 11 | {- In the questions below, replace 'undefined' with your answers. Use 12 | GHCi to test them.-} 13 | 14 | {- 1. Write a function: -} 15 | 16 | isHorizontal :: Direction -> Bool 17 | isHorizontal Up = False 18 | isHorizontal Down = False 19 | isHorizontal Left = True 20 | isHorizontal Right = True 21 | 22 | {- We could also write: 23 | 24 | isHorizontal Up = False 25 | isHorizontal Down = False 26 | isHorizontal _ = True 27 | 28 | or 29 | 30 | isHorizontal Left = True 31 | isHorizontal Right = True 32 | isHorizontal _ = False 33 | 34 | -} 35 | 36 | {- that returns 'True' if the direction is 'Left' or 'Right', and 37 | 'False' otherwise. -} 38 | 39 | 40 | {- 2. Write a function: -} 41 | 42 | flipHorizontally :: Direction -> Direction 43 | flipHorizontally Left = Right 44 | flipHorizontally Right = Left 45 | flipHorizontally x = x 46 | 47 | {- that flips horizontally (Left <-> Right, Up and Down stay the same). -} 48 | 49 | {- Could also write: 50 | 51 | flipHorizontally Left = Right 52 | flipHorizontally Right = Left 53 | flipHorizontally Up = Up 54 | flipHorizontally Down = Down 55 | -} 56 | 57 | 58 | {- 3. Rewrite 'equalDirections' to take a 'Pair Direction Direction' as 59 | input: -} 60 | 61 | pairOfEqualDirections :: Pair Direction Direction -> Bool 62 | pairOfEqualDirections (MkPair Up Up) = True 63 | pairOfEqualDirections (MkPair Down Down) = True 64 | pairOfEqualDirections (MkPair Left Left) = True 65 | pairOfEqualDirections (MkPair Right Right) = True 66 | pairOfEqualDirections (MkPair _ _) = False 67 | 68 | {- 4. Define a datatype 'Triple a b c' for values that have three 69 | components. Write functions 'get1of3 :: Triple a b c -> a', 70 | 'get2of3' and 'get3of3' that return the first, second and third 71 | components. You will have to come up with the type signatures 72 | for the second and third one. -} 73 | 74 | data Triple a b c = MkTriple a b c 75 | deriving Show 76 | 77 | get1of3 :: Triple a b c -> a 78 | get1of3 (MkTriple a b c) = a 79 | 80 | get2of3 :: Triple a b c -> b 81 | get2of3 (MkTriple a b c) = b 82 | 83 | get3of3 :: Triple a b c -> c 84 | get3of3 (MkTriple a b c) = c 85 | 86 | {- 5. Pattern matching on specific characters is done by writing the 87 | character to match. For example: -} 88 | 89 | isA :: Char -> Bool 90 | isA 'A' = True 91 | isA _ = False 92 | 93 | {- Write a function 'dropSpaces' :: [Char] -> [Char]' that drops 94 | spaces from the start of a list of characters. For example, we 95 | should have: 96 | 97 | *Week01> dropSpaces " hello" 98 | "hello" 99 | 100 | (Strings in Haskell are really lists of 'Char's) -} 101 | 102 | dropSpaces :: [Char] -> [Char] 103 | dropSpaces [] = [] 104 | dropSpaces (' ':xs) = dropSpaces xs 105 | dropSpaces xs = xs 106 | 107 | {- Alternatively: 108 | 109 | dropSpaces [] = [] 110 | dropSpaces (x:xs) = if x == ' ' then dropSpaces xs else (x:xs) 111 | 112 | or 113 | 114 | dropSpaces [] = [] 115 | dropSpaces (x:xs) 116 | | x == ' ' = dropSpaces xs 117 | | otherwise = (x:xs) 118 | -} 119 | 120 | {- 6. Using 'reverse' and 'dropSpaces', write a function that removes 121 | spaces at the *end* of a list of characters. For example: 122 | 123 | *Week10> dropTrailingSpaces "hello " 124 | "hello" 125 | -} 126 | 127 | -- This works by reversing the input so that the spaces to be dropped 128 | -- are at the start, using 'dropSpaces' to remove those spaces, then 129 | -- reversing again to put the letters back in the right order. 130 | 131 | dropTrailingSpaces :: [Char] -> [Char] 132 | dropTrailingSpaces xs = reverse (dropSpaces (reverse xs)) 133 | 134 | {- Alternative, which names the intermediate steps: 135 | 136 | dropTrailingSpaces xs = answer 137 | where reversed = reverse xs 138 | dropped = dropSpaces reversed 139 | answer = reverse dropped 140 | 141 | Alternatively, using knowledge from Week 03 to create a pipeline (read 142 | from right to left!) 143 | 144 | dropTrailingSpaces = reverse . dropSpaces . reverse 145 | 146 | -} 147 | 148 | {- 7. HTML escaping. When writing HTML, the characters '<', '&', and '>' 149 | are special because they are used to represent tags and 150 | entities. To have these characters display properly as 151 | themselves in HTML they need to be replaced by their entity 152 | versions: 153 | 154 | '<' becomes '<' ("less than") 155 | '>' becomes '>' ("greater than") 156 | '&' becomes '&' ("ampersand") 157 | 158 | Write a function that performs this replacement on a string. You 159 | should have, for example, 160 | 161 | Week01Problems*> htmlEscape "" 162 | "<not a tag>" 163 | -} 164 | 165 | htmlEscape :: String -> String 166 | htmlEscape "" = "" 167 | htmlEscape ('<':cs) = "<" ++ htmlEscape cs 168 | htmlEscape ('&':cs) = "&" ++ htmlEscape cs 169 | htmlEscape ('>':cs) = ">" ++ htmlEscape cs 170 | htmlEscape (c:cs) = c : htmlEscape cs 171 | 172 | -- You could also do this using guards, or lots of if-then-else 173 | 174 | {- 8. The following datatype represents a piece of text marked up with 175 | style information. -} 176 | 177 | data Markup 178 | = Text String -- ^ Some text 179 | | Bold Markup -- ^ Some markup to be styled in bold 180 | | Italic Markup -- ^ Some markup to be styled in italics 181 | | Concat Markup Markup -- ^ Two pieces of markup to be displayed in sequence 182 | 183 | {- Here is an example: -} 184 | 185 | exampleMarkup :: Markup 186 | exampleMarkup = Concat (Bold (Text "Delays")) (Concat (Text " are ") (Italic (Text "possible"))) 187 | 188 | {- Writing markup like this is tedious, especially when there are 189 | lots of 'Concat's. Write a function that takes a list of 190 | 'Markup's and concatenates them all together using 'Concat'. -} 191 | 192 | catMarkup :: [Markup] -> Markup 193 | catMarkup [] = Text "" 194 | catMarkup (m:ms) = Concat m (catMarkup ms) 195 | 196 | {- NOTE: There is no constructor for 'Markup' that directly 197 | represents an empty piece of Markup. I have used 'Text ""' to 198 | represent empty markup. Another possibility would be to add a 199 | constructor 'Empty' to the 'Markup' type. -} 200 | 201 | {- Another way of making the writing of Markup easier is the 202 | automatic insertion of spaces. Write another function that 203 | concatenates a list of 'Markup's putting spaces between them: -} 204 | 205 | catMarkupSpaced :: [Markup] -> Markup 206 | catMarkupSpaced [] = Text "" 207 | catMarkupSpaced [m] = m 208 | catMarkupSpaced (m:ms) = Concat m (Concat (Text " ") (catMarkupSpaced ms)) 209 | 210 | {- NOTE: Notice that this function matches specially on the single 211 | element list. This allows us to place spaces (i.e. 'Text " "') 212 | _between_ each element of the input list. 213 | 214 | Another way to write this function would be to do it in two 215 | stages. First take the original input list and place 'Text " "' 216 | between each element. This can either be done by writing a new 217 | function, or by using the 'intersperse' function from the 218 | 'Data.List' module. Then the resulting list can be concatenated 219 | using the 'catMarkup' function defined above. -} 220 | 221 | {- Sometimes we want to remove all formatting from a piece of 222 | text. Write a function that removes all 'Bold' and 'Italic' 223 | instructions from a piece of Markup, replacing them with their 224 | underlying plain markup. 225 | 226 | For example: 227 | 228 | Week01Problems*> removeStyle exampleMarkup 229 | Concat (Text "Delays") (Concat (Text " are ") (Text "possible")) 230 | -} 231 | 232 | removeStyle :: Markup -> Markup 233 | removeStyle (Text s) = Text s 234 | removeStyle (Bold m) = removeStyle m 235 | removeStyle (Italic m) = removeStyle m 236 | removeStyle (Concat m1 m2) = Concat (removeStyle m1) (removeStyle m2) 237 | 238 | {- Finally, we can 'render' our markup to HTML. Write a function that 239 | converts 'Markup' to its HTML string representation, using 240 | '..' for bold and '...' for 241 | italics. Use the 'htmEscape' function from above to make sure 242 | that 'Text' nodes are correctly converted to HTML. 243 | 244 | For example: 245 | 246 | Week01Problems*> markupToHTML exampleMarkup 247 | "Delays are possible" 248 | 249 | and 250 | 251 | Week01Problems*> markupToHTML (Bold (Text "<&>")) 252 | "<&>" 253 | -} 254 | 255 | markupToHTML :: Markup -> String 256 | markupToHTML (Text s) = htmlEscape s 257 | markupToHTML (Bold m) = "" ++ markupToHTML m ++ "" 258 | markupToHTML (Italic m) = "" ++ markupToHTML m ++ "" 259 | markupToHTML (Concat m1 m2) = markupToHTML m1 ++ markupToHTML m2 260 | -------------------------------------------------------------------------------- /lecture-notes/Week02Live.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | module Week02Live where 3 | 4 | type Coin = Int 5 | 6 | makeChange :: [Coin] -- coins that are available 7 | -> [Coin] -- coins used so far 8 | -> Int -- target amount 9 | -> Maybe [Coin] -- coins that add up to the target (maybe) 10 | makeChange available used 0 = Just used 11 | makeChange [] _ n = Nothing 12 | makeChange (coin:available) used n 13 | | n >= coin = makeChange available (coin:used) (n - coin) 14 | | otherwise = makeChange available used n 15 | 16 | correctChange :: [Coin] -> Int -> Bool 17 | correctChange available target = case makeChange available [] target of 18 | Nothing -> True 19 | Just used -> sum used == target 20 | 21 | makeChange_v2 :: [Coin] -> [Coin] -> Int -> Maybe [Coin] 22 | makeChange_v2 available used 0 = Just used 23 | makeChange_v2 [] used n = Nothing 24 | makeChange_v2 (coin:available) used n 25 | | n >= coin = case makeChange_v2 available (coin:used) (n - coin) of 26 | Just change -> Just change 27 | Nothing -> makeChange_v2 available used n 28 | | otherwise = makeChange_v2 available used n 29 | 30 | ------------------------------------------------------------------------------ 31 | 32 | success :: a -> Maybe a 33 | success x = Just x 34 | 35 | failure :: Maybe a 36 | failure = Nothing 37 | 38 | orElse :: Maybe a -> Maybe a -> Maybe a 39 | orElse (Just x) _ = Just x 40 | orElse Nothing y = y 41 | 42 | makeChange_v3 :: [Coin] -> [Coin] -> Int -> Maybe [Coin] 43 | makeChange_v3 available used 0 = success used 44 | makeChange_v3 [] used n = failure 45 | makeChange_v3 (coin:available) used n 46 | | n >= coin = 47 | makeChange_v3 available (coin:used) (n - coin) 48 | `orElse` 49 | makeChange_v3 available used n 50 | | otherwise = makeChange_v3 available used n 51 | 52 | -- myFunc(f(), g()) 53 | 54 | successL :: a -> [a] 55 | successL x = [x] 56 | 57 | failureL :: [a] 58 | failureL = [] 59 | 60 | orElseL :: [a] -> [a] -> [a] 61 | orElseL xs ys = xs ++ ys 62 | 63 | makeChange_v4 :: [Coin] -> [Coin] -> Int -> [[Coin]] 64 | makeChange_v4 available used 0 = successL used 65 | makeChange_v4 [] used n = failureL 66 | makeChange_v4 (coin:available) used n 67 | | n >= coin = 68 | makeChange_v4 available (coin:used) (n - coin) 69 | `orElseL` 70 | makeChange_v4 available used n 71 | | otherwise = makeChange_v4 available used n 72 | 73 | ------------------------------------------------------------------------------ 74 | 75 | data Choices a 76 | = Success a 77 | | Failure 78 | | Choose (Choices a) (Choices a) 79 | deriving Show 80 | 81 | successC :: a -> Choices a 82 | successC x = Success x 83 | 84 | failureC :: Choices a 85 | failureC = Failure 86 | 87 | orElseC :: Choices a -> Choices a -> Choices a 88 | orElseC xs ys = Choose xs ys 89 | 90 | makeChange_v5 :: [Coin] -> [Coin] -> Int -> Choices [Coin] 91 | makeChange_v5 available used 0 = successC used 92 | makeChange_v5 [] used n = failureC 93 | makeChange_v5 (coin:available) used n 94 | | n >= coin = 95 | makeChange_v5 available (coin:used) (n - coin) 96 | `orElseC` 97 | makeChange_v5 available used n 98 | | otherwise = makeChange_v5 available used n 99 | 100 | greedy :: Choices a -> Maybe a 101 | greedy (Success x) = Just x 102 | greedy Failure = Nothing 103 | greedy (Choose x y) = greedy x 104 | 105 | firstChoice :: Choices a -> Maybe a 106 | firstChoice (Success x) = Just x 107 | firstChoice Failure = Nothing 108 | firstChoice (Choose x y) = firstChoice x `orElse` firstChoice y 109 | 110 | allChoices :: Choices a -> [a] 111 | allChoices (Success x) = [x] 112 | allChoices Failure = [] 113 | allChoices (Choose x y) = allChoices x ++ allChoices y 114 | 115 | best :: (a -> Int) -> Choices a -> Maybe a 116 | best cost (Success x) = Just x 117 | best cost Failure = Nothing 118 | best cost (Choose x y) = 119 | case (best cost x, best cost y) of 120 | (Nothing, Nothing) -> Nothing 121 | (Just x, Nothing) -> Just x 122 | (Nothing, Just y) -> Just y 123 | (Just x, Just y) -> 124 | if cost x <= cost y then Just x else Just y 125 | -------------------------------------------------------------------------------- /lecture-notes/Week02Problems.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | module Week02Problems where 3 | 4 | import Week02 5 | 6 | {------------------------------------------------------------------------------} 7 | {- TUTORIAL QUESTIONS -} 8 | {------------------------------------------------------------------------------} 9 | 10 | {- In the questions below, replace 'undefined' with your answers. Use 11 | GHCi to test them.-} 12 | 13 | {- 1. Write a function that counts the number of occurrences of an 14 | element in list: -} 15 | 16 | popCount :: Eq a => a -> [a] -> Int 17 | popCount = undefined 18 | 19 | {- (popCount is short for "population count"). Examples: 20 | 21 | popCount 2 [1,2,5,2,7,2,9] == 3 22 | popCount 9 [1,2,5,2,7,2,9] == 1 23 | popCount 0 [1,2,5,2,7,2,9] == 0 24 | -} 25 | 26 | 27 | {- 2. Write a version of 'insert' that only inserts into a sorted list 28 | if the element is not already there. Examples: 29 | 30 | insertNoDup 2 [1,3,4] == [1,2,3,4] 31 | insertNoDup 2 [1,2,3,4] == [1,2,3,4] 32 | -} 33 | 34 | insertNoDup :: Ord a => a -> [a] -> [a] 35 | insertNoDup = undefined 36 | 37 | 38 | {- 3. Write a version of 'remove' that removes all copies of an element 39 | from a sorted list, not just the first one. Examples: 40 | 41 | removeAll 2 [1,2,2,3] == [1,3] 42 | removeAll 2 [1,3] == [1,3] 43 | -} 44 | 45 | removeAll :: Ord a => a -> [a] -> [a] 46 | removeAll = undefined 47 | 48 | 49 | {- 4. Rewrite 'treeFind' and 'treeInsert' to use 'compare' and 'case' 50 | expressions. -} 51 | 52 | treeFind2 :: Ord k => k -> KV k v -> Maybe v 53 | treeFind2 = undefined 54 | 55 | treeInsert2 :: Ord k => k -> v -> KV k v -> KV k v 56 | treeInsert2 = undefined 57 | 58 | 59 | {- 5. MergeSort is another sorting algorithm that works in the following 60 | way: 61 | 62 | - If the list to be sorted is zero length, then it is already 63 | sorted. 64 | 65 | - If the list to be sorted has one element, then it is already 66 | sorted. 67 | 68 | - Otherwise, split the list into two, one with the even elements 69 | and one with the odd elements. Sort the two lists by calling 70 | 'mergeSort' recursively. Then merge the two lists together 71 | maintaining the ordering. 72 | 73 | Write this function in three parts: -} 74 | 75 | {- 'split' splits the input into two lists: one with the odd numbered 76 | elements and one with the even numbered elements. For example: 77 | 78 | > split [45,12,89,29,93] 79 | ([45,89,93],[12,29]) 80 | 81 | HINT: you can pattern match on multiple elements at the head of 82 | a list with 'x1:x2:xs', and you can use the '(odds,evens) = ...' 83 | syntax in a 'where' clause. -} 84 | 85 | split :: [a] -> ([a], [a]) 86 | split = undefined 87 | 88 | {- 'merge' merges two sorted lists into one sorted list. Examples: 89 | 90 | merge [1,3,5] [2,4,6] = [1,2,3,4,5,6] 91 | merge [1,3,5] [7,9,11] = [1,3,5,7,9,11] 92 | -} 93 | 94 | merge :: Ord a => [a] -> [a] -> [a] 95 | merge = undefined 96 | 97 | {- 'mergeSort' uses 'split' and 'merge' to implement the merge sort 98 | algorithm described above. -} 99 | 100 | mergeSort :: Ord a => [a] -> [a] 101 | mergeSort = undefined 102 | 103 | 104 | {- 6. Write another version of 'makeChange' that returns all the 105 | possible ways of making change as a list: -} 106 | 107 | makeChangeAll :: [Coin] -> [Coin] -> Int -> [[Coin]] 108 | makeChangeAll = undefined 109 | 110 | {- HINT: you don't need a case expression, just a way of appending two 111 | lists of possibilities. -} 112 | 113 | {- 7. This question involves converting between two datatypes. A 'Row' 114 | is a list of strings, such as you might find in a database: -} 115 | 116 | -- | A row is a list of strings, one for each field. For example: 117 | -- 118 | -- > ["Mount Snowden", "Wales"] 119 | type Row = [String] 120 | 121 | {- Note that the names of the fields, which might be 'Mountain' and 122 | 'Country' here, are implicit in this representation. 123 | 124 | The second type is a record, which is a list of pairs of field 125 | names with their data: -} 126 | 127 | -- | A record is a list of fieldname / value pairs. For example: 128 | -- 129 | -- > [("Mountain", "Mont Blanc"), ("Country", "France")] 130 | type Record = [(String,String)] 131 | 132 | {- Implement the following functions on rows and records: -} 133 | 134 | -- | Look up a field in a record, returning @Nothing@ if the field is 135 | -- not in the record. For example, 136 | -- > lookupField "a" [("a","1"),("b","2")] 137 | -- returns @Just "1"@, but 138 | -- > lookupField "c" [("a","1"),("b","3")] 139 | -- returns @Nothing@. 140 | lookupField :: String -> Record -> Maybe String 141 | lookupField fieldname record = 142 | error "lookupField: not implemented" 143 | 144 | -- | Given a header listing field names, like: 145 | -- 146 | -- > ["Mountain", "Country"] 147 | -- 148 | -- and a row like: 149 | -- 150 | -- > ["Ben Nevis", "Scotland"] 151 | -- 152 | -- turn it into a record like: 153 | -- 154 | -- > [("Mountain", "Ben Nevis"), ("Country", "Scotland")] 155 | -- 156 | -- If the number of field names in the header does not match the 157 | -- number of fields in the row, an @Nothing@ should be returned. 158 | rowToRecord :: [String] -> Row -> Maybe Record 159 | rowToRecord header row = 160 | error "rowToRecord: not implemented" 161 | 162 | -- | Given a header listing field names, and a list of rows, converts 163 | -- each row into a record. See 'rowToRecord' for how individual rows 164 | -- are converted to records. 165 | rowsToRecords :: [String] -> [Row] -> Maybe [Record] 166 | rowsToRecords header rows = 167 | error "rowsToRecord: not implemented" 168 | 169 | -- | Given a header listing field names, like: 170 | -- 171 | -- > ["Mountain", "Country"] 172 | -- 173 | -- and a record like: 174 | -- 175 | -- > [("Mountain", "Ben Nevis"), ("Country", "Scotland")] 176 | -- 177 | -- turn it into a row like: 178 | -- 179 | -- > ["Ben Nevis", "Scotland"] 180 | -- 181 | -- It does not matter what order the fields in the record are in, so the 182 | -- record: 183 | -- 184 | -- > [("Country", "Scotland"), ("Mountain", "Ben Nevis")] 185 | -- 186 | -- should result in the same row. 187 | -- 188 | -- This function returns an @Nothing@ if any of the field names listed in 189 | -- the header are not in the record. 190 | recordToRow :: [String] -> Record -> Maybe Row 191 | recordToRow header record = 192 | error "recordToRow: not implemented" 193 | 194 | -- | Given a header listing field names, and a list of records, 195 | -- converts each record into a row. See 'recordToRow' for how 196 | -- individual records are converted to rows. 197 | recordsToRows :: [String] -> [Record] -> Maybe [Row] 198 | recordsToRows header records = 199 | error "recordsToRows: not implemented" 200 | -------------------------------------------------------------------------------- /lecture-notes/Week03Live.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Week03Live where 4 | 5 | import Prelude hiding (id, ($), (.), flip, map, filter) 6 | 7 | -- Week 03 : HIGHER ORDER FUNCTIONS 8 | 9 | -- This week : coursework to be released before Friday lecture. 10 | -- worth 50% 11 | -- Deadline : 17:00 Tuesday 3rd December 2024 12 | 13 | id :: forall a. a -> a 14 | id x = x 15 | 16 | ($) :: forall a b. (a -> b) -> a -> b 17 | ($) = id 18 | 19 | -- Composition 20 | (.) :: (b -> c) -> (a -> b) -> (a -> c) 21 | (.) f g = \x -> f (g x) 22 | 23 | -- Pipe (|>) 24 | (|>) :: forall a b. a -> (a -> b) -> b 25 | (|>) = flip ($) 26 | -- (|>) a f = f a 27 | 28 | -- flip 29 | flip :: forall a b c. (a -> b -> c) -> (b -> (a -> c)) 30 | flip f b a = f a b 31 | 32 | 33 | -- partialApply 34 | partialApply :: ((a, b) -> c) -> a -> (b -> c) 35 | partialApply f x = \ y -> f (x, y) 36 | 37 | 38 | 39 | ------------------------------------------------------------------------------ 40 | 41 | -- map 42 | map :: forall a b. (a -> b) -> [a] -> [b] 43 | map f [] = [] 44 | map f (x : xs) = f x : map f xs 45 | 46 | -- filter 47 | filter :: (a -> Bool) -- test p 48 | -> [a] -- values xs 49 | -> [a] -- only the x in xs that satisfy p 50 | filter p [] = [] 51 | filter p (x : xs) 52 | | p x = x : filter p xs 53 | | otherwise = filter p xs 54 | 55 | 56 | -- dupAll 57 | dupAll :: [a] -> [a] 58 | dupAll xs = xs |> map (\x -> [x,x]) |> concat 59 | -- xs |> map (\x -> x : x : ) 60 | 61 | -- Duplicating every element of a list by generating two-element lists 62 | -- and then concatenating: 63 | 64 | -- [1,2,3,4] 65 | -- map (\x -> [x,x]) gives [[1,1], [2,2], [3,3], [4,4]] 66 | -- concat gives [1,1,2,2,3,3,4,4] 67 | 68 | -- dupAll [1,2,3,4] = [1,1,2,2,3,3,4,4] 69 | 70 | 71 | -- What if we do something else in the mop? 72 | -- 73 | -- Instead of constructing a two-element list for every element of the 74 | -- input list, what if we return a _function_ that prepends two 75 | -- elements to a list? 76 | -- 77 | -- [1,2,3,4] |> map (\x ys -> x : x : ys) 78 | -- gives 79 | -- [\ys -> 1 : 1 : ys, \ys -> 2 : 2 : ys, \ys -> 3 : 3 : ys, \ys -> 4 : 4 : ys] 80 | -- 81 | -- If we now 'map (\f -> f [])' after this, we fill in each 'ys' with 82 | -- '[]', then we get a list of two-element lists again: 83 | -- 84 | -- [1,2,3,4] |> map (\x ys -> x : x : ys) |> map (\f -> f []) 85 | -- gives 86 | -- [[1,1],[2,2],[3,3],[4,4]] 87 | -- 88 | -- But there are more things we can do. Since we have a list of 89 | -- functions, we can compose them all together with a function like 90 | -- this: 91 | 92 | composeAll :: [a -> a] -> a -> a 93 | composeAll [] = id 94 | composeAll (f:fs) = f . composeAll fs 95 | 96 | -- [1,2,3,4] |> map (\x ys -> x : x : ys) |> composeAll 97 | -- gives 98 | -- [1,1,2,2,3,3,4,4] 99 | -- 100 | -- Exercise: Why? Can you write out the steps that lead to this 101 | -- answer? 102 | -- 103 | -- So we get the same answer as before, but this idea of taking the 104 | -- rest of the output as 'ys' enables extra power. Effectively we are 105 | -- getting access to the “future” result. In this example we are then 106 | -- prepending two copies of each element to this future result. But we 107 | -- can do a bit more: 108 | -- 109 | -- [1,2,3,4] |> map (\x ys -> [x] ++ ys ++ [x]) |> composeAll 110 | -- gives 111 | -- [1,2,3,4,4,3,2,1] 112 | -- 113 | -- At every step, this puts each element of the input at the beginning 114 | -- and end of the rest of the results, leading to this "balanced" 115 | -- output. 116 | -- 117 | -- This kind of "access to the future" is surprisingly useful. In some 118 | -- programming languages it is possible to queue up things to do after 119 | -- the current task has finished. In the Go programming langauge, for 120 | -- example, there is a 'defer' instruction which adds some code to run 121 | -- when the current function finishes. This is used to add "clean up" 122 | -- code, similar to 'finally' blocks in Java. See 123 | -- https://go.dev/blog/defer-panic-and-recover . 124 | 125 | 126 | ------------------------------------------------------------------------------ 127 | 128 | -- We didn't do this in the lecture, but it is similar to the 129 | -- exercises at the end of the Week 03 Problems file. 130 | 131 | data Formula a 132 | = Atom a 133 | | And (Formula a) (Formula a) 134 | | Or (Formula a) (Formula a) 135 | | Not (Formula a) 136 | deriving Show 137 | 138 | eval :: Formula Bool -> Bool 139 | eval (Atom b) = b 140 | eval (And p q) = eval p && eval q 141 | eval (Or p q) = eval p || eval q 142 | eval (Not p) = not (eval p) 143 | 144 | evalWith :: (a -> Bool) -> Formula a -> Bool 145 | evalWith valuation (Atom a) = valuation a 146 | evalWith valuation (And p q) = evalWith valuation p && evalWith valuation q 147 | evalWith valuation (Or p q) = evalWith valuation q || evalWith valuation q 148 | evalWith valuation (Not p) = not (evalWith valuation p) 149 | 150 | mapFormula :: (a -> b) -> Formula a -> Formula b 151 | mapFormula f (Atom a) = Atom (f a) 152 | mapFormula f (And p q) = And (mapFormula f p) (mapFormula f q) 153 | mapFormula f (Or p q) = Or (mapFormula f p) (mapFormula f q) 154 | mapFormula f (Not p) = Not (mapFormula f p) 155 | -------------------------------------------------------------------------------- /lecture-notes/Week03Problems.hs: -------------------------------------------------------------------------------- 1 | module Week03Problems where 2 | 3 | import Data.Char 4 | 5 | {------------------------------------------------------------------------------} 6 | {- TUTORIAL QUESTIONS -} 7 | {------------------------------------------------------------------------------} 8 | 9 | {- 1. Lambda notation. 10 | 11 | Rewrite the following functions using the '\x -> e' notation (the 12 | "lambda" notation), so that they are written as 'double = 13 | ', and so on. -} 14 | 15 | mulBy2 :: Int -> Int 16 | mulBy2 x = 2*x 17 | 18 | mul :: Int -> Int -> Int 19 | mul x y = x * y 20 | 21 | invert :: Bool -> Bool 22 | invert True = False 23 | invert False = True 24 | {- HINT: use a 'case', or an 'if'. -} 25 | 26 | 27 | {- 2. Partial Application 28 | 29 | The function 'mul' defined above has the type 'Int -> Int -> 30 | Int'. (a) What is the type of the Haskell expression: 31 | 32 | mul 10 33 | 34 | (b) what is 'mul 10'? How can you use it to multiply a number? -} 35 | 36 | 37 | {- 3. Partial Application 38 | 39 | Write the 'mulBy2' function above using 'mul'. Can you make your 40 | function as short as possible? -} 41 | 42 | double_v2 :: Int -> Int 43 | double_v2 = undefined -- fill this in 44 | 45 | {- 4. Using 'map'. 46 | 47 | The function 'toUpper' takes a 'Char' and turns lower case 48 | characters into upper cases one. All other characters it returns 49 | unmodified. For example: 50 | 51 | > toUpper 'a' 52 | 'A' 53 | > toUpper 'A' 54 | 'A' 55 | 56 | Strings are lists of characters. 'map' is a function that applies a 57 | function to every character in a list and returns a new list. 58 | 59 | Write the function 'shout' that uppercases a string, so that: 60 | 61 | > shout "hello" 62 | "HELLO" 63 | -} 64 | 65 | shout :: String -> String -- remember that String = [Char] 66 | shout = undefined 67 | 68 | 69 | {- 5. Using 'map' with another function. 70 | 71 | The function 'concat' concatenates a list of lists to make one 72 | list: 73 | 74 | > concat [[1,2],[3,4],[5,6]] 75 | [1,2,3,4,5,6] 76 | 77 | Using 'map', 'concat', and either a helper function or a function 78 | written using '\', write a function 'dupAll' that duplicates every 79 | element in a list. For example: 80 | 81 | > dupAll [1,2,3] 82 | [1,1,2,2,3,3] 83 | > dupAll "my precious" 84 | "mmyy pprreecciioouuss" 85 | 86 | HINT: try writing a helper function that turns single data values 87 | into two element lists. -} 88 | 89 | dupAll :: [a] -> [a] 90 | dupAll = undefined 91 | 92 | 93 | {- 6. Using 'filter' 94 | 95 | (a) Use 'filter' to return a list consisting of only the 'E's in 96 | a 'String'. 97 | 98 | (b) Use 'onlyEs' and 'length' to count the number of 'E's in a string. 99 | 100 | (c) Write a single function that takes a character 'c' and a string 101 | 's' and counts the number of 'c's in 's'. -} 102 | 103 | onlyEs :: String -> String 104 | onlyEs = undefined 105 | 106 | numberOfEs :: String -> Int 107 | numberOfEs = undefined 108 | 109 | numberOf :: Char -> String -> Int 110 | numberOf = undefined 111 | 112 | 113 | {- 7. Rewriting 'filter' 114 | 115 | (a) Write a function that does the same thing as filter, using 116 | 'map' and 'concat'. 117 | 118 | (b) Write a function that does a 'map' and a 'filter' at the same 119 | time, again using 'map' and 'concat'. 120 | -} 121 | 122 | filter_v2 :: (a -> Bool) -> [a] -> [a] 123 | filter_v2 = undefined 124 | 125 | filterMap :: (a -> Maybe b) -> [a] -> [b] 126 | filterMap = undefined 127 | 128 | 129 | {- 8. Composition 130 | 131 | Write a function '>>>' that composes two functions. It takes two 132 | functions 'f' and 'g', and returns a function that first runs 'f' 133 | on its argument, and then runs 'g' on the result. 134 | 135 | HINT: this is similar to the function 'compose' in the notes for 136 | this week. -} 137 | 138 | (>>>) :: (a -> b) -> (b -> c) -> a -> c 139 | (>>>) = undefined 140 | 141 | {- Try rewriting the 'numberOfEs' function from above using this one. -} 142 | 143 | {- 9. Backwards application 144 | 145 | Write a function of the following type that takes a value 'x' and a 146 | function 'f' and applies 'f' to 'x'. Note that this functions takes 147 | its arguments in reverse order to normal function application! -} 148 | 149 | (|>) :: a -> (a -> b) -> b 150 | (|>) x f = undefined 151 | 152 | 153 | {- This function can be used between its arguments like so: 154 | 155 | "HELLO" |> map toLower 156 | 157 | and it is useful for chaining calls left-to-right instead of 158 | right-to-left as is usual in Haskell: 159 | 160 | "EIEIO" |> onlyEs |> length 161 | -} 162 | 163 | {- 10. Flipping 164 | 165 | Write a function that takes a two argument function as an input, 166 | and returns a function that does the same thing, but takes its 167 | arguments in reverse order: -} 168 | 169 | flip :: (a -> b -> c) -> b -> a -> c 170 | flip = undefined 171 | 172 | {- 11. Evaluating Formulas 173 | 174 | Here is a datatype describing formulas in propositional logic, as 175 | in CS208 last year. Atomic formulas are represented as 'String's. -} 176 | 177 | data Formula 178 | = Atom String 179 | | And Formula Formula 180 | | Or Formula Formula 181 | | Not Formula 182 | deriving Show 183 | 184 | {- (a) Write a function that evaluates a 'Formula' to a 'Bool'ean value, 185 | assuming that all the atomic formulas are given the value 186 | 'True'. Note that the following Haskell functions do the basic 187 | operations on 'Bool'eans: 188 | 189 | (&&) :: Bool -> Bool -> Bool -- 'AND' 190 | (||) :: Bool -> Bool -> Bool -- 'OR' 191 | not :: Bool -> Bool -- 'NOT' 192 | -} 193 | 194 | eval_v1 :: Formula -> Bool 195 | eval_v1 = undefined 196 | 197 | 198 | 199 | 200 | {- (b) Now write a new version of 'eval_v1' that, instead of evaluating 201 | every 'Atom a' to 'True', takes a function that gives a 'Bool' 202 | for each atomic proposition: -} 203 | 204 | eval :: (String -> Bool) -> Formula -> Bool 205 | eval = undefined 206 | 207 | {- For example: 208 | 209 | eval (\s -> s == "A") (Or (Atom "A") (Atom "B")) == True 210 | eval (\s -> s == "A") (And (Atom "A") (Atom "B")) == False 211 | -} 212 | 213 | {- 12. Substituting Formulas 214 | 215 | Write a function that, given a function 's' that turns 'String's 216 | into 'Formula's (a "substitution"), replaces all the atomic 217 | formulas in a Formula with whatever 'f' tells it to: -} 218 | 219 | subst :: (String -> Formula) -> Formula -> Formula 220 | subst = undefined 221 | 222 | {- For example: 223 | 224 | subst (\s -> if s == "A" then Not (Atom "A") else Atom s) (And (Atom "A") (Atom "B")) == And (Not (Atom "A")) (Atom "B") 225 | -} 226 | 227 | {- 13. Evaluating with failure 228 | 229 | The 'eval' function in 8(b) assumed that every atom could be 230 | assigned a value. But what if it can't? Write a function of the 231 | following type that takes as input a function that may or may not 232 | give a 'Bool' for each atom, and correspondingly, may or may not 233 | give a 'Bool' for the whole formula. -} 234 | 235 | evalMaybe :: (String -> Maybe Bool) -> Formula -> Maybe Bool 236 | evalMaybe = undefined 237 | -------------------------------------------------------------------------------- /lecture-notes/Week03Solutions.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | module Week03Solutions where 3 | 4 | import Data.Char 5 | 6 | {------------------------------------------------------------------------------} 7 | {- TUTORIAL QUESTIONS -} 8 | {------------------------------------------------------------------------------} 9 | 10 | {- 1. Lambda notation. 11 | 12 | Rewrite the following functions using the '\x -> e' notation (the 13 | "lambda" notation), so that they are written as 'double = 14 | ', and so on. -} 15 | 16 | mulBy2 :: Int -> Int 17 | mulBy2 = \x -> 2*x 18 | 19 | mul :: Int -> Int -> Int 20 | mul = \x y -> x * y 21 | 22 | invert :: Bool -> Bool 23 | invert = -- \x -> if x then False else True 24 | -- not 25 | \x -> case x of 26 | True -> False 27 | False -> True 28 | {- HINT: use a 'case', or an 'if'. -} 29 | 30 | 31 | {- 2. Partial Application 32 | 33 | The function 'mul' defined above has the type 'Int -> Int -> 34 | Int'. (a) What is the type of the Haskell expression: 35 | 36 | mul 10 37 | 38 | ANSWER: mul 10 has type 'Int -> Int' 39 | 40 | (b) what is 'mul 10'? How can you use it to multiply a number? 41 | 42 | ANSWER: 'mul 10' is a function that multiplies its argument bt 43 | 10. You can use to do this multiplication by applying it to a 44 | value. So 'mul 10 20' gives the answer 200. 45 | -} 46 | 47 | 48 | {- 3. Partial Application 49 | 50 | Write the 'mulBy2' function above using 'mul'. Can you make your 51 | function as short as possible? -} 52 | 53 | double_v2 :: Int -> Int 54 | double_v2 = mul 2 55 | 56 | {- The longer version is: 57 | 58 | double_v2 x = mul 2 x 59 | 60 | but every time you have a function definition that looks like this: 61 | 62 | fname x y z = z 63 | 64 | it can be shortened to: 65 | 66 | fname x y = 67 | -} 68 | 69 | {- 4. Using 'map'. 70 | 71 | The function 'toUpper' takes a 'Char' and turns lower case 72 | characters into upper cases one. All other characters it returns 73 | unmodified. For example: 74 | 75 | > toUpper 'a' 76 | 'A' 77 | > toUpper 'A' 78 | 'A' 79 | 80 | Strings are lists of characters. 'map' is a function that applies a 81 | function to every character in a list and returns a new list. 82 | 83 | Write the function 'shout' that uppercases a string, so that: 84 | 85 | > shout "hello" 86 | "HELLO" 87 | -} 88 | 89 | shout :: String -> String -- remember that String = [Char] 90 | shout = map toUpper 91 | 92 | 93 | {- Longer version: 94 | 95 | shout xs = map toUpper xs 96 | 97 | -} 98 | 99 | {- 5. Using 'map' with another function. 100 | 101 | The function 'concat' concatenates a lists of lists to make one 102 | list: 103 | 104 | > concat [[1,2],[3,4],[5,6]] 105 | [1,2,3,4,5,6] 106 | 107 | Using 'map', 'concat', and either a helper function or a function 108 | written using '\', write a function 'dupAll' that duplicates every 109 | element in a list. For example: 110 | 111 | > dupAll [1,2,3] 112 | [1,1,2,2,3,3] 113 | > dupAll "my precious" 114 | "mmyy pprreecciioouuss" 115 | 116 | HINT: try writing a helper function that turns single data values 117 | into two element lists. -} 118 | 119 | dupAll :: [a] -> [a] 120 | dupAll xs = concat (map (\x -> [x,x]) xs) 121 | 122 | 123 | {- A shorter version is this: 124 | 125 | dupAll = concat . map (\x -> [x,x]) 126 | 127 | which uses the composition operator '.' 128 | -} 129 | 130 | 131 | -- [1,2,3] 132 | -- [[1,1],[2,2],[3,3]] 133 | -- [1,1,2,2,3,3] 134 | 135 | {- Compare this to the recursive version: 136 | 137 | dupAll [] = [] 138 | dupAll (x:xs) = x : x : dupAll xs 139 | 140 | The difference between this and the definition using 'map' is that 141 | it mixes the concerns of 'duplicate an element' and 'do this to 142 | every element'. The version using 'map' explicitly makes clear that 143 | something is happening to every element of the list. 144 | 145 | In a small example like this, it is not immediately clear which 146 | version is easier, but when the amount of things we want to do to 147 | every element gets larger, map can often be clearer to show intent. -} 148 | 149 | 150 | 151 | {- 6. Using 'filter' 152 | 153 | (a) Use 'filter' to return a list consisting of only the 'E's in 154 | a 'String'. 155 | 156 | (b) Use 'onlyEs' and 'length' to count the number of 'E's in a string. 157 | 158 | (c) Write a single function that takes a character 'c' and a string 159 | 's' and counts the number of 'c's in 's'. -} 160 | 161 | onlyEs :: String -> String 162 | onlyEs = filter (\x -> x == 'E') 163 | 164 | numberOfEs :: String -> Int 165 | numberOfEs xs = length (onlyEs xs) 166 | 167 | {- A shorter version is: 168 | 169 | numberOfEs = length . onlyEs 170 | -} 171 | 172 | numberOf :: Char -> String -> Int 173 | numberOf c = length . filter (\x -> x == c) 174 | 175 | 176 | {- 7. Rewriting 'filter' 177 | 178 | (a) Write a function that does the same thing as filter, using 179 | 'map' and 'concat'. 180 | 181 | (b) Write a function that does a 'map' and a 'filter' at the same 182 | time, again using 'map' and 'concat'. 183 | -} 184 | 185 | {- This is idea of the solution below. If the predicate is "\x -> x == 'E'", then we map every 'E' to ['E'] and everything else to []. Then we concatenate all the lists. 186 | 187 | ['E', 'I','E', 'I','O'] 188 | ==> [['E'],[], ['E'], [], [] ] 189 | ==> ['E', 'E' ] 190 | -} 191 | 192 | filter_v2 :: (a -> Bool) -> [a] -> [a] 193 | filter_v2 p = concat . map (\x -> if p x then [x] else []) 194 | 195 | filterMap :: (a -> Maybe b) -> [a] -> [b] 196 | filterMap p = concat . map (\x -> case p x of 197 | Nothing -> [] 198 | Just y -> [y]) 199 | 200 | 201 | {- 8. Composition 202 | 203 | Write a function '>>>' that composes two functions: takes two 204 | functions 'f' and 'g', and returns a function that first runs 'f' 205 | on its argument, and then runs 'g' on the result. 206 | 207 | HINT: this is similar to the function 'compose'. -} 208 | 209 | (>>>) :: (a -> b) -> (b -> c) -> a -> c 210 | (>>>) f g x = g (f x) 211 | 212 | -- NOTE: the functions 'f' and 'g' appear the other way round in 213 | -- the function body. 214 | 215 | {- Try rewriting the 'numberOfEs' function from above using this one. -} 216 | 217 | numberOfEs_v2 = filter (\x -> x == 'E') >>> length 218 | 219 | {- 9. Backwards application 220 | 221 | Write a function of the following type that takes a value 'x' and a 222 | function 'f' and applies 'f' to 'x'. Note that this functions takes 223 | its arguments in reverse order to normal function application! -} 224 | 225 | (|>) :: a -> (a -> b) -> b 226 | (|>) x f = f x 227 | 228 | 229 | {- This function can be used between its arguments like so: 230 | 231 | "HELLO" |> map toLower 232 | 233 | and it is useful for chaining calls left-to-right instead of 234 | right-to-left as is usual in Haskell: 235 | 236 | "EIEIO" |> onlyEs |> length 237 | -} 238 | 239 | {- 10. Flipping 240 | 241 | Write a function that takes a two argument function as an input, 242 | and returns a function that does the same thing, but takes its 243 | arguments in reverse order: -} 244 | 245 | flip :: (a -> b -> c) -> b -> a -> c 246 | flip f a b = f b a 247 | 248 | 249 | {- 11. Evaluating Formulas 250 | 251 | Here is a datatype describing formulas in propositional logic, as 252 | in CS208 last year. Atomic formulas are represented as 'String's. -} 253 | 254 | data Formula 255 | = Atom String 256 | | And Formula Formula 257 | | Or Formula Formula 258 | | Not Formula 259 | deriving Show 260 | 261 | {- (a) Write a function that evaluates a 'Formula' to a 'Bool'ean value, 262 | assuming that all the atomic formulas are given the value 263 | 'True'. Note that the following Haskell functions do the basic 264 | operations on 'Bool'eans: 265 | 266 | (&&) :: Bool -> Bool -> Bool -- 'AND' 267 | (||) :: Bool -> Bool -> Bool -- 'OR' 268 | not :: Bool -> Bool -- 'NOT' 269 | -} 270 | 271 | eval_v1 :: Formula -> Bool 272 | eval_v1 (Atom a) = True 273 | eval_v1 (And p q) = eval_v1 p && eval_v1 q 274 | eval_v1 (Or p q) = eval_v1 p || eval_v1 q 275 | eval_v1 (Not p) = not (eval_v1 p) 276 | 277 | 278 | 279 | 280 | {- (b) Now write a new version of 'eval_v1' that, instead of evaluating 281 | every 'Atom a' to 'True', takes a function that gives a 'Bool' 282 | for each atomic proposition: -} 283 | 284 | eval :: (String -> Bool) -> Formula -> Bool 285 | eval v (Atom a) = v a 286 | eval v (And p q) = eval v p && eval v q 287 | eval v (Or p q) = eval v p || eval v q 288 | eval v (Not p) = not (eval v p) 289 | 290 | {- For example: 291 | 292 | eval (\s -> s == "A") (Or (Atom "A") (Atom "B")) == True 293 | eval (\s -> s == "A") (And (Atom "A") (Atom "B")) == False 294 | -} 295 | 296 | 297 | {- 12. Substituting Formulas 298 | 299 | Write a function that, given a function 's' that turns 'String's 300 | into 'Formula's (a "substitution"), replaces all the atomic 301 | formulas in a Formula with whatever 'f' tells it to: -} 302 | 303 | subst :: (String -> Formula) -> Formula -> Formula 304 | subst v (Atom a) = v a 305 | subst v (And p q) = subst v p `And` subst v q 306 | subst v (Or p q) = subst v p `Or` subst v q 307 | subst v (Not p) = Not (subst v p) 308 | 309 | {- For example: 310 | 311 | subst (\s -> if s == "A" then Not (Atom "A") else Atom s) (And (Atom "A") (Atom "B")) == And (Not (Atom "A")) (Atom "B") 312 | -} 313 | 314 | {- 13. Evaluating with failure 315 | 316 | The 'eval' function in 8(b) assumed that every atom could be 317 | assigned a value. But what if it can't? Write a function of the 318 | following type that takes as input a function that may or may not 319 | give a 'Bool' for each atom, and correspondingly, may or may not 320 | give a 'Bool' for the whole formula. -} 321 | 322 | evalMaybe :: (String -> Maybe Bool) -> Formula -> Maybe Bool 323 | evalMaybe v (Atom a) = v a 324 | evalMaybe v (And p q) = 325 | case evalMaybe v p of 326 | Nothing -> Nothing 327 | Just x -> 328 | case evalMaybe v q of 329 | Nothing -> Nothing 330 | Just y -> 331 | Just (x && y) 332 | evalMaybe v (Or p q) = 333 | case evalMaybe v p of 334 | Nothing -> Nothing 335 | Just x -> 336 | case evalMaybe v q of 337 | Nothing -> Nothing 338 | Just y -> 339 | Just (x || y) 340 | evalMaybe v (Not p) = 341 | case evalMaybe v p of 342 | Nothing -> Nothing 343 | Just x -> 344 | Just (not x) 345 | 346 | {- This is pretty complex and noisy looking, because it makes all the 347 | error handling explicit. On the other hand, it is easy to trace 348 | what will happen in all of the possible cases, including those that 349 | happen when there are errors. We will see ways of making it look 350 | nicer in Weeks 6 & 7. 351 | 352 | One thing to think about is why the 'Atom a' case is this: 353 | 354 | evalMaybe v (Atom a) = v a 355 | 356 | and not: 357 | 358 | evalMaybe v (Atom a) = 359 | case v a of 360 | Nothing -> Nothing 361 | Just x -> Just x 362 | 363 | the answer is that anything like: 364 | 365 | case of 366 | Nothing -> Nothing 367 | Just x -> Just x 368 | 369 | is always equal to '' -- the 'case' is returning 370 | 'Nothing' when the value is 'Nothing' and 'Just x' when it is 'Just 371 | x', so in the end it does nothing to the value returned by 372 | '' and can be removed. -} 373 | -------------------------------------------------------------------------------- /lecture-notes/Week04Live.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fwarn-incomplete-patterns #-} 2 | module Week04Live where 3 | 4 | import Data.Char (toUpper) 5 | import Prelude hiding (foldl, length, product, sum, concat) 6 | 7 | -- WEEK 04 : PATTERNS of RECURSION 8 | 9 | sum :: [Int] -> Int 10 | sum [] = 0 11 | sum (x : xs) = x + sum xs 12 | 13 | append :: [a] -> [a] -> [a] 14 | append [] ys = ys 15 | append (x : xs) ys = x : (append xs ys) 16 | 17 | append' :: [a] -> [a] -> [a] 18 | append' xs ys = foldr (:) ys xs 19 | 20 | concat :: [[a]] -> [a] 21 | concat [] = [] 22 | concat (xs : xss) = xs ++ concat xss 23 | 24 | common :: b -> (a -> b -> b) -> [a] -> b 25 | common base step [] = base 26 | common base step (x : xs) = step x (common base step xs) 27 | 28 | sum' :: [Int] -> Int 29 | sum' = foldr (+) 0 30 | 31 | -- a : (b : (c : (d : []))) 32 | -- a + (b + (c + (d + 0))) 33 | 34 | concat' :: [[a]] -> [a] 35 | concat' = foldr (++) [] 36 | 37 | data Natural = Zero | Succ Natural deriving (Show) 38 | 39 | foldNatural :: b -- ^ base case 40 | -> (b -> b) -- ^ step case 41 | -> Natural -> b -- ^ a machine for crushing naturals 42 | foldNatural base step Zero = base 43 | foldNatural base step (Succ n) = step (foldNatural base step n) 44 | 45 | add :: Natural -> Natural -> Natural 46 | add x y = foldNatural y Succ x 47 | 48 | add' :: Natural -> Natural -> Natural 49 | add' Zero y = y 50 | add' (Succ x) y = Succ (add' x y) 51 | 52 | -- x = Succ (Succ (Succ Zero)) "3" 53 | -- y = Succ (Succ Zero) "2" 54 | -- 55 | -- Succ (Succ (Succ Zero)) 56 | -- (Succ (Succ Zero)) 57 | -- (Succ (Succ (Succ Zero))) 58 | -- (Succ (Succ (Succ (Succ Zero)))) 59 | -- (Succ (Succ (Succ (Succ (Succ Zero))))) 60 | 61 | -- a : (b : (c : [])) 62 | -- a + (b + (c + 0 )) 63 | -- (((0 + a) + b) + c) 64 | 65 | foldl :: b -- initial value of the accumulator 66 | -> (b -> a -> b) -- update function for the accumulator 67 | -> [a] -> b -- list-crushing function 68 | foldl acc update [] = acc 69 | foldl acc update (x : xs) = 70 | let acc' = update acc x in 71 | foldl acc' update xs 72 | 73 | step :: String -> String -> String 74 | step a b = "(" ++ a ++ " ### " ++ b ++ ")" 75 | 76 | {- 77 | public static String step (String a, String b) { 78 | return "(" + a + " + " + b + ")"; 79 | } 80 | -} 81 | 82 | base :: String 83 | base = "0" 84 | 85 | 86 | data Bank = Account Integer Integer deriving Show 87 | 88 | data Transaction 89 | = CreditA Integer 90 | | CreditB Integer 91 | | DebitA Integer 92 | | DebitB Integer 93 | | TransferAtoB Integer 94 | deriving Show 95 | 96 | bankStep :: Bank -> Transaction -> Bank 97 | bankStep (Account a b) (CreditA amount) = Account (a + amount) b 98 | bankStep (Account a b) (DebitA amount) = Account (a - amount) b 99 | bankStep (Account a b) (CreditB amount) = Account a (b + amount) 100 | bankStep (Account a b) (DebitB amount) = Account a (b - amount) 101 | bankStep (Account a b) (TransferAtoB amount) = Account (a - amount) (b + amount) 102 | 103 | daysTransactions :: [Transaction] 104 | daysTransactions = 105 | [ CreditA 10, 106 | DebitB 20, 107 | CreditA 10, 108 | TransferAtoB 20 109 | ] 110 | 111 | initialBank :: Bank 112 | initialBank = Account 0 0 113 | 114 | ------------------------------------------------------------------------------ 115 | 116 | -- interface ListVisitor { 117 | -- public Result visitNil(); 118 | -- public Result visitElement(Element a, Result restOfTheList); 119 | -- } 120 | -- 121 | -- Result visitListRight(ListVisitor visitor, List list) { 122 | -- Result answer = visitor.visitNil(); 123 | -- for (int i = list.length() - 1; i >= 0; i--) { 124 | -- answer = visitor.visitElement(list.get(i), answer); 125 | -- } 126 | -- return answer; 127 | -- } 128 | -- 129 | -- Result visitListLeft(ListVisitor visitor, List list) { 130 | -- Result answer = visitor.visitNil(); 131 | -- for (Element e : list) { 132 | -- answer = visitor.visitElement(e, answer); 133 | -- } 134 | -- return answer; 135 | -- } 136 | 137 | ------------------------------------------------------------------------------ 138 | 139 | data Formula a 140 | = Atom a 141 | | And (Formula a) (Formula a) 142 | | Or (Formula a) (Formula a) 143 | | Not (Formula a) 144 | deriving Show 145 | 146 | foldrFormula :: (a -> b -> b) -> b -> Formula a -> b 147 | foldrFormula combine initial f = case f of 148 | Atom a -> combine a initial 149 | And e f -> 150 | -- foldr c n (xs ++ ys) == foldr c (foldr c n ys) xs 151 | let intermediate = foldrFormula combine initial f in 152 | let final = foldrFormula combine intermediate e in 153 | final 154 | Or e f -> 155 | -- foldr c n (xs ++ ys) == foldr c (foldr c n ys) xs 156 | -- f x y (e a b) == let z = e a b in f x y z 157 | let intermediate = foldrFormula combine initial f in 158 | let final = foldrFormula combine intermediate e in 159 | final 160 | Not f -> foldrFormula combine initial f 161 | 162 | myFormula :: Formula String 163 | myFormula = Not (And (Atom "X") (Atom "Y")) 164 | 165 | foldFormula :: (a -> result) -- atoms 166 | -> (result -> result -> result) -- ands 167 | -> (result -> result -> result) -- ors 168 | -> (result -> result) -- not 169 | -> Formula a 170 | -> result 171 | foldFormula atom and or not (Atom b) = atom b 172 | foldFormula atom and or not (And e f) = 173 | and (foldFormula atom and or not e) 174 | (foldFormula atom and or not f) 175 | foldFormula atom and or not (Or e f) = 176 | or (foldFormula atom and or not e) 177 | (foldFormula atom and or not f) 178 | foldFormula atom and or not (Not f) = 179 | not (foldFormula atom and or not f) 180 | 181 | -- foldrFormula c n = foldr c n . foldFormula (\x -> [x]) (++) (++) id 182 | 183 | ------------------------------------------------------------------------------ 184 | -- List comprehensions 185 | 186 | exampleList :: [Int] 187 | exampleList = [1..10] 188 | 189 | evens :: [Int] 190 | evens = [ x | x <- exampleList 191 | , x `mod` 2 == 0 192 | ] 193 | 194 | evenSums :: [(Int, Int)] 195 | evenSums = 196 | [ (x, y) 197 | | x <- exampleList, y <- exampleList 198 | , (x + y) `mod` 2 == 0 199 | , x <= y ] 200 | 201 | -- SELECT DISTINCT T1.x, T2.x 202 | -- FROM exampleList as T1, exampleList as T2 203 | -- WHERE (T1.x + T2.x) `mod` 2 == 0 204 | -- AND T1.x <= T2.x 205 | 206 | myDatabase :: [(String, String, Int)] 207 | myDatabase = [ ("BobTown", "Mars", 100) 208 | , ("GallaisVille", "Venus", 200) 209 | , ("Alasdairopolis", "Mercury", 1) 210 | , ("JulesCity", "Mars", 200) 211 | ] 212 | 213 | -- An example "query" 214 | myQuery = [ map toUpper cityName 215 | | (cityName, planet, pop) <- myDatabase 216 | , (pop > 5) || (planet == "Mars") 217 | ] 218 | 219 | -- equivalent to 220 | -- 221 | -------------------------------------------------------------------------------- /lecture-notes/Week04Problems.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | module Week04Problems where 3 | 4 | import Prelude hiding (foldr, foldl, Maybe (..), Left, Right, filter, zip, map, concat) 5 | import Data.List.Split (splitOn) 6 | import Data.List hiding (foldr, foldl, filter, map, concat) 7 | import Week04 8 | 9 | {------------------------------------------------------------------------------} 10 | {- TUTORIAL QUESTIONS -} 11 | {------------------------------------------------------------------------------} 12 | 13 | {- 1. The following recursive function returns the list it is given as 14 | input: -} 15 | 16 | listIdentity :: [a] -> [a] 17 | listIdentity [] = [] 18 | listIdentity (x:xs) = x : listIdentity xs 19 | 20 | {- Write this function as a 'foldr' (fill in the 'undefined's): -} 21 | 22 | listIdentity' :: [a] -> [a] 23 | listIdentity' = foldr undefined undefined 24 | 25 | {- 2. The following recursive function does a map and a filter at the 26 | same time. If the function argument sends an element to 27 | 'Nothing' it is discarded, and if it sends it to 'Just b' then 28 | 'b' is placed in the output list. -} 29 | 30 | mapFilter :: (a -> Maybe b) -> [a] -> [b] 31 | mapFilter f [] = [] 32 | mapFilter f (x:xs) = case f x of 33 | Nothing -> mapFilter f xs 34 | Just b -> b : mapFilter f xs 35 | 36 | {- Write this function as a 'foldr' by replacing the 'undefined's: -} 37 | 38 | mapFilter' :: (a -> Maybe b) -> [a] -> [b] 39 | mapFilter' f xs = foldr undefined undefined xs 40 | 41 | 42 | 43 | {- For example, if we define -} 44 | 45 | decodeBinaryDigit :: Char -> Maybe Int 46 | decodeBinaryDigit '0' = Just 0 47 | decodeBinaryDigit '1' = Just 1 48 | decodeBinaryDigit _ = Nothing 49 | 50 | {- 51 | mapFilter' decodeBinaryDigit "a0b1c0" == [0,1,0] 52 | -} 53 | 54 | 55 | {- 3. Above we saw that 'foldl' and 'foldr' in general give different 56 | answers. However, it is possible to define 'foldl' just by using 57 | 'foldr'. 58 | 59 | First try to define a function that is the same as 'foldl', 60 | using 'foldr', 'reverse' and a '\' function: -} 61 | 62 | foldlFromFoldrAndReverse :: (b -> a -> b) -> b -> [a] -> b 63 | foldlFromFoldrAndReverse f x xs = undefined 64 | 65 | {- Much harder: define 'foldl' just using 'foldr' and a '\' function: -} 66 | 67 | foldlFromFoldr :: (b -> a -> b) -> b -> [a] -> b 68 | foldlFromFoldr f x xs = undefined 69 | 70 | 71 | {- 4. The following is a datatype of Natural Numbers (whole numbers 72 | greater than or equal to zero), represented in unary. A natural 73 | number 'n' is represented as 'n' applications of 'Succ' to 74 | 'Zero'. So '2' is 'Succ (Succ Zero)'. Using the same recipe we 75 | used above for 'Tree's and 'Maybe's, work out the type and 76 | implementation of a 'fold' function for 'Nat's. -} 77 | 78 | data Nat 79 | = Zero 80 | | Succ Nat 81 | deriving Show 82 | 83 | {- HINT: think about proofs by induction. A proof by induction has a 84 | base case and a step case. -} 85 | 86 | 87 | {- 5. Write a list comprehension to generate all the cubes (x*x*x) of 88 | the numbers 1 to 10: -} 89 | 90 | cubes :: [Int] 91 | cubes = undefined 92 | 93 | 94 | {- 6. The replicate function copies a single value a fixed number of 95 | times: 96 | 97 | > replicate 5 'x' 98 | "xxxxx" 99 | 100 | Write a version of replicate using a list comprehension: -} 101 | 102 | replicate' :: Int -> a -> [a] 103 | replicate' = undefined 104 | 105 | {- 7. One-pass Average. 106 | 107 | It is possible to use 'foldr' to 108 | implement many other interesting functions on lists. For example 109 | 'sum' and 'len': -} 110 | 111 | sumDoubles :: [Double] -> Double 112 | sumDoubles = foldr (\x sum -> x + sum) 0 113 | 114 | lenList :: [a] -> Integer 115 | lenList = foldr (\_ l -> l + 1) 0 116 | 117 | {- Putting these together, we can implement 'avg' to compute the average 118 | (mean) of a list of numbers: -} 119 | 120 | avg :: [Double] -> Double 121 | avg xs = sumDoubles xs / fromInteger (lenList xs) 122 | 123 | {- Neat as this function is, it is not as efficient as it could be. It 124 | traverses the input list twice: once to compute the sum, and then 125 | again to compute the length. It would be better if we had a single 126 | pass that computed the sum and length simultaneously and returned a 127 | pair. 128 | 129 | Implement such a function, using foldr: -} 130 | 131 | sumAndLen :: [Double] -> (Double, Integer) 132 | sumAndLen = undefined 133 | 134 | {- Once you have implemented your 'sumAndLen' function, this alternative 135 | average function will work: -} 136 | 137 | avg' :: [Double] -> Double 138 | avg' xs = total / fromInteger length 139 | where (total, length) = sumAndLen xs 140 | 141 | {- 8. mapTree from foldTree 142 | 143 | Here is the 'Tree' datatype that is imported from the Week04 module: 144 | 145 | data Tree a 146 | = Leaf 147 | | Node (Tree a) a (Tree a) 148 | deriving Show 149 | 150 | As we saw in the lecture notes, it is possible to write a generic 151 | recursor pattern for trees, similar to 'foldr', copied here for reference: 152 | 153 | foldTree :: b -> (b -> a -> b -> b) -> Tree a -> b 154 | foldTree l n Leaf = l 155 | foldTree l n (Node lt x rt) = n (foldTree l n lt) x (foldTree l n rt) 156 | 157 | Your job is to implement 'mapTree' (from Week03) in terms of 158 | 'foldTree': -} 159 | 160 | mapTree :: (a -> b) -> Tree a -> Tree b 161 | mapTree = undefined 162 | 163 | {- Here is the explicitly recursive version of 'mapTree', for 164 | reference: -} 165 | 166 | mapTree0 :: (a -> b) -> Tree a -> Tree b 167 | mapTree0 f Leaf = Leaf 168 | mapTree0 f (Node lt x rt) = Node (mapTree0 f lt) (f x) (mapTree0 f rt) 169 | 170 | {- 9. Finally, use 'foldTree' to flatten a tree to list in left-to-right 171 | order: -} 172 | 173 | flatten :: Tree a -> [a] 174 | flatten = undefined 175 | -------------------------------------------------------------------------------- /lecture-notes/Week04Solutions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ParallelListComp #-} 2 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 3 | module Week04Solutions where 4 | 5 | import Prelude hiding (foldr, foldl, Maybe (..), Left, Right, filter, zip, map, concat) 6 | import Data.List.Split (splitOn) 7 | import Data.List hiding (foldr, foldl, filter, map, concat) 8 | import Week04 9 | 10 | {------------------------------------------------------------------------------} 11 | {- TUTORIAL QUESTIONS -} 12 | {------------------------------------------------------------------------------} 13 | 14 | {- 1. The following recursive function returns the list it is given as 15 | input: -} 16 | 17 | listIdentity :: [a] -> [a] 18 | listIdentity [] = [] 19 | listIdentity (x:xs) = x : listIdentity xs 20 | 21 | {- Write this function as a 'foldr': -} 22 | 23 | listIdentity' :: [a] -> [a] 24 | listIdentity' = foldr (\x r -> x : r) -- step case, combines the head and the tail using ':' 25 | [] -- base case, the empty list [] 26 | 27 | {- See how the base case is the same as the first clause in the original 28 | definition of 'listIdentity'. The step case is the same as the 29 | second clause, except that the recursive call 'listIdentity xs' has 30 | been replaced by 'r'. 31 | 32 | We can also shorten this to: 33 | 34 | listIdentity' = foldr (:) [] 35 | 36 | because '(:)' is the same thing as '(\x r -> x : r)': any infix 37 | operation, like ':' can be written as a function that takes two 38 | arguments by putting it in brackets. 39 | 40 | Let's see how this works by writing out the steps on a short list: 41 | 42 | foldr (\x r -> x:r) [] [1,2] 43 | = (\x r -> x:r) 1 (foldr (\x r -> x:r) [] [2]) 44 | = (\x r -> x:r) 1 ((\x r -> x:r) 2 (foldr (\x r -> x:r) [] [])) 45 | = (\x r -> x:r) 1 ((\x r -> x:r) 2 []) 46 | = (\x r -> x:r) 1 (2:[]) 47 | = 1:2:[] 48 | = [1,2] 49 | -} 50 | 51 | {- 2. The following recursive function does a map and a filter at the 52 | same time. If the function argument sends an element to 53 | 'Nothing' it is discarded, and if it sends it to 'Just b' then 54 | 'b' is placed in the output list. -} 55 | 56 | mapFilter :: (a -> Maybe b) -> [a] -> [b] 57 | mapFilter f [] = [] 58 | mapFilter f (x:xs) = case f x of 59 | Nothing -> mapFilter f xs 60 | Just b -> b : mapFilter f xs 61 | 62 | {- Write this function as a 'foldr': -} 63 | 64 | mapFilter' :: (a -> Maybe b) -> [a] -> [b] 65 | mapFilter' f = foldr (\x r -> case f x of Nothing -> r -- \___ step case 66 | Just b -> b : r) -- / 67 | [] -- base case 68 | 69 | {- The base case is the same as for 'listIdentity'' above. 70 | 71 | In the step case, we have to decide whether or not to add the new 72 | element to the list. We 'case' on the result of 'f x'. If it is 73 | 'Nothing', we return 'r' (which is representing the recursive call 74 | 'mapFilter f xs'). If it is 'Just b', we put 'b' on the front of 75 | 'r' (compare the 'listIdentity' function above). -} 76 | 77 | 78 | {- 3. Above we saw that 'foldl' and 'foldr' in general give different 79 | answers. However, it is possible to define 'foldl' just by using 80 | 'foldr'. 81 | 82 | First try to define a function that is the same as 'foldl', 83 | using 'foldr', 'reverse' and a '\' function: -} 84 | 85 | {- The key thing to notice is that the difference between 'foldl' and 86 | 'foldr' is that 'foldl' goes left-to-right and 'foldr' goes right 87 | to left. So it makes sense to reverse the input list. The function 88 | argument 'f' then takes its arguments in the wrong order, so we 89 | flip them using a little '\' function. -} 90 | 91 | foldlFromFoldrAndReverse :: (b -> a -> b) -> b -> [a] -> b 92 | foldlFromFoldrAndReverse f x xs = foldr (\a b -> f b a) x (reverse xs) 93 | 94 | {- We could have also used the 'flip' function from last week's 95 | questions, which is provided by the standard library: -} 96 | 97 | foldlFromFoldrAndReverse_v2 :: (b -> a -> b) -> b -> [a] -> b 98 | foldlFromFoldrAndReverse_v2 f x xs = foldr (flip f) x (reverse xs) 99 | 100 | {- Much harder: define 'foldl' just using 'foldr' and a '\' function: -} 101 | 102 | {- 103 | foldl :: (b -> a -> b) -> b -> [a] -> b 104 | foldl f a [] = a 105 | foldl f a (x:xs) = foldl f (f a x) xs 106 | -} 107 | 108 | -- This is quite a bit more complex than the other solution using 109 | -- 'reverse'. The key idea is to construct a "transformer" function 110 | -- with 'foldr' that acts like 'foldl' would. Try writing out some 111 | -- steps of this function with some example 'f's to see how it works. 112 | 113 | foldlFromFoldr :: (b -> a -> b) -> b -> [a] -> b 114 | foldlFromFoldr f a xs = foldr (\a g b -> g (f b a)) id xs a 115 | 116 | {- Remember from Week03 that 'id' is '\x -> x': the function that just 117 | returns its argument. -} 118 | 119 | {- Understanding 'foldlFromFoldr' may take a bit of work. The key point 120 | is that we use 'foldr' to build a /function/ from the input list 121 | 'xs' that will compute the left fold from any given initial value. 122 | 123 | In more detail, the 'foldr' is used to build a function that takes 124 | an accumulator argument, similar to the 'fastReverse' function in 125 | Week01: 126 | 127 | - The 'id' is the base case: it takes the accumulator and returns 128 | it (compare the first clause of 'foldl', which returns 'a'). 129 | 130 | - The '\a g b -> g (f b a)' is the step case: 131 | 132 | - 'a' is the value from the input list 133 | - 'g' is the result of processing the rest of the list, which a 134 | /function/ that is expecting an accumulator. 135 | - 'b' is the accumulator so far. 136 | 137 | So this function combines the value 'a' and the accumulator 'b' 138 | using 'f', and passes that to 'g'. 139 | 140 | So it is doing a 'fastReverse' and a 'foldr' at the same time (with 141 | the flipped arguments to 'f'), so can be seen as an optimised 142 | version of the first solution. 143 | 144 | It may be helpful to understand the /types/ involved. We are 145 | writing a function with this type (the type of 'foldl'): 146 | 147 | (b -> a -> b) -> b -> [a] -> b 148 | 149 | and 'foldr' has this generic type: 150 | 151 | (a -> b -> b) -> b -> [a] -> b 152 | 153 | but we are *using* 'foldr' with this type: 154 | 155 | foldr :: (a -> (b -> b) -> (b -> b)) -> -- 'step case' 156 | (b -> b) -> -- 'base case' 157 | [a] -> -- 'input list' 158 | b -> -- 'initial accumulator' 159 | b -- result 160 | 161 | Note that the 'step case' takes a function and returns a function: 162 | we are building a /function/ by recursion. 163 | 164 | Don't worry if you don't get this at the first few attempts. It 165 | takes some time to rewrite your mind to see functions as something 166 | that can be built incrementally by other functions! Looking at the 167 | types is usually a good way to not get lost. -} 168 | 169 | 170 | 171 | {- 4. The following is a datatype of Natural Numbers (whole numbers 172 | greater than or equal to zero), represented in unary. A natural 173 | number 'n' is represented as 'n' applications of 'Succ' to 174 | 'Zero'. So '2' is 'Succ (Succ Zero)'. Using the same recipe we 175 | used above for 'Tree's and 'Maybe's, work out the type and 176 | implementation of a 'fold' function for 'Nat's. -} 177 | 178 | data Nat 179 | = Zero -- a bit like [] 180 | | Succ Nat -- a bit like x : xs, but without the 'x' 181 | deriving Show 182 | 183 | foldNat :: (b -> b) -> b -> Nat -> b 184 | foldNat succ zero Zero = zero 185 | foldNat succ zero (Succ n) = succ (foldNat succ zero n) 186 | 187 | {- HINT: think about proofs by induction. A proof by induction has a 188 | base case and a step case. -} 189 | 190 | {- Here we have 'zero' for the base case, 'succ' for the step case. 191 | 192 | As an example, we can define 'add' for 'Nat' in terms of 'foldNat', 193 | which has a similar structure to 'append' for lists: -} 194 | 195 | add :: Nat -> Nat -> Nat 196 | add x y = foldNat Succ y x 197 | 198 | {- 5. Write a list comprehension to generate all the cubes (x*x*x) of 199 | the numbers 1 to 10: -} 200 | 201 | cubes :: [Int] 202 | cubes = [ x*x*x | x <- [1..10] ] 203 | 204 | 205 | {- 6. The replicate function copies a single value a fixed number of 206 | times: 207 | 208 | > replicate 5 'x' 209 | "xxxxx" 210 | 211 | Write a version of replicate using a list comprehension: -} 212 | 213 | replicate' :: Int -> a -> [a] 214 | replicate' n a = [ a | _ <- [1..n]] 215 | 216 | {- 7. One-pass Average. 217 | 218 | It is possible to use 'foldr' to 219 | implement many other interesting functions on lists. For example 220 | 'sum' and 'len': -} 221 | 222 | sumDoubles :: [Double] -> Double 223 | sumDoubles = foldr (\x sum -> x + sum) 0 224 | 225 | lenList :: [a] -> Integer 226 | lenList = foldr (\_ l -> l + 1) 0 227 | 228 | {- Putting these together, we can implement 'avg' to compute the average 229 | (mean) of a list of numbers: -} 230 | 231 | avg :: [Double] -> Double 232 | avg xs = sumDoubles xs / fromInteger (lenList xs) 233 | 234 | {- Neat as this function is, it is not as efficient as it could be. It 235 | traverses the input list twice: once to compute the sum, and then 236 | again to compute the length. It would be better if we had a single 237 | pass that computed the sum and length simultaneously and returned a 238 | pair. 239 | 240 | Implement such a function, using foldr: -} 241 | 242 | sumAndLen :: [Double] -> (Double, Integer) 243 | sumAndLen = foldr (\x (sum, len) -> (x + sum, len + 1)) (0,0) 244 | 245 | -- NOTE: The solution combines the functions used in 'sumDoubles' and 246 | -- 'lenList' by making it take a pair '(sum,len)' as well as the list 247 | -- element 'x'. It then adds 'x' to the 'sum' part and '1' to the 248 | -- 'len' part. 249 | 250 | {- Once you have implemented your 'sumAndLen' function, this alternative 251 | average function will work: -} 252 | 253 | avg' :: [Double] -> Double 254 | avg' xs = total / fromInteger length 255 | where (total, length) = sumAndLen xs 256 | 257 | {- 8. mapTree from foldTree 258 | 259 | Here is the 'Tree' datatype that is imported from the Week04 module: 260 | 261 | data Tree a 262 | = Leaf 263 | | Node (Tree a) a (Tree a) 264 | deriving Show 265 | 266 | As we saw in the lecture notes, it is possible to write a generic 267 | recursor pattern for trees, similar to 'foldr', copied here for reference: 268 | 269 | foldTree :: b -> (b -> a -> b -> b) -> Tree a -> b 270 | foldTree l n Leaf = l 271 | foldTree l n (Node lt x rt) = n (foldTree l n lt) x (foldTree l n rt) 272 | 273 | Your job is to implement 'mapTree' (from Week03) in terms of 274 | 'foldTree': -} 275 | 276 | mapTree :: (a -> b) -> Tree a -> Tree b 277 | mapTree f = foldTree Leaf -- Leaf case: 'Leaf's become 'Leaf's 278 | (\l x r -> Node l (f x) r) -- Node case: 'Node's become 'Node's, but with the data changed 279 | 280 | {- Here is the explicitly recursive version of 'mapTree', for 281 | reference: -} 282 | 283 | mapTree0 :: (a -> b) -> Tree a -> Tree b 284 | mapTree0 f Leaf = Leaf 285 | mapTree0 f (Node lt x rt) = Node (mapTree0 f lt) (f x) (mapTree0 f rt) 286 | 287 | 288 | {- 9. Finally, use 'foldTree' to flatten a tree to list in left-to-right 289 | order: -} 290 | 291 | flatten :: Tree a -> [a] 292 | flatten = foldTree [] -- Leaf case: has no elements, so is the empty list 293 | (\l x r -> l ++ [x] ++ r) -- Node case: append the left, middle, and right together 294 | -------------------------------------------------------------------------------- /lecture-notes/Week05Intro.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | module Week05Intro where 3 | 4 | import Prelude hiding (Left, Right, Semigroup (..), 5 | Foldable (..), Functor (..), 6 | Monoid (..), Maybe (..)) 7 | import Data.Char 8 | 9 | {- WEEK 05 : CLASSES OF TYPES 10 | 11 | 1. Types in Haskell 12 | 2. The Billion-dollar mistake 13 | 3. Make Illegal States Unrepresentable 14 | 4. Parse; don't validate 15 | 5. Introduction to Type Classes 16 | 17 | -} 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -- 1. Type Synonyms, Newtypes and Data types 29 | 30 | -- Giving things names 31 | data Direction = Up | Down | Left | Right 32 | -- data Tree a = Leaf | Node (Tree a) a (Tree a) 33 | 34 | type Transformation = Direction -> Direction 35 | 36 | flipVertically :: Transformation 37 | -- Direction -> Direction 38 | flipVertically Up = Down 39 | flipVertically Down = Up 40 | flipVertically d = d 41 | 42 | newtype Bool2 = MkBool2 Bool 43 | -- data Bool2 = MkBool2 Bool 44 | 45 | -- Units of Measure 46 | -- Int, Double, Integer, Float 47 | 48 | newtype Metres = M Double 49 | newtype Seconds = S Double 50 | 51 | distanceToTheMoon :: Metres 52 | distanceToTheMoon = M 38275628376 53 | 54 | timeForLightToTheMoon :: Seconds 55 | timeForLightToTheMoon = S 49 56 | 57 | -- Double 58 | 59 | 60 | -- Passwords 61 | 62 | newtype Password = P String 63 | 64 | 65 | 66 | -- 2. Exceptional conditions as Data 67 | 68 | -- Maybe vs null 69 | -- Maybe vs exceptions 70 | 71 | -- Billion dollar mistake: 72 | -- https://www.infoq.com/presentations/Null-References-The-Billion-Dollar-Mistake-Tony-Hoare/ 73 | 74 | data Maybe a 75 | = Nothing 76 | | Just a 77 | deriving (Eq, Show) 78 | 79 | -- case maybeThing of 80 | -- Nothing -> ... 81 | -- Just a -> ... 82 | -- 83 | -- a.doThing() 84 | 85 | search :: Eq k => k -> [(k,v)] -> Maybe v 86 | search k [] = Nothing 87 | search k ((k',v):kvs) = if k == k' then Just v else search k kvs 88 | 89 | -- [(k,Maybe Double)] -> Maybe (Maybe Double) 90 | -- [(k,Double)] -> Maybe Double 91 | 92 | 93 | -- https://docs.oracle.com/en/java/javase/11/docs/api/java.base/java/util/Map.html#get(java.lang.Object) 94 | 95 | 96 | -- 3. Make Illegal States unrepresentable 97 | -- https://fsharpforfunandprofit.com/posts/designing-with-types-making-illegal-states-unrepresentable/ 98 | 99 | {- 100 | public class Student { 101 | // never null! 102 | @Nonnull 103 | private String name; 104 | 105 | // at least one of these is non-null 106 | private String registrationNumber; 107 | 108 | private String dsUsername; 109 | 110 | // ... 111 | } 112 | -} 113 | 114 | data IdInfo 115 | = OnlyRegnum String 116 | | OnlyUsername String 117 | | Both String String 118 | deriving Show 119 | 120 | data Student = MkStudent { name :: String 121 | , idinfo :: IdInfo 122 | } deriving Show 123 | 124 | 125 | 126 | -- Non-empty lists 127 | 128 | -- [] , [1,2,3] 129 | 130 | data NEList a = NEList a [a] 131 | 132 | -- head :: NEList a -> a 133 | -- head (NEList a _) = a 134 | 135 | -- head :: [a] -> Maybe a 136 | 137 | 138 | 139 | -- Parse; don't Validate 140 | -- https://lexi-lambda.github.io/blog/2019/11/05/parse-don-t-validate/ 141 | 142 | validateUsername :: String -> Bool 143 | validateUsername "" = False 144 | validateUsername _ = True 145 | 146 | parseUsername :: String -> Maybe (NEList Char) 147 | parseUsername "" = Nothing 148 | parseUsername (x:xs) = Just (NEList x xs) 149 | 150 | type Record = [(String,String)] 151 | 152 | checkRecord :: Record -> Bool 153 | checkRecord record = 154 | case search "username" record of 155 | Nothing -> False 156 | Just _ -> 157 | case search "id" record of 158 | Nothing -> False 159 | Just _ -> True 160 | 161 | parseRecord :: Record -> Maybe (String,String) 162 | parseRecord record = 163 | case search "username" record of 164 | Nothing -> Nothing 165 | Just username -> 166 | case search "id" record of 167 | Nothing -> Nothing 168 | Just id -> Just (username, id) 169 | 170 | 171 | -- REMINDER: 172 | -- 173 | -- *** CLASS TEST *** 174 | -- 175 | -- 12:00 noon Wednesday 25th Oct to 12:00 noon Thursday 26th Oct 176 | -- 177 | -- Covering weeks 1-5. 178 | -- Worth 50% of course mark 179 | -- Redemption test in Week 9 180 | 181 | 182 | 183 | 184 | -- 4. Type classes 185 | 186 | -- Eq, Show, Ord 187 | 188 | 189 | -- == : String -> String -> Bool 190 | -- : Int -> Int -> Bool 191 | -- : Double -> Double -> Bool 192 | -- : Bool -> Bool -> Bool 193 | -- : List String -> List String -> Bool 194 | -- === (type and value comparison in JavaScript) 195 | -- 196 | -- + : Int -> Int -> Int 197 | -- : Double -> Double -> Double 198 | -- : BigInteger -> BigInteger -> BigInteger 199 | 200 | -- boolean equals(Object o) 201 | -- String toString() 202 | 203 | -- x.toString() 204 | 205 | -- eqString 206 | -- eqInt 207 | -- eqDouble 208 | -- eqBool 209 | 210 | -- addInt 211 | -- addDouble 212 | -- addBigInteger 213 | 214 | -- class Eq a where 215 | 216 | data Tree a 217 | = Leaf 218 | | Node (Tree a) a (Tree a) 219 | -- deriving (Eq) 220 | 221 | {- 222 | class Eq a where 223 | (==) :: a -> a -> Bool 224 | -} 225 | 226 | instance Eq (Tree a) where 227 | (==) Leaf Leaf = True 228 | (==) (Node l1 _ r1) (Node l2 _ r2) = l1 == l2 && r1 == r2 229 | (==) _ _ = False 230 | 231 | {- 232 | class Show a where 233 | show :: a -> String 234 | -} 235 | 236 | instance Show (Tree a) where 237 | show Leaf = "Leaf" 238 | show (Node l _ r) = "(Node " ++ show l ++ " _ " ++ show r ++ ")" 239 | 240 | 241 | {- Type classes: 242 | 243 | - define a common interface that can be implemented by many types 244 | 245 | - For example: 246 | - Eq for equality testing 247 | - Show for printing 248 | - Ord for ordering 249 | - Num for numeric types 250 | 251 | 252 | -} 253 | 254 | -- Automatic differentiation via dual numbers: 255 | data Dual = Dual { primal :: Double, 256 | deriv :: Double 257 | } deriving Show 258 | 259 | -- (*) (Dual p1 d1) (Dual p2 p2) = Dual (p1 * p2) (p1 * d2 + p2 * d1) 260 | 261 | 262 | 263 | --- Next time: Semigroups, Monoids, Foldable, Functor 264 | 265 | class Semigroup a where 266 | (<>) :: a -> a -> a 267 | 268 | -- Associativity: 269 | -- forall a b c. a <> (b <> c) == (a <> b) <> c 270 | 271 | instance Semigroup Integer where 272 | (<>) = (+) 273 | -- (<>) = (*) 274 | -- (<>) = max 275 | -- (<>) = min 276 | 277 | instance Semigroup Bool where 278 | (<>) = (&&) 279 | -- (<>) = (||) 280 | 281 | instance Semigroup [a] where 282 | (<>) = (++) 283 | 284 | data RoughCount = Zero | One | Many deriving (Show, Eq) 285 | 286 | instance Semigroup RoughCount where 287 | Zero <> x = x 288 | x <> Zero = x 289 | One <> One = Many 290 | Many <> x = Many 291 | x <> Many = Many 292 | 293 | data RockPaperScissors = Rock | Paper | Scissors deriving (Eq, Show) 294 | 295 | play :: RockPaperScissors -> RockPaperScissors -> RockPaperScissors 296 | play Rock Scissors = Rock 297 | play Paper Rock = Paper 298 | play Scissors Paper = Scissors 299 | play Rock Rock = Rock 300 | play Paper Paper = Paper 301 | play Scissors Scissors = Scissors 302 | play x y = play y x 303 | 304 | {- NOT ASSOCIATIVE: 305 | 306 | ghci> play Rock (play Paper Scissors) 307 | Rock 308 | ghci> play (play Rock Paper) Scissors 309 | Scissors 310 | -} 311 | 312 | class Semigroup a => Monoid a where 313 | mempty :: a 314 | -- forall a. a <> mempty == a 315 | -- forall a. mempty <> a == a 316 | 317 | instance Monoid Integer where 318 | -- (+) 319 | mempty = 0 320 | -- NO MONOID for max/min 321 | 322 | instance Monoid Bool where 323 | -- (&&) 324 | mempty = True 325 | 326 | instance Monoid [a] where 327 | mempty = [] 328 | 329 | foldList :: Monoid a => [a] -> a 330 | foldList [] = mempty 331 | foldList (x:xs) = x <> foldList xs 332 | 333 | foldTree :: Monoid a => Tree a -> a 334 | foldTree Leaf = mempty 335 | foldTree (Node l x r) = foldTree l <> x <> foldTree r 336 | 337 | foldMaybe :: Monoid a => Maybe a -> a 338 | foldMaybe Nothing = mempty 339 | foldMaybe (Just a) = a 340 | 341 | class Foldable c where 342 | fold :: Monoid a => c a -> a 343 | 344 | instance Foldable [] where 345 | fold = foldList 346 | 347 | instance Foldable Tree where 348 | fold = foldTree 349 | 350 | instance Foldable Maybe where 351 | fold = foldMaybe 352 | 353 | -- Functors 354 | 355 | -- map :: (a -> b) -> [a] -> [b] 356 | -- mapTree :: (a -> b) -> Tree a -> Tree b 357 | -- mapMaybe :: (a -> b) -> Maybe a -> Maybe b 358 | 359 | foldMap :: Monoid b => (a -> b) -> [a] -> b 360 | foldMap f = fold . map f 361 | 362 | class Functor c {- Mappable c -} where 363 | fmap :: (a -> b) -> c a -> c b 364 | -------------------------------------------------------------------------------- /lecture-notes/Week05Live.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fwarn-incomplete-patterns #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | module Week05Live where 4 | 5 | import Prelude hiding (Semigroup (..), Monoid (..), Foldable (..), Functor (..)) 6 | import Data.Char 7 | 8 | -- Next week: 30th October: Class Test (24hrs, 50%). 9 | 10 | -- TYPES TYPES TYPES 11 | 12 | -- “Make Illegal States Unrepresentable” 13 | 14 | -- “Billion Dollar Mistake” 15 | -- NULL 16 | -- (as invented by Sir Tony Hoare) 17 | -- replace with Maybe (in Haskell) 18 | -- with Optional (in Java) 19 | 20 | -- "Parse, Don't Validate" 21 | 22 | newtype Metres = MkMetres Double 23 | newtype Seconds = MkSeconds Double 24 | newtype MetresPerSecond = MkMetresPerSecond Double 25 | 26 | newtype Untrusted = MkUntrusted String 27 | 28 | distanceToTheMoon :: Metres 29 | distanceToTheMoon = MkMetres 34987394875 30 | 31 | secondsInAnHour :: Seconds 32 | secondsInAnHour = MkSeconds (60 * 60) 33 | 34 | computeSpeed :: Metres -> Seconds -> MetresPerSecond 35 | computeSpeed (MkMetres distance) (MkSeconds time) = 36 | MkMetresPerSecond (distance / time) 37 | 38 | -- F# programming language from Microsoft 39 | -- units of measure types built in 40 | 41 | 42 | {- public class Student { 43 | // name is not null 44 | // at least one of dsUsername and registrationNumber is not null 45 | public final String name; 46 | public final String dsUsername; 47 | public final String registrationNumber; 48 | 49 | public Student(String name, String dsUsername) { .. } 50 | public Student(String name, String registrationNumber) { .. } 51 | public Student(String name, String dsUsername, String registrationNumber) { .. } 52 | } 53 | -} 54 | 55 | data These a b 56 | = MkThis a 57 | | MkThat b 58 | | MkThese a b 59 | 60 | newtype DSUsername = MkDSUsername String 61 | newtype RegistrationNumber = MkRegistrationNumber String 62 | 63 | data Student = MkStudent 64 | { name :: String 65 | , regInfo :: These DSUsername RegistrationNumber 66 | } 67 | 68 | -- registration :: Student -> IO RegistrationNumber 69 | student :: Student 70 | student = MkStudent 71 | { name = "bob" 72 | , regInfo = MkThis (MkDSUsername "jjb15109") 73 | } 74 | 75 | mkRegistrationNumber :: String -> Maybe RegistrationNumber 76 | mkRegistrationNumber str 77 | | all isDigit str = Just (MkRegistrationNumber str) 78 | | otherwise = Nothing 79 | 80 | 81 | -- module RegistrationNumber (RegistrationNumber, mkRegistrationNumber) where 82 | -- 83 | -- newtype RegistrationNumber = MkRegistrationNumber String 84 | -- mkRegistrationNumber :: String -> Maybe RegistrationNumber 85 | -- mkRegistrationNumber = ... 86 | -- 87 | -- getNumber :: RegistrationNumber -> String 88 | -- getNumber (MkRegistrationNumber str) = str 89 | 90 | 91 | class MyShow a where 92 | myshow :: a -> String 93 | 94 | data Blah = A | B | C deriving Show 95 | 96 | newtype CaseInsensitiveString = 97 | MkCIString String 98 | 99 | instance Show CaseInsensitiveString where 100 | show (MkCIString str) = show (map toUpper str) 101 | 102 | instance Eq CaseInsensitiveString where 103 | MkCIString str1 == MkCIString str2 = 104 | map toUpper str1 == map toUpper str2 105 | 106 | -- Type class <~~~~~> interface in Java 107 | 108 | -- public class JHGJH implements X, Y, Z 109 | 110 | -- On Friday: 111 | -- - Monoids -- generalising addition, multiplication, and, or, concatenation, ... 112 | -- - Foldable, Functor 113 | 114 | -- Semigroups 115 | class Semigroup m where 116 | (<>) :: m -> m -> m 117 | 118 | -- associativity : (x <> y) <> z == x <> (y <> z) 119 | 120 | instance Semigroup [a] where 121 | (<>) = (++) 122 | 123 | newtype Throwaway a = MkThrowaway { getThrowaway :: [a] } deriving Show 124 | 125 | instance Semigroup (Throwaway a) where 126 | xs <> ys = MkThrowaway [] 127 | 128 | newtype Sum = MkSum { getSum :: Int } deriving Show 129 | 130 | instance Semigroup Sum where 131 | MkSum m <> MkSum n = MkSum (m + n) 132 | 133 | newtype Prod = MkProd { getProd :: Int } deriving Show 134 | 135 | instance Semigroup Prod where 136 | MkProd m <> MkProd n = MkProd (m * n) 137 | 138 | newtype Max = MkMax { getMax :: Int } deriving Show 139 | 140 | instance Semigroup Max where 141 | MkMax m <> MkMax n = MkMax (max m n) 142 | 143 | test :: Semigroup m => (Int -> m) -> m 144 | test f = f 0 <> f 1 <> f 2 145 | 146 | -- Monoids 147 | class Semigroup m => Monoid m where 148 | mempty :: m 149 | 150 | -- mempty <> x == x 151 | -- x <> mempty == x 152 | 153 | {- interface Monoid { 154 | -- binary method problem in OOP 155 | } 156 | -} 157 | 158 | instance Monoid [a] where 159 | mempty = [] 160 | 161 | -- instance Monoid (Throwaway a) where 162 | -- mempty = < nothing sensible to write here > 163 | 164 | instance Monoid Sum where 165 | mempty :: Sum 166 | mempty = MkSum 0 167 | 168 | instance Monoid Prod where 169 | mempty = MkProd 1 170 | 171 | -- instance Monoid Max where 172 | -- mempty = -- no answer to go here 173 | -- -- need to solve: mempty `max` x == x 174 | 175 | -- Foldable 176 | foldList :: Monoid m => [m] -> m 177 | foldList [] = mempty 178 | foldList (x : xs) = x <> foldList xs 179 | 180 | newtype First a = MkFirst { getFirst :: Maybe a } deriving Show 181 | 182 | instance Semigroup (First a) where 183 | MkFirst Nothing <> x = x 184 | x <> _ = x 185 | 186 | instance Monoid (First a) where 187 | mempty = MkFirst Nothing 188 | 189 | 190 | class Foldable t where 191 | fold :: Monoid m => t m -> m 192 | 193 | instance Foldable [] where 194 | fold = foldList 195 | 196 | instance Foldable Maybe where 197 | fold Nothing = mempty 198 | fold (Just m) = m 199 | 200 | data Formula a 201 | = Atom a 202 | | IsTrue 203 | | And (Formula a) (Formula a) 204 | | Not (Formula a) 205 | deriving (Show) 206 | 207 | instance Foldable Formula where 208 | fold (Atom m) = m 209 | fold IsTrue = mempty 210 | fold (And e f) = fold e <> fold f 211 | fold (Not e) = fold e 212 | 213 | myFormula :: Formula String 214 | myFormula = Not (And (Not (Atom "e")) (Atom "f")) 215 | 216 | -- Formula String -> Formula [String] 217 | 218 | mapFormula :: (a -> b) -> Formula a -> Formula b 219 | mapFormula f (Atom a) = Atom (f a) 220 | mapFormula f (And p q) = And (mapFormula f p) (mapFormula f q) 221 | mapFormula f IsTrue = IsTrue 222 | mapFormula f (Not p) = Not (mapFormula f p) 223 | 224 | -- Functors 225 | class Functor f where 226 | fmap :: (a -> b) -> f a -> f b 227 | 228 | instance Functor Formula where 229 | fmap = mapFormula 230 | 231 | instance Functor [] where 232 | fmap = map 233 | 234 | getAll :: (Foldable t, Functor t) => t a -> [a] 235 | getAll = fold . fmap (\x -> [x]) 236 | 237 | sumAll :: (Foldable t, Functor t) => t Int -> Int 238 | sumAll = getSum . fold . fmap MkSum 239 | -------------------------------------------------------------------------------- /lecture-notes/Week05Problems.hs: -------------------------------------------------------------------------------- 1 | module Week05Problems where 2 | 3 | import Data.Foldable 4 | import Data.Monoid 5 | import Data.Bits (FiniteBits(countLeadingZeros)) 6 | 7 | {------------------------------------------------------------------------------} 8 | {- TUTORIAL QUESTIONS -} 9 | {------------------------------------------------------------------------------} 10 | 11 | {- 1. Define a 'Show' instance for the following datatype that prints 12 | out the data in a JSON-like format. For example, 13 | 14 | show (MkHost "www.cis.strath.ac.uk" 80) == "{\"name\":\"www.cis.strath.ac.uk\", \"port\": 80}" 15 | 16 | The backslashes before the '"'s in the string are "escape 17 | characters". They are there so that Haskell knows not to end the 18 | string at this point. 19 | -} 20 | 21 | data Host = MkHost String Int 22 | 23 | instance Show Host where 24 | show = undefined 25 | 26 | 27 | 28 | {- 2. Define an 'Eq' instance for the following datatype that makes two 29 | numbers equal if they have the same remainder after division by 30 | 12 (use the 'mod' function to get remainders: '14 `mod` 12 == 31 | 2). -} 32 | 33 | newtype ClockHour = MkClockHour Int 34 | 35 | instance Eq ClockHour where 36 | x == y = undefined 37 | 38 | {- You should have: 39 | 40 | > (MkClockHour 2) == (MkClockHour 2) 41 | True 42 | 43 | > (MkClockHour 2) == (MkClockHour 14) 44 | True 45 | 46 | > (MkClockHour 2) == (MkClockHour 13) 47 | False 48 | 49 | > (MkClockHour 1) == (MkClockHour 2) 50 | False 51 | -} 52 | 53 | 54 | 55 | {- 3. Define Semigroup and Monoid instances for the following data type 56 | for rough counting: -} 57 | 58 | data RoughCount 59 | = Zero 60 | | One 61 | | Many 62 | deriving (Eq, Show) 63 | 64 | {- So that: 65 | 66 | - 'Zero' combined with 'x' gives 'x' 67 | - 'One' combined with 'One' is Many, and 68 | - 'Many' combined with anything is 'Many'. 69 | 70 | What is the 'mempty' that does nothing? -} 71 | 72 | instance Semigroup RoughCount where 73 | x <> y = undefined 74 | 75 | instance Monoid RoughCount where 76 | mempty = undefined 77 | 78 | 79 | 80 | {- 4. Define Semigroup and Monoid instances for the 'Tree a' data type, 81 | under the assumption that the type 'a' of data stored in the 82 | tree is a Semigroup. -} 83 | 84 | data Tree a 85 | = Leaf 86 | | Node (Tree a) a (Tree a) 87 | deriving Show 88 | 89 | {- The semigroup operation '<>' should merge trees. The rules of 90 | combination are as follows: 91 | 92 | - A leaf combined with any tree 't' is just 't'. 93 | 94 | - Combining a 'Node l1 x1 r1' and a 'Node l2 x2 r2' results in a 95 | 'Node' with: 96 | 97 | - Left sub-tree from combining 'l1' and 'l2' 98 | - Data from combining 'x1' and 'x2' 99 | - Right sub-tree from combining 'r1' and 'r2' 100 | 101 | The notation 'Semigroup a =>' tells Haskell that we are assuming 102 | that the type 'a' is an instance of Semigroup, just as it does in 103 | function types. -} 104 | 105 | instance Semigroup a => Semigroup (Tree a) where 106 | x <> y = undefined 107 | 108 | {- What is the 'Tree' that combines to no effect by the above rules? -} 109 | 110 | instance Semigroup a => Monoid (Tree a) where 111 | mempty = undefined 112 | 113 | 114 | 115 | {- 5. Define Semigroup and Monoid instances for the following datatype. -} 116 | 117 | newtype Fun a = MkFun (a -> a) 118 | 119 | unFun :: Fun a -> (a -> a) 120 | unFun (MkFun f) = f 121 | 122 | instance Semigroup (Fun a) where 123 | MkFun f <> MkFun g = undefined 124 | 125 | instance Monoid (Fun a) where 126 | mempty = undefined 127 | 128 | {- HINT: Think about composition from Week 03. There are /two/ different 129 | right answers for the Semigroup part. 130 | 131 | To make it a Monoid, What is the function that has no effect when 132 | composed with another? 133 | 134 | You should have: 135 | 136 | unFun (MkFun reverse <> MkFun reverse) [1,2,3] == [1,2,3] 137 | 138 | unFun (MkFun reverse <> MkFun id) [1,2,3] == [3,2,1] 139 | 140 | unFun (MkFun (+1) <> MkFun (+2)) 0 == 3 141 | -} 142 | 143 | 144 | 145 | {- 6. Define Semigroup and Monoid instances for the following datatype. -} 146 | 147 | newtype MaybeFun a = MkMaybeFun (a -> Maybe a) 148 | 149 | unMaybeFun :: MaybeFun a -> a -> Maybe a 150 | unMaybeFun (MkMaybeFun f) = f 151 | 152 | instance Semigroup (MaybeFun a) where 153 | MkMaybeFun f <> MkMaybeFun g = undefined 154 | 155 | instance Monoid (MaybeFun a) where 156 | mempty = undefined 157 | 158 | {- HINT: For this one, you'll need to define your own composition of 159 | functions that may fail, using a 'case'. 160 | 161 | You should have: 162 | 163 | unMaybeFun (MkMaybeFun (\_ -> Nothing) <> MkMaybeFun (\x -> Just x)) 1 == Nothing 164 | 165 | unMaybeFun (MkMaybeFun (\x -> Just x) <> MkMaybeFun (\x -> Just x)) 1 == Just 1 166 | -} 167 | 168 | 169 | 170 | 171 | 172 | {- 7. The 'OneTwoOrThree' type can be used to represent when we have 173 | either one, two, or three things: -} 174 | 175 | data OneTwoOrThree a 176 | = One_ a 177 | | Two a a 178 | | Three a a a 179 | deriving Show 180 | 181 | {- (a) Define a Functor instance for the OneTwoOrThree type: -} 182 | 183 | instance Functor OneTwoOrThree where 184 | fmap = undefined 185 | 186 | {- You should have: 187 | 188 | fmap (+1) (Three 1 2 3) == Three 2 3 4 189 | -} 190 | 191 | {- (b) Define a Foldable instance for the OneTwoOrThree type. We will 192 | use the standard library Foldable, which requires that we 193 | define 'foldMap' as well. We use the definition in terms of 194 | 'fmap' and 'fold' from Part 5.5 of the notes: 195 | -} 196 | 197 | instance Foldable OneTwoOrThree where 198 | foldMap f = fold . fmap f 199 | 200 | fold = undefined 201 | 202 | {- The following ought to work: 203 | 204 | fold (Three [1,2] [3,4] [5,6]) == [1,2,3,4,5,6] 205 | -} 206 | 207 | 208 | {- 8. Define a function of the type: 209 | 210 | toList :: (Functor c, Foldable c) => c a -> [a] 211 | 212 | which shows that with 'Foldable' you can always define a 213 | 'toList' function. -} 214 | 215 | toList :: (Functor c, Foldable c) => c a -> [a] 216 | toList = undefined 217 | 218 | {- If you only have a 'toList' function for a container can you always 219 | define 'fold'? -} 220 | 221 | 222 | {- 9. Use the 'RoughCount' monoid above to do a rough count of the 223 | number of 'True's in a container full of 'Bool's: -} 224 | 225 | roughlyHowTrue :: Foldable c => c Bool -> RoughCount 226 | roughlyHowTrue = undefined 227 | 228 | {- HINT: use 'foldMap' with a function that converts each 'Bool' to a 229 | 'RoughCount' that counts how 'True' it is. 230 | 231 | You should have: 232 | 233 | roughlyHowTrue [False, False, False] == Zero 234 | roughlyHowTrue [True, False, False] == One 235 | roughlyHowTrue [False, True, False] == One 236 | roughlyHowTrue [True, True, False] == Many 237 | roughlyHowTrue [False, True, True] == Many 238 | -} 239 | 240 | 241 | {- 10. Contrary to the notes, the standard library does not define 242 | Semigroup or Monoid instances for numeric types like 'Int' and 243 | 'Double'. Instead, the Data.Monoid module (imported above) 244 | defines two newtypes: 245 | 246 | newtype Product a = Product a 247 | 248 | newtype Sum a = Sum a 249 | 250 | with functions 'getProduct :: Product a -> a' and 251 | 'getSum :: Sum a -> a' that extract the values. 252 | 253 | When 'Num a' is true (i.e. 'a' is a numeric type), 'Product a' 254 | is a monoid that multiples and 'Sum a' is a monoid that adds. 255 | 256 | Use these functions with 'foldMap' to define generic 'sumAll' 257 | and 'productAll' functions for any foldable container 'c' and 258 | any kind of numeric type 'a': 259 | -} 260 | 261 | sumAll :: (Foldable c, Num a) => c a -> a 262 | sumAll = undefined 263 | 264 | productAll :: (Foldable c, Num a) => c a -> a 265 | productAll = undefined 266 | 267 | {- HINT: the trick is to think in three stages: 268 | 1. Every 'a' in the container needs to be converted to a 'Sum a' (or 'Product a'). 269 | 2. The 'fold' then sums them, or multiplies them. 270 | 3. We end up with a 'Product a' or 'Sum a', use the appropriate function to get back the 'a' 271 | -} 272 | 273 | 274 | {- 11. Use the 'Sum Int' monoid with foldMap to write a generic 'size' 275 | function, similar to the one in the notes. -} 276 | 277 | sizeGeneric :: Foldable c => c a -> Int 278 | sizeGeneric = undefined 279 | 280 | 281 | {- 12. The standard library module contains definitions to tell Haskell 282 | that the type of pairs forms a Monoid if the two constituent 283 | types do: 284 | 285 | instance (Monoid a, Monoid b) => Monoid (a,b) where 286 | ... 287 | 288 | 289 | Use this to write a generic 'average' function that combines 290 | the 'sumAll' and 'sizeGeneric' functions into one that does a 291 | *single* pass of the container. 292 | -} 293 | 294 | average :: Foldable c => c Double -> Double 295 | average c = total / fromInteger count 296 | where (Sum total, Sum count) = undefined -- fill in the 'undefined' 297 | -------------------------------------------------------------------------------- /lecture-notes/Week05Solutions.hs: -------------------------------------------------------------------------------- 1 | module Week05Solutions where 2 | 3 | import Data.Foldable 4 | import Data.Monoid 5 | import Data.Bits (FiniteBits(countLeadingZeros)) 6 | 7 | {------------------------------------------------------------------------------} 8 | {- TUTORIAL QUESTIONS -} 9 | {------------------------------------------------------------------------------} 10 | 11 | {- 1. Define a 'Show' instance for the following datatype that prints 12 | out the data in a JSON-like format. For example, 13 | 14 | show (MkHost "www.cis.strath.ac.uk" 80) == "{\"name\":\"www.cis.strath.ac.uk\", \"port\": 80}" 15 | 16 | The backslashes before the '"'s in the string are "escape 17 | characters". They are there so that Haskell knows not to end the 18 | string at this point. 19 | -} 20 | 21 | data Host = MkHost String Int 22 | 23 | instance Show Host where 24 | show (MkHost name port) = 25 | "{\"name\":\"" ++ name ++ "\", \"port\": " ++ show port ++ "}" 26 | 27 | -- NOTE: we include 'name' directly, because we are adding our own 28 | -- quote marks. But for the port number, we have to use 'show' to 29 | -- convert the number to a string. 30 | 31 | {- 2. Define an 'Eq' instance for the following datatype that makes two 32 | numbers equal if they have the same remainder after division by 33 | 12 (use the 'mod' function to get remainders: '14 `mod` 12 == 34 | 2). -} 35 | 36 | newtype ClockHour = MkClockHour Int 37 | 38 | instance Eq ClockHour where 39 | MkClockHour x == MkClockHour y = x `mod` 12 == y `mod` 12 40 | 41 | -- NOTE: to be more clear, we could have put some parentheses in to 42 | -- show how things get grouped together: 43 | -- 44 | -- ((MkClockHour x) == (MkClockHour y)) = ((x `mod` 12) == (y `mod` 12)) 45 | 46 | {- You should have: 47 | 48 | > (MkClockHour 2) == (MkClockHour 2) 49 | True 50 | 51 | > (MkClockHour 2) == (MkClockHour 14) 52 | True 53 | 54 | > (MkClockHour 2) == (MkClockHour 13) 55 | False 56 | 57 | > (MkClockHour 1) == (MkClockHour 2) 58 | False 59 | -} 60 | 61 | 62 | 63 | {- 3. Define Semigroup and Monoid instances for the following data type 64 | for rough counting: -} 65 | 66 | data RoughCount 67 | = Zero 68 | | One 69 | | Many 70 | deriving (Eq, Show) 71 | 72 | {- So that: 73 | 74 | - 'Zero' combined with 'x' gives 'x' 75 | - 'One' combined with 'One' is Many, and 76 | - 'Many' combined with anything is 'Many'. 77 | 78 | What is the 'mempty' that does nothing? -} 79 | 80 | instance Semigroup RoughCount where 81 | Zero <> x = x -- Zero and 'x' is 'x' 82 | x <> Zero = x 83 | One <> One = Many -- One and One is Many 84 | Many <> _ = Many -- Adding Many to anything... 85 | _ <> Many = Many -- ... gives Many 86 | 87 | instance Monoid RoughCount where 88 | mempty = Zero 89 | 90 | 91 | 92 | {- 4. Define Semigroup and Monoid instances for the 'Tree a' data type, 93 | under the assumption that the type 'a' of data stored in the 94 | tree is a Semigroup. -} 95 | 96 | data Tree a 97 | = Leaf 98 | | Node (Tree a) a (Tree a) 99 | deriving Show 100 | 101 | {- The semigroup operation '<>' should merge trees. The rules of 102 | combination are as follows: 103 | 104 | - A leaf combined with any tree 't' is just 't'. 105 | 106 | - Combining a 'Node l1 x1 r1' and a 'Node l2 x2 r2' results in a 107 | 'Node' with: 108 | 109 | - Left sub-tree from combining 'l1' and 'l2' 110 | - Data from combining 'x1' and 'x2' 111 | - Right sub-tree from combining 'r1' and 'r2' 112 | 113 | The notation 'Semigroup a =>' tells Haskell that we are assuming 114 | that the type 'a' is an instance of Semigroup, just as it does in 115 | function types. -} 116 | 117 | instance Semigroup a => Semigroup (Tree a) where 118 | -- First point above: 119 | Leaf <> y = y 120 | x <> Leaf = x 121 | -- Second point: 122 | Node l1 x1 r1 <> Node l2 x2 r2 = Node (l1 <> l2) (x1 <> x2) (r1 <> r2) 123 | 124 | {- What is the 'Tree' that combines to no effect by the above rules? -} 125 | 126 | instance Semigroup a => Monoid (Tree a) where 127 | mempty = Leaf 128 | 129 | 130 | 131 | {- 5. Define Semigroup and Monoid instances for the following datatype. -} 132 | 133 | newtype Fun a = MkFun (a -> a) 134 | 135 | unFun :: Fun a -> (a -> a) 136 | unFun (MkFun f) = f 137 | 138 | instance Semigroup (Fun a) where 139 | MkFun f <> MkFun g = MkFun (f . g) 140 | 141 | -- NOTE: the answer is nothing more than function composition + the 142 | -- constructor. Note that we also get a Semigroup if we compose the 143 | -- other way round: 144 | -- 145 | -- MkFun f <> MkFun g = MkFun (g . f) 146 | -- 147 | -- This is possible because the source and target type in 'a -> a' are 148 | -- the same. 149 | 150 | instance Monoid (Fun a) where 151 | mempty = MkFun id 152 | 153 | {- HINT: Think about composition from Week 03. There are /two/ different 154 | right answers for the Semigroup part. 155 | 156 | To make it a Monoid, What is the function that has no effect when 157 | composed with another? 158 | 159 | You should have: 160 | 161 | unFun (MkFun reverse <> MkFun reverse) [1,2,3] == [1,2,3] 162 | 163 | unFun (MkFun reverse <> MkFun id) [1,2,3] == [3,2,1] 164 | 165 | unFun (MkFun (+1) <> MkFun (+2)) 0 == 3 166 | -} 167 | 168 | 169 | 170 | {- 6. Define Semigroup and Monoid instances for the following datatype. -} 171 | 172 | newtype MaybeFun a = MkMaybeFun (a -> Maybe a) 173 | 174 | unMaybeFun :: MaybeFun a -> a -> Maybe a 175 | unMaybeFun (MkMaybeFun f) = f 176 | 177 | instance Semigroup (MaybeFun a) where 178 | MkMaybeFun f <> MkMaybeFun g = MkMaybeFun (composeMaybe f g) 179 | 180 | -- NOTE: to compose a function that returns a Maybe, we have to do a 181 | -- case on whether or not it succeeds: 182 | 183 | composeMaybe :: (a -> Maybe a) -> (a -> Maybe a) -> (a -> Maybe a) 184 | composeMaybe f g x = case f x of 185 | Nothing -> Nothing 186 | Just y -> g y 187 | 188 | instance Monoid (MaybeFun a) where 189 | mempty = MkMaybeFun (\x -> Just x) 190 | 191 | -- NOTE: the "do nothing" element here is '\x -> Just x'. We can see 192 | -- why by seeing how it computes with 'composeMaybe': 193 | -- 194 | -- Combining with (\x -> Just x) on the left and 'g' on the right 195 | -- gives: 196 | -- 197 | -- composeMaybe (\x -> Just x) g x 198 | -- == case (\x -> Just x) x of Nothing -> Nothing; Just y -> g y 199 | -- == case Just x of Nothing -> Nothing; Just y -> g y 200 | -- == g x 201 | -- 202 | -- and the other way round: 203 | -- 204 | -- composeMaybe f (\x -> Just x) x 205 | -- == case f x of Nothing -> Nothing; Just y -> (\x -> Just x) y 206 | -- == case f x of Nothing -> Nothing; Just y -> Just y 207 | -- == f x 208 | 209 | {- HINT: For this one, you'll need to define your own composition of 210 | functions that may fail, using a 'case'. 211 | 212 | You should have: 213 | 214 | unMaybeFun (MkMaybeFun (\_ -> Nothing) <> MkMaybeFun (\x -> Just x)) 1 == Nothing 215 | 216 | unMaybeFun (MkMaybeFun (\x -> Just x) <> MkMaybeFun (\x -> Just x)) 1 == Just 1 217 | -} 218 | 219 | 220 | 221 | 222 | 223 | {- 7. The 'OneTwoOrThree' type can be used to represent when we have 224 | either one, two, or three things: -} 225 | 226 | data OneTwoOrThree a 227 | = One_ a 228 | | Two a a 229 | | Three a a a 230 | deriving Show 231 | 232 | {- (a) Define a Functor instance for the OneTwoOrThree type: -} 233 | 234 | instance Functor OneTwoOrThree where 235 | fmap f (One_ x) = One_ (f x) 236 | fmap f (Two x y) = Two (f x) (f y) 237 | fmap f (Three x y z) = Three (f x) (f y) (f z) 238 | 239 | {- You should have: 240 | 241 | fmap (+1) (Three 1 2 3) == Three 2 3 4 242 | -} 243 | 244 | {- (b) Define a Foldable instance for the OneTwoOrThree type. We will 245 | use the standard library Foldable, which requires that we 246 | define 'foldMap' as well. We use the definition in terms of 247 | 'fmap' and 'fold' from Part 5.5 of the notes: 248 | -} 249 | 250 | instance Foldable OneTwoOrThree where 251 | foldMap f = fold . fmap f 252 | 253 | fold (One_ x) = x 254 | fold (Two x y) = x <> y 255 | fold (Three x y z) = x <> y <> z 256 | 257 | {- The following ought to work: 258 | 259 | fold (Three [1,2] [3,4] [5,6]) == [1,2,3,4,5,6] 260 | -} 261 | 262 | 263 | {- 8. Define a function of the type: 264 | 265 | toList :: (Functor c, Foldable c) => c a -> [a] 266 | 267 | which shows that with 'Foldable' you can always define a 268 | 'toList' function. -} 269 | 270 | toList :: (Functor c, Foldable c) => c a -> [a] 271 | toList = fold . fmap (\x -> [x]) 272 | 273 | {- If you only have a 'toList' function for a container can you always 274 | define 'fold'? -} 275 | 276 | -- NOTE: we can do it like this: 277 | -- 278 | -- fold = foldr (<>) mempty . toList 279 | -- 280 | -- 'toList' first converts to flat list of the elements, and then we 281 | -- use 'foldr' to combine them all into one. 282 | 283 | 284 | {- 9. Use the 'RoughCount' monoid above to do a rough count of the 285 | number of 'True's in a container full of 'Bool's: -} 286 | 287 | roughlyHowTrue :: Foldable c => c Bool -> RoughCount 288 | roughlyHowTrue = foldMap (\x -> if x then One else Zero) 289 | 290 | -- NOTE: Using 'foldMap', we just need to convert each boolean to 291 | -- 'One' or 'Zero' as appropriate. 292 | 293 | {- HINT: use 'foldMap' with a function that converts each 'Bool' to a 294 | 'RoughCount' that counts how 'True' it is. 295 | 296 | You should have: 297 | 298 | roughlyHowTrue [False, False, False] == Zero 299 | roughlyHowTrue [True, False, False] == One 300 | roughlyHowTrue [False, True, False] == One 301 | roughlyHowTrue [True, True, False] == Many 302 | roughlyHowTrue [False, True, True] == Many 303 | -} 304 | 305 | 306 | {- 10. Contrary to the notes, the standard library does not define 307 | Semigroup or Monoid instances for numeric types like 'Int' and 308 | 'Double'. Instead, the Data.Monoid module (imported above) 309 | defines two newtypes: 310 | 311 | newtype Product a = Product a 312 | 313 | newtype Sum a = Sum a 314 | 315 | with functions 'getProduct :: Product a -> a' and 316 | 'getSum :: Sum a -> a' that extract the values. 317 | 318 | When 'Num a' is true (i.e. 'a' is a numeric type), 'Product a' 319 | is a monoid that multiples and 'Sum a' is a monoid that adds. 320 | 321 | Use these functions with 'foldMap' to define generic 'sumAll' 322 | and 'productAll' functions for any foldable container 'c' and 323 | any kind of numeric type 'a': 324 | -} 325 | 326 | sumAll :: (Foldable c, Num a) => c a -> a 327 | sumAll = getSum . foldMap Sum 328 | 329 | productAll :: (Foldable c, Num a) => c a -> a 330 | productAll = getProduct . foldMap Product 331 | 332 | -- NOTE: 'Sum' is equivalent to (\x -> Sum x), treating the 333 | -- constructor as a function. Similar for 'Product' 334 | 335 | {- HINT: the trick is to think in three stages: 336 | 1. Every 'a' in the container needs to be converted to a 'Sum a' (or 'Product a'). 337 | 2. The 'fold' then sums them, or multiplies them. 338 | 3. We end up with a 'Product a' or 'Sum a', use the appropriate function to get back the 'a' 339 | -} 340 | 341 | 342 | {- 11. Use the 'Sum Int' monoid with foldMap to write a generic 'size' 343 | function, similar to the one in the notes. -} 344 | 345 | sizeGeneric :: Foldable c => c a -> Int 346 | sizeGeneric = getSum . foldMap (\_ -> Sum 1) 347 | 348 | -- NOTE: instead of adding up the values in the container, we convert 349 | -- all of them to '1' and then add them up. 350 | 351 | 352 | {- 12. The standard library module contains definitions to tell Haskell 353 | that the type of pairs forms a Monoid if the two constituent 354 | types do: 355 | 356 | instance (Monoid a, Monoid b) => Monoid (a,b) where 357 | ... 358 | 359 | 360 | Use this to write a generic 'average' function that combines 361 | the 'sumAll' and 'sizeGeneric' functions into one that does a 362 | *single* pass of the container. 363 | -} 364 | 365 | average :: Foldable c => c Double -> Double 366 | average c = total / fromInteger count 367 | where (Sum total, Sum count) = foldMap (\x -> (Sum x, Sum 1)) c 368 | -------------------------------------------------------------------------------- /lecture-notes/Week06Intro.hs: -------------------------------------------------------------------------------- 1 | module Week06Intro where 2 | 3 | -- REMEMBER: 4 | -- - Test **tomorrow** Wednesday 25th 12:00(noon) ---> Thursday 26th 12:00(noon) 5 | -- - 10 questions on weeks 1-5 6 | -- - should take ~1-2hrs 7 | -- - counts for 50% 8 | -- - redemption test in Week 9 9 | 10 | 11 | {- WEEK 06 : SIMULATING SIDE EFFECTS 12 | 13 | Haskell doesn't have "side effects" or is "pure". 14 | - What does this mean? 15 | - Is it a good thing? 16 | - Is it a bad thing? 17 | 18 | In Haskell: 19 | 20 | f :: Int -> Maybe Int 21 | 22 | what can it do? 23 | 24 | - Not terminate (or crash with an unrecoverable error) 25 | - Or it can return an Int 26 | - if we give it the same input twice, we'll get the same answer 27 | 28 | 29 | In Java: 30 | 31 | public static int f(int x) 32 | 33 | what can it do? 34 | 35 | - Non terminate 36 | - throw an Exception 37 | - return an int 38 | - print things to the screen 39 | - generate random numbers 40 | - read files 41 | - make network calls 42 | - posting cat pictures to 43 | - buy things on amazon 44 | - launch nuclear missiles 45 | 46 | How do we make Haskell do these things? 47 | -} 48 | 49 | 50 | 51 | 52 | {- Part 6.1 : Simulating Exceptions -} 53 | 54 | {- data Maybe a = Nothing | Just a -} 55 | 56 | 57 | returnOk :: a -> Maybe a 58 | returnOk x = Just x 59 | 60 | failure :: Maybe a 61 | failure = Nothing 62 | 63 | search :: Eq k => k -> [(k,v)] -> Maybe v 64 | search k [] = failure 65 | search k ((k',v):kvs) = if k == k' then returnOk v else search k kvs 66 | 67 | -- lookupList 68 | lookupList :: Eq k => [k] -> [(k,v)] -> Maybe [v] 69 | lookupList [] kvs = returnOk [] 70 | lookupList (k:ks) kvs = 71 | case search k kvs of 72 | Nothing -> failure 73 | Just v -> 74 | case lookupList ks kvs of 75 | Nothing -> failure 76 | Just vs -> returnOk (v:vs) 77 | 78 | ifOK :: Maybe a -> (a -> Maybe b) -> Maybe b 79 | ifOK Nothing k = failure 80 | ifOk (Just a) k = k a 81 | 82 | 83 | -- lookupList_v2 84 | lookupList_v2 :: Eq k => [k] -> [(k,v)] -> Maybe [v] 85 | lookupList_v2 [] kvs = returnOk [] 86 | lookupList_v2 (k:ks) kvs = 87 | search k kvs `ifOK` (\v -> 88 | lookupList_v2 ks kvs `ifOK` (\vs -> 89 | returnOk (v:vs))) 90 | 91 | -- ";" 92 | -- MyType a = ; 93 | 94 | catch :: Maybe a -> Maybe a -> Maybe a 95 | catch Nothing handler = handler 96 | catch (Just a) handler = Just a 97 | 98 | safeLookupList :: Eq k => [k] -> [(k,v)] -> Maybe [v] 99 | safeLookupList ks kvs = catch (lookupList_v2 ks kvs) (returnOk []) 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | {- Part 6.2 : Simulating (Mutable) State -} 108 | 109 | {- We can make updatable state 'pure' by making fresh names for 110 | variables instead of treating each variable as a thing that can 111 | change. 112 | 113 | Instead of: 114 | 115 | int i = 0; 116 | 117 | i = 10; 118 | 119 | i = i + 1; 120 | 121 | ... 122 | 123 | i = i - 1; 124 | 125 | Make fresh variables: 126 | 127 | int i0 = 0; 128 | 129 | int i1 = 10; 130 | 131 | int i2 = i1 + 1; 132 | 133 | ... 134 | 135 | int i3 = i2 - 1; 136 | 137 | This is the form that compilers use internally when compiling most 138 | languages SSA (Static Single Assignment). Used in (e.g.) LLVM and 139 | GCC. 140 | -} 141 | 142 | {- LinkedList<> output = new LinkedList>(); 143 | int i = 0; 144 | for (String x : xs) { 145 | Pair<> p = new Pair(i, x); 146 | output.append(p); 147 | i++; 148 | } 149 | -} 150 | 151 | numberList :: [a] -> Int -> (Int, [(a, Int)]) 152 | numberList [] i = (i, []) 153 | numberList (x:xs) i0 = 154 | let p = (x, i0) 155 | i1 = i0 + 1 156 | (i2, ys) = numberList xs i1 157 | in (i2, p : ys) 158 | 159 | 160 | type State a = Int -> (Int, a) 161 | 162 | returnSt :: a -> State a 163 | -- a -> Int -> (Int,a) 164 | returnSt a i = (i,a) 165 | 166 | andThen :: State a -> (a -> State b) -> State b 167 | -- (Int -> (Int,a)) -> (a -> Int -> (Int, b)) -> Int -> (Int, b) 168 | andThen computation1 kontinuation i0 = 169 | let (i1, a) = computation1 i0 170 | (i2, b) = kontinuation a i1 171 | in (i2, b) 172 | 173 | get :: State Int 174 | get i = (i,i) 175 | 176 | put :: Int -> State () 177 | put i i0 = (i, ()) 178 | 179 | numberList_v2 :: [a] -> State [(a,Int)] 180 | numberList_v2 [] = returnSt [] 181 | numberList_v2 (x:xs) = 182 | -- get `andThen` \i -> 183 | -- put (i+1) `andThen` \() -> 184 | increment `andThen` \i -> 185 | numberList_v2 xs `andThen` \ys -> 186 | returnSt ((x,i) : ys) 187 | 188 | increment :: State Int 189 | increment = get `andThen` \i -> put (i+1) `andThen` \() -> returnSt i 190 | 191 | 192 | -- returnOk :: a -> Maybe a 193 | -- returnSt :: a -> State a 194 | 195 | -- State a = Int -> (Int,a) 196 | 197 | -- ifOK :: Maybe a -> (a -> Maybe b) -> Maybe b 198 | -- andThen :: State a -> (a -> State b) -> State b 199 | 200 | -- failure :: Maybe a 201 | -- get :: State Int, put :: Int -> State () 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | -- Part 2 214 | 215 | -- Printing 216 | 217 | data Tree a 218 | = Leaf 219 | | Node (Tree a) a (Tree a) 220 | deriving (Eq, Show) 221 | 222 | testTree :: Tree Int 223 | testTree = Node (Node Leaf 4 Leaf) 7 (Node Leaf 9 Leaf) 224 | 225 | printAndSum :: Tree Int -> ([String], Int) 226 | printAndSum Leaf = ([], 0) 227 | printAndSum (Node l x r) = 228 | let (output1, lsum) = printAndSum l 229 | xoutput = "Doing " ++ show x 230 | (output2, rsum) = printAndSum r 231 | in (output1 ++ [xoutput] ++ output2, lsum + x + rsum) 232 | 233 | -- Printing 234 | type Printing a = ([String], a) 235 | 236 | -- returnPr 237 | returnPr :: a -> Printing a 238 | returnPr x = ([], x) 239 | 240 | -- andThenPrinting 241 | andThenPrinting :: Printing a -> (a -> Printing b) -> Printing b 242 | andThenPrinting (output1, a) k = 243 | let (output2, b) = k a 244 | in (output1 ++ output2, b) 245 | 246 | printStr :: String -> Printing () 247 | printStr s = ([s], ()) 248 | 249 | 250 | -- printAndSum_v2 251 | printAndSum_v2 :: Tree Int -> Printing Int 252 | printAndSum_v2 Leaf = returnPr 0 253 | printAndSum_v2 (Node l x r) = 254 | printAndSum_v2 l `andThenPrinting` \lsum -> 255 | printStr ("Doing " ++ show x) `andThenPrinting` \() -> 256 | printAndSum_v2 r `andThenPrinting` \rsum -> 257 | returnPr (lsum + x + rsum) 258 | 259 | 260 | -- Processes 261 | 262 | data Process a 263 | = End a 264 | | Input (String -> Process a) 265 | | Output String (Process a) 266 | 267 | {- 268 | Input 269 | | 270 | /----\----- ..... 271 | / \ 272 | "Alice" "Bob" 273 | | | 274 | Output "Hello Alice" Output "Hello Bob" 275 | | | 276 | End () End () 277 | -} 278 | 279 | greeter :: Process () 280 | greeter = Output "What is your name?" 281 | (Input (\name -> 282 | Output ("Hello " ++ name) (End ()))) 283 | 284 | runProcess :: Process a -> IO a 285 | runProcess (End a) = return a 286 | runProcess (Input p) = do s <- getLine; runProcess (p s) 287 | runProcess (Output s p) = do putStrLn s; runProcess p 288 | 289 | returnProcess :: a -> Process a 290 | returnProcess x = End x 291 | 292 | sequ :: Process a -> (a -> Process b) -> Process b 293 | sequ (End a) k = k a 294 | sequ (Input p) k = Input (\s -> sequ (p s) k) 295 | sequ (Output s p) k = Output s (sequ p k) 296 | 297 | input :: Process String 298 | input = Input (\s -> End s) 299 | 300 | output :: String -> Process () 301 | output s = Output s (End ()) 302 | 303 | greeter_v2 :: Process () 304 | greeter_v2 = 305 | output "What is your name?" `sequ` \() -> 306 | input `sequ` \name -> 307 | output ("Hello " ++ name) `sequ` \() -> 308 | returnProcess () 309 | 310 | {- do output "What is your name?" 311 | name <- input 312 | output ("Hello " ++ name) 313 | -} 314 | 315 | 316 | 317 | 318 | 319 | -- Four ways of "simulating side effects" 320 | -- 321 | -- All have similar interfaces: 322 | -- 323 | -- ifOK :: Maybe a -> (a -> Maybe b) -> Maybe b 324 | -- andThen :: State a -> (a -> State b) -> State b 325 | -- andThenPrinting :: Printing a -> (a -> Printing b) -> Printing b 326 | -- sequ :: Process a -> (a -> Process b) -> Process b 327 | 328 | 329 | 330 | 331 | -- The common name is "Monad" 332 | -- or "Warm fuzzy thing" 333 | 334 | 335 | 336 | 337 | 338 | -- class Monad m where 339 | -- return :: a -> m a 340 | -- (>>=) :: m a -> (a -> m b) -> m b 341 | 342 | -- ';' 343 | -------------------------------------------------------------------------------- /lecture-notes/Week06Live.hs: -------------------------------------------------------------------------------- 1 | module Week06Live where 2 | 3 | -- REMINDER: Class Test: 4 | -- Wednesday 30th October 12:00 noon ---> Thursday 31st October 12:00 noon 5 | -- Test will be via MyPlace 6 | -- Test is worth 50% and marked out of 50 7 | 8 | -- WEEK 06 : Simulating Side Effects 9 | 10 | 11 | -- f :: Int -> Int 12 | -- f 0 (today) == f 0 (tomorrow) 13 | 14 | -- f :: Int -> Effect Int 15 | 16 | 17 | -- int f(int i) 18 | -- 19 | -- - read the clock in the computer 20 | -- - ask the user for input 21 | -- - post cat picture to your favourite social network (Myspace) 22 | -- - Launch the nuclear weapons 23 | 24 | -- Week 06 : Simulating Side Effects 25 | -- Week 07 : Common interface 26 | -- Week 08 : Real I/O and side effects with the common interface 27 | 28 | -- Simulate exceptions 29 | 30 | data Tree a 31 | = Leaf a 32 | | Node (Tree a) (Tree a) 33 | deriving Show 34 | 35 | find :: Eq a => a -> Tree (a, b) -> Maybe b 36 | find k (Leaf (k', v)) 37 | | k == k' = Just v 38 | | otherwise = Nothing 39 | find k (Node l r) = case find k l of 40 | Just v -> Just v 41 | Nothing -> find k r 42 | 43 | andThen :: Maybe a -> (a -> Maybe b) -> Maybe b 44 | andThen Nothing k = Nothing 45 | andThen (Just v) k = k v 46 | 47 | failure :: Maybe a 48 | failure = Nothing 49 | 50 | find2 :: (Eq k1, Eq k2) 51 | => k1 -> k2 52 | -> Tree (k1, Tree (k2, a)) -> Maybe a 53 | find2 k1 k2 t = 54 | find k1 t `andThen` \ t2 -> find k2 t2 55 | 56 | -- Tree t1 = find(k1, t); 57 | -- return find(k2, t1) 58 | 59 | returnOk :: a -> Maybe a 60 | returnOk x = Just x 61 | 62 | findAll :: Eq k => Tree (k, v) -> [k] -> Maybe [v] 63 | findAll dictionary [] = Just [] 64 | findAll dictionary (k:ks) = 65 | find k dictionary `andThen` \ v -> 66 | findAll dictionary ks `andThen` \ vs -> 67 | returnOk (v : vs) 68 | 69 | 70 | -- State 71 | 72 | -- int i = 0; 73 | -- 74 | -- i = i + 1; 75 | 76 | type State s a = s -> (a, s) 77 | 78 | andThenState :: State s a 79 | -> (a -> State s b) 80 | -> State s b 81 | andThenState c k initial = 82 | let (a, intermediate) = c initial in 83 | k a intermediate 84 | 85 | returnState :: a -> State s a 86 | returnState v s = (v, s) 87 | 88 | getState :: State s s 89 | getState s = (s, s) 90 | 91 | putState :: s -> State s () 92 | putState new old = ((), new) 93 | 94 | numberTree :: Tree a -> State Int (Tree (a, Int)) 95 | numberTree (Leaf a) = 96 | getState `andThenState` \ i -> 97 | putState (i + 1) `andThenState` \ _ -> 98 | returnState (Leaf (a, i)) 99 | numberTree (Node l r) = 100 | numberTree l `andThenState` \ numbered_l -> 101 | numberTree r `andThenState` \ numbered_r -> 102 | returnState (Node numbered_l numbered_r) 103 | -- let (numbered_l, i1) = numberTree l i0 104 | -- (numbered_r, i2) = numberTree r i1 105 | -- in (Node numbered_l numbered_r, i2) 106 | 107 | example = Node (Node (Leaf 'a') (Leaf 'b')) (Leaf 'c') 108 | 109 | 110 | 111 | -- andThen :: Maybe a -> (a -> Maybe b) -> Maybe b 112 | -- andThenState :: State s a -> (a -> State s b) -> State s b 113 | 114 | -- c `andThen` k ~=~ A x = c; 115 | -- k[x] 116 | -- 117 | 118 | -- Choice a -> Choice a -> Choice a 119 | -- andThenChoice :: Choice a -> (a -> Choice b) -> Choice b 120 | 121 | 122 | 123 | -- Printing 124 | type Logging log a = (log, a) 125 | 126 | andThenLogging 127 | :: Semigroup log 128 | => Logging log a -> (a -> Logging log b) -> Logging log b 129 | andThenLogging (output1, a) k = 130 | let (output2, b) = k a in 131 | (output1 <> output2, b) 132 | 133 | returnLogging :: Monoid log => a -> Logging log a 134 | returnLogging a = (mempty, a) 135 | 136 | logging :: String -> Logging [String] () 137 | logging str = ([str], ()) 138 | 139 | printTree :: Show a => Tree a -> Logging [String] (Tree a) 140 | printTree (Leaf a) = 141 | logging ("Visiting " ++ show a) `andThenLogging` \ _ -> 142 | returnLogging (Leaf a) 143 | printTree (Node l r) = 144 | printTree l `andThenLogging` \ l' -> 145 | printTree r `andThenLogging` \ r' -> 146 | returnLogging (Node l' r') 147 | 148 | -- I/O Processes 149 | 150 | data Process a 151 | = End a 152 | | Input (String -> Process a) 153 | | Output String (Process a) 154 | 155 | {- 156 | Input 157 | | 158 | /----\----- ..... 159 | / \ 160 | "Alice" "Bob" 161 | | | 162 | Output "Hello Alice" Output "Hello Bob" 163 | | | 164 | End () End () 165 | -} 166 | 167 | greeter :: Process () 168 | greeter = Input (\name -> Output ("Hello " ++ name) (End ())) 169 | 170 | {- name <- input; 171 | print ("Hello " ++ name); 172 | return () 173 | -} 174 | 175 | andThenProcess :: Process a -> (a -> Process b) -> Process b 176 | andThenProcess (End a) k = k a 177 | andThenProcess (Input react) k 178 | = Input (\ str -> react str `andThenProcess` k) 179 | andThenProcess (Output msg p) k 180 | = Output msg (p `andThenProcess` k) 181 | 182 | runProcess :: [String] -> Process a -> Logging [String] a 183 | runProcess inputs (End a) = returnLogging a 184 | runProcess (i : inputs) (Input react) 185 | = runProcess inputs (react i) 186 | runProcess inputs (Output msg p) 187 | = logging msg `andThenLogging` \ _ -> 188 | runProcess inputs p 189 | 190 | input :: Process String 191 | input = Input (\ str -> End str) 192 | 193 | output :: String -> Process () 194 | output msg = Output msg (End ()) 195 | 196 | returnProcess :: a -> Process a 197 | returnProcess = End 198 | 199 | greeter2 :: Process () 200 | greeter2 = 201 | input `andThenProcess` \ name -> 202 | output ("Hello " ++ name) `andThenProcess` \ _ -> 203 | returnProcess () 204 | 205 | greeter3 :: Process () 206 | greeter3 = 207 | input `andThenProcess` \name -> 208 | if name == "Bob" then 209 | (output "That is a silly name" `andThenProcess` \ _ -> 210 | greeter3) 211 | else 212 | (output ("Hello " ++ name) `andThenProcess` \ _ -> 213 | returnProcess ()) 214 | 215 | 216 | 217 | realRunProcess :: Process a -> IO a 218 | realRunProcess (End a) = return a 219 | realRunProcess (Input react) = 220 | do input <- getLine; realRunProcess (react input) 221 | realRunProcess (Output msg p) = 222 | do putStrLn msg; realRunProcess p 223 | -------------------------------------------------------------------------------- /lecture-notes/Week06Problems.hs: -------------------------------------------------------------------------------- 1 | module Week06Problems where 2 | 3 | {------------------------------------------------------------------------------} 4 | {- TUTORIAL QUESTIONS -} 5 | {------------------------------------------------------------------------------} 6 | 7 | data Tree a 8 | = Leaf 9 | | Node (Tree a) a (Tree a) 10 | deriving Show 11 | 12 | {- 1. Using 'Result' to handle errors. 13 | 14 | Here is the 'Result' type described in the notes. It is like the 15 | 'Maybe' type except that the "fail" case has a String message 16 | attached: -} 17 | 18 | data Result a 19 | = Ok a 20 | | Error String 21 | deriving (Eq, Show) 22 | 23 | {- Implement 'returnOK', 'failure', 'ifOK' and 'catch' for 'Result' 24 | instead of 'Maybe'. Note that in 'failure' we have to provide an 25 | error message, and in 'catch' the "exception handler" gets the 26 | error message. -} 27 | 28 | returnOk :: a -> Result a 29 | returnOk = undefined 30 | 31 | failure :: String -> Result a 32 | failure = undefined 33 | 34 | ifOK :: Result a -> (a -> Result b) -> Result b 35 | ifOK = undefined 36 | 37 | catch :: Result a -> (String -> Result a) -> Result a 38 | catch = undefined 39 | 40 | {- Reimplement 'search' to use 'Result' instead of 'Maybe'. We add 'Show 41 | k' to the requirements, so that we can put the key that wasn't 42 | found in the error message. -} 43 | 44 | search :: (Show k, Eq k) => k -> [(k,v)] -> Result v 45 | search = undefined 46 | 47 | {- Finally, reimplement 'lookupAll v4' to return 'Result (Tree v)' 48 | instead of 'Maybe (Tree v)'. (The code will be identical!) -} 49 | 50 | lookupAll_v4 :: (Show k, Eq k) => [(k,v)] -> Tree k -> Result (Tree v) 51 | lookupAll_v4 = undefined 52 | 53 | 54 | 55 | {- 2. Processes 56 | 57 | The following data type represents processes that can 'Input' lines 58 | and carry on given information about what that line is; 'Output' 59 | lines and then carry on being a process; or 'End', with a value. -} 60 | 61 | data Process a 62 | = End a 63 | | Input (String -> Process a) 64 | | Output String (Process a) 65 | 66 | {- Here is an example process, written out in full. It implements a 67 | simple interactive program: -} 68 | 69 | interaction :: Process () 70 | interaction = 71 | Output "What is your name?" 72 | (Input (\name -> 73 | Output ("Hello " ++ name ++ "!") (End ()))) 74 | 75 | {- Processes by themselves do not do anything. They are only 76 | descriptions of what to do. To have an effect on the world, we to 77 | need to translate them to Haskell's primitives for doing I/O (we 78 | will cover this in more detail in Week 08): -} 79 | 80 | runProcess :: Process a -> IO a 81 | runProcess (End a) = return a 82 | runProcess (Input k) = do line <- getLine; runProcess (k line) 83 | runProcess (Output line p) = do putStrLn line; runProcess p 84 | 85 | {- Now we can run the 'interaction' described above: 86 | 87 | > runProcess interaction 88 | What is your name? 89 | Bob <--- this line entered by the user 90 | Hello Bob! 91 | -} 92 | 93 | {- Writing out processes in the style of 'interaction' above is annoying 94 | due to the brackets needed. We can make it simpler by defining some 95 | functions, First we define two basic operations: 'input' and 96 | 'output', which are little "mini-Processes" that do one input or 97 | output operation. -} 98 | 99 | input :: Process String 100 | input = Input (\x -> End x) 101 | 102 | output :: String -> Process () 103 | output s = Output s (End ()) 104 | 105 | {- The key operation is sequencing of processes. First we (simulate) run 106 | one process, then we take the result value from that and use it to 107 | make a second process which we run. Note that this has the same 108 | flavour as the 'ifOK', 'andThen' and 'andThenWithPrinting' 109 | functions from the notes. -} 110 | 111 | sequ :: Process a -> (a -> Process b) -> Process b 112 | sequ (End a) f = undefined 113 | sequ (Input k) f = undefined 114 | sequ (Output s p) f = undefined 115 | 116 | {- HINT: this is very very similar to the 'subst' function from the Week 117 | 03 problems. 118 | 119 | Once you have 'sequ', you can define a neater version of 120 | 'interaction' that makes the sequential nature clearer: -} 121 | 122 | interaction_v2 :: Process () 123 | interaction_v2 = 124 | output "What is your name?" `sequ` \() -> 125 | input `sequ` \name -> 126 | output ("Hello " ++ name ++ "!") `sequ` \() -> 127 | End () 128 | 129 | {- Running 'runProcess interaction_v2' should have the same effect as 130 | running 'runProcess interaction' did. 131 | 132 | Let's put sequ to work. 133 | 134 | Implement an interactive 'map' using 'input', 'output' and 135 | 'sequ'. This is a 'map' that prompts the user for what string to 136 | use to replace each string in the input list. This will be similar 137 | to printAndSum_v2 from the notes. 138 | 139 | For example: 140 | 141 | > runProcess (interactiveMap ["A","B","C"]) 142 | A 143 | a 144 | B 145 | b 146 | C 147 | c 148 | ["a","b","c"] 149 | 150 | where the lower case lines are entered by the user. -} 151 | 152 | interactiveMap :: [String] -> Process [String] 153 | interactiveMap = undefined 154 | 155 | {- Finally, implement a function that does an 'interactive filter', 156 | similar to the interactive map. For every element in the input 157 | list, it outputs it and prompts for user input. If the user types 158 | "y" then the element is kept. If the user types anything else, it 159 | is not copied into the output list. -} 160 | 161 | interactiveFilter :: Show a => [a] -> Process [a] 162 | interactiveFilter = undefined 163 | 164 | {- For example, 165 | 166 | > runProcess (interactiveFilter ["A","B","C"]) 167 | Keep "A"? 168 | y 169 | Keep "B"? 170 | n 171 | Keep "C"? 172 | y 173 | ["A","C"] 174 | 175 | -} 176 | -------------------------------------------------------------------------------- /lecture-notes/Week06Solutions.hs: -------------------------------------------------------------------------------- 1 | module Week06Solutions where 2 | 3 | {------------------------------------------------------------------------------} 4 | {- TUTORIAL QUESTIONS -} 5 | {------------------------------------------------------------------------------} 6 | 7 | data Tree a 8 | = Leaf 9 | | Node (Tree a) a (Tree a) 10 | deriving Show 11 | 12 | {- 1. Using 'Result' to handle errors. 13 | 14 | Here is the 'Result' type described in the notes. It is like the 15 | 'Maybe' type except that the "fail" case has a String message 16 | attached: -} 17 | 18 | data Result a 19 | = Ok a 20 | | Error String 21 | deriving (Eq, Show) 22 | 23 | {- Implement 'returnOK', 'failure', 'ifOK' and 'catch' for 'Result' 24 | instead of 'Maybe'. Note that in 'failure' we have to provide an 25 | error message, and in 'catch' the "exception handler" gets the 26 | error message. -} 27 | 28 | returnOk :: a -> Result a 29 | returnOk x = Ok x -- NOTE: because 'Ok' is like 'Just' here 30 | 31 | failure :: String -> Result a 32 | failure msg = Error msg -- NOTE: 'Error' is like 'Nothing', except that we have an error message too 33 | 34 | ifOK :: Result a -> (a -> Result b) -> Result b 35 | ifOK (Ok a) k = k a 36 | ifOK (Error msg) k = Error msg 37 | 38 | catch :: Result a -> (String -> Result a) -> Result a 39 | catch (Ok a) handler = Ok a 40 | catch (Error msg) handler = handler msg 41 | 42 | {- Reimplement 'search' to use 'Result' instead of 'Maybe'. We add 'Show 43 | k' to the requirements, so that we can put the key that wasn't 44 | found in the error message. -} 45 | 46 | search :: (Show k, Eq k) => k -> [(k,v)] -> Result v 47 | search k [] = failure ("Key '" ++ show k ++ "' not found") 48 | search k ((k',v'):kvs) = 49 | if k == k' then 50 | returnOk v' 51 | else 52 | search k kvs 53 | 54 | {- Finally, reimplement 'lookupAll v4' to return 'Result (Tree v)' 55 | instead of 'Maybe (Tree v)'. (The code will be identical!) -} 56 | 57 | lookupAll_v4 :: (Show k, Eq k) => [(k,v)] -> Tree k -> Result (Tree v) 58 | lookupAll_v4 kvs Leaf = returnOk Leaf 59 | lookupAll_v4 kvs (Node l k r) = 60 | lookupAll_v4 kvs l `ifOK` \l' -> 61 | search k kvs `ifOK` \v -> 62 | lookupAll_v4 kvs r `ifOK` \r' -> 63 | returnOk (Node l' v r') 64 | 65 | 66 | {- 2. Processes 67 | 68 | The following data type represents processes that can 'Input' lines 69 | and carry on given information about what that line is; 'Output' 70 | lines and then carry on being a process; or 'End', with a value. -} 71 | 72 | data Process a 73 | = End a 74 | | Input (String -> Process a) 75 | | Output String (Process a) 76 | 77 | {- Here is an example process, written out in full. It implements a 78 | simple interactive program: -} 79 | 80 | interaction :: Process () 81 | interaction = 82 | Output "What is your name?" 83 | (Input (\name -> 84 | Output ("Hello " ++ name ++ "!") (End ()))) 85 | 86 | {- Processes by themselves do not do anything. They are only 87 | descriptions of what to do. To have an effect on the world, we to 88 | need to translate them to Haskell's primitives for doing I/O (we 89 | will cover this in more detail in Week 08): -} 90 | 91 | runProcess :: Process a -> IO a 92 | runProcess (End a) = return a 93 | runProcess (Input k) = do line <- getLine; runProcess (k line) 94 | runProcess (Output line p) = do putStrLn line; runProcess p 95 | 96 | {- Now we can run the 'interaction' described above: 97 | 98 | > runProcess interaction 99 | What is your name? 100 | Bob <--- this line entered by the user 101 | Hello Bob! 102 | -} 103 | 104 | {- Writing out processes in the style of 'interaction' above is annoying 105 | due to the brackets needed. We can make it simpler by defining some 106 | functions, First we define two basic operations: 'input' and 107 | 'output', which are little "mini-Processes" that do one input or 108 | output operation. -} 109 | 110 | input :: Process String 111 | input = Input (\x -> End x) 112 | 113 | output :: String -> Process () 114 | output s = Output s (End ()) 115 | 116 | {- The key operation is sequencing of processes. First we (simulate) run 117 | one process, then we take the result value from that and use it to 118 | make a second process which we run. Note that this has the same 119 | flavour as the 'ifOK', 'andThen' and 'andThenWithPrinting' 120 | functions from the notes. -} 121 | 122 | sequ :: Process a -> (a -> Process b) -> Process b 123 | sequ (End a) f = f a 124 | sequ (Input k) f = Input (\x -> sequ (k x) f) 125 | sequ (Output s p) f = Output s (sequ p f) 126 | 127 | -- NOTE: why does this work? 128 | -- 129 | -- - In the 'End' case, the first process has ended with the value 130 | -- 'a', so the process we return is the second one given the value 'a'. 131 | -- 132 | -- - In the 'Input' case, the first process expects to do an input. So 133 | -- we generate a process that does an input. The anonymous function 134 | -- we use is '\x -> sequ (k x) f', which takes the input 'x', uses 135 | -- it to find out what the first process will continue to do and 136 | -- sequence 'f' after that. 137 | -- 138 | -- - In the 'Output' case, the first process expects to do an 'Output' 139 | -- of 's'. So we return a process that does that, and then carries 140 | -- on doing 'p' followed by 'f'. 141 | 142 | {- HINT: this is very very similar to the 'subst' function from Week 03. 143 | 144 | Once you have 'subst', you can define a neater version of 145 | 'interaction' that makes the sequential nature clearer: -} 146 | 147 | interaction_v2 :: Process () 148 | interaction_v2 = 149 | output "What is your name?" `sequ` \() -> 150 | input `sequ` \name -> 151 | output ("Hello " ++ name ++ "!") `sequ` \() -> 152 | End () 153 | 154 | {- Let's put sequ to work. 155 | 156 | Implement an interactive 'map' using 'input', 'output' and 157 | 'sequ'. This is a 'map' that prompts the user for what string to 158 | use to replace each string in the input list. This will be similar 159 | to printAndSum_v2 from the notes. 160 | 161 | For example: 162 | 163 | > runProcess (interactiveMap ["A","B","C"]) 164 | A 165 | a 166 | B 167 | b 168 | C 169 | c 170 | ["a","b","c"] 171 | 172 | where the lower case lines are entered by the user. -} 173 | 174 | interactiveMap :: [String] -> Process [String] 175 | interactiveMap [] = End [] 176 | interactiveMap (x:xs) = 177 | output x `sequ` \() -> 178 | input `sequ` \y -> 179 | interactiveMap xs `sequ` \ys -> 180 | End (y:ys) 181 | 182 | {- Finally, implement a function that does an 'interactive filter', 183 | similar to the interactive map. For every element in the input 184 | list, it outputs it and prompts for user input. If the user types 185 | "y" then the element is kept. Otherwise it is not copied into the 186 | output list. -} 187 | 188 | interactiveFilter :: Show a => [a] -> Process [a] 189 | interactiveFilter [] = End [] 190 | interactiveFilter (x:xs) = 191 | output ("Keep " ++ show x ++ "?") `sequ` \() -> 192 | input `sequ` \inp -> 193 | if inp == "y" then 194 | interactiveFilter xs `sequ` \ys -> 195 | End (x:ys) 196 | else 197 | interactiveFilter xs 198 | 199 | {- For example, 200 | 201 | > runProcess (interactiveFilter ["A","B","C"]) 202 | Keep "A"? 203 | y 204 | Keep "B"? 205 | n 206 | Keep "C"? 207 | y 208 | ["A","C"] 209 | 210 | -} 211 | -------------------------------------------------------------------------------- /lecture-notes/Week07Intro.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 4 | module Week07Intro where 5 | 6 | import Prelude hiding ( Monad (..) 7 | , Applicative (..) 8 | , mapM 9 | , mapM_ 10 | , (<$>)) 11 | import Data.Char (isDigit, digitToInt) 12 | 13 | {- This is needed due to the RebindableSyntax extension. I'm using this 14 | extension so the 'do' notation in this file uses my redefined 15 | 'Monad' type class, not the standard library one. RebindableSyntax 16 | lets the user redefine what 'do', and 'if' mean. I've given 'if' 17 | the standard meaning here: -} 18 | ifThenElse True x y = x 19 | ifThenElse False x y = y 20 | (>>) x y = x >>= \_ -> y 21 | 22 | 23 | {- WEEK 7 : MONADS 24 | 25 | Last week we saw three examples of how to simulate side effects 26 | with "pure" code in Haskell: 27 | 28 | 1. simulating exceptions using the 'Maybe' type, 29 | 30 | 2. simulating mutable state by explicit state passing, and 31 | 32 | 3. simulating printing by collecting outputs. 33 | 34 | This week, we look at the common pattern in all these examples, and 35 | give it a name: 'Monad'. -} 36 | 37 | 38 | 39 | 40 | 41 | 42 | {- 7.1 DEFINING MONADS and THE MAYBE MONAD 43 | 44 | returnOk :: a -> Maybe a 45 | returnState :: a -> State a 46 | returnPrinting :: a -> Printing a 47 | 48 | and a "do this, then do that" operation: 49 | 50 | ifOK :: Maybe a -> (a -> Maybe b) -> Maybe b 51 | andThen :: State a -> (a -> State b) -> State b 52 | andThenWithPrinting :: Printing a -> (a -> Printing b) -> Printing b 53 | 54 | The Week 06 tutorial questions asked you to write this function for 55 | 'Process'es, with yet again a similar type. 56 | 57 | sequ :: Process a -> (a -> Process b) -> Process b 58 | -} 59 | 60 | -- Monad 61 | 62 | class Monad m where 63 | return :: a -> m a 64 | (>>=) :: m a -> (a -> m b) -> m b 65 | 66 | 67 | join :: m (m a) -> m a 68 | join = undefined 69 | 70 | 71 | -- Maybe monad 72 | instance Monad Maybe where 73 | return a = Just a 74 | Nothing >>= k = Nothing 75 | Just a >>= k = k a 76 | 77 | failure :: Maybe a 78 | failure = Nothing 79 | 80 | {- 7.2 'do' NOTATION -} 81 | {- 82 | lookupList_v2 :: Eq k => [k] -> [(k,v)] -> Maybe [v] 83 | lookupList_v2 [] kvs = returnOk [] 84 | lookupList_v2 (k:ks) kvs = 85 | search k kvs >>= \v -> 86 | lookupList_v2 ks kvs >>= \vs -> 87 | returnOk (v:vs) 88 | -} 89 | search :: Eq k => k -> [(k,v)] -> Maybe v 90 | search k [] = failure 91 | search k ((k',v):kvs) = if k == k' then return v else search k kvs 92 | 93 | lookupList_v2 :: Eq k => [k] -> [(k,v)] -> Maybe [v] 94 | lookupList_v2 [] kvs = return [] 95 | lookupList_v2 (k:ks) kvs = do 96 | v <- search k kvs; 97 | vs <- lookupList_v2 ks kvs; 98 | return (v:vs) 99 | 100 | 101 | {- 7.3 STATE MONAD -} 102 | 103 | newtype State a = MkState (Int -> (Int, a)) 104 | 105 | instance Monad State where 106 | return a = MkState (\s -> (s, a)) 107 | 108 | -- t :: Int -> (Int, a) 109 | -- k :: a -> State b 110 | MkState t >>= k = 111 | MkState (\s0 -> let (s1, a) = t s0 112 | MkState t' = k a 113 | (s2, b) = t' s1 114 | in (s2, b)) 115 | 116 | get :: State Int 117 | get = MkState (\s -> (s,s)) 118 | 119 | put :: Int -> State () 120 | put s = MkState (\_ -> (s,())) 121 | 122 | 123 | increment :: State () 124 | increment = do i <- get 125 | put (i+1) 126 | 127 | modify :: (Int -> Int) -> State () 128 | modify f = do i <- get 129 | put (f i) 130 | 131 | decrement = modify (\x -> x - 1) 132 | 133 | numberList :: [a] -> State [(Int,a)] 134 | numberList [] = return [] 135 | numberList (x:xs) = 136 | do i <- get; 137 | increment; 138 | ys <- numberList xs; 139 | return ((i,x):ys) 140 | 141 | runState :: State a -> Int -> a 142 | runState (MkState t) i = let (_,a) = t i in a 143 | 144 | -- Most Monads come with: 145 | -- (a) a collection of basic operations: failure, or get/put 146 | -- (b) a 'run' function that executes the computation 147 | 148 | 149 | {- 7.5 THINGS FOR ALL MONADS -} 150 | 151 | mapM :: Monad m => (a -> m b) -> [a] -> m [b] 152 | mapM f [] = return [] 153 | mapM f (x:xs) = do y <- f x 154 | ys <- mapM f xs 155 | return (y:ys) 156 | 157 | numberList_v2 :: [a] -> State [(Int,a)] 158 | numberList_v2 = mapM (\a -> do i <- get; increment; return (i,a)) 159 | 160 | -- mapM_ 161 | mapM_ :: Monad m => (a -> m ()) -> [a] -> m () 162 | mapM_ f [] = return () 163 | mapM_ f (x:xs) = do f x 164 | mapM_ f xs 165 | 166 | runState_ :: State a -> Int -> Int 167 | runState_ (MkState t) i = let (i1,_) = t i in i1 168 | 169 | addUpList :: [Int] -> State () 170 | addUpList = mapM_ (\i -> modify (+i)) 171 | 172 | for_ :: Monad m => [a] -> (a -> m ()) -> m () 173 | for_ = flip mapM_ 174 | 175 | addUpList :: [Int] -> State () 176 | addUpList xs = for_ xs $ \i -> 177 | modify (+i) 178 | -------------------------------------------------------------------------------- /lecture-notes/Week07Live.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 4 | module Week07Live where 5 | 6 | import Prelude hiding ( Monad (..) 7 | , Applicative (..) 8 | , mapM 9 | , mapM_ 10 | , (<$>)) 11 | import Data.Char (isDigit, digitToInt) 12 | 13 | {- This is needed due to the RebindableSyntax extension. I'm using this 14 | extension so the 'do' notation in this file uses my redefined 15 | 'Monad' type class, not the standard library one. RebindableSyntax 16 | lets the user redefine what 'do', and 'if' mean. I've given 'if' 17 | the standard meaning here: -} 18 | ifThenElse True x y = x 19 | ifThenElse False x y = y 20 | (>>) x y = x >>= \_ -> y 21 | 22 | 23 | {- WEEK 7 : MONADS 24 | 25 | Last week we saw three examples of how to simulate side effects 26 | with "pure" code in Haskell: 27 | 28 | 1. simulating exceptions using the 'Maybe' type, 29 | 30 | 2. simulating mutable state by explicit state passing, and 31 | 32 | 3. simulating printing by collecting outputs. 33 | 34 | This week, we look at the common pattern in all these examples, and 35 | give it a name: 'Monad'. -} 36 | 37 | 38 | {- 7.1 DEFINING MONADS and THE MAYBE MONAD 39 | 40 | returnOk :: a -> Maybe a 41 | returnState :: a -> State a 42 | returnPrinting :: a -> Printing a 43 | 44 | and a "do this, then do that" operation: 45 | 46 | ifOK :: Maybe a -> (a -> Maybe b) -> Maybe b 47 | andThen :: State a -> (a -> State b) -> State b 48 | andThenWithPrinting :: Printing a -> (a -> Printing b) -> Printing b 49 | 50 | The Week 06 tutorial questions asked you to write this function for 51 | 'Process'es, with yet again a similar type. 52 | 53 | sequ :: Process a -> (a -> Process b) -> Process b 54 | -} 55 | 56 | -- Monad 57 | class Monad m where 58 | return :: a -> m a 59 | (>>=) :: m a -> (a -> m b) -> m b --- pronounced 'bind' 60 | 61 | -- Maybe monad 62 | 63 | 64 | instance Monad Maybe where 65 | return = Just 66 | Nothing >>= k = Nothing 67 | Just v >>= k = k v 68 | 69 | -- return v >>= k === k v 70 | -- c >>= return === c 71 | -- (c >>= k1) >>= k2 === c >>= (\ x -> k1 x >>= k2) 72 | 73 | apply :: Maybe (a -> b) -> Maybe a -> Maybe b 74 | apply mf mx = 75 | mf >>= \ f -> 76 | mx >>= \ x -> 77 | return (f x) 78 | 79 | filterM :: (a -> Maybe Bool) -> [a] -> Maybe [a] 80 | filterM p [] = return [] 81 | filterM p (x : xs) = 82 | p x >>= \ b -> 83 | filterM p xs >>= \ xs' -> 84 | return (if b then x : xs' else xs') 85 | 86 | -- do Notation 87 | 88 | apply_v2 :: Maybe (a -> b) -> Maybe a -> Maybe b 89 | apply_v2 mf mx = 90 | do f <- mf 91 | x <- mx 92 | return (f x) 93 | 94 | filterM_v2 :: (a -> Maybe Bool) -> [a] -> Maybe [a] 95 | filterM_v2 p [] = do return [] 96 | filterM_v2 p (x : xs) = do 97 | b <- p x 98 | xs' <- filterM_v2 p xs 99 | return (if b then x : xs' else xs') 100 | 101 | 102 | -- State Monad 103 | 104 | newtype State s a = MkState { runState :: s -> (a, s) } 105 | 106 | instance Monad (State s) where 107 | return v = MkState (\ s -> (v, s)) 108 | c1 >>= k = MkState (\ s0 -> 109 | let (a, s1) = runState c1 s0 in 110 | let (b, s2) = runState (k a) s1 in 111 | (b, s2)) 112 | 113 | 114 | apply_v3 :: State s (a -> b) -> State s a -> State s b 115 | apply_v3 mf mx = 116 | do f <- mf 117 | x <- mx 118 | return (f x) 119 | 120 | filterM_v3 :: (a -> State s Bool) -> [a] -> State s [a] 121 | filterM_v3 p [] = do return [] 122 | filterM_v3 p (x : xs) = do 123 | b <- p x 124 | xs' <- filterM_v3 p xs 125 | return (if b then x : xs' else xs') 126 | 127 | -- Functions for all monads 128 | apply_v4 :: Monad m => m (a -> b) -> m a -> m b 129 | apply_v4 mf mx = 130 | do f <- mf 131 | x <- mx 132 | return (f x) 133 | 134 | filterM_v4 :: Monad m => (a -> m Bool) -> [a] -> m [a] 135 | filterM_v4 p [] = do return [] 136 | filterM_v4 p (x : xs) = do 137 | b <- p x 138 | xs' <- filterM_v4 p xs 139 | return (if b then x : xs' else xs') 140 | 141 | treeSort :: Monad m 142 | => (a -> a -> m Bool) 143 | -> [a] 144 | -> m [a] 145 | treeSort cmp [] = return [] 146 | treeSort cmp (x : xs) = do 147 | lower <- filterM_v4 (\y -> cmp x y) xs 148 | higher <- filterM_v4 (\y -> do r <- cmp x y; return (not r)) xs 149 | -- (\y -> apply_v4 (return not) (cmp x y)) 150 | -- (\y -> not <$> cmp x y) 151 | lowerSorted <- treeSort cmp lower 152 | higherSorted <- treeSort cmp higher 153 | return (lowerSorted ++ [x] ++ higherSorted) 154 | 155 | newtype Count a = MkCount { runCount :: (Int, a) } 156 | deriving Show 157 | 158 | instance Monad Count where 159 | return x = MkCount (0, x) 160 | c >>= k = MkCount (let (count1,a) = runCount c in 161 | let (count2,b) = runCount (k a) in 162 | (count1+count2, b)) 163 | 164 | step :: Count () 165 | step = MkCount (1, ()) 166 | 167 | mapM :: Monad m => (a -> m b) -> [a] -> m [b] 168 | mapM f [] = return [] 169 | mapM f (x : xs) = do 170 | y <- f x 171 | ys <- mapM f xs 172 | return (y : ys) 173 | 174 | mapM_ :: Monad m => (a -> m ()) -> [a] -> m () 175 | mapM_ f [] = return () 176 | mapM_ f (x : xs) = do 177 | _ <- f x 178 | _ <- mapM_ f xs 179 | return () 180 | 181 | for_ :: Monad m => [a] -> (a -> m ()) -> m () 182 | for_ xs f = mapM_ f xs 183 | 184 | -- for_ [0..10] (\x -> do print x) 185 | -------------------------------------------------------------------------------- /lecture-notes/Week07Problems.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 4 | module Week07Problems where 5 | 6 | import Prelude hiding ( Monad (..) 7 | , Applicative (..) 8 | , mapM 9 | , mapM_ 10 | , (<$>)) 11 | import Week07 hiding (search, lookupAll, ifThenElse, (>>)) 12 | 13 | {- This is needed due to the RebindableSyntax extension. I'm using this 14 | extension so the 'do' notation in this file uses my redefined 15 | 'Monad' type class, not the standard library one. RebindableSyntax 16 | lets the user redefine what 'do', and 'if' mean. I've given 'if' 17 | the standard meaning here: -} 18 | ifThenElse True x y = x 19 | ifThenElse False x y = y 20 | (>>) x y = x >>= \_ -> y 21 | 22 | {------------------------------------------------------------------------------} 23 | {- TUTORIAL QUESTIONS -} 24 | {------------------------------------------------------------------------------} 25 | 26 | {- 1. The 'Maybe' monad is useful for simulating exceptions. But when an 27 | exception is thrown, we don't get any information on what the 28 | exceptional condition was! The way to fix this is to use a type 29 | that includes some information on the 'Error' case: -} 30 | 31 | data Result a 32 | = Ok a 33 | | Error String 34 | deriving Show 35 | 36 | {- Write a Monad instance for 'Result', using the code from your 37 | 'returnOk' and 'ifOK' functions from last week, and then use it 38 | to rewrite the 'search' and 'lookupAll' functions. -} 39 | 40 | 41 | {- 2. Write a function using the Printing monad and 'do' notation that 42 | "prints out" all the strings in a tree of 'String's: -} 43 | 44 | printTree :: Tree String -> Printing () 45 | printTree = undefined 46 | 47 | 48 | {- 3. The implementation of 'sumImp' in the notes can only sum up lists 49 | of 'Int's. 50 | 51 | (a) What changes would you have to make to 'State' so that you 52 | can add up lists of 'Double's? You'll have to make a new 53 | newtype like 'State', and reimplement the 'runState', the 54 | 'Monad' instance, the 'get' and 'put' function, and finally 55 | the 'sumpImp' function. The changes to the actual code will 56 | be minimal, if anything. All the changes are in the types. -} 57 | 58 | 59 | 60 | 61 | {- (b) Make an alternative version of 'State' that is parameterised 62 | by the type of the state (so that someone using it can 63 | decide whether it is 'Int' or 'Double' for instance). -} 64 | 65 | 66 | {- 4. Write a function like mapM that works on 'Tree's instead of lists: -} 67 | 68 | mapTreeM :: Monad m => (a -> m b) -> Tree a -> m (Tree b) 69 | mapTreeM = undefined 70 | 71 | 72 | {- 5. Write a function like mapM that works on 'Maybe's instead of lists: -} 73 | 74 | mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) 75 | mapMaybeM = undefined 76 | -------------------------------------------------------------------------------- /lecture-notes/Week07Solutions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 4 | module Week07Solutions where 5 | 6 | import Prelude hiding ( Monad (..) 7 | , Applicative (..) 8 | , mapM 9 | , mapM_ 10 | , (<$>)) 11 | import Week07 hiding (search, lookupAll, ifThenElse, (>>)) 12 | 13 | {- This is needed due to the RebindableSyntax extension. I'm using this 14 | extension so the 'do' notation in this file uses my redefined 15 | 'Monad' type class, not the standard library one. RebindableSyntax 16 | lets the user redefine what 'do', and 'if' mean. I've given 'if' 17 | the standard meaning here: -} 18 | ifThenElse True x y = x 19 | ifThenElse False x y = y 20 | (>>) x y = x >>= \_ -> y 21 | 22 | {------------------------------------------------------------------------------} 23 | {- TUTORIAL QUESTIONS -} 24 | {------------------------------------------------------------------------------} 25 | 26 | {- 1. The 'Maybe' monad is useful for simulating exceptions. But when an 27 | exception is thrown, we don't get any information on what the 28 | exceptional condition was! The way to fix this is to use a type 29 | that includes some information on the 'Error' case: -} 30 | 31 | data Result a 32 | = Ok a 33 | | Error String 34 | deriving Show 35 | 36 | {- Write a Monad instance for 'Result', using the code from your 37 | 'returnOk' and 'ifOK' functions from last week, and then use it 38 | to rewrite the 'search' and 'lookupAll' functions. -} 39 | 40 | instance Monad Result where 41 | return = Ok 42 | 43 | Ok x >>= k = k x 44 | Error msg >>= k = Error msg 45 | 46 | search :: (Show k, Eq k) => k -> [(k,v)] -> Result v 47 | search k [] = Error ("Key '" ++ show k ++ "' not found") 48 | search k ((k',v'):kvs) = 49 | if k == k' then 50 | return v' 51 | else 52 | search k kvs 53 | 54 | lookupAll :: (Show k, Eq k) => [(k,v)] -> Tree k -> Result (Tree v) 55 | lookupAll kvs Leaf = 56 | return Leaf 57 | lookupAll kvs (Node l k r) = 58 | do l' <- lookupAll kvs l 59 | v <- search k kvs 60 | r' <- lookupAll kvs r 61 | return (Node l' v r') 62 | 63 | 64 | {- 2. Write a function using the Printing monad and 'do' notation that 65 | "prints out" all the strings in a tree of 'String's: -} 66 | 67 | printTree :: Tree String -> Printing () 68 | printTree Leaf = 69 | return () 70 | printTree (Node l x r) = 71 | do printTree l 72 | printLine x 73 | printTree r 74 | 75 | 76 | {- 3. The implementation of 'sumImp' in the notes can only sum up lists 77 | of 'Int's. 78 | 79 | (a) What changes would you have to make to 'State' so that you 80 | can add up lists of 'Double's? You'll have to make a new 81 | newtype like 'State', and reimplement the 'runState', the 82 | 'Monad' instance, the 'get' and 'put' function, and finally 83 | the 'sumpImp' function. The changes to the actual code will 84 | be minimal, if anything. All the changes are in the types. -} 85 | 86 | -- To do this, we modify the 'State' newtype, to change the 'Int's to 87 | -- 'Double's. I have added the suffix 'D' for 'D'ouble. 88 | 89 | newtype StateD a = MkStateD (Double -> (Double, a)) 90 | 91 | -- Then we write the functions again, with new types: 92 | 93 | runStateD :: StateD a -> Double -> (Double, a) 94 | runStateD (MkStateD t) = t 95 | 96 | instance Monad StateD where 97 | return :: a -> StateD a 98 | return x = 99 | MkStateD (\s -> (s, x)) 100 | 101 | (>>=) :: StateD a -> (a -> StateD b) -> StateD b 102 | op >>= f = 103 | MkStateD (\s -> 104 | let (s0, a) = runStateD op s 105 | (s1, b) = runStateD (f a) s0 106 | in (s1, b)) 107 | 108 | getD :: StateD Double 109 | getD = MkStateD (\s -> (s,s)) 110 | 111 | putD :: Double -> StateD () 112 | putD i = MkStateD (\_ -> (i,())) 113 | 114 | sumImpD :: [Double] -> StateD Double 115 | sumImpD xs = 116 | do putD 0 117 | for_ xs (\x -> do 118 | total <- getD 119 | putD (total + x)) 120 | result <- getD 121 | return result 122 | 123 | {- (b) Make an alternative version of 'State' that is parameterised 124 | by the type of the state (so that someone using it can 125 | decide whether it is 'Int' or 'Double' for instance). -} 126 | 127 | -- To do this, we add an extra parameter to the 'State' newtype, which 128 | -- we call 's' here. I have added the suffix 'G' for 'G'eneric. 129 | 130 | newtype StateG s a = MkStateG (s -> (s, a)) 131 | 132 | -- then we rewrite all our functions with basically the same code, but 133 | -- more general types: 134 | 135 | runStateG :: StateG s a -> s -> (s, a) 136 | runStateG (MkStateG t) = t 137 | 138 | instance Monad (StateG s) where 139 | return :: a -> StateG s a 140 | return x = 141 | MkStateG (\s -> (s, x)) 142 | 143 | (>>=) :: StateG s a -> (a -> StateG s b) -> StateG s b 144 | op >>= f = 145 | MkStateG (\s -> 146 | let (s0, a) = runStateG op s 147 | (s1, b) = runStateG (f a) s0 148 | in (s1, b)) 149 | 150 | getG :: StateG s s 151 | getG = MkStateG (\s -> (s,s)) 152 | 153 | putG :: s -> StateG s () 154 | putG i = MkStateG (\_ -> (i,())) 155 | 156 | sumImpG :: Monoid m => [m] -> StateG m m 157 | sumImpG xs = 158 | do putG mempty 159 | for_ xs (\x -> do 160 | total <- getG 161 | putG (total <> x)) 162 | result <- getG 163 | return result 164 | 165 | {- 4. Write a function like mapM that works on 'Tree's instead of lists: -} 166 | 167 | mapTreeM :: Monad m => (a -> m b) -> Tree a -> m (Tree b) 168 | mapTreeM f Leaf = return Leaf 169 | mapTreeM f (Node l x r) = 170 | do l' <- mapTreeM f l 171 | y <- f x 172 | r' <- mapTreeM f r 173 | return (Node l' y r') 174 | 175 | 176 | {- 5. Write a function like mapM that works on 'Maybe's instead of lists: -} 177 | 178 | mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) 179 | mapMaybeM f Nothing = return Nothing 180 | mapMaybeM f (Just x) = 181 | do y <- f x 182 | return (Just y) 183 | -------------------------------------------------------------------------------- /lecture-notes/Week08Live.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | {-# LANGUAGE InstanceSigs, DeriveFunctor #-} 3 | module Week08Live where 4 | 5 | import Control.Monad (ap) 6 | 7 | import Prelude hiding (putChar, getChar) 8 | import Data.Char (toUpper, isDigit, digitToInt, isSpace, isAlpha) 9 | import Data.Foldable (for_) 10 | import Data.IORef (IORef, newIORef, readIORef, 11 | writeIORef, modifyIORef) 12 | import Control.Exception (finally) 13 | import System.IO (openFile, hPutChar, hGetChar, stdin, stdout, 14 | hClose, IOMode (..), hIsEOF, Handle) 15 | 16 | {- WEEK 8 : REAL I/O and PARSER COMBINATORS -} 17 | 18 | {- Part 8.1 : I/O Conceptually 19 | 20 | A great philosopher once wrote: 21 | 22 | The philosophers have only interpreted the world, in various 23 | ways. The point, however, is to change it. 24 | 25 | -- Karl Marx ( https://en.wikipedia.org/wiki/Theses_on_Feuerbach ) 26 | 27 | -} 28 | 29 | data IOAction a 30 | = End a 31 | | Input () (Char -> IOAction a) 32 | | Output Char (() -> IOAction a) 33 | 34 | -- putChar :: Char -> () 35 | 36 | f x = (putChar x, putChar x) 37 | 38 | f2 x = (z, z) 39 | where z = putChar x 40 | 41 | 42 | f' x = do 43 | putChar x 44 | putChar x 45 | -- return (l, r) 46 | 47 | -- putChar x >>= (\l -> putChar x >>= (\r -> return (l,r))) 48 | 49 | f2' x = do 50 | z <- putChar x 51 | return (z, z) 52 | 53 | 54 | putChar :: Char -> IO () 55 | putChar = hPutChar stdout 56 | 57 | getChar :: IO Char 58 | getChar = hGetChar stdin 59 | 60 | -- getChar 61 | 62 | -- printLine 63 | 64 | -- readLine 65 | readLine :: IO String 66 | readLine = go [] 67 | where go xs = do 68 | c <- getChar 69 | if c == '\n' then 70 | return (reverse xs) 71 | else 72 | go (c:xs) 73 | 74 | 75 | 76 | {- Part 8.4 : PARSER COMBINATORS -} 77 | 78 | -- If we can get input, how do we take it apart? 79 | 80 | type Parser_v1 a = String -> Maybe a 81 | 82 | -- Parsing Booleans 83 | 84 | boolean_v1 :: Parser_v1 Bool 85 | boolean_v1 "True" = Just True 86 | boolean_v1 "False" = Just False 87 | boolean_v1 _ = Nothing 88 | 89 | -- How to parse pairs of Booleans? 90 | 91 | -- Problem: these parsers are "monolithic". There is no way to access 92 | -- the trailing input they couldn't parse. 93 | 94 | 95 | -- Solution: Parsing with Leftovers 96 | newtype Parser a = MkParser { runParser :: String -> Maybe (a, String) } 97 | deriving (Functor) 98 | 99 | -- runParser :: Parser a -> String -> Maybe (a, String) 100 | -- runParser (MkParser p) = p 101 | 102 | -- See next week 103 | instance Applicative Parser where 104 | pure x = MkParser (\ str -> Just (x, str)) 105 | (<*>) = ap 106 | 107 | instance Monad Parser where 108 | mx >>= mf = MkParser (\ str0 -> 109 | case runParser mx str0 of 110 | Nothing -> Nothing 111 | Just (x, str1) -> runParser (mf x) str1) 112 | 113 | char :: Parser Char 114 | char = MkParser go where 115 | 116 | go (x : xs) = Just (x, xs) 117 | go [] = Nothing 118 | 119 | orElseMaybe :: Maybe a -> Maybe a -> Maybe a 120 | orElseMaybe (Just x) _ = Just x 121 | orElseMaybe Nothing y = y 122 | 123 | orElse :: Parser a -> Parser a -> Parser a 124 | orElse p1 p2 = 125 | MkParser (\input -> runParser p1 input `orElseMaybe` runParser p2 input) 126 | 127 | failure :: Parser a 128 | failure = MkParser (\_ -> Nothing) 129 | 130 | {- The basic parser interface: 131 | 132 | 133 | Parser a 134 | ^--- represents a parser of things of type 'a' 135 | 136 | return :: a -> Parser a 137 | ^--- parse nothing and return 'a' 138 | 139 | (>>=) :: Parser a -> (a -> Parser b) -> Parser b 140 | ^--- sequence two parsers, feeding the output of the first into the second 141 | 142 | orElse :: Parser a -> Parser a -> Parser a 143 | ^--- try one parser, if that fails try the other parser 144 | 145 | failure :: Parser a 146 | ^--- always fail 147 | 148 | char :: Parser Char 149 | ^--- read one character from the input 150 | -} 151 | 152 | 153 | 154 | -- Examples: 155 | 156 | expectChar :: Char -> Parser () 157 | expectChar c = do c' <- char 158 | if c == c' then return () else failure 159 | 160 | string :: String -> Parser () 161 | string str = for_ str (\c -> expectChar c) 162 | 163 | 164 | boolean :: Parser Bool 165 | boolean = 166 | do string "True" 167 | return True 168 | `orElse` 169 | do string "False" 170 | return False 171 | 172 | boolean2 :: Parser (Bool, Bool) 173 | boolean2 = do 174 | expectChar '(' 175 | l <- boolean 176 | expectChar ',' 177 | r <- boolean 178 | expectChar ')' 179 | return (l, r) 180 | 181 | eof :: Parser () 182 | eof = MkParser go where 183 | 184 | go [] = Just ((), "") 185 | go _ = Nothing 186 | 187 | {- PLAN: write a parser for an expression language using the combinators. -} 188 | 189 | -- 1. Fix a grammar 190 | 191 | {- ::= + 192 | | 193 | 194 | ::= * 195 | | 196 | 197 | ::= 198 | | 199 | | ( * ) { separated by commas } 200 | | ( ) 201 | 202 | ::= [0-9]+ 203 | (one or more of characters in 0 .. 9) 204 | 205 | ::= [A-Za-z]+ 206 | (one or more of alphabetic characters) 207 | -} 208 | 209 | data Expr 210 | = Addition MultExpr Expr 211 | | AMultExpr MultExpr 212 | deriving Show 213 | 214 | data MultExpr 215 | = Multiplication BaseExpr MultExpr 216 | | ABaseExpr BaseExpr 217 | deriving Show 218 | 219 | data BaseExpr 220 | = Number Integer 221 | | Variable String 222 | | FunCall String [Expr] 223 | | Parens Expr 224 | deriving Show 225 | 226 | -- 2. Design an Abstract Syntax Tree type 227 | 228 | -- 2.1: the datatype 229 | 230 | -- 2.2: a simple evaluator 231 | 232 | whitespace = satisfies isSpace 233 | 234 | whitespaces = zeroOrMore whitespace 235 | 236 | expr :: Parser Expr 237 | expr = 238 | do me <- multExpr 239 | whitespaces 240 | expectChar '+' 241 | whitespaces 242 | fe <- expr 243 | return (Addition me fe) 244 | `orElse` 245 | do me <- multExpr 246 | return (AMultExpr me) 247 | 248 | multExpr :: Parser MultExpr 249 | multExpr = 250 | do be <- baseExpr 251 | whitespaces 252 | expectChar '*' 253 | whitespaces 254 | fe <- multExpr 255 | return (Multiplication be fe) 256 | `orElse` 257 | do be <- baseExpr 258 | return (ABaseExpr be) 259 | 260 | oneOrMore :: Parser a -> Parser [a] 261 | zeroOrMore :: Parser a -> Parser [a] 262 | 263 | oneOrMore p = do 264 | x <- p 265 | xs <- zeroOrMore p 266 | return (x : xs) 267 | 268 | zeroOrMore p = oneOrMore p `orElse` return [] 269 | 270 | sepBy :: Parser () -> Parser a -> Parser [a] 271 | sepBy sep p = 272 | do x <- p 273 | xs <- zeroOrMore (do sep; p) 274 | return (x:xs) 275 | `orElse` 276 | return [] 277 | 278 | baseExpr :: Parser BaseExpr 279 | baseExpr = 280 | do n <- number 281 | return (Number n) 282 | `orElse` 283 | do fnm <- variable 284 | whitespaces 285 | expectChar '(' 286 | arguments <- sepBy (expectChar ',') expr 287 | expectChar ')' 288 | return (FunCall fnm arguments) 289 | `orElse` 290 | do v <- variable 291 | return (Variable v) 292 | `orElse` 293 | do expectChar '(' 294 | whitespaces 295 | e <- expr 296 | whitespaces 297 | expectChar ')' 298 | return (Parens e) 299 | 300 | fullExpr :: Parser Expr 301 | fullExpr = do whitespaces; e <- expr; whitespaces; eof; return e 302 | 303 | number :: Parser Integer 304 | number = do 305 | ds <- oneOrMore digit 306 | return (read ds) 307 | 308 | satisfies :: (Char -> Bool) -> Parser Char 309 | satisfies pred = do 310 | c <- char 311 | if pred c then return c else failure 312 | 313 | digit = satisfies isDigit 314 | alpha = satisfies isAlpha 315 | 316 | variable :: Parser String 317 | variable = oneOrMore alpha 318 | 319 | -- 3. Write a parser, following the grammar 320 | 321 | -- 3.1: oneOrMore, alphabetic, number 322 | 323 | 324 | 325 | -- 3.2: expr, mulExpr, baseExpr 326 | 327 | -- 3.4: whitespace 328 | -------------------------------------------------------------------------------- /lecture-notes/Week08Live2023.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 3 | module Week08Live2023 where 4 | 5 | import Data.Char (toUpper, isDigit, digitToInt, isSpace, isAlpha) 6 | import Data.Foldable (for_) 7 | 8 | 9 | --- REMINDER: Week 09 (Resit) class test 10 | -- -- Wednesday 15th Nov -> Thursday 16th Nov (12:00noon) 11 | 12 | 13 | -- Parsing 14 | 15 | -- "asd,klj","sdjhds",90,fdfhg,kjh 16 | 17 | -- { "a": [1,2], "b": {"c": [ 1,2,3 sdf], "d": null } 18 | 19 | type Parser_v1 a = String -> Maybe a 20 | 21 | boolParser_v1 :: Parser_v1 Bool 22 | boolParser_v1 "true" = Just True 23 | boolParser_v1 "false" = Just False 24 | boolParser_v1 _ = Nothing 25 | 26 | -- truefalse => (True, False) 27 | 28 | -- input -> splitOn ' ' -> (boolParser, boolParser) 29 | 30 | newtype Parser a = MkParser (String -> Maybe (a, String)) 31 | 32 | runParser :: Parser a -> String -> Maybe (a, String) 33 | runParser (MkParser p) s = p s 34 | 35 | boolParser :: Parser Bool 36 | boolParser = MkParser (\input -> 37 | case input of 38 | 't':'r':'u':'e':rest -> Just (True, rest) 39 | 'f':'a':'l':'s':'e':rest -> Just (False, rest) 40 | _ -> Nothing) 41 | 42 | andThen :: Parser a -> Parser b -> Parser (a,b) 43 | andThen (MkParser p1) (MkParser p2) = 44 | MkParser (\input -> 45 | case p1 input of 46 | Just (a, rest) -> 47 | case p2 rest of 48 | Just (b, final) -> Just ((a,b), final) 49 | Nothing -> Nothing 50 | Nothing -> Nothing) 51 | 52 | char :: Parser Char 53 | char = MkParser (\input -> case input of 54 | c:cs -> Just (c, cs) 55 | [] -> Nothing) 56 | 57 | bind :: Parser a -> (a -> Parser b) -> Parser b 58 | bind (MkParser p) k = 59 | MkParser (\input -> 60 | case p input of 61 | Just (a, rest) -> 62 | case k a of 63 | MkParser p2 -> 64 | case p2 rest of 65 | Just (b, final) -> Just (b, final) 66 | Nothing -> Nothing 67 | Nothing -> Nothing) 68 | 69 | nothing :: a -> Parser a 70 | nothing a = MkParser (\input -> Just (a, input)) 71 | 72 | andThen2 :: Parser a -> Parser b -> Parser (a,b) 73 | andThen2 p1 p2 = 74 | bind p1 (\a -> bind p2 (\b -> nothing (a,b))) 75 | 76 | -- isChar :: Char -> Parser () 77 | -- isChar c = bind char (\c' -> if c == c' then nothing () else failure) 78 | 79 | failure :: Parser a 80 | failure = MkParser (\input -> Nothing) 81 | 82 | instance Monad Parser where 83 | (>>=) = bind 84 | 85 | instance Applicative Parser where 86 | pure = nothing 87 | f <*> a = do x <- f; y <- a; return (x y) 88 | 89 | instance Functor Parser where 90 | fmap :: (a -> b) -> Parser a -> Parser b 91 | fmap f (MkParser p) = 92 | MkParser (\input -> case p input of 93 | Just (a, rest) -> Just (f a, rest) 94 | Nothing -> Nothing) 95 | 96 | pairOfBools :: Parser (Bool, Bool) 97 | pairOfBools = 98 | do b1 <- boolParser 99 | isChar ',' 100 | b2 <- boolParser 101 | return (b1, b2) 102 | 103 | trueP :: Parser Bool 104 | trueP = 105 | do isString "true" 106 | return True 107 | 108 | falseP :: Parser Bool 109 | falseP = 110 | do isString "false" 111 | return False 112 | 113 | orElse :: Parser a -> Parser a -> Parser a 114 | orElse (MkParser p1) (MkParser p2) = 115 | MkParser (\input -> 116 | case p1 input of 117 | Nothing -> p2 input 118 | Just (a, rest) -> Just (a,rest)) 119 | 120 | 121 | 122 | boolParser_v2 :: Parser Bool 123 | boolParser_v2 = trueP `orElse` falseP 124 | 125 | {- := ... 126 | | true 127 | | false 128 | -} 129 | 130 | {- Parser a <--- represents a parser of things of type 'a' 131 | 132 | return :: a -> Parser a <-- parse nothing and return 'a' 133 | 134 | (>>=) :: Parser a -> (a -> Parser b) -> Parser b 135 | 136 | orElse :: Parser a -> Parser a -> Parser a 137 | 138 | failure :: Parser a 139 | 140 | char :: Parser Char 141 | -} 142 | 143 | isChar :: Char -> Parser () 144 | isChar c = 145 | do c' <- char 146 | if c == c' then return () else failure 147 | 148 | isString :: String -> Parser () 149 | isString str = for_ str (\c -> isChar c) 150 | 151 | 152 | {- PLAN: write a parser for an expression language using the combinators. -} 153 | 154 | -- 1. Fix a grammar 155 | 156 | {- ::= + 157 | | 158 | 159 | ::= * 160 | | 161 | 162 | ::= 163 | | 164 | | ( ) 165 | 166 | ::= [0-9]+ 167 | (one or more of characters in 0 .. 9) 168 | 169 | ::= [A-Za-z]+ 170 | (one or more of alphabetic characters) 171 | -} 172 | 173 | -- 2. Design an Abstract Syntax Tree type 174 | 175 | data Expr 176 | = Add Expr Expr 177 | | Mul Expr Expr 178 | | Variable String 179 | | FunCall String [Expr] 180 | | Number Integer 181 | deriving (Show, Eq) 182 | 183 | -- 3. Write a parser 184 | 185 | whitespace :: Parser () 186 | whitespace = 187 | do zeroOrMore (isChar ' ') 188 | return () 189 | 190 | expr :: Parser Expr 191 | expr = 192 | do e1 <- mulexpr 193 | whitespace 194 | isChar '+' 195 | whitespace 196 | e2 <- expr 197 | return (Add e1 e2) 198 | `orElse` 199 | do e <- mulexpr 200 | return e 201 | 202 | mulexpr :: Parser Expr 203 | mulexpr = 204 | do e1 <- baseexpr 205 | whitespace 206 | isChar '*' 207 | whitespace 208 | e2 <- mulexpr 209 | return (Mul e1 e2) 210 | `orElse` 211 | do e <- baseexpr 212 | return e 213 | 214 | baseexpr :: Parser Expr 215 | baseexpr = 216 | do n <- number 217 | return (Number n) 218 | `orElse` 219 | do f <- variable 220 | isChar '(' 221 | args <- sepBy (isChar ',') expr 222 | isChar ')' 223 | return (FunCall f args) 224 | `orElse` 225 | do v <- variable 226 | return (Variable v) 227 | `orElse` 228 | do isChar '(' 229 | whitespace 230 | e <- expr 231 | whitespace 232 | isChar ')' 233 | return e 234 | 235 | wholeExpr :: Parser Expr 236 | wholeExpr = 237 | do whitespace 238 | e <- expr 239 | whitespace 240 | return e 241 | 242 | -- Plan for number: 243 | -- 1. write a parser for digits 0-9 244 | -- 2. write a parser for sequences of digits 245 | -- 3. turn lists of digits into numbers 246 | 247 | digit :: Parser Integer 248 | digit = 249 | do c <- char 250 | case c of 251 | '0' -> return 0 252 | '1' -> return 1 253 | '2' -> return 2 254 | '3' -> return 3 255 | '4' -> return 4 256 | '5' -> return 5 257 | '6' -> return 6 258 | '7' -> return 7 259 | '8' -> return 8 260 | '9' -> return 9 261 | _ -> failure 262 | 263 | zeroOrMore :: Parser a -> Parser [a] 264 | zeroOrMore p = 265 | do d <- p 266 | ds <- zeroOrMore p 267 | return (d:ds) 268 | `orElse` 269 | return [] 270 | 271 | sepBy :: Parser () -> Parser a -> Parser [a] 272 | sepBy sep p = 273 | do x <- p 274 | xs <- zeroOrMore (do sep; p) 275 | return (x:xs) 276 | `orElse` 277 | return [] 278 | 279 | oneOrMore :: Parser a -> Parser [a] 280 | oneOrMore p = do d <- p 281 | ds <- zeroOrMore p 282 | return (d:ds) 283 | 284 | number :: Parser Integer 285 | number = 286 | do ds <- oneOrMore digit 287 | return (fromDigits ds) 288 | 289 | fromDigits :: [Integer] -> Integer 290 | fromDigits = foldl (\n d -> n*10 + d) 0 291 | 292 | alphabetic :: Parser Char 293 | alphabetic = 294 | do c <- char 295 | if isAlpha c then return c else failure 296 | 297 | variable :: Parser String 298 | variable = oneOrMore alphabetic 299 | -------------------------------------------------------------------------------- /lecture-notes/Week08Problems.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | module Week08Problems where 3 | 4 | import System.IO (Handle, openFile, IOMode (WriteMode), hClose, hPutChar) 5 | import GHC.IO (finally) 6 | import Data.Foldable (for_) 7 | import Week08 8 | import Data.List (intercalate) 9 | import Data.Char (isAlphaNum) 10 | 11 | {------------------------------------------------------------------------------} 12 | {- TUTORIAL QUESTIONS -} 13 | {------------------------------------------------------------------------------} 14 | 15 | {- 1. (a) Write a function 'withOutputFile' that does what 'withInputFile' 16 | (section 8.3) does but for output. -} 17 | 18 | withOutputFile :: FilePath -> (Handle -> IO a) -> IO a 19 | withOutputFile = undefined 20 | 21 | {- (b) Use your 'withOutputFile' to write an exception safe version 22 | of 'writeToFile'. -} 23 | 24 | writeFile :: FilePath -> String -> IO () 25 | writeFile = undefined 26 | 27 | 28 | {- 2. Write a parser for primary colours, similar to the 'parseBool' 29 | function from the notes. Here is the PrimaryColour type: -} 30 | 31 | data PrimaryColour 32 | = Red 33 | | Green 34 | | Blue 35 | deriving (Show, Eq) 36 | 37 | parsePrimaryColour :: Parser PrimaryColour 38 | parsePrimaryColour = undefined 39 | 40 | {- For example, 41 | 42 | > runParser parsePrimaryColour "Red" 43 | Just ("", Red) 44 | > runParser parsePrimaryColour "Green" 45 | Just ("", Green) 46 | > runParser parsePrimaryColour "Blue" 47 | Just ("", Blue) 48 | > runParser parsePrimaryColour "Purple" 49 | Nothing 50 | -} 51 | 52 | {- 3. Use 'sepBy', 'isString' and 'parsePrimaryColour' to write a parser 53 | for comma separated lists of primary colours. -} 54 | 55 | parseListOfPrimaryColours :: Parser [PrimaryColour] 56 | parseListOfPrimaryColours = undefined 57 | 58 | {- 4. Let us now make a little programming language. Expressions in this 59 | language follow Java-/C-style function use syntax. For example: 60 | 61 | f(4,5) is AppExp "f" [IntExp 4, IntExp 5] 62 | 63 | f(g(3),5) is AppExp "f" [AppExp "g" [IntExp 3], IntExp 5] 64 | 65 | The grammar is: 66 | 67 | ::= 68 | | '(' ')' 69 | | '(' (',' )* ')' 70 | 71 | That is, an is either: 72 | 73 | (a) an integer 74 | (b) an identifier (word without spaces) followed by "()"; or 75 | (c) an identifier followed by '(', then an , then zero or more commas and s, then a ')' 76 | 77 | Here is the datatype for expressions in this language: -} 78 | 79 | data Expr 80 | = IntExp Int 81 | | AppExp String [Expr] 82 | deriving Show 83 | 84 | {- The following function prints out 'Expr's in the Java-/C-style 85 | syntax: -} 86 | 87 | printExpr :: Expr -> String 88 | printExpr (IntExp i) = show i 89 | printExpr (AppExp funNm args) = 90 | funNm ++ "(" ++ intercalate "," (map printExpr args) ++ ")" 91 | 92 | 93 | {- Your task is to write a parser for 'Expr's. This will similar to 94 | the general structure of the JSON parser in the notes. Have a 95 | section of the parser for each constructor ('IntExp' and 96 | 'AppExp'), and use the grammar above as a guide. Use the 97 | 'number' parser from the notes to parse numbers. The 98 | 'parseIdentifier' parser defined below will be useful for doing 99 | the function names. -} 100 | 101 | parseExpr :: Parser Expr 102 | parseExpr = undefined 103 | 104 | 105 | parseIdentifier :: Parser String 106 | parseIdentifier = 107 | do c <- parseIdentifierChar 108 | cs <- zeroOrMore parseIdentifierChar 109 | return (c:cs) 110 | where 111 | parseIdentifierChar = 112 | do c <- char 113 | if isAlphaNum c then return c else failParse 114 | -------------------------------------------------------------------------------- /lecture-notes/Week08Solutions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | module Week08Solutions where 3 | 4 | import System.IO (Handle, openFile, IOMode (WriteMode), hClose, hPutChar) 5 | import GHC.IO (finally) 6 | import Data.Foldable (for_) 7 | import Week08 8 | import Data.List (intercalate) 9 | import Data.Char (isAlphaNum) 10 | 11 | {------------------------------------------------------------------------------} 12 | {- TUTORIAL QUESTIONS -} 13 | {------------------------------------------------------------------------------} 14 | 15 | {- 1. (a) Write a function 'withOutputFile' that does what 'withInputFile' 16 | (section 8.3) does but for output. -} 17 | 18 | -- The only difference is that the call to 'openFile' uses 'WriteMode' 19 | -- instead of 'ReadMode'. 20 | 21 | withOutputFile :: FilePath -> (Handle -> IO a) -> IO a 22 | withOutputFile path body = 23 | do handle <- openFile path WriteMode 24 | result <- body handle `finally` hClose handle 25 | return result 26 | 27 | {- (b) Use your 'withOutputFile' to write an exception safe version 28 | of 'writeToFile'. -} 29 | 30 | writeFile :: FilePath -> String -> IO () 31 | writeFile path content = 32 | withOutputFile path $ \handle -> 33 | for_ content (hPutChar handle) 34 | 35 | 36 | {- 2. Write a parser for primary colours, similar to the 'parseBool' 37 | function from the notes. Here is the PrimaryColour type: -} 38 | 39 | data PrimaryColour 40 | = Red 41 | | Green 42 | | Blue 43 | deriving (Show, Eq) 44 | 45 | -- This is (I think) the clearest way to write this parser. Using 46 | -- 'isString' avoids too many low-level operations involving 47 | -- individual characters. 48 | 49 | parsePrimaryColour :: Parser PrimaryColour 50 | parsePrimaryColour = 51 | do isString "Red" 52 | return Red 53 | `orElse` 54 | do isString "Green" 55 | return Green 56 | `orElse` 57 | do isString "Blue" 58 | return Blue 59 | 60 | {- For example, 61 | 62 | > runParser parsePrimaryColour "Red" 63 | Just ("", Red) 64 | > runParser parsePrimaryColour "Green" 65 | Just ("", Green) 66 | > runParser parsePrimaryColour "Blue" 67 | Just ("", Blue) 68 | > runParser parsePrimaryColour "Purple" 69 | Nothing 70 | -} 71 | 72 | {- 3. Use 'sepBy', 'isString' and 'parsePrimaryColour' to write a parser 73 | for comma separated lists of primary colours. -} 74 | 75 | parseListOfPrimaryColours :: Parser [PrimaryColour] 76 | parseListOfPrimaryColours = sepBy (isString ",") parsePrimaryColour 77 | 78 | -- You could also do: 79 | -- 80 | -- parseListOfPrimaryColours = parseList parsePrimaryColour 81 | -- 82 | -- to parse Haskell-style lists that are surrounded by '[' and ']'. 83 | 84 | 85 | {- 4. Let us now make a little programming language. Expressions in this 86 | language follow Java-/C-style function use syntax. For example: 87 | 88 | f(4,5) is AppExp "f" [IntExp 4, IntExp 5] 89 | 90 | f(g(3),5) is AppExp "f" [AppExp "g" [IntExp 3], IntExp 5] 91 | 92 | The grammar is: 93 | 94 | ::= 95 | | '(' ')' 96 | | '(' (',' )* ')' 97 | 98 | That is, an is either: 99 | 100 | (a) an integer 101 | (b) an identifier (word without spaces) followed by "()"; or 102 | (c) an identifier followed by '(', then an , then zero or more commas and s, then a ')' 103 | 104 | Here is the datatype for expressions in this language: -} 105 | 106 | data Expr 107 | = IntExp Int 108 | | AppExp String [Expr] 109 | deriving Show 110 | 111 | {- The following function prints out 'Expr's in the Java-/C-style 112 | syntax: -} 113 | 114 | printExpr :: Expr -> String 115 | printExpr (IntExp i) = show i 116 | printExpr (AppExp funNm args) = 117 | funNm ++ "(" ++ intercalate "," (map printExpr args) ++ ")" 118 | 119 | 120 | {- Your task is to write a parser for 'Expr's. This will similar to 121 | the general structure of the JSON parser in the notes. Have a 122 | section of the parser for each constructor ('IntExp' and 123 | 'AppExp'), and use the grammar above as a guide. Use the 124 | 'number' parser from the notes to parse numbers. The 125 | 'parseIdentifier' parser defined below will be useful for doing 126 | the function names. -} 127 | 128 | parseExpr :: Parser Expr 129 | parseExpr = 130 | do n <- number 131 | return (IntExp n) 132 | `orElse` 133 | do funNm <- parseIdentifier 134 | isChar '(' 135 | args <- sepBy (isChar ',') parseExpr 136 | isChar ')' 137 | return (AppExp funNm args) 138 | 139 | 140 | parseIdentifier :: Parser String 141 | parseIdentifier = 142 | do c <- parseIdentifierChar 143 | cs <- zeroOrMore parseIdentifierChar 144 | return (c:cs) 145 | where 146 | parseIdentifierChar = 147 | do c <- char 148 | if isAlphaNum c then return c else failParse 149 | -------------------------------------------------------------------------------- /lecture-notes/Week09Live.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 3 | module Week09Live where 4 | 5 | import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, takeMVar) 6 | import Prelude hiding (mapM) 7 | import Data.Traversable (for) 8 | import Network.HTTP ( simpleHTTP 9 | , getRequest 10 | , getResponseBody 11 | ) 12 | import Week08 (Parser, runParser, JSON (..), parseJSON) 13 | 14 | 15 | {- WEEK 09 : DATA DEPENDENCIES and APPLICATIVE FUNCTORS -} 16 | 17 | {- Part 9.1 : Sequences of Actions -} 18 | 19 | mapM :: Monad m => (a -> m b) -> [a] -> m [b] 20 | mapM f [] = return [] 21 | mapM f (x:xs) = do 22 | y <- f x 23 | ys <- mapM f xs 24 | return (y : ys) 25 | 26 | -- (>>=) : Monad m => m a -> (a -> m b) -> m b 27 | 28 | ap :: Monad m => m (a -> b) -> m a -> m b 29 | ap mf ma = do 30 | f <- mf 31 | a <- ma 32 | return (f a) 33 | 34 | -- mapM_v2 :: forall m a b. Monad m => (a -> m b) -> [a] -> m [b] 35 | -- mapM_v2 f [] = return [] 36 | -- mapM_v2 f (x : xs) 37 | -- = (return (:) :: m (b -> [b] -> [b])) 38 | -- `ap` (f x :: m b) 39 | -- `ap` (mapM f xs :: m [b]) 40 | -- (:) (f x) (map f x) 41 | 42 | {- 43 | class Functor m => Applicative m where 44 | pure :: a -> m a 45 | (<*>) :: m (a -> b) -> m a -> m b 46 | -} 47 | 48 | mapA :: Applicative f => (a -> f b) -> [a] -> f [b] 49 | mapA f [] = pure [] 50 | mapA f (x : xs) = (:) <$> f x <*> mapA f xs 51 | 52 | 53 | {- Part 9.2 : Applicative -} 54 | 55 | -- Type class 56 | 57 | {- Part 9.3 : Data Dependencies and Parallelism -} 58 | 59 | -- Request/response 60 | type Request = String 61 | type Response = String 62 | 63 | -- Fetch 64 | data Fetch a 65 | = Done a 66 | | Fetch [Request] ([Response] -> Fetch a) 67 | 68 | instance Show a => Show (Fetch a) where 69 | show (Done a) = "(Done " ++ show a ++ ")" 70 | show (Fetch reqs _) = "(Fetch " ++ show reqs ++ " )" 71 | 72 | makeRequest :: Request -> Fetch Response 73 | makeRequest url = Fetch [url] (\[resp] -> Done resp) 74 | 75 | getField :: JSON -> String -> JSON 76 | getField (Object fields) nm = 77 | case lookup nm fields of 78 | Nothing -> Null 79 | Just v -> v 80 | getField _ _ = 81 | Null 82 | 83 | getString :: JSON -> String 84 | getString (String s) = s 85 | getString _ = "ERROR" 86 | 87 | makeJSONRequest :: Request -> Fetch String 88 | makeJSONRequest url = 89 | do resp <- makeRequest url 90 | case runParser parseJSON resp of 91 | Nothing -> return "ERROR" 92 | Just (_, json) -> return (getString (getField json "title")) 93 | 94 | 95 | -- Monad 96 | instance Monad Fetch where 97 | Done x >>= k = k x 98 | Fetch reqs c >>= k = Fetch reqs (\resps -> c resps >>= k) 99 | 100 | -- Applicative 101 | instance Applicative Fetch where 102 | pure = Done 103 | Done f <*> Done x = Done (f x) 104 | Done f <*> Fetch reqsr cr 105 | = Fetch reqsr (\ respr -> fmap f (cr respr)) 106 | Fetch reqsl cl <*> Done x 107 | = Fetch reqsl (\ respl -> fmap (\ f -> f x) (cl respl)) 108 | Fetch reqsl cl <*> Fetch reqsr cr 109 | = Fetch (reqsl ++ reqsr) (\ resplr -> 110 | let (respl, respr) = splitAt (length reqsl) resplr in 111 | let left = cl respl in 112 | let right = cr respr in 113 | left <*> right) 114 | 115 | instance Functor Fetch where 116 | fmap f mx = pure f <*> mx 117 | 118 | -- runFetch :: Fetch a -> IO a 119 | 120 | {- PART 9.4 : Concurrency and Communication -} 121 | 122 | {- 123 | forkIO 124 | -} 125 | 126 | 127 | {- type MVar a 128 | 129 | newEmptyMVar :: IO (MVar a) 130 | 131 | putMVar :: MVar a -> a -> IO () 132 | 133 | takeMVar :: MVar a -> IO a 134 | -} 135 | 136 | -- Logger 137 | data LogMsg 138 | = Message String 139 | | Stop 140 | deriving Show 141 | 142 | loggerMain :: MVar LogMsg -> Int -> IO () 143 | loggerMain inbox count = 144 | do msg <- takeMVar inbox 145 | case msg of 146 | Message msg -> 147 | do putStrLn ("LOG(" ++ show count ++ "): " ++ msg) 148 | loggerMain inbox (count+1) 149 | Stop -> 150 | do putStrLn "LOG STOPPED" 151 | return () 152 | 153 | startLogger :: IO (MVar LogMsg) 154 | startLogger = 155 | do ch <- newEmptyMVar 156 | forkIO (loggerMain ch 0) 157 | return ch 158 | 159 | logMsg :: MVar LogMsg -> String -> IO () 160 | logMsg log msg = putMVar log (Message msg) 161 | 162 | logStop :: MVar LogMsg -> IO () 163 | logStop log = putMVar log Stop 164 | 165 | type Logger = MVar LogMsg 166 | 167 | -- doRequest 168 | doRequest :: Logger -> Request -> IO Response 169 | doRequest log url = 170 | do log `logMsg` ("Requesting " ++ url) 171 | httpResp <- simpleHTTP (getRequest url) 172 | body <- getResponseBody httpResp 173 | log `logMsg` ("Request " ++ url ++ " finished") 174 | return body 175 | 176 | -- http://jsonplaceholder.typicode.com/todos/12 177 | 178 | -- parMapM 179 | parMapM :: (a -> IO b) -> [a] -> IO [b] 180 | parMapM f xs = do 181 | mboxes <- mapM (\x -> do m <- newEmptyMVar 182 | forkIO (do y <- f x 183 | putMVar m y) 184 | return m) 185 | xs 186 | mapM takeMVar mboxes 187 | 188 | runFetch :: Logger -> Fetch a -> IO a 189 | runFetch log (Done a) = return a 190 | runFetch log (Fetch reqs k) = 191 | do resps <- parMapM (doRequest log) reqs 192 | runFetch log (k resps) 193 | 194 | getTodo :: Int -> Fetch String 195 | getTodo n = makeJSONRequest ("http://jsonplaceholder.typicode.com/todos/" ++ show n) 196 | 197 | getTodos1 :: Fetch (String, String, String) 198 | getTodos1 = 199 | do todo1 <- getTodo 234 200 | todo2 <- getTodo 123 201 | todo3 <- getTodo 12 202 | return (todo1, todo2, todo3) 203 | 204 | getTodos2 :: Fetch (String, String, String) 205 | getTodos2 = 206 | (,,) <$> getTodo 234 <*> getTodo 123 <*> getTodo 12 207 | 208 | runFetchWithLogger :: Fetch a -> IO a 209 | runFetchWithLogger job = 210 | do log <- startLogger 211 | result <- runFetch log job 212 | logStop log 213 | return result 214 | -------------------------------------------------------------------------------- /lecture-notes/Week09Live2023.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 3 | module Week09Live2023 where 4 | 5 | import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, takeMVar) 6 | --import Prelude hiding (mapM) 7 | import Data.Traversable (for) 8 | import Network.HTTP ( simpleHTTP 9 | , getRequest 10 | , getResponseBody 11 | ) 12 | import Week08 (Parser, runParser, JSON (..), parseJSON) 13 | 14 | {- WEEK 09 : DATA DEPENDENCIES and APPLICATIVE FUNCTORS -} 15 | 16 | 17 | {- PART 9.1 : Sequences of Actions -} 18 | 19 | -- mapM 20 | -- parsing with parens 21 | 22 | -- (>>=) :: M a -> (a -> M b) -> M b 23 | 24 | mapM' :: Monad m => (a -> m b) -> [a] -> m [b] 25 | mapM' f [] = return [] 26 | mapM' f (x:xs) = 27 | do y <- f x 28 | ys <- mapM' f xs 29 | return (y:ys) 30 | 31 | data Tree a = Leaf | Node (Tree a) a (Tree a) 32 | 33 | mapMTree :: Monad m => (a -> m b) -> Tree a -> m (Tree b) 34 | mapMTree f Leaf = return Leaf 35 | mapMTree f (Node l x r) = 36 | (return Node) `ap` mapMTree f l `ap` f x `ap` mapMTree f r 37 | -- Node (mapMTree f l) (f x) (mapMTree f r) 38 | -- do l' <- mapMTree f l 39 | -- x' <- f x 40 | -- r' <- mapMTree f r 41 | -- return (Node l' x' r') 42 | 43 | 44 | {- PART 9.2 : Applicative -} 45 | 46 | ap :: Monad m => m (a -> b) -> m a -> m b 47 | ap mf ma = do f <- mf 48 | a <- ma 49 | return (f a) 50 | 51 | {- class Applicative f where 52 | pure :: a -> f a 53 | (<*>) :: f (a -> b) -> f a -> f b 54 | vs (a -> f b) -> f a -> f b 55 | -} 56 | 57 | {- PART 9.3 : Data Dependencies and Parallelism -} 58 | 59 | -- Request/Reponse 60 | type Request = String 61 | type Response = String 62 | 63 | -- Fetch 64 | data Fetch a 65 | = Fetch [Request] ([Response] -> Fetch a) 66 | | Return a 67 | 68 | instance Show (Fetch a) where 69 | show (Return a) = "Return" 70 | show (Fetch reqs _) = "Fetch " ++ show reqs ++ " " 71 | 72 | instance Monad Fetch where 73 | -- return = Return 74 | 75 | Return a >>= k = k a 76 | Fetch reqs f >>= k = Fetch reqs (\resps -> f resps >>= k) 77 | 78 | instance Applicative Fetch where 79 | pure = Return 80 | 81 | (<*>) :: Fetch (a -> b) -> Fetch a -> Fetch b 82 | -- Fetch a -> (a -> Fetch b) -> Fetch b 83 | Return f <*> Return a = Return (f a) 84 | Fetch reqs k <*> Return a = 85 | Fetch reqs (\resps -> k resps <*> Return a) 86 | Return f <*> Fetch reqs k = 87 | Fetch reqs (\resps -> Return f <*> k resps) 88 | Fetch reqs1 k1 <*> Fetch reqs2 k2 = 89 | Fetch (reqs1 ++ reqs2) 90 | (\resps -> 91 | k1 (take (length reqs1) resps) <*> 92 | k2 (drop (length reqs1) resps)) 93 | 94 | makeRequest :: String -> Fetch String 95 | makeRequest req = Fetch [req] (\[resp] -> Return resp) 96 | 97 | instance Functor Fetch where 98 | fmap f job = pure f <*> job 99 | 100 | {- PART 9.4 : Concurrency and Communication -} 101 | 102 | 103 | -- forkIO 104 | 105 | 106 | {- type MVar a 107 | 108 | newEmptyMVar :: IO (MVar a) 109 | 110 | putMVar :: MVar a -> a -> IO () 111 | 112 | takeMVar :: MVar a -> IO a 113 | -} 114 | 115 | backgroundJob :: MVar String -> IO () 116 | backgroundJob mailbox = do 117 | str <- takeMVar mailbox 118 | putStrLn ("BACKGROUND THREAD: " ++ str) 119 | 120 | data LogMsg 121 | = Log String 122 | | Stop 123 | deriving Show 124 | 125 | logService :: MVar LogMsg -> Int -> IO () 126 | logService mailbox logCount = 127 | do msg <- takeMVar mailbox 128 | case msg of 129 | Log logMsg -> 130 | do putStrLn ("LOG(" ++ show logCount ++ "): " ++ logMsg) 131 | logService mailbox (logCount + 1) 132 | Stop -> 133 | do putStrLn "LOGGING STOPPED" 134 | 135 | type Logger = MVar LogMsg 136 | 137 | startLogger :: IO Logger 138 | startLogger = do 139 | mailbox <- newEmptyMVar 140 | forkIO (logService mailbox 0) 141 | return mailbox 142 | 143 | logMessage :: Logger -> String -> IO () 144 | logMessage logger msg = 145 | putMVar logger (Log msg) 146 | 147 | logStop :: Logger -> () -> IO () 148 | logStop logger () = 149 | putMVar logger Stop 150 | 151 | 152 | 153 | -- http://jsonplaceholder.typicode.com/todos/12 154 | 155 | 156 | 157 | -- Executing Requests concurrently 158 | 159 | doRequest :: Logger -> Request -> IO Response 160 | doRequest log url = 161 | do log `logMessage` ("Requesting " ++ url) 162 | httpResp <- simpleHTTP (getRequest url) 163 | body <- getResponseBody httpResp 164 | log `logMessage` ("Request " ++ url ++ " finished") 165 | return body 166 | 167 | parMapM :: (a -> IO b) -> [a] -> IO [b] 168 | parMapM f xs = 169 | do mailboxes <- 170 | mapM (\a -> do m <- newEmptyMVar 171 | forkIO (do b <- f a 172 | putMVar m b) 173 | return m) 174 | xs 175 | mapM takeMVar mailboxes 176 | 177 | runFetch :: Logger -> Fetch a -> IO a 178 | runFetch log (Return a) = return a 179 | runFetch log (Fetch reqs k) = 180 | do resps <- parMapM (doRequest log) reqs 181 | runFetch log (k resps) 182 | 183 | getField :: JSON -> String -> JSON 184 | getField (Object fields) nm = 185 | case lookup nm fields of 186 | Nothing -> Null 187 | Just x -> x 188 | getField _ nm = Null 189 | 190 | getString :: JSON -> String 191 | getString (String s) = s 192 | getString _ = "ERROR" 193 | 194 | getTodo :: Int -> Fetch String 195 | getTodo id = 196 | do json <- makeRequest ("http://jsonplaceholder.typicode.com/todos/" ++ show id) 197 | case runParser parseJSON json of 198 | Nothing -> return "ERROR" 199 | Just (_, json) -> return (getString (getField json "title")) 200 | 201 | getTodos1 :: Fetch (String, String, String) 202 | getTodos1 = 203 | do todo1 <- getTodo 234 204 | todo2 <- getTodo 123 205 | todo3 <- getTodo 12 206 | return (todo1, todo2, todo3) 207 | 208 | getTodos2 :: Fetch (String, String, String) 209 | getTodos2 = 210 | pure (\todo1 todo2 todo3 -> (todo1, todo2, todo3)) 211 | <*> getTodo 234 212 | <*> getTodo 123 213 | <*> getTodo 12 214 | 215 | runFetchWithLogger :: Fetch a -> IO a 216 | runFetchWithLogger job = 217 | do log <- startLogger 218 | result <- runFetch log job 219 | log `logStop` () 220 | return result 221 | -------------------------------------------------------------------------------- /lecture-notes/Week10Live.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------ 2 | -- Advanced Functional Programming 3 | 4 | -- This is a taster for CS410 next year. 5 | -- However I thought it would be too unfair to jump straight to Agda 6 | -- and be like "look at all the amazing things we can do in this 7 | -- totally different language". 8 | 9 | -- So instead, let's do something advanced but in a somewhat painful 10 | -- manner in Haskell! 11 | 12 | ------------------------------------------------------------------------ 13 | -- Some spicy language extensions (there's tons more!) 14 | 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Week10Live where 19 | 20 | import Data.Kind (Type) 21 | 22 | ------------------------------------------------------------------------ 23 | -- Deriving magic 24 | 25 | -- A random data definition 26 | -- Doesn't (o () o) look like a bird facing you? 27 | data Bird o = MkBird o () o 28 | deriving (Show, Functor) 29 | 30 | -- The purpose of this lecture is to look at the `deriving Functor` 31 | -- part and figure out how we could build our own if we needed to. 32 | 33 | bird15 :: Bird Int 34 | bird15 = (1+) <$> MkBird 0 () 4 35 | 36 | ------------------------------------------------------------------------ 37 | -- Building blocks: Cst, Prd, Idt 38 | 39 | newtype Cst a f i = MkCst { runCst :: a } deriving Show 40 | instance Functor (Cst a f) where 41 | fmap f (MkCst v) = MkCst v 42 | 43 | newtype Prd k l f i = MkPrd { runPrd :: (k f i, l f i) } deriving Show 44 | instance (Functor (k f), Functor (l f)) => Functor (Prd k l f) where 45 | fmap f (MkPrd (v, w)) = MkPrd (fmap f v, fmap f w) 46 | 47 | newtype Idt f i = MkIdt { runIdt :: i } deriving Show 48 | instance Functor (Idt f) where 49 | fmap f (MkIdt v) = MkIdt (f v) 50 | 51 | ------------------------------------------------------------------------ 52 | -- Conversion 53 | 54 | type CodeBird = Prd Idt (Prd (Cst ()) Idt) () -- data Bird o = MkBird o () o 55 | 56 | 57 | birdDown :: Bird o -> CodeBird o 58 | birdDown (MkBird v () w) = MkPrd (MkIdt v, MkPrd (MkCst (), MkIdt w)) 59 | 60 | birdUp :: CodeBird o -> Bird o 61 | birdUp (MkPrd (MkIdt v, MkPrd (MkCst (), MkIdt w))) = MkBird v () w 62 | 63 | identity :: Bird o -> Bird o 64 | identity = birdUp . birdDown 65 | 66 | birdMap :: (a -> b) -> Bird a -> Bird b 67 | birdMap f = birdUp . fmap f . birdDown 68 | 69 | 70 | ------------------------------------------------------------------------ 71 | -- Encodable 72 | 73 | class Encodable t where 74 | type Code t :: Type -> Type 75 | encode :: t a -> Code t a 76 | decode :: Code t a -> t a 77 | 78 | instance Encodable Bird where 79 | type Code Bird = CodeBird 80 | encode = birdDown 81 | decode = birdUp 82 | 83 | gfmap :: (Encodable t, Functor (Code t)) 84 | => (a -> b) -> t a -> t b 85 | gfmap f = decode . fmap f . encode 86 | 87 | ------------------------------------------------------------------------ 88 | -- List 89 | 90 | -- data Bird o = MkBird o () o 91 | data List a = Nil | Cons a (List a) 92 | 93 | -- newtype Prd k l i = MkPrd { runPrd :: (k i, l i) } deriving Show 94 | newtype Sum k l f i = MkSum { runSum :: Either (k f i) (l f i) } 95 | 96 | instance (Functor (k f), Functor (l f)) => Functor (Sum k l f) where 97 | fmap f (MkSum (Left v)) = MkSum (Left (fmap f v)) 98 | fmap f (MkSum (Right w)) = MkSum (Right (fmap f w)) 99 | 100 | instance Encodable Maybe where 101 | type Code Maybe = Sum (Cst ()) Idt () 102 | encode Nothing = MkSum (Left (MkCst ())) 103 | encode (Just x) = MkSum (Right (MkIdt x)) 104 | 105 | decode (MkSum (Left (MkCst ()))) = Nothing 106 | decode (MkSum (Right (MkIdt x))) = Just x 107 | 108 | data Fix f a where 109 | MkFix :: f (Fix f) a -> Fix f a 110 | 111 | instance Functor (f (Fix f)) => Functor (Fix f) where 112 | fmap f (MkFix v) = MkFix (fmap f v) 113 | 114 | newtype Rec f a = MkRec { runRec :: f a } 115 | instance Functor f => Functor (Rec f) where 116 | fmap f (MkRec v) = MkRec (fmap f v) 117 | 118 | 119 | type Void = Fix Rec () 120 | absurd :: Void -> a 121 | absurd (MkFix (MkRec v)) = absurd v 122 | 123 | instance Encodable [] where 124 | type Code [] = Fix (Sum (Cst ()) (Prd Idt Rec)) 125 | encode [] = MkFix (MkSum (Left (MkCst ()))) 126 | encode (x : xs) = MkFix (MkSum (Right (MkPrd (MkIdt x, MkRec (encode xs))))) 127 | decode (MkFix (MkSum (Left (MkCst ())))) = [] 128 | decode (MkFix (MkSum (Right (MkPrd (MkIdt x, MkRec xs))))) = x : decode xs 129 | 130 | ------------------------------------------------------------------------ 131 | -- Rose Trees 132 | 133 | data Rose a = MkRose a [Rose a] deriving Show 134 | 135 | newtype Cmp k l f i = MkCmp { runCmp :: k f (l f i) } 136 | instance (Functor (k f), Functor (l f)) => Functor (Cmp k l f) where 137 | fmap f (MkCmp t) = MkCmp (fmap (fmap f) t) 138 | 139 | newtype KCmp t l f i = MkKCmp { runKCmp :: t (l f i) } 140 | instance (Functor t, Functor (l f)) => Functor (KCmp t l f) where 141 | fmap f (MkKCmp t) = MkKCmp (fmap (fmap f) t) 142 | 143 | instance Encodable Rose where 144 | type Code Rose = Fix (Prd Idt (KCmp [] Rec)) 145 | encode (MkRose x xs) = MkFix (MkPrd (MkIdt x, MkKCmp (MkRec . encode <$> xs))) 146 | decode (MkFix (MkPrd (MkIdt x, MkKCmp xs))) = MkRose x (decode . runRec <$> xs) 147 | 148 | rose :: Rose String 149 | rose = gfmap show (MkRose 1 [MkRose 2 [], MkRose 3 [], MkRose 4 [MkRose 5 []]]) 150 | -------------------------------------------------------------------------------- /lecture-notes/Week10Live2.hs: -------------------------------------------------------------------------------- 1 | module Week10Live2 where 2 | 3 | import Test.QuickCheck 4 | 5 | {- QuickCheck is a library for Property Based Testing 6 | 7 | Instead of individual tests: 8 | - “On input X, expect to get output Y” 9 | 10 | You define properties, usually of the form: 11 | - for all x, y, z. P(x,y,z) 12 | where P is something executable. 13 | 14 | QuickCheck then generates random values for 'x', 'y', and 'z' and 15 | tries to find a counterexample: some values that make P(x,y,z) 16 | false. 17 | 18 | Logically, we are trying to prove a universal statement: 19 | 20 | for all x, y, z. P(x,y,z) 21 | 22 | QuickCheck operates by trying to prove the negation of this 23 | statement, which is an existential statement: 24 | 25 | exists x, y, z. not P(x,y,z) 26 | 27 | There are two possible outcomes: 28 | 29 | 1. QuickCheck finds an 'x', 'y', 'z' that makes P(x,y,z) false, 30 | which is a proof that the original statement is false. 31 | 32 | 2. QuickCheck fails to find an 'x', 'y', 'z' that make P(x,y,z) 33 | false, which could mean either: 34 | (a) the original statement is true (cool!) 35 | (b) the original statement is not true, but we just 36 | haven't found a counterexample (less cool) 37 | 38 | These two outcomes are true of any kind of testing (except in 39 | special cases where a finite number of tests suffices). In general, 40 | the slogan is "Testing can only prove the presence of errors, not 41 | their absence." (something like this was said by Edsger Dijkstra). 42 | 43 | Nevertheless, testing is extremely useful and nigh essential for 44 | making reliable software. Property-Based Testing as in QuickCheck 45 | is a useful tool in addition to normal testing because: 46 | 47 | 1. It encourages you to think about and write down general 48 | /properties/ instead of individual test cases. These 49 | properties can often be useful for other developers trying to 50 | understand your code. 51 | 52 | 2. Often, there are well-known properties that apply in many 53 | situations. Trying to write down complex properties is often a 54 | sign that your code is too complex and contains too many 55 | special cases. 56 | 57 | 3. The /randomised/ aspect of QuickCheck is good at generating 58 | examples that you may not have thought of, so the overall test 59 | coverage can be improved. (CAUTION: it might also be the case 60 | that the random generator is biased and just fails to generate 61 | some potential counterexamples) 62 | 63 | QuickCheck is still largely a "blackbox" testing tool, in that it 64 | doesn't look at the property to try to generate specific 65 | counterexamples, it just obliviously generates them and runs the 66 | test. Some tools (e.g. fuzzers) do a more directed search for 67 | counterexamples. -} 68 | 69 | 70 | {- Example : MONOIDS -} 71 | 72 | {- The monoid laws: 73 | 74 | 1. for all x. mempty <> x == x 75 | 2. for all x. x <> mempty == x 76 | 3. for all x y z. (x <> y) <> z == x <> (y <> z) 77 | 78 | -} 79 | 80 | monoid_left_unit_law :: (Eq a, Monoid a) => a -> Bool 81 | monoid_left_unit_law x = mempty <> x == x 82 | 83 | monoid_right_unit_law :: (Eq a, Monoid a) => a -> Bool 84 | monoid_right_unit_law x = x <> mempty == x 85 | 86 | monoid_assoc_law :: (Eq a, Semigroup a) => a -> a -> a -> Bool 87 | monoid_assoc_law x y z = (x <> y) <> z == x <> (y <> z) 88 | 89 | monoid_laws :: (Show a, Eq a, Monoid a) => Gen a -> Property 90 | monoid_laws gen = 91 | conjoin [ forAll gen $ \x -> monoid_left_unit_law x 92 | , forAll gen $ \x -> monoid_right_unit_law x 93 | , forAll gen $ \x -> 94 | forAll gen $ \y -> 95 | forAll gen $ \z -> 96 | monoid_assoc_law x y z 97 | ] 98 | 99 | -- Good examples: 100 | 101 | newtype And = MkAnd Bool deriving (Show, Eq) 102 | instance Semigroup And where 103 | MkAnd x <> MkAnd y = MkAnd (x && y) 104 | instance Monoid And where 105 | mempty = MkAnd True 106 | instance Arbitrary And where 107 | arbitrary = MkAnd <$> arbitrary 108 | -- arbitrary :: Gen Bool 109 | 110 | 111 | -- Bad examples: 112 | 113 | instance Semigroup Double where 114 | x <> y = x + y 115 | 116 | -- Rock, Paper, Scissors 117 | data RPS = Rock | Paper | Scissors deriving (Eq, Show) 118 | 119 | instance Arbitrary RPS where 120 | arbitrary = oneof [ pure Rock, pure Paper, pure Scissors ] 121 | 122 | instance Semigroup RPS where 123 | Rock <> Rock = Rock 124 | Rock <> Scissors = Rock 125 | Rock <> Paper = Paper 126 | Paper <> Paper = Paper 127 | Paper <> Rock = Paper 128 | Paper <> Scissors = Scissors 129 | Scissors <> Scissors = Scissors 130 | Scissors <> Paper = Paper 131 | Scissors <> Rock = Rock 132 | 133 | 134 | 135 | {- Example : GENERATORS -} 136 | 137 | data JSON 138 | = Number Int 139 | | Boolean Bool 140 | | String String 141 | | Null 142 | | Array [JSON] 143 | | Object [(String,JSON)] 144 | deriving (Show, Eq) 145 | 146 | -- Example from: https://typeable.io/blog/2021-08-09-pbt.html 147 | instance Arbitrary JSON where 148 | arbitrary = sized arbitrary' 149 | where 150 | arbitrary' 0 = pure $ Array [] 151 | arbitrary' n = 152 | oneof [ Object <$> resize (n `div` 2) arbitrary 153 | , Array <$> resize (n `div` 2) arbitrary 154 | , String <$> arbitrary 155 | , Number <$> arbitrary 156 | , Boolean <$> arbitrary 157 | , pure Null 158 | ] 159 | --------------------------------------------------------------------------------