temporal-media-0.2.1: src/Temporal/Media.hs
{-# 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.
module Temporal.Media(
-- * Introduction
-- | "Temporal.Media" is an embedded domain-specific
-- language (EDSL) 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>
-- * Types
Dur(..), Media, Event(..), EventList(..),
-- * Constructors
none, temp,
-- * Composition
(+:+), (=:=), (=:/),
sequent, parallel, parallelT,
delay, loop,
-- * Transformations
stretch,
reverseM,
slice, takeM, dropM,
-- * Mappings
eventMap,
tmap, dmap, tdmap,
tmapRel, dmapRel, tdmapRel,
-- * Rendering
dur, renderMedia,
-- * Miscellaneous
linseg
)
where
import Data.List(foldl')
import Data.Maybe(catMaybes)
import Data.Ratio(Ratio)
import Data.Function(on)
import Control.Arrow(first, second, (***))
import Data.DList(DList, empty, singleton, append, fromList, toList)
--import Debug.Trace
--debug :: Show a => String -> a -> a
--debug str x = trace (str ++ " : " ++ show x) x
-- | class of 'time' values
class (Ord a, Num a, Fractional a) => Dur a
instance Dur Double
instance Dur Float
instance Integral a => Dur (Ratio a)
-- | 'Media' is core data type. Essentially 'Media' provides
-- functional interface to 'EventList' construction.
data Media t a = Media t (M t a)
-- | Media operations
data M t a where
-- constructors
None :: t -> M t a
Prim :: t -> a -> M t a
-- composition
Seq :: [(t, M t a)] -> M t a
Par :: [(t, M t a)] -> M t a
Loop :: Int -> (t, M t a) -> M t a
-- transformation
Stretch :: t -> (t, M t a) -> M t a
Slice :: Interval t -> (t, M t a) -> M t a
Reverse :: M t a -> M t a
-- mappings
Fmap :: (a' -> a) -> M t a' -> M t a
Emap :: (Event t a' -> Event t a) -> M t a' -> M t a
-- | 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)
instance Functor (Event t) where
fmap f (Event t d a) = Event t d $ f a
-- | List of 'Event' s. First argument stands for total duration
-- of 'EventList'.
data EventList t a = EventList t [Event t a]
deriving (Show, Eq)
instance Functor (EventList t) where
fmap f (EventList t es) = EventList t $ map (fmap f) es
------------------------------------------------------------
------------------------------------------------------------
-- constructors
-- | '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
msgDurErr = error "duration must be non-negative"
-- duration querry
-- | Duration querry.
dur :: Media t a -> t
dur (Media t _) = t
unM :: Media t a -> M t a
unM (Media _ x) = 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')]
-- | 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')]
-- | 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]
-- | '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
-- | 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
-- | 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)
--loop n = sequent . replicate n
-- transformation
-- | 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)
-- | '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
-- | @('takeM' t)@ is equivalent to @('slice' 0 t)@.
takeM :: Dur t => t -> Media t a -> Media t a
takeM t = slice 0 t
-- | @('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
-- | Reverses input.
reverseM :: Media t a -> Media t a
reverseM (Media t a) = Media t $
case a of
Reverse x -> x
_ -> Reverse a
-- mappings
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
-- | 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
-- | map with time
tmap :: (t -> a -> b) -> Media t a -> Media t b
tmap f = tdmap (flip $ const f)
-- | map with duration
dmap :: (t -> a -> b) -> Media t a -> Media t b
dmap f = tdmap (const f)
-- | 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
-- | 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
-- | 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
-- 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)
----------------------------------------------------------------
----------------------------------------------------------------
-- 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 }