diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,11 @@ # 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 value streams and sequencing useful for functional reactive programming (FRP) and locally stateful programming (LSP). + ## Getting started ```haskell @@ -26,7 +27,7 @@ -- 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 :: (Applicative m, Monad m) => TweenT Float Float m Float +tweenx :: Monad m => TweenT Float Float m Float tweenx = do -- Tween from 0 to 50 over 1 second tween_ easeOutExpo 0 50 1 @@ -35,20 +36,20 @@ -- Loop forever tweenx --- A quadratic tween back and forth from 0 to 50 over 1 seconds that never +-- An exponential tween back and forth from 0 to 50 over 1 seconds that never -- ends. -tweeny :: (Applicative m, Monad m) => TweenT Float Float m Float +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 :: (Applicative m, Monad m) => VarT m Delta Float +time :: Monad m => VarT m Delta Float time = var unDelta -- | Our Point value that varies over time continuously in x and y. -backAndForth :: (Applicative m, Monad m) => VarT m Delta Point +backAndForth :: Monad m => VarT m Delta Point backAndForth = -- Turn our splines into continuous output streams. We must provide -- a starting value since splines are not guaranteed to be defined at @@ -93,4 +94,17 @@ 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 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,44 +1,51 @@ module Main where -import Control.Varying -import Control.Applicative -import Control.Concurrent (forkIO, killThread) -import Data.Functor.Identity -import Data.Time.Clock +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) -newtype Delta = Delta { unDelta :: Float } +-- | 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 :: (Applicative m, Monad m) => TweenT Float Float m Float +tweenx :: Monad m => TweenT Float Float m () tweenx = do - -- Tween from 0 to 50 over 1 second - tween_ easeOutExpo 0 50 1 + -- Tween from 0 to 50 over 'dur' seconds + easeMiddle 0 50 dur -- Chain another tween back to the starting position - tween_ easeOutExpo 50 0 1 + easeMiddle 50 0 dur -- Loop forever tweenx -- A quadratic tween back and forth from 0 to 50 over 1 seconds that never -- ends. -tweeny :: (Applicative m, Monad m) => TweenT Float Float m Float +tweeny :: Monad m => TweenT Float Float m () tweeny = do - tween_ easeOutExpo 50 0 1 - tween_ easeOutExpo 0 50 1 + easeMiddle 50 0 dur + easeMiddle 0 50 dur tweeny --- Our time signal counts input delta time samples. -time :: (Applicative m, Monad m) => VarT m Delta Float -time = var unDelta - -- | Our Point value that varies over time continuously in x and y. -backAndForth :: (Applicative m, Monad m) => VarT m Delta Point +backAndForth :: Monad m => VarT m Float Point backAndForth = -- Turn our splines into continuous output streams. We must provide -- a starting value since splines are not guaranteed to be defined at @@ -48,38 +55,24 @@ in -- Construct a varying Point that takes time as an input. (Point <$> x <*> y) - -- Stream in a time signal using the 'plug left' combinator. - -- We could similarly use the 'plug right' (~>) function - -- and put the time signal before the construction above. This is needed - -- because the tween streams take time as an input. - <~ time main :: IO () main = do - putStrLn "An example of value streams using the varying library." - putStrLn "Enter a newline to continue, and then a newline to quit" - _ <- getLine - - t <- getCurrentTime - tId <- forkIO $ loop backAndForth t - - _ <- getLine - killThread tId - -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 + 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 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -7,25 +7,25 @@ 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 - ] - ] + 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)) $ take (n - 1) $ cycle [var (+1)] + where x = foldl (>>>) (var (+1)) $ replicate (n - 1) $ var (+1) myTween :: Tween Float Float () myTween = do diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -24,3 +24,15 @@ 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,37 +1,29 @@ -- | -- Module: Control.Varying --- Copyright: (c) 2015 Schell Scivally +-- Copyright: (c) 2016 Schell Scivally -- License: MIT --- Maintainer: Schell Scivally +-- Maintainer: Schell Scivally -- -- [@Core@] --- Get started writing value streams using the pure constructor 'var', the --- monadic constructor 'varM' or the raw constructor 'VarT' +-- Automaton based value streams. -- -- [@Event@] --- Write event streams using the many event emitters and combinators. +-- Discontinuous value streams that occur only sometimes. -- -- [@Spline@] --- Use do-notation to sequence event streams to form complex behavior. +-- Sequencing of value and event streams using do-notation to form complex +-- behavior. -- -- [@Tween@] --- Tween numerical values over time using interpolation functions and the --- "quick 'n dirty" time generators in 'Control.Varying.Time'. --- --- [@Time@] --- Create time streams and temporal event streams. +-- Tween numerical values over time using common easing functions. Great for +-- animation. -- module Control.Varying ( - -- * Reexports - module Control.Varying.Core, - module Control.Varying.Event, - module Control.Varying.Spline, - module Control.Varying.Time, - module Control.Varying.Tween, + -- * Reexports + module V ) where -import Control.Varying.Core -import Control.Varying.Event -import Control.Varying.Tween -import Control.Varying.Time -import Control.Varying.Spline +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,635 +1,798 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE BangPatterns #-} --- | --- Module: Control.Varying.Core --- Copyright: (c) 2015 Schell Scivally --- License: MIT --- Maintainer: Schell Scivally --- --- Value streams represent values that change over a given domain. --- --- A stream takes some input (the domain e.g. time, place, etc) and when --- sampled using 'runVarT' - produces a value and a new value stream. This --- pattern is known as an automaton. `varying` uses this pattern as its base --- type with the additon of a monadic computation to create locally stateful --- signals that change over some domain. -module Control.Varying.Core ( - Var, - VarT(..), - -- * Creating value streams - -- $creation - done, - var, - varM, - mkState, - -- * Composing value streams - -- $composition - (<~), - (~>), - (<<<), - (>>>), - -- * Adjusting and accumulating - delay, - accumulate, - -- * Sampling value streams (running and other entry points) - -- $running - scanVar, - stepMany, - -- * Tracing value streams in flight - vtrace, - vstrace, - vftrace, -) where - -import Prelude hiding (id, (.)) -import Control.Arrow -import Control.Category -import Control.Monad -import Control.Applicative -import Data.Monoid -import Data.Functor.Identity -import Debug.Trace --------------------------------------------------------------------------------- --- Core datatypes --------------------------------------------------------------------------------- --- | A value stream parameterized with Identity that takes input of type @a@ --- and gives output of type @b@. This is the pure, effect-free version of --- 'VarT'. -type Var a b = VarT Identity a b - --- | A value stream is a structure that contains a value that changes over some --- input. It's a kind of Mealy machine (an automaton) with effects. Using --- 'runVarT' with an input value of type 'a' yields a "step", which is a value --- of type 'b' and a new 'VarT' for yielding the next value. -newtype VarT m a b = VarT { runVarT :: a -> m (b, VarT m a b) } - -- ^ Given an input value, return a computation that - -- effectfully produces an output value and a new stream for - -- producing the next sample. --------------------------------------------------------------------------------- --- $creation --- You can create a pure value stream by lifting a function @(a -> b)@ --- with 'var': --- --- @ --- addsOne :: Monad m => VarT m Int Int --- addsOne = var (+1) --- @ --- --- 'var' is equivalent to 'arr'. --- --- You can create a monadic value stream by lifting a monadic computation --- @(a -> m b)@ using 'varM': --- --- @ --- getsFile :: VarT IO FilePath String --- getsFile = varM readFile --- @ --- --- You can create either with the raw constructor. You can also create your --- own combinators using the raw constructor, as it allows you full control --- over how value streams are stepped and sampled: --- --- @ --- delay :: Monad m => b -> VarT m a b -> VarT m a b --- delay b v = VarT $ \a -> return (b, go a v) --- where go a v' = VarT $ \a' -> do (b', v'') <- runVarT v' a --- return (b', go a' v'') --- @ --- --------------------------------------------------------------------------------- --- | Lift a pure computation into a stream. -var :: Applicative m => (a -> b) -> VarT m a b -var f = VarT $ \(!a) -> pure (f a, var f) - --- | Lift a constant value into a stream. -done :: (Applicative m, Monad m) => b -> VarT m a b -done b = VarT $ \(!_) -> return (b, done b) - --- | Lift a monadic computation into a stream. -varM :: Monad m => (a -> m b) -> VarT m a b -varM f = VarT $ \(!a) -> do - b <- f a - return (b, varM f) - --- | Create a stream from a state transformer. -mkState :: Monad m - => (a -> s -> (b, s)) -- ^ state transformer - -> s -- ^ intial state - -> VarT m a b -mkState f s = VarT $ \(!a) -> do - let (b', s') = f a s - return (b', mkState f s') --------------------------------------------------------------------------------- --- $running --- To sample a stream simply run it in the desired monad with --- 'runVarT'. This will produce a sample value and a new stream. --- --- > do (sample, v') <- runVarT v inputValue - --------------------------------------------------------------------------------- --- | Iterate a stream over a list of input until all input is consumed, --- then iterate the stream using one single input. Returns the resulting --- output value and the new stream. -stepMany :: (Monad m, Functor m) => VarT m a b -> [a] -> a -> m (b, VarT m a b) -stepMany v [] e = runVarT v e -stepMany v (e:es) x = snd <$> runVarT v e >>= \v1 -> stepMany v1 es x - --- | Run the stream over the input values, gathering the output values in a --- list. -scanVar :: (Applicative m, Monad m) => VarT m a b -> [a] -> m ([b], VarT m a b) -scanVar v = foldM f ([], v) - where f (outs, v') a = do (b, v'') <- runVarT v' a - return (outs ++ [b], v'') --------------------------------------------------------------------------------- --- Testing and debugging --------------------------------------------------------------------------------- --- | Trace the sample value of a stream and pass it along as output. This is --- very useful for debugging graphs of streams. -vtrace :: (Applicative a, Show b) => VarT a b b -vtrace = vstrace "" - --- | Trace the sample value of a stream with a prefix and pass the sample along --- as output. This is very useful for debugging graphs of streams. -vstrace :: (Applicative a, Show b) => String -> VarT a b b -vstrace s = vftrace ((s ++) . show) - --- | Trace the sample value after being run through a "show" function. --- This is very useful for debugging graphs of streams. -vftrace :: Applicative a => (b -> String) -> VarT a b b -vftrace f = var $ \b -> trace (f b) b --------------------------------------------------------------------------------- --- Adjusting and accumulating --------------------------------------------------------------------------------- --- | Accumulates input values using a folding function and yields --- that accumulated value each sample. -accumulate :: (Monad m, Applicative m) => (c -> b -> c) -> c -> VarT m b c -accumulate f b = VarT $ \(!a) -> do - let b' = f b a - return (b', accumulate f b') - --- | Delays the given stream by one sample using the argument as the first --- sample. This enables the programmer to create streams that depend on --- themselves for values. For example: --- --- > let v = 1 + delay 0 v in testVar_ v -delay :: (Monad m, Applicative m) => b -> VarT m a b -> VarT m a b -delay b v = VarT $ \(!a) -> return (b, go a v) - where go a v' = VarT $ \(!a') -> do (b', v'') <- runVarT v' a - return (b', go a' v'') --------------------------------------------------------------------------------- --- $composition --- You can compose value streams together using Arrow's '>>>' and '<<<' or the --- synonyms '~>' and '<~'. The "right plug" ('>>>' and '~>') takes the output --- from a value stream on the left and "plugs" it into the input of the value --- stream on the right. --- The "left plug" does the same thing in the opposite direction. This allows --- you to write value streams that read naturally. --------------------------------------------------------------------------------- -(~>) :: (Monad m, Applicative m) => VarT m a b -> VarT m b c -> VarT m a c -(~>) = (>>>) - -(<~) :: (Monad m, Applicative m) => VarT m b c -> VarT m a b -> VarT m a c -(<~) = (<<<) --------------------------------------------------------------------------------- --- Typeclass instances --------------------------------------------------------------------------------- --- | You can transform the sample value of any stream: --- --- > fmap (*3) $ accumulate (+) 0 --- Will sum input values and then multiply the sum by 3. -instance (Applicative m, Monad m) => Functor (VarT m b) where - fmap f v = v >>> var f --- | A very simple category instance. --- --- @ --- id = var id --- f . g = g >>> f --- @ --- or --- --- > f . g = f <<< g --- --- It is preferable for consistency (and readability) to use 'plug left' ('<<<') --- and 'plug right' ('>>>') instead of ('.') where possible. -instance (Applicative m, Monad m) => Category (VarT m) where - id = var id - f0 . g0 = VarT $ \(!a) -> do - (b, g) <- runVarT g0 a - (c, f) <- runVarT f0 b - return (c, f . g) - --- | Streams are applicative. --- --- > (,) <$> pure True <*> var "Applicative" -instance (Applicative m, Monad m) => Applicative (VarT m a) where - pure = done - vf <*> vx = VarT $ \(!a) -> do - (f, vf') <- runVarT vf a - (x, vx') <- runVarT vx a - return (f x, vf' <*> vx') --- Note [1] - --- | Streams are arrows, which means you can use proc notation. --- --- @ --- v = proc a -> do --- ex <- intEventVar -< () --- ey <- anotherIntEventVar -< () --- returnA -\< (+) \<$\> ex \<*\> ey --- @ --- which is equivalent to --- --- > v = (\ex ey -> (+) <$> ex <*> ey) <$> intEventVar <*> anotherIntEventVar -instance (Applicative m, Monad m) => Arrow (VarT m) where - arr = var - first v = VarT $ \(b,d) -> do (c, v') <- runVarT v b - return ((c,d), first v') - --- | Streams can be monoids --- --- > let v = var (const "Hello ") `mappend` var (const "World!") -instance (Applicative m, Monad m, Monoid b) => Monoid (VarT m a b) where - mempty = pure mempty - mappend = liftA2 mappend - --- | Streams can be written as numbers. --- --- > let v = 1 >>> accumulate (+) 0 --- which will sum the natural numbers. -instance (Applicative m, Monad m, Num b) => Num (VarT m a b) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - abs = fmap abs - signum = fmap signum - fromInteger = pure . fromInteger - --- | Streams can be written as floats. --- --- > let v = pi >>> accumulate (*) 0.0 --- which will attempt (and succeed) to multiply pi by zero every step. -instance (Applicative m, Monad m, Floating b) => Floating (VarT m a b) where - pi = pure pi - exp = fmap exp - log = fmap log - sin = fmap sin; sinh = fmap sinh; asin = fmap asin; asinh = fmap asinh - cos = fmap cos; cosh = fmap cosh; acos = fmap acos; acosh = fmap acosh - atan = fmap atan; atanh = fmap atanh - --- | Streams can be written as fractionals. --- --- > let v = 2.5 >>> accumulate (+) 0 --- which will add 2.5 each step. -instance (Applicative m, Monad m, Fractional b) => Fractional (VarT m a b) where - (/) = liftA2 (/) - fromRational = pure . fromRational - - --- [1] Proof of the applicative laws: --- --- identity --- ======== --- pure id <*> va = va --- --- -- Definition of pure --- VarT (\_ -> pure (id, pure id)) <*> v --- --- -- Definition of <*> --- VarT (\x -> do --- (f, vf') <- runVarT (VarT (\_ -> pure (id, pure id))) x --- (a, va') <- runVarT va x --- pure (f a, vf' <*> va')) --- --- -- Newtype --- VarT (\x -> do --- (f, vf') <- (\_ -> pure (id, pure id)) x --- (a, va') <- runVarT va x --- pure (f a, vf' <*> va')) --- --- -- Application --- VarT (\x -> do --- (f, vf') <- pure (id, pure id) --- (a, va') <- runVarT va x --- pure (f a, vf' <*> va')) --- --- -- pure x >>= f = f x --- VarT (\x -> do --- (a, va') <- runVarT va x --- pure (id a, pure id <*> va')) --- --- -- Definition of id --- VarT (\x -> do --- (a, va') <- runVarT va x --- pure (a, pure id <*> va')) --- --- -- Coinduction --- VarT (\x -> do --- (a, va') <- runVarT va x --- pure (a, va')) --- --- -- f >>= pure = f --- VarT (\x -> runVarT va x) --- --- -- Eta reduction --- VarT (runVarT va) --- --- -- Newtype --- va --- --- --- composition --- =========== --- pure (.) <*> u <*> v <*> w = u <*> (v <*> w) --- --- -- Definition of pure --- VarT (\_ -> pure ((.), pure (.))) <*> u <*> v <*> w --- --- -- Definition of <*> --- VarT (\x -> do --- (h, t) <- runVarT (VarT (\_ -> pure ((.), pure (.)))) x --- (f, u') <- runVarT u x --- pure (h f, t <*> u')) <*> v <*> w --- --- -- Newtype --- VarT (\x -> do --- (h, t) <- (\_ -> pure ((.), pure (.))) x --- (f, u') <- runVarT u x --- pure (h f, t <*> u')) <*> v <*> w --- --- -- Application --- VarT (\x -> do --- (h, t) <- pure ((.), pure (.))) --- (f, u') <- runVarT u x --- pure (h f, t <*> u')) <*> v <*> w --- --- -- pure x >>= f = f x --- VarT (\x -> do --- (f, u') <- runVarT u x --- pure ((.) f, pure (.) <*> u')) <*> v <*> w --- --- -- Definition of <*> --- VarT (\x -> do --- (h, t) <- --- runVarT --- (VarT (\y -> do --- (f, u') <- runVarT u y --- pure ((.) f, pure (.) <*> u'))) x --- (g, v') <- runVarT v x --- pure (h g, t <*> v')) <*> w --- --- -- Newtype --- VarT (\x -> do --- (h, t) <- --- (\y -> do --- (f, u') <- runVarT u y --- pure ((.) f, pure (.) <*> u')) x --- (g, v') <- runVarT v x --- pure (h g, t <*> v')) <*> w --- --- -- Application --- VarT (\x -> do --- (h, t) <- do --- (f, u') <- runVarT u x --- pure ((.) f, pure (.) <*> u') --- (g, v') <- runVarT v x --- pure (h g, t <*> v')) <*> w --- --- -- (f >=> g) >=> h = f >=> (g >=> h) --- VarT (\x -> do --- (f, u') <- runVarT u x --- (h, t) <- pure ((.) f, pure (.) <*> u') --- (g, v') <- runVarT v x --- pure (h g, t <*> v')) <*> w --- --- -- pure x >>= f = f x --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- pure ((.) f g, pure (.) <*> u' <*> v')) <*> w --- --- -- Definition of <*> --- VarT (\x -> do --- (h, t) <- --- runVarT --- (VarT (\y -> do --- (f, u') <- runVarT u y --- (g, v') <- runVarT v y --- pure ((.) f g, pure (.) <*> u' <*> v'))) x --- (a, w') <- runVarT w x --- pure (h a, t <*> w')) --- --- -- Newtype --- VarT (\x -> do --- (h, t) <- --- (\y -> do --- (f, u') <- runVarT u y --- (g, v') <- runVarT v y --- pure ((.) f g, pure (.) <*> u' <*> v')) x --- (a, w') <- runVarT w x --- pure (h a, t <*> w')) --- --- -- Application --- VarT (\x -> do --- (h, t) <- do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- pure ((.) f g, pure (.) <*> u' <*> v')) --- (a, w') <- runVarT w x --- pure (h a, t <*> w')) --- --- -- (f >=> g) >=> h = f >=> (g >=> h) --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- (h, t) <- pure ((.) f g, pure (.) <*> u' <*> v')) --- (a, w') <- runVarT w x --- pure (h a, t <*> w')) --- --- -- pure x >>= f = f x --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- (a, w') <- runVarT w x --- pure ((.) f g a, pure (.) <*> u' <*> v' <*> w')) --- --- -- Definition of . --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- (a, w') <- runVarT w x --- pure (f (g a), pure (.) <*> u' <*> v' <*> w')) --- --- -- Coinduction --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- (a, w') <- runVarT w x --- pure (f (g a), u' <*> (v' <*> w'))) --- --- -- pure x >>= f = f --- VarT (\x -> do --- (f, u') <- runVarT u x --- (g, v') <- runVarT v x --- (a, w') <- runVarT w x --- (b, vw) <- pure (g a, v' <*> w') --- pure (f b, u' <*> vw)) --- --- -- (f >=> g) >=> h = f >=> (g >=> h) --- VarT (\x -> do --- (f, u') <- runVarT u x --- (b, vw) <- do --- (g, v') <- runVarT v x --- (a, w') <- runVarT w x --- pure (g a, v' <*> w') --- pure (f b, u' <*> vw)) --- --- -- Abstraction --- VarT (\x -> do --- (f, u') <- runVarT u x --- (b, vw) <- --- (\y -> do --- (g, v') <- runVarT v y --- (a, w') <- runVarT w y) --- pure (g a, v' <*> w')) x --- pure (f b, u' <*> vw)) --- --- -- Newtype --- VarT (\x -> do --- (f, u') <- runVarT u x --- (b, vw) <- --- runVarT --- (VarT (\y -> do --- (g, v') <- runVarT v y --- (a, w') <- runVarT w y) --- pure (g a, v' <*> w')) x --- pure (f b, u' <*> vw)) --- --- -- Definition of <*> --- VarT (\x -> do --- (f, u') <- runVarT u x --- (b, vw) <- runVarT (v <*> w) x --- pure (f b, u' <*> vw)) --- --- -- Definition of <*> --- u <*> (v <*> w) --- --- --- homomorphism --- ============ --- pure f <*> pure a = pure (f a) --- --- -- Definition of pure --- VarT (\_ -> pure (f, pure f)) <*> pure a --- --- -- Definition of pure --- VarT (\_ -> pure (f, pure f)) <*> VarT (\_ -> pure (a, pure a)) --- --- -- Definition of <*> --- VarT (\x -> do --- (f', vf') <- runVarT (VarT (\_ -> pure (f, pure f))) x --- (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x --- pure (f' a', vf' <*> va')) --- --- -- Newtype --- VarT (\x -> do --- (f', vf') <- (\_ -> pure (f, pure f)) x --- (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x --- pure (f' a', vf' <*> va')) --- --- -- Application --- VarT (\x -> do --- (f', vf') <- pure (f, pure f) --- (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x --- pure (f' a', vf' <*> va')) --- --- -- pure x >>= f = f x --- VarT (\x -> do --- (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x --- pure (f a', pure f <*> va')) --- --- -- Newtype --- VarT (\x -> do --- (a', va') <- (\_ -> pure (a, pure a)) x --- pure (f a', pure f <*> va')) --- --- -- Application --- VarT (\x -> do --- (a', va') <- pure (a, pure a) --- pure (f a', pure f <*> va')) --- --- -- pure x >>= f = f x --- VarT (\x -> pure (f a, pure f <*> pure a)) --- --- -- Coinduction --- VarT (\x -> pure (f a, pure (f a))) --- --- -- Definition of pure --- pure (f a) --- --- --- interchange --- =========== --- u <*> pure y = pure ($ y) <*> u --- --- -- Definition of <*> --- VarT (\x -> do --- (f, u') <- runVarT u x --- (a, y') <- runVarT (pure y) x --- pure (f a, u' <*> y')) --- --- -- Definition of pure --- VarT (\x -> do --- (f, u') <- runVarT u x --- (a, y') <- runVarT (VarT (\_ -> pure (y, pure y))) x --- pure (f a, u' <*> y')) --- --- -- Newtype --- VarT (\x -> do --- (f, u') <- runVarT u x --- (a, y') <- (\_ -> pure (y, pure y)) x --- pure (f a, u' <*> y')) --- --- -- Application --- VarT (\x -> do --- (f, u') <- runVarT u x --- (a, y') <- pure (y, pure y)) --- pure (f a, u' <*> y')) --- --- -- pure x >>= f = f --- VarT (\x -> do --- (f, u') <- runVarT u x --- pure (f y, u' <*> pure y)) --- --- -- Coinduction --- VarT (\x -> do --- (f, u') <- runVarT u x --- pure (f y, pure ($ y) <*> u')) --- --- -- Definition of $ --- VarT (\x -> do --- (f, u') <- runVarT u x --- pure (($ y) f, pure ($ y) <*> u') --- --- -- pure x >>= f = f --- VarT (\x -> do --- (g, y') <- pure (($ y), pure ($ y)) --- (f, u') <- runVarT u x --- pure (g f, y' <*> u') --- --- -- Abstraction --- VarT (\x -> do --- (g, y') <- (\_ -> pure (($ y), pure ($ y))) x --- (f, u') <- runVarT u x --- pure (g f, y' <*> u') --- --- -- Newtype --- VarT (\x -> do --- (g, y') <- runVarT (VarT (\_ -> pure (($ y), pure ($ y)))) x --- (f, u') <- runVarT u x --- pure (g f, y' <*> u') --- --- -- Definition of <*> --- VarT (\_ -> pure (($ y), pure ($ y))) <*> u --- --- -- Definition of pure --- pure ($ y) <*> u +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: Control.Varying.Core +-- Copyright: (c) 2015 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- Varying values represent values that change over a given domain. +-- +-- A 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 + , done + , var + , arr + , varM + , mkState + -- * Composing vars + -- $composition + , (<<<) + , (>>>) + -- * Adjusting and accumulating + , delay + , accumulate + -- * Sampling vars (running and other entry points) + -- $running + , scanVar + , stepMany + -- * Debugging and tracing vars in flight + , vtrace + , vstrace + , vftrace + , testVarOver + -- * Proofs of the Applicative laws + -- $proofs + ) where + +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, (.)) + +-------------------------------------------------------------------------------- +-- 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. +-- +-- @ +-- id = var id +-- f . g = g >>> f +-- @ +-- +-- or +-- +-- > 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 :: 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 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 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 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) + +-- | 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 + -> VarT m a b +mkState f s = VarT $ \a -> do + let (b', s') = f a s + return (b', mkState f s') +-------------------------------------------------------------------------------- +-- $composition +-- You can compose 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. +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- Adjusting and accumulating +-------------------------------------------------------------------------------- +-- | Accumulates input values using a folding function and yields +-- that accumulated value each sample. This is analogous to a stepwise foldl. +-- +-- >>> testVarOver (accumulate (++) []) $ words "hey there man" +-- "hey" +-- "heythere" +-- "heythereman" +-- +-- >>> print $ foldl (++) [] $ words "hey there man" +-- "heythereman" +accumulate :: Monad m => (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 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 = 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'') +-------------------------------------------------------------------------------- +-- $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 +-------------------------------------------------------------------------------- +-- | 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 + +-- | 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'') +-------------------------------------------------------------------------------- +-- Testing and debugging +-------------------------------------------------------------------------------- +-- | 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. +-- +-- >>> let v = id >>> vtrace +-- >>> testVarOver v [1,2,3] +-- 1 +-- 1 +-- 2 +-- 2 +-- 3 +-- 3 +vtrace :: (Applicative a, Show b) => VarT a b b +vtrace = vstrace "" + + +-- | Trace the sample value of a var with a prefix and pass the sample along +-- as output. This is very useful for debugging graphs of vars. +-- +-- >>> let v = id >>> vstrace "test: " +-- >>> testVarOver v [1,2,3] +-- test: 1 +-- 1 +-- test: 2 +-- 2 +-- test: 3 +-- 3 +vstrace :: (Applicative a, Show b) => String -> VarT a b b +vstrace s = vftrace ((s ++) . show) + +-- | Trace the sample value using a custom show-like function. This is useful +-- when you would like to debug a var that uses values that don't have show +-- instances. +-- +-- >>> newtype NotShowableInt = NotShowableInt { unNotShowableInt :: Int } +-- >>> let v = id >>> vftrace (("NotShowableInt: " ++) . show . unNotShowableInt) +-- >>> let as = map NotShowableInt [1,1,1] +-- >>> bs <- fst <$> scanVar v as +-- >>> -- We need to do something to evaluate these output values... +-- >>> print $ sum $ map unNotShowableInt bs +-- NotShowableInt: 1 +-- NotShowableInt: 1 +-- NotShowableInt: 1 +-- 3 +vftrace :: Applicative a => (b -> String) -> VarT a b b +vftrace f = var $ \b -> trace (f b) b + +-- | Run a 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 +-- +-- > -- Definition of pure +-- > VarT (\_ -> pure (id, pure id)) <*> v +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (f, vf') <- runVarT (VarT (\_ -> pure (id, pure id))) x +-- > (a, va') <- runVarT va x +-- > pure (f a, vf' <*> va')) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (f, vf') <- (\_ -> pure (id, pure id)) x +-- > (a, va') <- runVarT va x +-- > pure (f a, vf' <*> va')) +-- +-- > -- Application +-- > VarT (\x -> do +-- > (f, vf') <- pure (id, pure id) +-- > (a, va') <- runVarT va x +-- > pure (f a, vf' <*> va')) +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> do +-- > (a, va') <- runVarT va x +-- > pure (id a, pure id <*> va')) +-- +-- > -- Definition of id +-- > VarT (\x -> do +-- > (a, va') <- runVarT va x +-- > pure (a, pure id <*> va')) +-- +-- > -- Coinduction +-- > VarT (\x -> do +-- > (a, va') <- runVarT va x +-- > pure (a, va')) +-- +-- > -- f >>= pure = f +-- > VarT (\x -> runVarT va x) +-- +-- > -- Eta reduction +-- > VarT (runVarT va) +-- +-- > -- Newtype +-- > va +-- > +-- +-- ==Composition +-- > pure (.) <*> u <*> v <*> w = u <*> (v <*> w) +-- +-- > -- Definition of pure +-- > VarT (\_ -> pure ((.), pure (.))) <*> u <*> v <*> w +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (h, t) <- runVarT (VarT (\_ -> pure ((.), pure (.)))) x +-- > (f, u') <- runVarT u x +-- > pure (h f, t <*> u')) <*> v <*> w +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (h, t) <- (\_ -> pure ((.), pure (.))) x +-- > (f, u') <- runVarT u x +-- > pure (h f, t <*> u')) <*> v <*> w +-- +-- > -- Application +-- > VarT (\x -> do +-- > (h, t) <- pure ((.), pure (.))) +-- > (f, u') <- runVarT u x +-- > pure (h f, t <*> u')) <*> v <*> w +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > pure ((.) f, pure (.) <*> u')) <*> v <*> w +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (h, t) <- +-- > runVarT +-- > (VarT (\y -> do +-- > (f, u') <- runVarT u y +-- > pure ((.) f, pure (.) <*> u'))) x +-- > (g, v') <- runVarT v x +-- > pure (h g, t <*> v')) <*> w +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (h, t) <- +-- > (\y -> do +-- > (f, u') <- runVarT u y +-- > pure ((.) f, pure (.) <*> u')) x +-- > (g, v') <- runVarT v x +-- > pure (h g, t <*> v')) <*> w +-- +-- > -- Application +-- > VarT (\x -> do +-- > (h, t) <- do +-- > (f, u') <- runVarT u x +-- > pure ((.) f, pure (.) <*> u') +-- > (g, v') <- runVarT v x +-- > pure (h g, t <*> v')) <*> w +-- +-- > -- (f >=> g) >=> h = f >=> (g >=> h) +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (h, t) <- pure ((.) f, pure (.) <*> u') +-- > (g, v') <- runVarT v x +-- > pure (h g, t <*> v')) <*> w +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > pure ((.) f g, pure (.) <*> u' <*> v')) <*> w +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (h, t) <- +-- > runVarT +-- > (VarT (\y -> do +-- > (f, u') <- runVarT u y +-- > (g, v') <- runVarT v y +-- > pure ((.) f g, pure (.) <*> u' <*> v'))) x +-- > (a, w') <- runVarT w x +-- > pure (h a, t <*> w')) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (h, t) <- +-- > (\y -> do +-- > (f, u') <- runVarT u y +-- > (g, v') <- runVarT v y +-- > pure ((.) f g, pure (.) <*> u' <*> v')) x +-- > (a, w') <- runVarT w x +-- > pure (h a, t <*> w')) +-- +-- > -- Application +-- > VarT (\x -> do +-- > (h, t) <- do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > pure ((.) f g, pure (.) <*> u' <*> v')) +-- > (a, w') <- runVarT w x +-- > pure (h a, t <*> w')) +-- +-- > -- (f >=> g) >=> h = f >=> (g >=> h) +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > (h, t) <- pure ((.) f g, pure (.) <*> u' <*> v')) +-- > (a, w') <- runVarT w x +-- > pure (h a, t <*> w')) +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > (a, w') <- runVarT w x +-- > pure ((.) f g a, pure (.) <*> u' <*> v' <*> w')) +-- +-- > -- Definition of . +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > (a, w') <- runVarT w x +-- > pure (f (g a), pure (.) <*> u' <*> v' <*> w')) +-- +-- > -- Coinduction +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > (a, w') <- runVarT w x +-- > pure (f (g a), u' <*> (v' <*> w'))) +-- +-- > -- pure x >>= f = f +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (g, v') <- runVarT v x +-- > (a, w') <- runVarT w x +-- > (b, vw) <- pure (g a, v' <*> w') +-- > pure (f b, u' <*> vw)) +-- +-- > -- (f >=> g) >=> h = f >=> (g >=> h) +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (b, vw) <- do +-- > (g, v') <- runVarT v x +-- > (a, w') <- runVarT w x +-- > pure (g a, v' <*> w') +-- > pure (f b, u' <*> vw)) +-- +-- > -- Abstraction +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (b, vw) <- +-- > (\y -> do +-- > (g, v') <- runVarT v y +-- > (a, w') <- runVarT w y) +-- > pure (g a, v' <*> w')) x +-- > pure (f b, u' <*> vw)) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (b, vw) <- +-- > runVarT +-- > (VarT (\y -> do +-- > (g, v') <- runVarT v y +-- > (a, w') <- runVarT w y) +-- > pure (g a, v' <*> w')) x +-- > pure (f b, u' <*> vw)) +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (b, vw) <- runVarT (v <*> w) x +-- > pure (f b, u' <*> vw)) +-- +-- > -- Definition of <*> +-- > u <*> (v <*> w) +-- +-- +-- ==Homomorphism +-- > pure f <*> pure a = pure (f a) +-- +-- > -- Definition of pure +-- > VarT (\_ -> pure (f, pure f)) <*> pure a +-- +-- > -- Definition of pure +-- > VarT (\_ -> pure (f, pure f)) <*> VarT (\_ -> pure (a, pure a)) +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (f', vf') <- runVarT (VarT (\_ -> pure (f, pure f))) x +-- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x +-- > pure (f' a', vf' <*> va')) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (f', vf') <- (\_ -> pure (f, pure f)) x +-- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x +-- > pure (f' a', vf' <*> va')) +-- +-- > -- Application +-- > VarT (\x -> do +-- > (f', vf') <- pure (f, pure f) +-- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x +-- > pure (f' a', vf' <*> va')) +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> do +-- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x +-- > pure (f a', pure f <*> va')) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (a', va') <- (\_ -> pure (a, pure a)) x +-- > pure (f a', pure f <*> va')) +-- +-- > -- Application +-- > VarT (\x -> do +-- > (a', va') <- pure (a, pure a) +-- > pure (f a', pure f <*> va')) +-- +-- > -- pure x >>= f = f x +-- > VarT (\x -> pure (f a, pure f <*> pure a)) +-- +-- > -- Coinduction +-- > VarT (\x -> pure (f a, pure (f a))) +-- +-- > -- Definition of pure +-- > pure (f a) +-- +-- +-- ==Interchange +-- > u <*> pure y = pure ($ y) <*> u +-- +-- > -- Definition of <*> +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (a, y') <- runVarT (pure y) x +-- > pure (f a, u' <*> y')) +-- +-- > -- Definition of pure +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (a, y') <- runVarT (VarT (\_ -> pure (y, pure y))) x +-- > pure (f a, u' <*> y')) +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (a, y') <- (\_ -> pure (y, pure y)) x +-- > pure (f a, u' <*> y')) +-- +-- > -- Application +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > (a, y') <- pure (y, pure y)) +-- > pure (f a, u' <*> y')) +-- +-- > -- pure x >>= f = f +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > pure (f y, u' <*> pure y)) +-- +-- > -- Coinduction +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > pure (f y, pure ($ y) <*> u')) +-- +-- > -- Definition of $ +-- > VarT (\x -> do +-- > (f, u') <- runVarT u x +-- > pure (($ y) f, pure ($ y) <*> u') +-- +-- > -- pure x >>= f = f +-- > VarT (\x -> do +-- > (g, y') <- pure (($ y), pure ($ y)) +-- > (f, u') <- runVarT u x +-- > pure (g f, y' <*> u') +-- +-- > -- Abstraction +-- > VarT (\x -> do +-- > (g, y') <- (\_ -> pure (($ y), pure ($ y))) x +-- > (f, u') <- runVarT u x +-- > pure (g f, y' <*> u') +-- +-- > -- Newtype +-- > VarT (\x -> do +-- > (g, y') <- runVarT (VarT (\_ -> pure (($ y), pure ($ y)))) x +-- > (f, u') <- runVarT u x +-- > pure (g f, y' <*> u') +-- +-- > -- Definition of <*> +-- > VarT (\_ -> pure (($ y), pure ($ y))) <*> u +-- +-- > -- Definition of pure +-- > pure ($ y) <*> u diff --git a/src/Control/Varying/Event.hs b/src/Control/Varying/Event.hs --- a/src/Control/Varying/Event.hs +++ b/src/Control/Varying/Event.hs @@ -1,82 +1,73 @@ +{-# 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 domain. +-- An event stream is simply a stream of @Maybe a@. This kind of stream is +-- considered to be only defined at those occurances of @Just a@. Events +-- describe things that happen at a specific time, place or any collection of +-- inputs. +-- -- For example, you can think of the event stream -- @'VarT' 'IO' 'Double' ('Event' ())@ as an occurrence of @()@ at a specific --- input of type 'Double'. +-- value of 'Double'. It is possible that this 'Double' is time, or it could be +-- the number of ice cream sandwiches eaten by a particular cat. -- --- For sequencing streams please check out 'Control.Varying.Spline' which --- lets you chain together sequences of event streams using do-notation. -module Control.Varying.Event ( - Event(..), - -- * Transforming event values. - toMaybe, - isEvent, - -- * Combining event and value streams - orE, +-- In `varying` we use event streams to dynamically update the network while it +-- is running. For more info on switching and sequencing streams with events +-- please check out 'Control.Varying.Spline', which lets you chain together +-- sequences of values and events using a familiar do-notation. + +module Control.Varying.Event + ( -- * Event constructors (synonyms of Maybe) + Event + , event + , noevent -- * Generating events from value streams - use, - onTrue, - onJust, - onUnique, - onWhen, + , use + , onTrue + , onUnique + , onWhen -- * Folding and gathering event streams - foldStream, - startingWith, startWith, - -- * Using multiple streams - eitherE, - anyE, + , foldStream + , startingWith, startWith + -- * Combining multiple event streams + , bothE + , anyE -- * List-like operations on event streams - filterE, - takeE, - dropE, + , filterE + , takeE + , dropE -- * Primitive event streams - once, - always, - never, + , once + , always + , never + , before + , after -- * Switching - andThenWith, - switchByMode, + , switch -- * Bubbling - onlyWhen, - onlyWhenE, -) where + , onlyWhen + , onlyWhenE + ) where -import Prelude hiding (until) -import Control.Varying.Core -import Control.Applicative -import Control.Monad -import Data.Monoid -import Data.Foldable (foldl') --------------------------------------------------------------------------------- --- Transforming event values into usable values --------------------------------------------------------------------------------- --- | Turns an 'Event' into a 'Maybe'. -toMaybe :: Event a -> Maybe a -toMaybe (Event a) = Just a -toMaybe _ = Nothing +import Control.Applicative +import Control.Monad +import Control.Varying.Core +import Data.Foldable (foldl') +import Prelude hiding (until) --- | Returns 'True' when the 'Event' contains a sample and 'False' --- otherwise. -isEvent :: Event a -> Bool -isEvent (Event _) = True -isEvent _ = False --------------------------------------------------------------------------------- --- Combining value streams and events --------------------------------------------------------------------------------- --- | Produces values from the first unless the second produces event --- values and if so, produces the values of those events. -orE :: (Applicative m, Monad m) => VarT m a b -> VarT m a (Event b) -> VarT m a b -orE y ye = VarT $ \a -> do - (b, y') <- runVarT y a - (e, ye') <- runVarT ye a - return $ case e of - NoEvent -> (b, orE y' ye') - Event b' -> (b', orE y' ye') +type Event = Maybe + +-- | A synonym for the @Maybe@ constructor @Just@. +event :: a -> Event a +event = Just + +-- | A synonym for the @Maybe@ constructor @Nothing@. +noevent :: Event a +noevent = Nothing -------------------------------------------------------------------------------- -- Generating events from values -------------------------------------------------------------------------------- @@ -99,18 +90,8 @@ -- @ -- 'use' b 'onTrue' :: 'Monad' m => 'VarT' m 'Bool' ('Event' b) -- @ -onTrue :: (Applicative m, Monad m) => VarT m Bool (Event ()) -onTrue = var $ \b -> if b then Event () else NoEvent - --- | Triggers an @'Event' a@ when the input is @'Just' a@. --- --- @ --- 'use' b 'onJust' :: 'Monad' m => 'VarT' m ('Maybe' x) ('Event' b) --- @ -onJust :: (Applicative m, Monad m) => VarT m (Maybe a) (Event a) -onJust = var $ \ma -> case ma of - Nothing -> NoEvent - Just a -> Event a +onTrue :: Monad m => VarT m Bool (Event ()) +onTrue = var $ \b -> if b then Just () else Nothing -- | Triggers an @'Event' a@ when the input is distinct from the previous -- input. @@ -118,16 +99,16 @@ -- @ -- 'use' b 'onUnique' :: ('Eq' x, 'Monad' m) => 'VarT' m x ('Event' b) -- @ -onUnique :: (Applicative m, Monad m, Eq a) => VarT m a (Event a) -onUnique = VarT $ \a -> return (Event a, trigger a) +onUnique :: (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 NoEvent - else Event a'' + then Nothing + else Just a'' in return (e, trigger a'') -- | Triggers an @'Event' a@ when the condition is met. onWhen :: Applicative m => (a -> Bool) -> VarT m a (Event a) -onWhen f = var $ \a -> if f a then Event a else NoEvent +onWhen f = var $ \a -> if f a then Just a else Nothing -------------------------------------------------------------------------------- -- Collecting -------------------------------------------------------------------------------- @@ -135,10 +116,11 @@ foldStream :: Monad m => (a -> t -> a) -> a -> VarT m (Event t) a foldStream f acc = VarT $ \e -> case e of - Event a -> let acc' = f acc a - in return (acc', foldStream f acc') - NoEvent -> return (acc, foldStream f acc) + Just a -> let acc' = f acc a + in return (acc', foldStream f acc') + Nothing -> return (acc, foldStream f acc) + -- | Produces the given value until the input events produce a value, then -- produce that value until a new input event produces. This always holds -- the last produced value, starting with the given value. @@ -146,199 +128,167 @@ -- @ -- time '>>>' 'Control.Varying.Time.after' 3 '>>>' 'startingWith' 0 -- @ -startingWith, startWith :: (Applicative m, Monad m) => a -> VarT 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 = foldStream (\_ a -> a) -- | Stream through some number of successful 'Event's and then inhibit -- forever. -takeE :: (Applicative m, Monad m) +takeE :: Monad m => Int -> VarT m a (Event b) -> VarT m a (Event b) takeE 0 _ = never 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) +dropE :: Monad m => Int -> VarT m a (Event b) -> VarT m a (Event b) dropE 0 ve = ve dropE n ve = VarT $ \a -> do (eb, ve') <- runVarT ve a case eb of - NoEvent -> return (NoEvent, dropE n ve') - Event _ -> return (NoEvent, dropE (n-1) ve') + Nothing -> return (Nothing, dropE n ve') + Just _ -> return (Nothing, dropE (n-1) ve') -- | Inhibit all 'Event's that don't pass the predicate. -filterE :: (Applicative m, Monad m) +filterE :: Monad m => (b -> Bool) -> VarT m a (Event b) -> VarT m a (Event b) -filterE p v = v >>> var check - where check (Event b) = if p b then Event b else NoEvent - check _ = NoEvent +filterE p v = (join . (check <$>)) <$> v + where check b = if p b then Just b else Nothing -------------------------------------------------------------------------------- -- Using multiple streams -------------------------------------------------------------------------------- --- | If the left 'Event' stream produces a value, wrap the value in 'Left' and --- produce that value, else if the right 'Event' stream produces a value, --- wrap the value in 'Right' and produce that value, else inhibit. -eitherE :: (Applicative m, Monad m) - => VarT m a (Event b) -> VarT m a (Event c) - -> VarT m a (Event (Either b c)) -eitherE vb vc = f <$> vb <*> vc - where f (Event b) _ = Event $ Left b - f _ (Event c) = Event $ Right c - f _ _ = NoEvent +-- | Combine two 'Event' streams. Produces an event only when both streams proc +-- at the same time. +bothE :: Monad m + => (a -> b -> c) -> VarT m a (Event a) -> VarT m a (Event b) + -> VarT m a (Event c) +bothE f va vb = (\ea eb -> f <$> ea <*> eb) <$> va <*> vb -- | Combine two 'Event' streams and produce an 'Event' any time either stream -- produces. In the case that both streams produce, this produces the 'Event' --- of the left stream. -anyE :: (Applicative m, Monad m) => [VarT m a (Event b)] -> VarT m a (Event b) +-- 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 (NoEvent, []) outs) + return (anyE <$> foldl' f (Nothing, []) outs) -------------------------------------------------------------------------------- -- Primitive event streams -------------------------------------------------------------------------------- --- | Produce the given value once and then inhibit forever. -once :: (Applicative m, Monad m) => b -> VarT m a (Event b) -once b = VarT $ \_ -> return (Event b, never) +-- | 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) -- | Never produces any 'Event' values. -- -- @ --- 'never' = 'pure' 'NoEvent' +-- 'never' = 'pure' 'Nothing' -- @ -never :: (Applicative m, Monad m) => VarT m b (Event c) -never = pure NoEvent +never :: Monad m => VarT m b (Event c) +never = pure Nothing -- | Produces 'Event's with the initial value forever. -- -- @ -- 'always' e = 'pure' ('Event' e) -- @ -always :: (Applicative m, Monad m) => b -> VarT m a (Event b) -always = pure . Event +always :: Monad m => b -> VarT m a (Event b) +always = pure . Just +-- | 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) + +-- | 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) + -------------------------------------------------------------------------------- -- Switching -------------------------------------------------------------------------------- --- | Switches using a mode signal. Streams maintain state only for the duration --- of the mode. -switchByMode :: (Applicative m, Monad m, Eq b) - => VarT m a b -> (b -> VarT m a c) -> VarT m a c -switchByMode switch f = VarT $ \a -> do - (b, _) <- runVarT switch a - (_, v) <- runVarT (f b) a - runVarT (switchOnUnique v $ switch >>> onUnique) a - where switchOnUnique v sv = VarT $ \a -> do - (eb, sv') <- runVarT sv a - (c', v') <- runVarT (vOf eb) a - return (c', switchOnUnique v' sv') - where vOf eb = case eb of - NoEvent -> v - Event b -> f b +-- | 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) -andThenWith :: (Applicative m, Monad m) - => VarT m a (Event b) -> (Event b -> VarT m a (Event b)) -> VarT m a (Event b) -v `andThenWith` f = run v NoEvent - where run v1 eb = VarT $ \a -> do - (eb1, v2) <- runVarT v1 a - case eb1 of - NoEvent -> runVarT (f eb) a - _ -> return (eb1, run v2 eb1) -------------------------------------------------------------------------------- -- Bubbling -------------------------------------------------------------------------------- +-- | 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') + -- | Produce 'Event's of a value stream @v@ only when its input value passes a -- predicate @f@. -- @v@ maintains state while cold. -onlyWhen :: (Applicative m, Monad m) +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 - --- | Produce events of a value stream @v@ only when an event stream @h@ --- produces an event. --- @v@ and @h@ maintain state while cold. -onlyWhenE :: (Applicative m, Monad m) - => VarT m a b -- ^ @v@ - The value stream - -> VarT m a (Event c) -- ^ @h@ - The event stream - -> VarT m a (Event b) -onlyWhenE v hot = VarT $ \a -> do - (e, hot') <- runVarT hot a - if isEvent e - then do (b, v') <- runVarT v a - return (Event b, onlyWhenE v' hot') - else return (NoEvent, onlyWhenE v hot') --------------------------------------------------------------------------------- --- Event typeclass instances --------------------------------------------------------------------------------- -instance Show a => Show (Event a) where - show (Event a) = "Event " ++ show a - show NoEvent = "NoEvent" - -instance (Floating a) => Floating (Event a) where - pi = pure pi - exp = fmap exp - log = fmap log - sin = fmap sin; sinh = fmap sinh; asin = fmap asin; asinh = fmap asinh - cos = fmap cos; cosh = fmap cosh; acos = fmap acos; acosh = fmap acosh - atan = fmap atan; atanh = fmap atanh - -instance (Fractional a) => Fractional (Event a) where - (/) = liftA2 (/) - fromRational = pure . fromRational - -instance Num a => Num (Event a) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - abs = fmap abs - signum = fmap signum - fromInteger = pure . fromInteger - -instance MonadPlus Event where - mzero = mempty - mplus = (<|>) - -instance Monad Event where - return = Event - (Event a) >>= f = f a - _ >>= _ = NoEvent - -instance Alternative Event where - empty = NoEvent - (<|>) (Event e) _ = Event e - (<|>) NoEvent e = e - -instance Applicative Event where - pure = Event - (<*>) (Event f) (Event a) = Event $ f a - (<*>) _ _ = NoEvent - --- | Any event is a 'Monoid' that responds to 'mempty' with 'NoEvent'. It --- responds to 'mappend' by always choosing the rightmost event. This means --- left events are replaced unless the right event is 'NoEvent'. -instance Monoid (Event a) where - mempty = NoEvent - mappend a NoEvent = a - mappend _ b = b - -instance Functor Event where - fmap f (Event a) = Event $ f a - fmap _ NoEvent = NoEvent - --- | A value of @'Event' ()@ means that an event has occurred and that the --- result is a @()@. A value of 'NoEvent' means that an event did not --- occur. --- --- Event streams (like @'VarT' m a ('Event' b)@) describe events that may occur --- over varying @a@ (also known as the series of @a@). Usually @a@ would be --- some form of time or some user input type. -data Event a = Event a | NoEvent deriving (Eq) diff --git a/src/Control/Varying/Spline.hs b/src/Control/Varying/Spline.hs --- a/src/Control/Varying/Spline.hs +++ b/src/Control/Varying/Spline.hs @@ -1,80 +1,95 @@ -- | --- Module: Control.Varying.SplineT +-- Module: Control.Varying.Spline -- Copyright: (c) 2015 Schell Scivally -- License: MIT --- Maintainer: Schell Scivally --- --- Using splines we can easily create continuous value streams from --- multiple piecewise event streams. A spline is a monadic layer on top of --- event streams which are only continuous over a certain domain. The idea --- is that we use do notation to "run an event stream" from which we will --- consume produced values. Once the event stream inhibits the computation --- completes and returns a result value. That result value is then --- used to determine the next spline in the sequence. --- --- A spline can be converted back into a value stream using 'execSpline' or --- 'execSplineT'. This allows us to build long, complex, sequential behaviors --- using familiar notation. +-- Maintainer: Schell Scivally -- -{-# LANGUAGE GADTs #-} +-- Using splines we can easily create continuous streams from discontinuous +-- streams. A spline is a monadic layer on top of 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 #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -module Control.Varying.Spline ( - -- * Spline - Spline, +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +module Control.Varying.Spline + ( -- * Spline + Spline -- * Spline Transformer - SplineT(..), - -- * Running and streaming - scanSpline, - outputStream, + , SplineT(..) + -- * Creating streams from splines + , outputStream + -- * Creating splines from streams + , fromEvent + , untilProc + , whileProc + , untilEvent + , untilEvent_ + , _untilEvent + , _untilEvent_ + -- * Other runners + , scanSpline -- * Combinators - step, - fromEvent, - untilEvent, - untilEvent_, - _untilEvent, - _untilEvent_, - race, - raceMany, - merge, - capture, - mapOutput, - adjustInput, -) where + , step + , race + , raceAny + , merge + , capture + , mapOutput + , adjustInput + -- * Hand Proofs of the Monad laws + -- $proofs + ) where -import Control.Varying.Core -import Control.Varying.Event -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.IO.Class -import Control.Applicative -import Data.Functor.Identity -import Data.Function -import Data.Monoid +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 + -- | 'SplineT' shares all the types of 'VarT' and adds a result value. Its --- monad, input and output types (@m@, @a@ and @b@, respectively) reflect the --- underlying 'VarT`. A spline adds a result type which represents the monadic --- computation's result value. --- Much like the State monad it has an "internal state" and an eventual --- result value, where the internal state is the output value. The result --- value is used only in determining the next spline to sequence. ---newtype SplineT a b m c = SplineT { unSplineT :: VarT m a (Either b c) } -newtype SplineT a b m c = SplineT { runSplineT :: a -> m (Either c (b, SplineT a b m c)) } +-- monad, input and output types (@m@, @a@ and @b@, respectively) represent the +-- same parameters in 'VarT'. A spline adds a result type which represents the +-- monadic computation's result value. +-- +-- A spline either concludes in a result or it produces an output value and +-- another spline. This makes it a stream that eventually ends. We can use this +-- to set up our streams in a monadic fashion, where the end result of one spline +-- can be used to determine the next spline to run. Using 'outputStream' we can +-- then fuse these piecewise continuous (but otherwise discontinuous) streams +-- into one continuous stream of type @VarT m a b@. Alternatively you can simply +-- poll the network until it ends using 'runSplineT'. +newtype SplineT a b m c = + SplineT { runSplineT :: a -> m (Either c (b, SplineT a b m c)) } -- | A spline is a functor by applying the function to the result of the --- spline. -instance (Applicative m, Monad m) => Functor (SplineT a b m) where - fmap f (SplineT s) = SplineT $ \a -> s a >>= \case +-- 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 spline responds to bind by running until it concludes in a value, -- then uses that value to run the next spline. -instance (Applicative m, Monad m) => Monad (SplineT a b m) where +-- +-- 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 @@ -82,34 +97,70 @@ Left c -> runSplineT (f c) a Right (b, SplineT s1) -> return $ Right (b, SplineT $ g s1) --- A spline responds to 'pure' by returning a spline that never produces an + +-- | A spline responds to 'pure' by returning a spline that never produces an -- output value and immediately returns the argument. It responds to '<*>' by -- applying the left arguments result value (the function) to the right -- arguments result value (the argument), sequencing them both in serial. -instance (Applicative m, Monad m) => Applicative (SplineT a b m) where +-- +-- @ +-- pure = 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 - x <- sx - return $ f x + f <$> sx --- #if MIN_VERSION_base(4,8,0) --- | A spline is a transformer by using @effect@. + +-- | A spline is a transformer by running the effect and immediately concluding, +-- using the effect's result as the result value. +-- +-- >>> :{ +-- let s = do () <- lift $ print "Hello" +-- step 2 +-- v = outputStream s 0 +-- in testVarOver v [()] +-- >>> :} +-- "Hello" +-- 2 instance MonadTrans (SplineT a b) where - lift f = SplineT $ const $ f >>= return . Left + lift f = SplineT $ const $ Left <$> f -- | A spline can do IO if its underlying monad has a MonadIO instance. It -- takes the result of the IO action as its immediate return value. -instance (Applicative m, Monad m, MonadIO m) => MonadIO (SplineT a b m) where +instance (Monad m, MonadIO m) => MonadIO (SplineT a b m) where liftIO = lift . liftIO --- #endif --- + -- | A SplineT monad parameterized with Identity that takes input of type @a@, -- output of type @b@ and a result value of type @c@. type Spline a b c = SplineT a b Identity c --- | Evaluates a spline into a value stream of its output type. -outputStream :: (Applicative m, Monad m) +-- | 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 @@ -119,56 +170,75 @@ -- | Run the spline over the input values, gathering the output values in a -- list. -scanSpline :: (Applicative m, Monad m) +scanSpline :: Monad m => SplineT a b m c -> b -> [a] -> m [b] scanSpline s b = fmap fst <$> scanVar (outputStream s b) -- | Create a spline from an event stream. -fromEvent :: (Applicative m, Monad m) => VarT m a (Event b) -> SplineT a (Event b) m b +fromEvent :: Monad m => VarT m a (Event b) -> SplineT a (Event b) m b fromEvent ve = SplineT $ \a -> do (e, ve1) <- runVarT ve a return $ case e of - Event b -> Left b - NoEvent -> Right (NoEvent, fromEvent ve1) + Just b -> Left b + Nothing -> Right (Nothing, fromEvent ve1) --- | Create a spline from a value stream and an event stream. The spline --- uses the value stream as its output value. The spline will run until --- the event stream produces a value, at that point the last output --- value and the event value are tupled and returned as the spline's result --- value. -untilEvent :: (Applicative m, Monad m) - => VarT m a b -> VarT m a (Event c) - -> SplineT a b m (b,c) +-- | 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) + +-- | 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 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, NoEvent), vve1) -> Right (b, SplineT $ f vve1) - ((b, Event c), _) -> Left (b, c) + ((b, Nothing), vve1) -> Right (b, SplineT $ f vve1) + ((b, Just c), _) -> Left (b, c) --- | A variant of 'untilEvent' that only results in the left result, --- discarding the right result. -untilEvent_ :: (Applicative m, Monad m) - => VarT m a b -> VarT m a (Event c) - -> SplineT a b m b +-- | 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 --- | A variant of 'untilEvent' that only results in the right result, --- discarding the left result. -_untilEvent :: (Applicative m, Monad m) - => VarT m a b -> VarT m a (Event c) - -> SplineT a b m c +-- | 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 ----- | A variant of 'untilEvent' that discards both the right and left results. -_untilEvent_ :: (Applicative m, Monad m) - => VarT m a b -> VarT m a (Event c) - -> SplineT a b m () +-- | 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 -- | 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. -race :: (Applicative m, Monad m) +-- +-- >>> :{ +-- 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) @@ -178,10 +248,26 @@ Left e -> return $ Left $ Right e Right (b, sb1) -> return $ Right (f a b, SplineT $ g sa1 sb1) -raceMany :: (Applicative m, Monad m, Monoid b) +-- | Run many splines in parallel, combining their output with 'mappend'. +-- Returns the result of the spline that concludes first. If any conclude at the +-- same time the leftmost result will be returned. +-- +-- >>> :{ +-- let ss = [ pure "hey " `_untilEvent` (1 >>> after 5) +-- , pure "there" `_untilEvent` (1 >>> after 3) +-- , pure "!" `_untilEvent` (1 >>> after 2) +-- ] +-- s = do winner <- raceAny ss +-- step $ show winner +-- v = outputStream s "" +-- in testVarOver v [(),()] +-- >>> :} +-- "hey there!" +-- "2" +raceAny :: (Monad m, Monoid b) => [SplineT a b m c] -> SplineT a b m c -raceMany [] = pure mempty `_untilEvent` never -raceMany ss = SplineT $ f [] (map runSplineT ss) mempty +raceAny [] = pure mempty `_untilEvent` never +raceAny ss = SplineT $ f [] (map runSplineT ss) mempty where f ys [] b _ = return $ Right (b, SplineT $ f [] ys mempty) f ys (v:vs) b a = v a >>= \case Left c -> return $ Left c @@ -189,57 +275,245 @@ -- | Run two splines in parallel, combining their output. Once both splines -- have concluded, return the results of each in a tuple. -merge :: (Applicative m, Monad m) +-- +-- >>> :{ +-- 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 a = runSplineT vb a >>= \case - Left d -> r c d + fr c vb = runSplineT vb >=> \case + Left d -> r c d Right (b, vb1) -> return $ Right (b, SplineT $ fr c vb1) - fl d va a = runSplineT va a >>= \case - Left c -> r c d + fl d va = runSplineT va >=> \case + Left c -> r c d Right (b, va1) -> return $ Right (b, SplineT $ fl d va1) f va vb a = runSplineT va a >>= \case Left c -> fr c vb a Right (b1, va1) -> runSplineT vb a >>= \case Left d -> return $ Right (b1, SplineT $ fl d va1) - Right (b2, vb1) -> return $ Right $ (apnd b1 b2, SplineT $ f va1 vb1) + Right (b2, vb1) -> return $ Right (apnd b1 b2, SplineT $ f va1 vb1) -- | Capture the spline's last output value and tuple it with the -- spline's result. This is helpful when you want to sample the last -- output value in order to determine the next spline to sequence. -capture :: (Applicative m, Monad m) - => SplineT a b m c -> SplineT a b m (Maybe b, c) +-- +-- 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 a = runSplineT s a >>= \case - Left c -> return $ Left (mb, c) - Right (b, s1) -> return $ Right (b, SplineT $ f (Just b) s1) + where f mb s = runSplineT s >=> return . \case + Left c -> Left (mb, c) + Right (b, s1) -> Right (b, SplineT $ f (Just b) s1) -- | Produce the argument as an output value exactly once. -step :: (Applicative m, Monad m) => b -> SplineT a b m () +-- +-- >>> :{ +-- 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. -mapOutput :: (Applicative m, Monad m) +-- +-- >>> :{ +-- 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 - runSplineT s a >>= \case - Left c -> return $ Left c - Right (b, s1) -> return $ Right (f b, SplineT $ g vf1 s1) + flip fmap (runSplineT s a) $ \case + Left c -> Left c + Right (b, s1) -> Right (f b, SplineT $ g vf1 s1) -- | Map the input value of a spline. -adjustInput :: (Applicative m, Monad m) +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 + where g vf sx a = do (f, vf1) <- runVarT vf a - runSplineT sx (f a) >>= \case - Left c -> return $ Left c - Right (b, sx1) -> return $ Right (b, SplineT $ g vf1 sx1) + flip fmap (runSplineT sx (f a)) $ \case + Left c -> Left c + Right (b, sx1) -> Right (b, SplineT $ g vf1 sx1) + +-------------------------------------------------------------------------------- +-- $proofs +-- ==Left Identity +-- > k =<< return c = k c +-- +-- > -- Definition of =<< +-- > fix (\f s -> +-- > SplineT (\a -> +-- > runSplineT s a >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap f s')))) (return c) +-- +-- > -- Definition of fix +-- > (\s -> +-- > SplineT (\a -> +-- > runSplineT s a >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s')))) (return c) +-- +-- > -- Application +-- > SplineT (\a -> +-- > runSplineT (return c) a >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s'))) +-- +-- > -- Definition of return +-- > SplineT (\a -> +-- > runSplineT (SplineT (\_ -> return (Left c))) a >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s'))) +-- +-- > -- Newtype +-- > SplineT (\a -> +-- > (\_ -> return (Left c)) a >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s'))) +-- +-- > -- Application +-- > SplineT (\a -> +-- > return (Left c) >>= \case +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s'))) +-- +-- > -- return x >>= f = f x +-- > SplineT (\a -> +-- > case (Left c) of +-- > Left c -> runSplineT (k c) a +-- > Right s' -> return (Right (fmap (k =<<) s'))) +-- +-- > -- Case evaluation +-- > SplineT (\a -> runSplineT (k c) a) +-- +-- > -- Eta reduction +-- > SplineT (runSplineT (k c)) +-- +-- > -- Newtype +-- > k c +-- +-- ==Right Identity +-- > return =<< m = m +-- +-- > -- Definition of =<< +-- > fix (\f s -> +-- > SplineT (\a -> +-- > runSplineT s a >>= \case +-- > Left c -> runSplineT (return c) a +-- > Right s' -> return (Right (fmap f s')))) m +-- +-- > -- Definition of fix +-- > (\s -> +-- > SplineT (\a -> +-- > runSplineT s a >>= \case +-- > Left c -> runSplineT (return c) a +-- > Right s' -> return (Right (fmap (return =<<) s')))) m +-- +-- > -- Application +-- > SplineT (\a -> +-- > runSplineT m a >>= \case +-- > Left c -> runSplineT (return c) a +-- > Right s' -> return (Right (fmap (return =<<) s'))) +-- +-- > -- Definition of return +-- > SplineT (\a -> +-- > runSplineT m a >>= \case +-- > Left c -> runSplineT (SplineT (\_ -> return (Left c))) a +-- > Right s' -> return (Right (fmap (return =<<) s'))) +-- +-- > -- Newtype +-- > SplineT (\a -> +-- > runSplineT m a >>= \case +-- > Left c -> (\_ -> return (Left c)) a +-- > Right s' -> return (Right (fmap (return =<<) s'))) +-- +-- > -- Application +-- > SplineT (\a -> +-- > runSplineT m a >>= \case +-- > Left c -> return (Left c) +-- > Right s' -> return (Right (fmap (return =<<) s'))) +-- +-- > -- m >>= return . f = fmap f m +-- > SplineT (\a -> fmap (either id (fmap (return =<<))) (runSplineT m a)) +-- +-- > -- Coinduction +-- > SplineT (\a -> fmap (either id (fmap id)) (runSplineT m a)) +-- +-- > -- fmap id = id +-- > SplineT (\a -> fmap (either id id) (runSplineT m a)) +-- +-- > -- either id id = id +-- > SplineT (\a -> fmap id (runSplineT m a)) +-- +-- > -- fmap id = id +-- > SplineT (\a -> runSplineT m a) +-- +-- > -- Eta reduction +-- > SplineT (runSplineT m) +-- +-- > -- Newtype +-- > m +-- +-- ==Application +-- > (m >>= f) >>= g = m >>= (\x -> f x >>= g) + +-- TODO: 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,23 +0,0 @@ --- | Module: Control.Varying.Time --- Copyright: (c) 2015 Schell Scivally --- License: MIT --- Maintainer: Schell Scivally -module Control.Varying.Time where - -import Control.Varying.Core -import Control.Varying.Event -import Control.Applicative --------------------------------------------------------------------------------- --- Using timed events --------------------------------------------------------------------------------- --- | Emits events before accumulating t of input dt. --- Note that as soon as we have accumulated >= t we stop emitting events --- and therefore an event will be never be emitted exactly at time == t. -before :: (Applicative m, Monad m, Num t, Ord t) => t -> VarT m t (Event t) -before t = accumulate (+) 0 ~> onWhen (< t) - --- | Emits events after t input has been accumulated. --- Note that event emission is not guaranteed to begin exactly at t, --- since it depends on the input. -after :: (Applicative m, Monad m, Num t, Ord t) => t -> VarT m t (Event t) -after t = accumulate (+) 0 ~> onWhen (>= t) diff --git a/src/Control/Varying/Tween.hs b/src/Control/Varying/Tween.hs --- a/src/Control/Varying/Tween.hs +++ b/src/Control/Varying/Tween.hs @@ -1,8 +1,8 @@ -- | -- Module: Control.Varying.Tween --- Copyright: (c) 2015 Schell Scivally +-- Copyright: (c) 2016 Schell Scivally -- License: MIT --- Maintainer: Schell Scivally +-- Maintainer: Schell Scivally -- -- Tweening is a technique of generating intermediate samples of a type -- __between__ a start and end value. By sampling a running tween @@ -13,19 +13,15 @@ -- 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 Rank2Types #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} module Control.Varying.Tween ( -- * Tweening types Easing , TweenT , Tween - -- * Running tweens - , runTweenT - , scanTween - , tweenStream -- * Creating tweens -- $creation , tween @@ -33,6 +29,8 @@ , constant , withTween , withTween_ + -- * Combining tweens + -- $combining -- * Interpolation functions -- $lerping , linear @@ -49,50 +47,72 @@ , easeOutCubic , easeInQuad , easeOutQuad - -- * Writing your own tweens - -- $writing + -- * Running tweens + , tweenStream + , runTweenT + , scanTween ) where -import Control.Varying.Core -import Control.Varying.Event -import Control.Varying.Spline -import Control.Varying.Time -import Control.Arrow -import Control.Applicative -import Control.Monad.Trans.State -import Control.Monad.Trans.Class -import Data.Functor.Identity +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, Fractional t, Real f) => Easing t f -easeInQuad c t b = c * (realToFrac $ 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, Fractional t, Real f) => Easing t f -easeOutQuad c t b = (-c) * (realToFrac $ t * (t - 2)) + b +easeOutQuad :: (Fractional t, Real f) => Easing t f +easeOutQuad c t b = (-c) * realToFrac (t * (t - 2)) + b -- | Ease in cubic. -easeInCubic :: (Num t, Fractional t, Real f) => Easing t f -easeInCubic c t b = c * (realToFrac $ t*t*t) + b +easeInCubic :: (Fractional t, Real f) => Easing t f +easeInCubic c t b = c * realToFrac (t*t*t) + b -- | Ease out cubic. -easeOutCubic :: (Num t, Fractional t, Real f) => Easing t f +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, Fractional t, Real f) => Int -> Easing t f +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, Fractional t, Real f) => Int -> Easing t f +easeOutPow :: (Fractional t, Real f) => Int -> Easing t f easeOutPow power c t b = let t' = realToFrac t - 1 c' = if power `mod` 2 == 1 then c else -c @@ -133,28 +153,123 @@ -- | Ease linear. linear :: (Floating t, Real f) => Easing t f -linear c t b = c * (realToFrac t) + b +linear c t b = c * realToFrac t + b -type TweenT f t m = SplineT f t (StateT f m) -type Tween f t = TweenT f t Identity +-- | 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) -runTweenT :: (Monad m, Num f) - => TweenT f t m x -> f -> f -> m (Either x ((t, TweenT f t m x)), f) -runTweenT s dt = runStateT (runSplineT s dt) -scanTween :: (Functor m, Applicative m, Monad m, Num f) - => TweenT f t m a -> t -> [f] -> m [t] -scanTween s t dts = evalStateT (scanSpline s t dts) 0 +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 `outputStream`. -tweenStream :: (Applicative m, Monad m, Num f) - => TweenT f t m x -> t -> VarT m f t -tweenStream s0 t0 = VarT $ f s0 t0 0 - where f s t l i = do (e, l1) <- runTweenT s i l - case e of - Left _ -> return (t, done t) - Right (b, s1) -> return (b, VarT $ f s1 b l1) +-- 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' @@ -166,36 +281,34 @@ -- | Creates a spline that produces a value interpolated between a start and -- end value using an easing equation ('Easing') over a duration. The --- resulting spline will take a time delta as input. For example: --- --- @ --- testWhile_ isEvent (deltaUTC >>> v) --- where v :: VarT IO a (Event Double) --- v = flip outputStream 0 $ tween easeOutExpo 0 100 5 --- @ --- --- Keep in mind `tween` must be fed time deltas, not absolute time or +-- 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` concludes returning the latest output value. -tween :: (Applicative m, Monad m, Real f, Fractional f, Real t, Fractional t) +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 = SplineT g - where c = end - start - b = start - g dt = do - leftover <- get - let t = dt + leftover +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)) - if t == dur - then do put 0 - return $ Right (end, return end) - else if t > dur - then do put $ t - dur - dt - return $ Left end - else do put t - return $ Right (f c (t/dur) b, SplineT g) -- | A version of 'tween' that discards the result. It is simply -- @@ -203,46 +316,32 @@ -- tween f a b c >> return () -- @ -- -tween_ :: (Applicative m, Monad m, Real t, Fractional t, Real f, Fractional f) +tween_ :: (Monad m, Real t, Real f, Fractional f) => Easing t f -> t -> t -> f -> TweenT f t m () -tween_ f a b c = tween f a b c >> return () +tween_ f a b c = Control.Monad.void (tween f a b c) -- | A version of 'tween' that maps its output using the given constant -- function. +-- -- @ -- withTween ease from to dur f = mapOutput (pure f) $ tween ease from to dur -- @ -withTween :: (Applicative m, Monad m, Real t, Fractional t, Real a, Fractional a) +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 = mapOutput (pure f) $ tween ease from to dur +withTween ease from to dur f = + TweenT + $ mapOutput (pure f) + $ unTweenT + $ tween ease from to dur --- | A version of 'withTween' that discards its output. -withTween_ :: (Applicative m, Monad m, Real t, Fractional t, Real a, Fractional a) +-- | 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 = withTween ease from to dur f >> return () +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 :: (Applicative m, Monad m, Num t, Ord t) +constant :: (Monad m, Num t, Ord t) => a -> t -> TweenT t a m a -constant value duration = pure value `untilEvent_` after duration - --------------------------------------------------------------------------------- --- $writing --- To create your own tweens just write a function that takes a start --- value, end value and a duration and return an event stream. --- --- @ --- tweenInOutExpo start end dur = do --- (dt, x) <- tween easeInExpo start end (dur/2) --- tween easeOutExpo x end $ dt + dur/2 --- @ --------------------------------------------------------------------------------- --- | An easing function. The parameters 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 much match the tween's value type. This may change in the --- future :) -type Easing t f = t -> f -> t -> t +constant value duration = + TweenT + $ pure value `untilEvent_` after duration 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 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,39 +1,39 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Main where + import Test.Hspec hiding (after, before) -import Control.Applicative import Control.Varying -import Control.Monad.Trans.Class import Control.Monad.IO.Class -import Control.Monad.Trans.State -import Control.Monad (when) import Data.Functor.Identity import Data.Time.Clock main :: IO () main = hspec $ do - describe "before" $ do + describe "before" $ it "should produce events before a given step" $ do - let varEv :: Var () (Event Int) - varEv = 1 ~> before 3 + let varEv :: Var () (Maybe Int) + varEv = 1 >>> before 3 scans = fst $ runIdentity $ scanVar varEv $ replicate 4 () - scans `shouldBe` [Event 1, Event 2, NoEvent, NoEvent] + scans `shouldBe` [Just 1, Just 2, Nothing, Nothing] - describe "after" $ do + describe "after" $ it "should produce events after a given step" $ do - let varEv :: Var () (Event Int) - varEv = 1 ~> after 3 + let varEv :: Var () (Maybe Int) + varEv = 1 >>> after 3 scans = fst $ runIdentity $ scanVar varEv $ replicate 4 () - scans `shouldBe` [NoEvent, NoEvent, Event 3, Event 4] - describe "anyE" $ do + scans `shouldBe` [Nothing, Nothing, Just 3, Just 4] + + describe "anyE" $ it "should produce on any event" $ do - let v1,v2,v3 :: Var () (Event Int) - v1 = use 1 ((1 :: Var () Int) ~> before 2) - v2 = use 2 ((1 :: Var () Int) ~> after 3) + let v1,v2,v3 :: Var () (Maybe Int) + v1 = use 1 ((1 :: Var () Int) >>> before 2) + v2 = use 2 ((1 :: Var () Int) >>> after 3) v3 = always 3 v = anyE [v1,v2,v3] scans = fst $ runIdentity $ scanVar v $ replicate 4 () - scans `shouldBe` [Event 1, Event 3, Event 2, Event 2] + scans `shouldBe` [Just 1, Just 3, Just 2, Just 2] describe "tween/tweenWith" $ do it "should step by the dt passed in" $ do let mytween :: Tween Double Double () @@ -49,7 +49,7 @@ describe "untilEvent" $ do let Identity scans = scanSpline (3 `untilEvent` ((1 :: Var () Int) - ~> after 10)) + >>> after 10)) 0 (replicate 10 ()) it "should produce output from the value stream until event procs" $ @@ -66,18 +66,18 @@ it "should produce output exactly one time per call" $ concat scans `shouldBe` "hey, there..." - describe "fromEvent" $ do + describe "untilProc" $ do let s = do - str <- fromEvent (var f ~> onJust) - step $ Event str - step $ Event "done" + 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 NoEvent [0,0,0,1,0] - it "should produce NoEvent until it procs" $ - scans `shouldBe` [NoEvent,NoEvent,NoEvent,Event "YES",Event "done"] + Identity scans = scanSpline s Nothing [0,0,0,1,0] + it "should produce Nothing until it procs" $ + scans `shouldBe` [Nothing,Nothing,Nothing,Just "YES",Just "done"] describe "lift/liftIO" $ do let s :: SplineT () String IO () @@ -108,8 +108,9 @@ it "should step twice and left should win" $ unwords scans `shouldBe` "start s10:s20 s11:s21 right won with True" - describe "raceMany" $ do - let s1 = do step "t" + describe "raceAny" $ do + let s1 :: Spline () String Int + s1 = do step "t" step "c" return 0 s2 = do step "h" @@ -118,7 +119,8 @@ s3 = do step "e" step "t" return (2 :: Int) - s = do x <- raceMany [s1,s2,s3] + 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" @@ -127,7 +129,7 @@ let r :: Spline () String () r = do x <- capture $ do step "a" step "b" - return 2 + return (2 :: Int) case x of (Just "b", 2) -> step "True" _ -> step "False" @@ -160,9 +162,9 @@ -- Adherance to typeclass laws -------------------------------------------------------------------------------- -- Spline helpers - let inc = 1 ~> accumulate (+) 0 + let inc = 1 >>> accumulate (+) 0 sinc :: Spline a Int (Int, Int) - sinc = inc `untilEvent` (1 ~> after 3) + sinc = inc `untilEvent` (1 >>> after 3) go a = runIdentity (scanSpline a 0 [0..9]) equal a b = go a `shouldBe` go b @@ -182,8 +184,8 @@ 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]) + 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 @@ -193,13 +195,13 @@ 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)) + 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)) + 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)" $ diff --git a/varying.cabal b/varying.cabal --- a/varying.cabal +++ b/varying.cabal @@ -1,144 +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.6.0.0 - --- A short (one-line) description of the package. -synopsis: FRP through value streams and monadic splines. - --- A longer description of the package. -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. - --- 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.6 && <5.0 - , transformers >=0.3 - - -- 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 -threaded -rtsopts -with-rtsopts=-N - - -- Other library packages from which modules are imported. - build-depends: base >=4.6 && <5.0 - , transformers >=0.3 - , time >=1.4 - , varying - - - -- Directories containing source files. - hs-source-dirs: app - - main-is: Main.hs - - -- Base language which the package is written in. - default-language: Haskell2010 - -test-suite varying-test - type: exitcode-stdio-1.0 - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - - -- Other library packages from which modules are imported. - build-depends: base >=4.6 && <5.0 - , time >=1.4 - , transformers - , varying - , hspec - , QuickCheck - - - -- Directories containing source files. - hs-source-dirs: test + 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 - main-is: Main.hs +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 - -- Base language which the package is written in. - default-language: Haskell2010 +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 benchmark varying-bench - type: exitcode-stdio-1.0 - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - - -- Other library packages from which modules are imported. - build-depends: base >=4.6 - , time >=1.4 - , transformers - , varying - , criterion - - - -- Directories containing source files. - hs-source-dirs: bench - - main-is: Main.hs - - -- Base language which the package is written in. - default-language: Haskell2010 + 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