-- 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.Ruler.Meter as Meter
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.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 control pos = ScoreT.typed_val <$> typed_control_at control pos

typed_control_at :: DeriveT.ControlRef -> RealTime
    -> Derive.Deriver (ScoreT.Typed Signal.Y)
typed_control_at control pos = case control of
    DeriveT.ControlSignal sig -> return $ Signal.at pos <$> sig
    DeriveT.DefaultedControl cont deflt ->
        fromMaybe (Signal.at pos <$> deflt) <$> Derive.control_at cont pos
    DeriveT.LiteralControl cont ->
        Derive.require ("not found and no default: " <> ShowVal.show_val cont)
            =<< Derive.control_at cont pos

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

real_time_at :: DeriveT.ControlRef -> RealTime -> Derive.Deriver RealTime
real_time_at control pos = do
    val <- time_control_at Typecheck.Real control pos
    case val of
        DeriveT.RealDuration t -> return t
        DeriveT.ScoreDuration t -> Derive.throw $ "expected RealTime for "
            <> ShowVal.show_val control <> " but got " <> ShowVal.show_val t

transpose_control_at :: Typecheck.TransposeType -> DeriveT.ControlRef
    -> RealTime -> Derive.Deriver (Signal.Y, Typecheck.TransposeType)
transpose_control_at default_type control pos = do
    ScoreT.Typed typ val <- typed_control_at control pos
    transpose_type <- case typ of
        ScoreT.Untyped -> return default_type
        ScoreT.Chromatic -> return Typecheck.Chromatic
        ScoreT.Diatonic -> return Typecheck.Diatonic
        _ -> Derive.throw $ "expected transpose type for "
            <> ShowVal.show_val control <> " but got " <> pretty typ
    return (val, transpose_type)


-- * function and signal

to_function :: DeriveT.ControlRef -> Derive.Deriver Typecheck.Function
to_function = fmap (ScoreT.typed_val .) . 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 control =
    either return (const $ Derive.throw $ "not found: " <> pretty control)
        =<< Typecheck.to_signal_or_function control

to_signal :: DeriveT.ControlRef -> Derive.Deriver Signal.Control
to_signal = fmap ScoreT.typed_val . 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 default_type control = do
    sig <- Typecheck.to_typed_function 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 = ScoreT.type_of (sig 0)
        untyped = ScoreT.typed_val . sig
    case typ of
        ScoreT.Untyped ->
            return (untyped, Typecheck.transpose_control default_type)
        _ -> case Controls.transpose_type typ of
            Just control -> return (untyped, control)
            _ -> Derive.throw $ "expected transpose type for "
                <> ShowVal.show_val control <> " but got " <> pretty 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 default_type control = do
    sig <- Typecheck.to_typed_function control
    let typ = ScoreT.type_of (sig 0)
        untyped = ScoreT.typed_val . sig
    case typ of
        ScoreT.Untyped -> return (untyped, default_type)
        ScoreT.Score -> return (untyped, Typecheck.Score)
        ScoreT.Real -> return (untyped, Typecheck.Real)
        _ -> Derive.throw $ "expected time type for "
            <> ShowVal.show_val control <> " but got " <> pretty 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 = Typecheck.pitch_at

to_psignal :: DeriveT.PControlRef -> Derive.Deriver PSignal.PSignal
to_psignal control = case control of
    DeriveT.ControlSignal sig -> return sig
    DeriveT.DefaultedControl cont deflt ->
        maybe (return deflt) return =<< Derive.get_named_pitch cont
    DeriveT.LiteralControl cont ->
        Derive.require ("not found: " <> showt cont)
            =<< Derive.get_named_pitch cont

nn_at :: RealTime -> DeriveT.PControlRef
    -> Derive.Deriver (Maybe Pitch.NoteNumber)
nn_at pos control = -- TODO throw exception?
    Derive.logged_pitch_nn ("Util.nn_at " <> pretty (pos, control))
        =<< Derive.resolve_pitch pos
        =<< pitch_at pos control

real_duration_at :: Typecheck.TypedFunction -> RealTime
    -> Derive.Deriver RealTime
real_duration_at f t = typed_real_duration Typecheck.Real t (f t)

-- * dynamic

-- | Unlike 'Derive.pitch_at', the transposition has already been applied.
transposed :: RealTime -> Derive.Deriver (Maybe PSignal.Transposed)
transposed pos =
    justm (Derive.pitch_at pos) $ fmap Just . Derive.resolve_pitch pos

get_transposed :: RealTime -> Derive.Deriver PSignal.Transposed
get_transposed pos = Derive.require ("no pitch at " <> pretty pos)
    =<< transposed 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 pos = Derive.require ("no pitch at " <> pretty pos)
    =<< Derive.pitch_at pos

get_pitch_here :: Derive.PassedArgs a -> Derive.Deriver PSignal.Pitch
get_pitch_here = get_pitch <=< 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 parse = parse_pitch parse <=< get_transposed

get_symbolic_pitch :: RealTime -> Derive.Deriver Pitch.Note
get_symbolic_pitch = Pitches.pitch_note <=< get_transposed

dynamic :: RealTime -> Derive.Deriver Signal.Y
dynamic pos = maybe Derive.default_dynamic ScoreT.typed_val <$>
    Derive.control_at Controls.dynamic pos

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

with_transposed_pitch :: PSignal.Transposed -> Derive.Deriver a
    -> Derive.Deriver a
with_transposed_pitch pitch =
    without_transpose . with_pitch (PSignal.coerce pitch)

without_transpose :: Derive.Deriver a -> Derive.Deriver a
without_transpose = Derive.remove_controls Controls.transposers

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

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

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

with_constant :: ScoreT.Control -> Signal.Y -> Derive.Deriver a
    -> Derive.Deriver a
with_constant control = Derive.with_control control . ScoreT.untyped
    . Signal.constant

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

add_constant, multiply_constant :: ScoreT.Control -> Signal.Y
    -> Derive.Deriver a -> Derive.Deriver a
multiply_constant control val
    | val == 1 = id
    | otherwise = Derive.with_merged_control Derive.merge_mul control
        (ScoreT.untyped (Signal.constant val))
add_constant control val
    | val == 0 = id
    | otherwise = Derive.with_merged_control Derive.merge_add control
        (ScoreT.untyped (Signal.constant val))

-- * environ

get_srate :: Derive.Deriver RealTime
get_srate = RealTime.seconds <$> Derive.get_val EnvKey.srate

get_scale :: Derive.Deriver Scale.Scale
get_scale = Derive.get_scale =<< get_scale_id

lookup_scale :: Derive.Deriver (Maybe Scale.Scale)
lookup_scale = Derive.lookup_scale =<< get_scale_id

get_scale_id :: Derive.Deriver Pitch.ScaleId
get_scale_id = Expr.str_to_scale_id <$> Derive.get_val EnvKey.scale

lookup_key :: Derive.Deriver (Maybe Pitch.Key)
lookup_key = fmap Pitch.Key <$> Derive.lookup_val EnvKey.key

get_instrument :: Derive.Deriver ScoreT.Instrument
get_instrument = Derive.get_val EnvKey.instrument

lookup_instrument :: Derive.Deriver (Maybe ScoreT.Instrument)
lookup_instrument = Derive.lookup_val EnvKey.instrument

get_attributes :: Derive.Deriver Attrs.Attributes
get_attributes = fromMaybe mempty <$> Derive.lookup_val 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 = do
    scale <- get_scale
    env <- Derive.get_environ
    let transpose transposition steps =
            to_maybe . Scale.scale_transpose scale transposition env steps
    return
        ( to_maybe . Scale.scale_read scale env
        , to_maybe . Scale.scale_show scale env
        , transpose
        )
    where to_maybe = either (const Nothing) Just

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

chromatic_difference :: PSignal.Transposed -> PSignal.Transposed
    -> Derive.Deriver Pitch.Semi
chromatic_difference = pitch_difference Scale.chromatic_difference

diatonic_difference :: PSignal.Transposed -> PSignal.Transposed
    -> Derive.Deriver Pitch.PitchClass
diatonic_difference = pitch_difference Scale.diatonic_difference

pitch_difference :: (Scale.Layout -> Pitch.Pitch -> Pitch.Pitch -> a)
    -> PSignal.Transposed -> PSignal.Transposed -> Derive.Deriver a
pitch_difference difference p1 p2 = do
    scale <- get_scale
    env <- Derive.get_environ
    let parse scale env = Scale.scale_read scale env <=< PSignal.pitch_note
    let msg = pretty p1 <> " - " <> pretty p2 <> ": "
    Derive.require_right ((msg<>) . pretty) $
        difference (Scale.scale_layout scale) <$>
            parse scale env p1 <*> parse scale env p2

nn_difference :: RealTime -> PSignal.Pitch -> PSignal.Pitch
    -> Derive.Deriver Pitch.NoteNumber
nn_difference pos pitch1 pitch2 = do
    pitch1 <- Derive.resolve_pitch pos pitch1
    pitch2 <- Derive.resolve_pitch pos pitch2
    (-) <$> Pitches.pitch_nn pitch1 <*> Pitches.pitch_nn pitch2

-- * note

eval_pitch_ :: ScoreTime -> Pitch.Pitch -> Derive.Deriver PSignal.Transposed
eval_pitch_ start pitch = do
    (_, show_pitch, _) <- get_pitch_functions
    eval_pitch show_pitch start 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 show_pitch start pitch = do
    note <- Derive.require ("scale doesn't have pitch: " <> pretty pitch)
        (show_pitch pitch)
    eval_note start 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 pos note = Eval.eval_pitch pos $
    Expr.call0 (Expr.Symbol (Pitch.note_text note))

-- | Generate a single note, from 0 to 1.
note :: Derive.NoteDeriver
note = Eval.eval_one_call True $ Expr.call0 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 args = Eval.reapply_call (Args.context args) Symbols.null_note []

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

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

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

-- | A zero-duration 'note'.
triggered_note :: Derive.NoteDeriver
triggered_note =
    Eval.eval_one_at True 0 0 $ Expr.generator0 Symbols.null_note

place :: Derive.PassedArgs d -> Derive.Deriver a -> Derive.Deriver a
place = uncurry Derive.place . Args.extent

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

-- * transformer notes

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

add_attributes :: Attrs.Attributes -> Derive.Deriver d -> Derive.Deriver d
add_attributes attrs
    | attrs == mempty = id
    | otherwise = with_attributes (<> attrs)

add_flags :: Flags.Flags -> Derive.NoteDeriver -> Derive.NoteDeriver
add_flags flags
    | flags == mempty = id
    | otherwise = fmap (fmap (Score.add_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 = _make_randoms Pure64.randomDouble
        -- Pure64.randomDouble doesn't document the range, but that's what it
        -- is.
    randoms_in low high = map (Num.scale low high) <$> randoms

instance Random Int where
    -- Random numbers between INT_MIN and INT_MAX.
    randoms = _make_randoms Pure64.randomInt
    randoms_in low high = map (Num.restrict low high) <$> randoms

-- | Get a random Double or Int.  Ints will lose precision if converted to
-- double!
random :: Random a => Derive.Deriver a
random = head <$> randoms

random_in :: (Random a, Real a) => a -> a -> Derive.Deriver a
random_in low high
    | low == high = return low
    | otherwise = head <$> randoms_in low 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 v
    | v >= 1 = return True
    | v <= 0 = return False
    | otherwise = do
        r <- random_in 0 1
        return $ r <= v

shuffle :: [a] -> Derive.Deriver [a]
shuffle xs = Random.shuffle xs <$> randoms

_make_randoms :: (Pure64.PureMT -> (a, Pure64.PureMT)) -> Derive.Deriver [a]
_make_randoms f = List.unfoldr (Just . f) <$> _random_generator

_random_generator :: Derive.Deriver Pure64.PureMT
_random_generator = do
    seed <- fromMaybe 0 <$> Derive.lookup_val EnvKey.seed
    return $ Pure64.pureMT (floor (seed :: Double))

pick_weighted :: NonEmpty (Double, a) -> Double -> a
pick_weighted weights rnd_ = go 0 weights
    where
    rnd = rnd_ * Num.sum (fmap fst weights)
    go collect ((weight, a) :| weights) = case weights of
        [] -> a
        w : ws
            | collect + weight > rnd -> a
            | otherwise -> go (collect + weight) (w :| ws)

-- | Like 'pick_weighted' when all the weights are equal.
pick :: NonEmpty a -> Double -> a
pick (x :| xs) rnd = (x:xs) !! i
    where i = round (rnd * fromIntegral (length 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 stddev = make_normal stddev <$> 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 stddev rnds = Num.sum (take samples rnds) / fromIntegral samples
    where
    samples = 12

-- * conditional

if_env :: (Eq val, Typecheck.Typecheck val) => EnvKey.Key -> Maybe val
    -> Derive.Deriver a -> Derive.Deriver a -> Derive.Deriver a
if_env key val is_set not_set =
    ifM ((==val) <$> Derive.lookup_val key) is_set 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 key val transformer deriver =
    if_env key val (transformer deriver) 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 start dur = case Derive.to_duration dur of
    DeriveT.RealDuration t -> return t
    DeriveT.ScoreDuration t
        | t == 0 -> return 0
        | 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'.
            score_start <- Derive.score start
            real_start <- Derive.real start
            end <- Derive.real $ score_start + t
            return $ end - 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 start dur = case Derive.to_duration dur of
    DeriveT.ScoreDuration t -> return t
    DeriveT.RealDuration t
        | t == 0 -> return 0
        | 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.
            score_start <- Derive.score start
            real_start <- Derive.real start
            end <- Derive.score $ real_start + t
            return $ end - 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 args t = do
    start <- Args.real_start args
    dur <- real_duration start t
    return (start, start + 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 args t = do
    end <- Args.real_end args
    dur <- real_duration end t
    return (end - dur, 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 default_type from (ScoreT.Typed typ val)
    | typ == ScoreT.Real
        || typ == ScoreT.Untyped && default_type == Typecheck.Real =
            return (RealTime.seconds val)
    | typ == ScoreT.Score
        || typ == ScoreT.Untyped && default_type == Typecheck.Score =
            real_duration from (ScoreTime.from_double val)
    | otherwise = Derive.throw $
        "expected time type for " <> ShowVal.show_val (ScoreT.Typed typ 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 start ts steps = do
    (block_id, tracknum) <- Internal.get_current_tracknum
    Derive.require ("no valid timestep from " <> ShowVal.show_val start)
        =<< Derive.eval_ui
            (firstJusts [TimeStep.step_from step ts block_id tracknum start |
                step <- 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.RankName -> Int
    -> Derive.Deriver ScoreTime
meter_duration start rank steps = do
    let ts = TimeStep.time_step $
            TimeStep.RelativeMark TimeStep.match_meter
                (Meter.name_to_rank rank)
    end <- timestep start ts (map (*steps) [1, -1])
    return $ abs (end - start)

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


-- * general purpose types

-- | This is for arguments which can be high or low.
data UpDown = Up | Down deriving (Show, Enum, Bounded, Eq, Ord)

instance Pretty UpDown where pretty = showt
instance Typecheck.Typecheck UpDown
instance ShowVal.ShowVal UpDown where
    show_val Up = "u"
    show_val Down = "d"