{-# Language BangPatterns #-} -- | A library for creating lists of constant time events related in time. module Temporal.Media( -- * Introduction -- | "Temporal.Media" is a library 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 'Track'. It provides interface -- to compose list of events. -- * Types Event(..), Track, dur, within, eventEnd, -- * Composition temp, stretch, delay, reflect, (+|), (*|), (=:=), (+:+), (=:/), line, chord, chordT, loop, rest, sustain, sustainT, -- * Filtering clip, takeT, dropT, filterEvents, -- * Mappings mapEvents, tmap, tmapRel, -- * Rendering render, alignByZero, sortEvents, -- * Monoid synonyms -- -- | This package heavily relies on 'Monoid's, so there are shorcuts -- for 'Monoid' methods. nil, module Data.Monoid, -- * Miscellaneous linseg, linsegRel ) where import Data.Monoid import Data.Foldable(Foldable(foldMap)) import Control.Applicative import Data.List(sortBy) import Data.Ord(comparing) -- TODO : optimise loops -- reflect ??? -- Monoid shortcuts -- | Synonym for method 'mempty'. nil :: Monoid a => a nil = mempty ---------------------------------------------- -- Track -- | 'Track' is a set of 'Event' s. There is total duration -- of the track, but Events can go beyond the scope of total duration -- (as a result of 'mapEvents' function). Total duration is used in sequent -- composition of tracks. data Track t a = Track t (TList t a) deriving (Show, Eq) instance Functor (Track t) where fmap f (Track d es) = Track d $ fmap f es instance Real t => Monoid (Track t a) where mempty = Track 0 mempty mappend (Track d es) (Track d' es') = Track (max d d') $ mappend es es' -- | Calculates track's duration. dur :: Track t a -> t dur (Track d _) = d -- | Stretches track in time domain. stretch :: Real t => t -> Track t a -> Track t a stretch k (Track d es) = Track (k*d) $ stretchTList k es -- | Delays all events by given duration. delay :: Real t => t -> Track t a -> Track t a delay k (Track d es) = Track (k+d) $ delayTList k es -- | Infix 'delay' function. (+|) :: Real t => t -> Track t a -> Track t a (+|) = delay -- | Infix 'stretch' function. (*|) :: Real t => t -> Track t a -> Track t a (*|) = stretch -- | Parallel composition. Play two tracks simultaneously. (=:=) :: (Real t) => Track t a -> Track t a -> Track t a a =:= b = a <> b -- | Sequent composition. Play first track then second. (+:+) :: (Real t) => Track t a -> Track t a -> Track t a a +:+ b = a <> delay (dur a) b -- | Turncating parallel composition. Total duration -- equals to minimum of the two tracks. All events -- that goes beyond the lmimt are dropped. (=:/) :: (Real t) => Track t a -> Track t a -> Track t a a =:/ b = clip 0 (dur a `min` dur b) $ a <> b -- | Parallel composition on list of tracks. chord :: (Real t, Ord t) => [Track t a] -> Track t a chord = mconcat -- | Sequent composition on list of tracks. line :: (Real t) => [Track t a] -> Track t a line = foldr (+:+) nil -- | Turncating parallel composition on list of tracks. chordT :: (Real t) => [Track t a] -> Track t a chordT xs = clip 0 (minimum $ dur <$> xs) $ chord xs -- | Analog of 'replicate' function for tracks. Replicated -- tracks are played sequentially. loop :: (Real t) => Int -> Track t a -> Track t a loop n = line . replicate n -- | Reversing the tracks reflect :: (Real t) => Track t a -> Track t a reflect a = mapEvents (\e -> e{ eventStart = d - (eventStart e + eventDur e) }) a where d = dur a -- | Empty track that lasts for some time. rest :: (Real t) => t -> Track t a rest = flip delay nil instance Foldable (Track t) where foldMap f (Track _ x) = foldMap f x -- | 'clip' cuts piece of value within given time interval. -- for @('clip' 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)@. clip :: (Real t) => t -> t -> Track t a -> Track t a clip t0 t1 | t0 < t1 = clip' t0 t1 | otherwise = reflect . clip' t1 t0 clip' :: (Real t) => t -> t -> Track t a -> Track t a clip' t0 t1 = clipDur . delay (-t0) . filterEvents (within t0 t1) where clipDur (Track _ a) = Track (t1 - t0) a -- | @('takeT' t)@ is equivalent to @('clip' 0 t)@. takeT :: (Real t) => t -> Track t a -> Track t a takeT t1 = clip 0 t1 -- | @('dropT' t m)@ is equivalent to @('clip' t (dur a) a)@. dropT :: Real t => t -> Track t a -> Track t a dropT t0 a = clip t0 (dur a) a -- | 'temp' constructs just an event. -- Value of type a lasts for one time unit and starts at zero. temp :: (Real t) => a -> Track t a temp = Track 1 . Single -- | Get all events on recordered on the track. render :: Real t => Track t a -> [Event t a] render (Track d es) = renderTList es ----------------------------------------------- -- Event -- | 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) -- | End point of event (start time plus duration). 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 } -- | Tests if given 'Event' happens between two time stamps. 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 -- | General mapping. Mapps not only values but events. mapEvents :: Real t => (Event t a -> Event t b) -> Track t a -> Track t b mapEvents = onEvents . fmap -- | Filter track. filterEvents :: Real t => (Event t a -> Bool) -> Track t a -> Track t a filterEvents = onEvents . filter onEvents :: Real 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 -- | Mapps values and time stamps. tmap :: Real t => (Event t a -> b) -> Track t a -> Track t b tmap f = mapEvents $ \e -> e{ eventContent = f e } -- | Relative tmap. Time values are normalized by argument's duration. tmapRel :: (RealFrac t) => (Event t a -> b) -> Track t a -> Track t b tmapRel f x = tmap (f . stretchEvent (1 / dur x)) x -- | After this transformation events last longer -- by some constant amount of time. sustain :: Real t => t -> Track t a -> Track t a sustain a = mapEvents $ \e -> e{ eventDur = a + eventDur e } -- | Prolongated events can not exceed total track duration. -- All event are sustained but those that are close to -- end of the track are clipped. It resembles sustain on piano, -- when track ends you release the pedal. sustainT :: (Real t) => t -> Track t a -> Track t a sustainT a x = mapEvents (\e -> turncate $ e{ eventDur = a + eventDur e }) x where turncate e | eventEnd e > d = e{ eventDur = max 0 $ d - eventStart e } | otherwise = e d = dur x -- | Shifts all events so that minimal start time -- equals to zero if first event has negative start time. 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 } -- | Sorts all events by start time. sortEvents :: Ord t => [Event t a] -> [Event t a] sortEvents = sortBy (comparing eventStart) ----------------------------------------------- ----------------------------------------------- -- Temporal List data TList t a = Empty | Single a | Append (TList t a) (TList t a) | TFun (Tfm t) (TList t a) deriving (Show, Eq) 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 instance Functor (TList t) where fmap f = foldT Empty (Single . f) Append TFun 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 instance Foldable (TList t) where foldMap f = foldT mempty f mappend (flip const) 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) -- transformation -- it's a pair of (stretch factor, delay offset) 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 -- composition on transformations: -- s2 `composeTfm` s1 composeTfm :: Num t => Tfm t -> Tfm t -> Tfm t composeTfm (Tfm s2 d2) (Tfm s1 d1) = Tfm (s1*s2) (d1*s2 + d2) --------------------------------------------------------------- -- Misc -- | Linear interpolation. Can be useful with 'mapEvents' 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) -- | With 'linsegRel' you can make linear interpolation -- function that has equal distance between points. -- First argument gives total length of the interpolation function -- and second argument gives list of values. So call -- -- > linsegRel dur [a1, a2, a3, ..., aN] -- -- is equivalent to: -- -- > linseg [a1, dur/N, a2, dur/N, a3, ..., dur/N, aN] linsegRel :: (Ord t, Fractional t) => t -> [t] -> t -> t linsegRel dur xs = linseg $ init $ f =<< xs where dt = dur / (fromIntegral $ length xs) f x = [x, dt]