Mercurial > hg > Members > atton > delta_monad

comparison similar.hs @ 19:003b6e58d815

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Define Similar as Monad by mu
author Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp>
date Mon, 22 Sep 2014 23:26:51 +0900
parents c77397d0677f
children d4aa70d94352
comparison
equal deleted inserted replaced
18:c77397d0677f 19:003b6e58d815
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 original :: (Similar a) -> Similar a 6 value :: (Similar a) -> Similar a
7 original (Similar xs x _ _) = Single xs x 7 value (Similar xs x _ _) = Single xs x
8 original s = s 8 value s = s
9
10 similar :: (Similar a) -> Similar a
11 similar (Similar _ _ ys y) = Single ys y
12 similar s = s
13
14 mergeSimilar :: Similar a -> Similar a -> Similar a
15 mergeSimilar (Single xs x) (Single ys y) = Similar xs x ys y
16 9
17 instance (Eq a) => Eq (Similar a) where 10 instance (Eq a) => Eq (Similar a) where
18 s == ss = (original s) == (original ss) 11 s == ss = (value s) == (value ss)
19 12
20 instance Functor Similar where 13 instance Functor Similar where
21 fmap f (Single xs x) = Single xs (f x) 14 fmap f (Single xs x) = Single xs (f x)
22 fmap f (Similar xs x ys y) = Similar xs (f x) ys (f y) 15 fmap f (Similar xs x ys y) = Similar xs (f x) ys (f y)
23 16
24 similarLogAppend :: [String] -> Similar a -> Similar a 17 mu :: Similar (Similar a) -> Similar a
25 similarLogAppend ls (Single xs x) = Single (ls ++ xs) x 18 mu (Single ls (Single lx x)) = Single (ls ++ lx) x
26 similarLogAppend ls (Similar xs x ys y) = Similar (ls ++ xs) x (ls ++ ys) y 19 mu (Single ls (Similar lx x ly y)) = Similar (ls ++ lx) x (ls ++ ly) y
27 20 mu (Similar lx (Single llx x) ly (Single lly y)) = Similar (lx ++ llx) x (ly ++ lly) y
21 mu (Similar lx (Similar llx x _ _) ly (Similar _ _ lly y)) = Similar (lx ++ llx) x (lx ++ lly) y
22 mu _ = error "Invalid Similar"
28 23
29 instance Monad Similar where 24 instance Monad Similar where
30 return = Single [] 25 return = Single []
31 (Single xs x) >>= f = similarLogAppend xs (original (f x)) 26 s >>= f = mu $ fmap f s
32 (Similar xs x ys y) >>= f = mergeSimilar (similarLogAppend xs (original (f x))) (similarLogAppend ys (similar (f y)))
33 27
34 28
35 {- 29 {-
36 30
37 31