diff --git a/Test/Data/EventList/Absolute/BodyEnd.hs b/Test/Data/EventList/Absolute/BodyEnd.hs deleted file mode 100644 --- a/Test/Data/EventList/Absolute/BodyEnd.hs +++ /dev/null @@ -1,325 +0,0 @@ -{- | -Copyright : (c) Henning Thielemann 2007 - -Maintainer : haskell@henning-thielemann.de -Stability : stable -Portability : Haskell 98 --} -module Test.Data.EventList.Absolute.BodyEnd (tests) where - -import Test.Utility -import Test.QuickCheck (test) - -import qualified Data.EventList.Absolute.TimeBody as AbsBody -import qualified Data.EventList.Absolute.TimeBodyPrivate as AbsBodyPriv -import qualified Data.EventList.Relative.TimeBody as RelBody -import qualified Data.AlternatingList.List.Disparate as Disp - --- for testing in GHCi --- import Data.AlternatingList.List.Disparate (empty) --- import Data.AlternatingList.List.Uniform ((/.), (./)) -import qualified Data.Char as Char - -import System.Random (Random, randomR, mkStdGen) -import Control.Monad (liftM) - -import qualified Data.EventList.Utility as Utility - -import qualified Numeric.NonNegative.Class as NonNeg -import Data.EventList.Utility (mapFst, mapSnd, mapPair) -import qualified Control.Monad as Monad -import Control.Monad.State (State(State), evalState) - -import Prelude hiding (filter, concat) - - -infixl 5 $~ - -($~) :: Num time => - (AbsBody.T time body -> a) -> (RelBody.T time body -> a) -($~) f = f . RelBody.toAbsoluteEventList 0 - -infixl 4 ==~ - -(==~) :: (Eq body, Num time) => - AbsBody.T time body -> RelBody.T time body -> Bool -(==~) xs ys = - xs == RelBody.toAbsoluteEventList 0 ys - - - -duration :: Num time => RelBody.T time body -> Bool -duration xs = - AbsBody.duration $~ xs == RelBody.duration xs - - -mapBody :: (Eq body1, Num time) => - (body0 -> body1) -> RelBody.T time body0 -> Bool -mapBody f xs = - AbsBody.mapBody f $~ xs ==~ RelBody.mapBody f xs - - - -mapBodyM :: - (Monad m, Eq body1, NonNeg.C time) => - (m (AbsBody.T time body1) -> AbsBody.T time body1) -> - (body0 -> m body1) -> RelBody.T time body0 -> Bool -mapBodyM run f xs = - run (AbsBody.mapBodyM f $~ xs) == - run (liftM (RelBody.toAbsoluteEventList 0) (RelBody.mapBodyM f xs)) - -mapBodyMRandom :: - (NonNeg.C time, Random body, Eq body) => - Int -> RelBody.T time (body, body) -> Bool -mapBodyMRandom seed = - mapBodyM - (flip evalState (mkStdGen seed)) - (State . randomR) - - -filter :: (Eq body, Num time) => - (body -> Bool) -> RelBody.T time body -> Bool -filter p xs = - AbsBody.filter p $~ xs ==~ RelBody.filter p xs - -{- -mapMaybe :: (Num time) => - (body0 -> Maybe body1) -> - RelBody.T time body0 -> RelBody.T time body1 -mapMaybe f = catMaybes . mapBody f --} - -catMaybes :: (Eq body, Num time) => - RelBody.T time (Maybe body) -> Bool -catMaybes xs = - AbsBody.catMaybes $~ xs ==~ RelBody.catMaybes xs - -{- -Could be implemented more easily in terms of Uniform.partition --} -partition :: (Eq body, Num time) => - (body -> Bool) -> RelBody.T time body -> Bool -partition p xs = - AbsBody.partition p $~ xs == --- mapPair (RelBody.toAbsoluteEventList 0, RelBody.toAbsoluteEventList 0) - (uncurry $ \ys zs -> (,) $~ ys $~ zs) - (RelBody.partition p xs) - -{- | -Since we need it later for MIDI generation, -we will also define a slicing into equivalence classes of events. --} -slice :: (Eq a, Eq body, Num time) => - (body -> a) -> RelBody.T time body -> Bool -slice f xs = - AbsBody.slice f $~ xs == - map (mapSnd (RelBody.toAbsoluteEventList 0)) (RelBody.slice f xs) - - -collectCoincident :: (NonNeg.C time, Eq body) => - RelBody.T time body -> Bool -collectCoincident xs = - AbsBody.collectCoincident $~ xs ==~ - RelBody.collectCoincident xs - -collectCoincidentFoldr :: (NonNeg.C time, Eq body) => - RelBody.T time body -> Bool -collectCoincidentFoldr xs = - AbsBody.collectCoincident $~ xs == - AbsBody.collectCoincidentFoldr $~ xs - -collectCoincidentNonLazy :: (NonNeg.C time, Eq body) => - RelBody.T time body -> Bool -collectCoincidentNonLazy xs = - AbsBody.collectCoincident $~ xs == - AbsBody.collectCoincidentNonLazy $~ xs - -collectCoincidentInfinite :: (NonNeg.C time, Eq body) => - NonEmptyList time body -> Bool -collectCoincidentInfinite = - checkInfinite . - AbsBody.collectCoincident . - makeUncollapsedInfiniteEventList - - -flatten :: (NonNeg.C time, Eq body) => - RelBody.T time [body] -> Bool -flatten xs = - AbsBody.flatten $~ xs ==~ RelBody.flatten xs - - -normalize :: (NonNeg.C time, Ord body) => - RelBody.T time body -> Bool -normalize xs = - AbsBody.normalize $~ xs ==~ RelBody.normalize xs - - -merge :: (NonNeg.C time, Ord body) => - RelBody.T time body -> RelBody.T time body -> Bool -merge xs ys = - AbsBody.merge $~ xs $~ ys ==~ RelBody.merge xs ys - - -insert :: (NonNeg.C time, Ord body) => - time -> body -> RelBody.T time body -> Bool -insert t b xs = - AbsBody.insert t b $~ xs ==~ RelBody.insert t b xs - - - -append :: (NonNeg.C time, Eq body) => - RelBody.T time body -> RelBody.T time body -> Bool -append xs ys = - AbsBody.append $~ xs $~ ys ==~ - RelBody.append xs ys - -concat :: (NonNeg.C time, Eq body) => - [RelBody.T time body] -> Bool -concat xs = - AbsBody.concat (map (RelBody.toAbsoluteEventList 0) xs) ==~ - RelBody.concat xs - - -{- -cycle :: (NonNeg.C time) => - RelBody.T time body -> RelBody.T time body -cycle = concat . List.repeat --} - - -decreaseStart :: (NonNeg.C time, Eq body) => - time -> time -> RelBody.T time body -> Bool -decreaseStart dif0 dif1 xs0 = - let difA = min dif0 dif1 - difB = max dif0 dif1 - xs = RelBody.delay difB xs0 - in AbsBody.decreaseStart difA $~ xs ==~ - RelBody.decreaseStart difA xs - - -delay :: (NonNeg.C time, Eq body) => - time -> RelBody.T time body -> Bool -delay dif xs = - AbsBody.delay dif $~ xs ==~ - RelBody.delay dif xs - - - -{- -resample :: (Integral time, Eq body) => - time -> RelBody.T (time, time) body -> Bool -resample rateInt xs0 = - let xs = RelBody.mapTime (\(n,d) -> n % (d+1)) xs0 - rate = rateInt % 1 - in AbsBody.resample rate $~ xs ==~ - (RelBody.resample rate xs `asTypeOf` - AbsBody.singleton (undefined::Int) undefined) --} - -resample :: (Eq body) => - TimeDiff -> RelBody.T (TimeDiff, TimeDiff) body -> Bool -resample rateInt xs0 = - let {- - I add a small amount to the numerator in order - to prevent the case of a fraction like 10.5, - which can be easily rounded to 10 or 11 - depending to previous rounding errors. - -} - xs = RelBody.mapTime ((1e-6 +) . makeFracTime) xs0 - rate = timeToDouble rateInt + 1 - in AbsBody.resample rate $~ xs ==~ - (RelBody.resample rate xs `asTypeOf` - RelBody.singleton (undefined::TimeDiff) undefined) - -resampleInfinite :: (Eq body) => - TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) body -> Bool -resampleInfinite rateInt = - let rate = timeToDouble rateInt + 1 - in checkInfinite . - (`asTypeOf` AbsBody.singleton (undefined::TimeDiff) undefined) . - AbsBody.resample rate . - makeInfiniteEventList . - mapPair (mapFst makeFracTime, RelBody.mapTime makeFracTime) - - - - -type NonEmptyList time body = ((time, body), RelBody.T time body) - -makeUncollapsedInfiniteEventList :: (NonNeg.C time) => - NonEmptyList time body -> AbsBody.T time body -makeUncollapsedInfiniteEventList = - makeInfiniteEventList . - mapFst (mapFst (1+)) - -makeInfiniteEventList :: (NonNeg.C time) => - NonEmptyList time body -> AbsBody.T time body -makeInfiniteEventList = - RelBody.toAbsoluteEventList 0 . RelBody.cycle . makeNonEmptyEventList - -makeNonEmptyEventList :: (NonNeg.C time) => - NonEmptyList time body -> RelBody.T time body -makeNonEmptyEventList (p, evs) = - uncurry RelBody.cons p evs - -{- | -Pick an arbitrary element from an infinite list -and check if it can be evaluated. --} -checkInfinite :: (Eq time, Eq body) => - AbsBody.T time body -> Bool -checkInfinite xs0 = - let x = maybe - (error "BodyEnd.checkInfinite: empty list") fst $ - AbsBody.viewL $ AbsBodyPriv.lift (Disp.drop 100) xs0 - in x == x - - - - - -tests :: [(String, IO ())] -tests = - ("duration", - test (duration :: RelBody.T TimeDiff Char -> Bool)) : - ("mapBody", - test (mapBody Char.toUpper :: RelBody.T TimeDiff Char -> Bool)) : - ("mapBodyM", - test (mapBodyMRandom :: Int -> RelBody.T TimeDiff (Char, Char) -> Bool)) : - ("filter", - test (\c -> filter (c<) :: RelBody.T TimeDiff Char -> Bool)) : - ("catMaybes", - test (catMaybes :: RelBody.T TimeDiff (Maybe Char) -> Bool)) : - ("partition", - test (\c -> partition (c<) :: RelBody.T TimeDiff Char -> Bool)) : - ("slice", - test (slice fst :: RelBody.T TimeDiff (Char,Char) -> Bool)) : - ("collectCoincident", - test (collectCoincident :: RelBody.T TimeDiff Char -> Bool)) : - ("collectCoincidentFoldr", - test (collectCoincidentFoldr :: RelBody.T TimeDiff Char -> Bool)) : - ("collectCoincidentNonLazy", - test (collectCoincidentNonLazy :: RelBody.T TimeDiff Char -> Bool)) : - ("collectCoincidentInfinite", - test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) : - ("flatten", - test (flatten :: RelBody.T TimeDiff [Char] -> Bool)) : - ("normalize", - test (normalize :: RelBody.T TimeDiff Char -> Bool)) : - ("merge", - test (merge :: RelBody.T TimeDiff Char -> RelBody.T TimeDiff Char -> Bool)) : - ("insert", - test (insert :: TimeDiff -> Char -> RelBody.T TimeDiff Char -> Bool)) : - ("append", - test (append :: RelBody.T TimeDiff Char -> RelBody.T TimeDiff Char -> Bool)) : - ("concat", - test (concat :: [RelBody.T TimeDiff Char] -> Bool)) : - ("decreaseStart", - test (decreaseStart :: TimeDiff -> TimeDiff -> RelBody.T TimeDiff Char -> Bool)) : - ("delay", - test (delay :: TimeDiff -> RelBody.T TimeDiff Char -> Bool)) : - ("resample", - test (resample :: TimeDiff -> RelBody.T (TimeDiff, TimeDiff) Char -> Bool)) : - ("resampleInfinite", - test (resampleInfinite :: TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) Char -> Bool)) : - [] diff --git a/Test/Data/EventList/Absolute/TimeEnd.hs b/Test/Data/EventList/Absolute/TimeEnd.hs deleted file mode 100644 --- a/Test/Data/EventList/Absolute/TimeEnd.hs +++ /dev/null @@ -1,298 +0,0 @@ -{- | -Copyright : (c) Henning Thielemann 2007 - -Maintainer : haskell@henning-thielemann.de -Stability : stable -Portability : Haskell 98 --} -module Test.Data.EventList.Absolute.TimeEnd (tests) where - -import Test.Utility -import Test.QuickCheck (test) - -import qualified Data.EventList.Absolute.TimeTime as AbsTime -import qualified Data.EventList.Absolute.TimeTimePrivate as AbsTimePriv -import qualified Data.EventList.Relative.TimeTime as RelTime -import qualified Data.AlternatingList.List.Mixed as Mixed - --- for testing in GHCi --- import Data.AlternatingList.List.Disparate (empty) --- import Data.AlternatingList.List.Uniform ((/.), (./)) -import qualified Data.Char as Char - -import System.Random (Random, randomR, mkStdGen) -import Control.Monad (liftM) - -import qualified Data.EventList.Utility as Utility - -import qualified Numeric.NonNegative.Class as NonNeg -import Data.EventList.Utility (mapFst, mapSnd, mapPair) -import qualified Control.Monad as Monad -import Control.Monad.State (State(State), evalState) - -import Prelude hiding (filter, concat) - - -infixl 5 $~ - -($~) :: Num time => - (AbsTime.T time body -> a) -> (RelTime.T time body -> a) -($~) f = f . RelTime.toAbsoluteEventList 0 - -infixl 4 ==~ - -(==~) :: (Eq body, Num time) => - AbsTime.T time body -> RelTime.T time body -> Bool -(==~) xs ys = - xs == RelTime.toAbsoluteEventList 0 ys - - - -duration :: Num time => RelTime.T time body -> Bool -duration xs = - AbsTime.duration $~ xs == RelTime.duration xs - - -mapBody :: (Eq body1, Num time) => - (body0 -> body1) -> RelTime.T time body0 -> Bool -mapBody f xs = - AbsTime.mapBody f $~ xs ==~ RelTime.mapBody f xs - - - -mapBodyM :: - (Monad m, Eq body1, NonNeg.C time) => - (m (AbsTime.T time body1) -> AbsTime.T time body1) -> - (body0 -> m body1) -> RelTime.T time body0 -> Bool -mapBodyM run f xs = - run (AbsTime.mapBodyM f $~ xs) == - run (liftM (RelTime.toAbsoluteEventList 0) (RelTime.mapBodyM f xs)) - -mapBodyMRandom :: - (NonNeg.C time, Random body, Eq body) => - Int -> RelTime.T time (body, body) -> Bool -mapBodyMRandom seed = - mapBodyM - (flip evalState (mkStdGen seed)) - (State . randomR) - - -filter :: (Eq body, Num time) => - (body -> Bool) -> RelTime.T time body -> Bool -filter p xs = - AbsTime.filter p $~ xs ==~ RelTime.filter p xs - -{- -mapMaybe :: (Num time) => - (body0 -> Maybe body1) -> - RelTime.T time body0 -> RelTime.T time body1 -mapMaybe f = catMaybes . mapBody f --} - -catMaybes :: (Eq body, Num time) => - RelTime.T time (Maybe body) -> Bool -catMaybes xs = - AbsTime.catMaybes $~ xs ==~ RelTime.catMaybes xs - -{- -Could be implemented more easily in terms of Uniform.partition --} -partition :: (Eq body, Num time) => - (body -> Bool) -> RelTime.T time body -> Bool -partition p xs = - AbsTime.partition p $~ xs == --- mapPair (RelTime.toAbsoluteEventList 0, RelTime.toAbsoluteEventList 0) - (uncurry $ \ys zs -> (,) $~ ys $~ zs) - (RelTime.partition p xs) - -{- | -Since we need it later for MIDI generation, -we will also define a slicing into equivalence classes of events. --} -slice :: (Eq a, Eq body, Num time) => - (body -> a) -> RelTime.T time body -> Bool -slice f xs = - AbsTime.slice f $~ xs == - map (mapSnd (RelTime.toAbsoluteEventList 0)) (RelTime.slice f xs) - - -collectCoincident :: (NonNeg.C time, Eq body) => - RelTime.T time body -> Bool -collectCoincident xs = - AbsTime.collectCoincident $~ xs ==~ - RelTime.collectCoincident xs - -collectCoincidentInfinite :: (NonNeg.C time, Eq body) => - NonEmptyList time body -> Bool -collectCoincidentInfinite = - checkInfinite . - AbsTime.collectCoincident . - makeUncollapsedInfiniteEventList - - -flatten :: (NonNeg.C time, Eq body) => - RelTime.T time [body] -> Bool -flatten xs = - AbsTime.flatten $~ xs ==~ RelTime.flatten xs - - -normalize :: (NonNeg.C time, Ord body) => - RelTime.T time body -> Bool -normalize xs = - AbsTime.normalize $~ xs ==~ RelTime.normalize xs - - -merge :: (NonNeg.C time, Ord body) => - RelTime.T time body -> RelTime.T time body -> Bool -merge xs ys = - AbsTime.merge $~ xs $~ ys ==~ RelTime.merge xs ys - - -insert :: (NonNeg.C time, Ord body) => - time -> body -> RelTime.T time body -> Bool -insert t b xs = - AbsTime.insert t b $~ xs ==~ RelTime.insert t b xs - - - -append :: (NonNeg.C time, Eq body) => - RelTime.T time body -> RelTime.T time body -> Bool -append xs ys = - AbsTime.append $~ xs $~ ys ==~ - RelTime.append xs ys - -concat :: (NonNeg.C time, Eq body) => - [RelTime.T time body] -> Bool -concat xs = - AbsTime.concat (map (RelTime.toAbsoluteEventList 0) xs) ==~ - RelTime.concat xs - - -{- -cycle :: (NonNeg.C time) => - RelTime.T time body -> RelTime.T time body -cycle = concat . List.repeat --} - - -decreaseStart :: (NonNeg.C time, Eq body) => - time -> time -> RelTime.T time body -> Bool -decreaseStart dif0 dif1 xs0 = - let difA = min dif0 dif1 - difB = max dif0 dif1 - xs = RelTime.delay difB xs0 - in AbsTime.decreaseStart difA $~ xs ==~ - RelTime.decreaseStart difA xs - - -delay :: (NonNeg.C time, Eq body) => - time -> RelTime.T time body -> Bool -delay dif xs = - AbsTime.delay dif $~ xs ==~ - RelTime.delay dif xs - - - -resample :: (Eq body) => - TimeDiff -> RelTime.T (TimeDiff, TimeDiff) body -> Bool -resample rateInt xs0 = - let {- - I add a small amount to the numerator in order - to prevent the case of a fraction like 10.5, - which can be easily rounded to 10 or 11 - depending to previous rounding errors. - -} - xs = RelTime.mapTime ((1e-6 +) . makeFracTime) xs0 - rate = timeToDouble rateInt + 1 - in AbsTime.resample rate $~ xs ==~ - (RelTime.resample rate xs `asTypeOf` - RelTime.pause (undefined::TimeDiff)) - -resampleInfinite :: (Eq body) => - TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) body -> Bool -resampleInfinite rateInt = - let rate = timeToDouble rateInt + 1 - in checkInfinite . - (`asTypeOf` AbsTime.pause (undefined::TimeDiff)) . - AbsTime.resample rate . - makeInfiniteEventList . - mapPair (mapFst makeFracTime, RelTime.mapTime makeFracTime) - - - -type NonEmptyList time body = ((time, body), RelTime.T time body) - -makeUncollapsedInfiniteEventList :: (NonNeg.C time) => - NonEmptyList time body -> AbsTime.T time body -makeUncollapsedInfiniteEventList = - makeInfiniteEventList . - mapFst (mapFst (1+)) - -makeInfiniteEventList :: (NonNeg.C time) => - NonEmptyList time body -> AbsTime.T time body -makeInfiniteEventList = - RelTime.toAbsoluteEventList 0 . RelTime.cycle . makeNonEmptyEventList - -makeNonEmptyEventList :: (NonNeg.C time) => - NonEmptyList time body -> RelTime.T time body -makeNonEmptyEventList (p, evs) = - uncurry RelTime.cons p evs - -{- | -Pick an arbitrary element from an infinite list -and check if it can be evaluated. --} -checkInfinite :: (Eq time, Eq body) => - AbsTime.T time body -> Bool -checkInfinite xs0 = - let (x,xs) = AbsTime.viewL (AbsTimePriv.lift (Mixed.dropUniform 100) xs0) - y = maybe - (error "checkInfinite: finite list") - fst - xs - in x == x && y == y - - - - -tests :: [(String, IO ())] -tests = - ("duration", - test (duration :: RelTime.T TimeDiff Char -> Bool)) : - ("mapBody", - test (mapBody Char.toUpper :: RelTime.T TimeDiff Char -> Bool)) : - ("mapBodyM", - test (mapBodyMRandom :: Int -> RelTime.T TimeDiff (Char, Char) -> Bool)) : - ("filter", - test (\c -> filter (c<) :: RelTime.T TimeDiff Char -> Bool)) : - ("catMaybes", - test (catMaybes :: RelTime.T TimeDiff (Maybe Char) -> Bool)) : - ("partition", - test (\c -> partition (c<) :: RelTime.T TimeDiff Char -> Bool)) : - ("slice", - test (slice fst :: RelTime.T TimeDiff (Char,Char) -> Bool)) : - ("collectCoincident", - test (collectCoincident :: RelTime.T TimeDiff Char -> Bool)) : - ("collectCoincidentInfinite", - test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) : - ("flatten", - test (flatten :: RelTime.T TimeDiff [Char] -> Bool)) : - ("normalize", - test (normalize :: RelTime.T TimeDiff Char -> Bool)) : - ("merge", - test (merge :: RelTime.T TimeDiff Char -> RelTime.T TimeDiff Char -> Bool)) : - ("insert", - test (insert :: TimeDiff -> Char -> RelTime.T TimeDiff Char -> Bool)) : - ("append", - test (append :: RelTime.T TimeDiff Char -> RelTime.T TimeDiff Char -> Bool)) : - ("concat", - test (concat :: [RelTime.T TimeDiff Char] -> Bool)) : - ("decreaseStart", - test (decreaseStart :: TimeDiff -> TimeDiff -> RelTime.T TimeDiff Char -> Bool)) : - ("delay", - test (delay :: TimeDiff -> RelTime.T TimeDiff Char -> Bool)) : - ("resample", - test (resample :: TimeDiff -> RelTime.T (TimeDiff, TimeDiff) Char -> Bool)) : - ("resampleInfinite", - test (resampleInfinite :: TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) Char -> Bool)) : - [] diff --git a/Test/Data/EventList/Relative/BodyEnd.hs b/Test/Data/EventList/Relative/BodyEnd.hs deleted file mode 100644 --- a/Test/Data/EventList/Relative/BodyEnd.hs +++ /dev/null @@ -1,907 +0,0 @@ -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) -import System.Random (Random, randomR, mkStdGen) -import Control.Monad.State (State(State), evalState) -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 - - - -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)) : - - ("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)) : - - [] diff --git a/Test/Data/EventList/Relative/TimeEnd.hs b/Test/Data/EventList/Relative/TimeEnd.hs deleted file mode 100644 --- a/Test/Data/EventList/Relative/TimeEnd.hs +++ /dev/null @@ -1,978 +0,0 @@ -module Test.Data.EventList.Relative.TimeEnd (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.MixedTime as MixedTimeList -import qualified Data.EventList.Relative.BodyTime as BodyTimeList -import qualified Data.AlternatingList.List.Mixed as Mixed - -import Data.EventList.Relative.MixedTime ((/.), (./), empty) - -import Data.EventList.Relative.TimeTimePrivate (($~~), lift) - -import qualified Numeric.NonNegative.Class as NonNeg -import Numeric.NonNegative.Class ((-|)) -import Data.EventList.Relative.TimeTime (isNormalized) - -import System.Random (Random, randomR, mkStdGen) -import Control.Monad.State (State(State), evalState) -import Control.Monad (liftM2) -import qualified Data.List as List -import qualified Data.Char as Char - - - -viewLConsTime :: (Eq body, Eq time) => - TimeTimeList.T time body -> Bool -viewLConsTime xs = - xs == uncurry MixedTimeList.consTime (MixedTimeList.viewTimeL xs) - -viewLConsBody :: (Eq body, Eq time) => - BodyTimeList.T time body -> Bool -viewLConsBody xs = - xs == maybe BodyTimeList.empty (uncurry MixedTimeList.consBody) (MixedTimeList.viewBodyL xs) - -viewRSnocTime :: (Eq body, Eq time) => - TimeTimeList.T time body -> Bool -viewRSnocTime xs = - xs == uncurry TimeMixedList.snocTime (TimeMixedList.viewTimeR xs) - -viewRSnocBody :: (Eq body, Eq time) => - TimeBodyList.T time body -> Bool -viewRSnocBody xs = - xs == maybe TimeBodyList.empty (uncurry TimeMixedList.snocBody) (TimeMixedList.viewBodyR xs) - - - - -viewLInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool -viewLInfinite = - checkInfinite . - maybe (error "viewBodyL: empty list") snd . MixedTimeList.viewBodyL . - snd . MixedTimeList.viewTimeL . - makeInfiniteEventList - -viewRInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool -viewRInfinite = - checkInfinite . - maybe (error "viewBodyR: empty list") fst . TimeMixedList.viewBodyR . - fst . TimeMixedList.viewTimeR . - makeInfiniteEventList - - -consInfinite :: (NonNeg.C time, Eq body) => - time -> body -> NonEmptyList time body -> Bool -consInfinite time body = - checkInfinite . - TimeTimeList.cons time body . - makeInfiniteEventList - -consTimeBodyInfinite :: (NonNeg.C time, Eq body) => - time -> body -> NonEmptyList time body -> Bool -consTimeBodyInfinite time body = - checkInfinite . - MixedTimeList.consTime time . - MixedTimeList.consBody body . - makeInfiniteEventList - - -snocInfinite :: (NonNeg.C time, Eq body) => - time -> body -> NonEmptyList time body -> Bool -snocInfinite time body = - checkInfinite . - flip (flip TimeTimeList.snoc body) time . - makeInfiniteEventList - -snocTimeBodyInfinite :: (NonNeg.C time, Eq body) => - time -> body -> NonEmptyList time body -> Bool -snocTimeBodyInfinite time body = - checkInfinite . - flip TimeMixedList.snocTime time . - flip TimeMixedList.snocBody body . - makeInfiniteEventList - - -consInfix :: (NonNeg.C time, Eq body) => - time -> body -> time -> time -> body -> time -> Bool -consInfix t0a b0 t0b t1a b1 t1b = - TimeTimeList.append (t0a /. b0 ./ t0b /. empty) (t1a /. b1 ./ t1b /. empty) - == (t0a /. b0 ./ (t0b+t1a) /. b1 ./ t1b /. empty) - - - - -mapBodyComposition :: (Eq body2, Eq time) => - (body0 -> body1) -> (body1 -> body2) -> TimeTimeList.T time body0 -> Bool -mapBodyComposition f g evs = - TimeTimeList.mapBody (g . f) evs == - TimeTimeList.mapBody g (TimeTimeList.mapBody f evs) - -mapTimeComposition :: (Eq body, Eq time2) => - (time0 -> time1) -> (time1 -> time2) -> TimeTimeList.T time0 body -> Bool -mapTimeComposition f g evs = - TimeTimeList.mapTime (g . f) evs == - TimeTimeList.mapTime g (TimeTimeList.mapTime f evs) - - -mapTimeBodyCommutative :: (Eq body1, Eq time1) => - (time0 -> time1) -> (body0 -> body1) -> TimeTimeList.T time0 body0 -> Bool -mapTimeBodyCommutative f g evs = - TimeTimeList.mapBody g (TimeTimeList.mapTime f evs) == - TimeTimeList.mapTime f (TimeTimeList.mapBody g evs) - - - -mapBodyInfinite :: (NonNeg.C time, Eq body1) => - (body0 -> body1) -> NonEmptyList time body0 -> Bool -mapBodyInfinite f = - checkInfinite . TimeTimeList.mapBody f . makeInfiniteEventList - -mapTimeInfinite :: (NonNeg.C time0, Eq time1, Eq body) => - (time0 -> time1) -> NonEmptyList time0 body -> Bool -mapTimeInfinite f = - checkInfinite . TimeTimeList.mapTime f . makeInfiniteEventList - - - -{- | -Does only hold for monotonic functions. --} -mapNormalize :: (NonNeg.C time, Ord body0, Ord body1) => - (body0 -> body1) -> TimeTimeList.T time body0 -> Bool -mapNormalize f = - isNormalized . TimeTimeList.mapBody f . TimeTimeList.normalize - - - -appendLeftIdentity :: (NonNeg.C time, Eq body) => - TimeTimeList.T time body -> Bool -appendLeftIdentity xs = - TimeTimeList.append (TimeTimeList.pause 0) xs == xs - -appendRightIdentity :: (NonNeg.C time, Eq body) => - TimeTimeList.T time body -> Bool -appendRightIdentity xs = - TimeTimeList.append xs (TimeTimeList.pause 0) == xs - -appendAssociative :: (NonNeg.C time, Eq body) => - TimeTimeList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -appendAssociative xs ys zs = - TimeTimeList.append xs (TimeTimeList.append ys zs) == - TimeTimeList.append (TimeTimeList.append xs ys) zs - -appendCons :: (NonNeg.C time, Eq body) => - time -> body -> TimeTimeList.T time body -> Bool -appendCons time body xs = - TimeTimeList.cons time body xs == - TimeTimeList.append (TimeTimeList.cons time body (TimeTimeList.pause 0)) xs - -appendSplitAtTime :: (NonNeg.C time, Eq body) => - time -> TimeTimeList.T time body -> Bool -appendSplitAtTime t xs = - xs == uncurry TimeTimeList.append (TimeTimeList.splitAtTime t xs) - -mapBodyAppend :: (Eq body1, NonNeg.C time) => - (body0 -> body1) -> TimeTimeList.T time body0 -> TimeTimeList.T time body0 -> Bool -mapBodyAppend f xs ys = - TimeTimeList.mapBody f (TimeTimeList.append xs ys) == - TimeTimeList.append (TimeTimeList.mapBody f xs) (TimeTimeList.mapBody f ys) - - -appendFirstInfinite :: (NonNeg.C time, Eq body) => - NonEmptyList time body -> TimeTimeList.T time body -> Bool -appendFirstInfinite xs = - checkInfinite . TimeTimeList.append (makeInfiniteEventList xs) - -appendSecondInfinite :: (NonNeg.C time, Eq body) => - TimeTimeList.T time body -> NonEmptyList time body -> Bool -appendSecondInfinite xs = - checkInfinite . TimeTimeList.append xs . makeInfiniteEventList - - -decreaseStartDelay :: (NonNeg.C time, Eq body) => - time -> TimeTimeList.T time body -> Bool -decreaseStartDelay dif xs = - xs == TimeTimeList.decreaseStart dif (TimeTimeList.delay dif xs) - -decreaseStartInfinite :: (NonNeg.C time, Eq body) => - time -> NonEmptyList time body -> Bool -decreaseStartInfinite dif = - checkInfinite . - TimeTimeList.decreaseStart dif . - TimeTimeList.delay dif . - makeInfiniteEventList - -delayAdditive :: (NonNeg.C time, Eq body) => - time -> time -> TimeTimeList.T time body -> Bool -delayAdditive dif0 dif1 xs = - TimeTimeList.delay (dif0+dif1) xs == - TimeTimeList.delay dif0 (TimeTimeList.delay dif1 xs) - -delayPause :: (NonNeg.C time) => - time -> time -> Bool -delayPause dif0 dif1 = - let pause = TimeTimeList.pause (dif0+dif1) - in TimeTimeList.delay dif0 (TimeTimeList.pause dif1) == - (asTypeOf pause (TimeTimeList.cons dif0 () pause)) - -delayAppendPause :: (NonNeg.C time, Eq body) => - time -> TimeTimeList.T time body -> Bool -delayAppendPause dif xs = - TimeTimeList.delay dif xs == TimeTimeList.append (TimeTimeList.pause dif) xs - -delayInfinite :: (NonNeg.C time, Eq body) => - time -> NonEmptyList time body -> Bool -delayInfinite dif = - checkInfinite . - TimeTimeList.delay dif . - makeInfiniteEventList - - - -splitAtTakeDropTime :: (NonNeg.C time, Eq body) => - time -> TimeTimeList.T time body -> Bool -splitAtTakeDropTime t xs = - (TimeTimeList.takeTime t xs, TimeTimeList.dropTime t xs) == - TimeTimeList.splitAtTime t xs - -takeTimeEndPause :: (NonNeg.C time, Ord body) => - time -> TimeTimeList.T time body -> Bool -takeTimeEndPause t xs = - t == 0 || - t >= TimeTimeList.duration xs || - 0 < snd (TimeMixedList.viewTimeR (TimeTimeList.takeTime t xs)) - -takeTimeAppendFirst :: (NonNeg.C time, Eq body) => - time -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -takeTimeAppendFirst t xs ys = - TimeTimeList.takeTime t (TimeTimeList.append xs ys) == - TimeTimeList.append - (TimeTimeList.takeTime t xs) - (TimeTimeList.takeTime (t -| TimeTimeList.duration xs) ys) - -takeTimeAppendSecond :: (NonNeg.C time, Eq body) => - time -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -takeTimeAppendSecond t xs0 ys = - -- the first list must not end with a zero pause - let xs = TimeTimeList.append xs0 (TimeTimeList.pause 1) - in TimeTimeList.takeTime (TimeTimeList.duration xs + t) (TimeTimeList.append xs ys) == - TimeTimeList.append xs (TimeTimeList.takeTime t ys) - -takeTimeNormalize :: (NonNeg.C time, Ord body) => - time -> TimeTimeList.T time body -> Bool -takeTimeNormalize t = - isNormalized . TimeTimeList.takeTime t . TimeTimeList.normalize - -dropTimeNormalize :: (NonNeg.C time, Ord body) => - time -> TimeTimeList.T time body -> Bool -dropTimeNormalize t = - isNormalized . TimeTimeList.dropTime t . TimeTimeList.normalize - -takeTimeInfinite :: (NonNeg.C time, Ord body) => - time -> NonEmptyList time body -> Bool -takeTimeInfinite t = - (t == ) . TimeTimeList.duration . - TimeTimeList.takeTime t . makeUncollapsedInfiniteEventList - -dropTimeInfinite :: (NonNeg.C time, Ord body) => - time -> NonEmptyList time body -> Bool -dropTimeInfinite t = - checkInfinite . TimeTimeList.dropTime t . makeUncollapsedInfiniteEventList - - - - -durationPause :: (NonNeg.C time) => - time -> Bool -durationPause t = - t == TimeTimeList.duration (TimeTimeList.pause t) - -durationAppend :: (NonNeg.C time) => - TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -durationAppend xs ys = - TimeTimeList.duration (TimeTimeList.append xs ys) == - TimeTimeList.duration xs + TimeTimeList.duration ys - -durationMerge :: (NonNeg.C time, Ord body) => - TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -durationMerge xs ys = - TimeTimeList.duration (TimeTimeList.merge xs ys) == - max (TimeTimeList.duration xs) (TimeTimeList.duration ys) - -durationTakeTime :: (NonNeg.C time, Eq body) => - time -> TimeTimeList.T time body -> Bool -durationTakeTime t xs = - min (TimeTimeList.duration xs) t == - TimeTimeList.duration (TimeTimeList.takeTime t xs) - -durationDropTime :: (NonNeg.C time, Eq body) => - time -> TimeTimeList.T time body -> Bool -durationDropTime t xs = - TimeTimeList.duration xs -| t == - TimeTimeList.duration (TimeTimeList.dropTime t xs) - - - -concatNaive :: (NonNeg.C time, Eq body) => - [TimeTimeList.T time body] -> Bool -concatNaive xs = - TimeTimeList.concat xs == TimeTimeList.concatNaive xs - - -equalPrefix :: (Eq time, Eq body) => - Int -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -equalPrefix n xs ys = - Mixed.takeDisparate n $~~ xs == - Mixed.takeDisparate n $~~ ys - -cycleNaive :: (NonNeg.C time, Eq body) => - NonEmptyList time body -> Bool -cycleNaive xs0 = - let xs = makeNonEmptyEventList xs0 - in equalPrefix 100 (TimeTimeList.cycle xs) (TimeTimeList.cycleNaive xs) - -cycleInfinite :: (NonNeg.C time, Eq body) => - NonEmptyList time body -> Bool -cycleInfinite xs0 = - let xs = makeInfiniteEventList xs0 - in equalPrefix 100 xs (TimeTimeList.cycle xs) - - -filterSatisfy :: (Num time) => - (body -> Bool) -> - TimeTimeList.T time body -> Bool -filterSatisfy p = - all p . TimeTimeList.getBodies . TimeTimeList.filter p - -filterProjection :: (Num time, Eq body) => - (body -> Bool) -> - TimeTimeList.T time body -> Bool -filterProjection p xs = - TimeTimeList.filter p xs == - TimeTimeList.filter p (TimeTimeList.filter p xs) - -filterCommutative :: (Num time, Eq body) => - (body -> Bool) -> - (body -> Bool) -> - TimeTimeList.T time body -> Bool -filterCommutative p q xs = - TimeTimeList.filter p (TimeTimeList.filter q xs) == - TimeTimeList.filter q (TimeTimeList.filter p xs) - -filterComposition :: (Num time, Eq body) => - (body -> Bool) -> - (body -> Bool) -> - TimeTimeList.T time body -> Bool -filterComposition p q xs = - TimeTimeList.filter p (TimeTimeList.filter q xs) == - TimeTimeList.filter (\b -> p b && q b) xs - -filterNormalize :: (NonNeg.C time, Ord body) => - (body -> Bool) -> - TimeTimeList.T time body -> Bool -filterNormalize p = - isNormalized . TimeTimeList.filter p . TimeTimeList.normalize - -filterAppend :: (NonNeg.C time, Eq body) => - (body -> Bool) -> - TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -filterAppend p xs ys = - TimeTimeList.filter p (TimeTimeList.append xs ys) == - TimeTimeList.append (TimeTimeList.filter p xs) (TimeTimeList.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) -> TimeTimeList.T time body -> Bool -filterPartition p xs = - (TimeTimeList.filter p xs, TimeTimeList.filter (not . p) xs) == - TimeTimeList.partition p xs - - -filterInfinite :: (NonNeg.C time, Eq body) => - (body -> Bool) -> NonEmptyList time body -> Bool -filterInfinite p xs = - null (TimeTimeList.getBodies (TimeTimeList.filter p (makeNonEmptyEventList xs))) - || - (checkInfinite . - TimeTimeList.filter p . - makeInfiniteEventList) xs - -catMaybesAppend :: (NonNeg.C time, Eq body) => - TimeTimeList.T time (Maybe body) -> TimeTimeList.T time (Maybe body) -> Bool -catMaybesAppend xs ys = - TimeTimeList.catMaybes (TimeTimeList.append xs ys) == - TimeTimeList.append (TimeTimeList.catMaybes xs) (TimeTimeList.catMaybes ys) - - -{- | -'TimeTimeList.merge' preserves normalization of its operands. --} -mergeNormalize :: (NonNeg.C time, Ord body) => - TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -mergeNormalize xs0 ys0 = - let xs = TimeTimeList.normalize xs0 - ys = TimeTimeList.normalize ys0 - in isNormalized $ TimeTimeList.merge xs ys - -mergeLeftIdentity :: (NonNeg.C time, Ord body) => - TimeTimeList.T time body -> Bool -mergeLeftIdentity xs = - TimeTimeList.merge (TimeTimeList.pause 0) xs == xs - -mergeRightIdentity :: (NonNeg.C time, Ord body) => - TimeTimeList.T time body -> Bool -mergeRightIdentity xs = - TimeTimeList.merge xs (TimeTimeList.pause 0) == xs - -mergeCommutative :: (NonNeg.C time, Ord body) => - TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -mergeCommutative xs0 ys0 = - let xs = TimeTimeList.normalize xs0 - ys = TimeTimeList.normalize ys0 - in TimeTimeList.merge xs ys == TimeTimeList.merge ys xs -{- -merge commutative: Falsifiable, after 8 tests: -3 ./ '!' /. 0 ./ ' ' /. 1 ./ ' ' /. 2 ./ empty -3 ./ '!' /. 3 ./ '!' /. 1 ./ empty --} - -mergeAssociative :: (NonNeg.C time, Ord body) => - TimeTimeList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -mergeAssociative xs0 ys0 zs0 = - let xs = TimeTimeList.normalize xs0 - ys = TimeTimeList.normalize ys0 - zs = TimeTimeList.normalize zs0 - in TimeTimeList.merge xs (TimeTimeList.merge ys zs) == - TimeTimeList.merge (TimeTimeList.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. - -Without posterior normalization you get - -merge append: Falsifiable, after 30 tests: -1 ./ 'a' /. 0 ./ empty -1 ./ ' ' /. 1 ./ empty -0 ./ ' ' /. 1 ./ empty - --} -mergeAppend :: (NonNeg.C time, Ord body) => - TimeTimeList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -mergeAppend xs ys zs = - TimeTimeList.normalize (TimeTimeList.append xs (TimeTimeList.merge ys zs)) == - TimeTimeList.normalize - (TimeTimeList.merge (TimeTimeList.append xs ys) - (TimeTimeList.delay (TimeTimeList.duration xs) zs)) - -appendByMerge :: (NonNeg.C time, Ord body) => - TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -appendByMerge xs ys = - TimeTimeList.normalize (TimeTimeList.append xs ys) == - TimeTimeList.normalize (TimeTimeList.merge xs - (TimeTimeList.delay (TimeTimeList.duration xs) ys)) - -{- -Normalization is important, otherwise the following counter-examples exist: - -merge associative: Falsifiable, after 99 tests: -0 ./ '\DEL' /. 2 ./ '\DEL' /. 2 ./ empty -0 ./ '\DEL' /. 2 ./ '\DEL' /. 0 ./ '~' /. 3 ./ empty -2 ./ ' ' /. 2 ./ '\DEL' /. 3 ./ empty - -merge associative: Falsifiable, after 99 tests: -6 ./ '~' /. 2 ./ '%' /. 1 ./ '#' /. 3 ./ '$' /. 2 ./ empty -6 ./ '~' /. 0 ./ '"' /. 2 ./ '{' /. 0 ./ '"' /. 6 ./ empty -0 ./ '{' /. 5 ./ '$' /. 3 ./ empty - -merge associative: Falsifiable, after 41 tests: -2 ./ '~' /. 0 ./ empty -2 ./ '~' /. 0 ./ '$' /. 3 ./ empty -1 ./ '#' /. 4 ./ '"' /. 4 ./ empty --} - --- does only hold for monotonic functions --- toUpper and toLower are not monotonic -mergeMap :: (NonNeg.C time, Ord body0 ,Ord body1) => - (body0 -> body1) -> TimeTimeList.T time body0 -> TimeTimeList.T time body0 -> Bool -mergeMap f xs0 ys0 = - let xs = TimeTimeList.normalize xs0 - ys = TimeTimeList.normalize ys0 - in TimeTimeList.mapBody f (TimeTimeList.merge xs ys) == - TimeTimeList.merge (TimeTimeList.mapBody f xs) (TimeTimeList.mapBody f ys) - -mergeFilter :: (NonNeg.C time, Ord body) => - (body -> Bool) -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -mergeFilter p xs0 ys0 = - let xs = TimeTimeList.normalize xs0 - ys = TimeTimeList.normalize ys0 - in TimeTimeList.filter p (TimeTimeList.merge xs ys) == - TimeTimeList.merge (TimeTimeList.filter p xs) (TimeTimeList.filter p ys) - -mergePartition :: (NonNeg.C time, Ord body) => - (body -> Bool) -> TimeTimeList.T time body -> Bool -mergePartition p xs0 = - let xs = TimeTimeList.normalize xs0 - in xs == uncurry TimeTimeList.merge (TimeTimeList.partition p xs) - -mergeEitherMapMaybe :: (NonNeg.C time, Ord body) => - TimeTimeList.T time body -> TimeTimeList.T time body -> Bool -mergeEitherMapMaybe xs0 ys0 = - let xs = TimeTimeList.normalize xs0 - ys = TimeTimeList.normalize ys0 - zs = TimeTimeList.merge - (TimeTimeList.mapBody Left xs) - (TimeTimeList.mapBody Right ys) - dur = TimeTimeList.duration zs - longXs = TimeTimeList.merge (TimeTimeList.pause dur) xs - longYs = TimeTimeList.merge (TimeTimeList.pause dur) ys - in longXs == TimeTimeList.mapMaybe (either Just (const Nothing)) zs - && - longYs == TimeTimeList.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 (TimeTimeList.merge xs ys) - - - -insertCommutative :: (NonNeg.C time, Ord body) => - (time, body) -> (time, body) -> TimeTimeList.T time body -> Bool -insertCommutative (time0, body0) (time1, body1) evs = - TimeTimeList.insert time0 body0 (TimeTimeList.insert time1 body1 evs) == - TimeTimeList.insert time1 body1 (TimeTimeList.insert time0 body0 evs) - -insertMerge :: (NonNeg.C time, Ord body) => - time -> body -> TimeTimeList.T time body -> Bool -insertMerge time body evs = - TimeTimeList.insert time body evs == - TimeTimeList.merge (TimeTimeList.cons time body $ TimeTimeList.pause 0) evs - -insertNormalize :: (NonNeg.C time, Ord body) => - time -> body -> TimeTimeList.T time body -> Bool -insertNormalize time body = - isNormalized . TimeTimeList.insert time body . TimeTimeList.normalize - -insertSplitAtTime :: (NonNeg.C time, Ord body) => - time -> body -> TimeTimeList.T time body -> Bool -insertSplitAtTime time body evs = - TimeTimeList.insert - (min time (TimeTimeList.duration evs)) body - (TimeTimeList.normalize evs) - == - let (prefix,suffix) = TimeTimeList.splitAtTime time evs - in TimeTimeList.normalize - (TimeTimeList.append prefix (TimeTimeList.cons 0 body suffix)) - -- append prefix (MixedTimeList.consBody body suffix) - -insertInfinite :: (NonNeg.C time, Ord body) => - time -> body -> NonEmptyList time body -> Bool -insertInfinite time body = - checkInfinite . TimeTimeList.insert time body . makeInfiniteEventList - - - - -coincidentFlatten :: (NonNeg.C time, Eq body) => - TimeTimeList.T time body -> Bool -coincidentFlatten xs = - xs == TimeTimeList.flatten (TimeTimeList.collectCoincident xs) - -collectCoincidentGaps :: (NonNeg.C time, Eq body) => - TimeTimeList.T time body -> Bool -collectCoincidentGaps xs = - let times = tail (TimeTimeList.getTimes (TimeTimeList.collectCoincident xs)) - in null times || all (0<) (init times) - -collectCoincidentNonEmpty :: (NonNeg.C time, Eq body) => - TimeTimeList.T time body -> Bool -collectCoincidentNonEmpty = - all (not . null) . TimeTimeList.getBodies . TimeTimeList.collectCoincident - -collectCoincidentInfinite :: (NonNeg.C time, Eq body) => - NonEmptyList time body -> Bool -collectCoincidentInfinite = - checkInfinite . - TimeTimeList.collectCoincident . - makeUncollapsedInfiniteEventList - - -mapCoincidentMap :: (NonNeg.C time, Eq body1) => - (body0 -> body1) -> TimeTimeList.T time body0 -> Bool -mapCoincidentMap f xs = - TimeTimeList.mapBody f xs == - TimeTimeList.mapCoincident (map f) xs - -mapCoincidentComposition :: (NonNeg.C time, Eq body2) => - ([body0] -> [body1]) -> ([body1] -> [body2]) -> TimeTimeList.T time body0 -> Bool -mapCoincidentComposition f g xs = - TimeTimeList.mapCoincident (g . f) xs == - (TimeTimeList.mapCoincident g . TimeTimeList.mapCoincident f) xs - -mapCoincidentReverse :: (NonNeg.C time, Eq body) => - TimeTimeList.T time body -> Bool -mapCoincidentReverse xs = - xs == TimeTimeList.mapCoincident reverse (TimeTimeList.mapCoincident reverse xs) - - - -mapBodyMAppend :: - (Monad m, Eq body1, NonNeg.C time) => - (m (TimeTimeList.T time body1) -> TimeTimeList.T time body1) -> - (body0 -> m body1) -> TimeTimeList.T time body0 -> TimeTimeList.T time body0 -> Bool -mapBodyMAppend run f xs ys = - run (TimeTimeList.mapM return f (TimeTimeList.append xs ys)) == - run (liftM2 TimeTimeList.append (TimeTimeList.mapM return f xs) (TimeTimeList.mapM return f ys)) - -mapBodyMAppendRandom :: - (Random body, NonNeg.C time, Eq body) => - Int -> TimeTimeList.T time (body,body) -> TimeTimeList.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) . - TimeTimeList.mapM return (State . randomR) . - makeInfiniteEventList - - -{- - -mapM :: Monad m => - (time0 -> m time1) -> (body0 -> m body1) -> - TimeTimeList.T time0 body0 -> m (TimeTimeList.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 :: TimeTimeList.T time body -> [body] -getBodies = Uniform.getFirsts - -getTimes :: TimeTimeList.T time body -> [time] -getTimes = Uniform.getSeconds - - -empty :: Immediate time body -empty = Disp.empty - - -cons :: time -> body -> TimeTimeList.T time body -> TimeTimeList.T time body -cons = Uniform.cons - - -snoc :: TimeTimeList.T time body -> body -> time -> TimeTimeList.T time body -snoc = Uniform.snoc - - -{- -propInsertPadded :: Event time body -> TimeTimeList.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 -> TimeTimeList.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 -> TimeTimeList.T time body -fromEventList t = - EventList.foldr consTime consBody (pause t) - -toEventList :: TimeTimeList.T time body -> EventList.T time body -toEventList xs = - zipWith EventList.Event (getTimes xs) (getBodies xs) - -{- | - --} - - -discretize :: (RealFrac time, Integral i) => - TimeTimeList.T time body -> TimeTimeList.T i body -discretize es = - evalState (Uniform.mapSecondM roundDiff es) 0 - -resample :: (RealFrac time, Integral i) => - time -> TimeTimeList.T time body -> TimeTimeList.T i body -resample rate es = - discretize (mapTime (rate*) es) - - -toAbsoluteEventList :: (Num time) => - time -> TimeTimeList.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, TimeTimeList.T time body) - -makeUncollapsedInfiniteEventList :: (NonNeg.C time) => - NonEmptyList time body -> TimeTimeList.T time body -makeUncollapsedInfiniteEventList = - makeInfiniteEventList . - (\(time,body,xs) -> (time+1,body,xs)) - -makeInfiniteEventList :: (NonNeg.C time) => - NonEmptyList time body -> TimeTimeList.T time body -makeInfiniteEventList = - TimeTimeList.cycle . makeNonEmptyEventList - -makeNonEmptyEventList :: (NonNeg.C time) => - NonEmptyList time body -> TimeTimeList.T time body -makeNonEmptyEventList (t, b, evs) = - TimeTimeList.cons t b evs - -{- | -Pick an arbitrary element from an infinite list -and check if it can be evaluated. --} -checkInfinite :: (Eq time, Eq body) => - TimeTimeList.T time body -> Bool -checkInfinite xs0 = - let (x,xs) = MixedTimeList.viewTimeL (lift (Mixed.dropUniform 100) xs0) - y = maybe - (error "checkInfinite: finite list") - fst - (MixedTimeList.viewBodyL xs) - in x == x && y == y - - - -tests :: [(String, IO ())] -tests = - ("viewTimeL consTime", - test (viewLConsTime :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("viewBodyL consBody", - test (viewLConsBody :: BodyTimeList.T TimeDiff Char -> Bool)) : - ("viewTimeR snocTime", - test (viewRSnocTime :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("viewBodyR snocBody", - test (viewRSnocBody :: TimeBodyList.T TimeDiff Char -> Bool)) : - - ("viewLInfinite", - test (viewLInfinite :: NonEmptyList TimeDiff Char -> Bool)) : - ("viewRInfinite", - test (viewRInfinite :: 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)) : - ("snocTimeBodyInfinite", - test (snocTimeBodyInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) : - ("consInfix", - test (consInfix :: TimeDiff -> Char -> TimeDiff -> TimeDiff -> Char -> TimeDiff -> Bool)) : - - - ("map body composition", - test (mapBodyComposition Char.toUpper Char.toLower - :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("map time composition", - test ((\dt0 dt1 -> mapTimeComposition (dt0+) (dt1+)) - :: TimeDiff -> TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("map time body commutative", - test ((\dt -> mapTimeBodyCommutative (dt+) Char.toUpper) - :: TimeDiff -> TimeTimeList.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 - :: TimeTimeList.T TimeDiff Char -> Bool)) : - - ("append left identity", - test (appendLeftIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("append right identity", - test (appendRightIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("append associative", - test (appendAssociative - :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> - TimeTimeList.T TimeDiff Char -> Bool)) : - - ("appendCons", - test (appendCons :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("mapBodyAppend", - test (mapBodyAppend Char.toUpper - :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("appendSplitAtTime", - test (appendSplitAtTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("appendFirstInfinite", - test (appendFirstInfinite :: NonEmptyList TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("appendSecondInfinite", - test (appendSecondInfinite :: TimeTimeList.T TimeDiff Char -> NonEmptyList TimeDiff Char -> Bool)) : - ("concatNaive", - test (concatNaive :: [TimeTimeList.T TimeDiff Char] -> Bool)) : - ("cycleNaive", - test (cycleNaive :: NonEmptyList TimeDiff Char -> Bool)) : - ("cycleInfinite", - test (cycleInfinite :: NonEmptyList TimeDiff Char -> Bool)) : - - ("decreaseStart delay", - test (decreaseStartDelay :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("decreaseStartInfinite", - test (decreaseStartInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) : - - ("delay additive", - test (delayAdditive :: TimeDiff -> TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("delay pause", - test (delayPause :: TimeDiff -> TimeDiff -> Bool)) : - ("delay append pause", - test (delayAppendPause :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("delayInfinite", - test (delayInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) : - - ("splitAtTakeDropTime", - test (splitAtTakeDropTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("takeTimeEndPause", - test (takeTimeEndPause :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("takeTimeAppendFirst", - test (takeTimeAppendFirst :: TimeDiff -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("takeTimeAppendSecond", - test (takeTimeAppendSecond :: TimeDiff -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("takeTimeNormalize", - test (takeTimeNormalize :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("dropTimeNormalize", - test (dropTimeNormalize :: TimeDiff -> TimeTimeList.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 :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("duration merge", - test (durationMerge :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("durationTakeTime", - test (durationTakeTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("durationDropTime", - test (durationDropTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : - - ("filterSatisfy", - test (\c -> filterSatisfy (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("filterProjection", - test (\c -> filterProjection (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("filterCommutative", - test (\c0 c1 -> filterCommutative (c0<) (c1>) :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("filterComposition", - test (\c0 c1 -> filterComposition (c0<) (c1>) :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("filterNormalize", - test (\c -> filterNormalize (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("filterAppend", - test (\c -> filterAppend (c<) :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("filterDuration", - test (\c -> filterDuration (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("filterPartition", - test (\c -> filterPartition (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("filterInfinite", - test (\c -> filterInfinite (c<) :: NonEmptyList TimeDiff Char -> Bool)) : - ("catMaybesAppend", - test (catMaybesAppend :: TimeTimeList.T TimeDiff (Maybe Char) -> TimeTimeList.T TimeDiff (Maybe Char) -> Bool)) : - - ("mergeNormalize", - test (mergeNormalize :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("merge left identity", - test (mergeLeftIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("merge right identity", - test (mergeRightIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("merge commutative", - test (mergeCommutative :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("merge associative", - test (mergeAssociative :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("merge append", - test (mergeAppend :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("appendByMerge", - test (appendByMerge :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("mergeMap", - test (mergeMap succ :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("mergeFilter", - test (\c -> mergeFilter (c>) - :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("mergePartition", - test (\c -> mergePartition (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("mergeEitherMapMaybe", - test (mergeEitherMapMaybe - :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("mergeInfinite", - test (mergeInfinite - :: NonEmptyList TimeDiff Char -> NonEmptyList TimeDiff Char -> Bool)) : - - ("insert commutative", - test (insertCommutative :: (TimeDiff, Char) -> (TimeDiff, Char) -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("insert merge", - test (insertMerge :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("insertNormalize", - test (insertNormalize :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("insertSplitAtTime", - test (insertSplitAtTime :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) : - ("insertInfinite", - test (insertInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) : - - ("coincidentFlatten", - test (coincidentFlatten :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("collectCoincidentGaps", - test (collectCoincidentGaps :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("collectCoincidentNonEmpty", - test (collectCoincidentNonEmpty :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("collectCoincidentInfinite", - test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) : - - ("mapCoincidentMap", - test (mapCoincidentMap Char.toUpper :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("mapCoincidentComposition", - test (mapCoincidentComposition reverse reverse :: TimeTimeList.T TimeDiff Char -> Bool)) : - ("mapCoincidentReverse", - test (mapCoincidentReverse :: TimeTimeList.T TimeDiff Char -> Bool)) : - - ("mapBodyMAppendRandom", - test (mapBodyMAppendRandom :: Int -> TimeTimeList.T TimeDiff (Char,Char) -> TimeTimeList.T TimeDiff (Char,Char) -> Bool)) : - ("mapBodyMInfinite", - test (mapBodyMInfinite :: Int -> NonEmptyList TimeDiff (Char,Char) -> Bool)) : - - [] diff --git a/Test/Main.hs b/Test/Main.hs deleted file mode 100644 --- a/Test/Main.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Main where - -import qualified Test.Data.EventList.Absolute.BodyEnd as AbsBodyEnd -import qualified Test.Data.EventList.Absolute.TimeEnd as AbsTimeEnd -import qualified Test.Data.EventList.Relative.BodyEnd as RelBodyEnd -import qualified Test.Data.EventList.Relative.TimeEnd as RelTimeEnd - -prefix :: String -> [(String, IO ())] -> [(String, IO ())] -prefix msg = - map (\(str,test) -> (msg ++ "." ++ str, test)) - -main :: IO () -main = - mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $ - concat $ - prefix "Absolute.BodyEnd" AbsBodyEnd.tests : - prefix "Absolute.TimeEnd" AbsTimeEnd.tests : - prefix "Relative.BodyEnd" RelBodyEnd.tests : - prefix "Relative.TimeEnd" RelTimeEnd.tests : - [] diff --git a/Test/Utility.hs b/Test/Utility.hs deleted file mode 100644 --- a/Test/Utility.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Test.Utility where - -import Test.QuickCheck (Arbitrary(..)) - -import qualified Numeric.NonNegative.Wrapper as NonNeg -import Control.Monad (liftM) -import Data.Char (chr) - - -type TimeDiff = NonNeg.Int - -timeToDouble :: TimeDiff -> NonNeg.Double -timeToDouble = fromIntegral - -makeFracTime :: (TimeDiff, TimeDiff) -> NonNeg.Double -makeFracTime (n,d) = - timeToDouble n / (timeToDouble d + 1) - - -instance Arbitrary Char where - arbitrary = liftM (chr . (32+) . flip mod 96) arbitrary - coarbitrary = undefined - -instance Arbitrary a => Arbitrary (Maybe a) where - arbitrary = - arbitrary >>= - \b -> if b then fmap Just arbitrary else return Nothing - coarbitrary = undefined diff --git a/event-list.cabal b/event-list.cabal --- a/event-list.cabal +++ b/event-list.cabal @@ -1,16 +1,11 @@ Name: event-list -Version: 0.0.5 +Version: 0.0.6 License: GPL License-File: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann Homepage: http://darcs.haskell.org/event-list/ -Category: Data Structures -Build-Type: Simple -Build-Depends: non-negative==0.0.1, base>=1.0, mtl, QuickCheck --- From the Monad Template Library we only need the State monad. --- If your compiler does not support functional dependencies, --- it would be easy to replace that by mapAccumL. +Category: Data Synopsis: Event lists with relative or absolute time stamps Description: These lists manage events that are associated with times. @@ -21,40 +16,61 @@ that is [b,a,b,...,a,b] or [a,b,a,...,a,b]. The data structures can be used to represent MIDI files, OpenSoundControl message streams, music performances etc. -GHC-Options: -Wall -Tested-With: GHC==6.4.1 -Hs-Source-Dirs: src -Exposed-Modules: - Data.EventList.Absolute.TimeBody - Data.EventList.Absolute.TimeTime - Data.EventList.Absolute.TimeMixed - Data.EventList.Relative.TimeBody - Data.EventList.Relative.TimeTime - Data.EventList.Relative.TimeMixed - Data.EventList.Relative.BodyBody - Data.EventList.Relative.BodyTime - Data.EventList.Relative.MixedTime - Data.EventList.Relative.MixedBody -Other-Modules: - Data.EventList.Utility - Data.EventList.Absolute.TimeBodyPrivate - Data.EventList.Absolute.TimeTimePrivate - Data.EventList.Relative.TimeBodyPrivate - Data.EventList.Relative.BodyBodyPrivate - Data.EventList.Relative.TimeTimePrivate - Data.EventList.Relative.BodyTimePrivate - Data.AlternatingList.Custom - Data.AlternatingList.List.Disparate - Data.AlternatingList.List.Uniform - Data.AlternatingList.List.Mixed +Tested-With: GHC==6.4.1, GHC==6.6.1, GHC==6.8.2 +Cabal-Version: >=1.2 +Build-Type: Simple -Executable: test -Hs-source-dirs: src, . -GHC-Options: -Wall -Main-Is: Test/Main.hs -Other-Modules: - Test.Utility - Test.Data.EventList.Absolute.BodyEnd - Test.Data.EventList.Absolute.TimeEnd - Test.Data.EventList.Relative.BodyEnd - Test.Data.EventList.Relative.TimeEnd +Flag splitBase + description: Choose the new smaller, split-up base package. + +Library + If flag(splitBase) + Build-Depends: base >= 2, non-negative==0.0.1, mtl, QuickCheck, random + -- random is needed for the Test + Else + Build-Depends: base >= 1.0 && < 2, non-negative==0.0.1, mtl, QuickCheck + -- From the Monad Template Library we only need the State monad. + -- If your compiler does not support functional dependencies, + -- it would be easy to replace that by mapAccumL. + + GHC-Options: -Wall + Hs-Source-Dirs: src + Exposed-Modules: + Data.EventList.Absolute.TimeBody + Data.EventList.Absolute.TimeTime + Data.EventList.Absolute.TimeMixed + Data.EventList.Relative.TimeBody + Data.EventList.Relative.TimeTime + Data.EventList.Relative.TimeMixed + Data.EventList.Relative.BodyBody + Data.EventList.Relative.BodyTime + Data.EventList.Relative.MixedTime + Data.EventList.Relative.MixedBody + Other-Modules: + Data.EventList.Utility + Data.EventList.Absolute.TimeBodyPrivate + Data.EventList.Absolute.TimeTimePrivate + Data.EventList.Relative.TimeBodyPrivate + Data.EventList.Relative.BodyBodyPrivate + Data.EventList.Relative.TimeTimePrivate + Data.EventList.Relative.BodyTimePrivate + Data.AlternatingList.Custom + Data.AlternatingList.List.Disparate + Data.AlternatingList.List.Uniform + Data.AlternatingList.List.Mixed + +Executable test + If flag(splitBase) + Hs-source-dirs: src, src-2 + Else + Hs-source-dirs: src, src-1 + + GHC-Options: -Wall + Main-Is: Test/Main.hs + Other-Modules: + Test.Instances + Test.Utility + Test.Data.EventList.Absolute.BodyEnd + Test.Data.EventList.Absolute.TimeEnd + Test.Data.EventList.Relative.BodyEnd + Test.Data.EventList.Relative.TimeEnd diff --git a/src-1/Test/Instances.hs b/src-1/Test/Instances.hs new file mode 100644 --- /dev/null +++ b/src-1/Test/Instances.hs @@ -0,0 +1,17 @@ +module Test.Instances where + +import Test.QuickCheck (Arbitrary(..)) + +import Control.Monad (liftM) +import Data.Char (chr) + + +instance Arbitrary Char where + arbitrary = liftM (chr . (32+) . flip mod 96) arbitrary + coarbitrary = undefined + +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = + arbitrary >>= + \b -> if b then fmap Just arbitrary else return Nothing + coarbitrary = undefined diff --git a/src-2/Test/Instances.hs b/src-2/Test/Instances.hs new file mode 100644 --- /dev/null +++ b/src-2/Test/Instances.hs @@ -0,0 +1,11 @@ +module Test.Instances where + +import Test.QuickCheck (Arbitrary(..)) + +import Control.Monad (liftM) +import Data.Char (chr) + + +instance Arbitrary Char where + arbitrary = liftM (chr . (32+) . flip mod 96) arbitrary + coarbitrary = undefined diff --git a/src/Test/Data/EventList/Absolute/BodyEnd.hs b/src/Test/Data/EventList/Absolute/BodyEnd.hs new file mode 100644 --- /dev/null +++ b/src/Test/Data/EventList/Absolute/BodyEnd.hs @@ -0,0 +1,325 @@ +{- | +Copyright : (c) Henning Thielemann 2007 + +Maintainer : haskell@henning-thielemann.de +Stability : stable +Portability : Haskell 98 +-} +module Test.Data.EventList.Absolute.BodyEnd (tests) where + +import Test.Utility +import Test.QuickCheck (test) + +import qualified Data.EventList.Absolute.TimeBody as AbsBody +import qualified Data.EventList.Absolute.TimeBodyPrivate as AbsBodyPriv +import qualified Data.EventList.Relative.TimeBody as RelBody +import qualified Data.AlternatingList.List.Disparate as Disp + +-- for testing in GHCi +-- import Data.AlternatingList.List.Disparate (empty) +-- import Data.AlternatingList.List.Uniform ((/.), (./)) +import qualified Data.Char as Char + +import System.Random (Random, randomR, mkStdGen) +import Control.Monad (liftM) + +import qualified Data.EventList.Utility as Utility + +import qualified Numeric.NonNegative.Class as NonNeg +import Data.EventList.Utility (mapFst, mapSnd, mapPair) +import qualified Control.Monad as Monad +import Control.Monad.State (State(State), evalState) + +import Prelude hiding (filter, concat) + + +infixl 5 $~ + +($~) :: Num time => + (AbsBody.T time body -> a) -> (RelBody.T time body -> a) +($~) f = f . RelBody.toAbsoluteEventList 0 + +infixl 4 ==~ + +(==~) :: (Eq body, Num time) => + AbsBody.T time body -> RelBody.T time body -> Bool +(==~) xs ys = + xs == RelBody.toAbsoluteEventList 0 ys + + + +duration :: Num time => RelBody.T time body -> Bool +duration xs = + AbsBody.duration $~ xs == RelBody.duration xs + + +mapBody :: (Eq body1, Num time) => + (body0 -> body1) -> RelBody.T time body0 -> Bool +mapBody f xs = + AbsBody.mapBody f $~ xs ==~ RelBody.mapBody f xs + + + +mapBodyM :: + (Monad m, Eq body1, NonNeg.C time) => + (m (AbsBody.T time body1) -> AbsBody.T time body1) -> + (body0 -> m body1) -> RelBody.T time body0 -> Bool +mapBodyM run f xs = + run (AbsBody.mapBodyM f $~ xs) == + run (liftM (RelBody.toAbsoluteEventList 0) (RelBody.mapBodyM f xs)) + +mapBodyMRandom :: + (NonNeg.C time, Random body, Eq body) => + Int -> RelBody.T time (body, body) -> Bool +mapBodyMRandom seed = + mapBodyM + (flip evalState (mkStdGen seed)) + (State . randomR) + + +filter :: (Eq body, Num time) => + (body -> Bool) -> RelBody.T time body -> Bool +filter p xs = + AbsBody.filter p $~ xs ==~ RelBody.filter p xs + +{- +mapMaybe :: (Num time) => + (body0 -> Maybe body1) -> + RelBody.T time body0 -> RelBody.T time body1 +mapMaybe f = catMaybes . mapBody f +-} + +catMaybes :: (Eq body, Num time) => + RelBody.T time (Maybe body) -> Bool +catMaybes xs = + AbsBody.catMaybes $~ xs ==~ RelBody.catMaybes xs + +{- +Could be implemented more easily in terms of Uniform.partition +-} +partition :: (Eq body, Num time) => + (body -> Bool) -> RelBody.T time body -> Bool +partition p xs = + AbsBody.partition p $~ xs == +-- mapPair (RelBody.toAbsoluteEventList 0, RelBody.toAbsoluteEventList 0) + (uncurry $ \ys zs -> (,) $~ ys $~ zs) + (RelBody.partition p xs) + +{- | +Since we need it later for MIDI generation, +we will also define a slicing into equivalence classes of events. +-} +slice :: (Eq a, Eq body, Num time) => + (body -> a) -> RelBody.T time body -> Bool +slice f xs = + AbsBody.slice f $~ xs == + map (mapSnd (RelBody.toAbsoluteEventList 0)) (RelBody.slice f xs) + + +collectCoincident :: (NonNeg.C time, Eq body) => + RelBody.T time body -> Bool +collectCoincident xs = + AbsBody.collectCoincident $~ xs ==~ + RelBody.collectCoincident xs + +collectCoincidentFoldr :: (NonNeg.C time, Eq body) => + RelBody.T time body -> Bool +collectCoincidentFoldr xs = + AbsBody.collectCoincident $~ xs == + AbsBody.collectCoincidentFoldr $~ xs + +collectCoincidentNonLazy :: (NonNeg.C time, Eq body) => + RelBody.T time body -> Bool +collectCoincidentNonLazy xs = + AbsBody.collectCoincident $~ xs == + AbsBody.collectCoincidentNonLazy $~ xs + +collectCoincidentInfinite :: (NonNeg.C time, Eq body) => + NonEmptyList time body -> Bool +collectCoincidentInfinite = + checkInfinite . + AbsBody.collectCoincident . + makeUncollapsedInfiniteEventList + + +flatten :: (NonNeg.C time, Eq body) => + RelBody.T time [body] -> Bool +flatten xs = + AbsBody.flatten $~ xs ==~ RelBody.flatten xs + + +normalize :: (NonNeg.C time, Ord body) => + RelBody.T time body -> Bool +normalize xs = + AbsBody.normalize $~ xs ==~ RelBody.normalize xs + + +merge :: (NonNeg.C time, Ord body) => + RelBody.T time body -> RelBody.T time body -> Bool +merge xs ys = + AbsBody.merge $~ xs $~ ys ==~ RelBody.merge xs ys + + +insert :: (NonNeg.C time, Ord body) => + time -> body -> RelBody.T time body -> Bool +insert t b xs = + AbsBody.insert t b $~ xs ==~ RelBody.insert t b xs + + + +append :: (NonNeg.C time, Eq body) => + RelBody.T time body -> RelBody.T time body -> Bool +append xs ys = + AbsBody.append $~ xs $~ ys ==~ + RelBody.append xs ys + +concat :: (NonNeg.C time, Eq body) => + [RelBody.T time body] -> Bool +concat xs = + AbsBody.concat (map (RelBody.toAbsoluteEventList 0) xs) ==~ + RelBody.concat xs + + +{- +cycle :: (NonNeg.C time) => + RelBody.T time body -> RelBody.T time body +cycle = concat . List.repeat +-} + + +decreaseStart :: (NonNeg.C time, Eq body) => + time -> time -> RelBody.T time body -> Bool +decreaseStart dif0 dif1 xs0 = + let difA = min dif0 dif1 + difB = max dif0 dif1 + xs = RelBody.delay difB xs0 + in AbsBody.decreaseStart difA $~ xs ==~ + RelBody.decreaseStart difA xs + + +delay :: (NonNeg.C time, Eq body) => + time -> RelBody.T time body -> Bool +delay dif xs = + AbsBody.delay dif $~ xs ==~ + RelBody.delay dif xs + + + +{- +resample :: (Integral time, Eq body) => + time -> RelBody.T (time, time) body -> Bool +resample rateInt xs0 = + let xs = RelBody.mapTime (\(n,d) -> n % (d+1)) xs0 + rate = rateInt % 1 + in AbsBody.resample rate $~ xs ==~ + (RelBody.resample rate xs `asTypeOf` + AbsBody.singleton (undefined::Int) undefined) +-} + +resample :: (Eq body) => + TimeDiff -> RelBody.T (TimeDiff, TimeDiff) body -> Bool +resample rateInt xs0 = + let {- + I add a small amount to the numerator in order + to prevent the case of a fraction like 10.5, + which can be easily rounded to 10 or 11 + depending to previous rounding errors. + -} + xs = RelBody.mapTime ((1e-6 +) . makeFracTime) xs0 + rate = timeToDouble rateInt + 1 + in AbsBody.resample rate $~ xs ==~ + (RelBody.resample rate xs `asTypeOf` + RelBody.singleton (undefined::TimeDiff) undefined) + +resampleInfinite :: (Eq body) => + TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) body -> Bool +resampleInfinite rateInt = + let rate = timeToDouble rateInt + 1 + in checkInfinite . + (`asTypeOf` AbsBody.singleton (undefined::TimeDiff) undefined) . + AbsBody.resample rate . + makeInfiniteEventList . + mapPair (mapFst makeFracTime, RelBody.mapTime makeFracTime) + + + + +type NonEmptyList time body = ((time, body), RelBody.T time body) + +makeUncollapsedInfiniteEventList :: (NonNeg.C time) => + NonEmptyList time body -> AbsBody.T time body +makeUncollapsedInfiniteEventList = + makeInfiniteEventList . + mapFst (mapFst (1+)) + +makeInfiniteEventList :: (NonNeg.C time) => + NonEmptyList time body -> AbsBody.T time body +makeInfiniteEventList = + RelBody.toAbsoluteEventList 0 . RelBody.cycle . makeNonEmptyEventList + +makeNonEmptyEventList :: (NonNeg.C time) => + NonEmptyList time body -> RelBody.T time body +makeNonEmptyEventList (p, evs) = + uncurry RelBody.cons p evs + +{- | +Pick an arbitrary element from an infinite list +and check if it can be evaluated. +-} +checkInfinite :: (Eq time, Eq body) => + AbsBody.T time body -> Bool +checkInfinite xs0 = + let x = maybe + (error "BodyEnd.checkInfinite: empty list") fst $ + AbsBody.viewL $ AbsBodyPriv.lift (Disp.drop 100) xs0 + in x == x + + + + + +tests :: [(String, IO ())] +tests = + ("duration", + test (duration :: RelBody.T TimeDiff Char -> Bool)) : + ("mapBody", + test (mapBody Char.toUpper :: RelBody.T TimeDiff Char -> Bool)) : + ("mapBodyM", + test (mapBodyMRandom :: Int -> RelBody.T TimeDiff (Char, Char) -> Bool)) : + ("filter", + test (\c -> filter (c<) :: RelBody.T TimeDiff Char -> Bool)) : + ("catMaybes", + test (catMaybes :: RelBody.T TimeDiff (Maybe Char) -> Bool)) : + ("partition", + test (\c -> partition (c<) :: RelBody.T TimeDiff Char -> Bool)) : + ("slice", + test (slice fst :: RelBody.T TimeDiff (Char,Char) -> Bool)) : + ("collectCoincident", + test (collectCoincident :: RelBody.T TimeDiff Char -> Bool)) : + ("collectCoincidentFoldr", + test (collectCoincidentFoldr :: RelBody.T TimeDiff Char -> Bool)) : + ("collectCoincidentNonLazy", + test (collectCoincidentNonLazy :: RelBody.T TimeDiff Char -> Bool)) : + ("collectCoincidentInfinite", + test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) : + ("flatten", + test (flatten :: RelBody.T TimeDiff [Char] -> Bool)) : + ("normalize", + test (normalize :: RelBody.T TimeDiff Char -> Bool)) : + ("merge", + test (merge :: RelBody.T TimeDiff Char -> RelBody.T TimeDiff Char -> Bool)) : + ("insert", + test (insert :: TimeDiff -> Char -> RelBody.T TimeDiff Char -> Bool)) : + ("append", + test (append :: RelBody.T TimeDiff Char -> RelBody.T TimeDiff Char -> Bool)) : + ("concat", + test (concat :: [RelBody.T TimeDiff Char] -> Bool)) : + ("decreaseStart", + test (decreaseStart :: TimeDiff -> TimeDiff -> RelBody.T TimeDiff Char -> Bool)) : + ("delay", + test (delay :: TimeDiff -> RelBody.T TimeDiff Char -> Bool)) : + ("resample", + test (resample :: TimeDiff -> RelBody.T (TimeDiff, TimeDiff) Char -> Bool)) : + ("resampleInfinite", + test (resampleInfinite :: TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) Char -> Bool)) : + [] diff --git a/src/Test/Data/EventList/Absolute/TimeEnd.hs b/src/Test/Data/EventList/Absolute/TimeEnd.hs new file mode 100644 --- /dev/null +++ b/src/Test/Data/EventList/Absolute/TimeEnd.hs @@ -0,0 +1,298 @@ +{- | +Copyright : (c) Henning Thielemann 2007 + +Maintainer : haskell@henning-thielemann.de +Stability : stable +Portability : Haskell 98 +-} +module Test.Data.EventList.Absolute.TimeEnd (tests) where + +import Test.Utility +import Test.QuickCheck (test) + +import qualified Data.EventList.Absolute.TimeTime as AbsTime +import qualified Data.EventList.Absolute.TimeTimePrivate as AbsTimePriv +import qualified Data.EventList.Relative.TimeTime as RelTime +import qualified Data.AlternatingList.List.Mixed as Mixed + +-- for testing in GHCi +-- import Data.AlternatingList.List.Disparate (empty) +-- import Data.AlternatingList.List.Uniform ((/.), (./)) +import qualified Data.Char as Char + +import System.Random (Random, randomR, mkStdGen) +import Control.Monad (liftM) + +import qualified Data.EventList.Utility as Utility + +import qualified Numeric.NonNegative.Class as NonNeg +import Data.EventList.Utility (mapFst, mapSnd, mapPair) +import qualified Control.Monad as Monad +import Control.Monad.State (State(State), evalState) + +import Prelude hiding (filter, concat) + + +infixl 5 $~ + +($~) :: Num time => + (AbsTime.T time body -> a) -> (RelTime.T time body -> a) +($~) f = f . RelTime.toAbsoluteEventList 0 + +infixl 4 ==~ + +(==~) :: (Eq body, Num time) => + AbsTime.T time body -> RelTime.T time body -> Bool +(==~) xs ys = + xs == RelTime.toAbsoluteEventList 0 ys + + + +duration :: Num time => RelTime.T time body -> Bool +duration xs = + AbsTime.duration $~ xs == RelTime.duration xs + + +mapBody :: (Eq body1, Num time) => + (body0 -> body1) -> RelTime.T time body0 -> Bool +mapBody f xs = + AbsTime.mapBody f $~ xs ==~ RelTime.mapBody f xs + + + +mapBodyM :: + (Monad m, Eq body1, NonNeg.C time) => + (m (AbsTime.T time body1) -> AbsTime.T time body1) -> + (body0 -> m body1) -> RelTime.T time body0 -> Bool +mapBodyM run f xs = + run (AbsTime.mapBodyM f $~ xs) == + run (liftM (RelTime.toAbsoluteEventList 0) (RelTime.mapBodyM f xs)) + +mapBodyMRandom :: + (NonNeg.C time, Random body, Eq body) => + Int -> RelTime.T time (body, body) -> Bool +mapBodyMRandom seed = + mapBodyM + (flip evalState (mkStdGen seed)) + (State . randomR) + + +filter :: (Eq body, Num time) => + (body -> Bool) -> RelTime.T time body -> Bool +filter p xs = + AbsTime.filter p $~ xs ==~ RelTime.filter p xs + +{- +mapMaybe :: (Num time) => + (body0 -> Maybe body1) -> + RelTime.T time body0 -> RelTime.T time body1 +mapMaybe f = catMaybes . mapBody f +-} + +catMaybes :: (Eq body, Num time) => + RelTime.T time (Maybe body) -> Bool +catMaybes xs = + AbsTime.catMaybes $~ xs ==~ RelTime.catMaybes xs + +{- +Could be implemented more easily in terms of Uniform.partition +-} +partition :: (Eq body, Num time) => + (body -> Bool) -> RelTime.T time body -> Bool +partition p xs = + AbsTime.partition p $~ xs == +-- mapPair (RelTime.toAbsoluteEventList 0, RelTime.toAbsoluteEventList 0) + (uncurry $ \ys zs -> (,) $~ ys $~ zs) + (RelTime.partition p xs) + +{- | +Since we need it later for MIDI generation, +we will also define a slicing into equivalence classes of events. +-} +slice :: (Eq a, Eq body, Num time) => + (body -> a) -> RelTime.T time body -> Bool +slice f xs = + AbsTime.slice f $~ xs == + map (mapSnd (RelTime.toAbsoluteEventList 0)) (RelTime.slice f xs) + + +collectCoincident :: (NonNeg.C time, Eq body) => + RelTime.T time body -> Bool +collectCoincident xs = + AbsTime.collectCoincident $~ xs ==~ + RelTime.collectCoincident xs + +collectCoincidentInfinite :: (NonNeg.C time, Eq body) => + NonEmptyList time body -> Bool +collectCoincidentInfinite = + checkInfinite . + AbsTime.collectCoincident . + makeUncollapsedInfiniteEventList + + +flatten :: (NonNeg.C time, Eq body) => + RelTime.T time [body] -> Bool +flatten xs = + AbsTime.flatten $~ xs ==~ RelTime.flatten xs + + +normalize :: (NonNeg.C time, Ord body) => + RelTime.T time body -> Bool +normalize xs = + AbsTime.normalize $~ xs ==~ RelTime.normalize xs + + +merge :: (NonNeg.C time, Ord body) => + RelTime.T time body -> RelTime.T time body -> Bool +merge xs ys = + AbsTime.merge $~ xs $~ ys ==~ RelTime.merge xs ys + + +insert :: (NonNeg.C time, Ord body) => + time -> body -> RelTime.T time body -> Bool +insert t b xs = + AbsTime.insert t b $~ xs ==~ RelTime.insert t b xs + + + +append :: (NonNeg.C time, Eq body) => + RelTime.T time body -> RelTime.T time body -> Bool +append xs ys = + AbsTime.append $~ xs $~ ys ==~ + RelTime.append xs ys + +concat :: (NonNeg.C time, Eq body) => + [RelTime.T time body] -> Bool +concat xs = + AbsTime.concat (map (RelTime.toAbsoluteEventList 0) xs) ==~ + RelTime.concat xs + + +{- +cycle :: (NonNeg.C time) => + RelTime.T time body -> RelTime.T time body +cycle = concat . List.repeat +-} + + +decreaseStart :: (NonNeg.C time, Eq body) => + time -> time -> RelTime.T time body -> Bool +decreaseStart dif0 dif1 xs0 = + let difA = min dif0 dif1 + difB = max dif0 dif1 + xs = RelTime.delay difB xs0 + in AbsTime.decreaseStart difA $~ xs ==~ + RelTime.decreaseStart difA xs + + +delay :: (NonNeg.C time, Eq body) => + time -> RelTime.T time body -> Bool +delay dif xs = + AbsTime.delay dif $~ xs ==~ + RelTime.delay dif xs + + + +resample :: (Eq body) => + TimeDiff -> RelTime.T (TimeDiff, TimeDiff) body -> Bool +resample rateInt xs0 = + let {- + I add a small amount to the numerator in order + to prevent the case of a fraction like 10.5, + which can be easily rounded to 10 or 11 + depending to previous rounding errors. + -} + xs = RelTime.mapTime ((1e-6 +) . makeFracTime) xs0 + rate = timeToDouble rateInt + 1 + in AbsTime.resample rate $~ xs ==~ + (RelTime.resample rate xs `asTypeOf` + RelTime.pause (undefined::TimeDiff)) + +resampleInfinite :: (Eq body) => + TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) body -> Bool +resampleInfinite rateInt = + let rate = timeToDouble rateInt + 1 + in checkInfinite . + (`asTypeOf` AbsTime.pause (undefined::TimeDiff)) . + AbsTime.resample rate . + makeInfiniteEventList . + mapPair (mapFst makeFracTime, RelTime.mapTime makeFracTime) + + + +type NonEmptyList time body = ((time, body), RelTime.T time body) + +makeUncollapsedInfiniteEventList :: (NonNeg.C time) => + NonEmptyList time body -> AbsTime.T time body +makeUncollapsedInfiniteEventList = + makeInfiniteEventList . + mapFst (mapFst (1+)) + +makeInfiniteEventList :: (NonNeg.C time) => + NonEmptyList time body -> AbsTime.T time body +makeInfiniteEventList = + RelTime.toAbsoluteEventList 0 . RelTime.cycle . makeNonEmptyEventList + +makeNonEmptyEventList :: (NonNeg.C time) => + NonEmptyList time body -> RelTime.T time body +makeNonEmptyEventList (p, evs) = + uncurry RelTime.cons p evs + +{- | +Pick an arbitrary element from an infinite list +and check if it can be evaluated. +-} +checkInfinite :: (Eq time, Eq body) => + AbsTime.T time body -> Bool +checkInfinite xs0 = + let (x,xs) = AbsTime.viewL (AbsTimePriv.lift (Mixed.dropUniform 100) xs0) + y = maybe + (error "checkInfinite: finite list") + fst + xs + in x == x && y == y + + + + +tests :: [(String, IO ())] +tests = + ("duration", + test (duration :: RelTime.T TimeDiff Char -> Bool)) : + ("mapBody", + test (mapBody Char.toUpper :: RelTime.T TimeDiff Char -> Bool)) : + ("mapBodyM", + test (mapBodyMRandom :: Int -> RelTime.T TimeDiff (Char, Char) -> Bool)) : + ("filter", + test (\c -> filter (c<) :: RelTime.T TimeDiff Char -> Bool)) : + ("catMaybes", + test (catMaybes :: RelTime.T TimeDiff (Maybe Char) -> Bool)) : + ("partition", + test (\c -> partition (c<) :: RelTime.T TimeDiff Char -> Bool)) : + ("slice", + test (slice fst :: RelTime.T TimeDiff (Char,Char) -> Bool)) : + ("collectCoincident", + test (collectCoincident :: RelTime.T TimeDiff Char -> Bool)) : + ("collectCoincidentInfinite", + test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) : + ("flatten", + test (flatten :: RelTime.T TimeDiff [Char] -> Bool)) : + ("normalize", + test (normalize :: RelTime.T TimeDiff Char -> Bool)) : + ("merge", + test (merge :: RelTime.T TimeDiff Char -> RelTime.T TimeDiff Char -> Bool)) : + ("insert", + test (insert :: TimeDiff -> Char -> RelTime.T TimeDiff Char -> Bool)) : + ("append", + test (append :: RelTime.T TimeDiff Char -> RelTime.T TimeDiff Char -> Bool)) : + ("concat", + test (concat :: [RelTime.T TimeDiff Char] -> Bool)) : + ("decreaseStart", + test (decreaseStart :: TimeDiff -> TimeDiff -> RelTime.T TimeDiff Char -> Bool)) : + ("delay", + test (delay :: TimeDiff -> RelTime.T TimeDiff Char -> Bool)) : + ("resample", + test (resample :: TimeDiff -> RelTime.T (TimeDiff, TimeDiff) Char -> Bool)) : + ("resampleInfinite", + test (resampleInfinite :: TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) Char -> Bool)) : + [] diff --git a/src/Test/Data/EventList/Relative/BodyEnd.hs b/src/Test/Data/EventList/Relative/BodyEnd.hs new file mode 100644 --- /dev/null +++ b/src/Test/Data/EventList/Relative/BodyEnd.hs @@ -0,0 +1,914 @@ +{- | +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) +import System.Random (Random, randomR, mkStdGen) +import Control.Monad.State (State(State), evalState) +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 + + + +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)) : + + ("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)) : + + [] diff --git a/src/Test/Data/EventList/Relative/TimeEnd.hs b/src/Test/Data/EventList/Relative/TimeEnd.hs new file mode 100644 --- /dev/null +++ b/src/Test/Data/EventList/Relative/TimeEnd.hs @@ -0,0 +1,993 @@ +{- | +Copyright : (c) Henning Thielemann 2008 + +Maintainer : haskell@henning-thielemann.de +Stability : stable +Portability : Haskell 98 +-} +module Test.Data.EventList.Relative.TimeEnd (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.MixedTime as MixedTimeList +import qualified Data.EventList.Relative.BodyTime as BodyTimeList +import qualified Data.AlternatingList.List.Mixed as Mixed + +import Data.EventList.Relative.MixedTime ((/.), (./), empty) + +import Data.EventList.Relative.TimeTimePrivate (($~~), lift) + +import qualified Numeric.NonNegative.Class as NonNeg +import Numeric.NonNegative.Class ((-|)) +import Data.EventList.Relative.TimeTime (isNormalized) + +import System.Random (Random, randomR, mkStdGen) +import Control.Monad.State (State(State), evalState) +import Control.Monad (liftM2) +import qualified Data.List as List +import qualified Data.Char as Char + + + +viewLConsTime :: (Eq body, Eq time) => + TimeTimeList.T time body -> Bool +viewLConsTime xs = + xs == uncurry MixedTimeList.consTime (MixedTimeList.viewTimeL xs) + +viewLConsBody :: (Eq body, Eq time) => + BodyTimeList.T time body -> Bool +viewLConsBody xs = + xs == maybe BodyTimeList.empty (uncurry MixedTimeList.consBody) (MixedTimeList.viewBodyL xs) + +viewRSnocTime :: (Eq body, Eq time) => + TimeTimeList.T time body -> Bool +viewRSnocTime xs = + xs == uncurry TimeMixedList.snocTime (TimeMixedList.viewTimeR xs) + +viewRSnocBody :: (Eq body, Eq time) => + TimeBodyList.T time body -> Bool +viewRSnocBody xs = + xs == maybe TimeBodyList.empty (uncurry TimeMixedList.snocBody) (TimeMixedList.viewBodyR xs) + + + + +viewLInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool +viewLInfinite = + checkInfinite . + maybe (error "viewBodyL: empty list") snd . MixedTimeList.viewBodyL . + snd . MixedTimeList.viewTimeL . + makeInfiniteEventList + +viewRInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool +viewRInfinite = + checkInfinite . + maybe (error "viewBodyR: empty list") fst . TimeMixedList.viewBodyR . + fst . TimeMixedList.viewTimeR . + makeInfiniteEventList + + +consInfinite :: (NonNeg.C time, Eq body) => + time -> body -> NonEmptyList time body -> Bool +consInfinite time body = + checkInfinite . + TimeTimeList.cons time body . + makeInfiniteEventList + +consTimeBodyInfinite :: (NonNeg.C time, Eq body) => + time -> body -> NonEmptyList time body -> Bool +consTimeBodyInfinite time body = + checkInfinite . + MixedTimeList.consTime time . + MixedTimeList.consBody body . + makeInfiniteEventList + + +snocInfinite :: (NonNeg.C time, Eq body) => + time -> body -> NonEmptyList time body -> Bool +snocInfinite time body = + checkInfinite . + flip (flip TimeTimeList.snoc body) time . + makeInfiniteEventList + +snocTimeBodyInfinite :: (NonNeg.C time, Eq body) => + time -> body -> NonEmptyList time body -> Bool +snocTimeBodyInfinite time body = + checkInfinite . + flip TimeMixedList.snocTime time . + flip TimeMixedList.snocBody body . + makeInfiniteEventList + + +consInfix :: (NonNeg.C time, Eq body) => + time -> body -> time -> time -> body -> time -> Bool +consInfix t0a b0 t0b t1a b1 t1b = + TimeTimeList.append (t0a /. b0 ./ t0b /. empty) (t1a /. b1 ./ t1b /. empty) + == (t0a /. b0 ./ (t0b+t1a) /. b1 ./ t1b /. empty) + + + + +mapBodyComposition :: (Eq body2, Eq time) => + (body0 -> body1) -> (body1 -> body2) -> TimeTimeList.T time body0 -> Bool +mapBodyComposition f g evs = + TimeTimeList.mapBody (g . f) evs == + TimeTimeList.mapBody g (TimeTimeList.mapBody f evs) + +mapTimeComposition :: (Eq body, Eq time2) => + (time0 -> time1) -> (time1 -> time2) -> TimeTimeList.T time0 body -> Bool +mapTimeComposition f g evs = + TimeTimeList.mapTime (g . f) evs == + TimeTimeList.mapTime g (TimeTimeList.mapTime f evs) + + +mapTimeBodyCommutative :: (Eq body1, Eq time1) => + (time0 -> time1) -> (body0 -> body1) -> TimeTimeList.T time0 body0 -> Bool +mapTimeBodyCommutative f g evs = + TimeTimeList.mapBody g (TimeTimeList.mapTime f evs) == + TimeTimeList.mapTime f (TimeTimeList.mapBody g evs) + + + +mapBodyInfinite :: (NonNeg.C time, Eq body1) => + (body0 -> body1) -> NonEmptyList time body0 -> Bool +mapBodyInfinite f = + checkInfinite . TimeTimeList.mapBody f . makeInfiniteEventList + +mapTimeInfinite :: (NonNeg.C time0, Eq time1, Eq body) => + (time0 -> time1) -> NonEmptyList time0 body -> Bool +mapTimeInfinite f = + checkInfinite . TimeTimeList.mapTime f . makeInfiniteEventList + + + +{- | +Does only hold for monotonic functions. +-} +mapNormalize :: (NonNeg.C time, Ord body0, Ord body1) => + (body0 -> body1) -> TimeTimeList.T time body0 -> Bool +mapNormalize f = + isNormalized . TimeTimeList.mapBody f . TimeTimeList.normalize + + + +appendLeftIdentity :: (NonNeg.C time, Eq body) => + TimeTimeList.T time body -> Bool +appendLeftIdentity xs = + TimeTimeList.append (TimeTimeList.pause 0) xs == xs + +appendRightIdentity :: (NonNeg.C time, Eq body) => + TimeTimeList.T time body -> Bool +appendRightIdentity xs = + TimeTimeList.append xs (TimeTimeList.pause 0) == xs + +appendAssociative :: (NonNeg.C time, Eq body) => + TimeTimeList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +appendAssociative xs ys zs = + TimeTimeList.append xs (TimeTimeList.append ys zs) == + TimeTimeList.append (TimeTimeList.append xs ys) zs + +appendCons :: (NonNeg.C time, Eq body) => + time -> body -> TimeTimeList.T time body -> Bool +appendCons time body xs = + TimeTimeList.cons time body xs == + TimeTimeList.append (TimeTimeList.cons time body (TimeTimeList.pause 0)) xs + +appendSplitAtTime :: (NonNeg.C time, Eq body) => + time -> TimeTimeList.T time body -> Bool +appendSplitAtTime t xs = + xs == uncurry TimeTimeList.append (TimeTimeList.splitAtTime t xs) + +mapBodyAppend :: (Eq body1, NonNeg.C time) => + (body0 -> body1) -> TimeTimeList.T time body0 -> TimeTimeList.T time body0 -> Bool +mapBodyAppend f xs ys = + TimeTimeList.mapBody f (TimeTimeList.append xs ys) == + TimeTimeList.append (TimeTimeList.mapBody f xs) (TimeTimeList.mapBody f ys) + + +appendFirstInfinite :: (NonNeg.C time, Eq body) => + NonEmptyList time body -> TimeTimeList.T time body -> Bool +appendFirstInfinite xs = + checkInfinite . TimeTimeList.append (makeInfiniteEventList xs) + +appendSecondInfinite :: (NonNeg.C time, Eq body) => + TimeTimeList.T time body -> NonEmptyList time body -> Bool +appendSecondInfinite xs = + checkInfinite . TimeTimeList.append xs . makeInfiniteEventList + + +decreaseStartDelay :: (NonNeg.C time, Eq body) => + time -> TimeTimeList.T time body -> Bool +decreaseStartDelay dif xs = + xs == TimeTimeList.decreaseStart dif (TimeTimeList.delay dif xs) + +decreaseStartInfinite :: (NonNeg.C time, Eq body) => + time -> NonEmptyList time body -> Bool +decreaseStartInfinite dif = + checkInfinite . + TimeTimeList.decreaseStart dif . + TimeTimeList.delay dif . + makeInfiniteEventList + +delayAdditive :: (NonNeg.C time, Eq body) => + time -> time -> TimeTimeList.T time body -> Bool +delayAdditive dif0 dif1 xs = + TimeTimeList.delay (dif0+dif1) xs == + TimeTimeList.delay dif0 (TimeTimeList.delay dif1 xs) + +delayPause :: (NonNeg.C time) => + time -> time -> Bool +delayPause dif0 dif1 = + let pause = TimeTimeList.pause (dif0+dif1) + in TimeTimeList.delay dif0 (TimeTimeList.pause dif1) == + (asTypeOf pause (TimeTimeList.cons dif0 () pause)) + +delayAppendPause :: (NonNeg.C time, Eq body) => + time -> TimeTimeList.T time body -> Bool +delayAppendPause dif xs = + TimeTimeList.delay dif xs == TimeTimeList.append (TimeTimeList.pause dif) xs + +delayInfinite :: (NonNeg.C time, Eq body) => + time -> NonEmptyList time body -> Bool +delayInfinite dif = + checkInfinite . + TimeTimeList.delay dif . + makeInfiniteEventList + + + +splitAtTakeDropTime :: (NonNeg.C time, Eq body) => + time -> TimeTimeList.T time body -> Bool +splitAtTakeDropTime t xs = + (TimeTimeList.takeTime t xs, TimeTimeList.dropTime t xs) == + TimeTimeList.splitAtTime t xs + +takeTimeEndPause :: (NonNeg.C time, Ord body) => + time -> TimeTimeList.T time body -> Bool +takeTimeEndPause t xs = + t == 0 || + t >= TimeTimeList.duration xs || + 0 < snd (TimeMixedList.viewTimeR (TimeTimeList.takeTime t xs)) + +takeTimeAppendFirst :: (NonNeg.C time, Eq body) => + time -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +takeTimeAppendFirst t xs ys = + TimeTimeList.takeTime t (TimeTimeList.append xs ys) == + TimeTimeList.append + (TimeTimeList.takeTime t xs) + (TimeTimeList.takeTime (t -| TimeTimeList.duration xs) ys) + +takeTimeAppendSecond :: (NonNeg.C time, Eq body) => + time -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +takeTimeAppendSecond t xs0 ys = + -- the first list must not end with a zero pause + let xs = TimeTimeList.append xs0 (TimeTimeList.pause 1) + in TimeTimeList.takeTime (TimeTimeList.duration xs + t) (TimeTimeList.append xs ys) == + TimeTimeList.append xs (TimeTimeList.takeTime t ys) + +takeTimeNormalize :: (NonNeg.C time, Ord body) => + time -> TimeTimeList.T time body -> Bool +takeTimeNormalize t = + isNormalized . TimeTimeList.takeTime t . TimeTimeList.normalize + +dropTimeNormalize :: (NonNeg.C time, Ord body) => + time -> TimeTimeList.T time body -> Bool +dropTimeNormalize t = + isNormalized . TimeTimeList.dropTime t . TimeTimeList.normalize + +takeTimeInfinite :: (NonNeg.C time, Ord body) => + time -> NonEmptyList time body -> Bool +takeTimeInfinite t = + (t == ) . TimeTimeList.duration . + TimeTimeList.takeTime t . makeUncollapsedInfiniteEventList + +dropTimeInfinite :: (NonNeg.C time, Ord body) => + time -> NonEmptyList time body -> Bool +dropTimeInfinite t = + checkInfinite . TimeTimeList.dropTime t . makeUncollapsedInfiniteEventList + + + + +durationPause :: (NonNeg.C time) => + time -> Bool +durationPause t = + t == TimeTimeList.duration (TimeTimeList.pause t) + +durationAppend :: (NonNeg.C time) => + TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +durationAppend xs ys = + TimeTimeList.duration (TimeTimeList.append xs ys) == + TimeTimeList.duration xs + TimeTimeList.duration ys + +durationMerge :: (NonNeg.C time, Ord body) => + TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +durationMerge xs ys = + TimeTimeList.duration (TimeTimeList.merge xs ys) == + max (TimeTimeList.duration xs) (TimeTimeList.duration ys) + +durationTakeTime :: (NonNeg.C time, Eq body) => + time -> TimeTimeList.T time body -> Bool +durationTakeTime t xs = + min (TimeTimeList.duration xs) t == + TimeTimeList.duration (TimeTimeList.takeTime t xs) + +durationDropTime :: (NonNeg.C time, Eq body) => + time -> TimeTimeList.T time body -> Bool +durationDropTime t xs = + TimeTimeList.duration xs -| t == + TimeTimeList.duration (TimeTimeList.dropTime t xs) + + + +concatNaive :: (NonNeg.C time, Eq body) => + [TimeTimeList.T time body] -> Bool +concatNaive xs = + TimeTimeList.concat xs == TimeTimeList.concatNaive xs + + +equalPrefix :: (Eq time, Eq body) => + Int -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +equalPrefix n xs ys = + Mixed.takeDisparate n $~~ xs == + Mixed.takeDisparate n $~~ ys + +cycleNaive :: (NonNeg.C time, Eq body) => + NonEmptyList time body -> Bool +cycleNaive xs0 = + let xs = makeNonEmptyEventList xs0 + in equalPrefix 100 (TimeTimeList.cycle xs) (TimeTimeList.cycleNaive xs) + +cycleInfinite :: (NonNeg.C time, Eq body) => + NonEmptyList time body -> Bool +cycleInfinite xs0 = + let xs = makeInfiniteEventList xs0 + in equalPrefix 100 xs (TimeTimeList.cycle xs) + + +filterSatisfy :: (Num time) => + (body -> Bool) -> + TimeTimeList.T time body -> Bool +filterSatisfy p = + all p . TimeTimeList.getBodies . TimeTimeList.filter p + +filterProjection :: (Num time, Eq body) => + (body -> Bool) -> + TimeTimeList.T time body -> Bool +filterProjection p xs = + TimeTimeList.filter p xs == + TimeTimeList.filter p (TimeTimeList.filter p xs) + +filterCommutative :: (Num time, Eq body) => + (body -> Bool) -> + (body -> Bool) -> + TimeTimeList.T time body -> Bool +filterCommutative p q xs = + TimeTimeList.filter p (TimeTimeList.filter q xs) == + TimeTimeList.filter q (TimeTimeList.filter p xs) + +filterComposition :: (Num time, Eq body) => + (body -> Bool) -> + (body -> Bool) -> + TimeTimeList.T time body -> Bool +filterComposition p q xs = + TimeTimeList.filter p (TimeTimeList.filter q xs) == + TimeTimeList.filter (\b -> p b && q b) xs + +filterNormalize :: (NonNeg.C time, Ord body) => + (body -> Bool) -> + TimeTimeList.T time body -> Bool +filterNormalize p = + isNormalized . TimeTimeList.filter p . TimeTimeList.normalize + +filterAppend :: (NonNeg.C time, Eq body) => + (body -> Bool) -> + TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +filterAppend p xs ys = + TimeTimeList.filter p (TimeTimeList.append xs ys) == + TimeTimeList.append (TimeTimeList.filter p xs) (TimeTimeList.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) -> TimeTimeList.T time body -> Bool +filterPartition p xs = + (TimeTimeList.filter p xs, TimeTimeList.filter (not . p) xs) == + TimeTimeList.partition p xs + + +filterInfinite :: (NonNeg.C time, Eq body) => + (body -> Bool) -> NonEmptyList time body -> Bool +filterInfinite p xs = + null (TimeTimeList.getBodies (TimeTimeList.filter p (makeNonEmptyEventList xs))) + || + (checkInfinite . + TimeTimeList.filter p . + makeInfiniteEventList) xs + +catMaybesAppend :: (NonNeg.C time, Eq body) => + TimeTimeList.T time (Maybe body) -> TimeTimeList.T time (Maybe body) -> Bool +catMaybesAppend xs ys = + TimeTimeList.catMaybes (TimeTimeList.append xs ys) == + TimeTimeList.append (TimeTimeList.catMaybes xs) (TimeTimeList.catMaybes ys) + + +{- | +'TimeTimeList.merge' preserves normalization of its operands. +-} +mergeNormalize :: (NonNeg.C time, Ord body) => + TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +mergeNormalize xs0 ys0 = + let xs = TimeTimeList.normalize xs0 + ys = TimeTimeList.normalize ys0 + in isNormalized $ TimeTimeList.merge xs ys + +mergeLeftIdentity :: (NonNeg.C time, Ord body) => + TimeTimeList.T time body -> Bool +mergeLeftIdentity xs = + TimeTimeList.merge (TimeTimeList.pause 0) xs == xs + +mergeRightIdentity :: (NonNeg.C time, Ord body) => + TimeTimeList.T time body -> Bool +mergeRightIdentity xs = + TimeTimeList.merge xs (TimeTimeList.pause 0) == xs + +mergeCommutative :: (NonNeg.C time, Ord body) => + TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +mergeCommutative xs0 ys0 = + let xs = TimeTimeList.normalize xs0 + ys = TimeTimeList.normalize ys0 + in TimeTimeList.merge xs ys == TimeTimeList.merge ys xs +{- +merge commutative: Falsifiable, after 8 tests: +3 ./ '!' /. 0 ./ ' ' /. 1 ./ ' ' /. 2 ./ empty +3 ./ '!' /. 3 ./ '!' /. 1 ./ empty +-} + +mergeAssociative :: (NonNeg.C time, Ord body) => + TimeTimeList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +mergeAssociative xs0 ys0 zs0 = + let xs = TimeTimeList.normalize xs0 + ys = TimeTimeList.normalize ys0 + zs = TimeTimeList.normalize zs0 + in TimeTimeList.merge xs (TimeTimeList.merge ys zs) == + TimeTimeList.merge (TimeTimeList.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. + +Without posterior normalization you get + +merge append: Falsifiable, after 30 tests: +1 ./ 'a' /. 0 ./ empty +1 ./ ' ' /. 1 ./ empty +0 ./ ' ' /. 1 ./ empty + +-} +mergeAppend :: (NonNeg.C time, Ord body) => + TimeTimeList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +mergeAppend xs ys zs = + TimeTimeList.normalize (TimeTimeList.append xs (TimeTimeList.merge ys zs)) == + TimeTimeList.normalize + (TimeTimeList.merge (TimeTimeList.append xs ys) + (TimeTimeList.delay (TimeTimeList.duration xs) zs)) + +appendByMerge :: (NonNeg.C time, Ord body) => + TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +appendByMerge xs ys = + TimeTimeList.normalize (TimeTimeList.append xs ys) == + TimeTimeList.normalize (TimeTimeList.merge xs + (TimeTimeList.delay (TimeTimeList.duration xs) ys)) + +{- +Normalization is important, otherwise the following counter-examples exist: + +merge associative: Falsifiable, after 99 tests: +0 ./ '\DEL' /. 2 ./ '\DEL' /. 2 ./ empty +0 ./ '\DEL' /. 2 ./ '\DEL' /. 0 ./ '~' /. 3 ./ empty +2 ./ ' ' /. 2 ./ '\DEL' /. 3 ./ empty + +merge associative: Falsifiable, after 99 tests: +6 ./ '~' /. 2 ./ '%' /. 1 ./ '#' /. 3 ./ '$' /. 2 ./ empty +6 ./ '~' /. 0 ./ '"' /. 2 ./ '{' /. 0 ./ '"' /. 6 ./ empty +0 ./ '{' /. 5 ./ '$' /. 3 ./ empty + +merge associative: Falsifiable, after 41 tests: +2 ./ '~' /. 0 ./ empty +2 ./ '~' /. 0 ./ '$' /. 3 ./ empty +1 ./ '#' /. 4 ./ '"' /. 4 ./ empty +-} + +-- does only hold for monotonic functions +-- toUpper and toLower are not monotonic +mergeMap :: (NonNeg.C time, Ord body0 ,Ord body1) => + (body0 -> body1) -> TimeTimeList.T time body0 -> TimeTimeList.T time body0 -> Bool +mergeMap f xs0 ys0 = + let xs = TimeTimeList.normalize xs0 + ys = TimeTimeList.normalize ys0 + in TimeTimeList.mapBody f (TimeTimeList.merge xs ys) == + TimeTimeList.merge (TimeTimeList.mapBody f xs) (TimeTimeList.mapBody f ys) + +mergeFilter :: (NonNeg.C time, Ord body) => + (body -> Bool) -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +mergeFilter p xs0 ys0 = + let xs = TimeTimeList.normalize xs0 + ys = TimeTimeList.normalize ys0 + in TimeTimeList.filter p (TimeTimeList.merge xs ys) == + TimeTimeList.merge (TimeTimeList.filter p xs) (TimeTimeList.filter p ys) + +mergePartition :: (NonNeg.C time, Ord body) => + (body -> Bool) -> TimeTimeList.T time body -> Bool +mergePartition p xs0 = + let xs = TimeTimeList.normalize xs0 + in xs == uncurry TimeTimeList.merge (TimeTimeList.partition p xs) + +mergeEitherMapMaybe :: (NonNeg.C time, Ord body) => + TimeTimeList.T time body -> TimeTimeList.T time body -> Bool +mergeEitherMapMaybe xs0 ys0 = + let xs = TimeTimeList.normalize xs0 + ys = TimeTimeList.normalize ys0 + zs = TimeTimeList.merge + (TimeTimeList.mapBody Left xs) + (TimeTimeList.mapBody Right ys) + dur = TimeTimeList.duration zs + longXs = TimeTimeList.merge (TimeTimeList.pause dur) xs + longYs = TimeTimeList.merge (TimeTimeList.pause dur) ys + in longXs == TimeTimeList.mapMaybe (either Just (const Nothing)) zs + && + longYs == TimeTimeList.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 (TimeTimeList.merge xs ys) + + + +insertCommutative :: (NonNeg.C time, Ord body) => + (time, body) -> (time, body) -> TimeTimeList.T time body -> Bool +insertCommutative (time0, body0) (time1, body1) evs = + TimeTimeList.insert time0 body0 (TimeTimeList.insert time1 body1 evs) == + TimeTimeList.insert time1 body1 (TimeTimeList.insert time0 body0 evs) + +{- +Normalization is important, otherwise we have the counterexample: +Relative.TimeEnd.insertMerge: Falsifiable, after 6 tests: +2 +'~' +0 /. '"' ./ 2 /. '~' ./ 0 /. '#' ./ 1 /. empty +-} +insertMerge :: (NonNeg.C time, Ord body) => + time -> body -> TimeTimeList.T time body -> Bool +insertMerge time body evs0 = + let evs = TimeTimeList.normalize evs0 + in TimeTimeList.insert time body evs == + TimeTimeList.merge (TimeTimeList.cons time body $ TimeTimeList.pause 0) evs + +insertNormalize :: (NonNeg.C time, Ord body) => + time -> body -> TimeTimeList.T time body -> Bool +insertNormalize time body = + isNormalized . TimeTimeList.insert time body . TimeTimeList.normalize + +insertSplitAtTime :: (NonNeg.C time, Ord body) => + time -> body -> TimeTimeList.T time body -> Bool +insertSplitAtTime time body evs = + TimeTimeList.insert + (min time (TimeTimeList.duration evs)) body + (TimeTimeList.normalize evs) + == + let (prefix,suffix) = TimeTimeList.splitAtTime time evs + in TimeTimeList.normalize + (TimeTimeList.append prefix (TimeTimeList.cons 0 body suffix)) + -- append prefix (MixedTimeList.consBody body suffix) + +insertInfinite :: (NonNeg.C time, Ord body) => + time -> body -> NonEmptyList time body -> Bool +insertInfinite time body = + checkInfinite . TimeTimeList.insert time body . makeInfiniteEventList + + + + +coincidentFlatten :: (NonNeg.C time, Eq body) => + TimeTimeList.T time body -> Bool +coincidentFlatten xs = + xs == TimeTimeList.flatten (TimeTimeList.collectCoincident xs) + +collectCoincidentGaps :: (NonNeg.C time, Eq body) => + TimeTimeList.T time body -> Bool +collectCoincidentGaps xs = + let times = tail (TimeTimeList.getTimes (TimeTimeList.collectCoincident xs)) + in null times || all (0<) (init times) + +collectCoincidentNonEmpty :: (NonNeg.C time, Eq body) => + TimeTimeList.T time body -> Bool +collectCoincidentNonEmpty = + all (not . null) . TimeTimeList.getBodies . TimeTimeList.collectCoincident + +collectCoincidentInfinite :: (NonNeg.C time, Eq body) => + NonEmptyList time body -> Bool +collectCoincidentInfinite = + checkInfinite . + TimeTimeList.collectCoincident . + makeUncollapsedInfiniteEventList + + +mapCoincidentMap :: (NonNeg.C time, Eq body1) => + (body0 -> body1) -> TimeTimeList.T time body0 -> Bool +mapCoincidentMap f xs = + TimeTimeList.mapBody f xs == + TimeTimeList.mapCoincident (map f) xs + +mapCoincidentComposition :: (NonNeg.C time, Eq body2) => + ([body0] -> [body1]) -> ([body1] -> [body2]) -> TimeTimeList.T time body0 -> Bool +mapCoincidentComposition f g xs = + TimeTimeList.mapCoincident (g . f) xs == + (TimeTimeList.mapCoincident g . TimeTimeList.mapCoincident f) xs + +mapCoincidentReverse :: (NonNeg.C time, Eq body) => + TimeTimeList.T time body -> Bool +mapCoincidentReverse xs = + xs == TimeTimeList.mapCoincident reverse (TimeTimeList.mapCoincident reverse xs) + + + +mapBodyMAppend :: + (Monad m, Eq body1, NonNeg.C time) => + (m (TimeTimeList.T time body1) -> TimeTimeList.T time body1) -> + (body0 -> m body1) -> TimeTimeList.T time body0 -> TimeTimeList.T time body0 -> Bool +mapBodyMAppend run f xs ys = + run (TimeTimeList.mapM return f (TimeTimeList.append xs ys)) == + run (liftM2 TimeTimeList.append (TimeTimeList.mapM return f xs) (TimeTimeList.mapM return f ys)) + +mapBodyMAppendRandom :: + (Random body, NonNeg.C time, Eq body) => + Int -> TimeTimeList.T time (body,body) -> TimeTimeList.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) . + TimeTimeList.mapM return (State . randomR) . + makeInfiniteEventList + + +{- + +mapM :: Monad m => + (time0 -> m time1) -> (body0 -> m body1) -> + TimeTimeList.T time0 body0 -> m (TimeTimeList.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 :: TimeTimeList.T time body -> [body] +getBodies = Uniform.getFirsts + +getTimes :: TimeTimeList.T time body -> [time] +getTimes = Uniform.getSeconds + + +empty :: Immediate time body +empty = Disp.empty + + +cons :: time -> body -> TimeTimeList.T time body -> TimeTimeList.T time body +cons = Uniform.cons + + +snoc :: TimeTimeList.T time body -> body -> time -> TimeTimeList.T time body +snoc = Uniform.snoc + + +{- +propInsertPadded :: Event time body -> TimeTimeList.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 -> TimeTimeList.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 -> TimeTimeList.T time body +fromEventList t = + EventList.foldr consTime consBody (pause t) + +toEventList :: TimeTimeList.T time body -> EventList.T time body +toEventList xs = + zipWith EventList.Event (getTimes xs) (getBodies xs) + +{- | + +-} + + +discretize :: (RealFrac time, Integral i) => + TimeTimeList.T time body -> TimeTimeList.T i body +discretize es = + evalState (Uniform.mapSecondM roundDiff es) 0 + +resample :: (RealFrac time, Integral i) => + time -> TimeTimeList.T time body -> TimeTimeList.T i body +resample rate es = + discretize (mapTime (rate*) es) + + +toAbsoluteEventList :: (Num time) => + time -> TimeTimeList.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, TimeTimeList.T time body) + +makeUncollapsedInfiniteEventList :: (NonNeg.C time) => + NonEmptyList time body -> TimeTimeList.T time body +makeUncollapsedInfiniteEventList = + makeInfiniteEventList . + (\(time,body,xs) -> (time+1,body,xs)) + +makeInfiniteEventList :: (NonNeg.C time) => + NonEmptyList time body -> TimeTimeList.T time body +makeInfiniteEventList = + TimeTimeList.cycle . makeNonEmptyEventList + +makeNonEmptyEventList :: (NonNeg.C time) => + NonEmptyList time body -> TimeTimeList.T time body +makeNonEmptyEventList (t, b, evs) = + TimeTimeList.cons t b evs + +{- | +Pick an arbitrary element from an infinite list +and check if it can be evaluated. +-} +checkInfinite :: (Eq time, Eq body) => + TimeTimeList.T time body -> Bool +checkInfinite xs0 = + let (x,xs) = MixedTimeList.viewTimeL (lift (Mixed.dropUniform 100) xs0) + y = maybe + (error "checkInfinite: finite list") + fst + (MixedTimeList.viewBodyL xs) + in x == x && y == y + + + +tests :: [(String, IO ())] +tests = + ("viewTimeL consTime", + test (viewLConsTime :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("viewBodyL consBody", + test (viewLConsBody :: BodyTimeList.T TimeDiff Char -> Bool)) : + ("viewTimeR snocTime", + test (viewRSnocTime :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("viewBodyR snocBody", + test (viewRSnocBody :: TimeBodyList.T TimeDiff Char -> Bool)) : + + ("viewLInfinite", + test (viewLInfinite :: NonEmptyList TimeDiff Char -> Bool)) : + ("viewRInfinite", + test (viewRInfinite :: 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)) : + ("snocTimeBodyInfinite", + test (snocTimeBodyInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) : + ("consInfix", + test (consInfix :: TimeDiff -> Char -> TimeDiff -> TimeDiff -> Char -> TimeDiff -> Bool)) : + + + ("map body composition", + test (mapBodyComposition Char.toUpper Char.toLower + :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("map time composition", + test ((\dt0 dt1 -> mapTimeComposition (dt0+) (dt1+)) + :: TimeDiff -> TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("map time body commutative", + test ((\dt -> mapTimeBodyCommutative (dt+) Char.toUpper) + :: TimeDiff -> TimeTimeList.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 + :: TimeTimeList.T TimeDiff Char -> Bool)) : + + ("append left identity", + test (appendLeftIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("append right identity", + test (appendRightIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("append associative", + test (appendAssociative + :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> + TimeTimeList.T TimeDiff Char -> Bool)) : + + ("appendCons", + test (appendCons :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("mapBodyAppend", + test (mapBodyAppend Char.toUpper + :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("appendSplitAtTime", + test (appendSplitAtTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("appendFirstInfinite", + test (appendFirstInfinite :: NonEmptyList TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("appendSecondInfinite", + test (appendSecondInfinite :: TimeTimeList.T TimeDiff Char -> NonEmptyList TimeDiff Char -> Bool)) : + ("concatNaive", + test (concatNaive :: [TimeTimeList.T TimeDiff Char] -> Bool)) : + ("cycleNaive", + test (cycleNaive :: NonEmptyList TimeDiff Char -> Bool)) : + ("cycleInfinite", + test (cycleInfinite :: NonEmptyList TimeDiff Char -> Bool)) : + + ("decreaseStart delay", + test (decreaseStartDelay :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("decreaseStartInfinite", + test (decreaseStartInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) : + + ("delay additive", + test (delayAdditive :: TimeDiff -> TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("delay pause", + test (delayPause :: TimeDiff -> TimeDiff -> Bool)) : + ("delay append pause", + test (delayAppendPause :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("delayInfinite", + test (delayInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) : + + ("splitAtTakeDropTime", + test (splitAtTakeDropTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("takeTimeEndPause", + test (takeTimeEndPause :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("takeTimeAppendFirst", + test (takeTimeAppendFirst :: TimeDiff -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("takeTimeAppendSecond", + test (takeTimeAppendSecond :: TimeDiff -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("takeTimeNormalize", + test (takeTimeNormalize :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("dropTimeNormalize", + test (dropTimeNormalize :: TimeDiff -> TimeTimeList.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 :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("duration merge", + test (durationMerge :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("durationTakeTime", + test (durationTakeTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("durationDropTime", + test (durationDropTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) : + + ("filterSatisfy", + test (\c -> filterSatisfy (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("filterProjection", + test (\c -> filterProjection (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("filterCommutative", + test (\c0 c1 -> filterCommutative (c0<) (c1>) :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("filterComposition", + test (\c0 c1 -> filterComposition (c0<) (c1>) :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("filterNormalize", + test (\c -> filterNormalize (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("filterAppend", + test (\c -> filterAppend (c<) :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("filterDuration", + test (\c -> filterDuration (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("filterPartition", + test (\c -> filterPartition (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("filterInfinite", + test (\c -> filterInfinite (c<) :: NonEmptyList TimeDiff Char -> Bool)) : + ("catMaybesAppend", + test (catMaybesAppend :: TimeTimeList.T TimeDiff (Maybe Char) -> TimeTimeList.T TimeDiff (Maybe Char) -> Bool)) : + + ("mergeNormalize", + test (mergeNormalize :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("merge left identity", + test (mergeLeftIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("merge right identity", + test (mergeRightIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("merge commutative", + test (mergeCommutative :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("merge associative", + test (mergeAssociative :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("merge append", + test (mergeAppend :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("appendByMerge", + test (appendByMerge :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("mergeMap", + test (mergeMap succ :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("mergeFilter", + test (\c -> mergeFilter (c>) + :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("mergePartition", + test (\c -> mergePartition (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("mergeEitherMapMaybe", + test (mergeEitherMapMaybe + :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("mergeInfinite", + test (mergeInfinite + :: NonEmptyList TimeDiff Char -> NonEmptyList TimeDiff Char -> Bool)) : + + ("insertCommutative", + test (insertCommutative :: (TimeDiff, Char) -> (TimeDiff, Char) -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("insertMerge", + test (insertMerge :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("insertNormalize", + test (insertNormalize :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("insertSplitAtTime", + test (insertSplitAtTime :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) : + ("insertInfinite", + test (insertInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) : + + ("coincidentFlatten", + test (coincidentFlatten :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("collectCoincidentGaps", + test (collectCoincidentGaps :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("collectCoincidentNonEmpty", + test (collectCoincidentNonEmpty :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("collectCoincidentInfinite", + test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) : + + ("mapCoincidentMap", + test (mapCoincidentMap Char.toUpper :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("mapCoincidentComposition", + test (mapCoincidentComposition reverse reverse :: TimeTimeList.T TimeDiff Char -> Bool)) : + ("mapCoincidentReverse", + test (mapCoincidentReverse :: TimeTimeList.T TimeDiff Char -> Bool)) : + + ("mapBodyMAppendRandom", + test (mapBodyMAppendRandom :: Int -> TimeTimeList.T TimeDiff (Char,Char) -> TimeTimeList.T TimeDiff (Char,Char) -> Bool)) : + ("mapBodyMInfinite", + test (mapBodyMInfinite :: Int -> NonEmptyList TimeDiff (Char,Char) -> Bool)) : + + [] diff --git a/src/Test/Main.hs b/src/Test/Main.hs new file mode 100644 --- /dev/null +++ b/src/Test/Main.hs @@ -0,0 +1,20 @@ +module Main where + +import qualified Test.Data.EventList.Absolute.BodyEnd as AbsBodyEnd +import qualified Test.Data.EventList.Absolute.TimeEnd as AbsTimeEnd +import qualified Test.Data.EventList.Relative.BodyEnd as RelBodyEnd +import qualified Test.Data.EventList.Relative.TimeEnd as RelTimeEnd + +prefix :: String -> [(String, IO ())] -> [(String, IO ())] +prefix msg = + map (\(str,test) -> (msg ++ "." ++ str, test)) + +main :: IO () +main = + mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $ + concat $ + prefix "Absolute.BodyEnd" AbsBodyEnd.tests : + prefix "Absolute.TimeEnd" AbsTimeEnd.tests : + prefix "Relative.BodyEnd" RelBodyEnd.tests : + prefix "Relative.TimeEnd" RelTimeEnd.tests : + [] diff --git a/src/Test/Utility.hs b/src/Test/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Test/Utility.hs @@ -0,0 +1,15 @@ +module Test.Utility where + +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import Test.Instances () + + +type TimeDiff = NonNeg.Int + +timeToDouble :: TimeDiff -> NonNeg.Double +timeToDouble = fromIntegral + +makeFracTime :: (TimeDiff, TimeDiff) -> NonNeg.Double +makeFracTime (n,d) = + timeToDouble n / (timeToDouble d + 1)