module Temporal.Media (
Dur(..), Temporal(..), Stretchable(..),
ToMaybe(..), TemporalFunctor(..),
Sustainable(..), sustain,
TemporalStretchable(..),
Reversible(..), Sliceable(..), cut,
Construct(..), Arrangeable(..), Controlable(..),
sequent, parallel, loop, delay, temp,
Media(..), fold, fromMedia,
Event, EventList(..),
mapEvent, toEvent, toEventList,
MediaUnit(..), unMediaUnit, foldU, fromMediaUnit,
Unit(..),
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
class (Num t, Ord t, Fractional t) => Dur t
instance Dur Double
instance Integral a => Dur (Ratio a)
class Dur t => Temporal t a where
none :: t -> a
dur :: a -> t
class Temporal t a => Stretchable t a where
stretch :: t -> a -> a
class ToMaybe m where
toMaybe :: m a -> Maybe a
class Dur t => TemporalFunctor t f where
tmap :: (t -> a -> b) -> f a -> f b
dmap :: (t -> a -> b) -> f a -> f b
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
sustainBy :: (t -> t -> a -> (b, t)) -> f a -> f b
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
class Reversible a where
reverse :: a -> a
class Temporal t a => Sliceable t a where
slice :: t -> t -> a -> a
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"
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
class Construct m where
prim :: a -> m a
class Arrangeable a where
(+:+) :: a -> a -> a
(=:=) :: a -> a -> a
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
temp :: (Construct m, Temporal t (m a), Stretchable t (m a))
=> t -> a -> m a
temp t = stretch t . prim
data Media c a = Prim a
| Media c a :+: Media c a
| Media c a :=: Media c a
| Control c (Media c a)
deriving (Show, Eq)
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
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
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
| 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
instance Construct (Media c) where
prim = Prim
instance Arrangeable (Media c a) where
(+:+) = (:+:)
(=:=) = (:=:)
instance Controlable c (Media c a) where
control = Control
fromMedia :: Arrangeable b => (a -> b) -> (c -> b -> b) -> Media c a -> b
fromMedia prim mod = fold prim (+:+) (=:=) mod
type Event t a = (t, t, a)
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
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
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
toEventList :: (Temporal t (m a), ToMaybe m)
=> (c -> EventList t a -> EventList t a)
-> Media c (m a) -> EventList t a
toEventList = fromMedia toEvent
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
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
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
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
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
fromMediaUnit :: Dur t => (c -> EventList t a -> EventList t a)
-> MediaUnit t c a -> EventList t a
fromMediaUnit f = toEventList f . unMediaUnit
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
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
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
instance Dur t => Construct (Unit t) where
prim a = Unit 1 $ Just a
tmapRel :: (TemporalFunctor t f, Temporal t (f a)) => (t -> a -> b) -> f a -> f b
tmapRel f x = tmap (f . ( / dur x)) x
dmapRel :: (TemporalFunctor t f, Temporal t (f a)) => (t -> a -> b) -> f a -> f b
dmapRel f x = dmap (f . ( / dur x)) x
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
tstretchRel :: (Temporal t a, TemporalStretchable t a) => (t -> t) -> a -> a
tstretchRel f x = tstretch (f . (/ dur x)) x
linseg1 :: (Num t, Ord t, Fractional t) => (t, t, t) -> (t -> t)
linseg1 (a, dur, b) x = a + (b a) * x / dur
linseg :: (Num t, Ord t, Fractional t) => [t] -> t -> t
linseg ps x
| x < 0 = head ps
| otherwise = if null ds
then last ps
else flip f x $ head ds
where ds = offset x ps
f ((k, _), p) x = linseg1 p $ x k
offset :: (Num t, Ord t) => t -> [t] -> [((t, t), (t, t, t))]
offset x ps = dropWhile ((x > ) . snd . fst) $ zip (stamps ps') ps'
where ps' = parts ps
stamps :: (Num t) => [(t, t, t)] -> [(t, t)]
stamps xs = P.reverse $ foldl f [(0, p)] xs
where f ((a, b):res) x = (b, b + snd3 x):(a, b):res
snd3 (_, a, _) = a
p = snd3 $ head xs
parts :: [t] -> [(t, t, t)]
parts xs =
case xs of
(a:dur:b:[]) -> [(a, dur, b)]
(a:dur:b:(x:xs')) -> (a, dur, b) : parts (b : x : xs')
_ -> error "linseg : length must be odd and greater than 2"