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