├── .gitignore ├── LICENSE ├── README.md ├── Unit01 ├── Lesson01.hs ├── Lesson02.hs ├── Lesson03.hs ├── Lesson04.hs ├── Lesson05.hs ├── Lesson06.hs ├── Lesson07.hs ├── Lesson08.hs ├── Lesson09.hs ├── Lesson10.hs ├── first_prog ├── first_prog.hs ├── hello └── hello.hs ├── Unit02 ├── Lesson11.hs ├── Lesson12.hs ├── Lesson13.hs ├── Lesson14.hs └── Lesson15.hs ├── Unit03 ├── Lesson16.hs ├── Lesson17.hs ├── Lesson17_Q2.hs ├── Lesson18.hs ├── Lesson19.hs └── Lesson20.hs ├── Unit04 ├── Example.hs ├── Example.java ├── Lesson21 │ ├── Lesson21.hs │ ├── fibo.hs │ └── pizza.hs ├── Lesson22 │ ├── Lesson22.hs │ ├── QC3.hs │ ├── QC4.hs │ ├── quotes.hs │ ├── simple_calc.hs │ ├── simple_calc_ans.hs │ ├── sum.hs │ └── sum_lazy.hs ├── Lesson23 │ ├── Lesson23.hs │ ├── bg_highlight.hs │ └── hello_world.hs ├── Lesson24 │ ├── Lesson24.hs │ ├── capitalize.hs │ ├── cp │ ├── cp.hs │ ├── fileCount_strict.hs │ ├── fileCounts │ ├── fileCounts.hs │ ├── goodbye.txt │ ├── hello.txt │ ├── hello1.txt │ └── stats.dat ├── Lesson25 │ ├── Lesson25.hs │ ├── glitcher │ ├── glitcher.hs │ ├── lovecraft.jpeg │ └── tatsuhiko.txt └── Lesson26 │ ├── books.html │ └── marc_to_html.hs ├── Unit05 ├── Lesson27.hs ├── Lesson28 │ ├── Lesson28.hs │ ├── dist.hs │ ├── min3.hs │ └── robots.hs ├── Lesson29.hs ├── Lesson30.hs ├── Lesson31.hs ├── Lesson32.hs ├── Lesson33.hs └── Unit05.hs ├── Unit06 ├── Lesson34 │ ├── Lesson34.hs │ ├── Main │ ├── Main.hs │ └── Palindrome.hs ├── Lesson35 │ ├── palindrome-checker │ │ ├── .gitignore │ │ ├── ChangeLog.md │ │ ├── LICENSE │ │ ├── README.md │ │ ├── Setup.hs │ │ ├── app │ │ │ └── Main.hs │ │ ├── package.yaml │ │ ├── palindrome-checker.cabal │ │ ├── src │ │ │ └── Lib.hs │ │ ├── stack.yaml │ │ └── test │ │ │ └── Spec.hs │ └── pizzas │ │ ├── .gitignore │ │ ├── ChangeLog.md │ │ ├── LICENSE │ │ ├── README.md │ │ ├── Setup.hs │ │ ├── app │ │ └── Main.hs │ │ ├── package.yaml │ │ ├── pizzas.cabal │ │ ├── src │ │ └── Lib.hs │ │ ├── stack.yaml │ │ └── test │ │ └── Spec.hs ├── Lesson36 │ └── palindrome-testing │ │ ├── .gitignore │ │ ├── ChangeLog.md │ │ ├── LICENSE │ │ ├── README.md │ │ ├── Setup.hs │ │ ├── app │ │ └── Main.hs │ │ ├── package.yaml │ │ ├── src │ │ └── Lib.hs │ │ ├── stack.yaml │ │ └── test │ │ └── Spec.hs └── Lesson37 │ └── primes │ ├── .gitignore │ ├── ChangeLog.md │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── app │ └── Main.hs │ ├── package.yaml │ ├── src │ └── Primes.hs │ ├── stack.yaml │ └── test │ └── Spec.hs ├── Unit07 ├── Lesson38.hs ├── Lesson39 │ └── http-lesson │ │ ├── .gitignore │ │ ├── ChangeLog.md │ │ ├── LICENSE │ │ ├── README.md │ │ ├── Setup.hs │ │ ├── app │ │ └── Main.hs │ │ ├── http-lesson.cabal │ │ ├── package.yaml │ │ ├── src │ │ └── Lib.hs │ │ ├── stack.yaml │ │ └── test │ │ └── Spec.hs ├── Lesson40 │ └── json-lesson │ │ ├── .gitignore │ │ ├── ChangeLog.md │ │ ├── LICENSE │ │ ├── README.md │ │ ├── Setup.hs │ │ ├── app │ │ ├── Book.hs │ │ ├── ErrorMessage.hs │ │ └── Main.hs │ │ ├── data.json │ │ ├── json-lesson.cabal │ │ ├── package.yaml │ │ ├── src │ │ └── Lib.hs │ │ ├── stack.yaml │ │ └── test │ │ └── Spec.hs ├── Lesson41 │ └── db-lesson │ │ ├── .gitignore │ │ ├── ChangeLog.md │ │ ├── LICENSE │ │ ├── README.md │ │ ├── Setup.hs │ │ ├── app │ │ ├── Main.hs │ │ └── tools.db │ │ ├── build_db.sql │ │ ├── db-lesson.cabal │ │ ├── package.yaml │ │ ├── src │ │ └── Lib.hs │ │ ├── stack.yaml │ │ ├── test │ │ └── Spec.hs │ │ └── tools.db └── Lesson42.hs ├── get-programming-with-haskell.cabal ├── stack.yaml └── stack.yaml.lock /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | 22 | # Windows 23 | *.exe 24 | 25 | Unit04/Lesson22/QC3 26 | Unit04/Lesson22/QC4 27 | Unit04/Lesson22/sum 28 | Unit04/Lesson22/sum_lazy 29 | Unit04/Lesson22/quotes 30 | Unit04/Lesson22/simple_calc 31 | Unit04/Lesson24/hello1.txt 32 | Unit04/Lesson25/glitched_lovecraft.jpeg 33 | Unit04/Lesson26/marc_to_html 34 | Unit04/Lesson26/sample.mrc 35 | Unit04/Lesson26/books.html 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Rhywun 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | #get-programming-with-haskell 2 | Coding along with the book by Will Kurt 3 | 4 | [2025 Update] 5 | 6 | NOTE 1: I am using Visual Studio Code with a couple plugins that ease things: 7 | 8 | 1. Haskell - provides the Haskell Language Server (HLS) with lots of IDE features 9 | 2. Better Comments Next - provides nice syntax coloring support for various things like TODOs and Notes - I have customized tags for chapter sections ("-- *") and inline execution ("-- >>>") 10 | 11 | NOTE 2: Current HLS defaults might give different results that they did a few years ago when formatting the code! 12 | 13 | NOTE 3: Files that I revisit today may be updated with inline executions (mentioned above in NOTE 1) which appear as comments beginning with "-- >>>" and which either didn't exist in 2018 or I was unaware of this functionality at that time! 14 | -------------------------------------------------------------------------------- /Unit01/Lesson01.hs: -------------------------------------------------------------------------------- 1 | module Lession01 where 2 | 3 | -- 4 | -- Summary 5 | -- 6 | 7 | -- Q1 8 | 9 | e0101 = 2 ^ 123 -- 10633823966279326983230456482242756608 10 | -------------------------------------------------------------------------------- /Unit01/Lesson02.hs: -------------------------------------------------------------------------------- 1 | module Lesson02 where 2 | 3 | simple x = x 4 | 5 | e1 = sqrt 4 -- 2.0 - Must be defined as the positive root only? 6 | 7 | y = 10 8 | -- y = 11 <- won't compile 9 | 10 | calcChange owed given = if given - owed > 0 then given - owed else 0 11 | 12 | -- Better: 13 | calcChange' owed given = if change > 0 then change else 0 14 | where change = given - owed 15 | 16 | -- QC3 17 | 18 | doublePlusTwo x = doubleX + 2 where doubleX = x * 2 19 | 20 | -- QC4 21 | -- 6 22 | 23 | -- 24 | -- Summary 25 | -- 26 | 27 | -- Q1 28 | -- Because an if without an else would not return a value if the if branch 29 | -- evaluated to false. 30 | 31 | -- Q2 32 | 33 | inc n = n + 1 34 | double n = 2 * n 35 | square n = n * n 36 | 37 | -- Q3 38 | 39 | f n = if even n then n - 2 else 3 * n + 1 40 | -------------------------------------------------------------------------------- /Unit01/Lesson03.hs: -------------------------------------------------------------------------------- 1 | module Lesson03 where 2 | 3 | -- 4 | -- Lambda functions 5 | -- 6 | 7 | lf1 = (\x -> x) 4 -- 4 8 | lf2 = (\x -> x) [1, 2, 3] -- [1,2,3] 9 | 10 | -- QC1 11 | 12 | qc11 = (\x -> 2 * x) 4 -- 8 13 | qc12 = (\x -> 2 * x) 5 -- 10 14 | qc13 = (\x -> 2 * x) 6 -- 12 15 | 16 | -- 17 | -- Writing your own where clause 18 | -- 19 | 20 | -- How can we rewrite this without `where`? 21 | sumSquareOrSquareSum x y = if sumSquare > squareSum 22 | then sumSquare 23 | else squareSum 24 | where 25 | sumSquare = x ^ 2 + y ^ 2 26 | squareSum = (x + y) ^ 2 27 | 28 | -- One solution - ouch: 29 | sumSquareOrSquareSum x y = 30 | if (x ^ 2 + y ^ 2) > ((x + y) ^ 2) then (x ^ 2 + y ^ 2) else (x + y) ^ 2 31 | 32 | -- Another - pass the computation functions to `body`: 33 | 34 | body sumSquare squareSum = 35 | if sumSquare > squareSum then sumSquare else squareSum 36 | 37 | sumSquareOrSquareSum' x y = body (x ^ 2 + y ^ 2) ((x + y) ^ 2) 38 | 39 | -- Finally, replace `body` with a lambda: 40 | sumSquareOrSquareSum'' x y 41 | = (\sumSquare squareSum -> 42 | if sumSquare > squareSum then sumSquare else squareSum 43 | ) 44 | (x ^ 2 + y ^ 2) 45 | ((x + y) ^ 2) 46 | 47 | -- QC2 48 | 49 | {- 50 | doubleDouble 3 -- 12 51 | -} 52 | doubleDouble x = dubs * 2 where dubs = x * 2 53 | 54 | {- 55 | doubleDouble' 3 -- 12 56 | -} 57 | doubleDouble' x = (\dubs -> dubs * 2) x * 2 58 | 59 | -- 60 | -- From lambda to let 61 | -- 62 | 63 | sumSquareOrSquareSum''' x y = 64 | let sumSquare = x ^ 2 + y ^ 2 65 | squareSum = (x + y) ^ 2 66 | in if sumSquare > squareSum then sumSquare else squareSum 67 | 68 | overwrite x = let x = 2 in let x = 3 in let x = 4 in x 69 | -- But... is this really overwriting? 70 | -- Seems to me like those x's are in different scopes, or...? 71 | 72 | -- QC3 73 | overwrite' x = (\x -> (\x -> (\x -> x) 4) 3) 2 74 | 75 | -- 76 | -- Practical lambda functions and lexical scope 77 | -- 78 | 79 | x = 4 80 | 81 | add1 y = y + x -- x is bound to top-level x 82 | -- y is bound to argument y 83 | 84 | add2 y = (\x -> y + x) 3 -- x is bound to lambda argument x 85 | -- y is bound to argument y 86 | 87 | add3 y = (\y -> (\x -> y + x) 1) 2 -- x is bound to lambda argument x 88 | -- y is bound to lambda argument y, 89 | -- function argument is ignored 90 | 91 | -- 92 | -- Summary 93 | -- 94 | 95 | -- Q1 96 | 97 | -- doubleDouble' x = (\dubs -> dubs * 2) x * 2 98 | doubleDouble'' = \x -> (\dubs -> dubs * 2) x * 2 99 | 100 | -- Q2 101 | 102 | {- 103 | counter1 4 -- hangs 104 | -} 105 | counter1 x = let x = x + 1 in let x = x + 1 in x 106 | 107 | {- 108 | counter2 4 = 6 109 | -} 110 | counter2 x = (\x -> x + 1) ((\x -> x + 1) x) 111 | -------------------------------------------------------------------------------- /Unit01/Lesson04.hs: -------------------------------------------------------------------------------- 1 | module Lesson04 where 2 | 3 | import Data.List 4 | import Data.Ord 5 | 6 | -- 7 | -- Consider this 8 | -- 9 | 10 | -- Note: To test myself, I'm attempting to answer the "Consider this" sections 11 | -- upon revisiting each chapter, using what I recall from previous experience 12 | 13 | getPrice :: (String -> String) -> String -> Float 14 | getPrice extractPrice url = parseString $ extractPrice url 15 | 16 | parseString :: String -> Float 17 | parseString = undefined 18 | 19 | -- 20 | -- Functions as arguments 21 | -- 22 | 23 | ifEvenInc n = if even n then n + 1 else n 24 | ifEvenDouble n = if even n then n * 2 else n 25 | ifEvenSquare n = if even n then n ^ 2 else n 26 | 27 | ifEven f x = if even x then f x else x 28 | -- ^ 29 | -- function as argument 30 | 31 | inc n = n + 1 32 | double n = n * 2 33 | square n = n ^ 2 34 | 35 | ifEvenInc' n = ifEven inc n 36 | ifEvenDouble' n = ifEven double n 37 | ifEvenSquare' n = ifEven square n 38 | 39 | -- 40 | 41 | e1 = ifEven (\x -> x ^ 2) 5 -- 5 42 | e2 = ifEven (\x -> x ^ 2) 6 -- 36 43 | 44 | -- QC1 45 | 46 | qc1 = ifEven (\x -> x ^ 3) 2 -- 8 47 | 48 | -- Example - custom sorting 49 | 50 | newOrder = 51 | [("Ian", "Curtis"), ("Bernard", "Sumner"), ("Peter", "Hook"), ("Stephen", "Morris")] 52 | 53 | e3 = sort newOrder 54 | -- [("Bernard","Sumner"),("Ian","Curtis"),("Peter","Hook"),("Stephen","Morris")] 55 | 56 | compareLastNames name1 name2 | lastName1 > lastName2 = GT 57 | | lastName1 < lastName2 = LT 58 | | otherwise = EQ 59 | where 60 | lastName1 = snd name1 61 | lastName2 = snd name2 62 | 63 | e4 = sortBy compareLastNames newOrder 64 | -- [("Ian","Curtis"),("Peter","Hook"),("Stephen","Morris"),("Bernard","Sumner")] 65 | 66 | -- I can do better: 67 | 68 | e5 = sortBy (\(_, b) (_, b') -> compare b b') newOrder 69 | e6 = sortBy (comparing snd) newOrder 70 | e7 = sortOn snd newOrder 71 | 72 | -- QC2 73 | 74 | names' = newOrder ++ [("George", "Morris")] 75 | 76 | compareLastNames' name1 name2 | lastName1 > lastName2 = GT 77 | | lastName1 < lastName2 = LT 78 | | firstName1 > firstName2 = GT 79 | | firstName1 < firstName2 = LT 80 | | otherwise = EQ 81 | where 82 | lastName1 = snd name1 83 | lastName2 = snd name2 84 | firstName1 = fst name1 85 | firstName2 = fst name2 86 | 87 | qc2 = sortBy compareLastNames' names' 88 | 89 | -- I can do better here too: 90 | 91 | e8 = sortBy (\x y -> mconcat [comparing snd x y, comparing fst x y]) names' -- Nice! 92 | 93 | -- 94 | -- Returning functions 95 | -- 96 | 97 | addressLetter name location = nameText ++ " - " ++ location 98 | where nameText = fst name ++ " " ++ snd name 99 | 100 | -- 101 | 102 | -- San Francisco has a new address for last names beginning with "L" or later: 103 | sfOffice name = if lastName < "L" 104 | then nameText ++ " - PO Box 1234 - San Francisco, CA 94111" 105 | else nameText ++ " - PO Box 1010 - San Francisco, CA 94109" 106 | where 107 | lastName = snd name 108 | nameText = fst name ++ " " ++ lastName 109 | 110 | -- New York wants the name followed by a ':' instead of a '-': 111 | nyOffice name = nameText ++ ": PO Box 789 - New York, NY 10013" 112 | where nameText = fst name ++ " " ++ snd name 113 | 114 | -- Reno only wants the last names: 115 | renoOffice name = nameText ++ " - PO Box 456 - Reno, NV 89523" where nameText = snd name 116 | 117 | -- Return the correct function for the specified location 118 | getLocationFunction location = case location of 119 | "ny" -> nyOffice 120 | "sf" -> sfOffice 121 | "reno" -> renoOffice 122 | _ -> \name -> fst name ++ " " ++ snd name 123 | 124 | {- 125 | addressLetter' ("Bob", "Smith") "ny" -- "Bob Smith: PO Box 789 - New York, NY, 10013" 126 | addressLetter' ("Joe","Blow") "la" -- "Joe Blow" 127 | -} 128 | addressLetter' name location = getLocationFunction location name 129 | 130 | -- 131 | -- Summary 132 | -- 133 | 134 | -- Q1 135 | 136 | compareLastNames'' name1 name2 | compareLastNames''' == EQ = compare firstName1 firstName2 137 | | otherwise = compareLastNames''' 138 | where 139 | lastName1 = snd name1 140 | lastName2 = snd name2 141 | firstName1 = fst name1 142 | firstName2 = fst name2 143 | compareLastNames''' = compare lastName1 lastName2 144 | 145 | -- Q2 146 | 147 | dcOffice name = nameText ++ " - PO Box 333 - Washington, DC 20202" 148 | where nameText = fst name ++ " " ++ snd name ++ ", Esq." 149 | 150 | getLocationFunction' location = case location of 151 | "ny" -> nyOffice 152 | "sf" -> sfOffice 153 | "reno" -> renoOffice 154 | "dc" -> dcOffice 155 | _ -> \name -> fst name ++ " " ++ snd name 156 | 157 | {- 158 | addressLetter'' ("Peter", "Parker") "dc" 159 | -- "Peter Parker, Esq. - PO Box 333 - Washington, DC 20202" 160 | -} 161 | addressLetter'' name location = getLocationFunction' location name 162 | -------------------------------------------------------------------------------- /Unit01/Lesson05.hs: -------------------------------------------------------------------------------- 1 | module Lesson05 where 2 | 3 | -- 4 | -- Closures - creating functions with functions 5 | -- 6 | 7 | inc n = n + 1 8 | double n = n * 2 9 | square n = n ^ 2 10 | 11 | ifEven f x = if even x then f x else x 12 | 13 | genIfEven f = \x -> ifEven f x 14 | 15 | ifEvenInc = genIfEven inc -- Partial application will simplify this later (`ifEven inc`) 16 | 17 | -- QC1 18 | 19 | genIfXEven x = \f -> ifEven f x 20 | 21 | {- 22 | genIf4Even inc -- 5 23 | -} 24 | genIf4Even = genIfXEven 4 25 | 26 | {- 27 | genIf5Even inc -- 5 28 | -} 29 | genIf5Even = genIfXEven 5 -- Any f you apply this to will not be called 30 | 31 | -- 32 | -- Example: Generating URLs for an API 33 | -- 34 | 35 | -- E.g. http://example.com/book/1234?token=1337hAsk3ll 36 | 37 | getRequestURL host apiKey resource id = 38 | host ++ "/" ++ resource ++ "/" ++ id ++ "?token=" ++ apiKey 39 | 40 | genHostRequestBuilder host = 41 | (\apiKey resource id -> getRequestURL host apiKey resource id) 42 | 43 | exampleUrlBuilder = genHostRequestBuilder "http://example.com" 44 | 45 | genApiRequestBuilder hostBuilder apiKey = 46 | (\resource id -> hostBuilder apiKey resource id) 47 | 48 | {- 49 | myExampleUrlBuilder "book" "1234" -- "http://example.com/book/1234?token=1337hAsk3ll" 50 | -} 51 | myExampleUrlBuilder = genApiRequestBuilder exampleUrlBuilder "1337hAsk3ll" 52 | 53 | -- QC2 54 | 55 | genApiRequestBuilder' hostBuilder resource apiKey = 56 | (\id -> hostBuilder apiKey resource id) 57 | 58 | -- Partial application: making closures simple 59 | 60 | add4 a b c d = a + b + c + d 61 | 62 | {- 63 | (addXto3 7) 1 2 3 -- 13 64 | -} 65 | addXto3 x = \b c d -> add4 x b c d 66 | 67 | {- 68 | mystery 2 3 4 -- 12 69 | -} 70 | mystery = add4 3 -- same as `addXto3 3` 71 | 72 | -- Now we don't need "generator" functions any more: 73 | 74 | exampleUrlBuilder' = getRequestURL "http://example.com" 75 | myExampleUrlBuilder' = exampleUrlBuilder' "1337hAsk3ll" 76 | 77 | -- QC3 78 | 79 | {- 80 | myBuilder "1234" -- "http://example.com/book/1234?token=1337hAsk3ll" 81 | -} 82 | myBuilder = getRequestURL "http://example.com" "1337hAsk3ll" "book" 83 | 84 | -- 85 | -- Putting it all together 86 | -- 87 | 88 | flipBinaryArgs f = \x y -> f y x -- same as `flip` 89 | 90 | -- QC4 91 | 92 | {- 93 | subtract2 5 -- 3 94 | -} 95 | subtract2 = flip (-) 2 96 | 97 | -- 98 | -- Summary 99 | -- 100 | 101 | -- Q1 102 | 103 | ifEvenInc' = ifEven inc 104 | ifEvenDouble = ifEven double 105 | ifEvenSquare = ifEven square 106 | 107 | -- Q2 108 | 109 | {- 110 | (binaryPartialApplication (+) 2) 3 -- 5 111 | -} 112 | binaryPartialApplication f x = \y -> f x y 113 | -------------------------------------------------------------------------------- /Unit01/Lesson06.hs: -------------------------------------------------------------------------------- 1 | module Lesson06 where 2 | 3 | import Data.List 4 | 5 | -- 6 | -- Consider this 7 | -- 8 | 9 | teams = ["red", "yellow", "orange", "blue", "purple"] 10 | 11 | -- Use `cycle` and `zip` to assign these to a list of employees - 12 | -- see `assignToGroups` below 13 | 14 | -- 15 | -- Lists and lazy evaluation 16 | -- 17 | 18 | simple x = x 19 | longList = [1 ..] 20 | stillLongList = simple longList 21 | 22 | -- QC1 23 | -- backwardsInfinity = reverse [1..] 24 | -- Compiles; but don't evaluate! SERIOUSLY, DON'T EVALUATE!! 25 | 26 | -- 27 | -- Common functions on lists 28 | -- 29 | 30 | ix1 = "puppies" !! 4 -- 'i' 31 | 32 | {- 33 | ix2 "dog" -- 'g' 34 | -} 35 | ix2 = (!! 2) -- a section 36 | 37 | cf1 = length [1 .. 20] -- 20 38 | 39 | {- 40 | isPalindrome "madam" -- True 41 | -} 42 | isPalindrome word = word == reverse word 43 | 44 | {- 45 | respond "hello" -- "uh.. okay" 46 | respond "hello!" -- "wow!" 47 | -} 48 | respond phrase = if '!' `elem` phrase then "wow!" else "uh.. okay" 49 | 50 | {- 51 | takeLast 10 [1..100] -- [91,92,93,94,95,96,97,98,99,100] 52 | -} 53 | takeLast n xs = reverse (take n (reverse xs)) 54 | 55 | {- 56 | ones 5 -- [1,1,1,1,1] 57 | -} 58 | ones n = take n (cycle [1]) 59 | 60 | assignToGroups n = zip groups where groups = cycle [1 .. n] 61 | -- This works because `zip` stops `cycle` when one list becomes empty 62 | 63 | threeGroups = assignToGroups 64 | 3 65 | [ "file1.txt" 66 | , "file2.txt" 67 | , "file3.txt" 68 | , "file4.txt" 69 | , "file5.txt" 70 | , "file6.txt" 71 | , "file7.txt" 72 | , "file8.txt" 73 | ] -- [(1,"file1.txt"),(2,"file2.txt"),(3,"file3.txt"), 74 | -- (1,"file4.txt"),(2,"file5.txt"),(3,"file6.txt"), etc.] 75 | 76 | -- 77 | -- Summary 78 | -- 79 | 80 | -- Q1 81 | 82 | {- 83 | take 7 (repeat' 5) -- [5,5,5,5,5,5,5] 84 | -} 85 | repeat' x = cycle [x] 86 | 87 | -- Q2 88 | 89 | {- 90 | subseq 2 4 "Mississippi" -- "ss" 91 | -} 92 | subseq from to xs = take (to - from) (drop from xs) 93 | 94 | -- Q3 95 | 96 | {- 97 | inFirstHalf 'e' "hello" -- True 98 | inFirstHalf 'o' "hello" -- False 99 | -} 100 | inFirstHalf x xs = x `elem` xs' 101 | where 102 | xs' = take n xs 103 | n = length xs `div` 2 104 | -------------------------------------------------------------------------------- /Unit01/Lesson07.hs: -------------------------------------------------------------------------------- 1 | module Lesson07 where 2 | 3 | -- 4 | -- Consider this 5 | -- 6 | 7 | {- 8 | take' 3 [1,2,3,4] -- [1,2,3] 9 | -} 10 | take' 0 xs = [] 11 | take' n (x : xs) = x : take' (n - 1) xs 12 | -- Note: this is not complete - see next lesson 13 | 14 | -- 15 | -- Your first recursive function: greatest common divisor 16 | -- 17 | 18 | {- 19 | gcd' 20 16 -- 4 20 | -} 21 | gcd' a b = if remainder == 0 then b else gcd' b remainder where remainder = a `mod` b 22 | 23 | -- QC2 24 | -- No: 25 | {- 26 | gcd' 16 20 -- 4 27 | -} 28 | 29 | -- Pattern matching 30 | 31 | -- Matching with `case`: 32 | sayAmount n = case n of 33 | 1 -> "one" 34 | 2 -> "two" 35 | _ -> "a bunch" 36 | 37 | -- With pattern matching: 38 | sayAmount' 1 = "one" 39 | sayAmount' 2 = "two" 40 | sayAmount' _ = "a bunch" 41 | 42 | isEmpty [] = True 43 | isEmpty _ = False 44 | 45 | head' (x : xs) = x 46 | head' [] = errorWithoutStackTrace "empty list" 47 | 48 | -- QC3 49 | 50 | {- 51 | tail' [1,2,3] -- [2,3] 52 | -} 53 | tail' (_ : xs) = xs 54 | 55 | -- 56 | -- Summary 57 | -- 58 | 59 | -- Q1 60 | 61 | tail' [] = [] 62 | 63 | -- Q2 64 | 65 | {- 66 | gcd'' 20 16 -- 4 67 | -} 68 | gcd'' a 0 = a 69 | gcd'' a b = gcd'' b (a `mod` b) 70 | -------------------------------------------------------------------------------- /Unit01/Lesson08.hs: -------------------------------------------------------------------------------- 1 | module Lesson08 where 2 | 3 | -- 4 | -- Consider this 5 | -- 6 | 7 | {- 8 | drop' 3 [1,2,3,4] -- 4 9 | -} 10 | drop' 0 xs = xs 11 | drop' n (x : xs) = drop' (n - 1) xs 12 | 13 | -- 14 | -- Recursion on lists 15 | -- 16 | 17 | -- length 18 | 19 | {- 20 | length' "hello" -- 5 21 | -} 22 | length' [] = 0 23 | length' xs = 1 + length' (tail xs) 24 | 25 | -- QC1 26 | 27 | {- 28 | length'' "hello" -- 5 29 | -} 30 | length'' [] = 0 31 | length'' (x : xs) = 1 + length' xs 32 | 33 | -- take 34 | 35 | {- 36 | take' 3 "hello" -- "hel" 37 | take' 5 [] -- [] 38 | -} 39 | take' _ [] = [] 40 | take' 0 _ = [] 41 | take' n (x : xs) = x : take' (n - 1) xs 42 | 43 | -- cycle 44 | 45 | {- 46 | take' 10 (cycle' "heh") -- "hehhehhehh" 47 | -} 48 | cycle' (x : xs) = x : cycle' (xs ++ [x]) 49 | 50 | -- repeat 51 | 52 | {- 53 | take' 4 (repeat' "heh") -- ["heh","heh","heh","heh"] 54 | -} 55 | repeat' x = x : repeat' x 56 | 57 | -- replicate 58 | 59 | {- 60 | replicate' 4 "heh" -- ["heh","heh","heh","heh"] 61 | -} 62 | replicate' 0 _ = [] 63 | replicate' n x = x : replicate' (n - 1) x 64 | 65 | -- 66 | -- Pathological recursion: Ackerman function and the Collatz conjecture 67 | -- 68 | 69 | {- 70 | :set +s 71 | ackermann 3 3 -- 61, 0.00 secs 72 | ackermann 3 8 -- 2045, 1.51 secs 73 | ackermann 3 9 -- 4093, 6.08 secs <-- Ouch, seriously slow! 74 | ackermann 4 2 -- don't even bother - the answer has 19,729 digits! 75 | :unset +s 76 | -} 77 | ackermann 0 n = n + 1 78 | ackermann m 0 = ackermann (m - 1) 1 79 | ackermann m n = ackermann (m - 1) (ackermann m (n - 1)) 80 | 81 | -- Counts the number of steps it takes the sequence to reach 1, starting at `n` 82 | -- There is no known proof that this completes! 83 | {- 84 | collatz 9 -- 20 85 | collatz 999 -- 50 86 | collatz 92 -- 18 87 | collatz 91 -- 93 88 | map collatz [100..110] -- [26,26,26,88,13,39,13,101,114,114,114] 89 | -} 90 | collatz 1 = 1 91 | collatz n = if even n then 1 + collatz (n `div` 2) else 1 + collatz (n * 3 + 1) 92 | 93 | -- I prefer using guards here: 94 | 95 | collatz' 1 = 1 96 | collatz' n | even n = 1 + collatz' (n `div` 2) 97 | | otherwise = 1 + collatz' (n * 3 + 1) 98 | 99 | -- 100 | -- Summary 101 | -- 102 | 103 | -- Q1 104 | 105 | {- 106 | reverse' "hello" -- "olleh" 107 | -} 108 | reverse' [] = [] 109 | reverse' (x : xs) = reverse' xs ++ [x] 110 | 111 | -- Q2 112 | 113 | -- This quickly grows out of control so let's replace it: 114 | {- 115 | fib 30 == 832040 <-- 1.56 sec 116 | fib 35 == 9227465 <-- 17.36 sec 117 | fib 40 == ? <-- gave up 118 | fib 1000 == ? <-- forget about it 119 | -} 120 | fib 0 = 0 121 | fib 1 = 1 122 | fib n = fib (n - 1) + fib (n - 2) 123 | 124 | -- The key is to remove one of the recursive calls: 125 | fastFib n1 _ 1 = n1 126 | fastFib _ n2 2 = n2 127 | fastFib n1 n2 3 = n1 + n2 128 | fastFib n1 n2 counter = fastFib (n1 + n2) n1 (counter - 1) 129 | 130 | {- 131 | fib' 30 == 832040 <-- 0.00 sec 132 | fib' 35 == 9227465 <-- 0.00 sec 133 | fib' 1000 == ...long number... <-- 0.01 sec 134 | -} 135 | fib' = fastFib 1 1 136 | -------------------------------------------------------------------------------- /Unit01/Lesson09.hs: -------------------------------------------------------------------------------- 1 | module Lesson09 where 2 | 3 | import Data.Char 4 | 5 | -- 6 | -- Consider this 7 | -- 8 | 9 | add3ToAll [] = [] 10 | add3ToAll (x : xs) = (3 + x) : add3ToAll xs 11 | 12 | mul3ByAll [] = [] 13 | mul3ByAll (x : xs) = (3 * x) : mul3ByAll xs 14 | 15 | -- Looks like a job for `map`: 16 | 17 | {- 18 | add3ToAll' [1,2,3] -- [4,5,6] 19 | -} 20 | add3ToAll' = map (3 +) 21 | 22 | {- 23 | mul3ByAll' [1,2,3] -- [3,6,9] 24 | -} 25 | mul3ByAll' = map (3 *) 26 | 27 | -- 28 | -- Using map 29 | -- 30 | 31 | -- Add the definite article to the beginning of each word 32 | {- 33 | determine ["dog","cat","moose"] -- ["the dog","the cat","the moose"] 34 | -} 35 | determine = map ("the " ++) 36 | 37 | -- Q: How to use the indefinite article, which varies between "a" and "an"? 38 | 39 | aOrAn xs | head xs `elem` "aeiou" = "an " 40 | | otherwise = "a " 41 | 42 | animals = ["ant", "bat", "cat"] 43 | 44 | -- This doesn't work: 45 | determine' = map (\xs -> aOrAn xs) -- ++ 46 | -- TODO: Giving up, return later? 47 | 48 | -- 49 | -- Abstracting away recursion with map 50 | -- 51 | 52 | addAnA [] = [] 53 | addAnA (x : xs) = ("a " ++ x) : addAnA xs 54 | 55 | squareAll [] = [] 56 | squareAll (x : xs) = x ^ 2 : squareAll xs 57 | 58 | -- Generalize the function to `f`: 59 | 60 | map' f [] = [] 61 | map' f (x : xs) = f x : map' f xs 62 | 63 | -- 64 | -- Filtering a list 65 | -- 66 | 67 | {- 68 | filter' even [1,2,3,4] -- [2,4] 69 | filter' (\(x:xs) -> x == 'a') ["apple","banana","avocado"] -- ["apple","avocado"] 70 | -} 71 | filter' p [] = [] 72 | filter' p (x : xs) = if p x then x : filter' p xs else filter' p xs 73 | 74 | -- QC1 75 | 76 | {- 77 | remove (> 3) [1,2,3,4,5] -- [1,2,3] 78 | -} 79 | remove p [] = [] 80 | remove p (x : xs) = if p x then remove p xs else x : remove p xs 81 | 82 | -- 83 | -- Folding a list 84 | -- 85 | 86 | fold1 = foldl (+) 0 [1, 2, 3, 4] -- 10 87 | 88 | -- QC2 89 | 90 | {- 91 | product' [2, 3, 4, 5] -- 120 92 | -} 93 | product' xs = foldl (*) 1 xs 94 | 95 | -- 96 | 97 | {- 98 | concat' ["race", "car"] -- racecar 99 | -} 100 | concat' xs = foldl (++) "" xs 101 | 102 | {- 103 | sumSquares [1,2,3,4] -- 30 104 | -} 105 | sumSquares xs = foldl (+) 0 (map (^ 2) xs) 106 | 107 | {- 108 | reverse' [1,2,3,4] -- [4,3,2,1] 109 | -} 110 | reverse' xs = foldl (\x y -> y : x) [] xs 111 | 112 | -- Implementing folds 113 | 114 | -- foldl 115 | 116 | foldl' f z [] = z 117 | foldl' f z (x : xs) = foldl' f (f z x) xs 118 | 119 | -- QC3 120 | -- True, because you take the tail of the list on each recursion. 121 | 122 | -- foldr 123 | 124 | foldr' f z [] = z 125 | foldr' f z (x : xs) = f x (foldr' f z xs) 126 | 127 | -- foldl and foldr give different answers when f is not commutative (such as subtraction): 128 | 129 | f1 = foldl (+) 0 [1, 2, 3, 4] == foldr (+) 0 [1, 2, 3, 4] -- True 130 | f2 = foldl (-) 0 [1, 2, 3, 4] == foldr (-) 0 [1, 2, 3, 4] -- False 131 | 132 | -- Q1 133 | 134 | {- 135 | 'e' `elem'` "hello" -- True 136 | -} 137 | elem' a xs = length (filter (== a) xs) > 0 138 | 139 | -- Q2 140 | 141 | {- 142 | isPalindrome "A man a plan a canal Panama" -- True 143 | -} 144 | isPalindrome xs = xs' == reverse xs' where xs' = map toUpper $ filter (/= ' ') xs 145 | 146 | -- Q3 147 | -- Cheat! 148 | -- Interesting - it's divergent: 149 | {- 150 | harmonic 10 -- 2.9289682539682538 151 | harmonic 100 -- 5.187377517639621 152 | harmonic 1000 -- 7.485470860550343 153 | -} 154 | harmonic n = sum (take n seriesValues) 155 | where 156 | seriesPairs = zip (repeat 1.0) [1.0, 2.0 ..] 157 | seriesValues = map (\pair -> fst pair / snd pair) seriesPairs 158 | -------------------------------------------------------------------------------- /Unit01/Lesson10.hs: -------------------------------------------------------------------------------- 1 | module Lesson10 where 2 | 3 | -- 4 | -- An object with one property: a cup of coffee 5 | -- 6 | 7 | cup oz = \message -> message oz 8 | 9 | coffeeCup = cup 12 10 | 11 | {- 12 | getOz coffeeCup -- 12 13 | -} 14 | getOz aCup = aCup (\oz -> oz) 15 | 16 | drink aCup ozDrank = if ozDiff >= 0 then cup ozDiff else cup 0 17 | where 18 | oz = getOz aCup 19 | ozDiff = oz - ozDrank 20 | 21 | {- 22 | getOz afterASip -- 11 23 | -} 24 | afterASip = drink coffeeCup 1 25 | 26 | {- 27 | getOz afterBigGulp -- 0 28 | -} 29 | afterBigGulp = drink coffeeCup 20 30 | 31 | isEmpty aCup = getOz aCup == 0 32 | 33 | {- 34 | getOz afterManySips -- 7 35 | -} 36 | afterManySips = foldl drink coffeeCup [1, 1, 1, 1, 1] 37 | 38 | -- 39 | -- A more complex object: let’s build fighting robots! 40 | -- 41 | 42 | robot (name, attack, hp) = \message -> message (name, attack, hp) 43 | 44 | killerRobot = robot ("Kill3r", 25, 200) 45 | name (n, _, _) = n 46 | attack (_, a, _) = a 47 | hp (_, _, hp) = hp 48 | 49 | getName aRobot = aRobot name 50 | getAttack aRobot = aRobot attack 51 | getHP aRobot = aRobot hp 52 | 53 | setName aRobot newName = aRobot (\(n, a, h) -> robot (newName, a, h)) 54 | setAttack aRobot newAttack = aRobot (\(n, a, h) -> robot (n, newAttack, h)) 55 | setHP aRobot newHP = aRobot (\(n, a, h) -> robot (n, a, newHP)) 56 | 57 | nicerRobot = setName killerRobot "kitty" 58 | gentlerRobot = setAttack killerRobot 5 59 | softerRobot = setHP killerRobot 50 60 | 61 | {- 62 | printRobot nicerRobot -- "kitty attack:25 hp:200" 63 | -} 64 | printRobot aRobot = 65 | aRobot (\(n, a, h) -> n ++ " attack:" ++ show a ++ " hp:" ++ show h) 66 | 67 | damage aRobot attackDamage = 68 | aRobot (\(n, a, h) -> robot (n, a, h - attackDamage)) 69 | 70 | hps = map getHP [nicerRobot, gentlerRobot, softerRobot] -- [200,200,50] 71 | 72 | -- 73 | 74 | fight aRobot defender = damage defender attack 75 | where attack = if getHP aRobot > 10 then getAttack aRobot else 0 76 | 77 | gentleGiant = robot ("Mr. Friendly", 10, 300) 78 | 79 | gentleGiantRound1 = fight killerRobot gentleGiant 80 | killerRobotRound1 = fight gentleGiant killerRobot 81 | gentleGiantRound2 = fight killerRobotRound1 gentleGiantRound1 82 | killerRobotRound2 = fight gentleGiantRound1 killerRobotRound1 83 | gentleGiantRound3 = fight killerRobotRound2 gentleGiantRound2 84 | killerRobotRound3 = fight gentleGiantRound2 killerRobotRound2 85 | 86 | -- 87 | -- Why stateless programming matters 88 | -- 89 | 90 | fastRobot = robot ("speedy", 15, 40) 91 | slowRobot = robot ("slowpoke", 20, 30) 92 | 93 | fastRobotRound3 = fight slowRobotRound3 fastRobotRound2 94 | fastRobotRound2 = fight slowRobotRound2 fastRobotRound1 95 | fastRobotRound1 = fight slowRobotRound1 fastRobot 96 | slowRobotRound2 = fight fastRobotRound1 slowRobotRound1 97 | slowRobotRound3 = fight fastRobotRound2 slowRobotRound2 98 | slowRobotRound1 = fight fastRobot slowRobot 99 | -------------------------------------------------------------------------------- /Unit01/first_prog: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Rhywun/get-programming-with-haskell/4f57ac35cb425c48f3976ebd81d4ac0174c6d352/Unit01/first_prog -------------------------------------------------------------------------------- /Unit01/first_prog.hs: -------------------------------------------------------------------------------- 1 | import System.IO 2 | 3 | main :: IO () 4 | main = do 5 | hSetBuffering stdout NoBuffering 6 | putStr "Who is the email for? " 7 | recipient <- getLine 8 | putStr "What is the title? " 9 | title <- getLine 10 | putStr "Who is the author? " 11 | author <- getLine 12 | putStrLn (createEmail recipient title author) 13 | 14 | toPart recipient = "Dear " ++ recipient ++ ",\n" 15 | 16 | bodyPart bookTitle = "Thanks for buying \"" ++ bookTitle ++ "\".\n" 17 | 18 | fromPart author = "Thanks,\n" ++ author 19 | 20 | createEmail recipient bookTitle author = 21 | toPart recipient ++ bodyPart bookTitle ++ fromPart author 22 | -------------------------------------------------------------------------------- /Unit01/hello: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Rhywun/get-programming-with-haskell/4f57ac35cb425c48f3976ebd81d4ac0174c6d352/Unit01/hello -------------------------------------------------------------------------------- /Unit01/hello.hs: -------------------------------------------------------------------------------- 1 | -- hello.hs - my first Haskell file! 2 | main = do 3 | print "Hello, Pat!" 4 | -------------------------------------------------------------------------------- /Unit02/Lesson11.hs: -------------------------------------------------------------------------------- 1 | module Lesson11 where 2 | 3 | -- 4 | -- Consider this: 5 | -- 6 | 7 | -- Q: Why doesn't this work? 8 | -- average' xs = sum xs / length xs 9 | -- -> "Could not deduce (Fractional Int) arising from a use of ‘/’" 10 | 11 | -- A: Because `/` expects a Fractional while `length` produces an Int 12 | -- -> Use `fromIntegral` to convert the result of `length` to a Num 13 | -- which can be used with `/` 14 | {- 15 | average' [2,3,4] -- 3.0 16 | -} 17 | average' xs = sum xs / fromIntegral (length xs) 18 | 19 | -- 20 | -- Types in Haskell 21 | -- 22 | 23 | x :: Int 24 | x = 2 25 | 26 | y :: Integer 27 | y = 2 28 | 29 | -- Difference between Int and Integer? 30 | {- 31 | x ^ 2000 -- 0 (exceeds upper bound of Int as required by computer architecture) 32 | y ^ 2000 -- 11481... (+ 598 more digits - there is no upper bound for Integer) 33 | -} 34 | 35 | letter :: Char 36 | letter = 'a' 37 | 38 | interestRate :: Double 39 | interestRate = 0.375 40 | 41 | isFun :: Bool 42 | isFun = True 43 | 44 | values :: [Int] 45 | values = [1, 2, 3] 46 | 47 | testScores :: [Double] 48 | testScores = [0.99, 0.7, 0.8] 49 | 50 | letters :: String 51 | letters = ['a', 'b', 'c'] 52 | 53 | ageAndHeight :: (Int, Int) 54 | ageAndHeight = (34, 74) 55 | 56 | firstLastMiddle :: (String, String, Char) 57 | firstLastMiddle = ("Oscar", "Grouch", 'D') 58 | 59 | streetAddress :: (Int, String) 60 | streetAddress = (123, "Happy St.") 61 | 62 | -- 63 | -- Function types 64 | -- 65 | 66 | double :: Int -> Int 67 | double n = n * 2 68 | 69 | half :: Int -> Double 70 | half n = fromIntegral n / 2 71 | 72 | -- QC1 73 | 74 | {- 75 | halve 5 -- 2 76 | -} 77 | halve :: Int -> Int 78 | halve n = n `div` 2 79 | 80 | -- show 81 | 82 | {- 83 | show 6 -- "6" 84 | show 'c' -- "'c'" 85 | show 6.0 -- "6.0" 86 | -} 87 | 88 | -- QC2 89 | 90 | {- 91 | printDouble 2 -- "4" 92 | -} 93 | printDouble :: Int -> String 94 | printDouble n = show (n * 2) 95 | 96 | -- read - usually requires a type annotation 97 | 98 | anotherNumber :: Double 99 | anotherNumber = read "6" -- 6.0 100 | 101 | -- can also put the type at the end: 102 | {- 103 | read "6" :: Int -- 6 104 | read "6" :: Double -- 6.0 105 | -} 106 | 107 | -- Functions with multiple arguments 108 | 109 | {- 110 | makeAddress 123 "Happy St." "Haskell Town" -- (123,"Happy St.","Haskell Town") 111 | -} 112 | makeAddress :: Int -> String -> String -> (Int, String, String) 113 | makeAddress number street town = (number, street, town) 114 | 115 | -- Equivalent: 116 | {- 117 | (((makeAddressLambda 123) "Happy St.") "Haskell Town") -- (123,"Happy St.","Haskell Town") 118 | (((makeAddress 123) "Happy St.") "Haskell Town") -- (123,"Happy St.","Haskell Town") 119 | -} 120 | makeAddressLambda :: Int -> String -> String -> (Int, String, String) 121 | makeAddressLambda = (\number -> (\street -> (\town -> (number, street, town)))) 122 | 123 | -- QC3 124 | makeAddress' = makeAddress 123 :: String -> String -> (Int, String, String) 125 | makeAddress'' = makeAddress 123 "Main" :: String -> (Int, String, String) 126 | makeAddress''' = makeAddress 123 "Main" "Rochester" :: (Int, String, String) 127 | 128 | -- Types for first-class functions 129 | 130 | ifEven :: (Int -> Int) -> Int -> Int 131 | ifEven f n = if even n then f n else n 132 | 133 | -- 134 | -- Type variables 135 | -- 136 | 137 | simple :: a -> a 138 | simple x = x 139 | 140 | {- 141 | makeTriple "Oscar" 'D' "Grouch" -- ("Oscar",'D',"Grouch") :: (String, Char, String) 142 | -} 143 | makeTriple :: a -> b -> c -> (a, b, c) 144 | makeTriple x y z = (x, y, z) 145 | 146 | -- QC4 147 | -- Because the function argument supplied to map can return a type that is different 148 | -- from the type of its argument. 149 | 150 | -- 151 | -- Summary 152 | -- 153 | 154 | -- Q1 155 | -- filter :: (a -> Bool) -> [a] -> [a] 156 | -- map :: (a -> b) -> [a] -> [b] 157 | -- The function supplied to `filter` is required to return Bool, while the function 158 | -- supplied to `map` can return any type. Also, `filter` takes and returns the same type 159 | -- of list, while `map' can return a list of any type. 160 | 161 | -- Q2 162 | -- head :: [a] -> a 163 | -- tail :: [a] -> [a] 164 | -- No, because `head` doesn't return a list. 165 | 166 | -- Q3 167 | 168 | myFoldl :: (a -> b -> a) -> a -> [b] -> a 169 | myFoldl f init [] = init 170 | myFoldl f init (x : xs) = myFoldl f newInit xs where newInit = f init x 171 | -------------------------------------------------------------------------------- /Unit02/Lesson12.hs: -------------------------------------------------------------------------------- 1 | module Lesson12 where 2 | 3 | -- 4 | -- Consider this 5 | -- 6 | 7 | -- Is there a better way to express this? 8 | anAlbum :: (String, String, Int, [String]) 9 | anAlbum = ("New Order", "Movement", 1981, ["Dreams Never End", "Truth", "Senses", "etc"]) 10 | 11 | -- Sure - create a record: 12 | data Album = Album 13 | { artist :: String 14 | , name :: String 15 | , year :: Int 16 | , tracks :: [String] 17 | } 18 | 19 | anAlbum' = 20 | Album "New Order" "Movement" 1981 ["Deams Never End", "Truth", "Senses", "etc"] 21 | -- or 22 | anAlbum'' = Album { artist = "New Order" 23 | , name = "Movement" 24 | , year = 1981 25 | , tracks = ["Deams Never End", "Truth", "Senses", "etc"] 26 | } 27 | 28 | -- Accessing fields: 29 | albumName = name anAlbum'' -- "Movement" 30 | 31 | -- 32 | -- Using type synonyms 33 | -- 34 | 35 | type FirstName = String 36 | 37 | type LastName = String 38 | 39 | type Age = Int 40 | 41 | type Height = Int 42 | 43 | patientInfo :: FirstName -> LastName -> Age -> Height -> String 44 | patientInfo fname lname age height = name ++ " " ++ ageHeight 45 | where 46 | name = lname ++ ", " ++ fname 47 | ageHeight = "(" ++ show age ++ "yrs. " ++ show height ++ "in.)" 48 | 49 | type PatientName = (FirstName, LastName) 50 | 51 | firstName :: PatientName -> FirstName 52 | firstName = fst 53 | 54 | lastName :: PatientName -> LastName 55 | lastName = snd 56 | 57 | -- QC1 58 | 59 | {- 60 | patientInfo' ("John", "Doe") 42 200 -- "Doe, John (42yrs. 200in.)" 61 | -} 62 | patientInfo' :: PatientName -> Age -> Height -> String 63 | patientInfo' (fname, lname) age height = name ++ " " ++ ageHeight 64 | where 65 | name = lname ++ ", " ++ fname 66 | ageHeight = "(" ++ show age ++ "yrs. " ++ show height ++ "in.)" 67 | 68 | -- 69 | -- Creating new types 70 | -- 71 | 72 | data Sex = Male | Female deriving (Show) 73 | 74 | sexInitial :: Sex -> Char 75 | sexInitial Male = 'M' 76 | sexInitial Female = 'F' 77 | 78 | -- 79 | 80 | data RhType = Pos | Neg 81 | 82 | -- jumping ahead... 83 | instance Show RhType where 84 | show Pos = "+" 85 | show Neg = "-" 86 | 87 | data ABOType = A | B | AB | O deriving (Show) 88 | 89 | data BloodType = BloodType ABOType RhType 90 | 91 | -- jumping ahead... 92 | instance Show BloodType where 93 | show (BloodType aboType rhType) = show aboType ++ show rhType 94 | 95 | bt1 :: BloodType 96 | bt1 = BloodType A Pos -- A+ 97 | 98 | bt2 :: BloodType 99 | bt2 = BloodType O Neg -- O- 100 | 101 | bt3 :: BloodType 102 | bt3 = BloodType AB Pos -- AB+ 103 | 104 | -- Can the first blood type donate to the second? 105 | {- 106 | canDonateTo' bt1 bt2 -- False 107 | canDonateTo' bt2 bt1 -- True 108 | -} 109 | canDonateTo' :: BloodType -> BloodType -> Bool 110 | canDonateTo' (BloodType O _) _ = True 111 | canDonateTo' _ (BloodType AB _) = True 112 | canDonateTo' (BloodType A _) (BloodType A _) = True 113 | canDonateTo' (BloodType B _) (BloodType B _) = True 114 | canDonateTo' _ _ = False 115 | 116 | type MiddleName = String 117 | 118 | data Name = Name FirstName LastName | NameWithMiddle FirstName MiddleName LastName 119 | 120 | -- jumping ahead... 121 | instance Show Name where 122 | show (Name f l ) = f ++ " " ++ l 123 | show (NameWithMiddle f m l) = f ++ " " ++ m ++ " " ++ l 124 | 125 | name1 :: Name 126 | name1 = Name "Jerome" "Salinger" 127 | 128 | name2 :: Name 129 | name2 = NameWithMiddle "Jerome" "David" "Salinger" 130 | 131 | -- 132 | -- Using record syntax 133 | -- 134 | 135 | type Weight = Int 136 | 137 | data PatientV1 = 138 | PatientV1 Name 139 | Sex 140 | Age -- in years 141 | Height -- in inches 142 | Weight -- in pounds 143 | BloodType 144 | deriving (Show) 145 | 146 | johnDoe :: PatientV1 147 | johnDoe = PatientV1 (Name "John" "Doe") Male 30 74 200 (BloodType AB Pos) 148 | 149 | -- QC2 150 | 151 | janeESmith :: PatientV1 152 | janeESmith = 153 | PatientV1 (NameWithMiddle "Jane" "Elizabeth" "Smith") Female 25 55 130 (BloodType O Neg) 154 | 155 | -- Let's use a record type instead 156 | 157 | data Patient = Patient 158 | { patientName :: Name 159 | , patientSex :: Sex 160 | , patientAge :: Age -- in years 161 | , patientHeight :: Height -- in inches 162 | , patientWeight :: Weight -- in pounds 163 | , patientBloodType :: BloodType 164 | } deriving (Show) 165 | 166 | -- the order of the fields doesn't matter: 167 | jackieSmith :: Patient 168 | jackieSmith = Patient { patientName = Name "Jackie" "Smith" 169 | , patientAge = 43 170 | , patientSex = Female 171 | , patientHeight = 62 172 | , patientWeight = 115 173 | , patientBloodType = BloodType O Neg 174 | } 175 | 176 | -- free getters: 177 | {- 178 | patientHeight jackieSmith -- 62 179 | patientBloodType jackieSmith -- O- 180 | -} 181 | 182 | -- QC3 183 | 184 | qc3 :: Name 185 | qc3 = patientName jackieSmith 186 | 187 | -- Record update: 188 | jackieSmithUpdated :: Patient 189 | jackieSmithUpdated = jackieSmith { patientAge = 44 } 190 | 191 | -- 192 | -- Summary 193 | -- 194 | 195 | -- Q1 196 | 197 | {- 198 | canDonateTo jackieSmith jackieSmithUpdated -- True 199 | -} 200 | canDonateTo :: Patient -> Patient -> Bool 201 | canDonateTo p1 p2 = canDonateTo' (patientBloodType p1) (patientBloodType p2) 202 | 203 | -- Q2 204 | 205 | {- 206 | putStrLn $ patientSummary jackieSmith --> 207 | ************** 208 | Patient Name: Jackie Smith 209 | Sex: Female 210 | Age: 43 211 | Height: 62 212 | Weight: 115 213 | Blood Type: O- 214 | ************** 215 | -} 216 | patientSummary :: Patient -> String 217 | patientSummary p = 218 | "**************" 219 | ++ "\nPatient Name: " 220 | ++ show (patientName p) 221 | ++ "\nSex: " 222 | ++ show (patientSex p) 223 | ++ "\nAge: " 224 | ++ show (patientAge p) 225 | ++ "\nHeight: " 226 | ++ show (patientHeight p) 227 | ++ "\nWeight: " 228 | ++ show (patientWeight p) 229 | ++ "\nBlood Type: " 230 | ++ show (patientBloodType p) 231 | ++ "\n**************" 232 | -------------------------------------------------------------------------------- /Unit02/Lesson13.hs: -------------------------------------------------------------------------------- 1 | module Lesson13 where 2 | 3 | -- 4 | -- Consider this 5 | -- 6 | 7 | {- 8 | inc' 1 -- 2 9 | inc' 1.1 -- 2.1 10 | -} 11 | inc' :: Num a => a -> a 12 | inc' x = x + 1 13 | 14 | -- 15 | -- Further exploring types 16 | -- 17 | 18 | simple :: a -> a 19 | simple x = x 20 | 21 | -- QC1 22 | aList :: [String] 23 | aList = ["cat", "dog", "mouse"] 24 | 25 | -- 26 | -- Type classes 27 | -- 28 | 29 | -- Example: 30 | {- 31 | :i Num --> 32 | class Num a where 33 | (+) :: a -> a -> a 34 | (-) :: a -> a -> a 35 | (*) :: a -> a -> a 36 | negate :: a -> a 37 | abs :: a -> a 38 | signum :: a -> a 39 | ...etc... 40 | -} 41 | 42 | -- QC2 43 | -- Because (/) is defined in type class Fractional. 44 | 45 | -- 46 | -- The benefits of type classes 47 | -- 48 | 49 | -- This will work on any type that implements Num, 50 | -- including types that haven't been written yet: 51 | addThenDouble :: Num a => a -> a -> a 52 | addThenDouble x y = (x + y) * 2 53 | 54 | -- 55 | -- Defining a type class 56 | -- 57 | 58 | class Describable a where 59 | describe :: a -> String 60 | 61 | -- 62 | -- Common type classes 63 | -- see text for discussion of Ord, Eq, Bounded, and Show 64 | -- 65 | 66 | -- 67 | -- Deriving type classes 68 | -- 69 | 70 | data IceCream = Chocolate | Vanilla deriving (Show, Eq, Ord) 71 | 72 | -- QC3 73 | 74 | -- Vanilla is greater than Chocolate because it appears last in the definition: 75 | qc3 = Vanilla > Chocolate -- True 76 | 77 | -- 78 | -- Summary 79 | -- 80 | 81 | -- Q1 82 | -- Word has the same range as Int but is composed of positive integers only. 83 | 84 | -- Q2 85 | 86 | inc'' :: Int -> Int 87 | inc'' x = x + 1 88 | 89 | -- `succ` doesn't work at bounds: 90 | {- 91 | succ (maxBound :: Int) --> 92 | *** Exception: Prelude.Enum.succ{Int}: tried to take `succ' of maxBound 93 | -} 94 | -- `inc` does work, but it wraps at a boundary. 95 | 96 | -- Q3 97 | 98 | {- 99 | cycleSucc (maxBound :: Int) -- -9223372036854775808 100 | cycleSucc (maxBound :: Char) -- '\NUL' 101 | -} 102 | cycleSucc :: (Bounded a, Enum a, Eq a) => a -> a 103 | cycleSucc n = if n == maxBound then minBound else succ n 104 | -------------------------------------------------------------------------------- /Unit02/Lesson14.hs: -------------------------------------------------------------------------------- 1 | module Lesson14 where 2 | 3 | import Data.List 4 | import Data.Ord 5 | 6 | -- 7 | -- Consider this 8 | -- 9 | 10 | data NewEngland = CT | MA | ME | NH | RI | VT 11 | 12 | instance Show NewEngland where 13 | show x = case x of 14 | CT -> "Connecticut" 15 | MA -> "Massachussetts" 16 | ME -> "Maine" 17 | NH -> "New Hampshire" 18 | RI -> "Rhode Island" 19 | VT -> "Vermont" 20 | 21 | -- 22 | -- A type in need of classes 23 | -- 24 | 25 | data SixSidedDie' = S1' | S2' | S3' | S4' | S5' | S6' 26 | 27 | -- 28 | -- Implementing Show 29 | -- 30 | 31 | instance Show SixSidedDie' where 32 | show S1' = "one" 33 | show S2' = "two" 34 | show S3' = "three" 35 | show S4' = "four" 36 | show S5' = "five" 37 | show S6' = "six" 38 | 39 | -- 40 | -- Type classes and polymorphism 41 | -- 42 | 43 | poly1 :: Int 44 | poly1 = read "10" -- 10 45 | 46 | poly2 :: Double 47 | poly2 = read "10" -- 10.0 48 | 49 | -- 50 | -- Default implementation and minimum complete definitions 51 | -- 52 | 53 | -- Notice we don't have to implement (/=): 54 | instance Eq SixSidedDie' where 55 | (==) S6' S6' = True 56 | (==) S5' S5' = True 57 | (==) S4' S4' = True 58 | (==) S3' S3' = True 59 | (==) S2' S2' = True 60 | (==) S1' S1' = True 61 | (==) _ _ = False 62 | 63 | -- Of course, this is the same as deriving (Eq) 64 | 65 | -- QC2 66 | -- RealFrac's minimal complete definition is `properFraction`. 67 | 68 | -- 69 | -- Implementing Ord 70 | -- 71 | 72 | instance Ord SixSidedDie' where 73 | compare S6' S6' = EQ 74 | compare S6' _ = GT 75 | compare _ S6' = LT 76 | compare S5' S5' = EQ 77 | compare S5' _ = GT 78 | compare _ S5' = LT 79 | compare _ _ = undefined -- added to let it compile; in reality 80 | -- this needs many more cases 81 | 82 | -- 83 | -- To derive or not to derive? 84 | -- 85 | 86 | -- At the end of the day, we're better off using `deriving` whenever possible 87 | 88 | data SixSidedDie = S1 | S2 | S3 | S4 | S5 | S6 deriving (Show, Eq, Ord, Enum) 89 | 90 | -- Now we can take advantage of Enum too: 91 | {- 92 | [S1 ..] -- [S1,S2,S3,S4,S5,S6] 93 | -} 94 | 95 | -- 96 | -- Type classes for more-complex types 97 | -- 98 | 99 | -- See p. 153 for discussion of `newtype` 100 | newtype Name = Name (String, String) deriving (Show, Eq) 101 | 102 | -- Implement a custom sort order: 103 | instance Ord Name where 104 | compare (Name (f1, l1)) (Name (f2, l2)) = compare (l1, f1) (l2, f2) 105 | 106 | {- 107 | sort names 108 | -- [Name ("Emil","Cioran"),Name ("Friedrich","Nietzsche"),Name ("Eugene","Thacker")] 109 | -} 110 | names = 111 | [Name ("Emil", "Cioran"), Name ("Eugene", "Thacker"), Name ("Friedrich", "Nietzsche")] 112 | 113 | -- A thought: this would probably be nicer with record syntax. Let's try it. 114 | 115 | data NameRec = NameRec 116 | { firstName :: String 117 | , lastName :: String 118 | } deriving (Show, Eq) 119 | 120 | instance Ord NameRec where 121 | compare = comparing lastName -- <- Nice 122 | 123 | {- 124 | sort namesRec 125 | -- [NameRec {firstName = "Emil", lastName = "Cioran"} 126 | ,NameRec {firstName = "Friedrich", lastName = "Nietzsche"} 127 | ,NameRec {firstName = "Eugene", lastName = "Thacker"}] 128 | -} 129 | namesRec = 130 | [NameRec "Emil" "Cioran", NameRec "Eugene" "Thacker", NameRec "Friedrich" "Nietzsche"] 131 | 132 | -- 133 | -- Summary 134 | -- 135 | 136 | -- Q1 137 | 138 | data Boo = Tru | Fls deriving (Enum) 139 | 140 | instance Eq Boo where 141 | x == y = fromEnum x == fromEnum y 142 | 143 | instance Ord Boo where 144 | compare x y = compare (fromEnum x) (fromEnum y) 145 | 146 | -- Q2 147 | 148 | data FiveSidedDie = Roll1 | Roll2 | Roll3 | Roll4 | Roll5 deriving (Show, Eq, Ord, Enum) 149 | 150 | class (Eq a, Enum a) => Die a where 151 | sides :: a -> Int 152 | 153 | instance Die FiveSidedDie where 154 | sides x = 5 155 | -------------------------------------------------------------------------------- /Unit02/Lesson15.hs: -------------------------------------------------------------------------------- 1 | module Lesson15 where 2 | 3 | -- 4 | -- Ciphers for beginners: ROT13 5 | -- 6 | 7 | data FourLetterAlphabet = L1 | L2 | L3 | L4 deriving (Show, Enum, Bounded) 8 | 9 | -- Rotate an enum `enum` halfway around an alphabet of size `size` 10 | {- 11 | rotN 4 L4 -- L2 12 | -} 13 | rotN :: (Bounded a, Enum a) => Int -> a -> a 14 | rotN size enum = toEnum rotation -- E.g. L2 15 | where 16 | half = size `div` 2 -- E.g. 2 17 | offset = fromEnum enum + half -- E.g. 3 + 2 == 5 18 | rotation = offset `mod` size -- E.g. 5 `mod` 4 == 1 19 | 20 | -- Char-specific rotN 21 | {- 22 | rotChar 'A' -- '\557121' 23 | -} 24 | rotChar :: Char -> Char 25 | rotChar = rotN $ 1 + fromEnum (maxBound :: Char) 26 | 27 | -- 28 | 29 | message :: [FourLetterAlphabet] 30 | message = [L1, L3, L4, L1, L1, L2] 31 | 32 | {- 33 | fourLetterEncoder message -- [L3,L1,L2,L3,L3,L4] 34 | fourLetterEncoder (fourLetterEncoder message) == message -- True 35 | -} 36 | fourLetterEncoder :: [FourLetterAlphabet] -> [FourLetterAlphabet] 37 | fourLetterEncoder = map rot4l 38 | where 39 | alphaSize = 1 + fromEnum (maxBound :: FourLetterAlphabet) 40 | rot4l = rotN alphaSize 41 | 42 | -- snip -- 43 | 44 | -- 45 | -- XOR: The magic of cryptography! 46 | -- 47 | 48 | xor :: [Bool] -> [Bool] -> [Bool] 49 | xor bs1 bs2 = map xorPair (zip bs1 bs2) 50 | where 51 | xorPair (b1, b2) = xorBool b1 b2 52 | xorBool b1 b2 = (b1 || b2) && not (b1 && b2) 53 | 54 | -- skip -- 55 | -------------------------------------------------------------------------------- /Unit03/Lesson16.hs: -------------------------------------------------------------------------------- 1 | module Lesson16 where 2 | 3 | -- Consider this 4 | 5 | data BreakfastSide = Toast | Biscuit | Homefries | Fruit deriving Show 6 | data BreakfastMeat = Sausage | Bacon | Ham deriving Show 7 | data BreakfastMain = Egg | Pancake | Waffle deriving Show 8 | 9 | data BreakfastSpecial 10 | = KidsSpecial BreakfastMain BreakfastSide 11 | | BasicSpecial BreakfastMain BreakfastMeat BreakfastSide 12 | | LumberjackSpecial BreakfastMain BreakfastMain 13 | BreakfastMeat BreakfastMeat 14 | BreakfastSide BreakfastSide BreakfastSide 15 | deriving Show 16 | 17 | breakfast1 = KidsSpecial Waffle Homefries 18 | breakfast2 = BasicSpecial Egg Sausage Toast 19 | 20 | -- An invalid breakfast cannot be formed: 21 | {- 22 | breakfast3 = BasicSpecial Egg Sausage Bacon 23 | -} 24 | 25 | -- But an "incomplete" breakfast CAN be formed - it's just a function awaiting more args: 26 | breakfast4 = LumberjackSpecial Egg Pancake 27 | 28 | -- 29 | -- Product types - combining types with “and” 30 | -- 31 | 32 | type FirstName = String 33 | type LastName = String 34 | type ISBN = String 35 | type Title = String 36 | type Year = Int 37 | type Price = Double 38 | 39 | newtype AuthorName' = FirstName LastName 40 | 41 | data Book'' = AuthorName' ISBN Title Year Price 42 | 43 | -- Or, using record sytax: 44 | 45 | data Book' = Book' 46 | { authorV1 :: AuthorName 47 | , isbnV1 :: String 48 | , titleV1 :: String 49 | , yearV1 :: Int 50 | , priceV1 :: Double 51 | } 52 | 53 | -- QC1 54 | 55 | data AuthorName = AuthorName 56 | { firstName :: String 57 | , lastName :: String 58 | } 59 | 60 | -- QC2 61 | 62 | data Car = Car 63 | 64 | type Spoiler = String 65 | 66 | data SportsCar = SportsCar Car Spoiler 67 | 68 | -- 69 | -- Sum types - combining types with “or” 70 | -- 71 | 72 | type MiddleName = String 73 | 74 | data Name 75 | = Name FirstName LastName 76 | | NameWithMiddle FirstName MiddleName LastName 77 | | TwoInitialsWithLast Char Char LastName 78 | deriving (Show) 79 | 80 | -- 81 | 82 | data Creator 83 | = AuthorCreator Author 84 | | ArtistCreator Artist 85 | deriving (Show) 86 | 87 | newtype Author = Author Name deriving (Show) 88 | 89 | data Artist = Person Name | Band String deriving (Show) 90 | 91 | hpLovecraft :: Creator 92 | hpLovecraft = AuthorCreator (Author (TwoInitialsWithLast 'H' 'P' "Lovecraft")) 93 | 94 | -- 95 | -- Putting together your bookstore 96 | -- 97 | 98 | data Book = Book 99 | { author :: Creator 100 | , isbn :: String 101 | , bookTitle :: String 102 | , bookYear :: Int 103 | , bookPrice :: Double 104 | } 105 | 106 | data VinylRecord = VinylRecord 107 | { artist :: Creator 108 | , recordTitle :: String 109 | , recordYear :: Int 110 | , recordPrice :: Double 111 | } 112 | 113 | data CollectibleToy = CollectibleToy 114 | { name :: String 115 | , descrption :: String 116 | , toyPrice :: Double 117 | } 118 | 119 | data StoreItem 120 | = BookItem Book 121 | | RecordItem VinylRecord 122 | | ToyItem CollectibleToy 123 | | PamphletItem Pamphlet 124 | 125 | price :: StoreItem -> Double 126 | price (BookItem book ) = bookPrice book 127 | price (RecordItem record) = recordPrice record 128 | price (ToyItem toy ) = toyPrice toy 129 | price (PamphletItem _ ) = 0.0 130 | 131 | -- QC3 132 | 133 | madeBy :: StoreItem -> String 134 | madeBy (BookItem book ) = show $ author book 135 | madeBy (RecordItem record) = show $ artist record 136 | madeBy (ToyItem _ ) = "Unknown Maker" 137 | madeBy (PamphletItem _ ) = undefined 138 | 139 | -- Q1 140 | 141 | data Pamphlet = Pamphlet 142 | { pamphletTitle :: String 143 | , pamphletDescrption :: String 144 | , pamphletContact :: String 145 | } 146 | 147 | -- Q2 148 | 149 | type Radius = Double 150 | 151 | type Height = Double 152 | 153 | type Width = Double 154 | 155 | data Shape 156 | = Circle Radius 157 | | Square Width 158 | | Rectangle Height Width 159 | 160 | perimeter :: Shape -> Double 161 | perimeter (Circle radius ) = 2 * pi * radius 162 | perimeter (Square width ) = 4 * width 163 | perimeter (Rectangle height width) = 2 * height + 2 * width 164 | 165 | area :: Shape -> Double 166 | area (Circle radius ) = pi * radius ^ (2 :: Int) 167 | area (Square width ) = width ^ (2 :: Int) 168 | area (Rectangle height width) = height * width 169 | -------------------------------------------------------------------------------- /Unit03/Lesson17_Q2.hs: -------------------------------------------------------------------------------- 1 | module Lesson17_Q2 where 2 | 3 | import Data.Semigroup 4 | 5 | newtype Events = 6 | Events [String] 7 | 8 | newtype Probs = 9 | Probs [Double] 10 | 11 | data PTable = 12 | PTable Events 13 | Probs 14 | 15 | -- Create a probability table, ensuring all probabilities sum to 1 by dividing 16 | -- all the probabilities by the sum of the probabilities 17 | createPTable :: Events -> Probs -> PTable 18 | createPTable (Events events) (Probs probs) = PTable (Events events) 19 | (Probs normalizedProbs) 20 | where 21 | totalProbs = sum probs 22 | normalizedProbs = map (/ totalProbs) probs 23 | 24 | -- Print a single table row 25 | showPair :: String -> Double -> String 26 | showPair event prob = mconcat [event, "|", show prob, "\n"] 27 | 28 | instance Show PTable where 29 | show (PTable (Events events) (Probs probs)) = mconcat pairs 30 | where 31 | pairs = zipWith showPair events probs 32 | 33 | -- Generate all combinations of two lists using the specified function `f` 34 | -- E.g. cartesianCombine (\x y -> mconcat [x, "-", y]) ["red", "blue"] ["red", "blue"] 35 | -- == ["red-red","red-blue","blue-red","blue-blue"] 36 | -- cartesianCombine (*) [2,3,4] [5,6] == [10,12,15,18,20,24] 37 | cartesianCombine :: (a -> b -> c) -> [a] -> [b] -> [c] 38 | cartesianCombine f l1 l2 = zipWith f newL1 cycledL2 39 | where 40 | nToAdd = length l2 41 | repeatedL1 = map (replicate nToAdd) l1 42 | newL1 = mconcat repeatedL1 43 | cycledL2 = cycle l2 44 | 45 | combineEvents :: Events -> Events -> Events 46 | combineEvents (Events e1) (Events e2) = 47 | Events (cartesianCombine (\x y -> mconcat [x, "-", y]) e1 e2) 48 | 49 | instance Semigroup Events where 50 | (<>) = combineEvents 51 | 52 | instance Monoid Events where 53 | mempty = Events [] 54 | mappend = (<>) 55 | 56 | combineProbs :: Probs -> Probs -> Probs 57 | combineProbs (Probs p1) (Probs p2) = Probs (cartesianCombine (*) p1 p2) 58 | 59 | instance Semigroup Probs where 60 | (<>) = combineProbs 61 | 62 | instance Monoid Probs where 63 | mempty = Probs [] 64 | mappend = (<>) 65 | 66 | instance Semigroup PTable where 67 | (<>) ptable1 (PTable (Events []) (Probs [])) = ptable1 68 | (<>) (PTable (Events []) (Probs [])) ptable2 = ptable2 69 | (<>) (PTable e1 p1) (PTable e2 p2) = createPTable (e1 <> e2) (p1 <> p2) 70 | 71 | instance Monoid PTable where 72 | mempty = PTable (Events []) (Probs []) 73 | mappend = (<>) 74 | 75 | -- 76 | -- Example PTables 77 | -- 78 | coin = createPTable (Events ["heads", "tails"]) (Probs [0.5, 0.5]) 79 | 80 | spinner = createPTable (Events ["red", "blue", "green"]) (Probs [0.1, 0.2, 0.7]) 81 | -- 82 | -- The <> operator gives us the probability of each possible combo: 83 | {- 84 | coin <> spinner == 85 | heads-red|5.0e-2 86 | heads-blue|0.1 87 | heads-green|0.35 88 | tails-red|5.0e-2 89 | tails-blue|0.1 90 | tails-green|0.35 91 | -} 92 | -- 93 | -- Probability of flipping heads three times in a row: 94 | {- 95 | mconcat [coin,coin,coin] == 96 | heads-heads-heads|0.125 97 | heads-heads-tails|0.125 98 | heads-tails-heads|0.125 99 | heads-tails-tails|0.125 100 | tails-heads-heads|0.125 101 | tails-heads-tails|0.125 102 | tails-tails-heads|0.125 103 | tails-tails-tails|0.125 104 | -} 105 | -------------------------------------------------------------------------------- /Unit03/Lesson18.hs: -------------------------------------------------------------------------------- 1 | module Lesson18 where 2 | 3 | import qualified Data.Map as Map 4 | 5 | -- Consider this 6 | 7 | type Latitude = Double 8 | type Longitude = Double 9 | 10 | data Coordinate = Coordinate Latitude Longitude deriving (Show) 11 | 12 | ct1 = Coordinate 40.632527 (-74.020869) 13 | 14 | -- 15 | -- Types that take arguments 16 | -- 17 | 18 | -- Simplest parameterized type: 19 | 20 | newtype Box a = Box a deriving (Show) 21 | 22 | wrap :: a -> Box a 23 | wrap = Box 24 | 25 | unwrap :: Box a -> a 26 | unwrap (Box x) = x 27 | 28 | -- QC1 29 | -- :t wrap (Box 'a') --> Box (Box Char) 30 | 31 | -- A more useful parameterized type 32 | 33 | data Triple a = Triple a a a deriving (Show) 34 | 35 | type Point3D = Triple Double 36 | 37 | aPoint :: Point3D 38 | aPoint = Triple 0.1 53.2 12.3 39 | 40 | type FullName = Triple String 41 | 42 | aPerson :: FullName 43 | aPerson = Triple "Howard" "Phillips" "Lovecraft" 44 | 45 | -- Accessors 46 | 47 | first :: Triple a -> a 48 | first (Triple x _ _) = x 49 | 50 | second :: Triple a -> a 51 | second (Triple _ x _) = x 52 | 53 | third :: Triple a -> a 54 | third (Triple _ _ x) = x 55 | 56 | -- 57 | 58 | toList :: Triple a -> [a] 59 | toList (Triple x y z) = [x, y, z] 60 | 61 | {- 62 | transform (* 3) aPoint -- Triple 0.30000000000000004 159.60000000000002 36.900000000000006 63 | transform reverse aPerson -- Triple "drawoH" "spillihP" "tfarcevoL" 64 | -} 65 | transform :: (a -> a) -> Triple a -> Triple a 66 | transform f (Triple x y z) = Triple (f x) (f y) (f z) 67 | 68 | -- QC2 69 | -- `map` can return a list with a different type from the original; `transform` can't. 70 | 71 | -- Lists 72 | 73 | -- Implement my own List type 74 | -- i.e. data [] a = [] | a:[a] 75 | 76 | data List a = Empty | Cons a (List a) deriving (Eq, Show) 77 | 78 | list1 :: List Int 79 | list1 = Cons 1 (Cons 2 (Cons 3 Empty)) 80 | 81 | list2 :: List Char 82 | list2 = Cons 'c' (Cons 'a' (Cons 't' Empty)) 83 | 84 | {- 85 | map' (*2) list1 -- Cons 2 (Cons 4 (Cons 6 Empty)) 86 | -} 87 | map' :: (a -> b) -> List a -> List b 88 | map' _ Empty = Empty 89 | map' f (Cons x xs) = Cons (f x) (map' f xs) 90 | 91 | -- 92 | -- Types with more than one parameter 93 | -- 94 | 95 | -- E.g. tuple 96 | -- i.e. data (,) a b = (,) a b 97 | 98 | itemCount1 :: (String, Int) 99 | itemCount1 = ("Erasers", 25) 100 | 101 | itemCount2 :: (String, Int) 102 | itemCount2 = ("Pencils", 25) 103 | 104 | itemCount3 :: (String, Int) 105 | itemCount3 = ("Pens", 13) 106 | 107 | itemInventory :: [(String, Int)] 108 | itemInventory = [itemCount1, itemCount2, itemCount3] 109 | 110 | -- QC3 111 | -- Error, because 12.4 is not an Int. 112 | 113 | -- Kinds 114 | 115 | -- QC4 116 | -- :k (,,) ==> (,,) :: * -> * -> * -> * 117 | 118 | -- Data.Map 119 | 120 | data Organ = Heart | Brain | Kidney | Spleen deriving (Show, Eq, Ord, Enum, Bounded) 121 | 122 | organs :: [Organ] 123 | organs = [Heart, Heart, Brain, Spleen, Spleen, Kidney] 124 | 125 | ids :: [Int] 126 | ids = [2, 7, 13, 14, 21, 24] 127 | 128 | pairs :: [(Int, Organ)] 129 | pairs = zip ids organs 130 | -- [(2,Heart),(7,Heart),(13,Brain),(14,Spleen),(21,Spleen),(24,Kidney)] 131 | 132 | catalog :: Map.Map Int Organ 133 | catalog = Map.fromList pairs 134 | -- fromList [(2,Heart),(7,Heart),(13,Brain),(14,Spleen),(21,Spleen),(24,Kidney)] 135 | 136 | {- 137 | Map.lookup 7 catalog -- Just Heart 138 | -} 139 | 140 | -- Q1 141 | 142 | {- 143 | tripleMap (+1) aPoint -- Triple 1.1 54.2 13.3 144 | -} 145 | tripleMap :: (a -> b) -> Triple a -> Triple b 146 | tripleMap f (Triple x y z) = Triple (f x) (f y) (f z) 147 | 148 | {- 149 | boxMap (*2) (Box 4) -- Box 8 150 | -} 151 | boxMap :: (a -> b) -> Box a -> Box b 152 | boxMap f (Box x) = Box (f x) 153 | 154 | -- Q2 155 | -- Cheat 156 | 157 | values :: [Organ] 158 | values = map snd (Map.toList catalog) -- [Heart,Heart,Brain,Spleen,Spleen,Kidney] 159 | 160 | allOrgans :: [Organ] 161 | allOrgans = [minBound .. maxBound] -- [Heart,Brain,Kidney,Spleen] 162 | 163 | -- Walk through the list of possible organs and count the number of 164 | -- matches of each in our catalog 165 | organCounts :: [Int] 166 | organCounts = map countOrgan allOrgans 167 | where countOrgan organ = (length . filter (== organ)) values -- [2,1,1,2] 168 | 169 | organInventory :: Map.Map Organ Int 170 | organInventory = Map.fromList (zip allOrgans organCounts) 171 | -- fromList [(Heart,2),(Brain,1),(Kidney,1),(Spleen,2)] 172 | -------------------------------------------------------------------------------- /Unit03/Lesson19.hs: -------------------------------------------------------------------------------- 1 | module Lesson19 where 2 | 3 | import Data.List ( intercalate ) 4 | import qualified Data.Map as Map 5 | import Data.Maybe 6 | 7 | -- Consider this 8 | 9 | groceries :: Map.Map String Int 10 | groceries = Map.fromList [("Milk", 1), ("Candy bars", 10), ("Cheese blocks", 2)] 11 | 12 | ct1 = Map.lookup "Milk" groceries -- Just 1 13 | ct2 = Map.lookup "MILK" groceries -- Nothing 14 | 15 | -- 16 | -- Introducing Maybe: solving missing values with types 17 | -- 18 | 19 | data Organ = Heart | Brain | Kidney | Spleen deriving (Show, Eq) 20 | 21 | organs :: [Organ] 22 | organs = [Heart, Heart, Brain, Spleen, Spleen, Kidney] 23 | 24 | ids :: [Int] 25 | ids = [2, 7, 13, 14, 21, 24] 26 | 27 | organPairs :: [(Int, Organ)] 28 | organPairs = zip ids organs 29 | 30 | organCatalog :: Map.Map Int Organ 31 | organCatalog = Map.fromList organPairs 32 | 33 | {- 34 | Map.lookup 7 organCatalog -- Just Heart 35 | Map.lookup 6 organCatalog -- Nothing 36 | -} 37 | 38 | -- QC1 39 | -- Map.lookup 6 organCatalog :: Maybe Organ 40 | 41 | -- 42 | -- The problem with null 43 | -- 44 | 45 | possibleDrawers :: [Int] 46 | possibleDrawers = [1 .. 50] 47 | 48 | {- 49 | getDrawerContents [12, 13] organCatalog -- [Nothing, Just Brain] 50 | -} 51 | getDrawerContents :: [Int] -> Map.Map Int Organ -> [Maybe Organ] 52 | getDrawerContents ids catalog = map (`Map.lookup` catalog) ids 53 | 54 | availableOrgans :: [Maybe Organ] 55 | availableOrgans = getDrawerContents possibleDrawers organCatalog 56 | -- [Nothing,Just Heart,Nothing,Nothing,Nothing,Nothing,Just Heart,Nothing,..etc..] 57 | 58 | {- 59 | countOrgan Heart availableOrgans -- 2 60 | -} 61 | countOrgan :: Organ -> [Maybe Organ] -> Int 62 | countOrgan organ available = length (filter (\x -> x == Just organ) available) 63 | 64 | -- 65 | -- Computing with Maybe 66 | -- 67 | 68 | justTheOrgans :: [Maybe Organ] 69 | justTheOrgans = filter isJust availableOrgans 70 | -- [Just Heart,Just Heart,Just Brain,Just Spleen,Just Spleen,Just Kidney] 71 | 72 | showOrgan :: Maybe Organ -> String 73 | showOrgan (Just organ) = show organ 74 | showOrgan Nothing = "" 75 | 76 | organList :: [String] 77 | organList = map showOrgan justTheOrgans 78 | -- ["Heart","Heart","Brain","Spleen","Spleen","Kidney"] 79 | 80 | cleanList :: String 81 | cleanList = intercalate ", " organList -- "Heart, Heart, Brain, Spleen, Spleen, Kidney" 82 | 83 | -- QC2 84 | 85 | {- 86 | numOrZero Nothing -- 0 87 | numOrZero (Just 3) -- 3 88 | -} 89 | numOrZero :: Maybe Int -> Int 90 | numOrZero Nothing = 0 91 | numOrZero (Just n) = n 92 | 93 | -- 94 | -- Back to the lab! More-complex computation with Maybe 95 | -- 96 | 97 | data Container = Vat Organ | Cooler Organ | Bag Organ 98 | 99 | instance Show Container where 100 | show (Vat organ) = show organ ++ " in a vat" 101 | show (Cooler organ) = show organ ++ " in a cooler" 102 | show (Bag organ) = show organ ++ " in a bag" 103 | 104 | data Location = Lab | Kitchen | Bathroom deriving (Show) 105 | 106 | organToContainer :: Organ -> Container 107 | organToContainer Brain = Vat Brain 108 | organToContainer Heart = Cooler Heart 109 | organToContainer organ = Bag organ 110 | 111 | placeInLocation :: Container -> (Location, Container) 112 | placeInLocation (Vat a) = (Lab, Vat a) 113 | placeInLocation (Cooler a) = (Lab, Cooler a) 114 | placeInLocation (Bag a) = (Kitchen, Bag a) 115 | 116 | {- 117 | process Brain -- (Lab,Brain in a vat) 118 | process Heart -- (Lab,Heart in a cooler) 119 | process Spleen -- (Kitchen,Spleen in a bag) 120 | -} 121 | process :: Organ -> (Location, Container) 122 | process organ = placeInLocation (organToContainer organ) 123 | 124 | {- 125 | report $ process Brain -- "Brain in a vat in the Lab" 126 | -} 127 | report :: (Location, Container) -> String 128 | report (location, container) = show container ++ " in the " ++ show location 129 | 130 | processAndReport :: (Maybe Organ) -> String 131 | processAndReport (Just organ) = report (process organ) 132 | processAndReport Nothing = "error, id not found" 133 | 134 | {- 135 | processRequest 13 organCatalog -- "Brain in a vat in the Lab" 136 | processRequest 12 organCatalog -- "error, id not found" 137 | -} 138 | processRequest :: Int -> Map.Map Int Organ -> String 139 | processRequest id' catalog = processAndReport organ where organ = Map.lookup id' catalog 140 | 141 | -- QC3 142 | 143 | report' :: Maybe (Location, Container) -> String 144 | report' Nothing = "container not found" 145 | report' (Just (location, container)) = show container ++ " in the " ++ show location 146 | 147 | -- Q1 148 | 149 | emptyDrawers :: Int 150 | emptyDrawers = length (filter (== Nothing) availableOrgans) :: Int -- 44 151 | 152 | -- Q2 153 | 154 | {- 155 | maybeMap (+ 1) (Just 2) -- Just 3 156 | maybeMap (+ 1) Nothing -- Nothing 157 | -} 158 | maybeMap :: (a -> b) -> Maybe a -> Maybe b 159 | maybeMap _ Nothing = Nothing 160 | maybeMap f (Just a) = Just (f a) 161 | -------------------------------------------------------------------------------- /Unit04/Example.hs: -------------------------------------------------------------------------------- 1 | module Example where 2 | 3 | mystery1 :: Int -> Int -> Int 4 | mystery1 val1 val2 = (val1 + val2 + val3) ^ (2 :: Int) where val3 = 3 5 | 6 | mystery2 :: Int -> Int -> IO Int 7 | mystery2 val1 val2 = do 8 | putStrLn "Enter a number" 9 | val3Input <- getLine 10 | let val3 = read val3Input 11 | return ((val1 + val2 + val3) ^ (2 :: Int)) 12 | 13 | safeValue :: Int 14 | safeValue = mystery1 2 4 + mystery1 5 6 15 | 16 | -- Won't compile: 17 | {- 18 | unsafeValue = (mystery2 2 4) + (mystery2 2 4) 19 | -} 20 | -------------------------------------------------------------------------------- /Unit04/Example.java: -------------------------------------------------------------------------------- 1 | public class Example 2 | { 3 | // This is a pure function 4 | public static int mystery1(int val1, int val2) 5 | { 6 | int val3 = 3; 7 | return Math.pow(val1 + val2 + val3, 2); 8 | } 9 | 10 | // This function is impure 11 | public static int mystery2(int val1, int val2) 12 | { 13 | int val3 = 3; 14 | System.out.print("Enter a number"); 15 | try 16 | { 17 | Scanner in = new Scanner(System.in); 18 | val3 = in.nextInt(); 19 | } 20 | catch (IOException e) 21 | { 22 | e.printStackTrace(); 23 | } 24 | return Math.pow(val1 + val2 + val3, 2); 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /Unit04/Lesson21/Lesson21.hs: -------------------------------------------------------------------------------- 1 | module Lesson21 where 2 | 3 | import System.Random 4 | 5 | helloPerson :: String -> String 6 | helloPerson name = "Hello " ++ name ++ "!" 7 | 8 | main1 :: IO () 9 | main1 = do 10 | putStrLn "Hello! What's your name?" 11 | name <- getLine -- (<-) extracts the String from the IO context 12 | let statement = helloPerson name -- `let` is used within `do` with non-IO types 13 | putStrLn statement 14 | 15 | -- QC1 16 | -- `getLine` retrieves the user's input. I would assume the type is String. (But 17 | -- it's really IO String.) 18 | 19 | -- Consider this: 20 | -- "You can get a line of user input by using the `getLine` function. But each time 21 | -- `getLine` is called, it can clearly return a different result." 22 | 23 | -- It works because `getLine` runs in the IO context, which is designed for this 24 | -- purpose. 25 | 26 | -- 27 | -- IO types - dealing with an impure world 28 | -- 29 | 30 | minDie = 1 :: Int 31 | 32 | maxDie = 6 :: Int 33 | 34 | main2 :: IO () 35 | main2 = do 36 | dieRoll <- randomRIO (minDie, maxDie) 37 | print dieRoll 38 | 39 | -- QC2 40 | -- No, because `getLine` returns IO String, not IO (). 41 | 42 | -- QC3 43 | -- No, because `helloPerson` takes a String, not an IO String. 44 | 45 | -- 46 | -- An example: command-line pizza cost calculator 47 | -- See pizza.hs 48 | -- 49 | 50 | -- Q1 51 | 52 | input :: Maybe String 53 | input = Just "Joe" 54 | 55 | maybeMain :: Maybe String 56 | maybeMain = do 57 | name <- input 58 | let statement = helloPerson name 59 | return statement 60 | -------------------------------------------------------------------------------- /Unit04/Lesson21/fibo.hs: -------------------------------------------------------------------------------- 1 | fastFib :: Int -> Int -> Int -> Int 2 | fastFib n1 _ 1 = n1 3 | fastFib _ n2 2 = n2 4 | fastFib n1 n2 3 = n1 + n2 5 | fastFib n1 n2 counter = fastFib (n1 + n2) n1 (counter - 1) 6 | 7 | {- 8 | fib 30 == 832040 <-- 0.00 sec 9 | fib 35 == 9227465 <-- 0.00 sec 10 | fib 1000 == ...long number... <-- 0.00 sec 11 | -} 12 | fib :: Int -> Int 13 | fib = fastFib 1 1 14 | 15 | main :: IO () 16 | main = do 17 | putStr "Number? " 18 | n <- getLine 19 | let result = fib $ read n 20 | putStrLn ("fib " ++ n ++ " = " ++ show result) 21 | -------------------------------------------------------------------------------- /Unit04/Lesson21/pizza.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Map as Map 2 | 3 | type Size = Double 4 | 5 | area :: Size -> Double 6 | area size = pi * (size / 2) ^ (2 :: Int) 7 | 8 | type Cost = Double 9 | 10 | type Pizza = (Size, Cost) 11 | 12 | costPerSqIn :: Pizza -> Double 13 | costPerSqIn (size, cost) = cost / area size 14 | 15 | cheaperPizza :: Pizza -> Pizza -> Pizza 16 | cheaperPizza p1 p2 = case compare (costPerSqIn p1) (costPerSqIn p2) of 17 | LT -> p1 18 | _ -> p2 19 | 20 | describePizza :: Pizza -> String 21 | describePizza (size, cost) = 22 | "The " ++ show size ++ "\" pizza is cheaper at " ++ show cpsi ++ " per sq. in." 23 | where cpsi = costPerSqIn (size, cost) 24 | 25 | main :: IO () 26 | main = do 27 | putStr "What is the size of pizza 1? " 28 | size1 <- getLine 29 | putStr "What is the cost of pizza 1? " 30 | cost1 <- getLine 31 | putStr "What is the size of pizza 2? " 32 | size2 <- getLine 33 | putStr "What is the cost of pizza 2? " 34 | cost2 <- getLine 35 | let pizza1 = (read size1, read cost1) 36 | let pizza2 = (read size2, read cost2) 37 | let betterPizza = cheaperPizza pizza1 pizza2 -- cheaper is better! 38 | putStrLn (describePizza betterPizza) 39 | 40 | -- 41 | -- A peek at Monad - do-notation in Maybe 42 | -- 43 | costData :: Map.Map Int Double 44 | costData = Map.fromList [(1, 18.0), (2, 16.0)] 45 | 46 | sizeData :: Map.Map Int Double 47 | sizeData = Map.fromList [(1, 20.0), (2, 15.0)] 48 | 49 | maybeMain :: Maybe String 50 | maybeMain = do 51 | size1 <- Map.lookup 1 sizeData 52 | cost1 <- Map.lookup 1 costData 53 | size2 <- Map.lookup 2 sizeData 54 | cost2 <- Map.lookup 2 costData 55 | let pizza1 = (size1, cost1) 56 | let pizza2 = (size2, cost2) 57 | let betterPizza = cheaperPizza pizza1 pizza2 58 | return (describePizza betterPizza) 59 | -------------------------------------------------------------------------------- /Unit04/Lesson22/Lesson22.hs: -------------------------------------------------------------------------------- 1 | module Lesson22 where 2 | 3 | -- 4 | -- Interacting with the command line the nonlazy way 5 | -- see sum.hs 6 | -- 7 | 8 | -- QC1 9 | 10 | main1 :: IO () 11 | main1 = do 12 | vals <- mapM (const getLine) [1 .. 3] 13 | mapM_ putStrLn vals 14 | 15 | -- QC2 16 | 17 | replicateM' :: (Monad m, Num a, Enum a) => a -> m b -> m [b] 18 | replicateM' n f = mapM (const f) [1 .. n] 19 | 20 | -- 21 | -- Interacting with lazy I/O 22 | -- see sum_lazy.hs 23 | -- 24 | 25 | -- QC3 26 | -- see QC3.hs 27 | 28 | -- QC4 29 | -- see QC4.hs 30 | 31 | -- Q1 32 | -- see simple_calc.hs 33 | 34 | -- Q2 35 | -- see quotes.hs 36 | -------------------------------------------------------------------------------- /Unit04/Lesson22/QC3.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = do 3 | userInput <- getContents 4 | let output = reverse userInput 5 | putStrLn output 6 | -------------------------------------------------------------------------------- /Unit04/Lesson22/QC4.hs: -------------------------------------------------------------------------------- 1 | toInts :: String -> [Int] 2 | toInts = map read . lines 3 | 4 | compute :: [Int] -> Int 5 | compute ns = sum $ map (^ 2) ns 6 | 7 | main :: IO () 8 | main = do 9 | input <- getContents 10 | let numbers = toInts input 11 | print (compute numbers) 12 | -------------------------------------------------------------------------------- /Unit04/Lesson22/quotes.hs: -------------------------------------------------------------------------------- 1 | quotes = ["Quote 1", "Quote 2", "Quote 3", "Quote 4", "Quote 5"] 2 | 3 | {- 4 | lookupQuote ["2","1","3","n"] == ["Quote 2","Quote 1","Quote 3"] 5 | -} 6 | lookupQuote :: [String] -> [String] 7 | lookupQuote [] = [] 8 | lookupQuote ("n" : xs) = [] 9 | lookupQuote (x : xs) = quote : lookupQuote xs where quote = quotes !! (read x - 1) 10 | 11 | main :: IO () 12 | main = do 13 | -- How do I print a prompt for each input? 14 | -- putStrLn "Enter a number from 1-5 or n to quit: " 15 | input <- getContents 16 | mapM_ putStrLn (lookupQuote (lines input)) 17 | -------------------------------------------------------------------------------- /Unit04/Lesson22/simple_calc.hs: -------------------------------------------------------------------------------- 1 | import Data.List.Split 2 | 3 | {- 4 | isPlus "1 + 2" -- True 5 | -} 6 | isPlus :: String -> Bool 7 | isPlus = elem '+' 8 | 9 | {- 10 | isMult "1 + 2" -- False 11 | -} 12 | isMult :: String -> Bool 13 | isMult = elem '*' 14 | 15 | {- 16 | splitEquation "1 + 2" -- (1, 2) 17 | -} 18 | splitEquation :: String -> (Int, Int) 19 | splitEquation eq 20 | | isPlus eq = (read (head sp), read (last sp)) 21 | | isMult eq = (read (head sm), read (last sm)) 22 | where 23 | sp = splitOn "+" eq 24 | sm = splitOn "*" eq 25 | 26 | {- 27 | evalEquation "12 + 34" -- 46 28 | evalEquation "56 * 78" -- 4368 29 | -} 30 | evalEquation :: String -> Int 31 | evalEquation eq 32 | | isPlus eq = l + r 33 | | isMult eq = l * r 34 | where 35 | lr = splitEquation eq 36 | l = fst lr 37 | r = snd lr 38 | 39 | main :: IO () 40 | main = do 41 | input <- getContents 42 | let results = map evalEquation (lines input) 43 | print results 44 | 45 | -- 46 | -- POST MORTEM 47 | -- My solution prints the results after all equations are input 48 | -- 49 | -- Perhaps we were supposed to use the non-lazy technique here? 50 | -- 51 | -------------------------------------------------------------------------------- /Unit04/Lesson22/simple_calc_ans.hs: -------------------------------------------------------------------------------- 1 | calc :: [String] -> Int 2 | calc (val1:"+":val2:rest) = read val1 + read val2 3 | calc (val1:"*":val2:rest) = read val1 * read val2 4 | 5 | main :: IO () 6 | main = do 7 | userInput <- getContents 8 | let values = lines userInput 9 | print (calc values) 10 | -------------------------------------------------------------------------------- /Unit04/Lesson22/sum.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import System.Environment 3 | 4 | -- All the logic is wrapped up in IO - sad! 5 | 6 | main :: IO () 7 | main = do 8 | args <- getArgs 9 | -- putStrLn "Args: " 10 | -- mapM_ putStrLn args 11 | let count = if not (null args) then read (head args) else 0 12 | numbers <- replicateM count getLine 13 | let ints = map read numbers :: [Int] 14 | print (sum ints) 15 | -------------------------------------------------------------------------------- /Unit04/Lesson22/sum_lazy.hs: -------------------------------------------------------------------------------- 1 | -- Warning: this gets strange - and you need to compile it and run it in 2 | -- a terminal for it to work right. 3 | 4 | {- 5 | toInts ['6','2','\n','2','1','\n'] -- [62,21] 6 | -} 7 | toInts :: String -> [Int] 8 | toInts = map read . lines 9 | 10 | main :: IO () 11 | main = do 12 | input <- getContents 13 | -- mapM_ print input 14 | let numbers = toInts input 15 | print (sum numbers) 16 | -------------------------------------------------------------------------------- /Unit04/Lesson23/Lesson23.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Lesson23 where 4 | 5 | import qualified Data.Text as T 6 | import qualified Data.Text.Lazy as TL 7 | import qualified Data.Text.Lazy.IO as TLIO 8 | 9 | -- 10 | -- Using Data.Text 11 | -- 12 | 13 | word1 :: String 14 | word1 = "pessimism" 15 | 16 | word2 :: T.Text 17 | word2 = T.pack word1 18 | 19 | word3 :: String 20 | word3 = T.unpack word2 21 | 22 | -- QC1 23 | 24 | word4 :: T.Text 25 | word4 = T.pack word3 26 | 27 | -- With OverloadedStrings language extension: 28 | 29 | sampleInput :: T.Text 30 | sampleInput = "this\nis some\ninput" 31 | 32 | {- 33 | T.lines sampleInput -- ["this","is some","input"] 34 | T.words sampleInput -- ["this","is","some","input"] 35 | T.splitOn (T.pack "is") sampleInput -- ["th","\n"," some\ninput"] 36 | T.unlines (T.lines sampleInput) -- "this\nis some\ninput\n" 37 | T.unwords (T.words sampleInput) -- "this is some input" 38 | T.intercalate (T.pack ",") (T.words sampleInput) -- "this,is,some,input" 39 | -} 40 | 41 | combinedTextMonoid :: T.Text 42 | combinedTextMonoid = mconcat ["some", " ", "text"] -- "some text" 43 | 44 | combinedTextSemigroup :: T.Text 45 | combinedTextSemigroup = "some" <> " " <> "text" -- "some text" 46 | 47 | -- QC3 48 | 49 | lines' :: T.Text -> [T.Text] 50 | lines' = T.splitOn "\n" 51 | 52 | unlines' :: [T.Text] -> T.Text 53 | unlines' = T.intercalate "\n" 54 | 55 | -- 56 | -- Text and Unicode & Text I/O 57 | -- see bg_highlight.hs 58 | -- 59 | 60 | -- Q1 61 | -- See hello_world.hs 62 | 63 | -- Q2 64 | -- Cheated. 65 | -- Q: Why is there no lazy read? 66 | 67 | toInts :: TL.Text -> [Int] 68 | toInts = map (read . TL.unpack) . TL.lines 69 | 70 | main2 :: IO () 71 | main2 = do 72 | input <- TLIO.getContents 73 | let numbers = toInts input 74 | TLIO.putStrLn (TL.pack (show (sum numbers))) 75 | -------------------------------------------------------------------------------- /Unit04/Lesson23/bg_highlight.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Data.Text as T 4 | import qualified Data.Text.IO as TIO 5 | 6 | dharma :: T.Text 7 | dharma = "धर्म" 8 | 9 | -- Do Strings handle Unicode? Looks like it: 10 | dharmaS :: String 11 | dharmaS = "धर्म" 12 | 13 | bgText :: T.Text 14 | bgText = "श्रेयान्स्वधर्मोविगुणःपरधर्मात्स्वनुष्ठितात्।स्वधर्मेनिधनंश्रेयःपरधर्मो" 15 | 16 | highlight :: T.Text -> T.Text -> T.Text 17 | highlight query fullText = T.intercalate highlighted pieces 18 | where 19 | pieces = T.splitOn query fullText 20 | highlighted = mconcat ["{", query, "}"] 21 | 22 | main :: IO () 23 | main = TIO.putStrLn (highlight dharma bgText) 24 | -------------------------------------------------------------------------------- /Unit04/Lesson23/hello_world.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Data.Text as T 4 | import qualified Data.Text.IO as TIO 5 | 6 | helloPerson :: T.Text -> T.Text 7 | helloPerson name = mconcat ["Hi, ", name, "!"] 8 | 9 | main :: IO () 10 | main = do 11 | TIO.putStrLn "Hello! What's your name?" 12 | name <- TIO.getLine 13 | let statement = helloPerson name 14 | TIO.putStrLn statement 15 | -------------------------------------------------------------------------------- /Unit04/Lesson24/Lesson24.hs: -------------------------------------------------------------------------------- 1 | module Lesson24 where 2 | 3 | import System.IO 4 | 5 | -- 6 | -- Opening and closing files 7 | -- 8 | 9 | -- QC1 10 | -- openFile "stuff.txt" ReadMode 11 | 12 | main1 :: IO () 13 | main1 = do 14 | file <- openFile "hello.txt" ReadMode 15 | hClose file 16 | putStrLn "Done." 17 | 18 | main2 :: IO () 19 | main2 = do 20 | inputFile <- openFile "hello.txt" ReadMode 21 | line1 <- hGetLine inputFile 22 | putStrLn line1 23 | line2 <- hGetLine inputFile 24 | outputFile <- openFile "goodbye.txt" AppendMode 25 | hPutStrLn outputFile line2 26 | hClose inputFile 27 | hClose outputFile 28 | putStrLn "Done." 29 | 30 | main3 :: IO () 31 | main3 = do 32 | helloFile <- openFile "hello1.txt" ReadMode 33 | eof <- hIsEOF helloFile 34 | firstLine <- if not eof then hGetLine helloFile else return "empty" 35 | putStrLn firstLine 36 | -- QC2 37 | eof <- hIsEOF helloFile 38 | secondLine <- if not eof then hGetLine helloFile else return "no second line" 39 | putStrLn secondLine 40 | putStrLn "done!" 41 | 42 | -- 43 | -- Simple I/O tools 44 | -- See fileCounts.hs 45 | -- 46 | 47 | -- 48 | -- The trouble with lazy I/O 49 | -- see fileCounts.hs, 2nd version of `main` 50 | -- 51 | 52 | -- QC4 53 | -- Because it's lazy - the data can be read any time later in the program. 54 | 55 | -- 56 | -- Strict I/O 57 | -- See fileCount_strict.hs 58 | -- 59 | 60 | -- Q1 61 | -- See cp.hs 62 | 63 | -- Q2 64 | -- See capitalize.hs 65 | 66 | -- FIXED - I'm still not clear on the difference between let= and <- 67 | -- ==> Use <- to assign a value of type IO a and let it behave like type a 68 | -- Use let= to assign a value that isn't an IO type 69 | -------------------------------------------------------------------------------- /Unit04/Lesson24/capitalize.hs: -------------------------------------------------------------------------------- 1 | import Data.Text ( toUpper ) 2 | import qualified Data.Text.IO as TIO 3 | import System.Environment 4 | 5 | main :: IO () 6 | main = do 7 | args <- getArgs 8 | let fileName = head args 9 | content <- TIO.readFile fileName 10 | let result = toUpper content 11 | TIO.writeFile fileName result 12 | putStrLn "Done." 13 | 14 | 15 | -- E.g. ./capitalize hello.txt ==> should capitaliza all text 16 | -------------------------------------------------------------------------------- /Unit04/Lesson24/cp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Rhywun/get-programming-with-haskell/4f57ac35cb425c48f3976ebd81d4ac0174c6d352/Unit04/Lesson24/cp -------------------------------------------------------------------------------- /Unit04/Lesson24/cp.hs: -------------------------------------------------------------------------------- 1 | import System.Environment 2 | import System.IO 3 | 4 | main :: IO () 5 | main = do 6 | args <- getArgs 7 | let src = head args 8 | let dest = last args 9 | content <- readFile src 10 | writeFile dest content 11 | putStrLn "Done." 12 | 13 | -- E.g. ./cp hello.txt hello1.txt ==> creates hello1.txt 14 | -------------------------------------------------------------------------------- /Unit04/Lesson24/fileCount_strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import System.Environment 4 | import System.IO 5 | import qualified Data.Text as T 6 | import qualified Data.Text.IO as TI 7 | 8 | {- 9 | getCounts "Hello, world!\nGood-bye, world!" == (30, 4, 2) 10 | -} 11 | getCounts :: T.Text -> (Int, Int, Int) 12 | getCounts xs = (T.length xs, (length . T.words) xs, (length . T.lines) xs) 13 | 14 | {- 15 | describeCounts (30, 4, 2) == "chars: 30 words: 4 lines: 2" 16 | -} 17 | describeCounts :: (Int, Int, Int) -> T.Text 18 | describeCounts (cc, wc, lc) = 19 | T.pack (unwords ["chars: ", show cc, " words: ", show wc, " lines: ", show lc]) 20 | 21 | -- This version solves the locking issue on stats.dat 22 | main :: IO () 23 | main = do 24 | args <- getArgs 25 | let fileName = head args 26 | input <- TI.readFile fileName 27 | let summary = (describeCounts . getCounts) input 28 | TI.appendFile "stats.dat" (mconcat [T.pack fileName, " ", summary, "\n"]) 29 | TI.putStrLn summary 30 | -------------------------------------------------------------------------------- /Unit04/Lesson24/fileCounts: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Rhywun/get-programming-with-haskell/4f57ac35cb425c48f3976ebd81d4ac0174c6d352/Unit04/Lesson24/fileCounts -------------------------------------------------------------------------------- /Unit04/Lesson24/fileCounts.hs: -------------------------------------------------------------------------------- 1 | import System.Environment 2 | import System.IO 3 | 4 | -- NOTE: this implementation is lazy & has issues 5 | 6 | {- 7 | getCounts "Hello, world!\nGood-bye, world!" -- (30, 4, 2) 8 | -} 9 | getCounts :: String -> (Int, Int, Int) 10 | getCounts xs = (length xs, (length . words) xs, (length . lines) xs) 11 | 12 | {- 13 | describeCounts (30, 4, 2) -- "chars: 30 words: 4 lines: 2" 14 | -} 15 | describeCounts :: (Int, Int, Int) -> String 16 | describeCounts (cc, wc, lc) = 17 | unwords ["chars: ", show cc, " words: ", show wc, " lines: ", show lc] 18 | 19 | -- QC3 20 | -- It is preferable to use `unwords` because we might want to use Text. 21 | 22 | -- This version won't work on stats.dat becasue the file is locked while writing 23 | {- 24 | main :: IO () 25 | main = do 26 | args <- getArgs 27 | let fileName = head args 28 | input <- readFile fileName 29 | let summary = (describeCounts . getCounts) input 30 | appendFile "stats.dat" (mconcat [fileName, " ", summary, "\n"]) 31 | putStrLn summary 32 | -} 33 | 34 | -- This version should work on stats.dat, because we've closed the file after its 35 | -- contents are read 36 | main :: IO () 37 | main = do 38 | args <- getArgs 39 | let fileName = head args 40 | file <- openFile fileName ReadMode 41 | input <- hGetContents file 42 | let summary = (describeCounts . getCounts) input 43 | putStrLn summary 44 | hClose file -- moved here to prevent lazy evaluation error 45 | appendFile "stats.dat" (mconcat [fileName, " ", summary, "\n"]) 46 | -------------------------------------------------------------------------------- /Unit04/Lesson24/goodbye.txt: -------------------------------------------------------------------------------- 1 | Good-bye world! 2 | Good-bye world! 3 | -------------------------------------------------------------------------------- /Unit04/Lesson24/hello.txt: -------------------------------------------------------------------------------- 1 | Hello world! 2 | Good-bye world! 3 | -------------------------------------------------------------------------------- /Unit04/Lesson24/hello1.txt: -------------------------------------------------------------------------------- 1 | HELLO WORLD! 2 | -------------------------------------------------------------------------------- /Unit04/Lesson24/stats.dat: -------------------------------------------------------------------------------- 1 | hello.txt chars: 29 words: 4 lines: 2 2 | stats.dat chars: 43 words: 7 lines: 1 3 | stats.dat chars: 86 words: 14 lines: 2 4 | stats.dat chars: 130 words: 21 lines: 3 5 | -------------------------------------------------------------------------------- /Unit04/Lesson25/Lesson25.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Lesson25 where 4 | 5 | import qualified Data.ByteString as B 6 | import qualified Data.ByteString.Char8 as BC 7 | import qualified Data.Text as T 8 | import qualified Data.Text.Encoding as E 9 | import qualified Data.Text.IO as TIO 10 | 11 | 12 | -- Consider this: 13 | 14 | tatsuhikoTakimoto :: T.Text 15 | tatsuhikoTakimoto = "滝本 竜彦" 16 | 17 | -- How many bytes? This is not the correct answer: 18 | {- 19 | T.length tatsuhikoTakimoto -- 5 20 | -} 21 | 22 | -- Answer: 23 | -- ??? 24 | 25 | -- 26 | -- Working with binary data by using ByteString 27 | -- 28 | 29 | sampleBytes :: B.ByteString 30 | sampleBytes = "Hello!" 31 | 32 | sampleString :: String 33 | -- sampleString = B.unpack sampleBytes <-- this doesn't work 34 | sampleString = BC.unpack sampleBytes 35 | 36 | -- QC1 37 | 38 | bcInt :: BC.ByteString 39 | bcInt = "6" 40 | 41 | {- 42 | bcbs2int bcInt -- 6 43 | -} 44 | bcbs2int :: BC.ByteString -> Int 45 | bcbs2int x = read $ BC.unpack x 46 | 47 | -- 48 | -- Glitching JPEGs 49 | -- see glitcher.hs 50 | -- 51 | 52 | -- 53 | -- ByteStrings, Char8, and Unicode 54 | -- 55 | 56 | nagarjunaBC :: BC.ByteString 57 | nagarjunaBC = "नागर्जुनॅ" -- "(>\ETB0M\FSA(E" 58 | 59 | nagarjunaText :: T.Text 60 | nagarjunaText = "नागर्जुनॅ" -- "\2344\2366\2327\2352\2381\2332\2369\2344\2373" 61 | 62 | nagarjunaB :: B.ByteString 63 | nagarjunaB = (BC.pack . T.unpack) nagarjunaText -- "(>\ETB0M\FSA(E" 64 | 65 | -- You'll need Data.Text.Encoding to make this work! 66 | -- (see text) 67 | 68 | -- Q1 69 | -- cheat 70 | 71 | q1 :: IO () 72 | q1 = do 73 | input <- B.readFile "tatsuhiko.txt" 74 | putStr "Bytes: " 75 | print (B.length input) 76 | putStr "Chars: " 77 | print ((T.length . E.decodeUtf8) input) 78 | 79 | -- Q2 80 | -- pass 81 | -------------------------------------------------------------------------------- /Unit04/Lesson25/glitcher: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Rhywun/get-programming-with-haskell/4f57ac35cb425c48f3976ebd81d4ac0174c6d352/Unit04/Lesson25/glitcher -------------------------------------------------------------------------------- /Unit04/Lesson25/glitcher.hs: -------------------------------------------------------------------------------- 1 | import System.Environment 2 | import System.Random 3 | import qualified Data.ByteString as B 4 | import qualified Data.ByteString.Char8 as BC 5 | 6 | main :: IO () 7 | main = do 8 | args <- getArgs 9 | let fileName = head args 10 | imageFile <- BC.readFile fileName 11 | glitched <- randomReplaceByte imageFile 12 | let glitchedFileName = "glitched_" <> fileName 13 | BC.writeFile glitchedFileName glitched 14 | putStrLn "Done." 15 | 16 | -- 17 | -- Pure code 18 | -- 19 | 20 | -- Convert an Int to a valid ASCII byte 21 | {- 22 | intToChar 12345 -- 'i' 23 | -} 24 | intToChar :: Int -> Char 25 | intToChar i = toEnum $ i `mod` 255 26 | 27 | -- Convert an Int to a ByteString 28 | {- 29 | intToBC 12345 -- "i" 30 | -} 31 | intToBC :: Int -> BC.ByteString 32 | intToBC i = BC.pack [intToChar i] 33 | 34 | -- Insert charVal at loc in bytes 35 | replaceByte :: Int -> Int -> BC.ByteString -> BC.ByteString 36 | replaceByte loc charVal bytes = before <> newChar <> after 37 | where 38 | (before, rest) = BC.splitAt loc bytes 39 | after = BC.drop 1 rest 40 | newChar = intToBC charVal 41 | 42 | -- Sort size bytes at start 43 | sortSection :: Int -> Int -> BC.ByteString -> BC.ByteString 44 | sortSection start size bytes = mconcat [before, changed, after] 45 | where 46 | (before, rest ) = BC.splitAt start bytes 47 | (target, after) = BC.splitAt size rest 48 | changed = BC.reverse (BC.sort target) 49 | 50 | -- 51 | -- Impure code 52 | -- 53 | 54 | -- Applies random numbers to `replaceByte` 55 | randomReplaceByte :: BC.ByteString -> IO BC.ByteString 56 | randomReplaceByte bytes = do 57 | let bytesLength = BC.length bytes 58 | location <- randomRIO (1, bytesLength) 59 | charVal <- randomRIO (0, 255) 60 | return (replaceByte location charVal bytes) 61 | 62 | -- QC3 63 | 64 | -- Get a random char 65 | {- 66 | randomChar -- 'R' 67 | randomChar -- '\RS' 68 | randomChar -- '=' 69 | -} 70 | randomChar :: IO Char 71 | randomChar = do 72 | charVal <- randomRIO (0, 255) 73 | return (toEnum charVal) 74 | 75 | randomSortSection :: BC.ByteString 76 | randomSortSection = undefined 77 | 78 | -- Giving up because I'm sick and tired of random breaking HIE 79 | -------------------------------------------------------------------------------- /Unit04/Lesson25/lovecraft.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Rhywun/get-programming-with-haskell/4f57ac35cb425c48f3976ebd81d4ac0174c6d352/Unit04/Lesson25/lovecraft.jpeg -------------------------------------------------------------------------------- /Unit04/Lesson25/tatsuhiko.txt: -------------------------------------------------------------------------------- 1 | 滝本 竜彦 -------------------------------------------------------------------------------- /Unit04/Lesson26/marc_to_html.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Data.ByteString as B 4 | import qualified Data.Text as T 5 | import qualified Data.Text.IO as TIO 6 | import qualified Data.Text.Encoding as E 7 | import Data.Maybe 8 | 9 | -- 10 | -- Working with book data 11 | -- 12 | 13 | howMany :: Int 14 | howMany = 500 15 | 16 | main :: IO () 17 | main = do 18 | marcData <- B.readFile "sample.mrc" 19 | let processed = processRecords howMany marcData 20 | TIO.writeFile "books.html" processed 21 | 22 | -- 23 | 24 | type Author = T.Text 25 | type Title = T.Text 26 | type Html = T.Text 27 | 28 | data Book = Book 29 | { author :: Author 30 | , title :: Title 31 | } deriving Show 32 | 33 | bookToHtml :: Book -> Html 34 | bookToHtml book = "

\n" <> titleInTags <> authorInTags <> "

\n" 35 | where 36 | titleInTags = "" <> title book <> "\n" 37 | authorInTags = "" <> author book <> "\n" 38 | 39 | book1 :: Book 40 | book1 = 41 | Book {title = "The Conspiracy Against the Human Race", author = "Ligotti, Thomas"} 42 | 43 | book2 :: Book 44 | book2 = Book {title = "A Short History of Decay", author = "Cioran, Emil"} 45 | 46 | book3 :: Book 47 | book3 = Book {title = "The Tears of Eros", author = "Bataille, Georges"} 48 | 49 | booksToHtml :: [Book] -> Html 50 | booksToHtml books = mconcat 51 | [ "\n" 52 | , "books" 53 | , "" 54 | , "\n" 55 | , "\n" 56 | , booksHtml 57 | , "\n\n" 58 | , "" 59 | ] 60 | where booksHtml = (mconcat . map bookToHtml) books 61 | 62 | myBooks :: [Book] 63 | myBooks = [book1, book2, book3] 64 | 65 | -- 66 | -- Working with MARC records 67 | -- 68 | 69 | type MarcRecordRaw = B.ByteString 70 | type MarcLeaderRaw = B.ByteString 71 | 72 | leaderLength :: Int 73 | leaderLength = 24 74 | 75 | getLeader :: MarcRecordRaw -> MarcLeaderRaw 76 | getLeader record = B.take leaderLength record 77 | 78 | rawToInt :: B.ByteString -> Int 79 | rawToInt = (read . T.unpack . E.decodeUtf8) 80 | 81 | getRecordLength :: MarcLeaderRaw -> Int 82 | getRecordLength leader = rawToInt (B.take 5 leader) 83 | 84 | -- Get the next record and the rest of the file 85 | nextAndRest :: B.ByteString -> (MarcRecordRaw, B.ByteString) 86 | nextAndRest stream = B.splitAt (getRecordLength stream) stream 87 | 88 | allRecords :: B.ByteString -> [MarcRecordRaw] 89 | allRecords stream = if stream == B.empty then [] else next : allRecords rest 90 | where (next, rest) = nextAndRest stream 91 | 92 | -- 93 | 94 | type MarcDirectoryRaw = B.ByteString 95 | 96 | getBaseAddress :: MarcLeaderRaw -> Int 97 | getBaseAddress leader = rawToInt (B.take 5 (B.drop 12 leader)) 98 | 99 | getDirectoryLength :: MarcLeaderRaw -> Int 100 | getDirectoryLength leader = getBaseAddress leader - (leaderLength + 1) 101 | 102 | getDirectory :: MarcRecordRaw -> MarcDirectoryRaw 103 | getDirectory record = B.take directoryLength afterLeader 104 | where 105 | directoryLength = getDirectoryLength record 106 | afterLeader = B.drop leaderLength record 107 | 108 | -- 109 | 110 | type MarcDirectoryEntryRaw = B.ByteString 111 | 112 | dirEntryLength :: Int 113 | dirEntryLength = 12 114 | 115 | splitDirectory :: MarcDirectoryRaw -> [MarcDirectoryEntryRaw] 116 | splitDirectory directory = if directory == B.empty 117 | then [] 118 | else nextEntry : splitDirectory restEntries 119 | where (nextEntry, restEntries) = B.splitAt dirEntryLength directory 120 | 121 | -- 122 | 123 | data FieldMetadata = FieldMetadata 124 | { tag :: T.Text 125 | , fieldLength :: Int 126 | , fieldStart :: Int 127 | } deriving Show 128 | 129 | makeFieldMetadata :: MarcDirectoryEntryRaw -> FieldMetadata 130 | makeFieldMetadata entry = FieldMetadata textTag theLength theStart 131 | where 132 | (theTag, rest) = B.splitAt 3 entry 133 | textTag = E.decodeUtf8 theTag 134 | (rawLength, rawStart) = B.splitAt 4 rest 135 | theLength = rawToInt rawLength 136 | theStart = rawToInt rawStart 137 | 138 | getFieldMetadata :: [MarcDirectoryEntryRaw] -> [FieldMetadata] 139 | getFieldMetadata = map makeFieldMetadata 140 | 141 | -- 142 | 143 | type FieldText = T.Text 144 | 145 | getTextField :: MarcRecordRaw -> FieldMetadata -> FieldText 146 | getTextField record fieldMetadata = E.decodeUtf8 byteStringValue 147 | where 148 | recordLength = getRecordLength record 149 | baseAddress = getBaseAddress record 150 | baseRecord = B.drop baseAddress record 151 | baseAtEntry = B.drop (fieldStart fieldMetadata) baseRecord 152 | byteStringValue = B.take (fieldLength fieldMetadata) baseAtEntry 153 | 154 | fieldDelimiter :: Char 155 | fieldDelimiter = toEnum 31 156 | 157 | titleTag :: T.Text 158 | titleTag = "245" 159 | 160 | titleSubfield :: Char 161 | titleSubfield = 'a' 162 | 163 | authorTag :: T.Text 164 | authorTag = "100" 165 | 166 | authorSubfield :: Char 167 | authorSubfield = 'a' 168 | 169 | lookupFieldMetadata :: T.Text -> MarcRecordRaw -> Maybe FieldMetadata 170 | lookupFieldMetadata aTag record = if length results < 1 171 | then Nothing 172 | else Just (head results) 173 | where 174 | metadata = (getFieldMetadata . splitDirectory . getDirectory) record 175 | results = filter ((== aTag) . tag) metadata 176 | 177 | lookupSubfield :: (Maybe FieldMetadata) -> Char -> MarcRecordRaw -> Maybe T.Text 178 | lookupSubfield Nothing _ _ = Nothing 179 | lookupSubfield (Just fieldMetadata) subfield record = if results == [] 180 | then Nothing 181 | else Just ((T.drop 1 . head) results) 182 | where 183 | rawField = getTextField record fieldMetadata 184 | subfields = T.split (== fieldDelimiter) rawField 185 | results = filter ((== subfield) . T.head) subfields 186 | 187 | lookupValue :: T.Text -> Char -> MarcRecordRaw -> Maybe T.Text 188 | lookupValue aTag subfield record = lookupSubfield entryMetadata subfield record 189 | where entryMetadata = lookupFieldMetadata aTag record 190 | 191 | lookupTitle :: MarcRecordRaw -> Maybe Title 192 | lookupTitle = lookupValue titleTag titleSubfield 193 | 194 | lookupAuthor :: MarcRecordRaw -> Maybe Author 195 | lookupAuthor = lookupValue authorTag authorSubfield 196 | 197 | marcToPairs :: B.ByteString -> [(Maybe Title, Maybe Author)] 198 | marcToPairs marcStream = zip titles authors 199 | where 200 | records = allRecords marcStream 201 | titles = map lookupTitle records 202 | authors = map lookupAuthor records 203 | 204 | pairsToBooks :: [(Maybe Title, Maybe Author)] -> [Book] 205 | pairsToBooks pairs = map 206 | (\(title, author) -> Book {title = fromJust title, author = fromJust author}) 207 | justPairs 208 | where justPairs = filter (\(title, author) -> isJust title && isJust author) pairs 209 | 210 | processRecords :: Int -> B.ByteString -> Html 211 | processRecords n = booksToHtml . pairsToBooks . (take n) . marcToPairs 212 | -------------------------------------------------------------------------------- /Unit05/Lesson27.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | module Lesson27 where 4 | 5 | import qualified Data.Map as Map 6 | import Data.Maybe (fromJust, isJust) 7 | 8 | -- Consider this: 9 | 10 | printInt :: Maybe String -> IO () 11 | printInt Nothing = putStrLn "value missing" 12 | printInt (Just val) = putStrLn val 13 | 14 | -- How do we convert a Maybe Int to Maybe String to pass into this function? 15 | 16 | intToStr :: Int -> String 17 | intToStr x = show (x * x) ++ "!" 18 | 19 | -- The answer will be, use `Functor` (i.e. `fmap`) 20 | 21 | -- * An example: computing in a Maybe 22 | 23 | successfulRequest :: Maybe Int 24 | successfulRequest = Just 6 25 | 26 | failedRequest :: Maybe Int 27 | failedRequest = Nothing 28 | 29 | -- >>> incMaybe successfulRequest 30 | -- >>> incMaybe failedRequest 31 | -- Just 7 32 | -- Nothing 33 | incMaybe :: Maybe Int -> Maybe Int 34 | incMaybe Nothing = Nothing 35 | incMaybe (Just n) = Just (n + 1) 36 | 37 | -- QC1 38 | 39 | -- >>> reverseMaybe $ Just "hello" 40 | -- >>> reverseMaybe Nothing 41 | -- Just "olleh" 42 | -- Nothing 43 | reverseMaybe :: Maybe String -> Maybe String 44 | reverseMaybe Nothing = Nothing 45 | reverseMaybe (Just x) = Just (reverse x) 46 | 47 | -- * Using functions in context with the Functor type class 48 | 49 | {- 50 | fmap :: Functor g => (a -> b) -> g a -> g b 51 | -} 52 | 53 | {- 54 | instance Functor Maybe where 55 | fmap :: (a -> b) -> Maybe a -> Maybe b 56 | fmap func (Just n) = Just (func n) 57 | fmap func Nothing = Nothing 58 | -} 59 | 60 | -- Now we can do this, without having to create a wrapper function: 61 | 62 | e1 :: Maybe Int 63 | e1 = (+ 1) <$> successfulRequest -- Just 7 64 | 65 | e2 :: Maybe Int 66 | e2 = (+ 1) <$> failedRequest -- Nothing 67 | 68 | -- Maybe Int -> Maybe String 69 | 70 | successStr :: Maybe String 71 | successStr = show <$> successfulRequest -- Just "6" 72 | 73 | failStr :: Maybe String 74 | failStr = show <$> failedRequest -- Nothing 75 | 76 | -- QC2 77 | 78 | qc2 :: Maybe String 79 | qc2 = reverse <$> Just "hello" -- Just "olleh" 80 | 81 | -- ! An aside: Note that the name of <$> is modeled after $ - 82 | -- ! thus, you don't need parentheses around `Just "hello"` 83 | 84 | -- * Functors are everywhere! 85 | 86 | data RobotPart = RobotPart 87 | { name :: String, 88 | description :: String, 89 | cost :: Double, 90 | count :: Int 91 | } 92 | deriving (Show) 93 | 94 | leftArm :: RobotPart 95 | leftArm = 96 | RobotPart 97 | { name = "left arm", 98 | description = "left arm for face punching!", 99 | cost = 1000.00, 100 | count = 3 101 | } 102 | 103 | rightArm :: RobotPart 104 | rightArm = 105 | RobotPart 106 | { name = "right arm", 107 | description = "right arm for kind hand gestures", 108 | cost = 1025.00, 109 | count = 5 110 | } 111 | 112 | robotHead :: RobotPart 113 | robotHead = 114 | RobotPart 115 | { name = "robot head", 116 | description = "this head looks mad", 117 | cost = 5092.25, 118 | count = 2 119 | } 120 | 121 | type Html = String 122 | 123 | -- | Rendering a RobotPart as HTML 124 | renderHtml :: RobotPart -> Html 125 | renderHtml part = 126 | mconcat 127 | [ "

", 128 | partName, 129 | "

", 130 | "

desc

", 131 | partDesc, 132 | "

cost

", 133 | partCost, 134 | "

count

", 135 | partCount, 136 | "

" 137 | ] 138 | where 139 | partName = name part 140 | partDesc = description part 141 | partCost = show (cost part) 142 | partCount = show (count part) 143 | 144 | -- | RobotPart "database" 145 | partsDB :: Map.Map Int RobotPart 146 | partsDB = Map.fromList keyVals 147 | where 148 | keys = [1, 2, 3] 149 | vals = [leftArm, rightArm, robotHead] 150 | keyVals = zip keys vals 151 | 152 | -- * Converting a Maybe RobotPart to Maybe Html 153 | 154 | partVal :: Maybe RobotPart 155 | partVal = Map.lookup 1 partsDB 156 | -- ^ Just (RobotPart {name = "left arm", description = ...}) 157 | 158 | partVal' :: Maybe RobotPart 159 | partVal' = Map.lookup 999 partsDB 160 | -- ^ Nothing 161 | 162 | -- >>> renderHtml <$> partVal 163 | -- Just "

left arm

desc

left arm for face punching!

cost

1000.0

count

3

" 164 | partHtml :: Maybe Html 165 | partHtml = renderHtml <$> partVal 166 | 167 | -- * Converting a list of RobotParts to a list of Html 168 | 169 | allParts :: [RobotPart] 170 | allParts = map snd (Map.toList partsDB) 171 | 172 | allPartsHtml :: [Html] 173 | allPartsHtml = renderHtml <$> allParts -- same as `map renderHtml allParts` 174 | 175 | -- QC3 176 | 177 | allParts' :: [RobotPart] 178 | allParts' = snd <$> Map.toList partsDB 179 | 180 | -- * Converting a Map of RobotParts to a Map of HTML 181 | 182 | -- NOTE - Notice that only the 2nd type variable (the value) participates in the Functor! 183 | 184 | htmlPartsDB :: Map.Map Int Html 185 | htmlPartsDB = renderHtml <$> partsDB 186 | 187 | -- * Converting an IO RobotPart to an IO Html 188 | 189 | leftArmIO :: IO RobotPart 190 | leftArmIO = return leftArm 191 | 192 | htmlSnippet :: IO Html 193 | htmlSnippet = renderHtml <$> leftArmIO 194 | 195 | -- Q1 196 | 197 | newtype Box a = Box a deriving (Show) 198 | 199 | -- >>> (+ 1) <$> Box 2 200 | -- Box 3 201 | instance Functor Box where 202 | fmap :: (a -> b) -> Box a -> Box b 203 | fmap f (Box a) = Box (f a) 204 | 205 | -- >>> morePresents 5 (Box "toy") 206 | -- Box ["toy","toy","toy","toy","toy"] 207 | morePresents :: Int -> Box a -> Box [a] 208 | morePresents n box = replicate n <$> box 209 | 210 | -- Q2 211 | 212 | myBox :: Box Int 213 | myBox = Box 1 214 | 215 | wrapped :: Box (Box Int) 216 | wrapped = Box <$> myBox -- Box (Box 1) 217 | 218 | unwrap :: Box a -> a 219 | unwrap (Box x) = x 220 | 221 | unwrapped :: Box Int 222 | unwrapped = unwrap <$> wrapped -- Box 1 223 | 224 | -- Q3 225 | 226 | -- The answer in the book is very similar but avoids `fromJust` and the `if` 227 | -- statement. 228 | main :: IO () 229 | main = do 230 | putStr "ID? " 231 | input <- getLine 232 | let part = Map.lookup (read input) partsDB 233 | if isJust part 234 | then do 235 | putStr "Cost: " 236 | print (fromJust (cost <$> part)) 237 | else putStrLn "Not found." 238 | -------------------------------------------------------------------------------- /Unit05/Lesson28/Lesson28.hs: -------------------------------------------------------------------------------- 1 | module Lesson28 where 2 | 3 | -- 4 | -- A command-line application for calculating the distance between cities 5 | -- see dist.hs 6 | -- 7 | 8 | -- Using a multi-argument function in IO using <$> and <*> 9 | -- see min3.hs 10 | 11 | -- 12 | -- Using <*> to create data in a context 13 | -- 14 | 15 | data User = User 16 | { name :: String 17 | , gamerId :: Int 18 | , score :: Int 19 | } deriving (Show) 20 | 21 | -- Note the we can create a User with regular function syntax: 22 | {- 23 | sue -- User {name = "Sue", gamerId = 1337, score = 9001} 24 | -} 25 | sue :: User 26 | sue = User "Sue" 1337 9001 27 | 28 | -- Maybe context 29 | -- 30 | maybeUsername :: Maybe String 31 | maybeUsername = Just "Sue" 32 | 33 | maybeGamerId :: Maybe Int 34 | maybeGamerId = Just 1337 35 | 36 | maybeScore :: Maybe Int 37 | maybeScore = Just 9001 38 | 39 | {- 40 | maybeSue -- Just (User {name = "Sue", gamerId = 1337, score = 9001}) 41 | -} 42 | maybeSue :: Maybe User 43 | maybeSue = User <$> maybeUsername <*> maybeGamerId <*> maybeScore 44 | 45 | -- IO context 46 | -- 47 | readInt :: IO Int 48 | readInt = read <$> getLine 49 | 50 | main :: IO () 51 | main = do 52 | putStrLn "Enter a username, gamerId and score, with ENTER after each:" 53 | user <- User <$> getLine <*> readInt <*> readInt 54 | print user 55 | 56 | -- QC5 57 | 58 | userMissingName :: Maybe User 59 | userMissingName = User <$> Nothing <*> Just 2001 <*> Just 0 -- Nothing 60 | 61 | -- 62 | -- Summary 63 | -- 64 | 65 | -- Q1, 02 66 | -- see dist.hs 67 | 68 | -- Q3 69 | -- see robots.hs 70 | -------------------------------------------------------------------------------- /Unit05/Lesson28/dist.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Map as Map 2 | 3 | -- * A command-line application for calculating the distance between cities 4 | 5 | type LatLong = (Double, Double) 6 | 7 | -- | The database 8 | locationDB :: Map.Map String LatLong 9 | locationDB = 10 | Map.fromList 11 | [ ("Arkham", (42.6054, -70.7829)), 12 | ("Innsmouth", (42.8250, -70.8150)), 13 | ("Carcosa", (29.9714, -90.7694)), 14 | ("New York", (40.7776, -73.9691)) 15 | ] 16 | 17 | -- * Computing the distance between two points with haversine 18 | 19 | toRadians :: Double -> Double 20 | toRadians degrees = degrees * pi / 180 21 | 22 | latLongToRads :: LatLong -> (Double, Double) 23 | latLongToRads (lat, long) = (toRadians lat, toRadians long) 24 | 25 | -- | Calculates the distance between two LatLongs on a sphere. 26 | -- >>> haversine (40.7776,-73.9691) (42.6054,-70.7829) 27 | -- 207.3909006336738 28 | haversine :: LatLong -> LatLong -> Double 29 | haversine coords1 coords2 = earthRadius * c 30 | where 31 | (rlat1, rlong1) = latLongToRads coords1 32 | (rlat2, rlong2) = latLongToRads coords2 33 | dlat = rlat2 - rlat1 34 | dlong = rlong2 - rlong1 35 | a = sin (dlat / 2) ^ (2 :: Int) + cos rlat1 * cos rlat2 * sin (dlong / 2) ^ (2 :: Int) 36 | c = 2 * atan2 (sqrt a) (sqrt (1 - a)) 37 | earthRadius = 3961.0 38 | 39 | -- | Prints a (potentially missing) distance. 40 | printDistance :: Maybe Double -> IO () 41 | printDistance Nothing = putStrLn "City not found." 42 | printDistance (Just distance) = putStrLn (show distance ++ " miles") 43 | 44 | -- We don't want to have to create a wrapper specialized for a single type: 45 | haversineMaybe :: Maybe LatLong -> Maybe LatLong -> Maybe Double 46 | haversineMaybe Nothing _ = Nothing 47 | haversineMaybe _ Nothing = Nothing 48 | haversineMaybe (Just val1) (Just val2) = Just (haversine val1 val2) 49 | 50 | -- QC1 51 | 52 | addMaybe :: Maybe Int -> Maybe Int -> Maybe Int 53 | addMaybe (Just x) (Just y) = Just (x + y) 54 | addMaybe _ _ = Nothing 55 | 56 | -- QC2 57 | 58 | distanceFromNY :: LatLong -> Double 59 | distanceFromNY = haversine (40.7776, -73.9691) 60 | 61 | -- 62 | -- Using <*> for partial application in a context 63 | -- 64 | 65 | -- Using Functor’s <$> operator for partial application in a context 66 | -- --> But this function can't be applied directly 67 | maybeInc :: Maybe (Integer -> Integer) 68 | maybeInc = (+) <$> Just 1 69 | 70 | -- Applicative to the rescue 71 | {- 72 | (<*>) :: Applicative f => f (a -> b) -> f a -> f b 73 | -- Just like fmap except the fuction is in a context too 74 | -} 75 | 76 | -- Examples: 77 | {- 78 | maybeInc <*> Just 4 -- Just 5 79 | (+) <$> Just 1 <*> Just 4 -- Just 5 80 | maybeInc <*> Nothing -- Nothing 81 | (++) <$> Just "cats" <*> Just " and dogs" -- Just "cats and dogs" 82 | (++) <$> Nothing <*> Just " and dogs" -- Nothing 83 | (++) <$> Just "cats" <*> Nothing -- Nothing 84 | -} 85 | 86 | -- QC3 87 | 88 | val1 :: Maybe Int 89 | val1 = Just 10 90 | 91 | val2 :: Maybe Int 92 | val2 = Just 5 93 | 94 | qc3_1 :: Maybe Int 95 | qc3_1 = (*) <$> val1 <*> val2 -- Just 50 96 | 97 | qc3_2 :: Maybe Int 98 | qc3_2 = div <$> val1 <*> val2 -- Just 2 99 | 100 | qc3_3 :: Maybe Int 101 | qc3_3 = mod <$> val1 <*> val2 -- Just 0 102 | 103 | -- Using <*> to finish your city distance program 104 | 105 | start :: Maybe LatLong 106 | start = Map.lookup "Carcosa" locationDB 107 | 108 | dest :: Maybe LatLong 109 | dest = Map.lookup "Innsmouth" locationDB 110 | 111 | dist :: Maybe Double 112 | -- partial application 113 | -- vvvvvvvvvvvvvvvvvvv 114 | dist = haversine <$> start <*> dest 115 | 116 | -- ^^^^^^^^^^^^^^ 117 | -- allows completion in context 118 | 119 | -- 120 | 121 | main :: IO () 122 | main = do 123 | putStr "Starting city? " 124 | startCity <- getLine 125 | let startLatLong = Map.lookup startCity locationDB 126 | putStr "Destination city? " 127 | destCity <- getLine 128 | let destLatLong = Map.lookup destCity locationDB 129 | let distance = haversine <$> startLatLong <*> destLatLong 130 | printDistance distance 131 | 132 | -- Q1 133 | 134 | haversineIO' :: IO LatLong -> IO LatLong -> IO Double 135 | haversineIO' val1 val2 = do 136 | v1 <- val1 137 | v2 <- val2 138 | let result = haversine v1 v2 139 | return result 140 | 141 | -- Q2 142 | 143 | haversineIO :: IO LatLong -> IO LatLong -> IO Double 144 | haversineIO val1 val2 = haversine <$> val1 <*> val2 145 | -------------------------------------------------------------------------------- /Unit05/Lesson28/min3.hs: -------------------------------------------------------------------------------- 1 | module Unit06.Lesson28.Min3 where 2 | 3 | minOfThree :: (Ord a) => a -> a -> a -> a 4 | minOfThree x y z = minimum [x, y, z] 5 | 6 | readInt :: IO Int 7 | readInt = read <$> getLine 8 | 9 | minOfThreeInts :: IO Int 10 | minOfThreeInts = minOfThree <$> readInt <*> readInt <*> readInt 11 | 12 | main :: IO () 13 | main = do 14 | putStrLn "Enter three numbers, separated by ENTER." 15 | n <- minOfThreeInts 16 | putStrLn (show n ++ " is the smallest.") 17 | 18 | -- QC4 19 | 20 | minOfThreeMaybeInts :: Maybe Int 21 | minOfThreeMaybeInts = minOfThree <$> Just 10 <*> Just 3 <*> Just 6 -- Just 3 22 | -------------------------------------------------------------------------------- /Unit05/Lesson28/robots.hs: -------------------------------------------------------------------------------- 1 | module Robots where 2 | 3 | import qualified Data.Map as Map 4 | 5 | data RobotPart = RobotPart 6 | { name :: String 7 | , description :: String 8 | , cost :: Double 9 | , count :: Int 10 | } deriving (Show) 11 | 12 | leftArm = RobotPart "left arm" "left arm for face punching!" 1000.0 3 13 | 14 | rightArm = RobotPart "right arm" "right arm for kind hand gestures" 1025.0 5 15 | 16 | robotHead = RobotPart "robot head" "this head looks mad" 5092.25 2 17 | 18 | leftLeg = RobotPart "left leg" "left leg for kicking!" 1225.5 3 19 | 20 | rightLeg = RobotPart "right leg" "right leg for dancing" 1119.99 2 21 | 22 | partsDB :: Map.Map Int RobotPart 23 | partsDB = Map.fromList keyVals 24 | where 25 | keys = [1, 2, 3, 4, 5] 26 | vals = [leftArm, rightArm, robotHead, leftLeg, rightLeg] 27 | keyVals = zip keys vals 28 | 29 | getLowerCost :: Maybe RobotPart -> Maybe RobotPart -> Maybe Double 30 | getLowerCost p1 p2 = min <$> (cost <$> p1) <*> (cost <$> p2) 31 | 32 | {- 33 | (RobotPart -> Double) 34 | vvvv 35 | cost <$> p1 -> Maybe Double 36 | ^^ 37 | Maybe RobotPart 38 | -} 39 | 40 | printLowerCost :: Maybe Double -> IO () 41 | printLowerCost Nothing = putStrLn "At least one part not found." 42 | printLowerCost (Just cost) = putStrLn (show cost ++ " is lower cost.") 43 | 44 | main :: IO () 45 | main = do 46 | putStr "ID 1? " 47 | input1 <- getLine 48 | let part1 = Map.lookup (read input1) partsDB 49 | putStr "ID 2? " 50 | input2 <- getLine 51 | let part2 = Map.lookup (read input2) partsDB 52 | let lower = getLowerCost part1 part2 53 | printLowerCost lower 54 | -------------------------------------------------------------------------------- /Unit05/Lesson29.hs: -------------------------------------------------------------------------------- 1 | module Lesson29 where 2 | 3 | {- 4 | class Functor f where 5 | fmap :: (a -> b) -> f a -> f b -- or <$> 6 | 7 | class Functor f => Applicative f where 8 | <*> :: f (a -> b) -> f a -> f b 9 | pure :: a -> f a 10 | -} 11 | 12 | -- QC1 13 | 14 | qc1 :: Maybe String 15 | qc1 = (++) <$> Just "hello, " <*> Just "world!" -- == Just "hello, world!" 16 | 17 | -- QC2 18 | 19 | qc2 :: IO String 20 | qc2 = pure "Hello World!" 21 | 22 | -- QC3 23 | 24 | -- (pure +) <*> (1,2) <*> (3,4) 25 | -- It doesn't work because (,) is not an instance of Applicative. 26 | 27 | -- 28 | -- List as a context 29 | -- 30 | 31 | ex1 :: [Int] 32 | ex1 = pure (+) <*> [1000, 2000, 3000] <*> [500, 20000] 33 | -- [1500,21000,2500,22000,3500,23000] i.e. all possible sums 34 | 35 | -- A game show example 36 | 37 | doorPrize :: [Int] 38 | doorPrize = [1000, 2000, 3000] 39 | 40 | boxPrize :: [Int] 41 | boxPrize = [500, 20000] 42 | 43 | -- Deterministic - obviously, this won't compile: 44 | -- totalPrize = (+) doorPrize boxPrize 45 | 46 | -- Non-deterministic: 47 | totalPrize :: [Int] 48 | totalPrize = pure (+) <*> doorPrize <*> boxPrize 49 | 50 | totalPrize' = (+) <$> doorPrize <*> boxPrize -- same as above 51 | 52 | -- QC4 53 | 54 | qc4 :: [Int] 55 | qc4 = pure (*) <*> doorPrize <*> [10, 50] -- [10000,50000,20000,100000,30000,150000] 56 | 57 | -- Generating the first N prime numbers 58 | 59 | -- Composites are easy to generate with Applicative: 60 | someComposites :: [Int] 61 | someComposites = (*) <$> [2 .. 4] <*> [2 .. 4] -- [4,6,8,6,9,12,8,12,16] 62 | 63 | -- Simple, if inefficient, prime number generator 64 | {- 65 | primesToN 32 -- [2,3,5,7,11,13,17,19,23,29,31] 66 | primesToN 1000 -- (slow!) 67 | -} 68 | primesToN :: Integer -> [Integer] 69 | primesToN n = filter notComposite twoToN 70 | where 71 | twoToN = [2 .. n] 72 | composite = (*) <$> twoToN <*> twoToN 73 | notComposite = not . (`elem` composite) 74 | 75 | -- Quickly generating large amounts of test data 76 | 77 | data User = User 78 | { name :: String 79 | , gamerID :: Int 80 | , score :: Int 81 | } deriving (Show) 82 | 83 | testNames :: [String] 84 | testNames = 85 | ["John Smith", "Robert'); DROP TABLE Students;--", "Christina NULL", "Randall Munroe"] 86 | 87 | testIDs :: [Int] 88 | testIDs = [1337, 0123, 999999] 89 | 90 | testScores :: [Int] 91 | testScores = [0, 100000, -99999] 92 | 93 | {- 94 | length testData -- 36 95 | -} 96 | testData :: [User] 97 | testData = pure User <*> testNames <*> testIDs <*> testScores 98 | 99 | -- QC5 100 | 101 | testNames' :: [String] 102 | testNames' = "Rhywun" : testNames 103 | 104 | {- 105 | length testData' -- 45 106 | -} 107 | testData' :: [User] 108 | testData' = pure User <*> testNames' <*> testIDs <*> testScores 109 | 110 | -- Q1 111 | 112 | {- 113 | allFmap (+ 1) [1,2,3] -- [2,3,4] 114 | allFmap (+ 1) (Just 5) -- Just 6 115 | allFmap (+ 1) Nothing -- Nothing 116 | -} 117 | allFmap :: Applicative f => (a -> b) -> f a -> f b 118 | allFmap f x = pure f <*> x 119 | 120 | -- Q2 121 | 122 | example :: Int 123 | example = (*) ((+) 2 4) 5 -- 30 124 | 125 | exampleMaybe :: Maybe Int 126 | exampleMaybe = pure (*) <*> pure ((+) 2 4) <*> pure 5 -- Just 30 127 | 128 | -- Q3 129 | 130 | bought :: [Int] 131 | bought = [6, 12] 132 | 133 | drank :: [Int] 134 | drank = [-4] 135 | 136 | peeps :: [Int] 137 | peeps = [3, 5] 138 | 139 | perPeep :: [Int] 140 | perPeep = [3, 4] 141 | 142 | -- subtract (peeps * perPeep) from bought + drank, answer is the max num of beers 143 | q3 :: [Int] 144 | q3 = pure (-) <*> (pure (+) <*> bought <*> drank) <*> (pure (*) <*> peeps <*> perPeep) 145 | 146 | -- q3 == [-7,-10,-13,-18,-1,-4,-7,-12] 147 | -- ^^^ 148 | -- Therefore, you'll need to buy 18 beers. 149 | 150 | -- Solution: 151 | 152 | startingBeer :: [Int] 153 | startingBeer = [6, 12] 154 | 155 | remainingBeer :: [Int] 156 | remainingBeer = (\count -> count - 4) <$> startingBeer 157 | 158 | guests :: [Int] 159 | guests = [2, 3] 160 | 161 | totalPeople :: [Int] 162 | totalPeople = (+ 2) <$> guests 163 | 164 | beersPerGuest :: [Int] 165 | beersPerGuest = [3, 4] 166 | 167 | totalBeersNeeded :: [Int] 168 | totalBeersNeeded = pure (*) <*> beersPerGuest <*> totalPeople 169 | 170 | beersToPurchase :: [Int] 171 | beersToPurchase = pure (-) <*> totalBeersNeeded <*> remainingBeer 172 | 173 | -- ==> 18 174 | -------------------------------------------------------------------------------- /Unit05/Lesson32.hs: -------------------------------------------------------------------------------- 1 | module Lesson32 where 2 | 3 | import Control.Monad 4 | import Data.Char 5 | 6 | -- Consider this: 7 | 8 | ct1 = [ x ^ 2 | x <- [1 .. 19], x `mod` 2 == 1 ] -- [1,9,25,49,81,121,169,225,289,361] 9 | 10 | -- 11 | -- Building lists with the list monad 12 | -- 13 | 14 | {- 15 | powersOfTwo 10 -- [2,4,8,16,32,64,128,256,512,1024] 16 | -} 17 | powersOfTwo :: Int -> [Int] 18 | powersOfTwo n = do 19 | n' <- [1 .. n] 20 | return (2 ^ n') 21 | 22 | -- It may be easier to read with `map`: 23 | 24 | powersOfTwoMap :: Int -> [Int] 25 | powersOfTwoMap n = map (\x -> 2 ^ x) [1 .. n] 26 | 27 | -- But not necessarily when it starts to get more complicated: 28 | 29 | {- 30 | powersOfTwoAndThree 5 -- [(2,3),(4,9),(8,27),(16,81),(32,243)] 31 | -} 32 | powersOfTwoAndThree :: Int -> [(Int, Int)] 33 | powersOfTwoAndThree n = do 34 | n' <- [1 .. n] 35 | let powersOfTwo = 2 ^ n' 36 | let powersOfThree = 3 ^ n' 37 | return (powersOfTwo, powersOfThree) 38 | 39 | -- Notice with two lists we get all possible combinations: 40 | 41 | {- 42 | allEvenOdds 5 -- [(2,1),(2,3),(2,5),(4,1),(4,3),(4,5)] 43 | -} 44 | allEvenOdds :: Int -> [(Int, Int)] 45 | allEvenOdds n = do 46 | evenN <- [2, 4 .. n] 47 | oddN <- [1, 3 .. n] 48 | return (evenN, oddN) 49 | 50 | -- QC1 51 | 52 | {- 53 | pairsOfSquares 10 -- [(1,1),(2,4),(3,9),(4,16),...,(10,100)] 54 | -} 55 | pairsOfSquares :: Int -> [(Int, Int)] 56 | pairsOfSquares n = do 57 | n' <- [1 .. n] 58 | return (n', n' ^ (2 :: Int)) 59 | 60 | -- The `guard` function for filtering: 61 | 62 | evensGuard :: Int -> [Int] 63 | evensGuard n = do 64 | value <- [1 .. n] 65 | guard (even value) 66 | return value 67 | 68 | -- QC2 69 | 70 | filter' :: (a -> Bool) -> [a] -> [a] 71 | filter' p xs = do 72 | x <- xs 73 | guard (p x) 74 | return x 75 | 76 | qc2 :: [Int] 77 | qc2 = filter' (> 2) [1, 2, 3, 4, 5] -- [3,4,5] 78 | 79 | -- 80 | -- List comprehensions 81 | -- 82 | 83 | -- Before: 84 | evenSquares :: [Int] 85 | evenSquares = do 86 | n <- [0 .. 9] 87 | let nSquared = n ^ (2 :: Int) 88 | guard (even nSquared) 89 | return nSquared 90 | 91 | -- After: 92 | evenSquares' :: [Int] 93 | evenSquares' = 94 | [ nSquared | n <- [0 .. 9], let nSquared = n ^ (2 :: Int), even nSquared ] 95 | 96 | -- More examples: 97 | 98 | powersOfTwo' :: Int -> [Int] 99 | powersOfTwo' n = [ n' ^ (2 :: Int) | n' <- [1 .. n] ] 100 | 101 | powersOfTwoAndThree' :: Int -> [(Int, Int)] 102 | powersOfTwoAndThree' n = 103 | [ (po2, po3) | n' <- [1 .. n], let po2 = 2 ^ n', let po3 = 3 ^ n' ] 104 | 105 | allEvenOdds' :: Int -> [(Int, Int)] 106 | allEvenOdds' n = [ (e, o) | e <- [2, 4 .. n], o <- [1, 3 .. n] ] 107 | 108 | evensGuard' :: Int -> [Int] 109 | evensGuard' n = [ value | value <- [1 .. n], even value ] 110 | 111 | -- QC3 112 | 113 | qc3 :: [String] 114 | qc3 = 115 | [ "Mr. " ++ uColor 116 | | color <- ["brown", "blue", "pink", "orange"] 117 | , let uColor = toUpper (head color) : tail color 118 | ] -- ["Mr. Brown","Mr. Blue","Mr. Pink","Mr. Orange"] 119 | 120 | -- Q1 121 | 122 | q1 :: [[Int]] 123 | q1 = [ [1 .. n] | n <- [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] ] 124 | 125 | -- Q2 126 | 127 | q2 :: [[Int]] 128 | q2 = do 129 | n <- [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] 130 | return [1 .. n] 131 | 132 | q2' :: [[Int]] 133 | q2' = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] >>= (\n -> return [1 .. n]) 134 | 135 | -- The book has this: 136 | 137 | monthEnds :: [Int] 138 | monthEnds = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] 139 | 140 | dates :: [Int] -> [Int] 141 | dates ends = [ date | end <- ends, date <- [1 .. end] ] 142 | 143 | datesDo :: [Int] -> [Int] 144 | datesDo ends = do 145 | end <- ends 146 | date <- [1 .. end] 147 | return date 148 | 149 | datesMonad :: [Int] -> [Int] 150 | -- datesMonad ends = ends >>= (\end -> [1 .. end] >>= (\date -> return date)) 151 | datesMonad ends = ends >>= (\end -> [1 .. end]) -- <-- From hlint 152 | -------------------------------------------------------------------------------- /Unit05/Lesson33.hs: -------------------------------------------------------------------------------- 1 | module Lesson33 where 2 | 3 | import Control.Applicative 4 | import Control.Monad 5 | 6 | -- 7 | -- Getting started 8 | -- 9 | 10 | data Name = Name 11 | { firstName :: String 12 | , lastName :: String 13 | } 14 | 15 | instance Show Name where 16 | show (Name fn ln) = mconcat [fn, " ", ln] 17 | 18 | data GradeLevel = Freshman | Sophmore | Junior | Senior deriving (Eq, Ord, Enum, Show) 19 | 20 | data Student = Student 21 | { studentId :: Int 22 | , gradeLevel :: GradeLevel 23 | , studentName :: Name 24 | } deriving (Show) 25 | 26 | students :: [Student] 27 | students = 28 | [ Student 1 Senior (Name "Audre" "Lorde") 29 | , Student 2 Junior (Name "Leslie" "Silko") 30 | , Student 3 Freshman (Name "Judith" "Butler") 31 | , Student 4 Senior (Name "Guy" "Debord") 32 | , Student 5 Sophmore (Name "Jean" "Baudrillard") 33 | , Student 6 Junior (Name "Julia" "Kristeva") 34 | ] 35 | 36 | -- 37 | -- SELECT 38 | -- 39 | 40 | -- Notice the signature is the same as for `fmap` except specialized to Monad 41 | 42 | {- 43 | _select gradeLevel students 44 | _select (firstName . studentName) students 45 | _select (\x -> (studentName x, gradeLevel x)) students 46 | -} 47 | _select :: Monad m => (a -> b) -> m a -> m b 48 | _select f xs = f <$> xs 49 | 50 | -- 51 | -- WHERE 52 | -- 53 | 54 | {- 55 | _where (\x -> gradeLevel x == Senior) students 56 | _where (startsWith 'J' . firstName . studentName) students 57 | _where (startsWith 'J' . firstName) (_select studentName students) 58 | -} 59 | _where :: (Monad m, Alternative m) => (a -> Bool) -> m a -> m a 60 | _where p xs = do 61 | x <- xs 62 | guard (p x) 63 | return x 64 | 65 | -- Or: 66 | _where' p xs = xs >>= (\x -> guard (p x) >> return x) 67 | 68 | startsWith :: Char -> String -> Bool 69 | startsWith char string = char == head string 70 | 71 | -- == [Judith Butler,Jean Baudrillard,Julia Kristeva] 72 | js = _where (startsWith 'J' . firstName) (_select studentName students) 73 | 74 | -- 75 | -- JOIN 76 | -- 77 | 78 | data Teacher = Teacher 79 | { teacherId :: Int 80 | , teacherName :: Name 81 | } deriving (Show) 82 | 83 | teachers = 84 | [Teacher 100 (Name "Simone" "De Beauvior"), Teacher 200 (Name "Susan" "Sontag")] 85 | 86 | data Course = Course 87 | { courseId :: Int 88 | , courseTitle :: String 89 | , courseTeacherId :: Int 90 | } deriving (Show) 91 | 92 | courses = [Course 101 "French" 100, Course 201 "English" 200] 93 | 94 | {- 95 | _join teachers courses teacherId courseTeacher 96 | -} 97 | _join :: (Monad m, Alternative m, Eq c) => m a -> m b -> (a -> c) -> (b -> c) -> m (a, b) 98 | _join data1 data2 prop1 prop2 = do 99 | d1 <- data1 100 | d2 <- data2 101 | let dpairs = (d1, d2) 102 | guard (prop1 (fst dpairs) == prop2 (snd dpairs)) 103 | return dpairs 104 | 105 | -- No idea what to do here to desugar: 106 | {- 107 | _join' data1 data2 prop1 prop2 = 108 | data1 >>= (\d1 -> data2 >>= (\d2 -> let dpairs = (d1, d2)) >> 109 | guard (prop1 (fst dpairs) == prop2 (snd dpairs)) >> return dpairs) 110 | -} 111 | 112 | -- 113 | -- Building your HINQ interface and example queries 114 | -- 115 | 116 | -- How to pleasantly combine these? 117 | 118 | joinData = _join teachers courses teacherId courseTeacherId 119 | 120 | whereResult = _where ((== "English") . courseTitle . snd) joinData 121 | 122 | selectResult = _select (teacherName . fst) whereResult -- == [Susan Sontag] 123 | 124 | -- Here's one way: 125 | _hinq selectQuery joinQuery whereQuery = (selectQuery . whereQuery) joinQuery 126 | 127 | finalResult = _hinq (_select (teacherName . fst)) 128 | (_join teachers courses teacherId courseTeacherId) 129 | (_where ((== "English") . courseTitle . snd)) 130 | 131 | -- What if we don't need a WHERE clause? 132 | teacherFirstName = _hinq (_select firstName) finalResult (_where (const True)) 133 | -- We can do better 134 | 135 | -- 136 | -- Making a HINQ type for your queries 137 | -- 138 | 139 | -- First, note the change to monoidal type signatures above 140 | -- on _select, _where, and _join 141 | 142 | data HINQ m a b 143 | = HINQ (m a -> m b) -- _select 144 | (m a) -- _join or data 145 | (m a -> m a) -- _where 146 | | HINQ_ (m a -> m b) -- _select 147 | (m a) -- _join or data 148 | 149 | runHINQ :: (Monad m, Alternative m) => HINQ m a b -> m b 150 | runHINQ (HINQ sClause jClause wClause) = _hinq sClause jClause wClause 151 | runHINQ (HINQ_ sClause jClause ) = _hinq sClause jClause (_where (const True)) 152 | 153 | -- 154 | -- Running your HINQ queries 155 | -- 156 | 157 | -- E.g. runHINQ query1 == [Susan Sontag] 158 | query1 :: HINQ [] (Teacher, Course) Name 159 | query1 = HINQ (_select (teacherName . fst)) 160 | (_join teachers courses teacherId courseTeacherId) 161 | (_where ((== "English") . courseTitle . snd)) 162 | 163 | -- E.g. runHINQ query2 == [Simone De Beauvior,Susan Sontag] 164 | query2 :: HINQ [] Teacher Name 165 | query2 = HINQ_ (_select teacherName) teachers 166 | 167 | -- HINQ with Maybe types 168 | 169 | possibleTeacher :: Maybe Teacher 170 | possibleTeacher = Just (head teachers) 171 | 172 | possibleCourse :: Maybe Course 173 | possibleCourse = Just (head courses) 174 | 175 | -- E.g. runHINQ maybeQuery1 == Just Simone De Beauvior 176 | maybeQuery1 :: HINQ Maybe (Teacher, Course) Name 177 | maybeQuery1 = HINQ (_select (teacherName . fst)) 178 | (_join possibleTeacher possibleCourse teacherId courseTeacherId) 179 | (_where ((== "French") . courseTitle . snd)) 180 | 181 | missingCourse :: Maybe Course 182 | missingCourse = Nothing 183 | 184 | -- E.g. runHINQ maybeQuery2 == Nothing 185 | maybeQuery2 :: HINQ Maybe (Teacher, Course) Name 186 | maybeQuery2 = HINQ (_select (teacherName . fst)) 187 | (_join possibleTeacher missingCourse teacherId courseTeacherId) 188 | (_where ((== "French") . courseTitle . snd)) 189 | 190 | -- Enough! 191 | -------------------------------------------------------------------------------- /Unit05/Unit05.hs: -------------------------------------------------------------------------------- 1 | module Unit05 where 2 | 3 | halve :: Int -> Double 4 | halve n = fromIntegral n / 2.0 5 | 6 | -- Given the tools we have so far, we need to write a wrapper in order to 7 | -- work in a context: 8 | 9 | -- >>> halveMaybe (Just 5) 10 | -- Just 2.5 11 | halveMaybe :: Maybe Int -> Maybe Double 12 | halveMaybe (Just n) = Just (halve n) 13 | halveMaybe Nothing = Nothing 14 | 15 | -- But now we have to write a lot of wrappers. 16 | -- And still there is no way to write a wrapper for IO. 17 | 18 | -- Thus: functors, applicatives, and monads. 19 | 20 | -- Sneak peek at functor: 21 | 22 | -- >>> fmap halve (Just 5) 23 | -- Just 2.5 24 | -------------------------------------------------------------------------------- /Unit06/Lesson34/Lesson34.hs: -------------------------------------------------------------------------------- 1 | module Lesson34 where 2 | 3 | -- 4 | -- Consider this 5 | -- 6 | 7 | -- Put Book and Magazine in separate files/modules, then use import qualified to 8 | -- import them into your main file, e.g.: 9 | {- 10 | import qualified Book as B 11 | import qualified Magazine as M 12 | -} 13 | 14 | -- 15 | 16 | {- 17 | head :: [a] -> a 18 | head (x:_) = x 19 | head [] = errorEmptyList "head" 20 | -} 21 | 22 | example :: [[Int]] 23 | example = [] 24 | 25 | -- Oops - `head` is already defined in Prelude, but we can still call it like this: 26 | {- 27 | Lesson34.head example -- [] 28 | -} 29 | head :: Monoid a => [a] -> a 30 | head (x:_) = x 31 | head [] = mempty 32 | 33 | -- QC1 34 | 35 | length :: Int 36 | length = 8 37 | 38 | qc1 :: Int 39 | qc1 = Lesson34.length * 2 -- 16 40 | 41 | -- 42 | -- Building a multifile program with modules 43 | -- Q1 44 | -- see Main.hs and Palindrome.hs 45 | -- 46 | -- Q2 47 | -- skip -- 48 | -------------------------------------------------------------------------------- /Unit06/Lesson34/Main: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Rhywun/get-programming-with-haskell/4f57ac35cb425c48f3976ebd81d4ac0174c6d352/Unit06/Lesson34/Main -------------------------------------------------------------------------------- /Unit06/Lesson34/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Data.Text.IO as TIO 6 | ( getLine 7 | , putStr 8 | , putStrLn 9 | ) 10 | import System.IO 11 | 12 | -- Unfortunately, HIE doesn't work without a cabal file, so we lose editor 13 | -- supprt here... but it does compile fine with ghc on the command line 14 | import qualified Palindrome 15 | 16 | main :: IO () 17 | main = do 18 | hSetBuffering stdout NoBuffering 19 | TIO.putStr "Word? " 20 | text <- TIO.getLine 21 | let response = if Palindrome.isPalindrome text 22 | then "It's a palindrome!" 23 | else "Not a palidrome :(" 24 | TIO.putStrLn response 25 | -------------------------------------------------------------------------------- /Unit06/Lesson34/Palindrome.hs: -------------------------------------------------------------------------------- 1 | module Palindrome 2 | ( isPalindrome 3 | ) 4 | where 5 | 6 | import Data.Char ( isPunctuation 7 | , isSpace 8 | ) 9 | import Data.Text as T 10 | ( Text 11 | , filter 12 | , toLower 13 | , reverse 14 | ) 15 | 16 | stripWhiteSpace :: Text -> Text 17 | stripWhiteSpace = T.filter (not . isSpace) 18 | 19 | stripPunctuation :: Text -> Text 20 | stripPunctuation = T.filter (not . isPunctuation) 21 | 22 | toLowerCase :: Text -> Text 23 | toLowerCase = T.toLower 24 | 25 | preprocess :: Text -> Text 26 | preprocess = stripWhiteSpace . stripPunctuation . toLowerCase 27 | 28 | isPalindrome :: Text -> Bool 29 | isPalindrome text = cleanText == T.reverse cleanText where cleanText = preprocess text 30 | -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | palindrome-checker.cabal 3 | *~ -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for palindrome-checker 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Patrick Huffer (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Patrick Huffer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/README.md: -------------------------------------------------------------------------------- 1 | # palindrome-checker 2 | -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | import Data.Text as T 5 | import Data.Text.IO as TIO 6 | import System.IO 7 | 8 | main :: IO () 9 | main = do 10 | hSetBuffering stdout NoBuffering 11 | TIO.putStr "Text? " 12 | text <- TIO.getLine 13 | let response = if isPalindrome text then "Palindrome!" else "No palindrome :(" 14 | TIO.putStrLn response 15 | -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/package.yaml: -------------------------------------------------------------------------------- 1 | name: palindrome-checker 2 | version: 0.1.0.0 3 | github: "Rhywun/palindrome-checker" 4 | license: BSD3 5 | author: "Patrick Huffer" 6 | maintainer: "rhywun@rhywun.com" 7 | copyright: "Patrick Huffer" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | executables: 29 | palindrome-checker-exe: 30 | main: Main.hs 31 | source-dirs: app 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - palindrome-checker 38 | 39 | tests: 40 | palindrome-checker-test: 41 | main: Spec.hs 42 | source-dirs: test 43 | ghc-options: 44 | - -threaded 45 | - -rtsopts 46 | - -with-rtsopts=-N 47 | dependencies: 48 | - palindrome-checker 49 | -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/palindrome-checker.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.28.2. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: 7061c767064ce034770fcb6220dde2d4066d6688ab6bc341f49e11c535d99be7 6 | 7 | name: palindrome-checker 8 | version: 0.1.0.0 9 | description: 10 | Please see the README on GitHub at 11 | 12 | homepage: https://github.com/Rhywun/palindrome-checker#readme 13 | bug-reports: https://github.com/Rhywun/palindrome-checker/issues 14 | author: Patrick Huffer 15 | maintainer: rhywun@rhywun.com 16 | copyright: Patrick Huffer 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | cabal-version: >= 1.10 21 | extra-source-files: 22 | ChangeLog.md 23 | README.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/Rhywun/palindrome-checker 28 | 29 | library 30 | exposed-modules: 31 | Lib 32 | other-modules: 33 | Paths_palindrome_checker 34 | hs-source-dirs: 35 | src 36 | build-depends: 37 | base >=4.7 && <5 38 | , text 39 | default-language: Haskell2010 40 | extensions: OverloadedStrings 41 | 42 | executable palindrome-checker-exe 43 | main-is: Main.hs 44 | other-modules: 45 | Paths_palindrome_checker 46 | hs-source-dirs: 47 | app 48 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 49 | build-depends: 50 | base >=4.7 && <5 51 | , palindrome-checker 52 | , text 53 | default-language: Haskell2010 54 | extensions: OverloadedStrings 55 | 56 | test-suite palindrome-checker-test 57 | type: exitcode-stdio-1.0 58 | main-is: Spec.hs 59 | other-modules: 60 | Paths_palindrome_checker 61 | hs-source-dirs: 62 | test 63 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 64 | build-depends: 65 | base >=4.7 && <5 66 | , palindrome-checker 67 | default-language: Haskell2010 68 | -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( isPalindrome 3 | ) 4 | where 5 | 6 | import qualified Data.Text as T 7 | import Data.Char ( toLower 8 | , isSpace 9 | , isPunctuation 10 | ) 11 | 12 | stripWhiteSpace :: T.Text -> T.Text 13 | stripWhiteSpace = T.filter (not . isSpace) 14 | 15 | stripPunctuation :: T.Text -> T.Text 16 | stripPunctuation = T.filter (not . isPunctuation) 17 | 18 | preProcess :: T.Text -> T.Text 19 | preProcess = stripWhiteSpace . stripPunctuation . T.toLower 20 | 21 | isPalindrome :: T.Text -> Bool 22 | isPalindrome text = cleanText == T.reverse cleanText where cleanText = preProcess text 23 | -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-12.23 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | # extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=1.7" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /Unit06/Lesson35/palindrome-checker/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for pizzas 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Patrick Huffer (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Patrick Huffer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/README.md: -------------------------------------------------------------------------------- 1 | # pizzas 2 | -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | import System.IO 5 | 6 | main :: IO () 7 | main = do 8 | hSetBuffering stdout NoBuffering 9 | putStr "What is the size of pizza 1? " 10 | size1 <- getLine 11 | putStr "What is the cost of pizza 1? " 12 | cost1 <- getLine 13 | putStr "What is the size of pizza 2? " 14 | size2 <- getLine 15 | putStr "What is the cost of pizza 2? " 16 | cost2 <- getLine 17 | let pizza1 = (read size1, read cost1) 18 | let pizza2 = (read size2, read cost2) 19 | let betterPizza = cheaperPizza pizza1 pizza2 -- cheaper is better! 20 | putStrLn (describePizza betterPizza) 21 | -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/package.yaml: -------------------------------------------------------------------------------- 1 | name: pizzas 2 | version: 0.1.0.0 3 | github: "Rhywun/pizzas" 4 | license: BSD3 5 | author: "Patrick Huffer" 6 | maintainer: "rhywun@rhywun.com" 7 | copyright: "Patrick Huffer" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on Github at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | executables: 29 | pizzas-exe: 30 | main: Main.hs 31 | source-dirs: app 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - pizzas 38 | 39 | tests: 40 | pizzas-test: 41 | main: Spec.hs 42 | source-dirs: test 43 | ghc-options: 44 | - -threaded 45 | - -rtsopts 46 | - -with-rtsopts=-N 47 | dependencies: 48 | - pizzas 49 | -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/pizzas.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 848315f6873f22bfa8d256bea6a50c526bf0ad8fcb70f89f98a9ed48a73e52d1 8 | 9 | name: pizzas 10 | version: 0.1.0.0 11 | description: Please see the README on Github at 12 | homepage: https://github.com/Rhywun/pizzas#readme 13 | bug-reports: https://github.com/Rhywun/pizzas/issues 14 | author: Patrick Huffer 15 | maintainer: rhywun@rhywun.com 16 | copyright: Patrick Huffer 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/Rhywun/pizzas 27 | 28 | library 29 | hs-source-dirs: 30 | src 31 | build-depends: 32 | base >=4.7 && <5 33 | exposed-modules: 34 | Lib 35 | other-modules: 36 | Paths_pizzas 37 | default-language: Haskell2010 38 | 39 | executable pizzas-exe 40 | main-is: Main.hs 41 | hs-source-dirs: 42 | app 43 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 44 | build-depends: 45 | base >=4.7 && <5 46 | , pizzas 47 | other-modules: 48 | Paths_pizzas 49 | default-language: Haskell2010 50 | 51 | test-suite pizzas-test 52 | type: exitcode-stdio-1.0 53 | main-is: Spec.hs 54 | hs-source-dirs: 55 | test 56 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 57 | build-depends: 58 | base >=4.7 && <5 59 | , pizzas 60 | other-modules: 61 | Paths_pizzas 62 | default-language: Haskell2010 63 | -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( cheaperPizza 3 | , describePizza 4 | ) 5 | where 6 | 7 | type Size = Double 8 | 9 | area :: Size -> Double 10 | area size = pi * (size / 2) ^ 2 11 | 12 | type Cost = Double 13 | 14 | type Pizza = (Size, Cost) 15 | 16 | costPerSqIn :: Pizza -> Double 17 | costPerSqIn (size, cost) = cost / area size 18 | 19 | cheaperPizza :: Pizza -> Pizza -> Pizza 20 | cheaperPizza p1 p2 = case compare (costPerSqIn p1) (costPerSqIn p2) of 21 | LT -> p1 22 | _ -> p2 23 | 24 | describePizza :: Pizza -> String 25 | describePizza (size, cost) = 26 | "The " ++ show size ++ "\" pizza is cheaper at " ++ show cpsi ++ " per sq. in." 27 | where cpsi = costPerSqIn (size, cost) 28 | -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-12.23 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.6" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /Unit06/Lesson35/pizzas/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /Unit06/Lesson36/palindrome-testing/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | palindrome-testing.cabal 3 | *~ -------------------------------------------------------------------------------- /Unit06/Lesson36/palindrome-testing/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for palindrome-testing 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /Unit06/Lesson36/palindrome-testing/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Patrick Huffer (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Patrick Huffer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Unit06/Lesson36/palindrome-testing/README.md: -------------------------------------------------------------------------------- 1 | # palindrome-testing 2 | -------------------------------------------------------------------------------- /Unit06/Lesson36/palindrome-testing/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Unit06/Lesson36/palindrome-testing/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | 5 | main :: IO () 6 | main = putStrLn "Hello, world!" 7 | -------------------------------------------------------------------------------- /Unit06/Lesson36/palindrome-testing/package.yaml: -------------------------------------------------------------------------------- 1 | name: palindrome-testing 2 | version: 0.1.0.0 3 | github: "Rhywun/palindrome-testing" 4 | license: BSD3 5 | author: "Patrick Huffer" 6 | maintainer: "rhywun@rhywun.com" 7 | copyright: "Patrick Huffer" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | dependencies: 28 | - text 29 | 30 | executables: 31 | palindrome-testing-exe: 32 | main: Main.hs 33 | source-dirs: app 34 | ghc-options: 35 | - -threaded 36 | - -rtsopts 37 | - -with-rtsopts=-N 38 | dependencies: 39 | - palindrome-testing 40 | 41 | tests: 42 | palindrome-testing-test: 43 | main: Spec.hs 44 | source-dirs: test 45 | ghc-options: 46 | - -threaded 47 | - -rtsopts 48 | - -with-rtsopts=-N 49 | dependencies: 50 | - palindrome-testing 51 | - QuickCheck 52 | - quickcheck-instances 53 | - text 54 | -------------------------------------------------------------------------------- /Unit06/Lesson36/palindrome-testing/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( isPalindrome 3 | , preprocess 4 | ) 5 | where 6 | 7 | import Data.Text as T 8 | import Data.Char ( toLower 9 | , isSpace 10 | , isPunctuation 11 | ) 12 | 13 | stripWhiteSpace :: T.Text -> T.Text 14 | stripWhiteSpace = T.filter (not . isSpace) 15 | 16 | stripPunctuation :: T.Text -> T.Text 17 | stripPunctuation = T.filter (not . isPunctuation) 18 | 19 | preprocess :: T.Text -> T.Text 20 | preprocess = stripWhiteSpace . stripPunctuation . T.toLower 21 | 22 | isPalindrome :: T.Text -> Bool 23 | isPalindrome text = cleanText == T.reverse cleanText where cleanText = preprocess text 24 | -------------------------------------------------------------------------------- /Unit06/Lesson36/palindrome-testing/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-12.23 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | # extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=1.7" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /Unit06/Lesson36/palindrome-testing/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Lib 2 | import Data.Char ( isPunctuation 3 | , isSpace 4 | , toLower 5 | ) 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Instances 8 | import Data.Text as T 9 | 10 | -- assert :: Bool -> String -> String -> IO () 11 | -- assert test pass fail = if test then putStrLn pass else putStrLn fail 12 | 13 | prop_punctuationInvariant :: T.Text -> Bool 14 | prop_punctuationInvariant text = preprocess text == preprocess noPuncText 15 | where noPuncText = T.filter (not . isPunctuation) text 16 | 17 | prop_whitespaceInvariant :: T.Text -> Bool 18 | prop_whitespaceInvariant text = preprocess text == preprocess noWhitespaceText 19 | where noWhitespaceText = T.filter (not . isSpace) text 20 | 21 | prop_reverseInvariant :: T.Text -> Bool 22 | prop_reverseInvariant text = isPalindrome text == isPalindrome (T.reverse text) 23 | 24 | main :: IO () 25 | main = do 26 | putStrLn "Running tests..." 27 | quickCheck prop_punctuationInvariant 28 | quickCheck prop_whitespaceInvariant 29 | quickCheck prop_reverseInvariant 30 | putStrLn "done!" 31 | -------------------------------------------------------------------------------- /Unit06/Lesson37/primes/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | primes.cabal 3 | *~ -------------------------------------------------------------------------------- /Unit06/Lesson37/primes/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for primes 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /Unit06/Lesson37/primes/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Patrick Huffer (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Patrick Huffer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Unit06/Lesson37/primes/README.md: -------------------------------------------------------------------------------- 1 | # primes 2 | -------------------------------------------------------------------------------- /Unit06/Lesson37/primes/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Unit06/Lesson37/primes/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Primes 4 | import System.IO 5 | 6 | main :: IO () 7 | main = do 8 | hSetBuffering stdout NoBuffering 9 | putStr "Enter a number to check if it's prime: " 10 | num <- getLine 11 | let result = isPrime (read num :: Int) -- TODO: Need error-checking here 12 | -- This is the subject of the next lesson 13 | case result of 14 | Just True -> putStrLn "It is prime!" 15 | Just False -> putStrLn "It's not prime." 16 | Nothing -> putStrLn "Sorry, this number is not a valid candidate for testing." 17 | 18 | -- re: Miller-Rabin primality test 19 | -- --reads-- 20 | -- Hard pass... 21 | -------------------------------------------------------------------------------- /Unit06/Lesson37/primes/package.yaml: -------------------------------------------------------------------------------- 1 | name: primes 2 | version: 0.1.0.0 3 | github: "Rhywun/primes" 4 | license: BSD3 5 | author: "Patrick Huffer" 6 | maintainer: "rhywun@rhywun.com" 7 | copyright: "Patrick Huffer" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | executables: 29 | primes-exe: 30 | main: Main.hs 31 | source-dirs: app 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - primes 38 | 39 | tests: 40 | primes-test: 41 | main: Spec.hs 42 | source-dirs: test 43 | ghc-options: 44 | - -threaded 45 | - -rtsopts 46 | - -with-rtsopts=-N 47 | dependencies: 48 | - primes 49 | - QuickCheck 50 | -------------------------------------------------------------------------------- /Unit06/Lesson37/primes/src/Primes.hs: -------------------------------------------------------------------------------- 1 | module Primes where 2 | 3 | -- List the primes in the given range 4 | {- 5 | sieve [2..20] -- [2,3,5,7,11,13,17,19] 6 | -} 7 | sieve :: [Int] -> [Int] 8 | sieve [] = [] 9 | sieve (nextPrime : rest) = nextPrime : sieve noFactors 10 | where noFactors = filter ((/= 0) . (`mod` nextPrime)) rest 11 | 12 | -- A list of primes of "reasonable" length. (Note that an upper limit of, say, 13 | -- 100,000 will still take a very long time to execute upon first usage.) 14 | {- 15 | length primes -- 1229 16 | take 10 primes -- [2,3,5,7,11,13,17,19,23,29] 17 | -} 18 | primes :: [Int] 19 | primes = sieve [2 .. 10000] 20 | 21 | -- Is it prime? 22 | {- 23 | isPrime 8 -- Just False 24 | isPrime 17 -- Just True 25 | isPrime (-1) -- Nothing 26 | -} 27 | isPrime :: Int -> Maybe Bool 28 | isPrime n | n < 2 = Nothing 29 | | n >= length primes = Nothing 30 | | otherwise = Just (n `elem` primes) 31 | 32 | {- 33 | unsafePrimeFactors 20 primes -- [2,2,5] 34 | -} 35 | unsafePrimeFactors :: Int -> [Int] -> [Int] 36 | unsafePrimeFactors 0 [] = [] 37 | unsafePrimeFactors n [] = [] 38 | unsafePrimeFactors n (next : primes) = if n `mod` next == 0 39 | then next : unsafePrimeFactors (n `div` next) (next : primes) 40 | else unsafePrimeFactors n primes 41 | 42 | {- 43 | primeFactors 20 -- Just [2,2,5] 44 | -} 45 | primeFactors :: Int -> Maybe [Int] 46 | primeFactors n | n < 2 = Nothing 47 | | n >= length primes = Nothing 48 | | otherwise = Just (unsafePrimeFactors n primesLessThanN) 49 | where primesLessThanN = filter (<= n) primes 50 | -------------------------------------------------------------------------------- /Unit06/Lesson37/primes/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-12.23 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | # extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=1.7" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /Unit06/Lesson37/primes/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Data.Maybe 2 | import Test.QuickCheck 3 | import Primes 4 | 5 | main :: IO () 6 | main = do 7 | quickCheck prop_validPrimesOnly 8 | quickCheck prop_primesArePrime 9 | quickCheck prop_nonPrimesAreComposite 10 | quickCheck prop_factorsMakeOriginal 11 | quickCheck prop_allFactorsPrime 12 | putStrLn "Done." 13 | 14 | -- Values outside the given range should return Nothing, inside Just 15 | prop_validPrimesOnly n = if n < 2 || n >= length primes 16 | then isNothing result 17 | else isJust result 18 | where result = isPrime n 19 | 20 | prop_primesArePrime n = if result == Just True then length divisors == 0 else True 21 | where 22 | result = isPrime n 23 | divisors = filter ((== 0) . (n `mod`)) [2 .. (n - 1)] 24 | 25 | prop_nonPrimesAreComposite n = if result == Just False then length divisors > 0 else True 26 | where 27 | result = isPrime n 28 | divisors = filter ((== 0) . (n `mod`)) [2 .. (n - 1)] 29 | 30 | prop_factorsMakeOriginal val = isNothing result || product (fromJust result) == val 31 | where result = primeFactors val 32 | 33 | prop_allFactorsPrime val = isNothing result || all (== Just True) resultsPrime 34 | where result = primeFactors val 35 | resultsPrime = map isPrime (fromJust result) 36 | -------------------------------------------------------------------------------- /Unit07/Lesson38.hs: -------------------------------------------------------------------------------- 1 | module Lesson38 where 2 | 3 | import Data.Char 4 | import System.IO 5 | 6 | -- 7 | -- Head, partial functions, and errors 8 | -- 9 | 10 | -- Dangerous! This compiles with no warning even with :set -Wall 11 | {- 12 | myTake 2 [1,2,3] -- [1,2] 13 | myTake 4 [1,2,3] -- [1,2,3,*** Exception: Prelude.head: empty list 14 | -} 15 | myTake :: Int -> [a] -> [a] 16 | myTake 0 _ = [] 17 | myTake n xs = head xs : myTake (n - 1) (tail xs) 18 | 19 | -- Now, with pattern matching, we get a warning if we don't handle [] 20 | myTakePM :: Int -> [a] -> [a] 21 | myTakePM 0 _ = [] 22 | myTakePM n (x : xs) = x : myTakePM (n - 1) xs 23 | 24 | -- QC1 25 | -- myTakePM _ [] = [] 26 | 27 | -- 28 | 29 | -- Throwing an error - bad practice, because just like above the compiler can't warn you 30 | myHead :: [a] -> a 31 | myHead [] = errorWithoutStackTrace "empty list" 32 | myHead (x : _) = x 33 | 34 | ---------------------------------------------- 35 | -- Long story short: never use head (or tail)! 36 | ---------------------------------------------- 37 | 38 | -- QC2 39 | -- maximum: [] 40 | -- succ: (maxBound :: Int) 41 | -- sum: [1..] <-- SERIOUSLY, DO NOT TRY THIS!!! 42 | 43 | -- 44 | -- Handling partial functions with Maybe 45 | -- 46 | 47 | {- 48 | maybeHead [1] -- Just 1 49 | maybeHead [] -- Nothing 50 | (+ 2) <$> maybeHead [3] -- Just 5 51 | (+ 2) <$> maybeHead [] -- Nothing 52 | (:) <$> maybeHead [1,2,3] <*> Just [] -- Just [1] 53 | (:) <$> maybeHead [] <*> Just [] -- Nothing 54 | -} 55 | maybeHead :: [a] -> Maybe a 56 | maybeHead [] = Nothing 57 | maybeHead (x : _) = Just x 58 | 59 | myTakeSafer :: Int -> Maybe [a] -> Maybe [a] 60 | myTakeSafer 0 _ = Just [] 61 | myTakeSafer n (Just xs) = (:) <$> maybeHead xs <*> myTakeSafer (n - 1) (Just (tail xs)) 62 | 63 | -- NOTE: See the `Safe` module for an extensive list of functions like these! E.g.: 64 | {- 65 | > import Safe 66 | tailMay [] -- Nothing 67 | tailSafe [] -- [] 68 | tailNote "uh oh" [] -- *** Exception: Safe.tailNote [], uh oh 69 | -} 70 | 71 | -- 72 | -- Introducing the Either type 73 | -- 74 | 75 | {- 76 | data Either a b = Left a | Right b 77 | -} 78 | 79 | {- 80 | eitherHead [1,2,3] -- Right 1 81 | eitherHead [] -- Left "Can't take head of empty list" 82 | (+1) <$> eitherHead [3,4,5] -- Right 4 83 | (+1) <$> eitherHead [] -- Left "Can't take head of empty list" 84 | -} 85 | eitherHead :: [a] -> Either String a 86 | eitherHead [] = Left "Can't take head of empty list" 87 | eitherHead (x : _) = Right x 88 | 89 | -- QC4 90 | 91 | intExample :: [Int] 92 | intExample = [1, 2, 3] 93 | 94 | qc4 :: Either String Int 95 | qc4 = (+) <$> eitherHead intExample <*> eitherHead (tail intExample) -- Right 3 96 | 97 | -- Building a prime check with Either 98 | 99 | data PrimeError = TooLarge | InvalidValue 100 | 101 | instance Show PrimeError where 102 | show TooLarge = "Value exceeds limit of prime checker." 103 | show InvalidValue = "Value is not a valid candidate for primes." 104 | 105 | displayResult :: Either PrimeError Bool -> String 106 | displayResult (Right True ) = "It's prime." 107 | displayResult (Right False) = "It's composite." 108 | displayResult (Left err ) = show err 109 | 110 | isPrime :: Int -> Either PrimeError Bool 111 | isPrime n | n < 2 = Left InvalidValue 112 | | n > maxN = Left TooLarge 113 | | otherwise = Right (n `elem` primes) 114 | where 115 | primes = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41] 116 | maxN = maximum primes 117 | 118 | mainPrimeCheck :: IO () 119 | mainPrimeCheck = do 120 | hSetBuffering stdout NoBuffering 121 | putStr "Enter a number to test if it is prime: " 122 | n <- read <$> getLine 123 | let result = isPrime n 124 | putStrLn (displayResult result) 125 | 126 | -- Q1 127 | 128 | isInt :: String -> Bool 129 | isInt = all isDigit 130 | 131 | {- 132 | addStrInts "123" "456" -- Right 579 133 | addStrInts "123" "456a" -- Left "Number 2 is not an integer." 134 | addStrInts "123a" "456" -- Left "Number 1 is not an integer." 135 | addStrInts "123a" "456b" -- Left "Both numbers are not integers." 136 | -} 137 | addStrInts :: String -> String -> Either String Int 138 | addStrInts x y | isInt x && isInt y = Right (read x + read y) 139 | | isInt x = Left "Number 2 is not an integer." 140 | | isInt y = Left "Number 1 is not an integer." 141 | | otherwise = Left "Both numbers are not integers." 142 | 143 | -- Q2 144 | 145 | {- 146 | saferSucc (1 :: Int) -- Just 2 147 | saferSucc (maxBound :: Int) -- Nothing 148 | -} 149 | saferSucc :: (Eq a, Enum a, Bounded a) => a -> Maybe a 150 | saferSucc x | x == maxBound = Nothing 151 | | otherwise = Just (succ x) 152 | 153 | {- 154 | saferTail [1,2,3] -- [2,3] 155 | saferTail [] -- [] 156 | -} 157 | saferTail :: [a] -> [a] 158 | saferTail [] = [] 159 | saferTail (_ : xs) = xs 160 | 161 | -- We're pretending 10 is an inifinite length 162 | {- 163 | saferLast [1,2,3] -- Right 3 164 | saferLast [1,2,3,4,5,6,7,8,9,10] -- Left "Can't take last of infinite list." 165 | saferLast [] -- Left "Can't take last of empty list." 166 | -} 167 | saferLast :: [a] -> Either String a 168 | saferLast [] = Left "Can't take last of empty list." 169 | saferLast xs | length xs > 9 = Left "Can't take last of infinite list." 170 | | otherwise = Right (last xs) 171 | -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | data.json 3 | *~ -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for http-lesson 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Patrick Huffer (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Patrick Huffer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/README.md: -------------------------------------------------------------------------------- 1 | # http-lesson 2 | -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.ByteString as B 4 | import qualified Data.ByteString.Char8 as BC 5 | import qualified Data.ByteString.Lazy as L 6 | import qualified Data.ByteString.Lazy.Char8 as LC 7 | import Data.String 8 | import Network.HTTP.Simple 9 | import Network.HTTP.Types.Header 10 | import Network.HTTP.Types.Status 11 | import Control.Monad.IO.Class ( MonadIO ) 12 | 13 | -- QC2 14 | -- NOTE: Bug in the book - `getResponseHeader` should be `getResponseHeaders` 15 | -- ^ 16 | 17 | response :: MonadIO m => m (Response LC.ByteString) 18 | response = httpLBS "http://news.ycombinator.com" 19 | 20 | qc2 :: MonadIO f => f [(HeaderName, BC.ByteString)] 21 | qc2 = getResponseHeaders <$> response 22 | 23 | -- `getResponseHeader` requires a HeaderName parameter: 24 | 25 | mainQC2 :: IO () 26 | mainQC2 = do 27 | response <- httpLBS "http://news.ycombinator.com" 28 | print $ getResponseHeader "Server" response 29 | -- prints ["nginx"] 30 | 31 | -- 32 | -- Making an HTTP request 33 | -- 34 | 35 | myToken = "WkWRfDFnAuVytwSTBPTohnvHkcfXuAHx" :: BC.ByteString 36 | 37 | noaaHost = "www.ncdc.noaa.gov" :: BC.ByteString 38 | 39 | apiPath = "/cdo-web/api/v2/datasets" :: BC.ByteString 40 | 41 | buildRequest :: BC.ByteString 42 | -> BC.ByteString 43 | -> BC.ByteString 44 | -> BC.ByteString 45 | -> Request 46 | buildRequest token host method path = 47 | setRequestMethod method 48 | $ setRequestHost host 49 | $ setRequestHeader "token" [token] 50 | $ setRequestPath path 51 | $ setRequestSecure True 52 | $ setRequestPort 443 defaultRequest 53 | 54 | buildRequestNoSSL :: BC.ByteString 55 | -> BC.ByteString 56 | -> BC.ByteString 57 | -> BC.ByteString 58 | -> Request 59 | buildRequestNoSSL token host method path = 60 | setRequestMethod method 61 | $ setRequestHost host 62 | $ setRequestHeader "token" [token] 63 | $ setRequestPath path 64 | $ setRequestSecure False 65 | $ setRequestPort 80 defaultRequest 66 | 67 | request = buildRequest myToken noaaHost "GET" apiPath :: Request 68 | 69 | -- Q1 70 | request' = buildRequestNoSSL myToken noaaHost "GET" apiPath :: Request 71 | 72 | -- 73 | -- Putting it all together 74 | -- 75 | 76 | main :: IO () 77 | main = do 78 | response <- httpLBS request 79 | let status = getResponseStatus response 80 | if statusCode status == 200 81 | then do 82 | putStrLn "Saving request to file..." 83 | let jsonBody = getResponseBody response 84 | L.writeFile "data.json" jsonBody 85 | else print $ statusMessage status -- <- Q2 86 | -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/http-lesson.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: dd2438faba26020695f569bb4b9f44fd853cc5911f3534daf21278e689beac17 8 | 9 | name: http-lesson 10 | version: 0.1.0.0 11 | description: Please see the README on Github at 12 | homepage: https://github.com/Rhywun/http-lesson#readme 13 | bug-reports: https://github.com/Rhywun/http-lesson/issues 14 | author: Patrick Huffer 15 | maintainer: rhywun@rhywun.com 16 | copyright: Patrick Huffer 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/Rhywun/http-lesson 27 | 28 | library 29 | exposed-modules: 30 | Lib 31 | other-modules: 32 | Paths_http_lesson 33 | hs-source-dirs: 34 | src 35 | default-extensions: OverloadedStrings 36 | build-depends: 37 | base >=4.7 && <5 38 | default-language: Haskell2010 39 | 40 | executable http-lesson-exe 41 | main-is: Main.hs 42 | other-modules: 43 | Paths_http_lesson 44 | hs-source-dirs: 45 | app 46 | default-extensions: OverloadedStrings 47 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 48 | build-depends: 49 | base >=4.7 && <5 50 | , bytestring 51 | , http-conduit 52 | , http-lesson 53 | , http-types 54 | default-language: Haskell2010 55 | 56 | test-suite http-lesson-test 57 | type: exitcode-stdio-1.0 58 | main-is: Spec.hs 59 | other-modules: 60 | Paths_http_lesson 61 | hs-source-dirs: 62 | test 63 | default-extensions: OverloadedStrings 64 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 65 | build-depends: 66 | base >=4.7 && <5 67 | , http-lesson 68 | default-language: Haskell2010 69 | -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/package.yaml: -------------------------------------------------------------------------------- 1 | name: http-lesson 2 | version: 0.1.0.0 3 | github: "Rhywun/http-lesson" 4 | license: BSD3 5 | author: "Patrick Huffer" 6 | maintainer: "rhywun@rhywun.com" 7 | copyright: "Patrick Huffer" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on Github at 21 | 22 | default-extensions: 23 | - OverloadedStrings 24 | 25 | dependencies: 26 | - base >= 4.7 && < 5 27 | 28 | library: 29 | source-dirs: src 30 | 31 | executables: 32 | http-lesson-exe: 33 | main: Main.hs 34 | source-dirs: app 35 | ghc-options: 36 | - -threaded 37 | - -rtsopts 38 | - -with-rtsopts=-N 39 | dependencies: 40 | - http-lesson 41 | - bytestring 42 | - http-conduit 43 | - http-types 44 | 45 | tests: 46 | http-lesson-test: 47 | main: Spec.hs 48 | source-dirs: test 49 | ghc-options: 50 | - -threaded 51 | - -rtsopts 52 | - -with-rtsopts=-N 53 | dependencies: 54 | - http-lesson 55 | -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-12.23 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.6" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /Unit07/Lesson39/http-lesson/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for json-lesson 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Patrick Huffer (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Patrick Huffer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/README.md: -------------------------------------------------------------------------------- 1 | # json-lesson 2 | -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/app/Book.hs: -------------------------------------------------------------------------------- 1 | module Book where 2 | 3 | import Data.Aeson 4 | import Data.ByteString.Lazy as B 5 | import Data.ByteString.Lazy.Char8 as BC 6 | import Data.Text as T 7 | import GHC.Generics 8 | 9 | -- A data type we created 10 | -- Easy to derive from FromJSON and ToJSON because we control the field names 11 | 12 | data Book = Book 13 | { title :: T.Text 14 | , author :: T.Text 15 | , year :: Int 16 | } deriving (Show, Generic) 17 | 18 | instance FromJSON Book 19 | 20 | instance ToJSON Book 21 | 22 | myBook = Book {title = "Will Kurt", author = "Learn Haskell", year = 2017} 23 | 24 | myBookJSON :: BC.ByteString 25 | myBookJSON = encode myBook 26 | -- "{\"year\":2017,\"author\":\"Learn Haskell\",\"title\":\"Will Kurt\"}" 27 | 28 | e1 :: Maybe Book 29 | e1 = decode myBookJSON 30 | -- Just (Book {title = "Will Kurt", author = "Learn Haskell", year = 2017}) 31 | 32 | rawJSON :: BC.ByteString 33 | rawJSON = 34 | "{\"year\":1949,\"author\":\"Emil Ciroan\",\"title\":\"A Short History of Decay\"}" 35 | 36 | bookFromJSON :: Maybe Book 37 | bookFromJSON = decode rawJSON 38 | -- Just Book {title = "A Short History of Decay", author = "Emil Ciroan", year = 1949}) 39 | 40 | wrongJSON :: BC.ByteString 41 | wrongJSON = 42 | "{\"year\":1949,\"writer\":\"Emil Ciroan\",\"title\":\"A Short History of Decay\"}" 43 | 44 | bookFromWrongJSON = decode wrongJSON :: Maybe Book 45 | -- Nothing 46 | 47 | bookFromWrongJSON' = eitherDecode wrongJSON :: Either String Book 48 | -- Left "Error in $: key \"author\" not present" 49 | 50 | -- QC2 51 | 52 | data Name = Name 53 | { firstName :: T.Text 54 | , lastName :: T.Text 55 | } deriving (Show, Generic) 56 | 57 | instance FromJSON Name 58 | instance ToJSON Name -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/app/ErrorMessage.hs: -------------------------------------------------------------------------------- 1 | module ErrorMessage where 2 | 3 | import Data.Aeson 4 | import Data.ByteString.Lazy as B 5 | import Data.ByteString.Lazy.Char8 as BC 6 | import Data.Text as T 7 | import GHC.Generics 8 | 9 | -- Suppose we are given this JSON 10 | 11 | sampleError :: BC.ByteString 12 | sampleError = "{\"message\":\"oops!\",\"error\": 123}" 13 | 14 | -- We have to create a data type to match this JSON 15 | 16 | -- We can't automatically derive from ToJSON or FromJSON 17 | -- because `error` is already defined in Haskell 18 | 19 | data ErrorMessage = ErrorMessage 20 | { message :: T.Text 21 | , error :: Int 22 | } deriving (Show) 23 | 24 | -- We have to derive the instance manually 25 | 26 | instance FromJSON ErrorMessage where 27 | parseJSON (Object v) = ErrorMessage <$> v .: "message" <*> v .: "error" 28 | 29 | -- Refresher on applicatives: 30 | 31 | exampleMessage :: Maybe T.Text 32 | exampleMessage = Just "Opps" 33 | 34 | exampleError :: Maybe Int 35 | exampleError = Just 123 36 | 37 | exampleErrorMessage = ErrorMessage <$> exampleMessage <*> exampleError 38 | -- Just (ErrorMessage {message = "Opps", error = 123}) 39 | 40 | -- What is `.:`? 41 | 42 | {- 43 | (.:) :: FromJSON a => Object -> Text -> Parser a 44 | -} 45 | 46 | -- QC3 47 | 48 | data Name = Name 49 | { firstName :: T.Text 50 | , lastName :: T.Text 51 | } deriving (Show) 52 | 53 | instance FromJSON Name where 54 | parseJSON (Object v) = Name <$> v .: "firstName" <*> v .: "lastName" 55 | 56 | -- Now we can decode: 57 | 58 | sampleErrorMessage :: Maybe ErrorMessage 59 | sampleErrorMessage = decode sampleError 60 | -- Just (ErrorMessage {message = "oops!", error = 123}) 61 | 62 | -- And encode: 63 | 64 | instance ToJSON ErrorMessage where 65 | toJSON (ErrorMessage message errorCode) = 66 | object ["message" .= message, "error" .= errorCode] 67 | 68 | {- 69 | encode anErrorMessage -- "{\"error\":0,\"message\":\"Everything is OK\"}" 70 | -} 71 | anErrorMessage = ErrorMessage "Everything is OK" 0 72 | 73 | -- QC4 74 | 75 | instance ToJSON Name where 76 | toJSON (Name firstName lastName) = 77 | object ["firstName" .= firstName, "lastName" .= lastName] 78 | 79 | qc4 = encode (Name "Joe" "Blow") -- "{\"lastName\":\"Blow\",\"firstName\":\"Joe\"}" 80 | -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Data.Aeson 5 | import Data.ByteString.Lazy as B 6 | import Data.ByteString.Lazy.Char8 as BC 7 | import Data.Text as T 8 | import GHC.Generics 9 | 10 | data NOAAResult = NOAAResult 11 | { uid :: T.Text 12 | , mindate :: T.Text 13 | , maxdate :: T.Text 14 | , name :: T.Text 15 | , datacoverage :: Double -- was Int - bug in the book 16 | , resultId :: T.Text -- "id" 17 | } deriving (Show) 18 | 19 | instance FromJSON NOAAResult where 20 | parseJSON (Object v) = 21 | NOAAResult 22 | <$> v 23 | .: "uid" 24 | <*> v 25 | .: "mindate" 26 | <*> v 27 | .: "maxdate" 28 | <*> v 29 | .: "name" 30 | <*> v 31 | .: "datacoverage" 32 | <*> v 33 | .: "id" 34 | 35 | data Resultset = Resultset 36 | { offset :: Int 37 | , count :: Int 38 | , limit :: Int 39 | } deriving (Show, Generic) 40 | 41 | instance FromJSON Resultset 42 | 43 | newtype Metadata = Metadata 44 | { resultset :: Resultset 45 | } deriving (Show, Generic) 46 | 47 | instance FromJSON Metadata 48 | 49 | data NOAAResponse = NOAAResponse 50 | { metadata :: Metadata 51 | , results :: [NOAAResult] 52 | } deriving (Show, Generic) 53 | 54 | instance FromJSON NOAAResponse 55 | 56 | -- 57 | 58 | printResults :: Maybe [NOAAResult] -> IO () 59 | printResults Nothing = print "Error loading data." 60 | -- Code in the book was broken 61 | printResults (Just results) = forM_ results (print . name) 62 | 63 | -- 64 | 65 | main :: IO () 66 | main = do 67 | jsonData <- B.readFile "data.json" 68 | let noaaResponse = decode jsonData :: Maybe NOAAResponse 69 | let noaaResults = results <$> noaaResponse 70 | printResults noaaResults 71 | 72 | -- 73 | -- Summary 74 | -- 75 | 76 | -- Q1 77 | 78 | instance ToJSON NOAAResult where 79 | toJSON (NOAAResult uid mindate maxdate name datacoverage resultId) = object 80 | [ "uid" .= uid 81 | , "mindate" .= mindate 82 | , "maxdate" .= maxdate 83 | , "name" .= name 84 | , "datacoverage" .= datacoverage 85 | , "id" .= resultId 86 | ] 87 | 88 | instance ToJSON Resultset 89 | 90 | instance ToJSON Metadata 91 | 92 | instance ToJSON NOAAResponse 93 | 94 | {- 95 | > jsonData <- B.readFile "data.json" 96 | > let noaaResponse = decode jsonData :: Maybe NOAAResponse 97 | > encode noaaResponse 98 | "{\"results\":[{\"uid\":\"gov.noaa.ncdc:C00861\",\"datacoverage\":1, ..." 99 | -} 100 | 101 | -- Q2 102 | 103 | data IntList = EmptyList | Cons Int (IntList) deriving (Show, Generic) 104 | 105 | intListExample :: IntList 106 | intListExample = Cons 1 $ Cons 2 EmptyList 107 | 108 | instance ToJSON IntList 109 | 110 | {- 111 | BC.putStrLn $ encode intListExample 112 | {"tag":"Cons","contents":[1,{"tag":"Cons","contents":[2,{"tag":"EmptyList"}]}]} 113 | -} 114 | -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/data.json: -------------------------------------------------------------------------------- 1 | { 2 | "metadata": { 3 | "resultset": { 4 | "offset": 1, 5 | "count": 11, 6 | "limit": 25 7 | } 8 | }, 9 | "results": [ 10 | { 11 | "uid": "gov.noaa.ncdc:C00861", 12 | "mindate": "1763-01-01", 13 | "maxdate": "2018-03-30", 14 | "name": "Daily Summaries", 15 | "datacoverage": 1, 16 | "id": "GHCND" 17 | }, 18 | { 19 | "uid": "gov.noaa.ncdc:C00946", 20 | "mindate": "1763-01-01", 21 | "maxdate": "2018-02-01", 22 | "name": "Global Summary of the Month", 23 | "datacoverage": 1, 24 | "id": "GSOM" 25 | }, 26 | { 27 | "uid": "gov.noaa.ncdc:C00947", 28 | "mindate": "1763-01-01", 29 | "maxdate": "2017-01-01", 30 | "name": "Global Summary of the Year", 31 | "datacoverage": 1, 32 | "id": "GSOY" 33 | }, 34 | { 35 | "uid": "gov.noaa.ncdc:C00345", 36 | "mindate": "1991-06-05", 37 | "maxdate": "2018-03-31", 38 | "name": "Weather Radar (Level II)", 39 | "datacoverage": 0.95, 40 | "id": "NEXRAD2" 41 | }, 42 | { 43 | "uid": "gov.noaa.ncdc:C00708", 44 | "mindate": "1994-05-20", 45 | "maxdate": "2018-03-28", 46 | "name": "Weather Radar (Level III)", 47 | "datacoverage": 0.95, 48 | "id": "NEXRAD3" 49 | }, 50 | { 51 | "uid": "gov.noaa.ncdc:C00821", 52 | "mindate": "2010-01-01", 53 | "maxdate": "2010-01-01", 54 | "name": "Normals Annual/Seasonal", 55 | "datacoverage": 1, 56 | "id": "NORMAL_ANN" 57 | }, 58 | { 59 | "uid": "gov.noaa.ncdc:C00823", 60 | "mindate": "2010-01-01", 61 | "maxdate": "2010-12-31", 62 | "name": "Normals Daily", 63 | "datacoverage": 1, 64 | "id": "NORMAL_DLY" 65 | }, 66 | { 67 | "uid": "gov.noaa.ncdc:C00824", 68 | "mindate": "2010-01-01", 69 | "maxdate": "2010-12-31", 70 | "name": "Normals Hourly", 71 | "datacoverage": 1, 72 | "id": "NORMAL_HLY" 73 | }, 74 | { 75 | "uid": "gov.noaa.ncdc:C00822", 76 | "mindate": "2010-01-01", 77 | "maxdate": "2010-12-01", 78 | "name": "Normals Monthly", 79 | "datacoverage": 1, 80 | "id": "NORMAL_MLY" 81 | }, 82 | { 83 | "uid": "gov.noaa.ncdc:C00505", 84 | "mindate": "1970-05-12", 85 | "maxdate": "2014-01-01", 86 | "name": "Precipitation 15 Minute", 87 | "datacoverage": 0.25, 88 | "id": "PRECIP_15" 89 | }, 90 | { 91 | "uid": "gov.noaa.ncdc:C00313", 92 | "mindate": "1900-01-01", 93 | "maxdate": "2014-01-01", 94 | "name": "Precipitation Hourly", 95 | "datacoverage": 1, 96 | "id": "PRECIP_HLY" 97 | } 98 | ] 99 | } -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/json-lesson.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: b7ef7fe77fb62e98a01c72f920a4913e4e0247724a15862a1a578897a0bc7763 8 | 9 | name: json-lesson 10 | version: 0.1.0.0 11 | description: Please see the README on Github at 12 | homepage: https://github.com/Rhywun/json-lesson#readme 13 | bug-reports: https://github.com/Rhywun/json-lesson/issues 14 | author: Patrick Huffer 15 | maintainer: rhywun@rhywun.com 16 | copyright: Patrick Huffer 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/Rhywun/json-lesson 27 | 28 | library 29 | exposed-modules: 30 | Lib 31 | other-modules: 32 | Paths_json_lesson 33 | hs-source-dirs: 34 | src 35 | build-depends: 36 | base >=4.7 && <5 37 | default-language: Haskell2010 38 | 39 | executable json-lesson-exe 40 | main-is: Main.hs 41 | other-modules: 42 | Book 43 | ErrorMessage 44 | Paths_json_lesson 45 | hs-source-dirs: 46 | app 47 | default-extensions: OverloadedStrings DeriveGeneric 48 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 49 | build-depends: 50 | aeson 51 | , base >=4.7 && <5 52 | , bytestring 53 | , json-lesson 54 | , text 55 | default-language: Haskell2010 56 | 57 | test-suite json-lesson-test 58 | type: exitcode-stdio-1.0 59 | main-is: Spec.hs 60 | other-modules: 61 | Paths_json_lesson 62 | hs-source-dirs: 63 | test 64 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 65 | build-depends: 66 | base >=4.7 && <5 67 | , json-lesson 68 | default-language: Haskell2010 69 | -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/package.yaml: -------------------------------------------------------------------------------- 1 | name: json-lesson 2 | version: 0.1.0.0 3 | github: "Rhywun/json-lesson" 4 | license: BSD3 5 | author: "Patrick Huffer" 6 | maintainer: "rhywun@rhywun.com" 7 | copyright: "Patrick Huffer" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on Github at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | executables: 29 | json-lesson-exe: 30 | main: Main.hs 31 | source-dirs: app 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - json-lesson 38 | - aeson 39 | - bytestring 40 | - text 41 | default-extensions: 42 | - OverloadedStrings 43 | - DeriveGeneric 44 | 45 | tests: 46 | json-lesson-test: 47 | main: Spec.hs 48 | source-dirs: test 49 | ghc-options: 50 | - -threaded 51 | - -rtsopts 52 | - -with-rtsopts=-N 53 | dependencies: 54 | - json-lesson 55 | -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-12.23 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.6" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /Unit07/Lesson40/json-lesson/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | app/tools.db 3 | *~ -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for db-lesson 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Patrick Huffer (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Patrick Huffer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/README.md: -------------------------------------------------------------------------------- 1 | # db-lesson 2 | -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/app/tools.db: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Rhywun/get-programming-with-haskell/4f57ac35cb425c48f3976ebd81d4ac0174c6d352/Unit07/Lesson41/db-lesson/app/tools.db -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/build_db.sql: -------------------------------------------------------------------------------- 1 | DROP TABLE IF EXISTS checkedout; 2 | DROP TABLE IF EXISTS tools; 3 | DROP TABLE IF EXISTS users; 4 | 5 | CREATE TABLE users ( 6 | id INTEGER PRIMARY KEY, 7 | username TEXT 8 | ); 9 | 10 | CREATE TABLE tools ( 11 | id INTEGER PRIMARY KEY, 12 | name TEXT, 13 | description TEXT, 14 | lastReturned TEXT, 15 | timesBorrowed INTEGER 16 | ); 17 | 18 | CREATE TABLE checkedout ( 19 | user_id INTEGER, 20 | tool_id INTEGER 21 | ); 22 | 23 | INSERT INTO users (username) VALUES ('willkurt'); 24 | 25 | INSERT INTO tools (name,description,lastReturned,timesBorrowed) 26 | VALUES ('hammer','hits stuff','2017-01-01',0); 27 | 28 | INSERT INTO tools (name,description,lastReturned,timesBorrowed) 29 | VALUES ('saw','cuts stuff','2017-01-01',0); 30 | -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/db-lesson.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.20.0. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: 71b1b5f9583952c2b11921d8388bf3e996e115be6500e85de6beb052acb2d544 6 | 7 | name: db-lesson 8 | version: 0.1.0.0 9 | description: Please see the README on Github at 10 | homepage: https://github.com/Rhywun/db-lesson#readme 11 | bug-reports: https://github.com/Rhywun/db-lesson/issues 12 | author: Patrick Huffer 13 | maintainer: rhywun@rhywun.com 14 | copyright: Patrick Huffer 15 | license: BSD3 16 | license-file: LICENSE 17 | build-type: Simple 18 | cabal-version: >= 1.10 19 | 20 | extra-source-files: 21 | ChangeLog.md 22 | README.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/Rhywun/db-lesson 27 | 28 | library 29 | hs-source-dirs: 30 | src 31 | build-depends: 32 | base >=4.7 && <5 33 | exposed-modules: 34 | Lib 35 | other-modules: 36 | Paths_db_lesson 37 | default-language: Haskell2010 38 | default-extensions: 39 | OverloadedStrings 40 | 41 | executable db-lesson-exe 42 | main-is: Main.hs 43 | hs-source-dirs: 44 | app 45 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 46 | build-depends: 47 | base >=4.7 && <5 48 | , db-lesson 49 | , time 50 | , sqlite-simple 51 | other-modules: 52 | Paths_db_lesson 53 | default-language: Haskell2010 54 | default-extensions: 55 | OverloadedStrings 56 | 57 | test-suite db-lesson-test 58 | type: exitcode-stdio-1.0 59 | main-is: Spec.hs 60 | hs-source-dirs: 61 | test 62 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 63 | build-depends: 64 | base >=4.7 && <5 65 | , db-lesson 66 | other-modules: 67 | Paths_db_lesson 68 | default-language: Haskell2010 69 | -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/package.yaml: -------------------------------------------------------------------------------- 1 | name: db-lesson 2 | version: 0.1.0.0 3 | github: "Rhywun/db-lesson" 4 | license: BSD3 5 | author: "Patrick Huffer" 6 | maintainer: "rhywun@rhywun.com" 7 | copyright: "Patrick Huffer" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on Github at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | executables: 29 | db-lesson-exe: 30 | main: Main.hs 31 | source-dirs: app 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - db-lesson 38 | 39 | tests: 40 | db-lesson-test: 41 | main: Spec.hs 42 | source-dirs: test 43 | ghc-options: 44 | - -threaded 45 | - -rtsopts 46 | - -with-rtsopts=-N 47 | dependencies: 48 | - db-lesson 49 | -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-12.23 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [ 43 | time-1.9.2 44 | ] 45 | 46 | # Override default flag values for local packages and extra-deps 47 | # flags: {} 48 | 49 | # Extra package databases containing global packages 50 | # extra-package-dbs: [] 51 | 52 | # Control whether we use the GHC we find on the path 53 | # system-ghc: true 54 | # 55 | # Require a specific version of stack, using version ranges 56 | # require-stack-version: -any # Default 57 | # require-stack-version: ">=1.6" 58 | # 59 | # Override the architecture used by stack, especially useful on Windows 60 | # arch: i386 61 | # arch: x86_64 62 | # 63 | # Extra directories used by stack for building 64 | # extra-include-dirs: [/path/to/dir] 65 | # extra-lib-dirs: [/path/to/dir] 66 | # 67 | # Allow a newer minor version of GHC than the snapshot specifies 68 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /Unit07/Lesson41/db-lesson/tools.db: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Rhywun/get-programming-with-haskell/4f57ac35cb425c48f3976ebd81d4ac0174c6d352/Unit07/Lesson41/db-lesson/tools.db -------------------------------------------------------------------------------- /Unit07/Lesson42.hs: -------------------------------------------------------------------------------- 1 | module Lesson42 where 2 | 3 | import Data.Array.Unboxed 4 | import Data.Array.ST 5 | import Data.STRef 6 | import Control.Monad 7 | import Control.Monad.ST 8 | 9 | -- 10 | -- Creating efficient arrays in Haskell with the UArray type 11 | -- 12 | 13 | aLargeList :: [Int] 14 | aLargeList = [1 .. 10000000] 15 | 16 | aLargeArray :: UArray Int Int 17 | aLargeArray = array (0, 9999999) [] 18 | 19 | {- 20 | -- First time: 21 | length aLargeListDoubled -- 10000000 22 | (1.09 secs, 1,680,117,320 bytes) 23 | 24 | -- Second time, same session: 25 | length aLargeListDoubled -- 10000000 26 | (0.08 secs, 116,640 bytes) 27 | -} 28 | aLargeListDoubled :: [Int] 29 | aLargeListDoubled = map (* 2) aLargeList 30 | 31 | zeroIndexArray :: UArray Int Bool 32 | zeroIndexArray = array (0, 4) [(3, True)] 33 | -- array (0,4) [(0,False),(1,False),(2,False),(3,True),(4,False)] 34 | 35 | oneIndexArray :: UArray Int Bool 36 | oneIndexArray = array (1, 5) $ zip [1 .. 5] $ repeat True 37 | -- array (1,5) [(1,True),(2,True),(3,True),(4,True),(5,True)] 38 | 39 | -- QC1 40 | -- The question is confusing but here goes: 41 | 42 | qc1 :: UArray Int Bool 43 | qc1 = array (0, 4) [(2, True), (3, True)] 44 | -- array (0,4) [(0,False),(1,False),(2,True),(3,True),(4,False)] 45 | 46 | -- Arrays can use any Bounded Enum index: 47 | 48 | a1 :: UArray Char Int 49 | a1 = array ('a', 'z') $ zip ['a' .. 'z'] [1 .. 26] -- array ('a','z') [('a',1),('b',2),...] 50 | 51 | -- Updating your UArray... 52 | 53 | beansInBuckets :: UArray Int Int 54 | beansInBuckets = array (0, 3) [] -- array (0,3) [(0,0),(1,0),(2,0),(3,0)] 55 | 56 | -- QC2 57 | 58 | qc2 :: UArray Int Int 59 | qc2 = array (0, 3) $ zip [0 .. 3] $ repeat 0 -- array (0,3) [(0,0),(1,0),(2,0),(3,0)] 60 | 61 | -- ...with the `//` operator: 62 | 63 | beansInBuckets' :: UArray Int Int 64 | beansInBuckets' = beansInBuckets // [(1, 5), (3, 6)] 65 | -- array (0,3) [(0,0),(1,5),(2,0),(3,6)] 66 | 67 | -- ... now add two beans to every bucket: 68 | 69 | beansInBuckets'' :: UArray Int Int 70 | beansInBuckets'' = accum (+) beansInBuckets' $ zip [0 .. 3] $ repeat 2 71 | -- array (0,3) [(0,2),(1,7),(2,2),(3,8)] 72 | 73 | -- QC3 74 | 75 | qc3 :: UArray Int Int 76 | qc3 = accum (*) beansInBuckets'' $ zip [0 .. 3] $ repeat 2 77 | -- array (0,3) [(0,4),(1,14),(2,4),(3,16)] 78 | 79 | -- 80 | -- Mutating state with STUArray 81 | -- 82 | 83 | -- Transform a list of Ints into an STUArray 84 | listToSTUArray :: [Int] -> ST s (STUArray s Int Int) 85 | listToSTUArray vals = do 86 | let end = length vals - 1 87 | myArray <- newArray (0, end) 0 88 | forM_ [0 .. end] $ \i -> do 89 | let val = vals !! i 90 | writeArray myArray i val 91 | return myArray 92 | 93 | -- 94 | -- Taking values out of the ST context 95 | -- 96 | 97 | {- 98 | listToUArray [1,2,3] -- array (0,2) [(0,1),(1,2),(2,3)] 99 | -} 100 | listToUArray :: [Int] -> UArray Int Int 101 | listToUArray vals = runSTUArray $ listToSTUArray vals 102 | 103 | -- Or, more typically, you would combine two functions such as `listToSTUArray` 104 | -- and `listToUArray` like so: 105 | 106 | {- 107 | listToUArray' [1,2,3] -- array (0,2) [(0,1),(1,2),(2,3)] 108 | -} 109 | listToUArray' :: [Int] -> UArray Int Int 110 | listToUArray' vals = runSTUArray $ do 111 | let end = length vals - 1 112 | myArray <- newArray (0, end) 0 113 | forM_ [0 .. end] $ \i -> do 114 | let val = vals !! i 115 | writeArray myArray i val 116 | return myArray 117 | 118 | -- The ST type 119 | 120 | {- 121 | swapST (1,2) -- (2,1) 122 | -} 123 | swapST :: (Int, Int) -> (Int, Int) 124 | swapST (x, y) = runST $ do 125 | x' <- newSTRef x 126 | y' <- newSTRef y 127 | writeSTRef x' y 128 | writeSTRef y' x 129 | xfinal <- readSTRef x' 130 | yfinal <- readSTRef y' 131 | return (xfinal, yfinal) 132 | 133 | -- 134 | -- Implementing a bubble sort 135 | -- 136 | 137 | myData :: UArray Int Int 138 | myData = listArray (0, 5) [7, 6, 4, 8, 10, 2] 139 | 140 | -- QC4 141 | myData' :: UArray Int Int 142 | myData' = listToUArray' [7, 6, 4, 8, 10, 2] 143 | 144 | {- 145 | bubbleSort myData -- array (0,5) [(0,2),(1,4),(2,6),(3,7),(4,8),(5,10)] 146 | ^ ^ ^ ^ ^ ^ 147 | -} 148 | bubbleSort :: UArray Int Int -> UArray Int Int 149 | bubbleSort myArray = runSTUArray $ do 150 | stArray <- thaw myArray 151 | let end = snd . bounds $ myArray 152 | forM_ [1 .. end] $ \i -> forM_ [0 .. (end - i)] $ \j -> do 153 | val <- readArray stArray j 154 | nextVal <- readArray stArray $ j + 1 155 | when (val > nextVal) $ do 156 | writeArray stArray j nextVal 157 | writeArray stArray (j + 1) val 158 | return stArray 159 | 160 | -- snip -- 161 | -------------------------------------------------------------------------------- /get-programming-with-haskell.cabal: -------------------------------------------------------------------------------- 1 | name: get-programming-with-haskell 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/rhywun/programming-with-haskell#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Patrick Huffer 9 | maintainer: rhywun@rhywun.com 10 | copyright: 2018 Patrick Huffer 11 | category: Education 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | library 17 | exposed-modules: 18 | other-modules: Paths_get_programming_with_haskell 19 | hs-source-dirs: . 20 | default-language: Haskell2010 21 | build-depends: base >=4.7 && <5 22 | , containers 23 | , random 24 | , text 25 | , split 26 | , bytestring 27 | , array -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd 10 | size: 640086 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml 12 | original: lts-21.25 13 | --------------------------------------------------------------------------------