{- | Copyright : (c) Henning Thielemann 2007 Maintainer : haskell@henning-thielemann.de Stability : stable Portability : Haskell 98 Event list with absolute times starting with a time and ending with a body -} module Data.EventList.Absolute.TimeTime (T, pause, isPause, viewL, switchL, cons, snoc, mapBody, mapTime, concatMapMonoid, mapM, mapM_, mapBodyM, mapTimeM, getTimes, getBodies, duration, merge, mergeBy, insert, insertBy, moveForward, decreaseStart, delay, filter, partition, slice, foldr, mapMaybe, catMaybes, normalize, isNormalized, collectCoincident, flatten, mapCoincident, append, concat, cycle, discretize, resample, ) where import Data.EventList.Absolute.TimeTimePrivate import Data.EventList.Absolute.TimeBodyPrivate (($~)) import qualified Data.EventList.Absolute.TimeBodyPrivate as TimeBodyPriv import qualified Data.EventList.Absolute.TimeBody as TimeBodyList 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.List.HT as ListHT import qualified Data.EventList.Utility as Utility import Data.Tuple.HT (mapSnd, mapPair, ) import Data.Maybe.HT (toMaybe, ) import Data.List.HT (isAscending, ) import qualified Control.Monad as Monad import Control.Monad.Trans.State (state, evalState) import Data.Monoid (Monoid, ) import Data.Maybe (fromMaybe) 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 = snd . viewTimeR -- duration = last . 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.viewFirstL) . Mixed.viewSecondL . 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 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 concatMapMonoid :: Monoid m => (time -> m) -> (body -> m) -> T time body -> m concatMapMonoid f g = Uniform.concatMapMonoid g f . decons 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 foldr :: (time -> a -> b) -> (body -> b -> a) -> a -> T time body -> b foldr f g x = Uniform.foldr g f x . decons 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 = mapTimeInit TimeBodyList.catMaybes {- Could be implemented more easily in terms of Uniform.partition -} partition :: (body -> Bool) -> T time body -> (T time body, T time body) partition p = switchTimeR (\ xs t -> mapPair (flip snocTime t, flip snocTime t) (TimeBodyList.partition p xs)) slice :: (Eq a, Num time) => (body -> a) -> T time body -> [(a, T time body)] slice = Utility.slice (fmap fst . snd . viewL) partition collectCoincident :: Eq time => T time body -> T time [body] collectCoincident = Cons . Mixed.switchSecondL (\ t0 -> Mixed.consSecond t0 . Mixed.mapFirstInit (Uniform.catMaybesFirst . flip evalState (Just t0) . Uniform.mapFirstM (\time -> state $ \ oldTime -> (Monad.guard (time /= oldTime) >> time, time)) . Uniform.mapFirst Just)) . decons flatten :: (Ord time, Num time) => T time [body] -> T time body flatten = mapTimeInit TimeBodyList.flatten {- | Apply a function to the lists of coincident events. -} mapCoincident :: (Ord time, Num 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 :: (Ord time, Num time, Ord body) => T time body -> T time body normalize = mapCoincident List.sort isNormalized :: (Ord time, Num time, Ord body) => T time body -> Bool isNormalized = all isAscending . getBodies . collectCoincident merge :: (Ord time, Ord body) => T time body -> T time body -> T time body merge = mergeBy (<) mergeBy :: (Ord time) => (body -> body -> Bool) -> T time body -> T time body -> T time body mergeBy before xs0 ys0 = let (xs,xt) = viewTimeR xs0 (ys,yt) = viewTimeR ys0 in snocTime (TimeBodyList.mergeBy before xs ys) (max xt yt) insert :: (Ord time, Ord body) => time -> body -> T time body -> T time body insert = insertBy (<) insertBy :: (Ord time) => (body -> body -> Bool) -> time -> body -> T time body -> T time body insertBy before t0 me0 mevs1 = let mev0 = (t0, me0) in switchL (\t1 -> uncurry cons mev0 $ pause (max t0 t1)) (\mev1 mevs -> if Utility.beforeBy before mev0 mev1 then uncurry cons mev0 $ mevs1 else uncurry cons mev1 $ uncurry (insertBy before) mev0 mevs) 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 = mapTimeInit TimeBodyList.moveForward append :: (Ord time, Num time) => T time body -> T time body -> T time body append = switchTimeR (\xs t -> lift (Mixed.appendDisparateUniform $~ xs) . delay t) concat :: (Ord time, Num time) => [T time body] -> T time body concat xs = let ts0 = scanl (+) 0 (List.map duration xs) (ts,dur) = fromMaybe (error "list of accumulated times is always non-empty") (ListHT.viewR ts0) in snocTime (TimeBodyPriv.Cons $ Disp.concat $ List.map TimeBodyPriv.decons $ zipWith TimeBodyList.delay ts (List.map (fst . viewTimeR) xs)) dur cycle :: (Ord time, Num time) => T time body -> T time body cycle = concat . List.repeat decreaseStart :: (Ord time, Num time) => time -> T time body -> T time body decreaseStart dif = Cons . Mixed.switchSecondL (\ t xs -> Mixed.consSecond (if t>=dif then t-dif else error "decreaseStart: difference too big") (Disp.mapSecond (subtract dif) xs)) . decons delay :: (Ord time, Num time) => time -> T time body -> T time body delay dif = if dif>=0 then mapTime (dif+) else error "delay: negative delay" discretize :: (RealFrac time, Integral i) => T time body -> T i body discretize = mapTime round resample :: (RealFrac time, Integral i) => time -> T time body -> T i body resample rate = discretize . mapTime (rate*)