module Temporal.Media(
Event(..), Track, within, eventEnd,
module Temporal.Class,
temp, fromEvent, singleEvent, reflect, (=:/),
harT, sustain, sustainT,
melTemp, harTemp, harTMap,
slice, takeT, dropT, filterEvents,
mapEvents, traverseEvents, tmap, tmapRel,
render, alignByZero, sortEvents,
nil,
module Data.Monoid,
linfun, linfunRel
) where
import Data.Monoid
import Data.Boolean
import Data.Foldable(Foldable(foldMap))
import Data.Traversable
import Control.Applicative hiding ((<*))
import Data.List(sortBy)
import Data.Ord(comparing)
import Temporal.Class
nil :: Monoid a => a
nil = mempty
data Track t a = Track t (TList t a)
deriving (Show, Eq, Functor, Foldable, Traversable)
instance (Num t, IfB t, OrdB t) => Monoid (Track t a) where
mempty = Track 0 mempty
mappend (Track d es) (Track d' es') =
Track (maxB d d') $ mappend es es'
type instance DurOf (Track t a) = t
instance Duration (Track t a) where
dur (Track d _) = d
instance Num t => Stretch (Track t a) where
str k (Track d es) = Track (k*d) $ stretchTList k es
instance Num t => Delay (Track t a) where
del k (Track d es) = Track (k+d) $ delayTList k es
(=:/) :: (Real t, IfB t, OrdB t) => Track t a -> Track t a -> Track t a
a =:/ b = slice 0 (dur a `minB` dur b) $ a <> b
instance (Num t, IfB t, OrdB t) => Melody (Track t a) where
mel = foldr (+:+) nil
a +:+ b = a <> del (dur a) b
instance (Num t, IfB t, OrdB t) => Harmony (Track t a) where
har = mconcat
a =:= b = a <> b
instance (Num t, IfB t, OrdB t) => Compose (Track t a) where
harT :: (Real t, IfB t, OrdB t) => [Track t a] -> Track t a
harT xs = slice 0 (minimum $ dur <$> xs) $ har xs
melTemp :: (Num t, IfB t, OrdB t) => [a] -> Track t a
melTemp = melMap temp
harTemp :: (Num t, IfB t, OrdB t) => [a] -> Track t a
harTemp = harMap temp
harTMap :: (Real t, IfB t, OrdB t) => (a -> Track t b) -> [a] -> Track t b
harTMap f xs = harT $ fmap f xs
reflect :: (Num t, IfB t, OrdB t) => Track t a -> Track t a
reflect a = mapEvents
(\e -> e{ eventStart = d (eventStart e + eventDur e) }) a
where d = dur a
instance (Num t, IfB t, OrdB t) => Rest (Track t a) where
rest = flip del nil
slice :: (Real t) => t -> t -> Track t a -> Track t a
slice t0 t1 = (slice' t0 t1)
slice' :: (Real t) => t -> t -> Track t a -> Track t a
slice' t0 t1 = sliceDur . del (t0) . filterEvents (within t0 t1)
where sliceDur (Track _ a) = Track (t1 t0) a
takeT :: (Real t) => t -> Track t a -> Track t a
takeT t1 = slice 0 t1
dropT :: Real t => t -> Track t a -> Track t a
dropT t0 a = slice t0 (dur a) a
temp :: (Num t) => a -> Track t a
temp = Track 1 . Single
fromEvent :: Num t => Event t a -> Track t a
fromEvent (Event start duration content) = singleEvent start duration content
singleEvent :: Num t => t -> t -> a -> Track t a
singleEvent start duration content = del start $ str duration $ temp content
render :: (Num t) => Track t a -> [Event t a]
render (Track d es) = renderTList es
data Event t a = Event {
eventStart :: t,
eventDur :: t,
eventContent :: a
} deriving (Show, Eq)
eventEnd :: Num t => Event t a -> t
eventEnd e = eventStart e + eventDur e
instance Functor (Event t) where
fmap f e = e{ eventContent = f (eventContent e) }
durEvent = eventDur
delayEvent d e = e{ eventStart = eventStart e + d }
stretchEvent d e = e{ eventStart = eventStart e * d,
eventDur = eventDur e * d }
within :: (Real t) => t -> t -> Event t a -> Bool
within t0 t1 e = within' t0 t1 (eventStart e) && within' t0 t1 (eventEnd e)
where within' a b x = x >= a && x <= b
mapEvents :: Num t => (Event t a -> Event t b) -> Track t a -> Track t b
mapEvents = onEvents . fmap
traverseEvents :: (Num t1, Applicative f) => (t1 -> f t2) -> (Event t1 a -> f (Event t2 b)) -> Track t1 a -> f (Track t2 b)
traverseEvents df f t = Track <$> (df $ dur t) <*> (fmap fromEventList $ traverse f $ render t)
filterEvents :: Real t => (Event t a -> Bool) -> Track t a -> Track t a
filterEvents = onEvents . filter
onEvents :: Num t => ([Event t a] -> [Event t b]) -> Track t a -> Track t b
onEvents phi t@(Track d es) = Track d $ fromEventList $ phi $ render t
tmap :: Real t => (Event t a -> b) -> Track t a -> Track t b
tmap f = mapEvents $ \e -> e{ eventContent = f e }
tmapRel :: (RealFrac t) => (Event t a -> b) -> Track t a -> Track t b
tmapRel f x = tmap (f . stretchEvent (1 / dur x)) x
sustain :: Num t => t -> Track t a -> Track t a
sustain a = mapEvents $ \e -> e{ eventDur = a + eventDur e }
sustainT :: (Ord t, Num t) => t -> Track t a -> Track t a
sustainT a x = mapEvents (\e -> truncate $ e{ eventDur = a + eventDur e }) x
where truncate e
| eventEnd e > d = e{ eventDur = max 0 $ d eventStart e }
| otherwise = e
d = dur x
alignByZero :: (Real t) => [Event t a] -> [Event t a]
alignByZero es
| minT < 0 = alignEvent <$> es
| otherwise = es
where minT = minimum $ eventStart <$> es
alignEvent e = e{ eventStart = eventStart e minT }
sortEvents :: Ord t => [Event t a] -> [Event t a]
sortEvents = sortBy (comparing eventStart)
data TList t a = Empty
| Single a
| Append (TList t a) (TList t a)
| TFun (Tfm t) (TList t a)
deriving (Show, Eq, Functor, Foldable, Traversable)
foldT :: b -> (a -> b) -> (b -> b -> b) -> (Tfm t -> b -> b)
-> TList t a -> b
foldT empty single append tfun x = case x of
Empty -> empty
Single a -> single a
Append a b -> append (f a) (f b)
TFun t a -> tfun t (f a)
where f = foldT empty single append tfun
instance Monoid (TList t a) where
mempty = Empty
mappend Empty a = a
mappend a Empty = a
mappend a b = Append a b
durTList = maximum . fmap totalEventDur . renderTList
where totalEventDur = (+) <$> eventStart <*> eventDur
stretchTList k x = case x of
TFun t a -> TFun (stretchTfm k t) a
Empty -> Empty
a -> TFun (Tfm k 0) a
delayTList k x = case x of
TFun t a -> TFun (delayTfm k t) a
Empty -> Empty
a -> TFun (Tfm 1 k) a
renderTList :: Num t => TList t a -> [Event t a]
renderTList = ($[]) . foldMap (:) . eventList
eventList :: Num t => TList t a -> TList t (Event t a)
eventList = iter unit
where iter !tfm x = case x of
Empty -> Empty
Single a -> Single (eventFromTfm tfm a)
TFun t a -> iter (tfm `composeTfm` t) a
Append a b -> Append (iter tfm a) (iter tfm b)
fromEventList :: [Event t a] -> TList t a
fromEventList = foldr (mappend . phi) mempty
where phi e = TFun (tfmFromEvent e) (Single $ eventContent e)
data Tfm t = Tfm !t !t
deriving (Show, Eq)
unit :: Num t => Tfm t
unit = Tfm 1 0
durTfm (Tfm str del) = str + del
stretchTfm k (Tfm str del) = Tfm (k*str) (k*del)
delayTfm k (Tfm str del) = Tfm str (k+del)
eventFromTfm :: Tfm t -> a -> Event t a
eventFromTfm (Tfm str del) = Event del str
tfmFromEvent :: Event t a -> Tfm t
tfmFromEvent = Tfm <$> eventDur <*> eventStart
composeTfm :: Num t => Tfm t -> Tfm t -> Tfm t
composeTfm (Tfm s2 d2) (Tfm s1 d1) = Tfm (s1*s2) (d1*s2 + d2)
linfun :: (Ord t, Fractional t) => [t] -> t -> t
linfun 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 linfun (b:x:xs') (t dur)
where seg a dur b t
| t < 0 = a
| t >= dur = b
| otherwise = a + (b a)*(t/dur)
linfunRel :: (Ord t, Fractional t) => t -> [t] -> t -> t
linfunRel dur xs = linfun $ init $ f =<< xs
where dt = dur / (fromIntegral $ length xs)
f x = [x, dt]