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