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