-- 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