temporal-media 0.6.2 → 0.6.3
raw patch · 2 files changed
+86/−55 lines, 2 files
Files
- src/Temporal/Media.hs +85/−54
- temporal-media.cabal +1/−1
src/Temporal/Media.hs view
@@ -1,22 +1,23 @@-{-# Language - BangPatterns, +{-# Language+ BangPatterns, TypeFamilies,- DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+ DeriveFunctor, DeriveFoldable, DeriveTraversable,+ CPP #-} -- | 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 + -- | "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 + -- 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. + -- 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. - + -- to compose list of events.+ -- * Types Event(..), Track, within, eventEnd, -- * Composition@@ -25,18 +26,18 @@ harT, sustain, sustainT, -- ** Common patterns melTemp, harTemp, harTMap,- + -- * Filtering- slice, takeT, dropT, filterEvents, + slice, takeT, dropT, filterEvents, -- * Mappings mapEvents, traverseEvents, tmap, tmapRel, -- * Rendering render, alignByZero, sortEvents,- + -- * Monoid synonyms -- -- | This package heavily relies on 'Monoid's, so there are shorcuts- -- for 'Monoid' methods. + -- for 'Monoid' methods. nil, module Data.Monoid, -- * Miscellaneous@@ -56,12 +57,12 @@ import Temporal.Class -- TODO : optimise loops--- reflect ??? +-- reflect ??? -- Monoid shortcuts -- | Synonym for method 'mempty'.-nil :: Monoid a => a +nil :: Monoid a => a nil = mempty ----------------------------------------------@@ -69,16 +70,31 @@ -- | '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. +-- (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, Functor, Foldable, Traversable) ++#if MIN_VERSION_base(4,11,0)+instance (Num t, IfB t, OrdB t) => Semigroup (Track t a) where+ x <> y = x `mappendTrack` y+ instance (Num t, IfB t, OrdB t) => Monoid (Track t a) where+ mempty = Track 0 mempty++#else++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'+ mappend = mappendTrack +#endif++mappendTrack :: (Num t, IfB t, OrdB t) => Track t a -> Track t a -> Track t a+mappendTrack (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@@ -88,7 +104,7 @@ instance Num t => Stretch (Track t a) where str k (Track d es) = Track (k*d) $ stretchTList k es --- | Delays all events by given duration. +-- | Delays all events by given duration. instance Num t => Delay (Track t a) where del k (Track d es) = Track (k+d) $ delayTList k es @@ -104,13 +120,13 @@ instance (Num t, IfB t, OrdB t) => Harmony (Track t a) where har = mconcat- a =:= b = a <> b + a =:= b = a <> b -instance (Num t, IfB t, OrdB t) => Compose (Track t a) where +instance (Num t, IfB t, OrdB t) => Compose (Track t a) where -- | Turncating parallel composition on list of tracks. harT :: (Real t, IfB t, OrdB t) => [Track t a] -> Track t a-harT xs = slice 0 (minimum $ dur <$> xs) $ har xs +harT xs = slice 0 (minimum $ dur <$> xs) $ har xs -- | Analog of 'replicate' function for tracks. Replicated -- tracks are played sequentially.@@ -129,7 +145,7 @@ -- | Reversing the tracks reflect :: (Num t, IfB t, OrdB t) => Track t a -> Track t a-reflect a = mapEvents +reflect a = mapEvents (\e -> e{ eventStart = d - (eventStart e + eventDur e) }) a where d = dur a @@ -140,7 +156,7 @@ -- | 'slice' cuts piece of value within given time interval. -- for @('slice' 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 +-- nothing inserted so that duration of result equals to -- @'abs' (t0 - t1)@. slice :: (Real t) => t -> t -> Track t a -> Track t a slice t0 t1 = (slice' t0 t1)@@ -157,7 +173,7 @@ dropT :: Real t => t -> Track t a -> Track t a dropT t0 a = slice t0 (dur a) a --- | 'temp' constructs just an event. +-- | 'temp' constructs just an event. -- Value of type a lasts for one time unit and starts at zero. temp :: (Num t) => a -> Track t a temp = Track 1 . Single@@ -172,19 +188,19 @@ singleEvent :: Num t => t -> t -> a -> Track t a singleEvent start duration content = del start $ str duration $ temp content --- | Get all events on recordered on the track. +-- | Get all events on recordered on the track. render :: (Num t) => Track t a -> [Event t a] render (Track d es) = renderTList es ----------------------------------------------- -- Event --- | Constant time events. Value @a@ starts at some time +-- | 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 + eventContent :: a } deriving (Show, Eq) -- | End point of event (start time plus duration).@@ -204,14 +220,14 @@ 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. Maps not only values but events. -mapEvents :: Num t => (Event t a -> Event t b) -> Track t a -> Track t b +-- | General mapping. Maps not only values but events.+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) --- | Filter track. +-- | Filter track. filterEvents :: Real t => (Event t a -> Bool) -> Track t a -> Track t a filterEvents = onEvents . filter @@ -223,7 +239,7 @@ 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. +-- | 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 @@ -234,7 +250,7 @@ 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 +-- All event are sustained but those that are close to -- end of the track are sliced. It resembles sustain on piano, -- when track ends you release the pedal. sustainT :: (Ord t, Num t) => t -> Track t a -> Track t a@@ -248,11 +264,11 @@ -- | 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 +alignByZero es | minT < 0 = alignEvent <$> es | otherwise = es where minT = minimum $ eventStart <$> es- alignEvent e = e{ eventStart = eventStart e - minT } + alignEvent e = e{ eventStart = eventStart e - minT } -- | Sorts all events by start time. sortEvents :: Ord t => [Event t a] -> [Event t a]@@ -269,7 +285,7 @@ deriving (Show, Eq, Functor, Foldable, Traversable) -foldT :: b -> (a -> b) -> (b -> b -> b) -> (Tfm t -> b -> b) +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@@ -279,13 +295,28 @@ where f = foldT empty single append tfun ++#if MIN_VERSION_base(4,11,0)+instance Semigroup (TList t a) where+ (<>) = mappendTList+ instance Monoid (TList t a) where- mempty = Empty- mappend Empty a = a- mappend a Empty = a- mappend a b = Append a b+ mempty = Empty -durTList = maximum . fmap totalEventDur . renderTList +#else++instance Monoid (TList t a) where+ mempty = Empty+ mappend = mappendTList++#endif++mappendTList :: TList t a -> TList t a -> TList t a+mappendTList Empty a = a+mappendTList a Empty = a+mappendTList a b = Append a b++durTList = maximum . fmap totalEventDur . renderTList where totalEventDur = (+) <$> eventStart <*> eventDur stretchTList k x = case x of@@ -296,26 +327,26 @@ delayTList k x = case x of TFun t a -> TFun (delayTfm k t) a Empty -> Empty- a -> TFun (Tfm 1 k) a + a -> TFun (Tfm 1 k) a renderTList :: Num t => TList t a -> [Event t a]-renderTList = ($[]) . foldMap (:) . eventList +renderTList = ($[]) . foldMap (:) . eventList -eventList :: Num t => TList t a -> TList t (Event t a) +eventList :: Num t => TList t a -> TList t (Event t a) eventList = iter unit- where iter !tfm x = case x of + where iter !tfm x = case x of Empty -> Empty Single a -> Single (eventFromTfm tfm a)- TFun t a -> iter (tfm `composeTfm` t) 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 +-- transformation -- it's a pair of (stretch factor, delay offset) data Tfm t = Tfm !t !t deriving (Show, Eq)@@ -325,7 +356,7 @@ 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) +delayTfm k (Tfm str del) = Tfm str (k+del) eventFromTfm :: Tfm t -> a -> Event t a eventFromTfm (Tfm str del) = Event del str@@ -342,7 +373,7 @@ --------------------------------------------------------------- -- Misc --- | Linear interpolation. Can be useful with 'mapEvents' for +-- | Linear interpolation. Can be useful with 'mapEvents' for -- envelope changes. -- -- > linfun [a, da, b, db, c, ... ]@@ -351,13 +382,13 @@ -- -- @da, db, ...@ - duration of segments linfun :: (Ord t, Fractional t) => [t] -> t -> t-linfun xs t = +linfun xs t = case xs of (a:dur:b:[]) -> seg a dur b t- (a:dur:b:(x:xs')) -> if t < dur + (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 + where seg a dur b t | t < 0 = a | t >= dur = b | otherwise = a + (b - a)*(t/dur)
temporal-media.cabal view
@@ -1,5 +1,5 @@ Name: temporal-media-Version: 0.6.2+Version: 0.6.3 License-file: LICENSE Cabal-Version: >= 1.6 License: BSD3