1 {-# LANGUAGE Arrows, FlexibleContexts, MultiParamTypeClasses #-}
3 module RMCA.Auxiliary where
9 import Data.ReactiveValue
12 --------------------------------------------------------------------------------
14 --------------------------------------------------------------------------------
16 (<$$>) :: (Functor f) => f a -> (a -> b) -> f b
19 ($>) :: (Functor f) => f a -> b -> f b
22 bound :: (Ord a) => (a, a) -> a -> a
28 fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
29 fromMaybeM_ = fromMaybe (return ())
31 safeHead :: [a] -> Maybe a
33 safeHead (x:_) = Just x
35 safeTail :: [a] -> [a]
39 maybeToEvent :: Maybe a -> Event a
40 maybeToEvent Nothing = NoEvent
41 maybeToEvent (Just x) = Event x
43 eventToMaybe :: Event a -> Maybe a
44 eventToMaybe NoEvent = Nothing
45 eventToMaybe (Event x) = Just x
47 eventToList :: Event [a] -> [a]
48 eventToList NoEvent = []
49 eventToList (Event x) = x
51 eventIf :: Bool -> Event ()
52 eventIf b = if b then Event () else NoEvent
54 maybeIf :: Bool -> Maybe ()
55 maybeIf b = if b then Just () else Nothing
57 --------------------------------------------------------------------------------
59 --------------------------------------------------------------------------------
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)
69 -- Just like stepBack but the output value is always defined and is
70 -- equal to the input at time 0.
72 stepBack' = proc x -> do
74 returnA -< fromMaybe x x'
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
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'
87 varFreqSine :: SF DTime Double
88 varFreqSine = sin ^<< (2*pi*) ^<< (`mod'` 1) ^<< integral <<^ (1/)
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*)
94 -- Similar to onChange but contains its initial value in the first
96 onChange' :: (Eq a) => SF a (Event a)
97 onChange' = proc x -> do
99 -- If it's the first value, throw an Event, else behave like onChange.
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'
106 --------------------------------------------------------------------------------
108 --------------------------------------------------------------------------------
110 newCBMVarRW :: a -> IO (ReactiveFieldReadWrite IO a)
112 mvar <- newCBMVar val
113 let getter = readCBMVar mvar
114 setter = writeCBMVar mvar
115 notifier = installCallbackCBMVar mvar
116 return $ ReactiveFieldReadWrite setter getter notifier
118 reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
120 reactiveValueAppend rv v = do ov <- reactiveValueRead rv
121 reactiveValueWrite rv (ov `mappend` v)
123 reactiveValueEmpty :: (Monoid b, ReactiveValueReadWrite a b m) =>
125 reactiveValueEmpty rv = reactiveValueWrite rv mempty
127 reactiveValueWriteOnNotEq :: ( Eq b
128 , ReactiveValueReadWrite a b m) =>
130 reactiveValueWriteOnNotEq rv nv = do
131 ov <- reactiveValueRead rv
132 when (ov /= nv) $ reactiveValueWrite rv nv
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) =>
138 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
139 where syncOnEvent = do
140 erv <- reactiveValueRead eventRV
141 when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
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)
151 updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
152 updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
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
162 reactiveValueWrite a x1
163 reactiveValueWrite b x2
164 reactiveValueWrite c x3
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
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)
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
183 x1 <- reactiveValueRead a
184 x2 <- reactiveValueRead b
185 x3 <- reactiveValueRead c
186 x4 <- reactiveValueRead d
187 return $ f x1 x2 x3 x4
189 reactiveValueOnCanRead a p
190 reactiveValueOnCanRead b p
191 reactiveValueOnCanRead c p
192 reactiveValueOnCanRead d p
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
202 let (x1,x2,x3,x4) = f x
203 reactiveValueWrite a x1
204 reactiveValueWrite b x2
205 reactiveValueWrite c x3
206 reactiveValueWrite d x4
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)
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
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
236 reactiveValueOnCanRead a p
237 reactiveValueOnCanRead b p
238 reactiveValueOnCanRead c p
239 reactiveValueOnCanRead d p
240 reactiveValueOnCanRead e p
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
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
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)
271 --------------------------------------------------------------------------------
272 -- Curry and uncurry functions
273 --------------------------------------------------------------------------------
275 curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
276 curry3 f a b c = f (a,b,c)
278 uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
279 uncurry3 f (a,b,c) = f a b c
281 curry4 :: ((a,b,c,d) -> e) -> a -> b -> c -> d -> e
282 curry4 f a b c d = f (a,b,c,d)
284 uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
285 uncurry4 f (a,b,c,d) = f a b c d
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)
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