{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module Temporal.Media (
	-- * Time classes
	Dur(..), Temporal(..), Stretchable(..), 
	ToMaybe(..), TemporalFunctor(..), 
    Sustainable(..), sustain,
    TemporalStretchable(..),
    -- * Transformers
	Reversible(..), Sliceable(..), cut, 
	-- * Structure 
	Construct(..), Arrangeable(..),	Controlable(..),
	sequent, parallel, loop, delay, temp,
	-- * Media
	Media(..), fold, fromMedia,
	-- * Simple interperetation
	-- ** Event list
	Event, EventList(..), 
	mapEvent, toEvent, toEventList,
	-- ** Unit Temporal Media
	MediaUnit(..), unMediaUnit, foldU, fromMediaUnit,
	Unit(..),
    -- ** Misc
     tmapRel, dmapRel, tdmapRel,  tstretchRel, linseg
)
where

import Control.Applicative
import Control.Monad

import Data.Function
import Data.Ratio
import Data.Tree

import Prelude hiding (reverse, take, drop)
import qualified Prelude as P (reverse)

import Debug.Trace

debug msg x = trace (msg ++ " : " ++ show x) x

-------------------------------------------------
-- Classes
--
-------------------------------------------------
-- Time classes

-- | time class
class (Num t, Ord t, Fractional t) => Dur t

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

-- | Temporal structures
class Dur t => Temporal t a where
	none    :: t -> a        -- ^ absence of value
	dur     :: a -> t        -- ^ duration of value            

-- | Stretching values by given time-factor
class Temporal t a => Stretchable t a where
	stretch :: t -> a -> a       

-- | Values covertible to 'Maybe'	
--
--  auxiliary class for conversion to 'EventList'
class ToMaybe m where
	toMaybe :: m a -> Maybe a

-- | temporal map
--
-- minimal complete defenition : @tdmap@
class Dur t => TemporalFunctor t f where
    -- | map with time
    tmap :: (t -> a -> b) -> f a -> f b   
    -- | map with duration
    dmap :: (t -> a -> b) -> f a -> f b 

    -- | map with time and duration
    tdmap  :: (t -> t -> a -> b) -> f a -> f b

    tmap f = tdmap (flip $ const f)
    dmap f = tdmap (const f)

class Dur t => Sustainable t f where    
    -- | map with time and duration and transform duration time
    sustainBy :: (t -> t -> a -> (b, t)) -> f a -> f b

-- | adds constant amount of duration to all notes
sustain :: (Dur t, Sustainable t f) => t -> f a -> f a
sustain dt' = sustainBy $ \t dt x -> (x, dt + dt')


class Stretchable t a => TemporalStretchable t a where
    tstretch :: (t -> t) -> a -> a



---------------------------------------------------
-- transformers
--

class Reversible a where
	reverse :: a -> a

-- | extracting parts, minimal complete definition:  'slice'.
class Temporal t a => Sliceable t a where
	slice :: t -> t -> a -> a   -- ^ @slice t0 t1 v@ extracts part of @v@ inside @[t0, t1]@
	take  :: t -> a -> a        
	drop  :: t -> a -> a

	take t   = slice 0 t
	drop t x = slice t (dur x) x

sliceErrorMessage = error "should be t0 <= t1, for slice t0 t1" 

-- | mixing slice and reverse. 
--
-- @cut t0 t1 v@ - if @t1 < t0@ reverses result of 'slice'
cut :: (Reversible a, Sliceable t a) => t -> t -> a -> a
cut t0 t1 m
	| t0 <= t1  = slice t0 t1 m
	| otherwise = slice (tm - t0) (tm - t1) $ reverse m
	where tm = dur m

----------------------------------------------------
-- Structure
--

-- | constructor for generic structures
class Construct m where
	prim :: a -> m a

-- | composing structures in sequent and parallel ways 
class Arrangeable a where
	(+:+) :: a -> a -> a
	(=:=) :: a -> a -> a

-- | modifer
class Controlable c a where
	control :: c -> a -> a
	

sequent, parallel :: Arrangeable a => [a] -> a

sequent  = foldl1 (+:+)
parallel = foldl1 (=:=)

loop :: Arrangeable a => Int -> a -> a
loop n = sequent . replicate n 

delay :: (Temporal t a, Arrangeable a) => t -> a -> a
delay t x = none t +:+ x


-- | constructs generic temporal structure @m a@ form time @t@ and initial value @a@
temp :: (Construct m, Temporal t (m a), Stretchable t (m a))
	=> t -> a -> m a
temp t = stretch t . prim


----------------------------------------------------
-- Media

-- | Data type to represent temporal media
data Media c a = Prim a                        -- ^ single value
	       | Media c a :+: Media c a       -- ^ sequential composition
	       | Media c a :=: Media c a       -- ^ parallel composition
	       | Control c (Media c a)         -- ^ specific environment modifier
		deriving (Show, Eq)


-- | Folding Media
--
-- > fold prim seq par mod x
--
-- * prim - responds to 'Prim'
--
-- * seq  - responds to ':+:'
--
-- * par  - responds to ':=:'
--
-- * mod  - responds to 'Control'
fold :: (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (c -> b -> b) 
	-> Media c a -> b
fold prim seq par mod m = 
	case m of
		Prim a      -> prim a
		a :+: b     -> (seq `on` f) a b
		a :=: b     -> (par `on` f) a b
		Control c a -> mod c $ f a 
	where f = fold prim seq par mod
	


instance Functor (Media c) where
	fmap f x = case x of
			Prim a      -> Prim $ f a
			a :+: b     -> fmap f a :+: fmap f b
			a :=: b     -> fmap f a :=: fmap f b
			Control c a -> Control c $ fmap f a

instance Monad (Media c) where
	return   = Prim
	ma >>= f = case ma of
			Prim a      -> f a
			a :+: b     -> (a >>= f) :+: (b >>= f)
			a :=: b     -> (a >>= f) :=: (b >>= f)
			Control c a -> Control c $ a >>= f

instance Applicative (Media c) where
	pure  = return
	(<*>) = ap


-- time

instance Temporal t a => Temporal t (Media c a) where
	none      = Prim . none
	dur       = fold dur (+) max (const id)

instance Stretchable t a => Stretchable t (Media c a) where
	stretch d = fmap $ stretch d

instance Stretchable t a => TemporalStretchable t (Media c a) where
    tstretch f m = tdmapM (\t _ -> stretch $ f t) m
    
-- transformers

instance Reversible a => Reversible (Media c a) where
	reverse x = case x of
			Prim a      -> Prim $ reverse a
			a :+: b     -> ((:+:) `on` reverse) b a
			a :=: b     -> ((:=:) `on` reverse) a b
			Control c a -> Control c $ reverse a


instance Sliceable t a => Sliceable t (Media c a) where
	slice t0 t1 m 
	    | t1 < t0   = sliceErrorMessage
	    | t1 <= 0   = none $ (t1 - t0)
	    | t0 >= tm  = none $ (t1 - t0)
	    | t0 < 0    = none (abs t0) :+: slice 0 t1 m
	    | t1 > tm   = slice t0 tm m :+: none (t1 - tm)
	    | otherwise = case m of
                        Prim a      -> Prim $ slice t0 t1 a
                        a :+: b     -> sliceSeq t0 t1 a b 
                        a :=: b     -> ((:=:) `on` slice t0 t1) a b
                        Control c a -> Control c $ slice t0 t1 a
		where tm = dur m

sliceSeq :: Sliceable t a => t -> t -> Media c a -> Media c a -> Media c a
sliceSeq t0 t1 a b
	| t1 <= ta  = slice t0 t1 a
	| t0 >= ta  = slice (t0 - ta) (t1 - ta) b
	| otherwise = slice t0 ta a :+: slice 0 (t1 - ta) b
	where ta = dur a

	
-- Structure

instance Construct (Media c) where
	prim = Prim

instance Arrangeable (Media c a) where
	(+:+) = (:+:)
	(=:=) = (:=:)

instance Controlable c (Media c a) where
	control = Control

----------------------------------------------------
-- Meaning

-- | Media interpretation
--
-- given two functions (to convert elementary value @(a -> b)@, 
-- and to convert modifiers @(c -> b -> b)@) `fromMedia` interprets 'Media' structure
fromMedia :: Arrangeable b => (a -> b) -> (c -> b -> b) -> Media c a -> b
fromMedia prim mod = fold prim (+:+) (=:=) mod
	
--------------------------------------------------------------------------------------	
-- | Event type
--
-- @(t, dt, a)@ - value @a@ starts at @t@ and lasts for @dt@
type Event t a = (t, t, a)

-- | list of events with given total time
data EventList t a = EventList t [Event t a]
	deriving (Show, Eq)


toEvent :: (Temporal t (m a), ToMaybe m) => m a -> EventList t a
toEvent a = EventList (dur a) $ maybe [] (return . singleEvent) $ toMaybe a
	where singleEvent x = (0, dur a, x)

mapEvent :: Dur t => (a -> b) -> Event t a -> Event t b
mapEvent f (t, dt, a) = (t, dt, f a)

instance Dur t => Functor (EventList t) where
	fmap f (EventList t es) = EventList t $ fmap (mapEvent f) es

-- time

instance Dur t => Temporal t (EventList t a) where
	none t = EventList t []
	dur (EventList t _) = t

instance (Dur t, Stretchable t a) => Stretchable t (EventList t a) where
	stretch d (EventList t es) = EventList (d * t) $ map (stretchEvent d) es
		where stretchEvent d (t, dt, a) = (d * t, d * dt, stretch d a)

instance Dur t => TemporalFunctor t (EventList t) where
	tdmap f (EventList t es) = EventList t $ map (tmapEvent f) es
		where tmapEvent f (t, dt, a) = (t, dt, a') where a' = f t dt a

instance Dur t => Sustainable t (EventList t) where
	sustainBy f (EventList t es) = EventList t $ map (tmapEvent f) es
		where tmapEvent f (t, dt, a) = (t, dt', a') where (a', dt') = f t dt a



-- structure

instance Dur t => Construct (EventList t) where
	prim a = EventList 1 [(0, 1, a)]

instance Dur t => Arrangeable (EventList t a) where
	(EventList t es) +:+ (EventList t' es') = 
		EventList (t + t') (es ++ map (delayEvent t) es')
		where delayEvent d (t, dt, a) = (t + d, dt, a)
	(EventList t es) =:= (EventList t' es') =
		EventList (max t t') $ merge es es'
		where merge []  x = x
		      merge x  [] = x
                      merge (a@(ta, _, _):as) (b@(tb, _, _):bs) 
			| ta < tb   = a : merge as     (b:bs)
			| otherwise = b : merge (a:as) bs

instance Dur t => Controlable () (EventList t a) where
	control = const id

-- meaning

-- | converting to 'EventList'
--
-- 'toEventList' mapps generic temporal value @(m a)@ that can be 
-- represented with @(t, Maybe a)@ to 'EventList' 
toEventList :: (Temporal t (m a), ToMaybe m) 
	=> (c -> EventList t a -> EventList t a) 
	-> Media c (m a) -> EventList t a
toEventList = fromMedia toEvent

-------------------------------------------------------------------------
-------------------------------------------------------------------
-- Special case : Media with explicit time. Value is unit 
--

-- | Media with explicit time
--
-- Value is unit (undividable, invariant to reverse and time stretching) 
-- O(1) 'dur'
data Dur t => MediaUnit t c a = MediaUnit t (Media c (Unit t a))

unMediaUnit :: Dur t => MediaUnit t c a -> Media c (Unit t a)
unMediaUnit (MediaUnit _ m) = m


instance Dur t => Functor (MediaUnit t c) where
	fmap f (MediaUnit t m) = MediaUnit t $ fmap (fmap f) m


instance Dur t => Monad (MediaUnit t c) where
	return = MediaUnit 1 . return . return
	(MediaUnit t ma) >>= f = MediaUnit (dur ma') ma'
		where ma' = ft =<< ma
                      ft ta = case unMediaUnit . f <$> ta of
				(Unit t (Just a)) -> stretch t a
				(Unit t Nothing)  -> none t 

instance Dur t => Applicative (MediaUnit t c) where
	pure  = return
	(<*>) = ap


-- time 

instance Dur t => Temporal t (MediaUnit t c a) where
	none t              = MediaUnit t $ none t     
	dur (MediaUnit t _) = t

instance Dur t => Stretchable t (MediaUnit t c a) where
	stretch d (MediaUnit t m) = MediaUnit (t * d) $ stretch d m


instance Dur t => TemporalFunctor t (MediaUnit t c) where
    dmap f (MediaUnit t m) = MediaUnit t $ fmap (tmap f) m
    tdmap f (MediaUnit t m) = MediaUnit t $ tdmapM (\t dt -> fmap (f t dt)) m

instance Dur t => TemporalStretchable t (MediaUnit t c a) where
    tstretch f (MediaUnit _ m) = liftA2 MediaUnit dur id $ tstretch f m

instance Dur t => Sustainable t (MediaUnit t c) where
    sustainBy f (MediaUnit t m) = uncurry MediaUnit $ sustainByM f' m
        where f' t dt = liftA2 (,) (fu t dt) (ft t dt)
              ft t dt (Unit d a) = maybe dt (snd . f t dt) a  
              fu t dt = fmap (fst . f t dt) 


tdmapM :: Temporal t a => (t -> t -> a -> b) -> Media c a -> Media c b
tdmapM f m = fmap (\(t, dt, a) -> f t dt a) $ setEvents m

sustainByM :: (Stretchable t a, Stretchable t b) 
    => (t -> t -> a -> (b, t)) -> Media c a -> (t, Media c b)
sustainByM f m = (newDur t', rearrangeSustain t' m')
    where t' = setSustainDurs m'  
          m' = tdmapM (\t dt a -> (dt, f t dt a)) m

------------------------------------------------------------
-- time dependent mapping tools

setEvents :: Temporal t a => Media c a -> Media c (Event t a)
setEvents m = setTimes 0 (setDurs m) m

setDurs :: Temporal t a => Media c a -> Tree t
setDurs = fold prim seq par contr
    where prim  a   = Node (dur a) []
          seq   a b = Node (on (+) rootLabel a b) [a, b]
          par   a b = Node (on max rootLabel a b) [a, b]
          contr c a = Node (rootLabel a) [a]
         

setTimes :: Dur t => t -> Tree t -> Media c a -> Media c (Event t a)
setTimes t0 durTree m = 
    case m of
        Prim a  -> Prim (t0, rootLabel durTree, a)
        a :+: b -> setTimes t0 ta a :+: setTimes (t0 + rootLabel ta) tb b
        a :=: b -> on (:=:) (uncurry $ setTimes t0) (ta, a) (tb, b)
        Control c a -> Control c $ setTimes t0 ta a
    where sf = subForest durTree
          ta = sf !! 0
          tb = sf !! 1
    

rearrangeSustain :: Stretchable t a => Tree (t, t) -> Media c (t, (a, t)) -> Media c a
rearrangeSustain tr m = 
    case m of
        Prim a  -> Prim $ stretch (newDur tr / oldDur tr) $ fst $ snd a
        a :+: b -> (rearrangeSustainSeq dta dta' dtb dtb') (ra a) (rb b)
        a :=: b -> (rearrangeSustainPar dta dta' dtb dtb') (ra a) (rb b)
        Control c a -> Control c $ ra a
    where sf   = subForest tr
          dta  = oldDur $ sf !! 0
          dtb  = oldDur $ sf !! 1
          dta' = newDur $ sf !! 0
          dtb' = newDur $ sf !! 1
          ra   = rearrangeSustain $ sf !! 0
          rb   = rearrangeSustain $ sf !! 1

rearrangeSustainSeq :: Stretchable t a =>
    t -> t -> t -> t ->
    Media c a -> Media c a -> Media c a
rearrangeSustainSeq dta dta' dtb dtb' a b
    | dta' < dta = sequent [a, none (dta - dta'), b]
    | dta' > dta && dtab  > 0 = parallel [sequent [a, none dtab], delay dta b]
    | dta' > dta && dtab <= 0 = parallel [a, sequent [delay dta b, none (abs $ dtab)]]
    | otherwise  = sequent[a, b]
    where dtab = dta + dtb' - dta' 


rearrangeSustainPar :: Stretchable t a =>
    t -> t -> t -> t ->
    Media c a -> Media c a -> Media c a
rearrangeSustainPar dta dta' dtb dtb' a b  
    | dtab < 0  = parallel [sequent [a, none (abs dtab)], b]
    | otherwise = parallel [a, sequent [b, none (abs dtab)]]
    where dtab = dta' - dtb'



setSustainDurs :: Dur t => Media c (t, (a, t)) -> Tree (t, t)
setSustainDurs = fold prim seq par contr
    where prim  a   = Node (fst a, snd $ snd a) []
          seq   a b = Node (on (+) oldDur a b, oldDur a + newDur b) [a, b]
          par   a b = Node (on max oldDur a b, on max newDur a b)   [a, b]
          contr c a = Node (oldDur a, newDur a) [a]
         

oldDur = fst . rootLabel
newDur = snd . rootLabel

    
-- transformers

-- | 'fold' replica for MediaUnit
foldU :: Dur t => (t -> a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (c -> b -> b)
	       -> MediaUnit t c a -> Maybe b
foldU prim seq par mod = fold prim' (liftA2 seq) (liftA2 par) mod' . unMediaUnit
	where prim' (Unit t a) = prim t <$> a
	      mod' c = fmap (mod c)
	     	

instance Dur t => Reversible (MediaUnit t c a) where
    reverse (MediaUnit t m) = MediaUnit t $ snd $ fold prim seq par contr m
            where prim u@(Unit dt a) = (dt, Prim u)
                  seq (da, a) (db, b) = (da + db, b :+: a)
                  par (da, a) (db, b) = (\x -> (max da db, x)) $ 
                        (if (da < db) 
                         then delay (db - da) a =:= b
                         else a =:= delay (da - db) b)
                  contr c (da, a) = (da, Control c a)
                    

instance Dur t => Sliceable t (MediaUnit t c a) where
	slice t0 t1 (MediaUnit t a) = MediaUnit (t1 - t0) $ slice t0 t1 a

-- Structure

instance Dur t => Construct (MediaUnit t c) where
	prim = MediaUnit 1 . prim . prim

instance Dur t => Arrangeable (MediaUnit t c a) where
	a +:+ b = MediaUnit (on (+) dur a b) $ on (+:+) unMediaUnit a b
	a =:= b = MediaUnit (on max dur a b) $ on (=:=) unMediaUnit a b
	

instance Dur t => Controlable c (MediaUnit t c a) where
	control c (MediaUnit t a) = MediaUnit t $ control c a

-- meaning

-- | Interpretation of 'MediaUnit'
--
-- it relies on properties of 'Unit' (it's temporal and covertible to 'Maybe')
fromMediaUnit :: Dur t => (c -> EventList t a -> EventList t a) 
	-> MediaUnit t c a -> EventList t a
fromMediaUnit f = toEventList f . unMediaUnit

------------------------------------------------------------
-- Unit

-- | unit values that can happen and lasts for some time
data Dur t => Unit t a = Unit t (Maybe a)
	deriving (Show, Eq)

instance Dur t => Functor (Unit t) where
	fmap f (Unit t a) = Unit t $ fmap f a

instance Dur t => Monad (Unit t) where
	return   = prim 
	(Unit t a) >>= f = case fmap f a of
				Nothing         -> none t
				Just (Unit t' b) -> Unit (t * t') b

instance Dur t => Applicative (Unit t) where
	pure  = return
	(<*>) = ap

-- time 

instance Dur t => Temporal t (Unit t a) where
	none t = Unit t Nothing
	dur (Unit t _) = t

instance Dur t => Stretchable t (Unit t a) where
	stretch d (Unit t a) = Unit (d * t) a

instance Dur t => ToMaybe (Unit t) where
	toMaybe (Unit _ a) = a

instance Dur t => TemporalFunctor t (Unit t) where
    dmap f (Unit t a) = Unit t $ fmap (f t) a
    
    tdmap f (Unit dt a) = 
          case a of
            Just x  -> phi dt x
            Nothing -> Unit dt Nothing
         where phi t x = Unit t $ Just $ f 0 t x

-- Unit transformers

instance Dur t => Reversible (Unit t a) where
	reverse = id

instance Dur t => Sliceable t (Unit t a) where
	slice t0 t1 u@(Unit t a) 
		| t1 < t0          = sliceErrorMessage
		| t1 < (t - eps) || t0 > eps = none $ t1 - t0 
		| otherwise        = u
		where eps = 1e-6 

-- structure

instance Dur t => Construct (Unit t) where
	prim a = Unit 1 $ Just a

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

-- | relative tmap
--
-- time values are normalized by argument duration.
--
-- @Dur t => t inside [0, 1]@ where 1 is total duration of second argument
tmapRel :: (TemporalFunctor t f, Temporal t (f a)) => (t -> a -> b) -> f a -> f b
tmapRel f x = tmap (f . ( / dur x)) x

-- | relative dmap
--
-- time values are normalized by argument duration.
--
-- @Dur t => t inside [0, 1]@ where 1 is total duration of second argument
dmapRel :: (TemporalFunctor t f, Temporal t (f a)) => (t -> a -> b) -> f a -> f b
dmapRel f x = dmap (f . ( / dur x)) x

-- | relative tdmap
--
-- time values are normalized by argument duration.
--
-- @Dur t => t inside [0, 1]@ where 1 is total duration of second argument
tdmapRel :: (TemporalFunctor t f, Temporal t (f a)) => (t -> t -> a -> b) -> f a -> f b
tdmapRel f x = tdmap (on f ( / dur x)) x

-- | relative tstretch
tstretchRel :: (Temporal t a, TemporalStretchable t a) => (t -> t) -> a -> a
tstretchRel f x = tstretch (f . (/ dur x)) x

-- linear interpolation

linseg1 :: (Num t, Ord t, Fractional t) => (t, t, t) -> (t -> t)
linseg1 (a, dur, b) x = a + (b - a) * x / dur

-- | linear interpolation
--
-- 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)