module Data.EventList.Relative.TimeBody
(T,
empty, singleton, null,
viewL, viewR, switchL, switchR, cons, snoc,
fromPairList, toPairList,
getTimes, getBodies, duration,
mapBody, mapTime,
zipWithBody, zipWithTime,
concatMapMonoid,
traverse, traverse_, traverseBody, traverseTime,
mapM, mapM_, mapBodyM, mapTimeM,
foldr, foldrPair,
merge, mergeBy, insert, insertBy,
moveForward,
decreaseStart, delay, filter, partition, partitionMaybe, 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 Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), )
import Data.Monoid (Monoid, )
import qualified Numeric.NonNegative.Class as NonNeg
import Data.Tuple.HT (mapFst, mapSnd, mapPair, )
import Data.Maybe.HT (toMaybe, )
import Data.List.HT (isAscending, )
import Data.EventList.Utility (floorDiff, beforeBy, )
import Control.Monad.Trans.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
switchL :: c -> ((time, body) -> T time body -> c) -> T time body -> c
switchL f g = Disp.switchL f (\ t b -> g (t,b) . Cons) . decons
switchR :: c -> (T time body -> (time, body) -> c) -> T time body -> c
switchR f g = Disp.switchR f (\xs t b -> g (Cons xs) (t,b)) . 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)
zipWithBody ::
(body0 -> body1 -> body2) ->
[body0] -> T time body1 -> T time body2
zipWithBody f = lift . Disp.zipWithSecond f
zipWithTime ::
(time0 -> time1 -> time2) ->
[time0] -> T time1 body -> T time2 body
zipWithTime f = lift . Disp.zipWithFirst f
concatMapMonoid :: Monoid m =>
(time -> m) -> (body -> m) ->
T time body -> m
concatMapMonoid f g =
Disp.concatMapMonoid f g . decons
traverse :: Applicative m =>
(time0 -> m time1) -> (body0 -> m body1) ->
T time0 body0 -> m (T time1 body1)
traverse f g = liftA (Disp.traverse f g)
traverse_ :: Applicative m =>
(time -> m ()) -> (body -> m ()) ->
T time body -> m ()
traverse_ f g = Disp.traverse_ f g . decons
traverseBody :: Applicative m =>
(body0 -> m body1) -> T time body0 -> m (T time body1)
traverseBody f = liftA (Disp.traverseSecond f)
traverseTime :: Applicative m =>
(time0 -> m time1) -> T time0 body -> m (T time1 body)
traverseTime f = liftA (Disp.traverseFirst 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)
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
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 =
Cons .
fst . Mixed.viewSecondR .
Uniform.mapSecond sum .
Uniform.catMaybesFirst .
flip Mixed.snocSecond (error "catMaybes: no trailing time") .
decons
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 recourse t0 t1 =
switchL
(empty, empty)
(\ (t, b) es ->
let t0' = t0 + t
t1' = t1 + t
in if p b
then mapFst (cons t0' b) (recourse 0 t1' es)
else mapSnd (cons t1' b) (recourse t0' 0 es))
in recourse
partitionMaybe :: (Num time) =>
(body0 -> Maybe body1) -> T time body0 ->
(T time body1, T time body0)
partitionMaybe f =
mapPair (catMaybes, catMaybes) .
foldrPair (\t a ->
let mb = f a
a1 = maybe (Just a) (const Nothing) mb
in mapPair (cons t mb, cons t a1))
(empty, empty)
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 = mapPair (Cons, Cons) . Disp.spanSecond p . decons
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 .
Mixed.switchFirstL
Disp.empty
(\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)) .
decons
mapCoincident :: (NonNeg.C time) =>
([a] -> [b]) -> T time a -> T time b
mapCoincident f = flatten . mapBody f . collectCoincident
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 isAscending . 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 =
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 (ytxt) yb ys
else uncurry cons y $ mergeBy before ys $ cons (xtyt) xb xs
insert :: (NonNeg.C time, Ord body) =>
time -> body -> T time body -> T time body
insert t0 me0 =
switchL
(singleton t0 me0)
(\ mev1@(t1, me1) mevs ->
let mev0 = (t0, me0)
in if mev0 < mev1
then uncurry cons mev0 $ cons (t1t0) me1 mevs
else uncurry cons mev1 $ insert (t0t1) me0 mevs)
insertBy :: (NonNeg.C time) =>
(body -> body -> Bool) ->
time -> body -> T time body -> T time body
insertBy before =
let recourse t0 me0 =
switchL
(singleton t0 me0)
(\ mev1@(t1, me1) mevs ->
if beforeBy before (t0, me0) mev1
then cons t0 me0 $ cons (t1t0) me1 mevs
else cons t1 me1 $ recourse (t0t1) me0 mevs)
in recourse
moveForward :: (NonNeg.C time) =>
T time (time, body) -> T time body
moveForward =
fromAbsoluteEventList .
AbsoluteEventList.moveForward .
toAbsoluteEventList 0
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+)
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