Mercurial > hg > Members > atton > delta_monad
diff delta.hs @ 57:dfcd72dc697e
ReDefine Delta used non-empty-list for infinite changes
author | Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp> |
---|---|
date | Sat, 22 Nov 2014 12:29:32 +0900 |
parents | 1e6fecb54f1f |
children | 1229ee398567 |
line wrap: on
line diff
--- a/delta.hs Wed Nov 19 21:09:45 2014 +0900 +++ b/delta.hs Sat Nov 22 12:29:32 2014 +0900 @@ -1,48 +1,39 @@ import Control.Applicative import Data.Numbers.Primes -- $ cabal install primes -type DeltaLog = [String] - -data Delta a = Mono DeltaLog a | Delta DeltaLog a (Delta a) deriving Show - -logAppend :: DeltaLog -> Delta a -> Delta a -logAppend l (Mono lx x) = Mono (l ++ lx) x -logAppend l (Delta lx x d) = Delta (l ++ lx) x (logAppend l d) +data Delta a = Mono a | Delta a (Delta a) deriving Show deltaAppend :: Delta a -> Delta a -> Delta a -deltaAppend (Mono lx x) d = Delta lx x d -deltaAppend (Delta lx x d) ds = Delta lx x (deltaAppend d ds) +deltaAppend (Mono x) d = Delta x d +deltaAppend (Delta x d) ds = Delta x (deltaAppend d ds) headDelta :: Delta a -> Delta a -headDelta d@(Mono _ _) = d -headDelta (Delta lx x _) = Mono lx x +headDelta d@(Mono _) = d +headDelta (Delta x _) = Mono x tailDelta :: Delta a -> Delta a -tailDelta d@(Mono _ _) = d -tailDelta (Delta _ _ ds) = ds +tailDelta d@(Mono _) = d +tailDelta (Delta _ ds) = ds instance Functor Delta where - fmap f (Mono lx x) = Mono lx (f x) - fmap f (Delta lx x d) = Delta lx (f x) (fmap f d) + fmap f (Mono x) = Mono (f x) + fmap f (Delta x d) = Delta (f x) (fmap f d) instance Applicative Delta where - pure f = Mono [] f - (Mono lf f) <*> (Mono lx x) = Mono (lf ++ lx) (f x) - df@(Mono lf f) <*> (Delta lx x d) = Delta (lf ++ lx) (f x) (df <*> d) - (Delta lf f df) <*> d@(Mono lx x) = Delta (lf ++ lx) (f x) (df <*> d) - (Delta lf f df) <*> (Delta lx x d) = Delta (lf ++ lx) (f x) (df <*> d) + pure f = Mono f + (Mono f) <*> (Mono x) = Mono (f x) + df@(Mono f) <*> (Delta x d) = Delta (f x) (df <*> d) + (Delta f df) <*> d@(Mono x) = Delta (f x) (df <*> d) + (Delta f df) <*> (Delta x d) = Delta (f x) (df <*> d) -mu :: Delta (Delta a) -> Delta a -mu (Mono ld d) = logAppend ld d -mu (Delta ld d ds) = (logAppend ld $ headDelta d) `deltaAppend` (mu $ fmap tailDelta ds) - instance Monad Delta where - return x = Mono [] x - d >>= f = mu $ fmap f d + return x = Mono x + (Mono x) >>= f = f x + (Delta x d) >>= f = (headDelta (f x)) `deltaAppend` (d >>= (tailDelta . f)) returnS :: (Show s) => s -> Delta s -returnS x = Mono [(show x)] x +returnS x = Mono x returnSS :: (Show s) => s -> s -> Delta s returnSS x y = (returnS x) `deltaAppend` (returnS y)