TimeEnd.hs

{- |
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)) :
   []