{- |
Copyright   :  (c) Henning Thielemann 2007-2010

Maintainer  :  haskell@henning-thielemann.de
Stability   :  stable
Portability :  Haskell 98
-}
module Data.EventList.Relative.TimeTimePrivate where

import qualified Data.EventList.Relative.TimeBodyPrivate as TimeBodyList
import qualified Data.EventList.Relative.TimeBodyPrivate as TimeBodyPriv

import qualified Data.EventList.Relative.BodyTimePrivate as BodyTimeList
import qualified Data.EventList.Relative.BodyTimePrivate as BodyTimePriv

import Data.EventList.Relative.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 Numeric.NonNegative.Class as NonNeg

import Data.Tuple.HT (mapFst, mapSnd, )

import qualified Control.Monad as Monad
import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav
import qualified Control.Applicative as App
import Control.Applicative (Applicative, )
import Data.Monoid (Monoid, mempty, mappend, mconcat, )

import Test.QuickCheck (Arbitrary(arbitrary))



newtype T time body = Cons {decons :: Uniform.T body time}
   deriving (Eq, Ord)


instance (Show time, Show body) => Show (T time body) where
   showsPrec p = Uniform.format " ./ " " /. " p . decons

instance (Arbitrary time, Arbitrary body) =>
             Arbitrary (T time body) where
   arbitrary = Monad.liftM Cons arbitrary


instance (NonNeg.C time) => Monoid (T time body) where
   mempty = Cons (Uniform.singleton 0)
   mappend =
      switchTimeR
      (\ xs t -> lift (Mixed.appendDisparateUniform $~* xs) . delay t)
   mconcat =
      flatten . consTime 0 .
      mconcat .
      map (consBody [] . fmap (:[]))

instance Functor (T time) where
   fmap f (Cons x) = Cons (Uniform.mapFirst f x)

instance Fold.Foldable (T time) where
   foldMap = Trav.foldMapDefault

instance Trav.Traversable (T time) where
   traverse f =
      App.liftA Cons . Uniform.traverse f App.pure . decons


infixl 5 $~~

($~~) :: (Uniform.T body time -> a) -> (T time body -> a)
($~~) f = f . decons


lift ::
   (Uniform.T body0 time0 -> Uniform.T body1 time1) ->
   (T time0 body0 -> T time1 body1)
lift f = Cons . f . decons

liftA :: Applicative m =>
   (Uniform.T body0 time0 -> m (Uniform.T body1 time1)) ->
   (T time0 body0 -> m (T time1 body1))
liftA f = App.liftA Cons . f . decons

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

unlift ::
   (T time0 body0 -> T time1 body1) ->
   (Uniform.T body0 time0 -> Uniform.T body1 time1)
unlift f = decons . f . Cons




consBody :: body -> T time body -> BodyTimeList.T time body
consBody b = BodyTimePriv.Cons . Mixed.consFirst b . decons

consTime :: time -> BodyTimeList.T time body -> T time body
consTime t = Cons . Mixed.consSecond t . BodyTimePriv.decons


viewTimeL :: T time body -> (time, BodyTimeList.T time body)
viewTimeL = mapSnd BodyTimePriv.Cons . Mixed.viewSecondL . decons

viewBodyL :: BodyTimeList.T time body -> Maybe (body, T time body)
viewBodyL = fmap (mapSnd Cons) . Mixed.viewFirstL . BodyTimePriv.decons


viewTimeR :: T time body -> (TimeBodyList.T time body, time)
viewTimeR = mapFst TimeBodyPriv.Cons . Mixed.viewSecondR . decons

viewBodyR :: TimeBodyList.T time body -> Maybe (T time body, body)
viewBodyR = fmap (mapFst Cons) . Mixed.viewFirstR . TimeBodyPriv.decons


{-# INLINE switchTimeL #-}
switchTimeL :: (time -> BodyTimeList.T time body -> a) -> T time body -> a
switchTimeL f =
   Mixed.switchSecondL (\b -> f b . BodyTimePriv.Cons) . decons

{-# INLINE switchBodyL #-}
switchBodyL :: a -> (body -> T time body -> a) -> BodyTimeList.T time body -> a
switchBodyL f g =
   Mixed.switchFirstL f (\t -> g t . Cons) . BodyTimePriv.decons


{-# INLINE switchTimeR #-}
switchTimeR :: (TimeBodyList.T time body -> time -> a) -> T time body -> a
switchTimeR f = Mixed.switchSecondR (f . TimeBodyPriv.Cons) . decons

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


mapTimeL ::
   (time -> time, BodyTimeList.T time body0 -> BodyTimeList.T time body1) ->
   T time body0 -> T time body1
mapTimeL = lift . Mixed.mapSecondL . mapSnd BodyTimePriv.unlift

mapTimeHead ::
   (time -> time) ->
   T time body -> T time body
mapTimeHead = lift . Mixed.mapSecondHead

mapTimeTail ::
   (BodyTimeList.T time body0 -> BodyTimeList.T time body1) ->
   T time body0 -> T time body1
mapTimeTail f =
   switchTimeL (\time -> consTime time . f)
{-
This causes a memory leak when used with chunky time values.

mapTimeTail =
   lift . Mixed.mapSecondTail . BodyTimePriv.unlift
-}


mapTimeR ::
   (TimeBodyList.T time body0 -> TimeBodyList.T time body1, time -> time) ->
   T time body0 -> T time body1
mapTimeR = lift . Mixed.mapSecondR . mapFst TimeBodyPriv.unlift

mapTimeLast ::
   (time -> time) ->
   T time body -> T time body
mapTimeLast = lift . Mixed.mapSecondLast

mapTimeInit ::
   (TimeBodyList.T time body0 -> TimeBodyList.T time body1) ->
   T time body0 -> T time body1
mapTimeInit = lift . Mixed.mapSecondInit . TimeBodyPriv.unlift


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

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 . null) .
   decons