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