Mercurial > hg > Members > atton > delta_monad

comparison similar.hs @ 16:4b315cf0edb9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Improve mu definition
author Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp>
date Tue, 09 Sep 2014 13:29:43 +0900
parents c599d2236d19
children 279ebcf670c4
comparison
equal deleted inserted replaced
15:c599d2236d19 16:4b315cf0edb9
9 9
10 value :: Similar a -> a 10 value :: Similar a -> a
11 value (Single x) = x 11 value (Single x) = x
12 value (Similar x s) = value s 12 value (Similar x s) = value s
13 13
14 toList :: Similar a -> [a] 14 similar :: Similar a -> Similar a -> Similar a
15 toList (Single x) = [x] 15 similar (Single x) ss = Similar x ss
16 toList (Similar x s) = x : (toList s) 16 similar (Similar x s) ss = Similar x (similar s ss)
17
18 toSimilar :: [a] -> Similar a
19 toSimilar [] = undefined
20 toSimilar (x:[]) = Single x
21 toSimilar (x:xs) = Similar x (toSimilar xs)
22 17
23 instance Functor Similar where 18 instance Functor Similar where
24 fmap f (Single a) = Single (f a) 19 fmap f (Single a) = Single (f a)
25 fmap f (Similar a s) = Similar (f a) (fmap f s) 20 fmap f (Similar a s) = Similar (f a) (fmap f s)
26 21
27 mu :: (Similar (Similar a)) -> Similar a 22 mu :: (Similar (Similar a)) -> Similar a
28 mu s = toSimilar $ concat $ toList $ fmap (toList) s 23 mu (Single s) = s
24 mu (Similar s ss) = similar s (mu ss)
29 25
30 instance Monad Similar where 26 instance Monad Similar where
31 return = Single 27 return = Single
32 (Single x) >>= f = f x 28 (Single x) >>= f = f x
33 (Similar x s) >>= f = mu $ Similar (f x) (fmap f s) 29 (Similar x s) >>= f = mu $ Similar (f x) (fmap f s)
34 30
35 31
32 -- samples
36 33
37 double :: Int -> Similar Int 34 double :: Int -> Similar Int
38 double x = Single (2 * x) 35 double x = Single (2 * x)
39 36
40 twicePlus :: Int -> Similar Int 37 twicePlus :: Int -> Similar Int
71 *Main> same $ return 100 >>= double >>= twicePlus 68 *Main> same $ return 100 >>= double >>= twicePlus
72 400 69 400
73 70
74 *Main> same $ return 100 >>= double >>= twicePlus 71 *Main> same $ return 100 >>= double >>= twicePlus
75 400 72 400
76 *Main> same $ return 100 >>= double >>= twicePlus >>= plusTwo 73 *Main> same $ return 100 >>= double >>= twicePlus >>= plusTwo
77 *** Exception: same 74 *** Exception: same
78 *Main> value $ return 100 >>= double >>= twicePlus >>= plusTwo 75 *Main> value $ return 100 >>= double >>= twicePlus >>= plusTwo
79 800 76 800
80 77
81 -} 78 -}
82 79