src/RMCA/Auxiliary.hs

   1 {-# LANGUAGE Arrows, FlexibleContexts, MultiParamTypeClasses #-}
   2
   3 -- | Auxiliary functions used throughout the code.
   4 module RMCA.Auxiliary where
   5
   6 import           Control.Monad
   7 import           Data.CBMVar
   8 import qualified Data.IntMap        as M
   9 import           Data.Maybe
  10 import           Data.ReactiveValue
  11 import           FRP.Yampa
  12
  13 -- |= General functions
  14
  15
  16 -- | Reversed version of '(\<$\>)'.
  17 (<$$>) :: (Functor f) => f a -> (a -> b) -> f b
  18 (<$$>) = flip (<$>)
  19
  20 -- | Reversed version of '(<$)'.
  21 ($>) :: (Functor f) => f a -> b -> f b
  22 ($>) = flip (<$)
  23
  24 -- | @bound (min,max)@ behaves like identity if the supplied value is between @min@ and @max@, otherwise it is replaced either by @min@ or by @max@.
  25 bound :: (Ord a) => (a, a) -> a -> a
  26 bound (min, max) x
  27   | x < min = min
  28   | x > max = max
  29   | otherwise = x
  30
  31 fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
  32 fromMaybeM_ = fromMaybe (return ())
  33
  34 safeHead :: [a] -> Maybe a
  35 safeHead [] = Nothing
  36 safeHead (x:_) = Just x
  37
  38 safeTail :: [a] -> [a]
  39 safeTail [] = []
  40 safeTail (_:xs) = xs
  41
  42 maybeToEvent :: Maybe a -> Event a
  43 maybeToEvent Nothing = NoEvent
  44 maybeToEvent (Just x) = Event x
  45
  46 eventToMaybe :: Event a -> Maybe a
  47 eventToMaybe NoEvent = Nothing
  48 eventToMaybe (Event x) = Just x
  49
  50 eventToList :: Event [a] -> [a]
  51 eventToList NoEvent = []
  52 eventToList (Event x) = x
  53
  54 -- | Generates an 'Event' if the given condition is 'True'.
  55 eventIf :: Bool -> Event ()
  56 eventIf b = if b then Event () else NoEvent
  57
  58 -- | Generates a 'Just' value if the given condition is 'True'.
  59 maybeIf :: Bool -> Maybe ()
  60 maybeIf b = if b then Just () else Nothing
  61
  62 intersectionWith3 :: (a -> b -> c -> d)
  63                   -> M.IntMap a
  64                   -> M.IntMap b
  65                   -> M.IntMap c
  66                   -> M.IntMap d
  67 intersectionWith3 f m n p =
  68   M.intersectionWith (\x (y,z) -> f x y z) m $ M.intersectionWith (,) n p
  69
  70 -- | = Yampa
  71
  72 countTo :: (Integral b, Ord b) => b -> SF (Event a) (Event b)
  73 countTo n = count >>^ filterE (> n)
  74
  75 -- | 'stepBack' contains its previous argument as its output. Because it's hard to define it at time 0, it's wrapped up in a 'Maybe'.
  76 stepBack :: SF a (Maybe a)
  77 stepBack = sscan f (Nothing, Nothing) >>^ snd
  78   where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
  79         f (Nothing,_) x' = (Just x', Nothing)
  80         f (Just x, _) x' = (Just x', Just x)
  81
  82 -- | Like 'stepBack' but the output value is always defined and is equal to the input at time 0.
  83 stepBack' :: SF a a
  84 stepBack' = proc x -> do
  85   x' <- stepBack -< x
  86   returnA -< fromMaybe x x'
  87
  88 -- | Throws an 'Event' when the incoming signal change. The 'Event' is tagged with the new value.
  89 onChange :: (Eq a) => SF a (Event a)
  90 onChange = proc x -> do
  91   x' <- stepBack -< x
  92   let makeEvent x x'
  93         | isNothing x' = NoEvent
  94         | otherwise = let x'' = fromJust x' in
  95             if x'' == x then NoEvent else Event x
  96   returnA -< makeEvent x x'
  97
  98 -- | Similar to 'onChange' but contains its initial value in the first
  99 -- event.
 100 onChange' :: (Eq a) => SF a (Event a)
 101 onChange' = proc x -> do
 102   x' <- stepBack -< x
 103   -- If it's the first value, throw an Event, else behave like onChange.
 104   let makeEvent x x'
 105         | isNothing x' = Event x
 106         | otherwise = let x'' = fromJust x' in
 107             if x'' == x then NoEvent else Event x
 108   returnA -< makeEvent x x'
 109
 110 -- | Integrates some variable modulo something.
 111 integralMod :: (Real a, VectorSpace a s) => a -> SF a a
 112 integralMod x = intMod' 0
 113   where intMod' x0 = switch (intMod'' x0) (\y -> intMod' (y - x))
 114         intMod'' x0 =  proc t -> do
 115           it <- (+ x0) ^<< integral -< t
 116           es <- edgeBy (\_ y -> maybeIf (y > x) $> y) 0 -< it
 117           returnA -< (it,es)
 118
 119
 120
 121 -- | Generates a sine function whose period is given as a varying input.
 122 varFreqSine :: SF DTime Double
 123 varFreqSine = sin ^<< (2*pi*) ^<< integralMod 1 <<^ (1/)
 124
 125 -- | Generates an 'Event' with a regular period, which is given as an input to the signal function.
 126 repeatedlyS :: a -> SF DTime (Event a)
 127 repeatedlyS x = edgeBy (\a b -> maybeIf (a * b < 0) $> x) 0
 128                 <<< varFreqSine <<^ (2*)
 129
 130 -- |
 131 -- = Auxiliary functions for manipulating reactive values
 132
 133 -- | Creates a new 'CBMVar' wrapped into a reactive field.
 134 newCBMVarRW :: a -> IO (ReactiveFieldReadWrite IO a)
 135 newCBMVarRW val = do
 136   mvar <- newCBMVar val
 137   let getter = readCBMVar mvar
 138       setter = writeCBMVar mvar
 139       notifier = installCallbackCBMVar mvar
 140   return $ ReactiveFieldReadWrite setter getter notifier
 141
 142 -- | Appends a value to a reactive value.
 143 reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
 144                        a -> b -> m ()
 145 reactiveValueAppend rv v = do ov <- reactiveValueRead rv
 146                               reactiveValueWrite rv (ov `mappend` v)
 147
 148 -- | Writes 'mempty' to a reactive value containing a 'Monoid'.
 149 reactiveValueEmpty :: (Monoid b, ReactiveValueReadWrite a b m) =>
 150                       a -> m ()
 151 reactiveValueEmpty rv = reactiveValueWrite rv mempty
 152
 153 -- | Writes a value to a reactive value if the value is different from the one already in the reactive value.
 154 reactiveValueWriteOnNotEq :: ( Eq b
 155                              , ReactiveValueReadWrite a b m) =>
 156                              a -> b -> m ()
 157 reactiveValueWriteOnNotEq rv nv = do
 158   ov <- reactiveValueRead rv
 159   when (ov /= nv) $ reactiveValueWrite rv nv
 160
 161 -- | Relation that will update when the value is an 'Event'.
 162 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
 163          a -> c -> IO ()
 164 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
 165   where  syncOnEvent = do
 166            erv <- reactiveValueRead eventRV
 167            when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
 168
 169 -- | When the reactive value on the left changes, the value on the right is updated using the value it contains and the value on the left with the provided function.
 170 syncRightOnLeftWithBoth :: ( ReactiveValueRead a b m
 171                            , ReactiveValueReadWrite c d m
 172                            ) => (b -> d -> d) -> a -> c -> m ()
 173 syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
 174   nl <- reactiveValueRead l
 175   or <- reactiveValueRead r
 176   reactiveValueWrite r (f nl or)
 177
 178 -- | Forces to update an reactive value by writing to it with the value it contains.
 179 updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
 180 updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
 181
 182 liftW3 :: ( Monad m
 183           , ReactiveValueWrite a b m
 184           , ReactiveValueWrite c d m
 185           , ReactiveValueWrite e f m) =>
 186           (i -> (b,d,f)) -> a -> c -> e -> ReactiveFieldWrite m i
 187 liftW3 f a b c = ReactiveFieldWrite setter
 188   where setter x = do
 189           let (x1,x2,x3) = f x
 190           reactiveValueWrite a x1
 191           reactiveValueWrite b x2
 192           reactiveValueWrite c x3
 193
 194 liftRW3 :: ( ReactiveValueReadWrite a b m
 195            , ReactiveValueReadWrite c d m
 196            , ReactiveValueReadWrite e f m) =>
 197            BijectiveFunc i (b,d,f) -> a -> c -> e -> ReactiveFieldReadWrite m i
 198 liftRW3 bij a b c =
 199   ReactiveFieldReadWrite setter getter notifier
 200   where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
 201         ReactiveFieldWrite setter = liftW3 f1 a b c
 202         (f1, f2) = (direct bij, inverse bij)
 203
 204 liftR4 :: ( ReactiveValueRead a b m
 205           , ReactiveValueRead c d m
 206           , ReactiveValueRead e f m
 207           , ReactiveValueRead g h m) =>
 208           (b -> d -> f -> h -> i) -> a -> c -> e -> g -> ReactiveFieldRead m i
 209 liftR4 f a b c d = ReactiveFieldRead getter notifier
 210   where getter = do
 211           x1 <- reactiveValueRead a
 212           x2 <- reactiveValueRead b
 213           x3 <- reactiveValueRead c
 214           x4 <- reactiveValueRead d
 215           return $ f x1 x2 x3 x4
 216         notifier p = do
 217           reactiveValueOnCanRead a p
 218           reactiveValueOnCanRead b p
 219           reactiveValueOnCanRead c p
 220           reactiveValueOnCanRead d p
 221
 222 liftW4 :: ( Monad m
 223           , ReactiveValueWrite a b m
 224           , ReactiveValueWrite c d m
 225           , ReactiveValueWrite e f m
 226           , ReactiveValueWrite g h m) =>
 227           (i -> (b,d,f,h)) -> a -> c -> e -> g -> ReactiveFieldWrite m i
 228 liftW4 f a b c d = ReactiveFieldWrite setter
 229   where setter x = do
 230           let (x1,x2,x3,x4) = f x
 231           reactiveValueWrite a x1
 232           reactiveValueWrite b x2
 233           reactiveValueWrite c x3
 234           reactiveValueWrite d x4
 235
 236 liftRW4 :: ( ReactiveValueReadWrite a b m
 237            , ReactiveValueReadWrite c d m
 238            , ReactiveValueReadWrite e f m
 239            , ReactiveValueReadWrite g h m) =>
 240            BijectiveFunc i (b,d,f,h) -> a -> c -> e -> g
 241         -> ReactiveFieldReadWrite m i
 242 liftRW4 bij a b c d =
 243   ReactiveFieldReadWrite setter getter notifier
 244   where ReactiveFieldRead getter notifier = liftR4 (curry4 f2) a b c d
 245         ReactiveFieldWrite setter = liftW4 f1 a b c d
 246         (f1, f2) = (direct bij, inverse bij)
 247
 248 liftR5 :: ( ReactiveValueRead a b m
 249           , ReactiveValueRead c d m
 250           , ReactiveValueRead e f m
 251           , ReactiveValueRead g h m
 252           , ReactiveValueRead i j m) =>
 253           (b -> d -> f -> h -> j -> k) -> a -> c -> e -> g -> i
 254        -> ReactiveFieldRead m k
 255 liftR5 f a b c d e = ReactiveFieldRead getter notifier
 256   where getter = do
 257           x1 <- reactiveValueRead a
 258           x2 <- reactiveValueRead b
 259           x3 <- reactiveValueRead c
 260           x4 <- reactiveValueRead d
 261           x5 <- reactiveValueRead e
 262           return $ f x1 x2 x3 x4 x5
 263         notifier p = do
 264           reactiveValueOnCanRead a p
 265           reactiveValueOnCanRead b p
 266           reactiveValueOnCanRead c p
 267           reactiveValueOnCanRead d p
 268           reactiveValueOnCanRead e p
 269
 270 liftW5 :: ( Monad m
 271           , ReactiveValueWrite a b m
 272           , ReactiveValueWrite c d m
 273           , ReactiveValueWrite e f m
 274           , ReactiveValueWrite g h m
 275           , ReactiveValueWrite i j m) =>
 276           (k -> (b,d,f,h,j)) -> a -> c -> e -> g -> i -> ReactiveFieldWrite m k
 277 liftW5 f a b c d e = ReactiveFieldWrite setter
 278   where setter x = do
 279           let (x1,x2,x3,x4,x5) = f x
 280           reactiveValueWrite a x1
 281           reactiveValueWrite b x2
 282           reactiveValueWrite c x3
 283           reactiveValueWrite d x4
 284           reactiveValueWrite e x5
 285
 286 liftRW5 :: ( ReactiveValueReadWrite a b m
 287            , ReactiveValueReadWrite c d m
 288            , ReactiveValueReadWrite e f m
 289            , ReactiveValueReadWrite g h m
 290            , ReactiveValueReadWrite i j m) =>
 291            BijectiveFunc k (b,d,f,h,j) -> a -> c -> e -> g -> i
 292         -> ReactiveFieldReadWrite m k
 293 liftRW5 bij a b c d e =
 294   ReactiveFieldReadWrite setter getter notifier
 295   where ReactiveFieldRead getter notifier = liftR5 (curry5 f2) a b c d e
 296         ReactiveFieldWrite setter = liftW5 f1 a b c d e
 297         (f1, f2) = (direct bij, inverse bij)
 298
 299 -- |
 300 -- = Curry and uncurry functions
 301
 302 curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
 303 curry3 f a b c = f (a,b,c)
 304
 305 uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
 306 uncurry3 f (a,b,c) = f a b c
 307
 308 curry4 :: ((a,b,c,d) -> e) -> a -> b -> c -> d -> e
 309 curry4 f a b c d = f (a,b,c,d)
 310
 311 uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
 312 uncurry4 f (a,b,c,d) = f a b c d
 313
 314 curry5 :: ((a,b,c,d,e) -> f) -> a -> b -> c -> d -> e -> f
 315 curry5 f a b c d e = f (a,b,c,d,e)
 316
 317 uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
 318 uncurry5 f (a,b,c,d,e) = f a b c d e