module Derive.C.Prelude.Note (
library
, c_note
, transformed_note, transformed_note_name
, note_call
, Config(..), use_attributes, no_duration_attributes
, GenerateNote
, default_note, default_note_integrate
, 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.Lists as Lists
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 = forall a. Monoid a => [a] -> a
mconcat
[ 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)
]
, forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers [(Symbol
Symbols.note_track, Transformer Note
c_note_track)]
, forall d.
(ToLibrary (Generator d), ToLibrary (Transformer d)) =>
[(Symbol, Calls d)] -> Library
Library.both [(Symbol
"attr", Calls Note
c_with_attributes)]
]
c_with_attributes :: Library.Calls Derive.Note
c_with_attributes :: Calls Note
c_with_attributes = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
Module.prelude CallName
"note" forall a. Monoid a => a
mempty
Doc
"A note with attributes or instrument."
(forall a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"attr" Doc
"Set instrument or add attributes.") forall a b. (a -> b) -> a -> b
$
\[Either Instrument Attributes]
inst_attrs NoteDeriver
deriver -> do
let ([Instrument]
insts, [Attributes]
attrs) = forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Instrument Attributes]
inst_attrs
inst :: Maybe Instrument
inst = forall a. [a] -> Maybe a
Lists.last [Instrument]
insts
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Maybe Instrument
inst forall a b. (a -> b) -> a -> b
$
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes (forall a. Monoid a => [a] -> a
mconcat [Attributes]
attrs) NoteDeriver
deriver
c_note :: Derive.Generator Derive.Note
c_note :: Generator Note
c_note = CallName -> Doc -> Tags -> GenerateNote -> Generator Note
note_call CallName
"note" Doc
"" forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ Config -> GenerateNote
default_note Config
use_attributes
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 = CallName
-> Doc
-> Tags
-> (NoteArgs -> NoteDeriver -> NoteDeriver)
-> Generator Note
transformed_note_name CallName
"note"
transformed_note_name :: Derive.CallName -> Doc.Doc -> Tags.Tags
-> (Derive.NoteArgs -> Derive.NoteDeriver -> Derive.NoteDeriver)
-> Derive.Generator Derive.Note
transformed_note_name :: CallName
-> Doc
-> Tags
-> (NoteArgs -> NoteDeriver -> NoteDeriver)
-> Generator Note
transformed_note_name CallName
name Doc
prepend_doc Tags
tags NoteArgs -> NoteDeriver -> NoteDeriver
transform =
CallName -> Doc -> Tags -> GenerateNote -> Generator Note
note_call CallName
name Doc
prepend_doc Tags
tags forall a b. (a -> b) -> a -> b
$ \NoteArgs
args ->
NoteArgs -> NoteDeriver -> NoteDeriver
transform NoteArgs
args (Config -> GenerateNote
default_note Config
use_attributes NoteArgs
args)
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 =
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
name Tags
tags Doc
prepended forall a b. (a -> b) -> a -> b
$
forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ forall a. Deriver a -> Deriver a
apply_instrument_controls forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenerateNote
generate
where
prepended :: Doc
prepended
| Doc
prepend_doc forall a. Eq a => a -> a -> Bool
== Doc
"" = Doc
generator_doc
| Bool
otherwise = Doc
"Modified note call: " forall a. Semigroup a => a -> a -> a
<> Doc
prepend_doc forall a. Semigroup a => a -> a -> a
<> Doc
"\n"
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 "
forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Symbol
Symbols.note_track 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."
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 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 = forall a. a -> Typed a
ScoreT.untyped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Y -> Signal kind
Signal.constant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Instrument -> ControlValMap
Derive.inst_controls Instrument
derive_inst
forall a. [(Control, Typed Control)] -> Deriver a -> Deriver a
Derive.with_merged_controls (forall k a. Map k a -> [(k, a)]
Map.toList 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 = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"note-track" 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.")
forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"inst" EnvironDefault
Derive.None
(forall a. Maybe a
Nothing :: Maybe ScoreT.Instrument)
Doc
"Set this instrument and run the transformer, if it exists."
) forall a b. (a -> b) -> a -> b
$ \Maybe Instrument
inst NoteArgs
args NoteDeriver
deriver -> Context Note -> Maybe Instrument -> NoteDeriver -> NoteDeriver
note_track (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 forall a b. (a -> b) -> a -> b
$ Text
">" forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Instrument -> Text
ScoreT.instrument_name Maybe Instrument
inst
Maybe (Transformer Note)
maybe_call <- forall call. Callable call => Symbol -> Deriver (Maybe call)
Derive.lookup_call Symbol
sym
let transform :: NoteDeriver -> NoteDeriver
transform = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall d.
Context d
-> Transformer d -> Deriver (Stream d) -> Deriver (Stream d)
call_transformer Context Note
ctx) Maybe (Transformer Note)
maybe_call
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Maybe Instrument
inst 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 =
forall a. CallName -> Deriver a -> Deriver a
Internal.with_stack_call (forall func. Call func -> CallName
Derive.call_name Transformer d
call) forall a b. (a -> b) -> a -> b
$
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 = forall func. Call func -> CallName
Derive.call_name Transformer d
call
, passed_ctx :: Context d
Derive.passed_ctx = Context d
ctx
}
type GenerateNote = Derive.NoteArgs -> Derive.NoteDeriver
data Config = Config {
Config -> Bool
config_staccato :: !Bool
, Config -> Bool
config_sustain :: !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)
use_attributes :: Config
use_attributes :: Config
use_attributes = Config
{ config_staccato :: Bool
config_staccato = Bool
True
, config_sustain :: Bool
config_sustain = Bool
True
}
no_duration_attributes :: Config
no_duration_attributes :: Config
no_duration_attributes = Bool -> Bool -> Config
Config Bool
False Bool
False
default_note :: Config -> GenerateNote
default_note :: Config -> GenerateNote
default_note Config
config NoteArgs
args = Text -> Config -> GenerateNote
default_note_integrate Text
integrate Config
config NoteArgs
args
where
integrate :: Text
integrate = Text
""
{-# SCC default_note_integrate #-}
default_note_integrate :: Text -> Config -> GenerateNote
default_note_integrate :: Text -> Config -> GenerateNote
default_note_integrate Text
integrate Config
config NoteArgs
args = do
RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start NoteArgs
args
RealTime
end <- forall a. PassedArgs a -> Deriver RealTime
Args.real_end NoteArgs
args
Dynamic
dyn <- forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic forall a. a -> a
id
let flags :: Flags
flags = Bool -> Stack -> Environ -> Flags
note_flags (RealTime
start forall a. Eq a => a -> a -> Bool
== RealTime
end) (Dynamic -> Stack
Derive.state_stack Dynamic
dyn)
(Dynamic -> Environ
Derive.state_environ Dynamic
dyn)
ControlValMap
cvmap <- RealTime -> Deriver ControlValMap
Derive.controls_at RealTime
start
let attrs :: Attributes
attrs = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
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
-> ControlValMap -> Attributes -> RealTime -> RealTime -> RealTime
duration_attributes Config
config ControlValMap
cvmap Attributes
attrs RealTime
start RealTime
end
forall a. a -> Stream a
Stream.from_event forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ControlValMap
-> PassedArgs a
-> Dynamic
-> RealTime
-> RealTime
-> Text
-> Flags
-> Deriver Note
NoteUtil.make_event_control_vals
ControlValMap
cvmap NoteArgs
args Dynamic
dyn RealTime
start (RealTime
adjusted_end forall a. Num a => a -> a -> a
- RealTime
start) Text
integrate 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
| Bool
infer_dur Bool -> Bool -> Bool
&& Bool
track_start = forall a. Monoid a => a
mempty
| Bool
infer_dur = Flags
Flags.infer_duration forall a. Semigroup a => a -> a -> a
<> Flags
Flags.strong
| Bool
otherwise = forall a. Monoid a => a
mempty
where
infer_dur :: Bool
infer_dur = Bool
block_end Bool -> Bool -> Bool
&& Bool
zero_dur
track_start :: Bool
track_start = Maybe TrackTime
start forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TrackTime
0
block_end :: Bool
block_end = Maybe TrackTime
start forall a. Eq a => a -> a -> Bool
== forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.block_end Environ
environ
start :: Maybe TrackTime
start = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall a. [a] -> Maybe a
Lists.head (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Frame -> Maybe (TrackTime, TrackTime)
Stack.region_of (Stack -> [Frame]
Stack.innermost Stack
stack))
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
| RealTime
cur_dur forall a. Ord a => a -> a -> Bool
> RealTime
0 = RealTime
cur_dur
| RealTime
next_dur forall a. Ord a => a -> a -> Bool
<= RealTime
0 Bool -> Bool -> Bool
&& RealTime
rest forall a. Ord a => a -> a -> Bool
> RealTime
0 = RealTime
rest
| Bool
otherwise = RealTime
next_pos forall a. Num a => a -> a -> a
- RealTime
cur_pos
where rest :: RealTime
rest = RealTime
next_pos forall a. Num a => a -> a -> a
+ RealTime
next_dur forall a. Num a => a -> a -> a
- RealTime
cur_pos
min_duration :: RealTime
min_duration :: RealTime
min_duration = RealTime
1 forall a. Fractional a => a -> a -> a
/ RealTime
64
duration_attributes :: Config -> ScoreT.ControlValMap -> Attrs.Attributes
-> RealTime -> RealTime -> RealTime
duration_attributes :: Config
-> ControlValMap -> Attributes -> RealTime -> RealTime -> RealTime
duration_attributes Config
config ControlValMap
controls Attributes
attrs RealTime
start RealTime
end
| RealTime
start forall a. Ord a => a -> a -> Bool
>= RealTime
end = RealTime
end
| Just Y
set_dur <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
Controls.sustain_set ControlValMap
controls, Bool
use_sustain =
RealTime
start forall a. Num a => a -> a -> a
+ forall a. Ord a => a -> a -> a
max RealTime
min_duration (Y -> RealTime
RealTime.seconds Y
set_dur)
| Bool
otherwise = RealTime
start forall a. Num a => a -> a -> a
+ forall a. Ord a => a -> a -> a
max RealTime
min_duration (RealTime
dur forall a. Num a => a -> a -> a
* RealTime
sustain 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 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_ 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
deflt Y -> RealTime
RealTime.seconds
(forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control ControlValMap
controls)