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