module Data.EventList.Relative.TimeTime
(T,
mapBody, mapTime,
mapM, mapM_, mapBodyM, mapTimeM,
getTimes, getBodies, duration,
merge, mergeBy, insert, 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
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
merge :: (NonNeg.C time, Ord body) =>
T time body -> T time body -> T time body
merge = mergeBy (<)
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)) ->
if before b0 b1
then consBody b0 $ mergeBy before xs1 $ consTime 0 ys
else consBody b1 $ mergeBy before ys1 $ consTime 0 xs
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 (ytxt) ys)
(viewBodyL xs)
insert :: (NonNeg.C time, Ord body) =>
time -> body -> T time body -> T time body
insert = insertBy (<)
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<t1
then cons t me0 (consTime (t1t) xs)
else recurseBody t1 t xs)
. viewTimeL
recurseBody t1 t =
maybe
(cons t me0 $ pause 0)
(\(me1,xs) ->
consTime t1 $
if t==t1 && before me0 me1
then consBody me0 (cons 0 me1 xs)
else consBody me1 (recurseTime (tt1) xs))
. viewBodyL
in recurseTime t0
pad :: (NonNeg.C time) =>
time -> T time body -> T time body
pad time = mergeBy (\ _ _ -> False) (pause time)
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)
moveForwardRestricted :: (Ord body, NonNeg.C time) =>
time -> T time (time, body) -> T time body
moveForwardRestricted maxTime =
decreaseStart maxTime .
moveBackward .
mapBody (mapFst (maxTime)) .
pad maxTime
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
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) (maxTimet) (Just b))
(pause maxTime)
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 (maxTimet) b)
(pause maxTime)
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
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))
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 (:[]))
concatNaive :: (NonNeg.C time) =>
[T time body] -> T time body
concatNaive = List.foldr append (pause 0)
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
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 (t1t0) xs)
else
maybe
(pause t1, pause 0)
(\(b,ys) -> mapFst (cons t1 b) (splitAtTime (t0t1) 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
Disp.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
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
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 (timelastTime)) .
Cons . AbsoluteEventPriv.decons