# HG changeset patch
# User Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp>
# Date 1411396011 -32400
# Node ID 003b6e58d815a399e2c9004aef9d1ea6e3b7e54b
# Parent  c77397d0677f8a5f3a071d5541df7e92f8549c4a
Define Similar as Monad by mu

diff -r c77397d0677f -r 003b6e58d815 similar.hs
--- 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
 
 
 {-