pang-a-lambda-0.2.0.0: src/FRP/Yampa/Extra.hs
{-# LANGUAGE MultiWayIf #-}
module FRP.Yampa.Extra where
import Debug.Trace
import FRP.Yampa
import FRP.Yampa.InternalCore
import FRP.Yampa.Switches
-- * Auxiliary FRP stuff
maybeToEvent :: Maybe a -> Event a
maybeToEvent = maybe noEvent Event
-- ** ListSF that never dies or produces offspring
inertSF :: SF a b -> ListSF a b
inertSF sf = ListSF (sf >>> arr (\o -> (o, False, [])))
-- ** Event-producing SF combinators
spikeOn :: SF a Bool -> SF a (Event ())
spikeOn sf = noEvent --> (sf >>> edge)
ifDiff :: Eq a => a -> SF a (Event a)
ifDiff x = loopPre x $ arr $ \(x',y') ->
if x' == y'
then (noEvent, x')
else (Event x', x')
-- ** Repetitive switching
repeatSF :: (c -> SF a (b, Event c)) -> c -> SF a b
repeatSF sf c = switch (sf c) (repeatSF sf)
repeatRevSF :: (c -> SF a (b, Event c)) -> c -> SF a b
repeatRevSF sf c = revSwitch (sf c) (repeatRevSF sf)
restartOn :: SF a b -> SF a (Event c) -> SF a b
restartOn sf sfc = switch (sf &&& sfc)
(\_ -> restartOn sf sfc)
-- restartRevOn :: SF a b -> SF a (Event c) -> SF a b
-- restartRevOn sf sfc = switch (sf &&& sfc)
-- (\_ -> restartOn sf sfc)
--
revSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
revSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}
where
tf0 a0 =
case tf10 a0 of
(sf1, (b0, NoEvent)) -> (switchAux sf1 k, b0)
(sf1, (_, Event c0)) -> switchingPoint sf1 k (sfTF (k c0) a0)
switchingPoint :: SF' a (b, Event c) -> (c -> SF a b) -> (SF' a b, b) -> (SF' a b, b)
switchingPoint sf1 k (sfN', b) = (sf', b)
where sf' = SF' tf'
tf' dt a = if | dt < 0 -> sfTF' (switchAux sf1 k) dt a
-- let (sf1', b') = sfTF' sf1 dt a
-- in (switchAux sf1' k, b')
| dt > 0 -> switchingPoint' sf1 k dt (sfTF' sfN' dt a)
| dt == 0 -> switchingPoint sf1 k (sfN', b)
switchingPoint' :: SF' a (b, Event c) -> (c -> SF a b) -> DTime -> (SF' a b, b) -> (SF' a b, b)
switchingPoint' sf1 k accumDT (sfN', b) = (sf', b)
where sf' = SF' tf'
tf' dt a = let dt' = dt + accumDT
in if | dt < 0 -> if | dt' < 0 -> sfTF' (switchAux sf1 k) dt' a
| dt' > 0 -> dt' `seq` switchingPoint' sf1 k dt' (sfTF' sfN' dt a)
| dt' == 0 -> switchingPoint' sf1 k accumDT (sfN', b)
| dt > 0 -> dt' `seq` switchingPoint' sf1 k dt' (sfTF' sfN' dt a)
| dt == 0 -> switchingPoint' sf1 k accumDT (sfN', b)
switchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b
switchAux sf1 k = SF' tf
where
tf dt a =
case (sfTF' sf1) dt a of
(sf1', (b, NoEvent)) -> (switchAux sf1' k, b)
(_, (_, Event c)) -> switchingPoint sf1 k (sfTF (k c) a)
alwaysForward :: SF a b -> SF a b
alwaysForward sf = SF $ \a -> let (sf', b) = sfTF sf a
in (alwaysForward' sf', b)
alwaysForward' :: SF' a b -> SF' a b
alwaysForward' sf = SF' $ \dt a -> let (sf', b) = sfTF' sf (max dt (-dt)) a
in (alwaysForward' sf', b)
checkpoint :: SF a (b, Event (), Event ()) -> SF a b
checkpoint sf = SF $ \a -> let (sf', (b, save, reset)) = sfTF sf a
in case reset of
Event () -> error "loop"
NoEvent -> let pt = case save of
Event () -> Just (Right sf)
NoEvent -> Nothing
in (checkpoint' pt sf', b)
checkpoint' :: Maybe (Either (SF' a (b, Event (), Event ())) (SF a (b, Event (), Event ())))
-> (SF' a (b, Event (), Event ()))
-> SF' a b
checkpoint' rstPt sf' = SF' $ \dt a -> let (sf'', (b, save, reset)) = sfTF' sf' dt a
in case reset of
Event () -> case rstPt of
Nothing -> let pt = case save of
Event () -> Just (Left sf'')
NoEvent -> rstPt
in pt `seq` (checkpoint' pt sf'', b)
Just (Left sf''') -> (checkpoint' rstPt sf''', b)
Just (Right sf ) -> sfTF (checkpoint sf) a
NoEvent -> let pt = case save of
Event () -> Just (Left sf'')
NoEvent -> rstPt
in pt `seq` (checkpoint' pt sf'', b)
forgetPast sf = SF $ \a -> let (sf', b) = sfTF sf a
in (forgetPast' 0 sf', b)
forgetPast' time sf' = SF' $ \dt a -> let time' = time + dt
in -- trace (show time') $
if time' < 0
then let (sf'', b) = sfTF' sf' (-time) a
in (forgetPast' 0 sf'', b)
else let (sf'', b) = sfTF' sf' dt a
in (forgetPast' time' sf'', b)
limitHistory :: DTime -> SF a b -> SF a b
limitHistory time sf = SF $ \a -> let (sf', b) = sfTF sf a
in (limitHistory' 0 time sf', b)
limitHistory' :: Time -> DTime -> SF' a b -> SF' a b
limitHistory' curT maxT sf' = SF' $ \dt a -> let curT' = curT + dt
time' = if curT' > maxT then maxT else curT'
in -- trace (show (dt, curT, maxT, maxMaxT)) $
if time' < 0
then let (sf'', b) = sfTF' sf' (-curT) a
in (limitHistory' 0 maxT sf'', b)
else let (sf'', b) = sfTF' sf' dt a
in (limitHistory' time' maxT sf'', b)
clocked :: SF a DTime -> SF a b -> SF a b
clocked clockSF sf = SF $ \a -> let (sf', b) = sfTF sf a
(cSF', _) = sfTF clockSF a
in (clocked' cSF' sf', b)
clocked' :: SF' a DTime -> SF' a b -> SF' a b
clocked' clockSF sf = SF' $ \dt a -> let (cSF', dt') = sfTF' clockSF dt a
(sf', b) = sfTF' sf dt' a
in (clocked' cSF' sf', b)
deltas = localTime >>> loopPre 0 (arr $ \(lt, ot) -> (lt-ot, lt))
type Endo a = a -> a
timeTransform :: Endo DTime -> SF a b -> SF a b
timeTransform transform sf = SF tf
where tf a = let (sf', b) = (sfTF sf) a
sf'' = timeTransformF transform sf'
in (sf'', b)
timeTransformF :: Endo DTime -> SF' a b -> SF' a b
timeTransformF transform sf = SF' tf
where tf dt a = let dt' = transform dt
(sf', b) = (sfTF' sf) dt' a
sf'' = timeTransformF transform sf'
in (sf'', b)
timeTransformSF :: SF a (DTime -> DTime) -> SF a b -> SF a b
timeTransformSF sfTime sf = SF tf
where tf a = let (sf', b) = (sfTF sf) a
(sfTime',_) = (sfTF sfTime) a
sf'' = timeTransformSF' sfTime' sf'
in (sf'', b)
timeTransformSF' :: SF' a (DTime -> DTime) -> SF' a b -> SF' a b
timeTransformSF' sfTime sf = SF' tf
where tf dt a = let (sfTime', transform) = (sfTF' sfTime) dt a
dt' = transform dt
(sf', b) = (sfTF' sf) dt' a
sf'' = timeTransformSF' sfTime' sf'
in (sf'', b)