{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
module Control.Varying.Spline (
Spline,
execSpline,
spline,
SplineT(..),
runSplineT,
evalSplineT,
execSplineT,
output,
untilEvent,
race,
mix,
capture,
mapOutput,
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
data Step f b where
Step :: Monoid f => f -> Event b -> Step f b
stepIter :: Step f b -> f
stepIter (Step a _) = a
stepResult :: Step f b -> Event b
stepResult (Step _ b) = b
toIter :: (Functor f, Monoid (f b))
=> (f a -> f b) -> Step (f a) c -> Step (f b) c
toIter f (Step a b) = Step (f a) b
instance Functor (Step f) 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 f a b m c = SplineT { unSplineT :: Var m a (Step (f b) c) }
| SplineTConst c
runSplineT :: (Applicative m, Monad m, Monoid (f b))
=> SplineT f a b m c -> Var m a (Step (f b) c)
runSplineT (SplineT v) = v
runSplineT (SplineTConst x) = pure $ pure x
type Spline a b m c = SplineT Event a b m c
instance (Applicative m, Monad m) => Functor (SplineT f a b m) where
fmap f (SplineTConst c) = SplineTConst $ f c
fmap f (SplineT v) = SplineT $ fmap (fmap f) v
instance (Monoid (f b), Applicative m, Monad m)
=> Applicative (SplineT f 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 (Monoid (f b), Applicative m, Monad m) => Monad (SplineT f a b m) where
return = pure
(SplineTConst x) >>= f = f x
(SplineT v) >>= f = SplineT $ Var $ \i -> do
(Step b e, v') <- runVar v i
case e of
NoEvent -> return (Step b NoEvent, runSplineT $ SplineT v' >>= f)
Event x -> runVar (runSplineT $ f x) i
instance Monoid (f b) => MonadTrans (SplineT f a b) where
lift f = SplineT $ varM $ const $ liftM (Step mempty . Event) f
instance (Monoid (f b), Functor m, Applicative m, MonadIO m)
=> MonadIO (SplineT f a b m) where
liftIO = lift . liftIO
execSplineT :: (Applicative m, Monad m, Monoid (f b))
=> SplineT f a b m c -> Var m a (f b)
execSplineT = (stepIter <$>) . runSplineT
evalSplineT :: (Applicative m, Monad m, Monoid (f b))
=> SplineT f a b m c -> Var m a (Event c)
evalSplineT = (stepResult <$>) . runSplineT
spline :: (Applicative m, Monad m) => b -> Var m a (Event b) -> Spline a b m b
spline x ve = SplineT $ Var $ \a -> do
(ex, ve') <- runVar 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 $ spline x' ve')
execSpline :: (Applicative m, Monad m) => b -> Spline a b m c -> Var m a b
execSpline x (SplineTConst _) = pure x
execSpline x s = execSplineT s ~> foldStream (\_ y -> y) x
untilEvent :: (Applicative m, Monad m)
=> Var m a b -> Var m a (Event c)
-> Spline 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))
race :: (Applicative m, Monad m, Monoid (f u))
=> SplineT f i u m a -> SplineT f i u m a -> SplineT f i u m a
race (SplineTConst a) s =
race (SplineT $ pure $ Step mempty $ Event a) s
race s (SplineTConst b) =
race s (SplineT $ pure $ Step mempty $ Event b)
race (SplineT va) (SplineT vb) = SplineT $ Var $ \i -> do
(Step ua ea, va') <- runVar va i
(Step ub eb, vb') <- runVar vb i
case (ea,eb) of
(Event _,_) -> return (Step (ua <> ub) ea, va')
(_,Event _) -> return (Step (ua <> ub) eb, vb')
(_,_) -> return (Step (ua <> ub) NoEvent,
runSplineT $ race (SplineT va') (SplineT vb'))
mix :: (Applicative m, Monad m, Monoid (f b))
=> [Maybe c -> SplineT f a b m c] -> SplineT f a b m ()
-> SplineT f a b m [Maybe c]
mix gs = go gs es $ zipWith ($) gs xs
where es = replicate n NoEvent
xs = replicate n Nothing
n = length gs
go fs evs guis egui = SplineT $ Var $ \a -> do
let step (ecs, fb, vs) (f, ec, g) = do
(Step fb' ec', v) <- runVar (runSplineT g) a
let ec'' = ec <> ec'
fb'' = fb <> fb'
v' = case ec' of
NoEvent -> v
Event c -> runSplineT $ f $ Just c
return (ecs ++ [ec''], fb'', vs ++ [SplineT v'])
(ecs, fb, guis') <- foldM step ([],mempty,[]) (zip3 fs evs guis)
(Step fb' ec, v) <- runVar (runSplineT egui) a
let fb'' = fb <> fb'
ec' = map toMaybe ecs <$ ec
return (Step fb'' ec',
runSplineT $ go fs ecs guis' $ SplineT v)
capture :: (Applicative m, Monad m, Monoid (f b), Eq (f b))
=> SplineT f a b m c -> SplineT f a b m (f b, c)
capture (SplineTConst x) = SplineTConst (mempty, x)
capture (SplineT v) = capture' mempty v
where capture' mb v' = SplineT $ Var $ \a -> do
(Step fb ec, v'') <- runVar v' a
let mb' = if fb == mempty then mb else fb
ec' = (mb',) <$> ec
return (Step fb ec', runSplineT $ capture' mb' v'')
output :: (Applicative m, Monad m, Monoid (f b), Applicative f)
=> b -> SplineT f a b m ()
output b = SplineT $ Var $ \_ ->
return (Step (pure b) NoEvent, pure $ Step (pure b) $ Event ())
mapOutput :: (Functor f, Monoid (f t), Applicative m, Monad m)
=> Var m a (b -> t) -> SplineT f a b m c -> SplineT f a t m c
mapOutput _ (SplineTConst c) = SplineTConst c
mapOutput vf (SplineT vx) = SplineT $ toIter <$> vg <*> vx
where vg = (<$>) <$> vf