forked from ikhoon/FP101x
-
Notifications
You must be signed in to change notification settings - Fork 0
/
chapter12-lab6.hs
119 lines (81 loc) · 4.15 KB
/
chapter12-lab6.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
import Prelude hiding (Monoid, Foldable, mappend, mempty, foldMap)
------------------------------------------------------------------------------------------------------------------------------
-- ROSE TREES, FUNCTORS, MONOIDS, FOLDABLES
------------------------------------------------------------------------------------------------------------------------------
data Rose a = a :> [Rose a] deriving Show
-- ===================================
-- Ex. 0-2
-- ===================================
root :: Rose a -> a
root (x :> xs) = x
children :: Rose a -> [Rose a]
children (x :> xs) = xs
xs = 0 :> [1 :> [2 :> [3 :> [4 :> [], 5 :> []]]], 6 :> [], 7 :> [8 :> [9 :> [10 :> []], 11 :> []], 12 :> [13 :> []]]]
tree0 = 'x' :> map (flip (:>) []) ['a'..'x']
tree1 = 'x' :> map (\c -> c :> []) ['a'..'A']
ex2 = root . head . children . head . children . head . drop 2 $ children xs
-- ===================================
-- Ex. 3-7
-- ===================================
size :: Rose a -> Int
size (x :> []) = 1
size (x :> xs) = 1 + (foldr (\n acc -> size n + acc) 0 xs)
tree3 = 1 :> map (\c -> c :> []) [1..5]
tree4 = 1 :> map (\c -> c :> []) [1..5]
leaves :: Rose a -> Int
leaves (x :> []) = 1
leaves (x :> xs) = (foldr (\n acc -> leaves n + acc) 0 xs)
ex7 = (*) (leaves . head . children . head . children $ xs) (product . map size . children . head . drop 2 . children $ xs)
-- ===================================
-- Ex. 8-10
-- ===================================
instance Functor Rose where
fmap f (x :> []) = (f x) :> []
fmap f (x :> xs) = f x :> map (\n -> fmap f n) xs
f' r = fmap head $ fmap (\x -> [x]) r
ex10 = round . root . head . children . fmap (\x -> if x > 0.5 then x else 0) $ fmap (\x -> sin(fromIntegral x)) xs
-- ===================================
-- Ex. 11-13
-- ===================================
class Monoid m where
mempty :: m
mappend :: m -> m -> m
newtype Sum a = Sum a
newtype Product a = Product a
instance Num a => Monoid (Sum a) where
mempty = Sum 0
mappend (Sum x) (Sum y) = Sum (x + y)
instance Num a => Monoid (Product a) where
mempty = Product 1
mappend (Product x) (Product y) = Product (x * y)
unSum :: Sum a -> a
unSum (Sum n) = n
unProduct :: Product a -> a
unProduct (Product n) = n
num1 = mappend (mappend (Sum 2) (mappend (mappend mempty (Sum 1)) mempty)) (mappend (Sum 2) (Sum 1))
num2 = mappend (Sum 3) (mappend mempty (mappend (mappend (mappend (Sum 2) mempty) (Sum (-1))) (Sum 3)))
ex13 = unSum (mappend (Sum 5) (Sum (unProduct (mappend (Product (unSum num2)) (mappend (Product (unSum num1)) (mappend mempty (mappend (Product 2) (Product 3))))))))
-- ===================================
-- Ex. 14-15
-- ===================================
class Functor f => Foldable f where
fold :: Monoid m => f m -> m
foldMap :: Monoid m => (a -> m) -> f a -> m
foldMap g = fold . fmap g
instance Foldable Rose where
fold (x :> []) = mappend x mempty
fold (x :> xs) = mappend x (foldr (\a b -> mappend (fold a) b) mempty xs)
sumxs = Sum 0 :> [Sum 13 :> [Sum 26 :> [Sum (-31) :> [Sum (-45) :> [], Sum 23 :> []]]], Sum 27 :> [], Sum 9 :> [Sum 15 :> [Sum 3 :> [Sum (-113) :> []], Sum 1 :> []], Sum 71 :> [Sum 55 :> []]]]
ex15 = unSum (mappend (mappend (fold sumxs) (mappend (fold . head . drop 2 . children $ sumxs) (Sum 30))) (fold . head . children $ sumxs))
-- ===================================
-- Ex. 16-18
-- ===================================
ex17 = unSum (mappend (mappend (foldMap (\x -> Sum x) xs) (mappend (foldMap (\x -> Sum x) . head . drop 2 . children $ xs) (Sum 30))) (foldMap (\x -> Sum x) . head . children $ xs))
ex18 = unSum (mappend (mappend (foldMap (\x -> Sum x) xs) (Sum (unProduct (mappend (foldMap (\x -> Product x) . head . drop 2 . children $ xs) (Product 3))))) (foldMap (\x -> Sum x) . head . children $ xs))
-- ===================================
-- Ex. 19-21
-- ===================================
fproduct, fsum :: (Foldable f, Num a) => f a -> a
fsum xs = unSum $ foldMap Sum xs
fproduct xs = unProduct $ foldMap Product xs
ex21 = ((fsum . head . drop 1 . children $ xs) + (fproduct . head . children . head . children . head . drop 2 . children $ xs)) - (fsum . head . children . head . children $ xs)