{- | Copyright : (c) Henning Thielemann 2007 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, mapM, mapM_, mapBodyM, mapTimeM, getTimes, getBodies, duration, 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, append, concat, concatNaive, cycle, cycleNaive, splitAtTime, takeTime, dropTime, discretize, resample, collectCoincident, flatten, mapCoincident, normalize, isNormalized, toAbsoluteEventList, fromAbsoluteEventList, ) where import Data.EventList.Relative.TimeTimePrivate as TimeTimePriv import Data.EventList.Relative.TimeBodyPrivate (($~*)) 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 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, gets, put, liftM2, ) import Prelude hiding (null, foldr, map, filter, concat, cycle, sequence, sequence_, mapM, mapM_) 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 :: Num time => T time body -> time duration = 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 viewR :: T time body -> (Maybe (T time body, body), time) viewR = mapFst (fmap (mapFst Cons)) . Mixed.viewR . 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 mapM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) mapM f g = liftM (Uniform.mapM g f) mapM_ :: Monad m => (time -> m ()) -> (body -> m ()) -> T time body -> m () mapM_ f g = Uniform.mapM_ g f . decons mapBodyM :: Monad m => (body0 -> m body1) -> T time body0 -> m (T time body1) mapBodyM = liftM . Uniform.mapFirstM mapTimeM :: Monad m => (time0 -> m time1) -> T time0 body -> m (T time1 body) mapTimeM = liftM . Uniform.mapSecondM {- | 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 isMonotonic . 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 as 'splitAt' and 'insert'. -} 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 recurse 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 maybe ys0 (\(b,xs1) -> consTime xt $ consBody b $ mergeBy before xs1 $ consTime (yt-xt) ys) (viewBodyL xs) {- | 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. -} 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 = (\ (t1,xs) -> if t consTime t1 $ if t==t1 && before me0 me1 then consBody me0 (cons 0 me1 xs) 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 append = (\(xs, t) -> lift (Mixed.appendDisparateUniform $~* xs) . delay t) . viewTimeR concat :: (NonNeg.C time) => [T time body] -> T time body concat = flatten . consTime 0 . BodyTimePriv.concat . List.map (consBody [] . mapBody (:[])) {- | '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 0) {- | Uses sharing. -} cycle :: (NonNeg.C time) => T time body -> T time body cycle = (\(t0,xs) -> consTime t0 $ BodyTimePriv.cycle $ BodyTimePriv.mapTimeLast (+t0) xs) . viewTimeL 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 = (\(t1,xs) -> if t0<=t1 then (pause t0, consTime (t1-t0) xs) else maybe (pause t1, pause 0) (\(b,ys) -> mapFst (cons t1 b) (splitAtTime (t0-t1) ys)) (viewBodyL xs)) . viewTimeL 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 decreaseStart :: (NonNeg.C time) => time -> T time body -> T time body decreaseStart dif = mapTimeHead (subtract dif) delay :: (NonNeg.C time) => time -> T time body -> T time body delay dif = mapTimeHead (dif+) {- | -} collectCoincident :: (NonNeg.C time) => T time body -> T time [body] collectCoincident = mapTimeInit TimeBodyList.collectCoincident flatten :: (Num time) => T time [body] -> T time body flatten = Cons . Uniform.foldr (Mixed.appendUniformUniform . Uniform.fromSecondList 0) Mixed.consSecond -- consTime Disp.empty . -- (\(b:bs) xs -> consBody b (List.foldr (cons 0) xs bs)) empty . Uniform.mapSecond sum . Uniform.filterFirst (not . List.null) . decons 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 :: (Num time) => (body -> Bool) -> T time body -> T time body filter p = mapMaybe (\b -> toMaybe (p b) b) 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 = mapTime sum . lift Uniform.catMaybesFirst partition :: (Num time) => (body -> Bool) -> T time body -> (T time body, T time body) partition p = mapPair (mapTime sum, mapTime sum) . mapPair (Cons, Cons) . Uniform.partitionFirst p . decons {- | Since we need it later for MIDI generation, we will also define a slicing into equivalence classes of events. -} slice :: (Eq a, Num 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 {- | -} 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