├── .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 |
--------------------------------------------------------------------------------