Mercurial > hg > Members > atton > delta_monad

comparison similar.hs @ 21:af8754322ed4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Define Similar sample
author Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp>
date Tue, 23 Sep 2014 17:27:11 +0900
parents d4aa70d94352
children f0400c4c953f
comparison
equal deleted inserted replaced
20:d4aa70d94352 21:af8754322ed4
1 import Control.Applicative 1 import Control.Applicative
2 import Data.Numbers.Primes -- $ cabal install primes 2 import Data.Numbers.Primes -- $ cabal install primes
3 3
4 data Similar a = Single [String] a | Similar [String] a [String] a deriving (Show) 4 data Similar a = Single [String] a | Similar [String] a [String] a deriving (Show)
5 5
6 value :: (Similar a) -> Similar a 6 value :: (Similar a) -> a
7 value (Similar xs x _ _) = Single xs x 7 value (Single _ x) = x
8 value s = s 8 value (Similar _ x _ _) = x
9
10 similar :: (Similar a) -> a
11 similar (Single _ x) = x
12 similar (Similar _ _ _ y) = y
9 13
10 instance (Eq a) => Eq (Similar a) where 14 instance (Eq a) => Eq (Similar a) where
11 s == ss = (value s) == (value ss) 15 s == ss = (value s) == (value ss)
12 16
13 instance Functor Similar where 17 instance Functor Similar where
19 (Single lf f) <*> (Single lx x) = Single (lf ++ lx) (f x) 23 (Single lf f) <*> (Single lx x) = Single (lf ++ lx) (f x)
20 (Single lf f) <*> (Similar lx x ly y) = Similar (lf ++ lx) (f x) (lf ++ ly) (f y) 24 (Single lf f) <*> (Similar lx x ly y) = Similar (lf ++ lx) (f x) (lf ++ ly) (f y)
21 (Similar lf f lg g) <*> (Single lx x) = Similar (lf ++ lx) (f x) (lg ++ lx) (g x) 25 (Similar lf f lg g) <*> (Single lx x) = Similar (lf ++ lx) (f x) (lg ++ lx) (g x)
22 (Similar lf f lg g) <*> (Similar lx x ly y) = Similar (lf ++ lx) (f x) (lg ++ ly) (g y) 26 (Similar lf f lg g) <*> (Similar lx x ly y) = Similar (lf ++ lx) (f x) (lg ++ ly) (g y)
23 27
24
25
26 mu :: Similar (Similar a) -> Similar a 28 mu :: Similar (Similar a) -> Similar a
27 mu (Single ls (Single lx x)) = Single (ls ++ lx) x 29 mu (Single ls (Single lx x)) = Single (ls ++ lx) x
28 mu (Single ls (Similar lx x ly y)) = Similar (ls ++ lx) x (ls ++ ly) y 30 mu (Single ls (Similar lx x ly y)) = Similar (ls ++ lx) x (ls ++ ly) y
29 mu (Similar lx (Single llx x) ly (Single lly y)) = Similar (lx ++ llx) x (ly ++ lly) y 31 mu (Similar lx (Single llx x) ly (Single lly y)) = Similar (lx ++ llx) x (ly ++ lly) y
30 mu (Similar lx (Similar llx x _ _) ly (Similar _ _ lly y)) = Similar (lx ++ llx) x (lx ++ lly) y 32 mu (Similar lx (Similar llx x _ _) ly (Similar _ _ lly y)) = Similar (lx ++ llx) x (lx ++ lly) y
33 instance Monad Similar where 35 instance Monad Similar where
34 return = Single [] 36 return = Single []
35 s >>= f = mu $ fmap f s 37 s >>= f = mu $ fmap f s
36 38
37 39
38 {-
39
40
41
42 -- samples
43 {-
44
45 generator :: Int -> Similar [Int]
46 generator x = return [1..x]
47
48 primeFilter :: [Int] -> Similar [Int]
49 primeFilter xs = return $ filter isPrime xs
50
51 count :: [Int] -> Similar Int
52 count xs = return $ length xs
53
54 primeCount :: Int -> Int
55 primeCount x = value $ generator x >>= primeFilter >>= count
56 -}
57
58
59 {-
60 same :: (Eq a) => Similar a -> a
61 same (Single x) = x
62 same (Similar x s) = if x == (same s) then x else (error "same")
63
64
65 similar :: Similar a -> Similar a -> Similar a
66 similar (Single x) ss = Similar x ss
67 similar (Similar x s) ss = Similar x (similar s ss)
68
69 instance Functor Similar where
70 fmap f (Single a) = Single (f a)
71 fmap f (Similar a s) = Similar (f a) (fmap f s)
72
73 instance Applicative Similar where
74 pure = Single
75 (Single f) <*> s = fmap f s
76 (Similar f s) <*> ss = similar (fmap f ss) (s <*> ss)
77
78 mu :: (Similar (Similar a)) -> Similar a
79 mu (Single s) = s
80 mu (Similar s ss) = similar s (mu ss)
81
82 40
83 41
84 -- samples 42 -- samples
85 43
86 double :: Int -> Similar Int 44 generator :: Int -> Similar [Int]
87 double x = Single (2 * x) 45 generator x = let intList = [1..x] in
46 Single [(show intList)] intList
88 47
89 twicePlus :: Int -> Similar Int 48 primeFilter :: [Int] -> Similar [Int]
90 twicePlus x = Similar (x + x) (double x) 49 primeFilter xs = let primeList = filter isPrime xs
50 refactorList = filter even xs in
51 Similar [(show primeList)] primeList [(show refactorList)] refactorList
91 52
92 plusTwo :: Int -> Similar Int 53 count :: [Int] -> Similar Int
93 plusTwo x = Similar (x + 2) (double x) 54 count xs = let primeCount = length xs in
55 Single [(show primeCount)] primeCount
94 56
95 -- samples 57 primeCount :: Int -> Similar Int
96 58 primeCount x = generator x >>= primeFilter >>= count
97 {-
98 - Similar as Functor
99 *Main> fmap (double ) (Single 1)
100 Single (Single 2)
101 *Main> fmap (twicePlus) (Single 1)
102 Single (Similar 2 (Single 2))
103 *Main> fmap (plusTwo) (Single 1)
104 Single (Similar 3 (Single 2))
105 *Main> fmap (fmap double) (fmap (plusTwo ) (Single 1))
106 Single (Similar (Single 6) (Single (Single 4)))
107 *Main> same $ fmap same $ fmap (fmap double) (fmap (plusTwo ) (Single 1))
108 *** Exception: same
109 *Main> same $ fmap same $ fmap (fmap double) (fmap (plusTwo ) (Single 2))
110 Single 8
111
112 - Similar as Applicative Functor
113 *Main> Single (\x -> x * x) <*> Single 100
114 Single 10000
115 *Main> Similar (\x -> x * x) (Single (\x -> x * 3)) <*> Single 100
116 Similar 10000 (Single 300)
117 *Main> Similar (\x -> x * x) (Single (\x -> x * 3)) <*> (Similar 100 (Single 200))
118 Similar 10000 (Similar 40000 (Similar 300 (Single 600)))
119
120 - Similar as Monad
121 *Main> return 100 >>= double >>= twicePlus
122 Similar 400 (Single 400)
123 *Main> return 100 >>= double >>= twicePlus >>= plusTwo
124 Similar 402 (Similar 800 (Similar 402 (Single 800)))
125
126 *Main> same $ return 100 >>= double >>= twicePlus >>= plusTwo
127 *** Exception: same
128 *Main> same $ return 100 >>= double >>= twicePlus
129 400
130
131 *Main> same $ return 100 >>= double >>= twicePlus
132 400
133 *Main> same $ return 100 >>= double >>= twicePlus >>= plusTwo
134 *** Exception: same
135 *Main> value $ return 100 >>= double >>= twicePlus >>= plusTwo
136 800
137
138 -}
139 -}
140 -}