{- |
Copyright   :  (c) Henning Thielemann 2007

Maintainer  :  haskell@henning-thielemann.de
Stability   :  stable
Portability :  Haskell 98

Event lists starting with a time difference and ending with a time difference.
-}
module Data.EventList.Relative.TimeTime
   (T,
    mapBody, mapTime,
    concatMapMonoid,
    mapM, mapM_, mapBodyM, mapTimeM,
    getTimes, getBodies, duration,
    merge, mergeBy, insert, {- insertBy, -} pad,
    moveForward, moveForwardRestricted, moveBackward, arrange, arrangeBy,
    moveForwardRestrictedBy,
    moveForwardRestrictedByQueue, moveForwardRestrictedByStrict,
    decreaseStart, delay, filter, partition, slice, foldr,
    pause, isPause, cons, snoc, viewL, viewR, switchL, switchR,
    mapMaybe, catMaybes, catMaybesR,
    append, concat, concatNaive, cycle, cycleNaive,
    splitAtTime, takeTime, dropTime,
    discretize, resample,
    collectCoincident, flatten, mapCoincident,
    normalize, isNormalized,
    toAbsoluteEventList, fromAbsoluteEventList,
   ) where

import Data.EventList.Relative.TimeTimePrivate as TimeTimePriv
import Data.EventList.Relative.TimeBodyPrivate (($~*))

import qualified Data.EventList.Relative.BodyTimePrivate as BodyTimePriv
import qualified Data.EventList.Relative.TimeBody as TimeBodyList

import qualified Data.EventList.Absolute.TimeTimePrivate as AbsoluteEventPriv
import qualified Data.EventList.Absolute.TimeTime as AbsoluteEventList

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

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

import Data.Monoid (Monoid, )

import qualified Numeric.NonNegative.Class as NonNeg
import Data.Tuple.HT (mapFst, mapSnd, mapPair, )
import Data.Maybe.HT (toMaybe, )
import Data.List.HT (isAscending, )
import Data.EventList.Utility (floorDiff, )
import Control.Monad.Trans.State (evalState, modify, get, gets, put, )
import Control.Monad (liftM2, )

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



pause :: time -> T time body
pause = Cons . Uniform.singleton

isPause :: T time body -> Bool
isPause = Uniform.isSingleton . decons



getBodies :: T time body -> [body]
getBodies = Uniform.getFirsts . decons

getTimes :: T time body -> [time]
getTimes = Uniform.getSeconds . decons

duration :: Num time => T time body -> time
duration = sum . getTimes



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

snoc :: T time body -> body -> time -> T time body
snoc xs body time =
   Cons $ (Uniform.snoc $~~ xs) body time


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

{-# INLINE switchL #-}
switchL :: (time -> a) -> ((time, body) -> T time body -> a) -> T time body -> a
switchL f g =
   Mixed.switchL f (\t b -> g (t,b) . Cons) .
   decons

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

{-# INLINE switchR #-}
switchR :: (time -> a) -> (T time body -> body -> time -> a) -> T time body -> a
switchR f g =
   Mixed.switchR f (g . Cons) .
   decons


mapBody :: (body0 -> body1) -> T time body0 -> T time body1
mapBody = lift . Uniform.mapFirst

mapTime :: (time0 -> time1) -> T time0 body -> T time1 body
mapTime = lift . Uniform.mapSecond



concatMapMonoid :: Monoid m =>
   (time -> m) -> (body -> m) ->
   T time body -> m
concatMapMonoid f g = Uniform.concatMapMonoid g f . decons

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

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


mapBodyM :: Monad m =>
   (body0 -> m body1) -> T time body0 -> m (T time body1)
mapBodyM = liftM . Uniform.mapFirstM

mapTimeM :: Monad m =>
   (time0 -> m time1) -> T time0 body -> m (T time1 body)
mapTimeM = liftM . Uniform.mapSecondM



{- |
Sort coincident elements.
-}
normalize :: (Ord body, NonNeg.C time) =>
   T time body -> T time body
normalize = mapCoincident List.sort

isNormalized :: (NonNeg.C time, Ord body) =>
   T time body -> Bool
isNormalized =
   all isAscending . getBodies . collectCoincident


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

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

{-
Could be implemented using as 'splitAt' and 'insert'.
-}
mergeBy :: (NonNeg.C time) =>
   (body -> body -> Bool) ->
   T time body -> T time body -> T time body
mergeBy before xs0 ys0 =
   let (xt,xs) = viewTimeL xs0
       (yt,ys) = viewTimeL ys0
   in  case compare xt yt of
          LT -> mergeFirstBy before xs0 ys0
          GT -> mergeFirstBy before ys0 xs0
          EQ ->
             consTime xt $
             case (viewBodyL xs, viewBodyL ys) of
                (Nothing, _) -> ys
                (_, Nothing) -> xs
                (Just (b0,xs1), Just (b1,ys1)) ->
                   {- do not insert both b0 and b1 immediately,
                      because the later one of b0 and b1 may be pushed even further,
                      thus recourse with 'mergeBy' on xs or ys -}
                   if before b0 b1
                     then consBody b0 $ mergeBy before xs1 $ consTime 0 ys
                     else consBody b1 $ mergeBy before ys1 $ consTime 0 xs

{- | merge two time ordered lists provided that e0 is earlier than e1 -}
mergeFirstBy :: (NonNeg.C time) =>
   (body -> body -> Bool) ->
   T time body -> T time body -> T time body
mergeFirstBy before xs0 ys0 =
   let (xt,xs) = viewTimeL xs0
       (yt,ys) = viewTimeL ys0
   in  switchBodyL
          ys0
          (\ b xs1 ->
              consTime xt $ consBody b $ mergeBy before xs1 $ consTime (yt-xt) ys)
          xs


{- |
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.
-}

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

{-
Ordering of bodies at the same time
could be simplified using collectCoincident.
-}
insertBy :: (NonNeg.C time) =>
   (body -> body -> Bool) ->
   time -> body -> T time body -> T time body
insertBy before t0 me0 =
   let recurseTime t =
          switchTimeL (\ t1 xs ->
             if t<t1
               then cons t me0 (consTime (t1-t) xs)
               else recurseBody t1 t xs)
       recurseBody t1 t =
          switchBodyL
             (cons t me0 $ pause 0)
             (\ me1 xs ->
                 consTime t1 $
                    if t==t1 && before me0 me1
                      then consBody me0 (cons 0 me1 xs)
                      else consBody me1 (recurseTime (t-t1) xs))
   in   recurseTime t0


{-
Ensure that the list has a minimum length
by extending the last pause accordingly.
-}
pad :: (NonNeg.C time) =>
   time -> T time body -> T time body
pad time = mergeBy (\ _ _ -> False) (pause time)


{- |
Move events towards the front of the event list.
You must make sure, that no event is moved before time zero.
This works only for finite lists.
-}
moveForward :: (NonNeg.C time) =>
   T time (time, body) -> T time body
moveForward =
   fromAbsoluteEventList .
   AbsoluteEventList.moveForward .
   toAbsoluteEventList 0

moveBackward :: (NonNeg.C time) =>
   T time (time, body) -> T time body
moveBackward =
   catMaybes .
   foldr
      (\t -> cons t Nothing)
      (\(t,b) -> insertBy (ltMaybe (\_ _ -> True)) t (Just b))
      (pause 0)

{- |
Like 'moveForward' but restricts the look-ahead time.
For @moveForwardRestricted maxTimeDiff xs@
all time differences (aka the moveForward offsets) in @xs@
must be at most @maxTimeDiff@.
With this restriction the function is lazy enough
for handling infinite event lists.
However the larger @maxTimeDiff@ the more memory and time is consumed.
-}
{-
Implementation notes:
We keep a (non-optimized) priority queue as the state of a state monad.
In a pause we emit all events that occur in this duration.
-}
moveForwardRestricted :: (Ord body, NonNeg.C time) =>
   time -> T time (time, body) -> T time body
moveForwardRestricted maxTime =
   decreaseStart maxTime .
   moveBackward .
   mapBody (mapFst (maxTime-)) .
   pad maxTime
{-
   moveForwardRestrictedBy
      (\_ _ -> True)
      -- (<)
-}

ltMaybe :: (body -> body -> Bool) -> (Maybe body -> Maybe body -> Bool)
ltMaybe cmp mx my =
   case (mx,my) of
      (Nothing, _) -> True
      (_, Nothing) -> False
      (Just x, Just y) -> cmp x y


-- | currently only for testing
moveForwardRestrictedBy :: (NonNeg.C time) =>
   (body -> body -> Bool) ->
   time -> T time (time, body) -> T time body
moveForwardRestrictedBy cmp maxTime =
   decreaseStart maxTime .
   catMaybes .
   foldr
      (\t -> cons t Nothing)
      (\(t,b) -> insertBy (ltMaybe cmp) (maxTime-t) (Just b))
      (pause maxTime)

-- | currently only for testing
moveForwardRestrictedByStrict :: (NonNeg.C time) =>
   (body -> body -> Bool) ->
   time -> T time (time, body) -> T time body
moveForwardRestrictedByStrict cmp maxTime =
   decreaseStart maxTime .
   foldr
      delay
      (\(t,b) -> insertBy cmp (maxTime-t) b)
      (pause maxTime)

-- | currently only for testing
moveForwardRestrictedByQueue :: (NonNeg.C time) =>
   (body -> body -> Bool) ->
   time -> T time (time, body) -> T time body
moveForwardRestrictedByQueue cmp maxTime xs =
   let (prefix,suffix) = splitAtTime maxTime xs
       prefixDur = duration prefix {- maxTime would work in most cases, too -}
       getChunk t =
          do (toEmit,toKeep) <- gets (splitAtTime t)
             put toKeep
             return (pad t toEmit)
       insertEvent (t,b) =
          insertBy cmp (maxTime - t) b
   in  evalState
          (foldr
             (\t m -> liftM2 append (getChunk t) m)
             (\b m -> modify (insertEvent b) >> m)
             (gets (pad prefixDur)) suffix)
          (moveForward (seq prefixDur prefix))
             {- this way 'prefixDur' will be computed early
                and 'prefix' need not to be stored until the end of the list -}


{- |
Merge several event lists respecting the start time of the outer event list.
-}
arrange :: (Ord body, NonNeg.C time) =>
   T time (T time body) -> T time body
arrange = arrangeBy (\_ _ -> False)

arrangeBy :: (NonNeg.C time) =>
   (body -> body -> Bool) ->
   T time (T time body) -> T time body
arrangeBy cmp =
   catMaybes .
   foldr
      (\t -> cons t Nothing)
      (\xs -> mergeBy (ltMaybe cmp) (mapBody Just xs))
      (pause 0)


{-
not lazy enough for @append (2 /. 'a' ./ 4 /. 'b' ./ 2 /. undefined) undefined@
-}
append :: (NonNeg.C time) =>
   T time body -> T time body -> T time body
append =
   switchTimeR
   (\ xs t -> lift (Mixed.appendDisparateUniform $~* xs) . delay t)

concat :: (NonNeg.C time) =>
   [T time body] -> T time body
concat =
   flatten . consTime 0 .
   BodyTimePriv.concat .
   List.map (consBody [] . mapBody (:[]))

{- |
'concat' and 'concatNaive' are essentially the same.
'concat' must use 'foldr' in order to work on infinite lists,
however if there are many empty lists,
summing of their durations will be done from right to left,
which is inefficient.
Thus we detect subsequent empty lists and merge them from left to right.
-}
concatNaive :: (NonNeg.C time) =>
   [T time body] -> T time body
concatNaive = List.foldr append (pause 0)


{- |
Uses sharing.
-}
cycle :: (NonNeg.C time) =>
   T time body -> T time body
cycle =
   switchTimeL
   (\t0 xs ->
       consTime t0 $
       BodyTimePriv.cycle $
       BodyTimePriv.mapTimeLast (+t0) xs)


cycleNaive :: (NonNeg.C time) =>
   T time body -> T time body
cycleNaive = concat . List.repeat



{- |
If there is an event at the cutting time,
this event is returned in the suffix part.
That is
@splitAtTime t0 (t0 ./ x /. t1 ./ empty) ==
    (pause t0, 0 ./ x /. t1 ./ empty)@
-}
{-
It could also be implemented by inserting a marker element
and then splitting at this element.
I hope that the current manual recursion routine is the most efficient solution.
-}
splitAtTime :: (NonNeg.C time) =>
   time -> T time body -> (T time body, T time body)
splitAtTime t0 =
   switchTimeL
   (\t1 xs ->
        if t0<=t1
          then (pause t0, consTime (t1-t0) xs)
          else
             switchBodyL
                (pause t1, pause 0)
                (\ b -> mapFst (cons t1 b) . splitAtTime (t0-t1))
                xs)

takeTime :: (NonNeg.C time) =>
   time -> T time body -> T time body
takeTime t = fst . splitAtTime t

dropTime :: (NonNeg.C time) =>
   time -> T time body -> T time body
dropTime t = snd . splitAtTime t


decreaseStart :: (NonNeg.C time) =>
   time -> T time body -> T time body
decreaseStart dif =
   mapTimeHead (subtract dif)

delay :: (NonNeg.C time) =>
   time -> T time body -> T time body
delay dif =
   mapTimeHead (dif+)

{- |

-}

collectCoincident :: (NonNeg.C time) => T time body -> T time [body]
collectCoincident =
   mapTimeInit TimeBodyList.collectCoincident


flatten :: (Num time) => T time [body] -> T time body
flatten =
   Cons .
   Uniform.foldr
      (Mixed.appendUniformUniform . Uniform.fromSecondList 0)
      Mixed.consSecond    -- consTime
      Disp.empty .
--      (\(b:bs) xs -> consBody b (List.foldr (cons 0) xs bs)) empty .
   Uniform.mapSecond sum .
   Uniform.filterFirst (not . List.null) .
   decons



mapCoincident :: (NonNeg.C time) =>
   ([a] -> [b]) -> T time a -> T time b
mapCoincident f =
   flatten . mapBody f . collectCoincident


{- |
Analogously to the 'concat' \/ 'concatNaive' pair
we have to versions of 'filter',
where the clever implementation sums up pauses
from the beginning to the end.
-}

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

{- |
Adds times in a left-associative fashion.
Use this if the time is a strict data type.
-}
catMaybes :: (Num time) =>
   T time (Maybe body) -> T time body
catMaybes = mapTime sum . lift Uniform.catMaybesFirst

{- |
Adds times in a right-associative fashion.
Use this if the time is a data type like lazy Peano numbers
or "Numeric.NonNegative.Chunky".
-}
catMaybesR :: (Num time) =>
   T time (Maybe body) -> T time body
catMaybesR =
   foldr
      (mapTimeHead . (+))
      (maybe id (cons 0))
      (pause 0)

partition :: (Num time) =>
   (body -> Bool) ->
   T time body -> (T time body, T time body)
partition p =
   mapPair (mapTime sum, mapTime sum) .
   mapPair (Cons, Cons) .
   Uniform.partitionFirst p .
   decons

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

{- |

-}

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

{- |

-}


discretize :: (NonNeg.C time, RealFrac time, NonNeg.C i, Integral i) =>
   T time body -> T i body
discretize =
   flip evalState 0.5 . mapTimeM floorDiff

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


toAbsoluteEventList :: (Num time) =>
   time -> T time body -> AbsoluteEventList.T time body
toAbsoluteEventList start =
   AbsoluteEventPriv.Cons . decons .
   flip evalState start .
   mapTimeM (\dur -> modify (dur+) >> get)

fromAbsoluteEventList :: (Num time) =>
   AbsoluteEventList.T time body -> T time body
fromAbsoluteEventList =
   flip evalState 0 .
   mapTimeM
      (\time -> do lastTime <- get; put time; return (time-lastTime)) .
   Cons . AbsoluteEventPriv.decons