{- | 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 body. The time is stored in differences between the events. Thus there is no increase of time information for long, or even infinite, streams of events. Further on, the time difference is stored in the latter of two neighbouring events. This is necessary for real-time computing where it is not known whether and when the next event happens. -} module Data.EventList.Relative.TimeBody (T, empty, singleton, null, viewL, viewR, cons, snoc, fromPairList, toPairList, getTimes, getBodies, duration, mapBody, mapTime, mapM, mapM_, mapBodyM, mapTimeM, foldr, foldrPair, merge, mergeBy, insert, insertBy, decreaseStart, delay, filter, partition, slice, span, mapMaybe, catMaybes, normalize, isNormalized, collectCoincident, flatten, mapCoincident, append, concat, cycle, discretize, resample, toAbsoluteEventList, fromAbsoluteEventList, ) where import Data.EventList.Relative.TimeBodyPrivate import qualified Data.EventList.Relative.BodyBodyPrivate as BodyBodyPriv import qualified Data.EventList.Absolute.TimeBodyPrivate as AbsoluteEventPriv import qualified Data.EventList.Absolute.TimeBody 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, mapFst, mapSnd, toMaybe, isMonotonic, beforeBy) import Control.Monad.State (evalState, modify, get, put) import Prelude hiding (mapM, mapM_, null, foldr, filter, concat, cycle, span) empty :: T time body empty = Cons Disp.empty null :: T time body -> Bool null = Disp.null . decons singleton :: time -> body -> T time body singleton time body = Cons $ Disp.singleton time body cons :: time -> body -> T time body -> T time body cons time body = lift (Disp.cons time body) snoc :: T time body -> time -> body -> T time body snoc xs time body = Cons $ (Disp.snoc $~* xs) time body viewL :: T time body -> Maybe ((time, body), T time body) viewL = fmap (mapSnd Cons) . Disp.viewL . decons viewR :: T time body -> Maybe (T time body, (time, body)) viewR = fmap (mapFst Cons) . Disp.viewR . decons fromPairList :: [(a,b)] -> T a b fromPairList = Cons . Disp.fromPairList toPairList :: T a b -> [(a,b)] toPairList = Disp.toPairList . decons getBodies :: T time body -> [body] getBodies = Disp.getSeconds . decons getTimes :: T time body -> [time] getTimes = Disp.getFirsts . decons duration :: Num time => T time body -> time duration = sum . getTimes mapBody :: (body0 -> body1) -> T time body0 -> T time body1 mapBody f = lift (Disp.mapSecond f) mapTime :: (time0 -> time1) -> T time0 body -> T time1 body mapTime f = lift (Disp.mapFirst f) mapM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) mapM f g = liftM (Disp.mapM f g) mapM_ :: Monad m => (time -> m ()) -> (body -> m ()) -> T time body -> m () mapM_ f g = Disp.mapM_ f g . decons mapBodyM :: Monad m => (body0 -> m body1) -> T time body0 -> m (T time body1) mapBodyM f = liftM (Disp.mapSecondM f) mapTimeM :: Monad m => (time0 -> m time1) -> T time0 body -> m (T time1 body) mapTimeM f = liftM (Disp.mapFirstM f) foldr :: (time -> a -> b) -> (body -> b -> a) -> b -> T time body -> b foldr f g x = Disp.foldr f g x . decons foldrPair :: (time -> body -> a -> a) -> a -> T time body -> a foldrPair f x = Disp.foldrPair f x . 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, because then the events need not to be altered on splits. But absolute time points can't be used for infinite music thus we take the burden of adapting the time differences when an event is removed from the performance list and put to the list of events of a particular instrument. @t0@ is the time gone since the last event in the first partition, @t1@ is the time gone since the last event in the second partition. Note, that using 'Data.EventList.Utility.mapPair' we circumvent the following problem: Since the recursive call to 'partition' may end up with Bottom, pattern matching with, say \expression{(es0,es1)}, will halt the bounding of the variables until the most inner call to 'partition' is finished. This never happens. If the pair constructor is made strict, that is we write \expression{~(es0,es1)}, then everything works. Also avoiding pattern matching and using 'fst' and 'snd' would help. -} 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 -} partition :: (Num time) => (body -> Bool) -> T time body -> (T time body, T time body) partition p = partitionRec p 0 0 partitionRec :: (Num time) => (body -> Bool) -> time -> time -> T time body -> (T time body, T time body) partitionRec p = let recurse t0 t1 = maybe (empty, empty) (\ ((t, b), es) -> let t0' = t0 + t t1' = t1 + t in if p b then mapFst (cons t0' b) (recurse 0 t1' es) else mapSnd (cons t1' b) (recurse t0' 0 es)) . viewL in recurse {- | 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 (snd . fst) . viewL) partition span :: (body -> Bool) -> T time body -> (T time body, T time body) span p = Utility.mapPair (Cons, Cons) . Disp.spanSecond p . decons {- | 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. -} collectCoincident :: (NonNeg.C time) => T time body -> T time [body] collectCoincident = mapTimeTail $ BodyBodyPriv.lift $ Uniform.filterFirst (0<) flatten :: (NonNeg.C time) => T time [body] -> T time body flatten = Cons . maybe Disp.empty (uncurry $ \time -> unlift (delay time) . fst . Mixed.viewSecondR . Uniform.foldr (Mixed.appendUniformUniform . Uniform.fromSecondList 0) Mixed.consSecond Disp.empty . Uniform.mapSecond sum . Uniform.filterSecond (not . List.null)) . Mixed.viewFirstL . decons {- | 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 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 (<) {- | 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. -} {- 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 = 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 {- | 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 :: (NonNeg.C time, Ord body) => time -> body -> T time body -> T time body insert t0 me0 = maybe (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) . viewL insertBy :: (NonNeg.C time, Ord body) => (body -> body -> Bool) -> time -> body -> T time body -> T time body insertBy before t0 me0 = maybe (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 $ insert (t0-t1) me0 mevs) . viewL append :: T time body -> T time body -> T time body append xs = lift (Disp.append $~* xs) concat :: [T time body] -> T time body concat = Cons . Disp.concat . map decons cycle :: T time body -> T time body cycle = lift Disp.cycle 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+) {- | We provide 'discretize' and 'resample' for discretizing the time information. When converting the precise relative event times to the integer relative event times we have to prevent accumulation of rounding errors. We avoid this problem with a stateful conversion which remembers each rounding error we make. This rounding error is used to correct the next rounding. Given the relative time and duration of an event the function 'floorDiff' creates a 'Control.Monad.State.State' which computes the rounded relative time. It is corrected by previous rounding errors. The resulting event list may have differing time differences which were equal before discretization, but the overall timing is uniformly close to the original. We use 'floorDiff' rather than 'Utility.roundDiff' in order to compute exclusively with non-negative numbers. -} 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*) {- | We tried hard to compute everything with respect to relative times. However sometimes we need absolute time values. -} 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