{-# LANGUAGE GADTs, FlexibleInstances #-}

-- | An embedded domain-specific language (EDSL) for 
-- creating lists of constant time events related in time.
-- Combinators are optimized in fusion style.

module Temporal.Media(
    -- * Introduction

    -- | "Temporal.Media" is an embedded domain-specific 
    -- language (EDSL) for creating lists of constant time 
    -- events related in time. Constant time event is value
    -- that starts at some fixed time and lasts for some 
    -- fixed time. Library provides functions to build lists
    -- of such events with time-relations like sequent,  
    -- parallel or delayed. 
    --
    -- Core type of library is 'Media'. It provides interface
    -- to compose list of events. There is optimization that 
    -- goes on behind the scene. 
    --
    -- * Fusion 
    --
    -- >fmap f . fmap g 
    --
    -- is trasformed to
    --
    -- >fmap (f . g) 
    --
    -- same holds for more general 'eventMap'.
    --
    -- * Loops
    --
    -- Transformations on 'loop' 's are  executed only for 
    -- one cycle.
    --
    -- * Structure functions
    --
    -- Structure functions ('sequent', 'parallel', 
    -- 'stretch', 'reverseM') are rendered as linear 
    -- transformations of time and duration of an event.
    --
    -- Example of usage can be found in package 'temporal-music-notation' [1].
    -- Score module is based on this library.
    --
    -- \[1\] <http://hackage.haskell.org/package/temporal-music-notation>
    
    -- * Types
    
    Dur(..), Media, Event(..), EventList(..),

    -- * Constructors
        
    none, temp,

    -- * Composition

    (+:+), (=:=), (=:/),
    sequent, parallel, parallelT,
    delay, loop,

    -- * Transformations
    
    stretch, 
    reverseM,
    slice, takeM, dropM,

    -- * Mappings

    eventMap,
    tmap, dmap, tdmap,
    tmapRel, dmapRel, tdmapRel,

    -- * Rendering
    dur, renderMedia,

    -- * Miscellaneous

    linseg
    )
where    



import Data.List(foldl')
import Data.Maybe(catMaybes)
import Data.Ratio(Ratio)
import Data.Function(on)

import Control.Arrow(first, second, (***))

import Control.Monad.State(State, state, runState)
import Control.Monad (foldM, liftM2)

import Data.DList(DList, empty, singleton, append, fromList, toList)

--import Debug.Trace

--debug :: Show a => String -> a -> a
--debug str x = trace (str ++ " : " ++ show x) x

-- | class of 'time' values
class (Ord a, Num a, Fractional a) => Dur a

instance Dur Double
instance Dur Float
instance Integral a => Dur (Ratio a)

-- | 'Media' is core data type. Essentially 'Media' provides 
-- functional interface to 'EventList' construction.
data Media t a = Media t (M t a) 

-- | Media operations
data M t a where
-- constructors
    None :: t -> M t a
    Prim :: t -> a -> M t a

-- composition
    Seq  :: [(t, M t a)] -> M t a
    Par  :: [(t, M t a)] -> M t a

    Loop :: Int -> (t, M t a) -> M t a

-- transformation
    Stretch :: t -> (t, M t a) -> M t a

    Slice :: Interval t -> (t, M t a) -> M t a
    Reverse :: M t a -> M t a

-- mappings
    Fmap :: (a' -> a) -> M t a' -> M t a
    Emap :: (Event t a' -> Event t a) -> M t a' -> M t a

-- | Constant time events. Value @a@ starts at some time 
-- and lasts for some time.
data Event t a = Event
    { eventStart    :: t
    , eventDur      :: t
    , eventContent  :: a
    } deriving (Show, Eq)


instance Functor (Event t) where
    fmap f (Event t d a) = Event t d $ f a

-- | List of 'Event' s. First argument stands for total duration
-- of 'EventList'.
data EventList t a = EventList t [Event t a]
    deriving (Show, Eq)

instance Functor (EventList t) where
    fmap f (EventList t es) = EventList t $ map (fmap f) es


------------------------------------------------------------
------------------------------------------------------------

-- constructors


-- | 'none' constructs an empty event. 
-- Nothing is going on for a given time.
none :: Dur t => t -> Media t a 
none d 
    | d >= 0    = Media d $ None d
    | otherwise = msgDurErr

-- | 'temp' constructs just an event. Value of type a
-- lasts for some time.
temp :: Dur t => t -> a -> Media t a
temp d a  
    | d >= 0    = Media d $ Prim d a
    | otherwise = msgDurErr

msgDurErr = error "duration must be non-negative"

-- duration querry

-- | Duration querry.
dur :: Media t a -> t
dur (Media t _) = t

unM :: Media t a -> M t a
unM (Media _ x) = x

-- composition

-- | Binary sequent composition. 
-- In @(a+:+b)@ @a@ happens first and then @b@ goes.
(+:+) :: Dur t => Media t a -> Media t a -> Media t a
Media t a +:+ Media t' a' = Media (t + t') $ 
    case (a, a') of
        (None d, None d') -> None $ d + d'
        _                 -> Seq [(t, a), (t', a')]

-- | Binary parallel composition. 
-- In @(a=:=b)@ @a@ and @b@ happen simultaneously.
(=:=) :: Dur t => Media t a -> Media t a -> Media t a
Media t a =:= Media t' a' = Media (max t t') $
    case (a, a') of
        (None d, None d') -> None $ max d d'
        _                 -> Par [(t, a), (t', a')] 

-- | Truncating binary composition. 
-- In @(a=:/b)@, @a@ and @b@ happen simultaneously but
-- whole result lasts only for @min ('dur' a) ('dur' b)@ time. 
(=:/) :: Dur t => Media t a -> Media t a -> Media t a
a =:/ b = parallelT [a, b]

-- | 'delay' appends block of nothing of given duration 
-- to the begging of value (if duration is positive)
-- or to the end of value (if duration is negative).
delay :: Dur t => t -> Media t a -> Media t a
delay d a 
    | d > 0     = none d +:+ a
    | d < 0     = a +:+ (none $ abs d)
    | otherwise = a

-- | Sequent composition on lists.
sequent :: Dur t => [Media t a] -> Media t a
sequent xs = Media (sum $ map fst ds) $ Seq ds
    where ds = map (\x -> (dur x, unM x)) xs

-- | Parallel composition on lists.
parallel :: Dur t => [Media t a] -> Media t a
parallel xs = Media (maximum $ map fst ds) $ Par ds
    where ds = map (\x -> (dur x, unM x)) xs

-- | Truncating parallel composition on lists.
parallelT :: Dur t => [Media t a] -> Media t a
parallelT xs = slice 0 d $ parallel xs
    where d = minimum $ map dur xs

-- | 'loop' repeats sequentially given value.
loop :: Dur t => Int -> Media t a -> Media t a
loop n (Media t a)
    | n <= 0    = none 0
    | otherwise = Media (t * fromIntegral n) $
            case a of
                Loop n' a' -> Loop (n * n') a'
                _          -> Loop n (t, a)

--loop n = sequent . replicate n

-- transformation

-- | Stretching values by factor.
stretch :: Dur t => t -> Media t a -> Media t a
stretch k m@(Media t a)  
    | k < 0     = reverseM $ stretch (abs k) m 
    | otherwise = Media (k * t) $ 
            case a of
                Stretch k' x -> Stretch (k * k') x
                _            -> Stretch k (t, a)


-- | 'slice' cuts piece of value within given time interval.
-- for @('slice' t0 t1 m)@, if @t1 < t0@ result is reversed.
-- If @t0@ is negative or @t1@ goes beyond @'dur' m@ blocks of
-- nothing inserted so that duration of result equals to 
-- @'abs' (t0 - t1)@.
slice :: Dur t => t -> t -> Media t a -> Media t a
slice t0 t1 m@(Media t a)     
    | t0 == t1  = none 0
    | t0 <  t1  = Media (t1 - t0) $ Slice (t0, t1) (t, a)
    | otherwise = slice (t - t0) (t - t1) $ reverseM m

-- | @('takeM' t)@ is equivalent to @('slice' 0 t)@.
takeM :: Dur t => t -> Media t a -> Media t a
takeM t = slice 0 t 


-- | @('dropM' t m)@ is equivalent to @('slice' t (dur m) m)@.
dropM :: Dur t => t -> Media t a -> Media t a
dropM t x = slice t (dur x) x


-- | Reverses input.
reverseM :: Media t a -> Media t a
reverseM (Media t a) = Media t $
    case a of
        Reverse x -> x
        _         -> Reverse a

-- mappings 

instance Functor (Media t) where
    fmap f (Media t a) = Media t $ 
            case a of
                Fmap f' a' -> Fmap (f . f') a'
                _          -> Fmap f a 

-- | General mapping. In the end all values of type 'Media' 
-- are to be converted to 'EventList' wich is list of 'Event' s 
-- and function 'eventMap' allows mapping on 'Media' subvalues as if 
-- they are events already.
--
-- Warning : It is possible to change start time position with 
-- 'eventMap' but it can lead to unexpected outcome when used 
-- with 'slice' function. 'slice' operates on structure of 
-- type 'Media' (how value was built with 'sequent', 'parallel'
-- or 'stretch' and other functions), but 'eventMap' operates 
-- on 'Media' subvalues as if they are converted to 'Event' s 
-- and some shifted events can slip through 'slice' 's fingers.
eventMap ::    
       (Event t a -> Event t a') 
    -> (Media t a -> Media t a')
eventMap f (Media t a) = Media t $ 
    case a of
        Emap f' a' -> Emap (f . f') a'
        _          -> Emap f a

-- | map with time
tmap :: (t -> a -> b) -> Media t a -> Media t b
tmap f = tdmap (flip $ const f)

-- | map with duration
dmap :: (t -> a -> b) -> Media t a -> Media t b
dmap f = tdmap (const f)

-- | map with time and duration 
tdmap :: (t -> t -> a -> b) -> Media t a -> Media t b
tdmap f = eventMap $ \(Event t d a) -> Event t d $ f t d a

-- | Relative 'tmap'. Time values are normalized by argument's duration.   
tmapRel :: Dur t => (t -> a -> b) -> Media t a -> Media t b
tmapRel f x = tmap (f . ( / dur x)) x

-- | Relative 'dmap'.
dmapRel :: Dur t => (t -> a -> b) -> Media t a -> Media t b
dmapRel f x = dmap (f . ( / dur x)) x

-- | Relative 'tdmap'. 
tdmapRel :: Dur t => (t -> t -> a -> b) -> Media t a -> Media t b
tdmapRel f x = tdmap (on f ( / dur x)) x

---------------------------------------------------------------
-- Misc

-- | Linear interpolation. Can be useful with 'eventMap' for 
-- envelope changes.
--
-- linseg [a, da, b, db, c, ... ]
--
-- @a, b, c ...@ - values
--
-- @da, db, ...@ - duration of segments
linseg :: (Ord t, Fractional t) => [t] -> t -> t
linseg xs t = 
    case xs of
        (a:dur:b:[])      -> seg a dur b t
        (a:dur:b:(x:xs')) -> if t < dur 
                             then seg a dur b t
                             else linseg (b:x:xs') (t - dur)
    where seg a dur b t 
                | t < 0     = a
                | t >= dur  = b
                | otherwise = a + (b - a)*(t/dur)

----------------------------------------------------------------
----------------------------------------------------------------
-- interpretation

-- | 'renderMedia' converts values of type 'Media' to
-- values of type 'EventList'. If some values have negative
-- time (it is possible through 'eventMap') all events are 
-- shifted so that first event has zero start time. Events
-- are unsorted by start time.
renderMedia :: Dur t => Media t a -> EventList t a
renderMedia (Media totalDur m) = formEventList dt es
    where (es, dt) = runState (renderM totalDur initCtx m) dt0
          dt0 = (0, totalDur)  



formEventList :: Dur t 
    => Interval t -> DList (Event t a) -> EventList t a
formEventList (t0, t1) es = 
    EventList (t1 - t0) $ shiftEs $ toList es
    where shiftEs
            | t0 < 0    = map shiftEvent
            | otherwise = id
          shiftEvent e = e{eventStart = eventStart e - t0}   
                


type MList t a = State (Interval t) (DList (Event t a))

renderM :: Dur t => t -> Ctx t a b -> M t a -> MList t b
renderM totalDur ctx m = 
    case m of
     -- constructors
        None d   -> return empty
        Prim d x -> if isSlicePrim (ctxSlice ctx) (0, totalDur)
                        then return empty
                        else renderPrim (ctxTfm ctx) d x

        _        -> if isSliceComp (ctxSlice ctx) (0, totalDur)
                        then return empty
                        else 
            case m of
           -- composition
                Seq xs   -> renderSeq ctx xs
                Par xs   -> renderPar ctx xs

                Loop n x -> renderLoop totalDur ctx n x

        -- transformation 
                Stretch d x -> renderStretch ctx d x

                Slice dt x  -> renderSlice dt ctx x
                Reverse x   -> renderReverse totalDur ctx x

        -- mappings
                Fmap f m' -> renderFmap totalDur ctx f m'
                Emap f m' -> renderEmap totalDur ctx f m' 

   
renderPrim :: Dur t => Tfm t a b -> t -> a -> MList t b
renderPrim tfm d x = state $ 
    \(t0, t1) -> let t0' = min t0 $ eventStart e
                     t1' = max t1 $ eventStart e + eventDur e
                 in  (singleton e, (t0', t1')) 
    where e = appTfm tfm $ Event 0 d x


renderSeq :: Dur t => Ctx t a b -> [(t, M t a)] -> MList t b
renderSeq ctx = fmap fst . foldM phi (empty, 0)
    where phi (res, d') (d, x) = fmap (\x -> (append res x, d' + d)) $ 
                    renderM d (shiftCtx d' ctx) x

renderPar :: Dur t => Ctx t a b -> [(t, M t a)] -> MList t b
renderPar ctx = fmap (foldl' append empty) . mapM phi
    where phi (d, x) = renderM d ctx x


renderLoop :: Dur t
    => t -> Ctx t a b -> Int -> (t, M t a) -> MList t b
renderLoop totalDur ctx n (d, x) = 
    fmap (foldl' append empty) $ mapM phi ids 
    where e   = renderM d initCtx x
          ids = loopIds (ctxSlice ctx) n d 
          phi (segType, ds) =                
                case segType of
                    Part  -> renderM d ctx' x
                    Whole -> fmap (fmap (appTfm $ ctxTfm ctx')) e
                where ctx' = shiftCtx ds ctx

data LoopSeg = Part | Whole

-- ineffective / consider better solution

loopIds :: Dur t => [SliceSeg t] -> Int -> t -> [(LoopSeg, t)] 
loopIds f n d = catMaybes $ map phi [0 .. n-1]
    where phi i
            | not $ isSlicePrim f dt = Just (Whole, fst dt)
            | not $ isSliceComp f dt = Just (Part,  fst dt)
            | otherwise              = Nothing
            where dt = (d * fromIntegral i, d)
                    



renderStretch :: Dur t
    => Ctx t a b -> t -> (t, M t a) -> MList t b
renderStretch ctx k (d, x) = 
    renderM d (stretchCtx k ctx) x

renderSlice :: Dur t
    => Interval t -> Ctx t a b -> (t, M t a) -> MList t b
renderSlice (t0, t1) ctx (d, m) = 
    renderM d (sliceCtx (t0, t1) ctx) m

renderReverse :: Dur t
    => t -> Ctx t a b ->  M t a -> MList t b
renderReverse totalDur ctx x = 
    renderM totalDur (reverseCtx totalDur ctx) x

renderFmap :: Dur t
    => t -> Ctx t a b -> (a' -> a) -> M t a' -> MList t b
renderFmap totalDur ctx f m = 
    renderM totalDur (appendFmapCtx f ctx) m

renderEmap :: Dur t
    => t -> Ctx t a b 
    -> (Event t a' -> Event t a) -> M t a' -> MList t b
renderEmap totalDur ctx f m = 
    renderM totalDur (appendEmapCtx f ctx) m


------------------------------------------------------
-- utils

-- Types

data LinTfm t = LinTfm
    { linTfmStart :: (t, t, t)
    , linTfmDur   :: (t, t, t)
    }

type Tfm t a b = (LinTfm t, Event t a -> Event t b)

type Interval t = (t, t)

type SliceSeg t = (t, LinTfm t)

data Ctx t a b = Ctx
    { ctxSlice :: [SliceSeg t]
    , ctxTfm   :: (Tfm t a b)
    }

-----------------------------------------------------------
-- funs on

-- LinTfm

appLinTfm :: Num t => LinTfm t -> (t, t) -> (t, t)
appLinTfm lt (t, d) = (x11*t + x12*d + b1, x21*t + x22*d + b2)
    where (x11, x12, b1) = linTfmStart lt
          (x21, x22, b2) = linTfmDur   lt

idLinTfm :: Num t => LinTfm t
idLinTfm = LinTfm (1, 0, 0) (0, 1, 0)

shiftLinTfm :: Num t => t -> LinTfm t -> LinTfm t
shiftLinTfm k (LinTfm (x11, x12, b1) (x21, x22, b2)) =
    LinTfm (x11, x12, b1')
           (x21, x22, b2') 
    where !b1' = k*x11 + b1
          !b2' = k*x21 + b2  

stretchLinTfm :: Num t => t -> LinTfm t -> LinTfm t
stretchLinTfm k (LinTfm (x11, x12, b1) (x21, x22, b2)) = 
    LinTfm (k*x11, k*x12, b1)
           (k*x21, k*x22, b2) 

reverseLinTfm :: Num t => t -> LinTfm t -> LinTfm t 
reverseLinTfm totalDur (LinTfm (x11, x12, b1) (x21, x22, b2)) =
    LinTfm (-x11, x12 - x11, totalDur * x11 + b1)
           (-x21, x22 - x21, totalDur * x21 + b2) 
            
-- Tfm

idTfm :: Num t => Tfm t a a
idTfm = (idLinTfm, id)

appTfm :: Dur t => Tfm t a b -> Event t a -> Event t b
appTfm (linTfm, f) = f . liftEv linTfm

liftEv :: Dur t => LinTfm t -> Event t a -> Event t a
liftEv lt (Event t d a) = Event t' d' a
    where (t', d') = appLinTfm lt (t, d)
 
appendFmap :: (a' -> a) -> Tfm t a b -> Tfm t a' b
appendFmap f = second ( . fmap f)

appendEmap :: Dur t => 
       (Event t a' -> Event t a) 
    -> (Tfm t a b  -> Tfm t a' b)
appendEmap f (linTfm, g) = (linTfm', resTfm)
    where linTfm' = idLinTfm
          resTfm  = g . liftEv linTfm . f  

-- Interval

within :: Dur t => Interval t -> Interval t -> Bool
within (a', b') (a, b) =
       a' >= aEps && a' <= bEps 
    && b' >= aEps && b' <= bEps
    where (aEps, bEps) = epsInterval (a, b)

outside :: Dur t => Interval t -> Interval t -> Bool
outside (a', b') (a, b) = b' < aEps || a' > bEps
    where (aEps, bEps) = epsInterval (a, b)        

epsInterval :: Dur t => Interval t -> Interval t
epsInterval (a, b) = (a - eps, b + eps)
    where eps  = 1e-9

toInterval :: Dur t => (t, t) -> Interval t
toInterval (t, d) = (t, t + d)

-- SliceSeg

isSlicePrim, isSliceComp :: Dur t 
    => [SliceSeg t] -> (t, t) -> Bool

isSlicePrim = isSlice (\a b -> not $ within a b)
isSliceComp = isSlice outside

isSlice :: Dur t 
    => (Interval t -> Interval t -> Bool)
    -> [SliceSeg t] -> (t, t) -> Bool
isSlice pred xs dt = 
    case xs of
        []           -> False
        (d, lt) : ts -> 
            let dt' = appLinTfm lt dt
            in  if toInterval dt' `pred` (0, d)
                    then True
                    else isSlice pred ts dt'

-- Ctx

initCtx :: Dur t => Ctx t a a
initCtx = Ctx [] idTfm

shiftCtx :: Dur t => t -> Ctx t a b -> Ctx t a b
shiftCtx t = appendLinTfmCtx $ shiftLinTfm t

stretchCtx :: Dur t => t -> Ctx t a b -> Ctx t a b
stretchCtx t = appendLinTfmCtx $ stretchLinTfm t

sliceCtx :: Dur t => Interval t -> Ctx t a b -> Ctx t a b
sliceCtx (t0, t1) x = shiftCtx (-t0) $ x{
    ctxSlice = (totalDur, idLinTfm) : ctxSlice x}
    where totalDur = t1 - t0

reverseCtx :: Dur t => t -> Ctx t a b -> Ctx t a b
reverseCtx t = appendLinTfmCtx $ reverseLinTfm t

appendLinTfmCtx :: Dur t 
    => (LinTfm t -> LinTfm t) 
    -> Ctx t a b -> Ctx t a b
appendLinTfmCtx m x = appendSlice m $ x{ 
    ctxTfm = first m $ ctxTfm x }
    where appendSlice m x
            | null $ ctxSlice x = x
            | otherwise         = x{ 
                ctxSlice = onSeg m $ ctxSlice x}
          onSeg f (x:xs) = second f x : xs

appendFmapCtx :: Dur t => (a' -> a) -> Ctx t a b -> Ctx t a' b
appendFmapCtx = appendMapCtx . appendFmap

appendEmapCtx :: Dur t 
    => (Event t a' -> Event t a) 
    -> Ctx t a b -> Ctx t a' b
appendEmapCtx = appendMapCtx . appendEmap

appendMapCtx :: Dur t
    => (Tfm t a b -> Tfm t a' b)
    -> (Ctx t a b -> Ctx t a' b)
appendMapCtx f x = x{ ctxTfm = f $ ctxTfm x }