{- | Copyright : (c) Henning Thielemann 2007-2010 Maintainer : haskell@henning-thielemann.de Stability : stable Portability : Haskell 98 Event lists starting with a time difference and ending with a time difference. -} module Data.EventList.Relative.TimeTime (T, mapBody, mapTime, zipWithBody, zipWithTime, unzip, concatMapMonoid, traverse, traverse_, traverseBody, traverseTime, mapM, mapM_, mapBodyM, mapTimeM, getTimes, getBodies, duration, merge, mergeBy, insert, {- insertBy, -} pad, moveForward, moveForwardRestricted, moveBackward, arrange, arrangeBy, moveForwardRestrictedBy, moveForwardRestrictedByQueue, moveForwardRestrictedByStrict, decreaseStart, delay, filter, partition, partitionMaybe, partitionMaybeR, slice, foldr, foldl, pause, isPause, cons, snoc, viewL, viewR, switchL, switchR, mapMaybe, catMaybes, catMaybesR, append, concat, concatNaive, cycle, cycleNaive, reverse, splitAtTime, takeTime, dropTime, forceTimeHead, discretize, resample, collectCoincident, flatten, mapCoincident, normalize, isNormalized, toAbsoluteEventList, fromAbsoluteEventList, ) where import Data.EventList.Relative.TimeTimePrivate as TimeTimePriv import qualified Data.EventList.Relative.BodyTimePrivate as BodyTimePriv import qualified Data.EventList.Relative.TimeBody as TimeBodyList import qualified Data.EventList.Absolute.TimeTimePrivate as AbsoluteEventPriv import qualified Data.EventList.Absolute.TimeTime as AbsoluteEventList -- 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 qualified Data.List as List import qualified Data.EventList.Utility as Utility 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.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), ) import Prelude hiding (null, foldr, foldl, map, filter, concat, cycle, reverse, sequence, sequence_, mapM, mapM_, unzip, ) pause :: time -> T time body pause = Cons . Uniform.singleton isPause :: T time body -> Bool isPause = Uniform.isSingleton . decons getBodies :: T time body -> [body] getBodies = Uniform.getFirsts . decons getTimes :: T time body -> [time] getTimes = Uniform.getSeconds . decons duration :: NonNeg.C time => T time body -> time duration = NonNeg.sum . getTimes cons :: time -> body -> T time body -> T time body cons time body = lift (Uniform.cons time body) snoc :: T time body -> body -> time -> T time body snoc xs body time = Cons $ (Uniform.snoc $~~ xs) body time viewL :: T time body -> (time, Maybe (body, T time body)) viewL = mapSnd (fmap (mapSnd Cons)) . Mixed.viewL . decons {-# INLINE switchL #-} switchL :: (time -> a) -> ((time, body) -> T time body -> a) -> T time body -> a switchL f g = Mixed.switchL f (\t b -> g (t,b) . Cons) . decons viewR :: T time body -> (Maybe (T time body, body), time) viewR = mapFst (fmap (mapFst Cons)) . Mixed.viewR . decons {-# INLINE switchR #-} switchR :: (time -> a) -> (T time body -> body -> time -> a) -> T time body -> a switchR f g = Mixed.switchR f (g . Cons) . decons mapBody :: (body0 -> body1) -> T time body0 -> T time body1 mapBody = lift . Uniform.mapFirst mapTime :: (time0 -> time1) -> T time0 body -> T time1 body mapTime = lift . Uniform.mapSecond zipWithBody :: (body0 -> body1 -> body2) -> [body0] -> T time body1 -> T time body2 zipWithBody f = lift . Uniform.zipWithFirst f zipWithTime :: (time0 -> time1 -> time2) -> (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 => (time -> m) -> (body -> m) -> T time body -> m concatMapMonoid f g = Uniform.concatMapMonoid g f . decons traverse :: Applicative m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) traverse f g = liftA (Uniform.traverse g f) traverse_ :: Applicative m => (time -> m ()) -> (body -> m ()) -> T time body -> m () traverse_ f g = Uniform.traverse_ g f . decons traverseBody :: Applicative m => (body0 -> m body1) -> T time body0 -> m (T time body1) traverseBody f = liftA (Uniform.traverseFirst f) traverseTime :: Applicative m => (time0 -> m time1) -> T time0 body -> m (T time1 body) traverseTime f = liftA (Uniform.traverseSecond f) mapM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) mapM f g = unwrapMonad . traverse (WrapMonad . f) (WrapMonad . g) mapM_ :: Monad m => (time -> m ()) -> (body -> m ()) -> T time body -> m () mapM_ f g = unwrapMonad . traverse_ (WrapMonad . f) (WrapMonad . g) mapBodyM :: Monad m => (body0 -> m body1) -> T time body0 -> m (T time body1) mapBodyM f = unwrapMonad . traverseBody (WrapMonad . f) mapTimeM :: Monad m => (time0 -> m time1) -> T time0 body -> m (T time1 body) mapTimeM f = unwrapMonad . traverseTime (WrapMonad . f) {- | Sort coincident elements. -} normalize :: (Ord body, NonNeg.C time) => T time body -> T time body normalize = mapCoincident List.sort isNormalized :: (NonNeg.C time, Ord body) => T time body -> Bool isNormalized = all isAscending . getBodies . collectCoincident {- | The first important function is 'merge' which merges the events of two lists into a new time order list. -} merge :: (NonNeg.C time, Ord body) => T time body -> T time body -> T time body merge = mergeBy (<) {- Could be implemented using 'splitAt' and 'insert'. -} mergeBy :: (NonNeg.C time) => (body -> body -> Bool) -> T time body -> T time body -> T time body 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 Haskore/section equivalence. It is also necessary to assert a unique representation 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. -} insert :: (NonNeg.C time, Ord body) => time -> body -> T time body -> T time body insert = insertBy (<) {- Ordering of bodies at the same time could be simplified using collectCoincident. -} insertBy :: (NonNeg.C time) => (body -> body -> Bool) -> time -> body -> T time body -> T time body insertBy before t0 me0 = let recurseTime t = 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 {- 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 :: (Ord time, Num 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 zero) {- | 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, Num 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 (\_ _ -> True) 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 zero) concat :: (NonNeg.C time) => [T time body] -> T time body concat = mconcat {- | 'concat' and 'concatNaive' are essentially the same. 'concat' must use 'foldr' in order to work on infinite lists, however if there are many empty lists, summing of their durations will be done from right to left, which is inefficient. Thus we detect subsequent empty lists and merge them from left to right. -} concatNaive :: (NonNeg.C time) => [T time body] -> T time body concatNaive = List.foldr append (pause zero) {- | Uses sharing. -} cycle :: (NonNeg.C time) => T time body -> T time body cycle = switchTimeL (\t0 xs -> consTime t0 $ BodyTimePriv.cycle $ BodyTimePriv.mapTimeLast (add t0) xs) cycleNaive :: (NonNeg.C time) => T time body -> T time body cycleNaive = concat . List.repeat {- | If there is an event at the cutting time, this event is returned in the suffix part. That is @splitAtTime t0 (t0 ./ x /. t1 ./ empty) == (pause t0, 0 ./ x /. t1 ./ empty)@ -} {- It could also be implemented by inserting a marker element and then splitting at this element. I hope that the current manual recursion routine is the most efficient solution. -} splitAtTime :: (NonNeg.C time) => time -> T time body -> (T time body, T time body) splitAtTime t0 = switchTimeL (\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 takeTime t = fst . splitAtTime t dropTime :: (NonNeg.C time) => time -> T time body -> T time body -- 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 (-| dif) collectCoincident :: (NonNeg.C time) => T time body -> T time [body] collectCoincident = mapTimeInit TimeBodyList.collectCoincident mapCoincident :: (NonNeg.C time) => ([a] -> [b]) -> T time a -> T time b mapCoincident f = flatten . mapBody f . collectCoincident {- | Analogously to the 'concat' \/ 'concatNaive' pair we have to versions of 'filter', where the clever implementation sums up pauses from the beginning to the end. -} filter :: (NonNeg.C time) => (body -> Bool) -> T time body -> T time body filter p = mapMaybe (\b -> toMaybe (p b) b) mapMaybe :: (NonNeg.C time) => (body0 -> Maybe body1) -> T time body0 -> T time body1 mapMaybe f = catMaybes . mapBody f {- | Adds times in a left-associative fashion. Use this if the time is a strict data type. -} catMaybes :: (NonNeg.C time) => T time (Maybe body) -> T time body 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 :: (NonNeg.C time) => T time (Maybe body) -> T time body catMaybesR = foldr (mapTimeHead . add) (maybe id (cons zero)) (pause zero) partition :: (NonNeg.C time) => (body -> Bool) -> T time body -> (T time body, T time body) partition p = mapPair (mapTime NonNeg.sum, mapTime NonNeg.sum) . mapPair (Cons, Cons) . Uniform.partitionFirst p . decons partitionMaybe :: (NonNeg.C time) => (body0 -> Maybe body1) -> T time body0 -> (T time body1, T time body0) partitionMaybe f = mapPair (mapTime NonNeg.sum . Cons, mapTime NonNeg.sum . Cons) . Uniform.partitionMaybeFirst f . decons {- | Cf. 'catMaybesR' -} partitionMaybeR :: (NonNeg.C time) => (body0 -> Maybe body1) -> T time body0 -> (T time body1, T time body0) partitionMaybeR f = mapPair (mapTime (List.foldr add zero), mapTime (List.foldr add zero)) . mapPair (Cons, Cons) . Uniform.partitionMaybeFirst f . decons {- | Since we need it later for MIDI generation, we will also define a slicing into equivalence classes of events. -} slice :: (Eq a, NonNeg.C time) => (body -> a) -> T time body -> [(a, T time body)] slice = Utility.slice (fmap fst . viewBodyL . snd . viewTimeL) partition foldl :: (a -> time -> b) -> (b -> body -> a) -> a -> T time body -> b foldl f g x = Uniform.foldl g f x . decons reverse :: T time body -> T time body reverse = lift Uniform.reverse discretize :: (NonNeg.C time, RealFrac time, NonNeg.C i, Integral i) => T time body -> T i body discretize = flip evalState 0.5 . mapTimeM floorDiff resample :: (NonNeg.C time, RealFrac time, NonNeg.C i, Integral i) => time -> T time body -> T i body resample rate = discretize . mapTime (rate*) toAbsoluteEventList :: (Num time) => time -> T time body -> AbsoluteEventList.T time body toAbsoluteEventList start = AbsoluteEventPriv.Cons . decons . flip evalState start . mapTimeM (\dur -> modify (dur+) >> get) fromAbsoluteEventList :: (Num time) => AbsoluteEventList.T time body -> T time body fromAbsoluteEventList = flip evalState 0 . mapTimeM (\time -> do lastTime <- get; put time; return (time-lastTime)) . Cons . AbsoluteEventPriv.decons