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