packages feed

event-list 0.0.11.1 → 0.1.3

raw patch · 24 files changed

Files

event-list.cabal view
@@ -1,5 +1,5 @@ Name:             event-list-Version:          0.0.11.1+Version:          0.1.3 License:          GPL License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -17,7 +17,7 @@    The data structures can be used to represent    MIDI files, OpenSoundControl message streams, music performances etc. Tested-With:       GHC==6.4.1, GHC==6.6.1, GHC==6.8.2-Cabal-Version:     >=1.6+Cabal-Version:     >=1.10 Build-Type:        Simple Source-Repository head   type:     darcs@@ -26,28 +26,26 @@ Source-Repository this   type:     darcs   location: http://code.haskell.org/~thielema/event-list/-  tag:      0.0.11.1+  tag:      0.1.3  Flag splitBase   description: Choose the new smaller, split-up base package. -Flag buildTests-  description: Build test executables-  default:     False- Library   Build-Depends:-    non-negative >=0.0 && <0.1,-    transformers >=0.1 && <0.3,-    utility-ht >=0.0.3 && <0.1,-    QuickCheck >=1.1 && <3+    non-negative >=0.1 && <0.2,+    transformers >=0.1 && <0.7,+    semigroups >=0.1 && <1.0,+    utility-ht >=0.0.10 && <0.1,+    QuickCheck >=2.1 && <3   If flag(splitBase)-    Build-Depends: base >= 2 && <6+    Build-Depends: base >= 2 && <5   Else     Build-Depends:       special-functors >= 1.0 && <1.1,       base >= 1.0 && < 2 +  Default-Language: Haskell98   GHC-Options:      -Wall   Hs-Source-Dirs:   src   Exposed-Modules:@@ -74,17 +72,20 @@     Data.AlternatingList.List.Uniform     Data.AlternatingList.List.Mixed -Executable       test-  If !flag(buildTests)-    Buildable:         False--  -- QuickCheck 1.1 has Maybe instance which we need+Test-Suite test+  Type: exitcode-stdio-1.0   Build-Depends:-    QuickCheck >=1.1 && <3+    QuickCheck >=2.1 && <3,+    transformers,+    semigroups,+    non-negative,+    utility-ht,+    base   If flag(splitBase)     Build-Depends:       random >=1.0 && <2.0 +  Default-Language: Haskell98   GHC-Options:      -Wall   Hs-Source-Dirs:   src   Main-Is:          Test/Main.hs
src/Data/AlternatingList/List/Disparate.hs view
@@ -39,12 +39,16 @@ import Control.Applicative (Applicative, pure, ) import Data.Monoid (Monoid, mempty, mappend, ) -import Test.QuickCheck (Arbitrary, arbitrary, )+import Test.QuickCheck (Arbitrary(arbitrary, shrink)) -import Prelude hiding-   (null, foldr, foldl, map, concat, cycle, length,-    take, drop, splitAt, reverse,-    sequence, sequence_, )+import Text.Show (Show, ShowS, showsPrec, showParen, showString, )+import Data.Function (id, flip, (.), ($), )+import Data.Functor (fmap, )+import Data.Maybe (Maybe(Just, Nothing), maybe, )+import Data.List (zipWith, (++), )+import Data.Tuple (curry, uncurry, )+import Data.Ord (Ord, (>=), )+import Prelude (Integral, Int, String, Bool, Eq, )   data Pair a b =@@ -73,10 +77,12 @@ instance (Arbitrary a, Arbitrary b) =>              Arbitrary (Pair a b) where    arbitrary = Monad.liftM2 Pair arbitrary arbitrary+   shrink (Pair a b) = fmap (uncurry Pair) $ shrink (a,b)  instance (Arbitrary a, Arbitrary b) =>              Arbitrary (T a b) where    arbitrary = Monad.liftM Cons arbitrary+   shrink (Cons xs) = fmap Cons $ shrink xs   fromPairList :: [(a,b)] -> T a b@@ -119,11 +125,17 @@    lift $ zipWith (\x (Pair a b) -> Pair a (f x b)) xs  +{- |+Counterpart to 'Foldable.fold'.+-} concatMonoid :: Monoid m =>    T m m -> m concatMonoid =    foldr mappend mappend mempty +{- |+Counterpart to 'Foldable.foldMap'.+-} concatMapMonoid :: Monoid m =>    (time -> m) ->    (body -> m) ->
src/Data/AlternatingList/List/Mixed.hs view
@@ -117,6 +117,12 @@ {-# INLINE switchSecondL #-} switchSecondL :: (b -> Disp.T a b -> c) -> Uniform.T a b -> c switchSecondL f (Uniform.Cons b xs) = f b xs+{-+The lazy pattern match leads to a space leak in synthesizer-alsa:testArrangeSpaceLeak+I would like to reproduce this in a small test,+but I did not achieve this so far.+-}+-- switchSecondL f ~(Uniform.Cons b xs) = f b xs   {-# INLINE switchR #-}
src/Data/AlternatingList/List/Uniform.hs view
@@ -19,7 +19,8 @@     getFirsts, getSeconds, length, genericLength,     fromFirstList, fromSecondList, fromEitherList,     singleton, isSingleton,-    cons, snoc, reverse, mapSecondHead,+    cons, snoc, reverse,+    mapSecondHead, forceSecondHead,     foldr, foldl,     format,     filterFirst, partitionFirst, partitionMaybeFirst,@@ -39,20 +40,19 @@ import Control.Applicative (Applicative, pure, ) import Data.Monoid (Monoid, mempty, mappend, ) -import Test.QuickCheck (Arbitrary, arbitrary, )+import Test.QuickCheck (Arbitrary(arbitrary, shrink)) +import Text.Show (Show, ShowS, showsPrec, showParen, showString, )+import Data.Function (id, flip, (.), ($), ) import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import Data.Maybe.HT (toMaybe, )-{- this way we cannot access (:) in Hugs-import Data.Maybe (Maybe, maybe)-import Text.Show (Show, ShowS, showsPrec, showParen, showString)-import Prelude-   (Bool, Int, (.), ($), id, undefined, flip, error,-    pred, fst, snd,-    Eq, Ord, Show, (>))--}-import Prelude hiding-   (null, foldr, foldl, map, concat, length, reverse, sequence, sequence_, )+import Data.Functor (fmap, )+import Data.Either (Either(Left, Right), either, )+import Data.Maybe (Maybe, maybe, )+import Data.Tuple (uncurry, )+import Data.Ord (Ord, (>=), )+{- this way we cannot access (:) in Hugs -}+import Prelude (Integral, Int, String, Bool, error, Eq, )   {- |@@ -82,6 +82,7 @@ instance (Arbitrary a, Arbitrary b) =>              Arbitrary (T a b) where    arbitrary = Monad.liftM2 Cons arbitrary arbitrary+   shrink (Cons x xs) = fmap (uncurry Cons) $ shrink (x,xs)   @@ -201,10 +202,19 @@ mapSecondHead :: (b -> b) -> T a b -> T a b mapSecondHead f ~(Cons b xs) = Cons (f b) xs +forceSecondHead :: T a b -> T a b+forceSecondHead = mapSecondHead id  + foldr :: (a -> c -> d) -> (b -> d -> c) -> d -> T a b -> c foldr f g d (Cons b xs) = g b $ Disp.foldr f g d xs+{-+The lazy pattern match leads to a space leak in synthesizer-alsa:testArrangeSpaceLeak+I would like to reproduce this in a small test,+but I did not achieve this so far.+-}+-- foldr f g d ~(Cons b xs) = g b $ Disp.foldr f g d xs  foldl :: (c -> a -> d) -> (d -> b -> c) -> d -> T a b -> c foldl f g d0 xs =
src/Data/EventList/Absolute/TimeBody.hs view
@@ -13,7 +13,7 @@     getTimes, getBodies, duration,     mapBody, mapTime,     concatMapMonoid,-    traverse, traverse_, traverseBody, traverseTime,+    traverse, traverse_, traverseBody, traverseTime, traverseWithTime,     mapM, mapM_, mapBodyM, mapTimeM,     merge, mergeBy, insert, insertBy,     moveForward,@@ -36,8 +36,9 @@ import qualified Data.AlternatingList.List.Uniform as Uniform import qualified Data.AlternatingList.List.Mixed as Mixed -import qualified Data.List as List import qualified Data.EventList.Utility as Utility+import qualified Data.Traversable as Trav+import qualified Data.List as List  import Data.Monoid (Monoid, ) @@ -51,8 +52,17 @@ import Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), )  import Control.Monad.Trans.State (state, evalState)+import Control.Monad (Monad, (>>), ) -import Prelude hiding (mapM, mapM_, null, foldr, filter, concat, cycle)+import Data.Function (id, flip, (.), ($), )+import Data.Functor (fmap, )+import Data.Maybe (Maybe(Just, Nothing), maybe, )+import Data.Tuple (uncurry, fst, snd, )+import Data.Ord (Ord, compare, (<), (>=), )+import Data.Eq (Eq, (==), (/=), )+import Prelude+   (Num, Integral, RealFrac, round, subtract, (*), (-),+    Bool, error, )   empty :: T time body@@ -123,6 +133,14 @@ traverseTime f = liftA (Disp.traverseFirst f)  +traverseWithTime :: Applicative m =>+   (time -> body0 -> m body1) -> T time body0 -> m (T time body1)+traverseWithTime f =+   fmap fromPairList .+   Trav.traverse (\(t,b) -> fmap ((,) t) (f t b)) .+   toPairList++ mapM :: Monad m =>    (time0 -> m time1) -> (body0 -> m body1) ->    T time0 body0 -> m (T time1 body1)@@ -264,7 +282,7 @@       Disp.empty  -flatten :: (Ord time, Num time) => T time [body] -> T time body+flatten :: (Ord time) => T time [body] -> T time body flatten =    foldrPair       (\t bs xs -> List.foldr (cons t) xs bs)@@ -275,7 +293,7 @@ Apply a function to the lists of coincident events. -} -mapCoincident :: (Ord time, Num time) =>+mapCoincident :: (Ord time) =>    ([a] -> [b]) -> T time a -> T time b mapCoincident f = flatten . mapBody f . collectCoincident @@ -293,7 +311,7 @@ isNormalized :: (Ord time, Num time, Ord body) =>    T time body -> Bool isNormalized =-   all isAscending . getBodies . collectCoincident+   List.all isAscending . getBodies . collectCoincident   {- |@@ -330,8 +348,8 @@              (_, Nothing) -> xs0              (Just (x,xs), Just (y,ys)) ->                 if beforeBy before x y-                  then uncurry cons x $ mergeBy before xs ys0-                  else uncurry cons y $ mergeBy before ys xs0+                  then uncurry cons x $ recourse xs ys0+                  else uncurry cons y $ recourse ys xs0    in  recourse  {- |
src/Data/EventList/Absolute/TimeBodyPrivate.hs view
@@ -17,8 +17,9 @@ import qualified Control.Applicative as App import Control.Applicative (Applicative, ) import Data.Monoid (Monoid, mempty, mappend, mconcat, )+import Data.Semigroup (Semigroup, (<>), ) -import Test.QuickCheck (Arbitrary(arbitrary))+import Test.QuickCheck (Arbitrary(arbitrary, shrink))  import Prelude hiding (concat, cycle) @@ -30,10 +31,14 @@ instance (Arbitrary time, Arbitrary body) =>              Arbitrary (T time body) where    arbitrary = Monad.liftM Cons arbitrary+   shrink = liftM shrink +instance (Num time, Ord time) => Semigroup (T time body) where+   (<>) = append+ instance (Num time, Ord time) => Monoid (T time body) where    mempty = Cons Disp.empty-   mappend = append+   mappend = (<>)    mconcat = concat  instance Functor (T time) where@@ -92,6 +97,10 @@ duration :: Num time => T time body -> time duration = switchR 0 (const fst) +{-+Is it necessary to exclude negative delays?+Even negative time stamps should not hurt absolutely timestamped lists.+-} delay :: (Ord time, Num time) =>    time -> T time body -> T time body delay dif =
src/Data/EventList/Absolute/TimeMixed.hs view
@@ -13,11 +13,3 @@     ) where  import Data.EventList.Absolute.TimeTimePrivate--- import qualified Data.EventList.Absolute.TimeBody as TimeBodyList--- import qualified Data.EventList.Absolute.TimeTime as TimeTimeList---- import qualified Data.AlternatingList.List.Disparate as Disp--- import qualified Data.AlternatingList.List.Uniform as Uniform-import qualified Data.AlternatingList.List.Mixed as Mixed---- import Data.AlternatingList.List.Mixed ((/.), (./))
src/Data/EventList/Absolute/TimeTime.hs view
@@ -47,12 +47,19 @@ import Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), )  import Control.Monad.Trans.State (state, evalState)+import Control.Monad (Monad, (>>), )  import Data.Monoid (Monoid, )-import Data.Maybe (fromMaybe) -import Prelude hiding-   (null, foldr, map, filter, concat, cycle, sequence, sequence_, mapM, mapM_)+import Data.Function (flip, (.), ($), )+import Data.Functor (fmap, )+import Data.Maybe (Maybe(Just), fromMaybe, )+import Data.Tuple (uncurry, fst, snd, )+import Data.Ord (Ord, max, (<), (>=), )+import Data.Eq (Eq, (/=), )+import Prelude+   (Num, Integral, RealFrac, round, subtract, (*), (+), (-),+    Bool, error, )   @@ -208,7 +215,7 @@    decons  -flatten :: (Ord time, Num time) => T time [body] -> T time body+flatten :: (Ord time) => T time [body] -> T time body flatten = mapTimeInit TimeBodyList.flatten  @@ -216,7 +223,7 @@ Apply a function to the lists of coincident events. -} -mapCoincident :: (Ord time, Num time) =>+mapCoincident :: (Ord time) =>    ([a] -> [b]) -> T time a -> T time b mapCoincident f = flatten . mapBody f . collectCoincident @@ -234,7 +241,7 @@ isNormalized :: (Ord time, Num time, Ord body) =>    T time body -> Bool isNormalized =-   all isAscending . getBodies . collectCoincident+   List.all isAscending . getBodies . collectCoincident   @@ -292,14 +299,14 @@ concat :: (Ord time, Num time) =>    [T time body] -> T time body concat xs =-   let ts0 = scanl (+) 0 (List.map duration xs)+   let ts0 = List.scanl (+) 0 (List.map duration xs)        (ts,dur) =           fromMaybe              (error "list of accumulated times is always non-empty")              (ListHT.viewR ts0)    in  snocTime           (TimeBodyPriv.Cons $ Disp.concat $ List.map TimeBodyPriv.decons $-           zipWith TimeBodyList.delay ts (List.map (fst . viewTimeR) xs))+           List.zipWith TimeBodyList.delay ts (List.map (fst . viewTimeR) xs))           dur  cycle :: (Ord time, Num time) =>
src/Data/EventList/Relative/BodyBody.hs view
@@ -19,10 +19,12 @@ -- import qualified Data.AlternatingList.List.Disparate as Disp import qualified Data.AlternatingList.List.Uniform as Uniform +import Control.Monad (Monad, ) import Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), liftA, ) import Data.Monoid (Monoid, ) -import Prelude hiding (mapM)+import Data.Function ((.), )+import Prelude ()   concatMapMonoid :: Monoid m =>
src/Data/EventList/Relative/BodyBodyPrivate.hs view
@@ -16,8 +16,7 @@ import qualified Data.Traversable as Trav import qualified Control.Applicative as App -import Test.QuickCheck (Arbitrary(arbitrary))-+import Test.QuickCheck (Arbitrary(arbitrary, shrink))   newtype T time body = Cons {decons :: Uniform.T time body}@@ -30,6 +29,7 @@ instance (Arbitrary time, Arbitrary body) =>              Arbitrary (T time body) where    arbitrary = Monad.liftM Cons arbitrary+   shrink = liftM shrink   {-
src/Data/EventList/Relative/BodyTime.hs view
@@ -28,14 +28,17 @@ import qualified Data.AlternatingList.List.Disparate as Disp -- import qualified Data.AlternatingList.List.Uniform as Uniform +import Control.Monad (Monad, ) import Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), ) import Data.Monoid (Monoid, mempty, )  import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import qualified Data.List as List -import Prelude hiding-   (mapM, mapM_, foldr, span, null, )+import Data.Function ((.), ($), )+import Data.Functor (fmap, )+import Data.Maybe (Maybe, )+import Prelude (Num, (+), Bool, )   fromPairList :: [(body, time)] -> T time body@@ -51,7 +54,7 @@ getTimes = Disp.getSeconds . decons  duration :: Num time => T time body -> time-duration = sum . getTimes+duration = List.sum . getTimes  durationR :: Num time => T time body -> time durationR = List.foldr (+) 0 . getTimes
src/Data/EventList/Relative/BodyTimePrivate.hs view
@@ -16,8 +16,9 @@ import qualified Data.Traversable as Trav import qualified Control.Applicative as App import Data.Monoid (Monoid, mempty, mappend, )+import Data.Semigroup (Semigroup, (<>), ) -import Test.QuickCheck (Arbitrary(arbitrary))+import Test.QuickCheck (Arbitrary(arbitrary, shrink))   @@ -31,10 +32,14 @@ instance (Arbitrary time, Arbitrary body) =>              Arbitrary (T time body) where    arbitrary = Monad.liftM Cons arbitrary+   shrink = liftM shrink +instance Semigroup (T time body) where+   Cons x <> Cons y = Cons (Disp.append x y)+ instance Monoid (T time body) where    mempty = Cons Disp.empty-   mappend (Cons x) (Cons y) = Cons (Disp.append x y)+   mappend = (<>)  instance Functor (T time) where    fmap f (Cons x) = Cons (Disp.mapFirst f x)
src/Data/EventList/Relative/TimeBody.hs view
@@ -25,7 +25,7 @@     fromPairList, toPairList,     getTimes, getBodies, duration,     mapBody, mapTime,-    zipWithBody, zipWithTime,+    zipWithBody, zipWithTime, unzip,     concatMapMonoid,     traverse, traverse_, traverseBody, traverseTime,     mapM, mapM_, mapBodyM, mapTimeM,@@ -39,6 +39,7 @@     append, concat, cycle,     discretize, resample,     toAbsoluteEventList, fromAbsoluteEventList,+    toAbsoluteEventListGen, fromAbsoluteEventListGen,    ) where  import Data.EventList.Relative.TimeBodyPrivate@@ -58,13 +59,21 @@ import Data.Monoid (Monoid, )  import qualified Numeric.NonNegative.Class as NonNeg+import Numeric.NonNegative.Class ((-|), zero, add, ) import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import Data.Maybe.HT (toMaybe, ) import Data.List.HT (isAscending, )-import Data.EventList.Utility (floorDiff, beforeBy, ) import Control.Monad.Trans.State (evalState, modify, get, put, )+import Control.Monad (Monad, return, (>>), ) -import Prelude hiding (mapM, mapM_, null, foldr, filter, concat, cycle, span, )+import Data.Function (flip, const, (.), ($), )+import Data.Functor (fmap, )+import Data.Maybe (Maybe(Just, Nothing), maybe, )+import Data.Bool (Bool, not, (||), (&&), )+import Data.Tuple (uncurry, fst, snd, )+import Data.Ord (Ord, (<), )+import Data.Eq (Eq, (/=), )+import Prelude (Num, Integral, RealFrac, (*), (+), (-), error, )   @@ -115,8 +124,8 @@ getTimes :: T time body -> [time] getTimes = Disp.getFirsts . decons -duration :: Num time => T time body -> time-duration = sum . getTimes+duration :: NonNeg.C time => T time body -> time+duration = NonNeg.sum . getTimes   @@ -138,7 +147,15 @@ zipWithTime f = lift . Disp.zipWithFirst f  +unzip :: T time (body0, body1) -> (T time body0, T time body1)+unzip =+   foldrPair+      (\time (body0, body1) ->+         mapPair (cons time body0, cons time body1))+      (empty, empty) ++ concatMapMonoid :: Monoid m =>    (time -> m) -> (body -> m) ->    T time body -> m@@ -200,12 +217,12 @@ {- | Keep only events that match a predicate while preserving absolute times. -}-filter :: (Num time) =>+filter :: (NonNeg.C time) =>    (body -> Bool) -> T time body -> T time body filter p = mapMaybe (\b -> toMaybe (p b) b) -- filter p = fst . partition p -mapMaybe :: (Num time) =>+mapMaybe :: (NonNeg.C time) =>    (body0 -> Maybe body1) ->    T time body0 -> T time body1 mapMaybe f = catMaybes . mapBody f@@ -214,12 +231,12 @@ Adds times in a left-associative fashion. Use this if the time is a strict data type. -}-catMaybes :: (Num time) =>+catMaybes :: (NonNeg.C time) =>    T time (Maybe body) -> T time body catMaybes =    Cons .    fst . Mixed.viewSecondR .-   Uniform.mapSecond sum .+   Uniform.mapSecond NonNeg.sum .    Uniform.catMaybesFirst .    flip Mixed.snocSecond (error "catMaybes: no trailing time") .    decons@@ -254,11 +271,11 @@ {- Could be implemented more easily in terms of Uniform.partition -}-partition :: (Num time) =>+partition :: (NonNeg.C time) =>    (body -> Bool) -> T time body -> (T time body, T time body)-partition p = partitionRec p 0 0+partition p = partitionRec p zero zero -partitionRec :: (Num time) =>+partitionRec :: (NonNeg.C time) =>    (body -> Bool) -> time -> time ->        T time body -> (T time body, T time body) partitionRec p =@@ -266,14 +283,14 @@           switchL              (empty, empty)              (\ (t, b) es ->-                let t0' = t0 + t-                    t1' = t1 + t+                let t0' = add t0 t+                    t1' = add t1 t                 in  if p b-                      then mapFst (cons t0' b) (recourse 0 t1' es)-                      else mapSnd (cons t1' b) (recourse t0' 0 es))+                      then mapFst (cons t0' b) (recourse zero t1' es)+                      else mapSnd (cons t1' b) (recourse t0' zero es))    in  recourse -partitionMaybe :: (Num time) =>+partitionMaybe :: (NonNeg.C time) =>    (body0 -> Maybe body1) -> T time body0 ->    (T time body1, T time body0) partitionMaybe f =@@ -289,7 +306,7 @@ we splice the event list into lists, each containing the same class. Absolute time stamps are preserved. -}-slice :: (Eq a, Num time) =>+slice :: (Eq a, NonNeg.C time) =>    (body -> a) -> T time body -> [(a, T time body)] slice = Utility.slice (fmap (snd . fst) . viewL) partition @@ -304,7 +321,7 @@ -} collectCoincident :: (NonNeg.C time) => T time body -> T time [body] collectCoincident =-   mapTimeTail $ BodyBodyPriv.lift $ Uniform.filterFirst (0<)+   mapTimeTail $ BodyBodyPriv.lift $ Uniform.filterFirst (zero <)  {- | Reverse to collectCoincident:@@ -321,9 +338,9 @@          unlift (delay time) .          fst . Mixed.viewSecondR .          Uniform.foldr-            (Mixed.appendUniformUniform . Uniform.fromSecondList 0)+            (Mixed.appendUniformUniform . Uniform.fromSecondList zero)             Mixed.consSecond Disp.empty .-         Uniform.mapSecond sum .+         Uniform.mapSecond NonNeg.sum .          Uniform.filterSecond (not . List.null)) .    decons @@ -347,7 +364,7 @@ isNormalized :: (NonNeg.C time, Ord body) =>    T time body -> Bool isNormalized =-   all isAscending . getBodies . collectCoincident+   List.all isAscending . getBodies . collectCoincident   @@ -364,6 +381,15 @@ {- | 'mergeBy' is like 'merge' but does not simply use the methods of the 'Ord' class but allows a custom comparison function.+If in event lists @xs@ and @ys@ there are coinciding elements @x@ and @y@,+and @cmp x y@ is 'True',+then @x@ comes before @y@ in @mergeBy cmp xs ys@.++> EventList> EventList.mergeBy (\_ _ -> True) (0 /. 'a' ./ empty) (0 /. 'b' ./ empty)+> 0 /. 'a' ./ 0 /. 'b' ./ empty+>+> EventList> EventList.mergeBy (\_ _ -> False) (0 /. 'a' ./ empty) (0 /. 'b' ./ empty)+> 0 /. 'b' ./ 0 /. 'a' ./ empty -}  {-@@ -372,29 +398,26 @@ mergeBy :: (NonNeg.C time) =>    (body -> body -> Bool) ->    T time body -> T time body -> T time body-mergeBy before xs0 ys0 =-   case (viewL xs0, viewL ys0) of-      (Nothing, _) -> ys0-      (_, Nothing) -> xs0-      (Just (x@(xt,xb),xs), Just (y@(yt,yb),ys)) ->-         if beforeBy before x y-           then uncurry cons x $ mergeBy before xs $ cons (yt-xt) yb ys-           else uncurry cons y $ mergeBy before ys $ cons (xt-yt) xb xs+mergeBy before =+   let recourse xs0 ys0 =+          case (viewL xs0, viewL ys0) of+             (Nothing, _) -> ys0+             (_, Nothing) -> xs0+             (Just ((xt,xb),xs), Just ((yt,yb),ys)) ->+                let (mt,~(b,dt)) = NonNeg.split xt yt+                in  uncurry (cons mt) $+                    if b && (dt/=zero || before xb yb)+                      then (xb, recourse xs $ cons dt yb ys)+                      else (yb, recourse ys $ cons dt xb xs)+   in  recourse + {- | 'insert' inserts an event into an event list at the given time. -} insert :: (NonNeg.C time, Ord body) =>    time -> body -> T time body -> T time body-insert t0 me0 =-   switchL-      (singleton t0 me0)-      (\ mev1@(t1, me1) mevs ->-          let mev0 = (t0, me0)-          in  if mev0 < mev1-                then uncurry cons mev0 $ cons   (t1-t0) me1 mevs-                else uncurry cons mev1 $ insert (t0-t1) me0 mevs)-+insert = insertBy (<)   insertBy :: (NonNeg.C time) =>@@ -402,12 +425,15 @@    time -> body -> T time body -> T time body insertBy before =    let recourse t0 me0 =+          (\ ~((t,me), rest) -> cons t me rest) .           switchL-             (singleton t0 me0)-             (\ mev1@(t1, me1) mevs ->-                 if beforeBy before (t0, me0) mev1-                   then cons t0 me0 $ cons     (t1-t0) me1 mevs-                   else cons t1 me1 $ recourse (t0-t1) me0 mevs)+             ((t0,me0), empty)+             (\(t1, me1) mevs ->+                let (mt,~(b,dt)) = NonNeg.split t0 t1+                in  mapFst ((,) mt) $+                    if b && (dt/=zero || before me0 me1)+                      then (me0, cons     dt me1 mevs)+                      else (me1, recourse dt me0 mevs))    in  recourse  @@ -416,7 +442,7 @@ You must make sure, that no event is moved before time zero. This works only for finite lists. -}-moveForward :: (NonNeg.C time) =>+moveForward :: (Ord time, Num time) =>    T time (time, body) -> T time body moveForward =    fromAbsoluteEventList .@@ -463,7 +489,7 @@ append xs = lift (Disp.append $~* xs)  concat :: [T time body] -> T time body-concat = Cons . Disp.concat . map decons+concat = Cons . Disp.concat . List.map decons  cycle :: T time body -> T time body cycle = lift Disp.cycle@@ -473,12 +499,12 @@ decreaseStart :: (NonNeg.C time) =>    time -> T time body -> T time body decreaseStart dif =-   mapTimeHead (subtract dif)+   mapTimeHead (-| dif)  delay :: (NonNeg.C time) =>    time -> T time body -> T time body delay dif =-   mapTimeHead (dif+)+   mapTimeHead (add dif)   @@ -506,7 +532,7 @@ discretize :: (NonNeg.C time, RealFrac time, NonNeg.C i, Integral i) =>    T time body -> T i body discretize =-   flip evalState 0.5 . mapTimeM floorDiff+   flip evalState 0.5 . mapTimeM Utility.floorDiff  resample :: (NonNeg.C time, RealFrac time, NonNeg.C i, Integral i) =>    time -> T time body -> T i body@@ -520,15 +546,34 @@ -} toAbsoluteEventList :: (Num time) =>    time -> T time body -> AbsoluteEventList.T time body-toAbsoluteEventList start =-   AbsoluteEventPriv.Cons . decons .-   flip evalState start .-   mapTimeM (\dur -> modify (dur+) >> get)+toAbsoluteEventList = toAbsoluteEventListGen (+)  fromAbsoluteEventList :: (Num time) =>    AbsoluteEventList.T time body -> T time body-fromAbsoluteEventList =-   flip evalState 0 .+fromAbsoluteEventList = fromAbsoluteEventListGen (-) 0++{- |+Convert from relative time stamps to absolute time stamps+using a custom accumulator function (like @(+)@).+-}+toAbsoluteEventListGen ::+   (absTime -> relTime -> absTime) ->+   absTime -> T relTime body -> AbsoluteEventList.T absTime body+toAbsoluteEventListGen accum start =+   AbsoluteEventPriv.Cons . decons .+   flip evalState start .+   mapTimeM (\dur -> modify (flip accum dur) >> get)++{- |+Convert from absolute time stamps to relative time stamps+using custom subtraction (like @(-)@) and zero.+-}+fromAbsoluteEventListGen ::+   (absTime -> absTime -> relTime) ->+   absTime ->+   AbsoluteEventList.T absTime body -> T relTime body+fromAbsoluteEventListGen diff start =+   flip evalState start .    mapTimeM-      (\time -> do lastTime <- get; put time; return (time-lastTime)) .+      (\time -> do lastTime <- get; put time; return (diff time lastTime)) .    Cons . AbsoluteEventPriv.decons
src/Data/EventList/Relative/TimeBodyPrivate.hs view
@@ -20,10 +20,11 @@ import qualified Control.Applicative as App import Control.Applicative (Applicative, ) import Data.Monoid (Monoid, mempty, mappend, )+import Data.Semigroup (Semigroup, (<>), )  import Data.Tuple.HT (mapSnd, ) -import Test.QuickCheck (Arbitrary(arbitrary))+import Test.QuickCheck (Arbitrary(arbitrary, shrink))   @@ -38,10 +39,14 @@ instance (Arbitrary time, Arbitrary body) =>              Arbitrary (T time body) where    arbitrary = Monad.liftM Cons arbitrary+   shrink = liftM shrink +instance Semigroup (T time body) where+   Cons x <> Cons y = Cons (Disp.append x y)+ instance Monoid (T time body) where    mempty = Cons Disp.empty-   mappend (Cons x) (Cons y) = Cons (Disp.append x y)+   mappend = (<>)  instance Functor (T time) where    fmap f (Cons x) = Cons (Disp.mapSecond f x)
src/Data/EventList/Relative/TimeMixed.hs view
@@ -6,8 +6,8 @@ Portability :  Haskell 98  -Event lists starting with a body and ending with a time difference.-+Event lists starting with a time difference+and ending with either a data body or a time difference. -} module Data.EventList.Relative.TimeMixed    (snocBody, snocTime,@@ -18,6 +18,7 @@     mapBodyR, mapBodyLast, mapBodyInit,     appendBodyEnd, prependBodyEnd,     splitAtTime, takeTime, dropTime,+    splitAfterTime, takeAfterTime, dropAfterTime,    ) where  import qualified Data.EventList.Relative.TimeBody as TimeBodyList@@ -38,7 +39,7 @@ -- import Data.AlternatingList.List.Mixed ((/.), (./))  import qualified Numeric.NonNegative.Class as NonNeg-import Data.Tuple.HT (mapFst, mapPair, )+import Data.Tuple.HT (mapFst, mapSnd, mapPair, )   snocBody :: TimeTimeList.T time body -> body -> TimeBodyList.T time body@@ -89,28 +90,41 @@    TimeTimePriv.lift . Mixed.appendDisparateUniform . TimeBodyPriv.decons  +liftSplit ::+   (Disp.T time0 body0 -> (Uniform.T body1 time1, Disp.T time2 body2)) ->+   TimeBodyList.T time0 body0 ->+   (TimeTimeList.T time1 body1, TimeBodyList.T time2 body2)+liftSplit f =+   mapPair (TimeTimePriv.Cons, TimeBodyPriv.Cons) . f . TimeBodyPriv.decons  splitAtTimeAux :: (NonNeg.C time) =>+   (time -> time -> (time, (Bool, time))) ->    time -> Disp.T time body ->    (Uniform.T body time, Disp.T time body)-splitAtTimeAux t0 =-   Mixed.switchFirstL-      (Uniform.singleton 0, Disp.empty)-      (\t1 xs ->-          if t0<=t1-            then (Uniform.singleton t0, Mixed.consFirst (t1-t0) xs)-            else-               Mixed.switchSecondL-                  (\b ys -> mapFst (Uniform.cons t1 b) (splitAtTimeAux (t0-t1) ys))-                  xs)+splitAtTimeAux splitTime =+   let go t0 =+         mapFst Uniform.forceSecondHead .+         Mixed.switchFirstL+            (Mixed.consSecond NonNeg.zero Disp.empty, Disp.empty)+            (\t1 xs ->+               let (mt,~(before,dt)) = splitTime t0 t1+               in  mapFst (Mixed.consSecond mt) $+                   if before+                     then (Disp.empty, Mixed.consFirst dt xs)+                     else+                        Mixed.switchSecondL+                           (\b ys -> mapFst (Mixed.consFirst b) $ go dt ys)+                           xs)+   in  go +{- |+At the division time move all zero time differences to the suffix part,+that is we will always split before a group of events.+-} splitAtTime :: (NonNeg.C time) =>    time -> TimeBodyList.T time body ->    (TimeTimeList.T time body, TimeBodyList.T time body)-splitAtTime t0 =-   mapPair (TimeTimePriv.Cons, TimeBodyPriv.Cons) .-   splitAtTimeAux t0 .-   TimeBodyPriv.decons+splitAtTime = liftSplit . splitAtTimeAux NonNeg.split  takeTime :: (NonNeg.C time) =>    time -> TimeBodyList.T time body -> TimeTimeList.T time body@@ -121,3 +135,21 @@ dropTime t = snd . splitAtTime t  +{- |+At the division time move all zero time differences to the prefix part,+that is we will always split after a group of events.+-}+splitAfterTime :: (NonNeg.C time) =>+   time -> TimeBodyList.T time body ->+   (TimeTimeList.T time body, TimeBodyList.T time body)+splitAfterTime =+   liftSplit .+   splitAtTimeAux (\t0 t1 -> mapSnd (mapFst not) $ NonNeg.split t1 t0)++takeAfterTime :: (NonNeg.C time) =>+   time -> TimeBodyList.T time body -> TimeTimeList.T time body+takeAfterTime t = fst . splitAfterTime t++dropAfterTime :: (NonNeg.C time) =>+   time -> TimeBodyList.T time body -> TimeBodyList.T time body+dropAfterTime t = snd . splitAfterTime t
src/Data/EventList/Relative/TimeTime.hs view
@@ -10,7 +10,7 @@ module Data.EventList.Relative.TimeTime    (T,     mapBody, mapTime,-    zipWithBody, zipWithTime,+    zipWithBody, zipWithTime, unzip,     concatMapMonoid,     traverse, traverse_, traverseBody, traverseTime,     mapM, mapM_, mapBodyM, mapTimeM,@@ -26,6 +26,7 @@     mapMaybe, catMaybes, catMaybesR,     append, concat, concatNaive, cycle, cycleNaive, reverse,     splitAtTime, takeTime, dropTime,+    forceTimeHead,     discretize, resample,     collectCoincident, flatten, mapCoincident,     normalize, isNormalized,@@ -47,21 +48,27 @@ import qualified Data.List as List import qualified Data.EventList.Utility as Utility -import Data.Monoid (Monoid, mconcat, mappend, )+import Data.Monoid (Monoid, mempty, mconcat, )  import qualified Numeric.NonNegative.Class as NonNeg+import Numeric.NonNegative.Class ((-|), zero, add, ) import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import Data.Maybe.HT (toMaybe, ) import Data.List.HT (isAscending, ) import Data.EventList.Utility (floorDiff, ) import Control.Monad.Trans.State (evalState, modify, get, gets, put, ) -import Control.Monad (liftM2, )+import Control.Monad (Monad, return, liftM2, (>>), ) import Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), ) -import Prelude hiding-   (null, foldr, foldl, map, filter, concat, cycle, reverse,-    sequence, sequence_, mapM, mapM_)+import Data.Function ((.), ($), id, flip, )+import Data.Functor (fmap, )+import Data.Maybe (Maybe(Just, Nothing), maybe, )+import Data.Tuple (fst, snd, )+import Data.Ord (Ord, (<), )+import Data.Eq (Eq, (==), )+import Data.Bool (Bool(False, True), not, (&&), )+import Prelude (Num, Integral, RealFrac, (*), (+), (-), seq, )   @@ -79,8 +86,8 @@ getTimes :: T time body -> [time] getTimes = Uniform.getSeconds . decons -duration :: Num time => T time body -> time-duration = sum . getTimes+duration :: NonNeg.C time => T time body -> time+duration = NonNeg.sum . getTimes   @@ -132,6 +139,14 @@    (time0, [time0]) -> T time1 body -> T time2 body zipWithTime f = lift . Uniform.zipWithSecond f +unzip :: T time (body0, body1) -> (T time body0, T time body1)+unzip =+   foldr+      (\time ->+         mapPair (consTime time, consTime time))+      (\(body0, body1) ->+         mapPair (consBody body0, consBody body1))+      (mempty, mempty)   concatMapMonoid :: Monoid m =>@@ -192,7 +207,7 @@ isNormalized :: (NonNeg.C time, Ord body) =>    T time body -> Bool isNormalized =-   all isAscending . getBodies . collectCoincident+   List.all isAscending . getBodies . collectCoincident   {- |@@ -210,51 +225,49 @@ mergeBy :: (NonNeg.C time) =>    (body -> body -> Bool) ->    T time body -> T time body -> T time body-mergeBy before xs0 ys0 =-   let (xt,xs) = viewTimeL xs0-       (yt,ys) = viewTimeL ys0-   in  case compare xt yt of-          LT -> mergeFirstBy before xs0 ys0-          GT -> mergeFirstBy before ys0 xs0-          EQ ->-             consTime xt $-             case (viewBodyL xs, viewBodyL ys) of-                (Nothing, _) -> ys-                (_, Nothing) -> xs-                (Just (b0,xs1), Just (b1,ys1)) ->-                   {- do not insert both b0 and b1 immediately,-                      because the later one of b0 and b1 may be pushed even further,-                      thus recourse with 'mergeBy' on xs or ys -}-                   if before b0 b1-                     then consBody b0 $ mergeBy before xs1 $ consTime 0 ys-                     else consBody b1 $ mergeBy before ys1 $ consTime 0 xs--{- | merge two time ordered lists provided that e0 is earlier than e1 -}-mergeFirstBy :: (NonNeg.C time) =>-   (body -> body -> Bool) ->-   T time body -> T time body -> T time body-mergeFirstBy before xs0 ys0 =-   let (xt,xs) = viewTimeL xs0-       (yt,ys) = viewTimeL ys0-   in  switchBodyL-          ys0-          (\ b xs1 ->-              consTime xt $ consBody b $ mergeBy before xs1 $ consTime (yt-xt) ys)-          xs+mergeBy before =+   let recourse xs0 ys0 =+          let (xt,xs) = viewTimeL xs0+              (yt,ys) = viewTimeL ys0+              (mt,~(bef,dt)) = NonNeg.split xt yt+          in  delay mt $+              if dt == zero+                then+                   case (viewBodyL xs, viewBodyL ys) of+                      (Nothing, _) -> consTime zero ys+                      (_, Nothing) -> consTime zero xs+                      (Just (b0,xs1), Just (b1,ys1)) ->+                         {-+                         do not insert both b0 and b1 immediately,+                         because the later one of b0 and b1 may be pushed even further,+                         thus recourse with 'mergeBy' on xs or ys+                         -}+                         if before b0 b1+                           then cons zero b0 $+                                recourse xs1 (consTime zero ys)+                           else cons zero b1 $+                                recourse (consTime zero xs) ys1+                else+                  if bef+                    then+                       let ys1 = consTime dt ys+                       in  flip (switchBodyL ys1) xs $ \ b xs1 ->+                              cons zero b $ recourse xs1 ys1+                    else+                       let xs1 = consTime dt xs+                       in  flip (switchBodyL xs1) ys $ \ b ys1 ->+                              cons zero b $ recourse xs1 ys1+   in  recourse   {- | Note that 'merge' compares entire events rather than just start times.  This is to ensure that it is commutative, a desirable-condition for some of the proofs used in \secref{equivalence}.+condition for some of the proofs used in Haskore/section equivalence. It is also necessary to assert a unique representation-of the performance independent of the structure of the 'Music.T note'.+of the event list independent of the structure of the event type. The same function for inserting into a time ordered list with a trailing pause.-The strictness annotation is necessary for working with infinite lists.--Here are two other functions that are already known for non-padded time lists. -}- insert :: (NonNeg.C time, Ord body) =>    time -> body -> T time body -> T time body insert = insertBy (<)@@ -268,18 +281,19 @@    time -> body -> T time body -> T time body insertBy before t0 me0 =    let recurseTime t =-          switchTimeL (\ t1 xs ->-             if t<t1-               then cons t me0 (consTime (t1-t) xs)-               else recurseBody t1 t xs)-       recurseBody t1 t =-          switchBodyL-             (cons t me0 $ pause 0)-             (\ me1 xs ->-                 consTime t1 $-                    if t==t1 && before me0 me1-                      then consBody me0 (cons 0 me1 xs)-                      else consBody me1 (recurseTime (t-t1) xs))+          switchTimeL $ \ t1 xs0 ->+             let (mt,~(b,dt)) = NonNeg.split t1 t+             in  delay mt $+                 if not b+                   then cons zero me0 $ consTime dt xs0+                   else+                     switchBodyL+                        (cons dt me0 $ pause zero)+                        (\ me1 xs -> consTime zero $+                           if dt==zero && before me0 me1+                             then consBody me0 (cons zero me1 xs)+                             else consBody me1 (recurseTime dt xs))+                        xs0    in   recurseTime t0  @@ -297,7 +311,7 @@ You must make sure, that no event is moved before time zero. This works only for finite lists. -}-moveForward :: (NonNeg.C time) =>+moveForward :: (Ord time, Num time) =>    T time (time, body) -> T time body moveForward =    fromAbsoluteEventList .@@ -311,7 +325,7 @@    foldr       (\t -> cons t Nothing)       (\(t,b) -> insertBy (ltMaybe (\_ _ -> True)) t (Just b))-      (pause 0)+      (pause zero)  {- | Like 'moveForward' but restricts the look-ahead time.@@ -332,7 +346,7 @@ moveForwardRestricted maxTime =    decreaseStart maxTime .    moveBackward .-   mapBody (mapFst (maxTime-)) .+   mapBody (mapFst (maxTime-|)) .    pad maxTime {-    moveForwardRestrictedBy@@ -357,7 +371,7 @@    catMaybes .    foldr       (\t -> cons t Nothing)-      (\(t,b) -> insertBy (ltMaybe cmp) (maxTime-t) (Just b))+      (\(t,b) -> insertBy (ltMaybe cmp) (maxTime-|t) (Just b))       (pause maxTime)  -- | currently only for testing@@ -368,11 +382,11 @@    decreaseStart maxTime .    foldr       delay-      (\(t,b) -> insertBy cmp (maxTime-t) b)+      (\(t,b) -> insertBy cmp (maxTime-|t) b)       (pause maxTime)  -- | currently only for testing-moveForwardRestrictedByQueue :: (NonNeg.C time) =>+moveForwardRestrictedByQueue :: (NonNeg.C time, Num time) =>    (body -> body -> Bool) ->    time -> T time (time, body) -> T time body moveForwardRestrictedByQueue cmp maxTime xs =@@ -399,7 +413,7 @@ -} arrange :: (Ord body, NonNeg.C time) =>    T time (T time body) -> T time body-arrange = arrangeBy (\_ _ -> False)+arrange = arrangeBy (\_ _ -> True)  arrangeBy :: (NonNeg.C time) =>    (body -> body -> Bool) ->@@ -409,16 +423,9 @@    foldr       (\t -> cons t Nothing)       (\xs -> mergeBy (ltMaybe cmp) (mapBody Just xs))-      (pause 0)+      (pause zero)  -{--not lazy enough for @append (2 /. 'a' ./ 4 /. 'b' ./ 2 /. undefined) undefined@--}-append :: (NonNeg.C time) =>-   T time body -> T time body -> T time body-append = mappend- concat :: (NonNeg.C time) =>    [T time body] -> T time body concat = mconcat@@ -433,7 +440,7 @@ -} concatNaive :: (NonNeg.C time) =>    [T time body] -> T time body-concatNaive = List.foldr append (pause 0)+concatNaive = List.foldr append (pause zero)   {- |@@ -446,7 +453,7 @@    (\t0 xs ->        consTime t0 $        BodyTimePriv.cycle $-       BodyTimePriv.mapTimeLast (+t0) xs)+       BodyTimePriv.mapTimeLast (add t0) xs)   cycleNaive :: (NonNeg.C time) =>@@ -472,13 +479,19 @@ splitAtTime t0 =    switchTimeL    (\t1 xs ->-        if t0<=t1-          then (pause t0, consTime (t1-t0) xs)-          else-             switchBodyL-                (pause t1, pause 0)-                (\ b -> mapFst (cons t1 b) . splitAtTime (t0-t1))-                xs)+      let (mt,~(bef,dt)) = NonNeg.split t0 t1+      in  {-+          The handling of the second pair member looks a bit cumbersome,+          but it is necessary to prepend the time once+          in order to prevent a memory leak.+          -}+          mapPair (consTime mt, forceTimeHead) $+          if bef+            then (mempty, consTime dt xs)+            else switchBodyL+                    (mempty, pause zero)+                    (\ b -> mapFst (consBody b) . splitAtTime dt)+                    xs)  takeTime :: (NonNeg.C time) =>    time -> T time body -> T time body@@ -486,13 +499,42 @@  dropTime :: (NonNeg.C time) =>    time -> T time body -> T time body-dropTime t = snd . splitAtTime t+-- dropTime t = snd . splitAtTime t+dropTime t0 =+   switchTimeL+   (\t1 xs ->+      let (bef,dt) = snd $ NonNeg.split t0 t1+      in  forceTimeHead $+          if bef+            then consTime dt xs+            else switchBodyL+                    (pause zero)+                    (\ _b -> dropTime dt)+                    xs) +{-+Surprisingly this has a space leak,+see test dropTimeLazyInfinite. +dropTime :: (NonNeg.C time) =>+   time -> T time body -> T time body+dropTime t0 =+   switchTimeL+   (\t1 xs ->+      let (bef,dt) = snd $ NonNeg.split t0 t1+      in  if bef+            then consTime dt xs+            else switchBodyL+                    (pause zero)+                    (\ _b -> dropTime dt)+                    xs)+-}++ decreaseStart :: (NonNeg.C time) =>    time -> T time body -> T time body decreaseStart dif =-   mapTimeHead (subtract dif)+   mapTimeHead (-| dif)   collectCoincident :: (NonNeg.C time) => T time body -> T time [body]@@ -514,12 +556,12 @@ from the beginning to the end. -} -filter :: (Num time) =>+filter :: (NonNeg.C time) =>    (body -> Bool) ->    T time body -> T time body filter p = mapMaybe (\b -> toMaybe (p b) b) -mapMaybe :: (Num time) =>+mapMaybe :: (NonNeg.C time) =>    (body0 -> Maybe body1) ->    T time body0 -> T time body1 mapMaybe f = catMaybes . mapBody f@@ -528,48 +570,50 @@ Adds times in a left-associative fashion. Use this if the time is a strict data type. -}-catMaybes :: (Num time) =>+catMaybes :: (NonNeg.C time) =>    T time (Maybe body) -> T time body-catMaybes = mapTime sum . lift Uniform.catMaybesFirst+catMaybes = mapTime NonNeg.sum . lift Uniform.catMaybesFirst  {- | Adds times in a right-associative fashion. Use this if the time is a data type like lazy Peano numbers or "Numeric.NonNegative.Chunky". -}-catMaybesR :: (Num time) =>+catMaybesR :: (NonNeg.C time) =>    T time (Maybe body) -> T time body catMaybesR =    foldr-      (mapTimeHead . (+))-      (maybe id (cons 0))-      (pause 0)+      (mapTimeHead . add)+      (maybe id (cons zero))+      (pause zero) -partition :: (Num time) =>+partition :: (NonNeg.C time) =>    (body -> Bool) ->    T time body -> (T time body, T time body) partition p =-   mapPair (mapTime sum, mapTime sum) .+   mapPair (mapTime NonNeg.sum, mapTime NonNeg.sum) .    mapPair (Cons, Cons) .    Uniform.partitionFirst p .    decons -partitionMaybe :: (Num time) =>+partitionMaybe :: (NonNeg.C time) =>    (body0 -> Maybe body1) -> T time body0 ->    (T time body1, T time body0) partitionMaybe f =-   mapPair (mapTime sum . Cons, mapTime sum . Cons) .+   mapPair (mapTime NonNeg.sum . Cons, mapTime NonNeg.sum . Cons) .    Uniform.partitionMaybeFirst f .    decons  {- | Cf. 'catMaybesR' -}-partitionMaybeR :: (Num time) =>+partitionMaybeR :: (NonNeg.C time) =>    (body0 -> Maybe body1) -> T time body0 ->    (T time body1, T time body0) partitionMaybeR f =-   mapPair (mapTime (List.foldr (+) 0), mapTime (List.foldr (+) 0)) .+   mapPair+      (mapTime (List.foldr add zero),+       mapTime (List.foldr add zero)) .    mapPair (Cons, Cons) .    Uniform.partitionMaybeFirst f .    decons@@ -578,13 +622,10 @@ Since we need it later for MIDI generation, we will also define a slicing into equivalence classes of events. -}-slice :: (Eq a, Num time) =>+slice :: (Eq a, NonNeg.C time) =>    (body -> a) -> T time body -> [(a, T time body)] slice = Utility.slice (fmap fst . viewBodyL . snd . viewTimeL) partition --foldr :: (time -> a -> b) -> (body -> b -> a) -> a -> T time body -> b-foldr f g x = Uniform.foldr g f x . decons  foldl :: (a -> time -> b) -> (b -> body -> a) -> a -> T time body -> b foldl f g x = Uniform.foldl g f x . decons
src/Data/EventList/Relative/TimeTimePrivate.hs view
@@ -20,6 +20,7 @@ import qualified Data.AlternatingList.List.Mixed as Mixed  import qualified Numeric.NonNegative.Class as NonNeg+import Numeric.NonNegative.Class (zero, add, )  import Data.Tuple.HT (mapFst, mapSnd, ) @@ -29,9 +30,11 @@ import qualified Control.Applicative as App import Control.Applicative (Applicative, ) import Data.Monoid (Monoid, mempty, mappend, mconcat, )+import Data.Semigroup (Semigroup, (<>), ) -import Test.QuickCheck (Arbitrary(arbitrary))+import Test.QuickCheck (Arbitrary(arbitrary, shrink)) +import Prelude hiding (foldr, )   newtype T time body = Cons {decons :: Uniform.T body time}@@ -44,18 +47,50 @@ instance (Arbitrary time, Arbitrary body) =>              Arbitrary (T time body) where    arbitrary = Monad.liftM Cons arbitrary+   shrink = liftM shrink  +instance (NonNeg.C time) => Semigroup (T time body) where+   (<>) = append+ instance (NonNeg.C time) => Monoid (T time body) where-   mempty = Cons (Uniform.singleton 0)-   mappend =-      switchTimeR-      (\ xs t -> lift (Mixed.appendDisparateUniform $~* xs) . delay t)+   mempty = Cons (Uniform.singleton zero)+   mappend = (<>)    mconcat =-      flatten . consTime 0 .+      flatten . consTime zero .       mconcat .       map (consBody [] . fmap (:[])) +append, appendAlt, appendSwitch ::+   (NonNeg.C time) =>+   T time body -> T time body -> T time body+append xs ys =+   forceTimeHead $+   foldr+      delay+      (\b ->+         consTime NonNeg.zero .+         consBody b)+      ys xs++appendAlt xs ys =+   foldr+      (\t ->+         delay t .+         either id (consTime NonNeg.zero))+      (\b -> Right . consBody b)+      (Left ys) xs++{-+not lazy enough for @append (2 /. 'a' ./ 4 /. 'b' ./ 2 /. undefined) undefined@+-}+appendSwitch =+   switchTimeR+      (\ xs t ->+         lift (Mixed.appendDisparateUniform $~* xs) .+         delay t)++ instance Functor (T time) where    fmap f (Cons x) = Cons (Uniform.mapFirst f x) @@ -154,6 +189,8 @@    switchTimeL (\time -> consTime time . f) {- This causes a memory leak when used with chunky time values.+I have found this problem in synthesizer-alsa:EventList.MIDI.matchNote,+but I could not reliably reproduce that in smaller setups.  mapTimeTail =    lift . Mixed.mapSecondTail . BodyTimePriv.unlift@@ -176,19 +213,27 @@ mapTimeInit = lift . Mixed.mapSecondInit . TimeBodyPriv.unlift  +foldr :: (time -> a -> b) -> (body -> b -> a) -> a -> T time body -> b+foldr f g x = Uniform.foldr g f x . decons++forceTimeHead :: (NonNeg.C time) =>+   T time body -> T time body+forceTimeHead =+   mapTimeHead id+ delay :: (NonNeg.C time) =>    time -> T time body -> T time body delay dif =-   mapTimeHead (dif+)+   mapTimeHead (add dif) -flatten :: (Num time) => T time [body] -> T time body+flatten :: (NonNeg.C time) => T time [body] -> T time body flatten =    Cons .    Uniform.foldr-      (Mixed.appendUniformUniform . Uniform.fromSecondList 0)+      (Mixed.appendUniformUniform . Uniform.fromSecondList zero)       Mixed.consSecond    -- consTime       Disp.empty . --      (\(b:bs) xs -> consBody b (List.foldr (cons 0) xs bs)) empty .-   Uniform.mapSecond sum .+   Uniform.mapSecond NonNeg.sum .    Uniform.filterFirst (not . null) .    decons
src/Data/EventList/Utility.hs view
@@ -37,7 +37,7 @@  beforeBy :: (Ord time) =>    (body -> body -> Bool) ->-   (time, body) -> (time, body) ->  Bool+   (time, body) -> (time, body) -> Bool beforeBy before (t0, me0) (t1, me1) =    case compare t0 t1 of       LT -> True
src/Test/Data/EventList/Absolute/BodyEnd.hs view
@@ -24,7 +24,6 @@  import qualified Numeric.NonNegative.Class as NonNeg import Data.Tuple.HT (mapFst, mapSnd, mapPair, )-import qualified Control.Monad as Monad import Control.Monad.Trans.State (state, evalState, )  import Prelude hiding (filter, concat)@@ -38,19 +37,22 @@  infixl 4 ==~ -(==~) :: (Eq body, Num time) =>+(==~) :: (Eq body, NonNeg.C time, Num time) =>    AbsBody.T time body -> RelBody.T time body -> Bool (==~) xs ys =    xs == RelBody.toAbsoluteEventList 0 ys   -duration :: Num time => RelBody.T time body -> Bool+duration ::+   (NonNeg.C time, Num time) =>+   RelBody.T time body -> Bool duration xs =    AbsBody.duration $~ xs == RelBody.duration xs  -mapBody :: (Eq body1, Num time) =>+mapBody ::+   (Eq body1, NonNeg.C time, Num time) =>    (body0 -> body1) -> RelBody.T time body0 -> Bool mapBody f xs =    AbsBody.mapBody f $~ xs ==~ RelBody.mapBody f xs@@ -58,7 +60,7 @@   mapBodyM ::-   (Monad m, Eq body1, NonNeg.C time) =>+   (Monad m, Eq body1, NonNeg.C time, Num time) =>    (m (AbsBody.T time body1) -> AbsBody.T time body1) ->    (body0 -> m body1) -> RelBody.T time body0 -> Bool mapBodyM run f xs =@@ -66,7 +68,7 @@    run (liftM (RelBody.toAbsoluteEventList 0) (RelBody.mapBodyM f xs))  mapBodyMRandom ::-   (NonNeg.C time, Random body, Eq body) =>+   (NonNeg.C time, Num time, Random body, Eq body) =>    Int -> RelBody.T time (body, body) -> Bool mapBodyMRandom seed =    mapBodyM @@ -74,7 +76,7 @@       (state . randomR)  -filter :: (Eq body, Num time) =>+filter :: (Eq body, NonNeg.C time, Num time) =>    (body -> Bool) -> RelBody.T time body -> Bool filter p xs =    AbsBody.filter p $~ xs ==~ RelBody.filter p xs@@ -86,7 +88,7 @@ mapMaybe f = catMaybes . mapBody f -} -catMaybes :: (Eq body, Num time) =>+catMaybes :: (Eq body, NonNeg.C time, Num time) =>    RelBody.T time (Maybe body) -> Bool catMaybes xs =    AbsBody.catMaybes $~ xs ==~ RelBody.catMaybes xs@@ -94,7 +96,7 @@ {- Could be implemented more easily in terms of Uniform.partition -}-partition :: (Eq body, Num time) =>+partition :: (Eq body, NonNeg.C time, Num time) =>    (body -> Bool) -> RelBody.T time body -> Bool partition p xs =    AbsBody.partition p $~ xs ==@@ -106,32 +108,33 @@ Since we need it later for MIDI generation, we will also define a slicing into equivalence classes of events. -}-slice :: (Eq a, Eq body, Num time) =>+slice :: (Eq a, Eq body, NonNeg.C time, Num time) =>    (body -> a) -> RelBody.T time body -> Bool slice f xs =    AbsBody.slice f $~ xs ==    map (mapSnd (RelBody.toAbsoluteEventList 0)) (RelBody.slice f xs)  -collectCoincident :: (NonNeg.C time, Eq body) =>+collectCoincident :: (Eq body, NonNeg.C time, Num time) =>    RelBody.T time body -> Bool collectCoincident xs =    AbsBody.collectCoincident $~ xs ==~    RelBody.collectCoincident xs -collectCoincidentFoldr :: (NonNeg.C time, Eq body) =>+collectCoincidentFoldr :: (Eq body, NonNeg.C time, Num time) =>    RelBody.T time body -> Bool collectCoincidentFoldr xs =    AbsBody.collectCoincident $~ xs ==    AbsBody.collectCoincidentFoldr $~ xs -collectCoincidentNonLazy :: (NonNeg.C time, Eq body) =>+collectCoincidentNonLazy :: (Eq body, NonNeg.C time, Num time) =>    RelBody.T time body -> Bool collectCoincidentNonLazy xs =    AbsBody.collectCoincident $~ xs ==    AbsBody.collectCoincidentNonLazy $~ xs -collectCoincidentInfinite :: (NonNeg.C time, Eq body) =>+collectCoincidentInfinite ::+   (Eq body, NonNeg.C time, Num time) =>    NonEmptyList time body -> Bool collectCoincidentInfinite =    checkInfinite .@@ -139,38 +142,38 @@    makeUncollapsedInfiniteEventList  -flatten :: (NonNeg.C time, Eq body) =>+flatten :: (Eq body, NonNeg.C time, Num time) =>    RelBody.T time [body] -> Bool flatten xs =    AbsBody.flatten $~ xs  ==~  RelBody.flatten xs  -normalize :: (NonNeg.C time, Ord body) =>+normalize :: (Ord body, NonNeg.C time, Num time) =>    RelBody.T time body -> Bool normalize xs =    AbsBody.normalize $~ xs  ==~  RelBody.normalize xs  -merge :: (NonNeg.C time, Ord body) =>+merge :: (Ord body, NonNeg.C time, Num time) =>    RelBody.T time body -> RelBody.T time body -> Bool merge xs ys =    AbsBody.merge $~ xs $~ ys  ==~  RelBody.merge xs ys  -insert :: (NonNeg.C time, Ord body) =>+insert :: (Ord body, NonNeg.C time, Num time) =>    time -> body -> RelBody.T time body -> Bool insert t b xs =    AbsBody.insert t b $~ xs  ==~  RelBody.insert t b xs   -append :: (NonNeg.C time, Eq body) =>+append :: (Eq body, NonNeg.C time, Num time) =>    RelBody.T time body -> RelBody.T time body -> Bool append xs ys =    AbsBody.append $~ xs $~ ys  ==~    RelBody.append xs ys -concat :: (NonNeg.C time, Eq body) =>+concat :: (Eq body, NonNeg.C time, Num time) =>    [RelBody.T time body] -> Bool concat xs =    AbsBody.concat (map (RelBody.toAbsoluteEventList 0) xs)  ==~@@ -184,7 +187,7 @@ -}  -decreaseStart :: (NonNeg.C time, Eq body) =>+decreaseStart :: (Eq body, NonNeg.C time, Num time) =>    time -> time -> RelBody.T time body -> Bool decreaseStart dif0 dif1 xs0 =    let difA = min dif0 dif1@@ -194,7 +197,7 @@        RelBody.decreaseStart difA xs  -delay :: (NonNeg.C time, Eq body) =>+delay :: (Eq body, NonNeg.C time, Num time) =>    time -> RelBody.T time body -> Bool delay dif xs =    AbsBody.delay dif $~ xs  ==~@@ -243,13 +246,15 @@  type NonEmptyList time body = ((time, body), RelBody.T time body) -makeUncollapsedInfiniteEventList :: (NonNeg.C time) =>+makeUncollapsedInfiniteEventList ::+   (NonNeg.C time, Num time) =>    NonEmptyList time body -> AbsBody.T time body makeUncollapsedInfiniteEventList =    makeInfiniteEventList .    mapFst (mapFst (1+)) -makeInfiniteEventList :: (NonNeg.C time) =>+makeInfiniteEventList ::+   (NonNeg.C time, Num time) =>    NonEmptyList time body -> AbsBody.T time body makeInfiniteEventList =    RelBody.toAbsoluteEventList 0 . RelBody.cycle . makeNonEmptyEventList
src/Test/Data/EventList/Absolute/TimeEnd.hs view
@@ -24,7 +24,6 @@  import qualified Numeric.NonNegative.Class as NonNeg import Data.Tuple.HT (mapFst, mapSnd, mapPair, )-import qualified Control.Monad as Monad import Control.Monad.Trans.State (state, evalState)  import Prelude hiding (filter, concat)@@ -38,19 +37,21 @@  infixl 4 ==~ -(==~) :: (Eq body, Num time) =>+(==~) :: (Eq body, Eq time, Num time) =>    AbsTime.T time body -> RelTime.T time body -> Bool (==~) xs ys =    xs == RelTime.toAbsoluteEventList 0 ys   -duration :: Num time => RelTime.T time body -> Bool+duration ::+   (NonNeg.C time, Num time) =>+   RelTime.T time body -> Bool duration xs =    AbsTime.duration $~ xs == RelTime.duration xs  -mapBody :: (Eq body1, Num time) =>+mapBody :: (Eq body1, NonNeg.C time, Num time) =>    (body0 -> body1) -> RelTime.T time body0 -> Bool mapBody f xs =    AbsTime.mapBody f $~ xs ==~ RelTime.mapBody f xs@@ -58,7 +59,7 @@   mapBodyM ::-   (Monad m, Eq body1, NonNeg.C time) =>+   (Monad m, Eq body1, NonNeg.C time, Num time) =>    (m (AbsTime.T time body1) -> AbsTime.T time body1) ->    (body0 -> m body1) -> RelTime.T time body0 -> Bool mapBodyM run f xs =@@ -66,7 +67,7 @@    run (liftM (RelTime.toAbsoluteEventList 0) (RelTime.mapBodyM f xs))  mapBodyMRandom ::-   (NonNeg.C time, Random body, Eq body) =>+   (NonNeg.C time, Num time, Random body, Eq body) =>    Int -> RelTime.T time (body, body) -> Bool mapBodyMRandom seed =    mapBodyM @@ -74,19 +75,19 @@       (state . randomR)  -filter :: (Eq body, Num time) =>+filter :: (Eq body, NonNeg.C time, Num time) =>    (body -> Bool) -> RelTime.T time body -> Bool filter p xs =    AbsTime.filter p $~ xs ==~ RelTime.filter p xs  {--mapMaybe :: (Num time) =>+mapMaybe :: (NonNeg.C time, Num time) =>    (body0 -> Maybe body1) ->    RelTime.T time body0 -> RelTime.T time body1 mapMaybe f = catMaybes . mapBody f -} -catMaybes :: (Eq body, Num time) =>+catMaybes :: (Eq body, NonNeg.C time, Num time) =>    RelTime.T time (Maybe body) -> Bool catMaybes xs =    AbsTime.catMaybes $~ xs ==~ RelTime.catMaybes xs@@ -94,7 +95,7 @@ {- Could be implemented more easily in terms of Uniform.partition -}-partition :: (Eq body, Num time) =>+partition :: (Eq body, NonNeg.C time, Num time) =>    (body -> Bool) -> RelTime.T time body -> Bool partition p xs =    AbsTime.partition p $~ xs ==@@ -106,20 +107,20 @@ Since we need it later for MIDI generation, we will also define a slicing into equivalence classes of events. -}-slice :: (Eq a, Eq body, Num time) =>+slice :: (Eq a, Eq body, NonNeg.C time, Num time) =>    (body -> a) -> RelTime.T time body -> Bool slice f xs =    AbsTime.slice f $~ xs ==    map (mapSnd (RelTime.toAbsoluteEventList 0)) (RelTime.slice f xs)  -collectCoincident :: (NonNeg.C time, Eq body) =>+collectCoincident :: (NonNeg.C time, Num time, Eq body) =>    RelTime.T time body -> Bool collectCoincident xs =    AbsTime.collectCoincident $~ xs ==~    RelTime.collectCoincident xs -collectCoincidentInfinite :: (NonNeg.C time, Eq body) =>+collectCoincidentInfinite :: (NonNeg.C time, Num time, Eq body) =>    NonEmptyList time body -> Bool collectCoincidentInfinite =    checkInfinite .@@ -127,38 +128,48 @@    makeUncollapsedInfiniteEventList  -flatten :: (NonNeg.C time, Eq body) =>+flatten :: (NonNeg.C time, Num time, Eq body) =>    RelTime.T time [body] -> Bool flatten xs =    AbsTime.flatten $~ xs  ==~  RelTime.flatten xs  -normalize :: (NonNeg.C time, Ord body) =>+normalize :: (NonNeg.C time, Num time, Ord body) =>    RelTime.T time body -> Bool normalize xs =    AbsTime.normalize $~ xs  ==~  RelTime.normalize xs  -merge :: (NonNeg.C time, Ord body) =>+{-+test fails++1 /. '\DEL' ./ 0 /. '"' ./ 1 /. '}' ./ 0 /. empty+0 /. '\DEL' ./ 1 /. '}' ./ 0 /. '\DEL' ./ 1 /. empty+++4 /. '|' ./ 0 /. '!' ./ 3 /. '"' ./ 1 /. '!' ./ 3 /. empty+1 /. '$' ./ 2 /. '~' ./ 1 /. '|' ./ 1 /. '|' ./ 1 /. empty+-}+merge :: (NonNeg.C time, Num time, Ord body) =>    RelTime.T time body -> RelTime.T time body -> Bool merge xs ys =    AbsTime.merge $~ xs $~ ys  ==~  RelTime.merge xs ys  -insert :: (NonNeg.C time, Ord body) =>+insert :: (NonNeg.C time, Num time, Ord body) =>    time -> body -> RelTime.T time body -> Bool insert t b xs =    AbsTime.insert t b $~ xs  ==~  RelTime.insert t b xs   -append :: (NonNeg.C time, Eq body) =>+append :: (NonNeg.C time, Num time, Eq body) =>    RelTime.T time body -> RelTime.T time body -> Bool append xs ys =    AbsTime.append $~ xs $~ ys  ==~    RelTime.append xs ys -concat :: (NonNeg.C time, Eq body) =>+concat :: (NonNeg.C time, Num time, Eq body) =>    [RelTime.T time body] -> Bool concat xs =    AbsTime.concat (map (RelTime.toAbsoluteEventList 0) xs)  ==~@@ -172,7 +183,7 @@ -}  -decreaseStart :: (NonNeg.C time, Eq body) =>+decreaseStart :: (NonNeg.C time, Num time, Eq body) =>    time -> time -> RelTime.T time body -> Bool decreaseStart dif0 dif1 xs0 =    let difA = min dif0 dif1@@ -182,7 +193,7 @@        RelTime.decreaseStart difA xs  -delay :: (NonNeg.C time, Eq body) =>+delay :: (NonNeg.C time, Num time, Eq body) =>    time -> RelTime.T time body -> Bool delay dif xs =    AbsTime.delay dif $~ xs  ==~@@ -197,20 +208,18 @@        I add a small amount to the numerator in order        to prevent the case of a fraction like 10.5,        which can be easily rounded to 10 or 11-       depending to previous rounding errors.+       depending on previous rounding errors.        -}        xs = RelTime.mapTime ((1e-6 +) . makeFracTime) xs0        rate = timeToDouble rateInt + 1    in  AbsTime.resample rate $~ xs ==~-       (RelTime.resample rate xs `asTypeOf`-           RelTime.pause (undefined::TimeDiff))+       intTimeList (RelTime.resample rate xs)  resampleInfinite :: (Eq body) =>    TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) body -> Bool resampleInfinite rateInt =    let rate = timeToDouble rateInt + 1-   in  checkInfinite .-       (`asTypeOf` AbsTime.pause (undefined::TimeDiff)) .+   in  checkInfinite . intTimeList .        AbsTime.resample rate .        makeInfiniteEventList .        mapPair (mapFst makeFracTime, RelTime.mapTime makeFracTime)@@ -219,18 +228,18 @@  type NonEmptyList time body = ((time, body), RelTime.T time body) -makeUncollapsedInfiniteEventList :: (NonNeg.C time) =>+makeUncollapsedInfiniteEventList :: (NonNeg.C time, Num time) =>    NonEmptyList time body -> AbsTime.T time body makeUncollapsedInfiniteEventList =    makeInfiniteEventList .    mapFst (mapFst (1+)) -makeInfiniteEventList :: (NonNeg.C time) =>+makeInfiniteEventList :: (NonNeg.C time, Num time) =>    NonEmptyList time body -> AbsTime.T time body makeInfiniteEventList =    RelTime.toAbsoluteEventList 0 . RelTime.cycle . makeNonEmptyEventList -makeNonEmptyEventList :: (NonNeg.C time) =>+makeNonEmptyEventList :: (NonNeg.C time, Num time) =>    NonEmptyList time body -> RelTime.T time body makeNonEmptyEventList (p, evs) =    uncurry RelTime.cons p evs
src/Test/Data/EventList/Relative/BodyEnd.hs view
@@ -21,16 +21,17 @@  import Data.EventList.Relative.MixedBody ((/.), (./), empty) +import qualified Numeric.NonNegative.Chunky as NonNegChunky import qualified Numeric.NonNegative.Class as NonNeg-import Numeric.NonNegative.Class ((-|))+import Numeric.NonNegative.Class ((-|), zero, add, ) import Data.EventList.Relative.TimeBody (isNormalized)  import Data.Tuple.HT (mapFst, mapPair, )+import Data.Bool.HT (implies, ) import System.Random (Random, randomR, mkStdGen, ) import Control.Monad.Trans.State (state, evalState, gets, modify, ) import Control.Monad (liftM2) import Data.Maybe (isJust)-import qualified Data.List as List   @@ -174,6 +175,25 @@ appendSplitAtTime t xs =    xs == uncurry TimeMixedList.appendBodyEnd (TimeMixedList.splitAtTime t xs) +appendSplitAfterTime :: (NonNeg.C time, Eq body) =>+   time -> TimeBodyList.T time body -> Bool+appendSplitAfterTime t xs =+   xs == uncurry TimeMixedList.appendBodyEnd (TimeMixedList.splitAfterTime t xs)++nonZeroTakeTime :: (NonNeg.C time, Eq body) =>+   time -> TimeBodyList.T time body -> Bool+nonZeroTakeTime t xs =+   NonNeg.zero < t && t < TimeBodyList.duration xs+   `implies`+   (TimeMixedList.switchTimeR (\_ t0 -> t0 > NonNeg.zero) $+      TimeMixedList.takeTime t xs)++nonZeroDropAfterTime :: (NonNeg.C time, Eq body) =>+   time -> TimeBodyList.T time body -> Bool+nonZeroDropAfterTime t xs =+   MixedBodyList.switchTimeL True (\t0 _ -> t0 > NonNeg.zero) $+      TimeMixedList.dropAfterTime t xs+ mapBodyAppend :: (Eq body1, NonNeg.C time) =>    (body0 -> body1) -> TimeBodyList.T time body0 -> TimeBodyList.T time body0 -> Bool mapBodyAppend f xs ys =@@ -208,7 +228,7 @@ delayAdditive :: (NonNeg.C time, Eq body) =>    time -> time -> TimeBodyList.T time body -> Bool delayAdditive dif0 dif1 xs =-   TimeBodyList.delay (dif0+dif1) xs ==+   TimeBodyList.delay (add dif0 dif1) xs ==    TimeBodyList.delay dif0 (TimeBodyList.delay dif1 xs)  delayAppendPause :: (NonNeg.C time, Eq body) =>@@ -234,9 +254,9 @@ takeTimeEndPause :: (NonNeg.C time, Ord body) =>    time -> TimeBodyList.T time body -> Bool takeTimeEndPause t xs =-   t == 0 ||+   t == zero ||    t >= TimeBodyList.duration xs ||-   0 <  snd (TimeMixedList.viewTimeR (TimeMixedList.takeTime t xs))+   zero <  snd (TimeMixedList.viewTimeR (TimeMixedList.takeTime t xs))  takeTimeAppendFirst :: (NonNeg.C time, Eq body) =>    time -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool@@ -246,12 +266,12 @@       (TimeMixedList.takeTime t xs)       (TimeMixedList.takeTime (t -| TimeBodyList.duration xs) ys) -takeTimeAppendSecond :: (NonNeg.C time, Eq body) =>+takeTimeAppendSecond :: (NonNeg.C time, Num time, Eq body) =>    time -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool takeTimeAppendSecond t xs ys0 =    -- the second list must not start with a zero pause    let ys = TimeBodyList.delay 1 ys0-       t1 = t+1+       t1 = add t 1    in  TimeMixedList.takeTime (TimeBodyList.duration xs + t1) (TimeBodyList.append xs ys) ==        TimeMixedList.prependBodyEnd xs (TimeMixedList.takeTime t1 ys) @@ -265,26 +285,43 @@ dropTimeNormalize t =    isNormalized . TimeMixedList.dropTime t . TimeBodyList.normalize -takeTimeInfinite :: (NonNeg.C time, Ord body) =>+takeTimeInfinite :: (NonNeg.C time, Num time, Ord body) =>    time -> NonEmptyList time body -> Bool takeTimeInfinite t =    (t == ) . TimeTimeList.duration .    TimeMixedList.takeTime t . makeUncollapsedInfiniteEventList -dropTimeInfinite :: (NonNeg.C time, Ord body) =>+dropTimeInfinite :: (NonNeg.C time, Num time, Ord body) =>    time -> NonEmptyList time body -> Bool dropTimeInfinite t =    checkInfinite . TimeMixedList.dropTime t . makeUncollapsedInfiniteEventList +_splitAtTimeLazyInfinite ::+   (NonNeg.C time, Num time, Ord body, Show time, Show body) =>+   BodyBodyList.T (NonNegChunky.T time) body -> Bool+_splitAtTimeLazyInfinite =+   not . null . show . snd .+   TimeMixedList.splitAtTime 1000000 .+   MixedBodyList.consTime+      (NonNegChunky.fromChunks $ iterate (2-) 1) +_dropTimeLazyInfinite ::+   (NonNeg.C time, Num time, Ord body, Show time, Show body) =>+   BodyBodyList.T (NonNegChunky.T time) body -> Bool+_dropTimeLazyInfinite =+   not . null . show .+   TimeMixedList.dropTime 1000000 .+   MixedBodyList.consTime+      (NonNegChunky.fromChunks $ iterate (2-) 1)  + durationPause :: (NonNeg.C time) =>    time -> Bool durationPause t =    t == TimeBodyList.duration (TimeBodyList.singleton t (error "durationPause: no need to access body")) -durationAppend :: (NonNeg.C time) =>+durationAppend :: (NonNeg.C time, Num time) =>    TimeBodyList.T time body -> TimeBodyList.T time body -> Bool durationAppend xs ys =    TimeBodyList.duration (TimeBodyList.append xs ys)  ==@@ -323,20 +360,20 @@    in  equalPrefix 100 xs (TimeBodyList.cycle xs)  -filterSatisfy :: (Num time) =>+filterSatisfy :: (NonNeg.C time) =>    (body -> Bool) ->    TimeBodyList.T time body -> Bool filterSatisfy p =    all p . TimeBodyList.getBodies . TimeBodyList.filter p -filterProjection :: (Num time, Eq body) =>+filterProjection :: (NonNeg.C time, Eq body) =>    (body -> Bool) ->    TimeBodyList.T time body -> Bool filterProjection p xs =    TimeBodyList.filter p xs ==    TimeBodyList.filter p (TimeBodyList.filter p xs) -filterCommutative :: (Num time, Eq body) =>+filterCommutative :: (NonNeg.C time, Eq body) =>    (body -> Bool) ->    (body -> Bool) ->    TimeBodyList.T time body -> Bool@@ -344,7 +381,7 @@    TimeBodyList.filter p (TimeBodyList.filter q xs) ==    TimeBodyList.filter q (TimeBodyList.filter p xs) -filterComposition :: (Num time, Eq body) =>+filterComposition :: (NonNeg.C time, Eq body) =>    (body -> Bool) ->    (body -> Bool) ->    TimeBodyList.T time body -> Bool@@ -503,6 +540,12 @@    TimeBodyList.insert time0 body0 (TimeBodyList.insert time1 body1 evs)  ==    TimeBodyList.insert time1 body1 (TimeBodyList.insert time0 body0 evs) +{-+Relative.BodyEnd.insert merge: Falsifiable, after 12 tests:+2+'}'+1 /. '%' ./ 1 /. '}' ./ 0 /. ' ' ./ 5 /. 'z' ./ 5 /. '\'' ./ 2 /. '\DEL' ./ 2 /. 'x' ./ 3 /. '\DEL' ./ empty+-} insertMerge :: (NonNeg.C time, Ord body) =>    time -> body -> TimeBodyList.T time body -> Bool insertMerge time body evs =@@ -523,7 +566,7 @@    ==       let (prefix,suffix) = TimeMixedList.splitAtTime time evs       in  TimeBodyList.normalize (TimeMixedList.appendBodyEnd prefix-             (MixedBodyList.consTime 0 (MixedBodyList.consBody body suffix)))+             (MixedBodyList.consTime zero (MixedBodyList.consBody body suffix)))  insertInfinite :: (NonNeg.C time, Ord body) =>    time -> body -> NonEmptyList time body -> Bool@@ -532,21 +575,21 @@   -moveForwardIdentity :: (NonNeg.C time, Ord body) =>+moveForwardIdentity :: (NonNeg.C time, Num time, Ord body) =>    TimeBodyList.T time body -> Bool moveForwardIdentity evs =    evs ==-   TimeBodyList.moveForward (TimeBodyList.mapBody ((,) 0) evs)+   TimeBodyList.moveForward (TimeBodyList.mapBody ((,) zero) evs) -moveForwardAdditive :: (NonNeg.C time, Ord body) =>+moveForwardAdditive :: (NonNeg.C time, Num time, Ord body) =>    TimeBodyList.T time ((time,time),body) -> Bool moveForwardAdditive evs =    TimeBodyList.normalize (moveForwardLimited (moveForwardLimited       (TimeBodyList.mapBody (\((t0,t1),b) -> (t0,(t1,b))) evs))) ==    TimeBodyList.normalize (moveForwardLimited-      (TimeBodyList.mapBody (mapFst (uncurry (+))) evs))+      (TimeBodyList.mapBody (mapFst (uncurry add)) evs)) -moveForwardCommutative :: (NonNeg.C time, Ord body) =>+moveForwardCommutative :: (NonNeg.C time, Num time, Ord body) =>    TimeBodyList.T time ((time,time),body) -> Bool moveForwardCommutative evs =    TimeBodyList.normalize (moveForwardLimited (moveForwardLimited@@ -575,16 +618,16 @@ -}  -moveForwardLimited :: (NonNeg.C time) =>+moveForwardLimited :: (NonNeg.C time, Num time) =>    TimeBodyList.T time (time,body) -> TimeBodyList.T time body moveForwardLimited = TimeBodyList.moveForward . restrictMoveTimes  restrictMoveTimes :: (NonNeg.C time) =>    TimeBodyList.T time (time,body) -> TimeBodyList.T time (time,body) restrictMoveTimes =-   flip evalState 0 .+   flip evalState zero .    TimeBodyList.mapM-      (\t -> modify (t+) >> return t)+      (\t -> modify (add t) >> return t)       (\(t,b) -> gets (\tm -> (min t tm, b)))  @@ -619,14 +662,14 @@    TimeBodyList.T time body -> Bool collectCoincidentGaps xs =    let times = TimeBodyList.getTimes (TimeBodyList.collectCoincident xs)-   in  null times || all (0<) (tail times)+   in  null times || all (zero<) (tail times)  collectCoincidentNonEmpty :: (NonNeg.C time, Eq body) =>    TimeBodyList.T time body -> Bool collectCoincidentNonEmpty =    all (not . null) . TimeBodyList.getBodies . TimeBodyList.collectCoincident -collectCoincidentInfinite :: (NonNeg.C time, Eq body) =>+collectCoincidentInfinite :: (NonNeg.C time, Num time, Eq body) =>    NonEmptyList time body -> Bool collectCoincidentInfinite =    checkInfinite .@@ -720,7 +763,7 @@    EventList.insert time body (fst evs)  ==  fst (insert time body evs) -} -appendSingle :: -- (Num time, Ord time, Ord body) =>+appendSingle :: -- (NonNeg.C time, Ord time, Ord body) =>    body -> TimeBodyList.T time body -> EventList.T time body appendSingle body xs =    Disp.foldr EventList.consTime EventList.consBody EventList.empty $@@ -742,20 +785,30 @@ discretize :: (RealFrac time, Integral i) =>    TimeBodyList.T time body -> TimeBodyList.T i body discretize es =-   evalState (Uniform.mapSecondM roundDiff es) 0+   evalState (Uniform.mapSecondM roundDiff es) zero  resample :: (RealFrac time, Integral i) =>    time -> TimeBodyList.T time body -> TimeBodyList.T i body resample rate es =    discretize (mapTime (rate*) es)+-} +resampleInfinite :: (Eq body) =>+   TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) body -> Bool+resampleInfinite rateInt =+   let rate = timeToDouble rateInt + 1+   in  checkInfinite . intTimeList . TimeBodyList.resample rate .+       makeInfiniteEventList .+       mapPair (mapFst makeFracTime, TimeBodyList.mapTime makeFracTime) ++{- toAbsoluteEventList :: (Num time) =>    time -> TimeBodyList.T time body -> AbsoluteEventList.T time body toAbsoluteEventList start xs =    let ts = Uniform.getSeconds xs        bs = Uniform.getFirsts  xs-       ats = List.scanl (+) start ts+       ats = List.scanl add start ts    in  maybe           (error "padded list always contains one time value")           (\ ~(ats0,lt) -> (zip ats0 bs, lt))@@ -765,13 +818,14 @@   -type NonEmptyList time body = (time, body, TimeBodyList.T time body)+type NonEmptyList time body = ((time, body), TimeBodyList.T time body) -makeUncollapsedInfiniteEventList :: (NonNeg.C time) =>+makeUncollapsedInfiniteEventList ::+   (NonNeg.C time, Num time) =>    NonEmptyList time body -> TimeBodyList.T time body makeUncollapsedInfiniteEventList =    makeInfiniteEventList .-   (\(time,body,xs) -> (time+1,body,xs))+   mapFst (\(time,body) -> (add time 1, body))  makeInfiniteEventList :: (NonNeg.C time) =>    NonEmptyList time body -> TimeBodyList.T time body@@ -780,7 +834,7 @@  makeNonEmptyEventList :: (NonNeg.C time) =>    NonEmptyList time body -> TimeBodyList.T time body-makeNonEmptyEventList (t, b, evs) =+makeNonEmptyEventList ((t, b), evs) =    TimeBodyList.cons t b evs  {- |@@ -826,17 +880,17 @@      quickCheck (mapBodyComposition toUpper toLower                :: TimeBodyList.T TimeDiff ArbChar -> Bool)) :    ("map time composition",-     quickCheck ((\dt0 dt1 -> mapTimeComposition (dt0+) (dt1+))+     quickCheck ((\dt0 dt1 -> mapTimeComposition (add dt0) (add dt1))                :: TimeDiff -> TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) :    ("map time body commutative",-     quickCheck ((\dt -> mapTimeBodyCommutative (dt+) toUpper)+     quickCheck ((\dt -> mapTimeBodyCommutative (add dt) toUpper)                :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) :     ("mapBodyInfinite",      quickCheck (mapBodyInfinite toUpper                :: NonEmptyList TimeDiff ArbChar -> Bool)) :    ("mapTimeInfinite",-     quickCheck (\dt -> mapTimeInfinite (dt+)+     quickCheck (\dt -> mapTimeInfinite (add dt)                :: NonEmptyList TimeDiff ArbChar -> Bool)) :     ("mapNormalize",@@ -859,6 +913,12 @@                :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) :    ("appendSplitAtTime",      quickCheck (appendSplitAtTime :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) :+   ("appendSplitAfterTime",+     quickCheck (appendSplitAfterTime :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) :+   ("nonZeroTakeTime",+     quickCheck (nonZeroTakeTime :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) :+   ("nonZeroDropAfterTime",+     quickCheck (nonZeroDropAfterTime :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) :    ("appendFirstInfinite",      quickCheck (appendFirstInfinite :: NonEmptyList TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) :    ("appendSecondInfinite",@@ -894,6 +954,12 @@      quickCheck (takeTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) :    ("dropTimeInfinite",      quickCheck (dropTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) :+{-+   ("splitAtTimeLazyInfinite",+     quickCheck (splitAtTimeLazyInfinite :: BodyBodyList.T (NonNegChunky.T TimeDiff) ArbChar -> Bool)) :+   ("dropTimeLazyInfinite",+     quickCheck (dropTimeLazyInfinite :: BodyBodyList.T (NonNegChunky.T TimeDiff) ArbChar -> Bool)) :+-}     ("duration pause",      quickCheck (durationPause :: TimeDiff -> Bool)) :@@ -1004,5 +1070,7 @@      quickCheck (mapBodyMAppendRandom :: Int -> TimeBodyList.T TimeDiff (ArbChar,ArbChar) -> TimeBodyList.T TimeDiff (ArbChar,ArbChar) -> Bool)) :    ("mapBodyMInfinite",      quickCheck (mapBodyMInfinite :: Int -> NonEmptyList TimeDiff (ArbChar,ArbChar) -> Bool)) :+   ("resampleInfinite",+     quickCheck (resampleInfinite :: TimeDiff -> NonEmptyList (TimeDiff,TimeDiff) ArbChar -> Bool)) :     []
src/Test/Data/EventList/Relative/TimeEnd.hs view
@@ -26,7 +26,7 @@  import qualified Numeric.NonNegative.Chunky as NonNegChunky import qualified Numeric.NonNegative.Class  as NonNeg-import Numeric.NonNegative.Class ((-|), )+import Numeric.NonNegative.Class ((-|), zero, add, ) import Data.EventList.Relative.TimeTime (isNormalized, )  import System.Random (Random, randomR, mkStdGen, )@@ -152,11 +152,88 @@    time -> body -> time -> time -> body -> time -> Bool consInfix t0a b0 t0b t1a b1 t1b =    TimeTimeList.append (t0a /. b0 ./ t0b /. empty) (t1a /. b1 ./ t1b /. empty)-      == (t0a /. b0 ./ (t0b+t1a) /. b1 ./ t1b /. empty)+      == (t0a /. b0 ./ (add t0b t1a) /. b1 ./ t1b /. empty)  +iterate' :: (a -> a) -> a -> [a]+iterate' f =+   let recourse x = ((:) $! x) $ recourse (f x)+   in  recourse +chunkyShow ::+   Int -> Bool+chunkyShow =+   (\t -> t==t) . take 1000000 . show .+   const (NonNegChunky.fromChunks $ iterate' (2-) (1::TimeDiff)) +_chunkyCheck ::+   Int -> Bool+_chunkyCheck =+   (\t -> t==t) .+   take 1000000 .+--   (!!1000000) .+{-+   NonNegChunky.toChunks .+   NonNegChunky.fromChunks .+-}+   iterate' (1+)++{-+With an early implementation of mapTimeTail this resulted in heap exhaustion.+-}+mapTimeTailChunkyInfinite ::+   (NonNeg.C time, Num time, Eq body, Show body) =>+   (body -> body) ->+   BodyTimeList.T (NonNegChunky.T time) body -> Bool+mapTimeTailChunkyInfinite _f =+   (\t -> t==t) . take 1000000 .+   NonNegChunky.toChunks .+   MixedTimeList.switchTimeL const .+{-+   MixedTimeList.switchTimeL+      MixedTimeList.consTime .+-}+   MixedTimeList.consTime+      (NonNegChunky.fromChunks $ iterate' (2-) 1)++{-+mapTimeTailChunkyInfinite ::+   (NonNeg.C time, Num time, Eq body, Show body) =>+   (body -> body) ->+   BodyTimeList.T (NonNegChunky.T time) body -> Bool+mapTimeTailChunkyInfinite f =+   (\t -> t==t) . take 1000000 . show .+   MixedTimeList.mapTimeTail (fmap f) .+   MixedTimeList.consTime+      (NonNegChunky.fromChunks $ iterate (2-) 1)+-}++{-+mapTimeTailChunkyInfinite :: (NonNeg.C time, Eq body) =>+   (body -> body) ->+   BodyTimeList.T (NonNegChunky.T time) body -> Bool+mapTimeTailChunkyInfinite f =+--   not . NonNegChunky.isNull .+--   not . null . NonNegChunky.toChunks .+   (\t -> t==t) . take 1000000 . NonNegChunky.toChunks .+   MixedTimeList.switchTimeL const .+--   TimeTimeList.dropTime 1000000 .+   MixedTimeList.mapTimeTail (fmap f) .+   MixedTimeList.consTime+      (NonNegChunky.fromChunks $ iterate (2-) 1)+++mapTimeTailChunkyInfinite :: (NonNeg.C time, Eq body) =>+   (body -> body) ->+   NonNegChunky.T time ->+   TimeTimeList.T (NonNegChunky.T time) body -> Bool+mapTimeTailChunkyInfinite f time =+   MixedTimeList.mapTimeTail (fmap f) .+   TimeTimeList.delay+      (let infTime = mappend time infTime in infTime)+-}++ mapBodyComposition :: (Eq body2, Eq time) =>    (body0 -> body1) -> (body1 -> body2) -> TimeTimeList.T time body0 -> Bool mapBodyComposition f g evs =@@ -203,12 +280,12 @@ appendLeftIdentity :: (NonNeg.C time, Eq body) =>    TimeTimeList.T time body -> Bool appendLeftIdentity xs =-   TimeTimeList.append (TimeTimeList.pause 0) xs  ==  xs+   TimeTimeList.append (TimeTimeList.pause zero) xs  ==  xs  appendRightIdentity :: (NonNeg.C time, Eq body) =>    TimeTimeList.T time body -> Bool appendRightIdentity xs =-   TimeTimeList.append xs (TimeTimeList.pause 0)  ==  xs+   TimeTimeList.append xs (TimeTimeList.pause zero)  ==  xs  appendAssociative :: (NonNeg.C time, Eq body) =>    TimeTimeList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool@@ -220,7 +297,7 @@    time -> body -> TimeTimeList.T time body -> Bool appendCons time body xs =    TimeTimeList.cons time body xs  ==-   TimeTimeList.append (TimeTimeList.cons time body (TimeTimeList.pause 0)) xs+   TimeTimeList.append (TimeTimeList.cons time body (TimeTimeList.pause zero)) xs  appendSplitAtTime :: (NonNeg.C time, Eq body) =>    time -> TimeTimeList.T time body -> Bool@@ -261,13 +338,13 @@ delayAdditive :: (NonNeg.C time, Eq body) =>    time -> time -> TimeTimeList.T time body -> Bool delayAdditive dif0 dif1 xs =-   TimeTimeList.delay (dif0+dif1) xs ==+   TimeTimeList.delay (add dif0 dif1) xs ==    TimeTimeList.delay dif0 (TimeTimeList.delay dif1 xs)  delayPause :: (NonNeg.C time) =>    time -> time -> Bool delayPause dif0 dif1 =-   let pause = TimeTimeList.pause (dif0+dif1)+   let pause = TimeTimeList.pause (add dif0 dif1)    in  TimeTimeList.delay dif0 (TimeTimeList.pause dif1) ==        (asTypeOf pause (TimeTimeList.cons dif0 () pause)) @@ -294,9 +371,9 @@ takeTimeEndPause :: (NonNeg.C time, Ord body) =>    time -> TimeTimeList.T time body -> Bool takeTimeEndPause t xs =-   t == 0 ||+   t == zero ||    t >= TimeTimeList.duration xs ||-   0 <  snd (TimeMixedList.viewTimeR (TimeTimeList.takeTime t xs))+   zero <  snd (TimeMixedList.viewTimeR (TimeTimeList.takeTime t xs))  takeTimeAppendFirst :: (NonNeg.C time, Eq body) =>    time -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool@@ -306,7 +383,7 @@       (TimeTimeList.takeTime t xs)       (TimeTimeList.takeTime (t -| TimeTimeList.duration xs) ys) -takeTimeAppendSecond :: (NonNeg.C time, Eq body) =>+takeTimeAppendSecond :: (NonNeg.C time, Num time, Eq body) =>    time -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool takeTimeAppendSecond t xs0 ys =    -- the first list must not end with a zero pause@@ -324,20 +401,58 @@ dropTimeNormalize t =    isNormalized . TimeTimeList.dropTime t . TimeTimeList.normalize -takeTimeInfinite :: (NonNeg.C time, Ord body) =>+takeTimeInfinite :: (NonNeg.C time, Num time, Ord body) =>    time -> NonEmptyList time body -> Bool takeTimeInfinite t =    (t == ) . TimeTimeList.duration .    TimeTimeList.takeTime t . makeUncollapsedInfiniteEventList -dropTimeInfinite :: (NonNeg.C time, Ord body) =>+dropTimeInfinite :: (NonNeg.C time, Num time, Ord body) =>    time -> NonEmptyList time body -> Bool dropTimeInfinite t =    checkInfinite . TimeTimeList.dropTime t . makeUncollapsedInfiniteEventList +dropTimeLargeInfinite ::+   (NonNeg.C time, Num time, Ord body) =>+   NonEmptyList time body -> Bool+dropTimeLargeInfinite =+   checkInfinite .+   TimeTimeList.dropTime 10000 .+   makeUncollapsedInfiniteEventList  +splitAtTimeLazyInfinite ::+   (NonNeg.C time, Num time, Ord body, Show time, Show body) =>+   BodyTimeList.T (NonNegChunky.T time) body -> Bool+splitAtTimeLazyInfinite =+   not . null . show . snd .+   TimeTimeList.splitAtTime 1000000 .+   MixedTimeList.consTime+      (NonNegChunky.fromChunks $ iterate (2-) 1) +dropTimeLazyInfinite ::+   (NonNeg.C time, Num time, Ord body, Show time, Show body) =>+   BodyTimeList.T (NonNegChunky.T time) body -> Bool+dropTimeLazyInfinite =+   not . null . show .+   TimeTimeList.dropTime 1000000 .+   MixedTimeList.consTime+      (NonNegChunky.fromChunks $ iterate (2-) 1)++{-+dropTimeLazyInfinite ::+   (NonNeg.C time, Num time, Ord body) =>+   BodyTimeList.T (NonNegChunky.T time) body -> Bool+dropTimeLazyInfinite =+   (\t -> t==t) . take 100 . NonNegChunky.toChunks .+   MixedTimeList.switchTimeL const .+   TimeTimeList.dropTime 1000000 .+   MixedTimeList.consTime+      (NonNegChunky.fromChunks $ iterate (2-) 1)+-}+++ durationPause :: (NonNeg.C time) =>    time -> Bool durationPause t =@@ -347,7 +462,7 @@    TimeTimeList.T time body -> TimeTimeList.T time body -> Bool durationAppend xs ys =    TimeTimeList.duration (TimeTimeList.append xs ys)  ==-   TimeTimeList.duration xs + TimeTimeList.duration ys+   TimeTimeList.duration xs `add` TimeTimeList.duration ys  durationMerge :: (NonNeg.C time, Ord body) =>    TimeTimeList.T time body -> TimeTimeList.T time body -> Bool@@ -394,20 +509,20 @@    in  equalPrefix 100 xs (TimeTimeList.cycle xs)  -filterSatisfy :: (Num time) =>+filterSatisfy :: (NonNeg.C time) =>    (body -> Bool) ->    TimeTimeList.T time body -> Bool filterSatisfy p =    all p . TimeTimeList.getBodies . TimeTimeList.filter p -filterProjection :: (Num time, Eq body) =>+filterProjection :: (NonNeg.C time, Eq body) =>    (body -> Bool) ->    TimeTimeList.T time body -> Bool filterProjection p xs =    TimeTimeList.filter p xs ==    TimeTimeList.filter p (TimeTimeList.filter p xs) -filterCommutative :: (Num time, Eq body) =>+filterCommutative :: (NonNeg.C time, Eq body) =>    (body -> Bool) ->    (body -> Bool) ->    TimeTimeList.T time body -> Bool@@ -415,7 +530,7 @@    TimeTimeList.filter p (TimeTimeList.filter q xs) ==    TimeTimeList.filter q (TimeTimeList.filter p xs) -filterComposition :: (Num time, Eq body) =>+filterComposition :: (NonNeg.C time, Eq body) =>    (body -> Bool) ->    (body -> Bool) ->    TimeTimeList.T time body -> Bool@@ -464,23 +579,23 @@    TimeTimeList.append (TimeTimeList.catMaybes xs) (TimeTimeList.catMaybes ys)  -catMaybesRInfinite :: (NonNeg.C time, Eq body) =>+catMaybesRInfinite :: (NonNeg.C time, Num time, Eq body) =>    NonEmptyList time (Maybe body) -> Bool catMaybesRInfinite xs =    {--   @(1+) is needed in order to assert that the accumulated time is infinite+   @(add 1) is needed in order to assert that the accumulated time is infinite    and can be clipped by @min 100@.    -}    let t =          min 100 $-         List.foldr (+) 0 $+         List.foldr add zero $          TimeTimeList.getTimes $          TimeTimeList.catMaybesR $-         TimeTimeList.mapTime (NonNegChunky.fromNumber . (1+)) $+         TimeTimeList.mapTime (NonNegChunky.fromNumber . (add 1)) $          makeInfiniteEventList xs    in  t == t -catMaybesRInitInfinite :: (NonNeg.C time, Eq body) =>+catMaybesRInitInfinite :: (NonNeg.C time, Num time, Eq body) =>    NonEmptyList time body -> Bool catMaybesRInitInfinite xs =    let t =@@ -488,7 +603,7 @@          MixedTimeList.switchTimeL const $          TimeTimeList.catMaybesR $          TimeTimeList.mapBody (const (Nothing::Maybe())) $-         TimeTimeList.mapTime (NonNegChunky.fromNumber . (1+)) $+         TimeTimeList.mapTime (NonNegChunky.fromNumber . (add 1)) $          makeInfiniteEventList xs    in  t == t @@ -506,27 +621,27 @@    TimeTimeList.partitionMaybeR f xs  partitionMaybeRInfinite ::-   (NonNeg.C time, Eq body0, Eq body1) =>+   (NonNeg.C time, Num time, Eq body0, Eq body1) =>    (body0 -> Maybe body1) ->    NonEmptyList time body0 -> Bool partitionMaybeRInfinite f xs =    {--   @(1+) is needed in order to assert that the accumulated time is infinite+   @(add 1) is needed in order to assert that the accumulated time is infinite    and can be clipped by @min 100@.    -}    let timeSum =          min 100 .-         List.foldr (+) 0 .+         List.foldr add zero .          TimeTimeList.getTimes        t =          mapPair (timeSum, timeSum) $          TimeTimeList.partitionMaybeR f $-         TimeTimeList.mapTime (NonNegChunky.fromNumber . (1+)) $+         TimeTimeList.mapTime (NonNegChunky.fromNumber . add 1) $          makeInfiniteEventList xs    in  t == t  partitionMaybeRInitInfinite ::-   (NonNeg.C time, Eq body0, Eq body1) =>+   (NonNeg.C time, Num time, Eq body0, Eq body1) =>    (body0 -> Maybe body1) ->    NonEmptyList time body0 -> Bool partitionMaybeRInitInfinite f xs =@@ -536,7 +651,7 @@        t =          mapPair (initTime, initTime) $          TimeTimeList.partitionMaybeR f $-         TimeTimeList.mapTime (NonNegChunky.fromNumber . (1+)) $+         TimeTimeList.mapTime (NonNegChunky.fromNumber . add 1) $          makeInfiniteEventList xs    in  t == t @@ -554,12 +669,12 @@ mergeLeftIdentity :: (NonNeg.C time, Ord body) =>    TimeTimeList.T time body -> Bool mergeLeftIdentity xs =-   TimeTimeList.merge (TimeTimeList.pause 0) xs  ==  xs+   TimeTimeList.merge (TimeTimeList.pause zero) xs  ==  xs  mergeRightIdentity :: (NonNeg.C time, Ord body) =>    TimeTimeList.T time body -> Bool mergeRightIdentity xs =-   TimeTimeList.merge xs (TimeTimeList.pause 0)  ==  xs+   TimeTimeList.merge xs (TimeTimeList.pause zero)  ==  xs  mergeCommutative :: (NonNeg.C time, Ord body) =>    TimeTimeList.T time body -> TimeTimeList.T time body -> Bool@@ -698,7 +813,7 @@ insertMerge time body evs0 =    let evs = TimeTimeList.normalize evs0    in  TimeTimeList.insert time body evs  ==-       TimeTimeList.merge (TimeTimeList.cons time body $ TimeTimeList.pause 0) evs+       TimeTimeList.merge (TimeTimeList.cons time body $ TimeTimeList.pause zero) evs  insertNormalize :: (NonNeg.C time, Ord body) =>    time -> body -> TimeTimeList.T time body -> Bool@@ -714,7 +829,7 @@    ==       let (prefix,suffix) = TimeTimeList.splitAtTime time evs       in  TimeTimeList.normalize-             (TimeTimeList.append prefix (TimeTimeList.cons 0 body suffix))+             (TimeTimeList.append prefix (TimeTimeList.cons zero body suffix))       --  append prefix (MixedTimeList.consBody body suffix)  insertInfinite :: (NonNeg.C time, Ord body) =>@@ -725,21 +840,21 @@   -moveForwardIdentity :: (NonNeg.C time, Ord body) =>+moveForwardIdentity :: (NonNeg.C time, Num time, Ord body) =>    TimeTimeList.T time body -> Bool moveForwardIdentity evs =    evs ==-   TimeTimeList.moveForward (TimeTimeList.mapBody ((,) 0) evs)+   TimeTimeList.moveForward (TimeTimeList.mapBody ((,) zero) evs) -moveForwardAdditive :: (NonNeg.C time, Ord body) =>+moveForwardAdditive :: (NonNeg.C time, Num time, Ord body) =>    TimeTimeList.T time ((time,time),body) -> Bool moveForwardAdditive evs =    TimeTimeList.normalize (moveForwardLimited (moveForwardLimited       (TimeTimeList.mapBody (\((t0,t1),b) -> (t0,(t1,b))) evs))) ==    TimeTimeList.normalize (moveForwardLimited-      (TimeTimeList.mapBody (mapFst (uncurry (+))) evs))+      (TimeTimeList.mapBody (mapFst (uncurry add)) evs)) -moveForwardCommutative :: (NonNeg.C time, Ord body) =>+moveForwardCommutative :: (NonNeg.C time, Num time, Ord body) =>    TimeTimeList.T time ((time,time),body) -> Bool moveForwardCommutative evs =    TimeTimeList.normalize (moveForwardLimited (moveForwardLimited@@ -747,7 +862,7 @@    TimeTimeList.normalize (moveForwardLimited (moveForwardLimited       (TimeTimeList.mapBody (\((t0,t1),b) -> (t1,(t0,b))) evs))) -moveForwardRestricted :: (NonNeg.C time, Ord body) =>+moveForwardRestricted :: (NonNeg.C time, Num time, Ord body) =>    time -> TimeTimeList.T time (time,body) -> Bool moveForwardRestricted maxTime evs0 =    let evs =@@ -758,7 +873,8 @@        &&  mevs  ==  TimeTimeList.moveForwardRestrictedByStrict (\_ _ -> True) maxTime evs        &&  mevs  ==  TimeTimeList.moveForwardRestrictedByQueue (\_ _ -> False) maxTime evs -moveForwardRestrictedInfinity :: (NonNeg.C time, Ord body) =>+moveForwardRestrictedInfinity ::+   (NonNeg.C time, Num time, Ord body) =>    time -> NonEmptyList time (time,body) -> Bool moveForwardRestrictedInfinity maxTime =    checkInfinite .@@ -769,16 +885,16 @@   -moveForwardLimited :: (NonNeg.C time) =>+moveForwardLimited :: (NonNeg.C time, Num time) =>    TimeTimeList.T time (time,body) -> TimeTimeList.T time body moveForwardLimited = TimeTimeList.moveForward . restrictMoveTimes  restrictMoveTimes :: (NonNeg.C time) =>    TimeTimeList.T time (time,body) -> TimeTimeList.T time (time,body) restrictMoveTimes =-   flip evalState 0 .+   flip evalState zero .    TimeTimeList.mapM-      (\t -> modify (t+) >> return t)+      (\t -> modify (add t) >> return t)       (\(t,b) -> gets (\tm -> (min t tm, b)))  @@ -788,7 +904,7 @@    evs ==    TimeTimeList.arrange       (TimeTimeList.mapBody-          (\x -> TimeTimeList.cons 0 x (TimeTimeList.pause 0)) evs)+          (\x -> TimeTimeList.cons zero x (TimeTimeList.pause zero)) evs)  arrangeDelay :: (NonNeg.C time, Ord body) =>    time -> NonEmptyList time body -> Bool@@ -797,8 +913,8 @@    in  TimeTimeList.delay delay evs ==        TimeTimeList.arrange           (TimeTimeList.mapBody-              (\x -> TimeTimeList.cons delay x (TimeTimeList.pause 0)) $-           TimeTimePriv.mapTimeLast (delay+) evs)+              (\x -> TimeTimeList.cons delay x (TimeTimeList.pause zero)) $+           TimeTimePriv.mapTimeLast (add delay) evs)  arrangeSimple :: (NonNeg.C time, Ord body) =>    TimeTimeList.T time (TimeTimeList.T time body) ->@@ -809,10 +925,10 @@    TimeTimeList.foldr       (TimeTimeList.delay)       (TimeTimeList.merge)-      (TimeTimeList.pause 0)+      (TimeTimeList.pause zero)       (TimeTimeList.mapBody TimeTimeList.normalize evs) -arrangeAbsolute :: (NonNeg.C time, Ord body) =>+arrangeAbsolute :: (NonNeg.C time, Num time, Ord body) =>    TimeTimeList.T time (TimeTimeList.T time body) ->    Bool arrangeAbsolute evs =@@ -822,10 +938,10 @@           TimeTimeList.merge              (TimeTimeList.delay t (TimeTimeList.normalize xs)) ys)       (,)-      (TimeTimeList.pause 0, TimeTimeList.pause 0)-      (TimeTimeList.toAbsoluteEventList 0 evs)+      (TimeTimeList.pause zero, TimeTimeList.pause zero)+      (TimeTimeList.toAbsoluteEventList zero evs) -arrangeInfinity :: (NonNeg.C time, Ord body) =>+arrangeInfinity :: (NonNeg.C time, Num time, Ord body) =>    NonEmptyList time (NonEmptyList time body) -> Bool arrangeInfinity =    checkInfinite .@@ -845,14 +961,14 @@    TimeTimeList.T time body -> Bool collectCoincidentGaps xs =    let times = tail (TimeTimeList.getTimes (TimeTimeList.collectCoincident xs))-   in  null times || all (0<) (init times)+   in  null times || all (zero<) (init times)  collectCoincidentNonEmpty :: (NonNeg.C time, Eq body) =>    TimeTimeList.T time body -> Bool collectCoincidentNonEmpty =    all (not . null) . TimeTimeList.getBodies . TimeTimeList.collectCoincident -collectCoincidentInfinite :: (NonNeg.C time, Eq body) =>+collectCoincidentInfinite :: (NonNeg.C time, Num time, Eq body) =>    NonEmptyList time body -> Bool collectCoincidentInfinite =    checkInfinite .@@ -975,20 +1091,30 @@ discretize :: (RealFrac time, Integral i) =>    TimeTimeList.T time body -> TimeTimeList.T i body discretize es =-   evalState (Uniform.mapSecondM roundDiff es) 0+   evalState (Uniform.mapSecondM roundDiff es) zero  resample :: (RealFrac time, Integral i) =>    time -> TimeTimeList.T time body -> TimeTimeList.T i body resample rate es =    discretize (mapTime (rate*) es)+-} +resampleInfinite :: (Eq body) =>+   TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) body -> Bool+resampleInfinite rateInt =+   let rate = timeToDouble rateInt + 1+   in  checkInfinite . intTimeList . TimeTimeList.resample rate .+       makeInfiniteEventList .+       mapPair (mapFst makeFracTime, TimeTimeList.mapTime makeFracTime) ++{- toAbsoluteEventList :: (Num time) =>    time -> TimeTimeList.T time body -> AbsoluteEventList.T time body toAbsoluteEventList start xs =    let ts = Uniform.getSeconds xs        bs = Uniform.getFirsts  xs-       ats = List.scanl (+) start ts+       ats = List.scanl add start ts    in  maybe           (error "padded list always contains one time value")           (\ ~(ats0,lt) -> (zip ats0 bs, lt))@@ -998,13 +1124,14 @@   -type NonEmptyList time body = (time, body, TimeTimeList.T time body)+type NonEmptyList time body = ((time, body), TimeTimeList.T time body) -makeUncollapsedInfiniteEventList :: (NonNeg.C time) =>+makeUncollapsedInfiniteEventList ::+   (NonNeg.C time, Num time) =>    NonEmptyList time body -> TimeTimeList.T time body makeUncollapsedInfiniteEventList =    makeInfiniteEventList .-   (\(time,body,xs) -> (time+1,body,xs))+   mapFst (\(time,body) -> (add time 1, body))  makeInfiniteEventList :: (NonNeg.C time) =>    NonEmptyList time body -> TimeTimeList.T time body@@ -1013,7 +1140,7 @@  makeNonEmptyEventList :: (NonNeg.C time) =>    NonEmptyList time body -> TimeTimeList.T time body-makeNonEmptyEventList (t, b, evs) =+makeNonEmptyEventList ((t, b), evs) =    TimeTimeList.cons t b evs  {- |@@ -1071,23 +1198,31 @@      quickCheck (snocTimeBodyInfinite :: TimeDiff -> ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) :    ("consInfix",      quickCheck (consInfix :: TimeDiff -> ArbChar -> TimeDiff -> TimeDiff -> ArbChar -> TimeDiff -> Bool)) :+   ("chunkyShow",+     quickCheck chunkyShow) :+{-+   ("chunkyCheck",+     quickCheck chunkyCheck) :+-}+   ("mapTimeTailChunkyInfinite",+     quickCheck (mapTimeTailChunkyInfinite succ :: BodyTimeList.T (NonNegChunky.T TimeDiff) ArbChar -> Bool)) :      ("map body composition",      quickCheck (mapBodyComposition toUpper toLower                :: TimeTimeList.T TimeDiff ArbChar -> Bool)) :    ("map time composition",-     quickCheck ((\dt0 dt1 -> mapTimeComposition (dt0+) (dt1+))+     quickCheck ((\dt0 dt1 -> mapTimeComposition (add dt0) (add dt1))                :: TimeDiff -> TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) :    ("map time body commutative",-     quickCheck ((\dt -> mapTimeBodyCommutative (dt+) toUpper)+     quickCheck ((\dt -> mapTimeBodyCommutative (add dt) toUpper)                :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) :     ("mapBodyInfinite",      quickCheck (mapBodyInfinite toUpper                :: NonEmptyList TimeDiff ArbChar -> Bool)) :    ("mapTimeInfinite",-     quickCheck (\dt -> mapTimeInfinite (dt+)+     quickCheck (\dt -> mapTimeInfinite (add dt)                :: NonEmptyList TimeDiff ArbChar -> Bool)) :     ("mapNormalize",@@ -1151,6 +1286,12 @@      quickCheck (takeTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) :    ("dropTimeInfinite",      quickCheck (dropTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) :+   ("dropTimeLargeInfinite",+     quickCheck (dropTimeLargeInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) :+   ("splitAtTimeLazyInfinite",+     quickCheck (splitAtTimeLazyInfinite :: BodyTimeList.T (NonNegChunky.T TimeDiff) ArbChar -> Bool)) :+   ("dropTimeLazyInfinite",+     quickCheck (dropTimeLazyInfinite :: BodyTimeList.T (NonNegChunky.T TimeDiff) ArbChar -> Bool)) :     ("duration pause",      quickCheck (durationPause :: TimeDiff -> Bool)) :@@ -1284,5 +1425,7 @@      quickCheck (mapBodyMAppendRandom :: Int -> TimeTimeList.T TimeDiff (ArbChar,ArbChar) -> TimeTimeList.T TimeDiff (ArbChar,ArbChar) -> Bool)) :    ("mapBodyMInfinite",      quickCheck (mapBodyMInfinite :: Int -> NonEmptyList TimeDiff (ArbChar,ArbChar) -> Bool)) :+   ("resampleInfinite",+     quickCheck (resampleInfinite :: TimeDiff -> NonEmptyList (TimeDiff,TimeDiff) ArbChar -> Bool)) :     []
src/Test/Main.hs view
@@ -5,16 +5,20 @@ import qualified Test.Data.EventList.Relative.BodyEnd as RelBodyEnd import qualified Test.Data.EventList.Relative.TimeEnd as RelTimeEnd +import qualified System.IO as IO++ prefix :: String -> [(String, IO ())] -> [(String, IO ())] prefix msg =    map (\(str,test) -> (msg ++ "." ++ str, test))  main :: IO () main =-   mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $-   concat $-      prefix "Absolute.BodyEnd" AbsBodyEnd.tests :-      prefix "Absolute.TimeEnd" AbsTimeEnd.tests :-      prefix "Relative.BodyEnd" RelBodyEnd.tests :-      prefix "Relative.TimeEnd" RelTimeEnd.tests :-      []+   IO.hSetBuffering IO.stdout IO.NoBuffering >>+   (mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $+    concat $+       prefix "Absolute.BodyEnd" AbsBodyEnd.tests :+       prefix "Absolute.TimeEnd" AbsTimeEnd.tests :+       prefix "Relative.BodyEnd" RelBodyEnd.tests :+       prefix "Relative.TimeEnd" RelTimeEnd.tests :+       [])
src/Test/Utility.hs view
@@ -3,7 +3,7 @@  import qualified Numeric.NonNegative.Wrapper as NonNeg -import Test.QuickCheck (Arbitrary(arbitrary))+import Test.QuickCheck (Arbitrary(arbitrary, shrink))  import qualified Data.Char as Char import System.Random (Random, )@@ -18,6 +18,7 @@  instance Arbitrary ArbChar where    arbitrary = liftM (ArbChar . Char.chr . (32+) . flip mod 96) arbitrary+   shrink (ArbChar c) = map ArbChar $ shrink c  toLower :: ArbChar -> ArbChar toLower (ArbChar c) = ArbChar (Char.toLower c)@@ -35,3 +36,6 @@ makeFracTime :: (TimeDiff, TimeDiff) -> NonNeg.Double makeFracTime (n,d) =    timeToDouble n / (timeToDouble d + 1)++intTimeList :: events TimeDiff body -> events TimeDiff body+intTimeList = id