-- Copyright 2013 Evan Laforge -- This program is distributed under the terms of the GNU General Public -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt {-# LANGUAGE CPP #-} -- | Functions to handle tempo tracks. module Derive.Tempo ( with_tempo, with_absolute, with_hybrid #ifdef TESTING , tempo_to_warp #endif ) where import qualified Ui.ScoreTime as ScoreTime import qualified Derive.Derive as Derive import qualified Derive.Deriver.Internal as Internal import qualified Derive.Warp as Warp import qualified Perform.RealTime as RealTime import qualified Perform.Signal as Signal import Global import Types -- * normal -- | Warp a deriver with a tempo signal. -- -- Tempo is the tempo signal, which is the standard musical definition of -- tempo: trackpos over time. Warp is the time warping that the tempo -- implies, which is the integral of (1/tempo). with_tempo :: Monoid a => Bool -- ^ If this tempo track is the toplevel track, -- i.e. controls all other tracks in this block, then I noramlize to the -- block duration. See comment below. -> Maybe (ScoreTime, ScoreTime) -- ^ block start and end, used to normalize block duration to 0--1. If -- Nothing, don't normalize. -> Maybe TrackId -- ^ Needed to record this track in TrackWarps. It's optional because if -- there's no explicit tempo track there's an implicit tempo around the -- whole block, but the implicit one doesn't have a track of course. -> Signal.Tempo -> Derive.Deriver a -> Derive.Deriver a with_tempo :: forall a. Monoid a => Bool -> Maybe (ScoreTime, ScoreTime) -> Maybe TrackId -> Tempo -> Deriver a -> Deriver a with_tempo Bool toplevel Maybe (ScoreTime, ScoreTime) range Maybe TrackId maybe_track_id Tempo signal Deriver a deriver = do forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (forall {k} (kind :: k). Signal kind -> Bool Signal.zero_or_below Tempo signal) forall a b. (a -> b) -> a -> b $ forall a. HasCallStack => Text -> Deriver a Derive.throw Text "tempo signal crosses zero" let warp :: Warp warp = Tempo -> Warp tempo_to_warp Tempo signal Deriver a -> Deriver a stretch_to_1 <- forall a. Monoid a => Maybe (ScoreTime, ScoreTime) -> ((ScoreTime, ScoreTime) -> Deriver (Deriver a -> Deriver a, X)) -> Deriver (Deriver a -> Deriver a) get_stretch_to_1 Maybe (ScoreTime, ScoreTime) range forall a b. (a -> b) -> a -> b $ \(ScoreTime start, ScoreTime end) -> do let real_start :: X real_start = Warp -> ScoreTime -> X Warp.warp Warp warp ScoreTime start real_end :: X real_end = Warp -> ScoreTime -> X Warp.warp Warp warp ScoreTime end real_dur :: X real_dur = X real_end forall a. Num a => a -> a -> a - X real_start -- This is tricky. I want nested tempo tracks to be equivalent to -- nested blocks, so it would be as if the score starting at the tempo -- track below were in its own block. However, in that case there -- would have to be an intervening block call event, and its duration -- would be the duration of the current block, which would insert an -- extra stretch by block duration. So I simulate that by inserting -- the stretch here if this isn't the toplevel tempo track. -- -- Otherwise, I would have to get the really real_dur by looking it up -- in the warp of the parent tempo track, which is not the same as the -- global warp, so I'd have to store that somewhere, and it seems a lot -- more complicated. let stretch :: ScoreTime stretch = ScoreTime 1 forall a. Fractional a => a -> a -> a / X -> ScoreTime RealTime.to_score X real_dur forall a. Num a => a -> a -> a * if Bool toplevel then ScoreTime 1 else ScoreTime end forall a. Num a => a -> a -> a - ScoreTime start Deriver a -> Deriver a place <- forall a. ScoreTime -> X -> (a -> a) -> Deriver (a -> a) require_nonzero (ScoreTime end forall a. Num a => a -> a -> a - ScoreTime start) X real_dur forall a b. (a -> b) -> a -> b $ forall a. ScoreTime -> Deriver a -> Deriver a Derive.stretch ScoreTime stretch forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. ScoreTime -> Deriver a -> Deriver a Derive.at (- X -> ScoreTime RealTime.to_score X real_start) forall (m :: * -> *) a. Monad m => a -> m a return (Deriver a -> Deriver a place, X real_dur) Deriver a -> Deriver a stretch_to_1 forall a b. (a -> b) -> a -> b $ forall a. Warp -> Deriver a -> Deriver a Internal.warp Warp warp forall a b. (a -> b) -> a -> b $ do Maybe TrackId -> Deriver State Error () Internal.add_new_track_warp Maybe TrackId maybe_track_id Deriver a deriver tempo_to_warp :: Signal.Tempo -> Warp.Warp tempo_to_warp :: Tempo -> Warp tempo_to_warp Tempo sig -- Optimize for a constant (or missing) tempo. -- Tempo tracks have to start at x=0, since they are integrated. | Just Double y <- forall {k} (kind :: k). X -> Signal kind -> Maybe Double Signal.constant_val_from X 0 Tempo sig = ScoreTime -> Warp -> Warp Warp.stretch (Double -> ScoreTime ScoreTime.from_double forall a b. (a -> b) -> a -> b $ Double 1 forall a. Fractional a => a -> a -> a / Double y) Warp Warp.identity | Bool otherwise = Warp -> Warp Warp.from_signal Warp warp_sig where warp_sig :: Warp warp_sig = Tempo -> Warp Signal.integrate_inverse Tempo sig require_nonzero :: ScoreTime -> RealTime -> (a -> a) -> Derive.Deriver (a -> a) require_nonzero :: forall a. ScoreTime -> X -> (a -> a) -> Deriver (a -> a) require_nonzero ScoreTime block_dur X real_dur a -> a ok | ScoreTime block_dur forall a. Eq a => a -> a -> Bool == ScoreTime 0 = forall (m :: * -> *) a. Monad m => a -> m a return forall a. a -> a id | X real_dur forall a. Eq a => a -> a -> Bool == X 0 = forall a. HasCallStack => Text -> Deriver a Derive.throw forall a b. (a -> b) -> a -> b $ Text "real time of block with dur " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt ScoreTime block_dur forall a. Semigroup a => a -> a -> a <> Text " was zero" | Bool otherwise = forall (m :: * -> *) a. Monad m => a -> m a return a -> a ok {- | If a tempo track is the block's topmost, it needs to do some special stretching to normalize to a length of 1, regardless of the tempo. This is so that when the calling block stretches it to the duration of the event it winds up being the right length. This is skipped for the top level block or all pieces would last exactly 1 second. This is another reason every block must have a 'with_tempo' at the top. The normalization feature relies on every block having a tempo track as its top-level track. 'Derive.Call.BlockUtil.note_deriver' establishes this invariant. This only needs to apply to the top tempo track, but actually applies to all of them. The subsequent applications should have no effect because the duration is already normalized to 1. This is just because it seems a little complicated to get a flag in here about whether the track is the top one. 'Derive.Call.Block.d_block' might seem like a better place to normalize the duration, but it doesn't have the local warp yet. TODO relying on the stack seems a little implicit, would it be better to have an explicit flag? -} get_stretch_to_1 :: Monoid a => Maybe (ScoreTime, ScoreTime) -> ((ScoreTime, ScoreTime) -> Derive.Deriver (Derive.Deriver a -> Derive.Deriver a, RealTime)) -- ^ Take the block range, and return a transformer to properly place the -- block, and the RealTime duration of the block. -> Derive.Deriver (Derive.Deriver a -> Derive.Deriver a) get_stretch_to_1 :: forall a. Monoid a => Maybe (ScoreTime, ScoreTime) -> ((ScoreTime, ScoreTime) -> Deriver (Deriver a -> Deriver a, X)) -> Deriver (Deriver a -> Deriver a) get_stretch_to_1 Maybe (ScoreTime, ScoreTime) Nothing (ScoreTime, ScoreTime) -> Deriver (Deriver a -> Deriver a, X) _ = forall (m :: * -> *) a. Monad m => a -> m a return forall a. a -> a id get_stretch_to_1 (Just (ScoreTime, ScoreTime) range) (ScoreTime, ScoreTime) -> Deriver (Deriver a -> Deriver a, X) compute = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a ifM Deriver Bool Internal.is_root_block (forall (m :: * -> *) a. Monad m => a -> m a return forall a. a -> a id) forall a b. (a -> b) -> a -> b $ do (Deriver a -> Deriver a transform, X dur) <- (ScoreTime, ScoreTime) -> Deriver (Deriver a -> Deriver a, X) compute (ScoreTime, ScoreTime) range Deriver Mode Derive.get_mode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \Mode mode -> case Mode mode of Mode Derive.RealDurationQuery -> do X -> Deriver State Error () set_real_duration X dur forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a b. a -> b -> a const forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. Monad m => a -> m a return forall a. Monoid a => a mempty Mode _ -> forall (m :: * -> *) a. Monad m => a -> m a return Deriver a -> Deriver a transform set_real_duration :: RealTime -> Derive.Deriver () set_real_duration :: X -> Deriver State Error () set_real_duration X dur = (Collect -> Collect) -> Deriver State Error () Internal.modify_collect forall a b. (a -> b) -> a -> b $ \Collect collect -> Collect collect { collect_real_duration :: CallDuration X Derive.collect_real_duration = forall a. a -> CallDuration a Derive.CallDuration X dur } -- * absolute -- | Warp the deriver to have the given tempo like 'with_tempo', but override -- the existing warp instead of composing with it. -- -- This can be used to isolate the tempo from any tempo effects that may be -- going on. with_absolute :: Monoid a => Bool -> Maybe (ScoreTime, ScoreTime) -> Maybe TrackId -> Signal.Tempo -> Derive.Deriver a -> Derive.Deriver a with_absolute :: forall a. Monoid a => Bool -> Maybe (ScoreTime, ScoreTime) -> Maybe TrackId -> Tempo -> Deriver a -> Deriver a with_absolute Bool toplevel Maybe (ScoreTime, ScoreTime) range Maybe TrackId maybe_track_id Tempo signal Deriver a deriver = do forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool toplevel forall a b. (a -> b) -> a -> b $ forall a. HasCallStack => Text -> Deriver a Derive.throw Text "nested absolute tracks not supported yet, use 'with_tempo' as a model" let warp :: Warp warp = Tempo -> Warp tempo_to_warp Tempo signal Deriver a -> Deriver a place <- forall a. Monoid a => Maybe (ScoreTime, ScoreTime) -> ((ScoreTime, ScoreTime) -> Deriver (Deriver a -> Deriver a, X)) -> Deriver (Deriver a -> Deriver a) get_stretch_to_1 Maybe (ScoreTime, ScoreTime) range forall a b. (a -> b) -> a -> b $ \(ScoreTime block_start, ScoreTime block_end) -> do ScoreTime start <- X -> ScoreTime RealTime.to_score forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Time a => a -> Deriver X Derive.real (ScoreTime 0 :: ScoreTime) ScoreTime end <- X -> ScoreTime RealTime.to_score forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Time a => a -> Deriver X Derive.real (ScoreTime 1 :: ScoreTime) let real_end :: X real_end = Warp -> ScoreTime -> X Warp.warp Warp warp ScoreTime block_end let real_dur :: X real_dur = X real_end forall a. Num a => a -> a -> a - Warp -> ScoreTime -> X Warp.warp Warp warp ScoreTime block_start Deriver a -> Deriver a place <- forall a. ScoreTime -> X -> (a -> a) -> Deriver (a -> a) require_nonzero (ScoreTime block_end forall a. Num a => a -> a -> a - ScoreTime block_start) X real_dur forall a b. (a -> b) -> a -> b $ forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a Internal.place ScoreTime start ((ScoreTime end forall a. Num a => a -> a -> a - ScoreTime start) forall a. Fractional a => a -> a -> a / X -> ScoreTime RealTime.to_score X real_dur) forall (m :: * -> *) a. Monad m => a -> m a return (Deriver a -> Deriver a place, X real_dur) forall a. Deriver a -> Deriver a Internal.in_real_time forall a b. (a -> b) -> a -> b $ Deriver a -> Deriver a place forall a b. (a -> b) -> a -> b $ forall a. Warp -> Deriver a -> Deriver a Internal.warp Warp warp forall a b. (a -> b) -> a -> b $ do Maybe TrackId -> Deriver State Error () Internal.add_new_track_warp Maybe TrackId maybe_track_id Deriver a deriver -- * hybrid -- | This is like 'with_tempo', but zero tempo segments are played in absolute -- time. That is, they won't stretch along with the non-zero segments. This -- means the output will always be at least as long as the absolute sections, -- so a block call may extend past the end of its event. with_hybrid :: Monoid a => Bool -> Maybe (ScoreTime, ScoreTime) -> Maybe TrackId -> Signal.Tempo -> Derive.Deriver a -> Derive.Deriver a with_hybrid :: forall a. Monoid a => Bool -> Maybe (ScoreTime, ScoreTime) -> Maybe TrackId -> Tempo -> Deriver a -> Deriver a with_hybrid Bool toplevel Maybe (ScoreTime, ScoreTime) range Maybe TrackId maybe_track_id Tempo signal Deriver a deriver = do forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool toplevel forall a b. (a -> b) -> a -> b $ forall a. HasCallStack => Text -> Deriver a Derive.throw Text "nested hybrid tracks not supported yet, use 'with_tempo' as a model" forall a. HasCallStack => Text -> Deriver a Derive.throw Text "not implemented" -- let warp = tempo_to_score_warp signal -- place <- get_stretch_to_1 range $ \(block_start, block_end) -> do -- -- The special treatment of flat segments only works once: after that -- -- it's a normal warp and stretches like any other warp. So I can't -- -- normalize to 0--1 expecting the caller to have stretched to the -- -- right placement, as 'with_tempo' does. Instead, I have to -- -- derive the whole thing in real time, and stretch and shift to the -- -- expected time here. -- start <- RealTime.to_score <$> Derive.real (0 :: ScoreTime) -- end <- RealTime.to_score <$> Derive.real (1 :: ScoreTime) -- let block_dur = block_end - block_start -- let absolute = Signal.flat_duration (Score.warp_signal warp) -- real_dur = max (RealTime.from_score absolute) -- (Warp.warp warp block_dur) -- -- If the block's absolute time is greater than the time allotted, -- -- the non-absolute bits become infinitely fast. Infinitely fast -- -- is not very musically interesting, so I limit to very fast. -- -- TODO This should be configurable. -- stretch = if block_dur == absolute then 1 -- else max 0.001 $ (end - start - absolute) -- / (block_dur - absolute) -- -- TODO this is probably wrong for block_start > 0, but I don't care -- -- at the moment. -- place <- require_nonzero block_dur real_dur $ -- Internal.in_real_time . Derive.place start stretch -- . Derive.at (-block_start) -- return (place, real_dur) -- place $ hybrid_warp warp $ do -- Internal.add_new_track_warp maybe_track_id -- deriver -- where -- hybrid_warp warp = Internal.with_warp (\w -> compose w warp) -- -- This is like 'tempo_to_warp', but replaces zero tempo with -- -- zeroes instead of a minimum, as is expected by 'Signal.compose_hybrid'. -- tempo_to_score_warp :: Signal.Tempo -> Score.Warp -- tempo_to_score_warp sig = Score.Warp (hybrid_to_warp sig) 0 1 -- hybrid_to_warp :: Signal.Tempo -> Signal.Warp -- hybrid_to_warp = Signal.integrate Signal.tempo_srate -- . Signal.map_y (\y -> if y == 0 then 0 else 1 / y) -- -- Like 'Score.compose_warps', but use 'Signal.compose_hybrid'. It also -- -- can't use the id signal optimization, since that only works with normal -- -- composition. -- compose w1 w2 = Score.Warp (Signal.compose_hybrid s1 s2) 0 1 -- where -- s1 = Score.warp_to_signal w1 -- s2 = Score.warp_to_signal w2