module FRP.Moe.Core where
import Prelude hiding ((.))
import Data.Monoid
import Data.Functor
import Control.Category
import Control.Applicative
import Control.Arrow
type DTime = Double
newtype SF a b = MkSF {runSF :: DTime -> a -> (b, SF a b)}
sfId :: SF a a
sfId = MkSF (\dt x -> (x, sfId))
sfArr :: (a -> b) -> SF a b
sfArr f = sf where sf = MkSF (\dt x -> (f x, sf))
sfComp :: SF b c -> SF a b -> SF a c
sfComp sf1 sf2 = MkSF (\dt x -> let (y, sf2') = runSF sf2 dt x
(z, sf1') = runSF sf1 dt y
in (z, sfComp sf1' sf2'))
sfLoop :: SF (a, c) (b, c) -> SF a b
sfLoop sf = MkSF (\dt x -> let ((y, z), sf') = runSF sf dt (x, z)
in (y, sfLoop sf'))
sfFirst :: SF a b -> SF (a, c) (b, c)
sfFirst sf = MkSF (\dt (x, y) -> let (z, sf') = runSF sf dt x
in ((z, y), sfFirst sf'))
sfSecond :: SF a b -> SF (c, a) (c, b)
sfSecond sf = MkSF (\dt (x, y) -> let (z, sf') = runSF sf dt y
in ((x, z), sfSecond sf'))
sfLeft :: SF a b -> SF (Either a c) (Either b c)
sfLeft sf = MkSF (\dt xy -> case xy of
Left x -> let (z, sf') = runSF sf dt x
in (Left z, sfLeft sf')
Right y -> (Right y, sfLeft sf))
sfRight :: SF a b -> SF (Either c a) (Either c b)
sfRight sf = MkSF (\dt xy -> case xy of
Left x -> (Left x, sfRight sf)
Right y -> let (z, sf') = runSF sf dt y
in (Right z, sfRight sf'))
sfDelay :: a -> SF a a
sfDelay x0 = MkSF (\dt x -> (x0, sfDelay x))
dTime :: SF () DTime
dTime = MkSF (\dt x -> (dt, dTime))
instance Monoid b => Monoid (SF a b) where
mempty = sfArr (\_ -> mempty)
mappend sf1 sf2 = mappend <$> sf1 <*> sf2
instance Functor (SF a) where
fmap f sf = MkSF (\dt x -> let (y, sf') = runSF sf dt x
in (f y, fmap f sf'))
instance Applicative (SF a) where
pure x = sfArr (const x)
sff <*> sfy = MkSF (\dt x -> let (f, sff') = runSF sff dt x
(y, sfy') = runSF sfy dt x
in (f y, sff' <*> sfy'))
instance Category SF where
id = sfId
(.) = sfComp
instance Arrow SF where
arr = sfArr
first = sfFirst
second = sfSecond
sf1 &&& sf2 = MkSF (\dt x -> let (y, sf1') = runSF sf1 dt x
(z, sf2') = runSF sf2 dt x
in ((y, z), sf1' &&& sf2'))
sf1 *** sf2 = MkSF (\dt (x, y) -> let (z, sf1') = runSF sf1 dt x
(u, sf2') = runSF sf2 dt y
in ((z, u), sf1' *** sf2'))
instance ArrowLoop SF where
loop = sfLoop
class Arrow a => ArrowDelay a where
delay :: b -> a b b
instance ArrowDelay SF where
delay = sfDelay
instance ArrowChoice SF where
left = sfLeft
right = sfRight
sf1 ||| sf2 = MkSF (\dt xy -> case xy of
Left x -> let (z, sf1') = runSF sf1 dt x
in (z, sf1' ||| sf2)
Right y -> let (z, sf2') = runSF sf2 dt y
in (z, sf1 ||| sf2'))
sf1 +++ sf2 = MkSF (\dt xy -> case xy of
Left x -> let (z, sf1') = runSF sf1 dt x
in (Left z, sf1' +++ sf2)
Right y -> let (z, sf2') = runSF sf2 dt y
in (Right z, sf1 +++ sf2'))
data Event a = Event a | NoEvent
switch :: SF b (c, Event d) -> (d -> SF b c) -> SF b c
switch sf gen = MkSF (\dt x -> let ((y, ev), sf') = runSF sf dt x
in case ev of
NoEvent -> (y, switch sf' gen)
Event e -> runSF (gen e) dt x)
dswitch :: SF b (c, Event d) -> (d -> SF b c) -> SF b c
dswitch sf gen = MkSF (\dt x -> let ((y, ev), sf') = runSF sf dt x
in case ev of
NoEvent -> (y, dswitch sf' gen)
Event e -> (y, snd (runSF (gen e) dt x)))
kswitch :: SF a b -> SF (a, b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
kswitch sf sfe gen = MkSF (\dt x -> let (y, sf') = runSF sf dt x
(ev, sfe') = runSF sfe dt (x, y)
in case ev of
NoEvent -> (y, kswitch sf' sfe' gen)
Event e -> runSF (gen sf' e) dt x)
dkswitch :: SF a b -> SF (a, b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
dkswitch sf sfe gen = MkSF (\dt x -> let (y, sf') = runSF sf dt x
(ev, sfe') = runSF sfe dt (x, y)
in case ev of
NoEvent -> (y, dkswitch sf' sfe' gen)
Event e -> (y, snd (runSF (gen sf' e) dt x)))
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 route sfs sfe gen = MkSF (\dt x -> let ysfs = route x sfs
zssfs = fmap (\(y, sf) -> runSF sf dt y) ysfs
zs = fmap fst zssfs
sfs' = fmap snd zssfs
(e, sfe') = runSF sfe dt (x, zs)
in case e of
NoEvent -> (zs, pswitch route sfs' sfe' gen)
Event ev -> runSF (gen sfs' ev) dt x)
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 route sfs sfe gen = MkSF (\dt x -> let ysfs = route x sfs
zssfs = fmap (\(y, sf) -> runSF sf dt y) ysfs
zs = fmap fst zssfs
sfs' = fmap snd zssfs
(e, sfe') = runSF sfe dt (x, zs)
in case e of
NoEvent -> (zs, dpswitch route sfs' sfe' gen)
Event ev -> (zs, snd (runSF (gen sfs' ev) dt x)))
nth :: Int -> DTime -> SF () a -> a
nth n dt sf = let f = runSF sf
(x, sf') = f dt ()
in if n == 0
then x
else x `seq` nth (n 1) dt sf'
gen :: SF a b -> [(DTime, a)] -> [b]
gen sf [] = []
gen sf ((dt, x) : dtxs) = let f = runSF sf
(y, sf') = f dt x
in y `seq` (y : gen sf' dtxs)