active (empty) → 0.1.0.0
raw patch · 6 files changed
+887/−0 lines, 6 filesdep +QuickCheckdep +arraydep +basesetup-changed
Dependencies added: QuickCheck, array, base, newtype, semigroupoids, semigroups, vector-space
Files
- CHANGES +3/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- active.cabal +40/−0
- src/Data/Active.hs +657/−0
- test/active-tests.hs +155/−0
+ CHANGES view
@@ -0,0 +1,3 @@+0.1.0.0: 9 March 2012++ Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2011-2012, Brent Yorgey++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Brent Yorgey nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ active.cabal view
@@ -0,0 +1,40 @@+name: active+version: 0.1.0.0+synopsis: Abstractions for animation+description: "Active" abstraction for animated things with finite start and end times.+license: BSD3+license-file: LICENSE+author: Brent Yorgey+maintainer: byorgey@cis.upenn.edu+copyright: (c) 2011 Brent Yorgey+category: Data+build-type: Simple+cabal-version: >=1.8+extra-source-files: CHANGES+tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1+source-repository head+ type: darcs+ location: http://patch-tag.com/r/byorgey/active++library+ exposed-modules: Data.Active+ build-depends: base >= 4.0 && < 4.6,+ array >= 0.3 && < 0.5,+ semigroups >= 0.1 && < 0.9,+ semigroupoids >= 1.2 && < 1.3,+ vector-space >= 0.8 && < 0.9,+ newtype >= 0.2 && < 0.3+ hs-source-dirs: src++test-suite active-tests+ type: exitcode-stdio-1.0+ main-is: active-tests.hs+ build-depends: base >= 4.0 && < 4.6,+ array >= 0.3 && < 0.5,+ semigroups >= 0.1 && < 0.9,+ semigroupoids >= 1.2 && < 1.3,+ vector-space >= 0.8 && < 0.9,+ newtype >= 0.2 && < 0.3,++ QuickCheck >= 2.4.2 && < 2.5+ hs-source-dirs: src, test
+ src/Data/Active.hs view
@@ -0,0 +1,657 @@+{-# LANGUAGE DeriveFunctor+ , GeneralizedNewtypeDeriving+ , TypeSynonymInstances+ , MultiParamTypeClasses+ , TypeFamilies+ , FlexibleInstances+ #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Active+-- Copyright : (c) 2011 Brent Yorgey+-- License : BSD-style (see LICENSE)+-- Maintainer : byorgey@cis.upenn.edu+--+-- Inspired by the work of Kevin Matlage and Andy Gill (/Every/+-- /Animation Should Have a Beginning, a Middle, and an End/, Trends+-- in Functional Programming,+-- 2010. <http://ittc.ku.edu/csdl/fpg/node/46>), this module defines a+-- simple abstraction for working with time-varying values. A value+-- of type @Active a@ is either a constant value of type @a@, or a+-- time-varying value of type @a@ (/i.e./ a function from time to+-- @a@) with specific start and end times. Since active values+-- have start and end times, they can be aligned, sequenced,+-- stretched, or reversed.+--+-- In a sense, this is sort of like a stripped-down version of+-- functional reactive programming (FRP), without the reactivity.+--+-- The original motivating use for this library is to support making+-- animations with the diagrams framework+-- (<http://projects.haskell.org/diagrams>), but the hope is that it+-- may find more general utility.+--+-- There are two basic ways to create an @Active@ value. The first is+-- to use 'mkActive' to create one directly, by specifying a start and+-- end time and a function of time. More indirectly, one can use the+-- 'Applicative' instance together with the unit interval 'ui', which+-- takes on values from the unit interval from time 0 to time 1, or+-- 'interval', which creates an active over an arbitrary interval.+--+-- For example, to create a value of type @Active Double@ which+-- represents one period of a sine wave starting at time 0 and ending+-- at time 1, we could write+--+-- > mkActive 0 1 (\t -> sin (fromTime t * tau))+--+-- or+--+-- > (sin . (*tau)) <$> ui+--+-- 'pure' can also be used to create @Active@ values which are+-- constant and have no start or end time. For example,+--+-- > mod <$> (floor <$> interval 0 100) <*> pure 7+--+-- cycles repeatedly through the numbers 0-6.+--+-- Note that the \"idiom bracket\" notation supported by the SHE+-- preprocessor (<http://personal.cis.strath.ac.uk/~conor/pub/she/>,+-- <http://hackage.haskell.org/package/she>) can make for somewhat+-- more readable 'Applicative' code. For example, the above example+-- can be rewritten using SHE as+--+-- > {-# OPTIONS_GHC -F -pgmF she #-}+-- >+-- > ... (| mod (| floor (interval 0 100) |) ~7 |)+--+-- There are many functions for transforming and composing active+-- values; see the documentation below for more details.+--+-----------------------------------------------------------------------------++module Data.Active+ ( -- * Representing time++ -- ** Time and duration++ Time, toTime, fromTime+ , Duration, toDuration, fromDuration++ -- ** Eras++ , Era, mkEra+ , start, end, duration++ -- * Dynamic values+ , Dynamic(..), mkDynamic, onDynamic++ , shiftDynamic++ -- * Active values+ -- $active+ , Active, mkActive, fromDynamic, isConstant, isDynamic++ , onActive, modActive, runActive++ , activeEra, setEra, atTime++ , activeStart, activeEnd++ -- * Combinators++ -- ** Special active values++ , ui, interval++ -- ** Transforming active values++ , stretch, stretchTo, during+ , shift, backwards++ , snapshot++ -- ** Working with values outside the era+ , clamp, clampBefore, clampAfter+ , trim, trimBefore, trimAfter++ -- ** Composing active values++ , after++ , (->>)++ , (|>>), movie++ -- * Discretization++ , discrete+ , simulate++ ) where++import Control.Applicative+import Control.Arrow ((&&&))+import Control.Newtype++import Data.Array+import Data.Maybe++import Data.Functor.Apply+import Data.Semigroup hiding (First(..))+import Data.Monoid (First(..))++import Data.VectorSpace hiding ((<.>))+import Data.AffineSpace++------------------------------------------------------------+-- Time+------------------------------------------------------------++-- | An abstract type for representing /points in time/. Note that+-- literal numeric values may be used as @Time@s, thanks to the the+-- 'Num' and 'Fractional' instances. 'toTime' and 'fromTime' are+-- also provided for convenience in converting between @Time@ and+-- other numeric types.+newtype Time = Time { unTime :: Rational }+ deriving ( Eq, Ord, Show, Read, Enum, Num, Fractional, Real, RealFrac+ , AdditiveGroup, InnerSpace+ )++instance Newtype Time Rational where+ pack = Time+ unpack = unTime++instance VectorSpace Time where+ type Scalar Time = Rational+ s *^ (Time t) = Time (s * t)++-- | Convert any value of a 'Real' type (including @Int@, @Integer@,+-- @Rational@, @Float@, and @Double@) to a 'Time'.+toTime :: Real a => a -> Time+toTime = fromRational . toRational++-- | Convert a 'Time' to a value of any 'Fractional' type (such as+-- @Rational@, @Float@, or @Double@).+fromTime :: Fractional a => Time -> a+fromTime = fromRational . unTime++-- | An abstract type representing /elapsed time/ between two points+-- in time. Note that durations can be negative. Literal numeric+-- values may be used as @Duration@s thanks to the 'Num' and+-- 'Fractional' instances. 'toDuration' and 'fromDuration' are also+-- provided for convenience in converting between @Duration@s and+-- other numeric types.+newtype Duration = Duration { unDuration :: Rational }+ deriving ( Eq, Ord, Show, Read, Enum, Num, Fractional, Real, RealFrac+ , AdditiveGroup)++instance Newtype Duration Rational where+ pack = Duration+ unpack = unDuration++instance VectorSpace Duration where+ type Scalar Duration = Rational+ s *^ (Duration d) = Duration (s * d)++instance AffineSpace Time where+ type Diff Time = Duration+ (Time t1) .-. (Time t2) = Duration (t1 - t2)+ (Time t) .+^ (Duration d) = Time (t + d)++-- | Convert any value of a 'Real' type (including @Int@, @Integer@,+-- @Rational@, @Float@, and @Double@) to a 'Duration'.+toDuration :: Real a => a -> Duration+toDuration = fromRational . toRational++-- | Convert a 'Duration' to any other 'Fractional' type (such as+-- @Rational@, @Float@, or @Double@).+fromDuration :: Fractional a => Duration -> a+fromDuration = fromRational . unDuration++-- | An @Era@ is a concrete span of time, that is, a pair of times+-- representing the start and end of the era. @Era@s form a+-- semigroup: the combination of two @Era@s is the smallest @Era@+-- which contains both. They do not form a 'Monoid', since there is+-- no @Era@ which acts as the identity with respect to this+-- combining operation.+--+-- @Era@ is abstract. To construct @Era@ values, use 'mkEra'; to+-- deconstruct, use 'start' and 'end'.+newtype Era = Era (Min Time, Max Time)+ deriving (Semigroup, Show)++-- | Create an 'Era' by specifying start and end 'Time's.+mkEra :: Time -> Time -> Era+mkEra s e = Era (Min s, Max e)++-- | Get the start 'Time' of an 'Era'.+start :: Era -> Time+start (Era (Min t, _)) = t++-- | Get the end 'Time' of an 'Era'.+end :: Era -> Time+end (Era (_, Max t)) = t++-- | Compute the 'Duration' of an 'Era'.+duration :: Era -> Duration+duration = (.-.) <$> end <*> start++------------------------------------------------------------+-- Dynamic+------------------------------------------------------------++-- | A @Dynamic a@ can be thought of as an @a@ value that changes over+-- the course of a particular 'Era'. It's envisioned that @Dynamic@+-- will be mostly an internal implementation detail and that+-- 'Active' will be most commonly used. But you never know what+-- uses people might find for things.+data Dynamic a = Dynamic { era :: Era+ , runDynamic :: Time -> a+ }+ deriving (Functor)++-- | 'Dynamic' is an instance of 'Apply' (/i.e./ 'Applicative' without+-- 'pure'): a time-varying function is applied to a time-varying+-- value pointwise; the era of the result is the combination of the+-- function and value eras. Note, however, that 'Dynamic' is /not/+-- an instance of 'Applicative' since there is no way to implement+-- 'pure': the era would have to be empty, but there is no such+-- thing as an empty era (that is, 'Era' is not an instance of+-- 'Monoid').+instance Apply Dynamic where+ (Dynamic d1 f1) <.> (Dynamic d2 f2) = Dynamic (d1 <> d2) (f1 <.> f2)++-- | @'Dynamic' a@ is a 'Semigroup' whenever @a@ is: the eras are+-- combined according to their semigroup structure, and the values+-- of type @a@ are combined pointwise. Note that @'Dynamic' a@ cannot+-- be an instance of 'Monoid' since 'Era' is not.+instance Semigroup a => Semigroup (Dynamic a) where+ Dynamic d1 f1 <> Dynamic d2 f2 = Dynamic (d1 <> d2) (f1 <> f2)++-- | Create a 'Dynamic' from a start time, an end time, and a+-- time-varying value.+mkDynamic :: Time -> Time -> (Time -> a) -> Dynamic a+mkDynamic s e = Dynamic (mkEra s e)++-- | Fold for 'Dynamic'.+onDynamic :: (Time -> Time -> (Time -> a) -> b) -> Dynamic a -> b+onDynamic f (Dynamic e d) = f (start e) (end e) d++-- | Shift a 'Dynamic' value by a certain duration.+shiftDynamic :: Duration -> Dynamic a -> Dynamic a+shiftDynamic sh =+ onDynamic $ \s e d ->+ mkDynamic+ (s .+^ sh)+ (e .+^ sh)+ (\t -> d (t .-^ sh))++------------------------------------------------------------+-- Active+------------------------------------------------------------++-- $active+-- For working with time-varying values, it is convenient to have an+-- 'Applicative' instance: '<*>' lets us apply time-varying+-- functions to time-varying values; 'pure' allows treating constants+-- as time-varying values which do not vary. However, as explained in+-- its documentation, 'Dynamic' cannot be made an instance of+-- 'Applicative' since there is no way to implement 'pure'. The+-- problem is that all 'Dynamic' values must have a finite start and+-- end time. The solution is to adjoin a special constructor for+-- pure/constant values with no start or end time, giving us 'Active'.++-- | There are two types of @Active@ values:+--+-- * An 'Active' can simply be a 'Dynamic', that is, a time-varying+-- value with start and end times.+--+-- * An 'Active' value can also be a constant: a single value,+-- constant across time, with no start and end times.+--+-- The addition of constant values enable 'Monoid' and 'Applicative'+-- instances for 'Active'.+newtype Active a = Active (MaybeApply Dynamic a)+ deriving (Functor, Apply, Applicative)++instance Newtype (Active a) (MaybeApply Dynamic a) where+ pack = Active+ unpack (Active m) = m++instance Newtype (MaybeApply f a) (Either (f a) a) where+ pack = MaybeApply+ unpack = runMaybeApply++-- | Ideally this would be defined in the @newtype@ package. If it is+-- ever added we can remove it from here.+over2 :: (Newtype n o, Newtype n' o', Newtype n'' o'')+ => (o -> n) -> (o -> o' -> o'') -> (n -> n' -> n'')+over2 _ f n1 n2 = pack (f (unpack n1) (unpack n2))++-- | Active values over a type with a 'Semigroup' instance are also an+-- instance of 'Semigroup'. Two active values are combined+-- pointwise; the resulting value is constant iff both inputs are.+instance Semigroup a => Semigroup (Active a) where+ (<>) = (over2 Active . over2 MaybeApply) combine+ where+ combine (Right m1) (Right m2)+ = Right (m1 <> m2)++ combine (Left (Dynamic dur f)) (Right m)+ = Left (Dynamic dur (f <> const m))++ combine (Right m) (Left (Dynamic dur f))+ = Left (Dynamic dur (const m <> f))++ combine (Left d1) (Left d2)+ = Left (d1 <> d2)++instance (Monoid a, Semigroup a) => Monoid (Active a) where+ mempty = Active (MaybeApply (Right mempty))+ mappend = (<>)++-- | Create an 'Active' value from a 'Dynamic'.+fromDynamic :: Dynamic a -> Active a+fromDynamic = Active . MaybeApply . Left++-- | Create a dynamic 'Active' from a start time, an end time, and a+-- time-varying value.+mkActive :: Time -> Time -> (Time -> a) -> Active a+mkActive s e f = fromDynamic (mkDynamic s e f)++-- | Fold for 'Active's. Process an 'Active a', given a function to+-- apply if it is a pure (constant) value, and a function to apply if+-- it is a 'Dynamic'.+onActive :: (a -> b) -> (Dynamic a -> b) -> Active a -> b+onActive f _ (Active (MaybeApply (Right a))) = f a+onActive _ f (Active (MaybeApply (Left d))) = f d++-- | Modify an 'Active' value using a case analysis to see whether it+-- is constant or dynamic.+modActive :: (a -> b) -> (Dynamic a -> Dynamic b) -> Active a -> Active b+modActive f g = onActive (pure . f) (fromDynamic . g)++-- | Interpret an 'Active' value as a function from time.+runActive :: Active a -> (Time -> a)+runActive = onActive const runDynamic++-- | Get the value of an @Active a@ at the beginning of its era.+activeStart :: Active a -> a+activeStart = onActive id (onDynamic $ \s _ d -> d s)++-- | Get the value of an @Active a@ at the end of its era.+activeEnd :: Active a -> a+activeEnd = onActive id (onDynamic $ \_ e d -> d e)++-- | Get the 'Era' of an 'Active' value (or 'Nothing' if it is+-- a constant/pure value).+activeEra :: Active a -> Maybe Era+activeEra = onActive (const Nothing) (Just . era)++-- | Test whether an 'Active' value is constant.+isConstant :: Active a -> Bool+isConstant = onActive (const True) (const False)++-- | Test whether an 'Active' value is 'Dynamic'.+isDynamic :: Active a -> Bool+isDynamic = onActive (const False) (const True)++------------------------------------------------------------+-- Combinators+------------------------------------------------------------++-- | @ui@ represents the /unit interval/, which takes on the value @t@+-- at time @t@, and has as its era @[0,1]@. It is equivalent to+-- @'interval' 0 1@, and can be visualized as follows:+--+-- <<http://www.cis.upenn.edu/~byorgey/hosted/ui.png>>+--+-- On the x-axis is time, and the value that @ui@ takes on is on the+-- y-axis. The shaded portion represents the era. Note that the+-- value of @ui@ (as with any active) is still defined outside its+-- era, and this can make a difference when it is combined with+-- other active values with different eras. Applying a function+-- with 'fmap' affects all values, both inside and outside the era.+-- To manipulate values outside the era specifically, see 'clamp'+-- and 'trim'.+--+-- To alter the /values/ that @ui@ takes on without altering its+-- era, use its 'Functor' and 'Applicative' instances. For example,+-- @(*2) \<$\> ui@ varies from @0@ to @2@ over the era @[0,1]@. To+-- alter the era, you can use 'stretch' or 'shift'.+ui :: Fractional a => Active a+ui = interval 0 1++-- | @interval a b@ is an active value starting at time @a@, ending at+-- time @b@, and taking the value @t@ at time @t@.+interval :: Fractional a => Time -> Time -> Active a+interval a b = mkActive a b (fromRational . unTime)++-- | @stretch s act@ \"stretches\" the active @act@ so that it takes+-- @s@ times as long (retaining the same start time).+stretch :: Rational -> Active a -> Active a+stretch str =+ modActive id . onDynamic $ \s e d ->+ mkDynamic s (s .+^ (str *^ (e .-. s)))+ (\t -> d (s .+^ ((t .-. s) ^/ str)))++-- | @stretchTo d@ 'stretch'es an 'Active' so it has duration @d@.+-- Has no effect if (1) @d@ is non-positive, or (2) the 'Active'+-- value is constant, or (3) the 'Active' value has zero duration.+stretchTo :: Duration -> Active a -> Active a+stretchTo d a+ | d <= 0 = a+ | (duration <$> activeEra a) == Just 0 = a+ | otherwise = maybe a (`stretch` a) ((toRational . (d /) . duration) <$> activeEra a)++-- | @a1 \`during\` a2@ 'stretch'es and 'shift's @a1@ so that it has the+-- same era as @a2@. Has no effect if either of @a1@ or @a2@ are constant.+during :: Active a -> Active a -> Active a+during a1 a2 = maybe a1 (\(d,s) -> stretchTo d . atTime s $ a1)+ ((duration &&& start) <$> activeEra a2)++-- | @shift d act@ shifts the start time of @act@ by duration @d@.+-- Has no effect on constant values.+shift :: Duration -> Active a -> Active a+shift sh = modActive id (shiftDynamic sh)++-- | Reverse an active value so the start of its era gets mapped to+-- the end and vice versa. For example, @backwards 'ui'@ can be+-- visualized as+--+-- <<http://www.cis.upenn.edu/~byorgey/hosted/backwards.png>>+backwards :: Active a -> Active a+backwards =+ modActive id . onDynamic $ \s e d ->+ mkDynamic s e+ (\t -> d (e - t + s))++-- | Take a \"snapshot\" of an active value at a particular time,+-- resulting in a constant value.+snapshot :: Time -> Active a -> Active a+snapshot t a = pure (runActive a t)++-- | \"Clamp\" an active value so that it is constant before and after+-- its era. Before the era, @clamp a@ takes on the value of @a@ at+-- the start of the era. Likewise, after the era, @clamp a@ takes+-- on the value of @a@ at the end of the era. @clamp@ has no effect+-- on constant values.+--+-- For example, @clamp 'ui'@ can be visualized as+--+-- <<http://www.cis.upenn.edu/~byorgey/hosted/clamp.png>>+--+-- See also 'clampBefore' and 'clampAfter', which clamp only before+-- or after the era, respectively.+clamp :: Active a -> Active a+clamp =+ modActive id . onDynamic $ \s e d ->+ mkDynamic s e+ (\t -> case () of _ | t < s -> d s+ | t > e -> d e+ | otherwise -> d t+ )++-- | \"Clamp\" an active value so that it is constant before the start+-- of its era. For example, @clampBefore 'ui'@ can be visualized as+--+-- <<http://www.cis.upenn.edu/~byorgey/hosted/clampBefore.png>>+--+-- See the documentation of 'clamp' for more information.+clampBefore :: Active a -> Active a+clampBefore = undefined++-- | \"Clamp\" an active value so that it is constant after the end+-- of its era. For example, @clampBefore 'ui'@ can be visualized as+--+-- <<http://www.cis.upenn.edu/~byorgey/hosted/clampAfter.png>>+--+-- See the documentation of 'clamp' for more information.+clampAfter :: Active a -> Active a+clampAfter = undefined++-- | \"Trim\" an active value so that it is empty outside its era.+-- @trim@ has no effect on constant values.+--+-- For example, @trim 'ui'@ can be visualized as+--+-- <<http://www.cis.upenn.edu/~byorgey/hosted/trim.png>>+--+-- Actually, @trim ui@ is not well-typed, since it is not guaranteed+-- that @ui@'s values will be monoidal (and usually they won't be)!+-- But the above image still provides a good intuitive idea of what+-- @trim@ is doing. To make this precise we could consider something+-- like @trim (First . Just <$> ui)@.+--+-- See also 'trimBefore' and 'trimActive', which trim only before or+-- after the era, respectively.+trim :: Monoid a => Active a -> Active a+trim =+ modActive id . onDynamic $ \s e d ->+ mkDynamic s e+ (\t -> case () of _ | t < s -> mempty+ | t > e -> mempty+ | otherwise -> d t+ )++-- | \"Trim\" an active value so that it is empty /before/ the start+-- of its era. For example, @trimBefore 'ui'@ can be visualized as+--+-- <<http://www.cis.upenn.edu/~byorgey/hosted/trimBefore.png>>+--+-- See the documentation of 'trim' for more details.+trimBefore :: Monoid a => Active a -> Active a+trimBefore =+ modActive id . onDynamic $ \s e d ->+ mkDynamic s e+ (\t -> case () of _ | t < s -> mempty+ | otherwise -> d t+ )++-- | \"Trim\" an active value so that it is empty /after/ the end+-- of its era. For example, @trimAfter 'ui'@ can be visualized as+--+-- <<http://www.cis.upenn.edu/~byorgey/hosted/trimAfter.png>>+--+-- See the documentation of 'trim' for more details.+trimAfter :: Monoid a => Active a -> Active a+trimAfter =+ modActive id . onDynamic $ \s e d ->+ mkDynamic s e+ (\t -> case () of _ | t > e -> mempty+ | otherwise -> d t+ )++-- | Set the era of an 'Active' value. Note that this will change a+-- constant 'Active' into a dynamic one which happens to have the+-- same value at all times.+setEra :: Era -> Active a -> Active a+setEra er =+ onActive+ (mkActive (start er) (end er) . const)+ (fromDynamic . onDynamic (\_ _ -> mkDynamic (start er) (end er)))++-- | @atTime t a@ is an active value with the same behavior as @a@,+-- shifted so that it starts at time @t@. If @a@ is constant it is+-- returned unchanged.+atTime :: Time -> Active a -> Active a+atTime t a = maybe a (\e -> shift (t .-. start e) a) (activeEra a)++-- | @a1 \`after\` a2@ produces an active that behaves like @a1@ but is+-- shifted to start at the end time of @a2@. If either @a1@ or @a2@+-- are constant, @a1@ is returned unchanged.+after :: Active a -> Active a -> Active a+after a1 a2 = maybe a1 ((`atTime` a1) . end) (activeEra a2)++infixr 5 ->>+++-- XXX illustrate++-- | Sequence/overlay two 'Active' values: shift the second to start+-- immediately after the first (using 'after'), then compose them+-- (using '<>').+(->>) :: Semigroup a => Active a -> Active a -> Active a+a1 ->> a2 = a1 <> (a2 `after` a1)+++-- XXX illustrate++-- | \"Splice\" two 'Active' values together: shift the second to+-- start immediately after the first (using 'after'), and produce+-- the value which acts like the first up to the common end/start+-- point, then like the second after that. If both are constant,+-- return the first.+(|>>) :: Active a -> Active a -> Active a+a1 |>> a2 = (fromJust . getFirst) <$>+ (trimAfter (First . Just <$> a1) ->> trimBefore (First . Just <$> a2))++-- XXX implement 'movie' with a balanced fold++-- | Splice together a list of active values using '|>>'. The list+-- must be nonempty.+movie :: [Active a] -> Active a+movie = foldr1 (|>>)++------------------------------------------------------------+-- Discretization+------------------------------------------------------------++-- | Create an @Active@ which takes on each value in the given list in+-- turn during the time @[0,1]@, with each value getting an equal+-- amount of time. In other words, @discrete@ creates a \"slide+-- show\" that starts at time 0 and ends at time 1. The first+-- element is used prior to time 0, and the last element is used+-- after time 1.+--+-- It is an error to call @discrete@ on the empty list.+discrete :: [a] -> Active a+discrete [] = error "Data.Active.discrete must be called with a non-empty list."+discrete xs = f <$> (ui :: Active Rational)+ where f t | t <= 0 = arr ! 0+ | t >= 1 = arr ! (n-1)+ | otherwise = arr ! floor (t * fromIntegral n)+ n = length xs+ arr = listArray (0, n-1) xs++-- | @simulate r act@ simulates the 'Active' value @act@, returning a+-- list of \"snapshots\" taken at regular intervals from the start+-- time to the end time. The interval used is determined by the+-- rate @r@, which denotes the \"frame rate\", that is, the number+-- of snapshots per unit time.+--+-- If the 'Active' value is constant (and thus has no start or end+-- times), a list of length 1 is returned, containing the constant+-- value.+simulate :: Rational -> Active a -> [a]+simulate rate =+ onActive (:[])+ (\d -> map (runDynamic d)+ (let s = start (era d)+ e = end (era d)+ in [s, s + 1^/rate .. e]+ )+ )
+ test/active-tests.hs view
@@ -0,0 +1,155 @@+module Main where++import Control.Applicative+import Control.Monad (when)+import Data.Semigroup++import System.Exit (exitFailure)++import Test.QuickCheck+import Text.Printf (printf)++import Data.Active+import Data.VectorSpace+import Data.AffineSpace++main :: IO ()+main = do+ results <- mapM (\(s,t) -> printf "%-40s" s >> t) tests+ when (not . all isSuccess $ results) $ exitFailure+ where+ isSuccess (Success{}) = True+ isSuccess _ = False+ qc x = quickCheckWithResult (stdArgs { maxSuccess = 200 }) x+ tests = [ ("era/start", qc prop_era_start )+ , ("era/end", qc prop_era_end )+ , ("duration", qc prop_duration )+ , ("shiftDyn/start", qc prop_shiftDynamic_start )+ , ("shiftDyn/end", qc prop_shiftDynamic_end )+ , ("shiftDyn/fun", qc prop_shiftDynamic_fun )+ , ("active/semi-hom", qc prop_active_semi_hom )+ , ("ui/id", qc prop_ui_id )+ , ("stretch/start", qc prop_stretch_start )+ , ("stretch/dur", qc prop_stretch_dur )+ , ("stretchTo/dur", qc prop_stretchTo_dur )+ , ("during/const", qc prop_during_const )+ , ("during/start", qc prop_during_start )+ , ("during/end", qc prop_during_end )+ , ("shift/start", qc prop_shift_start )+ , ("shift/end", qc prop_shift_end )+-- , ("backwards", qc prop_backwards )+ , ("atTime/start", qc prop_atTime_start )+ , ("atTime/fun", qc prop_atTime_fun )+ ]++instance Arbitrary Any where+ arbitrary = Any <$> arbitrary++instance Arbitrary Time where+ arbitrary = fromRational <$> arbitrary++instance CoArbitrary Time where+ coarbitrary t = coarbitrary (toRational t)++instance Arbitrary Duration where+ arbitrary = (fromRational . abs) <$> arbitrary++instance Arbitrary a => Arbitrary (Dynamic a) where+ arbitrary = do+ s <- arbitrary+ d <- arbitrary+ mkDynamic <$> pure s <*> pure (s .+^ d) <*> arbitrary++instance Show (Dynamic a) where+ show (Dynamic e f) = "<" ++ show e ++ ">"++instance Arbitrary a => Arbitrary (Active a) where+ arbitrary = oneof [ pure <$> arbitrary+ , fromDynamic <$> arbitrary+ ]++instance Show a => Show (Active a) where+ show = onActive (\c -> "<<" ++ show c ++ ">>")+ (\d -> show d)++prop_era_start :: Time -> Time -> Bool+prop_era_start t1 t2 = start (mkEra t1 t2) == t1++prop_era_end :: Time -> Time -> Bool+prop_era_end t1 t2 = end (mkEra t1 t2) == t2++prop_duration :: Time -> Time -> Bool+prop_duration t1 t2 = duration (mkEra t1 t2) == (t2 .-. t1)++prop_shiftDynamic_start :: Duration -> Dynamic Bool -> Bool+prop_shiftDynamic_start dur dyn+ = (start . era) (shiftDynamic dur dyn) == ((start . era) dyn .+^ dur)++prop_shiftDynamic_end :: Duration -> Dynamic Bool -> Bool+prop_shiftDynamic_end dur dyn+ = (end . era) (shiftDynamic dur dyn) == ((end . era) dyn .+^ dur)++prop_shiftDynamic_fun :: Duration -> Dynamic Bool -> Time -> Bool+prop_shiftDynamic_fun dur dyn t+ = runDynamic dyn t == runDynamic (shiftDynamic dur dyn) (t .+^ dur)++prop_active_semi_hom :: Active Any -> Active Any -> Time -> Bool+prop_active_semi_hom a1 a2 t =+ runActive a1 t <> runActive a2 t == runActive (a1 <> a2) t++prop_ui_id :: Time -> Bool+prop_ui_id t = runActive (ui :: Active Time) t == t++prop_stretch_start :: Rational -> Active Bool -> Bool+prop_stretch_start r a+ = (start <$> activeEra a) == (start <$> activeEra (stretch r a))++prop_stretch_dur :: Rational -> Active Bool -> Bool+prop_stretch_dur r a+ = (((r *^) . duration) <$> activeEra a) == (duration <$> activeEra (stretch r a))++{-+prop_stretch_fun :: Rational -> Blind (Active Bool) -> Time -> Bool+prop_stretch_fun r (Blind a) t+ = runActive a t runActive (stretch r t)+-}++prop_stretchTo_dur :: Positive Duration -> Active Bool -> Property+prop_stretchTo_dur (Positive dur) a+ = isDynamic a && ((duration <$> activeEra a) /= Just 0)+ ==> (duration <$> activeEra (stretchTo dur a)) == Just dur++prop_during_const :: Active Bool -> Active Bool -> Property+prop_during_const a1 a2 =+ (isConstant a1 || isConstant a2) ==> (start <$> activeEra (a1 `during` a2)) == (start <$> activeEra a1)++prop_during_start :: Dynamic Bool -> Dynamic Bool -> Bool+prop_during_start d1 d2 =+ (start <$> activeEra (a1 `during` a2)) == (start <$> activeEra a2)+ where a1 = fromDynamic d1+ a2 = fromDynamic d2++prop_during_end :: Dynamic Bool -> Dynamic Bool -> Bool+prop_during_end d1 d2 =+ (end <$> activeEra (a1 `during` a2)) == (end <$> activeEra a2)+ where a1 = fromDynamic d1+ a2 = fromDynamic d2++prop_shift_start :: Duration -> Active Bool -> Bool+prop_shift_start d a =+ ((.+^ d) . start <$> activeEra a) == (start <$> activeEra (shift d a))++prop_shift_end :: Duration -> Active Bool -> Bool+prop_shift_end d a =+ ((.+^ d) . end <$> activeEra a) == (end <$> activeEra (shift d a))++prop_atTime_start :: Time -> Dynamic Bool -> Bool+prop_atTime_start t dyn =+ (start <$> activeEra (atTime t a)) == Just t+ where a = fromDynamic dyn++prop_atTime_fun :: Time -> Dynamic Bool -> Duration -> Bool+prop_atTime_fun t dyn d =+ runActive (atTime t a) (t .+^ d) == runActive a (s .+^ d)+ where a = fromDynamic dyn+ s = start (era dyn)