Mercurial > hg > Members > atton > delta_monad
comparison delta.hs @ 52:69a01cc80075
Define Delta for Infinite changes in Haskell
author | Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp> |
---|---|
date | Wed, 19 Nov 2014 13:33:37 +0900 |
parents | 8d9c55bac8b2 |
children | 1e6fecb54f1f |
comparison
equal
deleted
inserted
replaced
51:8d9c55bac8b2 | 52:69a01cc80075 |
---|---|
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 Delta a = Delta [String] a [String] a | 4 type DeltaLog = [String] |
5 | 5 |
6 instance (Show a) => Show (Delta a) where | 6 data Delta a = Mono DeltaLog a | Delta DeltaLog a (Delta a) deriving Show |
7 show (Delta lx x ly y) = values ++ logs | |
8 where | |
9 values = "Delta {" ++ (show x) ++ "|" ++ (show y) ++ "}\n" | |
10 logs = concat . reverse $ zipWith formatter lx ly | |
11 formatter x y = " {" ++ x ++ (separator x y) ++ y ++ "}\n" | |
12 separator x y = if (max (length x) (length y)) > 50 then "|\n " else "|" | |
13 | 7 |
14 value :: (Delta a) -> a | 8 logAppend :: DeltaLog -> Delta a -> Delta a |
15 value (Delta _ x _ _) = x | 9 logAppend l (Mono lx x) = Mono (l ++ lx) x |
10 logAppend l (Delta lx x d) = Delta (l ++ lx) x (logAppend l d) | |
16 | 11 |
17 deltaLeft :: (Delta a) -> a | 12 deltaAppend :: Delta a -> Delta a -> Delta a |
18 deltaLeft (Delta _ x _ _) = x | 13 deltaAppend (Mono lx x) d = Delta lx x d |
14 deltaAppend (Delta lx x d) ds = Delta lx x (deltaAppend d ds) | |
19 | 15 |
20 deltaRight :: (Delta a) -> a | 16 firstDelta :: Delta a -> Delta a |
21 deltaRight (Delta _ _ _ y) = y | 17 firstDelta d@(Mono _ _) = d |
18 firstDelta (Delta lx x _) = Mono lx x | |
22 | 19 |
23 instance (Eq a) => Eq (Delta a) where | 20 tailDelta :: Delta a -> Delta a |
24 s == ss = (value s) == (value ss) | 21 tailDelta d@(Mono _ _) = d |
22 tailDelta (Delta _ _ ds) = ds | |
25 | 23 |
26 instance Functor Delta where | 24 instance Functor Delta where |
27 fmap f (Delta xs x ys y) = Delta xs (f x) ys (f y) | 25 fmap f (Mono lx x) = Mono lx (f x) |
26 fmap f (Delta lx x d) = Delta lx (f x) (fmap f d) | |
28 | 27 |
29 instance Applicative Delta where | 28 instance Applicative Delta where |
30 pure f = Delta [] f [] f | 29 pure f = Mono [] f |
31 (Delta lf f lg g) <*> (Delta lx x ly y) = Delta (lf ++ lx) (f x) (lg ++ ly) (g y) | 30 (Mono lf f) <*> (Mono lx x) = Mono (lf ++ lx) (f x) |
31 df@(Mono lf f) <*> (Delta lx x d) = Delta (lf ++ lx) (f x) (df <*> d) | |
32 (Delta lf f df) <*> d@(Mono lx x) = Delta (lf ++ lx) (f x) (df <*> d) | |
33 (Delta lf f df) <*> (Delta lx x d) = Delta (lf ++ lx) (f x) (df <*> d) | |
34 | |
32 | 35 |
33 mu :: Delta (Delta a) -> Delta a | 36 mu :: Delta (Delta a) -> Delta a |
34 mu (Delta lx (Delta llx x _ _) ly (Delta _ _ lly y)) = Delta (lx ++ llx) x (ly ++ lly) y | 37 mu (Mono ld d) = logAppend ld d |
38 mu (Delta ld d ds) = (logAppend ld $ firstDelta d) `deltaAppend` (mu $ fmap tailDelta ds) | |
35 | 39 |
36 instance Monad Delta where | 40 instance Monad Delta where |
37 return x = Delta [] x [] x | 41 return x = Mono [] x |
38 s >>= f = mu $ fmap f s | 42 d >>= f = mu $ fmap f d |
39 | |
40 | 43 |
41 returnS :: (Show s) => s -> Delta s | 44 returnS :: (Show s) => s -> Delta s |
42 returnS x = Delta [(show x)] x [(show x)] x | 45 returnS x = Mono [(show x)] x |
43 | 46 |
44 returnSS :: (Show s) => s -> s -> Delta s | 47 returnSS :: (Show s) => s -> s -> Delta s |
45 returnSS x y = Delta [(show x)] x [(show y)] y | 48 returnSS x y = (returnS x) `deltaAppend` (returnS y) |
49 | |
46 | 50 |
47 -- samples | 51 -- samples |
48 | 52 |
49 generator :: Int -> Delta [Int] | 53 generator :: Int -> Delta [Int] |
50 generator x = let intList = [1..x] in | 54 generator x = let intList = [1..x] in |