]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Auxiliary.hs
Refactored parallel boards.
[tmp/julm/arpeggigon.git] / src / RMCA / Auxiliary.hs
1 {-# LANGUAGE Arrows, FlexibleContexts, MultiParamTypeClasses #-}
2
3 module RMCA.Auxiliary where
4
5 import Control.Monad
6 import Data.CBMVar
7 import Data.Fixed
8 import Data.Maybe
9 import Data.ReactiveValue
10 import FRP.Yampa
11
12 --------------------------------------------------------------------------------
13 -- General functions
14 --------------------------------------------------------------------------------
15
16 (<$$>) :: (Functor f) => f a -> (a -> b) -> f b
17 (<$$>) = flip (<$>)
18
19 ($>) :: (Functor f) => f a -> b -> f b
20 ($>) = flip (<$)
21
22 bound :: (Ord a) => (a, a) -> a -> a
23 bound (min, max) x
24 | x < min = min
25 | x > max = max
26 | otherwise = x
27
28 fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
29 fromMaybeM_ = fromMaybe (return ())
30
31 safeHead :: [a] -> Maybe a
32 safeHead [] = Nothing
33 safeHead (x:_) = Just x
34
35 safeTail :: [a] -> [a]
36 safeTail [] = []
37 safeTail (_:xs) = xs
38
39 maybeToEvent :: Maybe a -> Event a
40 maybeToEvent Nothing = NoEvent
41 maybeToEvent (Just x) = Event x
42
43 eventToMaybe :: Event a -> Maybe a
44 eventToMaybe NoEvent = Nothing
45 eventToMaybe (Event x) = Just x
46
47 eventToList :: Event [a] -> [a]
48 eventToList NoEvent = []
49 eventToList (Event x) = x
50
51 eventIf :: Bool -> Event ()
52 eventIf b = if b then Event () else NoEvent
53
54 maybeIf :: Bool -> Maybe ()
55 maybeIf b = if b then Just () else Nothing
56
57 --------------------------------------------------------------------------------
58 -- FRP
59 --------------------------------------------------------------------------------
60
61 -- stepBack contains its previous argument as its output. Because it's
62 -- hard to define it at time 0, it's wrapped up in a Maybe.
63 stepBack :: SF a (Maybe a)
64 stepBack = sscan f (Nothing, Nothing) >>^ snd
65 where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
66 f (Nothing,_) x' = (Just x', Nothing)
67 f (Just x, _) x' = (Just x', Just x)
68
69 -- Just like stepBack but the output value is always defined and is
70 -- equal to the input at time 0.
71 stepBack' :: SF a a
72 stepBack' = proc x -> do
73 x' <- stepBack -< x
74 returnA -< fromMaybe x x'
75
76 -- Throws an Event when the incoming signal change. The Event is
77 -- tagged with the new value.
78 onChange :: (Eq a) => SF a (Event a)
79 onChange = proc x -> do
80 x' <- stepBack -< x
81 let makeEvent x x'
82 | isNothing x' = NoEvent
83 | otherwise = let x'' = fromJust x' in
84 if x'' == x then NoEvent else Event x
85 returnA -< makeEvent x x'
86
87 varFreqSine :: SF DTime Double
88 varFreqSine = sin ^<< (2*pi*) ^<< (`mod'` 1) ^<< integral <<^ (1/)
89
90 repeatedlyS :: a -> SF DTime (Event a)
91 repeatedlyS x = edgeBy (\a b -> if a * b < 0 then Just x else Nothing) 0
92 <<< varFreqSine <<^ (2*)
93
94 -- Similar to onChange but contains its initial value in the first
95 -- event.
96 onChange' :: (Eq a) => SF a (Event a)
97 onChange' = proc x -> do
98 x' <- stepBack -< x
99 -- If it's the first value, throw an Event, else behave like onChange.
100 let makeEvent x x'
101 | isNothing x' = Event x
102 | otherwise = let x'' = fromJust x' in
103 if x'' == x then NoEvent else Event x
104 returnA -< makeEvent x x'
105
106 --------------------------------------------------------------------------------
107 -- Reactive Values
108 --------------------------------------------------------------------------------
109
110 newCBMVarRW :: a -> IO (ReactiveFieldReadWrite IO a)
111 newCBMVarRW val = do
112 mvar <- newCBMVar val
113 let getter = readCBMVar mvar
114 setter = writeCBMVar mvar
115 notifier = installCallbackCBMVar mvar
116 return $ ReactiveFieldReadWrite setter getter notifier
117
118 reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
119 a -> b -> m ()
120 reactiveValueAppend rv v = do ov <- reactiveValueRead rv
121 reactiveValueWrite rv (ov `mappend` v)
122
123 reactiveValueEmpty :: (Monoid b, ReactiveValueReadWrite a b m) =>
124 a -> m ()
125 reactiveValueEmpty rv = reactiveValueWrite rv mempty
126
127 reactiveValueWriteOnNotEq :: ( Eq b
128 , ReactiveValueReadWrite a b m) =>
129 a -> b -> m ()
130 reactiveValueWriteOnNotEq rv nv = do
131 ov <- reactiveValueRead rv
132 when (ov /= nv) $ reactiveValueWrite rv nv
133
134 -- Update when the value is an Event. It would be nice to have that
135 -- even for Maybe as well.
136 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
137 a -> c -> IO ()
138 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
139 where syncOnEvent = do
140 erv <- reactiveValueRead eventRV
141 when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
142
143 syncRightOnLeftWithBoth :: ( ReactiveValueRead a b m
144 , ReactiveValueReadWrite c d m
145 ) => (b -> d -> d) -> a -> c -> m ()
146 syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
147 nl <- reactiveValueRead l
148 or <- reactiveValueRead r
149 reactiveValueWrite r (f nl or)
150
151 updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
152 updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
153
154 liftW3 :: ( Monad m
155 , ReactiveValueWrite a b m
156 , ReactiveValueWrite c d m
157 , ReactiveValueWrite e f m) =>
158 (i -> (b,d,f)) -> a -> c -> e -> ReactiveFieldWrite m i
159 liftW3 f a b c = ReactiveFieldWrite setter
160 where setter x = do
161 let (x1,x2,x3) = f x
162 reactiveValueWrite a x1
163 reactiveValueWrite b x2
164 reactiveValueWrite c x3
165
166 liftRW3 :: ( ReactiveValueReadWrite a b m
167 , ReactiveValueReadWrite c d m
168 , ReactiveValueReadWrite e f m) =>
169 BijectiveFunc i (b,d,f) -> a -> c -> e -> ReactiveFieldReadWrite m i
170 liftRW3 bij a b c =
171 ReactiveFieldReadWrite setter getter notifier
172 where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
173 ReactiveFieldWrite setter = liftW3 f1 a b c
174 (f1, f2) = (direct bij, inverse bij)
175
176 liftR4 :: ( ReactiveValueRead a b m
177 , ReactiveValueRead c d m
178 , ReactiveValueRead e f m
179 , ReactiveValueRead g h m) =>
180 (b -> d -> f -> h -> i) -> a -> c -> e -> g -> ReactiveFieldRead m i
181 liftR4 f a b c d = ReactiveFieldRead getter notifier
182 where getter = do
183 x1 <- reactiveValueRead a
184 x2 <- reactiveValueRead b
185 x3 <- reactiveValueRead c
186 x4 <- reactiveValueRead d
187 return $ f x1 x2 x3 x4
188 notifier p = do
189 reactiveValueOnCanRead a p
190 reactiveValueOnCanRead b p
191 reactiveValueOnCanRead c p
192 reactiveValueOnCanRead d p
193
194 liftW4 :: ( Monad m
195 , ReactiveValueWrite a b m
196 , ReactiveValueWrite c d m
197 , ReactiveValueWrite e f m
198 , ReactiveValueWrite g h m) =>
199 (i -> (b,d,f,h)) -> a -> c -> e -> g -> ReactiveFieldWrite m i
200 liftW4 f a b c d = ReactiveFieldWrite setter
201 where setter x = do
202 let (x1,x2,x3,x4) = f x
203 reactiveValueWrite a x1
204 reactiveValueWrite b x2
205 reactiveValueWrite c x3
206 reactiveValueWrite d x4
207
208 liftRW4 :: ( ReactiveValueReadWrite a b m
209 , ReactiveValueReadWrite c d m
210 , ReactiveValueReadWrite e f m
211 , ReactiveValueReadWrite g h m) =>
212 BijectiveFunc i (b,d,f,h) -> a -> c -> e -> g
213 -> ReactiveFieldReadWrite m i
214 liftRW4 bij a b c d =
215 ReactiveFieldReadWrite setter getter notifier
216 where ReactiveFieldRead getter notifier = liftR4 (curry4 f2) a b c d
217 ReactiveFieldWrite setter = liftW4 f1 a b c d
218 (f1, f2) = (direct bij, inverse bij)
219
220 liftR5 :: ( ReactiveValueRead a b m
221 , ReactiveValueRead c d m
222 , ReactiveValueRead e f m
223 , ReactiveValueRead g h m
224 , ReactiveValueRead i j m) =>
225 (b -> d -> f -> h -> j -> k) -> a -> c -> e -> g -> i
226 -> ReactiveFieldRead m k
227 liftR5 f a b c d e = ReactiveFieldRead getter notifier
228 where getter = do
229 x1 <- reactiveValueRead a
230 x2 <- reactiveValueRead b
231 x3 <- reactiveValueRead c
232 x4 <- reactiveValueRead d
233 x5 <- reactiveValueRead e
234 return $ f x1 x2 x3 x4 x5
235 notifier p = do
236 reactiveValueOnCanRead a p
237 reactiveValueOnCanRead b p
238 reactiveValueOnCanRead c p
239 reactiveValueOnCanRead d p
240 reactiveValueOnCanRead e p
241
242 liftW5 :: ( Monad m
243 , ReactiveValueWrite a b m
244 , ReactiveValueWrite c d m
245 , ReactiveValueWrite e f m
246 , ReactiveValueWrite g h m
247 , ReactiveValueWrite i j m) =>
248 (k -> (b,d,f,h,j)) -> a -> c -> e -> g -> i -> ReactiveFieldWrite m k
249 liftW5 f a b c d e = ReactiveFieldWrite setter
250 where setter x = do
251 let (x1,x2,x3,x4,x5) = f x
252 reactiveValueWrite a x1
253 reactiveValueWrite b x2
254 reactiveValueWrite c x3
255 reactiveValueWrite d x4
256 reactiveValueWrite e x5
257
258 liftRW5 :: ( ReactiveValueReadWrite a b m
259 , ReactiveValueReadWrite c d m
260 , ReactiveValueReadWrite e f m
261 , ReactiveValueReadWrite g h m
262 , ReactiveValueReadWrite i j m) =>
263 BijectiveFunc k (b,d,f,h,j) -> a -> c -> e -> g -> i
264 -> ReactiveFieldReadWrite m k
265 liftRW5 bij a b c d e =
266 ReactiveFieldReadWrite setter getter notifier
267 where ReactiveFieldRead getter notifier = liftR5 (curry5 f2) a b c d e
268 ReactiveFieldWrite setter = liftW5 f1 a b c d e
269 (f1, f2) = (direct bij, inverse bij)
270
271 --------------------------------------------------------------------------------
272 -- Curry and uncurry functions
273 --------------------------------------------------------------------------------
274
275 curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
276 curry3 f a b c = f (a,b,c)
277
278 uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
279 uncurry3 f (a,b,c) = f a b c
280
281 curry4 :: ((a,b,c,d) -> e) -> a -> b -> c -> d -> e
282 curry4 f a b c d = f (a,b,c,d)
283
284 uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
285 uncurry4 f (a,b,c,d) = f a b c d
286
287 curry5 :: ((a,b,c,d,e) -> f) -> a -> b -> c -> d -> e -> f
288 curry5 f a b c d e = f (a,b,c,d,e)
289
290 uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
291 uncurry5 f (a,b,c,d,e) = f a b c d e