{- | Copyright : (c) Henning Thielemann 2008 Maintainer : haskell@henning-thielemann.de Stability : stable Portability : Haskell 98 -} module Test.Data.EventList.Relative.BodyEnd (tests) where import Test.Utility import Test.QuickCheck (test) import qualified Data.EventList.Relative.TimeBody as TimeBodyList import qualified Data.EventList.Relative.TimeTime as TimeTimeList import qualified Data.EventList.Relative.TimeMixed as TimeMixedList import qualified Data.EventList.Relative.MixedBody as MixedBodyList import qualified Data.EventList.Relative.BodyBody as BodyBodyList import qualified Data.AlternatingList.List.Disparate as Disp import qualified Data.EventList.Relative.TimeBodyPrivate as TimeBodyPriv import Data.EventList.Relative.MixedBody ((/.), (./), empty) import qualified Numeric.NonNegative.Class as NonNeg import Numeric.NonNegative.Class ((-|)) import Data.EventList.Relative.TimeBody (isNormalized) import Data.EventList.Utility (mapPair, mapFst, ) import System.Random (Random, randomR, mkStdGen) import Control.Monad.State (State(State), evalState, gets, modify, ) import Control.Monad (liftM2) import Data.Maybe (isJust) import qualified Data.List as List import qualified Data.Char as Char viewLConsTime :: (Eq body, Eq time) => TimeBodyList.T time body -> Bool viewLConsTime xs = xs == maybe TimeBodyList.empty (uncurry MixedBodyList.consTime) (MixedBodyList.viewTimeL xs) viewLConsBody :: (Eq body, Eq time) => BodyBodyList.T time body -> Bool viewLConsBody xs = xs == uncurry MixedBodyList.consBody (MixedBodyList.viewBodyL xs) viewLInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool viewLInfinite = checkInfinite . maybe (error "viewBodyL: empty list") snd . TimeBodyList.viewL . makeInfiniteEventList consInfinite :: (NonNeg.C time, Eq body) => time -> body -> NonEmptyList time body -> Bool consInfinite time body = checkInfinite . TimeBodyList.cons time body . makeInfiniteEventList consTimeBodyInfinite :: (NonNeg.C time, Eq body) => time -> body -> NonEmptyList time body -> Bool consTimeBodyInfinite time body = checkInfinite . MixedBodyList.consTime time . MixedBodyList.consBody body . makeInfiniteEventList snocInfinite :: (NonNeg.C time, Eq body) => time -> body -> NonEmptyList time body -> Bool snocInfinite time body = checkInfinite . flip (flip TimeBodyList.snoc time) body . makeInfiniteEventList consInfix :: (NonNeg.C time, Eq body) => time -> body -> time -> body -> Bool consInfix t0 b0 t1 b1 = TimeBodyList.append (t0 /. b0 ./ empty) (t1 /. b1 ./ empty) == (t0 /. b0 ./ t1 /. b1 ./ empty) mapBodyComposition :: (Eq body2, Eq time) => (body0 -> body1) -> (body1 -> body2) -> TimeBodyList.T time body0 -> Bool mapBodyComposition f g evs = TimeBodyList.mapBody (g . f) evs == TimeBodyList.mapBody g (TimeBodyList.mapBody f evs) mapTimeComposition :: (Eq body, Eq time2) => (time0 -> time1) -> (time1 -> time2) -> TimeBodyList.T time0 body -> Bool mapTimeComposition f g evs = TimeBodyList.mapTime (g . f) evs == TimeBodyList.mapTime g (TimeBodyList.mapTime f evs) mapTimeBodyCommutative :: (Eq body1, Eq time1) => (time0 -> time1) -> (body0 -> body1) -> TimeBodyList.T time0 body0 -> Bool mapTimeBodyCommutative f g evs = TimeBodyList.mapBody g (TimeBodyList.mapTime f evs) == TimeBodyList.mapTime f (TimeBodyList.mapBody g evs) mapBodyInfinite :: (NonNeg.C time, Eq body1) => (body0 -> body1) -> NonEmptyList time body0 -> Bool mapBodyInfinite f = checkInfinite . TimeBodyList.mapBody f . makeInfiniteEventList mapTimeInfinite :: (NonNeg.C time0, Eq time1, Eq body) => (time0 -> time1) -> NonEmptyList time0 body -> Bool mapTimeInfinite f = checkInfinite . TimeBodyList.mapTime f . makeInfiniteEventList {- | Does only hold for monotonic functions. -} mapNormalize :: (NonNeg.C time, Ord body0, Ord body1) => (body0 -> body1) -> TimeBodyList.T time body0 -> Bool mapNormalize f = isNormalized . TimeBodyList.mapBody f . TimeBodyList.normalize appendLeftIdentity :: (NonNeg.C time, Eq body) => TimeBodyList.T time body -> Bool appendLeftIdentity xs = TimeBodyList.append TimeBodyList.empty xs == xs appendRightIdentity :: (NonNeg.C time, Eq body) => TimeBodyList.T time body -> Bool appendRightIdentity xs = TimeBodyList.append xs TimeBodyList.empty == xs appendAssociative :: (NonNeg.C time, Eq body) => TimeBodyList.T time body -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool appendAssociative xs ys zs = TimeBodyList.append xs (TimeBodyList.append ys zs) == TimeBodyList.append (TimeBodyList.append xs ys) zs appendCons :: (NonNeg.C time, Eq body) => time -> body -> TimeBodyList.T time body -> Bool appendCons time body xs = TimeBodyList.cons time body xs == TimeBodyList.append (TimeBodyList.cons time body TimeBodyList.empty) xs appendSplitAtTime :: (NonNeg.C time, Eq body) => time -> TimeBodyList.T time body -> Bool appendSplitAtTime t xs = xs == uncurry TimeMixedList.appendBodyEnd (TimeMixedList.splitAtTime t xs) mapBodyAppend :: (Eq body1, NonNeg.C time) => (body0 -> body1) -> TimeBodyList.T time body0 -> TimeBodyList.T time body0 -> Bool mapBodyAppend f xs ys = TimeBodyList.mapBody f (TimeBodyList.append xs ys) == TimeBodyList.append (TimeBodyList.mapBody f xs) (TimeBodyList.mapBody f ys) appendFirstInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> TimeBodyList.T time body -> Bool appendFirstInfinite xs = checkInfinite . TimeBodyList.append (makeInfiniteEventList xs) appendSecondInfinite :: (NonNeg.C time, Eq body) => TimeBodyList.T time body -> NonEmptyList time body -> Bool appendSecondInfinite xs = checkInfinite . TimeBodyList.append xs . makeInfiniteEventList decreaseStartDelay :: (NonNeg.C time, Eq body) => time -> TimeBodyList.T time body -> Bool decreaseStartDelay dif xs = xs == TimeBodyList.decreaseStart dif (TimeBodyList.delay dif xs) decreaseStartInfinite :: (NonNeg.C time, Eq body) => time -> NonEmptyList time body -> Bool decreaseStartInfinite dif = checkInfinite . TimeBodyList.decreaseStart dif . TimeBodyList.delay dif . makeInfiniteEventList delayAdditive :: (NonNeg.C time, Eq body) => time -> time -> TimeBodyList.T time body -> Bool delayAdditive dif0 dif1 xs = TimeBodyList.delay (dif0+dif1) xs == TimeBodyList.delay dif0 (TimeBodyList.delay dif1 xs) delayAppendPause :: (NonNeg.C time, Eq body) => time -> TimeBodyList.T time body -> Bool delayAppendPause dif xs = TimeBodyList.delay dif xs == TimeMixedList.appendBodyEnd (TimeTimeList.pause dif) xs delayInfinite :: (NonNeg.C time, Eq body) => time -> NonEmptyList time body -> Bool delayInfinite dif = checkInfinite . TimeBodyList.delay dif . makeInfiniteEventList splitAtTakeDropTime :: (NonNeg.C time, Eq body) => time -> TimeBodyList.T time body -> Bool splitAtTakeDropTime t xs = (TimeMixedList.takeTime t xs, TimeMixedList.dropTime t xs) == TimeMixedList.splitAtTime t xs takeTimeEndPause :: (NonNeg.C time, Ord body) => time -> TimeBodyList.T time body -> Bool takeTimeEndPause t xs = t == 0 || t >= TimeBodyList.duration xs || 0 < snd (TimeMixedList.viewTimeR (TimeMixedList.takeTime t xs)) takeTimeAppendFirst :: (NonNeg.C time, Eq body) => time -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool takeTimeAppendFirst t xs ys = TimeMixedList.takeTime t (TimeBodyList.append xs ys) == TimeTimeList.append (TimeMixedList.takeTime t xs) (TimeMixedList.takeTime (t -| TimeBodyList.duration xs) ys) takeTimeAppendSecond :: (NonNeg.C time, Eq body) => time -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool takeTimeAppendSecond t xs ys0 = -- the second list must not start with a zero pause let ys = TimeBodyList.delay 1 ys0 t1 = t+1 in TimeMixedList.takeTime (TimeBodyList.duration xs + t1) (TimeBodyList.append xs ys) == TimeMixedList.prependBodyEnd xs (TimeMixedList.takeTime t1 ys) takeTimeNormalize :: (NonNeg.C time, Ord body) => time -> TimeBodyList.T time body -> Bool takeTimeNormalize t = TimeTimeList.isNormalized . TimeMixedList.takeTime t . TimeBodyList.normalize dropTimeNormalize :: (NonNeg.C time, Ord body) => time -> TimeBodyList.T time body -> Bool dropTimeNormalize t = isNormalized . TimeMixedList.dropTime t . TimeBodyList.normalize takeTimeInfinite :: (NonNeg.C time, Ord body) => time -> NonEmptyList time body -> Bool takeTimeInfinite t = (t == ) . TimeTimeList.duration . TimeMixedList.takeTime t . makeUncollapsedInfiniteEventList dropTimeInfinite :: (NonNeg.C time, Ord body) => time -> NonEmptyList time body -> Bool dropTimeInfinite t = checkInfinite . TimeMixedList.dropTime t . makeUncollapsedInfiniteEventList durationPause :: (NonNeg.C time) => time -> Bool durationPause t = t == TimeBodyList.duration (TimeBodyList.singleton t (error "durationPause: no need to access body")) durationAppend :: (NonNeg.C time) => TimeBodyList.T time body -> TimeBodyList.T time body -> Bool durationAppend xs ys = TimeBodyList.duration (TimeBodyList.append xs ys) == TimeBodyList.duration xs + TimeBodyList.duration ys durationMerge :: (NonNeg.C time, Ord body) => TimeBodyList.T time body -> TimeBodyList.T time body -> Bool durationMerge xs ys = TimeBodyList.duration (TimeBodyList.merge xs ys) == max (TimeBodyList.duration xs) (TimeBodyList.duration ys) durationTakeTime :: (NonNeg.C time, Eq body) => time -> TimeBodyList.T time body -> Bool durationTakeTime t xs = min (TimeBodyList.duration xs) t == TimeTimeList.duration (TimeMixedList.takeTime t xs) durationDropTime :: (NonNeg.C time, Eq body) => time -> TimeBodyList.T time body -> Bool durationDropTime t xs = TimeBodyList.duration xs -| t == TimeBodyList.duration (TimeMixedList.dropTime t xs) equalPrefix :: (Eq time, Eq body) => Int -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool equalPrefix n xs ys = TimeBodyPriv.lift (Disp.take n) xs == TimeBodyPriv.lift (Disp.take n) ys cycleInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool cycleInfinite xs0 = let xs = makeInfiniteEventList xs0 in equalPrefix 100 xs (TimeBodyList.cycle xs) filterSatisfy :: (Num time) => (body -> Bool) -> TimeBodyList.T time body -> Bool filterSatisfy p = all p . TimeBodyList.getBodies . TimeBodyList.filter p filterProjection :: (Num time, Eq body) => (body -> Bool) -> TimeBodyList.T time body -> Bool filterProjection p xs = TimeBodyList.filter p xs == TimeBodyList.filter p (TimeBodyList.filter p xs) filterCommutative :: (Num time, Eq body) => (body -> Bool) -> (body -> Bool) -> TimeBodyList.T time body -> Bool filterCommutative p q xs = TimeBodyList.filter p (TimeBodyList.filter q xs) == TimeBodyList.filter q (TimeBodyList.filter p xs) filterComposition :: (Num time, Eq body) => (body -> Bool) -> (body -> Bool) -> TimeBodyList.T time body -> Bool filterComposition p q xs = TimeBodyList.filter p (TimeBodyList.filter q xs) == TimeBodyList.filter (\b -> p b && q b) xs filterNormalize :: (NonNeg.C time, Ord body) => (body -> Bool) -> TimeBodyList.T time body -> Bool filterNormalize p = isNormalized . TimeBodyList.filter p . TimeBodyList.normalize filterAppend :: (NonNeg.C time, Eq body) => (body -> Bool) -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool filterAppend p xs0 ys = let xs = TimeBodyList.filter p xs0 in TimeBodyList.filter p (TimeBodyList.append xs ys) == TimeBodyList.append xs (TimeBodyList.filter p ys) filterDuration :: (NonNeg.C time, Eq body) => (body -> Bool) -> TimeTimeList.T time body -> Bool filterDuration p xs = TimeTimeList.duration xs >= TimeTimeList.duration (TimeTimeList.filter p xs) filterPartition :: (NonNeg.C time, Ord body) => (body -> Bool) -> TimeBodyList.T time body -> Bool filterPartition p xs = (TimeBodyList.filter p xs, TimeBodyList.filter (not . p) xs) == TimeBodyList.partition p xs filterInfinite :: (NonNeg.C time, Eq body) => (body -> Bool) -> NonEmptyList time body -> Bool filterInfinite p xs = null (TimeBodyList.getBodies (TimeBodyList.filter p (makeNonEmptyEventList xs))) || (checkInfinite . TimeBodyList.filter p . makeInfiniteEventList) xs catMaybesAppend :: (NonNeg.C time, Eq body) => TimeBodyList.T time (Maybe body) -> TimeBodyList.T time (Maybe body) -> Bool catMaybesAppend xs0 ys = let xs = TimeBodyList.filter isJust xs0 in TimeBodyList.catMaybes (TimeBodyList.append xs ys) == TimeBodyList.append (TimeBodyList.catMaybes xs) (TimeBodyList.catMaybes ys) {- | 'TimeBodyList.merge' preserves normalization of its operands. -} mergeNormalize :: (NonNeg.C time, Ord body) => TimeBodyList.T time body -> TimeBodyList.T time body -> Bool mergeNormalize xs0 ys0 = let xs = TimeBodyList.normalize xs0 ys = TimeBodyList.normalize ys0 in isNormalized $ TimeBodyList.merge xs ys mergeLeftIdentity :: (NonNeg.C time, Ord body) => TimeBodyList.T time body -> Bool mergeLeftIdentity xs = TimeBodyList.merge TimeBodyList.empty xs == xs mergeRightIdentity :: (NonNeg.C time, Ord body) => TimeBodyList.T time body -> Bool mergeRightIdentity xs = TimeBodyList.merge xs TimeBodyList.empty == xs mergeCommutative :: (NonNeg.C time, Ord body) => TimeBodyList.T time body -> TimeBodyList.T time body -> Bool mergeCommutative xs0 ys0 = let xs = TimeBodyList.normalize xs0 ys = TimeBodyList.normalize ys0 in TimeBodyList.merge xs ys == TimeBodyList.merge ys xs mergeAssociative :: (NonNeg.C time, Ord body) => TimeBodyList.T time body -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool mergeAssociative xs0 ys0 zs0 = let xs = TimeBodyList.normalize xs0 ys = TimeBodyList.normalize ys0 zs = TimeBodyList.normalize zs0 in TimeBodyList.merge xs (TimeBodyList.merge ys zs) == TimeBodyList.merge (TimeBodyList.merge xs ys) zs {- Prior normalization is not enough, because 'append' does not preserve normalization if the first list ends with time difference 0 and the second one starts with time difference 0. -} mergeAppend :: (NonNeg.C time, Ord body) => TimeBodyList.T time body -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool mergeAppend xs ys zs = TimeBodyList.normalize (TimeBodyList.append xs (TimeBodyList.merge ys zs)) == TimeBodyList.normalize (TimeBodyList.merge (TimeBodyList.append xs ys) (TimeBodyList.delay (TimeBodyList.duration xs) zs)) {- Normalization is important does only hold for monotonic functions toUpper and toLower are not monotonic -} mergeMap :: (NonNeg.C time, Ord body0 ,Ord body1) => (body0 -> body1) -> TimeBodyList.T time body0 -> TimeBodyList.T time body0 -> Bool mergeMap f xs0 ys0 = let xs = TimeBodyList.normalize xs0 ys = TimeBodyList.normalize ys0 in TimeBodyList.mapBody f (TimeBodyList.merge xs ys) == TimeBodyList.merge (TimeBodyList.mapBody f xs) (TimeBodyList.mapBody f ys) mergeFilter :: (NonNeg.C time, Ord body) => (body -> Bool) -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool mergeFilter p xs0 ys0 = let xs = TimeBodyList.normalize xs0 ys = TimeBodyList.normalize ys0 in TimeBodyList.filter p (TimeBodyList.merge xs ys) == TimeBodyList.merge (TimeBodyList.filter p xs) (TimeBodyList.filter p ys) mergePartition :: (NonNeg.C time, Ord body) => (body -> Bool) -> TimeBodyList.T time body -> Bool mergePartition p xs0 = let xs = TimeBodyList.normalize xs0 in xs == uncurry TimeBodyList.merge (TimeBodyList.partition p xs) mergeEitherMapMaybe :: (NonNeg.C time, Ord body) => TimeBodyList.T time body -> TimeBodyList.T time body -> Bool mergeEitherMapMaybe xs0 ys0 = let xs = TimeBodyList.normalize xs0 ys = TimeBodyList.normalize ys0 zs = TimeBodyList.merge (TimeBodyList.mapBody Left xs) (TimeBodyList.mapBody Right ys) in xs == TimeBodyList.mapMaybe (either Just (const Nothing)) zs && ys == TimeBodyList.mapMaybe (either (const Nothing) Just) zs mergeInfinite :: (NonNeg.C time, Ord body) => NonEmptyList time body -> NonEmptyList time body -> Bool mergeInfinite xs0 ys0 = let xs = makeInfiniteEventList xs0 ys = makeInfiniteEventList ys0 in checkInfinite (TimeBodyList.merge xs ys) insertCommutative :: (NonNeg.C time, Ord body) => (time, body) -> (time, body) -> TimeBodyList.T time body -> Bool insertCommutative (time0, body0) (time1, body1) evs = TimeBodyList.insert time0 body0 (TimeBodyList.insert time1 body1 evs) == TimeBodyList.insert time1 body1 (TimeBodyList.insert time0 body0 evs) insertMerge :: (NonNeg.C time, Ord body) => time -> body -> TimeBodyList.T time body -> Bool insertMerge time body evs = TimeBodyList.insert time body evs == TimeBodyList.merge (TimeBodyList.cons time body TimeBodyList.empty) evs insertNormalize :: (NonNeg.C time, Ord body) => time -> body -> TimeBodyList.T time body -> Bool insertNormalize time body = isNormalized . TimeBodyList.insert time body . TimeBodyList.normalize insertSplitAtTime :: (NonNeg.C time, Ord body) => time -> body -> TimeBodyList.T time body -> Bool insertSplitAtTime time body evs = TimeBodyList.insert (min time (TimeBodyList.duration evs)) body (TimeBodyList.normalize evs) == let (prefix,suffix) = TimeMixedList.splitAtTime time evs in TimeBodyList.normalize (TimeMixedList.appendBodyEnd prefix (MixedBodyList.consTime 0 (MixedBodyList.consBody body suffix))) insertInfinite :: (NonNeg.C time, Ord body) => time -> body -> NonEmptyList time body -> Bool insertInfinite time body = checkInfinite . TimeBodyList.insert time body . makeInfiniteEventList moveForwardIdentity :: (NonNeg.C time, Ord body) => TimeBodyList.T time body -> Bool moveForwardIdentity evs = evs == TimeBodyList.moveForward (TimeBodyList.mapBody ((,) 0) evs) moveForwardAdditive :: (NonNeg.C time, Ord body) => TimeBodyList.T time ((time,time),body) -> Bool moveForwardAdditive evs = TimeBodyList.normalize (moveForwardLimited (moveForwardLimited (TimeBodyList.mapBody (\((t0,t1),b) -> (t0,(t1,b))) evs))) == TimeBodyList.normalize (moveForwardLimited (TimeBodyList.mapBody (mapFst (uncurry (+))) evs)) moveForwardCommutative :: (NonNeg.C time, Ord body) => TimeBodyList.T time ((time,time),body) -> Bool moveForwardCommutative evs = TimeBodyList.normalize (moveForwardLimited (moveForwardLimited (TimeBodyList.mapBody (\((t0,t1),b) -> (t0,(t1,b))) evs))) == TimeBodyList.normalize (moveForwardLimited (moveForwardLimited (TimeBodyList.mapBody (\((t0,t1),b) -> (t1,(t0,b))) evs))) {- moveForwardRestricted :: (NonNeg.C time, Ord body) => time -> TimeBodyList.T time (time,body) -> Bool moveForwardRestricted maxTime evs0 = let evs = TimeBodyList.mapBody (mapFst (min maxTime)) $ restrictMoveTimes (TimeBodyList.normalize evs0) in TimeBodyList.moveForward evs == TimeBodyList.moveForwardRestricted maxTime evs moveForwardRestrictedInfinity :: (NonNeg.C time, Eq body) => time -> NonEmptyList time (time,body) -> Bool moveForwardRestrictedInfinity maxTime = checkInfinite . TimeBodyList.moveForwardRestricted maxTime . TimeBodyList.mapBody (mapFst (min maxTime)) . restrictMoveTimes . makeUncollapsedInfiniteEventList -} moveForwardLimited :: (NonNeg.C time) => TimeBodyList.T time (time,body) -> TimeBodyList.T time body moveForwardLimited = TimeBodyList.moveForward . restrictMoveTimes restrictMoveTimes :: (NonNeg.C time) => TimeBodyList.T time (time,body) -> TimeBodyList.T time (time,body) restrictMoveTimes = flip evalState 0 . TimeBodyList.mapM (\t -> modify (t+) >> return t) (\(t,b) -> gets (\tm -> (min t tm, b))) spanSatisfy :: (NonNeg.C time, Eq body) => (body -> Bool) -> TimeBodyList.T time body -> Bool spanSatisfy p = uncurry (&&) . mapPair (all p . TimeBodyList.getBodies, maybe True (not . p . snd . fst) . TimeBodyList.viewL) . TimeBodyList.span p spanAppend :: (NonNeg.C time, Eq body) => (body -> Bool) -> TimeBodyList.T time body -> Bool spanAppend p xs = uncurry TimeBodyList.append (TimeBodyList.span p xs) == xs spanInfinite :: (NonNeg.C time, Ord body) => (body -> Bool) -> NonEmptyList time body -> Bool spanInfinite p = checkInfinite . uncurry TimeBodyList.append . TimeBodyList.span p . makeInfiniteEventList coincidentFlatten :: (NonNeg.C time, Eq body) => TimeBodyList.T time body -> Bool coincidentFlatten xs = xs == TimeBodyList.flatten (TimeBodyList.collectCoincident xs) collectCoincidentGaps :: (NonNeg.C time, Eq body) => TimeBodyList.T time body -> Bool collectCoincidentGaps xs = let times = TimeBodyList.getTimes (TimeBodyList.collectCoincident xs) in null times || all (0<) (tail times) collectCoincidentNonEmpty :: (NonNeg.C time, Eq body) => TimeBodyList.T time body -> Bool collectCoincidentNonEmpty = all (not . null) . TimeBodyList.getBodies . TimeBodyList.collectCoincident collectCoincidentInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool collectCoincidentInfinite = checkInfinite . TimeBodyList.collectCoincident . makeUncollapsedInfiniteEventList mapCoincidentMap :: (NonNeg.C time, Eq body1) => (body0 -> body1) -> TimeBodyList.T time body0 -> Bool mapCoincidentMap f xs = TimeBodyList.mapBody f xs == TimeBodyList.mapCoincident (map f) xs mapCoincidentComposition :: (NonNeg.C time, Eq body2) => ([body0] -> [body1]) -> ([body1] -> [body2]) -> TimeBodyList.T time body0 -> Bool mapCoincidentComposition f g xs = TimeBodyList.mapCoincident (g . f) xs == (TimeBodyList.mapCoincident g . TimeBodyList.mapCoincident f) xs mapCoincidentReverse :: (NonNeg.C time, Eq body) => TimeBodyList.T time body -> Bool mapCoincidentReverse xs = xs == TimeBodyList.mapCoincident reverse (TimeBodyList.mapCoincident reverse xs) mapBodyMAppend :: (Monad m, Eq body1, NonNeg.C time) => (m (TimeBodyList.T time body1) -> TimeBodyList.T time body1) -> (body0 -> m body1) -> TimeBodyList.T time body0 -> TimeBodyList.T time body0 -> Bool mapBodyMAppend run f xs ys = run (TimeBodyList.mapM return f (TimeBodyList.append xs ys)) == run (liftM2 TimeBodyList.append (TimeBodyList.mapM return f xs) (TimeBodyList.mapM return f ys)) mapBodyMAppendRandom :: (Random body, NonNeg.C time, Eq body) => Int -> TimeBodyList.T time (body,body) -> TimeBodyList.T time (body,body) -> Bool mapBodyMAppendRandom seed = mapBodyMAppend (flip evalState (mkStdGen seed)) (State . randomR) mapBodyMInfinite :: (Random body, NonNeg.C time, Eq body) => Int -> NonEmptyList time (body,body) -> Bool mapBodyMInfinite seed = checkInfinite . flip evalState (mkStdGen seed) . TimeBodyList.mapM return (State . randomR) . makeInfiniteEventList {- mapM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> TimeBodyList.T time0 body0 -> m (TimeBodyList.T time1 body1) mapM timeAction bodyAction = Uniform.mapM bodyAction timeAction mapImmM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> Immediate time0 body0 -> m (Immediate time1 body1) mapImmM timeAction bodyAction = Disp.mapM bodyAction timeAction getBodies :: TimeBodyList.T time body -> [body] getBodies = Uniform.getFirsts getTimes :: TimeBodyList.T time body -> [time] getTimes = Uniform.getSeconds empty :: Immediate time body empty = Disp.empty cons :: time -> body -> TimeBodyList.T time body -> TimeBodyList.T time body cons = Uniform.cons snoc :: TimeBodyList.T time body -> body -> time -> TimeBodyList.T time body snoc = Uniform.snoc {- propInsertPadded :: Event time body -> TimeBodyList.T time body -> Bool propInsertPadded (Event time body) evs = EventList.insert time body (fst evs) == fst (insert time body evs) -} appendSingle :: -- (Num time, Ord time, Ord body) => body -> TimeBodyList.T time body -> EventList.T time body appendSingle body xs = Disp.foldr EventList.consTime EventList.consBody EventList.empty $ Uniform.snocFirst xs body fromEventList :: time -> EventList.T time body -> TimeBodyList.T time body fromEventList t = EventList.foldr consTime consBody (pause t) toEventList :: TimeBodyList.T time body -> EventList.T time body toEventList xs = zipWith EventList.Event (getTimes xs) (getBodies xs) {- | -} discretize :: (RealFrac time, Integral i) => TimeBodyList.T time body -> TimeBodyList.T i body discretize es = evalState (Uniform.mapSecondM roundDiff es) 0 resample :: (RealFrac time, Integral i) => time -> TimeBodyList.T time body -> TimeBodyList.T i body resample rate es = discretize (mapTime (rate*) es) toAbsoluteEventList :: (Num time) => time -> TimeBodyList.T time body -> AbsoluteEventList.T time body toAbsoluteEventList start xs = let ts = Uniform.getSeconds xs bs = Uniform.getFirsts xs ats = List.scanl (+) start ts in maybe (error "padded list always contains one time value") (\ ~(ats0,lt) -> (zip ats0 bs, lt)) (viewR ats) -} type NonEmptyList time body = (time, body, TimeBodyList.T time body) makeUncollapsedInfiniteEventList :: (NonNeg.C time) => NonEmptyList time body -> TimeBodyList.T time body makeUncollapsedInfiniteEventList = makeInfiniteEventList . (\(time,body,xs) -> (time+1,body,xs)) makeInfiniteEventList :: (NonNeg.C time) => NonEmptyList time body -> TimeBodyList.T time body makeInfiniteEventList = TimeBodyList.cycle . makeNonEmptyEventList makeNonEmptyEventList :: (NonNeg.C time) => NonEmptyList time body -> TimeBodyList.T time body makeNonEmptyEventList (t, b, evs) = TimeBodyList.cons t b evs {- | Pick an arbitrary element from an infinite list and check if it can be evaluated. -} checkInfinite :: (Eq time, Eq body) => TimeBodyList.T time body -> Bool checkInfinite xs0 = let x = maybe (error "BodyEnd.checkInfinite: empty list") fst $ TimeBodyList.viewL $ TimeBodyPriv.lift (Disp.drop 100) xs0 in x == x tests :: [(String, IO ())] tests = ("viewTimeL consTime", test (viewLConsTime :: TimeBodyList.T TimeDiff Char -> Bool)) : ("viewBodyL consBody", test (viewLConsBody :: BodyBodyList.T TimeDiff Char -> Bool)) : ("viewLInfinite", test (viewLInfinite :: NonEmptyList TimeDiff Char -> Bool)) : ("consInfinite", test (consInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) : ("consTimeBodyInfinite", test (consTimeBodyInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) : ("snocInfinite", test (snocInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) : ("consInfix", test (consInfix :: TimeDiff -> Char -> TimeDiff -> Char -> Bool)) : ("map body composition", test (mapBodyComposition Char.toUpper Char.toLower :: TimeBodyList.T TimeDiff Char -> Bool)) : ("map time composition", test ((\dt0 dt1 -> mapTimeComposition (dt0+) (dt1+)) :: TimeDiff -> TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("map time body commutative", test ((\dt -> mapTimeBodyCommutative (dt+) Char.toUpper) :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("mapBodyInfinite", test (mapBodyInfinite Char.toUpper :: NonEmptyList TimeDiff Char -> Bool)) : ("mapTimeInfinite", test (\dt -> mapTimeInfinite (dt+) :: NonEmptyList TimeDiff Char -> Bool)) : ("mapNormalize", test (mapNormalize succ :: TimeBodyList.T TimeDiff Char -> Bool)) : ("append left identity", test (appendLeftIdentity :: TimeBodyList.T TimeDiff Char -> Bool)) : ("append right identity", test (appendRightIdentity :: TimeBodyList.T TimeDiff Char -> Bool)) : ("append associative", test (appendAssociative :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("appendCons", test (appendCons :: TimeDiff -> Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("mapBodyAppend", test (mapBodyAppend Char.toUpper :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("appendSplitAtTime", test (appendSplitAtTime :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("appendFirstInfinite", test (appendFirstInfinite :: NonEmptyList TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("appendSecondInfinite", test (appendSecondInfinite :: TimeBodyList.T TimeDiff Char -> NonEmptyList TimeDiff Char -> Bool)) : ("cycleInfinite", test (cycleInfinite :: NonEmptyList TimeDiff Char -> Bool)) : ("decreaseStart delay", test (decreaseStartDelay :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("decreaseStartInfinite", test (decreaseStartInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) : ("delay additive", test (delayAdditive :: TimeDiff -> TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("delay append pause", test (delayAppendPause :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("delayInfinite", test (delayInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) : ("splitAtTakeDropTime", test (splitAtTakeDropTime :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("takeTimeEndPause", test (takeTimeEndPause :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("takeTimeAppendFirst", test (takeTimeAppendFirst :: TimeDiff -> TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("takeTimeAppendSecond", test (takeTimeAppendSecond :: TimeDiff -> TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("takeTimeNormalize", test (takeTimeNormalize :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("dropTimeNormalize", test (dropTimeNormalize :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("takeTimeInfinite", test (takeTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) : ("dropTimeInfinite", test (dropTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) : ("duration pause", test (durationPause :: TimeDiff -> Bool)) : ("duration append", test (durationAppend :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("duration merge", test (durationMerge :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("durationTakeTime", test (durationTakeTime :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("durationDropTime", test (durationDropTime :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) : ("filterSatisfy", test (\c -> filterSatisfy (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) : ("filterProjection", test (\c -> filterProjection (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) : ("filterCommutative", test (\c0 c1 -> filterCommutative (c0<) (c1>) :: TimeBodyList.T TimeDiff Char -> Bool)) : ("filterComposition", test (\c0 c1 -> filterComposition (c0<) (c1>) :: TimeBodyList.T TimeDiff Char -> Bool)) : ("filterNormalize", test (\c -> filterNormalize (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) : ("filterAppend", test (\c -> filterAppend (c<) :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("filterDuration", test (\c -> filterDuration (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : ("filterPartition", test (\c -> filterPartition (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) : ("filterInfinite", test (\c -> filterInfinite (c<) :: NonEmptyList TimeDiff Char -> Bool)) : ("catMaybesAppend", test (catMaybesAppend :: TimeBodyList.T TimeDiff (Maybe Char) -> TimeBodyList.T TimeDiff (Maybe Char) -> Bool)) : ("mergeNormalize", test (mergeNormalize :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("merge left identity", test (mergeLeftIdentity :: TimeBodyList.T TimeDiff Char -> Bool)) : ("merge right identity", test (mergeRightIdentity :: TimeBodyList.T TimeDiff Char -> Bool)) : ("merge commutative", test (mergeCommutative :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("merge associative", test (mergeAssociative :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("merge append", test (mergeAppend :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("mergeMap", test (mergeMap succ :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("mergeFilter", test (\c -> mergeFilter (c>) :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("mergePartition", test (\c -> mergePartition (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) : ("mergeEitherMapMaybe", test (mergeEitherMapMaybe :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("mergeInfinite", test (mergeInfinite :: NonEmptyList TimeDiff Char -> NonEmptyList TimeDiff Char -> Bool)) : ("insert commutative", test (insertCommutative :: (TimeDiff, Char) -> (TimeDiff, Char) -> TimeBodyList.T TimeDiff Char -> Bool)) : ("insert merge", test (insertMerge :: TimeDiff -> Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("insertNormalize", test (insertNormalize :: TimeDiff -> Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("insertSplitAtTime", test (insertSplitAtTime :: TimeDiff -> Char -> TimeBodyList.T TimeDiff Char -> Bool)) : ("insertInfinite", test (insertInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) : ("moveForwardIdentity", test (moveForwardIdentity :: TimeBodyList.T TimeDiff Char -> Bool)) : ("moveForwardAdditive", test (moveForwardAdditive :: TimeBodyList.T TimeDiff ((TimeDiff,TimeDiff),Char) -> Bool)) : ("moveForwardCommutative", test (moveForwardCommutative :: TimeBodyList.T TimeDiff ((TimeDiff,TimeDiff),Char) -> Bool)) : {- ("moveForwardRestricted", test (moveForwardRestricted :: TimeDiff -> TimeBodyList.T TimeDiff (TimeDiff,Char) -> Bool)) : ("moveForwardRestrictedInfinity", test (moveForwardRestrictedInfinity :: TimeDiff -> NonEmptyList TimeDiff (TimeDiff,Char) -> Bool)) : -} ("spanSatisfy", test (\c -> spanSatisfy (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) : ("spanAppend", test (\c -> spanAppend (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) : ("spanInfinite", test (\c -> spanInfinite (c<) :: NonEmptyList TimeDiff Char -> Bool)) : ("coincidentFlatten", test (coincidentFlatten :: TimeBodyList.T TimeDiff Char -> Bool)) : ("collectCoincidentGaps", test (collectCoincidentGaps :: TimeBodyList.T TimeDiff Char -> Bool)) : ("collectCoincidentNonEmpty", test (collectCoincidentNonEmpty :: TimeBodyList.T TimeDiff Char -> Bool)) : ("collectCoincidentInfinite", test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) : ("mapCoincidentMap", test (mapCoincidentMap Char.toUpper :: TimeBodyList.T TimeDiff Char -> Bool)) : ("mapCoincidentComposition", test (mapCoincidentComposition reverse reverse :: TimeBodyList.T TimeDiff Char -> Bool)) : ("mapCoincidentReverse", test (mapCoincidentReverse :: TimeBodyList.T TimeDiff Char -> Bool)) : ("mapBodyMAppendRandom", test (mapBodyMAppendRandom :: Int -> TimeBodyList.T TimeDiff (Char,Char) -> TimeBodyList.T TimeDiff (Char,Char) -> Bool)) : ("mapBodyMInfinite", test (mapBodyMInfinite :: Int -> NonEmptyList TimeDiff (Char,Char) -> Bool)) : []