{- |
Copyright   :  (c) Henning Thielemann 2007

Maintainer  :  haskell@henning-thielemann.de
Stability   :  stable
Portability :  Haskell 98
-}
module Data.EventList.Absolute.TimeBody
   (T,
    empty, singleton, null,
    viewL, viewR, cons, snoc,
    fromPairList, toPairList,
    getTimes, getBodies, duration,
    mapBody, mapTime,
    mapM, mapM_, mapBodyM, mapTimeM,
    merge, mergeBy, insert, insertBy,
    decreaseStart, delay, filter, partition, slice, foldr, foldrPair,
    mapMaybe, catMaybes,
    normalize, isNormalized,
    collectCoincident, flatten, mapCoincident,
    append, concat, cycle,
--    splitAtTime, takeTime, dropTime,
    discretize, resample,
    checkTimes,

    collectCoincidentFoldr, collectCoincidentNonLazy, -- for testing
   ) where

import Data.EventList.Absolute.TimeBodyPrivate

import qualified Data.AlternatingList.List.Disparate as Disp
import qualified Data.AlternatingList.List.Uniform as Uniform
import qualified Data.AlternatingList.List.Mixed as Mixed

import qualified Data.List as List
import qualified Data.EventList.Utility as Utility

import Data.EventList.Utility
   (mapFst, mapSnd, toMaybe, isMonotonic, isMonotonicLazy, beforeBy)
import qualified Control.Monad as Monad
import Control.Monad.State (State(State), evalState)

import Prelude hiding (mapM, mapM_, null, foldr, filter, concat, cycle)


empty :: T time body
empty = Cons $ Disp.empty

null :: T time body -> Bool
null = Disp.null . decons

singleton :: time -> body -> T time body
singleton time body = Cons $ Disp.singleton time body


cons :: time -> body -> T time body -> T time body
cons time body = lift (Disp.cons time body)

snoc :: T time body -> time -> body -> T time body
snoc xs time body =
   Cons $ (Disp.snoc $~ xs) time body
--   lift (\ys -> Disp.snoc ys time body) xs


viewL :: T time body -> Maybe ((time, body), T time body)
viewL = fmap (mapSnd Cons) . Disp.viewL . decons

viewR :: T time body -> Maybe (T time body, (time, body))
viewR = fmap (mapFst Cons) . Disp.viewR . decons


fromPairList :: [(a,b)] -> T a b
fromPairList = Cons . Disp.fromPairList

toPairList :: T a b -> [(a,b)]
toPairList = Disp.toPairList . decons

getBodies :: T time body -> [body]
getBodies = Disp.getSeconds . decons

getTimes :: T time body -> [time]
getTimes = Disp.getFirsts . decons

{- |
Duration of an empty event list is considered zero.
However, I'm not sure if this is sound.
-}
duration :: Num time => T time body -> time
duration = maybe 0 (fst . snd) . viewR



mapBody :: (body0 -> body1) -> T time body0 -> T time body1
mapBody f = lift (Disp.mapSecond f)

mapTime :: (time0 -> time1) -> T time0 body -> T time1 body
mapTime f = lift (Disp.mapFirst f)



mapM :: Monad m =>
   (time0 -> m time1) -> (body0 -> m body1) ->
   T time0 body0 -> m (T time1 body1)
mapM f g = liftM (Disp.mapM f g)

mapM_ :: Monad m =>
   (time -> m ()) -> (body -> m ()) ->
   T time body -> m ()
mapM_ f g = Disp.mapM_ f g . decons


mapBodyM :: Monad m =>
   (body0 -> m body1) -> T time body0 -> m (T time body1)
mapBodyM f = liftM (Disp.mapSecondM f)

mapTimeM :: Monad m =>
   (time0 -> m time1) -> T time0 body -> m (T time1 body)
mapTimeM f = liftM (Disp.mapFirstM f)


{- |
Check whether time values are in ascending order.
The list is processed lazily and
times that are smaller than there predecessors are replaced by 'undefined'.
If you would remove the 'undefined' times from the resulting list
the times may still not be ordered.
E.g. consider the time list @[0,3,1,2]@
-}
checkTimes :: (Ord time) => T time body -> T time body
checkTimes xs =
   lift
      (Disp.zipWithFirst
         (\b t -> if b then t else error "times out of order")
         (isMonotonicLazy (getTimes xs)))
      xs


foldr :: (time -> a -> b) -> (body -> b -> a) -> b -> T time body -> b
foldr f g x = Disp.foldr f g x . decons

foldrPair :: (time -> body -> a -> a) -> a -> T time body -> a
foldrPair f x = Disp.foldrPair f x . decons


filter :: (Num time) =>
   (body -> Bool) -> T time body -> T time body
filter p = mapMaybe (\b -> toMaybe (p b) b)

mapMaybe :: (Num time) =>
   (body0 -> Maybe body1) ->
   T time body0 -> T time body1
mapMaybe f = catMaybes . mapBody f

catMaybes :: (Num time) =>
   T time (Maybe body) -> T time body
catMaybes =
   foldrPair (maybe id . cons) empty

{-
Could be implemented more easily in terms of Uniform.partition
-}
partition ::
   (body -> Bool) -> T time body -> (T time body, T time body)
partition p =
   foldrPair
      (\ t b ->
          (if p b then mapFst else mapSnd) (cons t b))
      (empty, empty)

{- |
Since we need it later for MIDI generation,
we will also define a slicing into equivalence classes of events.
-}
slice :: (Eq a) =>
   (body -> a) -> T time body -> [(a, T time body)]
slice = Utility.slice (fmap (snd . fst) . viewL) partition


{- |
We will also sometimes need a function which groups events by equal start times.
This implementation is not so obvious since we work with time differences.
The criterion is: Two neighbouring events start at the same time
if the second one has zero time difference.
-}
collectCoincident :: Eq time => T time body -> T time [body]
collectCoincident =
   Cons .
   maybe
      Disp.empty
      (uncurry $ \ t0 ->
         Mixed.consFirst t0 .
         Uniform.catMaybesFirst .
         flip evalState (Just t0) .
         Uniform.mapFirstM (\time -> State $ \ oldTime ->
            (Monad.guard (time /= oldTime) >> time, time)) .
         Uniform.mapFirst Just) .
   Mixed.viewFirstL .
   decons

collectCoincidentFoldr :: Eq time => T time body -> T time [body]
collectCoincidentFoldr =
   Cons .
   foldrPair
      (\t0 b0 xs ->
          Mixed.consFirst t0 $
          maybe
             (Uniform.singleton [b0])
             (\((t1,bs),ys) ->
                 if t0 == t1
                   then Mixed.consSecond (b0:bs) ys
                   else Mixed.consSecond [b0] xs) $
             Disp.viewL xs)
      Disp.empty

{- |
Will fail on infinite lists.
-}
collectCoincidentNonLazy :: Eq time => T time body -> T time [body]
collectCoincidentNonLazy =
   Cons .
   foldrPair
      (\t0 b0 xs ->
          maybe
             (Disp.singleton t0 [b0])
             (\((t1,bs),ys) ->
                 if t0 == t1
                   then Disp.cons t0 (b0:bs) ys
                   else Disp.cons t0 [b0] xs) $
             Disp.viewL xs)
      Disp.empty


flatten :: (Ord time, Num time) => T time [body] -> T time body
flatten =
   foldrPair
      (\t bs xs -> List.foldr (cons t) xs bs)
      empty


{- |
Apply a function to the lists of coincident events.
-}

mapCoincident :: (Ord time, Num time) =>
   ([a] -> [b]) -> T time a -> T time b
mapCoincident f = flatten . mapBody f . collectCoincident

{- |

'List.sort' sorts a list of coinciding events,
that is all events but the first one have time difference 0.
'normalize' sorts all coinciding events in a list
thus yielding a canonical representation of a time ordered list.
-}

normalize :: (Ord time, Num time, Ord body) => T time body -> T time body
normalize = mapCoincident List.sort

isNormalized :: (Ord time, Num time, Ord body) =>
   T time body -> Bool
isNormalized =
   all isMonotonic . getBodies . collectCoincident


{- |
The first important function is 'merge'
which merges the events of two lists into a new time order list.
-}

merge :: (Ord time, Ord body) =>
   T time body -> T time body -> T time body
merge = mergeBy (<)

{- |
Note that 'merge' compares entire events rather than just start
times.  This is to ensure that it is commutative, a desirable
condition for some of the proofs used in \secref{equivalence}.
It is also necessary to assert a unique representation
of the performance independent of the structure of the 'Music.T note'.
The same function for inserting into a time ordered list with a trailing pause.
The strictness annotation is necessary for working with infinite lists.

Here are two other functions that are already known for non-padded time lists.
-}

{-
Could be implemented using as 'splitAt' and 'insert'.
-}
mergeBy :: (Ord time) =>
   (body -> body -> Bool) ->
   T time body -> T time body -> T time body
mergeBy before =
   let recurse xs0 ys0 =
          case (viewL xs0, viewL ys0) of
             (Nothing, _) -> ys0
             (_, Nothing) -> xs0
             (Just (x,xs), Just (y,ys)) ->
                if beforeBy before x y
                  then uncurry cons x $ mergeBy before xs ys0
                  else uncurry cons y $ mergeBy before ys xs0
   in  recurse

{- |
The final critical function is @insert@,
which inserts an event
into an already time-ordered sequence of events.
For instance it is used in MidiFiles to insert a @NoteOff@ event
into a list of @NoteOn@ and @NoteOff@ events.
-}

insert :: (Ord time, Ord body) =>
   time -> body -> T time body -> T time body
insert = insertBy (<)


insertBy :: (Ord time) =>
   (body -> body -> Bool) ->
   time -> body -> T time body -> T time body
insertBy before t0 me0 mevs1 =
   let mev0 = (t0, me0)
   in  maybe
          (uncurry singleton mev0)
          (\(mev1, mevs) ->
              if beforeBy before mev0 mev1
                then uncurry cons mev0 $ mevs1
                else uncurry cons mev1 $ uncurry (insertBy before) mev0 mevs) $
       viewL mevs1


append :: (Ord time, Num time) =>
   T time body -> T time body -> T time body
append xs = lift (Disp.append $~ xs) . delay (duration xs)

concat :: (Ord time, Num time) =>
   [T time body] -> T time body
concat xs =
   let ts = scanl (+) 0 (map duration xs)
   in  Cons $ Disp.concat $ map decons $ zipWith delay ts xs

cycle :: (Ord time, Num time) =>
   T time body -> T time body
cycle = concat . List.repeat



{-
splitAtTime :: (Ord time, Num time) =>
   time -> T time body -> (Uniform.T body time, T time body)
splitAtTime t0 =
   maybe
      (Uniform.singleton 0, empty)
      (\(t1,xs) ->
          if t0<=t1
            then (Uniform.singleton t0, consTime (t1-t0) xs)
            else
               (\(b,ys) -> mapFst (Uniform.cons t1 b) (splitAtTime (t0-t1) ys))
               (viewBodyL xs)) .
   viewTimeL

takeTime :: (Ord time, Num time) =>
   time -> T time body -> Uniform.T body time
takeTime t = fst . splitAtTime t

dropTime :: (Ord time, Num time) =>
   time -> T time body -> T time body
dropTime t = snd . splitAtTime t
-}


decreaseStart :: (Ord time, Num time) =>
   time -> T time body -> T time body
decreaseStart dif =
   maybe
      empty
      (\((t, b), xs) ->
         cons
            (if t>=dif
               then t-dif
               else error "decreaseStart: difference too big") b
            (mapTime (subtract dif) xs)) .
      viewL

delay :: (Ord time, Num time) =>
   time -> T time body -> T time body
delay dif =
   if dif>=0
     then mapTime (dif+)
     else error "delay: negative delay"



{- |

Here are some functions for discretizing the time information.
When converting the precise relative event times
to the integer relative event times
we have to prevent accumulation of rounding errors.
We avoid this problem with a stateful conversion
which remembers each rounding error we make.
This rounding error is used to correct the next rounding.
Given the relative time and duration of a note
the function @discretizeEventM@ creates a @State@
which computes the rounded relative time.
It is corrected by previous rounding errors.

The resulting event list may have differing time differences
which were equal before discretization,
but the overall timing is uniformly close to the original.

-}

discretize :: (RealFrac time, Integral i) =>
   T time body -> T i body
discretize = mapTime round

resample :: (RealFrac time, Integral i) =>
   time -> T time body -> T i body
resample rate = discretize . mapTime (rate*)