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

-- | Basic calls for note tracks.
module Derive.C.Prelude.Note (
    library
    , c_note, transformed_note, note_call
    , Config(..), use_attributes, no_duration_attributes
    , GenerateNote, default_note, note_flags
    , adjust_duration
    , min_duration
) where
import qualified Data.Either as Either
import qualified Data.Map as Map

import qualified Util.Doc as Doc
import qualified Util.Seq as Seq
import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.Call as Call
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Call.NoteUtil as NoteUtil
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.Flags as Flags
import qualified Derive.Library as Library
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream
import qualified Derive.Symbols as Symbols

import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal

import           Global
import           Types


library :: Library.Library
library :: Library
library = [Library] -> Library
forall a. Monoid a => [a] -> a
mconcat
    [ [(Symbol, Generator Note)] -> Library
forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [ (Symbol
Symbols.null_note, Generator Note
c_note)
        , (Symbol
Symbols.default_note, Generator Note
c_note)
        ]
    , [(Symbol, Transformer Note)] -> Library
forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers [(Symbol
Symbols.note_track, Transformer Note
c_note_track)]
    , [(Symbol, Calls Note)] -> Library
forall d.
(ToLibrary (Generator d), ToLibrary (Transformer d)) =>
[(Symbol, Calls d)] -> Library
Library.both [(Symbol
"attr", Calls Note
c_with_attributes)]
    ]

-- | This is mostly useful for tests when I need some call that makes a note
-- and takes arguments.
c_with_attributes :: Library.Calls Derive.Note
c_with_attributes :: Calls Note
c_with_attributes = Module
-> CallName
-> Tags
-> Doc
-> Parser [Either Instrument Attributes]
-> ([Either Instrument Attributes] -> NoteDeriver -> NoteDeriver)
-> Calls Note
forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
Module.prelude CallName
"note" Tags
forall a. Monoid a => a
mempty
    Doc
"A note with attributes or instrument."
    (ArgName -> Doc -> Parser [Either Instrument Attributes]
forall a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"attr" Doc
"Set instrument or add attributes.") (([Either Instrument Attributes] -> NoteDeriver -> NoteDeriver)
 -> Calls Note)
-> ([Either Instrument Attributes] -> NoteDeriver -> NoteDeriver)
-> Calls Note
forall a b. (a -> b) -> a -> b
$
    \[Either Instrument Attributes]
inst_attrs NoteDeriver
deriver -> do
        let ([Instrument]
insts, [Attributes]
attrs) = [Either Instrument Attributes] -> ([Instrument], [Attributes])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Instrument Attributes]
inst_attrs
            inst :: Maybe Instrument
inst = [Instrument] -> Maybe Instrument
forall a. [a] -> Maybe a
Seq.last [Instrument]
insts
        (NoteDeriver -> NoteDeriver)
-> (Instrument -> NoteDeriver -> NoteDeriver)
-> Maybe Instrument
-> NoteDeriver
-> NoteDeriver
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NoteDeriver -> NoteDeriver
forall a. a -> a
id Instrument -> NoteDeriver -> NoteDeriver
forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Maybe Instrument
inst (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
            Attributes -> NoteDeriver -> NoteDeriver
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes ([Attributes] -> Attributes
forall a. Monoid a => [a] -> a
mconcat [Attributes]
attrs) NoteDeriver
deriver

-- * note

c_note :: Derive.Generator Derive.Note
c_note :: Generator Note
c_note = CallName -> Doc -> Tags -> GenerateNote -> Generator Note
note_call CallName
"note" Doc
"" Tags
forall a. Monoid a => a
mempty (Config -> GenerateNote
default_note Config
use_attributes)

-- | Create a standard note call with a transformer applied.
transformed_note :: Doc.Doc -> Tags.Tags
    -> (Derive.NoteArgs -> Derive.NoteDeriver -> Derive.NoteDeriver)
    -> Derive.Generator Derive.Note
transformed_note :: Doc
-> Tags
-> (NoteArgs -> NoteDeriver -> NoteDeriver)
-> Generator Note
transformed_note Doc
prepend_doc Tags
tags NoteArgs -> NoteDeriver -> NoteDeriver
transform =
    CallName -> Doc -> Tags -> GenerateNote -> Generator Note
note_call CallName
"note" Doc
prepend_doc Tags
tags (GenerateNote -> Generator Note) -> GenerateNote -> Generator Note
forall a b. (a -> b) -> a -> b
$ \NoteArgs
args ->
        NoteArgs -> NoteDeriver -> NoteDeriver
transform NoteArgs
args (Config -> GenerateNote
default_note Config
use_attributes NoteArgs
args)

-- | Create a note call, configuring it with the actual note generating
-- function.  The generator is called with the usual note arguments, and
-- receives the usual instrument and attribute transform.
note_call :: Derive.CallName -> Doc.Doc -> Tags.Tags -> GenerateNote
    -> Derive.Generator Derive.Note
note_call :: CallName -> Doc -> Tags -> GenerateNote -> Generator Note
note_call CallName
name Doc
prepend_doc Tags
tags GenerateNote
generate =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc GenerateNote
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
name Tags
tags Doc
prepended (WithArgDoc GenerateNote -> Generator Note)
-> WithArgDoc GenerateNote -> Generator Note
forall a b. (a -> b) -> a -> b
$
    GenerateNote -> WithArgDoc GenerateNote
forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 (GenerateNote -> WithArgDoc GenerateNote)
-> GenerateNote -> WithArgDoc GenerateNote
forall a b. (a -> b) -> a -> b
$ GenerateNote -> GenerateNote
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting (GenerateNote -> GenerateNote) -> GenerateNote -> GenerateNote
forall a b. (a -> b) -> a -> b
$ NoteDeriver -> NoteDeriver
forall a. Deriver a -> Deriver a
apply_instrument_controls (NoteDeriver -> NoteDeriver) -> GenerateNote -> GenerateNote
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenerateNote
generate
    where
    prepended :: Doc
prepended
        | Doc
prepend_doc Doc -> Doc -> Bool
forall a. Eq a => a -> a -> Bool
== Doc
"" = Doc
generator_doc
        | Bool
otherwise = Doc
"Modified note call: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
prepend_doc Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\n"
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
generator_doc
    generator_doc :: Doc
generator_doc =
        Doc
"The note call is the default note generator, and will emit a single\
        \ score event. Usually this is bound to the null call, \"\", which is\
        \ therefore the most syntactically convenient note generator.\
        \\nThis should probably remain bound to "
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Symbol -> Doc
forall a. ShowVal a => a -> Doc
ShowVal.doc Symbol
Symbols.note_track Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" symbol, which is used\
        \ internally by many other calls when they want a plain note. This is\
        \ so you can bind \"\" to one of those other calls without getting\
        \ recursion."
    -- Some history: long ago, you could call the note with >inst to set the
    -- instrument, and +a to set attributes.  The intention was an easy
    -- notation to write a single part that alternated between multiple
    -- instruments, in the way that trackers would often do it.  But eventually
    -- I generalized tracks to be able to contain arbitrary calls, and the note
    -- became the "" call, which couldn't take arguments.  Later I got +a
    -- syntax back courtesty of lookup calls, but the >inst literal syntax is
    -- gone now, and in any case I tend to have one instrument per-track due to
    -- wanting to scope transformations per-instrument.  But maybe some day
    -- I'll bring back >inst syntax as a lookup call.


-- | Apply the 'Instrument.Common.config_controls' field.  It happens in the
-- note call to make sure it happens only once per note.
apply_instrument_controls :: Derive.Deriver a -> Derive.Deriver a
apply_instrument_controls :: forall a. Deriver a -> Deriver a
apply_instrument_controls Deriver a
deriver = Deriver (Maybe Instrument)
Call.lookup_instrument Deriver (Maybe Instrument)
-> (Maybe Instrument -> Deriver a) -> Deriver a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Instrument
Nothing -> Deriver a
deriver
    Just Instrument
inst -> do
        (Instrument
_inst, Instrument
derive_inst) <- Instrument -> Deriver (Instrument, Instrument)
Derive.get_instrument Instrument
inst
        let controls :: Map Control (Typed (Signal kind))
controls = Signal kind -> Typed (Signal kind)
forall a. a -> Typed a
ScoreT.untyped (Signal kind -> Typed (Signal kind))
-> (Y -> Signal kind) -> Y -> Typed (Signal kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Signal kind
forall {k} (kind :: k). Y -> Signal kind
Signal.constant (Y -> Typed (Signal kind))
-> Map Control Y -> Map Control (Typed (Signal kind))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                Instrument -> Map Control Y
Derive.inst_controls Instrument
derive_inst
        [(Control, Typed Control)] -> Deriver a -> Deriver a
forall a. [(Control, Typed Control)] -> Deriver a -> Deriver a
Derive.with_merged_controls (Map Control (Typed Control) -> [(Control, Typed Control)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Control (Typed Control)
forall {k} {kind :: k}. Map Control (Typed (Signal kind))
controls) Deriver a
deriver

c_note_track :: Derive.Transformer Derive.Note
c_note_track :: Transformer Note
c_note_track = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (NoteArgs -> NoteDeriver -> NoteDeriver)
-> Transformer Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"note-track" Tags
forall a. Monoid a => a
mempty
    (Doc
"This is the implicit call at the top of every note track. The first\
    \ argument is the instrument named after the note track's `>`.\
    \ If there is a note transformer of the same name as the\
    \ instrument, starting with `>`, it will be called after setting the\
    \ instrument. This way, you can set instrument-specific variables or\
    \ transformations.")
    (WithArgDoc (NoteArgs -> NoteDeriver -> NoteDeriver)
 -> Transformer Note)
-> WithArgDoc (NoteArgs -> NoteDeriver -> NoteDeriver)
-> Transformer Note
forall a b. (a -> b) -> a -> b
$ Parser (Maybe Instrument)
-> (Maybe Instrument -> NoteArgs -> NoteDeriver -> NoteDeriver)
-> WithArgDoc (NoteArgs -> NoteDeriver -> NoteDeriver)
forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (ArgName
-> EnvironDefault
-> Maybe Instrument
-> Doc
-> Parser (Maybe Instrument)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.defaulted_env ArgName
"inst" EnvironDefault
Derive.None Maybe Instrument
forall a. Maybe a
Nothing
        Doc
"Set this instrument and run the transformer, if it exists."
    ) ((Maybe Instrument -> NoteArgs -> NoteDeriver -> NoteDeriver)
 -> WithArgDoc (NoteArgs -> NoteDeriver -> NoteDeriver))
-> (Maybe Instrument -> NoteArgs -> NoteDeriver -> NoteDeriver)
-> WithArgDoc (NoteArgs -> NoteDeriver -> NoteDeriver)
forall a b. (a -> b) -> a -> b
$ \Maybe Instrument
inst NoteArgs
args NoteDeriver
deriver -> Context Note -> Maybe Instrument -> NoteDeriver -> NoteDeriver
note_track (NoteArgs -> Context Note
forall val. PassedArgs val -> Context val
Derive.passed_ctx NoteArgs
args) Maybe Instrument
inst NoteDeriver
deriver

note_track :: Derive.Context Derive.Note -> Maybe ScoreT.Instrument
    -> Derive.NoteDeriver -> Derive.NoteDeriver
note_track :: Context Note -> Maybe Instrument -> NoteDeriver -> NoteDeriver
note_track Context Note
ctx Maybe Instrument
inst NoteDeriver
deriver = do
    let sym :: Symbol
sym = Text -> Symbol
Expr.Symbol (Text -> Symbol) -> Text -> Symbol
forall a b. (a -> b) -> a -> b
$ Text
">" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Instrument -> Text) -> Maybe Instrument -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Instrument -> Text
ScoreT.instrument_name Maybe Instrument
inst
    Maybe (Transformer Note)
maybe_call <- Symbol -> Deriver (Maybe (Transformer Note))
forall call. Callable call => Symbol -> Deriver (Maybe call)
Derive.lookup_call Symbol
sym
    let transform :: NoteDeriver -> NoteDeriver
transform = (NoteDeriver -> NoteDeriver)
-> (Transformer Note -> NoteDeriver -> NoteDeriver)
-> Maybe (Transformer Note)
-> NoteDeriver
-> NoteDeriver
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NoteDeriver -> NoteDeriver
forall a. a -> a
id (Context Note -> Transformer Note -> NoteDeriver -> NoteDeriver
forall d.
Context d
-> Transformer d -> Deriver (Stream d) -> Deriver (Stream d)
call_transformer Context Note
ctx) Maybe (Transformer Note)
maybe_call
    (NoteDeriver -> NoteDeriver)
-> (Instrument -> NoteDeriver -> NoteDeriver)
-> Maybe Instrument
-> NoteDeriver
-> NoteDeriver
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NoteDeriver -> NoteDeriver
forall a. a -> a
id Instrument -> NoteDeriver -> NoteDeriver
forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Maybe Instrument
inst (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ NoteDeriver -> NoteDeriver
transform NoteDeriver
deriver

call_transformer :: Derive.Context d -> Derive.Transformer d
    -> Derive.Deriver (Stream.Stream d) -> Derive.Deriver (Stream.Stream d)
call_transformer :: forall d.
Context d
-> Transformer d -> Deriver (Stream d) -> Deriver (Stream d)
call_transformer Context d
ctx Transformer d
call Deriver (Stream d)
deriver =
    CallName -> Deriver (Stream d) -> Deriver (Stream d)
forall a. CallName -> Deriver a -> Deriver a
Internal.with_stack_call (Transformer d -> CallName
forall func. Call func -> CallName
Derive.call_name Transformer d
call) (Deriver (Stream d) -> Deriver (Stream d))
-> Deriver (Stream d) -> Deriver (Stream d)
forall a b. (a -> b) -> a -> b
$
        Transformer d
-> PassedArgs d -> Deriver (Stream d) -> Deriver (Stream d)
forall func. Call func -> func
Derive.call_func Transformer d
call PassedArgs d
passed Deriver (Stream d)
deriver
    where
    passed :: PassedArgs d
passed = Derive.PassedArgs
        { passed_vals :: [Val]
Derive.passed_vals = []
        , passed_call_name :: CallName
Derive.passed_call_name = Transformer d -> CallName
forall func. Call func -> CallName
Derive.call_name Transformer d
call
        , passed_ctx :: Context d
Derive.passed_ctx = Context d
ctx
        }

-- ** generate

-- | Generate a single note.  This is intended to be used as the lowest level
-- null call for some instrument.
type GenerateNote = Derive.NoteArgs -> Derive.NoteDeriver

data Config = Config {
    -- | Note duration is affected by 'Attrs.staccato'.
    Config -> Bool
config_staccato :: !Bool
    -- | Note duration can depend on 'Controls.sustain' and
    -- 'Controls.sustain_abs'.
    , Config -> Bool
config_sustain :: !Bool
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
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)

use_attributes :: Config
use_attributes :: Config
use_attributes = Config
    { config_staccato :: Bool
config_staccato = Bool
True
    , config_sustain :: Bool
config_sustain = Bool
True
    }

-- | Don't observe any of the duration affecting attributes.
no_duration_attributes :: Config
no_duration_attributes :: Config
no_duration_attributes = Bool -> Bool -> Config
Config Bool
False Bool
False

-- | The actual note generator.
{-# SCC default_note #-}
default_note :: Config -> GenerateNote
default_note :: Config -> GenerateNote
default_note Config
config NoteArgs
args = do
    RealTime
start <- NoteArgs -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
Args.real_start NoteArgs
args
    RealTime
end <- NoteArgs -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
Args.real_end NoteArgs
args
    Dynamic
dyn <- (Dynamic -> Dynamic) -> Deriver Dynamic
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Dynamic
forall a. a -> a
id
    -- Add flags to get the arrival-note postproc to figure out the duration.
    -- Details in "Derive.Call.Post.ArrivalNote".
    let flags :: Flags
flags = Bool -> Stack -> Environ -> Flags
note_flags (RealTime
start RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== RealTime
end) (Dynamic -> Stack
Derive.state_stack Dynamic
dyn)
            (Dynamic -> Environ
Derive.state_environ Dynamic
dyn)
    Map Control Y
control_vals <- RealTime -> Deriver (Map Control Y)
Derive.controls_at RealTime
start
    let attrs :: Attributes
attrs = (LookupError -> Attributes)
-> (Attributes -> Attributes)
-> Either LookupError Attributes
-> Attributes
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Attributes -> LookupError -> Attributes
forall a b. a -> b -> a
const Attributes
forall a. Monoid a => a
mempty) Attributes -> Attributes
forall a. a -> a
id (Either LookupError Attributes -> Attributes)
-> Either LookupError Attributes -> Attributes
forall a b. (a -> b) -> a -> b
$
            Text -> Environ -> Either LookupError Attributes
forall a. Typecheck a => Text -> Environ -> Either LookupError a
Env.get_val Text
EnvKey.attributes (Dynamic -> Environ
Derive.state_environ Dynamic
dyn)
    let adjusted_end :: RealTime
adjusted_end = Config
-> Map Control Y -> Attributes -> RealTime -> RealTime -> RealTime
duration_attributes Config
config Map Control Y
control_vals Attributes
attrs RealTime
start RealTime
end
    Note -> Stream Note
forall a. a -> Stream a
Stream.from_event (Note -> Stream Note) -> Deriver State Error Note -> NoteDeriver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Control Y
-> NoteArgs
-> Dynamic
-> RealTime
-> RealTime
-> Flags
-> Deriver State Error Note
forall a.
Map Control Y
-> PassedArgs a
-> Dynamic
-> RealTime
-> RealTime
-> Flags
-> Deriver State Error Note
NoteUtil.make_event_control_vals
        Map Control Y
control_vals NoteArgs
args Dynamic
dyn RealTime
start (RealTime
adjusted_end RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
start) Flags
flags

note_flags :: Bool -> Stack.Stack -> Env.Environ -> Flags.Flags
note_flags :: Bool -> Stack -> Environ -> Flags
note_flags Bool
zero_dur Stack
stack Environ
environ
    -- An event at TrackTime 0 never gets an inferred duration.
    -- Otherwise, I couldn't write single note calls for percussion.
    | Bool
infer_dur Bool -> Bool -> Bool
&& Bool
track_start = Flags
forall a. Monoid a => a
mempty
    | Bool
infer_dur = Flags
Flags.infer_duration Flags -> Flags -> Flags
forall a. Semigroup a => a -> a -> a
<> Flags
Flags.strong
    | Bool
otherwise = Flags
forall a. Monoid a => a
mempty
    where
    -- Note that I can't use Args.duration or Args.range_on_track, because
    -- this may be invoked via e.g. Call.note, which fakes up an event with
    -- range (0, 1), and sets the duration via the warp.
    infer_dur :: Bool
infer_dur = Bool
block_end Bool -> Bool -> Bool
&& Bool
zero_dur
    track_start :: Bool
track_start = Maybe TrackTime
start Maybe TrackTime -> Maybe TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime -> Maybe TrackTime
forall a. a -> Maybe a
Just TrackTime
0
    block_end :: Bool
block_end = Maybe TrackTime
start Maybe TrackTime -> Maybe TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Environ -> Maybe TrackTime
forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.block_end Environ
environ
    -- This is the start time on the track, which, due to slicing, is not
    -- necessarily the same as Args.start.
    start :: Maybe TrackTime
start = (TrackTime, TrackTime) -> TrackTime
forall a b. (a, b) -> a
fst ((TrackTime, TrackTime) -> TrackTime)
-> Maybe (TrackTime, TrackTime) -> Maybe TrackTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TrackTime, TrackTime)] -> Maybe (TrackTime, TrackTime)
forall a. [a] -> Maybe a
Seq.head ((Frame -> Maybe (TrackTime, TrackTime))
-> [Frame] -> [(TrackTime, TrackTime)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Frame -> Maybe (TrackTime, TrackTime)
Stack.region_of (Stack -> [Frame]
Stack.innermost Stack
stack))

-- ** adjust start and duration

adjust_duration :: RealTime -> RealTime -> RealTime -> RealTime -> RealTime
adjust_duration :: RealTime -> RealTime -> RealTime -> RealTime -> RealTime
adjust_duration RealTime
cur_pos RealTime
cur_dur RealTime
next_pos RealTime
next_dur
        -- Departing notes are not changed.
    | RealTime
cur_dur RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
> RealTime
0 = RealTime
cur_dur
        -- Arriving followed by arriving with a rest in between extends to
        -- the arrival of the rest.
    | RealTime
next_dur RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<= RealTime
0 Bool -> Bool -> Bool
&& RealTime
rest RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
> RealTime
0 = RealTime
rest
        -- Arriving followed by arriving with no rest, or an arriving note
        -- followed by a departing note will sound until the next note.
    | Bool
otherwise = RealTime
next_pos RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
cur_pos
    where rest :: RealTime
rest = RealTime
next_pos RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
next_dur RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
cur_pos

-- | This keeps a negative sustain_abs from making note duration negative.
min_duration :: RealTime
min_duration :: RealTime
min_duration = RealTime
1 RealTime -> RealTime -> RealTime
forall a. Fractional a => a -> a -> a
/ RealTime
64

{- | Interpret attributes and controls that effect the note's duration.

    This is actually somewhat complicated.  Instead of all the
    duration-affecting controls all applying together, notes fit into distinct
    categories:

    - Zero-duration notes ignore all this.

    - Staccato notes divide their duration by 2.

    - Normal notes multiply 'Controls.sustain' and add 'Controls.duration_abs',
    which could be negative.  They clip at a minimum duration to keep from
    going negative.
-}
duration_attributes :: Config -> ScoreT.ControlValMap -> Attrs.Attributes
    -> RealTime -> RealTime -> RealTime -- ^ new end
duration_attributes :: Config
-> Map Control Y -> Attributes -> RealTime -> RealTime -> RealTime
duration_attributes Config
config Map Control Y
controls Attributes
attrs RealTime
start RealTime
end
    | RealTime
start RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>= RealTime
end = RealTime
end -- don't mess with 0 dur or negative notes
    | Just Y
set_dur <- Control -> Map Control Y -> Maybe Y
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
Controls.sustain_set Map Control Y
controls, Bool
use_sustain =
        RealTime
start RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max RealTime
min_duration (Y -> RealTime
RealTime.seconds Y
set_dur)
    | Bool
otherwise = RealTime
start RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max RealTime
min_duration (RealTime
dur RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
* RealTime
sustain RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
sustain_abs)
    where
    has :: Attributes -> Bool
has = Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs
    dur :: RealTime
dur = RealTime
end RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
start
    staccato :: Bool
staccato = Config -> Bool
config_staccato Config
config Bool -> Bool -> Bool
&& Attributes -> Bool
has Attributes
Attrs.staccato
    sustain :: RealTime
sustain = if Bool
staccato then RealTime
sustain_ RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
* RealTime
0.5 else RealTime
sustain_
    sustain_ :: RealTime
sustain_ = if Bool
use_sustain then RealTime -> Control -> RealTime
lookup_time RealTime
1 Control
Controls.sustain else RealTime
1
    sustain_abs :: RealTime
sustain_abs = if Bool
staccato Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
use_sustain then RealTime
0
        else RealTime -> Control -> RealTime
lookup_time RealTime
0 Control
Controls.sustain_abs
    use_sustain :: Bool
use_sustain = Config -> Bool
config_sustain Config
config
    lookup_time :: RealTime -> Control -> RealTime
lookup_time RealTime
deflt Control
control = RealTime -> (Y -> RealTime) -> Maybe Y -> RealTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
deflt Y -> RealTime
RealTime.seconds
        (Control -> Map Control Y -> Maybe Y
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control Map Control Y
controls)