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 -- | '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'.
  73 stepBack :: SF a (Maybe a)
  74 stepBack = sscan f (Nothing, Nothing) >>^ snd
  75   where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
  76         f (Nothing,_) x' = (Just x', Nothing)
  77         f (Just x, _) x' = (Just x', Just x)
  78
  79 -- | Like 'stepBack' but the output value is always defined and is equal to the input at time 0.
  80 stepBack' :: SF a a
  81 stepBack' = proc x -> do
  82   x' <- stepBack -< x
  83   returnA -< fromMaybe x x'
  84
  85 -- | Throws an 'Event' when the incoming signal change. The 'Event' is tagged with the new value.
  86 onChange :: (Eq a) => SF a (Event a)
  87 onChange = proc x -> do
  88   x' <- stepBack -< x
  89   let makeEvent x x'
  90         | isNothing x' = NoEvent
  91         | otherwise = let x'' = fromJust x' in
  92             if x'' == x then NoEvent else Event x
  93   returnA -< makeEvent x x'
  94
  95 -- | Similar to 'onChange' but contains its initial value in the first
  96 -- event.
  97 onChange' :: (Eq a) => SF a (Event a)
  98 onChange' = proc x -> do
  99   x' <- stepBack -< x
 100   -- If it's the first value, throw an Event, else behave like onChange.
 101   let makeEvent x x'
 102         | isNothing x' = Event x
 103         | otherwise = let x'' = fromJust x' in
 104             if x'' == x then NoEvent else Event x
 105   returnA -< makeEvent x x'
 106
 107 -- | Integrates some variable modulo something.
 108 integralMod :: (Real a, VectorSpace a s) => a -> SF a a
 109 integralMod x = intMod' 0
 110   where intMod' x0 = switch (intMod'' x0) (\y -> intMod' (y - x))
 111         intMod'' x0 =  proc t -> do
 112           it <- (+ x0) ^<< integral -< t
 113           es <- edgeBy (\_ y -> maybeIf (y > x) $> y) 0 -< it
 114           returnA -< (it,es)
 115
 116
 117
 118 -- | Generates a sine function whose period is given as a varying input.
 119 varFreqSine :: SF DTime Double
 120 varFreqSine = sin ^<< (2*pi*) ^<< integralMod 1 <<^ (1/)
 121
 122 -- | Generates an 'Event' with a regular period, which is given as an input to the signal function.
 123 repeatedlyS :: a -> SF DTime (Event a)
 124 repeatedlyS x = edgeBy (\a b -> maybeIf (a * b < 0) $> x) 0
 125                 <<< varFreqSine <<^ (2*)
 126
 127 -- |
 128 -- = Auxiliary functions for manipulating reactive values
 129
 130 -- | Creates a new 'CBMVar' wrapped into a reactive field.
 131 newCBMVarRW :: a -> IO (ReactiveFieldReadWrite IO a)
 132 newCBMVarRW val = do
 133   mvar <- newCBMVar val
 134   let getter = readCBMVar mvar
 135       setter = writeCBMVar mvar
 136       notifier = installCallbackCBMVar mvar
 137   return $ ReactiveFieldReadWrite setter getter notifier
 138
 139 -- | Appends a value to a reactive value.
 140 reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
 141                        a -> b -> m ()
 142 reactiveValueAppend rv v = do ov <- reactiveValueRead rv
 143                               reactiveValueWrite rv (ov `mappend` v)
 144
 145 -- | Writes 'mempty' to a reactive value containing a 'Monoid'.
 146 reactiveValueEmpty :: (Monoid b, ReactiveValueReadWrite a b m) =>
 147                       a -> m ()
 148 reactiveValueEmpty rv = reactiveValueWrite rv mempty
 149
 150 -- | Writes a value to a reactive value if the value is different from the one already in the reactive value.
 151 reactiveValueWriteOnNotEq :: ( Eq b
 152                              , ReactiveValueReadWrite a b m) =>
 153                              a -> b -> m ()
 154 reactiveValueWriteOnNotEq rv nv = do
 155   ov <- reactiveValueRead rv
 156   when (ov /= nv) $ reactiveValueWrite rv nv
 157
 158 -- | Relation that will update when the value is an 'Event'.
 159 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
 160          a -> c -> IO ()
 161 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
 162   where  syncOnEvent = do
 163            erv <- reactiveValueRead eventRV
 164            when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
 165
 166 -- | 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.
 167 syncRightOnLeftWithBoth :: ( ReactiveValueRead a b m
 168                            , ReactiveValueReadWrite c d m
 169                            ) => (b -> d -> d) -> a -> c -> m ()
 170 syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
 171   nl <- reactiveValueRead l
 172   or <- reactiveValueRead r
 173   reactiveValueWrite r (f nl or)
 174
 175 -- | Forces to update an reactive value by writing to it with the value it contains.
 176 updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
 177 updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
 178
 179 liftW3 :: ( Monad m
 180           , ReactiveValueWrite a b m
 181           , ReactiveValueWrite c d m
 182           , ReactiveValueWrite e f m) =>
 183           (i -> (b,d,f)) -> a -> c -> e -> ReactiveFieldWrite m i
 184 liftW3 f a b c = ReactiveFieldWrite setter
 185   where setter x = do
 186           let (x1,x2,x3) = f x
 187           reactiveValueWrite a x1
 188           reactiveValueWrite b x2
 189           reactiveValueWrite c x3
 190
 191 liftRW3 :: ( ReactiveValueReadWrite a b m
 192            , ReactiveValueReadWrite c d m
 193            , ReactiveValueReadWrite e f m) =>
 194            BijectiveFunc i (b,d,f) -> a -> c -> e -> ReactiveFieldReadWrite m i
 195 liftRW3 bij a b c =
 196   ReactiveFieldReadWrite setter getter notifier
 197   where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
 198         ReactiveFieldWrite setter = liftW3 f1 a b c
 199         (f1, f2) = (direct bij, inverse bij)
 200
 201 liftR4 :: ( ReactiveValueRead a b m
 202           , ReactiveValueRead c d m
 203           , ReactiveValueRead e f m
 204           , ReactiveValueRead g h m) =>
 205           (b -> d -> f -> h -> i) -> a -> c -> e -> g -> ReactiveFieldRead m i
 206 liftR4 f a b c d = ReactiveFieldRead getter notifier
 207   where getter = do
 208           x1 <- reactiveValueRead a
 209           x2 <- reactiveValueRead b
 210           x3 <- reactiveValueRead c
 211           x4 <- reactiveValueRead d
 212           return $ f x1 x2 x3 x4
 213         notifier p = do
 214           reactiveValueOnCanRead a p
 215           reactiveValueOnCanRead b p
 216           reactiveValueOnCanRead c p
 217           reactiveValueOnCanRead d p
 218
 219 liftW4 :: ( Monad m
 220           , ReactiveValueWrite a b m
 221           , ReactiveValueWrite c d m
 222           , ReactiveValueWrite e f m
 223           , ReactiveValueWrite g h m) =>
 224           (i -> (b,d,f,h)) -> a -> c -> e -> g -> ReactiveFieldWrite m i
 225 liftW4 f a b c d = ReactiveFieldWrite setter
 226   where setter x = do
 227           let (x1,x2,x3,x4) = f x
 228           reactiveValueWrite a x1
 229           reactiveValueWrite b x2
 230           reactiveValueWrite c x3
 231           reactiveValueWrite d x4
 232
 233 liftRW4 :: ( ReactiveValueReadWrite a b m
 234            , ReactiveValueReadWrite c d m
 235            , ReactiveValueReadWrite e f m
 236            , ReactiveValueReadWrite g h m) =>
 237            BijectiveFunc i (b,d,f,h) -> a -> c -> e -> g
 238         -> ReactiveFieldReadWrite m i
 239 liftRW4 bij a b c d =
 240   ReactiveFieldReadWrite setter getter notifier
 241   where ReactiveFieldRead getter notifier = liftR4 (curry4 f2) a b c d
 242         ReactiveFieldWrite setter = liftW4 f1 a b c d
 243         (f1, f2) = (direct bij, inverse bij)
 244
 245 liftR5 :: ( ReactiveValueRead a b m
 246           , ReactiveValueRead c d m
 247           , ReactiveValueRead e f m
 248           , ReactiveValueRead g h m
 249           , ReactiveValueRead i j m) =>
 250           (b -> d -> f -> h -> j -> k) -> a -> c -> e -> g -> i
 251        -> ReactiveFieldRead m k
 252 liftR5 f a b c d e = ReactiveFieldRead getter notifier
 253   where getter = do
 254           x1 <- reactiveValueRead a
 255           x2 <- reactiveValueRead b
 256           x3 <- reactiveValueRead c
 257           x4 <- reactiveValueRead d
 258           x5 <- reactiveValueRead e
 259           return $ f x1 x2 x3 x4 x5
 260         notifier p = do
 261           reactiveValueOnCanRead a p
 262           reactiveValueOnCanRead b p
 263           reactiveValueOnCanRead c p
 264           reactiveValueOnCanRead d p
 265           reactiveValueOnCanRead e p
 266
 267 liftW5 :: ( Monad m
 268           , ReactiveValueWrite a b m
 269           , ReactiveValueWrite c d m
 270           , ReactiveValueWrite e f m
 271           , ReactiveValueWrite g h m
 272           , ReactiveValueWrite i j m) =>
 273           (k -> (b,d,f,h,j)) -> a -> c -> e -> g -> i -> ReactiveFieldWrite m k
 274 liftW5 f a b c d e = ReactiveFieldWrite setter
 275   where setter x = do
 276           let (x1,x2,x3,x4,x5) = f x
 277           reactiveValueWrite a x1
 278           reactiveValueWrite b x2
 279           reactiveValueWrite c x3
 280           reactiveValueWrite d x4
 281           reactiveValueWrite e x5
 282
 283 liftRW5 :: ( ReactiveValueReadWrite a b m
 284            , ReactiveValueReadWrite c d m
 285            , ReactiveValueReadWrite e f m
 286            , ReactiveValueReadWrite g h m
 287            , ReactiveValueReadWrite i j m) =>
 288            BijectiveFunc k (b,d,f,h,j) -> a -> c -> e -> g -> i
 289         -> ReactiveFieldReadWrite m k
 290 liftRW5 bij a b c d e =
 291   ReactiveFieldReadWrite setter getter notifier
 292   where ReactiveFieldRead getter notifier = liftR5 (curry5 f2) a b c d e
 293         ReactiveFieldWrite setter = liftW5 f1 a b c d e
 294         (f1, f2) = (direct bij, inverse bij)
 295
 296 -- |
 297 -- = Curry and uncurry functions
 298
 299 curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
 300 curry3 f a b c = f (a,b,c)
 301
 302 uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
 303 uncurry3 f (a,b,c) = f a b c
 304
 305 curry4 :: ((a,b,c,d) -> e) -> a -> b -> c -> d -> e
 306 curry4 f a b c d = f (a,b,c,d)
 307
 308 uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
 309 uncurry4 f (a,b,c,d) = f a b c d
 310
 311 curry5 :: ((a,b,c,d,e) -> f) -> a -> b -> c -> d -> e -> f
 312 curry5 f a b c d e = f (a,b,c,d,e)
 313
 314 uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
 315 uncurry5 f (a,b,c,d,e) = f a b c d e