module Temporal.Media(
Dur(..), Media, Event(..), EventList(..),
none, temp,
(+:+), (=:=), (=:/),
sequent, parallel, parallelT,
delay, loop,
stretch,
reverseM,
slice, takeM, dropM,
eventMap,
tmap, dmap, tdmap,
tmapRel, dmapRel, tdmapRel,
dur, renderMedia,
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)
class (Ord a, Num a, Fractional a) => Dur a
instance Dur Double
instance Dur Float
instance Integral a => Dur (Ratio a)
data Media t a = Media t (M t a)
data M t a where
None :: t -> M t a
Prim :: t -> a -> M t a
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
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
Fmap :: (a' -> a) -> M t a' -> M t a
Emap :: (Event t a' -> Event t a) -> M t a' -> M t a
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
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
none :: Dur t => t -> Media t a
none d
| d >= 0 = Media d $ None d
| otherwise = msgDurErr
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"
dur :: Media t a -> t
dur (Media t _) = t
unM :: Media t a -> M t a
unM (Media _ x) = x
(+:+) :: 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')]
(=:=) :: 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')]
(=:/) :: Dur t => Media t a -> Media t a -> Media t a
a =:/ b = parallelT [a, b]
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 :: 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 :: 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
parallelT :: Dur t => [Media t a] -> Media t a
parallelT xs = slice 0 d $ parallel xs
where d = minimum $ map dur xs
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)
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 :: 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 :: Dur t => t -> Media t a -> Media t a
takeM t = slice 0 t
dropM :: Dur t => t -> Media t a -> Media t a
dropM t x = slice t (dur x) x
reverseM :: Media t a -> Media t a
reverseM (Media t a) = Media t $
case a of
Reverse x -> x
_ -> Reverse a
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
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
tmap :: (t -> a -> b) -> Media t a -> Media t b
tmap f = tdmap (flip $ const f)
dmap :: (t -> a -> b) -> Media t a -> Media t b
dmap f = tdmap (const f)
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
tmapRel :: Dur t => (t -> a -> b) -> Media t a -> Media t b
tmapRel f x = tmap (f . ( / dur x)) x
dmapRel :: Dur t => (t -> a -> b) -> Media t a -> Media t b
dmapRel f x = dmap (f . ( / dur x)) x
tdmapRel :: Dur t => (t -> t -> a -> b) -> Media t a -> Media t b
tdmapRel f x = tdmap (on f ( / dur x)) x
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)
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
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
Seq xs -> renderSeq ctx xs
Par xs -> renderPar ctx xs
Loop n x -> renderLoop totalDur ctx n x
Stretch d x -> renderStretch ctx d x
Slice dt x -> renderSlice dt ctx x
Reverse x -> renderReverse totalDur ctx x
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
loopIds :: Dur t => [SliceSeg t] -> Int -> t -> [(LoopSeg, t)]
loopIds f n d = catMaybes $ map phi [0 .. n1]
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
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)
}
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)
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
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)
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'
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 }