module FRP.Animas (
module Control.Arrow,
module FRP.Animas.VectorSpace,
RandomGen(..),
Random(..),
( # ),
dup,
swap,
Time,
DTime,
SF,
Event(..),
arrPrim, arrEPrim,
identity,
constant,
localTime,
time,
(-->),
(>--),
(-=>),
(>=-),
initially,
sscan,
sscanPrim,
never,
now,
after,
repeatedly,
afterEach,
afterEachCat,
edge,
iEdge,
edgeTag,
edgeJust,
edgeBy,
once,
noEvent,
noEventFst,
noEventSnd,
delayEvent,
delayEventCat,
takeEvents,
dropEvents,
notYet,
old_hold,
hold,
dHold,
trackAndHold,
old_accum,
old_accumBy,
old_accumFilter,
accum,
accumHold,
dAccumHold,
accumBy,
accumHoldBy,
dAccumHoldBy,
accumFilter,
event,
fromEvent,
isEvent,
isNoEvent,
tag,
tagWith,
attach,
lMerge,
rMerge,
merge,
mergeBy,
mapMerge,
mergeEvents,
catEvents,
joinE,
splitE,
filterE,
mapFilterE,
gate,
switch, dSwitch,
rSwitch, drSwitch,
kSwitch, dkSwitch,
parB,
pSwitchB,dpSwitchB,
rpSwitchB,drpSwitchB,
par,
pSwitch, dpSwitch,
rpSwitch,drpSwitch,
old_pre, old_iPre,
pre,
iPre,
delay,
integral,
derivative,
imIntegral,
loopPre,
loopIntegral,
noise,
noiseR,
occasionally,
ReactHandle,
reactimate,
reactInit,
react,
embed,
embedSynch,
deltaEncode,
deltaEncodeBy,
Step,
initStep,
step
) where
import Control.Monad (unless)
import System.Random (RandomGen(..), Random(..))
#if __GLASGOW_HASKELL__ >= 610
import qualified Control.Category (Category(..))
#else
#endif
import Control.Arrow
import FRP.Animas.Diagnostics
import FRP.Animas.Miscellany (( # ), dup, swap)
import FRP.Animas.Event
import FRP.Animas.VectorSpace
import Data.IORef
infixr 0 -->, >--, -=>, >=-
type Time = Double
type DTime = Double
data SF a b = SF {sfTF :: a -> Transition a b}
data SF' a b where
SFArr :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b
SFSScan :: !(DTime -> a -> Transition a b)
-> !(c -> a -> Maybe (c, b)) -> !c -> b
-> SF' a b
SFEP :: !(DTime -> Event a -> Transition (Event a) b)
-> !(c -> a -> (c, b, b)) -> !c -> b
-> SF' (Event a) b
SFCpAXA :: !(DTime -> a -> Transition a d)
-> !(FunDesc a b) -> !(SF' b c) -> !(FunDesc c d)
-> SF' a d
SF' :: !(DTime -> a -> Transition a b) -> SF' a b
type Transition a b = (SF' a b, b)
sfTF' :: SF' a b -> (DTime -> a -> Transition a b)
sfTF' (SFArr tf _) = tf
sfTF' (SFSScan tf _ _ _) = tf
sfTF' (SFEP tf _ _ _) = tf
sfTF' (SFCpAXA tf _ _ _) = tf
sfTF' (SF' tf) = tf
sfArr :: FunDesc a b -> SF' a b
sfArr FDI = sfId
sfArr (FDC b) = sfConst b
sfArr (FDE f fne) = sfArrE f fne
sfArr (FDG f) = sfArrG f
sfId :: SF' a a
sfId = sf
where
sf = SFArr (\_ a -> (sf, a)) FDI
sfConst :: b -> SF' a b
sfConst b = sf
where
sf = SFArr (\_ _ -> (sf, b)) (FDC b)
sfNever :: SF' a (Event b)
sfNever = sfConst NoEvent
sfArrE :: (Event a -> b) -> b -> SF' (Event a) b
sfArrE f fne = sf
where
sf = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea))
(FDE f fne)
sfArrG :: (a -> b) -> SF' a b
sfArrG f = sf
where
sf = SFArr (\_ a -> (sf, f a)) (FDG f)
sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b
sfSScan f c b = sf
where
sf = SFSScan tf f c b
tf _ a = case f c a of
Nothing -> (sf, b)
Just (c', b') -> (sfSScan f c' b', b')
sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b
sscanPrim f c_init b_init = SF {sfTF = tf0}
where
tf0 a0 = case f c_init a0 of
Nothing -> (sfSScan f c_init b_init, b_init)
Just (c', b') -> (sfSScan f c' b', b')
sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b
sfEP f c bne = sf
where
sf = SFEP (\_ ea -> case ea of
NoEvent -> (sf, bne)
Event a -> let
(c', b, bne') = f c a
in
(sfEP f c' bne', b))
f
c
bne
epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b
epPrim f c bne = SF {sfTF = tf0}
where
tf0 NoEvent = (sfEP f c bne, bne)
tf0 (Event a) = let
(c', b, bne') = f c a
in
(sfEP f c' bne', b)
data FunDesc a b where
FDI :: FunDesc a a
FDC :: b -> FunDesc a b
FDE :: (Event a -> b) -> b -> FunDesc (Event a) b
FDG :: (a -> b) -> FunDesc a b
fdFun :: FunDesc a b -> (a -> b)
fdFun FDI = id
fdFun (FDC b) = const b
fdFun (FDE f _) = f
fdFun (FDG f) = f
fdComp :: FunDesc a b -> FunDesc b c -> FunDesc a c
fdComp FDI fd2 = fd2
fdComp fd1 FDI = fd1
fdComp (FDC b) fd2 = FDC ((fdFun fd2) b)
fdComp _ (FDC c) = FDC c
fdComp (FDE f1 f1ne) fd2 = FDE (f2 . f1) (f2 f1ne)
where
f2 = fdFun fd2
fdComp (FDG f1) (FDE f2 f2ne) = FDG f
where
f a = case f1 a of
NoEvent -> f2ne
f1a -> f2 f1a
fdComp (FDG f1) fd2 = FDG (fdFun fd2 . f1)
fdPar :: FunDesc a b -> FunDesc c d -> FunDesc (a,c) (b,d)
fdPar FDI FDI = FDI
fdPar FDI (FDC d) = FDG (\(~(a, _)) -> (a, d))
fdPar FDI fd2 = FDG (\(~(a, c)) -> (a, (fdFun fd2) c))
fdPar (FDC b) FDI = FDG (\(~(_, c)) -> (b, c))
fdPar (FDC b) (FDC d) = FDC (b, d)
fdPar (FDC b) fd2 = FDG (\(~(_, c)) -> (b, (fdFun fd2) c))
fdPar fd1 fd2 = FDG (\(~(a, c)) -> ((fdFun fd1) a, (fdFun fd2) c))
fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b,c)
fdFanOut FDI FDI = FDG dup
fdFanOut FDI (FDC c) = FDG (\a -> (a, c))
fdFanOut FDI fd2 = FDG (\a -> (a, (fdFun fd2) a))
fdFanOut (FDC b) FDI = FDG (\a -> (b, a))
fdFanOut (FDC b) (FDC c) = FDC (b, c)
fdFanOut (FDC b) fd2 = FDG (\a -> (b, (fdFun fd2) a))
fdFanOut (FDE f1 f1ne) (FDE f2 f2ne) = FDE f1f2 f1f2ne
where
f1f2 NoEvent = f1f2ne
f1f2 ea@(Event _) = (f1 ea, f2 ea)
f1f2ne = (f1ne, f2ne)
fdFanOut fd1 fd2 =
FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a))
vfyNoEv :: Event a -> b -> b
vfyNoEv NoEvent b = b
vfyNoEv _ _ = usrErr "AFRP" "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event."
freeze :: SF' a b -> DTime -> SF a b
freeze sf dt = SF {sfTF = (sfTF' sf) dt}
freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b)
freezeCol sfs dt = fmap (flip freeze dt) sfs
#if __GLASGOW_HASKELL__ >= 610
instance Control.Category.Category SF where
(.) = flip compPrim
id = SF $ \x -> (sfId,x)
#else
#endif
instance Arrow SF where
arr = arrPrim
first = firstPrim
second = secondPrim
(***) = parSplitPrim
(&&&) = parFanOutPrim
#if __GLASGOW_HASKELL__ >= 610
#else
(>>>) = compPrim
#endif
arrPrim :: (a -> b) -> SF a b
arrPrim f = SF {sfTF = \a -> (sfArrG f, f a)}
arrEPrim :: (Event a -> b) -> SF (Event a) b
arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)}
compPrim :: SF a b -> SF b c -> SF a c
compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
where
tf0 a0 = (cpXX sf1 sf2, c0)
where
(sf1, b0) = tf10 a0
(sf2, c0) = tf20 b0
cpXX :: SF' a b -> SF' b c -> SF' a c
cpXX (SFArr _ fd1) sf2 = cpAX fd1 sf2
cpXX sf1 (SFArr _ fd2) = cpXA sf1 fd2
cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) =
sfSScan f (s1, b, s2, c) c
where
f (s1, b, s2, c) a =
let
(u, s1', b') = case f1 s1 a of
Nothing -> (True, s1, b)
Just (s1',b') -> (False, s1', b')
in
case f2 s2 b' of
Nothing | u -> Nothing
| otherwise -> Just ((s1', b', s2, c), c)
Just (s2', c') -> Just ((s1', b', s2', c'), c')
cpXX (SFSScan _ f1 s1 eb) (SFEP _ f2 s2 cne) =
sfSScan f (s1, eb, s2, cne) cne
where
f (s1, eb, s2, cne) a =
case f1 s1 a of
Nothing ->
case eb of
NoEvent -> Nothing
Event b ->
let (s2', c, cne') = f2 s2 b
in
Just ((s1, eb, s2', cne'), c)
Just (s1', eb') ->
case eb' of
NoEvent -> Just ((s1', eb', s2, cne), cne)
Event b ->
let (s2', c, cne') = f2 s2 b
in
Just ((s1', eb', s2', cne'), c)
cpXX (SFEP _ f1 s1 bne) (SFSScan _ f2 s2 c) =
sfSScan f (s1, bne, s2, c) c
where
f (s1, bne, s2, c) ea =
let (u, s1', b', bne') = case ea of
NoEvent -> (True, s1, bne, bne)
Event a ->
let (s1', b, bne') = f1 s1 a
in
(False, s1', b, bne')
in
case f2 s2 b' of
Nothing | u -> Nothing
| otherwise -> Just (seq s1' (s1', bne', s2, c), c)
Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c')
cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) =
sfEP f (s1, s2, cne) (vfyNoEv bne cne)
where
f (s1, s2, cne) a =
case f1 s1 a of
(s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne)
(s1', Event b, NoEvent) ->
let (s2', c, cne') = f2 s2 b in ((s1', s2', cne'), c, cne')
_ -> usrErr "AFRP" "cpXX" "Assertion failed: Functions on events must not map NoEvent to Event."
cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) =
cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23)
cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDG f21) sf22 fd23) =
cpXX (cpXG sf1 f21) (cpXA sf22 fd23)
cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP _ _ _ _) =
cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2)
cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =
cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23
cpXX sf1 sf2 = SF' tf
where
tf dt a = (cpXX sf1' sf2', c)
where
(sf1', b) = (sfTF' sf1) dt a
(sf2', c) = (sfTF' sf2) dt b
cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d
cpAXA FDI sf2 fd3 = cpXA sf2 fd3
cpAXA fd1 sf2 FDI = cpAX fd1 sf2
cpAXA (FDC b) sf2 fd3 = cpCXA b sf2 fd3
cpAXA _ _ (FDC d) = sfConst d
cpAXA fd1 sf2 fd3 =
cpAXAAux fd1 (fdFun fd1) fd3 (fdFun fd3) sf2
where
cpAXAAux :: FunDesc a b -> (a -> b) -> FunDesc c d -> (c -> d)
-> SF' b c -> SF' a d
cpAXAAux fd1 _ fd3 _ (SFArr _ fd2) =
sfArr (fdComp (fdComp fd1 fd2) fd3)
cpAXAAux fd1 _ fd3 _ sf2@(SFSScan _ _ _ _) =
cpAX fd1 (cpXA sf2 fd3)
cpAXAAux fd1 _ fd3 _ sf2@(SFEP _ _ _ _) =
cpAX fd1 (cpXA sf2 fd3)
cpAXAAux fd1 _ fd3 _ (SFCpAXA _ fd21 sf22 fd23) =
cpAXA (fdComp fd1 fd21) sf22 (fdComp fd23 fd3)
cpAXAAux fd1 f1 fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3
where
tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c)
where
(sf2', c) = (sfTF' sf2) dt (f1 a)
cpAX :: FunDesc a b -> SF' b c -> SF' a c
cpAX FDI sf2 = sf2
cpAX (FDC b) sf2 = cpCX b sf2
cpAX (FDE f1 f1ne) sf2 = cpEX f1 f1ne sf2
cpAX (FDG f1) sf2 = cpGX f1 sf2
cpXA :: SF' a b -> FunDesc b c -> SF' a c
cpXA sf1 FDI = sf1
cpXA _ (FDC c) = sfConst c
cpXA sf1 (FDE f2 f2ne) = cpXE sf1 f2 f2ne
cpXA sf1 (FDG f2) = cpXG sf1 f2
cpCX :: b -> SF' b c -> SF' a c
cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b)
cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c
cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne)
cpCX b (SFCpAXA _ fd21 sf22 fd23) =
cpCXA ((fdFun fd21) b) sf22 fd23
cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI
where
tf dt _ = (cpCX b sf2', c)
where
(sf2', c) = (sfTF' sf2) dt b
cpCXA :: b -> SF' b c -> FunDesc c d -> SF' a d
cpCXA b sf2 FDI = cpCX b sf2
cpCXA _ _ (FDC c) = sfConst c
cpCXA b sf2 fd3 = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2
where
cpCXAAux :: FunDesc a b -> b -> FunDesc c d -> (c -> d)
-> SF' b c -> SF' a d
cpCXAAux _ b _ f3 (SFArr _ fd2) = sfConst (f3 ((fdFun fd2) b))
cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c)
where
f' s _ = case f s b of
Nothing -> Nothing
Just (s', c') -> Just (s', f3 c')
cpCXAAux _ b _ f3 (SFEP _ _ _ cne) = sfConst (f3 (vfyNoEv b cne))
cpCXAAux _ b fd3 _ (SFCpAXA _ fd21 sf22 fd23) =
cpCXA ((fdFun fd21) b) sf22 (fdComp fd23 fd3)
cpCXAAux fd1 b fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3
where
tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c)
where
(sf2', c) = (sfTF' sf2) dt b
cpGX :: (a -> b) -> SF' b c -> SF' a c
cpGX f1 sf2 = cpGXAux (FDG f1) f1 sf2
where
cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c
cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)
cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c
cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) =
cpAXA (fdComp fd1 fd21) sf22 fd23
cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI
where
tf dt a = (cpGXAux fd1 f1 sf2', c)
where
(sf2', c) = (sfTF' sf2) dt (f1 a)
cpXG :: SF' a b -> (b -> c) -> SF' a c
cpXG sf1 f2 = cpXGAux (FDG f2) f2 sf1
where
cpXGAux :: FunDesc b c -> (b -> c) -> SF' a b -> SF' a c
cpXGAux fd2 _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)
cpXGAux _ f2 (SFSScan _ f s b) = sfSScan f' s (f2 b)
where
f' s a = case f s a of
Nothing -> Nothing
Just (s', b') -> Just (s', f2 b')
cpXGAux _ f2 (SFEP _ f1 s bne) = sfEP f s (f2 bne)
where
f s a = let (s', b, bne') = f1 s a in (s', f2 b, f2 bne')
cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) =
cpAXA fd11 sf12 (fdComp fd22 fd2)
cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2
where
tf dt a = (cpXGAux fd2 f2 sf1', f2 b)
where
(sf1', b) = (sfTF' sf1) dt a
cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c
cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2
where
cpEXAux :: FunDesc (Event a) b -> (Event a -> b) -> b
-> SF' b c -> SF' (Event a) c
cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)
cpEXAux _ f1 _ (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c
cpEXAux _ f1 f1ne (SFEP _ f2 s cne) =
sfEP f (s, cne) (vfyNoEv f1ne cne)
where
f scne@(s, cne) a =
case (f1 (Event a)) of
NoEvent -> (scne, cne, cne)
Event b ->
let (s', c, cne') = f2 s b in ((s', cne'), c, cne')
cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) =
cpAXA (fdComp fd1 fd21) sf22 fd23
cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf fd1 sf2 FDI
where
tf dt ea = (cpEXAux fd1 f1 f1ne sf2', c)
where
(sf2', c) =
case ea of
NoEvent -> (sfTF' sf2) dt f1ne
_ -> (sfTF' sf2) dt (f1 ea)
cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c
cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1
where
cpXEAux :: FunDesc (Event b) c -> (Event b -> c) -> c
-> SF' a (Event b) -> SF' a c
cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)
cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb)
where
f' s a = case f s a of
Nothing -> Nothing
Just (s', NoEvent) -> Just (s', f2ne)
Just (s', eb') -> Just (s', f2 eb')
cpXEAux _ f2 f2ne (SFEP _ f1 s ebne) =
sfEP f s (vfyNoEv ebne f2ne)
where
f s a =
case f1 s a of
(s', NoEvent, NoEvent) -> (s', f2ne, f2ne)
(s', eb, NoEvent) -> (s', f2 eb, f2ne)
_ -> usrErr "AFRP" "cpXEAux" "Assertion failed: Functions on events must not map NoEvent to Event."
cpXEAux fd2 _ _ (SFCpAXA _ fd11 sf12 fd13) =
cpAXA fd11 sf12 (fdComp fd13 fd2)
cpXEAux fd2 f2 f2ne sf1 = SFCpAXA tf FDI sf1 fd2
where
tf dt a = (cpXEAux fd2 f2 f2ne sf1',
case eb of NoEvent -> f2ne; _ -> f2 eb)
where
(sf1', eb) = (sfTF' sf1) dt a
firstPrim :: SF a b -> SF (a,c) (b,c)
firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
where
tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))
where
(sf1, b0) = tf10 a0
fpAux :: SF' a b -> SF' (a,c) (b,c)
fpAux (SFArr _ FDI) = sfId
fpAux (SFArr _ (FDC b)) = sfArrG (\(~(_, c)) -> (b, c))
fpAux (SFArr _ fd1) = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c))
fpAux sf1 = SF' tf
where
tf dt ~(a, c) = (fpAux sf1', (b, c))
where
(sf1', b) = (sfTF' sf1) dt a
secondPrim :: SF a b -> SF (c,a) (c,b)
secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
where
tf0 ~(c0, a0) = (spAux sf1, (c0, b0))
where
(sf1, b0) = tf10 a0
spAux :: SF' a b -> SF' (c,a) (c,b)
spAux (SFArr _ FDI) = sfId
spAux (SFArr _ (FDC b)) = sfArrG (\(~(c, _)) -> (c, b))
spAux (SFArr _ fd1) = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a))
spAux sf1 = SF' tf
where
tf dt ~(c, a) = (spAux sf1', (c, b))
where
(sf1', b) = (sfTF' sf1) dt a
parSplitPrim :: SF a b -> SF c d -> SF (a,c) (b,d)
parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
where
tf0 ~(a0, c0) = (psXX sf1 sf2, (b0, d0))
where
(sf1, b0) = tf10 a0
(sf2, d0) = tf20 c0
psXX :: SF' a b -> SF' c d -> SF' (a,c) (b,d)
psXX (SFArr _ fd1) (SFArr _ fd2) = sfArr (fdPar fd1 fd2)
psXX (SFArr _ FDI) sf2 = spAux sf2
psXX (SFArr _ (FDC b)) sf2 = psCX b sf2
psXX (SFArr _ fd1) sf2 = psAX (fdFun fd1) sf2
psXX sf1 (SFArr _ FDI) = fpAux sf1
psXX sf1 (SFArr _ (FDC d)) = psXC sf1 d
psXX sf1 (SFArr _ fd2) = psXA sf1 (fdFun fd2)
psXX sf1 sf2 = SF' tf
where
tf dt ~(a, c) = (psXX sf1' sf2', (b, d))
where
(sf1', b) = (sfTF' sf1) dt a
(sf2', d) = (sfTF' sf2) dt c
psCX :: b -> SF' c d -> SF' (a,c) (b,d)
psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2)
psCX b sf2 = SF' tf
where
tf dt ~(_, c) = (psCX b sf2', (b, d))
where
(sf2', d) = (sfTF' sf2) dt c
psXC :: SF' a b -> d -> SF' (a,c) (b,d)
psXC (SFArr _ fd1) d = sfArr (fdPar fd1 (FDC d))
psXC sf1 d = SF' tf
where
tf dt ~(a, _) = (psXC sf1' d, (b, d))
where
(sf1', b) = (sfTF' sf1) dt a
psAX :: (a -> b) -> SF' c d -> SF' (a,c) (b,d)
psAX f1 (SFArr _ fd2) = sfArr (fdPar (FDG f1) fd2)
psAX f1 sf2 = SF' tf
where
tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d))
where
(sf2', d) = (sfTF' sf2) dt c
psXA :: SF' a b -> (c -> d) -> SF' (a,c) (b,d)
psXA (SFArr _ fd1) f2 = sfArr (fdPar fd1 (FDG f2))
psXA sf1 f2 = SF' tf
where
tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c))
where
(sf1', b) = (sfTF' sf1) dt a
parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)
parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
where
tf0 a0 = (pfoXX sf1 sf2, (b0, c0))
where
(sf1, b0) = tf10 a0
(sf2, c0) = tf20 a0
pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c)
pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2)
pfoXX (SFArr _ FDI) sf2 = pfoIX sf2
pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2
pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2
pfoXX sf1 (SFArr _ FDI) = pfoXI sf1
pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c
pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2)
pfoXX sf1 sf2 = SF' tf
where
tf dt a = (pfoXX sf1' sf2', (b, c))
where
(sf1', b) = (sfTF' sf1) dt a
(sf2', c) = (sfTF' sf2) dt a
pfoIX :: SF' a c -> SF' a (a ,c)
pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2)
pfoIX sf2 = SF' tf
where
tf dt a = (pfoIX sf2', (a, c))
where
(sf2', c) = (sfTF' sf2) dt a
pfoXI :: SF' a b -> SF' a (b ,a)
pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI)
pfoXI sf1 = SF' tf
where
tf dt a = (pfoXI sf1', (b, a))
where
(sf1', b) = (sfTF' sf1) dt a
pfoCX :: b -> SF' a c -> SF' a (b ,c)
pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2)
pfoCX b sf2 = SF' tf
where
tf dt a = (pfoCX b sf2', (b, c))
where
(sf2', c) = (sfTF' sf2) dt a
pfoXC :: SF' a b -> c -> SF' a (b ,c)
pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c))
pfoXC sf1 c = SF' tf
where
tf dt a = (pfoXC sf1' c, (b, c))
where
(sf1', b) = (sfTF' sf1) dt a
pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c)
pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2)
pfoAX f1 sf2 = SF' tf
where
tf dt a = (pfoAX f1 sf2', (f1 a, c))
where
(sf2', c) = (sfTF' sf2) dt a
pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c)
pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2))
pfoXA sf1 f2 = SF' tf
where
tf dt a = (pfoXA sf1' f2, (b, f2 a))
where
(sf1', b) = (sfTF' sf1) dt a
instance ArrowLoop SF where
loop = loopPrim
loopPrim :: SF (a,c) (b,c)
-> SF a b
loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
where
tf0 a0 = (loopAux sf1, b0)
where
(sf1, (b0, c0)) = tf10 (a0, c0)
loopAux :: SF' (a,c) (b,c) -> SF' a b
loopAux (SFArr _ FDI) = sfId
loopAux (SFArr _ (FDC (b, _))) = sfConst b
loopAux (SFArr _ fd1) =
sfArrG (\a -> let (b,c) = (fdFun fd1) (a,c) in b)
loopAux sf1 = SF' tf
where
tf dt a = (loopAux sf1', b)
where
(sf1', (b, c)) = (sfTF' sf1) dt (a, c)
identity :: SF a a
identity = SF {sfTF = \a -> (sfId, a)}
constant :: b -> SF a b
constant b = SF {sfTF = \_ -> (sfConst b, b)}
localTime :: SF a Time
localTime = constant 1.0 >>> integral
time :: SF a Time
time = localTime
(-->) :: b -> SF a b -> SF a b
b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)}
(>--) :: a -> SF a b -> SF a b
a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0}
(-=>) :: (b -> b) -> SF a b -> SF a b
f -=> (SF {sfTF = tf10}) =
SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}
(>=-) :: (a -> a) -> SF a b -> SF a b
f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}
initially :: a
-> SF a a
initially = (--> identity)
sscan :: (b -> a -> b )
-> b
-> SF a b
sscan f b_init = sscanPrim f' b_init b_init
where
f' b a = let b' = f b a in Just (b', b')
never :: SF a (Event b)
never = SF {sfTF = \_ -> (sfNever, NoEvent)}
now :: b
-> SF a (Event b)
now b0 = (Event b0 --> never)
after :: Time
-> b
-> SF a (Event b)
after q x = afterEach [(q,x)]
repeatedly :: Time
-> b
-> SF a (Event b)
repeatedly q x | q > 0 = afterEach qxs
| otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."
where
qxs = (q,x):qxs
afterEach :: [(Time,b)]
-> SF a (Event b)
afterEach qxs = afterEachCat qxs >>> arr (fmap head)
afterEachCat :: [(Time,b)] -> SF a (Event [b])
afterEachCat [] = never
afterEachCat ((q,x):qxs)
| q < 0 = usrErr "AFRP" "afterEachCat" "Negative period."
| otherwise = SF {sfTF = tf0}
where
tf0 _ = if q <= 0 then
emitEventsScheduleNext 0.0 [x] qxs
else
(awaitNextEvent (q) x qxs, NoEvent)
emitEventsScheduleNext _ xs [] = (sfNever, Event (reverse xs))
emitEventsScheduleNext t xs ((q,x):qxs)
| q < 0 = usrErr "AFRP" "afterEachCat" "Negative period."
| t' >= 0 = emitEventsScheduleNext t' (x:xs) qxs
| otherwise = (awaitNextEvent t' x qxs, Event (reverse xs))
where
t' = t q
awaitNextEvent t x qxs = SF' tf
where
tf dt _ | t' >= 0 = emitEventsScheduleNext t' [x] qxs
| otherwise = (awaitNextEvent t' x qxs, NoEvent)
where
t' = t + dt
delayEvent :: Time
-> SF (Event a) (Event a)
delayEvent q | q < 0 = usrErr "AFRP" "delayEvent" "Negative delay."
| q == 0 = identity
| otherwise = delayEventCat q >>> arr (fmap head)
delayEventCat :: Time -> SF (Event a) (Event [a])
delayEventCat q | q < 0 = usrErr "AFRP" "delayEventCat" "Negative delay."
| q == 0 = arr (fmap (:[]))
| otherwise = SF {sfTF = tf0}
where
tf0 e = (case e of
NoEvent -> noPendingEvent
Event x -> pendingEvents (q) [] [] (q) x,
NoEvent)
noPendingEvent = SF' tf
where
tf _ e = (case e of
NoEvent -> noPendingEvent
Event x -> pendingEvents (q) [] [] (q) x,
NoEvent)
pendingEvents t_last rqxs qxs t_next x = SF' tf
where
tf dt e
| t_next' >= 0 =
emitEventsScheduleNext e t_last' rqxs qxs t_next' [x]
| otherwise =
(pendingEvents t_last'' rqxs' qxs t_next' x, NoEvent)
where
t_next' = t_next + dt
t_last' = t_last + dt
(t_last'', rqxs') =
case e of
NoEvent -> (t_last', rqxs)
Event x' -> (q, (t_last'+q,x') : rqxs)
emitEventsScheduleNext e _ [] [] _ rxs =
(case e of
NoEvent -> noPendingEvent
Event x -> pendingEvents (q) [] [] (q) x,
Event (reverse rxs))
emitEventsScheduleNext e t_last rqxs [] t_next rxs =
emitEventsScheduleNext e t_last [] (reverse rqxs) t_next rxs
emitEventsScheduleNext e t_last rqxs ((q', x') : qxs') t_next rxs
| q' > t_next = (case e of
NoEvent ->
pendingEvents t_last
rqxs
qxs'
(t_next q')
x'
Event x'' ->
pendingEvents (q)
((t_last+q, x'') : rqxs)
qxs'
(t_next q')
x',
Event (reverse rxs))
| otherwise = emitEventsScheduleNext e
t_last
rqxs
qxs'
(t_next q')
(x' : rxs)
edge :: SF Bool (Event ())
edge = iEdge True
iEdge :: Bool -> SF Bool (Event ())
iEdge b = sscanPrim f (if b then 2 else 0) NoEvent
where
f :: Int -> Bool -> Maybe (Int, Event ())
f 0 False = Nothing
f 0 True = Just (1, Event ())
f 1 False = Just (0, NoEvent)
f 1 True = Just (2, NoEvent)
f 2 False = Just (0, NoEvent)
f 2 True = Nothing
f _ _ = undefined
edgeTag :: a
-> SF Bool (Event a)
edgeTag a = edge >>> arr (`tag` a)
edgeJust :: SF (Maybe a) (Event a)
edgeJust = edgeBy isJustEdge (Just undefined)
where
isJustEdge Nothing Nothing = Nothing
isJustEdge Nothing ma@(Just _) = ma
isJustEdge (Just _) (Just _) = Nothing
isJustEdge (Just _) Nothing = Nothing
edgeBy :: (a -> a -> Maybe b)
-> a
-> SF a (Event b)
edgeBy isEdge a_init = SF {sfTF = tf0}
where
tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))
ebAux a_prev = SF' tf
where
tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a))
notYet :: SF (Event a) (Event a)
notYet = initially NoEvent
once :: SF (Event a) (Event a)
once = takeEvents 1
takeEvents :: Int
-> SF (Event a) (Event a)
takeEvents n | n <= 0 = never
takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n 1)))
dropEvents :: Int
-> SF (Event a) (Event a)
dropEvents n | n <= 0 = identity
dropEvents n = dSwitch (never &&& identity)
(const (NoEvent >-- dropEvents (n 1)))
switch :: SF a (b, Event c)
-> (c -> SF a b)
-> SF a b
switch (SF {sfTF = tf10}) k = SF {sfTF = tf0}
where
tf0 a0 =
case tf10 a0 of
(sf1, (b0, NoEvent)) -> (switchAux sf1 k, b0)
(_, (_, Event c0)) -> sfTF (k c0) a0
switchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b
switchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b
switchAux (SFArr _ fd1) k = switchAuxA1 (fdFun fd1) k
switchAux sf1 k = SF' tf
where
tf dt a =
case (sfTF' sf1) dt a of
(sf1', (b, NoEvent)) -> (switchAux sf1' k, b)
(_, (_, Event c)) -> sfTF (k c) a
switchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b
switchAuxA1 f1 k = sf
where
sf = SF' tf
tf _ a =
case f1 a of
(b, NoEvent) -> (sf, b)
(_, Event c) -> sfTF (k c) a
dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}
where
tf0 a0 =
let (sf1, (b0, ec0)) = tf10 a0
in (case ec0 of
NoEvent -> dSwitchAux sf1 k
Event c0 -> fst (sfTF (k c0) a0),
b0)
dSwitchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b
dSwitchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b
dSwitchAux (SFArr _ fd1) k = dSwitchAuxA1 (fdFun fd1) k
dSwitchAux sf1 k = SF' tf
where
tf dt a =
let (sf1', (b, ec)) = (sfTF' sf1) dt a
in (case ec of
NoEvent -> dSwitchAux sf1' k
Event c -> fst (sfTF (k c) a),
b)
dSwitchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b
dSwitchAuxA1 f1 k = sf
where
sf = SF' tf
tf _ a =
let (b, ec) = f1 a
in (case ec of
NoEvent -> sf
Event c -> fst (sfTF (k c) a),
b)
rSwitch :: SF a b
-> SF (a, Event (SF a b)) b
rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)
drSwitch :: SF a b -> SF (a, Event (SF a b)) b
drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch)
kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}
where
tf0 a0 =
let (sf1, b0) = tf10 a0
in
case tfe0 (a0, b0) of
(sfe, NoEvent) -> (kSwitchAux sf1 sfe, b0)
(_, Event c0) -> sfTF (k sf10 c0) a0
kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe
kSwitchAux (SFArr _ fd1) sfe = kSwitchAuxA1 (fdFun fd1) sfe
kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1
kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde)
kSwitchAux sf1 sfe = SF' tf
where
tf dt a =
let (sf1', b) = (sfTF' sf1) dt a
in
case (sfTF' sfe) dt (a, b) of
(sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)
(_, Event c) -> sfTF (k (freeze sf1 dt) c) a
kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b
kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde)
kSwitchAuxC1 b sfe = SF' tf
where
tf dt a =
case (sfTF' sfe) dt (a, b) of
(sfe', NoEvent) -> (kSwitchAuxC1 b sfe', b)
(_, Event c) -> sfTF (k (constant b) c) a
kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1
kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde)
kSwitchAuxA1 f1 sfe = SF' tf
where
tf dt a =
let b = f1 a
in
case (sfTF' sfe) dt (a, b) of
(sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b)
(_, Event c) -> sfTF (k (arr f1) c) a
kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe
kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) fe
kSwitchAuxAE sf1 fe = SF' tf
where
tf dt a =
let (sf1', b) = (sfTF' sf1) dt a
in
case fe (a, b) of
NoEvent -> (kSwitchAuxAE sf1' fe, b)
Event c -> sfTF (k (freeze sf1 dt) c) a
kSwitchAuxC1AE b fe = SF' tf
where
tf _ a =
case fe (a, b) of
NoEvent -> (kSwitchAuxC1AE b fe, b)
Event c -> sfTF (k (constant b) c) a
kSwitchAuxA1AE f1 fe = SF' tf
where
tf _ a =
let b = f1 a
in
case fe (a, b) of
NoEvent -> (kSwitchAuxA1AE f1 fe, b)
Event c -> sfTF (k (arr f1) c) a
dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}
where
tf0 a0 =
let (sf1, b0) = tf10 a0
in (case tfe0 (a0, b0) of
(sfe, NoEvent) -> dkSwitchAux sf1 sfe
(_, Event c0) -> fst (sfTF (k sf10 c0) a0),
b0)
dkSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1
dkSwitchAux sf1 sfe = SF' tf
where
tf dt a =
let (sf1', b) = (sfTF' sf1) dt a
in (case (sfTF' sfe) dt (a, b) of
(sfe', NoEvent) -> dkSwitchAux sf1' sfe'
(_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a),
b)
broadcast :: Functor col => a -> col sf -> col (a, sf)
broadcast a sfs = fmap (\sf -> (a, sf)) sfs
parB :: Functor col => col (SF a b) -> SF a (col b)
parB = par broadcast
pSwitchB :: Functor col =>
col (SF a b)
-> SF (a, col b) (Event c)
-> (col (SF a b) -> c -> SF a (col b))
-> SF a (col b)
pSwitchB = pSwitch broadcast
dpSwitchB :: Functor col =>
col (SF a b)
-> SF (a,col b) (Event c)
-> (col (SF a b) -> c -> SF a (col b))
-> SF a (col b)
dpSwitchB = dpSwitch broadcast
rpSwitchB :: Functor col =>
col (SF a b)
-> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)
rpSwitchB = rpSwitch broadcast
drpSwitchB :: Functor col =>
col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)
drpSwitchB = drpSwitch broadcast
par :: Functor col =>
(forall sf . (a -> col sf -> col (b, sf)))
-> col (SF b c)
-> SF a (col c)
par rf sfs0 = SF {sfTF = tf0}
where
tf0 a0 =
let bsfs0 = rf a0 sfs0
sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
sfs = fmap fst sfcs0
cs0 = fmap snd sfcs0
in
(parAux rf sfs, cs0)
parAux :: Functor col =>
(forall sf . (a -> col sf -> col (b, sf)))
-> col (SF' b c)
-> SF' a (col c)
parAux rf sfs = SF' tf
where
tf dt a =
let bsfs = rf a sfs
sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
sfs' = fmap fst sfcs'
cs = fmap snd sfcs'
in
(parAux rf sfs', cs)
pSwitch :: Functor col =>
(forall sf . (a -> col sf -> col (b, sf)))
-> col (SF b c)
-> SF (a, col c) (Event d)
-> (col (SF b c) -> d -> SF a (col c))
-> SF a (col c)
pSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}
where
tf0 a0 =
let bsfs0 = rf a0 sfs0
sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
sfs = fmap fst sfcs0
cs0 = fmap snd sfcs0
in
case (sfTF sfe0) (a0, cs0) of
(sfe, NoEvent) -> (pSwitchAux sfs sfe, cs0)
(_, Event d0) -> sfTF (k sfs0 d0) a0
pSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs
pSwitchAux sfs sfe = SF' tf
where
tf dt a =
let bsfs = rf a sfs
sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
sfs' = fmap fst sfcs'
cs = fmap snd sfcs'
in
case (sfTF' sfe) dt (a, cs) of
(sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs)
(_, Event d) -> sfTF (k (freezeCol sfs dt) d) a
dpSwitch :: Functor col =>
(forall sf . (a -> col sf -> col (b, sf)))
-> col (SF b c)
-> SF (a, col c) (Event d)
-> (col (SF b c) -> d -> SF a (col c))
-> SF a (col c)
dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}
where
tf0 a0 =
let bsfs0 = rf a0 sfs0
sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
cs0 = fmap snd sfcs0
in
(case (sfTF sfe0) (a0, cs0) of
(sfe, NoEvent) -> dpSwitchAux (fmap fst sfcs0) sfe
(_, Event d0) -> fst (sfTF (k sfs0 d0) a0),
cs0)
dpSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs
dpSwitchAux sfs sfe = SF' tf
where
tf dt a =
let bsfs = rf a sfs
sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
cs = fmap snd sfcs'
in
(case (sfTF' sfe) dt (a, cs) of
(sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs')
sfe'
(_, Event d) -> fst (sfTF (k (freezeCol sfs dt)
d)
a),
cs)
rpSwitch :: Functor col =>
(forall sf . (a -> col sf -> col (b, sf)))
-> col (SF b c)
-> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)
rpSwitch rf sfs =
pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->
noEventSnd >=- rpSwitch rf (f sfs')
drpSwitch :: Functor col =>
(forall sf . (a -> col sf -> col (b, sf)))
-> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)
drpSwitch rf sfs =
dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->
noEventSnd >=- drpSwitch rf (f sfs')
old_hold :: a -> SF (Event a) a
old_hold a_init = switch (constant a_init &&& identity)
((NoEvent >--) . old_hold)
hold :: a
-> SF (Event a) a
hold a_init = epPrim f () a_init
where
f _ a = ((), a, a)
dHold :: a -> SF (Event a) a
dHold a0 = hold a0 >>> iPre a0
trackAndHold :: a
-> SF (Maybe a) a
trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init
old_accum :: a -> SF (Event (a -> a)) (Event a)
old_accum = accumBy (flip ($))
accum :: a
-> SF (Event (a -> a)) (Event a)
accum a_init = epPrim f a_init NoEvent
where
f a g = (a', Event a', NoEvent)
where
a' = g a
accumHold :: a
-> SF (Event (a -> a)) a
accumHold a_init = epPrim f a_init a_init
where
f a g = (a', a', a')
where
a' = g a
dAccumHold :: a -> SF (Event (a -> a)) a
dAccumHold a_init = accumHold a_init >>> iPre a_init
old_accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)
old_accumBy f b_init = switch (never &&& identity) $ \a -> abAux (f b_init a)
where
abAux b = switch (now b &&& notYet) $ \a -> abAux (f b a)
accumBy :: (b -> a -> b)
-> b
-> SF (Event a) (Event b)
accumBy g b_init = epPrim f b_init NoEvent
where
f b a = (b', Event b', NoEvent)
where
b' = g b a
accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b
accumHoldBy g b_init = epPrim f b_init b_init
where
f b a = (b', b', b')
where
b' = g b a
dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b
dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init
old_accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)
old_accumFilter f c_init = switch (never &&& identity) $ \a -> afAux (f c_init a)
where
afAux (c, Nothing) = switch (never &&& notYet) $ \a -> afAux (f c a)
afAux (c, Just b) = switch (now b &&& notYet) $ \a -> afAux (f c a)
accumFilter :: (c -> a -> (c, Maybe b))
-> c
-> SF (Event a) (Event b)
accumFilter g c_init = epPrim f c_init NoEvent
where
f c a = case g c a of
(c', Nothing) -> (c', NoEvent, NoEvent)
(c', Just b) -> (c', Event b, NoEvent)
old_pre :: SF a a
old_pre = SF {sfTF = tf0}
where
tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.")
preAux a_prev = SF' tf
where
tf _ a = (preAux a, a_prev)
old_iPre :: a -> SF a a
old_iPre = (--> old_pre)
pre :: SF a a
pre = sscanPrim f uninit uninit
where
f c a = Just (a, c)
uninit = usrErr "AFRP" "pre" "Uninitialized pre operator."
iPre :: a
-> SF a a
iPre = (--> pre)
delay :: Time
-> a
-> SF a a
delay q a_init | q < 0 = usrErr "AFRP" "delay" "Negative delay."
| q == 0 = identity
| otherwise = SF {sfTF = tf0}
where
tf0 a0 = (delayAux [] [(q, a0)] 0 a_init, a_init)
delayAux _ [] _ _ = undefined
delayAux rbuf buf@((bdt, ba) : buf') t_diff a_prev = SF' tf
where
tf dt a | t_diff' < bdt =
(delayAux rbuf' buf t_diff' a_prev, a_prev)
| otherwise = nextSmpl rbuf' buf' (t_diff' bdt) ba
where
t_diff' = t_diff + dt
rbuf' = (dt, a) : rbuf
nextSmpl rbuf [] t_diff a =
nextSmpl [] (reverse rbuf) t_diff a
nextSmpl rbuf buf@((bdt, ba) : buf') t_diff a
| t_diff < bdt = (delayAux rbuf buf t_diff a, a)
| otherwise = nextSmpl rbuf buf' (t_diffbdt) ba
integral :: VectorSpace a s => SF a a
integral = SF {sfTF = tf0}
where
igrl0 = zeroVector
tf0 a0 = (integralAux igrl0 a0, igrl0)
integralAux igrl a_prev = SF' tf
where
tf dt a = (integralAux igrl' a, igrl')
where
igrl' = igrl ^+^ realToFrac dt *^ a_prev
imIntegral :: VectorSpace a s => a -> SF a a
imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`)
iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b
f `iterFrom` b = SF (iterAux b) where
iterAux b a = (SF' (\ dt a' -> iterAux (f a a' dt b) a'), b)
derivative :: VectorSpace a s => SF a a
derivative = SF {sfTF = tf0}
where
tf0 a0 = (derivativeAux a0, zeroVector)
derivativeAux a_prev = SF' tf
where
tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)
loopPre :: c -> SF (a,c) (b,c) -> SF a b
loopPre c_init sf = loop (second (iPre c_init) >>> sf)
loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b
loopIntegral sf = loop (second integral >>> sf)
noise :: (RandomGen g, Random b) => g -> SF a b
noise g0 = streamToSF (randoms g0)
noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b
noiseR range g0 = streamToSF (randomRs range g0)
streamToSF :: [b] -> SF a b
streamToSF [] = intErr "AFRP" "streamToSF" "Empty list!"
streamToSF (b:bs) = SF {sfTF = tf0}
where
tf0 _ = (stsfAux bs, b)
stsfAux [] = intErr "AFRP" "streamToSF" "Empty list!"
stsfAux (b:bs) = SF' tf
where
tf _ _ = (stsfAux bs, b)
occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b)
occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0}
| otherwise = usrErr "AFRP" "occasionally"
"Non-positive average interval."
where
tf0 _ = (occAux ((randoms g) :: [Time]), NoEvent)
occAux [] = undefined
occAux (r:rs) = SF' tf
where
tf dt _ = let p = 1 exp ((dt/t_avg))
in (occAux rs, if r < p then Event x else NoEvent)
reactimate :: IO a
-> (Bool -> IO (DTime, Maybe a))
-> (Bool -> b -> IO Bool)
-> SF a b
-> IO ()
reactimate init sense actuate (SF {sfTF = tf0}) =
do
a0 <- init
let (sf, b0) = tf0 a0
loop sf a0 b0
where
loop sf a b = do
done <- actuate True b
unless (a `seq` b `seq` done) $ do
(dt, ma') <- sense False
let a' = maybe a id ma'
(sf', b') = (sfTF' sf) dt a'
loop sf' a' b'
data ReactState a b = ReactState {
rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool,
rsSF :: SF' a b,
rsA :: a,
rsB :: b
}
type ReactHandle a b = IORef (ReactState a b)
reactInit :: IO a
-> (ReactHandle a b -> Bool -> b -> IO Bool)
-> SF a b
-> IO (ReactHandle a b)
reactInit init actuate (SF {sfTF = tf0}) =
do a0 <- init
let (sf,b0) = tf0 a0
r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf,
rsA = a0, rsB = b0 })
done <- actuate r True b0
return r
react :: ReactHandle a b
-> (DTime,Maybe a)
-> IO Bool
react rh (dt,ma') =
do rs@(ReactState {rsActuate = actuate,
rsSF = sf,
rsA = a,
rsB = b }) <- readIORef rh
let a' = maybe a id ma'
(sf',b') = (sfTF' sf) dt a'
writeIORef rh (rs {rsSF = sf',rsA = a',rsB = b'})
done <- actuate rh True b'
return done
embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]
embed sf0 (a0, dtas) = b0 : loop a0 sf dtas
where
(sf, b0) = (sfTF sf0) a0
loop _ _ [] = []
loop a_prev sf ((dt, ma) : dtas) =
b : (a `seq` b `seq` (loop a sf' dtas))
where
a = maybe a_prev id ma
(sf', b) = (sfTF' sf) dt a
embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b
embedSynch sf0 (a0, dtas) = SF {sfTF = tf0}
where
tts = scanl (\t (dt, _) -> t + dt) 0 dtas
bbs@(b:_) = embed sf0 (a0, dtas)
tf0 _ = (esAux 0 (zip tts bbs), b)
esAux _ [] = intErr "AFRP" "embedSynch" "Empty list!"
esAux tp_prev tbtbs = SF' tf
where
tf dt r | r < 0 = usrErr "AFRP" "embedSynch"
"Negative ratio."
| otherwise = let tp = tp_prev + dt * r
(b, tbtbs') = advance tp tbtbs
in
(esAux tp tbtbs', b)
advance _ tbtbs@[(_, b)] = (b, tbtbs)
advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _))
| tp < t' = (b, tbtbtbs)
| t' <= tp = advance tp tbtbs
advance _ _ = undefined
deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncode _ [] = usrErr "AFRP" "deltaEncode" "Empty input list."
deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas
deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncodeBy _ _ [] = usrErr "AFRP" "deltaEncodeBy" "Empty input list."
deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as))
where
debAux _ [] = []
debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as
| otherwise = Just a : debAux a as
newtype Step a b = Step { stepSf :: SF' a b }
initStep :: a
-> SF a b
-> (b, Step a b)
initStep x sf =
let (sf', x') = sfTF sf x in
(x', Step sf')
step :: DTime
-> a
-> Step a b
-> (b, Step a b)
step dt x (Step sf) =
let (sf', x') = sfTF' sf dt x in
(x', Step sf')