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

-- | Functions for instrument cmds.  This is called DUtil because there is also
-- "Cmd.Instrument.CUtil" and they are usually imported together.
--
-- I need a better name than \"Util\" for everything.
module Derive.Instrument.DUtil where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Util.Log as Log
import qualified Cmd.Cmd as Cmd
import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.C.Prelude.Note as Note
import qualified Derive.Call as Call
import qualified Derive.Call.GraceUtil as GraceUtil
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Flags as Flags
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import           Global
import           Types


generator :: Derive.CallName -> Doc.Doc
    -> Derive.WithArgDoc (Derive.GeneratorF d)
    -> Derive.Generator d
generator :: forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.instrument CallName
name forall a. Monoid a => a
mempty

generator0 :: Derive.Taggable d => Derive.CallName -> Doc.Doc
    -> (Derive.PassedArgs d -> Derive.Deriver (Stream.Stream d))
    -> Derive.Generator d
generator0 :: forall d.
Taggable d =>
CallName
-> Doc -> (PassedArgs d -> Deriver (Stream d)) -> Generator d
generator0 CallName
name Doc
doc PassedArgs d -> Deriver (Stream d)
call = forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name Doc
doc (forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 PassedArgs d -> Deriver (Stream d)
call)

transformer :: Derive.CallName -> Doc.Doc
    -> Derive.WithArgDoc (Derive.TransformerF d) -> Derive.Transformer d
transformer :: forall d.
CallName -> Doc -> WithArgDoc (TransformerF d) -> Transformer d
transformer CallName
name Doc
doc =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.instrument CallName
name forall a. Monoid a => a
mempty Doc
doc

transformer0 :: Derive.Taggable d => Derive.CallName -> Doc.Doc
    -> Derive.TransformerF d -> Derive.Transformer d
transformer0 :: forall d.
Taggable d =>
CallName -> Doc -> TransformerF d -> Transformer d
transformer0 CallName
name Doc
doc TransformerF d
call =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.instrument CallName
name forall a. Monoid a => a
mempty Doc
doc (forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t TransformerF d
call)

-- | Make a call that simply calls the default note call with the given attrs.
attributes_note :: Attrs.Attributes -> Derive.Generator Derive.Note
attributes_note :: Attributes -> Generator Event
attributes_note Attributes
attrs =
    forall d.
Taggable d =>
CallName
-> Doc -> (PassedArgs d -> Deriver (Stream d)) -> Generator d
generator0 (Text -> CallName
Derive.CallName forall a b. (a -> b) -> a -> b
$ Text
"attributes_note " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
attrs)
        Doc
"Invoke the default note call with the given attrs." forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args ->
    forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs (PassedArgs Event -> NoteDeriver
Call.reapply_note PassedArgs Event
args)

zero_duration_transform :: Doc.Doc
    -> (Derive.NoteArgs -> Derive.NoteDeriver -> Derive.NoteDeriver)
    -> Derive.Generator Derive.Note
zero_duration_transform :: Doc
-> (PassedArgs Event -> NoteDeriver -> NoteDeriver)
-> Generator Event
zero_duration_transform Doc
doc PassedArgs Event -> NoteDeriver -> NoteDeriver
transform = Doc
-> Tags
-> (PassedArgs Event -> NoteDeriver -> NoteDeriver)
-> Generator Event
Note.transformed_note
    (Doc
"A normal note, but modified when it has zero duration: " forall a. Semigroup a => a -> a -> a
<> Doc
doc)
    forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args NoteDeriver
deriver ->
        forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall a. PassedArgs a -> Deriver Bool
is_zero_duration PassedArgs Event
args) (PassedArgs Event -> NoteDeriver -> NoteDeriver
transform PassedArgs Event
args NoteDeriver
deriver) NoteDeriver
deriver

-- | Create a generator that has a different implementation for zero and
-- non-zero duration.
zero_duration :: Derive.CallName -> Doc.Doc
    -> (Derive.NoteArgs -> Derive.NoteDeriver)
    -> (Derive.NoteArgs -> Derive.NoteDeriver) -> Derive.Generator Derive.Note
zero_duration :: CallName
-> Doc
-> (PassedArgs Event -> NoteDeriver)
-> (PassedArgs Event -> NoteDeriver)
-> Generator Event
zero_duration CallName
name Doc
doc PassedArgs Event -> NoteDeriver
zero PassedArgs Event -> NoteDeriver
non_zero = forall d.
Taggable d =>
CallName
-> Doc -> (PassedArgs d -> Deriver (Stream d)) -> Generator d
generator0 CallName
name Doc
doc forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args ->
    forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall a. PassedArgs a -> Deriver Bool
is_zero_duration PassedArgs Event
args) (PassedArgs Event -> NoteDeriver
zero PassedArgs Event
args) (PassedArgs Event -> NoteDeriver
non_zero PassedArgs Event
args)

is_zero_duration :: Derive.PassedArgs a -> Derive.Deriver Bool
is_zero_duration :: forall a. PassedArgs a -> Deriver Bool
is_zero_duration PassedArgs a
args
    | forall a. PassedArgs a -> TrackTime
Args.duration PassedArgs a
args forall a. Eq a => a -> a -> Bool
== TrackTime
0 = do
        -- It turns out it's hard to figure out if a note has zero
        -- duration, and isn't just an infer-duration note.
        Stack
stack <- Deriver Stack
Internal.get_stack
        Environ
environ <- Deriver Environ
Derive.get_environ
        Bool
zero <- (forall a. Eq a => a -> a -> Bool
==RealTime
0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PassedArgs a -> Deriver RealTime
Args.real_duration PassedArgs a
args
        let flags :: Flags
flags = Bool -> Stack -> Environ -> Flags
Note.note_flags Bool
zero Stack
stack Environ
environ
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
zero Bool -> Bool -> Bool
&& Bool -> Bool
not (Flags
flags Flags -> Flags -> Bool
`Flags.has` Flags
Flags.infer_duration)
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Just like the default note call, except apply a function to the output.
postproc_note :: Derive.CallName -> Doc.Doc -> (Score.Event -> Score.Event)
    -> Derive.Generator Derive.Note
postproc_note :: CallName -> Doc -> (Event -> Event) -> Generator Event
postproc_note CallName
name Doc
doc Event -> Event
f = forall d.
CallName
-> Doc
-> Generator d
-> (Deriver (Stream d) -> Deriver (Stream d))
-> Generator d
postproc_generator CallName
name Doc
doc Generator Event
Note.c_note forall {f :: * -> *} {f :: * -> *}.
(Functor f, Functor f) =>
f (f Event) -> f (f Event)
apply
    where apply :: f (f Event) -> f (f Event)
apply f (f Event)
d = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> Event
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f Event)
d

-- | Transform an existing call by applying a function to it.  It gets a new
-- name and the documentation is prepended to the documentation of the original
-- call.
postproc_generator :: Derive.CallName -> Doc.Doc -> Derive.Generator d
    -> (Derive.Deriver (Stream.Stream d) -> Derive.Deriver (Stream.Stream d))
    -> Derive.Generator d
postproc_generator :: forall d.
CallName
-> Doc
-> Generator d
-> (Deriver (Stream d) -> Deriver (Stream d))
-> Generator d
postproc_generator CallName
name Doc
new_doc (Derive.Call CallName
_ CallDoc
old_doc GeneratorFunc d
func) Deriver (Stream d) -> Deriver (Stream d)
f = Derive.Call
    { call_name :: CallName
call_name = CallName
name
    , call_doc :: CallDoc
call_doc = Doc -> CallDoc -> CallDoc
append_doc Doc
new_doc CallDoc
old_doc
    , call_func :: GeneratorFunc d
call_func = GeneratorFunc d
func { gfunc_f :: GeneratorF d
Derive.gfunc_f = Deriver (Stream d) -> Deriver (Stream d)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. GeneratorFunc d -> GeneratorF d
Derive.gfunc_f GeneratorFunc d
func }
    }
    where
    append_doc :: Doc -> CallDoc -> CallDoc
append_doc Doc
text (Derive.CallDoc Module
tags Tags
module_ Doc
doc [ArgDoc]
args) =
        Module -> Tags -> Doc -> [ArgDoc] -> CallDoc
Derive.CallDoc Module
tags Tags
module_ (Doc
doc forall a. Semigroup a => a -> a -> a
<> Doc
"\n" forall a. Semigroup a => a -> a -> a
<> Doc
text) [ArgDoc]
args

multiple_calls :: [(Expr.Symbol, [Expr.Symbol])]
    -> [(Expr.Symbol, Derive.Generator Derive.Note)]
multiple_calls :: [(Symbol, [Symbol])] -> [(Symbol, Generator Event)]
multiple_calls [(Symbol, [Symbol])]
calls =
    [ (Symbol
call, CallName -> [Symbol] -> Generator Event
multiple_call (Symbol -> CallName
Derive.sym_to_call_name Symbol
call) [Symbol]
subcalls)
    | (Symbol
call, [Symbol]
subcalls) <- [(Symbol, [Symbol])]
calls
    ]

-- | Create a call that just dispatches to other calls.
multiple_call :: Derive.CallName -> [Expr.Symbol]
    -> Derive.Generator Derive.Note
multiple_call :: CallName -> [Symbol] -> Generator Event
multiple_call CallName
name [Symbol]
calls = forall d.
Taggable d =>
CallName
-> Doc -> (PassedArgs d -> Deriver (Stream d)) -> Generator d
generator0 CallName
name
    -- I intentionally omit the calls from the doc string, so they will
    -- combine in the call doc.  Presumably the calls are apparent from the
    -- name.
    Doc
"Dispatch to multiple calls." forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args ->
        forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (forall d.
Callable (Generator d) =>
PassedArgs d -> Symbol -> Deriver (Stream d)
Eval.reapply_generator PassedArgs Event
args) [Symbol]
calls

-- | The grace note falls either before or after the beat.
data Placement = Before | After deriving (Int -> Placement -> ShowS
[Placement] -> ShowS
Placement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Placement] -> ShowS
$cshowList :: [Placement] -> ShowS
show :: Placement -> String
$cshow :: Placement -> String
showsPrec :: Int -> Placement -> ShowS
$cshowsPrec :: Int -> Placement -> ShowS
Show, Placement -> Placement -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Placement -> Placement -> Bool
$c/= :: Placement -> Placement -> Bool
== :: Placement -> Placement -> Bool
$c== :: Placement -> Placement -> Bool
Eq)

doubled_call :: Expr.Symbol -> Derive.CallName -> Placement -> RealTime
    -> Signal.Y -> Derive.Generator Derive.Note
doubled_call :: Symbol -> CallName -> Placement -> RealTime -> Y -> Generator Event
doubled_call Symbol
callee CallName
name Placement
place RealTime
default_time Y
default_dyn_scale = forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name
    (Doc
"Doubled call. The grace note falls "
        forall a. Semigroup a => a -> a -> a
<> (if Placement
place forall a. Eq a => a -> a -> Bool
== Placement
Before then Doc
"before" else Doc
"after") forall a. Semigroup a => a -> a -> a
<> Doc
" the beat.")
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
default_time)
        Doc
"Time between the strokes."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dyn" Y
default_dyn_scale Doc
"Dyn scale for the grace note."
    ) forall a b. (a -> b) -> a -> b
$ \(Typecheck.DefaultReal Duration
time, Y
dyn_scale) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> do
        Y
dyn <- RealTime -> Deriver State Error Y
Call.dynamic forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Event
args
        let with_dyn :: Deriver a -> Deriver a
with_dyn = forall a. Y -> Deriver a -> Deriver a
Call.with_dynamic (Y
dyn forall a. Num a => a -> a -> a
* Y
dyn_scale)
        let note :: NoteDeriver
note = forall d.
Callable (Generator d) =>
PassedArgs d -> Symbol -> Deriver (Stream d)
Eval.reapply_generator_normalized PassedArgs Event
args Symbol
callee
        [Event]
notes <- forall a.
NoteDeriver
-> Int -> Duration -> Normalized -> PassedArgs a -> Deriver [Event]
GraceUtil.repeat_notes NoteDeriver
note Int
2 Duration
time
            (Y -> Normalized
Typecheck.Normalized forall a b. (a -> b) -> a -> b
$ if Placement
place forall a. Eq a => a -> a -> Bool
== Placement
Before then Y
0 else Y
1) PassedArgs Event
args
        case [Event]
notes of
            [Event
first, Event
second]
                | Placement
place forall a. Eq a => a -> a -> Bool
== Placement
Before -> [Event] -> NoteDeriver
Sub.derive [forall {a}. Deriver a -> Deriver a
with_dyn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event
first, Event
second]
                | Bool
otherwise -> [Event] -> NoteDeriver
Sub.derive [Event
first, forall {a}. Deriver a -> Deriver a
with_dyn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event
second]
            -- Shouldn't happen, because I passed 2 to repeat_notes.
            [Event]
_ -> forall a. Stack => Text -> Deriver a
Derive.throw Text
"expected 2 notes"

-- * composite

composite_doc :: Doc.Doc
composite_doc :: Doc
composite_doc = Doc
"Composite instrument calls create notes for multiple\
    \ instruments, splitting pitch and control signals among them. The\
    \ composite instrument itself doesn't wind up in the output, so it\
    \ should have an empty allocation."

-- | A composite patch corresponds to multiple underlying patches.
--
-- This is useful for instruments with multiple pitches, e.g. a drum with
-- a keymap for strokes as well as a tuned pitch, or a pitched instrument with
-- a secondary pitch as a resonance.
data Composite = Composite {
    -- | Dispatch to this call.
    Composite -> Symbol
c_call :: !Expr.Symbol
    -- | And this instrument.
    , Composite -> Instrument
c_instrument :: !ScoreT.Instrument
    , Composite -> Pitch
c_pitch :: !Pitch
    , Composite -> Set Control
c_controls :: !Controls
    } deriving (Int -> Composite -> ShowS
[Composite] -> ShowS
Composite -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Composite] -> ShowS
$cshowList :: [Composite] -> ShowS
show :: Composite -> String
$cshow :: Composite -> String
showsPrec :: Int -> Composite -> ShowS
$cshowsPrec :: Int -> Composite -> ShowS
Show)

instance Pretty Composite where
    pretty :: Composite -> Text
pretty (Composite Symbol
call Instrument
inst Pitch
pitch Set Control
controls) = [Text] -> Text
Text.unwords
        [ forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
":", forall a. Pretty a => a -> Text
pretty Symbol
call, Text
ppitch
        , Set Control -> Text
show_controls Set Control
controls
        ]
        where
        ppitch :: Text
ppitch = case Pitch
pitch of
            Pitch
NoPitch -> Text
"(no pitch)"
            Pitch PControl
control -> forall a. ShowVal a => a -> Text
ShowVal.show_val PControl
control

data Pitch = NoPitch | Pitch ScoreT.PControl deriving (Int -> Pitch -> ShowS
[Pitch] -> ShowS
Pitch -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pitch] -> ShowS
$cshowList :: [Pitch] -> ShowS
show :: Pitch -> String
$cshow :: Pitch -> String
showsPrec :: Int -> Pitch -> ShowS
$cshowsPrec :: Int -> Pitch -> ShowS
Show)

-- | Assigning a control to a composite actually means the other composite
-- parts will *not* get it.  This is because derivers naturally inherit the
-- entire environment, and it seems better to list what it should have, and not
-- exhaustively list all it gets.
--
-- So if this is empty it gets all controls, and if it's not, it still gets the
-- named controls but other composites don't.
type Controls = Set ScoreT.Control

show_controls :: Controls -> Text
show_controls :: Set Control -> Text
show_controls Set Control
cs
    | forall a. Set a -> Bool
Set.null Set Control
cs = Text
"(all)"
    | Bool
otherwise = forall a. Pretty a => a -> Text
pretty Set Control
cs

controls_doc :: Controls -> Doc.Doc
controls_doc :: Set Control -> Doc
controls_doc = Text -> Doc
Doc.Doc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Control -> Text
show_controls

redirect_pitch :: Derive.CallName -> Expr.Symbol -> Controls
    -> Expr.Symbol -> Controls -> Derive.Generator Derive.Note
redirect_pitch :: CallName
-> Symbol
-> Set Control
-> Symbol
-> Set Control
-> Generator Event
redirect_pitch CallName
name Symbol
pitched_call Set Control
pitched_controls Symbol
unpitched_call
        Set Control
unpitched_controls =
    forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name (Doc
"A composite instrument splits pitch and controls to\
        \ separate instruments.\n" forall a. Semigroup a => a -> a -> a
<> Doc
composite_doc)
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ ArgName
"pitched" EnvironDefault
Sig.Prefixed
        (Doc
"This instrument gets the pitch signal and controls: "
            forall a. Semigroup a => a -> a -> a
<> Set Control -> Doc
controls_doc Set Control
pitched_controls)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ ArgName
"unpitched" EnvironDefault
Sig.Prefixed
        (Doc
"This instrument gets controls: " forall a. Semigroup a => a -> a -> a
<> Set Control -> Doc
controls_doc Set Control
unpitched_controls)
    ) forall a b. (a -> b) -> a -> b
$ \(Instrument
pitched, Instrument
unpitched) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> PassedArgs Event -> [Composite] -> NoteDeriver
composite_call PassedArgs Event
args
        [ Symbol -> Instrument -> Pitch -> Set Control -> Composite
Composite Symbol
pitched_call Instrument
pitched (PControl -> Pitch
Pitch PControl
ScoreT.default_pitch)
            Set Control
pitched_controls
        , Symbol -> Instrument -> Pitch -> Set Control -> Composite
Composite Symbol
unpitched_call Instrument
unpitched Pitch
NoPitch Set Control
unpitched_controls
        ]

double_pitch :: Derive.CallName -> Controls -> ScoreT.PControl -> Controls
    -> Derive.Generator Derive.Note
double_pitch :: CallName
-> Set Control -> PControl -> Set Control -> Generator Event
double_pitch CallName
name Set Control
base_controls PControl
pcontrol Set Control
secondary_controls =
    forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name (Doc
"A composite instrument that has two pitch signals.\n"
        forall a. Semigroup a => a -> a -> a
<> Doc
composite_doc)
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ ArgName
"base-inst" EnvironDefault
Sig.Prefixed
        (Doc
"Instrument that gets `#`, and controls: "
            forall a. Semigroup a => a -> a -> a
<> Set Control -> Doc
controls_doc Set Control
base_controls)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ ArgName
"second-inst" EnvironDefault
Sig.Prefixed
        (Doc
"Instrument that gets " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc PControl
pcontrol
            forall a. Semigroup a => a -> a -> a
<> Doc
", and controls: " forall a. Semigroup a => a -> a -> a
<> Set Control -> Doc
controls_doc Set Control
secondary_controls)
    ) forall a b. (a -> b) -> a -> b
$ \(Instrument
inst1, Instrument
inst2) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> PassedArgs Event -> [Composite] -> NoteDeriver
composite_call PassedArgs Event
args
        [ Symbol -> Instrument -> Pitch -> Set Control -> Composite
Composite Symbol
"" Instrument
inst1 (PControl -> Pitch
Pitch PControl
ScoreT.default_pitch) Set Control
base_controls
        , Symbol -> Instrument -> Pitch -> Set Control -> Composite
Composite Symbol
"" Instrument
inst2 (PControl -> Pitch
Pitch PControl
pcontrol) Set Control
secondary_controls
        ]

-- | See 'Composite'.
composite_call :: Derive.NoteArgs -> [Composite] -> Derive.NoteDeriver
composite_call :: PassedArgs Event -> [Composite] -> NoteDeriver
composite_call PassedArgs Event
args [Composite]
composites = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (forall {d}.
Callable (Generator d) =>
PassedArgs d -> Composite -> Deriver (Stream d)
split PassedArgs Event
args) [Composite]
composites
    where
    split :: PassedArgs d -> Composite -> Deriver (Stream d)
split PassedArgs d
args (Composite Symbol
call Instrument
inst Pitch
pitch Set Control
controls) =
        forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Instrument
inst forall a b. (a -> b) -> a -> b
$ forall {a}. Pitch -> Deriver a -> Deriver a
with_pitch Pitch
pitch forall a b. (a -> b) -> a -> b
$
        forall {a}. Set Control -> Deriver a -> Deriver a
replace_controls Set Control
controls forall a b. (a -> b) -> a -> b
$
        forall d.
Callable (Generator d) =>
PassedArgs d -> Symbol -> Deriver (Stream d)
Eval.reapply_generator PassedArgs d
args Symbol
call
    with_pitch :: Pitch -> Deriver a -> Deriver a
with_pitch Pitch
p Deriver a
deriver = case Pitch
p of
        Pitch
NoPitch -> forall a. PSignal -> Deriver a -> Deriver a
Derive.with_pitch forall a. Monoid a => a
mempty Deriver a
deriver
        Pitch PControl
control
            | PControl
control forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch -> Deriver a
deriver
            | Bool
otherwise -> do
                Maybe PSignal
mb_psig <- PControl -> Deriver (Maybe PSignal)
Derive.lookup_pitch_signal PControl
control
                forall a. PSignal -> Deriver a -> Deriver a
Derive.with_pitch (forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe PSignal
mb_psig) Deriver a
deriver
    replace_controls :: Set Control -> Deriver a -> Deriver a
replace_controls Set Control
controls Deriver a
deriver = do
        -- This is not so much add the desired controls, because they're all
        -- ready there, but remove the rest.
        let not_mine :: Set Control
not_mine = Set Control
used_controls forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Control
controls
        forall a. [Control] -> Deriver a -> Deriver a
Derive.remove_controls (forall a. Set a -> [a]
Set.toList Set Control
not_mine) Deriver a
deriver
    used_controls :: Set Control
used_controls = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap Composite -> Set Control
c_controls [Composite]
composites


-- * control vals

constant_pitch :: Derive.Generator Derive.Note
constant_pitch :: Generator Event
constant_pitch = Bool -> Set Control -> Generator Event
constant_controls Bool
True forall a. Monoid a => a
mempty

constant_controls :: Bool -> Set ScoreT.Control -> Derive.Generator Derive.Note
constant_controls :: Bool -> Set Control -> Generator Event
constant_controls Bool
constant_pitch Set Control
controls =
    Doc
-> Tags
-> (PassedArgs Event -> NoteDeriver -> NoteDeriver)
-> Generator Event
Note.transformed_note Doc
doc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args ->
        (if Bool
constant_pitch then forall b a. PassedArgs b -> Deriver a -> Deriver a
set_constant_pitch PassedArgs Event
args else forall a. a -> a
id)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Set Control -> PassedArgs b -> Deriver a -> Deriver a
set_constant_controls Set Control
controls PassedArgs Event
args
    where
    doc :: Doc
doc = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Doc
"Notes have a constant pitch, sampled at attack time."
            | Bool
constant_pitch]
        , [ Doc
"These controls are sampled at attack time, which means they work\
                \ with ControlFunctions: "
                forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
Doc.commas (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
Doc.pretty (forall a. Set a -> [a]
Set.toList Set Control
controls)) forall a. Semigroup a => a -> a -> a
<> Doc
".\n"
            | Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set Control
controls)
          ]
        ]

set_constant_controls :: Set ScoreT.Control -> Derive.PassedArgs b
    -> Derive.Deriver a -> Derive.Deriver a
set_constant_controls :: forall b a. Set Control -> PassedArgs b -> Deriver a -> Deriver a
set_constant_controls Set Control
controls PassedArgs b
args Deriver a
deriver
    | forall a. Set a -> Bool
Set.null Set Control
controls = Deriver a
deriver
    | Bool
otherwise = do
        ControlValMap
vals <- RealTime -> Deriver State Error ControlValMap
Derive.controls_at forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs b
args
        let sampled :: Map Control (Typed (Signal kind))
sampled = 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
<$>
                forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Control
k Y
_ -> Control
k forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Control
controls) ControlValMap
vals
        forall a. [(Control, Typed Control)] -> Deriver a -> Deriver a
Derive.with_controls (forall k a. Map k a -> [(k, a)]
Map.toList forall {k} {kind :: k}. Map Control (Typed (Signal kind))
sampled) Deriver a
deriver

set_constant_pitch :: Derive.PassedArgs b -> Derive.Deriver a
    -> Derive.Deriver a
set_constant_pitch :: forall b a. PassedArgs b -> Deriver a -> Deriver a
set_constant_pitch PassedArgs b
args Deriver a
deriver = do
    Maybe Pitch
pitch <- RealTime -> Deriver State Error (Maybe Pitch)
Derive.pitch_at forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs b
args
    case Maybe Pitch
pitch of
        Maybe Pitch
Nothing -> Deriver a
deriver
        Just Pitch
pitch -> forall a. Pitch -> Deriver a -> Deriver a
Derive.with_constant_pitch Pitch
pitch forall a b. (a -> b) -> a -> b
$
            forall b a. Set Control -> PassedArgs b -> Deriver a -> Deriver a
set_constant_controls Set Control
transposers PassedArgs b
args Deriver a
deriver
            where
            transposers :: Set Control
transposers = Scale -> Set Control
PSignal.pscale_transposers (forall a. RawPitch a -> Scale
PSignal.pitch_scale Pitch
pitch)

-- * postproc

element_from :: (Typecheck.Typecheck old, Typecheck.ToVal new) => EnvKey.Key
    -> (old -> Either Log.Msg new) -> Cmd.InstrumentPostproc
element_from :: forall old new.
(Typecheck old, ToVal new) =>
Text -> (old -> Either Msg new) -> InstrumentPostproc
element_from Text
key = forall old new.
(Typecheck old, ToVal new) =>
Text -> Text -> (old -> Either Msg new) -> InstrumentPostproc
move_val Text
key Text
EnvKey.element

element_from_id :: EnvKey.Key -> Cmd.InstrumentPostproc
element_from_id :: Text -> InstrumentPostproc
element_from_id Text
key =
    forall old new.
(Typecheck old, ToVal new) =>
Text -> Text -> (old -> Either Msg new) -> InstrumentPostproc
move_val Text
key Text
EnvKey.element (\Val
v -> forall a b. b -> Either a b
Right (Val
v :: DeriveT.Val))

-- | Move an environ val from one key to another.  This is meant to be put in
-- 'Cmd.Cmd.inst_postproc', because doing it in the note call may be too early.
move_val :: (Typecheck.Typecheck old, Typecheck.ToVal new) => EnvKey.Key
    -> EnvKey.Key -> (old -> Either Log.Msg new) -> Cmd.InstrumentPostproc
move_val :: forall old new.
(Typecheck old, ToVal new) =>
Text -> Text -> (old -> Either Msg new) -> InstrumentPostproc
move_val Text
old_key Text
new_key old -> Either Msg new
convert Event
event =
    case forall a. Typecheck a => Text -> Environ -> Maybe (Either Text a)
Env.checked_val2 Text
old_key (Event -> Environ
Score.event_environ Event
event) of
        Maybe (Either Text old)
Nothing -> (Event
event, [])
        Just (Left Text
err) -> (Event
event, [Msg
msg])
            where
            msg :: Msg
msg = Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn (forall a. a -> Maybe a
Just (Event -> Stack
Score.event_stack Event
event)) forall a b. (a -> b) -> a -> b
$
                Text
"postproc: " forall a. Semigroup a => a -> a -> a
<> Text
err
        Just (Right old
old) -> case old -> Either Msg new
convert old
old of
            Left Msg
msg ->
                ( Event
event
                , [Msg
msg { msg_stack :: Maybe Stack
Log.msg_stack = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Event -> Stack
Score.event_stack Event
event }]
                )
            Right new
new ->
                ((Environ -> Environ) -> Event -> Event
Score.modify_environ (forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
new_key new
new) Event
event, [])

with_symbolic_pitch :: Cmd.InstrumentPostproc
with_symbolic_pitch :: InstrumentPostproc
with_symbolic_pitch = forall val.
(Eq val, Typecheck val) =>
Text -> Maybe val -> InstrumentPostproc -> InstrumentPostproc
when_env Text
"symbolic-pitch" (forall a. a -> Maybe a
Just Bool
True) InstrumentPostproc
add_symbolic_pitch

add_symbolic_pitch :: Cmd.InstrumentPostproc
add_symbolic_pitch :: InstrumentPostproc
add_symbolic_pitch =
    (Transposed -> Either Text Note) -> InstrumentPostproc
add_symbolic_pitch_convert (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Either PitchError Note
PSignal.pitch_note)

add_symbolic_pitch_convert :: (PSignal.Transposed -> Either Text Pitch.Note)
    -> Cmd.InstrumentPostproc
add_symbolic_pitch_convert :: (Transposed -> Either Text Note) -> InstrumentPostproc
add_symbolic_pitch_convert Transposed -> Either Text Note
convert Event
event = forall a. LogId a -> (a, [Msg])
Log.run_id forall a b. (a -> b) -> a -> b
$
    case RealTime -> Event -> Maybe Transposed
Score.transposed_at (Event -> RealTime
Score.event_start Event
event) Event
event of
        Maybe Transposed
Nothing -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"no symbolic pitch for " forall a. Semigroup a => a -> a -> a
<> Event -> Text
Score.short_event Event
event
            forall (m :: * -> *) a. Monad m => a -> m a
return Event
event
        Just Transposed
pitch -> case Transposed -> Either Text Note
convert Transposed
pitch of
            Left Text
err -> do
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"converting symbolic pitch for "
                    forall a. Semigroup a => a -> a -> a
<> Event -> Text
Score.short_event Event
event forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
                forall (m :: * -> *) a. Monad m => a -> m a
return Event
event
            Right Note
note ->
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall key. ToVal key => Text -> key -> Event -> Event
set_environ Text
EnvKey.element (Note -> Text
Pitch.note_text Note
note) Event
event

set_environ :: Typecheck.ToVal key => EnvKey.Key -> key -> Score.Event
    -> Score.Event
set_environ :: forall key. ToVal key => Text -> key -> Event -> Event
set_environ Text
key key
val =
    Text -> (Maybe Val -> Val) -> Event -> Event
Score.modify_val Text
key (forall a b. a -> b -> a
const (forall a. ToVal a => a -> Val
Typecheck.to_val key
val))

when_env :: (Eq val, Typecheck.Typecheck val) => EnvKey.Key -> Maybe val
    -> Cmd.InstrumentPostproc -> Cmd.InstrumentPostproc
when_env :: forall val.
(Eq val, Typecheck val) =>
Text -> Maybe val -> InstrumentPostproc -> InstrumentPostproc
when_env Text
key Maybe val
val InstrumentPostproc
postproc Event
event
    | Maybe val
val forall a. Eq a => a -> a -> Bool
== forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
key (Event -> Environ
Score.event_environ Event
event) = InstrumentPostproc
postproc Event
event
    | Bool
otherwise = (Event
event, [])