event-list 0.0.6 → 0.0.7
raw patch · 11 files changed
+515/−82 lines, 11 filesdep ~QuickCheckdep ~mtldep ~non-negativePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: QuickCheck, mtl, non-negative
API changes (from Hackage documentation)
+ Data.EventList.Absolute.TimeBody: moveForward :: (Ord time, Num time) => T time (time, body) -> T time body
+ Data.EventList.Absolute.TimeTime: moveForward :: (Ord time, Num time) => T time (time, body) -> T time body
+ Data.EventList.Relative.BodyTime: cons :: body -> time -> T time body -> T time body
+ Data.EventList.Relative.BodyTime: fromPairList :: [(body, time)] -> T time body
+ Data.EventList.Relative.BodyTime: snoc :: T time body -> body -> time -> T time body
+ Data.EventList.Relative.BodyTime: toPairList :: T time body -> [(body, time)]
+ Data.EventList.Relative.BodyTime: viewL :: T time body -> Maybe ((body, time), T time body)
+ Data.EventList.Relative.BodyTime: viewR :: T time body -> Maybe (T time body, (body, time))
+ Data.EventList.Relative.TimeBody: moveForward :: (C time) => T time (time, body) -> T time body
+ Data.EventList.Relative.TimeTime: arrange :: (Ord body, C time) => T time (T time body) -> T time body
+ Data.EventList.Relative.TimeTime: arrangeBy :: (C time) => (body -> body -> Bool) -> T time (T time body) -> T time body
+ Data.EventList.Relative.TimeTime: moveBackward :: (C time) => T time (time, body) -> T time body
+ Data.EventList.Relative.TimeTime: moveForward :: (C time) => T time (time, body) -> T time body
+ Data.EventList.Relative.TimeTime: moveForwardRestricted :: (Ord body, C time) => time -> T time (time, body) -> T time body
+ Data.EventList.Relative.TimeTime: moveForwardRestrictedBy :: (C time) => (body -> body -> Bool) -> time -> T time (time, body) -> T time body
+ Data.EventList.Relative.TimeTime: moveForwardRestrictedByQueue :: (C time) => (body -> body -> Bool) -> time -> T time (time, body) -> T time body
+ Data.EventList.Relative.TimeTime: moveForwardRestrictedByStrict :: (C time) => (body -> body -> Bool) -> time -> T time (time, body) -> T time body
+ Data.EventList.Relative.TimeTime: pad :: (C time) => time -> T time body -> T time body
Files
- event-list.cabal +12/−3
- src-1/Test/Instances.hs +0/−17
- src/Data/AlternatingList/List/Disparate.hs +1/−1
- src/Data/AlternatingList/List/Uniform.hs +1/−1
- src/Data/EventList/Absolute/TimeBody.hs +16/−0
- src/Data/EventList/Absolute/TimeTime.hs +13/−0
- src/Data/EventList/Relative/BodyTime.hs +28/−1
- src/Data/EventList/Relative/TimeBody.hs +90/−50
- src/Data/EventList/Relative/TimeTime.hs +135/−2
- src/Test/Data/EventList/Relative/BodyEnd.hs +72/−2
- src/Test/Data/EventList/Relative/TimeEnd.hs +147/−5
event-list.cabal view
@@ -1,5 +1,5 @@ Name: event-list-Version: 0.0.6+Version: 0.0.7 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -23,12 +23,18 @@ 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+ Build-Depends: mtl >=1 && <2, QuickCheck >=1 && <2 If flag(splitBase)- Build-Depends: base >= 2, non-negative==0.0.1, mtl, QuickCheck, random+ Build-Depends: base >= 2, random -- random is needed for the Test Else- Build-Depends: base >= 1.0 && < 2, non-negative==0.0.1, mtl, QuickCheck+ Build-Depends: base >= 1.0 && < 2 -- From the Monad Template Library we only need the State monad. -- If your compiler does not support functional dependencies, -- it would be easy to replace that by mapAccumL.@@ -60,6 +66,9 @@ Data.AlternatingList.List.Mixed Executable test+ If !flag(buildTests)+ Buildable: False+ If flag(splitBase) Hs-source-dirs: src, src-2 Else
− src-1/Test/Instances.hs
@@ -1,17 +0,0 @@-module Test.Instances where--import Test.QuickCheck (Arbitrary(..))--import Control.Monad (liftM)-import Data.Char (chr)---instance Arbitrary Char where- arbitrary = liftM (chr . (32+) . flip mod 96) arbitrary- coarbitrary = undefined--instance Arbitrary a => Arbitrary (Maybe a) where- arbitrary =- arbitrary >>=- \b -> if b then fmap Just arbitrary else return Nothing- coarbitrary = undefined
src/Data/AlternatingList/List/Disparate.hs view
@@ -53,7 +53,7 @@ format :: (Show a, Show b) => String -> String -> Int -> T a b -> ShowS format first second p xs =- showParen (p>5) $+ showParen (p>=5) $ flip (foldr (\a -> showsPrec 5 a . showString first) (\b -> showsPrec 5 b . showString second))
src/Data/AlternatingList/List/Uniform.hs view
@@ -62,7 +62,7 @@ format :: (Show a, Show b) => String -> String -> Int -> T a b -> ShowS format first second p xs =- showParen (p>5) $+ showParen (p>=5) $ flip (foldr (\a -> showsPrec 5 a . showString first) (\b -> showsPrec 5 b . showString second))
src/Data/EventList/Absolute/TimeBody.hs view
@@ -14,6 +14,7 @@ mapBody, mapTime, mapM, mapM_, mapBodyM, mapTimeM, merge, mergeBy, insert, insertBy,+ moveForward, decreaseStart, delay, filter, partition, slice, foldr, foldrPair, mapMaybe, catMaybes, normalize, isNormalized,@@ -325,6 +326,21 @@ then uncurry cons mev0 $ mevs1 else uncurry cons mev1 $ uncurry (insertBy before) mev0 mevs) $ viewL mevs1+++{- |+Move events towards the front of the event list.+You must make sure, that no event is moved before time zero.+This works only for finite lists.+-}+moveForward :: (Ord time, Num time) =>+ T time (time, body) -> T time body+moveForward =+ fromPairList .+ List.sortBy (Utility.composeDouble compare fst) .+ List.map (\ ~(time,(timeDiff,body)) -> (time - timeDiff, body)) .+ toPairList+ append :: (Ord time, Num time) =>
src/Data/EventList/Absolute/TimeTime.hs view
@@ -15,6 +15,7 @@ mapM, mapM_, mapBodyM, mapTimeM, getTimes, getBodies, duration, merge, mergeBy, insert, insertBy,+ moveForward, decreaseStart, delay, filter, partition, slice, foldr, mapMaybe, catMaybes, normalize, isNormalized,@@ -225,6 +226,18 @@ then uncurry cons mev0 $ mevs1 else uncurry cons mev1 $ uncurry (insertBy before) mev0 mevs) mxs++++{- |+Move events towards the front of the event list.+You must make sure, that no event is moved before time zero.+This works only for finite lists.+-}+moveForward :: (Ord time, Num time) =>+ T time (time, body) -> T time body+moveForward =+ mapTimeInit TimeBodyList.moveForward
src/Data/EventList/Relative/BodyTime.hs view
@@ -10,13 +10,18 @@ -} module Data.EventList.Relative.BodyTime- (T, mapM, empty, ) where+ (T, mapM, empty,+ fromPairList, toPairList,+ cons, snoc, viewL, viewR,+ ) where import Data.EventList.Relative.BodyTimePrivate import qualified Data.AlternatingList.List.Disparate as Disp -- import qualified Data.AlternatingList.List.Uniform as Uniform +import Data.EventList.Utility (mapFst, mapSnd, )+ import Prelude hiding (mapM) @@ -28,5 +33,27 @@ liftM (Disp.mapM bodyAction timeAction) +fromPairList :: [(body, time)] -> T time body+fromPairList = Cons . Disp.fromPairList++toPairList :: T time body -> [(body, time)]+toPairList = Disp.toPairList . decons++ empty :: T time body empty = Cons Disp.empty+++cons :: body -> time -> T time body -> T time body+cons body time = lift (Disp.cons body time)++snoc :: T time body -> body -> time -> T time body+snoc xs body time =+ Cons $ (Disp.snoc $*~ xs) body time+++viewL :: T time body -> Maybe ((body, time), T time body)+viewL = fmap (mapSnd Cons) . Disp.viewL . decons++viewR :: T time body -> Maybe (T time body, (body, time))+viewR = fmap (mapFst Cons) . Disp.viewR . decons
src/Data/EventList/Relative/TimeBody.hs view
@@ -28,6 +28,7 @@ mapM, mapM_, mapBodyM, mapTimeM, foldr, foldrPair, merge, mergeBy, insert, insertBy,+ moveForward, decreaseStart, delay, filter, partition, slice, span, mapMaybe, catMaybes, normalize, isNormalized,@@ -139,7 +140,29 @@ {- |+Keep only events that match a predicate while preserving absolute times.+-}+filter :: (Num 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) =>+ (body0 -> Maybe body1) ->+ T time body0 -> T time body1+mapMaybe f = catMaybes . mapBody f++catMaybes :: (Num time) =>+ T time (Maybe body) -> T time body+catMaybes =+ Cons .+ fst . Mixed.viewSecondR .+ Uniform.mapSecond sum .+ Uniform.catMaybesFirst .+ flip Mixed.snocSecond (error "catMaybes: no trailing time") .+ decons++{- The function 'partition' is somehow the inverse to 'merge'. It is similar to 'List.partition'. We could use the List function if the event times would be absolute,@@ -166,26 +189,6 @@ -} -filter :: (Num 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) =>- (body0 -> Maybe body1) ->- T time body0 -> T time body1-mapMaybe f = catMaybes . mapBody f--catMaybes :: (Num time) =>- T time (Maybe body) -> T time body-catMaybes =- Cons .- fst . Mixed.viewSecondR .- Uniform.mapSecond sum .- Uniform.catMaybesFirst .- flip Mixed.snocSecond (error "catMaybes: no trailing time") .- decons- {- Could be implemented more easily in terms of Uniform.partition -}@@ -210,8 +213,9 @@ in recurse {- |-Since we need it later for MIDI generation,-we will also define a slicing into equivalence classes of events.+Using a classification function+we splice the event list into lists, each containing the same class.+Absolute time stamps are preserved. -} slice :: (Eq a, Num time) => (body -> a) -> T time body -> [(a, T time body)]@@ -223,15 +227,19 @@ {- |-We will also sometimes need a function which groups events by equal start times.-This implementation is not so obvious since we work with time differences.-The criterion is: Two neighbouring events start at the same time-if the second one has zero time difference.+Group events that have equal start times+(that is zero time differences). -} collectCoincident :: (NonNeg.C time) => T time body -> T time [body] collectCoincident = mapTimeTail $ BodyBodyPriv.lift $ Uniform.filterFirst (0<) +{- |+Reverse to collectCoincident:+Turn each @body@ into a separate event.++> xs == flatten (collectCoincident xs)+-} flatten :: (NonNeg.C time) => T time [body] -> T time body flatten = Cons .@@ -252,20 +260,16 @@ {- | Apply a function to the lists of coincident events. -}- mapCoincident :: (NonNeg.C time) => ([a] -> [b]) -> T time a -> T time b mapCoincident f = flatten . mapBody f . collectCoincident {- |-- 'List.sort' sorts a list of coinciding events, that is all events but the first one have time difference 0. 'normalize' sorts all coinciding events in a list thus yielding a canonical representation of a time ordered list. -}- normalize :: (NonNeg.C time, Ord body) => T time body -> T time body normalize = mapCoincident List.sort @@ -277,28 +281,22 @@ {- |-The first important function is 'merge'-which merges the events of two lists into a new time order list.+This function merges the events of two lists into a new event list.+Note that 'merge' compares entire events rather than just start times.+This is to ensure that it is commutative,+one of the properties we test for. -}- merge :: (NonNeg.C time, Ord body) => T time body -> T time body -> T time body merge = mergeBy (<) {- |-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}.-It is also necessary to assert a unique representation-of the performance independent of the structure of the 'Music.T note'.-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.+'mergeBy' is like 'merge' but does not simply use the methods of the 'Ord' class+but allows a custom comparison function. -} {--Could be implemented using as 'splitAt' and 'insert'.+Could be implemented using 'splitAt' and 'insert'. -} mergeBy :: (NonNeg.C time) => (body -> body -> Bool) ->@@ -312,15 +310,9 @@ then uncurry cons x $ mergeBy before xs $ cons (yt-xt) yb ys else uncurry cons y $ mergeBy before ys $ cons (xt-yt) xb xs - {- |-The final critical function is @insert@,-which inserts an event-into an already time-ordered sequence of events.-For instance it is used in MidiFiles to insert a @NoteOff@ event-into a list of @NoteOn@ and @NoteOff@ events.+'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 =@@ -346,6 +338,54 @@ then cons t0 me0 $ cons (t1-t0) me1 mevs else cons t1 me1 $ insert (t0-t1) me0 mevs) . viewL+++{- |+Move events towards the front of the event list.+You must make sure, that no event is moved before time zero.+This works only for finite lists.+-}+moveForward :: (NonNeg.C time) =>+ T time (time, body) -> T time body+moveForward =+ fromAbsoluteEventList .+ AbsoluteEventList.moveForward .+ toAbsoluteEventList 0+++{-+Like 'moveForward' but restricts the look-ahead time.+For @moveForwardRestricted maxTimeDiff xs@+all time differences (aka the moveForward offsets) in @xs@+must be at most @maxTimeDiff@.+With this restriction the function is lazy enough+for handling infinite event lists.+However the larger @maxTimeDiff@ the more memory and time is consumed.+-}+{- for implementation notes see TimeTime++This implementation requires TimeTime.duration, TimeMixed.appendBodyEnd, TimeMixed.splitAtTime+and thus we would need a lot of movement of functions between modules++moveForwardRestricted :: (NonNeg.C time) =>+ time -> T time (time, body) -> T time body+moveForwardRestricted maxTime xs =+ let (prefix,suffix) = splitAtTime maxTime xs+ prefixDur = duration prefix+ getChunk t =+ do (toEmit,toKeep) <- gets (splitAtTime t)+ put toKeep+ return (pad t toEmit)+ insertEvent (t,b) =+ insertBy (\ _ _ -> False) (maxTime - t) b+ in evalState+ (foldr+ (\t m -> liftM2 append (getChunk t) m)+ (\b m -> modify (insertEvent b) >> m)+ (gets (pad prefixDur)) suffix)+ (moveForward (seq prefixDur prefix))+-}+ append :: T time body -> T time body -> T time body
src/Data/EventList/Relative/TimeTime.hs view
@@ -12,7 +12,10 @@ mapBody, mapTime, mapM, mapM_, mapBodyM, mapTimeM, getTimes, getBodies, duration,- merge, mergeBy, insert,+ merge, mergeBy, insert, {- insertBy, -} pad,+ moveForward, moveForwardRestricted, moveBackward, arrange, arrangeBy,+ moveForwardRestrictedBy,+ moveForwardRestrictedByQueue, moveForwardRestrictedByStrict, decreaseStart, delay, filter, partition, slice, foldr, pause, isPause, cons, snoc, viewL, viewR, mapMaybe, catMaybes,@@ -43,7 +46,7 @@ import qualified Numeric.NonNegative.Class as NonNeg import Data.EventList.Utility (floorDiff, mapPair, mapFst, mapSnd, toMaybe, isMonotonic) import qualified Control.Monad.State as Monad-import Control.Monad.State (evalState, modify, get, put)+import Control.Monad.State (evalState, modify, get, gets, put, liftM2, ) import Prelude hiding (null, foldr, map, filter, concat, cycle, sequence, sequence_, mapM, mapM_)@@ -218,6 +221,136 @@ else consBody me1 (recurseTime (t-t1) xs)) . viewBodyL in recurseTime t0+++{-+Ensure that the list has a minimum length+by extending the last pause accordingly.+-}+pad :: (NonNeg.C time) =>+ time -> T time body -> T time body+pad time = mergeBy (\ _ _ -> False) (pause time)+++{- |+Move events towards the front of the event list.+You must make sure, that no event is moved before time zero.+This works only for finite lists.+-}+moveForward :: (NonNeg.C time) =>+ T time (time, body) -> T time body+moveForward =+ fromAbsoluteEventList .+ AbsoluteEventList.moveForward .+ toAbsoluteEventList 0++moveBackward :: (NonNeg.C time) =>+ T time (time, body) -> T time body+moveBackward =+ catMaybes .+ foldr+ (\t -> cons t Nothing)+ (\(t,b) -> insertBy (ltMaybe (\_ _ -> True)) t (Just b))+ (pause 0)++{- |+Like 'moveForward' but restricts the look-ahead time.+For @moveForwardRestricted maxTimeDiff xs@+all time differences (aka the moveForward offsets) in @xs@+must be at most @maxTimeDiff@.+With this restriction the function is lazy enough+for handling infinite event lists.+However the larger @maxTimeDiff@ the more memory and time is consumed.+-}+{-+Implementation notes:+We keep a (non-optimized) priority queue as the state of a state monad.+In a pause we emit all events that occur in this duration.+-}+moveForwardRestricted :: (Ord body, NonNeg.C time) =>+ time -> T time (time, body) -> T time body+moveForwardRestricted maxTime =+ decreaseStart maxTime .+ moveBackward .+ mapBody (mapFst (maxTime-)) .+ pad maxTime+{-+ moveForwardRestrictedBy+ (\_ _ -> True)+ -- (<)+-}++ltMaybe :: (body -> body -> Bool) -> (Maybe body -> Maybe body -> Bool)+ltMaybe cmp mx my =+ case (mx,my) of+ (Nothing, _) -> True+ (_, Nothing) -> False+ (Just x, Just y) -> cmp x y+++-- | currently only for testing+moveForwardRestrictedBy :: (NonNeg.C time) =>+ (body -> body -> Bool) ->+ time -> T time (time, body) -> T time body+moveForwardRestrictedBy cmp maxTime =+ decreaseStart maxTime .+ catMaybes .+ foldr+ (\t -> cons t Nothing)+ (\(t,b) -> insertBy (ltMaybe cmp) (maxTime-t) (Just b))+ (pause maxTime)++-- | currently only for testing+moveForwardRestrictedByStrict :: (NonNeg.C time) =>+ (body -> body -> Bool) ->+ time -> T time (time, body) -> T time body+moveForwardRestrictedByStrict cmp maxTime =+ decreaseStart maxTime .+ foldr+ delay+ (\(t,b) -> insertBy cmp (maxTime-t) b)+ (pause maxTime)++-- | currently only for testing+moveForwardRestrictedByQueue :: (NonNeg.C time) =>+ (body -> body -> Bool) ->+ time -> T time (time, body) -> T time body+moveForwardRestrictedByQueue cmp maxTime xs =+ let (prefix,suffix) = splitAtTime maxTime xs+ prefixDur = duration prefix {- maxTime would work in most cases, too -}+ getChunk t =+ do (toEmit,toKeep) <- gets (splitAtTime t)+ put toKeep+ return (pad t toEmit)+ insertEvent (t,b) =+ insertBy cmp (maxTime - t) b+ in evalState+ (foldr+ (\t m -> liftM2 append (getChunk t) m)+ (\b m -> modify (insertEvent b) >> m)+ (gets (pad prefixDur)) suffix)+ (moveForward (seq prefixDur prefix))+ {- this way 'prefixDur' will be computed early+ and 'prefix' need not to be stored until the end of the list -}+++{- |+Merge several event lists respecting the start time of the outer event list.+-}+arrange :: (Ord body, NonNeg.C time) =>+ T time (T time body) -> T time body+arrange = arrangeBy (\_ _ -> False)++arrangeBy :: (NonNeg.C time) =>+ (body -> body -> Bool) ->+ T time (T time body) -> T time body+arrangeBy cmp =+ catMaybes .+ foldr+ (\t -> cons t Nothing)+ (\xs -> mergeBy (ltMaybe cmp) (mapBody Just xs))+ (pause 0)+ append :: (NonNeg.C time) => T time body -> T time body -> T time body
src/Test/Data/EventList/Relative/BodyEnd.hs view
@@ -25,9 +25,9 @@ import Numeric.NonNegative.Class ((-|)) import Data.EventList.Relative.TimeBody (isNormalized) -import Data.EventList.Utility (mapPair)+import Data.EventList.Utility (mapPair, mapFst, ) import System.Random (Random, randomR, mkStdGen)-import Control.Monad.State (State(State), evalState)+import Control.Monad.State (State(State), evalState, gets, modify, ) import Control.Monad (liftM2) import Data.Maybe (isJust) import qualified Data.List as List@@ -514,6 +514,63 @@ +moveForwardIdentity :: (NonNeg.C time, Ord body) =>+ TimeBodyList.T time body -> Bool+moveForwardIdentity evs =+ evs ==+ TimeBodyList.moveForward (TimeBodyList.mapBody ((,) 0) evs)++moveForwardAdditive :: (NonNeg.C 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))++moveForwardCommutative :: (NonNeg.C time, Ord body) =>+ TimeBodyList.T time ((time,time),body) -> Bool+moveForwardCommutative evs =+ TimeBodyList.normalize (moveForwardLimited (moveForwardLimited+ (TimeBodyList.mapBody (\((t0,t1),b) -> (t0,(t1,b))) evs))) ==+ TimeBodyList.normalize (moveForwardLimited (moveForwardLimited+ (TimeBodyList.mapBody (\((t0,t1),b) -> (t1,(t0,b))) evs)))++{-+moveForwardRestricted :: (NonNeg.C time, Ord body) =>+ time -> TimeBodyList.T time (time,body) -> Bool+moveForwardRestricted maxTime evs0 =+ let evs =+ TimeBodyList.mapBody (mapFst (min maxTime)) $+ restrictMoveTimes (TimeBodyList.normalize evs0)+ in TimeBodyList.moveForward evs ==+ TimeBodyList.moveForwardRestricted maxTime evs++moveForwardRestrictedInfinity :: (NonNeg.C time, Eq body) =>+ time -> NonEmptyList time (time,body) -> Bool+moveForwardRestrictedInfinity maxTime =+ checkInfinite .+ TimeBodyList.moveForwardRestricted maxTime .+ TimeBodyList.mapBody (mapFst (min maxTime)) .+ restrictMoveTimes .+ makeUncollapsedInfiniteEventList+-}+++moveForwardLimited :: (NonNeg.C 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 .+ TimeBodyList.mapM+ (\t -> modify (t+) >> return t)+ (\(t,b) -> gets (\tm -> (min t tm, b)))+++ spanSatisfy :: (NonNeg.C time, Eq body) => (body -> Bool) -> TimeBodyList.T time body -> Bool spanSatisfy p =@@ -882,6 +939,19 @@ test (insertSplitAtTime :: TimeDiff -> Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("insertInfinite", test (insertInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :++ ("moveForwardIdentity",+ test (moveForwardIdentity :: TimeBodyList.T TimeDiff Char -> Bool)) :+ ("moveForwardAdditive",+ test (moveForwardAdditive :: TimeBodyList.T TimeDiff ((TimeDiff,TimeDiff),Char) -> Bool)) :+ ("moveForwardCommutative",+ test (moveForwardCommutative :: TimeBodyList.T TimeDiff ((TimeDiff,TimeDiff),Char) -> Bool)) :+{-+ ("moveForwardRestricted",+ test (moveForwardRestricted :: TimeDiff -> TimeBodyList.T TimeDiff (TimeDiff,Char) -> Bool)) :+ ("moveForwardRestrictedInfinity",+ test (moveForwardRestrictedInfinity :: TimeDiff -> NonEmptyList TimeDiff (TimeDiff,Char) -> Bool)) :+-} ("spanSatisfy", test (\c -> spanSatisfy (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) :
src/Test/Data/EventList/Relative/TimeEnd.hs view
@@ -17,6 +17,9 @@ import qualified Data.EventList.Relative.BodyTime as BodyTimeList import qualified Data.AlternatingList.List.Mixed as Mixed +import qualified Data.EventList.Relative.TimeTimePrivate as TimeTimePriv+import qualified Data.EventList.Absolute.TimeTime as AbsTimeTimeList+ import Data.EventList.Relative.MixedTime ((/.), (./), empty) import Data.EventList.Relative.TimeTimePrivate (($~~), lift)@@ -25,9 +28,10 @@ import Numeric.NonNegative.Class ((-|)) import Data.EventList.Relative.TimeTime (isNormalized) -import System.Random (Random, randomR, mkStdGen)-import Control.Monad.State (State(State), evalState)-import Control.Monad (liftM2)+import System.Random (Random, randomR, mkStdGen, )+import Control.Monad.State (State(State), evalState, gets, modify, )+import Control.Monad (liftM2, )+import Data.EventList.Utility (mapFst, ) import qualified Data.List as List import qualified Data.Char as Char @@ -541,8 +545,8 @@ (TimeTimeList.mapBody Left xs) (TimeTimeList.mapBody Right ys) dur = TimeTimeList.duration zs- longXs = TimeTimeList.merge (TimeTimeList.pause dur) xs- longYs = TimeTimeList.merge (TimeTimeList.pause dur) ys+ longXs = TimeTimeList.pad dur xs+ longYs = TimeTimeList.pad dur ys in longXs == TimeTimeList.mapMaybe (either Just (const Nothing)) zs && longYs == TimeTimeList.mapMaybe (either (const Nothing) Just) zs@@ -603,6 +607,117 @@ +moveForwardIdentity :: (NonNeg.C time, Ord body) =>+ TimeTimeList.T time body -> Bool+moveForwardIdentity evs =+ evs ==+ TimeTimeList.moveForward (TimeTimeList.mapBody ((,) 0) evs)++moveForwardAdditive :: (NonNeg.C 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))++moveForwardCommutative :: (NonNeg.C time, Ord body) =>+ TimeTimeList.T time ((time,time),body) -> Bool+moveForwardCommutative evs =+ TimeTimeList.normalize (moveForwardLimited (moveForwardLimited+ (TimeTimeList.mapBody (\((t0,t1),b) -> (t0,(t1,b))) evs))) ==+ TimeTimeList.normalize (moveForwardLimited (moveForwardLimited+ (TimeTimeList.mapBody (\((t0,t1),b) -> (t1,(t0,b))) evs)))++moveForwardRestricted :: (NonNeg.C time, Ord body) =>+ time -> TimeTimeList.T time (time,body) -> Bool+moveForwardRestricted maxTime evs0 =+ let evs =+ TimeTimeList.mapBody (mapFst (min maxTime)) $+ restrictMoveTimes (TimeTimeList.normalize evs0)+ mevs = TimeTimeList.moveForward evs+ in mevs == TimeTimeList.moveForwardRestrictedBy (\_ _ -> True) maxTime evs+ && mevs == TimeTimeList.moveForwardRestrictedByStrict (\_ _ -> True) maxTime evs+ && mevs == TimeTimeList.moveForwardRestrictedByQueue (\_ _ -> False) maxTime evs++moveForwardRestrictedInfinity :: (NonNeg.C time, Ord body) =>+ time -> NonEmptyList time (time,body) -> Bool+moveForwardRestrictedInfinity maxTime =+ checkInfinite .+ TimeTimeList.moveForwardRestricted maxTime .+ TimeTimeList.mapBody (mapFst (min maxTime)) .+ restrictMoveTimes .+ makeUncollapsedInfiniteEventList++++moveForwardLimited :: (NonNeg.C 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 .+ TimeTimeList.mapM+ (\t -> modify (t+) >> return t)+ (\(t,b) -> gets (\tm -> (min t tm, b)))+++arrangeSingletons :: (NonNeg.C time, Ord body) =>+ TimeTimeList.T time body -> Bool+arrangeSingletons evs =+ evs ==+ TimeTimeList.arrange+ (TimeTimeList.mapBody+ (\x -> TimeTimeList.cons 0 x (TimeTimeList.pause 0)) evs)++arrangeDelay :: (NonNeg.C time, Ord body) =>+ time -> NonEmptyList time body -> Bool+arrangeDelay delay evs0 =+ let evs = makeNonEmptyEventList evs0+ in TimeTimeList.delay delay evs ==+ TimeTimeList.arrange+ (TimeTimeList.mapBody+ (\x -> TimeTimeList.cons delay x (TimeTimeList.pause 0)) $+ TimeTimePriv.mapTimeLast (delay+) evs)++arrangeSimple :: (NonNeg.C time, Ord body) =>+ TimeTimeList.T time (TimeTimeList.T time body) ->+ Bool+arrangeSimple evs =+ TimeTimeList.normalize (TimeTimeList.arrange evs) ==+ -- implementation not lazy enough for regular use+ TimeTimeList.foldr+ (TimeTimeList.delay)+ (TimeTimeList.merge)+ (TimeTimeList.pause 0)+ (TimeTimeList.mapBody TimeTimeList.normalize evs)++arrangeAbsolute :: (NonNeg.C time, Ord body) =>+ TimeTimeList.T time (TimeTimeList.T time body) ->+ Bool+arrangeAbsolute evs =+ TimeTimeList.normalize (TimeTimeList.arrange evs) ==+ AbsTimeTimeList.foldr+ (\t (xs,ys) ->+ TimeTimeList.merge+ (TimeTimeList.delay t (TimeTimeList.normalize xs)) ys)+ (,)+ (TimeTimeList.pause 0, TimeTimeList.pause 0)+ (TimeTimeList.toAbsoluteEventList 0 evs)++arrangeInfinity :: (NonNeg.C time, Ord body) =>+ NonEmptyList time (NonEmptyList time body) -> Bool+arrangeInfinity =+ checkInfinite .+ TimeTimeList.arrange .+ TimeTimeList.mapBody makeUncollapsedInfiniteEventList .+ makeUncollapsedInfiniteEventList++++ coincidentFlatten :: (NonNeg.C time, Eq body) => TimeTimeList.T time body -> Bool coincidentFlatten xs =@@ -968,6 +1083,33 @@ test (insertSplitAtTime :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) : ("insertInfinite", test (insertInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :++ ("moveForwardIdentity",+ test (moveForwardIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) :+ ("moveForwardAdditive",+ test (moveForwardAdditive :: TimeTimeList.T TimeDiff ((TimeDiff,TimeDiff),Char) -> Bool)) :+ ("moveForwardCommutative",+ test (moveForwardCommutative :: TimeTimeList.T TimeDiff ((TimeDiff,TimeDiff),Char) -> Bool)) :+ ("moveForwardRestricted",+ test (moveForwardRestricted :: TimeDiff -> TimeTimeList.T TimeDiff (TimeDiff,Char) -> Bool)) :+ ("moveForwardRestrictedInfinity",+ test (moveForwardRestrictedInfinity :: TimeDiff -> NonEmptyList TimeDiff (TimeDiff,Char) -> Bool)) :++ ("arrangeSingletons",+ test (arrangeSingletons ::+ TimeTimeList.T TimeDiff Char -> Bool)) :+ ("arrangeDelay",+ test (arrangeDelay ::+ TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) :+ ("arrangeSimple",+ test (arrangeSimple ::+ TimeTimeList.T TimeDiff (TimeTimeList.T TimeDiff Char) -> Bool)) :+ ("arrangeAbsolute",+ test (arrangeAbsolute ::+ TimeTimeList.T TimeDiff (TimeTimeList.T TimeDiff Char) -> Bool)) :+ ("arrangeInfinity",+ test (arrangeInfinity ::+ NonEmptyList TimeDiff (NonEmptyList TimeDiff Char) -> Bool)) : ("coincidentFlatten", test (coincidentFlatten :: TimeTimeList.T TimeDiff Char -> Bool)) :