diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,17 +1,10 @@ # varying [![Hackage](https://img.shields.io/hackage/v/varying.svg)](http://hackage.haskell.org/package/varying) -[![Build Status](https://travis-ci.org/schell/varying.svg)](https://travis-ci.org/schell/varying) +[![Build Status](https://gitlab.com/schell/varying/badges/master/build.svg)](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 ``` diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/src/Control/Varying.hs b/src/Control/Varying.hs --- a/src/Control/Varying.hs +++ b/src/Control/Varying.hs @@ -1,41 +1,29 @@ -- | -- Module: Control.Varying --- Copyright: (c) 2015 Schell Scivally +-- Copyright: (c) 2016 Schell Scivally -- License: MIT --- Maintainer: Schell Scivally --- --- The simplest, squishiest FRP library around. +-- Maintainer: Schell Scivally -- -- [@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 diff --git a/src/Control/Varying/Core.hs b/src/Control/Varying/Core.hs --- a/src/Control/Varying/Core.hs +++ b/src/Control/Varying/Core.hs @@ -1,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 +-- Maintainer: Schell Scivally -- --- 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 +-- (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 +-- +-- 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 diff --git a/src/Control/Varying/Event.hs b/src/Control/Varying/Event.hs --- a/src/Control/Varying/Event.hs +++ b/src/Control/Varying/Event.hs @@ -1,471 +1,294 @@ +{-# LANGUAGE LambdaCase #-} -- | -- Module: Control.Varying.Event -- Copyright: (c) 2015 Schell Scivally -- License: MIT --- Maintainer: Schell Scivally +-- Maintainer: Schell Scivally -- --- '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 diff --git a/src/Control/Varying/Spline.hs b/src/Control/Varying/Spline.hs --- a/src/Control/Varying/Spline.hs +++ b/src/Control/Varying/Spline.hs @@ -1,199 +1,519 @@ -- | --- Module: Control.Varying.SplineT +-- Module: Control.Varying.Spline -- Copyright: (c) 2015 Schell Scivally -- License: MIT --- Maintainer: Schell Scivally +-- Maintainer: Schell Scivally -- --- 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 diff --git a/src/Control/Varying/Time.hs b/src/Control/Varying/Time.hs deleted file mode 100644 --- a/src/Control/Varying/Time.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | Module: Control.Varying.Time --- Copyright: (c) 2015 Schell Scivally --- License: MIT --- Maintainer: Schell Scivally -{-# 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) diff --git a/src/Control/Varying/Tween.hs b/src/Control/Varying/Tween.hs --- a/src/Control/Varying/Tween.hs +++ b/src/Control/Varying/Tween.hs @@ -1,8 +1,8 @@ -- | -- Module: Control.Varying.Tween --- Copyright: (c) 2015 Schell Scivally +-- Copyright: (c) 2016 Schell Scivally -- License: MIT --- Maintainer: Schell Scivally +-- Maintainer: Schell Scivally -- -- Tweening is a technique of generating intermediate samples of a type -- __between__ a start and end value. By sampling a running tween @@ -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 diff --git a/src/Example.hs b/src/Example.hs deleted file mode 100644 --- a/src/Example.hs +++ /dev/null @@ -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 - diff --git a/test/DocTests.hs b/test/DocTests.hs new file mode 100644 --- /dev/null +++ b/test/DocTests.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = + doctest ["src", "app"] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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]) diff --git a/varying.cabal b/varying.cabal --- a/varying.cabal +++ b/varying.cabal @@ -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