Mercurial > hg > Members > atton > delta_monad

comparison similar.hs @ 15:c599d2236d19

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Similar as Monad
author Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp>
date Sat, 06 Sep 2014 16:01:27 +0900
parents 116131b196bb
children 4b315cf0edb9
comparison
equal deleted inserted replaced
14:116131b196bb 15:c599d2236d19
5 5
6 same :: (Eq a) => Similar a -> a 6 same :: (Eq a) => Similar a -> a
7 same (Single x) = x 7 same (Single x) = x
8 same (Similar x s) = if x == (same s) then x else (error "same") 8 same (Similar x s) = if x == (same s) then x else (error "same")
9 9
10 value :: Similar a -> a
11 value (Single x) = x
12 value (Similar x s) = value s
13
14 toList :: Similar a -> [a]
15 toList (Single x) = [x]
16 toList (Similar x s) = x : (toList s)
17
18 toSimilar :: [a] -> Similar a
19 toSimilar [] = undefined
20 toSimilar (x:[]) = Single x
21 toSimilar (x:xs) = Similar x (toSimilar xs)
10 22
11 instance Functor Similar where 23 instance Functor Similar where
12 fmap f (Single a) = Single (f a) 24 fmap f (Single a) = Single (f a)
13 fmap f (Similar a s) = Similar (f a) (fmap f s) 25 fmap f (Similar a s) = Similar (f a) (fmap f s)
14 26
15 mu :: (Eq a) => (Similar (Similar a)) -> Similar a 27 mu :: (Similar (Similar a)) -> Similar a
16 mu (Single x) = x 28 mu s = toSimilar $ concat $ toList $ fmap (toList) s
17 mu (Similar (Single x) s) = Similar x (mu s)
18 mu (Similar s ss) = Similar (same s) (mu ss)
19 29
20 {-
21 instance Monad Similar where 30 instance Monad Similar where
22 return = Single 31 return = Single
23 (Single x) >>= f = f x 32 (Single x) >>= f = f x
24 (Similar x s) >>= f = mu $ Similar (f x) (fmap f s) 33 (Similar x s) >>= f = mu $ Similar (f x) (fmap f s)
25 -}
26 34
27 35
28 36
29 double :: Int -> Similar Int 37 double :: Int -> Similar Int
30 double x = Single (2 * x) 38 double x = Single (2 * x)
36 plusTwo x = Similar (x + 2) (double x) 44 plusTwo x = Similar (x + 2) (double x)
37 45
38 -- samples 46 -- samples
39 47
40 {- 48 {-
41 *Main> same $ Main.return 100 Main.>>= (\x -> Similar x twicePlus $ double x) 49 - Similar as Functor
42 200 50 *Main> fmap (double ) (Single 1)
51 Single (Single 2)
52 *Main> fmap (twicePlus) (Single 1)
53 Single (Similar 2 (Single 2))
54 *Main> fmap (plusTwo) (Single 1)
55 Single (Similar 3 (Single 2))
56 *Main> fmap (fmap double) (fmap (plusTwo ) (Single 1))
57 Single (Similar (Single 6) (Single (Single 4)))
58 *Main> same $ fmap same $ fmap (fmap double) (fmap (plusTwo ) (Single 1))
59 *** Exception: same
60 *Main> same $ fmap same $ fmap (fmap double) (fmap (plusTwo ) (Single 2))
61 Single 8
43 62
44 *Main> same $ Main.return 2 Main.>>= (\x -> Similar x plusTwo $ double x) 63 - Similar as Monad
45 4 64 *Main> return 100 >>= double >>= twicePlus
65 Similar 400 (Single 400)
66 *Main> return 100 >>= double >>= twicePlus >>= plusTwo
67 Similar 402 (Similar 800 (Similar 402 (Single 800)))
46 68
47 *Main> same $ Main.return 100 Main.>>= (\x -> Similar x plusTwo $ double x) 69 *Main> same $ return 100 >>= double >>= twicePlus >>= plusTwo
48 *** Exception: Prelude.undefined 70 *** Exception: same
71 *Main> same $ return 100 >>= double >>= twicePlus
72 400
73
74 *Main> same $ return 100 >>= double >>= twicePlus
75 400
76 *Main> same $ return 100 >>= double >>= twicePlus >>= plusTwo
77 *** Exception: same
78 *Main> value $ return 100 >>= double >>= twicePlus >>= plusTwo
79 800
80
49 -} 81 -}
50 82