varying 0.5.0.3 → 0.6.0.0
raw patch · 10 files changed
+752/−396 lines, 10 files
Files
- README.md +44/−82
- app/Main.hs +14/−16
- bench/Main.hs +8/−8
- changelog.md +4/−0
- src/Control/Varying/Core.hs +384/−40
- src/Control/Varying/Event.hs +66/−38
- src/Control/Varying/Spline.hs +94/−134
- src/Control/Varying/Tween.hs +97/−53
- test/Main.hs +40/−24
- varying.cabal +1/−1
README.md view
@@ -2,13 +2,8 @@ [](http://hackage.haskell.org/package/varying) [](https://travis-ci.org/schell/varying) -This library provides automaton based value streams useful for both functional-reactive programming (FRP) and locally stateful programming (LSP). It is-influenced by the [netwire](http://hackage.haskell.org/package/netwire) and-[auto](http://hackage.haskell.org/package/auto) packages. Unlike netwire the-concepts of inhibition and time are explicit (through `Control.Varying.Event`-and `Control.Varying.Time`). The library aims at being minimal and well-documented with a small API.+This library provides automaton based value streams and sequencing useful for+functional reactive programming (FRP) and locally stateful programming (LSP). ## Getting started @@ -17,47 +12,49 @@ import Control.Varying import Control.Applicative-import Text.Printf+import Control.Concurrent (forkIO, killThread) import Data.Functor.Identity+import Data.Time.Clock -- | A simple 2d point type. data Point = Point { px :: Float , py :: Float } deriving (Show, Eq) --- An exponential tween back and forth from 0 to 100 over 2 seconds that+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 and would result in () if it--- terminated.-tweenx :: (Applicative m, Monad m) => SplineT Float Float m ()+-- outputs the current x value at every step.+tweenx :: (Applicative m, Monad m) => TweenT Float Float m Float tweenx = do- -- Tween from 0 to 100 over 1 second- x <- tween easeOutExpo 0 100 1+ -- Tween from 0 to 50 over 1 second+ tween_ easeOutExpo 0 50 1 -- Chain another tween back to the starting position- _ <- tween easeOutExpo x 0 1+ tween_ easeOutExpo 50 0 1 -- Loop forever tweenx --- A quadratic tween back and forth from 0 to 100 over 2 seconds that never+-- A quadratic tween back and forth from 0 to 50 over 1 seconds that never -- ends.-tweeny :: (Applicative m, Monad m) => SplineT Float Float m ()+tweeny :: (Applicative m, Monad m) => TweenT Float Float m Float tweeny = do- y <- tween easeOutQuad 0 100 1- _ <- tween easeOutQuad y 0 1+ tween_ easeOutExpo 50 0 1+ tween_ easeOutExpo 0 50 1 tweeny --- Our time signal that provides delta time samples.-time :: VarT IO a Float-time = deltaUTC+-- 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 :: VarT IO a Point+backAndForth :: (Applicative m, Monad m) => VarT m Delta Point backAndForth = -- Turn our splines into continuous output streams. We must provide -- a starting value since splines are not guaranteed to be defined at -- their edges.- let x = outputStream 0 tweenx- y = outputStream 0 tweeny+ let x = tweenStream tweenx 0+ y = tweenStream tweeny 0 in -- Construct a varying Point that takes time as an input. (Point <$> x <*> y)@@ -70,65 +67,30 @@ main :: IO () main = do putStrLn "An example of value streams using the varying library."- putStrLn "Enter a newline to continue, quit with ctrl+c"+ putStrLn "Enter a newline to continue, and then a newline to quit" _ <- getLine - loop backAndForth- where loop :: VarT IO () Point -> IO ()- loop v = do (point, vNext) <- runVarT v ()- printf "\nPoint %03.1f %03.1f" (px point) (py point)- loop vNext--```--## Caveats-With tweening, if your input time delta is greater than the duration of the-first spline, that spline immediately concludes and returns its result value --the stream then continues on to the next spline in the sequence, *applying the-same unmodified input* as the previous spline. This is because splines-immediately conclude and trigger the next spline, and there is no machinery for-altering input after the splines conclusion. What's worse is if you have a-cyclical (infinite) sequence of spline tweens, each with a duration less than-the given delta - the stream will never produce an output. The input will-conclude every spline prematurely and the stream will loop infinitely, hanging-the current thread.--### Here is an example--```haskell-let dv :: Monad m => SplineT Float (V2 Float) m ()- dv = do tween_ easeInExpo 10 (V2 100 10) 0.25- tween_ easeInExpo (V2 100 10) 100 0.25- tween_ easeInExpo 100 (V2 10 100) 0.25- tween_ easeInExpo (V2 10 100) 10 0.25- dv- v :: Monad m => VarT m Float (V2 Float)- v = (deltaTime ~> outputStream dv 0)-(vec2, v1) <- runVarT v 0.5 -- hangs indefinitely-```--Surprisingly enough, this is expected behavior (inputs that conclude the-current spline should be passed downstream immediately), but the behavior isn't-easily spotted. If you encounter your program hanging check to see that your-cyclical splines aren't receiving an input that is bigger than they expect.+ t <- getCurrentTime+ tId <- forkIO $ loop backAndForth t -### A very easy fix-There is a very simple fix for this scenario - produce exactly one duplicate-output just before recursing:+ _ <- getLine+ killThread tId -```haskell-let dv :: Monad m => SplineT Float (V2 Float) m ()- dv = do tween_ easeInExpo 10 (V2 100 10) 0.25- tween_ easeInExpo (V2 100 10) 100 0.25- tween_ easeInExpo 100 (V2 10 100) 0.25- vec <- tween easeInExpo (V2 10 100) 10 0.25- step vec -- <----------------------------\- dv -- |- v :: Monad m => VarT m Float (V2 Float) -- |- v = (deltaTime ~> outputStream dv 0) -- |-(vec, v1) <- runVarT v 0.5 -- will produce 'vec' ---/+loop :: Var Delta 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+ xStr = replicate (round x) ' ' ++ "x" ++ replicate (50 - round x) ' '+ yStr = replicate (round y) ' ' ++ "y" ++ replicate (50 - round y) ' '+ str = zipWith f xStr yStr+ f 'x' 'y' = '|'+ f 'y' 'x' = '|'+ f a ' ' = a+ f ' ' b = b+ f _ _ = ' '+ putStrLn str+ loop vNext t1 ```--The downside is that this is not mathematically accurate - the delta will be-completely consumed and the stream will output the last position even though-the delta was not necessarily an amount great enough to warrant that output.
app/Main.hs view
@@ -13,25 +13,24 @@ newtype Delta = Delta { unDelta :: Float } --- An exponential tween back and forth from 0 to 100 over 2 seconds that+-- 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 and would result in () if it--- terminated.-tweenx :: (Applicative m, Monad m) => SplineT Float Float m Float+-- outputs the current x value at every step.+tweenx :: (Applicative m, Monad m) => TweenT Float Float m Float tweenx = do- -- Tween from 0 to 100 over 1 second- x <- tween easeOutExpo 0 50 1+ -- Tween from 0 to 50 over 1 second+ tween_ easeOutExpo 0 50 1 -- Chain another tween back to the starting position- _ <- tween easeOutExpo x 0 1+ tween_ easeOutExpo 50 0 1 -- Loop forever tweenx --- A quadratic tween back and forth from 0 to 100 over 2 seconds that never+-- A quadratic tween back and forth from 0 to 50 over 1 seconds that never -- ends.-tweeny :: (Applicative m, Monad m) => SplineT Float Float m Float+tweeny :: (Applicative m, Monad m) => TweenT Float Float m Float tweeny = do- y <- tween easeOutExpo 50 0 1- _ <- tween easeOutExpo y 50 1+ tween_ easeOutExpo 50 0 1+ tween_ easeOutExpo 0 50 1 tweeny -- Our time signal counts input delta time samples.@@ -44,8 +43,8 @@ -- Turn our splines into continuous output streams. We must provide -- a starting value since splines are not guaranteed to be defined at -- their edges.- let x = outputStream tweenx 0- y = outputStream tweeny 0+ let x = tweenStream tweenx 0+ y = tweenStream tweeny 0 in -- Construct a varying Point that takes time as an input. (Point <$> x <*> y)@@ -70,7 +69,8 @@ loop :: Var Delta Point -> UTCTime -> IO () loop v t = do t1 <- getCurrentTime- -- Here we'll run in the Identity monad using a fixed time step.+ -- 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 xStr = replicate (round x) ' ' ++ "x" ++ replicate (50 - round x) ' '@@ -82,6 +82,4 @@ f ' ' b = b f _ _ = ' ' putStrLn str- --threadDelay 10 loop vNext t1-
bench/Main.hs view
@@ -16,9 +16,9 @@ , bench "64" $ nf (run $ chain 64) 0 , bench "128" $ nf (run $ chain 128) 0 ]- , bgroup "SplineT"- [ bench "runSplineT" $- nf (run $ outputStream spline 0) 0+ , bgroup "TweenT"+ [ bench "tweenStream" $+ nf (run $ tweenStream myTween 0) 0 ] ] return ()@@ -27,8 +27,8 @@ chain n = seq x x where x = foldl (~>) (var (+1)) $ take (n - 1) $ cycle [var (+1)] -spline :: Spline Float Float ()-spline = do- void $ tween easeInExpo 0 100 1- void $ tween easeOutExpo 100 0 1- spline+myTween :: Tween Float Float ()+myTween = do+ void $ tween_ easeInExpo 0 100 1+ void $ tween_ easeOutExpo 100 0 1+ myTween
changelog.md view
@@ -20,3 +20,7 @@ 0.5.0.2 - separated tweening time and value, added runSplineE, builds on all GHC since 7.6++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(_).
src/Control/Varying/Core.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE BangPatterns #-} -- | -- Module: Control.Varying.Core -- Copyright: (c) 2015 Schell Scivally@@ -32,7 +33,6 @@ accumulate, -- * Sampling value streams (running and other entry points) -- $running- runVarT, scanVar, stepMany, -- * Tracing value streams in flight@@ -50,6 +50,22 @@ 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':@@ -83,15 +99,15 @@ -------------------------------------------------------------------------------- -- | 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)+var f = VarT $ \(!a) -> pure (f a, var f) -- | Lift a constant value into a stream.-done :: Applicative m => b -> VarT m a b-done = Done+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+varM f = VarT $ \(!a) -> do b <- f a return (b, varM f) @@ -100,7 +116,7 @@ => (a -> s -> (b, s)) -- ^ state transformer -> s -- ^ intial state -> VarT m a b-mkState f s = VarT $ \a -> do+mkState f s = VarT $ \(!a) -> do let (b', s') = f a s return (b', mkState f s') --------------------------------------------------------------------------------@@ -111,10 +127,6 @@ -- > do (sample, v') <- runVarT v inputValue ---------------------------------------------------------------------------------runVarT :: Monad m => VarT m a b -> a -> m (b, VarT m a b)-runVarT (Done b) _ = return (b, Done b)-runVarT (VarT v) a = v a- -- | 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.@@ -151,7 +163,7 @@ -- | 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+accumulate f b = VarT $ \(!a) -> do let b' = f b a return (b', accumulate f b') @@ -161,9 +173,9 @@ -- -- > 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'')+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@@ -186,9 +198,7 @@ -- > 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 (Done x) = Done $ f x fmap f v = v >>> var f- -- | A very simple category instance. -- -- @@@ -203,18 +213,21 @@ -- 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)+ 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 <*> va = VarT $ \a -> do (f, vf') <- runVarT vf a- (b, va') <- runVarT va a- return (f b, vf' <*> va')+ 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. --@@ -270,22 +283,353 @@ instance (Applicative m, Monad m, Fractional b) => Fractional (VarT m a b) where (/) = liftA2 (/) fromRational = pure . fromRational------------------------------------------------------------------------------------ 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.-data VarT m a b = Done b- -- ^ Given a value, return a computation that yields a constant value- -- forever. You can also do this with the function 'done'.- | VarT (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.++-- [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
src/Control/Varying/Event.hs view
@@ -6,8 +6,8 @@ -- -- 'Event' streams describe things that happen at a specific domain. -- For example, you can think of the event stream--- @VarT IO Double (Event ())@ as an occurrence of () at a specific input--- of type 'Double'.+-- @'VarT' 'IO' 'Double' ('Event' ())@ as an occurrence of @()@ at a specific+-- input of type 'Double'. -- -- For sequencing streams please check out 'Control.Varying.Spline' which -- lets you chain together sequences of event streams using do-notation.@@ -80,26 +80,44 @@ -------------------------------------------------------------------------------- -- Generating events from values ----------------------------------------------------------------------------------- | Populates a varying Event with a value. This is meant to be used with--- the various 'on...' event triggers. For example+-- | -- @--- use 1 onTrue+-- 'use' :: 'Monad' m => b -> 'VarT' m a ('Event' x) -> 'VarT' m a ('Event' b) -- @--- produces values of `Event 1` when the input value is `True`.+--+-- Populates a varying Event with a value. This is meant to be used with+-- the various @on...@ event triggers. For example,+-- @+-- 'use' 1 'onTrue'+-- @+-- produces values of @'Event' 1@ when the input value is 'True'. use :: (Functor f, Functor e) => a -> f (e b) -> f (e a) use a v = (a <$) <$> v --- | Triggers an `Event ()` when the input value is True.+-- | Triggers an @'Event' ()@ when the input value is 'True'.+--+-- @+-- '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`.+-- | 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 --- | Triggers an `Event a` when the input is a unique value.+-- | Triggers an @'Event' a@ when the input is distinct from the previous+-- input.+--+-- @+-- '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) where trigger a' = VarT $ \a'' -> let e = if a' == a''@@ -107,7 +125,7 @@ else Event a'' in return (e, trigger a'') --- | Triggers an `Event a` when the condition is met.+-- | 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 --------------------------------------------------------------------------------@@ -124,14 +142,16 @@ -- | Produces the given value until the input events produce a value, then -- produce that value until a new input event produces. This always holds -- the last produced value, starting with the given value.+-- -- @--- time >>> after 3 >>> startingWith 0+-- time '>>>' 'Control.Varying.Time.after' 3 '>>>' 'startingWith' 0 -- @ startingWith, startWith :: (Applicative m, Monad m) => a -> VarT m (Event a) a startingWith = startWith startWith = foldStream (\_ a -> a) --- | Stream through some number of successful events and then inhibit forever.+-- | Stream through some number of successful 'Event's and then inhibit+-- forever. takeE :: (Applicative m, Monad m) => Int -> VarT m a (Event b) -> VarT m a (Event b) takeE 0 _ = never@@ -141,7 +161,7 @@ NoEvent -> return (NoEvent, takeE n ve') Event b -> return (Event b, takeE (n-1) ve') --- | Inhibit the first n occurences of an event.+-- | Inhibit the first n occurences of an 'Event'. dropE :: (Applicative m, Monad m) => Int -> VarT m a (Event b) -> VarT m a (Event b) dropE 0 ve = ve@@ -151,7 +171,7 @@ NoEvent -> return (NoEvent, dropE n ve') Event _ -> return (NoEvent, dropE (n-1) ve') --- | Inhibit all events that don't pass the predicate.+-- | 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@@ -160,8 +180,8 @@ -------------------------------------------------------------------------------- -- 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,+-- | 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)@@ -171,9 +191,9 @@ f _ (Event c) = Event $ Right c f _ _ = NoEvent --- | 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.+-- | 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. anyE :: (Applicative m, Monad m) => [VarT m a (Event b)] -> VarT m a (Event b) anyE [] = never anyE vs = VarT $ \a -> do@@ -187,11 +207,19 @@ once :: (Applicative m, Monad m) => b -> VarT m a (Event b) once b = VarT $ \_ -> return (Event b, never) --- | Never produces any event values.+-- | Never produces any 'Event' values.+--+-- @+-- 'never' = 'pure' 'NoEvent'+-- @ never :: (Applicative m, Monad m) => VarT m b (Event c) never = pure NoEvent --- | Produces events with the initial value forever.+-- | Produces 'Event's with the initial value forever.+--+-- @+-- 'always' e = 'pure' ('Event' e)+-- @ always :: (Applicative m, Monad m) => b -> VarT m a (Event b) always = pure . Event @@ -225,22 +253,22 @@ -------------------------------------------------------------------------------- -- Bubbling ----------------------------------------------------------------------------------- | Produce events of a value stream 'v' only when its input value passes a--- predicate 'f'.--- 'v' maintains state while cold.+-- | Produce 'Event's of a value stream @v@ only when its input value passes a+-- predicate @f@.+-- @v@ maintains state while cold. onlyWhen :: (Applicative m, Monad m)- => VarT m a b -- ^ 'v' - The value stream- -> (a -> Bool) -- ^ 'f' - The predicate to run on 'v''s input values.+ => VarT m a b -- ^ @v@ - The value stream+ -> (a -> Bool) -- ^ @f@ - The predicate to run on @v@'s input values. -> 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'+-- | Produce events of a value stream @v@ only when an event stream @h@ -- produces an event.--- 'v' and 'h' maintain state while cold.+-- @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 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@@ -294,9 +322,9 @@ (<*>) (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.+-- | 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@@ -306,11 +334,11 @@ 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+-- | 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.+-- 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)
src/Control/Varying/Spline.hs view
@@ -28,14 +28,10 @@ -- * Spline Transformer SplineT(..), -- * Running and streaming- runSplineT,- runSplineE, scanSpline, outputStream,- resultStream, -- * Combinators step,- effect, fromEvent, untilEvent, untilEvent_,@@ -56,6 +52,7 @@ import Control.Monad.IO.Class import Control.Applicative import Data.Functor.Identity+import Data.Function import Data.Monoid -- | 'SplineT' shares all the types of 'VarT' and adds a result value. Its@@ -65,80 +62,48 @@ -- 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.-data SplineT a b m c = Pass c- | SplineT (VarT m a (b, Event c))---- | Convert a spline into a stream of output value and eventual result value--- tuples. Requires a default output value in case none are produced.-runSplineT :: (Applicative m, Monad m) => SplineT a b m c -> b -> VarT m a (b, Event c)---runSplineT (SplineT v) _ = VarT $ runVarT v >=> \case--- ((b,NoEvent), v1) -> return ((b,NoEvent), runSplineT (SplineT v1) b)--- ((b,Event c), _) -> return ((b, Event c), runSplineT (Pass c) b)-runSplineT (Pass c) b = pure (b, Event c)-runSplineT (SplineT v) _ = VarT $ \a -> do- (o@(b,ec), v1) <- runVarT v a- let !s = case ec of- NoEvent -> SplineT v1- Event c -> Pass c- return (o, runSplineT s b)---- | Run a spline without converting it into a stream. Produces either an output--- value on the left or the result value on the right.-runSplineE :: Monad m => SplineT a b m c -> a -> m (Either b c, SplineT a b m c)-runSplineE (Pass c) _ = return (Right c, Pass c)-runSplineE (SplineT v) a = do- ((b, ev), v1) <- runVarT v a- return $ case ev of- NoEvent -> (Left b, SplineT v1)- Event c -> (Right c, Pass c)+--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)) } --- | A spline is a functor by applying the function to the result.+-- | A spline is a functor by applying the function to the result of the+-- spline. instance (Applicative m, Monad m) => Functor (SplineT a b m) where- fmap f (Pass c) = Pass $ f c- fmap f (SplineT v) = SplineT (((f <$>) <$>) <$> v)+ fmap f (SplineT s) = SplineT $ \a -> s a >>= \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.+instance (Applicative m, Monad m) => Monad (SplineT a b m) where+ return = SplineT . const . return . Left+ (SplineT s0) >>= f = SplineT $ g s0+ where g s a = do e <- s a+ case e of+ Left c -> runSplineT (f c) a+ Right (b, SplineT s1) -> return $ Right (b, SplineT $ g s1)+ -- A spline responds to 'pure' by returning a spline that never produces an -- 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. instance (Applicative m, Monad m) => Applicative (SplineT a b m) where- pure = Pass- (Pass f) <*> (Pass x) = Pass $ f x- (Pass f) <*> (SplineT v) = f <$> SplineT v- (SplineT vf) <*> (Pass x) = ($ x) <$> SplineT vf+ pure = return sf <*> sx = do f <- sf x <- sx return $ f x --- | A spline responds to bind by running until it produces an eventual value,--- then uses that value to run the next spline.-instance (Applicative m, Monad m) => Monad (SplineT a b m) where- return = Pass- (Pass x) >>= f = f x- (SplineT v) >>= f = SplineT $ VarT $ \a -> do- ((b, ec), v1) <- runVarT v a- case ec of- NoEvent -> return ((b, NoEvent), runSplineT (SplineT v1 >>= f) b)- Event c -> runVarT (runSplineT (f c) b) a--#if MIN_VERSION_base(4,8,0)--- | A spline is a transformer if its output type is a Monoid.-instance Monoid b => MonadTrans (SplineT a b) where- lift = effect mempty+-- #if MIN_VERSION_base(4,8,0)+-- | A spline is a transformer by using @effect@.+instance MonadTrans (SplineT a b) where+ lift f = SplineT $ const $ f >>= return . Left -- | 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 (Monoid b, Applicative m, Monad m, MonadIO m) => MonadIO (SplineT a b m) where+instance (Applicative m, Monad m, MonadIO m) => MonadIO (SplineT a b m) where liftIO = lift . liftIO-#endif---- | Run the spline over the input values, gathering the output and result--- values in a list.-scanSpline :: (Applicative m, Monad m)- => SplineT a b m c -> b -> [a] -> m [b]-scanSpline s b = fmap fst <$> scanVar (outputStream s b)-+-- #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@@ -146,16 +111,25 @@ -- | Evaluates a spline into a value stream of its output type. outputStream :: (Applicative m, Monad m) => SplineT a b m c -> b -> VarT m a b-outputStream s b = fst <$> runSplineT s b+outputStream (SplineT s0) b0 = VarT $ f s0 b0+ where f s b a = do e <- s a+ case e of+ Left _ -> return (b, done b)+ Right (b1, SplineT s1) -> return (b1, VarT $ f s1 b1) -resultStream :: (Applicative m, Monad m)- => SplineT a b m c -> b -> VarT m a (Event c)-resultStream s b = snd <$> runSplineT s b+-- | Run the spline over the input values, gathering the output values in a+-- list.+scanSpline :: (Applicative m, Monad m)+ => 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 $ f <$> ve- where f e = (e,e)+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 a value stream and an event stream. The spline -- uses the value stream as its output value. The spline will run until@@ -165,16 +139,18 @@ untilEvent :: (Applicative m, Monad m) => VarT m a b -> VarT m a (Event c) -> SplineT a b m (b,c)-untilEvent v ve = SplineT $ f <$> v <*> ve- where f b ec = (b, (b,) <$> ec)+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) -- | A variant of 'untilEvent' that only results in the left result, -- discarding the right result. untilEvent_ :: (Applicative m, Monad m) => VarT m a b -> VarT m a (Event c) -> SplineT a b m b-untilEvent_ v ve = SplineT $ f <$> v <*> ve- where f b ec = (b, b <$ ec)+untilEvent_ v ve = fst <$> untilEvent v ve -- | A variant of 'untilEvent' that only results in the right result, -- discarding the left result.@@ -183,7 +159,7 @@ -> 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 right and left results. _untilEvent_ :: (Applicative m, Monad m) => VarT m a b -> VarT m a (Event c) -> SplineT a b m ()@@ -195,91 +171,75 @@ 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)-race _ (Pass x) _ = Pass $ Left x-race _ _ (Pass x) = Pass $ Right x-race f (SplineT va) (SplineT vb) = SplineT $ VarT $ \i -> do- ((a, ed), va1) <- runVarT va i- ((b, ee), vb1) <- runVarT vb i- let c = f a b- case (ed,ee) of- (Event d,_) -> return ( (c, Event $ Left d), pure (c, Event $ Left d))- (_,Event e) -> return ( (c, Event $ Right e), pure (c, Event $ Right e))- (_,_) -> return ( (c, NoEvent)- , runSplineT (race f (SplineT va1) (SplineT vb1)) c- )+race f sa0 sb0 = SplineT (g sa0 sb0)+ where g sa sb i = runSplineT sa i >>= \case+ Left d -> return $ Left $ Left d+ Right (a, sa1) -> runSplineT sb i >>= \case+ 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) => [SplineT a b m c] -> SplineT a b m c raceMany [] = pure mempty `_untilEvent` never---raceMany (Pass c:_) = Pass c-raceMany ss = SplineT $ VarT $ \a -> do- let f (b, ec, ss1) s = do- ((b1, ec1), v1) <- runVarT (runSplineT s b) a- return (b <> b1, msum [ec, ec1], ss1 ++ [SplineT v1])- (b,ec,ss1) <- foldM f (mempty, NoEvent, []) ss- return ((b,ec), runSplineT (raceMany ss1) b)+raceMany 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+ Right (b1, s) -> f (ys ++ [runSplineT s]) vs (b <> b1) a -- | Run two splines in parallel, combining their output. Once both splines -- have concluded, return the results of each in a tuple. merge :: (Applicative m, Monad m)- => (b -> b -> b) -> (c -> d -> e)- -> SplineT a b m c -> SplineT a b m d -> SplineT a b m e-merge _ g (Pass c) (Pass d) = Pass $ g c d-merge _ g (Pass c) s = g c <$> s-merge _ g s (Pass d) = flip g d <$> s-merge f g (SplineT v1) (SplineT v2) = SplineT $ VarT $ \a -> do- ((b1,e1), v3) <- runVarT v1 a- ((b2,e2), v4) <- runVarT v2 a- let b = f b1 b2- case (e1,e2) of- (Event c, Event d) -> let e = (b, Event $ g c d) in return (e, pure e)- (Event _, _) -> do let s = SplineT $ pure (b1,e1)- sv4 = SplineT v4- return ((b, NoEvent), runSplineT (merge f g s sv4) b)- (_, Event _) -> do let s = SplineT $ pure (b2,e2)- sv3 = SplineT v3- return ((b, NoEvent), runSplineT (merge f g sv3 s) b)- _ -> do let sv3 = SplineT v3- sv4 = SplineT v4- return ((b, NoEvent), runSplineT (merge f g sv3 sv4) b)+ => (b -> b -> b)+ -> SplineT a b m c -> SplineT a b m d -> SplineT a b m (c, d)+merge apnd s1 s2 = SplineT $ f s1 s2 --- | Run the side effect and use its result as the spline's result. This--- discards the output argument and switches immediately, but the argument is--- needed to construct the spline. For this reason spline's can't be an instance--- of MonadTrans or MonadIO.-effect :: (Applicative m, Monad m) => b -> m x -> SplineT a b m x-effect b f = SplineT $ VarT $ const $ do- x <- f- return ((b, Event x), pure (b, Event x))+ where r c d = return $ Left (c, d) + fr c vb a = runSplineT vb a >>= \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+ 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)+ -- | 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. capture :: (Applicative m, Monad m) => SplineT a b m c -> SplineT a b m (Maybe b, c)-capture (Pass x) = Pass (Nothing, x)-capture (SplineT v) = capture' v- where capture' v' = SplineT $ VarT $ \a -> do- ((b, ec), v'') <- runVarT v' a- let mb' = Just b- return ((b, (mb',) <$> ec), runSplineT (capture' v'') b)+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) -- | Produce the argument as an output value exactly once. step :: (Applicative m, Monad m) => b -> SplineT a b m ()-step b = SplineT $ VarT $ \_ -> return ((b, NoEvent), pure (b,Event ()))+step b = SplineT $ const $ return $ Right (b, return ()) -- | Map the output value of a spline. mapOutput :: (Applicative m, Monad m) => VarT m a (b -> t) -> SplineT a b m c -> SplineT a t m c-mapOutput vf (SplineT vx) = SplineT $ vg <*> vx- where vg = (\f (b,ec) -> (f b, ec)) <$> vf-mapOutput _ (Pass c) = Pass 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) -- | 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 vf (SplineT vx) = SplineT $ VarT $ \a -> do- (f, vf1) <- runVarT vf a- (b, vx1) <- runVarT vx $ f a- return (b, runSplineT (adjustInput vf1 $ SplineT vx1) $ fst b)-adjustInput _ (Pass c) = Pass c+adjustInput vf0 s = SplineT $ g vf0 s+ 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)
src/Control/Varying/Tween.hs view
@@ -15,35 +15,43 @@ -- dreams). ---{-# LANGUAGE Rank2Types #-}-module Control.Varying.Tween (+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-}+module Control.Varying.Tween+ ( -- * Tweening types+ Easing+ , TweenT+ , Tween+ -- * Running tweens+ , runTweenT+ , scanTween+ , tweenStream -- * Creating tweens -- $creation- tween,- tween_,- constant,- timeAsPercentageOf,+ , tween+ , tween_+ , constant+ , withTween+ , withTween_ -- * Interpolation functions -- $lerping- linear,- easeInCirc,- easeOutCirc,- easeInExpo,- easeOutExpo,- easeInSine,- easeOutSine,- easeInOutSine,- easeInPow,- easeOutPow,- easeInCubic,- easeOutCubic,- easeInQuad,- easeOutQuad,+ , linear+ , easeInCirc+ , easeOutCirc+ , easeInExpo+ , easeOutExpo+ , easeInSine+ , easeOutSine+ , easeInOutSine+ , easeInPow+ , easeOutPow+ , easeInCubic+ , easeOutCubic+ , easeInQuad+ , easeOutQuad -- * Writing your own tweens -- $writing- Tween,- Easing-) where+ ) where import Control.Varying.Core import Control.Varying.Event@@ -51,6 +59,9 @@ import Control.Varying.Time import Control.Arrow import Control.Applicative+import Control.Monad.Trans.State+import Control.Monad.Trans.Class+import Data.Functor.Identity -------------------------------------------------------------------------------- -- $lerping@@ -124,6 +135,26 @@ linear :: (Floating t, Real f) => Easing t f linear c t b = c * (realToFrac t) + b +type TweenT f t m = SplineT f t (StateT f m)+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)+runTweenT s dt = runStateT (runSplineT s dt)++scanTween :: (Functor m, Applicative m, Monad m, Num f)+ => TweenT f t m a -> t -> [f] -> m [t]+scanTween s t dts = evalStateT (scanSpline s t dts) 0++-- | Converts a tween into a continuous value stream. This is the tween version+-- of `outputStream`.+tweenStream :: (Applicative m, Monad m, Num f)+ => TweenT f t m x -> t -> VarT m f t+tweenStream s0 t0 = VarT $ f s0 t0 0+ where f s t l i = do (e, l1) <- runTweenT s i l+ case e of+ Left _ -> return (t, done t)+ Right (b, s1) -> return (b, VarT $ f s1 b l1) -------------------------------------------------------------------------------- -- $creation -- The most direct route toward tweening values is to use 'tween'@@ -140,65 +171,78 @@ -- @ -- testWhile_ isEvent (deltaUTC >>> v) -- where v :: VarT IO a (Event Double)--- v = execSpline 0 $ tween easeOutExpo 0 100 5+-- v = flip outputStream 0 $ tween easeOutExpo 0 100 5 -- @ -- -- 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 ;)-tween :: (Applicative m, Monad m, Num t, Fractional f, Ord f)- => Easing t f -> t -> t -> f -> SplineT f t m t-tween f start end dur =- let c = end - start- b = start- vt = h <$> timeAsPercentageOf dur- h t = if t >= 1.0- then (end, Event end)- else (f c t b, NoEvent)- in SplineT vt+--+-- `tween` concludes returning the latest output value.+tween :: (Applicative m, Monad m, Real f, Fractional f, Real t, Fractional t)+ => Easing t f -> t -> t -> f -> TweenT f t m t+tween f start end dur = SplineT g+ where c = end - start+ b = start+ g dt = do+ leftover <- get+ let t = dt + leftover + if t == dur+ then do put 0+ return $ Right (end, return end)+ else if t > dur+ then do put $ t - dur - dt+ return $ Left end+ else do put t+ return $ Right (f c (t/dur) b, SplineT g)+ -- | A version of 'tween' that discards the result. It is simply -- -- @ -- tween f a b c >> return () -- @ ---tween_ :: (Applicative m, Monad m, Num t, Fractional f, Ord f)- => Easing t f -> t -> t -> f -> SplineT f t m ()+tween_ :: (Applicative m, Monad m, Real t, Fractional t, Real f, Fractional f)+ => Easing t f -> t -> t -> f -> TweenT f t m () tween_ f a b c = tween f a b c >> return () +-- | A version of 'tween' that maps its output using the given constant+-- function.+-- @+-- withTween ease from to dur f = mapOutput (pure f) $ tween ease from to dur+-- @+withTween :: (Applicative m, Monad m, Real t, Fractional t, Real a, Fractional a)+ => Easing t a -> t -> t -> a -> (t -> x) -> TweenT a x m t+withTween ease from to dur f = mapOutput (pure f) $ tween ease from to dur++-- | A version of 'withTween' that discards its output.+withTween_ :: (Applicative m, Monad m, Real t, Fractional t, Real a, Fractional a)+ => Easing t a -> t -> t -> a -> (t -> x) -> TweenT a x m ()+withTween_ ease from to dur f = withTween ease from to dur f >> return ()+ -- | Creates a tween that performs no interpolation over the duration. constant :: (Applicative m, Monad m, Num t, Ord t)- => a -> t -> SplineT t a m a+ => a -> t -> TweenT t a m a constant value duration = pure value `untilEvent_` after duration --- | VarTies 0.0 to 1.0 linearly for duration `t` and 1.0 after `t`.-timeAsPercentageOf :: (Applicative m, Monad m, Ord t, Num t, Fractional t)- => t -> VarT m t t-timeAsPercentageOf t = (/t) <$> accumulate (+) 0- -------------------------------------------------------------------------------- -- $writing -- To create your own tweens just write a function that takes a start -- value, end value and a duration and return an event stream. -- -- @--- tweenInOutExpo s e d = execSpline s $ do--- x <- tween easeInExpo s e (d/2)--- tween easeOutExpo x e (d/2)+-- tweenInOutExpo start end dur = do+-- (dt, x) <- tween easeInExpo start end (dur/2)+-- tween easeOutExpo x end $ dt + dur/2 -- @ ----------------------------------------------------------------------------------- | An easing function. The parameters or often named `c`, `t` and `b`,+-- | An easing function. The parameters are often named `c`, `t` and `b`, -- where `c` is the total change in value over the complete duration--- (endValue - startValue), `t` is the current percentage of the duration--- that has elapsed and `b` is the start value.+-- (endValue - startValue), `t` is the current percentage (0 to 1) of the+-- duration that has elapsed and `b` is the start value. -- -- To make things simple only numerical values can be tweened and the type -- of time deltas much match the tween's value type. This may change in the -- future :) type Easing t f = t -> f -> t -> t---- | A linear interpolation between two values over some duration.--- A `Tween` takes three values - a start value, an end value and--- a duration.-type Tween m t f = t -> t -> f -> VarT m f (Event t)
test/Main.hs view
@@ -1,12 +1,14 @@ module Main where import Test.Hspec hiding (after, before)-import Test.QuickCheck import Control.Applicative import Control.Varying+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Monad.Trans.State+import Control.Monad (when) import Data.Functor.Identity import Data.Time.Clock-import Control.Monad.IO.Class main :: IO () main = hspec $ do@@ -26,33 +28,32 @@ describe "anyE" $ do it "should produce on any event" $ do let v1,v2,v3 :: Var () (Event Int)- v1 = use 1 (1 ~> before 2)- v2 = use 2 (1 ~> after 3)+ 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]- describe "timeAsPercentageOf" $ do- it "should run past 1.0" $ do- let scans = fst $ runIdentity $ scanVar (timeAsPercentageOf 4)- [1,1,1,1,1 :: Float]- last scans `shouldSatisfy` (> 1)- it "should progress by increments of the total" $ do- let scans = fst $ runIdentity $ scanVar (timeAsPercentageOf 4)- [1,1,1,1,1 :: Float]- scans `shouldBe` [0.25,0.5,0.75,1.0,1.25 :: Float]-- describe "tween" $+ describe "tween/tweenWith" $ do it "should step by the dt passed in" $ do- let Identity scans = scanSpline (tween linear 0 4 (4 :: Float)) 0- [0,1,1,1,1,1]- scans `shouldBe` [0,1,2,3,4,4]+ let mytween :: Tween Double Double ()+ mytween = tween_ linear 0 4 4 >> tween_ linear 4 0 4+ Identity scans = scanTween mytween 0 [0,1,1,1,1,1,1,1,1,1]+ scans `shouldBe` [0,1,2,3,4,3,2,1,0,0]+ it "should prevent infinite loops" $ do+ let mytween :: TweenT Double Double IO ()+ mytween = tween_ linear 0 4 4 >> tween_ linear 4 0 4 >> mytween + scans <- scanTween mytween 0 [6,1,1,1]+ scans `shouldBe` [2, 1, 0, 1]+ describe "untilEvent" $ do- let Identity scans = scanSpline (3 `untilEvent` (1 ~> after 10)) 0+ let Identity scans = scanSpline (3 `untilEvent` ((1 :: Var () Int)+ ~> after 10))+ 0 (replicate 10 ()) it "should produce output from the value stream until event procs" $- head scans `shouldBe` 3+ head scans `shouldBe` (3 :: Int) it "should produce output from the value stream until event procs" $ last scans `shouldBe` 3 @@ -66,17 +67,22 @@ concat scans `shouldBe` "hey, there..." describe "fromEvent" $ do- let s = fromEvent $ var f ~> onJust+ let s = do+ str <- fromEvent (var f ~> onJust)+ step $ Event str+ step $ Event "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 "YES"]+ scans `shouldBe` [NoEvent,NoEvent,NoEvent,Event "YES",Event "done"] - describe "effect" $ do+ describe "lift/liftIO" $ do let s :: SplineT () String IO () s = do step "Getting the time..."- utc <- effect "running" $ getCurrentTime+ utc <- liftIO getCurrentTime let t = head $ words $ show utc step t step "The End"@@ -153,12 +159,15 @@ -------------------------------------------------------------------------------- -- Adherance to typeclass laws --------------------------------------------------------------------------------+ -- Spline helpers let inc = 1 ~> accumulate (+) 0 sinc :: Spline a Int (Int, Int) sinc = inc `untilEvent` (1 ~> after 3) go a = runIdentity (scanSpline a 0 [0..9]) equal a b = go a `shouldBe` go b + -- Var helpers+ describe "spline's functor instance" $ do let sincf = fmap id sinc it "fmap id = id" $ equal sinc sincf@@ -168,6 +177,13 @@ sdot = fmap (g . f) sinc sfdot = fmap g $ fmap f sinc it "fmap (g . f) = fmap g . fmap f" $ equal sdot sfdot++ describe "var's applicative instance" $ do+ let f = (+1)+ x = 1+ it "(homomorphism) pure f <*> pure x = pure (f x)" $+ (fst $ runIdentity $ scanVar (pure f <*> pure x) [0..5])+ `shouldBe` (fst $ runIdentity $ scanVar (pure $ f x) [0..5]) describe "spline's applicative instance" $ do let ident = pure id <*> sinc
varying.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.5.0.3+version: 0.6.0.0 -- A short (one-line) description of the package. synopsis: FRP through value streams and monadic splines.