]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Auxiliary/ReactiveValue.hs
Equality test when setting play heads.
[tmp/julm/arpeggigon.git] / src / RMCA / Auxiliary / ReactiveValue.hs
1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
2
3 module RMCA.Auxiliary.ReactiveValue where
4
5 import Control.Monad
6 import Data.CBMVar
7 import Data.CBRef
8 import Data.ReactiveValue
9 import FRP.Yampa
10 import RMCA.Auxiliary.Misc
11
12 -- |
13 -- = Auxiliary functions for manipulating reactive values
14
15 -- | Creates a new 'CBMVar' wrapped into a reactive field.
16 newCBMVarRW :: a -> IO (ReactiveFieldReadWrite IO a)
17 newCBMVarRW val = do
18 mvar <- newCBMVar val
19 let getter = readCBMVar mvar
20 setter = writeCBMVar mvar
21 notifier = installCallbackCBMVar mvar
22 return $ ReactiveFieldReadWrite setter getter notifier
23
24 -- | Writes a value to a reactive value if the value is different from the one already in the reactive value.
25 reactiveValueWriteOnNotEq :: ( Eq b
26 , ReactiveValueReadWrite a b m) =>
27 a -> b -> m ()
28 reactiveValueWriteOnNotEq rv nv = do
29 ov <- reactiveValueRead rv
30 when (ov /= nv) $ reactiveValueWrite rv nv
31
32 -- | Relation that will update when the value is an 'Event'.
33 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
34 a -> c -> IO ()
35 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
36 where syncOnEvent = do
37 erv <- reactiveValueRead eventRV
38 when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
39
40 -- | 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.
41 syncRightOnLeftWithBoth :: ( ReactiveValueRead a b m
42 , ReactiveValueReadWrite c d m
43 ) => (b -> d -> d) -> a -> c -> m ()
44 syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
45 nl <- reactiveValueRead l
46 or <- reactiveValueRead r
47 reactiveValueWrite r (f nl or)
48
49 -- | Forces to update an reactive value by writing to it with the value it contains.
50 updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
51 updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
52
53 floatConv :: (ReactiveValueReadWrite a b m,
54 Real c, Real b, Fractional c, Fractional b) =>
55 a -> ReactiveFieldReadWrite m c
56 floatConv = liftRW $ bijection (realToFrac, realToFrac)
57
58 swapHandlerStorage :: (ReactiveValueReadWrite a b IO) =>
59 a -> IO (ReactiveFieldReadWrite IO b)
60 swapHandlerStorage rv = do
61 ioref <- newCBRef ()
62 let setter val = reactiveValueWrite rv val >> writeCBRef ioref ()
63 getter = reactiveValueRead rv
64 notifier = installCallbackCBRef ioref
65 return $ ReactiveFieldReadWrite setter getter notifier
66
67 liftW3 :: ( Monad m
68 , ReactiveValueWrite a b m
69 , ReactiveValueWrite c d m
70 , ReactiveValueWrite e f m) =>
71 (i -> (b,d,f)) -> a -> c -> e -> ReactiveFieldWrite m i
72 liftW3 f a b c = ReactiveFieldWrite setter
73 where setter x = do
74 let (x1,x2,x3) = f x
75 reactiveValueWrite a x1
76 reactiveValueWrite b x2
77 reactiveValueWrite c x3
78
79 liftRW3 :: ( ReactiveValueReadWrite a b m
80 , ReactiveValueReadWrite c d m
81 , ReactiveValueReadWrite e f m) =>
82 BijectiveFunc i (b,d,f) -> a -> c -> e -> ReactiveFieldReadWrite m i
83 liftRW3 bij a b c =
84 ReactiveFieldReadWrite setter getter notifier
85 where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
86 ReactiveFieldWrite setter = liftW3 f1 a b c
87 (f1, f2) = (direct bij, inverse bij)
88
89 liftR4 :: ( ReactiveValueRead a b m
90 , ReactiveValueRead c d m
91 , ReactiveValueRead e f m
92 , ReactiveValueRead g h m) =>
93 (b -> d -> f -> h -> i) -> a -> c -> e -> g -> ReactiveFieldRead m i
94 liftR4 f a b c d = ReactiveFieldRead getter notifier
95 where getter = do
96 x1 <- reactiveValueRead a
97 x2 <- reactiveValueRead b
98 x3 <- reactiveValueRead c
99 x4 <- reactiveValueRead d
100 return $ f x1 x2 x3 x4
101 notifier p = do
102 reactiveValueOnCanRead a p
103 reactiveValueOnCanRead b p
104 reactiveValueOnCanRead c p
105 reactiveValueOnCanRead d p
106
107 liftW4 :: ( Monad m
108 , ReactiveValueWrite a b m
109 , ReactiveValueWrite c d m
110 , ReactiveValueWrite e f m
111 , ReactiveValueWrite g h m) =>
112 (i -> (b,d,f,h)) -> a -> c -> e -> g -> ReactiveFieldWrite m i
113 liftW4 f a b c d = ReactiveFieldWrite setter
114 where setter x = do
115 let (x1,x2,x3,x4) = f x
116 reactiveValueWrite a x1
117 reactiveValueWrite b x2
118 reactiveValueWrite c x3
119 reactiveValueWrite d x4
120
121 liftRW4 :: ( ReactiveValueReadWrite a b m
122 , ReactiveValueReadWrite c d m
123 , ReactiveValueReadWrite e f m
124 , ReactiveValueReadWrite g h m) =>
125 BijectiveFunc i (b,d,f,h) -> a -> c -> e -> g
126 -> ReactiveFieldReadWrite m i
127 liftRW4 bij a b c d =
128 ReactiveFieldReadWrite setter getter notifier
129 where ReactiveFieldRead getter notifier = liftR4 (curry4 f2) a b c d
130 ReactiveFieldWrite setter = liftW4 f1 a b c d
131 (f1, f2) = (direct bij, inverse bij)
132
133 liftR5 :: ( ReactiveValueRead a b m
134 , ReactiveValueRead c d m
135 , ReactiveValueRead e f m
136 , ReactiveValueRead g h m
137 , ReactiveValueRead i j m) =>
138 (b -> d -> f -> h -> j -> k) -> a -> c -> e -> g -> i
139 -> ReactiveFieldRead m k
140 liftR5 f a b c d e = ReactiveFieldRead getter notifier
141 where getter = do
142 x1 <- reactiveValueRead a
143 x2 <- reactiveValueRead b
144 x3 <- reactiveValueRead c
145 x4 <- reactiveValueRead d
146 x5 <- reactiveValueRead e
147 return $ f x1 x2 x3 x4 x5
148 notifier p = do
149 reactiveValueOnCanRead a p
150 reactiveValueOnCanRead b p
151 reactiveValueOnCanRead c p
152 reactiveValueOnCanRead d p
153 reactiveValueOnCanRead e p
154
155 liftW5 :: ( Monad m
156 , ReactiveValueWrite a b m
157 , ReactiveValueWrite c d m
158 , ReactiveValueWrite e f m
159 , ReactiveValueWrite g h m
160 , ReactiveValueWrite i j m) =>
161 (k -> (b,d,f,h,j)) -> a -> c -> e -> g -> i -> ReactiveFieldWrite m k
162 liftW5 f a b c d e = ReactiveFieldWrite setter
163 where setter x = do
164 let (x1,x2,x3,x4,x5) = f x
165 reactiveValueWrite a x1
166 reactiveValueWrite b x2
167 reactiveValueWrite c x3
168 reactiveValueWrite d x4
169 reactiveValueWrite e x5
170
171 liftRW5 :: ( ReactiveValueReadWrite a b m
172 , ReactiveValueReadWrite c d m
173 , ReactiveValueReadWrite e f m
174 , ReactiveValueReadWrite g h m
175 , ReactiveValueReadWrite i j m) =>
176 BijectiveFunc k (b,d,f,h,j) -> a -> c -> e -> g -> i
177 -> ReactiveFieldReadWrite m k
178 liftRW5 bij a b c d e =
179 ReactiveFieldReadWrite setter getter notifier
180 where ReactiveFieldRead getter notifier = liftR5 (curry5 f2) a b c d e
181 ReactiveFieldWrite setter = liftW5 f1 a b c d e
182 (f1, f2) = (direct bij, inverse bij)