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

-- | Library of basic low level pitch calls.
--
-- Low level calls should do simple orthogonal things and their names are
-- generally just one or two characters.
module Derive.C.Prelude.Pitch (
    library
    , approach
) where
import qualified Data.Maybe as Maybe

import qualified Util.Doc as Doc
import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.Module as Module
import qualified Derive.Call.PitchUtil as PitchUtil
import qualified Derive.Call.Post as Post
import qualified Derive.Call.ScaleDegree as ScaleDegree
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale.JustScales as JustScales
import qualified Derive.Sig as Sig
import           Derive.Sig (defaulted, required)
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import qualified Ui.Events as Events
import qualified Ui.Types as Types

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators forall a b. (a -> b) -> a -> b
$
        [ (Symbol
"set", Generator Pitch
c_set)
        , (Symbol
"set-or-move", Generator Pitch
c_set_or_move)
        , (Symbol
"'", Generator Pitch
c_set_prev)
        , (Symbol
"*", Generator Pitch
c_multiply)

        -- interpolating
        , (Symbol
"n", Generator Pitch
c_neighbor)
        , (Symbol
"a", Generator Pitch
c_approach)
        , (Symbol
"u", Generator Pitch
c_up)
        , (Symbol
"d", Generator Pitch
c_down)
        , (Symbol
"p", Generator Pitch
c_porta)
        ] forall a. [a] -> [a] -> [a]
++ [(Symbol, Generator Pitch)]
PitchUtil.interpolator_variations
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers [(Symbol
"set", Transformer Pitch
c_set_transformer)]
    ]

-- * pitch

c_set :: Derive.Generator Derive.Pitch
c_set :: Generator Pitch
c_set = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"set" forall a. Monoid a => a
mempty Doc
"Emit a pitch with no interpolation." forall a b. (a -> b) -> a -> b
$
    -- This could take a transpose too, but then set has to be in
    -- 'require_previous', it gets shadowed for "" because of scales that use
    -- numbers, and it's not clearly useful.
    forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (forall a. Typecheck a => ArgName -> Doc -> Parser a
required ArgName
"pitch" Doc
"Set this pitch.") forall a b. (a -> b) -> a -> b
$ \Either NoteNumber (RawPitch Untransposed_)
pitch_ PassedArgs Pitch
args -> do
        let pitch :: RawPitch Untransposed_
pitch = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either NoteNumber -> RawPitch Untransposed_
PSignal.nn_pitch forall a. a -> a
id Either NoteNumber (RawPitch Untransposed_)
pitch_
        RealTime
pos <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> RawPitch Untransposed_ -> Pitch
PSignal.from_sample RealTime
pos RawPitch Untransposed_
pitch

c_set_or_move :: Derive.Generator Derive.Pitch
c_set_or_move :: Generator Pitch
c_set_or_move = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"set-or-move" forall a. Monoid a => a
mempty
    Doc
"Emit a pitch with no interpolation if it coincides with a note attack,\
    \ and interpolate otherwise." forall a b. (a -> b) -> a -> b
$
    forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
required ArgName
"pitch" Doc
"Set this pitch."
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.15) Doc
"Time to move to the pitch."
    ) forall a b. (a -> b) -> a -> b
$ \(Either NoteNumber (RawPitch Untransposed_)
pitch_, Typecheck.DefaultReal Duration
time) PassedArgs Pitch
args -> do
        let pitch :: RawPitch Untransposed_
pitch = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either NoteNumber -> RawPitch Untransposed_
PSignal.nn_pitch forall a. a -> a
id Either NoteNumber (RawPitch Untransposed_)
pitch_
        (TrackTime -> Events -> Bool
event_at (forall a. PassedArgs a -> TrackTime
Args.start PassedArgs Pitch
args) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver Events
Args.get_note_events) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
False -> do
                (RealTime
start, RealTime
end) <- forall t d.
Time t =>
PassedArgs d -> t -> Deriver (RealTime, RealTime)
Call.duration_from_start PassedArgs Pitch
args Duration
time
                let maybe_from :: Maybe (RawPitch Untransposed_)
maybe_from = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassedArgs Pitch -> Maybe (RealTime, RawPitch Untransposed_)
Args.prev_pitch PassedArgs Pitch
args
                Curve
-> RealTime
-> Maybe (RawPitch Untransposed_)
-> RealTime
-> PitchOrTranspose
-> Deriver Pitch
PitchUtil.make_segment_from Curve
ControlUtil.Linear RealTime
start Maybe (RawPitch Untransposed_)
maybe_from
                    RealTime
end (forall a b. a -> Either a b
Left RawPitch Untransposed_
pitch)
            Bool
True -> do
                RealTime
pos <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> RawPitch Untransposed_ -> Pitch
PSignal.from_sample RealTime
pos RawPitch Untransposed_
pitch

event_at :: TrackTime -> Events.Events -> Bool
event_at :: TrackTime -> Events -> Bool
event_at TrackTime
pos Events
events = forall a. Maybe a -> Bool
Maybe.isJust (TrackTime -> Orientation -> Events -> Maybe Event
Events.at TrackTime
pos Orientation
Types.Positive Events
events)
    Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
Maybe.isJust (TrackTime -> Orientation -> Events -> Maybe Event
Events.at TrackTime
pos Orientation
Types.Negative Events
events)

c_set_transformer :: Derive.Transformer Derive.Pitch
c_set_transformer :: Transformer Pitch
c_set_transformer = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"set" forall a. Monoid a => a
mempty
    Doc
"Prepend a pitch to a signal. This is useful to create a discontinuity,\
    \ e.g. interpolate to a pitch and then jump to another one."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (forall a. Typecheck a => ArgName -> Doc -> Parser a
required ArgName
"pitch" Doc
"Set this pitch.")
    forall a b. (a -> b) -> a -> b
$ \Either NoteNumber (RawPitch Untransposed_)
pitch_ PassedArgs Pitch
args Deriver (Stream Pitch)
deriver -> do
        let pitch :: RawPitch Untransposed_
pitch = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either NoteNumber -> RawPitch Untransposed_
PSignal.nn_pitch forall a. a -> a
id Either NoteNumber (RawPitch Untransposed_)
pitch_
        RealTime
pos <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        forall sig.
Monoid sig =>
(sig -> sig) -> Deriver (Stream sig) -> Deriver (Stream sig)
Post.signal (forall a. Semigroup a => a -> a -> a
<> RealTime -> RawPitch Untransposed_ -> Pitch
PSignal.from_sample RealTime
pos RawPitch Untransposed_
pitch) Deriver (Stream Pitch)
deriver

-- | Re-set the previous val.  This can be used to extend a breakpoint.
c_set_prev :: Derive.Generator Derive.Pitch
c_set_prev :: Generator Pitch
c_set_prev = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"set-prev" Tags
Tags.prev
    Doc
"Re-set the previous pitch.  This can be used to extend a breakpoint."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ \PassedArgs Pitch
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case PassedArgs Pitch -> Maybe (RealTime, RawPitch Untransposed_)
Args.prev_pitch PassedArgs Pitch
args of
            Just (RealTime
x, RawPitch Untransposed_
y) | RealTime
start forall a. Ord a => a -> a -> Bool
> RealTime
x ->
                forall a. a -> Stream a
Stream.from_event forall a b. (a -> b) -> a -> b
$ RealTime -> RawPitch Untransposed_ -> Pitch
PSignal.from_sample RealTime
start RawPitch Untransposed_
y
            Maybe (RealTime, RawPitch Untransposed_)
_ -> forall a. Stream a
Stream.empty

c_multiply :: Derive.Generator Derive.Pitch
c_multiply :: Generator Pitch
c_multiply = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"multiply" forall a. Monoid a => a
mempty
    Doc
"Emit the given pitch multiplied by a factor."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
required ArgName
"pitch" Doc
"Source pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"interval" (forall a b. a -> Either a b
Left Double
0 :: Either Pitch.Hz Pitch.Hz)
        (NamedIntervals -> Doc
ScaleDegree.interval_arg_doc NamedIntervals
intervals)
    ) forall a b. (a -> b) -> a -> b
$ \(RawPitch Untransposed_
pitch, Either Double Text
interval) PassedArgs Pitch
args -> do
        Double
interval <- NamedIntervals -> [Either Double Text] -> Deriver Double
ScaleDegree.resolve_intervals NamedIntervals
intervals [Either Double Text
interval]
        Scale
scale <- Deriver Scale
Call.get_scale
        let transposed :: RawPitch Untransposed_
transposed = Scale
-> (Double -> Double)
-> RawPitch Untransposed_
-> RawPitch Untransposed_
Pitches.modify_hz (Scale -> Scale
Pitches.scale Scale
scale) (forall a. Num a => a -> a -> a
*Double
interval)
                RawPitch Untransposed_
pitch
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> RawPitch Untransposed_ -> Pitch
PSignal.from_sample RealTime
start RawPitch Untransposed_
transposed
    where
    intervals :: NamedIntervals
intervals = NamedIntervals
JustScales.default_named_intervals

-- * interpolating

c_neighbor :: Derive.Generator Derive.Pitch
c_neighbor :: Generator Pitch
c_neighbor = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"neighbor" forall a. Monoid a => a
mempty
    Doc
"Emit a slide from a neighboring pitch to the given one."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
required ArgName
"pitch" Doc
"Destination pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"neighbor" (Double -> Transpose
Pitch.Chromatic Double
1) Doc
"Neighobr interval."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.1) Doc
"Time to get to destination."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    ) forall a b. (a -> b) -> a -> b
$ \(RawPitch Untransposed_
pitch, Transpose
neighbor, Typecheck.DefaultReal Duration
time, Curve
curve) PassedArgs Pitch
args -> do
        (RealTime
start, RealTime
end) <- forall t d.
Time t =>
PassedArgs d -> t -> Deriver (RealTime, RealTime)
Call.duration_from_start PassedArgs Pitch
args Duration
time
        let pitch1 :: RawPitch Untransposed_
pitch1 = forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Transpose
neighbor RawPitch Untransposed_
pitch
        Curve
-> RealTime
-> RawPitch Untransposed_
-> RealTime
-> RawPitch Untransposed_
-> Deriver Pitch
PitchUtil.make_segment Curve
curve RealTime
start RawPitch Untransposed_
pitch1 RealTime
end RawPitch Untransposed_
pitch

c_approach :: Derive.Generator Derive.Pitch
c_approach :: Generator Pitch
c_approach = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"approach" Tags
Tags.next
    Doc
"Slide to the next pitch." forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.2) Doc
"Time to get to destination."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    ) forall a b. (a -> b) -> a -> b
$ \(Typecheck.DefaultReal Duration
time, Curve
curve) PassedArgs Pitch
args -> do
        (RealTime
start, RealTime
end) <- forall t d.
Time t =>
PassedArgs d -> t -> Deriver (RealTime, RealTime)
Call.duration_from_start PassedArgs Pitch
args Duration
time
        PassedArgs Pitch -> Curve -> RealTime -> RealTime -> Deriver Pitch
approach PassedArgs Pitch
args Curve
curve RealTime
start RealTime
end

approach :: Derive.PitchArgs -> ControlUtil.Curve -> RealTime -> RealTime
    -> Derive.Deriver PSignal.PSignal
approach :: PassedArgs Pitch -> Curve -> RealTime -> RealTime -> Deriver Pitch
approach PassedArgs Pitch
args Curve
curve RealTime
start RealTime
end = do
    Maybe (RawPitch Untransposed_)
maybe_next <- PassedArgs Pitch -> Deriver (Maybe (RawPitch Untransposed_))
Args.eval_next_pitch PassedArgs Pitch
args
    case (PassedArgs Pitch -> Maybe (RealTime, RawPitch Untransposed_)
Args.prev_pitch PassedArgs Pitch
args, Maybe (RawPitch Untransposed_)
maybe_next) of
        (Just (RealTime
_, RawPitch Untransposed_
prev), Just RawPitch Untransposed_
next) ->
            Curve
-> RealTime
-> RawPitch Untransposed_
-> RealTime
-> RawPitch Untransposed_
-> Deriver Pitch
PitchUtil.make_segment Curve
curve RealTime
start RawPitch Untransposed_
prev RealTime
end RawPitch Untransposed_
next
        (Maybe (RealTime, RawPitch Untransposed_),
 Maybe (RawPitch Untransposed_))
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

c_up :: Derive.Generator Derive.Pitch
c_up :: Generator Pitch
c_up = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"up" Tags
Tags.prev
    Doc
"Ascend at the given speed until the next event." forall a b. (a -> b) -> a -> b
$ Doc -> Double -> WithArgDoc (Generator Pitch Pitch)
slope Doc
"Ascend" Double
1

c_down :: Derive.Generator Derive.Pitch
c_down :: Generator Pitch
c_down = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"down" Tags
Tags.prev
    Doc
"Descend at the given speed until the next event." forall a b. (a -> b) -> a -> b
$ Doc -> Double -> WithArgDoc (Generator Pitch Pitch)
slope Doc
"Descend" (-Double
1)

slope :: Doc.Doc -> Double -> Derive.WithArgDoc
    (Derive.PitchArgs -> Derive.Deriver PSignal.PSignal)
slope :: Doc -> Double -> WithArgDoc (Generator Pitch Pitch)
slope Doc
word Double
sign = forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"slope" (Double -> Transpose
Pitch.Chromatic Double
1)
        (Doc
word forall a. Semigroup a => a -> a -> a
<> Doc
" this many steps per second.")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe (RawPitch Untransposed_))
PitchUtil.from_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    ) forall a b. (a -> b) -> a -> b
$ \(Transpose
slope, Maybe (RawPitch Untransposed_)
from, Curve
curve) PassedArgs Pitch
args -> case Maybe (RawPitch Untransposed_)
-> PassedArgs Pitch -> Maybe (RawPitch Untransposed_)
PitchUtil.prev_val Maybe (RawPitch Untransposed_)
from PassedArgs Pitch
args of
        Maybe (RawPitch Untransposed_)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        Just RawPitch Untransposed_
prev_pitch -> do
            RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
            RealTime
next <- forall a. Time a => a -> Deriver RealTime
Derive.real (forall a. PassedArgs a -> TrackTime
Args.next PassedArgs Pitch
args)
            let dest :: RawPitch Untransposed_
dest = forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Transpose
transpose RawPitch Untransposed_
prev_pitch
                transpose :: Transpose
transpose = (Double -> Double) -> Transpose -> Transpose
Pitch.modify_transpose
                    (forall a. Num a => a -> a -> a
* (RealTime -> Double
RealTime.to_seconds (RealTime
next forall a. Num a => a -> a -> a
- RealTime
start) forall a. Num a => a -> a -> a
* Double
sign)) Transpose
slope
            Curve
-> RealTime
-> RawPitch Untransposed_
-> RealTime
-> RawPitch Untransposed_
-> Deriver Pitch
PitchUtil.make_segment Curve
curve RealTime
start RawPitch Untransposed_
prev_pitch RealTime
next RawPitch Untransposed_
dest

c_porta :: Derive.Generator Derive.Pitch
c_porta :: Generator Pitch
c_porta = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"porta" forall a. Monoid a => a
mempty
    Doc
"Interpolate between two pitches. This is similar to `i>>`,  but intended\
    \ to be higher level, in that instruments or scores can override it to\
    \ represent an idiomatic portamento."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PitchOrTranspose
PitchUtil.pitch_arg
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"time" DefaultReal
ControlUtil.default_interpolation_time
        Doc
"Time to reach destination."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"place" EnvironDefault
Sig.Both (Double -> Normalized
Typecheck.Normalized Double
1)
        Doc
"Placement, from before to after the call."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe (RawPitch Untransposed_))
PitchUtil.from_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    ) forall a b. (a -> b) -> a -> b
$ \(PitchOrTranspose
to, Typecheck.DefaultReal Duration
time, Normalized
place, Maybe (RawPitch Untransposed_)
from, Curve
curve) PassedArgs Pitch
args -> do
        let maybe_from :: Maybe (RawPitch Untransposed_)
maybe_from = Maybe (RawPitch Untransposed_)
from forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassedArgs Pitch -> Maybe (RealTime, RawPitch Untransposed_)
Args.prev_pitch PassedArgs Pitch
args)
        Duration
time <- if forall a. PassedArgs a -> TrackTime
Args.duration PassedArgs Pitch
args forall a. Eq a => a -> a -> Bool
== TrackTime
0
            then forall (m :: * -> *) a. Monad m => a -> m a
return Duration
time
            else RealTime -> Duration
DeriveT.RealDuration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PassedArgs a -> Deriver RealTime
Args.real_duration PassedArgs Pitch
args
        (RealTime
start, RealTime
end) <- Normalized -> TrackTime -> Duration -> Deriver (RealTime, RealTime)
ControlUtil.place_range Normalized
place (forall a. PassedArgs a -> TrackTime
Args.start PassedArgs Pitch
args) Duration
time
        Curve
-> RealTime
-> Maybe (RawPitch Untransposed_)
-> RealTime
-> PitchOrTranspose
-> Deriver Pitch
PitchUtil.make_segment_from Curve
curve RealTime
start Maybe (RawPitch Untransposed_)
maybe_from RealTime
end PitchOrTranspose
to

-- * util

generator1 :: Derive.CallName -> Tags.Tags -> Doc.Doc
    -> Derive.WithArgDoc (Derive.PassedArgs d -> Derive.Deriver d)
    -> Derive.Call (Derive.GeneratorFunc d)
generator1 :: forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude