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