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

module Derive.C.Prelude.Val (library) where
import qualified Data.Attoparsec.Text as A
import qualified Data.Map as Map

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.ParseText as ParseText

import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Call.PitchUtil as PitchUtil
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale as Scale
import qualified Derive.Scale.Theory as Theory
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 Derive.ValType as ValType

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

import qualified Ui.Event as Event
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


library :: Library.Library
library :: Library
library = [(Symbol, ValCall)] -> Library
Library.vals
    [ (Symbol
">", ValCall
c_next_val)
    , (Symbol
"<", ValCall
c_prev_val)
    , (Symbol
"next-event", ValCall
c_next_event)
    , (Symbol
"bpm", ValCall
c_bpm)
    , (Symbol
"env", ValCall
c_env)
    , (Symbol
"ts", ValCall
c_timestep)
    , (Symbol
"ts/", ValCall
c_timestep_reciprocal)
    , (Symbol
"1/", ValCall
c_reciprocal)
    , (Symbol
"nn", ValCall
c_nn)
    , (Symbol
"hz", ValCall
c_hz)
    -- literals
    , (Symbol
"list", ValCall
c_list)
    , (Symbol
"lrange", ValCall
c_lrange)
    , (Symbol
"st", ValCall
c_scoretime)
    , (Symbol
"rt", ValCall
c_realtime)
    , (Symbol
"pitch", ValCall
c_pitch)
    , (Symbol
"#", ValCall
c_pcontrol_ref)
    , (Symbol
"signal", ValCall
c_signal)
    , (Symbol
"psignal", ValCall
c_psignal)
    -- , ("control", c_control)
    -- , ("pcontrol", c_pcontrol)
    -- lookup
    , (Symbol
"<-#", ValCall
c_get_pitch)
    -- generate signals
    , (Symbol
"i>", ValCall
c_linear_next)
    , (Symbol
"e>", ValCall
c_exp_next)
    , (Symbol
"df", ValCall
c_down_from)
    ]

c_next_val :: Derive.ValCall
c_next_val :: ValCall
c_next_val = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"next-val" Tags
Tags.next
    Doc
"Evaluate the next event. Only works on pitch and control tracks, and\
    \ if the next event doesn't need its previous event."
    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
$ \PassedArgs Tagged
args -> do
        Event
event <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"no next event" forall a b. (a -> b) -> a -> b
$
            forall a. [a] -> Maybe a
Lists.head (forall a. PassedArgs a -> [Event]
Args.next_events PassedArgs Tagged
args)
        RealTime
start <- forall a. Time a => a -> Deriver RealTime
Derive.real (Event -> ScoreTime
Event.start Event
event)
        Event -> RealTime -> Maybe Type -> Deriver Val
next_val Event
event RealTime
start (forall val. Context val -> Maybe Type
Derive.ctx_track_type (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs Tagged
args))

next_val :: Event.Event -> RealTime -> Maybe ParseTitle.Type
    -> Derive.Deriver DeriveT.Val
next_val :: Event -> RealTime -> Maybe Type -> Deriver Val
next_val Event
event RealTime
start Maybe Type
ttype = case Maybe Type
ttype of
    Just Type
ParseTitle.ControlTrack -> RealTime -> Event -> Deriver Val
eval_control RealTime
start Event
event
    Just Type
ParseTitle.TempoTrack -> RealTime -> Event -> Deriver Val
eval_control RealTime
start Event
event
    Just Type
ParseTitle.PitchTrack -> do
        PSignal
signal <- forall {b}.
(Monoid b, Callable (Transformer b), Callable (Generator b),
 Callable (TrackCall b), Taggable b) =>
Event -> Deriver State Error b
eval Event
event
        case PSignal -> RealTime -> Maybe Pitch
PSignal.at PSignal
signal RealTime
start of
            Maybe Pitch
Nothing -> forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"next pitch event didn't emit a pitch"
            Just Pitch
pitch -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pitch -> Val
DeriveT.VPitch Pitch
pitch
    Just Type
ParseTitle.NoteTrack ->
        forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"can't get next value for note tracks"
    Maybe Type
Nothing -> forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"no track type"
    where
    eval_control :: RealTime -> Event -> Deriver Val
eval_control RealTime
start Event
event = do
        Control
signal <- forall {b}.
(Monoid b, Callable (Transformer b), Callable (Generator b),
 Callable (TrackCall b), Taggable b) =>
Event -> Deriver State Error b
eval Event
event
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Y -> Val
DeriveT.num forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Signal kind -> RealTime -> Y
Signal.at (Control
signal :: Signal.Control) RealTime
start
    eval :: Event -> Deriver State Error b
eval Event
event = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [a]
Stream.events_of forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => Text -> Deriver a
Derive.throw forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall d.
CallableExpr d =>
Event -> Deriver (Either Text (Stream d))
Eval.eval_event Event
event)

c_prev_val :: Derive.ValCall
c_prev_val :: ValCall
c_prev_val = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"prev-val" Tags
Tags.prev
    Doc
"Return the previous value. Only works on pitch and control tracks."
    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
$ \PassedArgs Tagged
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Tagged
args
        case forall a. PassedArgs a -> Maybe a
Args.prev_val PassedArgs Tagged
args of
            Just (Derive.TagControl Control
sig) ->
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Y -> Val
DeriveT.num forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Signal kind -> RealTime -> Y
Signal.at Control
sig RealTime
start
            Just (Derive.TagPitch PSignal
sig) ->
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"no previous pitch")
                    (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Val
DeriveT.VPitch) (PSignal -> RealTime -> Maybe Pitch
PSignal.at PSignal
sig RealTime
start)
            Maybe Tagged
_ -> forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"no previous value"

c_next_event :: Derive.ValCall
c_next_event :: ValCall
c_next_event = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"next-event" Tags
Tags.next
    Doc
"Start RealTime of the next event. Only used for tests."
    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
$ \PassedArgs Tagged
args -> do
        Event
event <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"no next event" forall a b. (a -> b) -> a -> b
$
            forall a. [a] -> Maybe a
Lists.head (forall a. PassedArgs a -> [Event]
Args.next_events PassedArgs Tagged
args)
        ScoreTime -> Deriver RealTime
Derive.score_to_real forall a b. (a -> b) -> a -> b
$ Event -> ScoreTime
Event.start Event
event

c_bpm :: Derive.ValCall
c_bpm :: ValCall
c_bpm = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"bpm" forall a. Monoid a => a
mempty Doc
"Convert bpm to tempo.  This is just (/60)."
    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 a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"bpm" Doc
"")
    forall a b. (a -> b) -> a -> b
$ \Y
bpm PassedArgs Tagged
_args -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Y
bpm :: Double) forall a. Fractional a => a -> a -> a
/ Y
60

c_env :: Derive.ValCall
c_env :: ValCall
c_env = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"env" forall a. Monoid a => a
mempty
    Doc
"Look up the given val in the environ."
    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 -> Doc -> Parser a
Sig.required ArgName
"name" Doc
"Look up the value of this key."
    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
"default" (forall a. Maybe a
Nothing :: Maybe DeriveT.Val)
        Doc
"If given, this is the default value when the key isn't present. If\
        \ not given, a missing key will throw an exception. The presence of\
        \ a default will also make the lookup expect the same type as the\
        \ default."
    ) forall a b. (a -> b) -> a -> b
$ \(Text
name, Maybe Val
maybe_deflt) PassedArgs Tagged
_args -> case Maybe Val
maybe_deflt of
        Maybe Val
Nothing -> forall a. Typecheck a => Text -> Deriver a
Derive.get_val Text
name
        Just Val
deflt -> forall {a}. Pretty a => a -> Val -> Maybe Val -> Deriver Val
check Text
name Val
deflt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
name
    where
    check :: a -> Val -> Maybe Val -> Deriver Val
check a
_ Val
deflt Maybe Val
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return Val
deflt
    check a
name Val
deflt (Just Val
val)
        | Val -> Val -> Bool
DeriveT.types_equal Val
deflt Val
val = forall (m :: * -> *) a. Monad m => a -> m a
return Val
val
        | Bool
otherwise = forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"env " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
name
            forall a. Semigroup a => a -> a -> a
<> Text
" expected " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.general_type_of Val
deflt)
            forall a. Semigroup a => a -> a -> a
<> Text
" but got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.general_type_of Val
val)

c_timestep :: Derive.ValCall
c_timestep :: ValCall
c_timestep = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"timestep" forall a. Monoid a => a
mempty
    (Doc
"Compute the duration of the given RelativeMark timestep at the current\
    \ position. This is for durations, so it only works with RelativeMark."
    ) 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 -> Doc -> Parser a
Sig.required ArgName
"rank" Doc
"Emit a duration of this rank."
    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
"steps" (Int
1 :: Int) Doc
"This number of steps of that rank."
    ) forall a b. (a -> b) -> a -> b
$ \(Rank
rank, Int
steps) PassedArgs Tagged
args -> ScoreTime -> Val
DeriveT.score_time forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ScoreTime -> Rank -> Int -> Deriver ScoreTime
Call.meter_duration (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Tagged
args) Rank
rank Int
steps

c_timestep_reciprocal :: Derive.ValCall
c_timestep_reciprocal :: ValCall
c_timestep_reciprocal = ValCall -> Module -> CallName -> Doc -> (Val -> Val) -> ValCall
Make.modify_vcall ValCall
c_timestep Module
Module.prelude
    CallName
"timestep-reciprocal"
    (Doc
"This is the same as `timestep` except it returns the reciprocal. This is\
    \ useful for e.g. trills which take cycles per second rather than duration."
    ) Val -> Val
reciprocal
    where
    reciprocal :: Val -> Val
reciprocal Val
val
        | Just Typed Y
num <- Val -> Maybe (Typed Y)
DeriveT.constant_val Val
val =
            Typed Control -> Val
DeriveT.VSignal forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Y -> Signal kind
Signal.constant forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => a -> a
recip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Y
num
        | Bool
otherwise = Val
val

c_reciprocal :: Derive.ValCall
c_reciprocal :: ValCall
c_reciprocal = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"reciprocal" forall a. Monoid a => a
mempty
    Doc
"Find the reciprocal of a number. Useful for tempo, e.g. set the tempo to\
    \ 1/time." 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 a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"num" Doc
"") forall a b. (a -> b) -> a -> b
$ \Y
num PassedArgs Tagged
_ ->
        if Y
num forall a. Eq a => a -> a -> Bool
== Y
0 then forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"1/0"
            else forall (m :: * -> *) a. Monad m => a -> m a
return (Y
1 forall a. Fractional a => a -> a -> a
/ Y
num :: Double)

c_nn :: Derive.ValCall
c_nn :: ValCall
c_nn = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"nn" forall a. Monoid a => a
mempty
    Doc
"Convert a pitch, hz, or twelve-tone pitch name to a NoteNumber.\
    \ A pitch name looks like `[a-g]s?[-1-9]`."
    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 a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"val" Doc
"") forall a b. (a -> b) -> a -> b
$ \Either Pitch (Either Y Str)
val PassedArgs Tagged
_ -> case Either Pitch (Either Y Str)
val of
        Left Pitch
pitch -> Transposed -> Deriver NoteNumber
Pitches.pitch_nn (forall a b. RawPitch a -> RawPitch b
PSignal.coerce (Pitch
pitch :: PSignal.Pitch))
        Right (Left Y
hz) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Y -> NoteNumber
Pitch.hz_to_nn Y
hz
        Right (Right Str
name) -> Str -> Deriver NoteNumber
get_name_nn Str
name

c_hz :: Derive.ValCall
c_hz :: ValCall
c_hz = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"hz" forall a. Monoid a => a
mempty
    Doc
"Convert a pitch, twelve-tone pitch name, or NoteNumber to hz.\
    \ A pitch name looks like `[a-g]s?[-1-9]`. If the octave isn't given, it\
    \ defaults to 0.  This is useful for `%just-base`, which ignores the\
    \ octave."
    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 a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"val" Doc
"") forall a b. (a -> b) -> a -> b
$ \Either Pitch (Either Str Y)
val PassedArgs Tagged
_ -> case Either Pitch (Either Str Y)
val of
        Left Pitch
pitch -> NoteNumber -> Y
Pitch.nn_to_hz forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Transposed -> Deriver NoteNumber
Pitches.pitch_nn (forall a b. RawPitch a -> RawPitch b
PSignal.coerce (Pitch
pitch :: PSignal.Pitch))
            -- Not transposed because they asked for a specific pitch.
        Right (Left Str
name) -> NoteNumber -> Y
Pitch.nn_to_hz forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Str -> Deriver NoteNumber
get_name_nn Str
name
        Right (Right Y
nn) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (NoteNumber -> Y
Pitch.nn_to_hz (Y -> NoteNumber
Pitch.NoteNumber Y
nn) :: Double)

get_name_nn :: Expr.Str -> Derive.Deriver Pitch.NoteNumber
get_name_nn :: Str -> Deriver NoteNumber
get_name_nn Str
name =
    forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"unknown pitch: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Str
name) forall a b. (a -> b) -> a -> b
$
        Text -> Maybe NoteNumber
parse_pitch_name (Str -> Text
Expr.unstr Str
name)

-- | c-1 is 0, g9 is 127.  The octave is optional, and defaults to 1.
parse_pitch_name :: Text -> Maybe Pitch.NoteNumber
parse_pitch_name :: Text -> Maybe NoteNumber
parse_pitch_name = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either Text a
ParseText.parse1 Parser Text NoteNumber
parse
    where
    parse :: Parser Text NoteNumber
parse = do
        Int
pc <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Char Int
pcs) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser Char
A.anyChar
        Int
sharp <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Int
0 forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
A.char Char
's' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
        Int
oct <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Int
1 forall a b. (a -> b) -> a -> b
$ Parser Text Int
ParseText.p_int
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> NoteNumber
Pitch.nn forall a b. (a -> b) -> a -> b
$ Int
pc forall a. Num a => a -> a -> a
+ Int
sharp forall a. Num a => a -> a -> a
+ (Int
octforall a. Num a => a -> a -> a
+Int
1) forall a. Num a => a -> a -> a
* Int
12
    pcs :: Map Char Int
pcs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Char]
"cdefgab" (forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) Int
0 [Int]
Theory.piano_intervals)

c_list :: Derive.ValCall
c_list :: ValCall
c_list = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"list" forall a. Monoid a => a
mempty Doc
"Create a list." 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 a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"val" Doc
"Value.") forall a b. (a -> b) -> a -> b
$ \[Val]
vals PassedArgs Tagged
_ ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Val] -> Val
DeriveT.VList [Val]
vals

c_lrange :: Derive.ValCall
c_lrange :: ValCall
c_lrange = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"range" forall a. Monoid a => a
mempty Doc
"Make a list range of numbers." 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 -> Doc -> Parser a
Sig.required ArgName
"start" Doc
"Start value."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"step" Doc
"Step."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"count" Doc
"Number of values."
    ) forall a b. (a -> b) -> a -> b
$ \(Y
start, Y
step, Y
count) PassedArgs Tagged
_ ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Val] -> Val
DeriveT.VList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Y -> Val
DeriveT.num forall a b. (a -> b) -> a -> b
$ forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.range Y
start Y
step Y
count

c_scoretime :: Derive.ValCall
c_scoretime :: ValCall
c_scoretime = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"scoretime" forall a. Monoid a => a
mempty
    Doc
"Convert a number to ScoreTime. This just changes the type annotation, the\
    \ value remains the same." 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 a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"val" EnvironDefault
Sig.None Doc
"") forall a b. (a -> b) -> a -> b
$ \Y
val PassedArgs Tagged
_ ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Y -> ScoreTime
ScoreTime.from_double Y
val

c_realtime :: Derive.ValCall
c_realtime :: ValCall
c_realtime = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"realtime" forall a. Monoid a => a
mempty
    Doc
"Convert a number to RealTime. This just changes the type annotation, the\
    \ value remains the same." 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 a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"val" EnvironDefault
Sig.None Doc
"") forall a b. (a -> b) -> a -> b
$ \Y
val PassedArgs Tagged
_ ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Y -> RealTime
RealTime.seconds Y
val

c_pitch :: Derive.ValCall
c_pitch :: ValCall
c_pitch = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"pitch" forall a. Monoid a => a
mempty Doc
"Create a 'Perform.Pitch.Pitch'."
    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 -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"oct" EnvironDefault
Sig.None (forall a b. a -> Either a b
Left Int
0 :: Either Int Int)
        Doc
"Octave, or a pitch name or pitch. If it's a pitch name or pitch, the\
        \ `pc` and `accs` args must be 0."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"pc" EnvironDefault
Sig.None (Int
0 :: Int) Doc
"Pitch class."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"accs" EnvironDefault
Sig.None (Int
0 :: Int) Doc
"Accidentals."
    ) forall a b. (a -> b) -> a -> b
$ \(Either Int (Either Text Pitch)
oct, Int
pc, Int
accs) PassedArgs Tagged
_ -> Either Int (Either Text Pitch) -> Int -> Int -> Deriver Pitch
make_pitch Either Int (Either Text Pitch)
oct Int
pc Int
accs

make_pitch :: Either Pitch.Octave (Either Text PSignal.Pitch)
    -> Pitch.PitchClass -> Pitch.Accidentals -> Derive.Deriver Pitch.Pitch
make_pitch :: Either Int (Either Text Pitch) -> Int -> Int -> Deriver Pitch
make_pitch (Left Int
oct) Int
pc Int
accs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Degree -> Pitch
Pitch.Pitch Int
oct (Int -> Int -> Degree
Pitch.Degree Int
pc Int
accs)
make_pitch (Right Either Text Pitch
name_pitch) Int
pc Int
accs
    | Int
pc forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
|| Int
accs forall a. Eq a => a -> a -> Bool
/= Int
0 = forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$
        Text
"pc and accs args must be 0 when a pitch is given: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Int
pc, Int
accs)
    | Bool
otherwise = do
        (Note
note, Scale
scale) <- case Either Text Pitch
name_pitch of
            Left Text
name -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Note
Pitch.Note Text
name) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Deriver Scale
Call.get_scale
            Right Pitch
pitch -> (,)
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transposed -> Deriver Note
Pitches.pitch_note (forall a b. RawPitch a -> RawPitch b
PSignal.coerce Pitch
pitch)
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScaleId -> Deriver Scale
Derive.get_scale (forall a. RawPitch a -> ScaleId
PSignal.pitch_scale_id Pitch
pitch)
        Environ
env <- Deriver Environ
Derive.get_environ
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => Text -> Deriver a
Derive.throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
env Note
note

c_pcontrol_ref :: Derive.ValCall
c_pcontrol_ref :: ValCall
c_pcontrol_ref = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"pcontrol-ref" forall a. Monoid a => a
mempty
    Doc
"Create a 'Derive.DeriveT.PControlRef'. For control literals, the\
    \ `#name` syntax suffices, but if you want to give a default pitch,\
    \ you need this call. This is because pitches are calls, and while\
    \ `%c,1` can be parsed as-is, `#p,(4c)` needs an evaluation."
    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 -> Doc -> Parser a
Sig.required ArgName
"name" Doc
"Name of pitch signal."
    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
"default" (forall a. Maybe a
Nothing :: Maybe PSignal.Pitch)
        Doc
"Default pitch, if the signal is not set."
    ) forall a b. (a -> b) -> a -> b
$ \(Text
name, Maybe Pitch
mb_default) PassedArgs Tagged
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall control val. control -> Maybe val -> Ref control val
DeriveT.Ref (Text -> PControl
ScoreT.PControl Text
name) (Pitch -> PSignal
PSignal.constant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Pitch
mb_default)

-- | This should be the inverse of ShowVal (ScoreT.Typed Signal.Control).
-- See 'DeriveT.show_signal'.
c_signal :: Derive.ValCall
c_signal :: ValCall
c_signal = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"signal" forall a. Monoid a => a
mempty
    Doc
"Create a signal. This is the control signal literal."
    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, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.optional_env ArgName
"type" EnvironDefault
Derive.None Text
"" Doc
"Type code."
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a b.
(Typecheck a, Typecheck b) =>
ArgName -> Doc -> Parser [(a, b)]
Sig.many_pairs ArgName
"breakpoints" Doc
"Breakpoints."
    ) forall a b. (a -> b) -> a -> b
$ \(Text
type_code, [(RealTime, Y)]
bps) PassedArgs Tagged
_ -> do
        Type
typ <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"unknown type code: " forall a. Semigroup a => a -> a -> a
<> Text
type_code)
            (Text -> Maybe Type
ScoreT.code_to_type Text
type_code)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Typed Control -> Val
DeriveT.VSignal forall a b. (a -> b) -> a -> b
$ forall a. Type -> a -> Typed a
ScoreT.Typed Type
typ forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs [(RealTime, Y)]
bps

-- | Like c_signal, should be the inverse of ShowVal PSignal.PSignal, except
-- it can't because I can't show pitches.
-- See 'DeriveT.show_psignal'.
c_psignal :: Derive.ValCall
c_psignal :: ValCall
c_psignal = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"psignal" forall a. Monoid a => a
mempty Doc
"Create a pitch signal."
    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 a b.
(Typecheck a, Typecheck b) =>
ArgName -> Doc -> Parser [(a, b)]
Sig.many_pairs ArgName
"breakpoints" Doc
"Breakpoints.")
    forall a b. (a -> b) -> a -> b
$ \[(RealTime, Pitch)]
bps PassedArgs Tagged
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PSignal -> Val
DeriveT.VPSignal forall a b. (a -> b) -> a -> b
$ [(RealTime, Pitch)] -> PSignal
PSignal.from_pairs [(RealTime, Pitch)]
bps

{-
c_control :: Derive.ValCall
c_control = val_call "control" mempty
    "Reference to a signal. Like 'env' but specialized to a signal.\
    \ This is the literal backing the %c,1 syntax sugar."
    -- TODO except it's not, not yet
    $ Sig.call ((,)
    <$> Sig.required "name" "Look up a signal under this key."
    <*> Sig.defaulted "default" (Nothing :: Maybe (ScoreT.Typed Signal.Y))
        "Returned when the name isn't present."
    ) $ \(name, maybe_default) _args -> do
        Typecheck.lookup_signal name >>= \case
            Nothing -> Derive.require
                ("no control and no default: " <> ShowVal.show_val name)
                maybe_default
            Just tsig -> return tsig

c_pcontrol :: Derive.ValCall
c_pcontrol = val_call "pcontrol" mempty
    "Reference to a pitch signal. Like 'env' but specialized to a pitch signal.\
    \ This is the literal backing the #c,(4c) syntax sugar."
    $ Sig.call ((,)
    <$> Sig.required "name" "Look up a signal under this key."
    <*> Sig.defaulted "default" (Nothing :: Maybe Sig.Dummy)
        "Returned when the name isn't present."
    ) $ \(name, maybe_default) _args ->
        Typecheck.lookup_pitch_signal name >>= \case
            Nothing -> Derive.require
                ("no pitch control and no default: " <> ShowVal.show_val name)
                maybe_default
            Just psig -> return psig
-}

-- * lookup

c_get_pitch :: Derive.ValCall
c_get_pitch :: ValCall
c_get_pitch = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"pitch" forall a. Monoid a => a
mempty Doc
"Get the current pitch." 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 a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"control" (Text
"" :: Text)
        Doc
"The default pitch if empty, otherwise, get the named pitch.") forall a b. (a -> b) -> a -> b
$
    \PControl
control PassedArgs Tagged
args -> forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"pitch"
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PControl -> RealTime -> Deriver State Error (Maybe Pitch)
Derive.named_pitch_at PControl
control forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Tagged
args

-- * generate signals

c_linear_next :: Derive.ValCall
c_linear_next :: ValCall
c_linear_next = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"linear-next" forall a. Monoid a => a
mempty
    Doc
"Create straight lines between the given breakpoints."
    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 Parser (NonEmpty Val)
breakpoints_arg forall a b. (a -> b) -> a -> b
$ \NonEmpty Val
vals PassedArgs Tagged
args ->
        forall a.
Int -> Curve -> NonEmpty Val -> PassedArgs a -> Deriver Val
breakpoints Int
0 Curve
ControlUtil.Linear NonEmpty Val
vals PassedArgs Tagged
args

c_exp_next :: Derive.ValCall
c_exp_next :: ValCall
c_exp_next = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"exp-next" forall a. Monoid a => a
mempty
    Doc
"Create curved lines between the given breakpoints."
    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
"exp" (Y
2 :: Double) Doc
ControlUtil.exponential_doc
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (NonEmpty Val)
breakpoints_arg
    ) forall a b. (a -> b) -> a -> b
$ \(Y
exp, NonEmpty Val
vals) PassedArgs Tagged
args ->
        forall a.
Int -> Curve -> NonEmpty Val -> PassedArgs a -> Deriver Val
breakpoints Int
1 ((Y -> Y) -> Curve
ControlUtil.Function forall a b. (a -> b) -> a -> b
$ Y -> Y -> Y
ControlUtil.expon Y
exp) NonEmpty Val
vals PassedArgs Tagged
args

breakpoints_arg :: Sig.Parser (NonEmpty DeriveT.Val)
breakpoints_arg :: Parser (NonEmpty Val)
breakpoints_arg = forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"bp" Doc
"Breakpoints are distributed evenly between\
    \ the event start and the next event. They can be all numbers, or all\
    \ pitches."

c_down_from :: Derive.ValCall
c_down_from :: ValCall
c_down_from = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"down-from" forall a. Monoid a => a
mempty
    Doc
"Go down from a starting value at a certain rate."
    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
"from" (Y
1 :: Double) Doc
"Start at this value."
    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
"speed" (Y
1 :: Double) Doc
"Descend this amount per second."
    ) forall a b. (a -> b) -> a -> b
$ \(Y
from, Y
speed) PassedArgs Tagged
args -> do
        (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range_or_next PassedArgs Tagged
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Typed a
ScoreT.untyped forall a b. (a -> b) -> a -> b
$
            Maybe Y -> Maybe Y -> Y -> Y -> RealTime -> RealTime -> Control
ControlUtil.slope_to_limit (forall a. a -> Maybe a
Just Y
0) forall a. Maybe a
Nothing Y
from (-Y
speed) RealTime
start RealTime
end

-- ** implementation

breakpoints :: Int -> ControlUtil.Curve -> NonEmpty DeriveT.Val
    -> Derive.PassedArgs a -> Derive.Deriver DeriveT.Val
breakpoints :: forall a.
Int -> Curve -> NonEmpty Val -> PassedArgs a -> Deriver Val
breakpoints Int
argnum Curve
curve NonEmpty Val
vals PassedArgs a
args = do
    (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range_or_next PassedArgs a
args
    RealTime
srate <- Deriver RealTime
Call.get_srate
    Either [Y] [Pitch]
vals <- ScoreTime -> Int -> NonEmpty Val -> Deriver (Either [Y] [Pitch])
num_or_pitch (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args) Int
argnum NonEmpty Val
vals
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either [Y] [Pitch]
vals of
        Left [Y]
nums -> Typed Control -> Val
DeriveT.VSignal forall a b. (a -> b) -> a -> b
$
            forall a. a -> Typed a
ScoreT.untyped forall a b. (a -> b) -> a -> b
$ RealTime -> Curve -> [(RealTime, Y)] -> Control
ControlUtil.breakpoints RealTime
srate Curve
curve forall a b. (a -> b) -> a -> b
$
            forall a. RealTime -> RealTime -> [a] -> [(RealTime, a)]
ControlUtil.distribute RealTime
start RealTime
end [Y]
nums
        Right [Pitch]
pitches -> PSignal -> Val
DeriveT.VPSignal forall a b. (a -> b) -> a -> b
$
            RealTime -> Curve -> [(RealTime, Pitch)] -> PSignal
PitchUtil.breakpoints RealTime
srate Curve
curve forall a b. (a -> b) -> a -> b
$
            forall a. RealTime -> RealTime -> [a] -> [(RealTime, a)]
ControlUtil.distribute RealTime
start RealTime
end [Pitch]
pitches

-- | Insist that the vals be either all numbers or pitches.
--
-- TODO If 'Sig.Parser' supported Alternative, maybe I could build this as
-- a parser and get both shorter code and documentation.
num_or_pitch :: ScoreTime -> Int -> NonEmpty DeriveT.Val
    -> Derive.Deriver (Either [Signal.Y] [PSignal.Pitch])
num_or_pitch :: ScoreTime -> Int -> NonEmpty Val -> Deriver (Either [Y] [Pitch])
num_or_pitch ScoreTime
start Int
argnum (Val
val :| [Val]
vals) = case Val
val of
    Val
val | Just (ScoreT.Typed Type
ScoreT.Untyped Y
n) <- Val -> Maybe (Typed Y)
DeriveT.constant_val Val
val -> do
        [Y]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {b}.
Typecheck b =>
Type -> (Int, Val) -> Deriver State Error b
expect Type
tsig) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
argnum forall a. Num a => a -> a -> a
+ Int
1 ..] [Val]
vals)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (Y
n forall a. a -> [a] -> [a]
: [Y]
vals)
    DeriveT.VPitch Pitch
pitch -> do
        [Pitch]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {b}.
Typecheck b =>
Type -> (Int, Val) -> Deriver State Error b
expect Type
ValType.TPitch) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
argnum forall a. Num a => a -> a -> a
+ Int
1 ..] [Val]
vals)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Pitch
pitch forall a. a -> [a] -> [a]
: [Pitch]
vals)
    Val
_ -> forall a. Int -> ArgName -> Type -> Val -> Deriver a
type_error Int
argnum ArgName
"bp" (Type -> Type -> Type
ValType.TEither Type
tsig Type
ValType.TPitch) Val
val
    where
    tsig :: Type
tsig = NumType -> NumValue -> Type
ValType.TSignal NumType
ValType.TUntyped NumValue
ValType.TAny
    expect :: Type -> (Int, Val) -> Deriver State Error b
expect Type
typ (Int
argnum, Val
val) =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Int -> ArgName -> Type -> Val -> Deriver a
type_error Int
argnum ArgName
"bp" Type
typ Val
val) forall (m :: * -> *) a. Monad m => a -> m a
return
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Typecheck a => ScoreTime -> Val -> Deriver (Maybe a)
Typecheck.from_val_eval ScoreTime
start Val
val

type_error :: Int -> Derive.ArgName -> ValType.Type -> DeriveT.Val
    -> Derive.Deriver a
type_error :: forall a. Int -> ArgName -> Type -> Val -> Deriver a
type_error Int
argnum ArgName
name Type
expected Val
received =
    forall a. HasCallStack => ErrorVal -> Deriver a
Derive.throw_error forall a b. (a -> b) -> a -> b
$ CallError -> ErrorVal
Derive.CallError forall a b. (a -> b) -> a -> b
$ TypeErrorT -> CallError
Derive.TypeError forall a b. (a -> b) -> a -> b
$ Derive.TypeErrorT
        { error_place :: ErrorPlace
error_place = Int -> ErrorPlace
Derive.TypeErrorArg Int
argnum
        , error_source :: EvalSource
error_source = EvalSource
Derive.Literal
        , error_arg_name :: ArgName
error_arg_name = ArgName
name
        , error_expected :: Type
error_expected = Type
expected
        , error_received :: Maybe Val
error_received = forall a. a -> Maybe a
Just Val
received
        , error_derive :: Maybe Error
error_derive = forall a. Maybe a
Nothing
        }


-- * util

val_call :: Typecheck.ToVal a => Derive.CallName -> Tags.Tags -> Doc.Doc
    -> Derive.WithArgDoc (Derive.PassedArgs Derive.Tagged -> Derive.Deriver a)
    -> Derive.ValCall
val_call :: forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call = forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.prelude