Mercurial > hg > Members > atton > delta_monad

comparison haskell/delta.hs @ 133:7984c9f4b5eb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Create directory for haskell codes
author Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp>
date Fri, 06 Feb 2015 16:00:09 +0900
parents delta.hs@f2187ad63791
children 3f48bd08865f
comparison
equal deleted inserted replaced
132:2412ccc94117 133:7984c9f4b5eb
1 import Control.Applicative
2 import Control.Monad.Writer
3 import Data.Numbers.Primes -- $ cabal install primes
4
5 -- Delta definition
6
7 data Delta a = Mono a | Delta a (Delta a) deriving Show
8
9 instance (Eq a) => Eq (Delta a) where
10 (Mono x) == (Mono y) = x == y
11 (Mono _) == (Delta _ _) = False
12 (Delta x xs) == (Delta y ys) = (x == y) && (xs == ys)
13
14 -- basic functions
15
16 deltaAppend :: Delta a -> Delta a -> Delta a
17 deltaAppend (Mono x) d = Delta x d
18 deltaAppend (Delta x d) ds = Delta x (deltaAppend d ds)
19
20 headDelta :: Delta a -> a
21 headDelta (Mono x) = x
22 headDelta (Delta x _) = x
23
24 tailDelta :: Delta a -> Delta a
25 tailDelta d@(Mono _) = d
26 tailDelta (Delta _ ds) = ds
27
28 -- instance definitions
29
30 instance Functor Delta where
31 fmap f (Mono x) = Mono (f x)
32 fmap f (Delta x d) = Delta (f x) (fmap f d)
33
34 instance Applicative Delta where
35 pure f = Mono f
36 (Mono f) <*> (Mono x) = Mono (f x)
37 df@(Mono f) <*> (Delta x d) = Delta (f x) (df <*> d)
38 (Delta f df) <*> d@(Mono x) = Delta (f x) (df <*> d)
39 (Delta f df) <*> (Delta x d) = Delta (f x) (df <*> d)
40
41 bind :: (Delta a) -> (a -> Delta b) -> (Delta b)
42 bind (Mono x) f = f x
43 bind (Delta x d) f = Delta (headDelta (f x)) (bind d (tailDelta . f))
44
45 mu :: (Delta (Delta a)) -> (Delta a)
46 mu d = bind d id
47
48 instance Monad Delta where
49 return x = Mono x
50 d >>= f = mu $ fmap f d
51
52 -- utils
53
54 returnDD :: (Show s) => s -> s -> Delta s
55 returnDD x y = (return x) `deltaAppend` (return y)
56
57 deltaFromList :: [a] -> Delta a
58 deltaFromList = (foldl1 deltaAppend) . (fmap return)
59
60
61 -- samples
62
63 generator :: Int -> Delta [Int]
64 generator x = let intList = [1..x] in
65 return intList
66
67 primeFilter :: [Int] -> Delta [Int]
68 primeFilter xs = let primeList = filter isPrime xs
69 refactorList = filter even xs in
70 returnDD primeList refactorList
71
72 count :: [Int] -> Delta Int
73 count xs = let primeCount = length xs in
74 return primeCount
75
76 primeCount :: Int -> Delta Int
77 primeCount x = generator x >>= primeFilter >>= count
78
79 bubbleSort :: [Int] -> Delta [Int]
80 bubbleSort [] = return []
81 bubbleSort xs = bubbleSort remainValue >>= (\xs -> returnDD (sortedValueL : xs)
82 (sortedValueR ++ xs))
83 where
84 maximumValue = maximum xs
85 sortedValueL = maximumValue
86 sortedValueR = replicate (length $ filter (== maximumValue) xs) maximumValue
87 remainValue = filter (/= maximumValue) xs
88
89
90
91 -- DeltaM definition (Delta with Monad)
92
93 data DeltaM m a = DeltaM (Delta (m a)) deriving (Show)
94
95
96 -- DeltaM utils
97
98 unDeltaM :: DeltaM m a -> Delta (m a)
99 unDeltaM (DeltaM d) = d
100
101 headDeltaM :: DeltaM m a -> m a
102 headDeltaM (DeltaM d) = headDelta d
103
104 tailDeltaM :: DeltaM m a -> DeltaM m a
105 tailDeltaM (DeltaM d) = DeltaM $ tailDelta d
106
107 appendDeltaM :: DeltaM m a -> DeltaM m a -> DeltaM m a
108 appendDeltaM (DeltaM d) (DeltaM dd) = DeltaM (deltaAppend d dd)
109
110 checkOut :: Int -> DeltaM m a -> m a
111 checkOut 0 (DeltaM (Mono x)) = x
112 checkOut 0 (DeltaM (Delta x _)) = x
113 checkOut n (DeltaM (Mono x)) = x
114 checkOut n (DeltaM (Delta _ d)) = checkOut (n-1) (DeltaM d)
115
116
117 -- DeltaM instance definitions
118
119 instance (Functor m) => Functor (DeltaM m) where
120 fmap f (DeltaM d) = DeltaM $ fmap (fmap f) d
121
122 instance (Applicative m) => Applicative (DeltaM m) where
123 pure f = DeltaM $ Mono $ pure f
124 (DeltaM (Mono f)) <*> (DeltaM (Mono x)) = DeltaM $ Mono $ f <*> x
125 df@(DeltaM (Mono f)) <*> (DeltaM (Delta x d)) = appendDeltaM (DeltaM $ Mono $ f <*> x) (df <*> (DeltaM d))
126 (DeltaM (Delta f df)) <*> dx@(DeltaM (Mono x)) = appendDeltaM (DeltaM $ Mono $ f <*> x) ((DeltaM df) <*> dx)
127 (DeltaM (Delta f df)) <*> (DeltaM (Delta x dx)) = appendDeltaM (DeltaM $ Mono $ f <*> x) ((DeltaM df) <*> (DeltaM dx))
128
129
130 mu' :: (Functor m, Monad m) => DeltaM m (DeltaM m a) -> DeltaM m a
131 mu' d@(DeltaM (Mono _)) = DeltaM $ Mono $ (>>= id) $ fmap headDeltaM $ headDeltaM d
132 mu' d@(DeltaM (Delta _ _)) = DeltaM $ Delta ((>>= id) $ fmap headDeltaM $ headDeltaM d)
133 (unDeltaM (mu' (fmap tailDeltaM (tailDeltaM d))))
134
135 instance (Functor m, Monad m) => Monad (DeltaM m) where
136 return x = DeltaM $ Mono $ return x
137 d >>= f = mu' $ fmap f d
138
139
140
141 -- DeltaM examples
142
143 -- DeltaM example utils
144 type DeltaLog = Writer [String]
145 type DeltaWithLog = DeltaM DeltaLog
146
147 returnW :: (Show a) => a -> DeltaLog a
148 returnW x = do tell $ [show x]
149 return x
150
151 dmap :: (m a -> b) -> DeltaM m a -> Delta b
152 dmap f (DeltaM d) = fmap f d
153
154 deltaWithLogFromList :: (Show a) => [a] -> DeltaWithLog a
155 deltaWithLogFromList xs = DeltaM $ deltaFromList $ fmap returnW xs
156
157
158 -- example : prime filter
159 -- usage : runWriter $ checkOut 0 $ primeCountM 30 -- run specific version
160 -- : dmap runWriter $ primeCountM 30 -- run all version
161
162 generatorM :: Int -> DeltaWithLog [Int]
163 generatorM x = let intList = [1..x] in
164 DeltaM $ deltaFromList $ fmap returnW $ replicate 2 intList
165
166 primeFilterM :: [Int] -> DeltaWithLog [Int]
167 primeFilterM xs = let primeList = filter isPrime xs
168 refactorList = filter even xs in
169 DeltaM $ deltaFromList $ fmap returnW [primeList, refactorList]
170
171
172 countM :: [Int] -> DeltaWithLog Int
173 countM xs = let primeCount = length xs in
174 DeltaM $ deltaFromList $ fmap returnW $ replicate 2 primeCount
175
176 primeCountM :: Int -> DeltaWithLog Int
177 primeCountM x = generatorM x >>= primeFilterM >>= countM