diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,3 @@ +0.1.0.0: 9 March 2012 + + Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/active.cabal b/active.cabal new file mode 100644 --- /dev/null +++ b/active.cabal @@ -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 diff --git a/src/Data/Active.hs b/src/Data/Active.hs new file mode 100644 --- /dev/null +++ b/src/Data/Active.hs @@ -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. ), 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 +-- (), 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 (, +-- ) 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: +-- +-- <> +-- +-- 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 +-- +-- <> +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 +-- +-- <> +-- +-- 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 +-- +-- <> +-- +-- 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 +-- +-- <> +-- +-- 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 +-- +-- <> +-- +-- 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 +-- +-- <> +-- +-- 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 +-- +-- <> +-- +-- 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] + ) + ) diff --git a/test/active-tests.hs b/test/active-tests.hs new file mode 100644 --- /dev/null +++ b/test/active-tests.hs @@ -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)