Mercurial > hg > Members > atton > delta_monad
comparison similar.hs @ 21:af8754322ed4
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 -} |