temporal-media 0.0 → 0.1.0

raw patch · 3 files changed

+274/−31 lines, 3 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• src/Temporal/Media.hs +230/−22
• src/Temporal/Media/Double.hs +42/−7
• temporal-media.cabal +2/−2

@@ -2,8 +2,10 @@ module Temporal.Media ( 	-- * Time classes 	Dur(..), Temporal(..), Stretchable(..), -	ToMaybe(..), TemporalFunctor(..),-	-- * Transformers+	ToMaybe(..), TemporalFunctor(..), +    Sustainable(..), sustain,+    TemporalStretchable(..),+    -- * Transformers 	Reversible(..), Sliceable(..), cut,  	-- * Structure  	Construct(..), Arrangeable(..),	Controlable(..),@@ -16,7 +18,9 @@ 	mapEvent, toEvent, toEventList, 	-- ** Unit Temporal Media 	MediaUnit(..), unMediaUnit, foldU, fromMediaUnit,-	Unit(..)+	Unit(..),+    -- ** Misc+     tmapRel, dmapRel, tdmapRel,  tstretchRel, linseg ) where @@ -25,10 +29,15 @@  import Data.Function import Data.Ratio+import Data.Tree  import Prelude hiding (reverse, take, drop) import qualified Prelude as P (reverse) +import Debug.Trace++debug msg x = trace (msg ++ " : " ++ show x) x+ ------------------------------------------------- -- Classes --@@ -47,7 +56,7 @@ 	dur     :: a -> t        -- ^ duration of value              -- | Stretching values by given time-factor-class Dur t => Stretchable t a where+class Temporal t a => Stretchable t a where 	stretch :: t -> a -> a         -- | Values covertible to 'Maybe'	@@ -57,9 +66,34 @@ 	toMaybe :: m a -> Maybe a  -- | temporal map+--+-- minimal complete defenition : @tdmap@ class Dur t => TemporalFunctor t f where-	tmap :: (t -> a -> b) -> f a -> f b+    -- | map with time+    tmap :: (t -> a -> b) -> f a -> f b   +    -- | map with duration+    dmap :: (t -> a -> b) -> f a -> f b  +    -- | map with time and duration+    tdmap  :: (t -> t -> a -> b) -> f a -> f b++    tmap f = tdmap (flip $ const f)+    dmap f = tdmap (const f)++class Dur t => Sustainable t f where    +    -- | map with time and duration and transform duration time+    sustainBy :: (t -> t -> a -> (b, t)) -> f a -> f b++-- | adds constant amount of duration to all notes+sustain :: (Dur t, Sustainable t f) => t -> f a -> f a+sustain dt' = sustainBy $ \t dt x -> (x, dt + dt')+++class Stretchable t a => TemporalStretchable t a where+    tstretch :: (t -> t) -> a -> a+++ --------------------------------------------------- -- transformers --@@ -186,7 +220,9 @@ instance Stretchable t a => Stretchable t (Media c a) where 	stretch d = fmap $ stretch d -+instance Stretchable t a => TemporalStretchable t (Media c a) where+    tstretch f m = tdmapM (\t _ -> stretch $ f t) m+     -- transformers  instance Reversible a => Reversible (Media c a) where@@ -232,7 +268,7 @@ ---------------------------------------------------- -- Meaning --- | Media imterpretation+-- | Media interpretation -- -- given two functions (to convert elementary value @(a -> b)@,  -- and to convert modifiers @(c -> b -> b)@) `fromMedia` interprets 'Media' structure@@ -271,9 +307,15 @@ 		where stretchEvent d (t, dt, a) = (d * t, d * dt, stretch d a)  instance Dur t => TemporalFunctor t (EventList t) where-	tmap f (EventList t es) = EventList t $ map (tmapEvent f) es-		where tmapEvent f (t, dt, a) = (t, dt, f dt a)+	tdmap f (EventList t es) = EventList t $ map (tmapEvent f) es+		where tmapEvent f (t, dt, a) = (t, dt, a') where a' = f t dt a +instance Dur t => Sustainable t (EventList t) where+	sustainBy f (EventList t es) = EventList t $ map (tmapEvent f) es+		where tmapEvent f (t, dt, a) = (t, dt', a') where (a', dt') = f t dt a+++ -- structure  instance Dur t => Construct (EventList t) where@@ -348,8 +390,102 @@   instance Dur t => TemporalFunctor t (MediaUnit t c) where-	tmap f (MediaUnit t m) = MediaUnit t $ fmap (tmap f) m +    dmap f (MediaUnit t m) = MediaUnit t $ fmap (tmap f) m+    tdmap f (MediaUnit t m) = MediaUnit t $ tdmapM (\t dt -> fmap (f t dt)) m +instance Dur t => TemporalStretchable t (MediaUnit t c a) where+    tstretch f (MediaUnit _ m) = liftA2 MediaUnit dur id $ tstretch f m++instance Dur t => Sustainable t (MediaUnit t c) where+    sustainBy f (MediaUnit t m) = uncurry MediaUnit $ sustainByM f' m+        where f' t dt = liftA2 (,) (fu t dt) (ft t dt)+              ft t dt (Unit d a) = maybe dt (snd . f t dt) a  +              fu t dt = fmap (fst . f t dt) +++tdmapM :: Temporal t a => (t -> t -> a -> b) -> Media c a -> Media c b+tdmapM f m = fmap (\(t, dt, a) -> f t dt a) $ setEvents m++sustainByM :: (Stretchable t a, Stretchable t b) +    => (t -> t -> a -> (b, t)) -> Media c a -> (t, Media c b)+sustainByM f m = (newDur t', rearrangeSustain t' m')+    where t' = setSustainDurs m'  +          m' = tdmapM (\t dt a -> (dt, f t dt a)) m++------------------------------------------------------------+-- time dependent mapping tools++setEvents :: Temporal t a => Media c a -> Media c (Event t a)+setEvents m = setTimes 0 (setDurs m) m++setDurs :: Temporal t a => Media c a -> Tree t+setDurs = fold prim seq par contr+    where prim  a   = Node (dur a) []+          seq   a b = Node (on (+) rootLabel a b) [a, b]+          par   a b = Node (on max rootLabel a b) [a, b]+          contr c a = Node (rootLabel a) [a]+         ++setTimes :: Dur t => t -> Tree t -> Media c a -> Media c (Event t a)+setTimes t0 durTree m = +    case m of+        Prim a  -> Prim (t0, rootLabel durTree, a)+        a :+: b -> setTimes t0 ta a :+: setTimes (t0 + rootLabel ta) tb b+        a :=: b -> on (:=:) (uncurry $ setTimes t0) (ta, a) (tb, b)+        Control c a -> Control c $ setTimes t0 ta a+    where sf = subForest durTree+          ta = sf !! 0+          tb = sf !! 1+    ++rearrangeSustain :: Stretchable t a => Tree (t, t) -> Media c (t, (a, t)) -> Media c a+rearrangeSustain tr m = +    case m of+        Prim a  -> Prim $ stretch (newDur tr / oldDur tr) $ fst $ snd a+        a :+: b -> (rearrangeSustainSeq dta dta' dtb dtb') (ra a) (rb b)+        a :=: b -> (rearrangeSustainPar dta dta' dtb dtb') (ra a) (rb b)+        Control c a -> Control c $ ra a+    where sf   = subForest tr+          dta  = oldDur $ sf !! 0+          dtb  = oldDur $ sf !! 1+          dta' = newDur $ sf !! 0+          dtb' = newDur $ sf !! 1+          ra   = rearrangeSustain $ sf !! 0+          rb   = rearrangeSustain $ sf !! 1++rearrangeSustainSeq :: Stretchable t a =>+    t -> t -> t -> t ->+    Media c a -> Media c a -> Media c a+rearrangeSustainSeq dta dta' dtb dtb' a b+    | dta' < dta = sequent [a, none (dta - dta'), b]+    | dta' > dta && dtab  > 0 = parallel [sequent [a, none dtab], delay dta b]+    | dta' > dta && dtab <= 0 = parallel [a, sequent [delay dta b, none (abs $ dtab)]]+    | otherwise  = sequent[a, b]+    where dtab = dta + dtb' - dta' +++rearrangeSustainPar :: Stretchable t a =>+    t -> t -> t -> t ->+    Media c a -> Media c a -> Media c a+rearrangeSustainPar dta dta' dtb dtb' a b  +    | dtab < 0  = parallel [sequent [a, none (abs dtab)], b]+    | otherwise = parallel [a, sequent [b, none (abs dtab)]]+    where dtab = dta' - dtb'++++setSustainDurs :: Dur t => Media c (t, (a, t)) -> Tree (t, t)+setSustainDurs = fold prim seq par contr+    where prim  a   = Node (fst a, snd $ snd a) []+          seq   a b = Node (on (+) oldDur a b, oldDur a + newDur b) [a, b]+          par   a b = Node (on max oldDur a b, on max newDur a b)   [a, b]+          contr c a = Node (oldDur a, newDur a) [a]+         ++oldDur = fst . rootLabel+newDur = snd . rootLabel++     -- transformers  -- | 'fold' replica for MediaUnit@@ -361,7 +497,15 @@ 	     	  instance Dur t => Reversible (MediaUnit t c a) where-	reverse (MediaUnit t m) = MediaUnit t $ reverse $ m+    reverse (MediaUnit t m) = MediaUnit t $ snd $ fold prim seq par contr m+            where prim u@(Unit dt a) = (dt, Prim u)+                  seq (da, a) (db, b) = (da + db, b :+: a)+                  par (da, a) (db, b) = (\x -> (max da db, x)) $ +                        (if (da < db) +                         then delay (db - da) a =:= b+                         else a =:= delay (da - db) b)+                  contr c (da, a) = (da, Control c a)+                      instance Dur t => Sliceable t (MediaUnit t c a) where 	slice t0 t1 (MediaUnit t a) = MediaUnit (t1 - t0) $ slice t0 t1 a@@ -372,16 +516,9 @@ 	prim = MediaUnit 1 . prim . prim  instance Dur t => Arrangeable (MediaUnit t c a) where-	a +:+ b = MediaUnit (dur a + dur b) $ (unMediaUnit a) +:+ (unMediaUnit b)-	a =:= b -	     | ta < tb   = f tb (a' +:+ none (tb - ta)) b'-	     | ta > tb   = f ta (b' +:+ none (ta - tb)) a'-	     | otherwise = f ta a' b'-		where ta = dur a-		      tb = dur b-		      a' = unMediaUnit a-		      b' = unMediaUnit b-		      f t a b = MediaUnit t $ a =:= b+	a +:+ b = MediaUnit (on (+) dur a b) $ on (+:+) unMediaUnit a b+	a =:= b = MediaUnit (on max dur a b) $ on (=:=) unMediaUnit a b+	  instance Dur t => Controlable c (MediaUnit t c a) where 	control c (MediaUnit t a) = MediaUnit t $ control c a@@ -428,7 +565,13 @@ 	toMaybe (Unit _ a) = a  instance Dur t => TemporalFunctor t (Unit t) where-	tmap f (Unit t a) = Unit t $ fmap (f t) a+    dmap f (Unit t a) = Unit t $ fmap (f t) a+    +    tdmap f (Unit dt a) = +          case a of+            Just x  -> phi dt x+            Nothing -> Unit dt Nothing+         where phi t x = Unit t $ Just $ f 0 t x  -- Unit transformers @@ -446,4 +589,69 @@  instance Dur t => Construct (Unit t) where 	prim a = Unit 1 $ Just a++-----------------------------------------------------------+-----------------------------------------------------------+-- Misc+--++-- | relative tmap+--+-- time values are normalized by argument duration.+--+-- @Dur t => t inside [0, 1]@ where 1 is total duration of second argument+tmapRel :: (TemporalFunctor t f, Temporal t (f a)) => (t -> a -> b) -> f a -> f b+tmapRel f x = tmap (f . ( / dur x)) x++-- | relative dmap+--+-- time values are normalized by argument duration.+--+-- @Dur t => t inside [0, 1]@ where 1 is total duration of second argument+dmapRel :: (TemporalFunctor t f, Temporal t (f a)) => (t -> a -> b) -> f a -> f b+dmapRel f x = dmap (f . ( / dur x)) x++-- | relative tdmap+--+-- time values are normalized by argument duration.+--+-- @Dur t => t inside [0, 1]@ where 1 is total duration of second argument+tdmapRel :: (TemporalFunctor t f, Temporal t (f a)) => (t -> t -> a -> b) -> f a -> f b+tdmapRel f x = tdmap (on f ( / dur x)) x++-- | relative tstretch+tstretchRel :: (Temporal t a, TemporalStretchable t a) => (t -> t) -> a -> a+tstretchRel f x = tstretch (f . (/ dur x)) x++-- linear interpolation++linseg1 :: (Num t, Ord t, Fractional t) => (t, t, t) -> (t -> t)+linseg1 (a, dur, b) x = a + (b - a) * x / dur++-- | linear interpolation+linseg :: (Num t, Ord t, Fractional t) => [t] -> t -> t+linseg ps x+    | x < 0     = head ps+    | otherwise = if null ds +                  then last ps+                  else flip f x $ head ds+    where ds  = offset x ps+          f ((k, _), p) x = linseg1 p $ x - k+   +offset :: (Num t, Ord t) => t -> [t] -> [((t, t), (t, t, t))]+offset x ps = dropWhile ((x > ) . snd . fst) $ zip (stamps ps') ps'+    where ps' = parts ps++stamps :: (Num t) => [(t, t, t)] -> [(t, t)]+stamps xs = P.reverse $ foldl f [(0, p)] xs+    where f ((a, b):res) x = (b, b + snd3 x):(a, b):res+          snd3 (_, a, _) = a+          p = snd3 $ head xs++parts :: [t] -> [(t, t, t)]+parts xs = +    case xs of+        (a:dur:b:[])      -> [(a, dur, b)] +        (a:dur:b:(x:xs')) -> (a, dur, b) : parts (b : x : xs')+        _                 -> error "linseg : length must be odd and greater than 2" 

@@ -2,8 +2,11 @@ -- | Special case of "Temporal.Media". Time is @Double@ module Temporal.Media.Double ( 	-- * Time classes-	Dur, none, dur, stretch, ToMaybe(..), tmap,-	-- * Transformers+	Dur, none, dur, stretch, ToMaybe(..), +    tmap, dmap, tdmap, +    sustain, sustainBy,+    tstretch, +    -- * Transformers 	Reversible(..), slice, take, drop, cut,  	-- * Structure  	Construct(..), Arrangeable(..), Controlable(..),@@ -16,7 +19,9 @@ 	mapEvent, toEvent, toEventList, 	-- ** Unit Media 	MediaUnit(..), unMediaUnit, foldU, fromMediaUnit,-	Unit(..)+	Unit(..),+    -- * Misc+    tmapRel, dmapRel, tdmapRel, tstretchRel, linseg )  where @@ -29,13 +34,14 @@ 	Reversible(..),  	Construct(..), Arrangeable(..), Controlable(..),  	sequent, parallel, loop,-	Media(..), fold, fromMedia)+	Media(..), fold, fromMedia, linseg)  ---------------------------------------- -- Time  -- -type Dur = Double+type Time = Double+type Dur  = Double  none :: M.Temporal Dur a => Dur -> a none = M.none@@ -46,9 +52,38 @@ stretch :: M.Stretchable Dur a => Dur -> a -> a stretch = M.stretch -tmap :: M.TemporalFunctor Dur f => (Dur -> a -> b) -> (f a -> f b)+-- | temporal stretch+tstretch :: M.TemporalStretchable Dur a => (Time -> Dur) -> a -> a+tstretch = M.tstretch++tstretchRel :: M.TemporalStretchable Dur a => (Time -> Dur) -> a -> a+tstretchRel = M.tstretchRel++tmap :: M.TemporalFunctor Dur f => (Time -> a -> b) -> (f a -> f b) tmap = M.tmap +dmap :: M.TemporalFunctor Dur f => (Dur -> a -> b) -> (f a -> f b)+dmap = M.dmap++tdmap :: M.TemporalFunctor Dur f => (Time -> Dur -> a -> b) -> (f a -> f b)+tdmap = M.tdmap+++tmapRel :: (M.Temporal Dur (f a), M.TemporalFunctor Dur f) => (Time -> a -> b) -> (f a -> f b)+tmapRel = M.tmapRel++dmapRel :: (M.Temporal Dur (f a), M.TemporalFunctor Dur f) => (Dur -> a -> b) -> (f a -> f b)+dmapRel = M.dmapRel++tdmapRel :: (M.Temporal Dur (f a), M.TemporalFunctor Dur f) => (Time -> Dur -> a -> b) -> (f a -> f b)+tdmapRel = M.tdmapRel++sustain :: M.Sustainable Dur f => Dur -> f a -> f a+sustain = M.sustain++sustainBy :: M.Sustainable Dur f => (Dur -> Dur -> a -> (b, Dur)) -> f a -> f b+sustainBy = M.sustainBy+ -------------------------------------------- -- transformers @@ -75,7 +110,7 @@ temp = M.temp 	 ---------------------------------------------+--------------------------------------------  -- EventList  type Event a     = M.Event Dur a

@@ -1,5 +1,5 @@ Name:          temporal-media-Version:       0.0+Version:       0.1.0 License-file:  LICENSE Cabal-Version: >= 1.2 License:       BSD3@@ -20,7 +20,7 @@  Library   Build-Depends:-        base >= 4, base < 5+        base >= 4, base < 5, containers >= 0.3   Hs-Source-Dirs:      src/   Exposed-Modules:         Temporal.Media