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