varying 0.1.5.0 → 0.8.1.0
raw patch · 14 files changed
Files
- README.md +87/−62
- app/Main.hs +78/−0
- bench/Main.hs +34/−0
- changelog.md +34/−0
- src/Control/Varying.hs +16/−28
- src/Control/Varying/Core.hs +734/−264
- src/Control/Varying/Event.hs +238/−415
- src/Control/Varying/Spline.hs +491/−171
- src/Control/Varying/Time.hs +0/−47
- src/Control/Varying/Tween.hs +269/−172
- src/Example.hs +0/−68
- test/DocTests.hs +7/−0
- test/Main.hs +238/−0
- varying.cabal +96/−92
README.md view
@@ -1,17 +1,10 @@ # varying [](http://hackage.haskell.org/package/varying)-[](https://travis-ci.org/schell/varying)+[](https://gitlab.com/schell/varying) -This library provides automaton based varying values 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`) and 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). -Depending on your types and values varying can provide discrete or continuous-time semantics. ## Getting started @@ -19,67 +12,99 @@ module Main where import Control.Varying-import Control.Varying.Time as Time -- time is not auto-exported-import Text.Printf+import Control.Applicative+import Control.Concurrent (forkIO, killThread)+import Data.Functor.Identity+import Data.Time.Clock -- | A simple 2d point type.-data Point = Point { x :: Float- , y :: Float+data Point = Point { px :: Float+ , 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.+tweenx :: Monad m => TweenT Float Float m Float+tweenx = do+ -- Tween from 0 to 50 over 1 second+ tween_ easeOutExpo 0 50 1+ -- Chain another tween back to the starting position+ tween_ easeOutExpo 50 0 1+ -- Loop forever+ tweenx++-- An exponential tween back and forth from 0 to 50 over 1 seconds that never+-- ends.+tweeny :: Monad m => TweenT Float Float m Float+tweeny = do+ tween_ easeOutExpo 50 0 1+ tween_ easeOutExpo 0 50 1+ tweeny++-- Our time signal counts input delta time samples.+time :: Monad m => VarT m Delta Float+time = var unDelta+ -- | Our Point value that varies over time continuously in x and y.-backAndForth :: Var IO a Point+backAndForth :: Monad m => VarT m Delta Point backAndForth =- -- Here we use Applicative to construct a varying Point that takes time- -- as an input.- (Point <$> tweenx <*> tweeny)- -- Here we feed the varying Point a time signal using the 'plug left'- -- function. We could similarly use the 'plug right' (~>) function- -- and put the time signal before the Point. This is needed because the- -- tweens take time as an input.+ -- 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 = tweenStream tweenx 0+ y = tweenStream tweeny 0+ 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 --- An exponential tween back and forth from 0 to 100 over 2 seconds.-tweenx :: Monad m => Var m Float Float-tweenx =- -- Tweens only happen for a certain duration and so their sample- -- values have the type (Ord t, Fractional t => Event t). After construction- -- a tween's full type will be- -- (Ord t, Fractional t, Monad m) => Var m t (Event t).- tween easeOutExpo 0 100 1- -- We can chain another tween back to the starting position using- -- `andThenE`, which will sample the first tween until it ends and then- -- switch to sampling the next tween.- `andThenE`- -- Tween back to the starting position.- tween easeOutExpo 100 0 1- -- At this point our resulting sample values will still have the- -- type (Event Float). The tween as a whole will be an event- -- stream. The tween also only runs back and forth once. We'd- -- like the tween to loop forever so that our point cycles back- -- and forth between 0 and 100 indefinitely.- -- We can accomplish this with recursion and the `andThen`- -- combinator, which samples an event stream until it- -- inhibits and then switches to a normal value stream (a- -- varying value). Put succinctly, it disolves our events into- -- values.- `andThen` tweenx+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 --- A quadratic tween back and forth from 0 to 100 over 2 seconds.-tweeny :: Monad m => Var m Float Float-tweeny =- tween easeOutQuad 0 100 1 `andThenE` tween easeOutQuad 100 0 1 `andThen` tweeny+ t <- getCurrentTime+ tId <- forkIO $ loop backAndForth t --- Our time signal.-time :: Var IO a Float-time = deltaUTC+ _ <- getLine+ killThread tId -main :: IO ()-main = do- putStrLn "Varying Values"- loop backAndForth- where loop :: Var IO () Point -> IO ()- loop v = do (point, vNext) <- runVar v ()- printf "\nPoint %03.1f %03.1f" (x point) (y point)- loop vNext+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+```++# Publications++The concept of `VarT` that this library is built on is isomorphic to Monadic Stream Functions as defined in "[Functional Reactive Programming, Refactored](http://dl.acm.org/citation.cfm?id=2976010)" ([mirror](http://www.cs.nott.ac.uk/~psxip1/#FRPRefactored)).++The isomorphism is+``` haskell+toMSF :: Functor m => VarT m a b -> MSF m a b+toMSF = MSF . (fmap . fmap . fmap $ toMSF) . runVarT++toVarT :: Functor m => MSF m a b -> VarT m a b+toVarT = VarT . (fmap . fmap . fmap $ toVarT) . unMSF ```
+ app/Main.hs view
@@ -0,0 +1,78 @@+module Main where++import Control.Concurrent (threadDelay)+import Control.Varying+import Data.Function (fix)+import Data.Functor.Identity (Identity (..))+import Data.Time.Clock (diffUTCTime, getCurrentTime)++-- | A simple 2d point type.+data Point = Point { px :: Float+ , py :: Float+ } deriving (Show, Eq)+++-- | The duration (in seconds) to tween in each direction.+dur :: Float+dur = 3+++-- | A novel, start-stop tween.+easeMiddle :: Monad m => Float -> Float -> Float -> TweenT Float Float m ()+easeMiddle start end t = do+ let change = end - start+ tween_ easeOutExpo start (start + change/2) $ t/2+ tween_ easeInExpo (start + change/2) end $ t/2++-- 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.+tweenx :: Monad m => TweenT Float Float m ()+tweenx = do+ -- Tween from 0 to 50 over 'dur' seconds+ easeMiddle 0 50 dur+ -- Chain another tween back to the starting position+ easeMiddle 50 0 dur+ -- Loop forever+ tweenx++-- A quadratic tween back and forth from 0 to 50 over 1 seconds that never+-- ends.+tweeny :: Monad m => TweenT Float Float m ()+tweeny = do+ easeMiddle 50 0 dur+ easeMiddle 0 50 dur+ tweeny++-- | Our Point value that varies over time continuously in x and y.+backAndForth :: 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+ -- their edges.+ let x = tweenStream tweenx 0+ y = tweenStream tweeny 0+ in+ -- Construct a varying Point that takes time as an input.+ (Point <$> x <*> y)++main :: IO ()+main = do+ t <- getCurrentTime+ ($ t) . ($ backAndForth) $ fix $ \loop v lastT -> do+ thisT <- getCurrentTime+ -- Here we'll run in the Identity monad using a time delta provided by+ -- getCurrentTime and diffUTCTime.+ let dt = realToFrac $ diffUTCTime thisT lastT+ 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+ f 'x' 'y' = '|'+ f 'y' 'x' = '|'+ f a ' ' = a+ f ' ' b = b+ f _ _ = ' '+ putStrLn str+ threadDelay $ floor $ 1000000 / (20 :: Double)+ loop vNext thisT
+ bench/Main.hs view
@@ -0,0 +1,34 @@+import Control.Varying+import Control.Monad+import Control.Applicative+import Data.Functor.Identity+import Criterion.Main++main :: IO ()+main = do+ let run v a = runIdentity (fst <$> runVarT v a)+ defaultMain [ bgroup "runVarT" [ bench "1" $ nf (run $ chain 1) 0+ , bench "2" $ nf (run $ chain 2) 0+ , bench "4" $ nf (run $ chain 4) 0+ , bench "8" $ nf (run $ chain 8) 0+ , bench "16" $ nf (run $ chain 16) 0+ , bench "32" $ nf (run $ chain 32) 0+ , bench "64" $ nf (run $ chain 64) 0+ , bench "128" $ nf (run $ chain 128) 0+ ]+ , bgroup "TweenT"+ [ bench "tweenStream" $+ nf (run $ tweenStream myTween 0) 0+ ]+ ]+ return ()++chain :: Int -> Var Int Int+chain n = seq x x+ where x = foldl (>>>) (var (+1)) $ replicate (n - 1) $ var (+1)++myTween :: Tween Float Float ()+myTween = do+ void $ tween_ easeInExpo 0 100 1+ void $ tween_ easeOutExpo 100 0 1+ myTween
changelog.md view
@@ -2,3 +2,37 @@ ========== 0.1.5.0 - added Control.Varying.Spline++0.2.0.0 - reordered spline type variables for MonadTrans++0.3.0.0 - updated the type of mapOutput to a more friendly, usable signature+ bug fixes++0.3.1.0 - added stepMany, eitherE++0.4.0.0 - Var and Spline are now parameterized with Identity, removed mix, changed+ the behavior of race, added untilEvent variants, added tests++0.5.0.0 - changed stepMany to remove Monoid requirement, added raceMany, added+ anyE, more tests and SplineT obeys Applicative and Monad laws++0.5.0.1 - removed time as dependency++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(_).++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++0.7.1.2 - Fixed broken ArrowLoop instance, updated documentation.++0.8.0.0 - TweenT is a newtype.++0.8.1.0 - Remove senseless ArrowApply instance
src/Control/Varying.hs view
@@ -1,41 +1,29 @@ -- | -- Module: Control.Varying--- Copyright: (c) 2015 Schell Scivally+-- Copyright: (c) 2016 Schell Scivally -- License: MIT--- Maintainer: Schell Scivally <schell.scivally@synapsegroup.com>------ The simplest, squishiest FRP library around.+-- Maintainer: Schell Scivally <schell@takt.com> -- -- [@Core@]--- Get started writing varying values (also called streams) using the pure--- constructor 'var', the monadic constructor 'varM' or the raw constructor--- 'Var'+-- Automaton based value streams. -- -- [@Event@]--- Write event streams using the many event emitters and combinators.+-- Discontinuous value streams that occur only sometimes. ----- [@Tween@]--- Tween numerical values over time using interpolation functions and the--- "quick 'n dirty" time generators in 'Control.Varying.Time'.+-- [@Spline@]+-- Sequencing of value and event streams using do-notation to form complex+-- behavior. ----- [@Time@]--- The 'Control.Varying.Time' module is not reexported because some of the--- functions collide with those in 'Event' - namely 'before' and 'after'.--- I think this is okay because in my experience most modules will either--- deal with events based on user input or events based on time, an in--- rare cases both - but in that case the majority of streams will be of one--- type making the choice of which module to import qualified an easy one.--- The time generator 'Control.Varying.Time.deltaUTC' in 'Control.Varying.Time'--- is practical and based on 'Data.Time.Clock.getCurrentTime'. It's meant--- to be simple, not optimal.+-- [@Tween@]+-- 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.Tween+ -- * Reexports+ module V ) where -import Control.Varying.Core-import Control.Varying.Event-import Control.Varying.Tween+import Control.Varying.Core as V+import Control.Varying.Event as V+import Control.Varying.Spline as V+import Control.Varying.Tween as V
src/Control/Varying/Core.hs view
@@ -1,328 +1,798 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- | -- Module: Control.Varying.Core -- Copyright: (c) 2015 Schell Scivally -- License: MIT--- Maintainer: Schell Scivally <schell.scivally@synapsegroup.com>+-- Maintainer: Schell Scivally <schell@takt.com> ----- Values that change over a given domain.+-- Varying values represent values that change over a given domain. ----- Varying values take some input (the domain ~ time, place, etc) and produce--- a sample and a new varying value. 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(..),- -- * Creating varying values+-- A varying value takes some input as its domain (e.g. time, place, etc)+-- and when run using 'runVarT' it produces a value and a new varying value.+-- This pattern is known as an automaton and `varying` uses this pattern at its+-- core. With the additon of monadic event sequencing, 'varying' makes it easy+-- to construct complicated signals that control program and data flow.+module Control.Varying.Core+ ( -- * Types and Typeclasses+ Var+ , VarT(..)+ -- * Creating vars -- $creation- var,- varM,- mkState,- -- * Composing varying values+ , done+ , var+ , arr+ , varM+ , mkState+ -- * Composing vars -- $composition- (<~),- (~>),+ , (<<<)+ , (>>>) -- * Adjusting and accumulating- delay,- accumulate,- -- * Sampling varying values (running, entry points)+ , delay+ , accumulate+ -- * Sampling vars (running and other entry points) -- $running- evalVar,- execVar,- loopVar,- loopVar_,- whileVar,- whileVar_,- -- * Testing varying values- testVar,- testVar_,- testWhile_,- vtrace,- vstrace,- vftrace,-) where+ , scanVar+ , stepMany+ -- * Debugging and tracing vars 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 (when)-import Control.Applicative-import Data.Monoid-import Debug.Trace+import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class+import Data.Functor.Contravariant+import Data.Functor.Identity+import Debug.Trace+import Prelude hiding (id, (.))+ ----------------------------------------------------------------------------------- $creation--- You can create a pure varying value by lifting a function @(a -> b)@--- with 'var':+-- Core datatypes+--------------------------------------------------------------------------------+-- | A continuously varying value, with effects.+-- It's a kind of <https://en.wikipedia.org/wiki/Mealy_machine Mealy machine>+-- (an automaton).+newtype VarT m a b+ = VarT+ { runVarT :: a -> m (b, VarT m a b) }+ -- ^ Run a @VarT@ computation with an input value of+ -- type 'a', yielding a step - a value of type 'b'+ -- and a new computation for yielding the next step.+++-- | A var 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++--------------------------------------------------------------------------------+-- Typeclass instances+--------------------------------------------------------------------------------+-- | You can transform the output value of any var: --+-- >>> let v = 1 >>> fmap (*3) (accumulate (+) 0)+-- >>> testVarOver v [(),(),()]+-- 3+-- 6+-- 9+instance Applicative m => Functor (VarT m b) where+ fmap f v = VarT $ (g <$>) . runVarT v+ where g (b, vb) = (f b, f <$> vb)++-- | A var is a category.+-- -- @--- addsOne :: Monad m => Var m Int Int--- addsOne = var (+1)+-- id = var id+-- f . g = g >>> f -- @ ----- 'var' is also equivalent to 'arr'.+-- or ----- You can create a monadic varying value by lifting a monadic computation+-- > f . g = f <<< g+--+-- >>> let v = accumulate (+) 0 . 1+-- >>> testVarOver v [(),(),()]+-- 1+-- 2+-- 3+instance 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)++-- | Vars are applicative.+--+-- >>> let v = (,) <$> pure True <*> pure "Applicative"+-- >>> testVarOver v [()]+-- (True,"Applicative")+--+-- Note - checkout the <$proofs proofs>+instance Applicative m => Applicative (VarT m a) where+ pure = done+ vf <*> vx = VarT $ \a ->+ g <$> runVarT vf a <*> runVarT vx a+ where g (f, vf1) (x, vx1) = (f x, vf1 <*> vx1)++-- | Vars 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 Monad m => Arrow (VarT m) where+ arr = var+ first v = VarT $ \(b, d) -> g d <$> runVarT v b+ where g d (c, v') = ((c, d), first v')++instance MonadPlus m => ArrowZero (VarT m) where+ zeroArrow = varM $ const mzero++instance MonadPlus m => ArrowPlus (VarT m) where+ VarT f <+> VarT g = VarT $ \a -> f a `mplus` g a++-- |+instance Monad m => ArrowChoice (VarT m) where+ left f = f +++ arr id+ right f = arr id +++ f+ f +++ g = (f >>> arr Left) ||| (g >>> arr Right)+ f ||| g = VarT $ \case+ Left b -> do+ (d, f1) <- runVarT f b+ return (d, f1 ||| g)+ Right c -> do+ (d, g1) <- runVarT g c+ return (d, f ||| g1)++-- | Inputs can depend on outputs as long as no time-travel is required.+--+-- This isn't the best example but it does make a good test case:+--+-- >>> :{+-- let+-- testVar :: VarT IO Double (Maybe Double)+-- testVar = proc val -> do+-- rec _ <- returnA -< 0.5+-- returnA -< Just 5.0+-- in+-- testVarOver testVar [5.0]+-- >>> :}+-- Just 5.0+instance MonadFix m => ArrowLoop (VarT m) where+ loop vmbdcd = VarT $ \b -> fmap fst $ mfix $ \(~(_, d)) -> do+ ((c1, d1), vmbdcd1) <- runVarT vmbdcd (b, d)+ return ((c1, loop vmbdcd1), d1)++-- | VarT with its input and output parameters flipped.+newtype FlipVarT m b a = FlipVarT { unFlipVarT :: VarT m a b }++-- | A VarT is contravariant when the type arguments are flipped.+instance Monad m => Contravariant (FlipVarT m b) where+ contramap f (FlipVarT vmab) = FlipVarT $ VarT $ \c -> do+ (b, vmab1) <- runVarT vmab $ f c+ return (b, unFlipVarT $ contramap f $ FlipVarT vmab1)++#if __GLASGOW_HASKELL__ >= 804+-- | Vars can be semigroups+--+-- >>> let v = var (const "Hello ") <> var (const "World!")+-- >>> testVarOver v [()]+-- "Hello World!"+instance (Applicative m, Semigroup b) => Semigroup (VarT m a b) where+ (<>) = liftA2 (<>)+#endif++-- | Vars can be monoids+--+-- >>> let v = var (const "Hello ") `mappend` var (const "World!")+-- >>> testVarOver v [()]+-- "Hello World!"+instance (Applicative m, Monoid b) => Monoid (VarT m a b) where+ mempty = pure mempty+ mappend = liftA2 mappend++-- | Vars can be written as numbers.+--+-- >>> let v = 1 >>> accumulate (+) 0+-- >>> testVarOver v [(),(),()]+-- 1+-- 2+-- 3+instance (Monad m, Num b) => Num (VarT m a b) where+ (+) = liftA2 (+)+ (-) = liftA2 (-)+ (*) = liftA2 (*)+ abs = fmap abs+ signum = fmap signum+ fromInteger = pure . fromInteger++-- | Vars can be written as floats.+--+-- >>> let v = pi >>> accumulate (*) 1 >>> arr round+-- >>> testVarOver v [(),(),()]+-- 3+-- 10+-- 31+instance (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++-- | Vars can be written as fractionals.+--+-- >>> let v = 2.5 >>> accumulate (/) 10+-- >>> testVarOver v [(),(),()]+-- 4.0+-- 1.6+-- 0.64+instance (Monad m, Fractional b) => Fractional (VarT m a b) where+ (/) = liftA2 (/)+ fromRational = pure . fromRational+--------------------------------------------------------------------------------+-- $creation+-- You can create a pure var 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 var by lifting a monadic computation -- @(a -> m b)@ using 'varM': -- -- @--- getsFile :: Var IO FilePath String+-- 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 varying values are stepped and sampled:------ @--- delay :: Monad m => b -> Var m a b -> Var m a b--- delay b v = Var $ \a -> return (b, go a v)--- where go a v' = Var $ \a' -> do (b', v'') <- runVar v' a--- return (b', go a' v'')--- @+-- over how vars 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 'Var'.-var :: Applicative a => (b -> c) -> Var a b c-var f = Var $ \a -> pure (f a, var f)+-- | Lift a pure computation to a var. 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 into a 'Var'.-varM :: Monad m => (a -> m b) -> Var m a b-varM f = Var $ \a -> do+-- | Lift a monadic computation to a var. This is+-- <http://hackage.haskell.org/package/arrow-list-0.7/docs/Control-Arrow-Kleisli-Class.html#v:arrM arrM>+-- 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) --- | Create a 'Var' from a state transformer.+-- | Lift a constant value to a var.+done :: Applicative m => b -> VarT m a b+done = var . const++-- | Create a var from a state transformer. mkState :: Monad m => (a -> s -> (b, s)) -- ^ state transformer -> s -- ^ intial state- -> Var m a b-mkState f s = Var $ \a -> do+ -> VarT m a b+mkState f s = VarT $ \a -> do let (b', s') = f a s return (b', mkState f s') ----------------------------------------------------------------------------------- $running--- The easiest way to sample a 'Var' is to run it in the desired monad with--- 'runVar'. This will give you a sample value and a new 'Var' bundled up in a--- tuple:------ > do (sample, v') <- runVar v inputValue------ Much like Control.Monad.State there are other entry points for running--- varying values like 'evalVar', 'execVar'. There are also extra control--- structures like 'loopVar' and 'whileVar' and more.+-- $composition+-- You can compose vars together using Category's '>>>' and '<<<'. The "right+-- plug" ('>>>') takes the output from a var on the left and "plugs" it into+-- the input of the var on the right. The "left plug" does the same thing in+-- the opposite direction. This allows you to write vars that read+-- naturally. ------------------------------------------------------------------------------------ | Iterate a 'Var' once and return the sample value.-evalVar :: Functor m => Var m a b -> a -> m b-evalVar v a = fst <$> runVar v a---- | Iterate a 'Var' once and return the next 'Var'.-execVar :: Functor m => Var m a b -> a -> m (Var m a b)-execVar v a = snd <$> runVar v a---- | Loop over a 'Var' that takes no input value.-loopVar_ :: (Functor m, Monad m) => Var m () a -> m ()-loopVar_ v = execVar v () >>= loopVar_---- | Loop over a 'Var' that produces its own next input value.-loopVar :: Monad m => a -> Var m a a -> m a-loopVar a v = runVar v a >>= uncurry loopVar---- | Iterate a 'Var' that requires no input until the given predicate fails.-whileVar_ :: Monad m => (a -> Bool) -> Var m () a -> m a-whileVar_ f v = do- (a, v') <- runVar v ()- if f a then whileVar_ f v' else return a---- | Iterate a 'Var' that produces its own next input value until the given--- predicate fails.-whileVar :: Monad m- => (a -> Bool) -- ^ The predicate to evaluate samples.- -> a -- ^ The initial input/sample value.- -> Var m a a -- ^ The 'Var' to iterate- -> m a -- ^ The last sample-whileVar f a v = if f a- then runVar v a >>= uncurry (whileVar f)- else return a ----------------------------------------------------------------------------------- Testing and debugging------------------------------------------------------------------------------------ | Trace the sample value of a 'Var' and pass it along as output. This is--- very useful for debugging graphs of 'Var's.-vtrace :: (Applicative a, Show b) => Var a b b-vtrace = vstrace ""---- | Trace the sample value of a 'Var' with a prefix and pass the sample along--- as output. This is very useful for debugging graphs of 'Var's.-vstrace :: (Applicative a, Show b) => String -> Var 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 'Var's.-vftrace :: Applicative a => (b -> String) -> Var a b b-vftrace f = var $ \b -> trace (f b) b---- | A utility function for testing 'Var's that don't require input. Runs--- a 'Var' printing each sample until the given predicate fails.-testWhile_ :: Show a => (a -> Bool) -> Var IO () a -> IO ()-testWhile_ f v = do- (a, v') <- runVar v ()- when (f a) $ print a >> testWhile_ f v'---- | A utility function for testing 'Var's that require input. The input--- must have a 'Read' instance. Use this in GHCI to step through your 'Var's--- by typing the input and hitting `return`.-testVar :: (Read a, Show b) => Var IO a b -> IO ()-testVar v = loopVar_ $ varM (const $ putStrLn "input: ")- ~> varM (const getLine)- ~> var read- ~> v- ~> varM print---- | A utility function for testing 'Var's that don't require input. Use--- this in GHCI to step through your 'Var's using the `return` key.-testVar_ :: Show b => Var IO () b -> IO ()-testVar_ v = loopVar_ $ pure () ~> v ~> varM print ~> varM (const getLine)--------------------------------------------------------------------------------- -- Adjusting and accumulating -------------------------------------------------------------------------------- -- | Accumulates input values using a folding function and yields--- that accumulated value each sample.-accumulate :: Monad m => (c -> b -> c) -> c -> Var m b c-accumulate f b = Var $ \a -> do+-- 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 => (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 'Var' by one sample using a parameter as the first--- sample. This enables the programmer to create 'Var's that depend on+-- | Delays the given var 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 vars that depend on -- themselves for values. For example: ----- > let v = 1 + delay 0 v in testVar_ v-delay :: Monad m => b -> Var m a b -> Var m a b-delay b v = Var $ \a -> return (b, go a v)- where go a v' = Var $ \a' -> do (b', v'') <- runVar v' a- return (b', go a' v'')+-- >>> let v = delay 0 v + 1 in testVarOver v [1,1,1]+-- 1+-- 2+-- 3+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'') ----------------------------------------------------------------------------------- $composition--- You can compose varying values together using '~>' and '<~'. The "right plug"--- ('~>') takes the output from a varying value on the left and "plugs" it--- into the input of the varying value on the right. The "left plug" does--- the same thing only in the opposite direction. This allows you to write--- varying values that read naturally.+-- $running+-- To sample a var simply run it in the desired monad with+-- 'runVarT'. This will produce a sample value and a new var.+--+-- >>> :{+-- 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 ----------------------------------------------------------------------------------- | Same as '~>' with flipped parameters.-(<~) :: Monad m => Var m b c -> Var m a b -> Var m a c-(<~) = flip (~>)-infixl 1 <~+-- | Iterate a var over a list of input until all input is consumed,+-- then iterate the var using one single input. Returns the resulting+-- output value and the new var.+--+-- >>> let Identity (outputs, _) = stepMany (accumulate (+) 0) [1,1,1] 1+-- >>> print outputs+-- 4+stepMany :: (Monad 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 --- | Connects two 'Var's by chaining the first's output into the input of the--- second. This is the defacto 'Var' composition method and in fact '.' is an--- alias of '<~', which is just '~>' flipped.-(~>) :: Monad m => Var m a b -> Var m b c -> Var m a c-(~>) v1 v2 = Var $ \a -> do- (b, v1') <- runVar v1 a- (c, v2') <- runVar v2 b- return (c, v1' ~> v2')-infixr 1 ~>+-- | Run the var 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 :: 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'') ----------------------------------------------------------------------------------- Typeclass instances+-- Testing and debugging ----------------------------------------------------------------------------------- | You can transform the sample value of any 'Var':+-- | Trace the sample value of a var and pass it along as output. This is+-- very useful for debugging graphs of vars. The (v|vs|vf)trace family of+-- vars use 'Debug.Trace.trace' under the hood, so the value is only traced+-- when evaluated. ----- > fmap (*3) $ accumulate (+) 0--- Will sum input values and then multiply the sum by 3.-instance (Applicative m, Monad m) => Functor (Var m b) where- fmap f' v = v ~> var f'+-- >>> 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 "" --- | A very simple category instance.------ @--- id = var id--- f . g = g ~> f--- @--- or------ > f . g = f <~ g++-- | Trace the sample value of a var with a prefix and pass the sample along+-- as output. This is very useful for debugging graphs of vars. ----- It is preferable for consistency (and readability) to use 'plug left' ('<~')--- and 'plug right' ('~>') instead of ('.') where possible.-instance (Applicative m, Monad m) => Category (Var m) where- id = var id- f . g = g ~> f+-- >>> 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) --- | 'Var's are applicative.+-- | Trace the sample value using a custom show-like function. This is useful+-- when you would like to debug a var that uses values that don't have show+-- instances. ----- > (,) <$> pure True <*> var "Applicative"-instance (Applicative m, Monad m) => Applicative (Var m a) where- pure = var . const- vf <*> va = Var $ \a -> do (f, vf') <- runVar vf a- (b, va') <- runVar va a- return (f b, vf' <*> va')+-- >>> 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 --- | 'Var's are arrows, which means you can use proc notation.+-- | Run a var in IO over some input, printing the output each step. This is+-- the function we've been using throughout this documentation.+testVarOver :: (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 ----- @--- v = proc a -> do--- ex <- intEventVar -< ()--- ey <- anotherIntEventVar -< ()--- returnA -\< (+) \<$\> ex \<*\> ey--- @--- which is equivalent to+-- > -- Definition of pure+-- > VarT (\_ -> pure (id, pure id)) <*> v ----- > v = (\ex ey -> (+) <$> ex <*> ey) <$> intEventVar <*> anotherIntEventVar-instance (Applicative m, Monad m) => Arrow (Var m) where- arr = var- first v = Var $ \(b,d) -> do (c, v') <- runVar v b- return ((c,d), first v')---- | 'Var's can be monoids+-- > -- Definition of <*>+-- > VarT (\x -> do+-- > (f, vf') <- runVarT (VarT (\_ -> pure (id, pure id))) x+-- > (a, va') <- runVarT va x+-- > pure (f a, vf' <*> va')) ----- > let v = var (const "Hello ") `mappend` var (const "World!")-instance (Applicative m, Monad m, Monoid b) => Monoid (Var m a b) where- mempty = pure mempty- mappend = liftA2 mappend---- | 'Var's can be written as numbers.+-- > -- Newtype+-- > VarT (\x -> do+-- > (f, vf') <- (\_ -> pure (id, pure id)) x+-- > (a, va') <- runVarT va x+-- > pure (f a, vf' <*> va')) ----- > let v = 1 ~> accumulate (+) 0--- which will sum the natural numbers.-instance (Applicative m, Monad m, Num b) => Num (Var m a b) where- (+) = liftA2 (+)- (-) = liftA2 (-)- (*) = liftA2 (*)- abs = fmap abs- signum = fmap signum- fromInteger = pure . fromInteger---- | 'Var's can be written as floats.+-- > -- Application+-- > VarT (\x -> do+-- > (f, vf') <- pure (id, pure id)+-- > (a, va') <- runVarT va x+-- > pure (f a, vf' <*> va')) ----- > 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 (Var 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---- | 'Var's can be written as fractionals.+-- > -- pure x >>= f = f x+-- > VarT (\x -> do+-- > (a, va') <- runVarT va x+-- > pure (id a, pure id <*> va')) ----- > let v = 2.5 ~> accumulate (+) 0--- which will add 2.5 each step.-instance (Applicative m, Monad m, Fractional b) => Fractional (Var m a b) where- (/) = liftA2 (/)- fromRational = pure . fromRational------------------------------------------------------------------------------------ Core datatypes------------------------------------------------------------------------------------ | The vessel of a varying value. A 'Var' is a structure that contains a value--- that changes over some input. That input could be time (Float, Double, etc)--- or 'Control.Varying.Event.Event's or 'Char' - whatever.--- It's a kind of Mealy machine (an automaton) with effects.-data Var m b c =- Var { runVar :: b -> m (c, Var m b c)- -- ^ Given an input value, return a computation that- -- effectfully produces an output value (a sample) and a 'Var'- -- for producing the next sample.- }+-- > -- 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
@@ -1,471 +1,294 @@+{-# LANGUAGE LambdaCase #-} -- | -- Module: Control.Varying.Event -- Copyright: (c) 2015 Schell Scivally -- License: MIT--- Maintainer: Schell Scivally <schell.scivally@synapsegroup.com>+-- Maintainer: Schell Scivally <schell@takt.com> ----- 'Event' streams describe things that happen at a specific time or place--- or value in general. For example, you can think of the event stream--- @Var IO Double (Event ())@ as an occurrence of `()` at a specific time--- (`Double`).+-- 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. ----- You can use 'Event' just like you would 'Maybe'.+-- For example, you can think of the event stream+-- @'VarT' 'IO' 'Double' ('Event' ())@ as an occurrence of @()@ at a specific+-- 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. ---module Control.Varying.Event (- Event(..),- -- * Transforming event values.- toMaybe,- isEvent,- -- * Combining event streams and value streams- latchWith,- orE,- tagOn,- tagM,- --ringM,- -- * Generating events from values- use,- onTrue,- onJust,- onUnique,- onWhen,- toEvent,- -- * Using event streams- foldStream,- collect,- collectWith,- hold,- holdWith,- startingWith,- startWith,- -- * Temporal operations (time - related)- between,- after,- beforeWith,- beforeOne,- before,- filterE,- takeE,- dropE,- once,- always,- never,- -- * Switching and chaining events- andThen,- andThenWith,- andThenE,- switchByMode,- onlyWhen,- onlyWhenE,- -- * Combining event streams- combineWith,- combine-) where--import Prelude hiding (until)-import Control.Varying.Core-import Control.Applicative-import Control.Monad-import Data.Monoid------------------------------------------------------------------------------------ Transforming event values into usable values.------------------------------------------------------------------------------------ | Turns an 'Event' into a 'Maybe'.-toMaybe :: Event a -> Maybe a-toMaybe (Event a) = Just a-toMaybe _ = Nothing+-- 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. --- | Returns 'True' when the 'Event' contains a sample and 'False'--- otherwise.-isEvent :: Event a -> Bool-isEvent (Event _) = True-isEvent _ = False------------------------------------------------------------------------------------ Combining varying values and events------------------------------------------------------------------------------------ | Holds the last value of one event stream while waiting for another event--- stream to produce a value. Once both streams have produced a value, combine--- the two using the given combine function and emit an event with the--- value.-latchWith :: (Applicative m, Monad m)- => (b -> c -> d) -> Var m a (Event b) -> Var m a (Event c)- -> Var m a (Event d)-latchWith f vb = latchWith' (NoEvent, vb)- where latchWith' (eb, vb') vc =- Var $ \a -> do (eb', vb'') <- runVar vb' a- (ec', vc') <- runVar vc a- let eb'' = eb' <|> eb- return ( f <$> eb'' <*> ec'- , latchWith' (eb'', vb'') vc'- )+module Control.Varying.Event+ ( -- * Event constructors (synonyms of Maybe)+ Event+ , event+ , noevent+ -- * Generating events from value streams+ , use+ , onTrue+ , onUnique+ , onWhen+ -- * Folding and gathering event streams+ , foldStream+ , startingWith, startWith+ -- * Combining multiple event streams+ , bothE+ , anyE+ -- * List-like operations on event streams+ , filterE+ , takeE+ , dropE+ -- * Primitive event streams+ , once+ , always+ , never+ , before+ , after+ -- * Switching+ , switch+ -- * Bubbling+ , onlyWhen+ , onlyWhenE+ ) where --- | 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) => Var m a b -> Var m a (Event b) -> Var m a b-orE y ye = Var $ \a -> do- (b, y') <- runVar y a- (e, ye') <- runVar ye a- return $ case e of- NoEvent -> (b, orE y' ye')- Event b' -> (b', orE y' ye')+import Control.Applicative+import Control.Monad+import Control.Varying.Core+import Data.Foldable (foldl')+import Prelude hiding (until) --- | Injects the values of the `vb` into the events of `ve`.-tagOn :: (Applicative m, Monad m)- => Var m a b -> Var m a (Event c) -> Var m a (Event b)-tagOn vb ve = (<$) <$> vb <*> ve+type Event = Maybe --- | Injects a monadic computation into an event stream, using the event--- values of type `b` as a parameter to produce an event stream of type--- `c`. After the first time an event is generated the result of the--- previous event is used in a clean up function.------ This is like `tagM` but performs a cleanup function first.---ringM :: (Applicative m, Monad m)--- => (c -> m ()) -> (b -> m c) -> Var m a (Event b) -> Var m a (Event c)---ringM cln = (go (const $ return ()) .) . tagM--- where go f ve = Var $ \a -> do (ec, ve') <- runVar ve a--- case ec of--- NoEvent -> return (ec, go f ve')--- Event c -> do f c--- return (ec, go cln ve')+-- | A synonym for the @Maybe@ constructor @Just@.+event :: a -> Event a+event = Just --- | Injects a monadic computation into the events of `vb`, providing a way--- to perform side-effects inside an `Event` inside a `Var`.-tagM :: (Applicative m, Monad m)- => (b -> m c) -> Var m a (Event b) -> Var m a (Event c)-tagM f vb = Var $ \a -> do- (eb, vb') <- runVar vb a- case eb of- Event b -> do c <- f b- return (Event c, tagM f vb')- NoEvent -> return (NoEvent, tagM f vb')+-- | A synonym for the @Maybe@ constructor @Nothing@.+noevent :: Event a+noevent = Nothing -------------------------------------------------------------------------------- -- 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.-onTrue :: (Applicative m, Monad m) => Var m Bool (Event ())-onTrue = var $ \b -> if b then Event () else NoEvent---- | Triggers an `Event a` when the input is `Just a`.-onJust :: (Applicative m, Monad m) => Var m (Maybe a) (Event a)-onJust = var $ \ma -> case ma of- Nothing -> NoEvent- Just a -> Event a+-- | Triggers an @'Event' ()@ when the input value is 'True'.+--+-- @+-- 'use' b 'onTrue' :: 'Monad' m => 'VarT' m 'Bool' ('Event' b)+-- @+onTrue :: Monad m => VarT m Bool (Event ())+onTrue = var $ \b -> if b then Just () else Nothing --- | Triggers an `Event a` when the input is a unique value.-onUnique :: (Applicative m, Monad m, Eq a) => Var m a (Event a)-onUnique = Var $ \a -> return (Event a, trigger a)- where trigger a' = Var $ \a'' -> let e = if a' == a''- then NoEvent- else Event a''+-- | 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 :: (Monad m, Eq a) => VarT m a (Event a)+onUnique = VarT $ \a -> return (Just a, trigger a)+ where trigger a' = VarT $ \a'' -> let e = if a' == 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) -> Var m a (Event a)-onWhen f = var $ \a -> if f a then Event a else NoEvent---- | Wraps all produced values of the given var with events.-toEvent :: (Applicative m, Monad m) => Var m a b -> Var m a (Event b)-toEvent = (~> var Event)+-- | 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 Just a else Nothing ----------------------------------------------------------------------------------- Using event values+-- Collecting ----------------------------------------------------------------------------------- | Collect all produced values into a monoidal structure using the given--- insert function.-collectWith :: (Monoid b, Applicative m, Monad m)- => (a -> b -> b) -> Var m (Event a) b-collectWith f = Var $ \a -> collect' mempty a- where collect' b e = let b' = case e of- NoEvent -> b- Event a' -> f a' b- in return (b', Var $ \a' -> collect' b' a')- -- | Like a left fold over all the stream's produced values.-foldStream :: Monad m => (a -> t -> a) -> a -> Var m (Event t) a-foldStream f acc = Var $ \e ->+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) --- | Collect all produced values into a list. The latest event value will--- be at the head of the list.-collect :: (Applicative m, Monad m) => Var m (Event a) [a]-collect = collectWith (:) -- | 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 -- @--- This is similar to 'hold' except that it takes events from its input value--- instead of another 'Var'.-startingWith, startWith :: (Applicative m, Monad m) => a -> Var m (Event a) a+--+-- >>> :{+-- let v = onWhen (== 3) >>> startingWith 0+-- in testVarOver v [0, 1, 2, 3, 4]+-- >>> :}+-- 0+-- 0+-- 0+-- 3+-- 3+startWith, startingWith+ :: Monad m+ => a+ -> VarT m (Event a) a+startWith = foldStream (\_ a -> a) startingWith = startWith-startWith a = Var $ \e ->- return $ case e of- NoEvent -> (a, startWith a)- Event a' -> (a', startWith a') --- | Flipped version of 'hold'.-holdWith :: (Applicative m, Monad m) => b -> Var m a (Event b) -> Var m a b-holdWith = flip hold---- | Produces the 'initial' value until the given 'Var' produces an event.--- After an event is produced that event's value will be produced until the--- next event produced by the given 'Var'.-hold :: (Applicative m, Monad m) => Var m a (Event b) -> b -> Var m a b-hold w initial = Var $ \x -> do- (mb, w') <- runVar w x- return $ case mb of- NoEvent -> (initial, hold w' initial)- Event e -> (e, hold w' e)---- | Produce events after the first until the second. After a successful--- cycle it will start over.-between :: (Applicative m, Monad m)- => Var m a (Event b) -> Var m a (Event c) -> Var m a (Event ())-between vb vc = (never `before` vb) `andThenE` (toEvent vu `before` vc) `andThen` between vb vc- where vu = pure ()---- | Produce events with the initial value only after the input stream has--- produced one event.-after :: (Applicative m, Monad m)- => Var m a b -> Var m a (Event c) -> Var m a (Event b)-after vb ve = Var $ \a -> do- (_, vb') <- runVar vb a- (e, ve') <- runVar ve a- case e of- Event _ -> return (NoEvent, toEvent vb')- NoEvent -> return (NoEvent, vb' `after` ve')---- | Like before, but use the value produced by the switching stream to--- create a stream to switch to.-beforeWith :: (Applicative m, Monad m)- => Var m a b- -> (Var m a (Event b), b -> Var m a (Event b))- -> Var m a (Event b)-beforeWith vb (ve, f) = Var $ \a -> do- (b, vb') <- runVar vb a- (e, ve') <- runVar ve a- case e of- Event b' -> runVar (f b') a- NoEvent -> return (Event b, beforeWith vb' (ve', f))---- | Like before, but sample the value of the second stream once before--- inhibiting.-beforeOne :: (Applicative m, Monad m) => Var m a b -> Var m a (Event b) -> Var m a (Event b)-beforeOne vb ve = Var $ \a -> do- (b, vb') <- runVar vb a- (e, ve') <- runVar ve a- case e of- Event b' -> return (Event b', never)- NoEvent -> return (Event b, vb' `beforeOne` ve')---- | Produce events of the initial varying value until the given event stream--- produces its first event, then inhibit forever.-before :: (Applicative m, Monad m)- => Var m a b -> Var m a (Event c) -> Var m a (Event b)-before vb ve = Var $ \a -> do- (b, vb') <- runVar vb a- (e, ve') <- runVar ve a- case e of- Event _ -> return (NoEvent, never)- NoEvent -> return (Event b, vb' `before` ve')---- | Produce the given value once and then inhibit forever.-once :: (Applicative m, Monad m) => b -> Var m a (Event b)-once b = Var $ \_ -> return (Event b, never)---- | Stream through some number of successful events and then inhibit forever.-takeE :: (Applicative m, Monad m)- => Int -> Var m a (Event b) -> Var m a (Event b)+-- | Stream through some number of successful 'Event's and then inhibit+-- forever.+takeE :: Monad m+ => Int -> VarT m a (Event b) -> VarT m a (Event b) takeE 0 _ = never-takeE n ve = Var $ \a -> do- (eb, ve') <- runVar ve a+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)- => Int -> Var m a (Event b) -> Var m a (Event b)+-- | Inhibit the first n occurences of an 'Event'.+dropE :: Monad m+ => Int -> VarT m a (Event b) -> VarT m a (Event b) dropE 0 ve = ve-dropE n ve = Var $ \a -> do- (eb, ve') <- runVar ve a+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')---- | Inhibit all events that don't pass the predicate.-filterE :: (Applicative m, Monad m)- => (b -> Bool) -> Var m a (Event b) -> Var m a (Event b)-filterE p v = v ~> var check- where check (Event b) = if p b then Event b else NoEvent- check _ = NoEvent+ Nothing -> return (Nothing, dropE n ve')+ Just _ -> return (Nothing, dropE (n-1) ve') --- | Never produces any event values.-never :: (Applicative m, Monad m) => Var m b (Event c)-never = pure NoEvent+-- | Inhibit all 'Event's that don't pass the predicate.+filterE :: Monad m+ => (b -> Bool) -> VarT m a (Event b) -> VarT m a (Event b)+filterE p v = (join . (check <$>)) <$> v+ where check b = if p b then Just b else Nothing+--------------------------------------------------------------------------------+-- Using multiple streams+--------------------------------------------------------------------------------+-- | Combine two 'Event' streams. Produces an event only when both streams proc+-- at the same time.+bothE :: 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 --- | Produces events with the initial value forever.-always :: (Applicative m, Monad m) => b -> Var m a (Event b)-always = pure . Event+-- | 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 leftmost stream.+anyE :: 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 (Nothing, []) outs) ----------------------------------------------------------------------------------- Switching on events+-- Primitive event streams ----------------------------------------------------------------------------------- | Produces the first 'Var's Event values until that stops producing, then--- switches to the second 'Var'.-andThen :: (Applicative m, Monad m) => Var m a (Event b) -> Var m a b -> Var m a b-andThen w1 w2 = w1 `andThenWith` const w2+-- | Produce the given event value once and then inhibit forever.+once :: Monad m => b -> VarT m a (Event b)+once b = VarT $ \_ -> return (Just b, never) --- | Switches from one event stream to another once the first stops--- producing.-andThenE :: (Applicative m, Monad m)- => Var m a (Event b) -> Var m a (Event b) -> Var m a (Event b)-andThenE y1 y2 = Var $ \a -> do- (e, y1') <- runVar y1 a- case e of- NoEvent -> runVar y2 a- Event b -> return (Event b, y1' `andThenE` y2)+-- | Never produces any 'Event' values.+--+-- @+-- 'never' = 'pure' 'Nothing'+-- @+never :: Monad m => VarT m b (Event c)+never = pure Nothing --- | Switches from one event stream when that stream stops producing. A new--- stream is created using the last produced value (or `Nothing`) and used--- as the second stream.-andThenWith :: (Applicative m, Monad m)- => Var m a (Event b) -> (Maybe b -> Var m a b) -> Var m a b-andThenWith = go Nothing- where go mb w1 f = Var $ \a -> do- (e, w1') <- runVar w1 a- case e of- NoEvent -> runVar (f mb) a- Event b -> return (b, go (Just b) w1' f)+-- | Produces 'Event's with the initial value forever.+--+-- @+-- 'always' e = 'pure' ('Event' e)+-- @+always :: Monad m => b -> VarT m a (Event b)+always = pure . Just --- | Switches using a mode signal. Signals maintain state for the duration--- of the mode.-switchByMode :: (Applicative m, Monad m, Eq b)- => Var m a b -> (b -> Var m a c) -> Var m a c-switchByMode switch f = Var $ \a -> do- (b, _) <- runVar switch a- (_, v) <- runVar (f b) a- runVar (switchOnUnique v $ switch ~> onUnique) a- where switchOnUnique v sv = Var $ \a -> do- (eb, sv') <- runVar sv a- (c', v') <- runVar (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 :: (Monad m, Num t, Ord t) => t -> VarT m t (Event t)+before t = accumulate (+) 0 >>> onWhen (< t) --- | Produce events of a varying value 'v' only when its input value passes a--- predicate 'f'.--- 'v' maintains state while cold.-onlyWhen :: (Applicative m, Monad m)- => Var m a b -- ^ 'v' - The varying value- -> (a -> Bool) -- ^ 'f' - The predicate to run on 'v''s input values.- -> Var m a (Event b)-onlyWhen v f = v `onlyWhenE` hot- where hot = var id ~> onWhen f+-- | 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 :: (Monad m, Num t, Ord t) => t -> VarT m t (Event t)+after t = accumulate (+) 0 >>> onWhen (>= t) --- | Produce events of a varying value 'v' only when an event stream 'h'--- produces an event.--- 'v' and 'h' maintain state while cold.-onlyWhenE :: (Applicative m, Monad m)- => Var m a b -- ^ 'v' - The varying value- -> Var m a (Event c) -- ^ 'h' - The event stream- -> Var m a (Event b)-onlyWhenE v hot = Var $ \a -> do- (e, hot') <- runVar hot a- if isEvent e- then do (b, v') <- runVar v a- return (Event b, onlyWhenE v' hot')- else return (NoEvent, onlyWhenE v hot') ----------------------------------------------------------------------------------- Combining event streams+-- Switching ----------------------------------------------------------------------------------- | Combine two events streams into one event stream. Like `combine` but--- uses a combining function instead of (,).-combineWith :: (Applicative m, Monad m)- => (b -> c -> d) -> Var m a (Event b) -> Var m a (Event c)- -> Var m a (Event d)-combineWith f vb vc = (uncurry f <$>) <$> combine vb vc+-- | Higher-order switching.+-- Use an event stream of value streams and produces event values of the latest+-- produced value stream. Switches to a new value stream each time one is+-- produced. The currently used value stream maintains local state until the+-- outer event stream produces a new value stream.+--+-- In this example we're sequencing the value streams we'd like to use and then+-- switching them when the outer event stream fires.+--+-- >>> import Control.Varying.Spline+-- >>> :{+-- let v :: VarT IO () (Event Int)+-- v = switch $ flip outputStream Nothing $ do+-- step $ Just $ 1 >>> accumulate (+) 0+-- step Nothing+-- step Nothing+-- step $ Just 5+-- step Nothing+-- in testVarOver v [(), (), (), (), ()] -- testing over five frames+-- >>> :}+-- Just 1+-- Just 2+-- Just 3+-- Just 5+-- Just 5+switch+ :: Monad m+ => VarT m a (Event (VarT m a b))+ -> VarT m a (Event b)+switch = switchGo $ pure Nothing+ where switchGo vInner v = VarT $ \a -> runVarT v a >>= \case+ (Nothing, vOuter) -> do+ (mayB, vInner1) <- runVarT vInner a+ return (mayB, switchGo vInner1 vOuter)+ (Just vInner2, vOuter) -> do+ (mayB, vInner3) <- runVarT (Just <$> vInner2) a+ return (mayB, switchGo vInner3 vOuter) --- | Combine two event streams into an event stream of tuples. A tuple is--- only produced when both event streams produce a value.-combine :: (Applicative m, Monad m)- => Var m a (Event b) -> Var m a (Event c) -> Var m a (Event (b,c))-combine vb vc = (\eb ec -> (,) <$> eb <*> ec) <$> vb <*> vc ----------------------------------------------------------------------------------- Operations on Events+-- Bubbling ---------------------------------------------------------------------------------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--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+-- | Produce events of a stream @v@ only when an event stream @h@ produces an+-- event.+-- @v@ and @h@ maintain state while cold.+onlyWhenE :: 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') --- | For all intents and purposes you can think of an Event as a Maybe.--- 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 @Var 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)+-- | Produce 'Event's of a value stream @v@ only when its input value passes a+-- predicate @f@.+-- @v@ maintains state while cold.+onlyWhen :: 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 (Event b)+onlyWhen v f = v `onlyWhenE` hot+ where hot = var id >>> onWhen f
src/Control/Varying/Spline.hs view
@@ -1,199 +1,519 @@ -- |--- Module: Control.Varying.SplineT+-- Module: Control.Varying.Spline -- Copyright: (c) 2015 Schell Scivally -- License: MIT--- Maintainer: Schell Scivally <schell.scivally@synapsegroup.com>+-- Maintainer: Schell Scivally <schell@takt.com> ----- Using splines we can easily create continuously varying values 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 do-notation--- computation completes and returns a result value. That result value is then--- used to determine the next spline in the sequence. This allows us to build--- up long, complex behaviors sequentially using a very familiar notation--- that can be easily turned into a continuously varying value.--{-# LANGUAGE GADTs #-}+-- Using splines we can easily create continuous streams from discontinuous+-- 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 a monad to+-- "run a stream switched by events". This means taking two streams - an output+-- stream and an event stream, and combining them into a temporarily producing+-- stream. Once that "stream pair" inhibits, the computation completes and+-- returns a result value. That result value is then used to determine the next+-- spline in the sequence. {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections #-}-module Control.Varying.Spline (- -- * Spline- Spline,- runSpline,- execSpline,- spline,+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+module Control.Varying.Spline+ ( -- * Spline+ Spline -- * Spline Transformer- SplineT(..),- runSplineT,- evalSplineT,- execSplineT,- varyUntilEvent,- capture,- -- * Step- Step(..),-) where+ , SplineT(..)+ -- * Creating streams from splines+ , outputStream+ -- * Creating splines from streams+ , fromEvent+ , untilProc+ , whileProc+ , untilEvent+ , untilEvent_+ , _untilEvent+ , _untilEvent_+ -- * Other runners+ , scanSpline+ -- * Combinators+ , 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.IO.Class-import Control.Applicative-import Data.Monoid+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Varying.Core+import Control.Varying.Event+import Data.Functor.Identity --- | A discrete step in a continuous function. This is simply a type that--- discretely describes an eventual value on the right and a monoidal output--- value on the left.-data Step f b where- Step :: Monoid f => f -> Event b -> Step f b --- | Returns the left value of a step.-stepIter :: Step f b -> f-stepIter (Step a _) = a+-- | 'SplineT' shares all the types of 'VarT' and adds a result value. Its+-- 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)) } --- | Returns the right value of a step.-stepResult :: Step f b -> Event b-stepResult (Step _ b) = b+-- | A spline is a functor by applying the function to the result of the+-- 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 Monad m => Functor (SplineT a b m) where+ fmap f (SplineT s) = SplineT $ s >=> \case+ Left c -> return $ Left $ f c+ Right (b, s1) -> return $ Right (b, fmap f s1) --- | A discrete step is a functor by applying a function to the contained--- event's value.-instance Functor (Step f) where- fmap f (Step a b) = Step a $ fmap f b+-- | 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 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 discrete spline is a monoid if its left and right types are monoids.-instance (Monoid f, Monoid b) => Monoid (Step f b) where- mempty = Step mempty (Event mempty)- mappend (Step a ea) (Step b eb) = Step (mappend a b) (mappend <$> ea <*> eb) --- | A discrete spline is an applicative if its left datatype is a monoid. It--- replies to 'pure' with an empty left value while the right value is the--- argument wrapped in an event. It means "the argument happens instantly".-instance Monoid f => Applicative (Step f) where- pure a = Step mempty $ Event a- (Step uia f) <*> (Step uib b) = Step (mappend uia uib) (f <*> b)+-- | 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.+--+-- @+-- pure = return+-- sf <*> sx = do+-- f <- sf+-- x <- sx+-- return $ f x+-- @+instance Monad m => Applicative (SplineT a b m) where+ pure = return+ sf <*> sx = do+ f <- sf+ f <$> sx --- | 'SplineT' shares a number of types with 'Var', specifically its monad,--- input and output types (m, a and b, respectively). A spline adds--- a container type that determines how empty output values should be--- created, appended and applied (the type must be monoidal and applicative).--- It also 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--- return value, where the internal state is the output value. The result--- value is used only in determining the next spline to sequence.-data SplineT m f a b c = SplineT { unSplineT :: Var m a (Step (f b) c) }- | SplineTConst c --- | Unwrap a spline into a varying value.-runSplineT :: (Applicative m, Monad m, Monoid (f b))- => SplineT m f a b c -> Var m a (Step (f b) c)-runSplineT (SplineT v) = v-runSplineT (SplineTConst x) = pure $ pure x+-- | 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 $ Left <$> f --- | 'Spline' is a specialized 'SplineT' that uses Event as its output--- container. This means that new values overwrite/replace old values due to--- Event's 'Last'-like monoid instance.-type Spline m a b c = SplineT m Event a b c+-- | 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 (Monad m, MonadIO m) => MonadIO (SplineT a b m) where+ liftIO = lift . liftIO --- | A spline is a functor by applying the function to the result.-instance (Applicative m, Monad m) => Functor (SplineT m f a b) where- fmap f (SplineT v) = SplineT $ fmap (fmap f) v- fmap f (SplineTConst c) = SplineTConst $ f c+-- | 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 --- | A spline is an applicative if its output type is a monoid. It--- responds to 'pure' by returning a spline that immediately returns the--- argument. It responds to '<*>' by applying the left arguments eventual--- value (the function) to the right arguments eventual value. The--- output values will me combined with 'mappend'.-instance (Monoid (f b), Applicative m, Monad m)- => Applicative (SplineT m f a b) where- pure = SplineTConst- (SplineTConst f) <*> (SplineTConst x) = SplineTConst $ f x- (SplineT vf) <*> (SplineTConst x) = SplineT $ fmap (fmap ($ x)) vf- (SplineTConst f) <*> (SplineT vx) = SplineT $ fmap (fmap f) vx- (SplineT vf) <*> (SplineT vx) = SplineT $ ((<*>) <$> vf) <*> vx+-- | 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 :: Monad m+ => SplineT a b m c -> b -> VarT m a 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) --- | A spline is monad if its output type is a monoid. A spline responds--- to bind by running until it produces an eventual value, then uses that--- value to run the next spline.-instance (Monoid (f b), Applicative m, Monad m) => Monad (SplineT m f a b) where- (SplineTConst x) >>= f = f x- (SplineT v) >>= f = SplineT $ Var $ \i -> do- (Step b e, v') <- runVar v i- case e of- NoEvent -> return (Step b NoEvent, runSplineT $ SplineT v' >>= f)- Event x -> runVar (runSplineT $ f x) i+-- | Run the spline over the input values, gathering the output values in a+-- list.+scanSpline :: Monad m+ => SplineT a b m c -> b -> [a] -> m [b]+scanSpline s b = fmap fst <$> scanVar (outputStream s b) --- | 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 and--- uses 'mempty' to generate an empty output value.-instance (Monoid (f b), Functor m, Applicative m, MonadIO m)- => MonadIO (SplineT m f a b) where- liftIO f = SplineT $ Var $ \_ -> do- n <- (Step mempty . Event) <$> liftIO f- return (n, pure n)+-- | Create a spline from an event stream.+fromEvent :: 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+ Just b -> Left b+ Nothing -> Right (Nothing, fromEvent ve1) --- | Evaluates a spline to a varying value of its output type.-execSplineT :: (Applicative m, Monad m, Monoid (f b))- => SplineT m f a b c -> Var m a (f b)-execSplineT = (stepIter <$>) . runSplineT+-- | 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 :: 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) --- | Evaluates a spline to an event stream of its result. The resulting--- varying value inhibits until the spline's domain is complete and then it--- produces events of the result type.-evalSplineT :: (Applicative m, Monad m, Monoid (f b))- => SplineT m f a b c -> Var m a (Event c)-evalSplineT = (stepResult <$>) . runSplineT+-- | Create a spline from an event stream. Outputs @b@ until the event stream+-- inhibits, at which point the spline concludes with @()@.+whileProc :: 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 using an event stream. The spline will run until the--- stream inhibits, using the stream's last produced value as the current--- output value. In the case the stream inhibits before producing--- a value the default value is used. The spline's result value is the last--- output value.-spline :: (Applicative m, Monad m) => b -> Var m a (Event b) -> Spline m a b b-spline x ve = SplineT $ Var $ \a -> do- (ex, ve') <- runVar ve a- case ex of- NoEvent -> let n = Step (Event x) (Event x) in return (n, pure n)- Event x' -> return (Step (Event x') NoEvent, runSplineT $ spline x' ve')+-- | 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 :: 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 vve a = do t <-runVarT vve a+ return $ case t of+ ((b, Nothing), vve1) -> Right (b, SplineT $ f vve1)+ ((b, Just c), _) -> Left (b, c) --- | Unwrap a spline into a varying value. This is an alias of--- 'runSplineT'.-runSpline :: (Applicative m, Monad m) => Spline m a b c -> Var m a (Step (Event b) c)-runSpline = runSplineT+-- | A variant of 'untilEvent' that results in the last known output value.+untilEvent_ :: Monad m+ => VarT m a b -> VarT m a (Event c) -> SplineT a b m b+untilEvent_ v ve = fst <$> untilEvent v ve --- | Using a default start value, evaluate the spline to a varying value.--- A spline is only defined over a finite domain so we must supply a default--- value to use before the spline produces its first output value.-execSpline :: (Applicative m, Monad m) => b -> Spline m a b c -> Var m a b-execSpline x (SplineTConst _) = pure x-execSpline x s = execSplineT s ~> foldStream (\_ y -> y) x+-- | A variant of 'untilEvent' that results in the event steam's event value.+_untilEvent :: Monad m+ => VarT m a b -> VarT m a (Event c) -> SplineT a b m c+_untilEvent v ve = snd <$> untilEvent v ve --- | Create a spline from a varying value and an event stream. The spline--- uses the varying value 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 used in a merge function to produce the--- spline's result value.-varyUntilEvent :: (Applicative m, Monad m)- => Var m a b -> Var m a (Event c) -> (b -> c -> d)- -> Spline m a b d-varyUntilEvent v ve f = SplineT $ Var $ \a -> do- (b, v') <- runVar v a- (ec, ve') <- runVar ve a- case ec of- NoEvent -> return (Step (Event b) NoEvent,- runSplineT $ varyUntilEvent v' ve' f)- Event c -> let n = Step (Event b) (Event $ f b c)- in return (n, pure n)+-- | A variant of 'untilEvent' that discards both the output and event values.+_untilEvent_ :: Monad m+ => VarT m a b -> VarT m a (Event c) -> SplineT a b m ()+_untilEvent_ v ve = void $ _untilEvent v ve --- | Capture the spline's latest output value and tuple it with the--- spline's result value. This is helpful when you want to sample the last+-- | 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 :: Monad m+ => (a -> b -> c) -> SplineT i a m d -> SplineT i b m e+ -> SplineT i c m (Either d e)+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)++-- | 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 :: (Monad m, Monoid b)+ => [SplineT a b m c] -> SplineT a b m c+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+ 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.+--+-- >>> :{+-- 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 :: Monad m+ => (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++ where r c d = return $ Left (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 = 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)++-- | 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, Monoid (f b), Eq (f b))- => SplineT m f a b c -> SplineT m f a b (f b, c)-capture (SplineTConst x) = SplineTConst (mempty, x)-capture (SplineT v) = capture' mempty v- where capture' mb v' = SplineT $ Var $ \a -> do- (Step fb ec, v'') <- runVar v' a- let mb' = if fb == mempty then mb else fb- ec' = (mb',) <$> ec- return (Step fb ec', runSplineT $ capture' mb' v'')+--+-- The tupled value is returned in as a 'Maybe b' since it is not+-- guaranteed that an output value is produced before a Spline concludes.+--+-- >>> :{+-- let+-- s :: MonadIO m => SplineT () Int m String+-- s = do+-- (mayX, boomStr) <-+-- capture+-- $ do+-- step 0+-- step 1+-- step 2+-- return "boom"+-- -- x is 2, but 'capture' can't be sure of that+-- maybe+-- (return "Failure")+-- ( (>> return boomStr)+-- . step+-- . (+1)+-- )+-- mayX+-- in+-- testVarOver (outputStream s 666) [(),(),(),()]+-- >>> :}+-- 0+-- 1+-- 2+-- 3+capture+ :: Monad m+ => SplineT a b m c+ -> SplineT a b m (Maybe b, c)+capture = SplineT . f Nothing+ 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 :: 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 :: 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+ 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 :: 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+ (f, vf1) <- runVarT vf a+ 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: Finish the rest of the hand proofs
− src/Control/Varying/Time.hs
@@ -1,47 +0,0 @@--- | Module: Control.Varying.Time--- Copyright: (c) 2015 Schell Scivally--- License: MIT--- Maintainer: Schell Scivally <schell.scivally@synapsegroup.com>-{-# LANGUAGE TupleSections #-}-module Control.Varying.Time where--import Control.Varying.Core-import Control.Varying.Event hiding (after, before)-import Control.Applicative-import Data.Time.Clock---- | Produces "time" deltas using 'getCurrentTime' and 'diffUTCTime'.-deltaUTC :: Fractional t => Var IO b t-deltaUTC = delta getCurrentTime (\a b -> realToFrac $ diffUTCTime a b)---- | Produces "time" deltas using a monadic computation and a difference--- function.-delta :: (Num t, Fractional t, Applicative m, Monad m)- => m a -> (a -> a -> t) -> Var m b t-delta m f = Var $ \_ -> do- t <- m- return (0, delta' t)- where delta' t = Var $ \_ -> do- t' <- m- let dt = t' `f` t- return (dt, delta' t')------------------------------------------------------------------------------------ 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 there is no guarantee that an event will be emitted at time == t.-before :: (Applicative m, Monad m, Num t, Ord t) => t -> Var m t (Event ())-before t = Var $ \dt -> do- if t - dt >= 0- then return (Event (), before $ t - dt)- else return (NoEvent, never)---- | Emits events after t input has been accumulated.--- Note that event emission is not guaranteed to begin exactly at t,--- only at some small delta after t.-after :: (Applicative m, Monad m, Num t, Ord t) => t -> Var m t (Event ())-after t = Var $ \dt -> do- if t - dt <= 0- then return (Event (), pure $ Event ())- else return (NoEvent, after $ t - dt)
src/Control/Varying/Tween.hs view
@@ -1,8 +1,8 @@ -- | -- Module: Control.Varying.Tween--- Copyright: (c) 2015 Schell Scivally+-- Copyright: (c) 2016 Schell Scivally -- License: MIT--- Maintainer: Schell Scivally <schell.scivally@synapsegroup.com>+-- Maintainer: Schell Scivally <schell@takt.com> -- -- Tweening is a technique of generating intermediate samples of a type -- __between__ a start and end value. By sampling a running tween@@ -13,238 +13,335 @@ -- time you use. At some point it would be great to be able to tween -- arbitrary types, and possibly tween one type into another (pipe -- dreams).-----{-# LANGUAGE Arrows #-}-{-# LANGUAGE Rank2Types #-}-module Control.Varying.Tween (+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Control.Varying.Tween+ ( -- * Tweening types+ Easing+ , TweenT+ , Tween -- * Creating tweens -- $creation- tween,- constant,- -- * Tweening with splines- -- $splines- tweenTo,+ , tween+ , tween_+ , constant+ , withTween+ , withTween_+ -- * Combining tweens+ -- $combining -- * Interpolation functions -- $lerping- linear,- easeInCirc,- easeOutCirc,- easeInOutCirc,- easeInExpo,- easeOutExpo,- easeInOutExpo,- easeInSine,- easeOutSine,- easeInOutSine,- easeInPow,- easeOutPow,- easeInOutPow,- easeInCubic,- easeOutCubic,- easeInOutCubic,- easeInQuad,- easeOutQuad,- easeInOutQuad,- -- * Interpolation helpers- easeInOut,- -- * Writing your own tweens- Tween,- Easing-) where+ , linear+ , easeInCirc+ , easeOutCirc+ , easeInExpo+ , easeOutExpo+ , easeInSine+ , easeOutSine+ , easeInOutSine+ , easeInPow+ , easeOutPow+ , easeInCubic+ , easeOutCubic+ , easeInQuad+ , easeOutQuad+ -- * Running tweens+ , tweenStream+ , runTweenT+ , scanTween+ ) where -import Control.Varying.Core-import Control.Varying.Event hiding (after, before)-import Control.Varying.Spline-import Control.Varying.Time-import Control.Arrow-import Control.Applicative+import Control.Monad (void)+import Control.Monad.Trans.State (StateT, evalStateT, get, put,+ runStateT)+import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Varying.Core (VarT (..), done)+import Control.Varying.Event (after)+import Control.Varying.Spline (SplineT (..), mapOutput, scanSpline,+ untilEvent_)+import Data.Bifunctor (first, second)+import Data.Functor.Identity (Identity)+import GHC.Generics (Generic) ++-- $setup+-- >>> import Control.Varying.Core++ --------------------------------------------------------------------------------+-- | 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 (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 must match the tween's value type. This may change in the+-- future :)+type Easing t f = t -> f -> t -> t+++-------------------------------------------------------------------------------- -- $lerping -- These pure functions take a `c` (total change in value, ie end - start), -- `t` (percent of duration completion) and `b` (start value) and result in--- and interpolation of a value. To see what these look like please check+-- an interpolation of a value. To see what these look like please check -- out http://www.gizma.com/easing/. -------------------------------------------------------------------------------- + -- | Ease in quadratic.-easeInQuad :: Num t => Easing t-easeInQuad c t b = c * t*t + b+easeInQuad :: (Fractional t, Real f) => Easing t f+easeInQuad c t b = c * realToFrac (t*t) + b -- | Ease out quadratic.-easeOutQuad :: Num t => Easing t-easeOutQuad c t b = (-c) * (t * (t - 2)) + b---- | Ease in and out quadratic.-easeInOutQuad :: (Ord t, Fractional t) => Easing t-easeInOutQuad = easeInOut easeInQuad easeOutQuad+easeOutQuad :: (Fractional t, Real f) => Easing t f+easeOutQuad c t b = (-c) * realToFrac (t * (t - 2)) + b -- | Ease in cubic.-easeInCubic :: Num t => Easing t-easeInCubic c t b = c * t*t*t + b+easeInCubic :: (Fractional t, Real f) => Easing t f+easeInCubic c t b = c * realToFrac (t*t*t) + b -- | Ease out cubic.-easeOutCubic :: Num t => Easing t-easeOutCubic c t b = let t' = t - 1 in c * (t'*t'*t' + 1) + b---- | Ease in and out cubic.-easeInOutCubic :: (Ord t, Fractional t) => Easing t-easeInOutCubic = easeInOut easeInCubic easeOutCubic---- | Ease in and out by some power.-easeInOutPow :: (Fractional t, Ord t) => Int -> Easing t-easeInOutPow p = easeInOut (easeInPow p) (easeOutPow p)+easeOutCubic :: (Fractional t, Real f) => Easing t f+easeOutCubic c t b = let t' = realToFrac t - 1 in c * (t'*t'*t' + 1) + b -- | Ease in by some power.-easeInPow :: Num t => Int -> Easing t-easeInPow power c t b = c * (t^power) + b+easeInPow :: (Fractional t, Real f) => Int -> Easing t f+easeInPow power c t b = c * (realToFrac t^power) + b -- | Ease out by some power.-easeOutPow :: Num t => Int -> Easing t+easeOutPow :: (Fractional t, Real f) => Int -> Easing t f easeOutPow power c t b =- let t' = t - 1+ let t' = realToFrac t - 1 c' = if power `mod` 2 == 1 then c else -c i = if power `mod` 2 == 1 then 1 else -1 in c' * ((t'^power) + i) + b -- | Ease in sinusoidal.-easeInSine :: Floating t => Easing t-easeInSine c t b = let cos' = cos (t * (pi / 2))+easeInSine :: (Floating t, Real f) => Easing t f+easeInSine c t b = let cos' = cos (realToFrac t * (pi / 2)) in -c * cos' + c + b -- | Ease out sinusoidal.-easeOutSine :: Floating t => Easing t-easeOutSine c t b = let cos' = cos (t * (pi / 2)) in c * cos' + b+easeOutSine :: (Floating t, Real f) => Easing t f+easeOutSine c t b = let cos' = cos (realToFrac t * (pi / 2)) in c * cos' + b -- | Ease in and out sinusoidal.-easeInOutSine :: Floating t => Easing t-easeInOutSine c t b = let cos' = cos (pi * t)+easeInOutSine :: (Floating t, Real f) => Easing t f+easeInOutSine c t b = let cos' = cos (pi * realToFrac t) in (-c / 2) * (cos' - 1) + b -- | Ease in exponential.-easeInExpo :: Floating t => Easing t-easeInExpo c t b = let e = 10 * (t - 1) in c * (2**e) + b+easeInExpo :: (Floating t, Real f) => Easing t f+easeInExpo c t b = let e = 10 * (realToFrac t - 1) in c * (2**e) + b -- | Ease out exponential.-easeOutExpo :: Floating t => Easing t-easeOutExpo c t b = let e = -10 * t in c * (-(2**e) + 1) + b---- | Ease in and out exponential.-easeInOutExpo :: (Ord t, Floating t) => Easing t-easeInOutExpo = easeInOut easeInExpo easeOutExpo+easeOutExpo :: (Floating t, Real f) => Easing t f+easeOutExpo c t b = let e = -10 * realToFrac t in c * (-(2**e) + 1) + b -- | Ease in circular.-easeInCirc :: Floating t => Easing t-easeInCirc c t b = let s = sqrt (1 - t*t) in -c * (s - 1) + b+easeInCirc :: (Floating t, Real f, Floating f) => Easing t f+easeInCirc c t b = let s = realToFrac $ sqrt (1 - t*t) in -c * (s - 1) + b -- | Ease out circular.-easeOutCirc :: Floating t => Easing t-easeOutCirc c t b = let t' = (t - 1)+easeOutCirc :: (Floating t, Real f) => Easing t f+easeOutCirc c t b = let t' = (realToFrac t - 1) s = sqrt (1 - t'*t') in c * s + b --- | Ease in and out circular.-easeInOutCirc :: (Ord t, Floating t) => Easing t-easeInOutCirc = easeInOut easeInCirc easeOutCirc+-- | Ease linear.+linear :: (Floating t, Real f) => Easing t f+linear c t b = c * realToFrac t + b --- | Ease in and out using the given easing equations.-easeInOut :: (Ord t, Num t, Fractional t) => Easing t -> Easing t -> Easing t-easeInOut ein eout c t b = if t >= 0.5 then ein c t b else eout c t b+-- | A 'TweenT' is a 'SplineT' that holds a duration in local state. This allows+-- 'TweenT's to be sequenced monadically.+--+-- * 'f' is the input time delta type (the input type)+-- * 't' is the start and end value type (the output type)+-- * 'a' is the result value type+--+-- You can sequence 'TweenT's with monadic notation to produce more complex ones.+-- This is especially useful for animation:+--+-- >>> :{+-- let+-- tweenInOutExpo+-- :: ( Monad m, Floating t, Real t, Real f, Fractional f )+-- => t+-- -> t+-- -> f+-- -> TweenT f t m t+-- tweenInOutExpo start end dur = do+-- x <- tween easeInExpo start (end/2) (dur/2)+-- tween easeOutExpo x end $ dur/2+-- >>> :}+newtype TweenT f t m a+ = TweenT { unTweenT :: SplineT f t (StateT f m) a }+ deriving (Generic, Functor, Applicative, Monad) --- | Ease linear.-linear :: Num t => Easing t-linear c t b = c * t + b +instance MonadTrans (TweenT f t) where+ lift = TweenT . lift . lift+++type Tween f t a = TweenT f t Identity a+++runTweenT+ :: Functor m+ => TweenT f t m a+ -> f+ -- ^ The input time delta this frame+ -> f+ -- ^ The leftover time delta from last frame+ -> m (Either a (t, TweenT f t m a), f)+ -- ^ Returns+ -- @+ -- a tuple of+ -- either+ -- the result+ -- or a tuple of+ -- this step's output value+ -- and the tween for the next step+ -- and the leftover time delta for the next step+ -- @+runTweenT (TweenT s) dt leftover =+ first (second $ second TweenT)+ <$> runStateT+ (runSplineT s dt)+ leftover+++scanTween+ :: (Monad m, Num f)+ => TweenT f t m a+ -> t+ -> [f]+ -> m [t]+scanTween (TweenT s) t dts =+ evalStateT+ (scanSpline s t dts)+ 0+++-- | Converts a tween into a continuous value stream. This is the tween version+-- of 'Control.Varying.Spline.outputStream'. This is the preferred way to run+-- your tweens.+--+-- >>> :{+-- let+-- x :: TweenT Float Float IO Float+-- x = tween linear 0 1 1+-- y :: TweenT Float Float IO Float+-- y = tween linear 0 1 2+-- v :: VarT IO Float (Float, Float)+-- v = (,)+-- <$> tweenStream x 0+-- <*> tweenStream y 0+-- in+-- testVarOver v [0.5, 0.5, 0.5, 0.5]+-- >>> :}+-- (0.5,0.25)+-- (1.0,0.5)+-- (1.0,0.75)+-- (1.0,1.0)+tweenStream+ :: forall m f t x+ . (Functor m, Monad m, Num f)+ => TweenT f t m x+ -- ^ The tween to convert into a stream+ -> t+ -- ^ An initial output value+ -> VarT m f t+tweenStream s0 t0 = VarT $ go s0 t0 0+ where+ go ::+ TweenT f t m x -- The Tween+ -> t -- the last output value+ -> f -- the leftover time delta from last fram+ -> f -- the input time delta+ -> m (t, VarT m f t)+ go 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 $ go s1 b l1)++ -------------------------------------------------------------------------------- -- $creation--- -- The most direct route toward tweening values is to use 'tween'--- along with an interpolation function such as 'easeInOutExpo'. For example,--- @tween easeInOutExpo 0 100 10@, this will create an event stream that--- produces @Event t@s where `t` is tweened from 0 to 100 over 10 seconds.--- Once the 10 seconds are up, the stream will inhibit (produce `NoEvent`)--- forever. To create a stream of `t` that is tweened from 0 to 100 and--- then stays at 100 forever after requires you to use a combinator from the--- 'Event' module, like so:------ >tween easeInOutExpo 0 100 10 `andThen` 100------ The 'andThen' combinator "disolves" our 'Event's by switching to--- another stream once the first inhibits.+-- along with an interpolation function such as 'easeInExpo'. For example,+-- @tween easeInExpo 0 100 10@, this will create a spline that produces a+-- number interpolated from 0 to 100 over 10 seconds. At the end of the+-- tween the spline will return the result value. -------------------------------------------------------------------------------- --- | Creates an event stream that produces an event value interpolated between--- a start and end value using an easing equation ('Easing') over a duration.--- The resulting 'Var' will take a time delta as input. For example:------ @--- testWhile_ isEvent v--- where v :: Var IO a (Event Double)--- v = deltaUTC ~> tween easeOutExpo 0 100 5--- @------ Keep in mind `tween` must be fed time deltas, not absolute time or+-- | 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.+-- Keep in mind that `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, Fractional t, Ord t)- => Easing t -> t -> t -> t -> Var m t (Event t)-tween f start end dur = proc dt -> do- -- Current time as percentage / amount of interpolation (0.0 - 1.0)- t <- timeAsPercentageOf dur -< dt- -- Emitted event- e <- before dur -< dt- -- Total change in value- let c = end - start- b = start- x = f c t b- -- Tag the event with the value.- returnA -< x <$ e+--+-- `tween` concludes returning the latest output value.+tween :: (Monad m, Real t, Real f, Fractional f)+ => Easing t f -> t -> t -> f -> TweenT f t m t+tween f start end dur =+ TweenT+ $ SplineT g+ where+ c = end - start+ b = start+ g dt = do+ leftover <- get+ let+ t = dt + leftover+ if t == dur+ then+ put 0 >> return (Right (end, return end))+ else+ if t > dur+ then+ put (t - dur - dt) >> return (Left end)+ else+ put t >> return (Right (f c (t/dur) b, SplineT g)) --- Creates a tween that performs no interpolation over the duration.-constant :: (Applicative m, Monad m, Num t, Ord t)- => a -> t -> Var m t (Event a)-constant value duration = use value $ before duration ------------------------------------------------------------------------------------ $splines--- If you plan on doing a lot of tweening it's probably easiest to build up--- your tweens as splines using do-notation.--- A spline in this context is a numeric computation that is "smooth" over some--- domain. It is defined in a piecewise manner by sequencing other splines--- together using do-notation.--- You can then run the spline, transforming it back into a continuous--- varying value.+-- | A version of 'tween' that discards the result. It is simply -- -- @--- thereAndBack = execSpline 0 $ do--- x <- tweenTo easeOutExpo 0 100 1--- tweenTo easeOutExpo x 0 1+-- tween f a b c >> return () -- @------------------------------------------------------------------------------------ |-tweenTo :: (Applicative m, Monad m, Fractional t, Ord t)- => Easing t -> t -> t -> t -> Spline m t t t-tweenTo f start end dur = spline start $ tween f start end dur---- | Varies 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 -> Var m t t-timeAsPercentageOf t = proc dt -> do- t' <- accumulate (+) 0 -< dt- returnA -< min 1 (t' / t)+--+tween_ :: (Monad m, Real t, Real f, Fractional f)+ => Easing t f -> t -> t -> f -> TweenT f t m ()+tween_ f a b c = Control.Monad.void (tween f a b c) --- | An easing function. The parameters or 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.+-- | A version of 'tween' that maps its output using the given constant+-- function. ----- 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 = t -> t -> t -> t+-- @+-- withTween ease from to dur f = mapOutput (pure f) $ tween ease from to dur+-- @+withTween :: (Monad m, Real t, Real a, Fractional a)+ => Easing t a -> t -> t -> a -> (t -> x) -> TweenT a x m t+withTween ease from to dur f =+ TweenT+ $ mapOutput (pure f)+ $ unTweenT+ $ tween ease from to dur --- | 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 = t -> t -> t -> Var m t (Event t)+-- | A version of 'withTween' that discards its result.+withTween_ :: (Monad m, Real t, Real a, Fractional a)+ => Easing t a -> t -> t -> a -> (t -> x) -> TweenT a x m ()+withTween_ ease from to dur f = Control.Monad.void (withTween ease from to dur f)++-- | Creates a tween that performs no interpolation over the duration.+constant :: (Monad m, Num t, Ord t)+ => a -> t -> TweenT t a m a+constant value duration =+ TweenT+ $ pure value `untilEvent_` after duration
− src/Example.hs
@@ -1,68 +0,0 @@-module Main where--import Control.Varying-import Control.Varying.Time as Time -- time is not auto-exported-import Control.Applicative-import Text.Printf---- | A simple 2d point type.-data Point = Point { x :: Float- , y :: Float- } deriving (Show, Eq)---- | Our Point value that varies over time continuously in x and y.-backAndForth :: Var IO a Point-backAndForth =- -- Here we use Applicative to construct a varying Point that takes time- -- as an input.- (Point <$> tweenx <*> tweeny)- -- Here we feed the varying Point a time signal using the 'plug left'- -- function. We could similarly use the 'plug right' (~>) function- -- and put the time signal before the Point. This is needed because the- -- tweens take time as an input.- <~ time---- An exponential tween back and forth from 0 to 100 over 2 seconds.-tweenx :: (Applicative m, Monad m) => Var m Float Float-tweenx =- -- Tweens only happen for a certain duration and so their sample- -- values have the type (Ord t, Fractional t => Event t). After construction- -- a tween's full type will be- -- (Ord t, Fractional t, Monad m) => Var m t (Event t).- tween easeOutExpo 0 100 1- -- We can chain another tween back to the starting position using- -- `andThenE`, which will sample the first tween until it ends and then- -- switch to sampling the next tween.- `andThenE`- -- Tween back to the starting position.- tween easeOutExpo 100 0 1- -- At this point our resulting sample values will still have the- -- type (Event Float). The tween as a whole will be an event- -- stream. The tween also only runs back and forth once. We'd- -- like the tween to loop forever so that our point cycles back- -- and forth between 0 and 100 indefinitely.- -- We can accomplish this with recursion and the `andThen`- -- combinator, which samples an event stream until it- -- inhibits and then switches to a normal value stream (a- -- varying value). Put succinctly, it disolves our events into- -- values.- `andThen` tweenx---- A quadratic tween back and forth from 0 to 100 over 2 seconds.-tweeny :: (Applicative m, Monad m) => Var m Float Float-tweeny =- tween easeOutQuad 0 100 1 `andThenE` tween easeOutQuad 100 0 1 `andThen` tweeny---- Our time signal.-time :: Var IO a Float-time = deltaUTC--main :: IO ()-main = do- putStrLn "Varying Values"- loop backAndForth- where loop :: Var IO () Point -> IO ()- loop v = do (point, vNext) <- runVar v ()- printf "\nPoint %03.1f %03.1f" (x point) (y point)- loop vNext-
+ test/DocTests.hs view
@@ -0,0 +1,7 @@+module Main where++import Test.DocTest++main :: IO ()+main =+ doctest ["src", "app"]
+ test/Main.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Main where+++import Test.Hspec hiding (after, before)+import Control.Varying+import Control.Monad.IO.Class+import Data.Functor.Identity+import Data.Time.Clock++main :: IO ()+main = hspec $ do+ describe "before" $+ it "should produce events before a given step" $ do+ let varEv :: Var () (Maybe Int)+ varEv = 1 >>> before 3+ scans = fst $ runIdentity $ scanVar varEv $ replicate 4 ()+ scans `shouldBe` [Just 1, Just 2, Nothing, Nothing]++ describe "after" $+ it "should produce events after a given step" $ do+ let varEv :: Var () (Maybe Int)+ varEv = 1 >>> after 3+ scans = fst $ runIdentity $ scanVar varEv $ replicate 4 ()+ scans `shouldBe` [Nothing, Nothing, Just 3, Just 4]++ describe "anyE" $+ it "should produce on any event" $ do+ 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` [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 ()+ 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 :: Var () Int)+ >>> after 10))+ 0+ (replicate 10 ())+ it "should produce output from the value stream until event procs" $+ head scans `shouldBe` (3 :: Int)+ it "should produce output from the value stream until event procs" $+ last scans `shouldBe` 3++ describe "step" $ do+ let s = do step "hey"+ step ", "+ step "there"+ step "."+ Identity scans = scanSpline s "" $ replicate 6 ()+ it "should produce output exactly one time per call" $+ concat scans `shouldBe` "hey, there..."++ describe "untilProc" $ do+ let s = do+ str <- untilProc $ 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 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 ()+ s = do step "Getting the time..."+ utc <- liftIO getCurrentTime+ let t = head $ words $ show utc+ step t+ step "The End"+ it "should step once, get the time and then step with a string of the time"+ $ do utc <- getCurrentTime+ let t = head $ words $ show utc+ scans <- liftIO $ scanSpline s "" [(), (), ()]+ scans `shouldBe` ["Getting the time...", t, "The End"]+ describe "race" $ do+ let s1 = do step "s10"+ step "s11"+ step "s12"+ return (1 :: Int)+ s2 = do step "s20"+ step "s21"+ return True+ r = do step "start"+ eIntBool <- race (\a b -> concat [a,":",b]) s1 s2+ case eIntBool of+ Left i -> step $ "left won with " ++ show i+ Right b -> step $ "right won with " ++ show b+ Identity scans = scanSpline r "" $ replicate 4 ()+ it "should step twice and left should win" $+ unwords scans `shouldBe` "start s10:s20 s11:s21 right won with True"++ describe "raceAny" $ do+ let s1 :: Spline () String Int+ s1 = do step "t"+ step "c"+ return 0+ s2 = do step "h"+ step "a"+ return 1+ s3 = do step "e"+ step "t"+ return (2 :: Int)+ s = do x <- raceAny [s1,s2,s3]++ step $ show x+ Identity scans = scanSpline s "" $ replicate 3 ()+ it "should output in parallel (mappend) and return the first or leftmost result" $ unwords scans `shouldBe` "the cat 0"++ describe "capture" $ do+ let r :: Spline () String ()+ r = do x <- capture $ do step "a"+ step "b"+ return (2 :: Int)+ case x of+ (Just "b", 2) -> step "True"+ _ -> step "False"+ Identity scans = scanSpline r "" $ replicate 3 ()+ it "should end with the last value captured" $+ unwords scans `shouldBe` "a b True"++ describe "mapOutput" $ do+ let s :: Spline a Char ()+ s = do step 'a'+ step 'b'+ step 'c'+ let f = pure toEnum+ mapOutput f $ do step 100+ step 101+ step 102+ step 'g'+ Identity scans = scanSpline s 'x' $ replicate 7 ()+ it "should map the output" $+ scans `shouldBe` "abcdefg"++ describe "adjustInput" $ do+ let s = var id `untilEvent_` never+ v :: Var a (Char -> Int)+ v = pure fromEnum+ s' = adjustInput v s+ Identity scans = scanSpline s' 0 "abcd"+ it "should" $ scans `shouldBe` [97,98,99,100]+--------------------------------------------------------------------------------+-- 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+ let g :: (Int, Int) -> (Int, Int)+ g (x,y) = (x + 1, y)+ f (x,y) = (x - 1, y)+ 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+ it "(identity) pure id <*> v = v" $ equal ident sinc+ let pfpx :: Spline a Int Int+ pfpx = pure (+1) <*> pure 1+ pfx = pure (1+1)+ it "(homomorphism) pure f <*> pure x = pure (f x)" $ equal pfpx pfx+ let u :: Spline a Int (Int -> Int)+ u = pure 66 `_untilEvent` use (+1) (1 >>> after (3 :: Int))+ upy = u <*> pure 1+ pyu = pure ($ 1) <*> u+ it "(interchange) u <*> pure y = pure ($ y) <*> u" $ equal upy pyu+ let v :: Spline a Int (Int -> Int)+ v = pure 66 `_untilEvent` use (1-) (1 >>> after (4 :: Float))+ w = pure 72 `_untilEvent` use 3 (1 >>> after (1 :: Float))+ pduvw = pure (.) <*> u <*> v <*> w+ uvw = u <*> (v <*> w)+ it "(compisition) pure (.) <*> u <*> v <*> w = u <*> (v <*> w)" $+ equal pduvw uvw++ describe "spline's monad instance" $ do+ let h = sinc+ hr = h >>= return+ p :: Spline a Int Int+ p = pure 1++ it "(right identity w/ const) m >>= return == m" $ equal (p >>= return) p+ it "(right identity) m >>= return == m" $ equal h hr+ it "(right identity w/ monadic results) m >>= return == m" $+ runIdentity (scanSpline h 0 [0..9 :: Int])+ `shouldBe` runIdentity (scanSpline hr 0 [0..9 :: Int])+ let f :: Int -> Spline a String Bool+ f x = do mapM_ (step . show) [0..x]+ return True+ it "(left identity) return a >>= f == f a" $+ runIdentity (scanSpline (return 3 >>= f) "" [0..9 :: Int])+ `shouldBe` runIdentity (scanSpline (f 3) "" [0..9 :: Int])+ let m :: Spline a String Int+ m = do step "hey"+ step "dude"+ return 2+ g :: Bool -> Spline a String ()+ g True = do step "okay"+ step "got it"+ g False = do step "dang"+ step "missed it"+ it "(associativity) (m >>= f) >>= g == m >>= (\\x -> f x >>= g)" $+ runIdentity (scanSpline ((m >>= f) >>= g) "" [0..9 :: Int])+ `shouldBe` runIdentity (scanSpline (m >>= (\x -> f x >>= g)) "" [0..9 :: Int])
varying.cabal view
@@ -1,103 +1,107 @@--- Initial varying.cabal generated by cabal init. For further--- documentation, see http://haskell.org/cabal/users-guide/---- The name of the package.-name: varying---- The package version. See the Haskell package versioning policy (PVP)--- for standards guiding when and how versions should be incremented.--- http://www.haskell.org/haskellwiki/Package_versioning_policy--- PVP summary: +-+------- breaking API changes--- | | +----- non-breaking API additions--- | | | +--- code changes with no API change-version: 0.1.5.0---- A short (one-line) description of the package.-synopsis: FRP through varying values and monadic splines.---- A longer description of the package.-description: Varying is a FRP implentation aimed at providing a- simple way to describe values that change over some domain.- It allows monadic, applicative or arrow notation and has- convenience functions for tweening.---- URL for the project homepage or repository.-homepage: https://github.com/schell/varying---- The license under which the package is released.-license: MIT---- The file containing the license text.-license-file: LICENSE---- The package author(s).-author: Schell Scivally---- An email address to which users can send suggestions, bug reports, and--- patches.-maintainer: schell.scivally@synapsegroup.com---- A copyright notice.--- copyright:--category: Control, FRP--build-type: Simple---- Extra files to be distributed with the package, such as examples or a--- README.--- extra-source-files:---- Constraint on the version of Cabal needed to build this package.-cabal-version: >=1.10+cabal-version: 1.12 -extra-source-files: README.md, changelog.md+-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 238c3b9ce9b85922d1e595508d4616c90817444c1d7b7e3c85527c9014f90094 +name: varying+version: 0.8.1.0+synopsis: FRP through value streams and monadic splines.+description: Varying is a FRP library aimed at providing a simple way to describe values that change over a domain. It allows monadic, applicative and arrow notation and has convenience functions for tweening. Great for animation.+category: Control, FRP+homepage: https://github.com/schell/varying+bug-reports: https://github.com/schell/varying/issues+author: Schell Scivally+maintainer: schell@takt.com+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ changelog.md source-repository head- type: git- location: https://github.com/schell/varying.git+ type: git+ location: https://github.com/schell/varying library- ghc-options: -Wall- -- Modules exported by the library.- exposed-modules: Control.Varying,- Control.Varying.Core,- Control.Varying.Time,- Control.Varying.Event,- Control.Varying.Tween,- Control.Varying.Spline-- -- Modules included in this library but not exported.- -- other-modules:-- -- LANGUAGE extensions used by modules in this package.- -- other-extensions:-- -- Other library packages from which modules are imported.- build-depends: base >=4.7 && <4.9,- time >=1.5 && <1.6,- transformers >= 0.4 && <0.5-- -- Directories containing source files.- hs-source-dirs: src-- -- Base language which the package is written in.- default-language: Haskell2010+ exposed-modules:+ Control.Varying+ Control.Varying.Core+ Control.Varying.Event+ Control.Varying.Spline+ Control.Varying.Tween+ other-modules:+ Paths_varying+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.8 && <5.0+ , contravariant >=1.4+ , transformers >=0.3+ default-language: Haskell2010 executable varying-example- ghc-options: -Wall-- -- Other library packages from which modules are imported.- build-depends: base >=4.7 && <4.9,- time >=1.5 && <1.6,- transformers >= 0.4 && <0.5-+ main-is: Main.hs+ other-modules:+ Paths_varying+ hs-source-dirs:+ app+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.8 && <5.0+ , contravariant >=1.4+ , time >=1.4+ , transformers >=0.3+ , varying+ default-language: Haskell2010 - -- Directories containing source files.- hs-source-dirs: src+test-suite doctests+ type: exitcode-stdio-1.0+ main-is: DocTests.hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.8 && <5.0+ , contravariant >=1.4+ , doctest+ , transformers >=0.3+ , varying+ default-language: Haskell2010 - main-is: Example.hs+test-suite other+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.8 && <5.0+ , contravariant >=1.4+ , hspec+ , time >=1.4+ , transformers >=0.3+ , varying+ default-language: Haskell2010 - -- Base language which the package is written in.- default-language: Haskell2010+benchmark varying-bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_varying+ hs-source-dirs:+ bench+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.8 && <5.0+ , contravariant >=1.4+ , criterion+ , time >=1.4+ , transformers+ , varying+ default-language: Haskell2010