diff --git a/event-list.cabal b/event-list.cabal --- a/event-list.cabal +++ b/event-list.cabal @@ -1,5 +1,5 @@ Name: event-list -Version: 0.0.6 +Version: 0.0.7 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -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 diff --git a/src-1/Test/Instances.hs b/src-1/Test/Instances.hs deleted file mode 100644 --- a/src-1/Test/Instances.hs +++ /dev/null @@ -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 diff --git a/src/Data/AlternatingList/List/Disparate.hs b/src/Data/AlternatingList/List/Disparate.hs --- a/src/Data/AlternatingList/List/Disparate.hs +++ b/src/Data/AlternatingList/List/Disparate.hs @@ -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)) diff --git a/src/Data/AlternatingList/List/Uniform.hs b/src/Data/AlternatingList/List/Uniform.hs --- a/src/Data/AlternatingList/List/Uniform.hs +++ b/src/Data/AlternatingList/List/Uniform.hs @@ -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)) diff --git a/src/Data/EventList/Absolute/TimeBody.hs b/src/Data/EventList/Absolute/TimeBody.hs --- a/src/Data/EventList/Absolute/TimeBody.hs +++ b/src/Data/EventList/Absolute/TimeBody.hs @@ -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) => diff --git a/src/Data/EventList/Absolute/TimeTime.hs b/src/Data/EventList/Absolute/TimeTime.hs --- a/src/Data/EventList/Absolute/TimeTime.hs +++ b/src/Data/EventList/Absolute/TimeTime.hs @@ -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 diff --git a/src/Data/EventList/Relative/BodyTime.hs b/src/Data/EventList/Relative/BodyTime.hs --- a/src/Data/EventList/Relative/BodyTime.hs +++ b/src/Data/EventList/Relative/BodyTime.hs @@ -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 diff --git a/src/Data/EventList/Relative/TimeBody.hs b/src/Data/EventList/Relative/TimeBody.hs --- a/src/Data/EventList/Relative/TimeBody.hs +++ b/src/Data/EventList/Relative/TimeBody.hs @@ -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 diff --git a/src/Data/EventList/Relative/TimeTime.hs b/src/Data/EventList/Relative/TimeTime.hs --- a/src/Data/EventList/Relative/TimeTime.hs +++ b/src/Data/EventList/Relative/TimeTime.hs @@ -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 diff --git a/src/Test/Data/EventList/Relative/BodyEnd.hs b/src/Test/Data/EventList/Relative/BodyEnd.hs --- a/src/Test/Data/EventList/Relative/BodyEnd.hs +++ b/src/Test/Data/EventList/Relative/BodyEnd.hs @@ -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)) : diff --git a/src/Test/Data/EventList/Relative/TimeEnd.hs b/src/Test/Data/EventList/Relative/TimeEnd.hs --- a/src/Test/Data/EventList/Relative/TimeEnd.hs +++ b/src/Test/Data/EventList/Relative/TimeEnd.hs @@ -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)) :