├── .gitignore ├── lecture-notes ├── Week07IO.hs ├── Week03LiveFri.hs ├── Week07Problems.hs ├── Week06Live.hs ├── Week02Live.hs ├── Week08Problems.hs ├── Week01Live2.hs ├── Week09Live.hs ├── Week08Solutions.hs ├── Week01Problems.hs ├── Week03Live.hs ├── Week04Problems.hs ├── Week06Problems.hs ├── Week07Solutions.hs ├── Week01Live.hs ├── Week02Problems.hs ├── Week03Problems.hs └── Week06Solutions.hs ├── LICENSE ├── CS316-FP.cabal ├── archives └── 2024 │ ├── lecture-notes │ ├── Week01Lecture2.hs │ ├── Week07Problems.hs │ ├── Week08Problems.hs │ ├── Week02Live.hs │ ├── Week08Solutions.hs │ ├── Week07Intro.hs │ ├── Week03Live.hs │ ├── Week10Live.hs │ ├── Week01Intro.hs │ ├── Week01Problems.hs │ ├── Week07Live.hs │ ├── Week10Live2.hs │ ├── Week04Problems.hs │ ├── Week06Problems.hs │ ├── Week09Live.hs │ ├── Week07Solutions.hs │ ├── Week06Live.hs │ ├── Week09Live2023.hs │ ├── Week05Live.hs │ ├── Week02Problems.hs │ ├── Week04Live.hs │ └── Week03Problems.hs │ └── README.md └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | *~ 3 | -------------------------------------------------------------------------------- /lecture-notes/Week07IO.hs: -------------------------------------------------------------------------------- 1 | module Week07IO where 2 | 3 | 4 | filterM :: Monad m => (a -> m Bool) -> [a] -> m [a] 5 | filterM p [] = return [] 6 | filterM p (x:xs) = 7 | do b <- p x 8 | xs' <- filterM p xs 9 | return (if b then x:xs' else xs') 10 | 11 | boom :: Bool 12 | boom = boom 13 | 14 | withLogging :: Show a => (a -> Bool) -> (a -> IO Bool) 15 | withLogging p a = do 16 | _ <- print a 17 | return (p a) 18 | 19 | 20 | treeSort :: Monad m 21 | => (a -> a -> m Bool) 22 | -> [a] 23 | -> m [a] 24 | treeSort cmp [] = return [] 25 | treeSort cmp (v : vs) = do 26 | smoll <- filterM (\ w -> cmp w v) vs 27 | biggg <- filterM (\ w -> do { b <- cmp w v; return (not b) }) vs 28 | leftt <- treeSort cmp smoll 29 | right <- treeSort cmp biggg 30 | return (leftt ++ [v] ++ right) 31 | 32 | logg :: (Show a, Show b) 33 | => (a -> b -> c) 34 | -> (a -> b -> IO c) 35 | logg cmp a b = do 36 | let str = unwords ["Checking", show a, "against", show b] 37 | putStrLn str 38 | return (cmp a b) 39 | 40 | logging 41 | :: Show a 42 | => (a -> a -> Bool) 43 | -> [a] 44 | -> IO () 45 | logging cmp xs = do 46 | _ <- treeSort (logg cmp) xs 47 | return () 48 | -------------------------------------------------------------------------------- /lecture-notes/Week03LiveFri.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 | 10 | 11 | id :: forall a. a -> a 12 | id x = x 13 | 14 | ($) :: forall a b. (a -> b) -> a -> b 15 | ($) = id 16 | 17 | -- Composition 18 | (.) :: (b -> c) -> (a -> b) -> (a -> c) 19 | (.) f g = \x -> f (g x) 20 | 21 | -- Pipe (|>) 22 | (|>) :: forall a b. a -> (a -> b) -> b 23 | (a |> f) = f a 24 | 25 | -- flip 26 | flip :: forall a b c. (a -> b -> c) -> (b -> (a -> c)) 27 | flip f b a = f a b 28 | 29 | 30 | -- partialApply 31 | partialApply :: ((a, b) -> c) -> a -> (b -> c) 32 | partialApply f x = \y -> f(x,y) 33 | 34 | 35 | 36 | ------------------------------------------------------------------------------ 37 | 38 | -- map 39 | map :: forall a b. (a -> b) -> [a] -> [b] 40 | map f [] = [] 41 | map f (x:xs) = (f x) : map f xs 42 | 43 | -- filter 44 | filter :: (a -> Bool) -- test p 45 | -> [a] -- values xs 46 | -> [a] -- only the x in xs that satisfy p 47 | filter p [] = [] 48 | filter p (x:xs) | p x = x : filter p xs 49 | | otherwise = filter p xs 50 | 51 | 52 | 53 | 54 | 55 | 56 | -- dupAll 57 | dupAll :: [a] -> [a] 58 | dupAll xs = xs |> map (\x -> [x,x]) |> concat 59 | 60 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /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. -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /archives/2024/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/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 | -------------------------------------------------------------------------------- /archives/2024/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/Week06Live.hs: -------------------------------------------------------------------------------- 1 | module Week06Live where 2 | 3 | -- WEEK 06 : Simulating Side Effects 4 | 5 | 6 | -- f :: Int -> Int 7 | -- f 0 (today) == f 0 (tomorrow) 8 | 9 | -- f :: Int -> Effect Int 10 | 11 | 12 | -- int f(int i) 13 | -- 14 | -- - read the clock in the computer 15 | -- - ask the user for input 16 | -- - post cat picture to your favourite social network (Myspace) 17 | -- - Launch the nuclear weapons 18 | 19 | -- Week 06 : Simulating Side Effects 20 | -- Week 07 : Common interface 21 | -- Week 08 : Real I/O and side effects with the common interface 22 | 23 | 24 | 25 | -- Simulate exceptions 26 | data Tree a = Leaf a | Node (Tree a) (Tree a) 27 | deriving (Show, Functor) 28 | 29 | 30 | 31 | find :: Eq a => a -> Tree (a,b) -> Maybe b 32 | find k (Leaf (key,v)) | k == key = Just v 33 | | otherwise = Nothing 34 | find k (Node l r) = find k l `orElse` find k r 35 | 36 | find2 37 | :: (Eq k1, Eq k2) 38 | => k1 -> k2 39 | -> (Tree (k1,Tree (k2,v))) 40 | -> Maybe v 41 | find2 k1 k2 tree = find k1 tree `andThen` (\v -> find k2 v) 42 | 43 | -- a -> Maybe b , b -> Maybe c 44 | -- Maybe b -> (b -> Maybe c) -> Maybe c 45 | 46 | andThen :: Maybe a -> (a -> Maybe b) -> Maybe b 47 | andThen Nothing _ = Nothing 48 | andThen (Just v) f = f v 49 | 50 | orElse :: Maybe a -> Maybe a -> Maybe a 51 | orElse (Just v) alt = Just v 52 | orElse Nothing alt = alt 53 | 54 | 55 | 56 | -- Printing 57 | type Print a = (a, [String]) 58 | 59 | exampleTree :: Tree (Int, String) 60 | exampleTree 61 | = Node (Node (Leaf (0, "Zero")) (Leaf (2, "Three"))) 62 | (Leaf (4, "Four")) 63 | 64 | andTHEN 65 | :: Print (Maybe a) 66 | -> ( a -> Print (Maybe b)) 67 | -> Print (Maybe b) 68 | andTHEN (Nothing, msg) f = (Nothing, msg) 69 | andTHEN (Just v, msg1) f = case f v of 70 | (mb, msg2) -> (mb, msg1 ++ msg2) 71 | 72 | orELSE 73 | :: Print (Maybe a) 74 | -> Print (Maybe a) 75 | -> Print (Maybe a) 76 | orELSE (Just v, msg) _ = (Just v, msg) 77 | orELSE (Nothing, msg1) (ma, msg2) = (ma, msg1 ++ msg2) 78 | 79 | say :: String -> Print (Maybe ()) 80 | say str = (Just (), [str]) 81 | 82 | succeed :: a -> Print (Maybe a) 83 | succeed v = (Just v, []) 84 | 85 | failure :: Print (Maybe a) 86 | failure = (Nothing, []) 87 | 88 | findPrint :: Eq a => a -> Tree (a,b) -> Print (Maybe b) 89 | findPrint k (Leaf (key, v)) 90 | | k == key = 91 | say "Found it!" `andTHEN` \ _ -> 92 | succeed v 93 | | otherwise = 94 | say "Going back up :(" `andTHEN` \ _ -> 95 | failure 96 | findPrint k (Node l r) = 97 | findPrint k l `orELSE` 98 | findPrint k r 99 | 100 | find2Print 101 | :: (Eq k1, Eq k2) 102 | => k1 103 | -> k2 104 | -> (Tree (k1, Tree (k2,v))) 105 | -> Print (Maybe v) 106 | find2Print k1 k2 treeTree = 107 | findPrint k1 treeTree `andTHEN` \ tree -> 108 | findPrint k2 tree 109 | 110 | exampleTreeTree :: Tree (Int, Tree (Int, String)) 111 | exampleTreeTree = 112 | Node (Leaf (2, exampleTree)) 113 | (Leaf (5, fmap (fmap reverse) exampleTree)) 114 | 115 | 116 | -- I/O Processes 117 | -------------------------------------------------------------------------------- /lecture-notes/Week02Live.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | module Week02Live where 3 | 4 | import Data.Maybe 5 | import Test.QuickCheck 6 | 7 | ------------------------------------------------------------------------ 8 | -- Motivating example 9 | 10 | -- Making change: you have a till and have to give some money back to 11 | -- a customer. First: let's model the domain of discourse! 12 | -- 13 | -- DEFINE Coin 14 | -- DEFINE Till 15 | -- DEFINE Amount 16 | -- DEFINE Change 17 | type Coin = Int 18 | type Till = [Coin] 19 | type Amount = Int 20 | type Change = [Coin] 21 | 22 | -- DISCUSS how Till, Change, Coin, Amount relate 23 | -- (e.g. define a function turning X into Y) 24 | 25 | tillTotal :: Till -> Amount 26 | tillTotal = sum 27 | {- 28 | tillTotal [] = 0 29 | tillTotal (c : cs) = c + tillTotal cs 30 | -} 31 | 32 | changeTotal :: Change -> Amount 33 | changeTotal = sum 34 | 35 | -- PONDER makeChange, a function that takes: 36 | -- a till 37 | -- an amount 38 | -- and returns change matching the amount 39 | 40 | -- WRITE some tests 41 | 42 | -- 1. Unit tests 43 | -- Till with exactly the right coin 44 | -- Till with [1..10] and amount of 55 45 | 46 | noCoin :: Bool 47 | noCoin = makeChange [1..10] 0 [] == Just [] 48 | 49 | rightCoin :: Bool 50 | rightCoin = (makeChange [5] 5 []) == Just [5] 51 | 52 | wholeTill :: Bool 53 | wholeTill = (makeChange [1..15] 55 []) == Just [1..10] 54 | 55 | -- 2. Property testing 56 | -- What property do we expect the outcome to verify? 57 | 58 | prop_makeChange1 :: Till -> Amount -> Property 59 | prop_makeChange1 till amount 60 | = let res = makeChange (map abs till) (abs amount) [] in 61 | isJust res ==> changeTotal (fromMaybe [] res) == abs amount 62 | 63 | {- 64 | prop_makeChange2 :: Till -> Amount -> Bool 65 | prop_makeChange2 till amount = 66 | tillTotal till >= changeTotal (makeChange till amount []) 67 | -} 68 | -- DEFINE makeChange 69 | 70 | makeChange :: Till -> Amount -> Change -> Maybe Change 71 | makeChange _ 0 acc = Just (reverse acc) 72 | makeChange (coin:till) n acc 73 | | n >= coin = makeChange till (n-coin) (coin:acc) 74 | | otherwise = makeChange till n acc 75 | makeChange [] n acc = Nothing 76 | 77 | 78 | -- TEST makeChange 79 | -- quickCheck, verboseCheck 80 | 81 | 82 | -- FIX (?) makeChange 83 | 84 | 85 | -- TEST new version 86 | -- TEST with precondition (==>) 87 | -- TEST with better inputs 88 | 89 | 90 | -- REFACTOR (?) makeChange 91 | 92 | 93 | 94 | ------------------------------------------------------------------------------ 95 | -- The Domain Specific Language of Failure 96 | 97 | -- Instead of doing case analysis, using Maybe, Nothing, Just, let's try 98 | -- to abstract a little bit away from that. 99 | 100 | -- DEFINE OOPS, the type of potentially failing computations 101 | -- DEFINE successOOPS 102 | -- DEFINE failureOOPS 103 | -- DEFINE orElseOOPS 104 | 105 | 106 | -- REFACTOR makeChange as makeChangeOOPS 107 | 108 | 109 | 110 | -- DISCUSS the impact of greed on computing change 111 | 112 | -- DEFINE BRRR, the type of computations exploring ALL possibilities 113 | -- DEFINE successBRRR 114 | -- DEFINE failureBRR 115 | -- DEFINE orElseBRR 116 | 117 | -- Search & replace over makeChangeOOPS to build makeChangeBRRR 118 | 119 | 120 | ------------------------------------------------------------------------------ 121 | -- Search tree vs. Search strategy 122 | 123 | -- In Haskell we can reify control flow; use: 124 | -- DEFINE Success instead of success(OOPS/BRRR) 125 | -- DEFINE Failure instead of failure(OOPS/BRRR) 126 | -- DEFINE OrElse instead of orElse(OOPS/BRRR) 127 | 128 | 129 | 130 | -- BUILD makeChange 131 | 132 | 133 | -- DEFINE greedy 134 | -- DEFINE firstChoice 135 | -- DEFINE allChoices 136 | -- DEFINE best (using an (a -> Int) measure) 137 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /archives/2024/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/Week01Live2.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | module Week01Lecture2 where 3 | 4 | import Data.List (intersperse) 5 | 6 | 7 | ------------------------------------------------------------------------------ 8 | -- A small Markup data structure 9 | -- Related work: This is the type of generic representation used in e.g. pandoc 10 | -- https://pandoc.org/ 11 | 12 | 13 | -- DEFINE data Markup 14 | -- text, bold, italic, concat 15 | data Annotation = Bold | Italic 16 | deriving (Show) 17 | 18 | data Markup 19 | = Text String 20 | | Ann Annotation Markup 21 | | Concat Markup Markup 22 | deriving (Show) 23 | 24 | smartConcat :: Markup -> Markup -> Markup 25 | smartConcat (Text s) (Text t) = Text (s ++ t) 26 | smartConcat m n = Concat m n 27 | 28 | -- DEFINE an example: hello world (with some random formatting) 29 | 30 | exampleMarkup :: Markup 31 | exampleMarkup 32 | = Concat (Text "Hello") 33 | $ Concat (Text " ") 34 | $ Ann Bold (Text "World") 35 | 36 | -- DISCUSS syntax vs. semantics based on example 37 | 38 | -- Markdown: Hello **World** 39 | -- HTML: Hello World 40 | 41 | 42 | ------------------------------------------------------------------------------ 43 | -- A small Markup language 44 | 45 | -- DISCUSS Domain Specific Languages 46 | -- Nouns: datatypes / ground values 47 | -- Verbs: functions 48 | 49 | 50 | -- DEFINE catMarkup 51 | catMarkup :: [Markup] -> Markup 52 | catMarkup [] = Text "" 53 | catMarkup [x] = x 54 | catMarkup (x:xs)= smartConcat x (catMarkup xs) 55 | 56 | test = [Text "Hello", Text "World"] 57 | 58 | 59 | -- DEFINE 60 | -- catMarkupSpaced [Text "hello", Text "world"] 61 | -- Concat (Text "hello") (Concat (Text " ") (Text "world")) 62 | 63 | catMarkupSpaced :: [Markup] -> Markup 64 | catMarkupSpaced [] = Text "" 65 | catMarkupSpaced [x] = x 66 | catMarkupSpaced (x:xs) 67 | = smartConcat x 68 | $ smartConcat (Text " ") 69 | $ catMarkupSpaced xs 70 | 71 | 72 | -- catMarkupSpaced [a,b,c] == catMarkup [a, Text " ", b, Text " ", c] 73 | catMarkupSpaced' :: [Markup] -> Markup 74 | catMarkupSpaced' mks = catMarkup (intersperse (Text " ") mks) 75 | 76 | -- REFACTOR as punctuate 77 | punctuate :: Markup -> [Markup] -> Markup 78 | punctuate sep mks = catMarkup (intersperse sep mks) 79 | 80 | 81 | -- DEFINE list :: [Markup] -> Markup 82 | -- DEFINE set :: [Markup] -> Markup 83 | 84 | -- [x,y,z] 85 | list :: [Markup] -> Markup 86 | list xs = catMarkup [Text "[", punctuate (Text ",") xs, Text "]"] 87 | 88 | list' :: [Markup] -> Markup 89 | list' = between (Text "[") (Text "]") . punctuate (Text ",") 90 | 91 | -- {x,y,z} 92 | set :: [Markup] -> Markup 93 | set xs = catMarkup [Text "{", punctuate (Text ",") xs, Text "}"] 94 | 95 | set' :: [Markup] -> Markup 96 | set' = between (Text "[") (Text "]") . punctuate (Text ",") 97 | 98 | -- REFACTOR list, set 99 | 100 | between :: Markup -> Markup -> (Markup -> Markup) 101 | between left right = \ middle -> catMarkup [left, middle, right] 102 | 103 | string :: Markup -> Markup 104 | string m = between (Text "\"") (Text "\"") m 105 | 106 | ------------------------------------------------------------------------------ 107 | -- A small Markup semantics 108 | 109 | -- DEFINE HTML 110 | 111 | data HTML 112 | = Simple String 113 | | Tag String [HTML] 114 | deriving (Show) 115 | 116 | type Domain = [HTML] 117 | 118 | ann :: Annotation -> (Domain -> Domain) 119 | ann Bold xs = [Tag "strong" xs] 120 | ann Italic xs = [Tag "i" xs] 121 | 122 | combine :: Domain -> Domain -> Domain 123 | combine h i = h ++ i 124 | 125 | markupToHTML :: Markup -> Domain 126 | markupToHTML (Text str) = [Simple str] 127 | markupToHTML (Ann a m) = ann a $ markupToHTML m 128 | markupToHTML (Concat m n) = combine (markupToHTML m) (markupToHTML n) 129 | 130 | -- DEFINE bold 131 | -- DEFINE italic 132 | 133 | 134 | 135 | 136 | -- DISCUSS Yet Another DSL! 137 | 138 | 139 | -- DEFINE markupToHTML :: Markup -> [HTML] 140 | 141 | 142 | 143 | 144 | -- DISCUSS (and DEFINE?) escapeHTML 145 | 146 | 147 | 148 | -- DISCUSS generalising Markup? 149 | -------------------------------------------------------------------------------- /archives/2024/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/Week09Live.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs, DataKinds, GADTs, StandaloneDeriving, RankNTypes #-} 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.Kind (Type) 8 | import Data.Traversable (for, fmapDefault, foldMapDefault) 9 | import qualified Network.HTTP as HTTP 10 | import Week08 (Parser, runParser, JSON (..), parseJSON) 11 | 12 | 13 | {- WEEK 09 : DATA DEPENDENCIES and APPLICATIVE FUNCTORS -} 14 | 15 | {- Part 9.1 : Sequences of Actions -} 16 | 17 | -- (>>=) :: Monad m => m a -> (a -> m b) -> m b 18 | -- forM :: Monad m => [ a] -> (a -> m b) -> m [b] 19 | 20 | -- DISCUSS dependencies between computations 21 | 22 | 23 | ap :: Monad m => m (a -> b) -> m a -> m b 24 | ap mf ma = 25 | do f <- mf 26 | a <- ma 27 | return (f a) 28 | -- DEFINE ap 29 | -- DISCUSS dependencies between computations 30 | 31 | 32 | 33 | -- DEFINE mapM_v2 :: forall m a b. Monad m => (a -> m b) -> [a] -> m [b] 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) = return (:) `ap` (f x) `ap` mapM_v2 f xs 37 | 38 | -- using ap 39 | 40 | -- Let's abstract over this pattern! 41 | 42 | {- Part 9.2 : Applicative -} 43 | 44 | -- Type class 45 | 46 | {- 47 | class Functor m => Applicative m where 48 | pure :: a -> m a 49 | (<*>) :: m (a -> b) -> m a -> m b 50 | -} 51 | 52 | -- DEFINE mapA :: Applicative f => (a -> f b) -> [a] -> f [b] 53 | 54 | mapA :: Applicative f => (a -> f b) -> [a] -> f [b] 55 | mapA f [] = pure [] 56 | mapA f (x:xs) 57 | = pure (:) <*> f x <*> mapA f xs 58 | -- = (:) <$> f x <*> mapA f xs 59 | 60 | 61 | 62 | {- Part 9.3 : Data Dependencies and Parallelism -} 63 | 64 | -- DEFINE Request/response 65 | 66 | newtype Request = MkRequest { getRequest :: String } 67 | deriving (Show) 68 | newtype Response = MkResponse { getResponse :: String } 69 | deriving (Show) 70 | 71 | -- DEFINE Fetch monad 72 | 73 | data Tree 74 | = Leaf 75 | | Tree :/\: Tree 76 | deriving Show 77 | 78 | data Batch (t :: Tree) (a :: Type) :: Type where 79 | One :: a -> Batch Leaf a 80 | (:++:) :: Batch l a -> Batch r a -> Batch (l :/\: r) a 81 | deriving instance Show a => Show (Batch t a) 82 | 83 | instance Traversable (Batch t) where 84 | traverse f (One a) = One <$> f a 85 | traverse f (l :++: r) = (:++:) <$> traverse f l <*> traverse f r 86 | 87 | instance Foldable (Batch t) where 88 | foldMap = foldMapDefault 89 | 90 | instance Functor (Batch t) where 91 | fmap = fmapDefault 92 | 93 | data Fetch a where 94 | End :: a -> Fetch a 95 | Ask :: Batch t Request -> (Batch t Response -> Fetch a) -> Fetch a 96 | 97 | -- DEFINE Show instance (to the best of our ability) 98 | instance Show a => Show (Fetch a) where 99 | show (End a) = "Ended: " ++ show a 100 | show (Ask reqs k) = "Requests: " ++ show reqs 101 | 102 | 103 | -- DEFINE makeRequest :: Request -> Fetch Response 104 | 105 | makeRequest :: Request -> Fetch Response 106 | makeRequest rq = Ask (One rq) $ \ (One rp) -> End rp 107 | 108 | -- DEFINE Monad & Applicative instances 109 | 110 | instance Monad Fetch where 111 | return = End 112 | (>>=) :: Fetch a -> (a -> Fetch b) -> Fetch b 113 | End a >>= f = f a 114 | Ask rqs k >>= f = Ask rqs ((>>= f) . k) 115 | 116 | instance Applicative Fetch where 117 | pure = End 118 | End f <*> mx = f <$> mx 119 | mf <*> End x = ($ x) <$> mf 120 | Ask rqs1 k1 <*> Ask rqs2 k2 = 121 | Ask (rqs1 :++: rqs2) $ \ (rsp1 :++: rsp2) -> 122 | k1 rsp1 <*> k2 rsp2 123 | 124 | instance Functor Fetch where 125 | fmap f (End a) = End (f a) 126 | fmap f (Ask rsq k) = Ask rsq (fmap f . k) 127 | 128 | 129 | runFetch 130 | :: Monad m 131 | => (forall t. Batch t Request -> m (Batch t Response)) 132 | -> Fetch a -> m a 133 | runFetch handle (End a) = return a 134 | runFetch handle (Ask rqs k) = do 135 | rsp <- handle rqs 136 | runFetch handle (k rsp) 137 | 138 | 139 | both :: Fetch (Response, Response) 140 | both = pure (,) 141 | <*> makeRequest (MkRequest "github.com") 142 | <*> makeRequest (MkRequest "instagram.com") 143 | 144 | 145 | runFetchIO 146 | :: (Request -> IO Response) 147 | -> Fetch a 148 | -> IO a 149 | runFetchIO handleIO = runFetch $ traverse handleIO 150 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /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 26 | 27 | - [Lecture notes](lecture-notes/Week01.hs) : Data and Functions 28 | - [Tutorial Problems](lecture-notes/Week01Problems.hs) 29 | - [Tutorial Solutions](lecture-notes/Week01Solutions.hs) 30 | - [Live Lecture code (Tuesday)](lecture-notes/Week01Live.hs) 31 | - [Live Lecture code (Friday)](lecture-notes/Week01Live2.hs) 32 | 33 | ### Week 2 34 | 35 | - [Lecture notes](lecture-notes/Week02.hs) : Solving Problems by Recursion 36 | - [Tutorial Problems](lecture-notes/Week02Problems.hs) 37 | - [Tutorial Solutions](lecture-notes/Week02Solutions.hs) 38 | - [Live Lecture code (Friday)](lecture-notes/Week02Live.hs) 39 | 40 | ### Week 3 41 | 42 | - [Lecture notes](lecture-notes/Week03.hs) : Higher Order Functions 43 | - [Tutorial Problems](lecture-notes/Week03Problems.hs) 44 | - [Tutorial Solutions](lecture-notes/Week03Solutions.hs) 45 | - [Live Lecture code (Tuesday)](lecture-notes/Week03Live.hs) 46 | - [Live Lecture code (Friday)](lecture-notes/Week03LiveFri.hs) 47 | 48 | ### Week 4 49 | 50 | - [Lecture notes](lecture-notes/Week04.hs) : Patterns of Recursion 51 | - [Tutorial Problems](lecture-notes/Week04Problems.hs) 52 | - [Tutorial Solutions](lecture-notes/Week04Solutions.hs) 53 | - [Live Lecture code (Tuesday and Friday)](lecture-notes/Week04Live.hs) 54 | 55 | ### Week 5 56 | - [Lecture notes](lecture-notes/Week05.hs) : Classes of Types 57 | - [Tutorial Problems](lecture-notes/Week05Problems.hs) 58 | - [Tutorial Solutions](lecture-notes/Week05Solutions.hs) 59 | - [Live Lecture Notes (Tuesday and Friday)](lecture-notes/Week05Live.hs) 60 | 61 | ### Week 6 62 | - [Lecture notes](lecture-notes/Week06.hs) : Simulating side-effects: Exceptions, State, and Printing 63 | - [Tutorial Problems](lecture-notes/Week06Problems.hs) 64 | - [Tutorial Solutions](lecture-notes/Week06Solutions.hs) 65 | - [Live Lecture code (Tuesday and Friday)](lecture-notes/Week06Live.hs) 66 | 67 | ### Week 7 68 | - [Lecture notes](lecture-notes/Week07.hs) : Monads 69 | - [Tutorial Problems](lecture-notes/Week07Problems.hs) 70 | - [Tutorial Solutions](lecture-notes/Week07Solutions.hs) 71 | - [Live Lecture Notes (Tuesday and Friday)](lecture-notes/Week07Live.hs) 72 | - [Live Lecture Notes with IO shenanigans](lecture-notes/Week07IO.hs) 73 | 74 | ### Week 8 75 | - [Lecture notes](lecture-notes/Week08.hs) : Real I/O and Parser Combinators 76 | - [Tutorial Problems](lecture-notes/Week08Problems.hs) 77 | - [Tutorial Solutions](lecture-notes/Week08Solutions.hs) 78 | - [Live Lecture code (2024)](lecture-notes/Week08Live.hs) 79 | 80 | ### Week 9 81 | 82 | - [Lecture notes](lecture-notes/Week09.hs) : Data Dependencies and Applicative Functors 83 | - [Live Lecture code](lecture-notes/Week09Live.hs) on data (in)dependencies and GADTs 84 | 85 | ### Week 10 86 | 87 | - [Lecture notes](lecture-notes/Week10.hs) : Lazy Evaluation and Infinite Data 88 | - [Live Lecture Code (Tuesday)](lecture-notes/Week10Live.hs) on concurrency 89 | 90 | You can take a look at [last year's notes](archives/) for similar notes and some different exercises. 91 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /archives/2024/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/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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /lecture-notes/Week03Live.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 2 | module Week02Live where 3 | 4 | import Data.List (subsequences) 5 | import Data.Maybe 6 | import Test.QuickCheck (Property, (==>)) 7 | 8 | ------------------------------------------------------------------------ 9 | -- Coming (sooner or later) 10 | 11 | -- AL 12 | -- Class test 13 | 14 | -- GA 15 | -- Coursework 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | ------------------------------------------------------------------------ 34 | -- Motivating example 35 | 36 | -- Making change: you have a till and have to give some money back to 37 | -- a customer. First: let's model the domain of discourse! 38 | 39 | -- modelling 40 | 41 | type Coin = Int 42 | type Till = [Coin] 43 | type Amount = Int 44 | type Change = [Coin] 45 | 46 | tillTotal :: Till -> Amount 47 | tillTotal = sum 48 | 49 | changeTotal :: Change -> Amount 50 | changeTotal = sum 51 | 52 | -- unit tests 53 | 54 | noCoin :: Bool 55 | noCoin = makeChange [1..10] 0 [] == Just [] 56 | 57 | rightCoin :: Bool 58 | rightCoin = (makeChange [5] 5 []) == Just [5] 59 | 60 | wholeTill :: Bool 61 | wholeTill = (makeChange [1..15] 55 []) == Just [1..10] 62 | 63 | -- property test 64 | -- "if we get a result then it's the right amount" 65 | 66 | cleanup :: (Till -> Amount -> a) -> (Till -> Amount -> a) 67 | cleanup f till amount = f (map abs till) (abs amount) 68 | 69 | prop_makeChange1 :: Till -> Amount -> Property 70 | prop_makeChange1 = cleanup $ \ till amount -> 71 | let res = makeChange till amount [] in 72 | isJust res ==> changeTotal (fromMaybe [] res) == amount 73 | 74 | -- DEFINE makeChange 75 | 76 | makeChange :: Till -> Amount -> Change -> Maybe Change 77 | makeChange _ 0 acc = Just (reverse acc) 78 | makeChange (coin:till) n acc 79 | | n >= coin = makeChange till (n-coin) (coin:acc) 80 | | otherwise = makeChange till n acc 81 | makeChange [] n acc = Nothing 82 | 83 | 84 | makeChange2 :: Till -> Amount -> Change -> Maybe Change 85 | makeChange2 _ 0 acc = Just (reverse acc) 86 | makeChange2 [] n acc = Nothing 87 | makeChange2 (coin:available) n acc 88 | | n >= coin = 89 | let future = makeChange2 available (n - coin) (coin:acc) in 90 | case future of 91 | Just x -> Just x 92 | Nothing -> (makeChange2 available n acc) 93 | | otherwise = makeChange2 available n acc 94 | 95 | {- 96 | -- case, defined by hand 97 | makeChangeCase 98 | :: Till -> Amount -> Change 99 | -> Maybe Change 100 | -> Maybe Change 101 | makeChange (coin:available) n acc (Just x) = Just x 102 | makeChange (coin:available) n acc Nothing = makeChange available n acc 103 | -} 104 | 105 | -- GA 106 | -- property test 107 | -- "if there is a valid subset of coins in the till, we successfully get change" 108 | 109 | prop_makeChange2 :: Till -> Amount -> Bool 110 | prop_makeChange2 = cleanup $ \ till amount -> 111 | let candidates = subsequences till in 112 | any (\ chg -> changeTotal chg == amount) candidates 113 | == isJust (makeChange till amount []) 114 | 115 | 116 | -- AL 117 | -- DISCUSS flaw 118 | -- FIX makeChange 119 | 120 | 121 | makeChange3 :: Till -> Amount -> Change -> Maybe Change 122 | makeChange3 _ 0 acc = Just (reverse acc) 123 | makeChange3 [] n acc = Nothing 124 | makeChange3 (coin:available) n acc 125 | | n >= coin = 126 | makeChange3 available (n - coin) (coin:acc) 127 | `orElse` 128 | makeChange3 available n acc 129 | | otherwise = makeChange3 available n acc 130 | 131 | 132 | 133 | ------------------------------------------------------------------------------ 134 | -- The Domain Specific Language of Failure 135 | 136 | -- Instead of doing case analysis, using Maybe, Nothing, Just, let's try 137 | -- to abstract a little bit away from that. 138 | 139 | -- AL 140 | -- DEFINE success 141 | -- DEFINE failure 142 | -- DEFINE orElse 143 | 144 | orElse :: Maybe a -> Maybe a -> Maybe a 145 | orElse (Just v) _ = Just v 146 | orElse Nothing ma = ma 147 | 148 | -- REFACTOR makeChange as makeChange 149 | 150 | 151 | 152 | 153 | ------------------------------------------------------------------------------ 154 | -- Search tree vs. Search strategy 155 | 156 | -- GA 157 | -- In Haskell we can reify control flow; use: 158 | -- DEFINE Success instead of success 159 | -- DEFINE Failure instead of failure 160 | -- DEFINE OrElse instead of orElse 161 | 162 | 163 | data Choices a 164 | = Success a 165 | | Failure 166 | | OrElse (Choices a) (Choices a) 167 | deriving (Show) 168 | {- 169 | makeChange3 :: Till -> Amount -> Change -> Maybe Change 170 | makeChange3 _ 0 acc = Just (reverse acc) 171 | makeChange3 [] n acc = Nothing 172 | makeChange3 (coin:available) n acc 173 | | n >= coin = 174 | makeChange3 available (n - coin) (coin:acc) in 175 | `orElse` 176 | makeChange3 available n acc 177 | | otherwise = makeChange3 available n acc 178 | 179 | 180 | -} 181 | makeChange4 :: Till -> Amount -> Change -> Choices Change 182 | makeChange4 _ 0 acc = Success (reverse acc) 183 | makeChange4 [] _ _ = Failure 184 | makeChange4 (coin:available) n acc 185 | | n >= coin = 186 | OrElse (makeChange4 available (n - coin) (coin:acc)) 187 | (makeChange4 available n acc) 188 | | otherwise = makeChange4 available n acc 189 | 190 | -- BUILD makeChange 191 | 192 | 193 | -- DEFINE greedy 194 | 195 | greedy :: Choices a -> Maybe a 196 | greedy Failure = Nothing 197 | greedy (Success v) = Just v 198 | greedy (OrElse l _) = greedy l 199 | 200 | backtracking :: Choices a -> Maybe a 201 | backtracking Failure = Nothing 202 | backtracking (Success v) = Just v 203 | backtracking (OrElse l r) = 204 | backtracking l `orElse` backtracking r 205 | 206 | -- DEFINE allChoices 207 | -- DEFINE best (using an (a -> Int) measure) 208 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /archives/2024/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/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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /archives/2024/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/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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /archives/2024/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/Week01Live.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 | Alasdair Lambert 14 | Guillaume Allais 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 | 42 | {- In this course, you will: 43 | 44 | - Learn more about Functional Programming (in Haskell) 45 | 46 | 47 | 48 | (Typed) Functional Programming is 49 | 50 | - Defining Datatypes To Represent Problems 51 | 52 | - Defining Functions To Create New Data From Old 53 | 54 | a.k.a "Value-oriented" programming. 55 | 56 | A "Functional Programming Language" is a programming language that 57 | is designed to make it easy to use Functional Programming ideas. -} 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | {- We use Haskell as an example Functional Programming Language. 72 | 73 | - Many languages now include ideas originally from Functional Programming. 74 | 75 | - Functions as values (a.k.a "lambdas") 76 | 77 | - "Algebraic" data types; "Make Illegal States Unrepresentable" 78 | 79 | - Immutability 80 | 81 | - Expressive Types 82 | 83 | - Errors as data, instead of Exceptions 84 | 85 | - No 'null' (the "Billion dollar mistake") 86 | 87 | - Close tracking of possible "side effects" 88 | 89 | Haskell is not perfect (I will grumble about it during the course 90 | [*]), but it does offer a place to learn about Functional 91 | Programming concepts without too many distractions. 92 | 93 | [*] "There are only two kinds of languages: the ones people 94 | complain about and the ones nobody uses.” ― Bjarne Stroustrup, 95 | The C++ Programming Language 96 | -} 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | {- Course arrangements: 105 | 106 | - Lectures: 107 | - Tuesdays at 11:00 108 | - Fridays at 11:00 109 | 110 | - Labs in Level 12 of Livingstone Tower 111 | - Tuesdays at 13:00-15:00 : 112 | 113 | - Holes: 114 | - No lecture on Tuesday 30th September 115 | 116 | - Video lectures, to support the in-person lectures 117 | - ~ 6 videos / week 118 | - ~ 10 minutes long 119 | 120 | - Online lecture notes in a GitHub repository 121 | - git clone https://github.com/msp-strath/cs316-functional-programming 122 | - git pull 123 | 124 | Feel free to send PRs if you spot mistakes! 125 | 126 | -} 127 | 128 | 129 | {- This is a programming course 130 | 131 | You will be expected to do a lot of programming in order to understand 132 | the concepts. 133 | 134 | 20 credit course : 12 hrs/week, 1 hour of videos, 2 of lectures, 2 labs. 135 | -} 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | {- YOU WILL NEED A WORKING HASKELL INSTALLATION 152 | 153 | - Suggested setup: 154 | 155 | - GHCup (GHC, Cabal, HLS) + VSCode + Haskell extension. 156 | 157 | - We use Emacs in the lectures and so does Bob in the videos 158 | 159 | - There are instructions on MyPlace 160 | 161 | - We (unfortunately) cannot test on Windows, so we will need the 162 | class's help to iron out Windows problems. 163 | 164 | -} 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | {- Assessment: 175 | 176 | - One class test (50%) in the labs mediated via myplace 177 | First attempt: Week 6 (October 28th) 178 | Redemption test: Week 9 (November 18th) 179 | We will only keep the best of both marks 180 | 181 | - One large coursework "mini-project" (50%) 182 | Specification released Week 3 183 | Submission Week 11 (December 11th) 184 | 185 | 186 | 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 $_ } 187 | 188 | -} 189 | 190 | 191 | -- Playing cards 192 | 193 | ------------------------------------------------------------------------------ 194 | -- Suits, and their colours 195 | 196 | data Suit = Diamonds | Hearts | Spades | Clubs 197 | deriving (Show,Enum,Bounded) 198 | 199 | exampleSuit :: Suit 200 | exampleSuit = Hearts 201 | 202 | data Colour = Red | Black 203 | deriving (Show) 204 | -- Why not Bool? Because `Red` and `Black` have clear 205 | -- domain-specific meaning that `True` and `False` simply 206 | -- do not have! 207 | 208 | getColour :: Suit -> Colour 209 | getColour Hearts = Red 210 | getColour Spades = Black 211 | getColour Clubs = Black 212 | getColour Diamonds = Red 213 | 214 | 215 | ------------------------------------------------------------------------------ 216 | -- Modeling ranks (compare to last year's definition!) 217 | 218 | data Rank where 219 | Number :: Int -> Rank 220 | Jack :: Rank 221 | Queen :: Rank 222 | King :: Rank 223 | deriving (Show) 224 | 225 | problematicRank :: Rank 226 | problematicRank = Number (-42) 227 | 228 | numericValue :: Rank -> Int 229 | numericValue = \case 230 | Number n -> n 231 | Jack -> 11 232 | Queen -> 12 233 | King -> 13 234 | 235 | lessThanOrEqualValue :: Rank -> Rank -> Bool 236 | lessThanOrEqualValue v1 v2 = numericValue v1 <= numericValue v2 237 | 238 | 239 | ------------------------------------------------------------------------------ 240 | -- A card is a suit together with a rank 241 | 242 | data Card = MkCard 243 | { getSuit :: Suit 244 | , getRank :: Rank 245 | } deriving (Show) 246 | 247 | suitOfCard :: Card -> Suit 248 | suitOfCard = getSuit 249 | 250 | 251 | suitOfCard' :: Card -> Suit 252 | suitOfCard' (MkCard s r) = s 253 | 254 | -- frugality principle 255 | 256 | ------------------------------------------------------------------------------ 257 | -- Generating a deck 258 | 259 | allSuits :: [Suit] 260 | allSuits = [minBound .. maxBound] 261 | 262 | allRanks :: [Rank] 263 | allRanks 264 | = (Number <$> [1..10]) ++ [Jack,Queen,King] 265 | 266 | -- Using a list comprehension 267 | deck :: [Card] 268 | deck = [ MkCard x y | x <- allSuits, y <- allRanks] 269 | 270 | -- Using applicative notations 271 | deck' :: [Card] 272 | deck' = MkCard <$> allSuits <*> allRanks 273 | -------------------------------------------------------------------------------- /archives/2024/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/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 | -------------------------------------------------------------------------------- /archives/2024/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 | -------------------------------------------------------------------------------- /archives/2024/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/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 | -------------------------------------------------------------------------------- /archives/2024/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/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 | --------------------------------------------------------------------------------