├── .gitignore ├── Impl ├── Test.hs └── strip ├── LICENSE ├── Makefile ├── README.cabal.md ├── README.md ├── W0Test.hs ├── W1Test.hs ├── W2Test.hs ├── W3Test.hs ├── W4Test.hs ├── W5Test.hs ├── W6Test.hs ├── W7Test.hs ├── haskell-exercises.cabal ├── stack.yaml └── templ ├── W1B.hs ├── W2B.hs ├── W3B.hs ├── W4B.hs ├── W5B.hs ├── W6B.hs └── W7B.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .stack-work -------------------------------------------------------------------------------- /Impl/Test.hs: -------------------------------------------------------------------------------- 1 | module Impl.Test where 2 | 3 | import Control.Monad 4 | import Test.QuickCheck hiding (Result,reason,(===)) 5 | import Test.QuickCheck.Test hiding (Result) 6 | import Test.QuickCheck.Monadic 7 | 8 | import GHC.IO.Handle 9 | import System.Directory 10 | import System.IO 11 | import Control.Exception (bracket,finally) 12 | 13 | -- toplevel 14 | 15 | myArgs = stdArgs {maxSize = 100} 16 | 17 | testEx str ts args = do 18 | putStrLn ("Testing "++str) 19 | res <- mapM (quickCheckWithResult args) ts 20 | if all isSuccess res 21 | then putStrLn "PASS" >> return True 22 | else putStrLn "FAIL" >> return False 23 | 24 | testExsArgs tests args = do 25 | sucs <- forM (zip [1..] tests) $ \(i,ts) -> testEx (show i) ts args 26 | let success = length . filter id $ sucs 27 | total = length tests 28 | putStrLn $ "TOTAL: "++show success++" / "++show total 29 | 30 | testExs tests = testExsArgs tests myArgs 31 | 32 | -- utils 33 | 34 | infixl 5 === 35 | actual === expected = 36 | counterexample ("Expected " ++ show expected ++ ", got " ++ show actual) $ actual == expected 37 | 38 | counterexample' :: Testable prop => String -> prop -> Gen Property 39 | counterexample' s p = return (counterexample s p) 40 | 41 | -- monadic tests 42 | 43 | stop_ p = stop p >> return () 44 | 45 | withOverrideHandle :: Handle -> Handle -> IO a -> IO a 46 | withOverrideHandle new old op = 47 | bracket (hDuplicate old) hClose $ \oldcopy -> 48 | bracket (hDuplicateTo new old) (\_ -> hDuplicateTo oldcopy old) $ \_ -> 49 | op 50 | 51 | withStdinout :: Handle -> Handle -> IO a -> IO a 52 | withStdinout newin newout = 53 | withOverrideHandle newin stdin . withOverrideHandle newout stdout 54 | 55 | capture :: String -> IO a -> IO (String,a) 56 | capture input op = do 57 | dir <- getTemporaryDirectory 58 | (path,h) <- openTempFile dir "haskell-exercises.in" 59 | hPutStrLn h input 60 | hClose h 61 | 62 | (opath,oh) <- openTempFile dir "haskell-exercises.out" 63 | read <- openFile path ReadMode 64 | 65 | val <- withStdinout read oh op `finally` 66 | do hClose oh 67 | hClose read 68 | 69 | str <- readFile opath 70 | 71 | return (str,val) 72 | 73 | runc string op = run (capture string op) 74 | 75 | runc' op = run (capture "" op) 76 | -------------------------------------------------------------------------------- /Impl/strip: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | awk -v pr=$1 '/^#ifdef sol/ {mode = 2} /^#else/ {mode = 1} /^#endif/ {mode = 0} !/^#/ { if (mode!=pr) print; }' 3 | 4 | 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | haskell-exercises (c) by Joel Kaasinen 2 | 3 | haskell-exercises is licensed under a 4 | Creative Commons Attribution 4.0 International License. 5 | 6 | You should have received a copy of the license along with this 7 | work. If not, see . 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | WEEKS=W1 W2 W3 W4 W5 W6 W7 2 | OUTS=$(patsubst %,%.hs,$(WEEKS)) 3 | SOLS=$(patsubst %,%Sol.hs,$(WEEKS)) 4 | 5 | all: $(OUTS) 6 | 7 | solutions: $(SOLS) 8 | 9 | $(OUTS): %.hs: templ/%B.hs 10 | @echo "=> $@" 11 | @./Impl/strip 2 < $< > $@ 12 | 13 | $(SOLS): %Sol.hs: templ/%B.hs 14 | @echo "=> $@" 15 | @./Impl/strip 1 < $< > $@ 16 | -------------------------------------------------------------------------------- /README.cabal.md: -------------------------------------------------------------------------------- 1 | Alternative Quick Start using cabal 2 | ----------------------------------- 3 | 4 | In case you have problems with `stack`, here is a more old-fashioned 5 | way to work with the exercises. 6 | 7 | 1. Install [The Haskell Platform](https://www.haskell.org/platform/) 8 | 9 | 2. Download dpendencies and check that you can run the tests: 10 | 11 | $ cabal sandbox init 12 | $ cabal exec runhaskell W0Test.hs 13 | 14 | This should print `Everything seems to be OK!`. If you see any errors, 15 | you might not have a problem with your Haskell installation. 16 | 17 | 4. Generate the exercise templates (files `W*.hs`): 18 | 19 | $ make 20 | 21 | 5. Now you can edit `W1.hs` and see how well you did by running 22 | 23 | $ cabal exec runhaskell W1Test.hs 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Opqdonut's Haskell Exercises 2 | ============================ 3 | 4 | **Note!** You probably want to check out my Haskell MOOC 5 | ([course page], [GitHub]) instead! It's completely free and open and is based 6 | on these exercises, but also contains study material and other 7 | improvements. These exercises still work, but this repository isn't 8 | maintained. 9 | 10 | [course page]: https://haskell.mooc.fi 11 | [GitHub]: https://github.com/moocfi/haskell-mooc 12 | 13 | Quick Start 14 | ----------- 15 | 16 | If these instructions don't work for you, see the 17 | [instructions for using cabal instead of stack](README.cabal.md) 18 | 19 | 1. Install [Stack](https://www.haskellstack.org/) 20 | 21 | 2. Download dependencies by running 22 | 23 | $ stack build 24 | 25 | 2. Then check you can actually run the tests with: 26 | 27 | $ stack runhaskell W0Test.hs 28 | 29 | This should print `Everything seems to be OK!`. If you see any errors, 30 | you might not have a problem with your Haskell installation. 31 | 32 | 3. Generate the exercise templates (files `W*.hs`): 33 | 34 | $ make 35 | 36 | 4. Now you can edit `W1.hs` and see how well you did by running 37 | 38 | $ stack runhaskell W1Test.hs 39 | 40 | 5. You can also play around with your solutions interactively by running 41 | 42 | $ stack ghci W1.hs 43 | 44 | Introduction 45 | ------------ 46 | 47 | This is a collection of small and simple Haskell exercises with unit 48 | tests. This means your answers to the exercises are checked by the 49 | computer – making these exercises great for self-study. 50 | 51 | The exercises don't really include any reading material, so you should 52 | study some Haskell tutorial, e.g. [Learn You A Haskell For Great 53 | Good!]( http://learnyouahaskell.com/) while working on the exercises. 54 | 55 | If bump into an exercise that talks about terms you don't understand, 56 | look them up in a tutorial or google them! The exercises are meant to 57 | encourage you to learn, not check that you already know stuff :) 58 | 59 | I created this set of exercises for a Haskell course I held at 60 | Helsinki University because I couldn't find a set of good Haskell 61 | exercises anywhere. I hope somebody else finds them useful as well. 62 | 63 | Contents 64 | -------- 65 | 66 | The exercises are split into sets called "weeks", each containing 67 | about 20 exercises. You are meant to work through the weeks in order, 68 | but you don't need to get every exercise in a week right to move on. 69 | 70 | The topics of the weeks are 71 | 72 | * W1: basics, syntax, defining functions, pattern matching, recursion 73 | * W2: lists, strings, higher-order functions, polymorphism 74 | * W3: data types 75 | * W4: IO 76 | * W5: type classes 77 | * W6: Monads 78 | * W7: recap of weeks 1-6 79 | 80 | Working on the Excercises 81 | ------------------------- 82 | 83 | - Read and edit the `Wn.hs` files according to the instructions 84 | - Don't remove or change any type signatures (things like `foo :: 85 | String -> String`) that are already in the files 86 | - Check your answers for week `n` with `stack runhaskell WnTest.hs` 87 | (or alternatively `cabal exec runhaskell WnTest.hs` if you're not using stack) 88 | - A typical test failure looks like this: 89 | 90 | Testing 11 91 | *** Failed! Falsifiable (after 1 test): 92 | 0 93 | 0 94 | Expected 1, got 3 95 | FAIL 96 | 97 | This means that the function from exercise 11 failed the test when 98 | the two arguments were 0 and 0. The result should have been 1, but 99 | it was 3. 100 | 101 | I'm sorry if the test failures aren't always understandable :/ 102 | 103 | - You can also play around with your solutions interactively by 104 | running `stack ghci Wn.hs` (or `cabal exec ghci Wn.hs`). 105 | This is a good idea for instance when you don't understand the 106 | test failures. 107 | 108 | Solutions 109 | --------- 110 | 111 | This repository also contains solutions to the exercises. You can get 112 | the solutions for week `n` by running 113 | 114 | $ make WnSol.hs 115 | 116 | The solutions are also visibile under the directory `templ/`. Don't look 117 | there if you don't want spoilers! 118 | -------------------------------------------------------------------------------- /W0Test.hs: -------------------------------------------------------------------------------- 1 | module W0Test where 2 | 3 | import Impl.Test 4 | 5 | main = putStrLn "Everything seems to be OK!" 6 | -------------------------------------------------------------------------------- /W1Test.hs: -------------------------------------------------------------------------------- 1 | module W1Test where 2 | 3 | import Impl.Test 4 | import W1 5 | import Data.List 6 | import Test.QuickCheck hiding ((===)) 7 | 8 | main = testExs tests 9 | 10 | tests = [[] 11 | ,[property ex2_double] 12 | ,[property ex3_quadruple] 13 | ,[property ex4_poly2] 14 | ,[property ex5_eeny_even, property ex5_meeny_odd] 15 | ,[property ex6_fizzbuzz_3_5 16 | ,property ex6_fizzbuzz_3 17 | ,property ex6_fizzbuzz_5 18 | ,property ex6_fizzbuzz_empty] 19 | ,[property ex7_isZero_0 20 | ,property ex7_isZero_positive 21 | ,property ex7_isZero_negative] 22 | ,[ex8_sumTo] 23 | ,[ex9_power] 24 | ,[property ex10_ilog2] 25 | ,[ex11_binomial] 26 | ,[ex12_tribonacci] 27 | ,[ex13_myGcd] 28 | ,[ex14_funnyCompare_even, ex14_funnyCompare_odd 29 | ,ex14_funnyCompare_mixed] 30 | ,[ex15_funnyMin_even, ex15_funnyMin_odd 31 | ,ex15_funnyMin_mixed] 32 | ,[ex16_pyramid] 33 | ,[ex17_smallestDivisor_prime, property ex17_smallestDivisor_comp] 34 | ,[ex18_isPrime] 35 | ,[ex19_nextPrime]] 36 | 37 | -- -- -- -- -- -- 38 | 39 | ex2_double x = double x `div` 2 === x 40 | 41 | ex3_quadruple x = quadruple x `div` 4 === x 42 | 43 | feq a b = abs (a-b) < 0.01 44 | 45 | ex4_poly2 = do 46 | x0 <- elements [1..4] :: Gen Double 47 | x1 <- elements [1..4] :: Gen Double 48 | a <- elements [1..4] :: Gen Double 49 | let b = -a*(x0+x1) 50 | c = a*x0*x1 51 | str = concat ["poly2 ",show a," ",show b," ",show c," "] 52 | t :: Double -> Double -> Property 53 | t x y = counterexample (str++show x++" should be "++show y) $ poly2 a b c x `feq` y 54 | return $ t x0 0 55 | .&&. t x1 0 56 | .&&. t ((x0+x1)/2) (-b^2/(4*a)+c) 57 | 58 | ex5_eeny_even x = eeny (2*x) === "eeny" 59 | ex5_meeny_odd x = eeny (2*x+1) === "meeny" 60 | 61 | div35 :: Gen Integer 62 | div35 = fmap (*15) arbitrary 63 | 64 | div5 :: Gen Integer 65 | div5 = fmap (\x -> 5*(3*x+1)) arbitrary 66 | 67 | div3 :: Gen Integer 68 | div3 = fmap (\x -> 3*(5*x+1)) arbitrary 69 | 70 | div0 :: Gen Integer 71 | div0 = fmap (\x -> 15*x+1) arbitrary 72 | 73 | ex6_fizzbuzz_3_5 = 74 | forAll div35 $ \i -> 75 | fizzbuzz i === "FizzBuzz" 76 | ex6_fizzbuzz_3 = 77 | forAll div3 $ \i -> 78 | fizzbuzz i === "Fizz" 79 | ex6_fizzbuzz_5 = 80 | forAll div5 $ \i -> 81 | fizzbuzz i === "Buzz" 82 | ex6_fizzbuzz_empty = 83 | forAll div0 $ \i -> 84 | fizzbuzz i === "" 85 | 86 | ex7_isZero_0 = isZero 0 === True 87 | 88 | ex7_isZero_positive :: Positive Integer -> Property 89 | ex7_isZero_positive (Positive n) = isZero n === False 90 | 91 | ex7_isZero_negative :: Positive Integer -> Property 92 | ex7_isZero_negative (Positive n) = isZero (-n) === False 93 | 94 | ex8_sumTo = 95 | forAll (elements [1..100]) $ \n -> 96 | sumTo n === sum [1..n] 97 | 98 | ex9_power = 99 | forAll (elements [1..10]) $ \n -> 100 | forAll (elements [1..10]) $ \k -> 101 | power n k === n^k 102 | 103 | ex10_ilog2 (Positive n) = 104 | ilog2 n === floor (logBase 2 $ fromIntegral n) 105 | 106 | ex11_binomial = 107 | forAll (elements [0..10]) $ \n -> 108 | forAll (elements [0..n]) $ \k -> 109 | binomial n k === f n `div` (f k * f (n-k)) 110 | where f n = product [1..n] 111 | 112 | ex12_tribonacci = 113 | forAll (elements [1..15]) $ \n -> 114 | tribonacci n === t n 115 | where t 1 = 1 116 | t 2 = 1 117 | t 3 = 2 118 | t n = t (n-1) + t (n-2) + t (n-3) 119 | 120 | ex13_myGcd = 121 | forAll (elements [1..max]) $ \x -> 122 | forAll (elements [1..max]) $ \y -> 123 | myGcd x y === gcd x y 124 | where max = 10000 125 | 126 | odds = filter odd [-5..100] 127 | evens = filter even [-5..100] 128 | 129 | ex14_funnyCompare_even = 130 | forAll (elements evens) $ \x -> 131 | forAll (elements evens) $ \y -> 132 | funnyCompare x y === compare x y 133 | 134 | ex14_funnyCompare_odd = 135 | forAll (elements odds) $ \x -> 136 | forAll (elements odds) $ \y -> 137 | funnyCompare x y === compare x y 138 | 139 | ex14_funnyCompare_mixed = 140 | forAll (elements evens) $ \x -> 141 | forAll (elements odds) $ \y -> 142 | funnyCompare x y === LT 143 | .&&. 144 | funnyCompare y x === GT 145 | 146 | ex15_funnyMin_even = 147 | forAll (elements evens) $ \x -> 148 | forAll (elements evens) $ \y -> 149 | funnyMin x y === min x y 150 | 151 | ex15_funnyMin_odd = 152 | forAll (elements odds) $ \x -> 153 | forAll (elements odds) $ \y -> 154 | funnyMin x y === min x y 155 | 156 | ex15_funnyMin_mixed = 157 | forAll (elements evens) $ \x -> 158 | forAll (elements odds) $ \y -> 159 | funnyMin x y === x 160 | .&&. 161 | funnyMin y x === x 162 | 163 | split delim xs = 164 | case rest of [] -> [a] 165 | (_:rest') -> a : split delim rest' 166 | where (a,rest) = break (==delim) xs 167 | 168 | ex16_pyramid = 169 | forAll (elements [0..40]) $ \n -> 170 | f (pyramid n) === ([0..n] ++ [n-1,n-2..0]) 171 | where f xs = map read $ split ',' xs 172 | 173 | primes = go [2..] 174 | where go (x:xs) = x : go (filter (notDivBy x) xs) 175 | notDivBy x y = mod y x /= 0 176 | 177 | ex17_smallestDivisor_prime = do 178 | forAll (elements $ take 12 primes) $ \p -> 179 | p === smallestDivisor p 180 | 181 | ex17_smallestDivisor_comp = do 182 | k <- (elements . take 10 $ primes) 183 | p <- (elements . take 20 . drop 10 $ primes) 184 | let n = k*p 185 | return $ counterexample (show n) $ 186 | k === smallestDivisor n 187 | 188 | ex18_isPrime = 189 | forAll (elements [0..max]) $ \n -> 190 | isPrime n === elem n primes' 191 | where max = 20 192 | primes' = takeWhile (<=max) primes 193 | 194 | ex19_nextPrime = 195 | forAll (elements [0..max]) $ \n -> 196 | nextPrime n === head (dropWhile (<=n) primes) 197 | where max = 100 198 | -------------------------------------------------------------------------------- /W2Test.hs: -------------------------------------------------------------------------------- 1 | module W2TestSansHT where 2 | 3 | import Impl.Test 4 | import W2 5 | import Data.List 6 | import Data.Char 7 | import Test.QuickCheck hiding ((===)) 8 | 9 | main = testExs tests 10 | 11 | tests = [[] 12 | ,[property ex2_measure_empty, property ex2_measure_nonEmpty] 13 | ,[ex3_takeFinal_1, ex3_takeFinal_2] 14 | ,[ex4_remove] 15 | ,[property ex5_substring] 16 | ,[property ex6_mymax] 17 | ,[property ex7_countSorted] 18 | ,[ex8_funny_1, ex8_funny_2] 19 | ,[property ex9_quicksort] 20 | ,[property ex10_powers] 21 | ,[property ex11_search_number, property ex11_search_string] 22 | ,[property ex12_fromTo] 23 | ,[property ex13_sums] 24 | ,[property ex14_mylast_nonempty, property ex14_mylast_empty] 25 | ,[property ex15_sorted_empty, property ex15_sorted_sorted] 26 | ,[property ex16_sumsOf] 27 | ,[property ex17_mymaximum_max, property ex17_mymaximum_min, property ex17_mymaximum_empty] 28 | ,[property ex18_map_1, property ex18_map_2] 29 | ,[property ex19_interpreter_1, property ex19_interpreter_2] 30 | ,[ex20_squares]] 31 | 32 | 33 | -- -- -- -- -- -- 34 | 35 | ex2_measure_empty () = measure [] === -1 36 | ex2_measure_nonEmpty (NonEmpty xs) = measure xs === length xs 37 | 38 | ex3_takeFinal_1 = 39 | forAll (choose (0,20)) $ \n -> 40 | forAll (choose (0,n)) $ \k -> 41 | takeFinal k [0..n] === [n-k+1..n] 42 | 43 | ex3_takeFinal_2 = 44 | forAll (choose (0,20)) $ \n -> 45 | forAll (choose (0,n)) $ \k -> 46 | takeFinal k (reverse [0..n]) === reverse [0..k-1] 47 | 48 | ex4_remove = 49 | forAll (choose (0,20)) $ \n -> 50 | forAll (choose (0,n)) $ \k -> 51 | remove k [0,2..2*n] === map (2*) ([0..(k-1)] ++ [k+1..n]) 52 | 53 | ex5_substring = do 54 | base <- choose (ord 'a',ord 'f') 55 | len <- choose (0,20) 56 | let list = f [base..base+len-1] 57 | i <- choose (0,len) 58 | n <- choose (0,len-i) 59 | return $ counterexample ("substring "++show i++" "++show n++" "++show list) $ 60 | substring i n list === f [base+i .. base + min (i+n) (len) - 1] 61 | where f = map chr 62 | 63 | ex6_mymax = do 64 | t <- choose (0,20) 65 | f <- choose (0,20) `suchThat` \f -> f/=t 66 | let p True = t 67 | p False = f 68 | return $ 69 | counterexample ("let p True = "++show t++"; p False = "++show f++" in mymax p False True") $ 70 | mymax p False True === (t>f) 71 | 72 | word = listOf1 (choose ('a','z')) 73 | sortedWord = fmap sort word 74 | unsortedWord = word `suchThat` \w -> w /= sort w 75 | 76 | ex7_countSorted = do 77 | ss <- listOf1 sortedWord 78 | us <- listOf1 unsortedWord 79 | k <- choose (1,5) 80 | let ws = comb k ss us 81 | return $ counterexample ("countSorted "++show ws) $ 82 | length ss === countSorted ws 83 | 84 | where comb k [] b = b 85 | comb k a b = take k a ++ comb k b (drop k a) 86 | 87 | ex8_funny_1 = 88 | counterexample ("funny "++show inp) $ 89 | funny inp === out 90 | where inp = ["a","bcdefgh","simo","xxxxxxxxxxx"] 91 | out = "BCDEFGH XXXXXXXXXXX" 92 | 93 | ex8_funny_2 = 94 | counterexample ("funny "++show inp) $ 95 | funny inp === out 96 | where inp = ["aaaaaa","bbbbbb","ccccc","ddddddd"] 97 | out = "AAAAAA BBBBBB DDDDDDD" 98 | 99 | ex9_quicksort xs = quicksort xs === sort xs 100 | 101 | ex10_powers = do 102 | n <- choose (2,5) 103 | len <- choose (1,10) 104 | end <- choose (n^(len-1),n^len-1) 105 | let p = powers n end 106 | return $ counterexample ("powers "++show n++" "++show end) $ conjoin 107 | [counterexample "all smaller than end" $ 108 | all (<=end) p 109 | ,counterexample "sorted" $ 110 | p == sort p 111 | ,counterexample "length" $ 112 | length p === len 113 | ,counterexample "powers of n" $ 114 | all (check n) p] 115 | where check n 0 = True 116 | check n 1 = True 117 | check n k 118 | | k `mod` n == 0 = check n (div k n) 119 | | otherwise = False 120 | 121 | ex11_search_number = do 122 | n <- choose (0,20 :: Integer) 123 | return $ counterexample ("search (+1) (=="++show n++") 0") $ 124 | search (+1) (==n) 0 === n 125 | 126 | ex11_search_string = do 127 | n <- word 128 | let w = n++n 129 | p = (==n) 130 | return $ counterexample ("search tail (=="++show n++") "++show w) $ 131 | search tail p w == n 132 | 133 | 134 | 135 | ex12_fromTo = do 136 | start <- choose (0,20) 137 | len <- choose (0,10) 138 | let end = start+len-1 139 | return $ counterexample ("fromTo "++show start++" "++show end) $ 140 | fromTo start end === [start..end] 141 | 142 | ex13_sums = do 143 | i <- choose (1,20) 144 | return $ counterexample ("sums "++show i) $ 145 | sums i === scanl1 (+) [1..i] 146 | 147 | 148 | ex14_mylast_nonempty :: NonEmptyList Integer -> Property 149 | ex14_mylast_nonempty (NonEmpty xs) = mylast 0 xs === last xs 150 | ex14_mylast_empty :: Char -> Property 151 | ex14_mylast_empty i = mylast i [] === i 152 | 153 | ex15_sorted_empty = 154 | counterexample "sorted []" $ sorted [] === True 155 | 156 | ex15_sorted_sorted = do 157 | l <- vector 5 158 | let s = sort l 159 | return $ conjoin 160 | [counterexample ("sorted "++show l) $ sorted l === (s == l) 161 | ,counterexample ("sorted "++show s) $ sorted s === True] 162 | 163 | ex16_sumsOf xs = sumsOf xs === scanl1 (+) xs 164 | 165 | ex17_mymaximum_max :: NonEmptyList Integer -> Property 166 | ex17_mymaximum_max (NonEmpty xs) = mymaximum compare 0 xs === maximum xs 167 | 168 | ex17_mymaximum_min :: NonEmptyList Integer -> Property 169 | ex17_mymaximum_min (NonEmpty xs) = mymaximum (\x y -> compare y x) 0 xs === minimum xs 170 | 171 | ex17_mymaximum_empty = do 172 | i <- choose (True,False) 173 | return $ mymaximum compare i [] === i 174 | 175 | ex18_map_1 = do 176 | i <- arbitrary :: Gen [Int] 177 | j <- arbitrary :: Gen [Bool] 178 | return $ counterexample ("map2 const "++show i++" "++show j) $ 179 | map2 const i j === take (length j) i 180 | 181 | ex18_map_2 = do 182 | i <- arbitrary :: Gen [Int] 183 | j <- arbitrary :: Gen [Int] 184 | return $ counterexample ("map2 (+) "++show i++" "++show j) $ 185 | map2 (+) i j === zipWith (+) i j 186 | 187 | 188 | ex19_interpreter_1 = do 189 | a0 <- choose (10,20) 190 | a1 <- choose (0,10) 191 | b0 <- choose (1,3) 192 | b1 <- choose (0,1) 193 | 194 | let first = replicate a0 "incA" ++ replicate b0 "incB" ++ ["printA","printB"] 195 | second = replicate (a0-a1) "decA" ++ replicate (b0-b1) "decB" ++ ["printB","printA"] 196 | input = first ++ second 197 | output = [show a0, show b0, show b1, show a1] 198 | 199 | return $ counterexample ("interpreter "++show input) $ 200 | interpreter input === output 201 | 202 | ex19_interpreter_2 = do 203 | nums <- vectorOf 4 $ choose (0,10) 204 | let diffs = zipWith (-) nums (0:nums) 205 | f x | x<0 = replicate (negate x) "decA" 206 | | otherwise = replicate x "incA" 207 | input = concatMap (\x -> f x ++ ["printA"]) diffs 208 | output = map show nums 209 | return $ counterexample ("interpreter "++show input) $ 210 | interpreter input === output 211 | 212 | ex20_squares = 213 | forAll (choose (0,1000)) $ \n -> 214 | let ret = squares n 215 | in conjoin [counterexample "length" $ length ret === n, 216 | counterexample "all squares" $ all isSq ret, 217 | counterexample "in order" $ sort ret == ret, 218 | counterexample "start and end" $ all check ret] 219 | 220 | where isSq x = x == (isqrt x)^2 221 | isqrt = round . sqrt . fromIntegral 222 | check x = let s = show x in head s == last s 223 | -------------------------------------------------------------------------------- /W3Test.hs: -------------------------------------------------------------------------------- 1 | module W3Test where 2 | 3 | import W3 4 | import Impl.Test 5 | 6 | import Data.Either 7 | import Control.Monad 8 | import Test.QuickCheck hiding (Result,reason,classify,(===)) 9 | 10 | main = testExs tests 11 | 12 | tests = [[property $ ex1_safeDiv_zero, property $ ex1_safeDiv_nonZero] 13 | ,[property $ ex2_eitherDiv_zero 14 | ,property $ ex2_eitherDiv_nonZero] 15 | ,[property $ ex3_mapMaybe_1, property $ ex3_mapMaybe_2] 16 | ,[property $ ex4_classify] 17 | ,[ex5_fred, ex5_age, ex5_name] 18 | ,[ex6_TwoCounters] 19 | ,[ex7_UpDown] 20 | ,[ex8_valAtRoot_Nothing, ex8_valAtRoot_Just] 21 | ,[ex9_treeSize] 22 | ,[ex10_leftest_Nothing, ex10_leftest_Just] 23 | ,[ex11_mapTree] 24 | ,[ex12_insertL] 25 | ,[ex13_measure] 26 | ,[property $ ex14_mysum, property $ ex14_mylength] 27 | ,[ex15_treeLeaves, ex15_treeSum] 28 | ,[ex16_rgb_red 29 | ,ex16_rgb_green 30 | ,ex16_rgb_blue 31 | ,ex16_rgb_darken 32 | ,ex16_rgb_mix 33 | ,ex16_rgb_complicated 34 | ] 35 | ] 36 | 37 | -- -- -- -- -- -- -- -- 38 | 39 | ex1_safeDiv_zero x = 40 | safeDiv x 0 === Nothing 41 | 42 | ex1_safeDiv_nonZero x y = 43 | (y/=0) ==> safeDiv x y === Just (div x y) 44 | 45 | ex2_eitherDiv_zero x = 46 | eitherDiv x 0 === Left (show x++"/0") 47 | 48 | ex2_eitherDiv_nonZero x y = 49 | (y/=0) ==> eitherDiv x y === Right (div x y) 50 | 51 | ex3_mapMaybe_1 xs = 52 | counterexample ("let f True = Just True; f False = Nothing in mapMaybe f "++show xs) $ 53 | mapMaybe f xs === filter id xs 54 | where f True = Just True 55 | f False = Nothing 56 | 57 | ex3_mapMaybe_2 :: [Integer] -> Property 58 | ex3_mapMaybe_2 is = 59 | counterexample ("let f x = if x>0 then Just (2*x) else Nothing\ 60 | \in mapMaybe f "++show is) $ 61 | mapMaybe f is === map (2*) (filter (>0) is) 62 | where f x = if x>0 then Just (2*x) else Nothing 63 | 64 | ex4_classify :: [Either Integer Bool] -> Property 65 | ex4_classify es = 66 | classify es === partitionEithers es 67 | 68 | ex5_fred = property $ do 69 | conjoin [counterexample "getName fred" $ 70 | getName fred === "Fred" 71 | ,counterexample "getAge fred" $ 72 | getAge fred === 90] 73 | 74 | word = listOf1 (choose ('a','z')) 75 | 76 | ex5_name = property $ do 77 | n <- word 78 | return $ counterexample ("getName (setName "++show n++" fred)") $ 79 | getName (setName n fred) === n 80 | 81 | ex5_age = property $ do 82 | a <- choose (0,89) 83 | return $ counterexample ("getAge (setAge "++show a++" fred)") $ 84 | getAge (setAge a fred) === a 85 | 86 | ex6_TwoCounters = property $ do 87 | a <- choose (0,20) 88 | b' <- choose (0,20) 89 | let b = a+b' 90 | let tc0 = iterate (incA . incB) zeros !! a 91 | tc1 = iterate incB tc0 !! b' 92 | return $ counterexample ("Did "++show a++" incAs and "++show b++" incBs.") $ 93 | (getA tc1, getB tc1) === (a,b) 94 | 95 | ex7_UpDown = property $ do 96 | a <- choose (0,20) 97 | b <- choose (0,20) 98 | let tc0 = iterate tick zero !! a 99 | tc1 = iterate tick (toggle tc0) !! b 100 | return $ counterexample ("Did "++show a++" ticks, a toggle, and "++show b++" ticks.") $ 101 | get tc1 === a-b 102 | 103 | ex8_valAtRoot_Nothing = 104 | valAtRoot Leaf === (Nothing :: Maybe Bool) 105 | 106 | ex8_valAtRoot_Just = property $ do 107 | l <- genTree 3 :: Gen (Tree Integer) 108 | r <- genTree 3 :: Gen (Tree Integer) 109 | v <- choose (0,10 :: Integer) 110 | let t = Node v l r 111 | return $ counterexample (show t) $ 112 | valAtRoot t === Just v 113 | 114 | genTree :: Arbitrary a => Int -> Gen (Tree a) 115 | genTree 0 = return Leaf 116 | genTree siz = do 117 | let siz' = siz-1 118 | sizl <- choose (0,siz') 119 | let sizr = siz'-sizl 120 | l <- genTree sizl 121 | r <- genTree sizr 122 | v <- arbitrary 123 | return $ Node v l r 124 | 125 | ex9_treeSize = 126 | forAllShrink (choose (0,50)) shrink $ \s -> do 127 | t <- genTree s 128 | return $ counterexample (show t) $ 129 | treeSize (t :: Tree Int) === s 130 | 131 | genLeft :: Arbitrary a => a -> Int -> Gen (Tree a) 132 | genLeft k s = go s 133 | where go 0 = do t <- genTree s 134 | return $ Node k Leaf t 135 | go n = do r <- genTree s 136 | l <- go (n-1) 137 | v <- arbitrary 138 | return $ Node v l r 139 | 140 | ex10_leftest_Nothing = leftest Leaf === (Nothing :: Maybe Bool) 141 | 142 | ex10_leftest_Just = property $ do 143 | k <- choose (0,10) 144 | s <- choose (0,10) 145 | t <- genLeft k s 146 | return $ counterexample (show t) $ 147 | leftest (t :: Tree Int) === Just k 148 | 149 | genL :: Int -> Gen (Tree Bool -> Tree Bool) 150 | genL s = go s 151 | where go 0 = do return $ id 152 | go n = do r <- genTree s 153 | l <- go (n-1) 154 | v <- arbitrary 155 | return $ \k -> Node v (l k) r 156 | 157 | ex11_mapTree = 158 | forAllShrink (choose (0,50)) shrink $ \s -> do 159 | t <- genTree s 160 | let t' = mapTree (even::Int->Bool) t 161 | return $ counterexample ("mapTree even "++show t++"\returned:\n"++show t') $ 162 | check t t' 163 | where check Leaf Leaf = property $ True 164 | check (Node a al ar) bt@(Node b bl br) = 165 | counterexample ("Alipuussa "++show bt) $ 166 | conjoin [b === even a, 167 | check al bl, 168 | check ar br] 169 | check a b = 170 | counterexample ("Tree structures don't match:\n"++show a++"\n"++show b) False 171 | 172 | ex12_insertL = 173 | forAllShrink (choose (0,20)) shrink $ \s -> do 174 | f <- genL s 175 | let t0 = f Leaf 176 | t1 = f (Node True Leaf Leaf) 177 | return $ counterexample ("insertL True "++show t0) $ 178 | insertL True t0 === t1 179 | 180 | genMeasure 0 = return $ Leaf 181 | genMeasure siz = do 182 | let siz' = siz-1 183 | sizl <- choose (0,siz') 184 | let sizr = siz'-sizl 185 | l <- genMeasure sizl 186 | r <- genMeasure sizr 187 | return $ Node siz l r 188 | 189 | zeroTree Leaf = Leaf 190 | zeroTree (Node _ l r) = Node 0 (zeroTree l) (zeroTree r) 191 | 192 | ex13_measure = 193 | forAllShrink (choose (0,20)) shrink $ \s -> do 194 | t <- genMeasure s 195 | let t' = zeroTree t :: Tree Int 196 | return $ counterexample (show t') $ 197 | measure t' === t 198 | 199 | ex14_mysum :: [Int] -> Property 200 | ex14_mysum xs = 201 | foldr sumf 0 xs === sum xs 202 | 203 | ex14_mylength :: [Int] -> Property 204 | ex14_mylength xs = 205 | foldr lengthf 0 xs === length xs 206 | 207 | ex15_treeLeaves = 208 | forAllShrink (choose (0,20)) shrink $ \s -> do 209 | t <- genTree s 210 | let leaves = s+1 211 | return $ counterexample (show t) $ 212 | foldTree leaft 1 (t :: Tree Bool) === leaves 213 | 214 | modTree k Leaf = Leaf 215 | modTree k (Node _ l r) = Node k (modTree k l) (modTree k r) 216 | 217 | ex15_treeSum = property $ do 218 | k <- choose (0,5 :: Int) 219 | s <- choose (0,5) 220 | t0 <- genTree s :: Gen (Tree ()) 221 | let t = modTree k t0 222 | return $ counterexample (show t) $ 223 | foldTree sumt 0 t === s*k 224 | 225 | ex16_rgb_red = 226 | counterexample (show Red) $ 227 | rgb Red === [1,0,0] 228 | ex16_rgb_green = 229 | counterexample (show Green) $ 230 | rgb Green === [0,1,0] 231 | ex16_rgb_blue = 232 | counterexample (show Blue) $ 233 | rgb Blue === [0,0,1] 234 | 235 | fcmp actual expected = 236 | counterexample ("Expected " ++ show expected ++ ", got " ++ show actual) $ 237 | diff < eps 238 | where diff = sum . map abs $ zipWith (-) actual expected 239 | eps = 0.01 240 | 241 | ex16_rgb_darken = property $ do 242 | s <- choose (0,1) 243 | let col = Darken s (Darken s Red) 244 | let ans = rgb col 245 | return $ counterexample (show col) $ 246 | fcmp ans [(1-s)^2, 0, 0] 247 | 248 | ex16_rgb_mix = property $ do 249 | r <- choose (0,1) 250 | g <- choose (0,1) 251 | let col = Mix (Darken r Red) (Darken g Green) 252 | let ans = rgb col 253 | return $ counterexample (show col) $ 254 | fcmp ans [(1-r), (1-g), 0] 255 | 256 | ex16_rgb_complicated = property $ do 257 | [r0,b0,g0,r1,b1,g1] <- replicateM 6 (choose (0,1)) 258 | [x,y] <- replicateM 2 (choose (0,0.1)) 259 | let c0 = Darken x (Mix (Darken (1-r0) Red) (Mix (Darken (1-b0) Blue) (Darken (1-g0) Green))) 260 | c1 = Mix (Darken (1-g1) Green) (Mix (Darken (1-b1) Blue) (Darken (1-r1) Red)) 261 | c = Darken y (Mix c0 c1) 262 | ans = rgb c 263 | f = min 1 264 | x' = 1-x 265 | y' = 1-y 266 | return $ counterexample (show c) $ 267 | fcmp ans [y'*(f $ x'*r0+r1), 268 | y'*(f $ x'*g0+g1), 269 | y'*(f $ x'*b0+b1)] 270 | -------------------------------------------------------------------------------- /W4Test.hs: -------------------------------------------------------------------------------- 1 | module W4Test where 2 | 3 | import W4 4 | import Impl.Test 5 | 6 | import Control.Monad 7 | import Data.List 8 | import Data.IORef 9 | import System.IO 10 | import System.Directory 11 | 12 | import Test.QuickCheck hiding (Result,reason,(===)) 13 | import Test.QuickCheck.Monadic 14 | 15 | main = testExsArgs tests stdArgs {maxSize = 40, maxSuccess = 40} 16 | 17 | tests = [[ex1_hello] 18 | ,[ex2_greet] 19 | ,[ex3_greet2] 20 | ,[ex4_readWords] 21 | ,[ex5_readUntil] 22 | ,[ex6_printFibs] 23 | ,[ex7_isums] 24 | ,[ex8_whenM_True, ex8_whenM_False] 25 | ,[ex9_while] 26 | ,[ex10_debug] 27 | ,[ex11_mapM_] 28 | ,[ex12_forM] 29 | ,[ex13_doubleCall] 30 | ,[ex14_compose] 31 | ,[ex15_mkCounter] 32 | ,[ex16_hFetchLines] 33 | ,[ex17_readCSV] 34 | ,[ex18_compareFiles] 35 | ,[ex19_interact_terminates, ex19_interact_loop] 36 | ] 37 | 38 | -- -- -- -- -- 39 | 40 | ex1_hello = monadicIO $ do 41 | (text,()) <- runc' hello 42 | stop_ $ text === "HELLO\nWORLD\n" 43 | 44 | word = listOf1 (choose ('a','z')) 45 | 46 | ex2_greet = monadicIO $ do 47 | name <- pick word 48 | (text,()) <- runc' $ greet name 49 | stop_ $ text === ("HELLO "++name++"\n") 50 | 51 | ex3_greet2 = monadicIO $ do 52 | name <- pick word 53 | (text,()) <- runc (name++"\n") greet2 54 | stop_ $ text === ("HELLO "++name++"\n") 55 | 56 | ex4_readWords = monadicIO $ do 57 | words <- pick $ listOf1 word 58 | (_,ret) <- runc (unlines words) (readWords (length words - 1)) 59 | stop_ $ ret === sort (init words) 60 | 61 | ex5_readUntil = monadicIO $ do 62 | end <- pick word 63 | words <- pick $ listOf1 (word `suchThat` (/=end)) 64 | let input = unlines $ words ++ [end] 65 | (_,ret) <- runc input (readUntil (==end)) 66 | stop_ . counterexample ("readUntil (==" ++ show end ++ ")\nInput: "++show input) $ 67 | ret === words 68 | 69 | ex6_printFibs = monadicIO $ do 70 | n <- pick $ choose (0,40) 71 | (text,_) <- runc' $ printFibs n 72 | stop_ . counterexample ("printFibs "++show n) $ 73 | text === unlines (map show (take n fibs)) 74 | where fibs = 1:1:zipWith (+) fibs (tail fibs) 75 | 76 | ex7_isums = monadicIO $ do 77 | numbers <- pick . listOf1 $ choose (-10,10) 78 | let n = length numbers 79 | (text,ret) <- runc (unlines $ map show numbers) $ isums n 80 | stop_ . counterexample ("isums "++show n) $ 81 | conjoin [counterexample "returning" $ 82 | ret === sum numbers, 83 | counterexample "printing" $ 84 | text === unlines (map show $ scanl1 (+) numbers)] 85 | 86 | ex8_whenM_True = monadicIO $ do 87 | r <- run $ newIORef False 88 | let op = writeIORef r True 89 | let cond = return True 90 | run $ whenM cond op 91 | v <- run $ readIORef r 92 | stop_ $ counterexample "whenM (return True)" $ 93 | v 94 | 95 | ex8_whenM_False = monadicIO $ do 96 | r <- run $ newIORef False 97 | let op = writeIORef r True 98 | let cond = return False 99 | run $ whenM cond op 100 | v <- run $ readIORef r 101 | stop_ $ counterexample "whenM (return False)" $ 102 | not v 103 | 104 | ex9_while = monadicIO $ do 105 | i <- pick $ choose (0,10 :: Int) 106 | a <- run $ newIORef 0 107 | b <- run $ newIORef 0 108 | let ehto = modifyIORef a (+1) >> fmap (<=i) (readIORef a) 109 | op = modifyIORef b (+1) 110 | run $ while ehto op 111 | af <- run $ readIORef a 112 | bf <- run $ readIORef b 113 | stop_ $ counterexample "while" $ 114 | conjoin [counterexample "number of calls to condition" $ af === i+1, 115 | counterexample "number of calls to operation" $ bf === i] 116 | 117 | ex10_debug = monadicIO $ do 118 | token <- pick word 119 | value <- pick word 120 | print <- pick word 121 | (text,ret) <- runc' $ debug token (putStrLn print >> return value) 122 | stop_ $ counterexample ("debug "++show token++" (do putStrLn "++show print++"; return "++show value++")") $ 123 | conjoin [counterexample "tulostus" $ text === (token ++ "\n" ++ print ++ "\n" ++ token ++ "\n"), 124 | counterexample "palautus" $ ret === value] 125 | 126 | ex11_mapM_ = monadicIO $ do 127 | r <- run $ (newIORef [] :: IO (IORef [Int])) 128 | lis <- pick $ listOf1 arbitrary 129 | let op x = modifyIORef r (x:) 130 | run $ mymapM_ op lis 131 | ret <- run $ readIORef r 132 | stop_ $ counterexample ("mapM op "++show lis) $ 133 | ret === reverse lis 134 | 135 | ex12_forM = monadicIO $ do 136 | r <- run $ (newIORef [] :: IO (IORef [Int])) 137 | lis <- pick $ listOf1 arbitrary 138 | let op x = do modifyIORef r (x:) 139 | return $ x+1 140 | ret <- run $ myforM lis op 141 | out <- run $ readIORef r 142 | stop_ $ counterexample ("forM "++show lis++" op") $ 143 | conjoin [counterexample "return value" $ ret === map (+1) lis, 144 | counterexample "side effects" $ out === reverse lis] 145 | 146 | ex13_doubleCall = monadicIO $ do 147 | i <- pick $ (choose (0,20) :: Gen Int) 148 | let op = return (return i) 149 | out <- run $ doubleCall $ op 150 | stop_ $ counterexample ("doubleCall (return (return "++show i++"))") $ 151 | out === i 152 | 153 | ex14_compose = monadicIO $ do 154 | i <- pick $ (choose (0,20) :: Gen Int) 155 | let op1 = return . (*2) 156 | op2 = return . (+1) 157 | out <- run $ compose op1 op2 i 158 | stop_ $ counterexample "compose (return . (*2)) (return . (+1))" $ 159 | out === (i+1)*2 160 | 161 | ex15_mkCounter = monadicIO $ do 162 | n <- pick $ choose (0,20) 163 | m <- run $ do (i,g) <- mkCounter 164 | replicateM_ n i 165 | g 166 | stop_ $ m === n 167 | 168 | ex16_hFetchLines = monadicIO $ do 169 | lines <- pick $ listOf1 word 170 | inds <- fmap (nub.sort) . pick . listOf1 $ choose (1,length lines) 171 | 172 | dir <- run $ getTemporaryDirectory 173 | (path,h) <- run $ openTempFile dir "hFetchLines.in" 174 | run $ hPutStr h $ unlines lines 175 | run $ hSeek h AbsoluteSeek 0 176 | 177 | outs <- run $ hFetchLines h inds 178 | 179 | stop_ $ counterexample ("hFetchLines h "++show inds++"\nContents:\n"++unlines lines) $ 180 | conjoin [outs !! j === lines !! (i-1) | (j,i) <- zip [0..] inds] 181 | 182 | toCSV = unlines . map (intercalate ",") 183 | 184 | tmpSpit pattern conts = do 185 | dir <- getTemporaryDirectory 186 | (path,h) <- openTempFile dir pattern 187 | hPutStr h conts 188 | hClose h 189 | return path 190 | 191 | ex17_readCSV = monadicIO $ do 192 | dat <- pick $ listOf1 (listOf1 word) 193 | let dat' = toCSV dat 194 | path <- run $ tmpSpit "readCSV.in" dat' 195 | ret <- run $ readCSV path 196 | stop_ $ counterexample ("File contents: "++show dat') $ ret === dat 197 | 198 | ex18_compareFiles = monadicIO $ do 199 | alines <- pick $ listOf1 word 200 | lines2 <- pick $ vectorOf (length alines) word 201 | diffs <- pick $ fmap (nub.sort) $ listOf1 (choose (0,length alines-1)) 202 | let blines = [ if elem i diffs then s1++s2 else s1 | (i,s1,s2) <- zip3 [0..] alines lines2] 203 | ac = unlines alines 204 | bc = unlines blines 205 | should = concatMap (\i -> ["< "++alines!!i,"> "++alines!!i++lines2!!i]) diffs 206 | path1 <- run $ tmpSpit "compareFilesA.in" ac 207 | path2 <- run $ tmpSpit "compareFilesB.in" bc 208 | (outp,()) <- runc' $ compareFiles path1 path2 209 | let ls = lines outp 210 | stop_ $ counterexample ("compareFiles\nFile A:\n"++ac++"File B:\n"++bc) $ 211 | conjoin [counterexample "number of lines printed" $ length ls === 2*length diffs, 212 | counterexample "lines printed" $ ls === should] 213 | 214 | ex19_interact_terminates = monadicIO $ do 215 | let f :: (String,String) -> (Bool,String,String) 216 | f (s,_) = (False,s,s) 217 | w <- pick $ word 218 | (text,ret) <- runc w $ interact' f "" 219 | stop_ $ conjoin [counterexample "tulostus" $ text === w, 220 | counterexample "palautus" $ ret === w] 221 | 222 | ex19_interact_loop = monadicIO $ do 223 | is <- pick $ listOf1 (arbitrary :: Gen Int) 224 | let f :: (String,[Int]) -> (Bool,String,[Int]) 225 | f ("END",lis) = (False,"END\n", lis) 226 | f (x,lis) = (True, "PICK\n", read x : lis) 227 | eret = reverse $ 0:is 228 | etext = unlines $ replicate (length is) "PICK" ++ ["END"] 229 | (text,ret) <- runc (unlines $ map show is ++ ["END"]) $ interact' f [0] 230 | stop_ $ conjoin [counterexample "printing" $ text === etext, 231 | counterexample "return value" $ ret === eret] 232 | -------------------------------------------------------------------------------- /W5Test.hs: -------------------------------------------------------------------------------- 1 | module W5Test where 2 | 3 | import W5 4 | import Impl.Test 5 | 6 | import Data.List 7 | import Data.Maybe 8 | import System.Random 9 | 10 | import Test.QuickCheck hiding (Result,reason,classify,Failure,(===)) 11 | 12 | main = testExs tests 13 | 14 | x = property False 15 | 16 | tests = [[property ex1_1, property ex1_2] 17 | ,[ex2] 18 | ,[ex3] 19 | ,[property ex4_eq, property ex4_neq, property ex4_len] 20 | ,[ex5] 21 | ,[ex6] 22 | ,[ex7] 23 | ,[property ex8_eq, property ex8_neq] 24 | ,[property ex9_bops, property ex9_sops, property ex9_fI] 25 | ,[property ex10_1, property ex10_2] 26 | ,[ex11_1, ex11_2] 27 | ,[property ex12_eq, property ex12_neq] 28 | ,[property ex13_list, property ex13_maybe] 29 | ,[property ex14_num, ex14_empties] 30 | ,[property ex15_num, property ex15_bool] 31 | ,[property ex16_1, property ex16_2] 32 | ,[ex17] 33 | ,[ex18] 34 | ] 35 | 36 | -- -- -- -- -- -- -- -- 37 | 38 | ex1_1 a b = a %$ b === (a ++ b ++ a) 39 | 40 | ex1_2 :: NonNegative Int -> Int -> Property 41 | ex1_2 (NonNegative n) v = 42 | counterexample (show n ++ " *! " ++ show v) $ 43 | conjoin [counterexample "length" $ length res === n 44 | ,counterexample "values" $ all (==v) res] 45 | where res = n *! v 46 | 47 | m_t2 input exp = counterexample (show input) $ allEqual input === exp 48 | 49 | g_t2 input = let x = input++[False,True] in m_t2 x False 50 | 51 | ex2 = conjoin [m_t2 ([] :: [Bool]) True 52 | ,m_t2 [True] True 53 | ,m_t2 [0] True 54 | ,m_t2 [0,0,0] True 55 | ,m_t2 [0,0,1] False 56 | ,property g_t2 57 | ] 58 | 59 | m_t3 input = 60 | length input > 2 ==> 61 | case secondSmallest input of 62 | Just s -> 63 | property $ 64 | length (filter ( 1) 66 | Nothing -> property $ counterexample "expected Just, was Nothing" False 67 | 68 | ex3 = (m_t3 :: [Int] -> Property) 69 | .&. (m_t3 :: [Double] -> Property) 70 | .&. counterexample (show [1]) (secondSmallest ([1] :: [Int]) == Nothing) 71 | 72 | ex4_eq :: [Integer] -> Property 73 | ex4_eq xs = 74 | counterexample ("findDifference "++show xs++" "++show xs) $ 75 | isNothing (findDifference xs xs) 76 | 77 | ex4_neq (NonEmpty bs) = property $ 78 | do 79 | i <- choose (0,length bs - 2) 80 | let (a,x:b) = splitAt i bs 81 | bs' = a ++ not x : b 82 | in return $ counterexample ("findDifference "++show bs++" "++show bs') $ 83 | case findDifference bs bs' of 84 | Nothing -> counterexample "was Nothing, expected Just" False 85 | Just s -> s === (show x ++ " /= " ++ show (not x)) 86 | 87 | ex4_len :: [Char] -> [Char] -> Property 88 | ex4_len s s' = 89 | l /= l' ==> counterexample ("findDifference "++show s++" "++show s') (findDifference s s' === Just err) 90 | where l = length s 91 | l' = length s' 92 | err = show l ++ " /= " ++ show l' 93 | 94 | m_t5 input exp = 95 | counterexample (show input) $ 96 | average input === exp 97 | 98 | ex5 = m_t5 [1,2,3] 2 99 | .&. m_t5 [9,9,9,9] 9 100 | .&. m_t5 [1,2,3,4] 2.5 101 | .&. m_t5 (replicate 10 1 ++ replicate 10 2) 1.5 102 | 103 | m_t6 x y exp = 104 | counterexample (show x ++ " == " ++ show y) $ 105 | (x == y) === exp 106 | 107 | ex6 = m_t6 Bar Bar True 108 | .&. m_t6 Quux Quux True 109 | .&. m_t6 Xyzzy Xyzzy True 110 | .&. m_t6 Bar Quux False 111 | .&. m_t6 Bar Xyzzy False 112 | .&. m_t6 Quux Bar False 113 | .&. m_t6 Quux Xyzzy False 114 | .&. m_t6 Xyzzy Bar False 115 | .&. m_t6 Xyzzy Quux False 116 | 117 | ex7 = conjoin 118 | [Quux ?<= Quux, Quux ?<= Bar, Quux ?<= Xyzzy 119 | ,Bar ?<= Bar, Bar ?<= Xyzzy 120 | ,Xyzzy ?<= Xyzzy 121 | ,Bar ?> Quux 122 | ,Xyzzy ?> Bar, Xyzzy ?> Quux 123 | ,counterexample ("compare Bar Xyzzy") (compare Bar Xyzzy === LT) 124 | ,counterexample ("compare Quux Quux") (compare Quux Quux === EQ) 125 | ,counterexample ("Xyzzy > Quux") ((Xyzzy > Quux) === True) 126 | ,counterexample ("min Xyzzy Bar") (min Xyzzy Bar === Bar) 127 | ,counterexample ("max Bar Quux") (max Bar Quux === Bar) 128 | ,counterexample ("compare Xyzzy Xyzzy") (compare Xyzzy Xyzzy == EQ) 129 | ,counterexample ("compare Bar Bar") (compare Bar Bar == EQ)] 130 | where x ?<= y = counterexample (show x ++ " <= " ++ show y) ((x <= y) == True) 131 | x ?> y = counterexample (show x ++ " > " ++ show y) ((x > y) == True) 132 | 133 | ex8_eq a b c = 134 | let v = Vector a b c in 135 | counterexample (show v ++ " == " ++ show v) $ 136 | (v == v) === True 137 | 138 | ex8_neq a b c d e f = 139 | let v = Vector a b c 140 | v2 = Vector d e f 141 | in counterexample (show v ++ " == " ++ show v2) $ 142 | (v == v2) === ((a,b,c)==(d,e,f)) 143 | 144 | ex9_bops a b c d e f = 145 | let v1 = Vector a b c 146 | v2 = Vector d e f 147 | g0 (Vector a _ _) = a 148 | g1 (Vector _ a _) = a 149 | g2 (Vector _ _ a) = a 150 | in conjoin 151 | [counterexample (show v1 ++ " + " ++ show v2) $ 152 | conjoin [g0 (v1+v2) === a+d 153 | ,g1 (v1+v2) === b+e 154 | ,g2 (v1+v2) === c+f] 155 | ,counterexample (show v1 ++ " * " ++ show v2) $ 156 | conjoin [g0 (v1*v2) === a*d 157 | ,g1 (v1*v2) === b*e 158 | ,g2 (v1*v2) === c*f] 159 | ,counterexample (show v1 ++ " - " ++ show v2) $ 160 | conjoin [g0 (v1-v2) === a-d 161 | ,g1 (v1-v2) === b-e 162 | ,g2 (v1-v2) === c-f] 163 | ] 164 | 165 | ex9_sops a b c = 166 | let v = Vector a b c 167 | g0 (Vector a _ _) = a 168 | g1 (Vector _ a _) = a 169 | g2 (Vector _ _ a) = a 170 | in conjoin 171 | [counterexample ("abs ("++show v++")") $ 172 | conjoin [g0 (abs v) === abs a 173 | ,g1 (abs v) === abs b 174 | ,g2 (abs v) === abs c] 175 | ,counterexample ("signum ("++show v++")") $ 176 | conjoin [g0 (signum v) === signum a 177 | ,g1 (signum v) === signum b 178 | ,g2 (signum v) === signum c] 179 | ,counterexample ("negate ("++show v++")") $ 180 | conjoin [g0 (negate v) === negate a 181 | ,g1 (negate v) === negate b 182 | ,g2 (negate v) === negate c]] 183 | 184 | ex9_fI a = 185 | fromIntegral a === Vector a a a 186 | 187 | ex10_1 bs = 188 | let out = freqs bs 189 | (t,f) = partition id bs 190 | in (counterexample "number of True values" $ 191 | null t || (length t,True) `elem` out) 192 | .&. 193 | (counterexample "number of False values" $ 194 | null f || (length f,False) `elem` out) 195 | 196 | ex10_2 :: [Integer] -> Property 197 | ex10_2 is = 198 | let out = freqs is 199 | vals = nub is 200 | in (counterexample "return list length" $ 201 | length out === length vals) 202 | .&&. 203 | (foldl (.&&.) (property True) $ map (ck out is) vals) 204 | where ck out vals i = let exp = length (filter (==i) vals) 205 | in counterexample ("Does the result "++show out++" contain "++show(exp,i)) $ (exp,i) `elem` out 206 | 207 | genTree :: Int -> Gen ITree 208 | genTree 0 = return ILeaf 209 | genTree siz = do 210 | let siz' = siz-1 211 | sizl <- choose (0,siz') 212 | let sizr = siz'-sizl 213 | l <- genTree sizl 214 | r <- genTree sizr 215 | v <- choose (0,10) 216 | return $ INode v l r 217 | 218 | modTree :: ITree -> Gen ITree 219 | modTree ILeaf = do 220 | s <- choose (1,5) 221 | t <- genTree s 222 | return $ t 223 | modTree (INode x l r) = 224 | oneof [return ILeaf, 225 | do x' <- choose (0,10) `suchThat` (/=x) 226 | return $ INode x' l r, 227 | do l' <- modTree l 228 | return $ INode x l' r, 229 | do r' <- modTree r 230 | return $ INode x l r'] 231 | 232 | ex11_1 = 233 | forAllShrink (choose (0,20)) shrink $ \s -> 234 | do t <- genTree s 235 | return $ counterexample (show t ++ "\n ==\n"++show t) $ (t==t) == True 236 | 237 | ex11_2 = 238 | forAllShrink (choose (0,20)) shrink $ \s -> 239 | do t <- genTree s 240 | t2 <- modTree t 241 | return $ counterexample (show t ++ "\n ==\n"++show t2) $ (t==t2) == False 242 | 243 | ex12_eq :: [Bool] -> Property 244 | ex12_eq xs = 245 | let l = foldr LNode Empty xs in 246 | counterexample (show l ++ " == " ++ show l) $ 247 | (l == l) === True 248 | 249 | ex12_neq :: [Integer] -> [Integer] -> Property 250 | ex12_neq xs ys = 251 | let l = foldr LNode Empty xs 252 | l2 = foldr LNode Empty ys 253 | in 254 | counterexample (show l ++ " == "++ show l2) $ 255 | (l == l2) === (xs == ys) 256 | 257 | ex13_list :: [Integer] -> Property 258 | ex13_list xs = counterexample (show xs) $ 259 | incrementAll xs === map (+1) xs 260 | 261 | ex13_maybe :: Maybe Integer -> Property 262 | ex13_maybe m = counterexample (show m) $ 263 | incrementAll m === case m of Nothing -> Nothing 264 | Just x -> Just (x+1) 265 | 266 | ex14_num k = 267 | counterexample ("fmap (+1) (MkResult "++show k) $ 268 | fmap (+(1::Int)) (MkResult k) === MkResult (k+1) 269 | 270 | ex14_empties = 271 | (counterexample ("fmap not NoResult") $ 272 | fmap not NoResult === NoResult) 273 | .&. 274 | (counterexample ("fmap not (Fail \"moi\")") $ 275 | fmap not (Failure "moi") === Failure "moi") 276 | 277 | ex15_num :: [Int] -> Property 278 | ex15_num xs = 279 | let l = foldr LNode Empty xs in 280 | counterexample ("fmap (+1) "++show l) $ 281 | ck (fmap (+1) l) (map (+1) xs) 282 | 283 | ex15_bool bs = 284 | let l = foldr LNode Empty bs in 285 | counterexample ("fmap not "++show l) $ 286 | ck (fmap not l) (map not bs) 287 | 288 | ck :: (Eq a, Show a) => List a -> [a] -> Property 289 | ck Empty [] = property True 290 | ck (LNode x xs) (y:ys) = (x === y) .&&. ck xs ys 291 | ck Empty ys = counterexample "Result list ended too soon!" False 292 | ck xs [] = counterexample "Result list was too long!" False 293 | 294 | ex16_1 i = 295 | counterexample ("runFun (fmap not (Fun even)) "++show i) $ 296 | runFun (fmap not (Fun even)) i === odd i 297 | 298 | ex16_2 i = 299 | counterexample ("runFun (fmap (*2) (Fun (\\i -> i))) "++show i) $ 300 | runFun (fmap (*2) (Fun id)) i === 2*i 301 | 302 | ex17 = property $ 303 | do s <- choose (0,10) 304 | let g = mkStdGen s 305 | (a,b,c) = threeRandom g :: (Int,Int,Int) 306 | return $ counterexample ("values were not different: threeRandom (mkStdGen "++show s++")") $ 307 | conjoin [a/=b, 308 | a/=c, 309 | b/=c] 310 | 311 | shape :: (Show a, Show b) => Tree a -> Tree b -> Property 312 | shape Leaf Leaf = property $ True 313 | shape (Node _ l r) (Node _ l' r') = 314 | conjoin [shape l l', 315 | shape r r'] 316 | shape x y = counterexample ("Trees don't have the same shape:\n"++show x++"\n"++show y) 317 | False 318 | 319 | genTree' :: Int -> Gen (Tree Bool) 320 | genTree' 0 = return Leaf 321 | genTree' siz = do 322 | let siz' = siz-1 323 | sizl <- choose (0,siz') 324 | let sizr = siz'-sizl 325 | l <- genTree' sizl 326 | r <- genTree' sizr 327 | v <- arbitrary 328 | return $ Node v l r 329 | 330 | v Leaf = [] 331 | v (Node x l r) = x : v l ++ v r 332 | 333 | ex18 = forAllShrink (choose (0,10)) shrink $ \siz -> 334 | do s <- choose (0,10) 335 | t <- genTree' siz 336 | let g = mkStdGen s 337 | (t',_) = randomizeTree t g :: (Tree Int,StdGen) 338 | vals = v t' 339 | return $ counterexample ("randomizeTree ("++show t++") (mkStdGen "++show s++")") $ 340 | conjoin [shape t t' 341 | ,counterexample "values were not different" $ vals == nub vals] 342 | -------------------------------------------------------------------------------- /W6Test.hs: -------------------------------------------------------------------------------- 1 | module W6Test where 2 | 3 | import W6 4 | 5 | import Data.List 6 | import Data.Char 7 | import Data.Either 8 | import Data.Ord 9 | import Control.Monad.Trans.State 10 | 11 | import Impl.Test 12 | import Test.QuickCheck hiding (Result,reason,classify,Failure,(===)) 13 | 14 | main = testExs tests 15 | 16 | tests :: [[Property]] 17 | tests = [[property ex1_ok, property ex1_fail] 18 | ,[property ex2_ok, property ex2_fail] 19 | ,[property ex3_ok, property ex3_fail] 20 | ,[property ex4_1, property ex4_2, property ex4_3] 21 | ,[property ex5] 22 | ,[property ex6] 23 | ,[property ex7] 24 | ,[property ex8] 25 | ,[property ex9_Maybe, property ex9_State] 26 | ,[property ex10] 27 | ,[property ex11_dfs_1, property ex11_dfs_2 28 | ,property ex11_routeExists_basic, property ex11_routeExists] 29 | ,[property ex12_1, property ex12_2] 30 | ,[property ex13] 31 | ,[property ex14_sumBounded_ok, property ex14_sumBounded_fail 32 | ,property ex14_sumNotTwice] 33 | ,[property ex15] 34 | ,[property ex16_1, property ex16_2, property ex16_stress] 35 | ] 36 | 37 | -- -- -- -- -- -- -- -- 38 | 39 | word = do fst <- choose ('A','Z') 40 | rest <- listOf (choose ('a','z')) 41 | return $ fst:rest 42 | 43 | bad = do a <- choose ('A','Z') 44 | b <- word 45 | c <- elements "0123456789" 46 | d <- word 47 | return $ a:b++c:d 48 | 49 | ex1_ok = do 50 | for <- word 51 | sur <- word 52 | let str = for++" "++sur 53 | counterexample' ("readNames "++show str) $ 54 | readNames str === Just (for,sur) 55 | 56 | m_ex1_fail s = 57 | counterexample ("readNames "++show s) $ readNames s === Nothing 58 | 59 | ex1_fail = 60 | do for <- word 61 | sur <- word 62 | b <- bad 63 | return $ conjoin [m_ex1_fail (for ++ sur), 64 | m_ex1_fail (map toLower for ++ " " ++ sur), 65 | m_ex1_fail (for ++ " " ++ map toLower sur), 66 | m_ex1_fail (for ++ b ++ " " ++ sur), 67 | m_ex1_fail (for ++ " " ++ sur ++ b)] 68 | 69 | ex2_ok = do 70 | as <- listOf1 arbitrary :: Gen [Int] 71 | i <- choose (0,length as) 72 | let ml = Just as 73 | mi = Just i 74 | counterexample' ("myTake ("++show mi++") ("++show ml++")") $ 75 | myTake mi ml === Just (take i as) 76 | 77 | ex2_fail = do 78 | as <- listOf1 arbitrary :: Gen [Int] 79 | i <- choose (length as+1,length as+5) 80 | let ml = Just as 81 | mi = Just i 82 | return $ conjoin [counterexample' ("myTake ("++show mi++") ("++show ml++")") $ 83 | myTake mi ml === Nothing, 84 | counterexample' ("myTake Nothing ("++show ml++")") $ 85 | myTake Nothing ml === Nothing, 86 | counterexample' ("myTake ("++show mi++") Nothing") $ 87 | myTake mi (Nothing :: Maybe String) === Nothing] 88 | 89 | ex3_ok = do 90 | as <- listOf1 arbitrary :: Gen [Integer] 91 | is <- listOf (choose (0,length as - 1)) 92 | counterexample' ("selectSum "++show as++" "++show is) $ 93 | selectSum as is === Just (sum $ map (as!!) is) 94 | 95 | ex3_fail = do 96 | as <- arbitrary :: Gen [Int] 97 | is1 <- listOf (choose (0,length as - 1)) 98 | is2 <- listOf (choose (0,length as - 1)) 99 | b <- elements [-1,length as] 100 | let is = is1++b:is2 101 | counterexample' ("selectSum "++show as++" "++show is) $ 102 | selectSum as is === Nothing 103 | 104 | b n k = case (n,k) of (_,0) -> 1 105 | (0,_) -> 0 106 | (n,k) -> b (n-1) (k-1) + b (n-1) k 107 | 108 | ex4_1 = do 109 | n <- choose (0,7) 110 | k <- choose (0,n) 111 | let Logger _ res = binom n k 112 | counterexample' ("Return value of binom "++show n++" "++show k) $ 113 | res === b n k 114 | 115 | ex4_2 = do 116 | n <- choose (0,7) 117 | k <- choose (0,n) 118 | let Logger log _ = binom n k 119 | counterexample' ("Log of binom "++show n++" "++show k) $ 120 | conjoin [counterexample' "log should not be empty" $ 121 | not $ null log, 122 | counterexample' "last message of log" $ 123 | last log === ("B("++show n++","++show k++")"), 124 | counterexample' "first message of log" $ 125 | head log === ("B("++show (n-k)++",0)")] 126 | 127 | 128 | 129 | ex4_3 = 130 | conjoin [t 2 2 ["B(0,0)","B(0,1)","B(1,1)","B(0,1)","B(0,2)","B(1,2)","B(2,2)"], 131 | t 2 7 ["B(0,5)","B(0,6)","B(1,6)","B(0,6)","B(0,7)","B(1,7)","B(2,7)"], 132 | t 3 3 ["B(0,0)","B(0,1)","B(1,1)","B(0,1)","B(0,2)","B(1,2)","B(2,2)","B(0,1)","B(0,2)","B(1,2)","B(0,2)","B(0,3)","B(1,3)","B(2,3)","B(3,3)"], 133 | t 4 3 ["B(1,0)","B(0,0)","B(0,1)","B(1,1)","B(2,1)","B(0,0)","B(0,1)","B(1,1)","B(0,1)","B(0,2)","B(1,2)","B(2,2)","B(3,2)","B(0,0)","B(0,1)","B(1,1)","B(0,1)","B(0,2)","B(1,2)","B(2,2)","B(0,1)","B(0,2)","B(1,2)","B(0,2)","B(0,3)","B(1,3)","B(2,3)","B(3,3)","B(4,3)"]] 134 | where t n k log = counterexample' ("binom "++show n++" "++show k) $ let Logger l _ = binom n k in l===log 135 | 136 | ex5 i = counterexample' ("runState update "++show i) $ 137 | runState update i === ((),2*i+1) 138 | 139 | ex6 bs = counterexample' ("runState (lengthAndCount True "++show bs++") 0") $ 140 | runState (lengthAndCount True bs) 0 === (length bs, length (filter id bs)) 141 | 142 | ex7 = do 143 | is <- fmap nub $ listOf1 (choose ('a','z') :: Gen Char) 144 | fs <- vectorOf (length is) (choose (1,2048)) 145 | let assocs = zip is fs 146 | x <- elements is 147 | y <- choose ('0','z') `suchThat` \y -> not (elem y is) 148 | let Just cx = lookup x assocs 149 | ((),rx) = runState (count x) assocs 150 | ((),ry) = runState (count y) assocs 151 | s x = "runState (count "++show x++") "++show assocs 152 | return $ conjoin [counterexample' (s y) $ 153 | sort ry === sort ((y,1):assocs), 154 | counterexample' (s x) $ 155 | sort rx === sort ((x,cx+1):delete (x,cx) assocs)] 156 | 157 | ex8 = 158 | forAllShrink (listOf (choose (0,10 :: Integer))) shrink $ \is -> 159 | let (r,_) = runState (occurrences is) [] 160 | ck i = ascs [r !! j | (j,x) <- zip [0..] is, x==i] 161 | ascs xs = xs == [1..length xs] 162 | in all ck (nub is) 163 | 164 | ex9_Maybe :: Maybe Bool -> Maybe Int -> Maybe Int -> Property 165 | ex9_Maybe b t e = ifM b t e === case b of Just True -> t 166 | Just False -> e 167 | Nothing -> Nothing 168 | 169 | ex9_State = do 170 | b <- arbitrary 171 | t <- choose (1,1024 :: Int) 172 | e <- choose (1,1024 :: Int) 173 | counterexample' ("runState (ifM (return "++show b++") (modify (+ "++show t++")) (modify (+ "++show e++"))) 0") $ 174 | runState (ifM (return b) (modify (+t)) (modify (+e))) 0 === ((), if b then t else e) 175 | 176 | ex10 :: [Int] -> [Int] -> Property 177 | ex10 as bs = 178 | counterexample ("mapM2 (\\x y -> if x == y then Nothing else Just (x-y)) "++show as++" "++show bs) $ 179 | mapM2 (\x y -> if x == y then Nothing else Just (x-y)) as bs === res 180 | where z = zipWith (-) as bs 181 | res = if all (/=0) z then Just z else Nothing 182 | 183 | ex11_dfs_1 = do 184 | let cs = [[1],[0,2],[1,3],[2,4],[3,5],[4]] 185 | i <- choose (1,length cs - 1) 186 | let st = [0..i-1] 187 | counterexample' ("runState (dfs "++show cs++" "++show i++") "++show st) $ 188 | let ((),res) = runState (dfs cs i) st 189 | in sort res === [0..5] 190 | 191 | ex11_dfs_2 = do 192 | let cs = [[1,4],[0,2],[1,3],[2,4],[3,0]] 193 | i <- choose (1,length cs - 1) 194 | counterexample' ("runState (dfs "++show cs++" "++show i++") []") $ 195 | let ((),res) = runState (dfs cs i) [] 196 | in sort res === [0..4] 197 | 198 | ex11_routeExists_basic = do 199 | siz <- choose (2,5) 200 | let cs = map (\i -> delete i [0..siz-1]) [0..siz-1] 201 | a <- choose (0,siz-1) 202 | b <- choose (0,siz-1) 203 | counterexample' ("routeExists "++show cs++" "++show a++" "++show b) $ 204 | routeExists cs a b === True 205 | 206 | shuffle xs = do 207 | is <- vector (length xs) :: Gen [Int] 208 | return $ map snd . sortBy (comparing fst) $ zip is xs 209 | 210 | 211 | genGraph' :: [Int] -> [Int] -> [(Int,Int)] -> Gen [(Int,Int)] 212 | genGraph' is [] es = return es 213 | genGraph' is todo es = do 214 | u <- elements $ todo 215 | v <- elements $ is \\ todo 216 | genGraph' is (delete u todo) ((u,v):(v,u):es) 217 | 218 | genGraph :: [Int] -> Gen [(Int,Int)] 219 | genGraph is = do 220 | base <- genGraph' is (tail is) [] 221 | [a,b,c] <- vectorOf 3 (elements is) 222 | return $ (a,b):(b,c):base 223 | 224 | mkGraph es = map neighs [0..n] 225 | where n = maximum (map fst es ++ map snd es) 226 | neighs i = nub $ sort $ map snd $ filter (\(x,_) -> x==i) es 227 | 228 | ex11_routeExists = do 229 | siz <- choose (5,7) 230 | k <- choose (2,siz-2) 231 | left <- genGraph [0..k] 232 | right <- genGraph [k+1..siz-1] 233 | i <- choose (0,siz-1) 234 | j <- choose (0,siz-1) 235 | let cities = mkGraph (left++right) 236 | counterexample' (show left++"\n"++show right++"\n"++"routeExists "++show cities++" "++show i++" "++show j) $ 237 | routeExists cities i j === ((i<=k) == (j<=k)) 238 | 239 | m is = maximum (scanl1 (+) is) 240 | 241 | ex12_1 = do 242 | let n = 6 243 | is <- vectorOf n (choose (0,10)) 244 | i <- choose (0,n-2) 245 | j <- choose (i+1,n-1) 246 | let a = is!!i 247 | b = is!!j 248 | ret = orderedPairs is 249 | counterexample' ("orderedPairs "++show is) $ 250 | if a 276 | let k = m is + 1 277 | in counterexample' ("sumBounded "++show k++" "++show is) $ 278 | sumBounded k is === Just (sum is) 279 | 280 | ex14_sumBounded_fail = 281 | forAll (listOf1 (choose (-10,10))) $ \is -> 282 | let k = m is - 1 283 | in counterexample' ("sumBounded "++show k++" "++show is) $ 284 | sumBounded k is === Nothing 285 | 286 | ex14_sumNotTwice is = 287 | sumNotTwice is === sum (nub is) 288 | 289 | ex15 = 290 | let op :: Int -> Result Int 291 | op i = if i>3 then fail "big" else return (i+1) 292 | s = "let op i = if (i>3) then fail \"big\" else return (i+1) in " 293 | in conjoin [counterexample' (s++" MkResult 1 >>= op") $ 294 | (MkResult 1 >>= op) === MkResult 2, 295 | counterexample' (s++" MkResult 4 >>= op") $ 296 | (MkResult 4 >>= op) === Failure "big", 297 | counterexample' (s++" Fail \"foo\" >>= op") $ 298 | (Failure "foo" >>= op) === Failure "foo", 299 | counterexample' (s++" NoResult >>= op") $ 300 | (NoResult >>= op) === NoResult] 301 | 302 | ex16_fmap_1 = 303 | do i <- choose (0,10) 304 | let op = fmap (+1) getSL 305 | counterexample' ("runSL (fmap (+1) getSL) " ++ show i) $ 306 | runSL op i === (i,i+1,[]) 307 | 308 | ex16_fmap_2 = 309 | do m <- word 310 | s <- choose (0,10) 311 | let op = fmap (const True) (msgSL m) 312 | counterexample' ("runSL (fmap (const True) (msgSL "++show m++")) "++show s) $ 313 | runSL op s === (True,s,[m]) 314 | 315 | ex16_1 = 316 | do i <- choose (0,10) 317 | let op = putSL i >> getSL >>= \i -> msgSL (show i) 318 | s = "putSL "++show i++" >> getSL >>= \\i -> msgSL (show i)" 319 | counterexample' ("runSL ("++s++") 1") $ runSL op 1 === ((),i,[show i]) 320 | 321 | ex16_2 = 322 | do msg <- word 323 | msg2 <- word 324 | i <- choose (0,10) 325 | j <- choose (0,10) 326 | let op = do msgSL msg 327 | x <- getSL 328 | msgSL (msg2++show x) 329 | putSL (x+i) 330 | return x 331 | s = "op = \ndo msgSL "++show msg++"\n x <- getSL\n msgSL ("++show msg2++"++show x)\n putSL (x+"++show i++")\n return x" 332 | counterexample' (s++"\nrunSL op "++show j) $ runSL op j === (j,j+i,[msg,msg2++show j]) 333 | 334 | ex16_stress = 335 | arbitrary >>= \o -> 336 | return . shrinking shrink o $ \ops -> 337 | let m (Left i) = modifySL (+i) 338 | m (Right s) = msgSL s 339 | s (Left i) = "modifySL (+"++show i++")" 340 | s (Right m) = "msgSL "++show m 341 | op = mapM_ m ops 342 | desc = "runSL ("++intercalate " >> " (map s ops)++") 0" 343 | (incs,msgs) = partitionEithers ops 344 | state = sum incs 345 | in counterexample' desc $ runSL op 0 === ((),state,msgs) 346 | -------------------------------------------------------------------------------- /W7Test.hs: -------------------------------------------------------------------------------- 1 | module W7Test where 2 | 3 | import W7 4 | 5 | import Impl.Test 6 | import Data.List 7 | import Data.Ord 8 | import Data.Function 9 | import Control.Monad 10 | import Control.Monad.State 11 | 12 | import Test.QuickCheck hiding (Result,reason,classify,Failure,(===)) 13 | 14 | main = testExs tests -- $forAllProperties (quickCheckWithResult args) 15 | 16 | tests = [[ex1_1, property ex1_2] 17 | ,[property ex2] 18 | ,[property ex3_1, property ex3_2] 19 | ,[property ex4_1, property ex4_2] 20 | ,[property ex5_getters, property ex5_addPoints] 21 | ,[property ex6_height, property ex6_size] 22 | ,[property ex7_eq, property ex7_neq, property ex7_sort] 23 | ,[property ex8_ok, property ex8_fail] 24 | ,[property ex9_maybe, property ex9_state] 25 | ,[property ex10_odds] 26 | ] 27 | 28 | -- -- -- -- -- -- -- -- 29 | 30 | ex1_1 = 31 | conjoin 32 | [pyramid 1 === "*\n" 33 | ,pyramid 2 === " *\n***\n" 34 | ,pyramid 3 === " *\n ***\n*****\n"] 35 | 36 | ex1_2 = forAll (choose (1,25)) $ \n -> 37 | let ls = lines (pyramid n) 38 | in conjoin [counterexample "number of lines" $ length ls === n 39 | ,counterexample "lengths of lines" $ 40 | map length ls === [n,n+1..2*n-1] 41 | ,counterexample "numbers of stars" $ 42 | map (length . filter (=='*')) ls === [1,3..2*n-1] 43 | ,counterexample "all lines consist of spaces followed by stars" $ 44 | all ck0 ls 45 | ] 46 | where 47 | ck0 (' ':xs) = ck0 xs 48 | ck0 ('*':xs) = ck1 xs 49 | ck0 _ = False 50 | ck1 ('*':xs) = ck1 xs 51 | ck1 [] = True 52 | ck1 _ = False 53 | 54 | ex2 :: [Int] -> Property 55 | ex2 xs = everySecond xs === f xs 56 | where f xs = [x | (i,x) <- zip [0..] xs, even i] 57 | 58 | ex3_1 = do 59 | ls <- listOf1 arbitrary :: Gen [Int] 60 | i <- choose (0,length ls-1) 61 | let l = ls !! i 62 | (g,q) = wrap ls 63 | counterexample' ("wrap "++show ls) $ 64 | conjoin [counterexample ("get "++show i) $ 65 | g i === l 66 | ,counterexample ("query "++show l) $ 67 | q l === True] 68 | 69 | ex3_2 = do 70 | ls <- listOf1 arbitrary :: Gen [Int] 71 | l <- arbitrary `suchThat` \i -> not (elem i ls) 72 | let (_,q) = wrap ls 73 | counterexample' ("wrap "++show ls) $ 74 | counterexample' ("query "++show l) $ 75 | q l === False 76 | 77 | ex4_1 = do 78 | starts <- listOf1 (choose (0,10)) 79 | seqs <- forM starts $ \s -> liftM (scanl (+) s) (listOf1 (choose (11,20))) 80 | let l = concat seqs 81 | res = increasings l 82 | counterexample' ("increasings "++show l) $ 83 | res == seqs 84 | 85 | ex4_2 = do 86 | l <- listOf1 (choose (0,20)) 87 | let res = increasings l 88 | return $ conjoin 89 | [counterexample ("concat (increasings "++show l++")") $ 90 | concat res === l 91 | ,counterexample ("increasings "++show l++"\nall increasing") $ 92 | all p res] 93 | where p (x:y:xs) = x node3 t0 t1 t2 140 | 1 -> node3 t0 t2 t1 141 | _ -> node3 t2 t0 t1 142 | 143 | ex6_height = 144 | forAllShrink (choose (0,10::Int)) shrink $ \h -> 145 | do 146 | t <- genH h 147 | counterexample' ("treeHeight ("++show t++")") $ treeHeight t === h 148 | 149 | genS 0 = return leaf 150 | genS s = do 151 | b <- arbitrary 152 | if b then genS2 s else genS3 s 153 | 154 | genS2 s = do 155 | i <- choose (0,s-1) 156 | t0 <- genS i 157 | t1 <- genS (s-1-i) 158 | return $ node2 t0 t1 159 | 160 | genS3 s = do 161 | i <- choose (0,s-1) 162 | t0 <- genS i 163 | j <- choose (0,s-1-i) 164 | t1 <- genS j 165 | t2 <- genS (s-1-i-j) 166 | return $ node3 t0 t1 t2 167 | 168 | ex6_size = 169 | forAllShrink (choose (0,20::Int)) shrink $ \s -> 170 | do 171 | t <- genS s 172 | counterexample' ("treeSize ("++show t++")") $ treeSize t === s 173 | 174 | genExpr = do 175 | i <- choose (0,4::Int) 176 | case i of 4 -> do (e1,v1) <- genExpr 177 | (e2,v2) <- genExpr 178 | return (Plus e1 e2,v1+v2) 179 | 3 -> do (e1,v1) <- genExpr 180 | (e2,v2) <- genExpr `suchThat` \(_,v2) -> v2 /= 0 181 | return (Div e1 e2,v1 `div` v2) 182 | _ -> do c <- choose (-10,10) 183 | return (Constant c, c) 184 | 185 | genExpr' k = do 186 | i <- choose (0,4::Int) 187 | case i of 4 -> do j <- choose (0,k) 188 | e1 <- genExpr' j 189 | e2 <- genExpr' (k-j) 190 | return $ Plus e1 e2 191 | 3 -> do m <- choose (1,4) 192 | fuzz <- choose (0,k `div` 2) 193 | e1 <- genExpr' (k*m+fuzz) 194 | e2 <- genExpr' m 195 | return $ Div e1 e2 196 | _ -> return $ Constant k 197 | 198 | genSucc = fmap fst genExpr 199 | genZero = genExpr' 0 200 | 201 | genFail = do 202 | i <- choose (0,3::Int) 203 | k <- choose (False,True) 204 | case i of 3 -> do e1 <- if k then genSucc else genFail 205 | e2 <- if k then genFail else genSucc 206 | return $ Div e1 e2 207 | 2 -> do e1 <- genSucc 208 | e2 <- genZero 209 | return $ Div e1 e2 210 | _ -> do e1 <- if k then genSucc else genFail 211 | e2 <- if k then genFail else genSucc 212 | return $ Plus e1 e2 213 | 214 | ex7_eq s = counterexample ("fromString "++show s++" == fromString "++show s) $ 215 | (fromString s == fromString s) === True 216 | 217 | ex7_neq s s' = s /= s' ==> counterexample ("fromString "++show s++" == fromString "++show s') 218 | ((fromString s == fromString s') === False) 219 | 220 | word = listOf1 (choose ('a','z')) 221 | 222 | ex7_sort = do 223 | words <- listOf1 word 224 | let res = map toString . sort $ map fromString words 225 | should = concat . map sort . groupBy ((==)`on`length) . sortBy (comparing length) $ words 226 | counterexample' ("map toString (sort (map fromString "++show words++"))") $ 227 | res === should 228 | 229 | ex8_ok = do 230 | (e,v) <- genExpr 231 | counterexample' ("safeEval ("++show e++")") $ 232 | safeEval e === Just v 233 | 234 | ex8_fail = do 235 | e <- genFail 236 | counterexample' ("safeEval ("++show e++")") $ 237 | safeEval e === Nothing 238 | 239 | t1 :: Int -> Int -> Maybe Bool 240 | t1 k x = Just (x>k) 241 | 242 | t2 :: Int -> Int -> State [Int] Bool 243 | t2 k x = do modify (k:) 244 | return (x>k) 245 | 246 | ex9_maybe = do 247 | ts <- listOf1 (choose (0,10)) 248 | i <- choose (maximum ts+1,maximum ts+10) 249 | j <- choose (minimum ts,maximum ts) 250 | let ms = map t1 ts 251 | s = "["++intercalate "," (map f ts)++"]" 252 | f t = "test1 "++show t 253 | d = "test "++s++" " 254 | return $ conjoin [counterexample (d++show i) (test ms i === Just True) 255 | ,counterexample (d++show j) (test ms j === Just False)] 256 | 257 | ex9_state = do 258 | ts <- listOf1 (choose (0,10)) 259 | i <- choose (maximum ts+1,maximum ts+10) 260 | j <- choose (minimum ts,maximum ts) 261 | let ms = map t2 ts 262 | s = "["++intercalate "," (map f ts)++"]" 263 | f t = "test2 "++show t 264 | d i = "runState (test "++s++" "++show i++") []" 265 | ts' = take (length (takeWhile (= 1.10 5 | 6 | library 7 | build-depends: base, directory, QuickCheck == 2.10.1, mtl 8 | default-language: Haskell2010 9 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.4 2 | install-ghc: true 3 | -------------------------------------------------------------------------------- /templ/W1B.hs: -------------------------------------------------------------------------------- 1 | module W1 where 2 | 3 | -- Week 1: 4 | -- * defining functions 5 | -- * basic expressions 6 | -- * pattern matching 7 | -- * recursion 8 | 9 | -- Ex 1: define variables one, two and three. They should all have 10 | -- type Int and values 1, 2 and 3. This exercise has no tests. 11 | 12 | -- Ex 2: define the function double of type Integer->Integer. Double 13 | -- should take one argument and return it multiplied by two. 14 | 15 | double :: Integer -> Integer 16 | #ifdef sol 17 | double x = 2*x 18 | #else 19 | double x = undefined 20 | #endif 21 | 22 | -- Ex 3: define the function quadruple that uses the function double 23 | -- from the previous exercise to return its argument multiplied by 24 | -- four. 25 | 26 | quadruple :: Integer -> Integer 27 | #ifdef sol 28 | quadruple x = double (double x) 29 | #else 30 | quadruple x = undefined 31 | #endif 32 | 33 | -- Ex 4: define the function poly2. It should take four arguments of 34 | -- type Double, a, b, c, and x and return a*x^2+b*x+c. Give poly2 a 35 | -- type signature, i.e. poly2 :: something. 36 | 37 | #ifdef sol 38 | poly2 :: Double -> Double -> Double -> Double -> Double 39 | poly2 a b c x = a*x*x+b*x+c 40 | #else 41 | poly2 = undefined 42 | #endif 43 | 44 | -- Ex 5: define the function eeny that returns "eeny" for even inputs 45 | -- and "meeny" for odd inputs. 46 | -- 47 | -- Ps. have a look at the built in function "even" 48 | 49 | eeny :: Integer -> String 50 | #ifdef sol 51 | eeny i = if even i then "eeny" else "meeny" 52 | #else 53 | eeny = undefined 54 | #endif 55 | 56 | -- Ex 6: fizzbuzz! Define the a function fizzbuzz that returns "Fizz" 57 | -- for numbers divisible by 3, "Buzz" for numbers divisible by 5, and 58 | -- "FizzBuzz" for numbers divisible by both. For other numbers it 59 | -- returns the empty string. 60 | -- 61 | -- You can use the function mod to compute modulo. 62 | 63 | #ifdef sol 64 | fizzbuzz :: Integer -> String 65 | fizzbuzz n = if divides 3 n && divides 5 n 66 | then "FizzBuzz" 67 | else if divides 3 n 68 | then "Fizz" 69 | else if divides 5 n 70 | then "Buzz" 71 | else "" 72 | where divides k n = mod n k == 0 73 | #else 74 | fizzbuzz = undefined 75 | #endif 76 | 77 | -- Ex 7: define a function isZero that returns True if it is given an 78 | -- Integer that is 0, and False otherwise. Give isZero a type signature. 79 | -- 80 | -- Use pattern matching! Don't use comparisons! 81 | -- 82 | -- Ps. the type of booleans in haskell is Bool 83 | 84 | #ifdef sol 85 | isZero :: Integer -> Bool 86 | isZero 0 = True 87 | isZero _ = False 88 | #else 89 | isZero = undefined 90 | #endif 91 | 92 | -- Ex 8: implement using recursion a function sumTo such that 93 | -- sumTo n 94 | -- computes the sum 1+2+...+n 95 | 96 | sumTo :: Integer -> Integer 97 | #ifdef sol 98 | sumTo 1 = 1 99 | sumTo n = n + sumTo (n-1) 100 | #else 101 | sumTo = undefined 102 | #endif 103 | 104 | -- Ex 9: power n k should compute n to the power k (i.e. n^k) 105 | -- Use recursion. 106 | 107 | power :: Integer -> Integer -> Integer 108 | #ifdef sol 109 | power n 0 = 1 110 | power n k = n * power n (k-1) 111 | #else 112 | power = undefined 113 | #endif 114 | 115 | -- Ex 10: ilog2 n should be the number of times you can halve the 116 | -- integer n (rounding down) before you get 1. 117 | -- 118 | -- Use recursion to define ilog2. Use the function "div" for integer 119 | -- division. 120 | 121 | ilog2 :: Integer -> Integer 122 | #ifdef sol 123 | ilog2 1 = 0 124 | ilog2 n = 1 + ilog2 (div n 2) 125 | #else 126 | ilog2 = undefined 127 | #endif 128 | 129 | -- Ex 11: compute binomial coefficients using recursion. Binomial 130 | -- coefficients are defined by the following equations: 131 | -- 132 | -- B(n,k) = B(n-1,k) + B(n-1,k-1) 133 | -- B(n,0) = 1 134 | -- B(0,k) = 0, when k>0 135 | -- 136 | -- Hint! pattern matching is your friend. 137 | 138 | binomial :: Integer -> Integer -> Integer 139 | #ifdef sol 140 | binomial n 0 = 1 141 | binomial 0 k = 0 142 | binomial n k = binomial (n-1) k + binomial (n-1) (k-1) 143 | #else 144 | binomial = undefined 145 | #endif 146 | 147 | -- Ex 12: The tribonacci numbers are defined by the equations 148 | -- 149 | -- T(1) = 1 150 | -- T(2) = 1 151 | -- T(3) = 2 152 | -- T(n+1) = T(n)+T(n-1)+T(n-2) 153 | -- 154 | -- Implement an efficient, linear time, recursive function that 155 | -- computes T(n). You'll probably want to define a helper function. 156 | 157 | tribonacci :: Integer -> Integer 158 | #ifdef sol 159 | tribonacci 1 = 1 160 | tribonacci 2 = 1 161 | tribonacci n = tribonacci' 1 1 2 (n-2) 162 | 163 | tribonacci' :: Integer -> Integer -> Integer -> Integer -> Integer 164 | tribonacci' a b c 1 = c 165 | tribonacci' a b c n = tribonacci' b c (a+b+c) (n-1) 166 | #else 167 | tribonacci = undefined 168 | #endif 169 | 170 | -- Ex 13: implement the euclidean algorithm for finding the greatest 171 | -- common divisor: http://en.wikipedia.org/wiki/Euclidean_algorithm 172 | 173 | myGcd :: Integer -> Integer -> Integer 174 | #ifdef sol 175 | myGcd 0 y = y 176 | myGcd x y = if x Int -> Ordering 200 | #ifdef sol 201 | funnyCompare x y = if even x 202 | then if even y 203 | then compare x y 204 | else LT 205 | else if even y 206 | then GT 207 | else compare x y 208 | #else 209 | funnyCompare = undefined 210 | #endif 211 | 212 | -- Ex 15: Implement the function funnyMin that returns the minimum of 213 | -- its two arguments, according to the ordering implemented by 214 | -- funnyCompare. 215 | -- 216 | -- Use pattern matching on the Ordering value returned by 217 | -- funnyCompare. To do this, you need to either use the case-of 218 | -- expression or define a helper function. 219 | 220 | funnyMin :: Int -> Int -> Int 221 | #ifdef sol 222 | funnyMin x y = helper (funnyCompare x y) x y 223 | where helper LT x _ = x 224 | helper _ _ y = y 225 | #else 226 | funnyMin = undefined 227 | #endif 228 | 229 | -- Ex 16: implement the recursive function pyramid that returns 230 | -- strings like this: 231 | -- 232 | -- pyramid 0 ==> "0" 233 | -- pyramid 1 ==> "0,1,0" 234 | -- pyramid 2 ==> "0,1,2,1,0" 235 | -- pyramid 3 ==> "0,1,2,3,2,1,0" 236 | -- 237 | -- Hints: 238 | -- * you can glue strings together with the operator ++ 239 | -- * the function show transforms a number into a string 240 | -- * you'll need a (recursive) helper function 241 | 242 | pyramid :: Integer -> String 243 | #ifdef sol 244 | pyramid n = helper 0 n 245 | 246 | helper k 0 = show k 247 | helper k n = show k ++ "," ++ helper (k+1) (n-1) ++ "," ++ show k 248 | #else 249 | pyramid = undefined 250 | #endif 251 | 252 | -- Ex 17: implement the function smallestDivisor that returns the 253 | -- smallest number (greater than 1) that divides the given number. 254 | -- 255 | -- That is, when 256 | -- smallestDivisor n ==> k 257 | -- we have 258 | -- n = t*k 259 | -- for some t. 260 | -- 261 | -- Ps. your function doesn't need to work for inputs 0 and 1, but 262 | -- remember this in the next exercise! 263 | 264 | smallestDivisor :: Integer -> Integer 265 | #ifdef sol 266 | smallestDivisor n = smallestDivisor' 2 n 267 | 268 | smallestDivisor' k n = 269 | if mod n k == 0 270 | then k 271 | else smallestDivisor' (k+1) n 272 | #else 273 | smallestDivisor = undefined 274 | #endif 275 | 276 | -- Ex 18: implement a function isPrime that checks if the given number 277 | -- is a prime number. Use the function smallestDivisor. 278 | -- 279 | -- Ps. 0 and 1 are not prime numbers 280 | 281 | isPrime :: Integer -> Bool 282 | #ifdef sol 283 | isPrime 0 = False 284 | isPrime 1 = False 285 | isPrime i = smallestDivisor i == i 286 | #else 287 | isPrime = undefined 288 | #endif 289 | 290 | -- Ex 19: implement a function nextPrime that returns the first prime 291 | -- number that comes after the given number. Use the function isPrime 292 | -- you just defined. 293 | 294 | nextPrime :: Integer -> Integer 295 | #ifdef sol 296 | nextPrime n = 297 | if isPrime (n+1) 298 | then (n+1) 299 | else nextPrime (n+1) 300 | #else 301 | nextPrime = undefined 302 | #endif 303 | -------------------------------------------------------------------------------- /templ/W2B.hs: -------------------------------------------------------------------------------- 1 | module W2 where 2 | 3 | -- Week 2: 4 | -- 5 | -- * lists 6 | -- * strings 7 | -- * library functions for them 8 | -- * higher order functions 9 | -- * polymorphism 10 | -- 11 | -- Functions you will need: 12 | -- * head, tail 13 | -- * take, drop 14 | -- * length 15 | -- * null 16 | -- * map 17 | -- * filter 18 | -- 19 | -- You can ask ghci for the types of these functions with the :t 20 | -- command: 21 | -- 22 | -- Prelude> :t length 23 | -- length :: [a] -> Int 24 | 25 | import Data.List 26 | import Data.Char 27 | 28 | -- Ex 1: Define the constant years, that is a list of the values 1982, 29 | -- 2004 and 2012 in this order. 30 | 31 | #ifdef sol 32 | years = [1982,2004,2012] 33 | #else 34 | years = undefined 35 | #endif 36 | 37 | -- Ex 2: define the function measure that for an empty list returns -1 38 | -- and for other lists returns the length of the list. 39 | 40 | measure :: [String] -> Int 41 | #ifdef sol 42 | measure ss = if null ss then -1 else length ss 43 | #else 44 | measure ss = undefined 45 | #endif 46 | 47 | -- Ex 3: define the function takeFinal, which returns the n last 48 | -- elements of the given list. 49 | 50 | takeFinal :: Int -> [Int] -> [Int] 51 | #ifdef sol 52 | takeFinal n xs = drop (length xs - n) xs 53 | #else 54 | takeFinal n xs = undefined 55 | #endif 56 | 57 | -- Ex 4: remove the nth element of the given list. More precisely, 58 | -- return a list that is identical to the given list except the nth 59 | -- element is missing. 60 | -- 61 | -- Note! indexing starts from 0 62 | -- 63 | -- Examples: 64 | -- remove 0 [1,2,3] ==> [2,3] 65 | -- remove 2 [4,5,6,7] ==> [4,5,7] 66 | -- 67 | -- The [a] in the type signature means "a list of any type" 68 | 69 | remove :: Int -> [a] -> [a] 70 | #ifdef sol 71 | remove i xs = take i xs ++ drop (i+1) xs 72 | #else 73 | remove i xs = undefined 74 | #endif 75 | 76 | -- Ex 5: substring i n s should return the length n substring of s 77 | -- starting at index i. 78 | -- 79 | -- Remember that strings are lists! 80 | 81 | substring :: Int -> Int -> String -> String 82 | #ifdef sol 83 | substring i n s = take n (drop i s) 84 | #else 85 | substring i n s = undefined 86 | #endif 87 | 88 | -- Ex 6: implement the function mymax that takes as argument a 89 | -- measuring function (of type a -> Int) and two values (of type a). 90 | -- 91 | -- mymax should apply the measuring function to both arguments and 92 | -- return the argument for which the measuring function returns a 93 | -- higher value. 94 | -- 95 | -- Examples: 96 | -- 97 | -- mymax (*2) 3 5 ==> 5 98 | -- mymax length [1,2,3] [4,5] ==> [1,2,3] 99 | -- mymax head [1,2,3] [4,5] ==> [4,5] 100 | 101 | mymax :: (a -> Int) -> a -> a -> a 102 | #ifdef sol 103 | mymax measure a b 104 | | measure a > measure b = a 105 | | otherwise = b 106 | #else 107 | mymax measure a b = undefined 108 | #endif 109 | 110 | -- Ex 7: countSorted receives a list of strings and returns a count of 111 | -- how many of the strings are in alphabetical order (i.e. how many of 112 | -- the strings have their letters in alphabetical order) 113 | -- 114 | -- Remember the functions length, filter and sort 115 | 116 | countSorted :: [String] -> Int 117 | #ifdef sol 118 | countSorted ss = length $ filter sorted ss 119 | where sorted s = sort s == s 120 | #else 121 | countSorted ss = undefined 122 | #endif 123 | 124 | -- Ex 8: Implement a function funny, that 125 | -- - takes in a list of strings 126 | -- - returns a string 127 | -- - that contains all input words of length over 5 128 | -- - ... combined into one string 129 | -- - ... separated with spaces 130 | -- - ... and converted to upper case! 131 | -- 132 | -- These functions will help: 133 | -- - toUpper :: Char -> Char from the module Data.Char 134 | -- - intercalate from the module Data.List 135 | 136 | funny :: [String] -> String 137 | #ifdef sol 138 | funny strings = map toUpper . intercalate " " . filter (\x -> length x > 5) $ strings 139 | #else 140 | funny strings = undefined 141 | #endif 142 | 143 | -- Ex 9: implement quicksort. Quicksort is a recursive sorting 144 | -- algorithm that works like this. 145 | -- 146 | -- - The empty list is the base case of the recursion: it is already sorted 147 | -- - From a nonempty list, the first element is chosen to be the "pivot", and 148 | -- - the elements smaller than pivot are gathered into a list 149 | -- - the elements smaller than larger or equal to the pivot are gathered 150 | -- - these two lists are sorted using recursion 151 | -- - finally the small elements, the pivot and the large elements 152 | -- are combined into one sorted list 153 | -- 154 | -- PS. yes if you want to nit-pick this isn't really quicksort :) 155 | 156 | quicksort :: [Int] -> [Int] 157 | #ifdef sol 158 | quicksort xs 159 | | null xs = xs 160 | | otherwise = let pivot = head xs 161 | rest = tail xs 162 | smaller = filter (=pivot) rest 164 | in quicksort smaller ++ [pivot] ++ quicksort bigger 165 | #else 166 | quicksort xs = undefined 167 | #endif 168 | 169 | -- Ex 10: powers k max should return all the powers of k that are less 170 | -- than or equal to max. For example: 171 | -- 172 | -- powers 2 5 ==> [1,2,4] 173 | -- powers 3 30 ==> [1,3,9,27] 174 | -- powers 2 2 ==> [1,2] 175 | -- 176 | -- Hints: 177 | -- * n^max > max 178 | -- * the function takeWhile 179 | 180 | powers :: Int -> Int -> [Int] 181 | #ifdef sol 182 | powers n max = takeWhile (<=max) $ map (n^) [0..max] 183 | #else 184 | powers n max = undefined 185 | #endif 186 | 187 | -- Ex 11: implement a search function that takes an updating function, 188 | -- a checking function and an initial value. Search should repeatedly 189 | -- apply the updating function to the initial value until a value is 190 | -- produced that passes the checking function. This value is then 191 | -- returned. 192 | -- 193 | -- Examples: 194 | -- 195 | -- search (+1) even 0 ==> 0 196 | -- 197 | -- search (+1) (>4) 0 ==> 5 198 | -- 199 | -- let check [] = True 200 | -- check ('A':xs) = True 201 | -- check _ = False 202 | -- in search tail check "xyzAvvt" 203 | -- ==> Avvt 204 | 205 | search :: (a->a) -> (a->Bool) -> a -> a 206 | #ifdef sol 207 | search update check initial 208 | | check initial = initial 209 | | otherwise = search update check (update initial) 210 | #else 211 | search update check initial = undefined 212 | #endif 213 | 214 | -- Ex 12: given numbers n and k, build the list of numbers n,n+1..k. 215 | -- Use recursion and the : operator to build the list. 216 | 217 | fromTo :: Int -> Int -> [Int] 218 | #ifdef sol 219 | fromTo n k = if n>k then [] else n:fromTo (n+1) k 220 | #else 221 | fromTo n k = undefined 222 | #endif 223 | 224 | -- Ex 13: given i, build the list of sums [1, 1+2, 1+2+3, .., 1+2+..+i] 225 | -- 226 | -- Ps. you'll probably need a recursive helper function 227 | 228 | sums :: Int -> [Int] 229 | #ifdef sol 230 | sums i = go 1 2 231 | where go acc n = if n>i then [acc] else acc : go (acc+n) (n+1) 232 | #else 233 | sums i = undefined 234 | #endif 235 | 236 | -- Ex 14: using list pattern matching and recursion, define a function 237 | -- mylast that returns the last value of the given list. For an empty 238 | -- list, a provided default value is returned. 239 | -- 240 | -- Examples: 241 | -- mylast 0 [] ==> 0 242 | -- mylast 0 [1,2,3] ==> 3 243 | 244 | mylast :: a -> [a] -> a 245 | #ifdef sol 246 | mylast def [] = def 247 | mylast _ (x:xs) = mylast x xs 248 | #else 249 | mylast def xs = undefined 250 | #endif 251 | 252 | -- Ex 15: define a function that checks if the given list is in 253 | -- increasing order. Use recursion and pattern matching. Don't use any 254 | -- library list functions. 255 | 256 | sorted :: [Int] -> Bool 257 | #ifdef sol 258 | sorted [] = True 259 | sorted [x] = True 260 | sorted (x:y:xs) 261 | | x>y = False 262 | | otherwise = sorted (y:xs) 263 | #else 264 | sorted xs = undefined 265 | #endif 266 | 267 | -- Ex 16: compute the partial sums of the given list like this: 268 | -- 269 | -- sumsOf [a,b,c] ==> [a,a+b,a+b+c] 270 | -- sumsOf [a,b] ==> [a,a+b] 271 | -- sumsOf [] ==> [] 272 | 273 | sumsOf :: [Int] -> [Int] 274 | #ifdef sol 275 | sumsOf xs = go 0 xs 276 | where go acc (x:xs) = (acc+x) : go (acc+x) xs 277 | go _ [] = [] 278 | #else 279 | sumsOf xs = undefined 280 | #endif 281 | 282 | -- Ex 17: define the function mymaximum that takes a list and a 283 | -- comparing function of type a -> a -> Ordering and returns the 284 | -- maximum value of the list, according to the comparing function. 285 | -- 286 | -- For an empty list the given default value is returned. 287 | -- 288 | -- Examples: 289 | -- mymaximum compare (-1) [] ==> -1 290 | -- mymaximum compare (-1) [1,3,2] ==> 3 291 | -- let comp 0 0 = EQ 292 | -- comp _ 0 = LT 293 | -- comp 0 _ = GT 294 | -- comp x y = compare x y 295 | -- in mymaximum comp 1 [1,4,6,100,0,3] 296 | -- ==> 0 297 | 298 | mymaximum :: (a -> a -> Ordering) -> a -> [a] -> a 299 | #ifdef sol 300 | mymaximum cmp def [] = def 301 | mymaximum cmp _ (x:xs) = go x xs 302 | where go biggest [] = biggest 303 | go biggest (x:xs) 304 | | cmp x biggest == GT = go x xs 305 | | otherwise = go biggest xs 306 | #else 307 | mymaximum cmp def xs = undefined 308 | #endif 309 | 310 | -- Ex 18: define a version of map that takes a two-argument function 311 | -- and two lists. Example: 312 | -- map2 f [x,y,z,w] [a,b,c] ==> [f x a, f y b, f z c] 313 | -- 314 | -- Use recursion and pattern matching. 315 | -- 316 | -- Ps. this function is in the Haskell Prelude but under a different 317 | -- name. 318 | 319 | map2 :: (a -> b -> c) -> [a] -> [b] -> [c] 320 | #ifdef sol 321 | map2 f (a:as) (b:bs) = f a b:map2 f as bs 322 | map2 f _ _ = [] 323 | #else 324 | map2 f as bs = undefined 325 | #endif 326 | 327 | -- Ex 19: in this exercise you get to implement an interpreter for a 328 | -- simple language. The language controls two counters, A and B, and 329 | -- has the following commands: 330 | -- 331 | -- incA -- increment counter A by one 332 | -- incB -- likewise for B 333 | -- decA -- decrement counter A by one 334 | -- decB -- likewise for B 335 | -- printA -- print value in counter A 336 | -- printB -- print value in counter B 337 | -- 338 | -- The interpreter will be a function of type [String] -> [String]. 339 | -- Its input is a list of commands, and its output is a list of the 340 | -- results of the print commands in the input. 341 | -- 342 | -- Both counters should start at 0. 343 | -- 344 | -- Examples: 345 | -- 346 | -- interpreter ["incA","incA","incA","printA","decA","printA"] ==> ["3","2"] 347 | -- interpreter ["incA","incB","incB","printA","printB"] ==> ["1","2"] 348 | -- 349 | -- Surprise! after you've implemented the function, try running this in GHCi: 350 | -- interact (unlines . interpreter . lines) 351 | -- after this you can enter commands on separate lines and see the 352 | -- responses to them 353 | -- 354 | -- Unfortunately the surprise might not work if you've implemented 355 | -- your interpreter correctly but weirdly :( 356 | 357 | interpreter :: [String] -> [String] 358 | #ifdef sol 359 | interpreter commands = go 0 0 commands 360 | where go a b ("incA":commands) = go (a+1) b commands 361 | go a b ("decA":commands) = go (a-1) b commands 362 | go a b ("incB":commands) = go a (b+1) commands 363 | go a b ("decB":commands) = go a (b-1) commands 364 | go a b ("printA":commands) = show a : go a b commands 365 | go a b ("printB":commands) = show b : go a b commands 366 | go a b [] = [] 367 | go a b (_:commands) = "BAD" : go a b commands 368 | #else 369 | interpreter commands = undefined 370 | #endif 371 | 372 | -- Ex 20: write a function that finds the n first squares (numbers of 373 | -- the form x*x) that start and end with the same digit. 374 | -- 375 | -- Example: squares 9 ==> [1,4,9,121,484,676,1521,1681,4624] 376 | -- 377 | -- Remember, the function show transforms a number to a string. 378 | 379 | squares :: Int -> [Integer] 380 | #ifdef sol 381 | squares n = take n . filter (\x -> head (show x) == last (show x)) $ map (\x -> x*x) [1..] 382 | #else 383 | squares n = undefined 384 | #endif 385 | -------------------------------------------------------------------------------- /templ/W3B.hs: -------------------------------------------------------------------------------- 1 | module W3 where 2 | 3 | -- Week 3: 4 | -- * built-in datatypes 5 | -- * custom datatypes 6 | -- * folds 7 | -- 8 | -- Useful functions / types: 9 | -- * Maybe 10 | 11 | -- Ex 1: implement safe integer devision, that is, a function that 12 | -- returns Just result normally, but Nothing if the divisor is zero. 13 | -- 14 | -- Remember that integer division can be done with the div function. 15 | 16 | safeDiv :: Integer -> Integer -> Maybe Integer 17 | #ifdef sol 18 | safeDiv x 0 = Nothing 19 | safeDiv x y = Just (div x y) 20 | #else 21 | safeDiv x y = undefined 22 | #endif 23 | 24 | -- Ex 2: another variant of safe division. This time a succesful 25 | -- division should be returned as 26 | -- Right result 27 | -- whereas a division by zero should return 28 | -- Left "1234/0" 29 | -- (replace 1234 with the value of x). 30 | 31 | eitherDiv :: Integer -> Integer -> Either String Integer 32 | #ifdef sol 33 | eitherDiv x 0 = Left $ show x ++ "/0" 34 | eitherDiv x y = Right $ div x y 35 | #else 36 | eitherDiv x y = undefined 37 | #endif 38 | 39 | -- Ex 3: implement the function mapMaybe, which works a bit like a 40 | -- combined map & filter. 41 | -- 42 | -- mapMaybe is given a list ([a]) and a function of type a -> Maybe b. 43 | -- This function is called for all values in the list. If the function 44 | -- returns Just x, x will be in the result list. If the function 45 | -- returns Nothing, nothing gets added to the result list. 46 | -- 47 | -- Examples: 48 | -- 49 | -- let f x = if x>0 then Just (2*x) else Nothing 50 | -- in mapMaybe f [0,1,-1,4,-2,2] 51 | -- ==> [2,8,4] 52 | -- 53 | -- mapMaybe Just [1,2,3] 54 | -- ==> [1,2,3] 55 | -- 56 | -- mapMaybe (\x -> Nothing) [1,2,3] 57 | -- ==> [] 58 | 59 | mapMaybe :: (a -> Maybe b) -> [a] -> [b] 60 | #ifdef sol 61 | mapMaybe f [] = [] 62 | mapMaybe f (x:xs) = case f x of Just y -> y:mapMaybe f xs 63 | Nothing -> mapMaybe f xs 64 | #else 65 | mapMaybe f xs = undefined 66 | #endif 67 | 68 | -- Ex 4: define the function classify that takes a list of Either a b 69 | -- values and returns a list of the Left values and a list of the 70 | -- Right values. 71 | -- 72 | -- PS. This function can be found from the standard library under the 73 | -- name partitionEithers. Don't use the library implementation or any 74 | -- other functions from the Data.Maybe module. 75 | -- 76 | -- Example: 77 | -- classify [Left 1, Right True, Left 0, Right False] 78 | -- ==> ([1,0],[True,False]) 79 | 80 | classify :: [Either a b] -> ([a],[b]) 81 | #ifdef sol 82 | classify es = go es [] [] 83 | where go (Left a : es) as bs = go es (a:as) bs 84 | go (Right b : es) as bs = go es as (b:bs) 85 | go [] as bs = (reverse as, reverse bs) 86 | #else 87 | classify es = undefined 88 | #endif 89 | 90 | -- Ex 5: define a datatype Person, which should contain the age (an 91 | -- Int) and the name (a String) of a person. 92 | -- 93 | -- Also define a Person value fred, and the functions getAge, getname, 94 | -- setAge and setName (see below). 95 | 96 | #ifdef sol 97 | data Person = MkPerson Int String 98 | deriving Show 99 | #else 100 | data Person = PersonUndefined 101 | deriving Show 102 | #endif 103 | 104 | -- fred is a person whose name is Fred and age is 90 105 | fred :: Person 106 | #ifdef sol 107 | fred = MkPerson 90 "Fred" 108 | #else 109 | fred = undefined 110 | #endif 111 | 112 | -- getName returns the name of the person 113 | getName :: Person -> String 114 | #ifdef sol 115 | getName (MkPerson _ name) = name 116 | #else 117 | getName p = undefined 118 | #endif 119 | 120 | -- getAge returns the age of the person 121 | getAge :: Person -> Int 122 | #ifdef sol 123 | getAge (MkPerson age _) = age 124 | #else 125 | getAge p = undefined 126 | #endif 127 | 128 | -- setName takes a person and returns a new person with the name changed 129 | setName :: String -> Person -> Person 130 | #ifdef sol 131 | setName name (MkPerson age _name) = MkPerson age name 132 | #else 133 | setName name p = undefined 134 | #endif 135 | 136 | -- setAge does likewise for age 137 | setAge :: Int -> Person -> Person 138 | #ifdef sol 139 | setAge age (MkPerson _age name) = MkPerson age name 140 | #else 141 | setAge age p = undefined 142 | #endif 143 | 144 | 145 | -- Ex 6: define a datatype TwoCounters which contains two Int 146 | -- counters. Also define the functions below for operating a 147 | -- TwoCounters. 148 | -- 149 | -- Examples: 150 | -- 151 | -- getA (incA (incA zeros)) 152 | -- ==> 2 153 | -- getB (incB (incA zeros)) 154 | -- ==> 1 155 | 156 | #ifdef sol 157 | data TwoCounters = TwoCounters Int Int 158 | #else 159 | data TwoCounters = Undefined 160 | #endif 161 | 162 | -- zeros is a TwoCounters value with both counters initialized to 0 163 | zeros :: TwoCounters 164 | #ifdef sol 165 | zeros = TwoCounters 0 0 166 | #else 167 | zeros = undefined 168 | #endif 169 | 170 | -- getA returns the value of the "A" counter 171 | getA :: TwoCounters -> Int 172 | #ifdef sol 173 | getA (TwoCounters a _) = a 174 | #else 175 | getA tc = undefined 176 | #endif 177 | 178 | -- getB returns the value of the "B" counter 179 | getB :: TwoCounters -> Int 180 | #ifdef sol 181 | getB (TwoCounters _ b) = b 182 | #else 183 | getB tc = undefined 184 | #endif 185 | 186 | -- incA increases the value of the "A" counter by one 187 | incA :: TwoCounters -> TwoCounters 188 | #ifdef sol 189 | incA (TwoCounters a b) = TwoCounters (a+1) b 190 | #else 191 | incA tc = undefined 192 | #endif 193 | 194 | -- incB does likewise for the "B" counter 195 | incB :: TwoCounters -> TwoCounters 196 | #ifdef sol 197 | incB (TwoCounters a b) = TwoCounters a (b+1) 198 | #else 199 | incB tc = undefined 200 | #endif 201 | 202 | -- Ex 7: define a datatype UpDown that represents a counter that can 203 | -- either be in incresing or decreasing mode. Also implement the 204 | -- functions zero, toggle, tick and get below. 205 | -- 206 | -- NB! Define _two_ constructors for your datatype, in other words, 207 | -- the definition should be of the form 208 | -- data UpDown = A something | B foobar 209 | -- 210 | -- Examples: 211 | -- 212 | -- get (tick zero) 213 | -- ==> 1 214 | -- get (tick (tick zero)) 215 | -- ==> 2 216 | -- get (tick (tick (toggle (tick zero)))) 217 | -- ==> -1 218 | 219 | #ifdef sol 220 | data UpDown = Up Int | Down Int 221 | #else 222 | data UpDown = UpDownUndefined1 | UpDownUndefined2 223 | #endif 224 | 225 | -- zero is an increasing counter with value 0 226 | zero :: UpDown 227 | #ifdef sol 228 | zero = Up 0 229 | #else 230 | zero = undefined 231 | #endif 232 | 233 | -- get returns the counter value 234 | get :: UpDown -> Int 235 | #ifdef sol 236 | get (Up x) = x 237 | get (Down x) = x 238 | #else 239 | get ud = undefined 240 | #endif 241 | 242 | -- tick increases an increasing counter by one or decreases a 243 | -- decreasing counter by one 244 | tick :: UpDown -> UpDown 245 | #ifdef sol 246 | tick (Up x) = Up (x+1) 247 | tick (Down x) = Down (x-1) 248 | #else 249 | tick ud = undefined 250 | #endif 251 | 252 | -- toggle changes an increasing counter into a decreasing counter and 253 | -- vice versa 254 | toggle :: UpDown -> UpDown 255 | #ifdef sol 256 | toggle (Up x) = Down x 257 | toggle (Down x) = Up x 258 | #else 259 | toggle ud = undefined 260 | #endif 261 | 262 | -- !!!!! 263 | -- The next exercises use the binary tree type defined like this: 264 | 265 | data Tree a = Leaf | Node a (Tree a) (Tree a) 266 | deriving (Show, Eq) 267 | 268 | -- Ex 8: implement the function valAtRoot which returns the value at 269 | -- the root (top-most node) of the tree. The return value is Maybe a 270 | -- because the tree might be empty (i.e. just a Leaf) 271 | 272 | valAtRoot :: Tree a -> Maybe a 273 | #ifdef sol 274 | valAtRoot Leaf = Nothing 275 | valAtRoot (Node v _ _) = Just v 276 | #else 277 | valAtRoot t = undefined 278 | #endif 279 | 280 | -- Ex 9: compute the size of a tree, that is, the number of Node 281 | -- constructors in it 282 | 283 | treeSize :: Tree a -> Int 284 | #ifdef sol 285 | treeSize Leaf = 0 286 | treeSize (Node _ l r) = 1 + treeSize l + treeSize r 287 | #else 288 | treeSize t = undefined 289 | #endif 290 | 291 | -- Ex 10: get the leftmost value in the tree. The return value is 292 | -- Maybe a because the tree might be empty. 293 | -- 294 | -- The leftmost value means the value that is reached by going to the 295 | -- left child of the current Node for as long as possible. 296 | -- 297 | -- Examples: 298 | -- 299 | -- leftest Leaf 300 | -- ==> Nothing 301 | -- leftest (Node 1 (Node 2 (Node 3 Leaf Leaf) Leaf) Leaf) 302 | -- ==> Just 3 303 | -- leftest (Node 1 (Node 2 Leaf (Node 3 Leaf Leaf)) (Node 4 Leaf Leaf)) 304 | -- ==> Just 2 305 | 306 | leftest :: Tree a -> Maybe a 307 | #ifdef sol 308 | leftest Leaf = Nothing 309 | leftest (Node x Leaf _) = Just x 310 | leftest (Node _ l _) = leftest l 311 | #else 312 | leftest t = undefined 313 | #endif 314 | 315 | -- Ex 11: implement map for trees. 316 | -- 317 | -- Examples: 318 | -- 319 | -- mapTree (+1) Leaf ==> Leaf 320 | -- mapTree (+2) (Node 0 (Node 1 Leaf Leaf) (Node 2 Leaf Leaf)) 321 | -- ==> (Node 2 (Node 3 Leaf Leaf) (Node 4 Leaf Leaf)) 322 | 323 | mapTree :: (a -> b) -> Tree a -> Tree b 324 | #ifdef sol 325 | mapTree _ Leaf = Leaf 326 | mapTree f (Node v l r) = Node (f v) (mapTree f l) (mapTree f r) 327 | #else 328 | mapTree f t = undefined 329 | #endif 330 | 331 | -- Ex 12: insert the given value into the leftmost possible place. You 332 | -- need to return a new tree since the function is pure. 333 | -- 334 | -- Example: 335 | -- insertL 0 Leaf 336 | -- ==> Node 0 Leaf Leaf 337 | -- insertL 0 (Node 1 Leaf Leaf) 338 | -- ==> Node 1 (Node 0 Leaf Leaf) Leaf) 339 | -- 340 | -- insertL 0 (Node 1 341 | -- (Node 2 342 | -- Leaf 343 | -- (Node 3 Leaf Leaf)) 344 | -- (Node 4 Leaf Leaf)) 345 | -- 346 | -- ==> Node 1 347 | -- (Node 2 348 | -- (Node 0 Leaf Leaf) 349 | -- (Node 3 Leaf Leaf)) 350 | -- (Node 4 Leaf Leaf) 351 | 352 | 353 | insertL :: a -> Tree a -> Tree a 354 | #ifdef sol 355 | insertL x Leaf = Node x Leaf Leaf 356 | insertL x (Node y l r) = Node y (insertL x l) r 357 | #else 358 | insertL x t = undefined 359 | #endif 360 | 361 | -- Ex 13: implement the function measure, that takes a tree and 362 | -- returns a tree with the same shape, but with the value at every 363 | -- node being the size of the subtree starting at that node. 364 | -- 365 | -- (If you don't remember what the size of a subtree meant, see Ex 9) 366 | -- 367 | -- Examples: 368 | -- 369 | -- measure (Node 'a' Leaf Leaf) 370 | -- ==> Node 1 Leaf Leaf 371 | -- measure (Node 'a' (Node 'b' Leaf Leaf) Leaf) 372 | -- ==> Node 2 (Node 1 Leaf Leaf) Leaf 373 | -- measure (Node 0 (Node 0 Leaf Leaf) Leaf) 374 | -- ==> Node 2 (Node 1 Leaf Leaf) Leaf 375 | -- measure (Node 0 (Node 0 Leaf Leaf) 376 | -- (Node 0 (Node 0 Leaf Leaf) 377 | -- (Node 0 Leaf 378 | -- (Node 0 Leaf Leaf)))) 379 | -- ==> Node 6 (Node 1 Leaf Leaf) 380 | -- (Node 4 (Node 1 Leaf Leaf) 381 | -- (Node 2 Leaf 382 | -- (Node 1 Leaf Leaf))) 383 | 384 | 385 | measure :: Tree a -> Tree Int 386 | #ifdef sol 387 | measure Leaf = Leaf 388 | measure (Node _ l r) = Node (val l' + val r' + 1) l' r' 389 | where val Leaf = 0 390 | val (Node v _ _) = v 391 | l' = measure l 392 | r' = measure r 393 | #else 394 | measure t = undefined 395 | #endif 396 | 397 | -- Ex 14: the standard library function 398 | -- foldr :: (a -> b -> b) -> b -> [a] -> b 399 | -- is used to "collapse" a list to a single value, like this: 400 | -- foldr f start [x,y,z,w] 401 | -- ==> f x (f y (f z (f w start) 402 | -- 403 | -- Implement the functions sumf and lengthf so that mysum computes the 404 | -- sum of the values in the list and mylength computes the length of 405 | -- the list. 406 | -- 407 | -- DON'T change the definitions of mysum and mylength, only implement 408 | -- sumf and lengtf appropriately. 409 | 410 | mysum :: [Int] -> Int 411 | mysum is = foldr sumf 0 is 412 | 413 | sumf :: Int -> Int -> Int 414 | #ifdef sol 415 | sumf x y = x + y 416 | #else 417 | sumf x y = undefined 418 | #endif 419 | 420 | mylength :: [a] -> Int 421 | mylength xs = foldr lengthf 0 xs 422 | 423 | lengthf :: a -> Int -> Int 424 | #ifdef sol 425 | lengthf x y = 1 + y 426 | #else 427 | lengthf x y = undefined 428 | #endif 429 | 430 | -- Ex 15: implement the function foldTree that works like foldr, but 431 | -- for Trees. 432 | -- 433 | -- Example: 434 | -- foldTree f l (Node 3 Leaf Leaf) 435 | -- ==> f 3 l l 436 | -- foldTree f l (Node 'a' (Node 'b' (Node 'c' Leaf Leaf) 437 | -- Leaf) 438 | -- (Node 'd' Leaf Leaf)) 439 | -- ==> f (f 'a' (f 'b' (f 'c' l l) 440 | -- l) 441 | -- (f 'd' l l)) 442 | -- 443 | -- Once you've implemented foldTree correctly, the functions treeSum 444 | -- and treeLeaves below work correctly. 445 | 446 | sumt :: Int -> Int -> Int -> Int 447 | sumt x y z = x+y+z 448 | 449 | -- Sum of numbers in the tree 450 | treeSum :: Tree Int -> Int 451 | treeSum t = foldTree sumt 0 t 452 | 453 | leaft :: a -> Int -> Int -> Int 454 | leaft x y z = y+z 455 | 456 | -- Number of leaves in the tree 457 | treeLeaves :: Tree a -> Int 458 | treeLeaves t = foldTree leaft 1 t 459 | 460 | foldTree :: (a -> b -> b -> b) -> b -> Tree a -> b 461 | #ifdef sol 462 | foldTree f x Leaf = x 463 | foldTree f x (Node val l r) = f val (foldTree f x l) (foldTree f x r) 464 | #else 465 | foldTree f x t = undefined 466 | #endif 467 | 468 | -- Ex 16: You'll find a Color datatype below. It has the three basic 469 | -- colours Red, Green and Blue, and two color transformations, Mix and 470 | -- Darken. 471 | -- 472 | -- Mix means the sum of the two colors. 473 | -- 474 | -- Darken means darkening the color. The Double value tells how much 475 | -- the color is darkened. 0.0 means no change and 1.0 means full 476 | -- darkening, i.e. black. 477 | -- 478 | -- Implement the function rgb :: Color -> [Double] that returns a list 479 | -- of length three that represents the rgb value of the given color. 480 | -- 481 | -- Examples: 482 | -- 483 | -- rgb Red ==> [1,0,0] 484 | -- rgb Green ==> [0,1,0] 485 | -- rgb Blue ==> [0,0,1] 486 | -- 487 | -- rgb (Mix Red Green) ==> [1,1,0] 488 | -- rgb (Mix Red (Mix Red Green)) ==> [1,1,0] 489 | -- rgb (Darken 0.2 Red) ==> [0.8,0,0] 490 | -- rgb (Darken 0.2 (Darken 0.2 Red)) ==> [0.64,0,0] 491 | -- rgb (Mix (Darken 0.4 Red) (Darken 0.4 Red)) ==> [1,0,0] 492 | -- rgb (Mix (Darken 0.6 Red) (Darken 0.6 Red)) ==> [0.8,0,0] 493 | -- 494 | -- NB! Mix should saturate at 1.0 495 | 496 | data Color = Red | Green | Blue | Mix Color Color | Darken Double Color 497 | deriving Show 498 | 499 | rgb :: Color -> [Double] 500 | #ifdef sol 501 | rgb Red = [1,0,0] 502 | rgb Green = [0,1,0] 503 | rgb Blue = [0,0,1] 504 | rgb (Mix c c') = map saturate $ zipWith (+) (rgb c) (rgb c') 505 | where saturate x = min x 1 506 | rgb (Darken d c) = map (*scale) (rgb c) 507 | where scale = 1-d 508 | #else 509 | rgb col = undefined 510 | #endif 511 | -------------------------------------------------------------------------------- /templ/W4B.hs: -------------------------------------------------------------------------------- 1 | module W4 where 2 | 3 | import Control.Monad 4 | import Data.List 5 | import Data.IORef 6 | import System.IO 7 | 8 | -- Week 4: 9 | -- * The IO type 10 | -- * do-notation 11 | -- 12 | -- Useful functions / operations: 13 | -- * putStrLn 14 | -- * getLine 15 | -- * readLn 16 | -- * replicateM 17 | -- * readFile 18 | -- * lines 19 | -- 20 | -- If these exercises feel weird or hard, feel free to skip this week for now 21 | 22 | -- Ex 1: define an IO operation hello that prints two lines. The 23 | -- first line should be HELLO and the second one WORLD 24 | 25 | hello :: IO () 26 | #ifdef sol 27 | hello = do putStrLn "HELLO" 28 | putStrLn "WORLD" 29 | #else 30 | hello = undefined 31 | #endif 32 | 33 | -- Ex 2: define the IO operation greet that takes a name as an 34 | -- argument and prints a line "HELLO name". 35 | 36 | greet :: String -> IO () 37 | #ifdef sol 38 | greet name = putStrLn $ "HELLO " ++ name 39 | #else 40 | greet name = undefined 41 | #endif 42 | 43 | 44 | -- Ex 3: define the IO operation greet2 that reads a name from the 45 | -- keyboard and then greets that name like in the previous 46 | -- exercise. 47 | -- 48 | -- Try to use the greet operation in your solution. 49 | 50 | greet2 :: IO () 51 | #ifdef sol 52 | greet2 = do name <- getLine 53 | greet name 54 | #else 55 | greet2 = undefined 56 | #endif 57 | 58 | -- Ex 4: define the IO operation readWords n which reads n lines from 59 | -- the user and returns them in alphabetical order. 60 | 61 | readWords :: Int -> IO [String] 62 | #ifdef sol 63 | readWords n = do words <- replicateM n getLine 64 | return $ sort words 65 | #else 66 | readWords n = undefined 67 | #endif 68 | 69 | -- Ex 5: define the IO operation readUntil f, which reads lines from 70 | -- the user and returns them as a list. Reading is stopped when f 71 | -- returns True for a line. (The value for which f returns True is not 72 | -- returned.) 73 | 74 | readUntil :: (String -> Bool) -> IO [String] 75 | #ifdef sol 76 | readUntil f = do word <- getLine 77 | if f word 78 | then return [] 79 | else do words <- readUntil f 80 | return $ word:words 81 | #else 82 | readUntil f = undefined 83 | #endif 84 | 85 | -- Ex 6: given n, print the n first fibonacci numbers, one per line 86 | 87 | printFibs :: Int -> IO () 88 | #ifdef sol 89 | printFibs n = mapM_ print $ fibs 0 1 n 90 | where fibs a b 0 = [] 91 | fibs a b n = b:fibs b (a+b) (n-1) 92 | #else 93 | printFibs n = undefined 94 | #endif 95 | 96 | -- Ex 7: isums n should read n numbers from the user and return their 97 | -- sum. Additionally, after each read number, the sum up to that 98 | -- number should be printed. 99 | 100 | isums :: Int -> IO Int 101 | #ifdef sol 102 | isums n = go 0 n 103 | where go sum 0 = return sum 104 | go sum n = do i <- readLn 105 | let sum' = sum+i 106 | print sum' 107 | go sum' (n-1) 108 | #else 109 | isums n = undefined 110 | #endif 111 | 112 | -- Ex 8: when is a useful function, but its first argument has type 113 | -- Bool. Write a function that behaves similarly but the first 114 | -- argument has type IO Bool. 115 | 116 | whenM :: IO Bool -> IO () -> IO () 117 | #ifdef sol 118 | whenM cond op = do b <- cond 119 | when b op 120 | #else 121 | whenM cond op = undefined 122 | #endif 123 | 124 | -- Ex 9: implement the while loop. while condition operation should 125 | -- run operation as long as condition returns True. 126 | -- 127 | -- Examples: 128 | -- while (return False) (putStrLn "IMPOSSIBLE") -- prints nothing 129 | -- 130 | -- let ask :: IO Bool 131 | -- ask = do putStrLn "Y/N?" 132 | -- line <- getLine 133 | -- return $ line == "Y" 134 | -- in while ask (putStrLn "YAY!") 135 | -- 136 | -- This prints YAY! as long as the user keeps answering Y 137 | 138 | while :: IO Bool -> IO () -> IO () 139 | #ifdef sol 140 | while cond op = whenM cond $ do op 141 | while cond op 142 | #else 143 | while cond op = undefined 144 | #endif 145 | 146 | -- Ex 10: given a string and an IO operation, print the string, run 147 | -- the IO operation, print the string again, and finally return what 148 | -- the operation returned. 149 | -- 150 | -- Note! the operation should be run only once 151 | -- 152 | -- Examples: 153 | -- debug "CIAO" (return 3) 154 | -- - prints two lines that contain CIAO 155 | -- - returns the value 3 156 | -- debug "BOOM" getLine 157 | -- 1. prints "BOOM" 158 | -- 2. reads a line from the user 159 | -- 3. prints "BOOM" 160 | -- 4. returns the line read from the user 161 | 162 | debug :: String -> IO a -> IO a 163 | #ifdef sol 164 | debug s op = do 165 | putStrLn s 166 | ret <- op 167 | putStrLn s 168 | return ret 169 | #else 170 | debug s op = undefined 171 | #endif 172 | 173 | -- Ex 11: Reimplement mapM_ (specialized to the IO type) using 174 | -- recursion and pattern matching. 175 | -- 176 | -- In case you don't know what mapM_ does, it takes a parameterized IO 177 | -- operation and a list of parameters, and runs the operation for each 178 | -- value in the list. 179 | 180 | mymapM_ :: (a -> IO b) -> [a] -> IO () 181 | #ifdef sol 182 | mymapM_ f [] = return () 183 | mymapM_ f (x:xs) = do f x 184 | mymapM_ f xs 185 | #else 186 | mymapM_ = undefined 187 | #endif 188 | 189 | -- Ex 12: Reimplement the function forM using pattern matching and 190 | -- recursion. 191 | 192 | myforM :: [a] -> (a -> IO b) -> IO [b] 193 | #ifdef sol 194 | myforM [] f = return [] 195 | myforM (a:as) f = do b <- f a 196 | bs <- myforM as f 197 | return $ b : bs 198 | #else 199 | myforM as f = undefined 200 | #endif 201 | 202 | -- Ex 13: sometimes one bumps into IO operations that return IO 203 | -- operations. For instance the type IO (IO Int) means an IO operation 204 | -- that returns an IO operation that returns an Int. 205 | -- 206 | -- Implement the function doubleCall which takes an operation op and 207 | -- 1. runs op 208 | -- 2. runs the operation returned by op 209 | -- 3. returns the value returned by this operation 210 | -- 211 | -- Examples: 212 | -- - doubleCall (return (return 3)) is the same as return 3 213 | -- 214 | -- - let op :: IO (IO [String]) 215 | -- op = do l <- readLn 216 | -- return $ replicateM l getLine 217 | -- in doubleCall op 218 | -- 219 | -- works just like 220 | -- 221 | -- do l <- readLn 222 | -- replicateM l getLine 223 | 224 | doubleCall :: IO (IO a) -> IO a 225 | #ifdef sol 226 | doubleCall op = do op2 <- op 227 | op2 228 | #else 229 | doubleCall op = undefined 230 | #endif 231 | 232 | -- Ex 14: implement the analogue of function composition (the (.) 233 | -- operator) for IO operations. That is, take an operation op1 of type 234 | -- a -> IO b 235 | -- an operation op2 of type 236 | -- c -> IO a 237 | -- and a value of type 238 | -- c 239 | -- and returns an operation op3 of type 240 | -- IO b 241 | -- 242 | -- op3 should of course 243 | -- 1. take the value of type c and pass it to op2 244 | -- 2. take the resulting value (of type a) and pass it to op1 245 | -- 3. return the result (of type b) 246 | 247 | compose :: (a -> IO b) -> (c -> IO a) -> c -> IO b 248 | #ifdef sol 249 | compose op1 op2 c = do a <- op2 c 250 | op1 a 251 | #else 252 | compose op1 op2 c = undefined 253 | #endif 254 | 255 | -- Ex 15: take a look at the documentaiton for Data.IORef 256 | -- 257 | -- 258 | -- Implement the function mkCounter that returns the io operations 259 | -- inc :: IO () and get :: IO Int. These operations should work like this: 260 | -- 261 | -- get returns the number of times inc has been called 262 | -- 263 | -- In other words, a simple stateful counter. 264 | -- 265 | -- An example of how mkCounter works in GHCi: 266 | -- 267 | -- *W4> (inc,get) <- mkCounter 268 | -- *W4> inc 269 | -- *W4> inc 270 | -- *W4> get 271 | -- 2 272 | -- *W4> inc 273 | -- *W4> inc 274 | -- *W4> get 275 | -- 4 276 | 277 | mkCounter :: IO (IO (), IO Int) 278 | #ifdef sol 279 | mkCounter = do 280 | ref <- newIORef 0 281 | let get = readIORef ref 282 | inc = modifyIORef ref (+1) 283 | return (inc,get) 284 | #else 285 | mkCounter = undefined 286 | #endif 287 | 288 | -- Ex 16: fetch from the given file (Handle) the lines with the given 289 | -- indices. Line indexing starts from 1. You can assume that the 290 | -- numbers are given in ascending order. 291 | -- 292 | -- Have a look at the docs for the System.IO module for help. 293 | 294 | hFetchLines :: Handle -> [Int] -> IO [String] 295 | #ifdef sol 296 | hFetchLines h nums = do cont <- hGetContents h 297 | let split = lines cont 298 | return $ pick 1 nums split 299 | where pick _ [] _ = [] 300 | pick _ _ [] = [] 301 | pick i (n:nums) (s:split) 302 | | i==n = s:pick (i+1) nums split 303 | | otherwise = pick (i+1) (n:nums) split 304 | #else 305 | hFetchLines h nums = undefined 306 | #endif 307 | 308 | -- Ex 17: CSV is a file format that stores a two-dimensional array of 309 | -- values in a file. Each row of the file is a row of the array. Each 310 | -- row of the file consists of values on that row separated with the , 311 | -- character. 312 | -- 313 | -- Implement the function readCSV that reads a CSV file and returns it 314 | -- as a list of lists. 315 | -- 316 | -- NB! You don't need to handle the intricacies of real CSV, e.g. 317 | -- quoting. You can assume each , character starts a new field. 318 | -- 319 | -- NB! The lines might have different numbers of elements. 320 | 321 | readCSV :: FilePath -> IO [[String]] 322 | #ifdef sol 323 | readCSV path = do str <- readFile path 324 | return $ map process $ lines str 325 | where process xs = case break (==',') xs of (a,[]) -> [a] 326 | (a,',':b) -> a:process b 327 | #else 328 | readCSV path = undefined 329 | #endif 330 | 331 | -- Ex 18: your task is to compare two files, a and b. The files should 332 | -- have the same contents, but if lines at index i differ from each 333 | -- other, you should print 334 | -- 335 | -- < file a version of the line 336 | -- > file b version of the line 337 | -- 338 | -- Example: 339 | -- 340 | -- File a contents: 341 | -- a 342 | -- aa 343 | -- x 344 | -- aa 345 | -- bb 346 | -- cc 347 | -- 348 | -- File b contents: 349 | -- a 350 | -- aa 351 | -- bb 352 | -- aa 353 | -- cc 354 | -- dd 355 | -- 356 | -- Output: 357 | -- < x 358 | -- > bb 359 | -- < bb 360 | -- > cc 361 | -- < cc 362 | -- > dd 363 | -- 364 | -- NB! You can assume the files have the same number of rows. 365 | -- 366 | -- Hint! It's probably wise to implement a pure function for finding 367 | -- the differing lines. A suitable type could be 368 | -- [String] -> [String] -> [String]. 369 | 370 | compareFiles :: FilePath -> FilePath -> IO () 371 | #ifdef sol 372 | compareFiles a b = do ac <- readFile a 373 | bc <- readFile b 374 | mapM_ putStrLn $ compareHelper (lines ac) (lines bc) 375 | 376 | compareHelper [] [] = [] 377 | compareHelper (a:as) (b:bs) 378 | | a /= b = ("< "++a):("> "++b):compareHelper as bs 379 | | otherwise = compareHelper as bs 380 | #else 381 | compareFiles a b = undefined 382 | #endif 383 | 384 | -- Ex 19: In this exercise we see how a program can be split into a 385 | -- pure part that does all of the work, and a simple IO wrapper that 386 | -- drives the pure logic. 387 | -- 388 | -- Implement the function interact' that takes a pure function f of 389 | -- type 390 | -- (String, st) -> (Bool, String, st) 391 | -- and a starting state of type st and returns an IO operation of type 392 | -- IO st 393 | -- 394 | -- interact' should read a line from the user, feed the line and the 395 | -- current state to f. f then returns a boolean, a string to print and 396 | -- a new state. The string is printed, and if the boolean is True, we 397 | -- continue running with the new state. If the boolean is False, the 398 | -- execution has ended and the state should be returned. 399 | -- 400 | -- Example: 401 | -- 402 | -- let f :: (String,Integer) -> (Bool,String,Integer) 403 | -- f ("inc",n) = (True,"",n+1) 404 | -- f ("print",n) = (True,show n,n) 405 | -- f ("quit",n) = (False,"bye bye",n) 406 | -- in interact' f 0 407 | -- 408 | 409 | interact' :: ((String,st) -> (Bool,String,st)) -> st -> IO st 410 | #ifdef sol 411 | interact' f state = do 412 | inp <- getLine 413 | case f (inp,state) of 414 | (True, out, state') -> 415 | do putStr out 416 | interact' f state' 417 | (False, out, state') -> 418 | do putStr out 419 | return state' 420 | #else 421 | interact' f state = undefined 422 | #endif 423 | -------------------------------------------------------------------------------- /templ/W5B.hs: -------------------------------------------------------------------------------- 1 | module W5 where 2 | 3 | import System.Random 4 | import Data.List 5 | 6 | -- Week 5: 7 | -- - operators 8 | -- - using typeclasses 9 | -- - implementing typeclasses 10 | -- - forcing/laziness 11 | -- 12 | -- Useful type classes to know: 13 | -- - Eq 14 | -- - Ord 15 | -- - Show 16 | -- - Num 17 | -- - Functor 18 | 19 | -- Ex 1: hey, did you know you can implement your own operators in 20 | -- Haskell? Implement the operator %$ that combines two strings like 21 | -- this: 22 | -- 23 | -- "aa" %$ "foo" ==> "aafooaa" 24 | -- 25 | -- and the operator *! that takes a value and a number and produces a 26 | -- list that repeats the value that many times: 27 | -- 28 | -- True *! 3 ==> [True,True,True] 29 | 30 | (%$) :: String -> String -> String 31 | #ifdef sol 32 | x %$ y = x ++ y ++ x 33 | #else 34 | x %$ y = undefined 35 | #endif 36 | 37 | (*!) :: Int -> a -> [a] 38 | #ifdef sol 39 | n *! val = replicate n val 40 | #else 41 | n *! val = undefined 42 | #endif 43 | 44 | -- Ex 2: implement the function allEqual which returns True if all 45 | -- values in the list are equal. 46 | -- 47 | -- Examples: 48 | -- 49 | -- allEqual [] ==> True 50 | -- allEqual [1,2,3] ==> False 51 | -- allEqual [1,1,1] ==> True 52 | -- 53 | -- PS. check out the error message you get with your implementation if 54 | -- you remove the Eq a => constraint from the type! 55 | 56 | allEqual :: Eq a => [a] -> Bool 57 | #ifdef sol 58 | allEqual [] = True 59 | allEqual (x:xs) = all (==x) xs 60 | #else 61 | allEqual xs = undefined 62 | #endif 63 | 64 | -- Ex 3: implement the function secondSmallest that returns the second 65 | -- smallest value in the list, or Nothing if there is no such value. 66 | -- 67 | -- Examples: 68 | -- 69 | -- secondSmallest [1.0] ==> Nothing 70 | -- secondSmallest [1,1] ==> Just 1 71 | -- secondSmallest [5,3,7,2,3,1] ==> Just 2 72 | 73 | secondSmallest :: Ord a => [a] -> Maybe a 74 | #ifdef sol 75 | secondSmallest [] = Nothing 76 | secondSmallest [x] = Nothing 77 | secondSmallest xs = Just v 78 | where m = minimum xs 79 | xs' = delete m xs 80 | v = minimum xs' 81 | #else 82 | secondSmallest xs = undefined 83 | #endif 84 | 85 | -- Ex 4: find how two lists differ from each other. If they have 86 | -- different lengths, return 87 | -- Just " /= " 88 | -- if they have the same length, find the first index i for which the 89 | -- elements differ, and return 90 | -- Just " /= " 91 | -- if the lists are the same, return 92 | -- Nothing 93 | -- 94 | -- NB! Write the type signature for findDifference your self. Which 95 | -- type classes do you need? 96 | -- 97 | -- Examples: 98 | -- findDifference [True,False] [True,True] 99 | -- ==> Just "False /= True" 100 | -- findDifference [0,0,0] [0,0,0,0] 101 | -- ==> Just "3 /= 4" 102 | 103 | #ifdef sol 104 | findDifference :: (Eq a, Show a) => [a] -> [a] -> Maybe String 105 | findDifference xs ys 106 | | lx/=ly = Just (show lx ++ " /= " ++ show ly) 107 | | otherwise = go xs ys 108 | where lx = length xs 109 | ly = length ys 110 | go [] [] = Nothing 111 | go (x:xs) (y:ys) 112 | | x/=y = Just (show x ++ " /= " ++ show y) 113 | | otherwise = findDifference xs ys 114 | #else 115 | findDifference = undefined 116 | #endif 117 | 118 | -- Ex 5: compute the average of a list of values of the Fractional 119 | -- class. 120 | -- 121 | -- Hint! since Fractional is a subclass of Num, you have all 122 | -- arithmetic operations available 123 | -- 124 | -- Hint! you can use the function fromIntegral to convert the list 125 | -- length to a Fractional 126 | 127 | average :: Fractional a => [a] -> a 128 | #ifdef sol 129 | average xs = sum xs / fromIntegral (length xs) 130 | #else 131 | average xs = undefined 132 | #endif 133 | 134 | -- Ex 6: define an Eq instance for the type Foo below. 135 | 136 | data Foo = Bar | Quux | Xyzzy 137 | deriving Show 138 | 139 | instance Eq Foo where 140 | #ifdef sol 141 | Bar == Bar = True 142 | Quux == Quux = True 143 | Xyzzy == Xyzzy = True 144 | _ == _ = False 145 | #else 146 | (==) = error "implement me" 147 | #endif 148 | 149 | -- Ex 7: implement an Ord instance for Foo so that Quux < Bar < Xyzzy 150 | 151 | instance Ord Foo where 152 | #ifdef sol 153 | Quux <= Bar = True 154 | Bar <= Xyzzy = True 155 | Quux <= Xyzzy = True 156 | x <= y = x == y 157 | #else 158 | compare = error "implement me?" 159 | (<=) = error "and me?" 160 | min = error "and me?" 161 | max = error "and me?" 162 | #endif 163 | 164 | -- Ex 8: here is a type for a 3d vector. Implement an Eq instance for it. 165 | 166 | data Vector = Vector Integer Integer Integer 167 | deriving Show 168 | 169 | instance Eq Vector where 170 | #ifdef sol 171 | (Vector a b c) == (Vector a' b' c') = a==a' && b==b' && c==c' 172 | #else 173 | (==) = error "implement me" 174 | #endif 175 | 176 | -- Ex 9: implementa Num instance for Vector such that all the 177 | -- arithmetic operations work componentwise. 178 | -- 179 | -- You should probably check the docs for which methods Num has! 180 | -- 181 | -- Examples: 182 | -- 183 | -- Vector 1 2 3 + Vector 0 1 1 ==> Vector 1 3 4 184 | -- Vector 1 2 3 * Vector 0 1 2 ==> Vector 0 2 6 185 | -- abs (Vector (-1) 2 (-3)) ==> Vector 1 2 3 186 | -- signum (Vector (-1) 2 (-3)) ==> Vector (-1) 1 (-1) 187 | 188 | instance Num Vector where 189 | #ifdef sol 190 | Vector a b c + Vector a' b' c' = Vector (a+a') (b+b') (c+c') 191 | Vector a b c * Vector a' b' c' = Vector (a*a') (b*b') (c*c') 192 | signum (Vector a b c) = Vector (signum a) (signum b) (signum c) 193 | negate (Vector a b c) = Vector (negate a) (negate b) (negate c) 194 | abs (Vector a b c) = Vector (abs a) (abs b) (abs c) 195 | fromInteger x = Vector x x x 196 | #else 197 | #endif 198 | 199 | -- Ex 10: compute how many times each value in the list occurs. Return 200 | -- the frequencies as a list of (frequency,value) pairs. 201 | -- 202 | -- Hint! feel free to use functions from Data.List 203 | -- 204 | -- Example: 205 | -- freqs [False,False,False,True] 206 | -- ==> [(3,False),(1,True)] 207 | 208 | freqs :: Eq a => [a] -> [(Int,a)] 209 | #ifdef sol 210 | freqs [] = [] 211 | freqs (x:xs) = (count+1,x) : freqs left 212 | where (equals,left) = partition (==x) xs 213 | count = length equals 214 | #else 215 | freqs xs = undefined 216 | #endif 217 | 218 | -- Ex 11: implement an Eq instance for the following binary tree type 219 | 220 | data ITree = ILeaf | INode Int ITree ITree 221 | deriving Show 222 | 223 | instance Eq ITree where 224 | #ifdef sol 225 | ILeaf == ILeaf = True 226 | INode x l r == INode y l' r' = x==y && l==l' && r==r' 227 | _ == _ = False 228 | #else 229 | (==) = error "implement me" 230 | #endif 231 | 232 | -- Ex 12: here is a list type parameterized over the type it contains. 233 | -- Implement an instance "Eq a => Eq (List a)" that compares elements 234 | -- of the lists. 235 | 236 | data List a = Empty | LNode a (List a) 237 | deriving Show 238 | 239 | instance Eq a => Eq (List a) where 240 | #ifdef sol 241 | Empty == Empty = True 242 | Empty == _ = False 243 | LNode x xs == LNode y ys = x == y && xs == ys 244 | _ == _ = False 245 | #else 246 | (==) = error "implement me" 247 | #endif 248 | 249 | -- Ex 13: start by reading a bit about Functors. A Functor is a thing 250 | -- you can "map" over, e.g. lists, Maybes. 251 | -- 252 | -- Implement the function incrementAll that takes a functorial value 253 | -- and increments each number inside by one. 254 | -- 255 | -- Examples: 256 | -- incrementAll [1,2,3] ==> [2,3,4] 257 | -- incrementAll (Just 3.0) ==> Just 4.0 258 | 259 | incrementAll :: (Functor f, Num n) => f n -> f n 260 | #ifdef sol 261 | incrementAll x = fmap (+1) x 262 | #else 263 | incrementAll x = undefined 264 | #endif 265 | 266 | -- Ex 14: below you'll find a type Result that works a bit like Maybe, 267 | -- but there are two different types of "Nothings": one with and one 268 | -- without an error description. 269 | -- 270 | -- Implement the instance Functor Result 271 | 272 | data Result a = MkResult a | NoResult | Failure String 273 | deriving (Show,Eq) 274 | 275 | instance Functor Result where 276 | #ifdef sol 277 | fmap f (MkResult x) = MkResult (f x) 278 | fmap _ NoResult = NoResult 279 | fmap _ (Failure s) = (Failure s) 280 | #else 281 | fmap f result = error "implement me" 282 | #endif 283 | 284 | -- Ex 15: Implement the instance Functor List (for the datatype List 285 | -- from ex 12) 286 | 287 | instance Functor List where 288 | #ifdef sol 289 | fmap f Empty = Empty 290 | fmap f (LNode x xs) = LNode (f x) (fmap f xs) 291 | #else 292 | #endif 293 | 294 | -- Ex 16: Fun a is a type that wraps a function Int -> a. Implement a 295 | -- Functor instance for it. 296 | -- 297 | -- Figuring out what the Functor instance should do is most of the 298 | -- puzzle. 299 | 300 | data Fun a = Fun (Int -> a) 301 | 302 | runFun :: Fun a -> Int -> a 303 | runFun (Fun f) x = f x 304 | 305 | instance Functor Fun where 306 | #ifdef sol 307 | -- An explanation in case the definition below puzzles you 308 | -- 309 | -- In this case fmap :: (a->b) -> Fun a -> Fun b 310 | -- so the definition should looklike this: fmap f (Fun g) = Fun h 311 | -- where f :: a->b, g :: Int->a, h :: Int->b 312 | -- 313 | -- Let's define h. h is a function that takes an int, so 314 | -- h i = .... 315 | -- h returns something of type b, and the only way to produce 316 | -- something of type b is the function f, so 317 | -- h i = f (...) 318 | -- f takes an a, and the only way we can get an a is g, so 319 | -- h i = f (g (...)) 320 | -- g takes an int, and i is an int 321 | -- h i = f (g i) 322 | -- we can rewrite this as 323 | -- h = f . g 324 | -- Thus: 325 | fmap f (Fun g) = Fun (f.g) 326 | #else 327 | #endif 328 | 329 | -- Ex 17: this and the next exercise serve as an introduction for the 330 | -- next week. 331 | -- 332 | -- The module System.Random has the typeclass RandomGen that 333 | -- represents a random generator. The class Random is for values that 334 | -- can be randomly generated by RandomGen. 335 | -- 336 | -- The relevant function in System.Random is 337 | -- random :: (Random a, RandomGen g) => g -> (a, g) 338 | -- that takes a random generator and returns a random value, and the 339 | -- new state of the generator (remember purity!) 340 | -- 341 | -- Implement the function threeRandom that generates three random 342 | -- values. You don't need to return the final state of the random 343 | -- generator (as you can see from the return type). 344 | -- 345 | -- NB! if you use the same generator multiple times, you get the same 346 | -- output. Remember to use the new generator returned by random. 347 | -- 348 | -- NB! the easiest way to get a RandomGen value is the function 349 | -- mkStdGen that takes a seed and returns a random generator. 350 | -- 351 | -- Examples: 352 | -- *W5> threeRandom (mkStdGen 1) :: (Int,Int,Int) 353 | -- (7917908265643496962,-1017158127812413512,-1196564839808993555) 354 | -- *W5> threeRandom (mkStdGen 2) :: (Bool,Bool,Bool) 355 | -- (True,True,False) 356 | 357 | threeRandom :: (Random a, RandomGen g) => g -> (a,a,a) 358 | #ifdef sol 359 | threeRandom g = (x,y,z) 360 | where (x,g1) = random g 361 | (y,g2) = random g1 362 | (z,_) = random g2 363 | #else 364 | threeRandom g = undefined 365 | #endif 366 | 367 | -- Ex 18: given a Tree (same type as on Week 3), randomize the 368 | -- contents of the tree. 369 | -- 370 | -- That is, you get a RandomGen and a Tree, and you should return a 371 | -- Tree with the same shape, but random values in the Nodes. 372 | -- 373 | -- This time you should also return the final state of the RandomGen 374 | -- 375 | -- Hint! the recursive solution is straightforward, but requires 376 | -- careful threading of the RandomGen versions. 377 | -- 378 | -- Examples: 379 | -- *W5> randomizeTree (Node 0 (Node 0 Leaf Leaf) Leaf) (mkStdGen 1) :: (Tree Char, StdGen) 380 | -- (Node '\603808' (Node '\629073' Leaf Leaf) Leaf,1054756829 1655838864) 381 | -- *W5> randomizeTree (Node True Leaf Leaf) (mkStdGen 2) :: (Tree Int, StdGen) 382 | -- (Node (-2493721835987381530) Leaf Leaf,1891679732 2103410263) 383 | 384 | 385 | data Tree a = Leaf | Node a (Tree a) (Tree a) 386 | deriving Show 387 | 388 | randomizeTree :: (Random a, RandomGen g) => Tree b -> g -> (Tree a,g) 389 | #ifdef sol 390 | randomizeTree Leaf g = (Leaf,g) 391 | randomizeTree (Node _ l r) g = (Node x l' r', g3) 392 | where (l',g1) = randomizeTree l g 393 | (r',g2) = randomizeTree r g1 394 | (x,g3) = random g2 395 | #else 396 | randomizeTree t g = undefined 397 | #endif 398 | -------------------------------------------------------------------------------- /templ/W6B.hs: -------------------------------------------------------------------------------- 1 | module W6 where 2 | 3 | import Control.Monad 4 | import Control.Monad.Trans.State 5 | import Data.Char 6 | 7 | -- Week 6: Monads 8 | -- 9 | -- Monads are a famously hard topic in learning Haskell. My advise is 10 | -- to try different approaches to understanding monads while writing 11 | -- as much code as possible. Merely contemplating various metaphors 12 | -- for monads will not lead to understanding. 13 | -- 14 | -- I recommend starting at these exercises only once you've read a bit 15 | -- about monads. The two standard monads the exercises will use are 16 | -- Maybe and State. Maybe is simple enough, but State requires some 17 | -- looking at. 18 | -- 19 | -- If you've yet to find a monad guide to your liking, try Learn You A 20 | -- Haskell For Great Good. The monad chapter is here: 21 | -- 22 | -- http://learnyouahaskell.com/a-fistful-of-monads 23 | -- 24 | -- But you should probably browse through the previous chapter about 25 | -- Functors too. The State monad is introduced a bit later: 26 | -- 27 | -- http://learnyouahaskell.com/for-a-few-monads-more#state 28 | 29 | 30 | -- Ex 1: let's use the Maybe type to talk about computations that can 31 | -- fail. A value of type "a -> Maybe b" takes an argument of type a 32 | -- and can either succesfully return a value of type b, or fail and 33 | -- return Nothing. 34 | -- 35 | -- Here is the operator ?> that defines the natural way of chaining 36 | -- computations like this. We get the result of the previous 37 | -- computation (Maybe a) and the next computation (a -> Maybe b) and 38 | -- return the new result (Maybe b): 39 | 40 | (?>) :: Maybe a -> (a -> Maybe b) -> Maybe b 41 | Nothing ?> _ = Nothing -- In case of failure, propagate failure 42 | Just x ?> f = f x -- In case of sucess, run the next computation 43 | 44 | -- Your task is to help implement the function readName that given a 45 | -- string like "Forename Surname" produces the pair ("Forname", 46 | -- "Surname"). readName should fail (return Nothing) in the following 47 | -- cases: 48 | -- 49 | -- 1. the input string doesn't contain a space 50 | -- 2. one of the names contains numbers 51 | -- 3. one of the names doesn't start with a capital letter 52 | -- 53 | -- The function readNames has already been implemented using ?>. You 54 | -- need to define the functions split, checkNumber and checkCapitals 55 | -- so that readNames works correctly. 56 | 57 | -- DO NOT touch this definition! 58 | readNames :: String -> Maybe (String,String) 59 | readNames s = 60 | split s 61 | ?> 62 | checkNumber 63 | ?> 64 | checkCapitals 65 | 66 | -- split should split a string into two words. If the input doesn't 67 | -- contain a space, Nothing should be returned 68 | -- 69 | -- (NB! There are obviously other corner cases like the inputs " " and 70 | -- "a b c", but you don't need to worry about those here) 71 | split :: String -> Maybe (String,String) 72 | #ifdef sol 73 | split s = case break (==' ') s of (a,' ':b) -> Just (a,b) 74 | _ -> Nothing 75 | #else 76 | split s = undefined 77 | #endif 78 | 79 | -- checkNumber should take a pair of two strings and return then 80 | -- unchanged if they don't contain numbers. Otherwise Nothing is 81 | -- returned. 82 | checkNumber :: (String, String) -> Maybe (String, String) 83 | #ifdef sol 84 | notNumber c = not $ elem c "0123456789" 85 | checkNumber (for,sur) = if all notNumber for && all notNumber sur 86 | then Just (for,sur) 87 | else Nothing 88 | #else 89 | checkNumber (for,sur) = undefined 90 | #endif 91 | 92 | -- checkCapitals should take a pair of two strings and return them 93 | -- unchanged if both start with a capital letter. Otherwise Nothing is 94 | -- returned. 95 | checkCapitals :: (String, String) -> Maybe (String, String) 96 | #ifdef sol 97 | checkCapitals (for,sur) = if isUpper (for!!0) && isUpper (sur!!0) 98 | then Just (for,sur) 99 | else Nothing 100 | #else 101 | checkCapitals (for,sur) = undefined 102 | #endif 103 | 104 | -- Ex 2: implement a function myTake that works just like take, but 105 | -- 1. the arguments are of types Maybe Int and Maybe [a] 106 | -- 2. if either of the arguments is Nothing, Nothing is returned 107 | -- 3. if the Int is larger than the length of the list, Nothing is returned 108 | -- 109 | -- Use the Maybe monad, i.e. the >>= operator or do-notation. 110 | -- 111 | -- DO NOT use pattern matching for Maybe. 112 | -- 113 | -- Examples: 114 | -- myTake (Just 2) (Just [5,6,7]) 115 | -- ==> Just [5,6] 116 | -- myTake Nothing (Just [5,6,7]) 117 | -- ==> Nothing 118 | -- myTake (Just 2) Nothing 119 | -- ==> Nothing 120 | -- myTake (Just 4) (Just [5,6,7]) 121 | -- ==> Nothing 122 | 123 | myTake :: Maybe Int -> Maybe [a] -> Maybe [a] 124 | #ifdef sol 125 | myTake mi ml = do i <- mi 126 | l <- ml 127 | when (i>length l) $ Nothing 128 | return $ take i l 129 | #else 130 | myTake mi ml = undefined 131 | #endif 132 | 133 | -- Ex 3: given a list of indices and a list of values, return the sum 134 | -- of the values in the given indices. You should fail if any of the 135 | -- indices is too large or too small. 136 | -- 137 | -- Use the Maybe monad, i.e. the >>= operator or do-notation. 138 | -- 139 | -- DO NOT use pattern matching for Maybe. 140 | -- 141 | -- Hint! implementa a function safeIndex :: [a] -> Int -> Maybe a 142 | -- 143 | -- Examples: 144 | -- selectSum [0..10] [4,6,9] 145 | -- Just 19 146 | -- selectSum [0..10] [4,6,9,20] 147 | -- Nothing 148 | 149 | selectSum :: Num a => [a] -> [Int] -> Maybe a 150 | #ifdef sol 151 | selectSum xs is = liftM sum $ mapM (safeIndex xs) is 152 | 153 | safeIndex :: [a] -> Int -> Maybe a 154 | safeIndex [] _ = Nothing 155 | safeIndex (x:xs) 0 = Just x 156 | safeIndex (x:xs) n = safeIndex xs (n-1) 157 | #else 158 | selectSum xs is = undefined 159 | #endif 160 | 161 | -- Ex 4: below you'll find the implementation of a Logger monad and 162 | -- some examples of its use. 163 | -- 164 | -- Your task is to implement a function binom that computes binomial 165 | -- coefficients recursively with the following formulae: 166 | -- 167 | -- B(n,0) = 1 168 | -- B(0,k) = 0, when k>0 169 | -- B(n,k) = B(n-1,k-1) + B(n-1,k) 170 | -- 171 | -- Every call to the function should be logged as "B(n,k)". 172 | -- Invocations should be logged in execution order. 173 | -- 174 | -- Examples: 175 | -- binom 0 0 ==> Logger ["B(0,0)"] 1 176 | -- binom 0 7 ==> Logger ["B(0,7)"] 0 177 | -- binom 1 1 ==> Logger ["B(0,0)","B(0,1)","B(1,1)"] 1 178 | -- binom 2 2 ==> Logger ["B(0,0)","B(0,1)","B(1,1)","B(0,1)","B(0,2)","B(1,2)","B(2,2)"] 1 179 | 180 | data Logger a = Logger [String] a 181 | deriving Show 182 | 183 | instance Functor Logger where 184 | fmap f (Logger l a) = Logger l (f a) 185 | 186 | instance Monad Logger where 187 | return x = Logger [] x 188 | Logger la a >>= f = Logger (la++lb) b 189 | where Logger lb b = f a 190 | 191 | -- disregard this. in recent versions of the Haskell standard library, 192 | -- all Monads must also be Applicative. These exercises don't really 193 | -- cover Applicative. 194 | instance Applicative Logger where 195 | pure = return 196 | (<*>) = ap 197 | 198 | 199 | msg :: String -> Logger () 200 | msg s = Logger [s] () 201 | 202 | -- An example 203 | multiplyLog :: Int -> Int -> Logger Int 204 | multiplyLog a b = do 205 | msg ("first arg is " ++ show a) 206 | msg ("second arg is " ++ show b) 207 | let ret = a * b 208 | msg ("returning product " ++ show ret) 209 | return ret 210 | 211 | productLog :: [Int] -> Logger Int 212 | productLog [] = do 213 | msg "recursion base case" 214 | return 1 215 | 216 | productLog (x:xs) = do 217 | msg ("head "++show x) 218 | msg ("recurse on "++show xs) 219 | productXs <- productLog xs 220 | multiplyLog x productXs 221 | 222 | -- Try running e.g. productLog [1,2,3] in GHCi! 223 | 224 | -- Implement this: 225 | binom :: Integer -> Integer -> Logger Integer 226 | #ifdef sol 227 | binom n 0 = msg ("B("++show n++",0)") >> return 1 228 | binom 0 k = msg ("B(0,"++show k++")") >> return 0 229 | binom n k = do a <- binom (n-1) (k-1) 230 | b <- binom (n-1) k 231 | msg ("B("++show n++","++show k++")") 232 | return $ a + b 233 | #else 234 | binom n k = undefined 235 | #endif 236 | 237 | -- Ex 5: using the State monad, write the operation update that first 238 | -- multiplies the state by 2 and then adds one to it. The state has 239 | -- type Int. 240 | -- 241 | -- Example: 242 | -- runState update 3 243 | -- ==> ((),7) 244 | 245 | update :: State Int () 246 | #ifdef sol 247 | update = do x <- get 248 | put (2*x) 249 | y <- get 250 | put (y+1) 251 | #else 252 | update = undefined 253 | #endif 254 | 255 | -- Ex 6: using the State monad, walk through a list and increment the 256 | -- state by one each time a given element is encountered. Additionally 257 | -- you should return the length of the list. 258 | -- 259 | -- Do this by implementing a recursive State operation lengthAndCount. 260 | -- Do not use the functions length or filter. 261 | -- 262 | -- Example: 263 | -- runState (lengthAndCount True [False,True,False,True,False]) 0 264 | -- ==> (5,2) 265 | 266 | lengthAndCount :: Eq a => a -> [a] -> State Int Int 267 | #ifdef sol 268 | lengthAndCount x [] = return 0 269 | lengthAndCount x (y:ys) = do len <- lengthAndCount x ys 270 | when (x==y) (modify (+1)) 271 | return $ len+1 272 | #else 273 | lengthAndCount x ys = undefined 274 | #endif 275 | 276 | -- Ex 7: using a state of type [(a,Int)] we can keep track of the 277 | -- numbers of occurrences of elements of type a. For instance 278 | -- [('a',1),('x',3)] means that we've seen one 'a' and three 'x's. 279 | -- 280 | -- Implement a State monad operation count that registers the 281 | -- occurrence of the given value. 282 | -- 283 | -- Examples: 284 | -- runState (count True) [] 285 | -- ==> ((),[(True,1)]) 286 | -- runState (count 7) [] 287 | -- ==> ((),[(7,1)]) 288 | -- runState (count 'a') [('a',1),('b',3)] 289 | -- ==> ((),[('a',2),('b',3)]) 290 | -- 291 | -- PS. Order of the list of pairs doesn't matter 292 | 293 | count :: Eq a => a -> State [(a,Int)] () 294 | #ifdef sol 295 | count x = modify (inc x) 296 | where inc x [] = [(x,1)] 297 | inc x ((y,k):ys) 298 | | x == y = (y,k+1):ys 299 | | otherwise = (y,k):inc x ys 300 | #else 301 | count x = return () 302 | #endif 303 | 304 | -- Ex 8: given a list of values, replace each value by a number saying 305 | -- which occurrence of the value this was in the list. 306 | -- 307 | -- Do this in the State monad, using the operation count you just 308 | -- defined. 309 | -- 310 | -- Hint: the function lookup will help 311 | -- 312 | -- Examples: 313 | -- runState (occurrences [True,True,True,False,False]) [] 314 | -- ==> ([1,2,3,1,2],[(True,3),(False,2)]) 315 | -- runState (occurrences [5,5,6,6,5,6,7]) [] 316 | -- ==> ([1,2,1,2,3,3,1],[(5,3),(6,3),(7,1)]) 317 | 318 | occurrences :: (Eq a) => [a] -> State [(a,Int)] [Int] 319 | #ifdef sol 320 | occurrences [] = return [] 321 | occurrences (x:xs) = do 322 | count x 323 | occs <- get 324 | let Just cnt = lookup x occs 325 | rest <- occurrences xs 326 | return $ cnt:rest 327 | #else 328 | occurrences xs = undefined 329 | #endif 330 | 331 | -- Ex 9: implement the function ifM, that takes three monadic 332 | -- operations. If the first of the operations returns True, the second 333 | -- operation should be run. Otherwise the third operation should be 334 | -- run. 335 | -- 336 | -- Examples (test is defined below): 337 | -- runState (put 11 >> ifM test (return 'a') (return 'b')) 0 338 | -- ==> ('b',11) 339 | -- runState (put 9 >> ifM test (return 'a') (return 'b')) 0 340 | -- ==> ('a',9) 341 | 342 | test :: State Int Bool 343 | test = do 344 | x <- get 345 | return (x<10) 346 | 347 | ifM :: Monad m => m Bool -> m a -> m a -> m a 348 | #ifdef sol 349 | ifM opBool opThen opElse = do 350 | b <- opBool 351 | if b then opThen else opElse 352 | #else 353 | ifM opBool opThen opElse = undefined 354 | #endif 355 | 356 | -- Ex 10: the standard library function Control.Monad.mapM defines a 357 | -- monadic map operation. Some examples of using it (safeDiv is define 358 | -- below): 359 | -- 360 | -- mapM (safeDiv 10.0) [1.0,5.0,2.0] => Just [10.0,2.0,5.0] 361 | -- mapM (safeDiv 10.0) [1.0,0.0,2.0] => Nothing 362 | -- 363 | -- Your task is to implement the function mapM2 that works like mapM, 364 | -- but there are two lists and the operation takes two arguments. If 365 | -- the lists are of different lists, you can stop processing them once 366 | -- the shorter one ends. 367 | -- 368 | -- Examples: 369 | -- mapM2 (\x y -> Just (x+y)) [1,2,3] [6,7] 370 | -- ==> Just [7,9] 371 | -- runState (mapM2 (\x y -> if x then modify (+y) else return () ) [True,False,True] [1,2,4]) 0 372 | -- ==> ([(),(),()],5) 373 | 374 | safeDiv :: Double -> Double -> Maybe Double 375 | safeDiv x 0.0 = Nothing 376 | safeDiv x y = Just (x/y) 377 | 378 | mapM2 :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c] 379 | #ifdef sol 380 | mapM2 op [] _ = return [] 381 | mapM2 op _ [] = return [] 382 | mapM2 op (x:xs) (y:ys) = do 383 | v <- op x y 384 | rest <- mapM2 op xs ys 385 | return (v:rest) 386 | #else 387 | mapM2 op xs ys = undefined 388 | #endif 389 | 390 | -- Ex 11: Funnykiztan has cities that are named with by 0..n-1. Some 391 | -- cities are connected by roads. Your task is to find out if you can 392 | -- can get from city A to city B by following the roads. 393 | -- 394 | -- The road network is given as an adjacency list, which means a list 395 | -- of lists [[Int]] where the i'th list gives the cities to which city 396 | -- i has a road to. 397 | -- 398 | -- For example the road network: 399 | -- 400 | -- 0--1 401 | -- |\ | 402 | -- | \| 403 | -- 2--3 404 | -- 405 | -- would be represented as: 406 | -- [[1,2,3] 407 | -- ,[0,3] 408 | -- ,[0,3] 409 | -- ,[0,1,2]] 410 | -- 411 | -- Below you'll find the function routeExists that solves the task. 412 | -- However a very important piece of the function, the helper function 413 | -- dfs is still unimplemented. 414 | -- 415 | -- The function dfs is intended to run a Depth-First Search. If you 416 | -- don't know what this means, have a look in wikipedia. 417 | -- 418 | -- Simply put, dfs uses roads to travel from city to city using roads, 419 | -- using a state of type [Int] to keep track of which cities have been 420 | -- visited. This is important because the road network will have 421 | -- cycles. 422 | -- 423 | -- Examples: 424 | -- routeExists example1 0 2 ==> True 425 | -- routeExists example2 0 2 ==> True 426 | -- routeExists example2 3 5 ==> False 427 | -- runState (dfs example2 0) [] ==> ((),[2,3,1,0]) 428 | -- When 1 and 2 have already been visited, dfs won't proceed to city 3: 429 | -- runState (dfs example1 0) [1,2] ==> ((),[0,1,2]) 430 | -- 431 | -- A word on tests. The tests first test the function dfs in a couple 432 | -- of simple situations. After this they test the function routeExists 433 | -- more extensively. The tests look at the state produced by dfs but 434 | -- do not care in which order it is. 435 | 436 | -- Three cities, each connected to the two others 437 | example1 :: [[Int]] 438 | example1 = [[1,2] 439 | ,[0,2] 440 | ,[0,1]] 441 | 442 | -- A more two-part network: 443 | -- 444 | -- 0 -- 1 445 | -- | | 4 -- 5 446 | -- | | 447 | -- 2 -- 3 448 | example2 :: [[Int]] 449 | example2 = [[1,2] 450 | ,[0,3] 451 | ,[0,3] 452 | ,[1,2] 453 | ,[5] 454 | ,[4]] 455 | 456 | routeExists :: [[Int]] -> Int -> Int -> Bool 457 | routeExists cities i j = j `elem` execState (dfs cities i) [] 458 | 459 | dfs :: [[Int]] -> Int -> State [Int] () 460 | #ifdef sol 461 | dfs cities i = do 462 | visited <- get 463 | when (not (elem i visited)) $ 464 | do modify (i:) 465 | let neighs = cities !! i 466 | mapM_ (dfs cities) neighs 467 | #else 468 | dfs cities i = undefined 469 | #endif 470 | 471 | -- Ex 12: define the function orderedPairs that returns all pairs 472 | -- (i,j) such that i [(1,3),(1,2),(1,4),(3,4),(2,4)] 479 | -- 480 | -- PS. once again the tests don't care about the order of results 481 | 482 | orderedPairs :: [Int] -> [(Int,Int)] 483 | #ifdef sol 484 | orderedPairs xs = do 485 | i <- inds 486 | j <- inds 487 | let a = xs !! i 488 | b = xs !! j 489 | if i [0] 506 | -- sums [1] 507 | -- ==> [1,0] 508 | -- sums [1,2,4] 509 | -- ==> [7,3,5,1,6,2,4,0] 510 | 511 | sums :: [Int] -> [Int] 512 | #ifdef sol 513 | sums [] = [0] 514 | sums (x:xs) = do include <- [True,False] 515 | sumRest <- sums xs 516 | if include then return (x+sumRest) else return sumRest 517 | #else 518 | sums xs = undefined 519 | #endif 520 | 521 | -- Ex 14: the standard library defines the function 522 | -- 523 | -- foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a 524 | -- 525 | -- This function behaves like foldr, but the operation used is 526 | -- monadic. foldM f acc xs works by running f for each element in xs, 527 | -- giving it also the result of the previous invocation of f. 528 | -- 529 | -- Your task is to implement the functions f1 and f2 so that the 530 | -- functions sumBounded and sumNotTwice work. 531 | 532 | -- sumBounded computes the sum of a list. However if some prefix of 533 | -- the list has a sum of over k, Nothing is returned. 534 | -- 535 | -- Examples: 536 | -- sumBounded 5 [1,2,1,-2,3] 537 | -- ==> Just 5 538 | -- sumBounded 5 [1,2,3,1,-2] 539 | -- ==> Nothing 540 | sumBounded :: Int -> [Int] -> Maybe Int 541 | sumBounded k xs = foldM (f1 k) 0 xs 542 | 543 | f1 :: Int -> Int -> Int -> Maybe Int 544 | #ifdef sol 545 | f1 k acc x 546 | | x+acc > k = Nothing 547 | | otherwise = Just (x+acc) 548 | #else 549 | f1 k acc x = undefined 550 | #endif 551 | 552 | -- sumNotTwice computes the sum of a list, but ignores duplicated 553 | -- elements. 554 | -- 555 | -- Examples: 556 | -- sumNotTwice [3,-2,3] 557 | -- ==> 1 558 | -- sumNotTwice [1,2,-2,3] 559 | -- ==> 4 560 | sumNotTwice :: [Int] -> Int 561 | sumNotTwice xs = fst $ runState (foldM f2 0 xs) [] 562 | 563 | f2 :: Int -> Int -> State [Int] Int 564 | #ifdef sol 565 | f2 acc x = do seen <- get 566 | if elem x seen then return acc else modify (x:) >> return (x+acc) 567 | #else 568 | f2 acc x = undefined 569 | #endif 570 | 571 | -- Ex 15: here is the Result type from last week. Implement a Monad 572 | -- Result instance that behaves roughly like the Monad Maybe instance. 573 | -- 574 | -- That is, 575 | -- 1. MkResults behave like Just 576 | -- 2. If part of computation produces NoResult, the whole computation 577 | -- produces NoResult (just like Nothing) 578 | -- 3. Similarly, if we get a Failure "reason" value, the whole 579 | -- computation produces Failure "reason" 580 | -- 581 | -- Additionally, the method "fail" of the Monad type class should 582 | -- produce a Failure. 583 | -- 584 | -- Examples: 585 | -- MkResult 1 >> Failure "boom" >> MkResult 2 586 | -- ==> Failure "boom" 587 | -- MkResult 1 >> NoResult >> Failure "not reached" 588 | -- ==> NoResult 589 | -- MkResult 1 >>= (\x -> MkResult (x+1)) 590 | -- ==> MkResult 2 591 | 592 | data Result a = MkResult a | NoResult | Failure String deriving (Show,Eq) 593 | 594 | -- A straightforward Functor instance 595 | instance Functor Result where 596 | fmap f (MkResult a) = MkResult (f a) 597 | fmap _ NoResult = NoResult 598 | fmap _ (Failure s) = Failure s 599 | 600 | -- disregard this. in recent versions of the Haskell standard library, 601 | -- all Monads must also be Applicative. These exercises don't really 602 | -- cover Applicative. 603 | instance Applicative Result where 604 | pure = return 605 | (<*>) = ap 606 | 607 | instance Monad Result where 608 | #ifdef sol 609 | return = MkResult 610 | fail s = Failure s 611 | MkResult a >>= f = f a 612 | NoResult >>= _ = NoResult 613 | Failure x >>= _ = Failure x 614 | #else 615 | -- implement return and >>= 616 | #endif 617 | 618 | -- Ex 16: Here is the type SL that combines the State and Logger 619 | -- types. Implement an instance Monad SL, that behaves like the 620 | -- combination of State and Logger. That is, state is propagated from 621 | -- one operation to the next, and log messages are stored in the order 622 | -- they are produced. 623 | -- 624 | -- To simplify the type signatures, the type of the state has been set 625 | -- to Int, instead of being a parameter like in the standard State 626 | -- monad. 627 | -- 628 | -- This is a tough one. Keep trying and you'll get it! 629 | -- 630 | -- You might find it easier to start with the Functor instance 631 | -- 632 | -- Examples: 633 | -- runSL (putSL 2 >> msgSL "hello" >> getSL) 0 634 | -- ==> (2,2,["hello"]) 635 | -- runSL (replicateM_ 5 (modifySL (+1) >> getSL >>= \x -> msgSL ("got "++show x))) 1 636 | -- ==> ((),6,["got 2","got 3","got 4","got 5","got 6"]) 637 | 638 | data SL a = SL (Int -> (a,Int,[String])) 639 | 640 | -- Run an SL operation with the given starting state 641 | runSL :: SL a -> Int -> (a,Int,[String]) 642 | runSL (SL f) state = f state 643 | 644 | -- Write a log message 645 | msgSL :: String -> SL () 646 | msgSL msg = SL (\s -> ((),s,[msg])) 647 | 648 | -- Fetch the state 649 | getSL :: SL Int 650 | getSL = SL (\s -> (s,s,[])) 651 | 652 | -- Overwrite the state 653 | putSL :: Int -> SL () 654 | putSL s' = SL (\s -> ((),s',[])) 655 | 656 | -- Modify the state 657 | modifySL :: (Int->Int) -> SL () 658 | modifySL f = SL (\s -> ((),f s,[])) 659 | 660 | instance Functor SL where 661 | #ifdef sol 662 | fmap f (SL g) = SL (\s -> let (a,s',log) = g s in (f a, s', log)) 663 | #else 664 | -- implement fmap 665 | #endif 666 | 667 | -- again, disregard this 668 | instance Applicative SL where 669 | pure = return 670 | (<*>) = ap 671 | 672 | instance Monad SL where 673 | #ifdef sol 674 | return x = SL (\s -> (x,s,[])) 675 | op >>= f = SL g 676 | where g state0 = let (v,state1,log) = runSL op state0 677 | op2 = f v 678 | (v2,state2,log2) = runSL op2 state1 679 | in (v2,state2,log++log2) 680 | #else 681 | -- implement return and >>= 682 | #endif 683 | -------------------------------------------------------------------------------- /templ/W7B.hs: -------------------------------------------------------------------------------- 1 | module W7 where 2 | 3 | import Data.List 4 | import Control.Monad.State 5 | 6 | -- Week 7: recap 7 | 8 | -- Ex 1: implement the function pyramid that draws a pyramid like this: 9 | -- 10 | -- * 11 | -- *** 12 | -- ***** 13 | -- ******* 14 | -- ********* 15 | -- *********** 16 | -- 17 | -- The function is given the height of the pyramid as its argument. 18 | -- 19 | -- Examples: 20 | -- pyramidi 1 ==> "*\n" 21 | -- pyramidi 2 ==> " *\n***\n" 22 | -- pyramidi 3 ==> " *\n ***\n*****\n" 23 | -- 24 | -- PS. you can test the the function like this in ghci: putStr (pyramidi 5) 25 | 26 | pyramid :: Int -> String 27 | #ifdef sol 28 | pyramid n = unlines $ p n 29 | where p 1 = ["*"] 30 | p n = map (' ':) (p (n-1)) ++ [replicate (2*n-1) '*'] 31 | #else 32 | pyramid n = undefined 33 | #endif 34 | 35 | -- Ex 2: collect every second element from the given list. 36 | -- 37 | -- DO NOT use list functions, only pattern matching and recursion. 38 | -- 39 | -- Examples: 40 | -- everySecond [1,2,3,4,5] 41 | -- ==> [1,3,5] 42 | -- everySecond [0,7,8,1,4,2] 43 | -- ==> [0,8,4] 44 | -- everySecond [] 45 | -- ==> [] 46 | 47 | everySecond :: [a] -> [a] 48 | #ifdef sol 49 | everySecond xs = yes xs 50 | where yes [] = [] 51 | yes (x:xs) = x:no xs 52 | no [] = [] 53 | no (_:xs) = yes xs 54 | #else 55 | everySecond xs = undefined 56 | #endif 57 | 58 | -- Ex 3: given a list, return a pair of functions (get,wrap) such that 59 | -- * get i -- returns element i of the list 60 | -- * query x -- returns True if x is contained in the list 61 | -- 62 | -- Example: 63 | -- let (get,query) = wrap [5,6,7] in (get 0, query 6, get 2, query 2) 64 | -- ==> (5,True,7,False) 65 | 66 | wrap :: Eq a => [a] -> (Int -> a, a -> Bool) 67 | #ifdef sol 68 | wrap xs = ((xs!!),\x -> elem x xs) 69 | #else 70 | wrap xs = undefined 71 | #endif 72 | 73 | -- Tehtävä 4: Toteuta funktio nousevat, joka pilkkoo lukulistan 74 | -- (aidosti) nouseviin pätkiin. 75 | -- 76 | -- Saat käyttää kaikkia standardikirjaston listafunktioita. 77 | -- 78 | -- Esimerkkejä: 79 | 80 | -- Ex 4: split the given list into (monotonically) increasing pieces. 81 | -- 82 | -- Feel free to use any list functions. 83 | -- 84 | -- Examples: 85 | -- increasings [1,2,3] ==> [[1,2,3]] 86 | -- increasings [1,1] ==> [[1],[1]] 87 | -- increasings [4,7,9,3,6,1,2,2,5,8,0] 88 | -- ==> [[4,7,9],[3,6],[1,2],[2,5,8],[0]] 89 | 90 | increasings :: [Int] -> [[Int]] 91 | #ifdef sol 92 | increasings [] = [] 93 | increasings xs = first:increasings rest 94 | where 95 | (first,rest) = split xs 96 | split [] = ([],[]) 97 | split [x] = ([x],[]) 98 | split (x:y:xs) 99 | | x "frank" 120 | -- getNumber $ newStudent "frank" "0123" 121 | -- ==> "0123" 122 | -- getPoints $ newStudent "frank" "0123" 123 | -- ==> 0 124 | -- getPoints $ addPoints 100 $ addPoints 100 $ newStudent "frank" "0123" 125 | -- ==> 200 126 | -- getPoints $ addPoints (-1000) $ newStudent "x" "0" 127 | -- ==> 0 128 | 129 | #ifdef sol 130 | data Student = Student String String Int 131 | 132 | newStudent :: String -> String -> Student 133 | newStudent n o = Student n o 0 134 | 135 | getName :: Student -> String 136 | getName (Student n _ _) = n 137 | getNumber :: Student -> String 138 | getNumber (Student _ o _) = o 139 | getPoints :: Student -> Int 140 | getPoints (Student _ _ p) = p 141 | 142 | addPoints :: Int -> Student -> Student 143 | addPoints x (Student n o p) 144 | | x >= 0 = Student n o (p+x) 145 | | otherwise = Student n o p 146 | #else 147 | data Student = StudentUndefined 148 | 149 | newStudent :: String -> String -> Student 150 | newStudent nam num = undefined 151 | 152 | getName :: Student -> String 153 | getName s = undefined 154 | 155 | getNumber :: Student -> String 156 | getNumber s = undefined 157 | 158 | getPoints :: Student -> Int 159 | getPoints s = undefined 160 | 161 | addPoints :: Int -> Student -> Student 162 | addPoints x s = undefined 163 | #endif 164 | 165 | -- Ex 6: define a type Tree23 that represents a tree where each 166 | -- (internal) node has 2 or 3 children. 167 | -- 168 | -- The nodes don't need to contain any additional fields 169 | -- 170 | -- Define the functions treeHeight and treeSize that compute the 171 | -- height and size of a Tree23. 172 | -- 173 | -- To facilitate testing, also define the functions node2 and node3 174 | -- that create 2- and 3- child nodes, and the value leaf that 175 | -- represents a leaf. 176 | -- 177 | -- PS. Leave the "deriving Show" line intact because the tests want to 178 | -- print out trees 179 | 180 | #ifdef sol 181 | data Tree23 = Leaf | Node2 Tree23 Tree23 | Node3 Tree23 Tree23 Tree23 182 | deriving Show 183 | 184 | leaf :: Tree23 185 | leaf = Leaf 186 | node2 :: Tree23 -> Tree23 -> Tree23 187 | node2 = Node2 188 | node3 :: Tree23 -> Tree23 -> Tree23 -> Tree23 189 | node3 = Node3 190 | 191 | treeHeight :: Tree23 -> Int 192 | treeHeight Leaf = 0 193 | treeHeight (Node2 l r) = 1 + max (treeHeight l) (treeHeight r) 194 | treeHeight (Node3 l c r) = 1 + maximum [treeHeight l, treeHeight c, treeHeight r] 195 | 196 | treeSize :: Tree23 -> Int 197 | treeSize Leaf = 0 198 | treeSize (Node2 l r) = 1 + treeSize l + treeSize r 199 | treeSize (Node3 l c r) = 1 + treeSize l + treeSize c + treeSize r 200 | #else 201 | data Tree23 = Undefined 202 | deriving Show 203 | 204 | leaf :: Tree23 205 | leaf = undefined 206 | node2 :: Tree23 -> Tree23 -> Tree23 207 | node2 = undefined 208 | node3 :: Tree23 -> Tree23 -> Tree23 -> Tree23 209 | node3 = undefined 210 | 211 | treeHeight :: Tree23 -> Int 212 | treeHeight t = undefined 213 | 214 | treeSize :: Tree23 -> Int 215 | treeSize t = undefined 216 | #endif 217 | 218 | -- Ex 7: define a type MyString that represents a string and Eq and 219 | -- Ord instances for it. 220 | -- 221 | -- Also define the functions fromString and toString that convert 222 | -- from/to String. 223 | -- 224 | -- The Ord MyString instance should order the strings in 225 | -- _lexicographic_ order. This means shorter strings come before 226 | -- longer strings, and strings of the same length come in alphabetic 227 | -- order. 228 | -- 229 | -- You're free to choose the implmenetation of MyString as you wish. 230 | -- 231 | -- Examples: 232 | -- 233 | -- fromString "xyz" == fromString "xyz" ==> True 234 | -- fromString "xyz" == fromString "xyw" ==> False 235 | -- 236 | -- compare (fromString "abc") (fromString "ab") ==> GT 237 | -- compare (fromString "abc") (fromString "abd") ==> LT 238 | 239 | #ifdef sol 240 | data MyString = MyString String 241 | 242 | fromString :: String -> MyString 243 | fromString = MyString 244 | toString :: MyString -> String 245 | toString (MyString s) = s 246 | 247 | instance Eq MyString where 248 | MyString s == MyString s' = s == s' 249 | 250 | instance Ord MyString where 251 | compare (MyString s) (MyString s') 252 | | length s == length s' = cmp s s' 253 | | otherwise = compare (length s) (length s') 254 | where cmp [] [] = EQ 255 | cmp (a:as) (b:bs) 256 | | a == b = cmp as bs 257 | | otherwise = compare a b 258 | #else 259 | data MyString = MyStringUndefined 260 | 261 | fromString :: String -> MyString 262 | fromString s = undefined 263 | toString :: MyString -> String 264 | toString ms = undefined 265 | 266 | instance Eq MyString where 267 | (==) = error "implement me" 268 | 269 | instance Ord MyString where 270 | compare = error "implement me" 271 | #endif 272 | 273 | -- Ex 8: below you'll find a type Expr that represents arithmetic 274 | -- expressions. For instance (1+2)/3+4 would be represented as 275 | -- Plus (Div (Plus (Constant 1) (Constant 2)) (Constant 3)) (Constant 4) 276 | -- 277 | -- Implement the function safeEval :: Expr -> Maybe Int that computes 278 | -- the value of the given arithmetic expression. safeEval should 279 | -- return Nothing if a division by zero occurs somewhere along the 280 | -- way. 281 | -- 282 | -- Hint: the Maybe-monad 283 | -- 284 | -- Examples: 285 | -- safeEval (Plus (Constant 1) (Constant 1)) 286 | -- ==> Just 2 287 | -- safeEval (Div (Constant 6) (Constant 2)) 288 | -- ==> Just 3 289 | -- safeEval (Div (Constant 6) (Constant 0)) 290 | -- ==> Nothing 291 | -- safeEval (Plus (Constant 1) (Div (Constant 8) (Plus (Constant 2) (Constant (-2))))) 292 | -- ==> Nothing 293 | 294 | data Expr = Constant Int | Plus Expr Expr | Div Expr Expr 295 | deriving Show 296 | 297 | safeEval :: Expr -> Maybe Int 298 | #ifdef sol 299 | safeEval (Constant c) = return c 300 | safeEval (Plus e1 e2) = do 301 | a <- safeEval e1 302 | b <- safeEval e2 303 | return $ a+b 304 | safeEval (Div e1 e2) = do 305 | a <- safeEval e1 306 | b <- safeEval e2 307 | if b==0 then Nothing else return $ div a b 308 | #else 309 | safeEval e = undefined 310 | #endif 311 | 312 | -- Ex 9: implement the function test that gets a list of monadic 313 | -- predicates (of type Monad m => a -> m Bool) and a value (of type 314 | -- a). The predicates should be run on the value until a predicate 315 | -- that returns False is found. 316 | -- 317 | -- test should return False if one of the predicates returns False, or 318 | -- True if all of the predicates passed. 319 | -- 320 | -- Examples: 321 | -- 322 | -- Simple Maybe-tests: 323 | -- test [test1 2, test1 3, test1 5] 7 324 | -- ==> Just True 325 | -- test [test1 2, test1 3, test1 5] 4 326 | -- ==> Just False 327 | -- test [test1 2, test1 3, failTest] 4 328 | -- ==> Nothing 329 | -- test [test1 2, test1 3, failTest] 1 330 | -- ==> Just False 331 | -- 332 | -- Keeping track of tests run using State: 333 | -- runState (test [test2 4, test2 8, test2 10] 11) [] 334 | -- ==> (True,[10,8,4]) 335 | -- runState (test [test2 4, test2 8, test2 10] 5) [] 336 | -- ==> (False,[8,4]) 337 | -- runState (test [test2 4, test2 8, test2 10] 0) [] 338 | -- ==> (False,[4]) 339 | 340 | test1 :: Int -> Int -> Maybe Bool 341 | test1 k x = Just (x>k) 342 | 343 | failTest :: Int -> Maybe Bool 344 | failTest x = Nothing 345 | 346 | test2 :: Int -> Int -> State [Int] Bool 347 | test2 k x = do modify (k:) 348 | return (x>k) 349 | 350 | test :: Monad m => [a -> m Bool] -> a -> m Bool 351 | #ifdef sol 352 | test [] _ = return True 353 | test (t:ts) x = do b <- t x 354 | if b 355 | then test ts x 356 | else return False 357 | #else 358 | test ts x = undefined 359 | #endif 360 | 361 | -- Ex 10: using the State monad, create a state with the elements that 362 | -- occur in the given list an _odd_ number of times. 363 | -- 364 | -- The order of the list doesn't matter. 365 | -- 366 | -- Examples: 367 | -- runState (odds [1,2,3,1,2,1]) [] 368 | -- ==> ((),[1,3]) 369 | -- runState (odds [1,2,3,1,2,3,1,2,3]) [] 370 | -- ==> ((),[3,2,1]) 371 | 372 | odds :: Eq a => [a] -> State [a] () 373 | #ifdef sol 374 | odds [] = return () 375 | odds (x:xs) = modify (flip x) >> odds xs 376 | where flip x xs 377 | | elem x xs = delete x xs 378 | | otherwise = x:xs 379 | #else 380 | odds xs = undefined 381 | #endif 382 | --------------------------------------------------------------------------------