temporal-media 0.2.1 → 0.3.0
raw patch · 3 files changed
+278/−545 lines, 3 filesdep −dlist
Dependencies removed: dlist
Files
- LICENSE +1/−1
- src/Temporal/Media.hs +273/−536
- temporal-media.cabal +4/−8
LICENSE view
@@ -1,4 +1,4 @@-Copyright Anton Kholomiov 2011+Copyright Anton Kholomiov 2011-2012 All rights reserved.
src/Temporal/Media.hs view
@@ -1,344 +1,352 @@-{-# LANGUAGE GADTs, BangPatterns #-}---- | An embedded domain-specific language (EDSL) for --- creating lists of constant time events related in time.--- Combinators are optimized in fusion style.+{-# Language + BangPatterns #-} +-- | A library for creating lists of constant time events related in time. module Temporal.Media( -- * Introduction - -- | "Temporal.Media" is an embedded domain-specific - -- language (EDSL) 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 -- fixed time. Library provides functions to build lists -- of such events with time-relations like sequent, -- parallel or delayed. --- -- Core type of library is 'Media'. It provides interface- -- to compose list of events. There is optimization that - -- goes on behind the scene. - --- -- * Fusion - --- -- >fmap f . fmap g - --- -- is trasformed to- --- -- >fmap (f . g) - --- -- same holds for more general 'eventMap'.- --- -- * Loops- --- -- Transformations on 'loop' 's are executed only for - -- one cycle.- --- -- * Structure functions- --- -- Structure functions ('sequent', 'parallel', - -- 'stretch', 'reverseM') are rendered as linear - -- transformations of time and duration of an event.- --- -- Example of usage can be found in package 'temporal-music-notation' [1].- -- Score module is based on this library.- --- -- \[1\] <http://hackage.haskell.org/package/temporal-music-notation>+ -- 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, - Dur(..), Media, Event(..), EventList(..),+ -- * 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 - -- * Constructors- - none, temp,+) where - -- * Composition+import Data.Monoid+import Data.Foldable(Foldable(foldMap)) - (+:+), (=:=), (=:/),- sequent, parallel, parallelT,- delay, loop,+import Control.Applicative - -- * Transformations- - stretch, - reverseM,- slice, takeM, dropM,+import Data.List(sortBy)+import Data.Ord(comparing) - -- * Mappings+-- TODO : optimise loops+-- reflect ??? - eventMap,- tmap, dmap, tdmap,- tmapRel, dmapRel, tdmapRel,+-- Monoid shortcuts - -- * Rendering- dur, renderMedia,+-- | Synonym for method 'mempty'.+nil :: Monoid a => a +nil = mempty - -- * Miscellaneous+----------------------------------------------+-- Track - linseg- )-where +-- | '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' -import Data.List(foldl')-import Data.Maybe(catMaybes)-import Data.Ratio(Ratio)-import Data.Function(on)+-- | Calculates track's duration.+dur :: Track t a -> t+dur (Track d _) = d -import Control.Arrow(first, second, (***))+-- | 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 -import Data.DList(DList, empty, singleton, append, fromList, toList)+-- | 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 ---import Debug.Trace+-- | Infix 'delay' function.+(+|) :: Real t => t -> Track t a -> Track t a +(+|) = delay ---debug :: Show a => String -> a -> a---debug str x = trace (str ++ " : " ++ show x) x+-- | Infix 'stretch' function.+(*|) :: Real t => t -> Track t a -> Track t a+(*|) = stretch --- | class of 'time' values-class (Ord a, Num a, Fractional a) => Dur a+-- | Parallel composition. Play two tracks simultaneously.+(=:=) :: (Real t) => Track t a -> Track t a -> Track t a+a =:= b = a <> b -instance Dur Double-instance Dur Float-instance Integral a => Dur (Ratio a)+-- | 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 --- | 'Media' is core data type. Essentially 'Media' provides --- functional interface to 'EventList' construction.-data Media t a = Media t (M t a) +-- | 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 --- | Media operations-data M t a where--- constructors- None :: t -> M t a- Prim :: t -> a -> M t a+-- | Parallel composition on list of tracks.+chord :: (Real t, Ord t) => [Track t a] -> Track t a+chord = mconcat --- composition- Seq :: [(t, M t a)] -> M t a- Par :: [(t, M t a)] -> M t a+-- | Sequent composition on list of tracks.+line :: (Real t) => [Track t a] -> Track t a+line = foldr (+:+) nil - Loop :: Int -> (t, M t a) -> M t a+-- | 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 --- transformation- Stretch :: t -> (t, M t a) -> M t a+-- | 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 - Slice :: Interval t -> (t, M t a) -> M t a- Reverse :: M t a -> M t a+-- | 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 --- mappings- Fmap :: (a' -> a) -> M t a' -> M t a- Emap :: (Event t a' -> Event t a) -> M t a' -> M t 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+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 (Event t d a) = Event t d $ f a+ fmap f e = e{ eventContent = f (eventContent e) } --- | List of 'Event' s. First argument stands for total duration--- of 'EventList'.-data EventList t a = EventList t [Event t a]- deriving (Show, Eq)+durEvent = eventDur+delayEvent d e = e{ eventStart = eventStart e + d }+stretchEvent d e = e{ eventStart = eventStart e * d,+ eventDur = eventDur e * d } -instance Functor (EventList t) where- fmap f (EventList t es) = EventList t $ map (fmap f) es+-- | 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 --- constructors +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 --- | 'none' constructs an empty event. --- Nothing is going on for a given time.-none :: Dur t => t -> Media t a -none d - | d >= 0 = Media d $ None d- | otherwise = msgDurErr --- | 'temp' constructs just an event. Value of type a--- lasts for some time.-temp :: Dur t => t -> a -> Media t a-temp d a - | d >= 0 = Media d $ Prim d a- | otherwise = msgDurErr+-- | 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 } -msgDurErr = error "duration must be non-negative"+-- | 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 --- duration querry --- | Duration querry.-dur :: Media t a -> t-dur (Media t _) = t+-- | 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 } -unM :: Media t a -> M t a-unM (Media _ x) = x+-- | 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 --- composition --- | Binary sequent composition. --- In @(a+:+b)@ @a@ happens first and then @b@ goes.-(+:+) :: 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')]+-- | 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 } --- | Binary parallel composition. --- In @(a=:=b)@ @a@ and @b@ happen simultaneously.-(=:=) :: 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')] +-- | Sorts all events by start time.+sortEvents :: Ord t => [Event t a] -> [Event t a]+sortEvents = sortBy (comparing eventStart) --- | Truncating binary composition. --- In @(a=:/b)@, @a@ and @b@ happen simultaneously but--- whole result lasts only for @min ('dur' a) ('dur' b)@ time. -(=:/) :: Dur t => Media t a -> Media t a -> Media t a-a =:/ b = parallelT [a, b]+-----------------------------------------------+-----------------------------------------------+-- Temporal List --- | 'delay' appends block of nothing of given duration --- to the begging of value (if duration is positive)--- or to the end of value (if duration is negative).-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+data TList t a = Empty+ | Single a+ | Append (TList t a) (TList t a)+ | TFun (Tfm t) (TList t a)+ deriving (Show, Eq) --- | Sequent composition on lists.-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 composition on lists.-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+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 --- | Truncating parallel composition on lists.-parallelT :: Dur t => [Media t a] -> Media t a-parallelT xs = slice 0 d $ parallel xs- where d = minimum $ map dur xs --- | 'loop' repeats sequentially given value.-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)+instance Monoid (TList t a) where+ mempty = Empty+ mappend Empty a = a+ mappend a Empty = a+ mappend a b = Append a b ---loop n = sequent . replicate n --- transformation+instance Functor (TList t) where+ fmap f = foldT Empty (Single . f) Append TFun --- | Stretching values by factor.-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) +durTList = maximum . fmap totalEventDur . renderTList + where totalEventDur = (+) <$> eventStart <*> eventDur --- | '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 --- @'abs' (t0 - t1)@.-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+stretchTList k x = case x of+ TFun t a -> TFun (stretchTfm k t) a+ Empty -> Empty+ a -> TFun (Tfm k 0) a --- | @('takeM' t)@ is equivalent to @('slice' 0 t)@.-takeM :: Dur t => t -> Media t a -> Media t a-takeM t = slice 0 t +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) --- | @('dropM' t m)@ is equivalent to @('slice' t (dur m) m)@.-dropM :: Dur t => t -> Media t a -> Media t a-dropM t x = slice t (dur x) x +renderTList :: Num t => TList t a -> [Event t a]+renderTList = ($[]) . foldMap (:) . eventList --- | Reverses input.-reverseM :: Media t a -> Media t a-reverseM (Media t a) = Media t $- case a of- Reverse x -> x- _ -> Reverse a+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)+ --- mappings +fromEventList :: [Event t a] -> TList t a+fromEventList = foldr (mappend . phi) mempty+ where phi e = TFun (tfmFromEvent e) (Single $ eventContent e) -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 +-- transformation +-- it's a pair of (stretch factor, delay offset)+data Tfm t = Tfm !t !t+ deriving (Show, Eq) --- | General mapping. In the end all values of type 'Media' --- are to be converted to 'EventList' wich is list of 'Event' s --- and function 'eventMap' allows mapping on 'Media' subvalues as if --- they are events already.------ Warning : It is possible to change start time position with --- 'eventMap' but it can lead to unexpected outcome when used --- with 'slice' function. 'slice' operates on structure of --- type 'Media' (how value was built with 'sequent', 'parallel'--- or 'stretch' and other functions), but 'eventMap' operates --- on 'Media' subvalues as if they are converted to 'Event' s --- and some shifted events can slip through 'slice' 's fingers.-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+unit :: Num t => Tfm t+unit = Tfm 1 0 --- | map with time-tmap :: (t -> a -> b) -> Media t a -> Media t b-tmap f = tdmap (flip $ const f)+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) --- | map with duration-dmap :: (t -> a -> b) -> Media t a -> Media t b-dmap f = tdmap (const f)+eventFromTfm :: Tfm t -> a -> Event t a+eventFromTfm (Tfm str del) = Event del str --- | map with time and duration -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+tfmFromEvent :: Event t a -> Tfm t+tfmFromEvent = Tfm <$> eventDur <*> eventStart --- | Relative 'tmap'. Time values are normalized by argument's duration. -tmapRel :: Dur t => (t -> a -> b) -> Media t a -> Media t b-tmapRel f x = tmap (f . ( / dur x)) x+-- 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) --- | Relative 'dmap'.-dmapRel :: Dur t => (t -> a -> b) -> Media t a -> Media t b-dmapRel f x = dmap (f . ( / dur x)) x --- | Relative 'tdmap'. -tdmapRel :: Dur t => (t -> t -> a -> b) -> Media t a -> Media t b-tdmapRel f x = tdmap (on f ( / dur x)) x- --------------------------------------------------------------- -- Misc --- | Linear interpolation. Can be useful with 'eventMap' for +-- | Linear interpolation. Can be useful with 'mapEvents' for -- envelope changes. ----- linseg [a, da, b, db, c, ... ]+-- > linseg [a, da, b, db, c, ... ] -- -- @a, b, c ...@ - values --@@ -355,289 +363,18 @@ | t >= dur = b | otherwise = a + (b - a)*(t/dur) ------------------------------------------------------------------------------------------------------------------------------------- interpretation --- | 'renderMedia' converts values of type 'Media' to--- values of type 'EventList'. If some values have negative--- time (it is possible through 'eventMap') all events are --- shifted so that first event has zero start time. Events--- are unsorted by start time.-renderMedia :: Dur t => Media t a -> EventList t a-renderMedia (Media totalDur m) = formEventList totalDur es- where es = toList $ renderM totalDur initCtx m---formEventList :: Dur t - => t -> [Event t a] -> EventList t a-formEventList totalDur es = - EventList (t1 - t0) $ shiftEs es- where shiftEs- | t0 < 0 = map shiftEvent- | otherwise = id- shiftEvent e = e{eventStart = eventStart e - t0} - (t0, t1) = eventListScope totalDur es- --eventListScope :: Dur t => t -> [Event t a] -> Interval t-eventListScope d = foldl' phi (0, d)- where phi (a, b) (Event t d _) = (a', b')- where (!a', !b') = (min a t, max b $ t + d)---type MList t a = 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- -- constructors- None d -> empty- Prim d x -> if isSlicePrim (ctxSlice ctx) (0, totalDur)- then empty- else renderPrim (ctxTfm ctx) d x-- _ -> if isSliceComp (ctxSlice ctx) (0, totalDur)- then empty- else - case m of- -- composition- Seq xs -> renderSeq ctx xs- Par xs -> renderPar ctx xs-- Loop n x -> renderLoop totalDur ctx n x-- -- transformation - Stretch d x -> renderStretch ctx d x-- Slice dt x -> renderSlice dt ctx x- Reverse x -> renderReverse totalDur ctx x-- -- mappings- 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 = singleton $ appTfm tfm $ Event 0 d x---renderSeq :: Dur t => Ctx t a b -> [(t, M t a)] -> MList t b-renderSeq ctx = fst . foldl' phi (empty, 0)- where phi (res, d') (d, x) = (\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 = foldl' phi empty - where phi res (d, x) = append res $ renderM d ctx x---- !bug! (t0, t1) t1 updates while shifting the loop-renderLoop :: Dur t- => t -> Ctx t a b -> Int -> (t, M t a) -> MList t b-renderLoop totalDur ctx n (d, x) = foldl' phi empty ids - where e = renderM d initCtx x- ids = loopIds (ctxSlice ctx) n d - phi res (segType, ds) = append res $- case segType of- Part -> renderM d (ctx' ds) x- Whole -> fmap (shiftSeg ds) e- where ctx' ds = shiftCtx ds ctx- shiftSeg ds = appTfm $ ctxTfm $ ctx' ds--data LoopSeg = Part | Whole---- ineffective / consider better solution--loopIds :: Dur t => [SliceSeg t] -> Int -> t -> [(LoopSeg, t)] -loopIds f n d = catMaybes $ map phi [0 .. n-1]- 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------------------------------------------------------------ utils---- Types--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)- }---------------------------------------------------------------- funs on---- LinTfm--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) - --- Tfm--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 ---- Interval--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)---- SliceSeg--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'---- Ctx--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 }-+-- | 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]
temporal-media.cabal view
@@ -1,5 +1,5 @@ Name: temporal-media-Version: 0.2.1+Version: 0.3.0 License-file: LICENSE Cabal-Version: >= 1.2 License: BSD3@@ -9,12 +9,7 @@ Description: An embedded domain-specific language (EDSL) for creating lists of constant time events related in time.- Combinators are optimized in fusion style.-- Ispired by the paper /An Algebraic Theory of Polymorphic Temporal Media/, - Paul Hudak - <http://haskell.cs.yale.edu/yale/papers/polymedia/hudak-RR-1259.pdf>, - Haskore and Hommage+ Category: Media, Music Stability: Experimental@@ -24,7 +19,8 @@ Library Build-Depends:- base >= 4, base < 5, dlist >= 0.5+ base >= 4, base < 5 Hs-Source-Dirs: src/+ Exposed-Modules: Temporal.Media