module Control.Varying.Spline (
Spline,
SplineT(..),
runSplineT,
scanSpline,
fromEvents,
outputStream,
resultStream,
step,
untilEvent,
untilEvent_,
_untilEvent,
pair,
race,
capture,
mapOutput,
adjustInput,
Step(..),
) where
import Control.Varying.Core
import Control.Varying.Event
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad
import Control.Applicative
import Data.Monoid
import Data.Functor.Identity
data Step b c = Step { stepOutput :: b
, stepResult :: Event c
}
mapStepOutput :: (a -> b) -> Step a c -> Step b c
mapStepOutput f (Step a b) = Step (f a) b
instance Functor (Step a) where
fmap f (Step a b) = Step a $ fmap f b
instance (Monoid f, Monoid b) => Monoid (Step f b) where
mempty = Step mempty (Event mempty)
mappend (Step a ea) (Step b eb) = Step (mappend a b) (mappend <$> ea <*> eb)
instance Monoid f => Applicative (Step f) where
pure a = Step mempty $ Event a
(Step uia f) <*> (Step uib b) = Step (mappend uia uib) (f <*> b)
data SplineT a b m c = SplineT { unSplineT :: VarT m a (Step (Event b) c) }
| SplineTConst c
runSplineT :: (Applicative m, Monad m)
=> SplineT a b m c -> VarT m a (Step (Event b) c)
runSplineT (SplineT v) = v
runSplineT (SplineTConst x) = pure $ pure x
scanSpline :: (Applicative m, Monad m)
=> SplineT a b m c -> [a] -> m [(Event b, Event c)]
scanSpline s as = map f <$> scanVar (runSplineT s) as
where f (Step eb ec) = (eb,ec)
type Spline a b c = SplineT a b Identity c
instance (Applicative m, Monad m) => Functor (SplineT a b m) where
fmap f (SplineTConst c) = SplineTConst $ f c
fmap f (SplineT v) = SplineT $ fmap (fmap f) v
instance (Applicative m, Monad m) => Applicative (SplineT a b m) where
pure = SplineTConst
(SplineTConst f) <*> (SplineTConst x) = SplineTConst $ f x
(SplineT vf) <*> (SplineTConst x) = SplineT $ fmap (fmap ($ x)) vf
(SplineTConst f) <*> (SplineT vx) = SplineT $ fmap (fmap f) vx
(SplineT vf) <*> (SplineT vx) = SplineT $ ((<*>) <$> vf) <*> vx
instance (Applicative m, Monad m) => Monad (SplineT a b m) where
return = pure
(SplineTConst x) >>= f = f x
(SplineT v) >>= f = SplineT $ VarT $ \i -> do
(Step b e, v') <- runVarT v i
case e of
NoEvent -> return (Step b NoEvent, runSplineT $ SplineT v' >>= f)
Event x -> runVarT (runSplineT $ f x) i
instance MonadTrans (SplineT a b) where
lift f = SplineT $ varM $ const $ liftM (Step mempty . Event) f
instance (Functor m, Applicative m, MonadIO m) => MonadIO (SplineT a b m) where
liftIO = lift . liftIO
outputStream :: (Applicative m, Monad m)
=> b -> SplineT a b m c -> VarT m a b
outputStream x s = ((stepOutput <$>) $ runSplineT s) ~> foldStream (\_ y -> y) x
resultStream :: (Applicative m, Monad m) => SplineT a b m c -> VarT m a (Event c)
resultStream = (stepResult <$>) . runSplineT
fromEvents :: (Applicative m, Monad m) => b -> VarT m a (Event b) -> SplineT a b m b
fromEvents x ve = SplineT $ VarT $ \a -> do
(ex, ve') <- runVarT ve a
case ex of
NoEvent -> let n = Step (Event x) (Event x) in return (n, pure n)
Event x' -> return ( Step (Event x') NoEvent
, runSplineT $ fromEvents x' ve'
)
untilEvent :: (Applicative m, Monad m)
=> VarT m a b -> VarT m a (Event c)
-> SplineT a b m (b,c)
untilEvent v ve = SplineT $ t ~> var (uncurry f)
where t = (,) <$> v <*> ve
f b ec = case ec of
NoEvent -> Step (Event b) NoEvent
Event c -> Step (Event b) (Event (b, c))
untilEvent_ :: (Applicative m, Monad m)
=> VarT m a b -> VarT m a (Event c)
-> SplineT a b m b
untilEvent_ v ve = fst <$> untilEvent v ve
_untilEvent :: (Applicative m, Monad m)
=> VarT m a b -> VarT m a (Event c)
-> SplineT a b m b
_untilEvent v ve = fst <$> untilEvent v ve
race :: (Applicative m, Monad m)
=> (b -> d -> e) -> SplineT a b m c -> SplineT a d m c -> SplineT a e m c
race f (SplineTConst a) s =
race f (SplineT $ pure $ Step mempty $ Event a) s
race f s (SplineTConst b) =
race f s (SplineT $ pure $ Step mempty $ Event b)
race f (SplineT va) (SplineT vb) = SplineT $ VarT $ \i -> do
(Step ua ea, va') <- runVarT va i
(Step ub eb, vb') <- runVarT vb i
let s' = runSplineT $ race f (SplineT va') (SplineT vb')
case (ea,eb) of
(Event a,_) -> return (Step (f <$> ua <*> ub) ea, s')
(_,Event b) -> return (Step (f <$> ua <*> ub) eb, s')
(_,_) -> return (Step (f <$> ua <*> ub) NoEvent, s')
pair :: (Monad m)
=> (b -> d -> f) -> SplineT a b m c -> SplineT a d m e
-> SplineT a f m (c, e)
pair f (SplineTConst a) s = pair f (SplineT $ pure $ Step mempty $ Event a) s
pair f s (SplineTConst b) = pair f s (SplineT $ pure $ Step mempty $ Event b)
pair f (SplineT va) (SplineT vb) = SplineT $ VarT $ \a -> do
(Step fa ea, va') <- runVarT va a
(Step fb eb, vb') <- runVarT vb a
return ( Step (f <$> fa <*> fb) ((,) <$> ea <*> eb)
, runSplineT $ pair f (SplineT va') (SplineT vb')
)
capture :: (Applicative m, Monad m, Eq b)
=> SplineT a b m c -> SplineT a b m (Maybe b, c)
capture (SplineTConst x) = SplineTConst (Nothing, x)
capture (SplineT v) = capture' Nothing v
where capture' mb v' = SplineT $ VarT $ \a -> do
(Step fb ec, v'') <- runVarT v' a
let mb' = if fb == NoEvent then mb else toMaybe fb
ec' = (mb',) <$> ec
return (Step fb ec', runSplineT $ capture' mb' v'')
step :: (Applicative m, Monad m) => b -> SplineT a b m ()
step b = SplineT $ VarT $ \_ ->
return (Step (pure b) NoEvent, pure $ Step (pure b) $ Event ())
mapOutput :: (Applicative m, Monad m)
=> VarT m a (b -> t) -> SplineT a b m c -> SplineT a t m c
mapOutput _ (SplineTConst c) = SplineTConst c
mapOutput vf (SplineT vx) = SplineT $ mapStepOutput <$> vg <*> vx
where vg = (<$>) <$> vf
adjustInput :: (Monad m)
=> VarT m a (a -> r) -> SplineT r b m c -> SplineT a b m c
adjustInput _ (SplineTConst c) = SplineTConst c
adjustInput vf (SplineT vx) = SplineT $ VarT $ \a -> do
(f, vf') <- runVarT vf a
(b, vx') <- runVarT vx $ f a
return (b, runSplineT $ adjustInput vf' $ SplineT vx')