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) => 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 -- | Writes a value to a reactive value if the value is different from the one already in the reactive value.
 143 reactiveValueWriteOnNotEq :: ( Eq b
 144                              , ReactiveValueReadWrite a b m) =>
 145                              a -> b -> m ()
 146 reactiveValueWriteOnNotEq rv nv = do
 147   ov <- reactiveValueRead rv
 148   when (ov /= nv) $ reactiveValueWrite rv nv
 149
 150 -- | Relation that will update when the value is an 'Event'.
 151 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
 152          a -> c -> IO ()
 153 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
 154   where  syncOnEvent = do
 155            erv <- reactiveValueRead eventRV
 156            when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
 157
 158 -- | 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.
 159 syncRightOnLeftWithBoth :: ( ReactiveValueRead a b m
 160                            , ReactiveValueReadWrite c d m
 161                            ) => (b -> d -> d) -> a -> c -> m ()
 162 syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
 163   nl <- reactiveValueRead l
 164   or <- reactiveValueRead r
 165   reactiveValueWrite r (f nl or)
 166
 167 -- | Forces to update an reactive value by writing to it with the value it contains.
 168 updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
 169 updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
 170
 171 liftW3 :: ( Monad m
 172           , ReactiveValueWrite a b m
 173           , ReactiveValueWrite c d m
 174           , ReactiveValueWrite e f m) =>
 175           (i -> (b,d,f)) -> a -> c -> e -> ReactiveFieldWrite m i
 176 liftW3 f a b c = ReactiveFieldWrite setter
 177   where setter x = do
 178           let (x1,x2,x3) = f x
 179           reactiveValueWrite a x1
 180           reactiveValueWrite b x2
 181           reactiveValueWrite c x3
 182
 183 liftRW3 :: ( ReactiveValueReadWrite a b m
 184            , ReactiveValueReadWrite c d m
 185            , ReactiveValueReadWrite e f m) =>
 186            BijectiveFunc i (b,d,f) -> a -> c -> e -> ReactiveFieldReadWrite m i
 187 liftRW3 bij a b c =
 188   ReactiveFieldReadWrite setter getter notifier
 189   where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
 190         ReactiveFieldWrite setter = liftW3 f1 a b c
 191         (f1, f2) = (direct bij, inverse bij)
 192
 193 liftR4 :: ( ReactiveValueRead a b m
 194           , ReactiveValueRead c d m
 195           , ReactiveValueRead e f m
 196           , ReactiveValueRead g h m) =>
 197           (b -> d -> f -> h -> i) -> a -> c -> e -> g -> ReactiveFieldRead m i
 198 liftR4 f a b c d = ReactiveFieldRead getter notifier
 199   where getter = do
 200           x1 <- reactiveValueRead a
 201           x2 <- reactiveValueRead b
 202           x3 <- reactiveValueRead c
 203           x4 <- reactiveValueRead d
 204           return $ f x1 x2 x3 x4
 205         notifier p = do
 206           reactiveValueOnCanRead a p
 207           reactiveValueOnCanRead b p
 208           reactiveValueOnCanRead c p
 209           reactiveValueOnCanRead d p
 210
 211 liftW4 :: ( Monad m
 212           , ReactiveValueWrite a b m
 213           , ReactiveValueWrite c d m
 214           , ReactiveValueWrite e f m
 215           , ReactiveValueWrite g h m) =>
 216           (i -> (b,d,f,h)) -> a -> c -> e -> g -> ReactiveFieldWrite m i
 217 liftW4 f a b c d = ReactiveFieldWrite setter
 218   where setter x = do
 219           let (x1,x2,x3,x4) = f x
 220           reactiveValueWrite a x1
 221           reactiveValueWrite b x2
 222           reactiveValueWrite c x3
 223           reactiveValueWrite d x4
 224
 225 liftRW4 :: ( ReactiveValueReadWrite a b m
 226            , ReactiveValueReadWrite c d m
 227            , ReactiveValueReadWrite e f m
 228            , ReactiveValueReadWrite g h m) =>
 229            BijectiveFunc i (b,d,f,h) -> a -> c -> e -> g
 230         -> ReactiveFieldReadWrite m i
 231 liftRW4 bij a b c d =
 232   ReactiveFieldReadWrite setter getter notifier
 233   where ReactiveFieldRead getter notifier = liftR4 (curry4 f2) a b c d
 234         ReactiveFieldWrite setter = liftW4 f1 a b c d
 235         (f1, f2) = (direct bij, inverse bij)
 236
 237 liftR5 :: ( ReactiveValueRead a b m
 238           , ReactiveValueRead c d m
 239           , ReactiveValueRead e f m
 240           , ReactiveValueRead g h m
 241           , ReactiveValueRead i j m) =>
 242           (b -> d -> f -> h -> j -> k) -> a -> c -> e -> g -> i
 243        -> ReactiveFieldRead m k
 244 liftR5 f a b c d e = ReactiveFieldRead getter notifier
 245   where getter = do
 246           x1 <- reactiveValueRead a
 247           x2 <- reactiveValueRead b
 248           x3 <- reactiveValueRead c
 249           x4 <- reactiveValueRead d
 250           x5 <- reactiveValueRead e
 251           return $ f x1 x2 x3 x4 x5
 252         notifier p = do
 253           reactiveValueOnCanRead a p
 254           reactiveValueOnCanRead b p
 255           reactiveValueOnCanRead c p
 256           reactiveValueOnCanRead d p
 257           reactiveValueOnCanRead e p
 258
 259 liftW5 :: ( Monad m
 260           , ReactiveValueWrite a b m
 261           , ReactiveValueWrite c d m
 262           , ReactiveValueWrite e f m
 263           , ReactiveValueWrite g h m
 264           , ReactiveValueWrite i j m) =>
 265           (k -> (b,d,f,h,j)) -> a -> c -> e -> g -> i -> ReactiveFieldWrite m k
 266 liftW5 f a b c d e = ReactiveFieldWrite setter
 267   where setter x = do
 268           let (x1,x2,x3,x4,x5) = f x
 269           reactiveValueWrite a x1
 270           reactiveValueWrite b x2
 271           reactiveValueWrite c x3
 272           reactiveValueWrite d x4
 273           reactiveValueWrite e x5
 274
 275 liftRW5 :: ( ReactiveValueReadWrite a b m
 276            , ReactiveValueReadWrite c d m
 277            , ReactiveValueReadWrite e f m
 278            , ReactiveValueReadWrite g h m
 279            , ReactiveValueReadWrite i j m) =>
 280            BijectiveFunc k (b,d,f,h,j) -> a -> c -> e -> g -> i
 281         -> ReactiveFieldReadWrite m k
 282 liftRW5 bij a b c d e =
 283   ReactiveFieldReadWrite setter getter notifier
 284   where ReactiveFieldRead getter notifier = liftR5 (curry5 f2) a b c d e
 285         ReactiveFieldWrite setter = liftW5 f1 a b c d e
 286         (f1, f2) = (direct bij, inverse bij)
 287
 288 -- |
 289 -- = Curry and uncurry functions
 290
 291 curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
 292 curry3 f a b c = f (a,b,c)
 293
 294 uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
 295 uncurry3 f (a,b,c) = f a b c
 296
 297 curry4 :: ((a,b,c,d) -> e) -> a -> b -> c -> d -> e
 298 curry4 f a b c d = f (a,b,c,d)
 299
 300 uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
 301 uncurry4 f (a,b,c,d) = f a b c d
 302
 303 curry5 :: ((a,b,c,d,e) -> f) -> a -> b -> c -> d -> e -> f
 304 curry5 f a b c d e = f (a,b,c,d,e)
 305
 306 uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
 307 uncurry5 f (a,b,c,d,e) = f a b c d e