diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,8 +2,9 @@ import Control.Varying import Control.Applicative -import Control.Concurrent (forkIO, killThread) +import Control.Monad (void) import Data.Functor.Identity +import Data.Function (fix) import Data.Time.Clock -- | A simple 2d point type. @@ -11,8 +12,6 @@ , py :: Float } deriving (Show, Eq) -newtype Delta = Delta { unDelta :: Float } - -- An exponential tween back and forth from 0 to 50 over 1 seconds that -- loops forever. This spline takes float values of delta time as input, -- outputs the current x value at every step. @@ -33,12 +32,8 @@ tween_ easeOutExpo 0 50 1 tweeny --- Our time signal counts input delta time samples. -time :: (Applicative m, Monad m) => VarT m Delta Float -time = var unDelta - -- | Our Point value that varies over time continuously in x and y. -backAndForth :: (Applicative m, Monad m) => VarT m Delta Point +backAndForth :: (Applicative m, Monad m) => VarT m Float Point backAndForth = -- Turn our splines into continuous output streams. We must provide -- a starting value since splines are not guaranteed to be defined at @@ -48,31 +43,25 @@ in -- Construct a varying Point that takes time as an input. (Point <$> x <*> y) - -- Stream in a time signal using the 'plug left' combinator. - -- We could similarly use the 'plug right' (~>) function - -- and put the time signal before the construction above. This is needed - -- because the tween streams take time as an input. - <~ time -main :: IO () -main = do - putStrLn "An example of value streams using the varying library." - putStrLn "Enter a newline to continue, and then a newline to quit" - _ <- getLine - - t <- getCurrentTime - tId <- forkIO $ loop backAndForth t +-- | An example of using 'fix' and combining splines to get a better programming +-- experience while writing tweens. +betterBackAndForth :: (Applicative m, Monad m) => VarT m Float Point +betterBackAndForth = flip tweenStream (Point 0 0) $ fix $ \nxt -> do + void $ race Point (tween_ easeOutExpo 0 50 1) (tween_ easeOutExpo 50 0 1) + void $ race Point (tween_ easeOutExpo 50 0 1) (tween_ easeOutExpo 0 50 1) + nxt - _ <- getLine - killThread tId +main :: IO () +main = getCurrentTime >>= loop betterBackAndForth -loop :: Var Delta Point -> UTCTime -> IO () +loop :: Var Float Point -> UTCTime -> IO () loop v t = do t1 <- getCurrentTime -- Here we'll run in the Identity monad using a time delta provided by -- getCurrentTime and diffUTCTime. let dt = realToFrac $ diffUTCTime t1 t - Identity (Point x y, vNext) = runVarT v $ Delta dt + Identity (Point x y, vNext) = runVarT v dt xStr = replicate (round x) ' ' ++ "x" ++ replicate (50 - round x) ' ' yStr = replicate (round y) ' ' ++ "y" ++ replicate (50 - round y) ' ' str = zipWith f xStr yStr diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -24,3 +24,9 @@ 0.6.0.0 - changed the internal type of SplineT to use Either, reducing unused output values and preventing time/space leaks. Updated tween types. Added withTween(_). + +0.7.0.0 - added proofs, reduced API size by removing trivial or weird (special) + combinators, changed some names, Event is a synonym of Maybe, removed + Time (moved functions to Event), renamed Event.mergeE to Event.bothE, + added Spline.untilProc and Spline.whileProc, documentation - working + towards 1.0 diff --git a/src/Control/Varying.hs b/src/Control/Varying.hs --- a/src/Control/Varying.hs +++ b/src/Control/Varying.hs @@ -1,37 +1,32 @@ -- | -- Module: Control.Varying --- Copyright: (c) 2015 Schell Scivally +-- Copyright: (c) 2016 Schell Scivally -- License: MIT --- Maintainer: Schell Scivally +-- Maintainer: Schell Scivally -- -- [@Core@] --- Get started writing value streams using the pure constructor 'var', the --- monadic constructor 'varM' or the raw constructor 'VarT' +-- Automaton based value streams. -- -- [@Event@] --- Write event streams using the many event emitters and combinators. +-- Discontinuous value streams that occur only sometimes. -- -- [@Spline@] --- Use do-notation to sequence event streams to form complex behavior. +-- Sequencing of value and event streams using do-notation to form complex +-- behavior. -- -- [@Tween@] --- Tween numerical values over time using interpolation functions and the --- "quick 'n dirty" time generators in 'Control.Varying.Time'. --- --- [@Time@] --- Create time streams and temporal event streams. +-- Tween numerical values over time using common easing functions. Great for +-- animation. -- -module Control.Varying ( - -- * Reexports - module Control.Varying.Core, - module Control.Varying.Event, - module Control.Varying.Spline, - module Control.Varying.Time, - module Control.Varying.Tween, -) where +module Control.Varying + ( -- * Reexports + module Control.Varying.Core + , module Control.Varying.Event + , module Control.Varying.Spline + , module Control.Varying.Tween + ) where import Control.Varying.Core import Control.Varying.Event import Control.Varying.Tween -import Control.Varying.Time -import Control.Varying.Spline +import Control.Varying.Spline diff --git a/src/Control/Varying/Core.hs b/src/Control/Varying/Core.hs --- a/src/Control/Varying/Core.hs +++ b/src/Control/Varying/Core.hs @@ -1,635 +1,734 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE BangPatterns #-} --- | --- Module: Control.Varying.Core --- Copyright: (c) 2015 Schell Scivally --- License: MIT --- Maintainer: Schell Scivally --- --- Value streams represent values that change over a given domain. --- --- A stream takes some input (the domain e.g. time, place, etc) and when --- sampled using 'runVarT' - produces a value and a new value stream. This --- pattern is known as an automaton. `varying` uses this pattern as its base --- type with the additon of a monadic computation to create locally stateful --- signals that change over some domain. -module Control.Varying.Core ( - Var, - VarT(..), - -- * Creating value streams - -- $creation - done, - var, - varM, - mkState, - -- * Composing value streams - -- $composition - (<~), - (~>), - (<<<), - (>>>), - -- * Adjusting and accumulating - delay, - accumulate, - -- * Sampling value streams (running and other entry points) - -- $running - scanVar, - stepMany, - -- * Tracing value streams in flight - vtrace, - vstrace, - vftrace, -) where - -import Prelude hiding (id, (.)) -import Control.Arrow -import Control.Category -import Control.Monad -import Control.Applicative -import Data.Monoid -import Data.Functor.Identity -import Debug.Trace --------------------------------------------------------------------------------- --- Core datatypes --------------------------------------------------------------------------------- --- | A value stream parameterized with Identity that takes input of type @a@ --- and gives output of type @b@. This is the pure, effect-free version of --- 'VarT'. -type Var a b = VarT Identity a b - --- | A value stream is a structure that contains a value that changes over some --- input. It's a kind of Mealy machine (an automaton) with effects. Using --- 'runVarT' with an input value of type 'a' yields a "step", which is a value --- of type 'b' and a new 'VarT' for yielding the next value. -newtype VarT m a b = VarT { runVarT :: a -> m (b, VarT m a b) } - -- ^ Given an input value, return a computation that - -- effectfully produces an output value and a new stream for - -- producing the next sample. --------------------------------------------------------------------------------- --- $creation --- You can create a pure value stream by lifting a function @(a -> b)@ --- with 'var': --- --- @ --- addsOne :: Monad m => VarT m Int Int --- addsOne = var (+1) --- @ --- --- 'var' is equivalent to 'arr'. --- --- You can create a monadic value stream by lifting a monadic computation --- @(a -> m b)@ using 'varM': --- --- @ --- getsFile :: VarT IO FilePath String --- getsFile = varM readFile --- @ --- --- You can create either with the raw constructor. You can also create your --- own combinators using the raw constructor, as it allows you full control --- over how value streams are stepped and sampled: --- --- @ --- delay :: Monad m => b -> VarT m a b -> VarT m a b --- delay b v = VarT $ \a -> return (b, go a v) --- where go a v' = VarT $ \a' -> do (b', v'') <- runVarT v' a --- return (b', go a' v'') --- @ --- --------------------------------------------------------------------------------- --- | Lift a pure computation into a stream. -var :: Applicative m => (a -> b) -> VarT m a b -var f = VarT $ \(!a) -> pure (f a, var f) - --- | Lift a constant value into a stream. -done :: (Applicative m, Monad m) => b -> VarT m a b -done b = VarT $ \(!_) -> return (b, done b) - --- | Lift a monadic computation into a stream. -varM :: Monad m => (a -> m b) -> VarT m a b -varM f = VarT $ \(!a) -> do - b <- f a - return (b, varM f) - --- | Create a stream from a state transformer. -mkState :: Monad m - => (a -> s -> (b, s)) -- ^ state transformer - -> s -- ^ intial state - -> VarT m a b -mkState f s = VarT $ \(!a) -> do - let (b', s') = f a s - return (b', mkState f s') --------------------------------------------------------------------------------- --- $running --- To sample a stream simply run it in the desired monad with --- 'runVarT'. This will produce a sample value and a new stream. --- --- > do (sample, v') <- runVarT v inputValue - --------------------------------------------------------------------------------- --- | Iterate a stream over a list of input until all input is consumed, --- then iterate the stream using one single input. Returns the resulting --- output value and the new stream. -stepMany :: (Monad m, Functor m) => VarT m a b -> [a] -> a -> m (b, VarT m a b) -stepMany v [] e = runVarT v e -stepMany v (e:es) x = snd <$> runVarT v e >>= \v1 -> stepMany v1 es x - --- | Run the stream over the input values, gathering the output values in a --- list. -scanVar :: (Applicative m, Monad m) => VarT m a b -> [a] -> m ([b], VarT m a b) -scanVar v = foldM f ([], v) - where f (outs, v') a = do (b, v'') <- runVarT v' a - return (outs ++ [b], v'') --------------------------------------------------------------------------------- --- Testing and debugging --------------------------------------------------------------------------------- --- | Trace the sample value of a stream and pass it along as output. This is --- very useful for debugging graphs of streams. -vtrace :: (Applicative a, Show b) => VarT a b b -vtrace = vstrace "" - --- | Trace the sample value of a stream with a prefix and pass the sample along --- as output. This is very useful for debugging graphs of streams. -vstrace :: (Applicative a, Show b) => String -> VarT a b b -vstrace s = vftrace ((s ++) . show) - --- | Trace the sample value after being run through a "show" function. --- This is very useful for debugging graphs of streams. -vftrace :: Applicative a => (b -> String) -> VarT a b b -vftrace f = var $ \b -> trace (f b) b --------------------------------------------------------------------------------- --- Adjusting and accumulating --------------------------------------------------------------------------------- --- | Accumulates input values using a folding function and yields --- that accumulated value each sample. -accumulate :: (Monad m, Applicative m) => (c -> b -> c) -> c -> VarT m b c -accumulate f b = VarT $ \(!a) -> do - let b' = f b a - return (b', accumulate f b') - --- | Delays the given stream by one sample using the argument as the first --- sample. This enables the programmer to create streams that depend on --- themselves for values. For example: --- --- > let v = 1 + delay 0 v in testVar_ v -delay :: (Monad m, Applicative m) => b -> VarT m a b -> VarT m a b -delay b v = VarT $ \(!a) -> return (b, go a v) - where go a v' = VarT $ \(!a') -> do (b', v'') <- runVarT v' a - return (b', go a' v'') --------------------------------------------------------------------------------- --- $composition --- You can compose value streams together using Arrow's '>>>' and '<<<' or the --- synonyms '~>' and '<~'. The "right plug" ('>>>' and '~>') takes the output --- from a value stream on the left and "plugs" it into the input of the value --- stream on the right. --- The "left plug" does the same thing in the opposite direction. This allows --- you to write value streams that read naturally. --------------------------------------------------------------------------------- -(~>) :: (Monad m, Applicative m) => VarT m a b -> VarT m b c -> VarT m a c -(~>) = (>>>) - -(<~) :: (Monad m, Applicative m) => VarT m b c -> VarT m a b -> VarT m a c -(<~) = (<<<) --------------------------------------------------------------------------------- --- Typeclass instances --------------------------------------------------------------------------------- --- | You can transform the sample value of any stream: --- --- > fmap (*3) $ accumulate (+) 0 --- Will sum input values and then multiply the sum by 3. -instance (Applicative m, Monad m) => Functor (VarT m b) where - fmap f v = v >>> var f --- | A very simple category instance. --- --- @ --- id = var id --- f . g = g >>> f --- @ --- or --- --- > f . g = f <<< g --- --- It is preferable for consistency (and readability) to use 'plug left' ('<<<') --- and 'plug right' ('>>>') instead of ('.') where possible. -instance (Applicative m, Monad m) => Category (VarT m) where - id = var id - f0 . g0 = VarT $ \(!a) -> do - (b, g) <- runVarT g0 a - (c, f) <- runVarT f0 b - return (c, f . g) - --- | Streams are applicative. --- --- > (,) <$> pure True <*> var "Applicative" -instance (Applicative m, Monad m) => Applicative (VarT m a) where - pure = done - vf <*> vx = VarT $ \(!a) -> do - (f, vf') <- runVarT vf a - (x, vx') <- runVarT vx a - return (f x, vf' <*> vx') --- Note [1] - --- | Streams are arrows, which means you can use proc notation. --- --- @ --- v = proc a -> do --- ex <- intEventVar -< () --- ey <- anotherIntEventVar -< () --- returnA -\< (+) \<$\> ex \<*\> ey --- @ --- which is equivalent to --- --- > v = (\ex ey -> (+) <$> ex <*> ey) <$> intEventVar <*> anotherIntEventVar -instance (Applicative m, Monad m) => Arrow (VarT m) where - arr = var - first v = VarT $ \(b,d) -> do (c, v') <- runVarT v b - return ((c,d), first v') - --- | Streams can be monoids --- --- > let v = var (const "Hello ") `mappend` var (const "World!") -instance (Applicative m, Monad m, Monoid b) => Monoid (VarT m a b) where - mempty = pure mempty - mappend = liftA2 mappend - --- | Streams can be written as numbers. --- --- > let v = 1 >>> accumulate (+) 0 --- which will sum the natural numbers. -instance (Applicative m, Monad m, Num b) => Num (VarT m a b) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - abs = fmap abs - signum = fmap signum - fromInteger = pure . fromInteger - --- | Streams can be written as floats. --- --- > let v = pi >>> accumulate (*) 0.0 --- which will attempt (and succeed) to multiply pi by zero every step. -instance (Applicative m, Monad m, Floating b) => Floating (VarT m a b) where - pi = pure pi - exp = fmap exp - log = fmap log - sin = fmap sin; sinh = fmap sinh; asin = fmap asin; asinh = fmap asinh - cos = fmap cos; cosh = fmap cosh; acos = fmap acos; acosh = fmap acosh - atan = fmap atan; atanh = fmap atanh - --- | Streams can be written as fractionals. --- --- > let v = 2.5 >>> accumulate (+) 0 --- which will add 2.5 each step. -instance (Applicative m, Monad m, Fractional b) => Fractional (VarT m a b) where - (/) = liftA2 (/) - fromRational = pure . fromRational - - --- [1] Proof of the applicative laws: --- --- identity --- ======== --- pure id <*> va = va --- --- -- Definition of pure --- VarT (\_ -> pure (id, pure id)) <*> v --- --- -- Definition of <*> --- VarT (\x -> do --- (f, vf') <- runVarT (VarT (\_ -> pure (id, pure id))) x --- (a, va') <- runVarT va x --- pure (f a, vf' <*> va')) --- --- -- Newtype --- VarT (\x -> do --- (f, vf') <- (\_ -> pure (id, pure id)) x --- (a, va') <- runVarT va x --- pure (f a, vf' <*> va')) --- --- -- Application --- VarT (\x -> do --- (f, vf') <- pure (id, pure id) --- (a, va') <- runVarT va x --- pure (f a, vf' <*> va')) --- --- -- pure x >>= f = f x --- VarT (\x -> do --- (a, va') <- runVarT va x --- pure (id a, pure id <*> va')) --- --- -- Definition of id --- VarT (\x -> do --- (a, va') <- runVarT va x --- pure (a, pure id <*> va')) --- --- -- Coinduction --- VarT (\x -> do --- (a, va') <- runVarT va x --- pure (a, va')) --- --- -- f >>= pure = f --- VarT (\x -> runVarT va x) --- --- -- Eta reduction --- VarT (runVarT va) --- --- -- Newtype --- va --- --- --- composition --- =========== --- pure (.) <*> u <*> v <*> w = u <*> (v <*> w) --- --- -- Definition of pure --- VarT (\_ -> pure ((.), pure (.))) <*> u <*> v <*> w --- --- -- Definition of <*> --- VarT (\x -> do --- (h, t) <- runVarT (VarT (\_ -> pure ((.), pure (.)))) x --- (f, u') <- runVarT u x --- pure (h f, t <*> u')) <*> v <*> w --- --- -- Newtype --- VarT (\x -> do --- (h, t) <- (\_ -> pure ((.), pure (.))) x --- (f, u') <- runVarT u x --- pure (h f, t <*> u')) <*> v <*> w --- --- -- Application --- VarT (\x -> do --- (h, t) <- pure ((.), pure (.))) --- (f, u') <- runVarT u x --- pure (h f, t <*> u')) <*> v <*> w --- --- -- pure x >>= f = f x --- VarT (\x -> do --- (f, u') <- runVarT u x --- pure ((.) f, pure (.) <*> u')) <*> v <*> w --- --- -- Definition of <*> --- VarT (\x -> do --- (h, t) <- --- runVarT --- (VarT (\y -> do --- (f, u') <- runVarT u y --- pure ((.) f, pure (.) <*> u'))) x --- (g, v') <- runVarT v x --- pure (h g, t <*> v')) <*> w --- --- -- Newtype --- VarT (\x -> do --- (h, t) <- --- (\y -> do --- (f, u') <- runVarT u y --- pure ((.) f, pure (.) <*> u')) x --- (g, v') <- runVarT v x --- pure (h g, t <*> v')) <*> w --- --- -- Application --- VarT (\x -> do --- (h, t) <- do --- (f, u') <- runVarT u x --- pure ((.) f, pure (.) <*> u') --- (g, v') <- runVarT v x --- pure (h g, t <*> v')) <*> w --- --- -- (f >=> g) >=> h = f >=> (g >=> h) --- VarT (\x -> do --- (f, u') <- runVarT u x --- (h, t) <- pure ((.) f, pure (.) <*> u') --- (g, v') <- runVarT v x --- pure (h g, t <*> v')) <*> w --- --- -- pure x >>= f = f x --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- pure ((.) f g, pure (.) <*> u' <*> v')) <*> w --- --- -- Definition of <*> --- VarT (\x -> do --- (h, t) <- --- runVarT --- (VarT (\y -> do --- (f, u') <- runVarT u y --- (g, v') <- runVarT v y --- pure ((.) f g, pure (.) <*> u' <*> v'))) x --- (a, w') <- runVarT w x --- pure (h a, t <*> w')) --- --- -- Newtype --- VarT (\x -> do --- (h, t) <- --- (\y -> do --- (f, u') <- runVarT u y --- (g, v') <- runVarT v y --- pure ((.) f g, pure (.) <*> u' <*> v')) x --- (a, w') <- runVarT w x --- pure (h a, t <*> w')) --- --- -- Application --- VarT (\x -> do --- (h, t) <- do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- pure ((.) f g, pure (.) <*> u' <*> v')) --- (a, w') <- runVarT w x --- pure (h a, t <*> w')) --- --- -- (f >=> g) >=> h = f >=> (g >=> h) --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- (h, t) <- pure ((.) f g, pure (.) <*> u' <*> v')) --- (a, w') <- runVarT w x --- pure (h a, t <*> w')) --- --- -- pure x >>= f = f x --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- (a, w') <- runVarT w x --- pure ((.) f g a, pure (.) <*> u' <*> v' <*> w')) --- --- -- Definition of . --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- (a, w') <- runVarT w x --- pure (f (g a), pure (.) <*> u' <*> v' <*> w')) --- --- -- Coinduction --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- (a, w') <- runVarT w x --- pure (f (g a), u' <*> (v' <*> w'))) --- --- -- pure x >>= f = f --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- (a, w') <- runVarT w x --- (b, vw) <- pure (g a, v' <*> w') --- pure (f b, u' <*> vw)) --- --- -- (f >=> g) >=> h = f >=> (g >=> h) --- VarT (\x -> do --- (f, u') <- runVarT u x --- (b, vw) <- do --- (g, v') <- runVarT v x --- (a, w') <- runVarT w x --- pure (g a, v' <*> w') --- pure (f b, u' <*> vw)) --- --- -- Abstraction --- VarT (\x -> do --- (f, u') <- runVarT u x --- (b, vw) <- --- (\y -> do --- (g, v') <- runVarT v y --- (a, w') <- runVarT w y) --- pure (g a, v' <*> w')) x --- pure (f b, u' <*> vw)) --- --- -- Newtype --- VarT (\x -> do --- (f, u') <- runVarT u x --- (b, vw) <- --- runVarT --- (VarT (\y -> do --- (g, v') <- runVarT v y --- (a, w') <- runVarT w y) --- pure (g a, v' <*> w')) x --- pure (f b, u' <*> vw)) --- --- -- Definition of <*> --- VarT (\x -> do --- (f, u') <- runVarT u x --- (b, vw) <- runVarT (v <*> w) x --- pure (f b, u' <*> vw)) --- --- -- Definition of <*> --- u <*> (v <*> w) --- --- --- homomorphism --- ============ --- pure f <*> pure a = pure (f a) --- --- -- Definition of pure --- VarT (\_ -> pure (f, pure f)) <*> pure a --- --- -- Definition of pure --- VarT (\_ -> pure (f, pure f)) <*> VarT (\_ -> pure (a, pure a)) --- --- -- Definition of <*> --- VarT (\x -> do --- (f', vf') <- runVarT (VarT (\_ -> pure (f, pure f))) x --- (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x --- pure (f' a', vf' <*> va')) --- --- -- Newtype --- VarT (\x -> do --- (f', vf') <- (\_ -> pure (f, pure f)) x --- (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x --- pure (f' a', vf' <*> va')) --- --- -- Application --- VarT (\x -> do --- (f', vf') <- pure (f, pure f) --- (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x --- pure (f' a', vf' <*> va')) --- --- -- pure x >>= f = f x --- VarT (\x -> do --- (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x --- pure (f a', pure f <*> va')) --- --- -- Newtype --- VarT (\x -> do --- (a', va') <- (\_ -> pure (a, pure a)) x --- pure (f a', pure f <*> va')) --- --- -- Application --- VarT (\x -> do --- (a', va') <- pure (a, pure a) --- pure (f a', pure f <*> va')) --- --- -- pure x >>= f = f x --- VarT (\x -> pure (f a, pure f <*> pure a)) --- --- -- Coinduction --- VarT (\x -> pure (f a, pure (f a))) --- --- -- Definition of pure --- pure (f a) --- --- --- interchange --- =========== --- u <*> pure y = pure ($ y) <*> u --- --- -- Definition of <*> --- VarT (\x -> do --- (f, u') <- runVarT u x --- (a, y') <- runVarT (pure y) x --- pure (f a, u' <*> y')) --- --- -- Definition of pure --- VarT (\x -> do --- (f, u') <- runVarT u x --- (a, y') <- runVarT (VarT (\_ -> pure (y, pure y))) x --- pure (f a, u' <*> y')) --- --- -- Newtype --- VarT (\x -> do --- (f, u') <- runVarT u x --- (a, y') <- (\_ -> pure (y, pure y)) x --- pure (f a, u' <*> y')) --- --- -- Application --- VarT (\x -> do --- (f, u') <- runVarT u x --- (a, y') <- pure (y, pure y)) --- pure (f a, u' <*> y')) --- --- -- pure x >>= f = f --- VarT (\x -> do --- (f, u') <- runVarT u x --- pure (f y, u' <*> pure y)) --- --- -- Coinduction --- VarT (\x -> do --- (f, u') <- runVarT u x --- pure (f y, pure ($ y) <*> u')) --- --- -- Definition of $ --- VarT (\x -> do --- (f, u') <- runVarT u x --- pure (($ y) f, pure ($ y) <*> u') --- --- -- pure x >>= f = f --- VarT (\x -> do --- (g, y') <- pure (($ y), pure ($ y)) --- (f, u') <- runVarT u x --- pure (g f, y' <*> u') --- --- -- Abstraction --- VarT (\x -> do --- (g, y') <- (\_ -> pure (($ y), pure ($ y))) x --- (f, u') <- runVarT u x --- pure (g f, y' <*> u') --- --- -- Newtype --- VarT (\x -> do --- (g, y') <- runVarT (VarT (\_ -> pure (($ y), pure ($ y)))) x --- (f, u') <- runVarT u x --- pure (g f, y' <*> u') --- --- -- Definition of <*> --- VarT (\_ -> pure (($ y), pure ($ y))) <*> u --- --- -- Definition of pure --- pure ($ y) <*> u +{-# LANGUAGE CPP #-} +-- | +-- Module: Control.Varying.Core +-- Copyright: (c) 2015 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- Varying values represent values that change over a given domain. +-- +-- A stream/signal takes some input know as the domain (e.g. time, place, etc) +-- and when sampled using 'runVarT' - produces a value and a new stream. This +-- pattern is known as an automaton. `varying` uses this pattern as its base +-- type with the additon of a monadic computation to create locally stateful +-- signals that change over some domain. +module Control.Varying.Core + ( -- * Types and Typeclasses + Var + , VarT(..) + -- * Creating streams + -- $creation + , done + , var + , arr + , varM + , mkState + -- * Composing streams + -- $composition + , (<<<) + , (>>>) + -- * Adjusting and accumulating + , delay + , accumulate + -- * Sampling streams (running and other entry points) + -- $running + , scanVar + , stepMany + -- * Debugging and tracing streams in flight + , vtrace + , vstrace + , vftrace + , testVarOver + -- * Proofs of the Applicative laws + -- $proofs + ) where + +import Prelude hiding (id, (.)) +import Control.Arrow +import Control.Category +import Control.Monad +import Control.Monad.IO.Class +import Control.Applicative +import Data.Functor.Identity +import Debug.Trace +#if __GLASGOW_HASKELL__ <= 709 +import Data.Monoid +#endif +-------------------------------------------------------------------------------- +-- Core datatypes +-------------------------------------------------------------------------------- +-- | A stream parameterized with Identity that takes input of type @a@ +-- and gives output of type @b@. This is the pure, effect-free version of +-- 'VarT'. +type Var a b = VarT Identity a b + +-- | A stream is a structure that contains a value that changes over some +-- input. It's a kind of +-- (an automaton) +-- with effects. Using 'runVarT' with an input value of type 'a' yields a +-- "step", which is a value of type 'b' and a new stream for yielding the next +-- value. +newtype VarT m a b = VarT { runVarT :: a -> m (b, VarT m a b) } + -- ^ Given an input value, return a computation that + -- effectfully produces an output value and a new stream. +-------------------------------------------------------------------------------- +-- Typeclass instances +-------------------------------------------------------------------------------- +-- | You can transform the output value of any stream: +-- +-- >>> let v = 1 >>> fmap (*3) (accumulate (+) 0) +-- >>> testVarOver v [(),(),()] +-- 3 +-- 6 +-- 9 +instance (Applicative m, Monad m) => Functor (VarT m b) where + fmap f v = (var f) . v +-- | A very simple category instance. +-- +-- @ +-- id = var id +-- f . g = g >>> f +-- @ +-- or +-- +-- > f . g = f <<< g +-- +-- >>> let v = accumulate (+) 0 . 1 +-- >>> testVarOver v [(),(),()] +-- 1 +-- 2 +-- 3 +instance (Applicative m, Monad m) => Category (VarT m) where + id = var id + f0 . g0 = VarT $ \(!a) -> do + (b, g) <- runVarT g0 a + (c, f) <- runVarT f0 b + return (c, f . g) + +-- | Streams are applicative. +-- +-- >>> let v = (,) <$> pure True <*> pure "Applicative" +-- >>> testVarOver v [()] +-- (True,"Applicative") +-- +-- Note - checkout the <$proofs proofs> +instance (Applicative m, Monad m) => Applicative (VarT m a) where + pure = done + vf <*> vx = VarT $ \(!a) -> do + (f, vf') <- runVarT vf a + (x, vx') <- runVarT vx a + return (f x, vf' <*> vx') + +-- | Streams are arrows, which means you can use proc notation, among other +-- meanings. +-- +-- >>> :set -XArrows +-- >>> :{ +-- let v = proc t -> do +-- x <- accumulate (+) 0 -< t +-- y <- accumulate (+) 1 -< t +-- returnA -< x + y +-- in testVarOver v [1,1,1] +-- >>> :} +-- 3 +-- 5 +-- 7 +-- +-- which is equivalent to +-- +-- >>> let v = (+) <$> accumulate (+) 0 <*> accumulate (+) 1 +-- >>> testVarOver v [1,1,1] +-- 3 +-- 5 +-- 7 +instance (Applicative m, Monad m) => Arrow (VarT m) where + arr = var + first v = VarT $ \(b,d) -> do (c, v') <- runVarT v b + return ((c,d), first v') + +-- | Streams can be monoids +-- +-- >>> let v = var (const "Hello ") `mappend` var (const "World!") +-- >>> testVarOver v [()] +-- "Hello World!" +instance (Applicative m, Monad m, Monoid b) => Monoid (VarT m a b) where + mempty = pure mempty + mappend = liftA2 mappend + +-- | Streams can be written as numbers. +-- +-- >>> let v = 1 >>> accumulate (+) 0 +-- >>> testVarOver v [(),(),()] +-- 1 +-- 2 +-- 3 +instance (Applicative m, Monad m, Num b) => Num (VarT m a b) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +-- | Streams can be written as floats. +-- +-- >>> let v = pi >>> accumulate (*) 1 >>> arr round +-- >>> testVarOver v [(),(),()] +-- 3 +-- 10 +-- 31 +instance (Applicative m, Monad m, Floating b) => Floating (VarT m a b) where + pi = pure pi + exp = fmap exp + log = fmap log + sin = fmap sin; sinh = fmap sinh; asin = fmap asin; asinh = fmap asinh + cos = fmap cos; cosh = fmap cosh; acos = fmap acos; acosh = fmap acosh + atan = fmap atan; atanh = fmap atanh + +-- | Streams can be written as fractionals. +-- +-- >>> let v = 2.5 >>> accumulate (/) 10 +-- >>> testVarOver v [(),(),()] +-- 4.0 +-- 1.6 +-- 0.64 +instance (Applicative m, Monad m, Fractional b) => Fractional (VarT m a b) where + (/) = liftA2 (/) + fromRational = pure . fromRational +-------------------------------------------------------------------------------- +-- $creation +-- You can create a pure stream by lifting a function @(a -> b)@ +-- with 'var': +-- +-- > arr (+1) == var (+1) :: VarT m Int Int +-- +-- 'var' is a parameterized version of 'arr'. +-- +-- You can create a monadic stream by lifting a monadic computation +-- @(a -> m b)@ using 'varM': +-- +-- @ +-- getsFile :: VarT IO FilePath String +-- getsFile = varM readFile +-- @ +-- +-- You can create either with the raw constructor. You can also create your +-- own combinators using the raw constructor, as it allows you full control +-- over how streams are stepped and sampled: +-- +-- > delay :: Monad m => b -> VarT m a b -> VarT m a b +-- > delay b v = VarT $ \a -> return (b, go a v) +-- > where go a v' = VarT $ \a' -> do (b', v'') <- runVarT v' a +-- > return (b', go a' v'') +-- > +-------------------------------------------------------------------------------- +-- | Lift a pure computation to a stream. This is 'arr' parameterized over the +-- @a `VarT m` b@ arrow. +var :: Applicative m => (a -> b) -> VarT m a b +var f = VarT $ \(!a) -> pure (f a, var f) + +-- | Lift a monadic computation to a stream. This is +-- +-- parameterized over the @a `VarT m` b@ arrow. +varM :: Monad m => (a -> m b) -> VarT m a b +varM f = VarT $ \(!a) -> do + b <- f a + return (b, varM f) + +-- | Lift a constant value to a stream. +done :: (Applicative m, Monad m) => b -> VarT m a b +done b = VarT $ \(!_) -> return (b, done b) + +-- | Create a stream from a state transformer. +mkState :: Monad m + => (a -> s -> (b, s)) -- ^ state transformer + -> s -- ^ intial state + -> VarT m a b +mkState f s = VarT $ \(!a) -> do + let (b', s') = f a s + return (b', mkState f s') +-------------------------------------------------------------------------------- +-- $composition +-- You can compose streams together using Category's '>>>' and '<<<'. The "right +-- plug" ('>>>') takes the output from a stream on the left and "plugs" it into +-- the input of the stream on the right. The "left plug" does the same thing in +-- the opposite direction. This allows you to write streams that read +-- naturally. +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- Adjusting and accumulating +-------------------------------------------------------------------------------- +-- | Accumulates input values using a folding function and yields +-- that accumulated value each sample. This is analogous to a stepwise foldl. +-- +-- >>> testVarOver (accumulate (++) []) $ words "hey there man" +-- "hey" +-- "heythere" +-- "heythereman" +-- +-- >>> print $ foldl (++) [] $ words "hey there man" +-- "heythereman" +accumulate :: (Monad m, Applicative m) => (c -> b -> c) -> c -> VarT m b c +accumulate f b = VarT $ \(!a) -> do + let b' = f b a + return (b', accumulate f b') + +-- | Delays the given stream by one sample using the argument as the first +-- sample. +-- +-- >>> testVarOver (delay 0 id) [1,2,3] +-- 0 +-- 1 +-- 2 +-- +-- This enables the programmer to create streams that depend on +-- themselves for values. For example: +-- +-- >>> let v = delay 0 v + 1 in testVarOver v [1,1,1] +-- 1 +-- 2 +-- 3 +delay :: (Monad m, Applicative m) => b -> VarT m a b -> VarT m a b +delay b v = VarT $ \(!a) -> return (b, go a v) + where go a v' = VarT $ \(!a') -> do (b', v'') <- runVarT v' a + return (b', go a' v'') +-------------------------------------------------------------------------------- +-- $running +-- To sample a stream simply run it in the desired monad with +-- 'runVarT'. This will produce a sample value and a new stream. +-- +-- >>> :{ +-- do let v0 = accumulate (+) 0 +-- (b, v1) <- runVarT v0 1 +-- print b +-- (c, v2) <- runVarT v1 b +-- print c +-- (d, _) <- runVarT v2 c +-- print d +-- >>> :} +-- 1 +-- 2 +-- 4 +-------------------------------------------------------------------------------- +-- | Iterate a stream over a list of input until all input is consumed, +-- then iterate the stream using one single input. Returns the resulting +-- output value and the new stream. +-- +-- >>> let Identity (outputs, _) = stepMany (accumulate (+) 0) [1,1,1] 1 +-- >>> print outputs +-- 4 +stepMany :: (Monad m, Functor m) => VarT m a b -> [a] -> a -> m (b, VarT m a b) +stepMany v [] e = runVarT v e +stepMany v (e:es) x = snd <$> runVarT v e >>= \v1 -> stepMany v1 es x + +-- | Run the stream over the input values, gathering the output values in a +-- list. +-- +-- >>> let Identity (outputs, _) = scanVar (accumulate (+) 0) [1,1,1,1] +-- >>> print outputs +-- [1,2,3,4] +scanVar :: (Applicative m, Monad m) => VarT m a b -> [a] -> m ([b], VarT m a b) +scanVar v = foldM f ([], v) + where f (outs, v') a = do (b, v'') <- runVarT v' a + return (outs ++ [b], v'') +-------------------------------------------------------------------------------- +-- Testing and debugging +-------------------------------------------------------------------------------- +-- | Trace the sample value of a stream and pass it along as output. This is +-- very useful for debugging graphs of streams. The (v|vs|vf)trace family of +-- streams use 'Debug.Trace.trace' under the hood, so the value is only traced +-- when evaluated. +-- +-- >>> let v = id >>> vtrace +-- >>> testVarOver v [1,2,3] +-- 1 +-- 1 +-- 2 +-- 2 +-- 3 +-- 3 +vtrace :: (Applicative a, Show b) => VarT a b b +vtrace = vstrace "" + +-- | Trace the sample value of a stream with a prefix and pass the sample along +-- as output. This is very useful for debugging graphs of streams. +-- +-- >>> let v = id >>> vstrace "test: " +-- >>> testVarOver v [1,2,3] +-- test: 1 +-- 1 +-- test: 2 +-- 2 +-- test: 3 +-- 3 +vstrace :: (Applicative a, Show b) => String -> VarT a b b +vstrace s = vftrace ((s ++) . show) + +-- | Trace the sample value using a custom show-like function. This is useful +-- when you would like to debug a stream that uses values that don't have show +-- instances. +-- +-- >>> newtype NotShowableInt = NotShowableInt { unNotShowableInt :: Int } +-- >>> let v = id >>> vftrace (("NotShowableInt: " ++) . show . unNotShowableInt) +-- >>> let as = map NotShowableInt [1,1,1] +-- >>> bs <- fst <$> scanVar v as +-- >>> -- We need to do something to evaluate these output values... +-- >>> print $ sum $ map unNotShowableInt bs +-- NotShowableInt: 1 +-- NotShowableInt: 1 +-- NotShowableInt: 1 +-- 3 +vftrace :: Applicative a => (b -> String) -> VarT a b b +vftrace f = var $ \b -> trace (f b) b + +-- | Run a stream in IO over some input, printing the output each step. This is +-- the function we've been using throughout this documentation. +testVarOver :: (Applicative m, Monad m, MonadIO m, Show b) + => VarT m a b -> [a] -> m () +testVarOver v xs = fst <$> scanVar v xs >>= mapM_ (liftIO . print) +-------------------------------------------------------------------------------- +-- $proofs +-- ==Identity +-- > pure id <*> va = va +-- +-- > -- Definition of pure +-- > VarT (\_ -> pure (id, pure id)) <*> v +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (f, vf') <- runVarT (VarT (\_ -> pure (id, pure id))) x +-- > (a, va') <- runVarT va x +-- > pure (f a, vf' <*> va')) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (f, vf') <- (\_ -> pure (id, pure id)) x +-- > (a, va') <- runVarT va x +-- > pure (f a, vf' <*> va')) +-- +-- > -- Application +-- > VarT (\x -> do +-- > (f, vf') <- pure (id, pure id) +-- > (a, va') <- runVarT va x +-- > pure (f a, vf' <*> va')) +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> do +-- > (a, va') <- runVarT va x +-- > pure (id a, pure id <*> va')) +-- +-- > -- Definition of id +-- > VarT (\x -> do +-- > (a, va') <- runVarT va x +-- > pure (a, pure id <*> va')) +-- +-- > -- Coinduction +-- > VarT (\x -> do +-- > (a, va') <- runVarT va x +-- > pure (a, va')) +-- +-- > -- f >>= pure = f +-- > VarT (\x -> runVarT va x) +-- +-- > -- Eta reduction +-- > VarT (runVarT va) +-- +-- > -- Newtype +-- > va +-- > +-- +-- ==Composition +-- > pure (.) <*> u <*> v <*> w = u <*> (v <*> w) +-- +-- > -- Definition of pure +-- > VarT (\_ -> pure ((.), pure (.))) <*> u <*> v <*> w +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (h, t) <- runVarT (VarT (\_ -> pure ((.), pure (.)))) x +-- > (f, u') <- runVarT u x +-- > pure (h f, t <*> u')) <*> v <*> w +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (h, t) <- (\_ -> pure ((.), pure (.))) x +-- > (f, u') <- runVarT u x +-- > pure (h f, t <*> u')) <*> v <*> w +-- +-- > -- Application +-- > VarT (\x -> do +-- > (h, t) <- pure ((.), pure (.))) +-- > (f, u') <- runVarT u x +-- > pure (h f, t <*> u')) <*> v <*> w +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > pure ((.) f, pure (.) <*> u')) <*> v <*> w +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (h, t) <- +-- > runVarT +-- > (VarT (\y -> do +-- > (f, u') <- runVarT u y +-- > pure ((.) f, pure (.) <*> u'))) x +-- > (g, v') <- runVarT v x +-- > pure (h g, t <*> v')) <*> w +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (h, t) <- +-- > (\y -> do +-- > (f, u') <- runVarT u y +-- > pure ((.) f, pure (.) <*> u')) x +-- > (g, v') <- runVarT v x +-- > pure (h g, t <*> v')) <*> w +-- +-- > -- Application +-- > VarT (\x -> do +-- > (h, t) <- do +-- > (f, u') <- runVarT u x +-- > pure ((.) f, pure (.) <*> u') +-- > (g, v') <- runVarT v x +-- > pure (h g, t <*> v')) <*> w +-- +-- > -- (f >=> g) >=> h = f >=> (g >=> h) +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (h, t) <- pure ((.) f, pure (.) <*> u') +-- > (g, v') <- runVarT v x +-- > pure (h g, t <*> v')) <*> w +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > pure ((.) f g, pure (.) <*> u' <*> v')) <*> w +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (h, t) <- +-- > runVarT +-- > (VarT (\y -> do +-- > (f, u') <- runVarT u y +-- > (g, v') <- runVarT v y +-- > pure ((.) f g, pure (.) <*> u' <*> v'))) x +-- > (a, w') <- runVarT w x +-- > pure (h a, t <*> w')) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (h, t) <- +-- > (\y -> do +-- > (f, u') <- runVarT u y +-- > (g, v') <- runVarT v y +-- > pure ((.) f g, pure (.) <*> u' <*> v')) x +-- > (a, w') <- runVarT w x +-- > pure (h a, t <*> w')) +-- +-- > -- Application +-- > VarT (\x -> do +-- > (h, t) <- do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > pure ((.) f g, pure (.) <*> u' <*> v')) +-- > (a, w') <- runVarT w x +-- > pure (h a, t <*> w')) +-- +-- > -- (f >=> g) >=> h = f >=> (g >=> h) +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > (h, t) <- pure ((.) f g, pure (.) <*> u' <*> v')) +-- > (a, w') <- runVarT w x +-- > pure (h a, t <*> w')) +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > (a, w') <- runVarT w x +-- > pure ((.) f g a, pure (.) <*> u' <*> v' <*> w')) +-- +-- > -- Definition of . +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > (a, w') <- runVarT w x +-- > pure (f (g a), pure (.) <*> u' <*> v' <*> w')) +-- +-- > -- Coinduction +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > (a, w') <- runVarT w x +-- > pure (f (g a), u' <*> (v' <*> w'))) +-- +-- > -- pure x >>= f = f +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > (a, w') <- runVarT w x +-- > (b, vw) <- pure (g a, v' <*> w') +-- > pure (f b, u' <*> vw)) +-- +-- > -- (f >=> g) >=> h = f >=> (g >=> h) +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (b, vw) <- do +-- > (g, v') <- runVarT v x +-- > (a, w') <- runVarT w x +-- > pure (g a, v' <*> w') +-- > pure (f b, u' <*> vw)) +-- +-- > -- Abstraction +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (b, vw) <- +-- > (\y -> do +-- > (g, v') <- runVarT v y +-- > (a, w') <- runVarT w y) +-- > pure (g a, v' <*> w')) x +-- > pure (f b, u' <*> vw)) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (b, vw) <- +-- > runVarT +-- > (VarT (\y -> do +-- > (g, v') <- runVarT v y +-- > (a, w') <- runVarT w y) +-- > pure (g a, v' <*> w')) x +-- > pure (f b, u' <*> vw)) +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (b, vw) <- runVarT (v <*> w) x +-- > pure (f b, u' <*> vw)) +-- +-- > -- Definition of <*> +-- > u <*> (v <*> w) +-- +-- +-- ==Homomorphism +-- > pure f <*> pure a = pure (f a) +-- +-- > -- Definition of pure +-- > VarT (\_ -> pure (f, pure f)) <*> pure a +-- +-- > -- Definition of pure +-- > VarT (\_ -> pure (f, pure f)) <*> VarT (\_ -> pure (a, pure a)) +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (f', vf') <- runVarT (VarT (\_ -> pure (f, pure f))) x +-- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x +-- > pure (f' a', vf' <*> va')) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (f', vf') <- (\_ -> pure (f, pure f)) x +-- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x +-- > pure (f' a', vf' <*> va')) +-- +-- > -- Application +-- > VarT (\x -> do +-- > (f', vf') <- pure (f, pure f) +-- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x +-- > pure (f' a', vf' <*> va')) +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> do +-- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x +-- > pure (f a', pure f <*> va')) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (a', va') <- (\_ -> pure (a, pure a)) x +-- > pure (f a', pure f <*> va')) +-- +-- > -- Application +-- > VarT (\x -> do +-- > (a', va') <- pure (a, pure a) +-- > pure (f a', pure f <*> va')) +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> pure (f a, pure f <*> pure a)) +-- +-- > -- Coinduction +-- > VarT (\x -> pure (f a, pure (f a))) +-- +-- > -- Definition of pure +-- > pure (f a) +-- +-- +-- ==Interchange +-- > u <*> pure y = pure ($ y) <*> u +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (a, y') <- runVarT (pure y) x +-- > pure (f a, u' <*> y')) +-- +-- > -- Definition of pure +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (a, y') <- runVarT (VarT (\_ -> pure (y, pure y))) x +-- > pure (f a, u' <*> y')) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (a, y') <- (\_ -> pure (y, pure y)) x +-- > pure (f a, u' <*> y')) +-- +-- > -- Application +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (a, y') <- pure (y, pure y)) +-- > pure (f a, u' <*> y')) +-- +-- > -- pure x >>= f = f +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > pure (f y, u' <*> pure y)) +-- +-- > -- Coinduction +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > pure (f y, pure ($ y) <*> u')) +-- +-- > -- Definition of $ +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > pure (($ y) f, pure ($ y) <*> u') +-- +-- > -- pure x >>= f = f +-- > VarT (\x -> do +-- > (g, y') <- pure (($ y), pure ($ y)) +-- > (f, u') <- runVarT u x +-- > pure (g f, y' <*> u') +-- +-- > -- Abstraction +-- > VarT (\x -> do +-- > (g, y') <- (\_ -> pure (($ y), pure ($ y))) x +-- > (f, u') <- runVarT u x +-- > pure (g f, y' <*> u') +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (g, y') <- runVarT (VarT (\_ -> pure (($ y), pure ($ y)))) x +-- > (f, u') <- runVarT u x +-- > pure (g f, y' <*> u') +-- +-- > -- Definition of <*> +-- > VarT (\_ -> pure (($ y), pure ($ y))) <*> u +-- +-- > -- Definition of pure +-- > pure ($ y) <*> u diff --git a/src/Control/Varying/Event.hs b/src/Control/Varying/Event.hs --- a/src/Control/Varying/Event.hs +++ b/src/Control/Varying/Event.hs @@ -4,79 +4,75 @@ -- License: MIT -- Maintainer: Schell Scivally -- --- 'Event' streams describe things that happen at a specific domain. +-- An event stream is simply a stream of @Maybe a@. This kind of stream is +-- considered to be only defined at those occurances of @Just a@. Events +-- describe things that happen at a specific time, place or any collection of +-- inputs. +-- -- For example, you can think of the event stream -- @'VarT' 'IO' 'Double' ('Event' ())@ as an occurrence of @()@ at a specific --- input of type 'Double'. +-- value of 'Double'. It is possible that this 'Double' is time, or it could be +-- the number of ice cream sandwiches eaten by a particular cat. -- --- For sequencing streams please check out 'Control.Varying.Spline' which --- lets you chain together sequences of event streams using do-notation. -module Control.Varying.Event ( - Event(..), - -- * Transforming event values. - toMaybe, - isEvent, - -- * Combining event and value streams - orE, +-- In `varying` we use event streams to dynamically update the network while it +-- is running. For more info on switching and sequencing streams with events +-- please check out 'Control.Varying.Spline', which lets you chain together +-- sequences of values and events using a familiar do-notation. +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif +module Control.Varying.Event + ( -- * Event constructors (synonyms of Maybe) + Event + , event + , noevent -- * Generating events from value streams - use, - onTrue, - onJust, - onUnique, - onWhen, + , use + , onTrue + , onUnique + , onWhen -- * Folding and gathering event streams - foldStream, - startingWith, startWith, - -- * Using multiple streams - eitherE, - anyE, + , foldStream + , startingWith, startWith + -- * Combining multiple event streams + , bothE + , anyE -- * List-like operations on event streams - filterE, - takeE, - dropE, + , filterE + , takeE + , dropE -- * Primitive event streams - once, - always, - never, - -- * Switching - andThenWith, - switchByMode, + , once + , always + , never + , before + , after -- * Bubbling - onlyWhen, - onlyWhenE, -) where + , onlyWhen + , onlyWhenE + ) where import Prelude hiding (until) import Control.Varying.Core -import Control.Applicative import Control.Monad -import Data.Monoid import Data.Foldable (foldl') --------------------------------------------------------------------------------- --- Transforming event values into usable values --------------------------------------------------------------------------------- --- | Turns an 'Event' into a 'Maybe'. -toMaybe :: Event a -> Maybe a -toMaybe (Event a) = Just a -toMaybe _ = Nothing --- | Returns 'True' when the 'Event' contains a sample and 'False' --- otherwise. -isEvent :: Event a -> Bool -isEvent (Event _) = True -isEvent _ = False --------------------------------------------------------------------------------- --- Combining value streams and events --------------------------------------------------------------------------------- --- | Produces values from the first unless the second produces event --- values and if so, produces the values of those events. -orE :: (Applicative m, Monad m) => VarT m a b -> VarT m a (Event b) -> VarT m a b -orE y ye = VarT $ \a -> do - (b, y') <- runVarT y a - (e, ye') <- runVarT ye a - return $ case e of - NoEvent -> (b, orE y' ye') - Event b' -> (b', orE y' ye') +-- stuff for FAMP +#if __GLASGOW_HASKELL__ <= 707 +import Control.Applicative +import Data.Function +#endif + +type Event = Maybe + +-- | A synonym for the @Maybe@ constructor @Just@. +event :: a -> Event a +event = Just + +-- | A synonym for the @Maybe@ constructor @Nothing@. +noevent :: Event a +noevent = Nothing -------------------------------------------------------------------------------- -- Generating events from values -------------------------------------------------------------------------------- @@ -100,17 +96,7 @@ -- 'use' b 'onTrue' :: 'Monad' m => 'VarT' m 'Bool' ('Event' b) -- @ onTrue :: (Applicative m, Monad m) => VarT m Bool (Event ()) -onTrue = var $ \b -> if b then Event () else NoEvent - --- | Triggers an @'Event' a@ when the input is @'Just' a@. --- --- @ --- 'use' b 'onJust' :: 'Monad' m => 'VarT' m ('Maybe' x) ('Event' b) --- @ -onJust :: (Applicative m, Monad m) => VarT m (Maybe a) (Event a) -onJust = var $ \ma -> case ma of - Nothing -> NoEvent - Just a -> Event a +onTrue = var $ \b -> if b then Just () else Nothing -- | Triggers an @'Event' a@ when the input is distinct from the previous -- input. @@ -119,15 +105,15 @@ -- 'use' b 'onUnique' :: ('Eq' x, 'Monad' m) => 'VarT' m x ('Event' b) -- @ onUnique :: (Applicative m, Monad m, Eq a) => VarT m a (Event a) -onUnique = VarT $ \a -> return (Event a, trigger a) +onUnique = VarT $ \a -> return (Just a, trigger a) where trigger a' = VarT $ \a'' -> let e = if a' == a'' - then NoEvent - else Event a'' + then Nothing + else Just a'' in return (e, trigger a'') -- | Triggers an @'Event' a@ when the condition is met. onWhen :: Applicative m => (a -> Bool) -> VarT m a (Event a) -onWhen f = var $ \a -> if f a then Event a else NoEvent +onWhen f = var $ \a -> if f a then Just a else Nothing -------------------------------------------------------------------------------- -- Collecting -------------------------------------------------------------------------------- @@ -135,9 +121,9 @@ foldStream :: Monad m => (a -> t -> a) -> a -> VarT m (Event t) a foldStream f acc = VarT $ \e -> case e of - Event a -> let acc' = f acc a - in return (acc', foldStream f acc') - NoEvent -> return (acc, foldStream f acc) + Just a -> let acc' = f acc a + in return (acc', foldStream f acc') + Nothing -> return (acc, foldStream f acc) -- | Produces the given value until the input events produce a value, then -- produce that value until a new input event produces. This always holds @@ -146,9 +132,9 @@ -- @ -- time '>>>' 'Control.Varying.Time.after' 3 '>>>' 'startingWith' 0 -- @ -startingWith, startWith :: (Applicative m, Monad m) => a -> VarT m (Event a) a -startingWith = startWith +startWith, startingWith :: (Applicative m, Monad m) => a -> VarT m (Event a) a startWith = foldStream (\_ a -> a) +startingWith = startWith -- | Stream through some number of successful 'Event's and then inhibit -- forever. @@ -158,8 +144,8 @@ takeE n ve = VarT $ \a -> do (eb, ve') <- runVarT ve a case eb of - NoEvent -> return (NoEvent, takeE n ve') - Event b -> return (Event b, takeE (n-1) ve') + Nothing -> return (Nothing, takeE n ve') + Just b -> return (Just b, takeE (n-1) ve') -- | Inhibit the first n occurences of an 'Event'. dropE :: (Applicative m, Monad m) @@ -168,52 +154,47 @@ dropE n ve = VarT $ \a -> do (eb, ve') <- runVarT ve a case eb of - NoEvent -> return (NoEvent, dropE n ve') - Event _ -> return (NoEvent, dropE (n-1) ve') + Nothing -> return (Nothing, dropE n ve') + Just _ -> return (Nothing, dropE (n-1) ve') -- | Inhibit all 'Event's that don't pass the predicate. filterE :: (Applicative m, Monad m) => (b -> Bool) -> VarT m a (Event b) -> VarT m a (Event b) -filterE p v = v >>> var check - where check (Event b) = if p b then Event b else NoEvent - check _ = NoEvent +filterE p v = (join . (check <$>)) <$> v + where check b = if p b then Just b else Nothing -------------------------------------------------------------------------------- -- Using multiple streams -------------------------------------------------------------------------------- --- | If the left 'Event' stream produces a value, wrap the value in 'Left' and --- produce that value, else if the right 'Event' stream produces a value, --- wrap the value in 'Right' and produce that value, else inhibit. -eitherE :: (Applicative m, Monad m) - => VarT m a (Event b) -> VarT m a (Event c) - -> VarT m a (Event (Either b c)) -eitherE vb vc = f <$> vb <*> vc - where f (Event b) _ = Event $ Left b - f _ (Event c) = Event $ Right c - f _ _ = NoEvent +-- | Combine two 'Event' streams. Produces an event only when both streams proc +-- at the same time. +bothE :: (Applicative m, Monad m) + => (a -> b -> c) -> VarT m a (Event a) -> VarT m a (Event b) + -> VarT m a (Event c) +bothE f va vb = (\ea eb -> f <$> ea <*> eb) <$> va <*> vb -- | Combine two 'Event' streams and produce an 'Event' any time either stream -- produces. In the case that both streams produce, this produces the 'Event' --- of the left stream. +-- of the leftmost stream. anyE :: (Applicative m, Monad m) => [VarT m a (Event b)] -> VarT m a (Event b) anyE [] = never anyE vs = VarT $ \a -> do outs <- mapM (`runVarT` a) vs let f (eb, vs1) (eb1, v) = (msum [eb, eb1], vs1 ++ [v]) - return (anyE <$> foldl' f (NoEvent, []) outs) + return (anyE <$> foldl' f (Nothing, []) outs) -------------------------------------------------------------------------------- -- Primitive event streams -------------------------------------------------------------------------------- --- | Produce the given value once and then inhibit forever. +-- | Produce the given event value once and then inhibit forever. once :: (Applicative m, Monad m) => b -> VarT m a (Event b) -once b = VarT $ \_ -> return (Event b, never) +once b = VarT $ \_ -> return (Just b, never) -- | Never produces any 'Event' values. -- -- @ --- 'never' = 'pure' 'NoEvent' +-- 'never' = 'pure' 'Nothing' -- @ never :: (Applicative m, Monad m) => VarT m b (Event c) -never = pure NoEvent +never = pure Nothing -- | Produces 'Event's with the initial value forever. -- @@ -221,38 +202,36 @@ -- 'always' e = 'pure' ('Event' e) -- @ always :: (Applicative m, Monad m) => b -> VarT m a (Event b) -always = pure . Event +always = pure . Just --------------------------------------------------------------------------------- --- Switching --------------------------------------------------------------------------------- --- | Switches using a mode signal. Streams maintain state only for the duration --- of the mode. -switchByMode :: (Applicative m, Monad m, Eq b) - => VarT m a b -> (b -> VarT m a c) -> VarT m a c -switchByMode switch f = VarT $ \a -> do - (b, _) <- runVarT switch a - (_, v) <- runVarT (f b) a - runVarT (switchOnUnique v $ switch >>> onUnique) a - where switchOnUnique v sv = VarT $ \a -> do - (eb, sv') <- runVarT sv a - (c', v') <- runVarT (vOf eb) a - return (c', switchOnUnique v' sv') - where vOf eb = case eb of - NoEvent -> v - Event b -> f b +-- | Emits events before accumulating t of input dt. +-- Note that as soon as we have accumulated >= t we stop emitting events +-- and therefore an event will never be emitted exactly at time == t. +before :: (Applicative m, Monad m, Num t, Ord t) => t -> VarT m t (Event t) +before t = accumulate (+) 0 >>> onWhen (< t) -andThenWith :: (Applicative m, Monad m) - => VarT m a (Event b) -> (Event b -> VarT m a (Event b)) -> VarT m a (Event b) -v `andThenWith` f = run v NoEvent - where run v1 eb = VarT $ \a -> do - (eb1, v2) <- runVarT v1 a - case eb1 of - NoEvent -> runVarT (f eb) a - _ -> return (eb1, run v2 eb1) +-- | Emits events after t input has been accumulated. +-- Note that event emission is not guaranteed to begin exactly at t, +-- since it depends on the input. +after :: (Applicative m, Monad m, Num t, Ord t) => t -> VarT m t (Event t) +after t = accumulate (+) 0 >>> onWhen (>= t) -------------------------------------------------------------------------------- -- Bubbling -------------------------------------------------------------------------------- +-- | Produce events of a stream @v@ only when an event stream @h@ produces an +-- event. +-- @v@ and @h@ maintain state while cold. +onlyWhenE :: (Applicative m, Monad m) + => VarT m a b -- ^ @v@ - The value stream + -> VarT m a (Event c) -- ^ @h@ - The event stream + -> VarT m a (Event b) +onlyWhenE v hot = VarT $ \a -> do + (e, hot') <- runVarT hot a + case e of + Just _ -> do (b, v') <- runVarT v a + return (Just b, onlyWhenE v' hot') + _ -> return (Nothing, onlyWhenE v hot') + -- | Produce 'Event's of a value stream @v@ only when its input value passes a -- predicate @f@. -- @v@ maintains state while cold. @@ -262,83 +241,3 @@ -> VarT m a (Event b) onlyWhen v f = v `onlyWhenE` hot where hot = var id >>> onWhen f - --- | Produce events of a value stream @v@ only when an event stream @h@ --- produces an event. --- @v@ and @h@ maintain state while cold. -onlyWhenE :: (Applicative m, Monad m) - => VarT m a b -- ^ @v@ - The value stream - -> VarT m a (Event c) -- ^ @h@ - The event stream - -> VarT m a (Event b) -onlyWhenE v hot = VarT $ \a -> do - (e, hot') <- runVarT hot a - if isEvent e - then do (b, v') <- runVarT v a - return (Event b, onlyWhenE v' hot') - else return (NoEvent, onlyWhenE v hot') --------------------------------------------------------------------------------- --- Event typeclass instances --------------------------------------------------------------------------------- -instance Show a => Show (Event a) where - show (Event a) = "Event " ++ show a - show NoEvent = "NoEvent" - -instance (Floating a) => Floating (Event a) where - pi = pure pi - exp = fmap exp - log = fmap log - sin = fmap sin; sinh = fmap sinh; asin = fmap asin; asinh = fmap asinh - cos = fmap cos; cosh = fmap cosh; acos = fmap acos; acosh = fmap acosh - atan = fmap atan; atanh = fmap atanh - -instance (Fractional a) => Fractional (Event a) where - (/) = liftA2 (/) - fromRational = pure . fromRational - -instance Num a => Num (Event a) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - abs = fmap abs - signum = fmap signum - fromInteger = pure . fromInteger - -instance MonadPlus Event where - mzero = mempty - mplus = (<|>) - -instance Monad Event where - return = Event - (Event a) >>= f = f a - _ >>= _ = NoEvent - -instance Alternative Event where - empty = NoEvent - (<|>) (Event e) _ = Event e - (<|>) NoEvent e = e - -instance Applicative Event where - pure = Event - (<*>) (Event f) (Event a) = Event $ f a - (<*>) _ _ = NoEvent - --- | Any event is a 'Monoid' that responds to 'mempty' with 'NoEvent'. It --- responds to 'mappend' by always choosing the rightmost event. This means --- left events are replaced unless the right event is 'NoEvent'. -instance Monoid (Event a) where - mempty = NoEvent - mappend a NoEvent = a - mappend _ b = b - -instance Functor Event where - fmap f (Event a) = Event $ f a - fmap _ NoEvent = NoEvent - --- | A value of @'Event' ()@ means that an event has occurred and that the --- result is a @()@. A value of 'NoEvent' means that an event did not --- occur. --- --- Event streams (like @'VarT' m a ('Event' b)@) describe events that may occur --- over varying @a@ (also known as the series of @a@). Usually @a@ would be --- some form of time or some user input type. -data Event a = Event a | NoEvent deriving (Eq) diff --git a/src/Control/Varying/Spline.hs b/src/Control/Varying/Spline.hs --- a/src/Control/Varying/Spline.hs +++ b/src/Control/Varying/Spline.hs @@ -1,79 +1,107 @@ -- | --- Module: Control.Varying.SplineT +-- Module: Control.Varying.Spline -- Copyright: (c) 2015 Schell Scivally -- License: MIT --- Maintainer: Schell Scivally --- --- Using splines we can easily create continuous value streams from --- multiple piecewise event streams. A spline is a monadic layer on top of --- event streams which are only continuous over a certain domain. The idea --- is that we use do notation to "run an event stream" from which we will --- consume produced values. Once the event stream inhibits the computation --- completes and returns a result value. That result value is then --- used to determine the next spline in the sequence. --- --- A spline can be converted back into a value stream using 'execSpline' or --- 'execSplineT'. This allows us to build long, complex, sequential behaviors --- using familiar notation. +-- Maintainer: Schell Scivally -- -{-# LANGUAGE GADTs #-} +-- Using splines we can easily create continuous streams from discontinuous +-- streams. A spline is a monadic layer on top of streams. The idea is that we +-- use a monad to splice together sequences of streams that eventually end. This +-- means taking two streams - an output stream and an event stream - combining +-- them into a temporarily producing stream. Once that "stream pair" inhibits +-- (stops producing), the computation completes and returns a result value. That +-- result value is then used to determine the next spline in the sequence. +{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -module Control.Varying.Spline ( - -- * Spline - Spline, +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif +module Control.Varying.Spline + ( -- * Spline + Spline -- * Spline Transformer - SplineT(..), - -- * Running and streaming - scanSpline, - outputStream, + , SplineT(..) + -- * Creating streams from splines + , outputStream + -- * Creating splines from streams + , untilProc + , whileProc + , untilEvent + , untilEvent_ + , _untilEvent + , _untilEvent_ + -- * Other runners + , scanSpline -- * Combinators - step, - fromEvent, - untilEvent, - untilEvent_, - _untilEvent, - _untilEvent_, - race, - raceMany, - merge, - capture, - mapOutput, - adjustInput, -) where + , step + , race + , raceAny + , merge + , capture + , mapOutput + , adjustInput + -- * Hand Proofs of the Monad laws + -- $proofs + ) where import Control.Varying.Core import Control.Varying.Event import Control.Monad import Control.Monad.Trans.Class import Control.Monad.IO.Class -import Control.Applicative import Data.Functor.Identity -import Data.Function import Data.Monoid +-- stuff for FAMP +#if __GLASGOW_HASKELL__ <= 707 +import Control.Applicative +import Data.Function +#endif + +-- $setup +-- >>> import Control.Varying.Time + -- | 'SplineT' shares all the types of 'VarT' and adds a result value. Its --- monad, input and output types (@m@, @a@ and @b@, respectively) reflect the --- underlying 'VarT`. A spline adds a result type which represents the monadic --- computation's result value. --- Much like the State monad it has an "internal state" and an eventual --- result value, where the internal state is the output value. The result --- value is used only in determining the next spline to sequence. ---newtype SplineT a b m c = SplineT { unSplineT :: VarT m a (Either b c) } -newtype SplineT a b m c = SplineT { runSplineT :: a -> m (Either c (b, SplineT a b m c)) } +-- monad, input and output types (@m@, @a@ and @b@, respectively) represent the +-- same parameters in 'VarT'. A spline adds a result type which represents the +-- monadic computation's result value. +-- +-- A spline either concludes in a result or it produces an output value and +-- another spline. This makes it a stream that eventually ends. We can use this +-- to set up our streams in a monadic fashion, where the end result of one spline +-- can be used to determine the next spline to run. Using 'outputStream' we can +-- then fuse these piecewise continuous (but otherwise discontinuous) streams +-- into one continuous stream of type @VarT m a b@. Alternatively you can simply +-- poll the network until it ends using 'runSplineT'. +newtype SplineT a b m c = + SplineT { runSplineT :: a -> m (Either c (b, SplineT a b m c)) } -- | A spline is a functor by applying the function to the result of the --- spline. +-- spline. This does just what you would expect of other Monads such as 'StateT' +-- or 'Maybe'. +-- +-- >>> :{ +-- let s0 = pure "first" `untilEvent` (1 >>> after 2) +-- s = do str <- fmap show s0 +-- step str +-- v = outputStream s "" +-- in testVarOver v [(),()] +-- >>> :} +-- "first" +-- "(\"first\",2)" instance (Applicative m, Monad m) => Functor (SplineT a b m) where - fmap f (SplineT s) = SplineT $ \a -> s a >>= \case + fmap f (SplineT s) = SplineT $ s >=> \case Left c -> return $ Left $ f c Right (b, s1) -> return $ Right (b, fmap f s1) -- | A spline responds to bind by running until it concludes in a value, -- then uses that value to run the next spline. +-- +-- Note - checkout the <$proofs proofs> instance (Applicative m, Monad m) => Monad (SplineT a b m) where return = SplineT . const . return . Left (SplineT s0) >>= f = SplineT $ g s0 @@ -86,6 +114,14 @@ -- output value and immediately returns the argument. It responds to '<*>' by -- applying the left arguments result value (the function) to the right -- arguments result value (the argument), sequencing them both in serial. +-- +-- @ +-- pure = return +-- sf <*> sx = do +-- f <- sf +-- x <- sx +-- return $ f x +-- @ instance (Applicative m, Monad m) => Applicative (SplineT a b m) where pure = return sf <*> sx = do @@ -93,22 +129,49 @@ x <- sx return $ f x --- #if MIN_VERSION_base(4,8,0) --- | A spline is a transformer by using @effect@. +-- | A spline is a transformer by running the effect and immediately concluding, +-- using the effect's result as the result value. +-- +-- >>> :{ +-- let s = do () <- lift $ print "Hello" +-- step 2 +-- v = outputStream s 0 +-- in testVarOver v [()] +-- >>> :} +-- "Hello" +-- 2 instance MonadTrans (SplineT a b) where - lift f = SplineT $ const $ f >>= return . Left + lift f = SplineT $ const $ fmap Left f -- | A spline can do IO if its underlying monad has a MonadIO instance. It -- takes the result of the IO action as its immediate return value. instance (Applicative m, Monad m, MonadIO m) => MonadIO (SplineT a b m) where liftIO = lift . liftIO --- #endif --- + -- | A SplineT monad parameterized with Identity that takes input of type @a@, -- output of type @b@ and a result value of type @c@. type Spline a b c = SplineT a b Identity c --- | Evaluates a spline into a value stream of its output type. +-- | Permute a spline into one continuous stream. Since a spline is not +-- guaranteed to be defined over any domain (specifically on its edges), this +-- function takes a default value to use as the "last known value". +-- +-- >>> :{ +-- let s :: SplineT () String IO () +-- s = do first <- pure "accumulating until 3" `_untilEvent` (1 >>> after 3) +-- secnd <- pure "accumulating until 4" `_untilEvent` (1 >>> after 4) +-- if first + secnd == 7 +-- then step "done" +-- else step "something went wrong!" +-- v = outputStream s "" +-- in testVarOver v $ replicate 6 () +-- >>> :} +-- "accumulating until 3" +-- "accumulating until 3" +-- "accumulating until 4" +-- "accumulating until 4" +-- "accumulating until 4" +-- "done" outputStream :: (Applicative m, Monad m) => SplineT a b m c -> b -> VarT m a b outputStream (SplineT s0) b0 = VarT $ f s0 b0 @@ -123,51 +186,61 @@ => SplineT a b m c -> b -> [a] -> m [b] scanSpline s b = fmap fst <$> scanVar (outputStream s b) --- | Create a spline from an event stream. -fromEvent :: (Applicative m, Monad m) => VarT m a (Event b) -> SplineT a (Event b) m b -fromEvent ve = SplineT $ \a -> do - (e, ve1) <- runVarT ve a - return $ case e of - Event b -> Left b - NoEvent -> Right (NoEvent, fromEvent ve1) +-- | Create a spline from an event stream. Outputs 'noevent' until the event +-- stream procs, at which point the spline concludes with the event value. +untilProc :: (Applicative m, Monad m) => VarT m a (Event b) -> SplineT a (Event b) m b +untilProc ve = SplineT $ runVarT ve >=> return . \case + (Just b, _) -> Left b + (Nothing, ve1) -> Right (Nothing, untilProc ve1) --- | Create a spline from a value stream and an event stream. The spline --- uses the value stream as its output value. The spline will run until --- the event stream produces a value, at that point the last output --- value and the event value are tupled and returned as the spline's result --- value. +-- | Create a spline from an event stream. Outputs @b@ until the event stream +-- inhibits, at which point the spline concludes with @()@. +whileProc :: (Applicative m, Monad m) => VarT m a (Event b) -> SplineT a b m () +whileProc ve = SplineT $ runVarT ve >=> return . \case + (Just b, ve1) -> Right (b, whileProc ve1) + (Nothing, _) -> Left () + +-- | Create a spline from a stream and an event stream. The spline +-- uses the stream's values as its own output values. The spline will run until +-- the event stream produces an event, at that point the last known output +-- value and the event value are tupled and returned as the spline's result. untilEvent :: (Applicative m, Monad m) - => VarT m a b -> VarT m a (Event c) - -> SplineT a b m (b,c) + => VarT m a b -> VarT m a (Event c) -> SplineT a b m (b,c) untilEvent v ve = SplineT $ f ((,) <$> v <*> ve) - where f vve a = do t <-runVarT vve a - return $ case t of - ((b, NoEvent), vve1) -> Right (b, SplineT $ f vve1) - ((b, Event c), _) -> Left (b, c) + where f vve = runVarT vve >=> return . \case + ((b, Nothing), vve1) -> Right (b, SplineT $ f vve1) + ((b, Just c), _) -> Left (b, c) --- | A variant of 'untilEvent' that only results in the left result, --- discarding the right result. +-- | A variant of 'untilEvent' that results in the last known output value. untilEvent_ :: (Applicative m, Monad m) - => VarT m a b -> VarT m a (Event c) - -> SplineT a b m b + => VarT m a b -> VarT m a (Event c) -> SplineT a b m b untilEvent_ v ve = fst <$> untilEvent v ve --- | A variant of 'untilEvent' that only results in the right result, --- discarding the left result. +-- | A variant of 'untilEvent' that results in the event steam's event value. _untilEvent :: (Applicative m, Monad m) - => VarT m a b -> VarT m a (Event c) - -> SplineT a b m c + => VarT m a b -> VarT m a (Event c) -> SplineT a b m c _untilEvent v ve = snd <$> untilEvent v ve ----- | A variant of 'untilEvent' that discards both the right and left results. +-- | A variant of 'untilEvent' that discards both the output and event values. _untilEvent_ :: (Applicative m, Monad m) - => VarT m a b -> VarT m a (Event c) - -> SplineT a b m () + => VarT m a b -> VarT m a (Event c) -> SplineT a b m () _untilEvent_ v ve = void $ _untilEvent v ve -- | Run two splines in parallel, combining their output. Return the result of -- the spline that concludes first. If they conclude at the same time the result -- is taken from the left spline. +-- +-- >>> :{ +-- let s1 = pure "route " `_untilEvent` (1 >>> after 2) +-- s2 = pure 666 `_untilEvent` (1 >>> after 3) +-- s = do winner <- race (\l r -> l ++ show r) s1 s2 +-- step $ show winner +-- v = outputStream s "" +-- in testVarOver v [(),(),()] +-- >>> :} +-- "route 666" +-- "Left 2" +-- "Left 2" race :: (Applicative m, Monad m) => (a -> b -> c) -> SplineT i a m d -> SplineT i b m e -> SplineT i c m (Either d e) @@ -178,10 +251,26 @@ Left e -> return $ Left $ Right e Right (b, sb1) -> return $ Right (f a b, SplineT $ g sa1 sb1) -raceMany :: (Applicative m, Monad m, Monoid b) +-- | Run many splines in parallel, combining their output with 'mappend'. +-- Returns the result of the spline that concludes first. If any conclude at the +-- same time the leftmost result will be returned. +-- +-- >>> :{ +-- let ss = [ pure "hey " `_untilEvent` (1 >>> after 5) +-- , pure "there" `_untilEvent` (1 >>> after 3) +-- , pure "!" `_untilEvent` (1 >>> after 2) +-- ] +-- s = do winner <- raceAny ss +-- step $ show winner +-- v = outputStream s "" +-- in testVarOver v [(),()] +-- >>> :} +-- "hey there!" +-- "2" +raceAny :: (Applicative m, Monad m, Monoid b) => [SplineT a b m c] -> SplineT a b m c -raceMany [] = pure mempty `_untilEvent` never -raceMany ss = SplineT $ f [] (map runSplineT ss) mempty +raceAny [] = pure mempty `_untilEvent` never +raceAny ss = SplineT $ f [] (map runSplineT ss) mempty where f ys [] b _ = return $ Right (b, SplineT $ f [] ys mempty) f ys (v:vs) b a = v a >>= \case Left c -> return $ Left c @@ -189,6 +278,18 @@ -- | Run two splines in parallel, combining their output. Once both splines -- have concluded, return the results of each in a tuple. +-- +-- >>> :{ +-- let s1 = pure "hey " `_untilEvent` (1 >>> after 3) +-- s2 = pure "there!" `_untilEvent` (1 >>> after 2) +-- s = do tuple <- merge (++) s1 s2 +-- step $ show tuple +-- v = outputStream s "" +-- in testVarOver v [(),(),()] +-- >>> :} +-- "hey there!" +-- "hey " +-- "(3,2)" merge :: (Applicative m, Monad m) => (b -> b -> b) -> SplineT a b m c -> SplineT a b m d -> SplineT a b m (c, d) @@ -196,50 +297,208 @@ where r c d = return $ Left (c, d) - fr c vb a = runSplineT vb a >>= \case - Left d -> r c d + fr c vb = runSplineT vb >=> \case + Left d -> r c d Right (b, vb1) -> return $ Right (b, SplineT $ fr c vb1) - fl d va a = runSplineT va a >>= \case - Left c -> r c d + fl d va = runSplineT va >=> \case + Left c -> r c d Right (b, va1) -> return $ Right (b, SplineT $ fl d va1) f va vb a = runSplineT va a >>= \case Left c -> fr c vb a Right (b1, va1) -> runSplineT vb a >>= \case Left d -> return $ Right (b1, SplineT $ fl d va1) - Right (b2, vb1) -> return $ Right $ (apnd b1 b2, SplineT $ f va1 vb1) + Right (b2, vb1) -> return $ Right (apnd b1 b2, SplineT $ f va1 vb1) -- | Capture the spline's last output value and tuple it with the -- spline's result. This is helpful when you want to sample the last -- output value in order to determine the next spline to sequence. +-- +-- >>> :{ +-- let s = do (Just x, "boom") <- capture $ do step 0 +-- step 1 +-- step 2 +-- return "boom" +-- -- x is 2 +-- step $ x + 1 +-- in testVarOver (outputStream s 666) [(),(),(),()] +-- >>> :} +-- 0 +-- 1 +-- 2 +-- 3 capture :: (Applicative m, Monad m) - => SplineT a b m c -> SplineT a b m (Maybe b, c) + => SplineT a b m c -> SplineT a b m (Event b, c) capture = SplineT . f Nothing - where f mb s a = runSplineT s a >>= \case - Left c -> return $ Left (mb, c) - Right (b, s1) -> return $ Right (b, SplineT $ f (Just b) s1) + where f mb s = runSplineT s >=> return . \case + Left c -> Left (mb, c) + Right (b, s1) -> Right (b, SplineT $ f (Just b) s1) -- | Produce the argument as an output value exactly once. +-- +-- >>> :{ +-- let s = do step "hi" +-- step "there" +-- step "friend" +-- in testVarOver (outputStream s "") [1,2,3,4] +-- >>> :} +-- "hi" +-- "there" +-- "friend" +-- "friend" step :: (Applicative m, Monad m) => b -> SplineT a b m () step b = SplineT $ const $ return $ Right (b, return ()) -- | Map the output value of a spline. +-- +-- >>> :{ +-- let s = mapOutput (pure show) $ step 1 >> step 2 >> step 3 +-- in testVarOver (outputStream s "") [(),(),()] +-- >>> :} +-- "1" +-- "2" +-- "3" mapOutput :: (Applicative m, Monad m) => VarT m a (b -> t) -> SplineT a b m c -> SplineT a t m c mapOutput vf0 s0 = SplineT $ g vf0 s0 where g vf s a = do (f, vf1) <- runVarT vf a - runSplineT s a >>= \case - Left c -> return $ Left c - Right (b, s1) -> return $ Right (f b, SplineT $ g vf1 s1) + flip fmap (runSplineT s a) $ \case + Left c -> Left c + Right (b, s1) -> Right (f b, SplineT $ g vf1 s1) -- | Map the input value of a spline. adjustInput :: (Applicative m, Monad m) => VarT m a (a -> r) -> SplineT r b m c -> SplineT a b m c adjustInput vf0 s = SplineT $ g vf0 s - where g vf sx (!a) = do + where g vf sx a = do (f, vf1) <- runVarT vf a - runSplineT sx (f a) >>= \case - Left c -> return $ Left c - Right (b, sx1) -> return $ Right (b, SplineT $ g vf1 sx1) + flip fmap (runSplineT sx (f a)) $ \case + Left c -> Left c + Right (b, sx1) -> Right (b, SplineT $ g vf1 sx1) + +-------------------------------------------------------------------------------- +-- $proofs +-- ==Left Identity +-- > k =<< return c = k c +-- +-- > -- Definition of =<< +-- > fix (\f s -> +-- > SplineT (\a -> +-- > runSplineT s a >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap f s')))) (return c) +-- +-- > -- Definition of fix +-- > (\s -> +-- > SplineT (\a -> +-- > runSplineT s a >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s')))) (return c) +-- +-- > -- Application +-- > SplineT (\a -> +-- > runSplineT (return c) a >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s'))) +-- +-- > -- Definition of return +-- > SplineT (\a -> +-- > runSplineT (SplineT (\_ -> return (Left c))) a >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s'))) +-- +-- > -- Newtype +-- > SplineT (\a -> +-- > (\_ -> return (Left c)) a >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s'))) +-- +-- > -- Application +-- > SplineT (\a -> +-- > return (Left c) >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s'))) +-- +-- > -- return x >>= f = f x +-- > SplineT (\a -> +-- > case (Left c) of +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s'))) +-- +-- > -- Case evaluation +-- > SplineT (\a -> runSplineT (k c) a) +-- +-- > -- Eta reduction +-- > SplineT (runSplineT (k c)) +-- +-- > -- Newtype +-- > k c +-- +-- ==Right Identity +-- > return =<< m = m +-- +-- > -- Definition of =<< +-- > fix (\f s -> +-- > SplineT (\a -> +-- > runSplineT s a >>= \case +-- > Left c -> runSplineT (return c) a +-- > Right s' -> return (Right (fmap f s')))) m +-- +-- > -- Definition of fix +-- > (\s -> +-- > SplineT (\a -> +-- > runSplineT s a >>= \case +-- > Left c -> runSplineT (return c) a +-- > Right s' -> return (Right (fmap (return =<<) s')))) m +-- +-- > -- Application +-- > SplineT (\a -> +-- > runSplineT m a >>= \case +-- > Left c -> runSplineT (return c) a +-- > Right s' -> return (Right (fmap (return =<<) s'))) +-- +-- > -- Definition of return +-- > SplineT (\a -> +-- > runSplineT m a >>= \case +-- > Left c -> runSplineT (SplineT (\_ -> return (Left c))) a +-- > Right s' -> return (Right (fmap (return =<<) s'))) +-- +-- > -- Newtype +-- > SplineT (\a -> +-- > runSplineT m a >>= \case +-- > Left c -> (\_ -> return (Left c)) a +-- > Right s' -> return (Right (fmap (return =<<) s'))) +-- +-- > -- Application +-- > SplineT (\a -> +-- > runSplineT m a >>= \case +-- > Left c -> return (Left c) +-- > Right s' -> return (Right (fmap (return =<<) s'))) +-- +-- > -- m >>= return . f = fmap f m +-- > SplineT (\a -> fmap (either id (fmap (return =<<))) (runSplineT m a)) +-- +-- > -- Coinduction +-- > SplineT (\a -> fmap (either id (fmap id)) (runSplineT m a)) +-- +-- > -- fmap id = id +-- > SplineT (\a -> fmap (either id id) (runSplineT m a)) +-- +-- > -- either id id = id +-- > SplineT (\a -> fmap id (runSplineT m a)) +-- +-- > -- fmap id = id +-- > SplineT (\a -> runSplineT m a) +-- +-- > -- Eta reduction +-- > SplineT (runSplineT m) +-- +-- > -- Newtype +-- > m +-- +-- ==Application +-- > (m >>= f) >>= g = m >>= (\x -> f x >>= g) + +-- TODO diff --git a/src/Control/Varying/Time.hs b/src/Control/Varying/Time.hs deleted file mode 100644 --- a/src/Control/Varying/Time.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | Module: Control.Varying.Time --- Copyright: (c) 2015 Schell Scivally --- License: MIT --- Maintainer: Schell Scivally -module Control.Varying.Time where - -import Control.Varying.Core -import Control.Varying.Event -import Control.Applicative --------------------------------------------------------------------------------- --- Using timed events --------------------------------------------------------------------------------- --- | Emits events before accumulating t of input dt. --- Note that as soon as we have accumulated >= t we stop emitting events --- and therefore an event will be never be emitted exactly at time == t. -before :: (Applicative m, Monad m, Num t, Ord t) => t -> VarT m t (Event t) -before t = accumulate (+) 0 ~> onWhen (< t) - --- | Emits events after t input has been accumulated. --- Note that event emission is not guaranteed to begin exactly at t, --- since it depends on the input. -after :: (Applicative m, Monad m, Num t, Ord t) => t -> VarT m t (Event t) -after t = accumulate (+) 0 ~> onWhen (>= t) diff --git a/src/Control/Varying/Tween.hs b/src/Control/Varying/Tween.hs --- a/src/Control/Varying/Tween.hs +++ b/src/Control/Varying/Tween.hs @@ -1,8 +1,8 @@ -- | -- Module: Control.Varying.Tween --- Copyright: (c) 2015 Schell Scivally +-- Copyright: (c) 2016 Schell Scivally -- License: MIT --- Maintainer: Schell Scivally +-- Maintainer: Schell Scivally -- -- Tweening is a technique of generating intermediate samples of a type -- __between__ a start and end value. By sampling a running tween @@ -16,7 +16,6 @@ -- {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE BangPatterns #-} module Control.Varying.Tween ( -- * Tweening types Easing @@ -56,7 +55,6 @@ import Control.Varying.Core import Control.Varying.Event import Control.Varying.Spline -import Control.Varying.Time import Control.Arrow import Control.Applicative import Control.Monad.Trans.State @@ -70,18 +68,17 @@ -- and interpolation of a value. To see what these look like please check -- out http://www.gizma.com/easing/. -------------------------------------------------------------------------------- - -- | Ease in quadratic. easeInQuad :: (Num t, Fractional t, Real f) => Easing t f -easeInQuad c t b = c * (realToFrac $ t*t) + b +easeInQuad c t b = c * realToFrac (t*t) + b -- | Ease out quadratic. easeOutQuad :: (Num t, Fractional t, Real f) => Easing t f -easeOutQuad c t b = (-c) * (realToFrac $ t * (t - 2)) + b +easeOutQuad c t b = (-c) * realToFrac (t * (t - 2)) + b -- | Ease in cubic. easeInCubic :: (Num t, Fractional t, Real f) => Easing t f -easeInCubic c t b = c * (realToFrac $ t*t*t) + b +easeInCubic c t b = c * realToFrac (t*t*t) + b -- | Ease out cubic. easeOutCubic :: (Num t, Fractional t, Real f) => Easing t f @@ -139,7 +136,7 @@ type Tween f t = TweenT f t Identity runTweenT :: (Monad m, Num f) - => TweenT f t m x -> f -> f -> m (Either x ((t, TweenT f t m x)), f) + => TweenT f t m x -> f -> f -> m (Either x (t, TweenT f t m x), f) runTweenT s dt = runStateT (runSplineT s dt) scanTween :: (Functor m, Applicative m, Monad m, Num f) @@ -166,14 +163,7 @@ -- | Creates a spline that produces a value interpolated between a start and -- end value using an easing equation ('Easing') over a duration. The --- resulting spline will take a time delta as input. For example: --- --- @ --- testWhile_ isEvent (deltaUTC >>> v) --- where v :: VarT IO a (Event Double) --- v = flip outputStream 0 $ tween easeOutExpo 0 100 5 --- @ --- +-- resulting spline will take a time delta as input. -- Keep in mind `tween` must be fed time deltas, not absolute time or -- duration. This is mentioned because the author has made that mistake -- more than once ;) @@ -225,7 +215,6 @@ constant :: (Applicative m, Monad m, Num t, Ord t) => a -> t -> TweenT t a m a constant value duration = pure value `untilEvent_` after duration - -------------------------------------------------------------------------------- -- $writing -- To create your own tweens just write a function that takes a start diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -14,26 +14,26 @@ main = hspec $ do describe "before" $ do it "should produce events before a given step" $ do - let varEv :: Var () (Event Int) + let varEv :: Var () (Maybe Int) varEv = 1 ~> before 3 scans = fst $ runIdentity $ scanVar varEv $ replicate 4 () - scans `shouldBe` [Event 1, Event 2, NoEvent, NoEvent] + scans `shouldBe` [Just 1, Just 2, Nothing, Nothing] describe "after" $ do it "should produce events after a given step" $ do - let varEv :: Var () (Event Int) + let varEv :: Var () (Maybe Int) varEv = 1 ~> after 3 scans = fst $ runIdentity $ scanVar varEv $ replicate 4 () - scans `shouldBe` [NoEvent, NoEvent, Event 3, Event 4] + scans `shouldBe` [Nothing, Nothing, Just 3, Just 4] describe "anyE" $ do it "should produce on any event" $ do - let v1,v2,v3 :: Var () (Event Int) + let v1,v2,v3 :: Var () (Maybe Int) v1 = use 1 ((1 :: Var () Int) ~> before 2) v2 = use 2 ((1 :: Var () Int) ~> after 3) v3 = always 3 v = anyE [v1,v2,v3] scans = fst $ runIdentity $ scanVar v $ replicate 4 () - scans `shouldBe` [Event 1, Event 3, Event 2, Event 2] + scans `shouldBe` [Just 1, Just 3, Just 2, Just 2] describe "tween/tweenWith" $ do it "should step by the dt passed in" $ do let mytween :: Tween Double Double () @@ -68,16 +68,16 @@ describe "fromEvent" $ do let s = do - str <- fromEvent (var f ~> onJust) - step $ Event str - step $ Event "done" + str <- fromEvent $ var f + step $ Just str + step $ Just "done" f :: Int -> Maybe String f 0 = Nothing f 1 = Just "YES" f x = Just $ show x - Identity scans = scanSpline s NoEvent [0,0,0,1,0] - it "should produce NoEvent until it procs" $ - scans `shouldBe` [NoEvent,NoEvent,NoEvent,Event "YES",Event "done"] + Identity scans = scanSpline s Nothing [0,0,0,1,0] + it "should produce Nothing until it procs" $ + scans `shouldBe` [Nothing,Nothing,Nothing,Just "YES",Just "done"] describe "lift/liftIO" $ do let s :: SplineT () String IO () diff --git a/varying.cabal b/varying.cabal --- a/varying.cabal +++ b/varying.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.6.0.0 +version: 0.7.0.0 -- A short (one-line) description of the package. synopsis: FRP through value streams and monadic splines. @@ -35,7 +35,7 @@ -- An email address to which users can send suggestions, bug reports, and -- patches. -maintainer: schell.scivally@synapsegroup.com +maintainer: efsubenovex@gmail.com -- A copyright notice. -- copyright: @@ -53,7 +53,6 @@ extra-source-files: README.md, changelog.md - source-repository head type: git location: https://github.com/schell/varying.git @@ -63,7 +62,6 @@ -- Modules exported by the library. exposed-modules: Control.Varying, Control.Varying.Core, - Control.Varying.Time, Control.Varying.Event, Control.Varying.Tween, Control.Varying.Spline @@ -114,7 +112,6 @@ , hspec , QuickCheck - -- Directories containing source files. hs-source-dirs: test @@ -133,7 +130,6 @@ , transformers , varying , criterion - -- Directories containing source files. hs-source-dirs: bench