1 {-# LANGUAGE Arrows, FlexibleContexts, MultiParamTypeClasses #-}
3 -- | Auxiliary functions used throughout the code.
4 module RMCA.Auxiliary where
8 import qualified Data.IntMap as M
10 import Data.ReactiveValue
13 -- |= General functions
16 -- | Reversed version of '(\<$\>)'.
17 (<$$>) :: (Functor f) => f a -> (a -> b) -> f b
20 -- | Reversed version of '(<$)'.
21 ($>) :: (Functor f) => f a -> b -> f b
24 -- | @bound (min,max)@ behaves like identity if the supplied value is between @min@ and @max@, otherwise it is replaced either by @min@ or by @max@.
25 bound :: (Ord a) => (a, a) -> a -> a
31 fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
32 fromMaybeM_ = fromMaybe (return ())
34 safeHead :: [a] -> Maybe a
36 safeHead (x:_) = Just x
38 safeTail :: [a] -> [a]
42 maybeToEvent :: Maybe a -> Event a
43 maybeToEvent Nothing = NoEvent
44 maybeToEvent (Just x) = Event x
46 eventToMaybe :: Event a -> Maybe a
47 eventToMaybe NoEvent = Nothing
48 eventToMaybe (Event x) = Just x
50 eventToList :: Event [a] -> [a]
51 eventToList NoEvent = []
52 eventToList (Event x) = x
54 -- | Generates an 'Event' if the given condition is 'True'.
55 eventIf :: Bool -> Event ()
56 eventIf b = if b then Event () else NoEvent
58 -- | Generates a 'Just' value if the given condition is 'True'.
59 maybeIf :: Bool -> Maybe ()
60 maybeIf b = if b then Just () else Nothing
62 intersectionWith3 :: (a -> b -> c -> d)
67 intersectionWith3 f m n p =
68 M.intersectionWith (\x (y,z) -> f x y z) m $ M.intersectionWith (,) n p
72 countTo :: (Integral b) => b -> SF (Event a) (Event b)
73 countTo n = count >>^ filterE (> n)
75 -- | 'stepBack' contains its previous argument as its output. Because it's hard to define it at time 0, it's wrapped up in a 'Maybe'.
76 stepBack :: SF a (Maybe a)
77 stepBack = sscan f (Nothing, Nothing) >>^ snd
78 where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
79 f (Nothing,_) x' = (Just x', Nothing)
80 f (Just x, _) x' = (Just x', Just x)
82 -- | Like 'stepBack' but the output value is always defined and is equal to the input at time 0.
84 stepBack' = proc x -> do
86 returnA -< fromMaybe x x'
88 -- | Throws an 'Event' when the incoming signal change. The 'Event' is tagged with the new value.
89 onChange :: (Eq a) => SF a (Event a)
90 onChange = proc x -> do
93 | isNothing x' = NoEvent
94 | otherwise = let x'' = fromJust x' in
95 if x'' == x then NoEvent else Event x
96 returnA -< makeEvent x x'
98 -- | Similar to 'onChange' but contains its initial value in the first
100 onChange' :: (Eq a) => SF a (Event a)
101 onChange' = proc x -> do
103 -- If it's the first value, throw an Event, else behave like onChange.
105 | isNothing x' = Event x
106 | otherwise = let x'' = fromJust x' in
107 if x'' == x then NoEvent else Event x
108 returnA -< makeEvent x x'
110 -- | Integrates some variable modulo something.
111 integralMod :: (Real a, VectorSpace a s) => a -> SF a a
112 integralMod x = intMod' 0
113 where intMod' x0 = switch (intMod'' x0) (\y -> intMod' (y - x))
114 intMod'' x0 = proc t -> do
115 it <- (+ x0) ^<< integral -< t
116 es <- edgeBy (\_ y -> maybeIf (y > x) $> y) 0 -< it
121 -- | Generates a sine function whose period is given as a varying input.
122 varFreqSine :: SF DTime Double
123 varFreqSine = sin ^<< (2*pi*) ^<< integralMod 1 <<^ (1/)
125 -- | Generates an 'Event' with a regular period, which is given as an input to the signal function.
126 repeatedlyS :: a -> SF DTime (Event a)
127 repeatedlyS x = edgeBy (\a b -> maybeIf (a * b < 0) $> x) 0
128 <<< varFreqSine <<^ (2*)
131 -- = Auxiliary functions for manipulating reactive values
133 -- | Creates a new 'CBMVar' wrapped into a reactive field.
134 newCBMVarRW :: a -> IO (ReactiveFieldReadWrite IO a)
136 mvar <- newCBMVar val
137 let getter = readCBMVar mvar
138 setter = writeCBMVar mvar
139 notifier = installCallbackCBMVar mvar
140 return $ ReactiveFieldReadWrite setter getter notifier
142 -- | Writes a value to a reactive value if the value is different from the one already in the reactive value.
143 reactiveValueWriteOnNotEq :: ( Eq b
144 , ReactiveValueReadWrite a b m) =>
146 reactiveValueWriteOnNotEq rv nv = do
147 ov <- reactiveValueRead rv
148 when (ov /= nv) $ reactiveValueWrite rv nv
150 -- | Relation that will update when the value is an 'Event'.
151 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
153 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
154 where syncOnEvent = do
155 erv <- reactiveValueRead eventRV
156 when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
158 -- | When the reactive value on the left changes, the value on the right is updated using the value it contains and the value on the left with the provided function.
159 syncRightOnLeftWithBoth :: ( ReactiveValueRead a b m
160 , ReactiveValueReadWrite c d m
161 ) => (b -> d -> d) -> a -> c -> m ()
162 syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
163 nl <- reactiveValueRead l
164 or <- reactiveValueRead r
165 reactiveValueWrite r (f nl or)
167 -- | Forces to update an reactive value by writing to it with the value it contains.
168 updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
169 updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
172 , ReactiveValueWrite a b m
173 , ReactiveValueWrite c d m
174 , ReactiveValueWrite e f m) =>
175 (i -> (b,d,f)) -> a -> c -> e -> ReactiveFieldWrite m i
176 liftW3 f a b c = ReactiveFieldWrite setter
179 reactiveValueWrite a x1
180 reactiveValueWrite b x2
181 reactiveValueWrite c x3
183 liftRW3 :: ( ReactiveValueReadWrite a b m
184 , ReactiveValueReadWrite c d m
185 , ReactiveValueReadWrite e f m) =>
186 BijectiveFunc i (b,d,f) -> a -> c -> e -> ReactiveFieldReadWrite m i
188 ReactiveFieldReadWrite setter getter notifier
189 where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
190 ReactiveFieldWrite setter = liftW3 f1 a b c
191 (f1, f2) = (direct bij, inverse bij)
193 liftR4 :: ( ReactiveValueRead a b m
194 , ReactiveValueRead c d m
195 , ReactiveValueRead e f m
196 , ReactiveValueRead g h m) =>
197 (b -> d -> f -> h -> i) -> a -> c -> e -> g -> ReactiveFieldRead m i
198 liftR4 f a b c d = ReactiveFieldRead getter notifier
200 x1 <- reactiveValueRead a
201 x2 <- reactiveValueRead b
202 x3 <- reactiveValueRead c
203 x4 <- reactiveValueRead d
204 return $ f x1 x2 x3 x4
206 reactiveValueOnCanRead a p
207 reactiveValueOnCanRead b p
208 reactiveValueOnCanRead c p
209 reactiveValueOnCanRead d p
212 , ReactiveValueWrite a b m
213 , ReactiveValueWrite c d m
214 , ReactiveValueWrite e f m
215 , ReactiveValueWrite g h m) =>
216 (i -> (b,d,f,h)) -> a -> c -> e -> g -> ReactiveFieldWrite m i
217 liftW4 f a b c d = ReactiveFieldWrite setter
219 let (x1,x2,x3,x4) = f x
220 reactiveValueWrite a x1
221 reactiveValueWrite b x2
222 reactiveValueWrite c x3
223 reactiveValueWrite d x4
225 liftRW4 :: ( ReactiveValueReadWrite a b m
226 , ReactiveValueReadWrite c d m
227 , ReactiveValueReadWrite e f m
228 , ReactiveValueReadWrite g h m) =>
229 BijectiveFunc i (b,d,f,h) -> a -> c -> e -> g
230 -> ReactiveFieldReadWrite m i
231 liftRW4 bij a b c d =
232 ReactiveFieldReadWrite setter getter notifier
233 where ReactiveFieldRead getter notifier = liftR4 (curry4 f2) a b c d
234 ReactiveFieldWrite setter = liftW4 f1 a b c d
235 (f1, f2) = (direct bij, inverse bij)
237 liftR5 :: ( ReactiveValueRead a b m
238 , ReactiveValueRead c d m
239 , ReactiveValueRead e f m
240 , ReactiveValueRead g h m
241 , ReactiveValueRead i j m) =>
242 (b -> d -> f -> h -> j -> k) -> a -> c -> e -> g -> i
243 -> ReactiveFieldRead m k
244 liftR5 f a b c d e = ReactiveFieldRead getter notifier
246 x1 <- reactiveValueRead a
247 x2 <- reactiveValueRead b
248 x3 <- reactiveValueRead c
249 x4 <- reactiveValueRead d
250 x5 <- reactiveValueRead e
251 return $ f x1 x2 x3 x4 x5
253 reactiveValueOnCanRead a p
254 reactiveValueOnCanRead b p
255 reactiveValueOnCanRead c p
256 reactiveValueOnCanRead d p
257 reactiveValueOnCanRead e p
260 , ReactiveValueWrite a b m
261 , ReactiveValueWrite c d m
262 , ReactiveValueWrite e f m
263 , ReactiveValueWrite g h m
264 , ReactiveValueWrite i j m) =>
265 (k -> (b,d,f,h,j)) -> a -> c -> e -> g -> i -> ReactiveFieldWrite m k
266 liftW5 f a b c d e = ReactiveFieldWrite setter
268 let (x1,x2,x3,x4,x5) = f x
269 reactiveValueWrite a x1
270 reactiveValueWrite b x2
271 reactiveValueWrite c x3
272 reactiveValueWrite d x4
273 reactiveValueWrite e x5
275 liftRW5 :: ( ReactiveValueReadWrite a b m
276 , ReactiveValueReadWrite c d m
277 , ReactiveValueReadWrite e f m
278 , ReactiveValueReadWrite g h m
279 , ReactiveValueReadWrite i j m) =>
280 BijectiveFunc k (b,d,f,h,j) -> a -> c -> e -> g -> i
281 -> ReactiveFieldReadWrite m k
282 liftRW5 bij a b c d e =
283 ReactiveFieldReadWrite setter getter notifier
284 where ReactiveFieldRead getter notifier = liftR5 (curry5 f2) a b c d e
285 ReactiveFieldWrite setter = liftW5 f1 a b c d e
286 (f1, f2) = (direct bij, inverse bij)
289 -- = Curry and uncurry functions
291 curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
292 curry3 f a b c = f (a,b,c)
294 uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
295 uncurry3 f (a,b,c) = f a b c
297 curry4 :: ((a,b,c,d) -> e) -> a -> b -> c -> d -> e
298 curry4 f a b c d = f (a,b,c,d)
300 uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
301 uncurry4 f (a,b,c,d) = f a b c d
303 curry5 :: ((a,b,c,d,e) -> f) -> a -> b -> c -> d -> e -> f
304 curry5 f a b c d e = f (a,b,c,d,e)
306 uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
307 uncurry5 f (a,b,c,d,e) = f a b c d e