src/RMCA/Auxiliary/Yampa.hs

   1 {-# LANGUAGE Arrows #-}
   2
   3 module RMCA.Auxiliary.Yampa where
   4
   5 import FRP.Yampa
   6 import Data.Maybe
   7 import RMCA.Auxiliary.Misc
   8 import Control.Monad
   9
  10 -- | = Yampa
  11
  12 countTo :: (Integral b) => b -> SF (Event a) (Event b)
  13 countTo n = count >>^ filterE (== n)
  14
  15 -- | Synchonizes two event sources. An event on the first source will be delayed until an event occurs on the second.
  16 --
  17 -- Ex:
  18 -- Event a => . . 1 . . . . 2 . . . 3 . . 4 . . . . . 5 . . 6 . . . . .
  19 -- Event b => . a . . . b . . . c . . . . . . d . e . f . . . . . g . .
  20 -- wairFor => . . . . . 1 . . . 2 . . . . . . 4 . . . 5 . . . . . 6 . .
  21
  22 -- A more direct approach, and without any use of *> to avoid depending
  23 -- on applicatives.
  24
  25 waitForEvent :: SF (Event a, Event b) (Event a)
  26 waitForEvent = sscanPrim procEvts NoEvent NoEvent
  27     where
  28         procEvts eaPrev (NoEvent,      NoEvent) = Just (eaPrev,  NoEvent)
  29         procEvts _      (ea@(Event _), NoEvent) = Just (ea,      NoEvent)
  30         procEvts eaPrev (NoEvent,      Event _) = Just (NoEvent, eaPrev)
  31         procEvts _      (ea@(Event _), Event _) = Just (NoEvent, ea)
  32
  33 {-
  34 waitForEvent :: SF (Event a, Event b) (Event a)
  35 waitForEvent = proc (ea,eb) -> do
  36   em <- arr $ uncurry $ mapMerge Left Right (\_ b -> Right b) -< (ea,eb)
  37   hob <- dAccumHoldBy accumulator NoEvent -< em
  38   returnA -< eb *> (ea `lMerge` hob)
  39   where accumulator :: Event a -> Either a b -> Event a
  40         accumulator _ (Left a) = Event a
  41         accumulator _ (Right _) = NoEvent
  42         --accumulator _ (Right b) =
  43 -}
  44
  45 {-
  46 waitForEvent :: SF (Event b, Event a) (Event b)
  47 waitForEvent = proc (eb,ea) -> do
  48   rec
  49     es' <- iPre NoEvent -< es
  50     es <- rSwitch waitAux -< ((eb,ea),es' `tag` waitAux)
  51   returnA -< es
  52   where waitAux = proc (eb,ea) -> do
  53           --ea' <- (if b then notYet else identity) -< ea
  54           eb' <- accumHoldBy (\_ b -> Event b) NoEvent -< eb
  55           returnA -< ea *> eb'
  56 -}
  57 -- | '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'.
  58 stepBack :: SF a (Maybe a)
  59 stepBack = sscan f (Nothing, Nothing) >>^ snd
  60   where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
  61         f (Nothing,_) x' = (Just x', Nothing)
  62         f (Just x, _) x' = (Just x', Just x)
  63
  64 -- | Like 'stepBack' but the output value is always defined and is equal to the input at time 0.
  65 stepBack' :: SF a a
  66 stepBack' = proc x -> do
  67   x' <- stepBack -< x
  68   returnA -< fromMaybe x x'
  69
  70 -- | Throws an 'Event' when the incoming signal change. The 'Event' is tagged with the new value.
  71 onChange :: (Eq a) => SF a (Event a)
  72 onChange = proc x -> do
  73   x' <- stepBack -< x
  74   let makeEvent x x'
  75         | isNothing x' = NoEvent
  76         | otherwise = let x'' = fromJust x' in
  77             if x'' == x then NoEvent else Event x
  78   returnA -< makeEvent x x'
  79
  80 -- | Similar to 'onChange' but contains its initial value in the first
  81 -- event.
  82 onChange' :: (Eq a) => SF a (Event a)
  83 onChange' = proc x -> do
  84   x' <- stepBack -< x
  85   -- If it's the first value, throw an Event, else behave like onChange.
  86   let makeEvent x x'
  87         | isNothing x' = Event x
  88         | otherwise = let x'' = fromJust x' in
  89             if x'' == x then NoEvent else Event x
  90   returnA -< makeEvent x x'
  91
  92 -- | Integrates some variable modulo something.
  93 integralMod :: (Real a, VectorSpace a s) => a -> SF a a
  94 integralMod x = intMod' 0
  95   where intMod' x0 = switch (intMod'' x0) (\y -> intMod' (y - x))
  96         intMod'' x0 =  proc t -> do
  97           it <- (+ x0) ^<< integral -< t
  98           es <- edgeBy (\_ y -> if y > x then Just y else Nothing) 0 -< it
  99           returnA -< (it,es)
 100
 101
 102
 103 -- | Generates a sine function whose period is given as a varying input.
 104 varFreqSine :: SF DTime Double
 105 varFreqSine = sin ^<< (2*pi*) ^<< integralMod 1 <<^ (1/)
 106
 107 -- | Generates an 'Event' with a regular period, which is given as an input to the signal function.
 108 repeatedlyS :: a -> SF DTime (Event a)
 109 repeatedlyS x = edgeBy (\a b -> if a * b < 0 then Just x else Nothing) 0
 110                 <<< varFreqSine <<^ (2*)
 111
 112 repeatedlyS' :: a -> SF DTime (Event a)
 113 repeatedlyS' x = (repeatedlyS x &&& now x) >>> arr (uncurry lMerge)
 114
 115 -- |
 116 -- = Curry and uncurry functions