-
Notifications
You must be signed in to change notification settings - Fork 0
/
unit3.hs
167 lines (131 loc) · 4.02 KB
/
unit3.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
{-# OPTIONS_GHC -Wno-noncanonical-monoid-instances #-}
import Data.Semigroup
import Data.List (sort)
import Foreign.C (e2BIG)
-- lesson: 16
type FirstName = String
type LastName = String
type MiddleName = String
data Book = Book {
author :: Creator
, isbn :: String
, bookTitle :: String
, bookYear :: String
, bookPrice :: Double
}
data Creator = AuthorCreator Author | ArtistCreator Artist
newtype Author = Author Name
data Artist = Person Name | Band String
data Name = Name FirstName LastName
| NameWithMiddle FirstName MiddleName LastName
| FirstNameWithTwoInits FirstName Char Char
| LastNameWithTwoInits Char Char LastName
authName :: Creator
authName = AuthorCreator (Author (
LastNameWithTwoInits 'H' 'P' "Lovecraft"
))
data VinylRecord = VinylRecord {
artist :: Creator
, recordTitle :: String
, recordYear :: Int
, recordPrice :: Double
}
data StoreItem = BookItem Book | RecordItem VinylRecord | ToyItem CollectableToy | PamphletItem Pamphlet
data CollectableToy = CollectableToy {
name :: String
, toyDescription :: String
, toyPrice :: Double
}
data Pamphlet = Pamphlet {
title :: String
, phamphletDescription :: String
, toyContact :: String
}
price :: StoreItem -> Double
price (BookItem book) = bookPrice book
price (RecordItem record) = recordPrice record
price (ToyItem toy) = toyPrice toy
price (PamphletItem _) = 0
type Radius = Double
type Height = Double
type Width = Double
data Shape = Circle Radius
| Square Height
| Rectangle Height Width deriving Show
perimeter :: Shape -> Double
perimeter (Circle r) = 2*pi*r
perimeter (Square h) = 4*h
-- lesson: 17
myLast :: [a] -> a
myLast = head . reverse
myMin :: Ord a => [a] -> a
myMin = head . sort
myMax :: Ord a => [a] -> a
myMax = myLast . sort
myAll :: (a -> Bool) -> [a] -> Bool
myAll testFunc = (foldr (&&) True) . (map testFunc)
instance Semigroup Integer where
(<>) x y = x + y
data Color = Red |
Yellow |
Green |
Blue |
Purple |
Orange |
Brown |
Transparent deriving (Show, Eq)
instance Semigroup Color where
(<>) any Transparent = any
(<>) Transparent any = any
(<>) Red Blue = Purple
(<>) Blue Red = Purple
(<>) Yellow Blue = Green
(<>) Blue Yellow = Green
(<>) Red Yellow = Orange
(<>) Yellow Red = Orange
-- to make it type associative we are using gaurds
(<>) a b | a == b = a
| all (`elem` [Red,Blue,Purple]) [a,b] = Purple
| all (`elem` [Blue,Green,Yellow]) [a,b] = Green
| all (`elem` [Brown,Yellow,Orange]) [a,b] = Orange
instance Monoid Color where
mempty = Transparent
mappend col1 col2 = col1 <> col2
-- Monoids
type Events = [String]
type Probs = [Double]
data PTable = PTable Events Probs
createPTable :: Events -> Probs -> PTable
createPTable events probs = PTable events normalizedProbs
where
totalProbs = sum probs
normalizedProbs = map (\x -> x / totalProbs) probs
showPair :: String -> Double -> String
showPair event prob = mconcat [event,"|",show prob,"\n"]
instance Show PTable where
show (PTable events probs) = mconcat pairs
where
pairs = zipWith showPair events probs
cartCombine :: (a -> b -> c) -> [a] -> [b] -> [c]
cartCombine func l1 l2 = zipWith func newL1 cycledL2
where
nToAdd = length l2
repeatedL1 = map (take nToAdd . repeat) l1
newL1 = mconcat repeatedL1
cycledL2 = cycle l2
combineEvents :: Events -> Events -> Events
combineEvents e1 e2 = cartCombine combiner e1 e2
where
combiner x y = mconcat [x,"-",y]
combineProbs :: Probs -> Probs -> Probs
combineProbs p1 p2 = cartCombine (*) p1 p2
instance Semigroup PTable where
(<>) ptable1 (PTable [] []) = ptable1
(<>) (PTable [] []) ptable2 = ptable2
(<>) (PTable e1 p1) (PTable e2 p2) = createPTable newEvents newProbs
where
newEvents = combineEvents e1 e2
newProbs = combineProbs p1 p2
instance Monoid PTable where
mempty = PTable [] []
mappend = (<>)