learning-Haskell/template-lab6.hs at master · 4gn3s/learning-Haskell · GitHub

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
------------------------------------------------------------------------------------------------------------------------------
-- ROSE TREES, FUNCTORS, MONOIDS, FOLDABLES
------------------------------------------------------------------------------------------------------------------------------

data Rose a = a :> [Rose a] deriving (Eq, Show)

-- ===================================
-- Ex. 0-2
-- ===================================

root :: Rose a -> a
root (x :> _) = x

children :: Rose a -> [Rose a]
children (_ :> xs) = xs

test1 = root (1 :> [2 :> [], 3 :> []]) == 1
test2 = root ('a' :> []) == 'a'
test3 = children (1 :> [2 :> [], 3 :> []]) == [2 :> [], 3 :> []]
test4 = children ('a' :> []) == []

ex0_tree = 'x' :> map (flip (:>) []) ['a'..'x']
ex0 = length $ children ex0_tree

ex1_tree = 'x' :> map (\c -> c :> []) ['a'..'A']
ex1 = length (children ex1_tree)

xs = 0 :> [1 :> [2 :> [3 :> [4 :> [], 5 :> []]]], 6 :> [], 7 :> [8 :> [9 :> [10 :> []], 11 :> []], 12 :> [13 :> []]]]
ex2 = root . head . children . head . children . head . drop 2 $ children xs

-- ===================================
-- Ex. 3-7
-- ===================================

size :: Rose a -> Int
size (x :> xs) = 1 + sum [size x' | x' <- xs]

leaves :: Rose a -> Int
leaves (_ :> []) = 1
leaves (_ :> xs) = sum $ map leaves xs

ex3_tree = 1 :> map (\c -> c :> []) [1..5]
ex3 = size ex3_tree

ex4_tree = 1 :> map (\c -> c :> []) [1..5]
ex4 = size . head . children $ ex4_tree

ex5_tree = 1 :> map (\c -> c :> []) [1..5]
ex5 = leaves ex5_tree

ex6_tree = 1 :> map (\c -> c :> []) [1..5]
ex6 = product (map leaves (children ex6_tree))

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 :> xs) = (f x :> [fmap f x' | x' <- xs])

test5 = fmap (*2) (1 :> [2 :> [], 3 :> []]) == (2 :> [4 :> [], 6 :> []])
test6 = fmap (+1) (1 :> []) == (2 :> [])

ex8_tree = 1 :> map (\c -> c :> []) [1..5]
ex8 = size (fmap leaves (fmap (:> []) ex8_tree))

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 deriving Show
newtype Product a = Product a deriving Show

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 a) = a
unProduct :: Product a -> a
unProduct (Product a) = a

ex11 = unProduct (Product 6 `mappend` (Product . unSum $ Sum 3 `mappend` Sum 4))

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 f = fold . fmap f

flatten :: Rose a -> [a]
flatten (x :> []) = [x]
flatten (x :> xs) = x : (concat [flatten x' | x' <- xs])

instance Foldable Rose where
  fold tree = foldr mappend mempty $ flatten tree


ex14_tree = 1 :> [2 :> [], 3 :> [4 :> []]]
ex14_tree' = fmap Product ex14_tree
ex14 = unProduct $ fold ex14_tree'

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
-- ===================================

ex16_tree = 42 :> [3 :> [2:> [], 1 :> [0 :> []]]]
ex16 = unSum $ foldMap Sum ex16_tree

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 f = unSum (foldMap Sum f)
fproduct f = unProduct (foldMap Product f)

ex19 = fsum xs

ex20 = fproduct xs

ex21 = ((fsum . head . drop 1 . children $ xs) + (fproduct . head . children . head . children . head . drop 2 . children $ xs)) - (fsum . head . children . head . children $ xs)