-- 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 #-}
{- | Derivers for control tracks.  That means tempo, control, and pitch.

    Control and pitch tracks can have a 'Derive.Merger'.  If no merger is
    given, they are combined with 'Derive.get_default_merger'.  @set@ will
    replace the signal.  So two tracks named @c@ will multiply, same as if the
    second were @mul c@.  If you want to override @c@ then @set c@ will do
    that.

    Tempo tracks don't support mergers because they are converted into
    a warp, which is then combined via composition.  Pitch tracks normally
    replace each other because adding together absolute pitches is undefined.
    Relative pitches can be added or multiplied, and this is expressed via
    normal controls using transposition signals like 'Controls.chromatic'.
-}
module Derive.Control (
    Config(..)
    , d_control_track
    , track_info
    -- * TrackSignal
    , stash_signal, render_of
#ifdef TESTING
    , derive_control
#endif
) where
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text

import qualified Util.Log as Log
import qualified Derive.Cache as Cache
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.EvalTrack as EvalTrack
import qualified Derive.Expr as Expr
import qualified Derive.LEvent as LEvent
import qualified Derive.PSignal as PSignal
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Stream as Stream
import qualified Derive.Tempo as Tempo

import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal
import qualified Ui.Block as Block
import qualified Ui.Track as Track
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Types as Types

import           Global
import           Types


data Config = Config {
    -- | True if this is the single topmost track and is a tempo track.
    -- Ultimately it'is used by "Derive.Tempo".
    Config -> Bool
config_toplevel_tempo :: !Bool
    , Config -> Bool
config_use_cache :: !Bool
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

-- | Top level deriver for control tracks.
{-# SCC d_control_track #-}
d_control_track :: Config -> TrackTree.Track -> Derive.NoteDeriver
    -> Derive.NoteDeriver
d_control_track :: Config -> Track -> NoteDeriver -> NoteDeriver
d_control_track Config
config Track
track NoteDeriver
deriver
    | (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
Char.isSpace Text
title = NoteDeriver
deriver
    | Bool
otherwise = do
        (ControlType
ctype, [Call]
expr) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"track title: " forall a. Semigroup a => a -> a -> a
<> Text
err)
            forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Either Text (ControlType, [Call])
ParseTitle.parse_control_title Text
title)
        Config
-> Track -> [Call] -> ControlType -> NoteDeriver -> NoteDeriver
eval_track Config
config Track
track [Call]
expr ControlType
ctype NoteDeriver
deriver
    where
    title :: Text
title = Track -> Text
TrackTree.track_title Track
track

-- * eval_track

eval_track :: Config -> TrackTree.Track -> [DeriveT.Call]
    -> ParseTitle.ControlType -> Derive.NoteDeriver -> Derive.NoteDeriver
eval_track :: Config
-> Track -> [Call] -> ControlType -> NoteDeriver -> NoteDeriver
eval_track Config
config Track
track [Call]
expr ControlType
ctype NoteDeriver
deriver = case ControlType
ctype of
    ParseTitle.Tempo Maybe Symbol
maybe_sym -> do
        Bool
is_ly <- Deriver Bool
Derive.is_lilypond_mode
        let sig_deriver :: Deriver State Error (Control, [Msg])
sig_deriver
                | Bool
is_ly = forall (m :: * -> *) a. Monad m => a -> m a
return (forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
1, [])
                | Bool
otherwise = forall a. Control -> Merger -> Deriver a -> Deriver a
with_control_env
                    Control
Controls.tempo (Text -> (Control -> Control -> Control) -> Y -> Merger
Derive.Merger Text
"compose" (forall a b. a -> b -> a
const forall a. a -> a
id) Y
0)
                    (forall a. Deriver a -> Deriver a
in_normal_mode forall a b. (a -> b) -> a -> b
$ Bool
-> Track
-> (ControlDeriver -> ControlDeriver)
-> Deriver State Error (Control, [Msg])
derive_control Bool
True Track
track forall d.
CallableExpr d =>
Deriver (Stream d) -> Deriver (Stream d)
transform)
        Config
-> Maybe Symbol
-> Track
-> Deriver State Error (Control, [Msg])
-> NoteDeriver
-> NoteDeriver
tempo_call Config
config Maybe Symbol
maybe_sym Track
track Deriver State Error (Control, [Msg])
sig_deriver NoteDeriver
deriver
    ParseTitle.Control (Right Typed Control
typed_control) Maybe Symbol
maybe_merge -> do
        let control :: Control
control = forall a. Typed a -> a
ScoreT.val_of Typed Control
typed_control
        Merger
merger <- Control -> Maybe Symbol -> Deriver Merger
get_merger Control
control Maybe Symbol
maybe_merge
        (Control
signal, [Msg]
logs) <- forall a. Control -> Merger -> Deriver a -> Deriver a
with_control_env Control
control Merger
merger
            (Bool
-> Track
-> (ControlDeriver -> ControlDeriver)
-> Deriver State Error (Control, [Msg])
derive_control Bool
False Track
track forall d.
CallableExpr d =>
Deriver (Stream d) -> Deriver (Stream d)
transform)
        Track
-> Typed Control
-> Merger
-> (Control, [Msg])
-> NoteDeriver
-> NoteDeriver
control_call Track
track Typed Control
typed_control Merger
merger (Control
signal, [Msg]
logs) NoteDeriver
deriver
    ParseTitle.Control (Left Symbol
tcall) Maybe Symbol
maybe_merge -> do
        (Typed Control
typed_control, Control
sig) <- forall d.
CallableExpr d =>
Symbol -> Track -> Deriver (Typed Control, d)
track_call Symbol
tcall Track
track
        Merger
merger <- Control -> Maybe Symbol -> Deriver Merger
get_merger (forall a. Typed a -> a
ScoreT.val_of Typed Control
typed_control) Maybe Symbol
maybe_merge
        Track
-> Typed Control
-> Merger
-> (Control, [Msg])
-> NoteDeriver
-> NoteDeriver
control_call Track
track Typed Control
typed_control Merger
merger (Control
sig, []) NoteDeriver
deriver
    ParseTitle.Pitch ScaleId
scale_id Either Symbol PControl
pcontrol_tcall -> case Either Symbol PControl
pcontrol_tcall of
        Right PControl
pcontrol -> Config
-> Track
-> PControl
-> ScaleId
-> (PitchDeriver -> PitchDeriver)
-> NoteDeriver
-> NoteDeriver
pitch_call Config
config Track
track PControl
pcontrol ScaleId
scale_id
            forall d.
CallableExpr d =>
Deriver (Stream d) -> Deriver (Stream d)
transform NoteDeriver
deriver
        -- TODO have to refactor pitch_call
        Left Symbol
_tcall -> forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"unimplemented"
    where
    transform :: Derive.CallableExpr d => Derive.Deriver (Stream.Stream d)
        -> Derive.Deriver (Stream.Stream d)
    transform :: forall d.
CallableExpr d =>
Deriver (Stream d) -> Deriver (Stream d)
transform = forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> [Call] -> Deriver (Stream d) -> Deriver (Stream d)
Eval.eval_transformers forall {a}. Context a
ctx [Call]
expr
    ctx :: Context a
ctx = forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
0 (Track -> ScoreTime
TrackTree.track_end Track
track) forall a b. (a -> b) -> a -> b
$ case ControlType
ctype of
        ParseTitle.Tempo {} -> Text
"tempo track"
        ParseTitle.Control {} -> Text
"control track"
        ParseTitle.Pitch {} -> Text
"pitch track"

track_call :: Derive.CallableExpr d => Expr.Symbol -> TrackTree.Track
    -> Derive.Deriver (ScoreT.Typed ScoreT.Control, d)
track_call :: forall d.
CallableExpr d =>
Symbol -> Track -> Deriver (Typed Control, d)
track_call Symbol
sym Track
track = do
    TrackCall d
call <- forall d. Callable (TrackCall d) => Symbol -> Deriver (TrackCall d)
Eval.get_track_call Symbol
sym
    forall d. TrackCall d -> TrackCallFunc d
Derive.tcall_func TrackCall d
call Track
track

-- | Switch 'Derive.RealDurationQuery' to 'Derive.Normal'.  A RealDurationQuery
-- needs to evaluate until the tempo track of the callee block.  But if I leave
-- it in RealDurationQuery mode, the calls on the tempo signal think I am
-- asking about their durations.
in_normal_mode :: Derive.Deriver a -> Derive.Deriver a
in_normal_mode :: forall a. Deriver a -> Deriver a
in_normal_mode Deriver a
deriver = 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 -> forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local
        (\Dynamic
st -> Dynamic
st { state_mode :: Mode
Derive.state_mode = Mode
Derive.Normal }) Deriver a
deriver
    Mode
_ -> Deriver a
deriver

-- | Get the combining operator for this track.
--
-- 'Controls.null' is used by control calls, and uses 'Derive.Set' by default.
-- Since the control call emits signal which then goes in a control track,
-- a merge operator would wind up being applied twice.
get_merger :: ScoreT.Control -> Maybe Expr.Symbol
    -> Derive.Deriver Derive.Merger
get_merger :: Control -> Maybe Symbol -> Deriver Merger
get_merger Control
control Maybe Symbol
merge = case Maybe Symbol
merge of
    Maybe Symbol
Nothing
        | Control
control forall a. Eq a => a -> a -> Bool
== Control
Controls.null -> forall (m :: * -> *) a. Monad m => a -> m a
return Merger
Derive.Set
        | Bool
otherwise -> Control -> Deriver Merger
Derive.get_default_merger Control
control
    Just Symbol
sym -> Symbol -> Deriver Merger
Derive.get_control_merge Symbol
sym

-- | A tempo track is derived like other signals, but in absolute time.
-- Otherwise it would wind up being composed with the environmental warp twice.
{-# SCC tempo_call #-}
tempo_call :: Config -> Maybe Expr.Symbol -> TrackTree.Track
    -> Derive.Deriver (TrackResults Signal.Control)
    -> Derive.NoteDeriver -> Derive.NoteDeriver
tempo_call :: Config
-> Maybe Symbol
-> Track
-> Deriver State Error (Control, [Msg])
-> NoteDeriver
-> NoteDeriver
tempo_call Config
config Maybe Symbol
sym Track
track Deriver State Error (Control, [Msg])
sig_deriver NoteDeriver
deriver = do
    (Control
signal, [Msg]
logs) <- forall a. Deriver a -> Deriver a
Internal.in_real_time forall a b. (a -> b) -> a -> b
$ do
        (Control
signal, [Msg]
logs) <- forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
EnvKey.control_gt_0 Bool
True Deriver State Error (Control, [Msg])
sig_deriver
        -- Do this in real time, so 'stash_if_wanted' knows it can directly
        -- reuse the signal.
        Track -> Control -> Deriver ()
stash_if_wanted Track
track Control
signal
        forall (m :: * -> *) a. Monad m => a -> m a
return (Control
signal, [Msg]
logs)

    -- The range is used by the tempo calls to normalize the block to 0--1.
    -- This should only happen for the tempo track at the top of the block.
    Maybe (ScoreTime, ScoreTime)
range <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> Deriver (ScoreTime, ScoreTime)
Internal.block_logical_range) forall a b. (a -> b) -> a -> b
$
        Track -> Maybe BlockId
TrackTree.track_block_id Track
track
    -- 'with_damage' must be applied *inside* 'Tempo.with_tempo'.  If it were
    -- outside, it would get the wrong RealTimes when it tried to create the
    -- ControlDamage.
    [Msg] -> NoteDeriver -> NoteDeriver
merge_logs [Msg]
logs forall a b. (a -> b) -> a -> b
$ forall a.
Monoid a =>
Config
-> Maybe Symbol
-> Maybe (ScoreTime, ScoreTime)
-> Maybe TrackId
-> Tempo
-> Deriver a
-> Deriver a
dispatch_tempo Config
config Maybe Symbol
sym Maybe (ScoreTime, ScoreTime)
range
        Maybe TrackId
maybe_track_id (forall {k1} {k2} (kind1 :: k1) (kind2 :: k2).
Signal kind1 -> Signal kind2
Signal.coerce Control
signal) (forall a. Deriver a -> Deriver a
with_damage NoteDeriver
deriver)
    where
    maybe_block_track_id :: Maybe (BlockId, TrackId)
maybe_block_track_id = Track -> Maybe (BlockId, TrackId)
TrackTree.block_track_id Track
track
    maybe_track_id :: Maybe TrackId
maybe_track_id = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (BlockId, TrackId)
maybe_block_track_id
    with_damage :: Deriver b -> Deriver b
with_damage = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall {b}. (BlockId, TrackId) -> Deriver b -> Deriver b
get_damage Maybe (BlockId, TrackId)
maybe_block_track_id
    get_damage :: (BlockId, TrackId) -> Deriver b -> Deriver b
get_damage (BlockId
block_id, TrackId
track_id) Deriver b
deriver = do
        ControlDamage
damage <- BlockId -> TrackId -> ScoreTime -> Events -> Deriver ControlDamage
Cache.get_tempo_damage BlockId
block_id TrackId
track_id
            (Track -> ScoreTime
TrackTree.track_end Track
track)
            (Track -> Events
TrackTree.track_events Track
track)
        forall derived. ControlDamage -> Deriver derived -> Deriver derived
Internal.with_control_damage ControlDamage
damage Deriver b
deriver

dispatch_tempo :: Monoid a => Config -> Maybe Expr.Symbol
    -> Maybe (ScoreTime, ScoreTime) -> Maybe TrackId -> Signal.Tempo
    -> Derive.Deriver a -> Derive.Deriver a
dispatch_tempo :: forall a.
Monoid a =>
Config
-> Maybe Symbol
-> Maybe (ScoreTime, ScoreTime)
-> Maybe TrackId
-> Tempo
-> Deriver a
-> Deriver a
dispatch_tempo Config
config Maybe Symbol
sym Maybe (ScoreTime, ScoreTime)
block_range Maybe TrackId
maybe_track_id Tempo
signal Deriver a
deriver =
    case Maybe Symbol
sym of
        Maybe Symbol
Nothing -> forall a.
Monoid a =>
Bool
-> Maybe (ScoreTime, ScoreTime)
-> Maybe TrackId
-> Tempo
-> Deriver a
-> Deriver a
Tempo.with_tempo Bool
toplevel Maybe (ScoreTime, ScoreTime)
block_range Maybe TrackId
maybe_track_id Tempo
signal
            Deriver a
deriver
        Just Symbol
sym
            | Symbol
sym forall a. Eq a => a -> a -> Bool
== Symbol
"hybrid" -> forall a.
Monoid a =>
Bool
-> Maybe (ScoreTime, ScoreTime)
-> Maybe TrackId
-> Tempo
-> Deriver a
-> Deriver a
Tempo.with_hybrid Bool
toplevel Maybe (ScoreTime, ScoreTime)
block_range
                Maybe TrackId
maybe_track_id Tempo
signal Deriver a
deriver
            | Symbol
sym forall a. Eq a => a -> a -> Bool
== Symbol
"abs" -> forall a.
Monoid a =>
Bool
-> Maybe (ScoreTime, ScoreTime)
-> Maybe TrackId
-> Tempo
-> Deriver a
-> Deriver a
Tempo.with_absolute Bool
toplevel Maybe (ScoreTime, ScoreTime)
block_range
                Maybe TrackId
maybe_track_id Tempo
signal Deriver a
deriver
            | Bool
otherwise -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$
                Text
"unknown tempo modifier: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Symbol
sym
    where toplevel :: Bool
toplevel = Config -> Bool
config_toplevel_tempo Config
config

{-# SCC control_call #-}
control_call :: TrackTree.Track -> ScoreT.Typed ScoreT.Control -> Derive.Merger
    -> TrackResults Signal.Control -> Derive.NoteDeriver -> Derive.NoteDeriver
control_call :: Track
-> Typed Control
-> Merger
-> (Control, [Msg])
-> NoteDeriver
-> NoteDeriver
control_call Track
track Typed Control
control Merger
merger (Control
signal, [Msg]
logs) NoteDeriver
deriver = do
    Track -> Control -> Deriver ()
stash_if_wanted Track
track Control
signal
    -- Apply and strip any control modifications made during the above derive.
    RealTime
end <- forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ Track -> ScoreTime
TrackTree.track_end Track
track
    forall a. RealTime -> Deriver a -> Deriver a
Derive.eval_control_mods RealTime
end forall a b. (a -> b) -> a -> b
$ [Msg] -> NoteDeriver -> NoteDeriver
merge_logs [Msg]
logs forall a b. (a -> b) -> a -> b
$ forall a. Deriver a -> Deriver a
with_damage forall a b. (a -> b) -> a -> b
$
        forall a.
Typed Control -> Merger -> Control -> Deriver a -> Deriver a
with_merger Typed Control
control Merger
merger Control
signal NoteDeriver
deriver
    -- I think this forces sequentialness because 'deriver' runs in the state
    -- from the end of 'sig_deriver'.  To make these parallelize, I need to
    -- run sig_deriver as a sub-derive, then mappend the Collect.
    where
    with_damage :: Deriver d -> Deriver d
with_damage = forall d.
Maybe (BlockId, TrackId)
-> (ScoreTime, ScoreTime) -> Deriver d -> Deriver d
with_control_damage
        (Track -> Maybe (BlockId, TrackId)
TrackTree.block_track_id Track
track) (Track -> (ScoreTime, ScoreTime)
TrackTree.track_range Track
track)

with_merger :: ScoreT.Typed ScoreT.Control -> Derive.Merger -> Signal.Control
    -> Derive.Deriver a -> Derive.Deriver a
with_merger :: forall a.
Typed Control -> Merger -> Control -> Deriver a -> Deriver a
with_merger (ScoreT.Typed Type
typ Control
control) Merger
merger Control
signal =
    forall a.
Merger -> Control -> Typed Control -> Deriver a -> Deriver a
Derive.with_merged_control Merger
merger Control
control (forall a. Type -> a -> Typed a
ScoreT.Typed Type
typ Control
signal)

merge_logs :: [Log.Msg] -> Derive.NoteDeriver -> Derive.NoteDeriver
merge_logs :: [Msg] -> NoteDeriver -> NoteDeriver
merge_logs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs

pitch_call :: Config -> TrackTree.Track -> ScoreT.PControl
    -> Pitch.ScaleId -> (Derive.PitchDeriver -> Derive.PitchDeriver)
    -> Derive.NoteDeriver -> Derive.NoteDeriver
pitch_call :: Config
-> Track
-> PControl
-> ScaleId
-> (PitchDeriver -> PitchDeriver)
-> NoteDeriver
-> NoteDeriver
pitch_call Config
config Track
track PControl
pcontrol ScaleId
scale_id PitchDeriver -> PitchDeriver
transform NoteDeriver
deriver =
    forall a. ScaleId -> Deriver a -> Deriver a
with_scale ScaleId
scale_id forall a b. (a -> b) -> a -> b
$ do
        (PSignal
signal, [Msg]
logs) <- forall a. PControl -> Deriver a -> Deriver a
with_pitch_env PControl
pcontrol forall a b. (a -> b) -> a -> b
$
            Bool
-> Track
-> (PitchDeriver -> PitchDeriver)
-> Deriver (PSignal, [Msg])
derive_pitch (Config -> Bool
config_use_cache Config
config) Track
track PitchDeriver -> PitchDeriver
transform
        -- Ignore errors, they should be logged on conversion.
        (NoteNumber
nn_sig, [(RealTime, Text)]
_) <- PSignal -> Deriver (NoteNumber, [(RealTime, Text)])
psignal_to_nn PSignal
signal
        Track -> Control -> Deriver ()
stash_if_wanted Track
track (forall {k1} {k2} (kind1 :: k1) (kind2 :: k2).
Signal kind1 -> Signal kind2
Signal.coerce NoteNumber
nn_sig)
        -- Apply and strip any control modifications made during the above
        -- derive.
        RealTime
end <- forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ Track -> ScoreTime
TrackTree.track_end Track
track
        forall a. RealTime -> Deriver a -> Deriver a
Derive.eval_control_mods RealTime
end forall a b. (a -> b) -> a -> b
$ [Msg] -> NoteDeriver -> NoteDeriver
merge_logs [Msg]
logs forall a b. (a -> b) -> a -> b
$ forall a. Deriver a -> Deriver a
with_damage forall a b. (a -> b) -> a -> b
$
            forall a. PControl -> PSignal -> Deriver a -> Deriver a
Derive.with_named_pitch PControl
pcontrol PSignal
signal NoteDeriver
deriver
    where
    with_damage :: Deriver d -> Deriver d
with_damage = forall d.
Maybe (BlockId, TrackId)
-> (ScoreTime, ScoreTime) -> Deriver d -> Deriver d
with_control_damage (Track -> Maybe (BlockId, TrackId)
TrackTree.block_track_id Track
track)
        (Track -> (ScoreTime, ScoreTime)
TrackTree.track_range Track
track)

with_scale :: Pitch.ScaleId -> Derive.Deriver a -> Derive.Deriver a
with_scale :: forall a. ScaleId -> Deriver a -> Deriver a
with_scale scale_id :: ScaleId
scale_id@(Pitch.ScaleId Text
name) Deriver a
deriver
    | ScaleId
scale_id forall a. Eq a => a -> a -> Bool
== ScaleId
Pitch.empty_scale = Deriver a
deriver
    | Bool
otherwise = forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
EnvKey.scale Text
name Deriver a
deriver

with_control_damage :: Maybe (BlockId, TrackId) -> (TrackTime, TrackTime)
    -> Derive.Deriver d -> Derive.Deriver d
with_control_damage :: forall d.
Maybe (BlockId, TrackId)
-> (ScoreTime, ScoreTime) -> Deriver d -> Deriver d
with_control_damage Maybe (BlockId, TrackId)
maybe_block_track_id (ScoreTime, ScoreTime)
track_range =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall {b}. (BlockId, TrackId) -> Deriver b -> Deriver b
get_damage Maybe (BlockId, TrackId)
maybe_block_track_id
    where
    get_damage :: (BlockId, TrackId) -> Deriver b -> Deriver b
get_damage (BlockId
block_id, TrackId
track_id) Deriver b
deriver = do
        ControlDamage
damage <- BlockId
-> TrackId -> (ScoreTime, ScoreTime) -> Deriver ControlDamage
Cache.get_control_damage BlockId
block_id TrackId
track_id (ScoreTime, ScoreTime)
track_range
        forall derived. ControlDamage -> Deriver derived -> Deriver derived
Internal.with_control_damage ControlDamage
damage Deriver b
deriver

-- | Split the signal chunks and log msgs of the 'LEvent.LEvents' stream.
-- Return signal chunks merged into a signal, the logs cast to Score.Event
-- logs.
type TrackResults sig = (sig, [Log.Msg])

-- | Derive the signal of a control track.
derive_control :: Bool -> TrackTree.Track
    -> (Derive.ControlDeriver -> Derive.ControlDeriver)
    -> Derive.Deriver (TrackResults Signal.Control)
derive_control :: Bool
-> Track
-> (ControlDeriver -> ControlDeriver)
-> Deriver State Error (Control, [Msg])
derive_control Bool
is_tempo Track
track ControlDeriver -> ControlDeriver
transform = do
    let track_type :: Type
track_type
            | Bool
is_tempo = Type
ParseTitle.TempoTrack
            | Bool
otherwise = Type
ParseTitle.ControlTrack
    (Control
signal, [Msg]
logs) <- forall d.
(Monoid d, CallableExpr d) =>
TrackInfo d
-> (Deriver (Stream d) -> Deriver (Stream d))
-> Deriver (TrackResults d)
derive_track (forall d. Monoid d => Track -> Type -> TrackInfo d
track_info Track
track Type
track_type)
        (forall d.
Cacheable d =>
Track -> Set TrackId -> Deriver (Stream d) -> Deriver (Stream d)
Cache.track Track
track forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlDeriver -> ControlDeriver
transform)
    Control
signal <- forall sig.
(RealTime -> sig -> sig)
-> (RealTime -> sig -> sig) -> Track -> sig -> Deriver sig
trim_signal forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.drop_after forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.clip_after Track
track Control
signal
    forall (m :: * -> *) a. Monad m => a -> m a
return (Control
signal, [Msg]
logs)

{-# SCC derive_pitch #-}
derive_pitch :: Bool -> TrackTree.Track
    -> (Derive.PitchDeriver -> Derive.PitchDeriver)
    -> Derive.Deriver (TrackResults PSignal.PSignal)
derive_pitch :: Bool
-> Track
-> (PitchDeriver -> PitchDeriver)
-> Deriver (PSignal, [Msg])
derive_pitch Bool
use_cache Track
track PitchDeriver -> PitchDeriver
transform = do
    let cache_track :: PitchDeriver -> PitchDeriver
cache_track = if Bool
use_cache then forall d.
Cacheable d =>
Track -> Set TrackId -> Deriver (Stream d) -> Deriver (Stream d)
Cache.track Track
track forall a. Monoid a => a
mempty else forall a. a -> a
id
    (PSignal
psignal, [Msg]
logs) <- forall d.
(Monoid d, CallableExpr d) =>
TrackInfo d
-> (Deriver (Stream d) -> Deriver (Stream d))
-> Deriver (TrackResults d)
derive_track (forall d. Monoid d => Track -> Type -> TrackInfo d
track_info Track
track Type
ParseTitle.PitchTrack)
        (PitchDeriver -> PitchDeriver
cache_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchDeriver -> PitchDeriver
transform)
    PSignal
signal <- forall sig.
(RealTime -> sig -> sig)
-> (RealTime -> sig -> sig) -> Track -> sig -> Deriver sig
trim_signal RealTime -> PSignal -> PSignal
PSignal.drop_after RealTime -> PSignal -> PSignal
PSignal.clip_after Track
track PSignal
psignal
    forall (m :: * -> *) a. Monad m => a -> m a
return (PSignal
signal, [Msg]
logs)

{- | The controls under a note track are intended to apply only to the note
    above them.  However, since signal calls frequently emit samples before,
    "Derive.Slice" includes one event past the end of the slice range.  To
    avoid a sample for the next note getting into this one, I trim off samples
    at and after the end of the slice.  Otherwise, the decay of each note would
    want to change pitch to that of the next note.

    Slices with a zero duration have a special exception that causes them to
    include a sample at the end time, since otherwise they wouldn't have any
    controls.  This also applies to non-zero slices which are nonetheless made
    zero by stretching to 0.
-}
trim_signal :: (RealTime -> sig -> sig) -> (RealTime -> sig -> sig)
    -> TrackTree.Track -> sig -> Derive.Deriver sig
trim_signal :: forall sig.
(RealTime -> sig -> sig)
-> (RealTime -> sig -> sig) -> Track -> sig -> Deriver sig
trim_signal RealTime -> sig -> sig
drop_after RealTime -> sig -> sig
clip_after Track
track sig
signal =
    case Track -> Sliced
TrackTree.track_sliced Track
track of
        Sliced
TrackTree.NotSliced -> forall (m :: * -> *) a. Monad m => a -> m a
return sig
signal
        Sliced
TrackTree.Inversion ->
            forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"unexpected Inversion of a control track"
        TrackTree.Sliced Orientation
orientation -> do
            RealTime
start <- forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ Track -> ScoreTime
TrackTree.track_start Track
track
            RealTime
end <- forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ Track -> ScoreTime
TrackTree.track_end Track
track
            -- I need to keep a signal exactly at end for certain blocks.
            let trim :: RealTime -> sig -> sig
trim
                    | RealTime
start forall a. Eq a => a -> a -> Bool
== RealTime
end Bool -> Bool -> Bool
|| Orientation
orientation forall a. Eq a => a -> a -> Bool
== Orientation
Types.Negative = RealTime -> sig -> sig
drop_after
                    | Bool
otherwise = RealTime -> sig -> sig
clip_after
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> sig -> sig
trim RealTime
end sig
signal
    -- TODO(polymorphic-signals)

{-# SCC derive_track #-}
derive_track :: (Monoid d, Derive.CallableExpr d) => EvalTrack.TrackInfo d
    -> (Derive.Deriver (Stream.Stream d) -> Derive.Deriver (Stream.Stream d))
    -> Derive.Deriver (TrackResults d)
derive_track :: forall d.
(Monoid d, CallableExpr d) =>
TrackInfo d
-> (Deriver (Stream d) -> Deriver (Stream d))
-> Deriver (TrackResults d)
derive_track TrackInfo d
tinfo Deriver (Stream d) -> Deriver (Stream d)
transform = do
    Stream d
stream <- Deriver (Stream d) -> Deriver (Stream d)
transform forall a b. (a -> b) -> a -> b
$ do
        State
state <- forall st err. Deriver st err st
Derive.get
        let ([Stream d]
streams, Threaded
threaded, Collect
collect) =
                forall d. CallableExpr d => State -> TrackInfo d -> DeriveResult d
EvalTrack.derive_control_track State
state TrackInfo d
tinfo
        Collect -> Deriver ()
Internal.merge_collect Collect
collect
        Threaded -> Deriver ()
Internal.set_threaded Threaded
threaded
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. Monoid a => [LEvent a] -> Stream a
compact forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Stream a -> [LEvent a]
Stream.to_list [Stream d]
streams
    let ([d]
signal_chunks, [Msg]
logs) = forall a. Stream a -> ([a], [Msg])
Stream.partition Stream d
stream
    -- I just merged the signals in 'compact', so this should just convert [x]
    -- to x.
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => [a] -> a
mconcat [d]
signal_chunks, [Msg]
logs)
    where
    -- Merge the signal here so it goes in the cache as one signal event.
    -- I can use concat instead of merge_asc_events because the signals
    -- will be merged with Signal.merge and the logs extracted.
    compact :: [LEvent a] -> Stream a
compact [LEvent a]
events = forall a. a -> [Msg] -> Stream a
Stream.from_event_logs (forall a. Monoid a => [a] -> a
mconcat [a]
sigs) [Msg]
logs
        where ([a]
sigs, [Msg]
logs) = forall d. [LEvent d] -> ([d], [Msg])
LEvent.partition [LEvent a]
events

-- | Make a TrackInfo for control tracks.
track_info :: Monoid d => TrackTree.Track -> ParseTitle.Type
    -> EvalTrack.TrackInfo d
track_info :: forall d. Monoid d => Track -> Type -> TrackInfo d
track_info Track
track Type
track_type = EvalTrack.TrackInfo
    { tinfo_track :: Track
tinfo_track = Track
track
    , tinfo_sub_tracks :: EventsTree
tinfo_sub_tracks = []
    , tinfo_type :: Type
tinfo_type = Type
track_type
    , tinfo_get_last_val :: GetLastVal d
tinfo_get_last_val = forall d. Monoid d => GetLastVal d
last_signal_val
    }

last_signal_val :: Monoid d => EvalTrack.GetLastVal d
last_signal_val :: forall d. Monoid d => GetLastVal d
last_signal_val [d]
xs
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [d]
xs = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just (forall a. Monoid a => [a] -> a
mconcat [d]
xs)

-- * TrackSignal

-- | If this track is to be rendered by the UI, stash the given signal in
-- either 'Derive.collect_track_signals' or 'Derive.collect_signal_fragments'.
{-# SCC stash_if_wanted #-}
stash_if_wanted :: TrackTree.Track -> Signal.Control -> Derive.Deriver ()
stash_if_wanted :: Track -> Control -> Deriver ()
stash_if_wanted Track
track Control
sig = forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM Deriver Bool
is_normal_mode forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (Track -> Deriver (Maybe (BlockId, TrackId, Maybe RenderSource))
render_of Track
track) forall a b. (a -> b) -> a -> b
$ \(BlockId
block_id, TrackId
track_id, Maybe RenderSource
_) ->
        case Track -> Sliced
TrackTree.track_sliced Track
track of
            Sliced
TrackTree.NotSliced -> BlockId -> TrackId -> Control -> Deriver ()
stash_signal BlockId
block_id TrackId
track_id Control
sig
            Sliced
_ -> BlockId -> TrackId -> ScoreTime -> Control -> Deriver ()
stash_signal_fragment BlockId
block_id TrackId
track_id
                -- The start of the range may not be unique in the case of
                -- orphans, I think because they aren't shifted to 0.  But
                -- the end should be unique.
                (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Track -> (ScoreTime, ScoreTime)
TrackTree.track_range Track
track) Control
sig

is_normal_mode :: Derive.Deriver Bool
is_normal_mode :: Deriver Bool
is_normal_mode = Deriver Mode
Derive.get_mode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Mode
mode -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Mode
mode of
    Mode
Derive.Normal -> Bool
True
    Mode
_ -> Bool
False

stash_signal_fragment :: BlockId -> TrackId -> TrackTime -> Signal.Control
    -> Derive.Deriver ()
stash_signal_fragment :: BlockId -> TrackId -> ScoreTime -> Control -> Deriver ()
stash_signal_fragment BlockId
block_id TrackId
track_id ScoreTime
slice_end Control
sig =
    -- TODO I think this is faster than Internal.merge_collect, but I haven't
    -- profiled so I don't know
    (Collect -> Collect) -> Deriver ()
Internal.modify_collect forall a b. (a -> b) -> a -> b
$ \Collect
collect -> Collect
collect
        { collect_signal_fragments :: SignalFragments
Derive.collect_signal_fragments =
            forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Map ScoreTime Control) -> Maybe (Map ScoreTime Control)
insert (BlockId
block_id, TrackId
track_id) forall a b. (a -> b) -> a -> b
$
                Collect -> SignalFragments
Derive.collect_signal_fragments Collect
collect
        }
    where
    -- If a control is constant over multiple inverted notes, I'll get a bunch
    -- of identical signal fragments.  Rather than waiting for merge to
    -- eliminate them, it seems a bit more efficient to not collect them in the
    -- first place.
    insert :: Maybe (Map ScoreTime Control) -> Maybe (Map ScoreTime Control)
insert (Just Map ScoreTime Control
old) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ case forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map ScoreTime Control
old of
        Just (ScoreTime
_, Control
prev) | Control
sig forall a. Eq a => a -> a -> Bool
== Control
prev -> Map ScoreTime Control
old
        Maybe (ScoreTime, Control)
_ -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScoreTime
slice_end Control
sig Map ScoreTime Control
old
    insert Maybe (Map ScoreTime Control)
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton ScoreTime
slice_end Control
sig

stash_signal :: BlockId -> TrackId -> Signal.Control -> Derive.Deriver ()
stash_signal :: BlockId -> TrackId -> Control -> Deriver ()
stash_signal BlockId
block_id TrackId
track_id Control
sig = do
    Warp
warp <- Deriver Warp
Internal.get_warp
    BlockId -> TrackId -> TrackSignal -> Deriver ()
put_track_signal BlockId
block_id TrackId
track_id forall a b. (a -> b) -> a -> b
$ Warp -> Control -> TrackSignal
EvalTrack.unwarp Warp
warp Control
sig

put_track_signal :: BlockId -> TrackId -> Track.TrackSignal -> Derive.Deriver ()
put_track_signal :: BlockId -> TrackId -> TrackSignal -> Deriver ()
put_track_signal BlockId
block_id TrackId
track_id TrackSignal
tsig = Collect -> Deriver ()
Internal.merge_collect forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
    { collect_track_signals :: TrackSignals
Derive.collect_track_signals = forall k a. k -> a -> Map k a
Map.singleton (BlockId
block_id, TrackId
track_id) TrackSignal
tsig }

-- | Get render information if this track wants a TrackSignal.
render_of :: TrackTree.Track
    -> Derive.Deriver (Maybe (BlockId, TrackId, Maybe Track.RenderSource))
render_of :: Track -> Deriver (Maybe (BlockId, TrackId, Maybe RenderSource))
render_of Track
track = case Track -> Maybe (BlockId, TrackId)
TrackTree.block_track_id Track
track of
    Maybe (BlockId, TrackId)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just (BlockId
block_id, TrackId
track_id) -> forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM Deriver Bool
not_root (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
        (Track
btrack, Track
track) <- BlockId -> TrackId -> Deriver (Track, Track)
get_block_track BlockId
block_id TrackId
track_id
        let flags :: Set TrackFlag
flags = Track -> Set TrackFlag
Block.track_flags Track
btrack
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Set TrackFlag -> Track -> Bool
Block.track_wants_signal Set TrackFlag
flags Track
track
            then forall a. a -> Maybe a
Just (BlockId
block_id, TrackId
track_id,
                RenderStyle -> Maybe RenderSource
extract (RenderConfig -> RenderStyle
Track.render_style (Track -> RenderConfig
Track.track_render Track
track)))
            else forall a. Maybe a
Nothing
    where
    not_root :: Deriver Bool
not_root = Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver Bool
Internal.is_root_block
    extract :: RenderStyle -> Maybe RenderSource
extract (Track.Line (Just RenderSource
source)) = forall a. a -> Maybe a
Just RenderSource
source
    extract (Track.Filled (Just RenderSource
source)) = forall a. a -> Maybe a
Just RenderSource
source
    extract RenderStyle
_ = forall a. Maybe a
Nothing

get_block_track :: BlockId -> TrackId
    -> Derive.Deriver (Block.Track, Track.Track)
get_block_track :: BlockId -> TrackId -> Deriver (Track, Track)
get_block_track BlockId
block_id TrackId
track_id = do
    Track
track <- TrackId -> Deriver Track
Derive.get_track TrackId
track_id
    Block
block <- BlockId -> Deriver Block
Derive.get_block BlockId
block_id
    Track
btrack <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require
        (Text
"get_block_track: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
" doesn't have "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackId
track_id) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TrackId
track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Maybe TrackId
Block.track_id)
            (Block -> [Track]
Block.block_tracks Block
block)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Track
btrack, Track
track)


-- * util

-- | Reduce a 'PSignal.PSignal' to raw note numbers, taking the current
-- transposition environment into account.
psignal_to_nn :: PSignal.PSignal
    -> Derive.Deriver (Signal.NoteNumber, [(RealTime, PSignal.ErrorText)])
psignal_to_nn :: PSignal -> Deriver (NoteNumber, [(RealTime, Text)])
psignal_to_nn PSignal
sig = do
    ControlMap
controls <- Deriver ControlMap
Derive.get_control_map
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PSignal -> (NoteNumber, [(RealTime, Text)])
PSignal.to_nn forall a b. (a -> b) -> a -> b
$ ControlMap -> PSignal -> PSignal
PSignal.apply_controls ControlMap
controls PSignal
sig

with_control_env :: ScoreT.Control -> Derive.Merger -> Derive.Deriver a
    -> Derive.Deriver a
with_control_env :: forall a. Control -> Merger -> Deriver a -> Deriver a
with_control_env Control
control Merger
merger = forall val a. ToVal val => [(Text, val)] -> Deriver a -> Deriver a
Derive.with_vals
    [ (Text
EnvKey.control, Control -> Text
ScoreT.control_name Control
control)
    , (Text
EnvKey.merge, forall a. ShowVal a => a -> Text
ShowVal.show_val Merger
merger)
    ]

with_pitch_env :: ScoreT.PControl -> Derive.Deriver a -> Derive.Deriver a
with_pitch_env :: forall a. PControl -> Deriver a -> Deriver a
with_pitch_env = forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
EnvKey.control forall b c a. (b -> c) -> (a -> b) -> a -> c
. PControl -> Text
ScoreT.pcontrol_name