Mercurial > hg > Members > atton > similar_monad

changeset 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
files similar.hs
diffstat 1 files changed, 12 insertions(+), 18 deletions(-) [+]
line wrap: on
line diff
--- a/similar.hs	Mon Sep 22 21:04:32 2014 +0900
+++ b/similar.hs	Mon Sep 22 23:26:51 2014 +0900
@@ -3,33 +3,27 @@
 
 data Similar a = Single [String] a | Similar [String] a [String] a deriving (Show)
 
-original :: (Similar a) -> Similar a
-original (Similar xs x _ _) = Single xs x
-original s                  = s
-
-similar :: (Similar a) -> Similar a
-similar (Similar _ _ ys y) = Single ys y
-similar s                  = s
-
-mergeSimilar :: Similar a -> Similar a -> Similar a
-mergeSimilar (Single xs x) (Single ys y) = Similar xs x ys y
+value :: (Similar a) -> Similar a
+value (Similar xs x _ _) = Single xs x
+value s                  = s
 
 instance (Eq a) => Eq (Similar a) where
-    s == ss = (original s) == (original ss)
+    s == ss = (value s) == (value ss)
 
 instance Functor Similar where
     fmap f (Single xs x)       = Single  xs (f x)
     fmap f (Similar xs x ys y) = Similar xs (f x) ys (f y)
 
-similarLogAppend :: [String] -> Similar a -> Similar a
-similarLogAppend ls (Single xs x)       = Single  (ls ++ xs) x
-similarLogAppend ls (Similar xs x ys y) = Similar (ls ++ xs) x (ls ++ ys) y
-
+mu :: Similar (Similar a) -> Similar a
+mu (Single  ls (Single lx x))                              = Single  (ls ++ lx)  x
+mu (Single  ls (Similar lx x ly y))                        = Similar (ls ++ lx)  x (ls ++ ly)  y
+mu (Similar lx (Single llx x) ly (Single lly y))           = Similar (lx ++ llx) x (ly ++ lly) y
+mu (Similar lx (Similar llx x _ _) ly (Similar _ _ lly y)) = Similar (lx ++ llx) x (lx ++ lly) y
+mu _                                                       = error "Invalid Similar"
 
 instance Monad Similar where
-    return                    = Single []
-    (Single  xs x)      >>= f = similarLogAppend xs (original (f x))
-    (Similar xs x ys y) >>= f = mergeSimilar (similarLogAppend xs (original (f x))) (similarLogAppend ys (similar (f y)))
+    return  = Single []
+    s >>= f = mu $ fmap f s
 
 
 {-