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

{- | Utilities for calls.

    The convention for calls is that there is a function @c_something@ which
    is type NoteCall or ControlCall or whatever.  It then extracts what is
    needed from the PassedArgs and passes those values to a function
    @something@ which is of type NoteDeriver or ControlDeriver or whatever.
    The idea is that PassedArgs is a large dependency and it should be reduced
    immediately to what is needed.
-}
module Derive.Call where
import qualified Data.List as List
import qualified System.Random.Mersenne.Pure64 as Pure64

import qualified Util.Num as Num
import qualified Util.Random as Random
import qualified Cmd.TimeStep as TimeStep
import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Flags as Flags
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale as Scale
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Symbols as Symbols
import qualified Derive.Typecheck as Typecheck

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

import qualified Ui.Meter.Meter as Meter
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


-- * signals

-- | To accomodate both normal calls, which are in score time, and post
-- processing calls, which are in real time, these functions take RealTimes.
control_at :: DeriveT.ControlRef -> RealTime -> Derive.Deriver Signal.Y
control_at :: ControlRef -> RealTime -> Deriver Double
control_at ControlRef
control RealTime
pos = Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val (Typed Double -> Double)
-> Deriver State Error (Typed Double) -> Deriver Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ControlRef -> RealTime -> Deriver State Error (Typed Double)
typed_control_at ControlRef
control RealTime
pos

typed_control_at :: DeriveT.ControlRef -> RealTime
    -> Derive.Deriver (ScoreT.Typed Signal.Y)
typed_control_at :: ControlRef -> RealTime -> Deriver State Error (Typed Double)
typed_control_at ControlRef
control RealTime
pos = case ControlRef
control of
    DeriveT.ControlSignal Typed Control
sig -> Typed Double -> Deriver State Error (Typed Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed Double -> Deriver State Error (Typed Double))
-> Typed Double -> Deriver State Error (Typed Double)
forall a b. (a -> b) -> a -> b
$ RealTime -> Control -> Double
forall {k} (kind :: k). RealTime -> Signal kind -> Double
Signal.at RealTime
pos (Control -> Double) -> Typed Control -> Typed Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Control
sig
    DeriveT.DefaultedControl Control
cont Typed Control
deflt ->
        Typed Double -> Maybe (Typed Double) -> Typed Double
forall a. a -> Maybe a -> a
fromMaybe (RealTime -> Control -> Double
forall {k} (kind :: k). RealTime -> Signal kind -> Double
Signal.at RealTime
pos (Control -> Double) -> Typed Control -> Typed Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Control
deflt) (Maybe (Typed Double) -> Typed Double)
-> Deriver State Error (Maybe (Typed Double))
-> Deriver State Error (Typed Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Control -> RealTime -> Deriver State Error (Maybe (Typed Double))
Derive.control_at Control
cont RealTime
pos
    DeriveT.LiteralControl Control
cont ->
        Text -> Maybe (Typed Double) -> Deriver State Error (Typed Double)
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"not found and no default: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Control -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Control
cont)
            (Maybe (Typed Double) -> Deriver State Error (Typed Double))
-> Deriver State Error (Maybe (Typed Double))
-> Deriver State Error (Typed Double)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Control -> RealTime -> Deriver State Error (Maybe (Typed Double))
Derive.control_at Control
cont RealTime
pos

-- TODO callers should use Typecheck.DefaultRealTimeFunction
time_control_at :: Typecheck.TimeType -> DeriveT.ControlRef -> RealTime
    -> Derive.Deriver DeriveT.Duration
time_control_at :: TimeType -> ControlRef -> RealTime -> Deriver Duration
time_control_at TimeType
default_type ControlRef
control RealTime
pos = do
    ScoreT.Typed Type
typ Double
val <- ControlRef -> RealTime -> Deriver State Error (Typed Double)
typed_control_at ControlRef
control RealTime
pos
    TimeType
time_type <- case Type
typ of
        Type
ScoreT.Untyped -> TimeType -> Deriver State Error TimeType
forall (m :: * -> *) a. Monad m => a -> m a
return TimeType
default_type
        Type
ScoreT.Score -> TimeType -> Deriver State Error TimeType
forall (m :: * -> *) a. Monad m => a -> m a
return TimeType
Typecheck.Score
        Type
ScoreT.Real -> TimeType -> Deriver State Error TimeType
forall (m :: * -> *) a. Monad m => a -> m a
return TimeType
Typecheck.Real
        Type
_ -> Text -> Deriver State Error TimeType
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver State Error TimeType)
-> Text -> Deriver State Error TimeType
forall a b. (a -> b) -> a -> b
$ Text
"expected time type for "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ControlRef -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val ControlRef
control Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
typ
    Duration -> Deriver Duration
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> Deriver Duration) -> Duration -> Deriver Duration
forall a b. (a -> b) -> a -> b
$ case TimeType
time_type of
        TimeType
Typecheck.Real -> RealTime -> Duration
DeriveT.RealDuration (Double -> RealTime
RealTime.seconds Double
val)
        TimeType
Typecheck.Score -> ScoreTime -> Duration
DeriveT.ScoreDuration (Double -> ScoreTime
ScoreTime.from_double Double
val)

real_time_at :: DeriveT.ControlRef -> RealTime -> Derive.Deriver RealTime
real_time_at :: ControlRef -> RealTime -> Deriver RealTime
real_time_at ControlRef
control RealTime
pos = do
    Duration
val <- TimeType -> ControlRef -> RealTime -> Deriver Duration
time_control_at TimeType
Typecheck.Real ControlRef
control RealTime
pos
    case Duration
val of
        DeriveT.RealDuration RealTime
t -> RealTime -> Deriver RealTime
forall (m :: * -> *) a. Monad m => a -> m a
return RealTime
t
        DeriveT.ScoreDuration ScoreTime
t -> Text -> Deriver RealTime
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver RealTime) -> Text -> Deriver RealTime
forall a b. (a -> b) -> a -> b
$ Text
"expected RealTime for "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ControlRef -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val ControlRef
control Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScoreTime -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val ScoreTime
t

transpose_control_at :: Typecheck.TransposeType -> DeriveT.ControlRef
    -> RealTime -> Derive.Deriver (Signal.Y, Typecheck.TransposeType)
transpose_control_at :: TransposeType
-> ControlRef -> RealTime -> Deriver (Double, TransposeType)
transpose_control_at TransposeType
default_type ControlRef
control RealTime
pos = do
    ScoreT.Typed Type
typ Double
val <- ControlRef -> RealTime -> Deriver State Error (Typed Double)
typed_control_at ControlRef
control RealTime
pos
    TransposeType
transpose_type <- case Type
typ of
        Type
ScoreT.Untyped -> TransposeType -> Deriver State Error TransposeType
forall (m :: * -> *) a. Monad m => a -> m a
return TransposeType
default_type
        Type
ScoreT.Chromatic -> TransposeType -> Deriver State Error TransposeType
forall (m :: * -> *) a. Monad m => a -> m a
return TransposeType
Typecheck.Chromatic
        Type
ScoreT.Diatonic -> TransposeType -> Deriver State Error TransposeType
forall (m :: * -> *) a. Monad m => a -> m a
return TransposeType
Typecheck.Diatonic
        Type
_ -> Text -> Deriver State Error TransposeType
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver State Error TransposeType)
-> Text -> Deriver State Error TransposeType
forall a b. (a -> b) -> a -> b
$ Text
"expected transpose type for "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ControlRef -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val ControlRef
control Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
typ
    (Double, TransposeType) -> Deriver (Double, TransposeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
val, TransposeType
transpose_type)


-- * function and signal

to_function :: DeriveT.ControlRef -> Derive.Deriver Typecheck.Function
to_function :: ControlRef -> Deriver Function
to_function = ((RealTime -> Typed Double) -> Function)
-> Deriver State Error (RealTime -> Typed Double)
-> Deriver Function
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val .) (Deriver State Error (RealTime -> Typed Double)
 -> Deriver Function)
-> (ControlRef -> Deriver State Error (RealTime -> Typed Double))
-> ControlRef
-> Deriver Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlRef -> Deriver State Error (RealTime -> Typed Double)
Typecheck.to_typed_function

-- | Convert a ControlRef to a control signal.  If there is
-- a 'DeriveT.ControlFunction' it will be ignored.
to_typed_signal :: DeriveT.ControlRef
    -> Derive.Deriver (ScoreT.Typed Signal.Control)
to_typed_signal :: ControlRef -> Deriver (Typed Control)
to_typed_signal ControlRef
control =
    (Typed Control -> Deriver (Typed Control))
-> (ControlFunction -> Deriver (Typed Control))
-> Either (Typed Control) ControlFunction
-> Deriver (Typed Control)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Typed Control -> Deriver (Typed Control)
forall (m :: * -> *) a. Monad m => a -> m a
return (Deriver (Typed Control)
-> ControlFunction -> Deriver (Typed Control)
forall a b. a -> b -> a
const (Deriver (Typed Control)
 -> ControlFunction -> Deriver (Typed Control))
-> Deriver (Typed Control)
-> ControlFunction
-> Deriver (Typed Control)
forall a b. (a -> b) -> a -> b
$ Text -> Deriver (Typed Control)
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver (Typed Control))
-> Text -> Deriver (Typed Control)
forall a b. (a -> b) -> a -> b
$ Text
"not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ControlRef -> Text
forall a. Pretty a => a -> Text
pretty ControlRef
control)
        (Either (Typed Control) ControlFunction -> Deriver (Typed Control))
-> Deriver State Error (Either (Typed Control) ControlFunction)
-> Deriver (Typed Control)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ControlRef
-> Deriver State Error (Either (Typed Control) ControlFunction)
Typecheck.to_signal_or_function ControlRef
control

to_signal :: DeriveT.ControlRef -> Derive.Deriver Signal.Control
to_signal :: ControlRef -> Deriver Control
to_signal = (Typed Control -> Control)
-> Deriver (Typed Control) -> Deriver Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Typed Control -> Control
forall a. Typed a -> a
ScoreT.typed_val (Deriver (Typed Control) -> Deriver Control)
-> (ControlRef -> Deriver (Typed Control))
-> ControlRef
-> Deriver Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlRef -> Deriver (Typed Control)
to_typed_signal

-- | Version of 'to_function' specialized for transpose signals.  Throws if
-- the signal had a non-transpose type.
to_transpose_function :: Typecheck.TransposeType -> DeriveT.ControlRef
    -> Derive.Deriver (Typecheck.Function, ScoreT.Control)
    -- ^ (signal, appropriate transpose control)
to_transpose_function :: TransposeType -> ControlRef -> Deriver (Function, Control)
to_transpose_function TransposeType
default_type ControlRef
control = do
    RealTime -> Typed Double
sig <- ControlRef -> Deriver State Error (RealTime -> Typed Double)
Typecheck.to_typed_function ControlRef
control
    -- Previously, I directly returned ScoreT.Typed Signal.Control so I could
    -- look at their types.  A function is more powerful but I have to actually
    -- call it to find the type.
    let typ :: Type
typ = Typed Double -> Type
forall a. Typed a -> Type
ScoreT.type_of (RealTime -> Typed Double
sig RealTime
0)
        untyped :: Function
untyped = Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val (Typed Double -> Double) -> (RealTime -> Typed Double) -> Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Typed Double
sig
    case Type
typ of
        Type
ScoreT.Untyped ->
            (Function, Control) -> Deriver (Function, Control)
forall (m :: * -> *) a. Monad m => a -> m a
return (Function
untyped, TransposeType -> Control
Typecheck.transpose_control TransposeType
default_type)
        Type
_ -> case Type -> Maybe Control
Controls.transpose_type Type
typ of
            Just Control
control -> (Function, Control) -> Deriver (Function, Control)
forall (m :: * -> *) a. Monad m => a -> m a
return (Function
untyped, Control
control)
            Maybe Control
_ -> Text -> Deriver (Function, Control)
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver (Function, Control))
-> Text -> Deriver (Function, Control)
forall a b. (a -> b) -> a -> b
$ Text
"expected transpose type for "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ControlRef -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val ControlRef
control Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
typ

-- | Version of 'to_function' that will complain if the control isn't a time
-- type.
to_time_function :: Typecheck.TimeType -> DeriveT.ControlRef
    -> Derive.Deriver (Typecheck.Function, Typecheck.TimeType)
to_time_function :: TimeType -> ControlRef -> Deriver (Function, TimeType)
to_time_function TimeType
default_type ControlRef
control = do
    RealTime -> Typed Double
sig <- ControlRef -> Deriver State Error (RealTime -> Typed Double)
Typecheck.to_typed_function ControlRef
control
    let typ :: Type
typ = Typed Double -> Type
forall a. Typed a -> Type
ScoreT.type_of (RealTime -> Typed Double
sig RealTime
0)
        untyped :: Function
untyped = Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val (Typed Double -> Double) -> (RealTime -> Typed Double) -> Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Typed Double
sig
    case Type
typ of
        Type
ScoreT.Untyped -> (Function, TimeType) -> Deriver (Function, TimeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Function
untyped, TimeType
default_type)
        Type
ScoreT.Score -> (Function, TimeType) -> Deriver (Function, TimeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Function
untyped, TimeType
Typecheck.Score)
        Type
ScoreT.Real -> (Function, TimeType) -> Deriver (Function, TimeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Function
untyped, TimeType
Typecheck.Real)
        Type
_ -> Text -> Deriver (Function, TimeType)
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver (Function, TimeType))
-> Text -> Deriver (Function, TimeType)
forall a b. (a -> b) -> a -> b
$ Text
"expected time type for "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ControlRef -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val ControlRef
control Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
typ

-- TODO maybe pos should be be ScoreTime so I can pass it to eval_pitch?
pitch_at :: RealTime -> DeriveT.PControlRef -> Derive.Deriver PSignal.Pitch
pitch_at :: RealTime -> PControlRef -> Deriver Pitch
pitch_at = RealTime -> PControlRef -> Deriver Pitch
Typecheck.pitch_at

to_psignal :: DeriveT.PControlRef -> Derive.Deriver PSignal.PSignal
to_psignal :: PControlRef -> Deriver PSignal
to_psignal PControlRef
control = case PControlRef
control of
    DeriveT.ControlSignal PSignal
sig -> PSignal -> Deriver PSignal
forall (m :: * -> *) a. Monad m => a -> m a
return PSignal
sig
    DeriveT.DefaultedControl PControl
cont PSignal
deflt ->
        Deriver PSignal
-> (PSignal -> Deriver PSignal) -> Maybe PSignal -> Deriver PSignal
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PSignal -> Deriver PSignal
forall (m :: * -> *) a. Monad m => a -> m a
return PSignal
deflt) PSignal -> Deriver PSignal
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PSignal -> Deriver PSignal)
-> Deriver State Error (Maybe PSignal) -> Deriver PSignal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PControl -> Deriver State Error (Maybe PSignal)
Derive.get_named_pitch PControl
cont
    DeriveT.LiteralControl PControl
cont ->
        Text -> Maybe PSignal -> Deriver PSignal
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PControl -> Text
forall a. Show a => a -> Text
showt PControl
cont)
            (Maybe PSignal -> Deriver PSignal)
-> Deriver State Error (Maybe PSignal) -> Deriver PSignal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PControl -> Deriver State Error (Maybe PSignal)
Derive.get_named_pitch PControl
cont

nn_at :: RealTime -> DeriveT.PControlRef
    -> Derive.Deriver (Maybe Pitch.NoteNumber)
nn_at :: RealTime -> PControlRef -> Deriver (Maybe NoteNumber)
nn_at RealTime
pos PControlRef
control = -- TODO throw exception?
    Text -> Transposed -> Deriver (Maybe NoteNumber)
Derive.logged_pitch_nn (Text
"Util.nn_at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (RealTime, PControlRef) -> Text
forall a. Pretty a => a -> Text
pretty (RealTime
pos, PControlRef
control))
        (Transposed -> Deriver (Maybe NoteNumber))
-> Deriver State Error Transposed -> Deriver (Maybe NoteNumber)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Pitch -> Deriver State Error Transposed
Derive.resolve_pitch RealTime
pos
        (Pitch -> Deriver State Error Transposed)
-> Deriver Pitch -> Deriver State Error Transposed
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> PControlRef -> Deriver Pitch
pitch_at RealTime
pos PControlRef
control

real_duration_at :: Typecheck.TypedFunction -> RealTime
    -> Derive.Deriver RealTime
real_duration_at :: (RealTime -> Typed Double) -> RealTime -> Deriver RealTime
real_duration_at RealTime -> Typed Double
f RealTime
t = TimeType -> RealTime -> Typed Double -> Deriver RealTime
forall t.
Time t =>
TimeType -> t -> Typed Double -> Deriver RealTime
typed_real_duration TimeType
Typecheck.Real RealTime
t (RealTime -> Typed Double
f RealTime
t)

-- * dynamic

-- | Unlike 'Derive.pitch_at', the transposition has already been applied.
transposed :: RealTime -> Derive.Deriver (Maybe PSignal.Transposed)
transposed :: RealTime -> Deriver (Maybe Transposed)
transposed RealTime
pos =
    Deriver State Error (Maybe Pitch)
-> (Pitch -> Deriver (Maybe Transposed))
-> Deriver (Maybe Transposed)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (RealTime -> Deriver State Error (Maybe Pitch)
Derive.pitch_at RealTime
pos) ((Pitch -> Deriver (Maybe Transposed))
 -> Deriver (Maybe Transposed))
-> (Pitch -> Deriver (Maybe Transposed))
-> Deriver (Maybe Transposed)
forall a b. (a -> b) -> a -> b
$ (Transposed -> Maybe Transposed)
-> Deriver State Error Transposed -> Deriver (Maybe Transposed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Transposed -> Maybe Transposed
forall a. a -> Maybe a
Just (Deriver State Error Transposed -> Deriver (Maybe Transposed))
-> (Pitch -> Deriver State Error Transposed)
-> Pitch
-> Deriver (Maybe Transposed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Pitch -> Deriver State Error Transposed
Derive.resolve_pitch RealTime
pos

get_transposed :: RealTime -> Derive.Deriver PSignal.Transposed
get_transposed :: RealTime -> Deriver State Error Transposed
get_transposed RealTime
pos = Text -> Maybe Transposed -> Deriver State Error Transposed
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"no pitch at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
pos)
    (Maybe Transposed -> Deriver State Error Transposed)
-> Deriver (Maybe Transposed) -> Deriver State Error Transposed
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Deriver (Maybe Transposed)
transposed RealTime
pos

-- | Pitch without the transposition applied.  You have to use this if you
-- create an event with a pitch based on this pitch, otherwise the
-- transposition will be applied twice.
get_pitch :: RealTime -> Derive.Deriver PSignal.Pitch
get_pitch :: RealTime -> Deriver Pitch
get_pitch RealTime
pos = Text -> Maybe Pitch -> Deriver Pitch
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"no pitch at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
pos)
    (Maybe Pitch -> Deriver Pitch)
-> Deriver State Error (Maybe Pitch) -> Deriver Pitch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Deriver State Error (Maybe Pitch)
Derive.pitch_at RealTime
pos

get_pitch_here :: Derive.PassedArgs a -> Derive.Deriver PSignal.Pitch
get_pitch_here :: forall a. PassedArgs a -> Deriver Pitch
get_pitch_here = RealTime -> Deriver Pitch
get_pitch (RealTime -> Deriver Pitch)
-> (PassedArgs a -> Deriver RealTime)
-> PassedArgs a
-> Deriver Pitch
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< PassedArgs a -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
Args.real_start

-- | Get the symbolic version of the transposed pitch.  Since it's transposed,
-- if you turn it back to a 'PSignal.Pitch', you should use
-- 'with_transposed_pitch'.
get_parsed_pitch :: (Pitch.Note -> Maybe Pitch.Pitch)
    -- ^ Parse pitch function, as returned by 'get_pitch_functions'.
    -- It's passed separately to avoid the overhead of calling
    -- get_pitch_functions multiple times.
    -> RealTime -> Derive.Deriver Pitch.Pitch
get_parsed_pitch :: (Note -> Maybe Pitch) -> RealTime -> Deriver Pitch
get_parsed_pitch Note -> Maybe Pitch
parse = (Note -> Maybe Pitch) -> Transposed -> Deriver Pitch
forall a. (Note -> Maybe a) -> Transposed -> Deriver a
parse_pitch Note -> Maybe Pitch
parse (Transposed -> Deriver Pitch)
-> (RealTime -> Deriver State Error Transposed)
-> RealTime
-> Deriver Pitch
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< RealTime -> Deriver State Error Transposed
get_transposed

get_symbolic_pitch :: RealTime -> Derive.Deriver Pitch.Note
get_symbolic_pitch :: RealTime -> Deriver Note
get_symbolic_pitch = Transposed -> Deriver Note
Pitches.pitch_note (Transposed -> Deriver Note)
-> (RealTime -> Deriver State Error Transposed)
-> RealTime
-> Deriver Note
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< RealTime -> Deriver State Error Transposed
get_transposed

dynamic :: RealTime -> Derive.Deriver Signal.Y
dynamic :: RealTime -> Deriver Double
dynamic RealTime
pos = Double
-> (Typed Double -> Double) -> Maybe (Typed Double) -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
Derive.default_dynamic Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val (Maybe (Typed Double) -> Double)
-> Deriver State Error (Maybe (Typed Double)) -> Deriver Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Control -> RealTime -> Deriver State Error (Maybe (Typed Double))
Derive.control_at Control
Controls.dynamic RealTime
pos

with_pitch :: PSignal.Pitch -> Derive.Deriver a -> Derive.Deriver a
with_pitch :: forall a. Pitch -> Deriver a -> Deriver a
with_pitch = Pitch -> Deriver a -> Deriver a
forall a. Pitch -> Deriver a -> Deriver a
Derive.with_constant_pitch

with_transposed_pitch :: PSignal.Transposed -> Derive.Deriver a
    -> Derive.Deriver a
with_transposed_pitch :: forall a. Transposed -> Deriver a -> Deriver a
with_transposed_pitch Transposed
pitch =
    Deriver a -> Deriver a
forall a. Deriver a -> Deriver a
without_transpose (Deriver a -> Deriver a)
-> (Deriver a -> Deriver a) -> Deriver a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Deriver a -> Deriver a
forall a. Pitch -> Deriver a -> Deriver a
with_pitch (Transposed -> Pitch
forall a b. RawPitch a -> RawPitch b
PSignal.coerce Transposed
pitch)

without_transpose :: Derive.Deriver a -> Derive.Deriver a
without_transpose :: forall a. Deriver a -> Deriver a
without_transpose = [Control] -> Deriver a -> Deriver a
forall a. [Control] -> Deriver a -> Deriver a
Derive.remove_controls [Control]
Controls.transposers

with_symbolic_pitch :: DeriveT.PitchCall -> ScoreTime -> Derive.Deriver a
    -> Derive.Deriver a
with_symbolic_pitch :: forall a. PitchCall -> ScoreTime -> Deriver a -> Deriver a
with_symbolic_pitch PitchCall
call ScoreTime
pos Deriver a
deriver = do
    Pitch
pitch <- ScoreTime -> PitchCall -> Deriver Pitch
forall a. ScoreTime -> PitchCall -> Deriver (RawPitch a)
Eval.eval_pitch ScoreTime
pos PitchCall
call
    Pitch -> Deriver a -> Deriver a
forall a. Pitch -> Deriver a -> Deriver a
with_pitch Pitch
pitch Deriver a
deriver

-- | Replace the dynamic with the given one.
with_dynamic :: Signal.Y -> Derive.Deriver a -> Derive.Deriver a
with_dynamic :: forall a. Double -> Deriver a -> Deriver a
with_dynamic = Control -> Double -> Deriver a -> Deriver a
forall a. Control -> Double -> Deriver a -> Deriver a
with_constant Control
Controls.dynamic

multiply_dynamic :: Signal.Y -> Derive.Deriver a -> Derive.Deriver a
multiply_dynamic :: forall a. Double -> Deriver a -> Deriver a
multiply_dynamic = Control -> Double -> Deriver a -> Deriver a
forall a. Control -> Double -> Deriver a -> Deriver a
multiply_constant Control
Controls.dynamic

with_constant :: ScoreT.Control -> Signal.Y -> Derive.Deriver a
    -> Derive.Deriver a
with_constant :: forall a. Control -> Double -> Deriver a -> Deriver a
with_constant Control
control = Control -> Typed Control -> Deriver a -> Deriver a
forall a. Control -> Typed Control -> Deriver a -> Deriver a
Derive.with_control Control
control (Typed Control -> Deriver a -> Deriver a)
-> (Double -> Typed Control) -> Double -> Deriver a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped
    (Control -> Typed Control)
-> (Double -> Control) -> Double -> Typed Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Control
forall {k} (kind :: k). Double -> Signal kind
Signal.constant

add_control, multiply_control :: ScoreT.Control -> ScoreT.Typed Signal.Control
    -> Derive.Deriver a -> Derive.Deriver a
add_control :: forall a. Control -> Typed Control -> Deriver a -> Deriver a
add_control = Merger -> Control -> Typed Control -> Deriver a -> Deriver a
forall a.
Merger -> Control -> Typed Control -> Deriver a -> Deriver a
Derive.with_merged_control Merger
Derive.merge_add
multiply_control :: forall a. Control -> Typed Control -> Deriver a -> Deriver a
multiply_control = Merger -> Control -> Typed Control -> Deriver a -> Deriver a
forall a.
Merger -> Control -> Typed Control -> Deriver a -> Deriver a
Derive.with_merged_control Merger
Derive.merge_mul

add_constant, multiply_constant :: ScoreT.Control -> Signal.Y
    -> Derive.Deriver a -> Derive.Deriver a
multiply_constant :: forall a. Control -> Double -> Deriver a -> Deriver a
multiply_constant Control
control Double
val
    | Double
val Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
1 = Deriver a -> Deriver a
forall a. a -> a
id
    | Bool
otherwise = Merger -> Control -> Typed Control -> Deriver a -> Deriver a
forall a.
Merger -> Control -> Typed Control -> Deriver a -> Deriver a
Derive.with_merged_control Merger
Derive.merge_mul Control
control
        (Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Double -> Control
forall {k} (kind :: k). Double -> Signal kind
Signal.constant Double
val))
add_constant :: forall a. Control -> Double -> Deriver a -> Deriver a
add_constant Control
control Double
val
    | Double
val Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 = Deriver a -> Deriver a
forall a. a -> a
id
    | Bool
otherwise = Merger -> Control -> Typed Control -> Deriver a -> Deriver a
forall a.
Merger -> Control -> Typed Control -> Deriver a -> Deriver a
Derive.with_merged_control Merger
Derive.merge_add Control
control
        (Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Double -> Control
forall {k} (kind :: k). Double -> Signal kind
Signal.constant Double
val))

-- * environ

get_srate :: Derive.Deriver RealTime
get_srate :: Deriver RealTime
get_srate = Double -> RealTime
RealTime.seconds (Double -> RealTime) -> Deriver Double -> Deriver RealTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Deriver Double
forall a. Typecheck a => Text -> Deriver a
Derive.get_val Text
EnvKey.srate

get_scale :: Derive.Deriver Scale.Scale
get_scale :: Deriver Scale
get_scale = ScaleId -> Deriver Scale
Derive.get_scale (ScaleId -> Deriver Scale)
-> Deriver State Error ScaleId -> Deriver Scale
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver State Error ScaleId
get_scale_id

lookup_scale :: Derive.Deriver (Maybe Scale.Scale)
lookup_scale :: Deriver (Maybe Scale)
lookup_scale = ScaleId -> Deriver (Maybe Scale)
Derive.lookup_scale (ScaleId -> Deriver (Maybe Scale))
-> Deriver State Error ScaleId -> Deriver (Maybe Scale)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver State Error ScaleId
get_scale_id

get_scale_id :: Derive.Deriver Pitch.ScaleId
get_scale_id :: Deriver State Error ScaleId
get_scale_id = Str -> ScaleId
Expr.str_to_scale_id (Str -> ScaleId)
-> Deriver State Error Str -> Deriver State Error ScaleId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Deriver State Error Str
forall a. Typecheck a => Text -> Deriver a
Derive.get_val Text
EnvKey.scale

lookup_key :: Derive.Deriver (Maybe Pitch.Key)
lookup_key :: Deriver (Maybe Key)
lookup_key = (Text -> Key) -> Maybe Text -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Key
Pitch.Key (Maybe Text -> Maybe Key)
-> Deriver State Error (Maybe Text) -> Deriver (Maybe Key)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Deriver State Error (Maybe Text)
forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.key

get_instrument :: Derive.Deriver ScoreT.Instrument
get_instrument :: Deriver Instrument
get_instrument = Text -> Deriver Instrument
forall a. Typecheck a => Text -> Deriver a
Derive.get_val Text
EnvKey.instrument

lookup_instrument :: Derive.Deriver (Maybe ScoreT.Instrument)
lookup_instrument :: Deriver (Maybe Instrument)
lookup_instrument = Text -> Deriver (Maybe Instrument)
forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.instrument

get_attributes :: Derive.Deriver Attrs.Attributes
get_attributes :: Deriver Attributes
get_attributes = Attributes -> Maybe Attributes -> Attributes
forall a. a -> Maybe a -> a
fromMaybe Attributes
forall a. Monoid a => a
mempty (Maybe Attributes -> Attributes)
-> Deriver State Error (Maybe Attributes) -> Deriver Attributes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Deriver State Error (Maybe Attributes)
forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.attributes

-- * parsing pitches

-- | Get symbolic pitch manipulating functions for the current scale.  This
-- is for calls that want to work with symbolic pitches.
get_pitch_functions :: Derive.Deriver
    ( Pitch.Note -> Maybe Pitch.Pitch
    , Pitch.Pitch -> Maybe Pitch.Note
    , Scale.Transposition -> Pitch.Step -> Pitch.Pitch -> Maybe Pitch.Pitch
    )
get_pitch_functions :: Deriver
  (Note -> Maybe Pitch, Pitch -> Maybe Note,
   Transposition -> Int -> Pitch -> Maybe Pitch)
get_pitch_functions = do
    Scale
scale <- Deriver Scale
get_scale
    Environ
env <- Deriver Environ
Derive.get_environ
    let transpose :: Transposition -> Int -> Pitch -> Maybe Pitch
transpose Transposition
transposition Int
steps =
            Either PitchError Pitch -> Maybe Pitch
forall {a} {a}. Either a a -> Maybe a
to_maybe (Either PitchError Pitch -> Maybe Pitch)
-> (Pitch -> Either PitchError Pitch) -> Pitch -> Maybe Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> Transpose
Scale.scale_transpose Scale
scale Transposition
transposition Environ
env Int
steps
    (Note -> Maybe Pitch, Pitch -> Maybe Note,
 Transposition -> Int -> Pitch -> Maybe Pitch)
-> Deriver
     (Note -> Maybe Pitch, Pitch -> Maybe Note,
      Transposition -> Int -> Pitch -> Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( Either PitchError Pitch -> Maybe Pitch
forall {a} {a}. Either a a -> Maybe a
to_maybe (Either PitchError Pitch -> Maybe Pitch)
-> (Note -> Either PitchError Pitch) -> Note -> Maybe Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
env
        , Either PitchError Note -> Maybe Note
forall {a} {a}. Either a a -> Maybe a
to_maybe (Either PitchError Note -> Maybe Note)
-> (Pitch -> Either PitchError Note) -> Pitch -> Maybe Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> Environ -> Pitch -> Either PitchError Note
Scale.scale_show Scale
scale Environ
env
        , Transposition -> Int -> Pitch -> Maybe Pitch
transpose
        )
    where to_maybe :: Either a a -> Maybe a
to_maybe = (a -> Maybe a) -> (a -> Maybe a) -> Either a a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> a -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just

parse_pitch :: (Pitch.Note -> Maybe a) -> PSignal.Transposed
    -> Derive.Deriver a
parse_pitch :: forall a. (Note -> Maybe a) -> Transposed -> Deriver a
parse_pitch Note -> Maybe a
parse Transposed
pitch = do
    Note
note <- Transposed -> Deriver Note
Pitches.pitch_note Transposed
pitch
    Text -> Maybe a -> Deriver a
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"unparseable pitch" (Maybe a -> Deriver a) -> Maybe a -> Deriver a
forall a b. (a -> b) -> a -> b
$ Note -> Maybe a
parse Note
note

chromatic_difference :: PSignal.Transposed -> PSignal.Transposed
    -> Derive.Deriver Pitch.Semi
chromatic_difference :: Transposed -> Transposed -> Deriver Int
chromatic_difference = (Layout -> Pitch -> Pitch -> Int)
-> Transposed -> Transposed -> Deriver Int
forall a.
(Layout -> Pitch -> Pitch -> a)
-> Transposed -> Transposed -> Deriver a
pitch_difference Layout -> Pitch -> Pitch -> Int
Scale.chromatic_difference

diatonic_difference :: PSignal.Transposed -> PSignal.Transposed
    -> Derive.Deriver Pitch.PitchClass
diatonic_difference :: Transposed -> Transposed -> Deriver Int
diatonic_difference = (Layout -> Pitch -> Pitch -> Int)
-> Transposed -> Transposed -> Deriver Int
forall a.
(Layout -> Pitch -> Pitch -> a)
-> Transposed -> Transposed -> Deriver a
pitch_difference Layout -> Pitch -> Pitch -> Int
Scale.diatonic_difference

pitch_difference :: (Scale.Layout -> Pitch.Pitch -> Pitch.Pitch -> a)
    -> PSignal.Transposed -> PSignal.Transposed -> Derive.Deriver a
pitch_difference :: forall a.
(Layout -> Pitch -> Pitch -> a)
-> Transposed -> Transposed -> Deriver a
pitch_difference Layout -> Pitch -> Pitch -> a
difference Transposed
p1 Transposed
p2 = do
    Scale
scale <- Deriver Scale
get_scale
    Environ
env <- Deriver Environ
Derive.get_environ
    let parse :: Scale -> Environ -> Transposed -> Either PitchError Pitch
parse Scale
scale Environ
env = Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
env (Note -> Either PitchError Pitch)
-> (Transposed -> Either PitchError Note)
-> Transposed
-> Either PitchError Pitch
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Transposed -> Either PitchError Note
PSignal.pitch_note
    let msg :: Text
msg = Transposed -> Text
forall a. Pretty a => a -> Text
pretty Transposed
p1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Transposed -> Text
forall a. Pretty a => a -> Text
pretty Transposed
p2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
    (PitchError -> Text) -> Either PitchError a -> Deriver a
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right ((Text
msg<>) (Text -> Text) -> (PitchError -> Text) -> PitchError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchError -> Text
forall a. Pretty a => a -> Text
pretty) (Either PitchError a -> Deriver a)
-> Either PitchError a -> Deriver a
forall a b. (a -> b) -> a -> b
$
        Layout -> Pitch -> Pitch -> a
difference (Scale -> Layout
Scale.scale_layout Scale
scale) (Pitch -> Pitch -> a)
-> Either PitchError Pitch -> Either PitchError (Pitch -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Scale -> Environ -> Transposed -> Either PitchError Pitch
parse Scale
scale Environ
env Transposed
p1 Either PitchError (Pitch -> a)
-> Either PitchError Pitch -> Either PitchError a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Scale -> Environ -> Transposed -> Either PitchError Pitch
parse Scale
scale Environ
env Transposed
p2

nn_difference :: RealTime -> PSignal.Pitch -> PSignal.Pitch
    -> Derive.Deriver Pitch.NoteNumber
nn_difference :: RealTime -> Pitch -> Pitch -> Deriver NoteNumber
nn_difference RealTime
pos Pitch
pitch1 Pitch
pitch2 = do
    Transposed
pitch1 <- RealTime -> Pitch -> Deriver State Error Transposed
Derive.resolve_pitch RealTime
pos Pitch
pitch1
    Transposed
pitch2 <- RealTime -> Pitch -> Deriver State Error Transposed
Derive.resolve_pitch RealTime
pos Pitch
pitch2
    (-) (NoteNumber -> NoteNumber -> NoteNumber)
-> Deriver NoteNumber
-> Deriver State Error (NoteNumber -> NoteNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transposed -> Deriver NoteNumber
Pitches.pitch_nn Transposed
pitch1 Deriver State Error (NoteNumber -> NoteNumber)
-> Deriver NoteNumber -> Deriver NoteNumber
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Transposed -> Deriver NoteNumber
Pitches.pitch_nn Transposed
pitch2

-- * note

eval_pitch_ :: ScoreTime -> Pitch.Pitch -> Derive.Deriver PSignal.Transposed
eval_pitch_ :: ScoreTime -> Pitch -> Deriver State Error Transposed
eval_pitch_ ScoreTime
start Pitch
pitch = do
    (Note -> Maybe Pitch
_, Pitch -> Maybe Note
show_pitch, Transposition -> Int -> Pitch -> Maybe Pitch
_) <- Deriver
  (Note -> Maybe Pitch, Pitch -> Maybe Note,
   Transposition -> Int -> Pitch -> Maybe Pitch)
get_pitch_functions
    (Pitch -> Maybe Note)
-> ScoreTime -> Pitch -> Deriver State Error Transposed
eval_pitch Pitch -> Maybe Note
show_pitch ScoreTime
start Pitch
pitch

-- | Evaluate a 'Pitch.Pitch'.  It returns a transposed pitch since
-- a 'Pitch.Pitch' is assumed to have been transposed (e.g. 'get_parsed_pitch'
-- uses a transposed pitch so range calculation works).
eval_pitch :: (Pitch.Pitch -> Maybe Pitch.Note) -> ScoreTime -> Pitch.Pitch
    -> Derive.Deriver PSignal.Transposed
eval_pitch :: (Pitch -> Maybe Note)
-> ScoreTime -> Pitch -> Deriver State Error Transposed
eval_pitch Pitch -> Maybe Note
show_pitch ScoreTime
start Pitch
pitch = do
    Note
note <- Text -> Maybe Note -> Deriver Note
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"scale doesn't have pitch: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Pitch -> Text
forall a. Pretty a => a -> Text
pretty Pitch
pitch)
        (Pitch -> Maybe Note
show_pitch Pitch
pitch)
    ScoreTime -> Note -> Deriver State Error Transposed
eval_note ScoreTime
start Note
note

-- | Evaluate a symbolic pitch.  Like 'eval_pitch', I assume the Note was
-- Transposed, or at least should be an absolute pitch.
eval_note :: ScoreTime -> Pitch.Note -> Derive.Deriver PSignal.Transposed
eval_note :: ScoreTime -> Note -> Deriver State Error Transposed
eval_note ScoreTime
pos Note
note = ScoreTime -> PitchCall -> Deriver State Error Transposed
forall a. ScoreTime -> PitchCall -> Deriver (RawPitch a)
Eval.eval_pitch ScoreTime
pos (PitchCall -> Deriver State Error Transposed)
-> PitchCall -> Deriver State Error Transposed
forall a b. (a -> b) -> a -> b
$
    Symbol -> PitchCall
forall val. Symbol -> Call val
Expr.call0 (Text -> Symbol
Expr.Symbol (Note -> Text
Pitch.note_text Note
note))

-- | Generate a single note, from 0 to 1.
note :: Derive.NoteDeriver
note :: NoteDeriver
note = Bool -> PitchCall -> NoteDeriver
forall d. CallableExpr d => Bool -> PitchCall -> Deriver (Stream d)
Eval.eval_one_call Bool
True (PitchCall -> NoteDeriver) -> PitchCall -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Symbol -> PitchCall
forall val. Symbol -> Call val
Expr.call0 Symbol
Symbols.null_note

-- | Like 'note', but the note reuses the Context, which means it will inherit
-- the caller's start and duration as well as sub-tracks and thus may apply
-- inversion.
--
-- This is appropriate when adding a wrapper around the default note call, but
-- not if you don't want to be overridden by sub-tracks.  See 'placed_note'
-- if you want to inherit the time, but not the rest.
reapply_note :: Derive.NoteArgs -> Derive.NoteDeriver
reapply_note :: NoteArgs -> NoteDeriver
reapply_note NoteArgs
args = Context Event -> Symbol -> [Term] -> NoteDeriver
forall d.
CallableExpr d =>
Context d -> Symbol -> [Term] -> Deriver (Stream d)
Eval.reapply_call (NoteArgs -> Context Event
forall a. PassedArgs a -> Context a
Args.context NoteArgs
args) Symbol
Symbols.null_note []

-- | Override the pitch signal and generate a single note.
pitched_note :: PSignal.Pitch -> Derive.NoteDeriver
pitched_note :: Pitch -> NoteDeriver
pitched_note Pitch
pitch = Pitch -> NoteDeriver -> NoteDeriver
forall a. Pitch -> Deriver a -> Deriver a
with_pitch Pitch
pitch NoteDeriver
note

transposed_pitched_note :: PSignal.Transposed -> Derive.NoteDeriver
transposed_pitched_note :: Transposed -> NoteDeriver
transposed_pitched_note Transposed
pitch = Transposed -> NoteDeriver -> NoteDeriver
forall a. Transposed -> Deriver a -> Deriver a
with_transposed_pitch Transposed
pitch NoteDeriver
note

-- | Add an attribute and generate a single note.
attribute_note :: Attrs.Attributes -> Derive.NoteDeriver
attribute_note :: Attributes -> NoteDeriver
attribute_note Attributes
attrs = Attributes -> NoteDeriver -> NoteDeriver
forall d. Attributes -> Deriver d -> Deriver d
add_attributes Attributes
attrs NoteDeriver
note

-- | A zero-duration 'note'.
triggered_note :: Derive.NoteDeriver
triggered_note :: NoteDeriver
triggered_note =
    Bool -> ScoreTime -> ScoreTime -> Expr -> NoteDeriver
forall d.
CallableExpr d =>
Bool -> ScoreTime -> ScoreTime -> Expr -> Deriver (Stream d)
Eval.eval_one_at Bool
True ScoreTime
0 ScoreTime
0 (Expr -> NoteDeriver) -> Expr -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Symbol -> Expr
forall val. Symbol -> Expr val
Expr.generator0 Symbol
Symbols.null_note

place :: Derive.PassedArgs d -> Derive.Deriver a -> Derive.Deriver a
place :: forall d a. PassedArgs d -> Deriver a -> Deriver a
place = (ScoreTime -> ScoreTime -> Deriver a -> Deriver a)
-> (ScoreTime, ScoreTime) -> Deriver a -> Deriver a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ScoreTime -> ScoreTime -> Deriver a -> Deriver a
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ((ScoreTime, ScoreTime) -> Deriver a -> Deriver a)
-> (PassedArgs d -> (ScoreTime, ScoreTime))
-> PassedArgs d
-> Deriver a
-> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs d -> (ScoreTime, ScoreTime)
forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.extent

placed_note :: Derive.PassedArgs d -> Derive.NoteDeriver
placed_note :: forall d. PassedArgs d -> NoteDeriver
placed_note PassedArgs d
args = PassedArgs d -> NoteDeriver -> NoteDeriver
forall d a. PassedArgs d -> Deriver a -> Deriver a
place PassedArgs d
args NoteDeriver
note

-- * transformer notes

-- | Derive with transformed Attributes.
with_attributes :: (Attrs.Attributes -> Attrs.Attributes) -> Derive.Deriver d
    -> Derive.Deriver d
with_attributes :: forall d. (Attributes -> Attributes) -> Deriver d -> Deriver d
with_attributes Attributes -> Attributes
f Deriver d
deriver = do
    Attributes
attrs <- Deriver Attributes
get_attributes
    Text -> Attributes -> Deriver d -> Deriver d
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
EnvKey.attributes (Attributes -> Attributes
f Attributes
attrs) Deriver d
deriver

add_attributes :: Attrs.Attributes -> Derive.Deriver d -> Derive.Deriver d
add_attributes :: forall d. Attributes -> Deriver d -> Deriver d
add_attributes Attributes
attrs
    | Attributes
attrs Attributes -> Attributes -> Bool
forall a. Eq a => a -> a -> Bool
== Attributes
forall a. Monoid a => a
mempty = Deriver d -> Deriver d
forall a. a -> a
id
    | Bool
otherwise = (Attributes -> Attributes) -> Deriver d -> Deriver d
forall d. (Attributes -> Attributes) -> Deriver d -> Deriver d
with_attributes (Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
attrs)

add_flags :: Flags.Flags -> Derive.NoteDeriver -> Derive.NoteDeriver
add_flags :: Flags -> NoteDeriver -> NoteDeriver
add_flags Flags
flags
    | Flags
flags Flags -> Flags -> Bool
forall a. Eq a => a -> a -> Bool
== Flags
forall a. Monoid a => a
mempty = NoteDeriver -> NoteDeriver
forall a. a -> a
id
    | Bool
otherwise = (Stream Event -> Stream Event) -> NoteDeriver -> NoteDeriver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Event -> Event) -> Stream Event -> Stream Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Flags -> Event -> Event
Score.add_flags Flags
flags))

-- * random

-- | Get an infinite list of random numbers.  These are deterministic in that
-- they depend only on the random seed, but the random seed is hashed with
-- each stack entry.  So if you fix the random seed at a certain point, you
-- should get consistent results below it.
--
-- It's a class because both Doubles and Ints are useful and I'd like to use
-- the same function name for both.
class Random a where
    -- | Infinite list of random numbers.  These are deterministic in that
    -- they depend on the current track, current call position, and the random
    -- seed.
    randoms :: Derive.Deriver [a]
    -- | Infinite list of random numbers in the given range.
    randoms_in :: a -> a -> Derive.Deriver [a]

instance Random Double where
    -- | Random numbers in the range [0, 1).
    randoms :: Deriver [Double]
randoms = (PureMT -> (Double, PureMT)) -> Deriver [Double]
forall a. (PureMT -> (a, PureMT)) -> Deriver [a]
_make_randoms PureMT -> (Double, PureMT)
Pure64.randomDouble
        -- Pure64.randomDouble doesn't document the range, but that's what it
        -- is.
    randoms_in :: Double -> Double -> Deriver [Double]
randoms_in Double
low Double
high = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Double -> Double
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Double
low Double
high) ([Double] -> [Double]) -> Deriver [Double] -> Deriver [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver [Double]
forall a. Random a => Deriver [a]
randoms

instance Random Int where
    -- Random numbers between INT_MIN and INT_MAX.
    randoms :: Deriver [Int]
randoms = (PureMT -> (Int, PureMT)) -> Deriver [Int]
forall a. (PureMT -> (a, PureMT)) -> Deriver [a]
_make_randoms PureMT -> (Int, PureMT)
Pure64.randomInt
    randoms_in :: Int -> Int -> Deriver [Int]
randoms_in Int
low Int
high = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int -> Int
forall a. Real a => a -> a -> a -> a
Num.restrict Int
low Int
high) ([Int] -> [Int]) -> Deriver [Int] -> Deriver [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver [Int]
forall a. Random a => Deriver [a]
randoms

-- | Get a random Double or Int.  Ints will lose precision if converted to
-- double!
random :: Random a => Derive.Deriver a
random :: forall a. Random a => Deriver a
random = [a] -> a
forall a. [a] -> a
head ([a] -> a) -> Deriver State Error [a] -> Deriver State Error a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error [a]
forall a. Random a => Deriver [a]
randoms

random_in :: (Random a, Real a) => a -> a -> Derive.Deriver a
random_in :: forall a. (Random a, Real a) => a -> a -> Deriver a
random_in a
low a
high
    | a
low a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
high = a -> Deriver State Error a
forall (m :: * -> *) a. Monad m => a -> m a
return a
low
    | Bool
otherwise = [a] -> a
forall a. [a] -> a
head ([a] -> a) -> Deriver State Error [a] -> Deriver State Error a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a -> Deriver State Error [a]
forall a. Random a => a -> a -> Deriver [a]
randoms_in a
low a
high

-- | If the chance is 1, return true all the time, if it's 0.5, return it half
-- of the time.
chance :: Double -> Derive.Deriver Bool
chance :: Double -> Deriver Bool
chance Double
v
    | Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1 = Bool -> Deriver Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    | Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 = Bool -> Deriver Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | Bool
otherwise = do
        Double
r <- Double -> Double -> Deriver Double
forall a. (Random a, Real a) => a -> a -> Deriver a
random_in Double
0 Double
1
        Bool -> Deriver Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Deriver Bool) -> Bool -> Deriver Bool
forall a b. (a -> b) -> a -> b
$ Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
v

shuffle :: [a] -> Derive.Deriver [a]
shuffle :: forall a. [a] -> Deriver [a]
shuffle [a]
xs = [a] -> [Int] -> [a]
forall a. [a] -> [Int] -> [a]
Random.shuffle [a]
xs ([Int] -> [a]) -> Deriver [Int] -> Deriver State Error [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver [Int]
forall a. Random a => Deriver [a]
randoms

_make_randoms :: (Pure64.PureMT -> (a, Pure64.PureMT)) -> Derive.Deriver [a]
_make_randoms :: forall a. (PureMT -> (a, PureMT)) -> Deriver [a]
_make_randoms PureMT -> (a, PureMT)
f = (PureMT -> Maybe (a, PureMT)) -> PureMT -> [a]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
List.unfoldr ((a, PureMT) -> Maybe (a, PureMT)
forall a. a -> Maybe a
Just ((a, PureMT) -> Maybe (a, PureMT))
-> (PureMT -> (a, PureMT)) -> PureMT -> Maybe (a, PureMT)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PureMT -> (a, PureMT)
f) (PureMT -> [a])
-> Deriver State Error PureMT -> Deriver State Error [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error PureMT
_random_generator

_random_generator :: Derive.Deriver Pure64.PureMT
_random_generator :: Deriver State Error PureMT
_random_generator = do
    Double
seed <- Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (Maybe Double -> Double)
-> Deriver State Error (Maybe Double) -> Deriver Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Deriver State Error (Maybe Double)
forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.seed
    PureMT -> Deriver State Error PureMT
forall (m :: * -> *) a. Monad m => a -> m a
return (PureMT -> Deriver State Error PureMT)
-> PureMT -> Deriver State Error PureMT
forall a b. (a -> b) -> a -> b
$ Word64 -> PureMT
Pure64.pureMT (Double -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
seed :: Double))

pick_weighted :: NonEmpty (Double, a) -> Double -> a
pick_weighted :: forall a. NonEmpty (Double, a) -> Double -> a
pick_weighted NonEmpty (Double, a)
weights Double
rnd_ = Double -> NonEmpty (Double, a) -> a
forall {b}. Double -> NonEmpty (Double, b) -> b
go Double
0 NonEmpty (Double, a)
weights
    where
    rnd :: Double
rnd = Double
rnd_ Double -> Double -> Double
forall a. Num a => a -> a -> a
* NonEmpty Double -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (((Double, a) -> Double) -> NonEmpty (Double, a) -> NonEmpty Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double, a) -> Double
forall a b. (a, b) -> a
fst NonEmpty (Double, a)
weights)
    go :: Double -> NonEmpty (Double, b) -> b
go Double
collect ((Double
weight, b
a) :| [(Double, b)]
weights) = case [(Double, b)]
weights of
        [] -> b
a
        (Double, b)
w : [(Double, b)]
ws
            | Double
collect Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
weight Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
rnd -> b
a
            | Bool
otherwise -> Double -> NonEmpty (Double, b) -> b
go (Double
collect Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
weight) ((Double, b)
w (Double, b) -> [(Double, b)] -> NonEmpty (Double, b)
forall a. a -> [a] -> NonEmpty a
:| [(Double, b)]
ws)

-- | Like 'pick_weighted' when all the weights are equal.
pick :: NonEmpty a -> Double -> a
pick :: forall a. NonEmpty a -> Double -> a
pick (a
x :| [a]
xs) Double
rnd = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
i
    where i :: Int
i = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
rnd Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs))

-- TODO what I want is a bounded normal distribution.
-- Unfortunately it seems to be really complicated to actually sample that.
-- I could use anything with a similar shape actually.
normal :: Double -> Derive.Deriver Double
normal :: Double -> Deriver Double
normal Double
stddev = Double -> [Double] -> Double
make_normal Double
stddev ([Double] -> Double) -> Deriver [Double] -> Deriver Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver [Double]
forall a. Random a => Deriver [a]
randoms
{- notes:
    . Approximate normal distribution: sum (take n randoms) / n
    . normalCumulative mean stddev x =
          SpecFunctions.erfc ((mean - x) / ndCdfDenom) / 2
          where
          ndCdfDenom = Constants.m_sqrt_2 * stddev
    . Make a with_variation, so the choice is in the call, not the patch.
    . I want to give center and width, and then pick according to that
      distribution.  Alternately, if I can map a uniform 0-1.
    . Truncated normal distribution seems best, and I can map a uniformly
      distributed value through its cumulative probability function.
    . This is called "inverse transform sampling".  It's possible for
      truncated normal, but complicated:
      https://www.christophlassner.de/blog/2013/08/12/Generation-of-Truncated-Gaussian-Samples/
    . Rejection sampling just means I do a 2d normal distribution until
      I get something under the PDF.  Theoretically unbound time.
    . I don't care about the exact statistical properties, just that it
      has a similar shape.
-}

-- | Approximation to a normal distribution between 0 and 1, inclusive.
-- I can't use an actual normal distribution because I need it to be bounded.
make_normal :: Double -> [Double] -> Double
make_normal :: Double -> [Double] -> Double
make_normal Double
stddev [Double]
rnds = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (Int -> [Double] -> [Double]
forall a. Int -> [a] -> [a]
take Int
samples [Double]
rnds) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
samples
    where
    samples :: Int
samples = Int
12

-- * conditional

if_env :: (Eq val, Typecheck.Typecheck val) => EnvKey.Key -> Maybe val
    -> Derive.Deriver a -> Derive.Deriver a -> Derive.Deriver a
if_env :: forall val a.
(Eq val, Typecheck val) =>
Text -> Maybe val -> Deriver a -> Deriver a -> Deriver a
if_env Text
key Maybe val
val Deriver a
is_set Deriver a
not_set =
    Deriver Bool -> Deriver a -> Deriver a -> Deriver a
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ((Maybe val -> Maybe val -> Bool
forall a. Eq a => a -> a -> Bool
==Maybe val
val) (Maybe val -> Bool)
-> Deriver State Error (Maybe val) -> Deriver Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Deriver State Error (Maybe val)
forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
key) Deriver a
is_set Deriver a
not_set

when_env :: (Eq val, Typecheck.Typecheck val) => EnvKey.Key -> Maybe val
    -> (Derive.Deriver a -> Derive.Deriver a)
    -> Derive.Deriver a -> Derive.Deriver a
when_env :: forall val a.
(Eq val, Typecheck val) =>
Text
-> Maybe val -> (Deriver a -> Deriver a) -> Deriver a -> Deriver a
when_env Text
key Maybe val
val Deriver a -> Deriver a
transformer Deriver a
deriver =
    Text -> Maybe val -> Deriver a -> Deriver a -> Deriver a
forall val a.
(Eq val, Typecheck val) =>
Text -> Maybe val -> Deriver a -> Deriver a -> Deriver a
if_env Text
key Maybe val
val (Deriver a -> Deriver a
transformer Deriver a
deriver) Deriver a
deriver

-- * time

-- | Get the real duration of time val at the given point in time.  RealTime is
-- linear, so 1 second is always 1 second no matter where it is, but ScoreTime
-- will map to different amounts of RealTime depending on where it is.
real_duration :: (Derive.Time t1, Derive.Time t2) => t1 -> t2
    -> Derive.Deriver RealTime
real_duration :: forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
real_duration t1
start t2
dur = case t2 -> Duration
forall a. Time a => a -> Duration
Derive.to_duration t2
dur of
    DeriveT.RealDuration RealTime
t -> RealTime -> Deriver RealTime
forall (m :: * -> *) a. Monad m => a -> m a
return RealTime
t
    DeriveT.ScoreDuration ScoreTime
t
        | ScoreTime
t ScoreTime -> ScoreTime -> Bool
forall a. Eq a => a -> a -> Bool
== ScoreTime
0 -> RealTime -> Deriver RealTime
forall (m :: * -> *) a. Monad m => a -> m a
return RealTime
0
        | Bool
otherwise -> do
            -- I'm adding score to real, so I want the amount of real time in
            -- the future I am if I advance the given amount of score time from
            -- 'start'.
            ScoreTime
score_start <- t1 -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
Derive.score t1
start
            RealTime
real_start <- t1 -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real t1
start
            RealTime
end <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (ScoreTime -> Deriver RealTime) -> ScoreTime -> Deriver RealTime
forall a b. (a -> b) -> a -> b
$ ScoreTime
score_start ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ ScoreTime
t
            RealTime -> Deriver RealTime
forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime -> Deriver RealTime) -> RealTime -> Deriver RealTime
forall a b. (a -> b) -> a -> b
$ RealTime
end RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
real_start

-- | Like 'real_duration', but get the duration in ScoreTime.  If you are
-- manipulating deriver abstractly instead of directly emitting events then you
-- will place them via 'Derive.at' and family, which are in ScoreTime.
score_duration :: (Derive.Time t1, Derive.Time t2) => t1 -> t2
    -> Derive.Deriver ScoreTime
score_duration :: forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
score_duration t1
start t2
dur = case t2 -> Duration
forall a. Time a => a -> Duration
Derive.to_duration t2
dur of
    DeriveT.ScoreDuration ScoreTime
t -> ScoreTime -> Deriver ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return ScoreTime
t
    DeriveT.RealDuration RealTime
t
        | RealTime
t RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== RealTime
0 -> ScoreTime -> Deriver ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return ScoreTime
0
        | Bool
otherwise -> do
            -- I'm adding real to score, so I want the amount of amount of
            -- score time I'd have to advance in order for the given amount
            -- of real time to pass.
            ScoreTime
score_start <- t1 -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
Derive.score t1
start
            RealTime
real_start <- t1 -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real t1
start
            ScoreTime
end <- RealTime -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
Derive.score (RealTime -> Deriver ScoreTime) -> RealTime -> Deriver ScoreTime
forall a b. (a -> b) -> a -> b
$ RealTime
real_start RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
t
            ScoreTime -> Deriver ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ScoreTime -> Deriver ScoreTime) -> ScoreTime -> Deriver ScoreTime
forall a b. (a -> b) -> a -> b
$ ScoreTime
end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
score_start

-- | A time range from the event start until a given duration.
duration_from_start :: Derive.Time t => Derive.PassedArgs d -> t
    -> Derive.Deriver (RealTime, RealTime) -- ^ (start, start+dur)
duration_from_start :: forall t d.
Time t =>
PassedArgs d -> t -> Deriver (RealTime, RealTime)
duration_from_start PassedArgs d
args t
t = do
    RealTime
start <- PassedArgs d -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs d
args
    RealTime
dur <- RealTime -> t -> Deriver RealTime
forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
real_duration RealTime
start t
t
    (RealTime, RealTime) -> Deriver (RealTime, RealTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime
start, RealTime
start RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
dur)

-- | Like 'duration_from_start', but subtract a duration from the end.
duration_from_end :: Derive.Time t => Derive.PassedArgs d -> t
    -> Derive.Deriver (RealTime, RealTime) -- ^ (end-dur, end)
duration_from_end :: forall t d.
Time t =>
PassedArgs d -> t -> Deriver (RealTime, RealTime)
duration_from_end PassedArgs d
args t
t = do
    RealTime
end <- PassedArgs d -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
Args.real_end PassedArgs d
args
    RealTime
dur <- RealTime -> t -> Deriver RealTime
forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
real_duration RealTime
end t
t
    (RealTime, RealTime) -> Deriver (RealTime, RealTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime
end RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
dur, RealTime
end)

-- | This is 'real_duration', but takes a ScoreT.Typed Signal.Y.
typed_real_duration :: Derive.Time t => Typecheck.TimeType -> t
    -> ScoreT.Typed Signal.Y -> Derive.Deriver RealTime
typed_real_duration :: forall t.
Time t =>
TimeType -> t -> Typed Double -> Deriver RealTime
typed_real_duration TimeType
default_type t
from (ScoreT.Typed Type
typ Double
val)
    | Type
typ Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
ScoreT.Real
        Bool -> Bool -> Bool
|| Type
typ Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
ScoreT.Untyped Bool -> Bool -> Bool
&& TimeType
default_type TimeType -> TimeType -> Bool
forall a. Eq a => a -> a -> Bool
== TimeType
Typecheck.Real =
            RealTime -> Deriver RealTime
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> RealTime
RealTime.seconds Double
val)
    | Type
typ Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
ScoreT.Score
        Bool -> Bool -> Bool
|| Type
typ Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
ScoreT.Untyped Bool -> Bool -> Bool
&& TimeType
default_type TimeType -> TimeType -> Bool
forall a. Eq a => a -> a -> Bool
== TimeType
Typecheck.Score =
            t -> ScoreTime -> Deriver RealTime
forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
real_duration t
from (Double -> ScoreTime
ScoreTime.from_double Double
val)
    | Bool
otherwise = Text -> Deriver RealTime
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver RealTime) -> Text -> Deriver RealTime
forall a b. (a -> b) -> a -> b
$
        Text
"expected time type for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Typed Double -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val (Type -> Double -> Typed Double
forall a. Type -> a -> Typed a
ScoreT.Typed Type
typ Double
val)

-- ** timestep

-- | Take the given number of steps.  Negative means step back.
timestep :: ScoreTime -> TimeStep.TimeStep
    -> [Int] -- ^ pick the first steps that return Just
    -> Derive.Deriver ScoreTime
timestep :: ScoreTime -> TimeStep -> [Int] -> Deriver ScoreTime
timestep ScoreTime
start TimeStep
ts [Int]
steps = do
    (BlockId
block_id, Int
tracknum) <- Deriver (BlockId, Int)
Internal.get_current_tracknum
    Text -> Maybe ScoreTime -> Deriver ScoreTime
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"no valid timestep from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScoreTime -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val ScoreTime
start)
        (Maybe ScoreTime -> Deriver ScoreTime)
-> Deriver State Error (Maybe ScoreTime) -> Deriver ScoreTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateId (Maybe ScoreTime) -> Deriver State Error (Maybe ScoreTime)
forall a. HasCallStack => StateId a -> Deriver a
Derive.eval_ui
            ([StateId (Maybe ScoreTime)] -> StateId (Maybe ScoreTime)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts [Int
-> TimeStep
-> BlockId
-> Int
-> ScoreTime
-> StateId (Maybe ScoreTime)
forall (m :: * -> *).
M m =>
Int
-> TimeStep -> BlockId -> Int -> ScoreTime -> m (Maybe ScoreTime)
TimeStep.step_from Int
step TimeStep
ts BlockId
block_id Int
tracknum ScoreTime
start |
                Int
step <- [Int]
steps])

-- | Get the timestep duration from the given point.  This tries first to
-- step forward, and then back.  This is because typically you use this to
-- configure duration for a call, and it's confusing when the call stops
-- working at the end of the block.
meter_duration :: ScoreTime -> Meter.Rank -> Int
    -> Derive.Deriver ScoreTime
meter_duration :: ScoreTime -> Rank -> Int -> Deriver ScoreTime
meter_duration ScoreTime
start Rank
rank Int
steps = do
    ScoreTime
end <- ScoreTime -> TimeStep -> [Int] -> Deriver ScoreTime
timestep ScoreTime
start TimeStep
ts ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
steps) [Int
1, -Int
1])
    ScoreTime -> Deriver ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ScoreTime -> Deriver ScoreTime) -> ScoreTime -> Deriver ScoreTime
forall a b. (a -> b) -> a -> b
$ ScoreTime -> ScoreTime
forall a. Num a => a -> a
abs (ScoreTime
end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
start)
    where
    ts :: TimeStep
ts = Step -> TimeStep
TimeStep.time_step (Step -> TimeStep) -> Step -> TimeStep
forall a b. (a -> b) -> a -> b
$ MarklistMatch -> Rank -> Step
TimeStep.RelativeMark MarklistMatch
TimeStep.match_meter Rank
rank

-- | Duration of a single timestep, starting here.
timestep_duration :: Derive.PassedArgs a -> Meter.Rank
    -> Derive.Deriver ScoreTime
timestep_duration :: forall a. PassedArgs a -> Rank -> Deriver ScoreTime
timestep_duration PassedArgs a
args Rank
step = ScoreTime -> Rank -> Int -> Deriver ScoreTime
meter_duration (PassedArgs a -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args) Rank
step Int
1


-- * general purpose types

-- | This is for arguments which can be high or low.
data UpDown = Up | Down deriving (Int -> UpDown -> ShowS
[UpDown] -> ShowS
UpDown -> String
(Int -> UpDown -> ShowS)
-> (UpDown -> String) -> ([UpDown] -> ShowS) -> Show UpDown
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UpDown] -> ShowS
$cshowList :: [UpDown] -> ShowS
show :: UpDown -> String
$cshow :: UpDown -> String
showsPrec :: Int -> UpDown -> ShowS
$cshowsPrec :: Int -> UpDown -> ShowS
Show, Int -> UpDown
UpDown -> Int
UpDown -> [UpDown]
UpDown -> UpDown
UpDown -> UpDown -> [UpDown]
UpDown -> UpDown -> UpDown -> [UpDown]
(UpDown -> UpDown)
-> (UpDown -> UpDown)
-> (Int -> UpDown)
-> (UpDown -> Int)
-> (UpDown -> [UpDown])
-> (UpDown -> UpDown -> [UpDown])
-> (UpDown -> UpDown -> [UpDown])
-> (UpDown -> UpDown -> UpDown -> [UpDown])
-> Enum UpDown
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: UpDown -> UpDown -> UpDown -> [UpDown]
$cenumFromThenTo :: UpDown -> UpDown -> UpDown -> [UpDown]
enumFromTo :: UpDown -> UpDown -> [UpDown]
$cenumFromTo :: UpDown -> UpDown -> [UpDown]
enumFromThen :: UpDown -> UpDown -> [UpDown]
$cenumFromThen :: UpDown -> UpDown -> [UpDown]
enumFrom :: UpDown -> [UpDown]
$cenumFrom :: UpDown -> [UpDown]
fromEnum :: UpDown -> Int
$cfromEnum :: UpDown -> Int
toEnum :: Int -> UpDown
$ctoEnum :: Int -> UpDown
pred :: UpDown -> UpDown
$cpred :: UpDown -> UpDown
succ :: UpDown -> UpDown
$csucc :: UpDown -> UpDown
Enum, UpDown
UpDown -> UpDown -> Bounded UpDown
forall a. a -> a -> Bounded a
maxBound :: UpDown
$cmaxBound :: UpDown
minBound :: UpDown
$cminBound :: UpDown
Bounded, UpDown -> UpDown -> Bool
(UpDown -> UpDown -> Bool)
-> (UpDown -> UpDown -> Bool) -> Eq UpDown
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UpDown -> UpDown -> Bool
$c/= :: UpDown -> UpDown -> Bool
== :: UpDown -> UpDown -> Bool
$c== :: UpDown -> UpDown -> Bool
Eq, Eq UpDown
Eq UpDown
-> (UpDown -> UpDown -> Ordering)
-> (UpDown -> UpDown -> Bool)
-> (UpDown -> UpDown -> Bool)
-> (UpDown -> UpDown -> Bool)
-> (UpDown -> UpDown -> Bool)
-> (UpDown -> UpDown -> UpDown)
-> (UpDown -> UpDown -> UpDown)
-> Ord UpDown
UpDown -> UpDown -> Bool
UpDown -> UpDown -> Ordering
UpDown -> UpDown -> UpDown
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UpDown -> UpDown -> UpDown
$cmin :: UpDown -> UpDown -> UpDown
max :: UpDown -> UpDown -> UpDown
$cmax :: UpDown -> UpDown -> UpDown
>= :: UpDown -> UpDown -> Bool
$c>= :: UpDown -> UpDown -> Bool
> :: UpDown -> UpDown -> Bool
$c> :: UpDown -> UpDown -> Bool
<= :: UpDown -> UpDown -> Bool
$c<= :: UpDown -> UpDown -> Bool
< :: UpDown -> UpDown -> Bool
$c< :: UpDown -> UpDown -> Bool
compare :: UpDown -> UpDown -> Ordering
$ccompare :: UpDown -> UpDown -> Ordering
Ord)

instance Pretty UpDown where pretty :: UpDown -> Text
pretty = UpDown -> Text
forall a. Show a => a -> Text
showt
instance Typecheck.Typecheck UpDown
instance ShowVal.ShowVal UpDown where
    show_val :: UpDown -> Text
show_val UpDown
Up = Text
"u"
    show_val UpDown
Down = Text
"d"