]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Auxiliary/RV.hs
Playheads all correct.
[tmp/julm/arpeggigon.git] / RMCA / Auxiliary / RV.hs
1 {-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
2
3 module RMCA.Auxiliary.RV where
4
5 import Data.CBMVar
6 import Data.ReactiveValue
7 import FRP.Yampa
8 import Control.Monad
9 import RMCA.Auxiliary.Curry
10
11 newCBMVarRW :: forall a. a -> IO (ReactiveFieldReadWrite IO a)
12 newCBMVarRW val = do
13 mvar <- newCBMVar val
14 let getter :: IO a
15 getter = readCBMVar mvar
16 setter :: a -> IO ()
17 setter = writeCBMVar mvar
18 notifier :: IO () -> IO ()
19 notifier = installCallbackCBMVar mvar
20 return $ ReactiveFieldReadWrite setter getter notifier
21
22 emptyRW :: (Monoid b, ReactiveValueReadWrite a b m) => a -> m b
23 emptyRW rv = do
24 val <- reactiveValueRead rv
25 reactiveValueWrite rv mempty
26 return val
27
28 emptyW :: (Monoid b, ReactiveValueWrite a b m) => a -> m ()
29 emptyW rv = reactiveValueWrite rv mempty
30
31 onTick :: (ReactiveValueRead a b m, ReactiveValueRead c d m) =>
32 a -> c -> ReactiveFieldRead m d
33 onTick notif rv = ReactiveFieldRead getter notifier
34 where getter = reactiveValueRead rv
35 notifier cb = do
36 reactiveValueOnCanRead notif cb
37 reactiveValueOnCanRead rv cb
38 {-
39 notif ^:> rv =
40 reactiveValueOnCanRead notif (reactiveValueOnCanRead rv (return ()))
41 -}
42 -- Update when the value is an Event. It would be nice to have that
43 -- even for Maybe as well.
44 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
45 a -> c -> IO ()
46 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
47 where syncOnEvent = do
48 erv <- reactiveValueRead eventRV
49 when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
50 {-
51 liftR3 :: ( Monad m
52 , ReactiveValueRead a b m
53 , ReactiveValueRead c d m
54 , ReactiveValueRead e f m) =>
55 ((b,d,f) -> i)
56 -> a
57 -> c
58 -> e
59 -> ReactiveFieldRead m i
60 liftR3 f a b c = ReactiveFieldRead getter notifier
61 where getter = do
62 x1 <- reactiveValueRead a
63 x2 <- reactiveValueRead b
64 x3 <- reactiveValueRead c
65 return $ f (x1, x2, x3)
66 notifier p = reactiveValueOnCanRead a p >>
67 reactiveValueOnCanRead b p >>
68 reactiveValueOnCanRead c p
69 -}
70
71 liftW3 :: ( Monad m
72 , ReactiveValueWrite a b m
73 , ReactiveValueWrite c d m
74 , ReactiveValueWrite e f m) =>
75 (i -> (b,d,f))
76 -> a
77 -> c
78 -> e
79 -> ReactiveFieldWrite m i
80 liftW3 f a b c = ReactiveFieldWrite setter
81 where setter x = do
82 let (x1,x2,x3) = f x
83 reactiveValueWrite a x1
84 reactiveValueWrite b x2
85 reactiveValueWrite c x3
86
87 liftRW3 :: ( Monad m
88 , ReactiveValueReadWrite a b m
89 , ReactiveValueReadWrite c d m
90 , ReactiveValueReadWrite e f m) =>
91 BijectiveFunc i (b,d,f)
92 -> a
93 -> c
94 -> e
95 -> ReactiveFieldReadWrite m i
96 liftRW3 bij a b c =
97 ReactiveFieldReadWrite setter getter notifier
98 where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
99 ReactiveFieldWrite setter = liftW3 f1 a b c
100 (f1, f2) = (direct bij, inverse bij)
101
102 liftR4 :: ( Monad m
103 , ReactiveValueRead a b m
104 , ReactiveValueRead c d m
105 , ReactiveValueRead e f m
106 , ReactiveValueRead g h m) =>
107 ((b,d,f,h) -> i)
108 -> a
109 -> c
110 -> e
111 -> g
112 -> ReactiveFieldRead m i
113 liftR4 f a b c d = ReactiveFieldRead getter notifier
114 where getter = do
115 x1 <- reactiveValueRead a
116 x2 <- reactiveValueRead b
117 x3 <- reactiveValueRead c
118 x4 <- reactiveValueRead d
119 return $ f (x1, x2, x3, x4)
120 notifier p = do
121 reactiveValueOnCanRead a p
122 reactiveValueOnCanRead b p
123 reactiveValueOnCanRead c p
124 reactiveValueOnCanRead d p
125
126 liftW4 :: ( Monad m
127 , ReactiveValueWrite a b m
128 , ReactiveValueWrite c d m
129 , ReactiveValueWrite e f m
130 , ReactiveValueWrite g h m) =>
131 (i -> (b,d,f,h))
132 -> a
133 -> c
134 -> e
135 -> g
136 -> ReactiveFieldWrite m i
137 liftW4 f a b c d = ReactiveFieldWrite setter
138 where setter x = do
139 let (x1,x2,x3,x4) = f x
140 reactiveValueWrite a x1
141 reactiveValueWrite b x2
142 reactiveValueWrite c x3
143 reactiveValueWrite d x4
144
145 liftRW4 :: ( Monad m
146 , ReactiveValueReadWrite a b m
147 , ReactiveValueReadWrite c d m
148 , ReactiveValueReadWrite e f m
149 , ReactiveValueReadWrite g h m) =>
150 BijectiveFunc i (b,d,f,h)
151 -> a
152 -> c
153 -> e
154 -> g
155 -> ReactiveFieldReadWrite m i
156 liftRW4 bij a b c d =
157 ReactiveFieldReadWrite setter getter notifier
158 where ReactiveFieldRead getter notifier = liftR4 f2 a b c d
159 ReactiveFieldWrite setter = liftW4 f1 a b c d
160 (f1, f2) = (direct bij, inverse bij)