-- 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 high level pitch calls.
--
-- High level calls do something a little more abstract and \"musical\"
-- than the low level calls in "Derive.Call.Prelude.Pitch".  Generally they
-- have complete-word names, while low level calls are just single letters.
--
-- TODO this module has a dumb name.  What would be better?
module Derive.C.Prelude.PitchHigh (library) where
import qualified Util.Doc as Doc
import qualified Derive.Args as Args
import qualified Derive.C.Prelude.Pitch as Call.Pitch
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.Sub as Sub
import qualified Derive.Call.Tags as Tags
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.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Sig as Sig
import           Derive.Sig (defaulted)
import qualified Derive.Typecheck as Typecheck

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

import           Types


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"lift", Transformer Note
c_lift_note)
        , (Symbol
"drop", Transformer Note
c_drop_note)
        , (Symbol
"Lift", Transformer Note
c_lift_note_start)
        , (Symbol
"Drop", Transformer Note
c_drop_note_start)
        ]
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [ (Symbol
"drop", Generator PSignal
c_drop)
        , (Symbol
"lift", Generator PSignal
c_lift)
        , (Symbol
"ad", Generator PSignal
c_approach_dyn)
        ]
    ]

-- * note calls

c_lift_note :: Derive.Transformer Derive.Note
c_lift_note :: Transformer Note
c_lift_note = CallName
-> Doc -> PitchDirection -> Align -> Align -> Transformer Note
make_note_fade CallName
"lift"
    Doc
"Raise pitch and drop `dyn` at the end of the note. Same as the `drop`\
    \ note call, except it defaults to going up instead of down."
    PitchDirection
PitchLift Align
AlignEnd Align
AlignStart

c_drop_note :: Derive.Transformer Derive.Note
c_drop_note :: Transformer Note
c_drop_note = CallName
-> Doc -> PitchDirection -> Align -> Align -> Transformer Note
make_note_fade CallName
"drop"
    Doc
"Drop pitch and `dyn` at the end of the note."
    PitchDirection
PitchDrop Align
AlignEnd Align
AlignStart

c_lift_note_start :: Derive.Transformer Derive.Note
c_lift_note_start :: Transformer Note
c_lift_note_start = CallName
-> Doc -> PitchDirection -> Align -> Align -> Transformer Note
make_note_fade CallName
"Lift"
    Doc
"Attack the note from a lower neighbor.  This is like the `n` pitch call,\
    \ but it's a note call, and it fades in `dyn` at the same time."
    PitchDirection
PitchDrop Align
AlignStart Align
AlignEnd
    -- The PitchDirection is reversed because a lift at the beginning of a note
    -- comes from below.  Also, I align the pitch to the end of the fade
    -- for symmetry with 'drop' and 'lift', I'm not sure if it's actually more
    -- musically useful that way.

c_drop_note_start :: Derive.Transformer Derive.Note
c_drop_note_start :: Transformer Note
c_drop_note_start = CallName
-> Doc -> PitchDirection -> Align -> Align -> Transformer Note
make_note_fade CallName
"Drop"
    Doc
"Like `Lift`, but attack the note from a higher neighbor."
    PitchDirection
PitchLift Align
AlignStart Align
AlignEnd
    -- Like 'c_lift_note_start', the PitchDirection is reversed.

make_note_fade :: Derive.CallName -> Doc.Doc -> PitchDirection -> Align
    -> Align -> Derive.Transformer Derive.Note
make_note_fade :: CallName
-> Doc -> PitchDirection -> Align -> Align -> Transformer Note
make_note_fade CallName
name Doc
doc PitchDirection
pitch_dir Align
align Align
align_fade =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
name Tags
Tags.under_invert Doc
doc
    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 Parser
  (Either Transpose Pitch, DefaultReal, Maybe DefaultReal, Curve)
fade_args
    forall a b. (a -> b) -> a -> b
$ \(Either Transpose Pitch
interval, Typecheck.DefaultReal Duration
time, Maybe DefaultReal
maybe_fade, Curve
curve) ->
    Transformer Note (Stream Note) -> Transformer Note (Stream Note)
Sub.under_invert forall a b. (a -> b) -> a -> b
$ \NoteArgs
args NoteDeriver
deriver -> do
        let fade :: Duration
fade = case Maybe DefaultReal
maybe_fade of
                Maybe DefaultReal
Nothing -> Duration
time
                Just (Typecheck.DefaultReal Duration
t) -> Duration
t
        ranges :: ((X, X), (X, X))
ranges@((X
pitch_start, X
_), (X, X)
_) <- Align
-> Align
-> Duration
-> Duration
-> ScoreTime
-> ScoreTime
-> Deriver ((X, X), (X, X))
pitch_fade_ranges Align
align Align
align_fade
            Duration
fade Duration
time (forall a. PassedArgs a -> ScoreTime
Args.start NoteArgs
args) (forall a. PassedArgs a -> ScoreTime
Args.end NoteArgs
args)
        X -> Deriver (Maybe Pitch)
Derive.pitch_at X
pitch_start forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe Pitch
Nothing -> NoteDeriver
deriver
            Just Pitch
pitch -> do
                (PSignal
slide, Control
dyn) <-
                    Align
-> Curve
-> Pitch
-> PitchDirection
-> Either Transpose Pitch
-> ((X, X), (X, X))
-> Deriver (PSignal, Control)
pitch_fade Align
align Curve
curve Pitch
pitch PitchDirection
pitch_dir Either Transpose Pitch
interval ((X, X), (X, X))
ranges
                PSignal
pitch_sig <- forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> PSignal
Derive.state_pitch
                let merged :: PSignal
merged = case Align
align of
                        -- Since the initial slide has to override the base
                        -- pitch, I can't just merge normally.
                        Align
AlignStart -> PSignal -> PSignal -> PSignal
PSignal.prepend PSignal
slide PSignal
pitch_sig
                        Align
AlignEnd -> PSignal
pitch_sig forall a. Semigroup a => a -> a -> a
<> PSignal
slide
                forall a. Control -> Typed Control -> Deriver a -> Deriver a
Call.multiply_control Control
Controls.dynamic (forall a. a -> Typed a
ScoreT.untyped Control
dyn) forall a b. (a -> b) -> a -> b
$
                    forall a. PSignal -> Deriver a -> Deriver a
Derive.with_pitch PSignal
merged NoteDeriver
deriver

fade_args :: Sig.Parser (Either Pitch.Transpose PSignal.Pitch,
    Typecheck.DefaultReal, Maybe Typecheck.DefaultReal, ControlUtil.Curve)
fade_args :: Parser
  (Either Transpose Pitch, DefaultReal, Maybe DefaultReal, Curve)
fade_args = (,,,)
    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
"interval"
        (forall a b. a -> Either a b
Left (Y -> Transpose
Pitch.Chromatic Y
7) :: Either Pitch.Transpose Sig.Dummy)
        Doc
"Interval or 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
"time" (X -> DefaultReal
Typecheck.real X
0.25) Doc
"Time to the 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
"fade" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Time to fade from or to nothing. If the fade is longer than the pitch\
        \ time, the pitch will finish moving before the dyn has faded out."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env

-- * pitch calls

c_drop :: Derive.Generator Derive.Pitch
c_drop :: Generator PSignal
c_drop = CallName -> Doc -> PitchDirection -> Generator PSignal
make_pitch_fade CallName
"drop" Doc
"Drop pitch and `dyn`." PitchDirection
PitchDrop

c_lift :: Derive.Generator Derive.Pitch
c_lift :: Generator PSignal
c_lift = CallName -> Doc -> PitchDirection -> Generator PSignal
make_pitch_fade CallName
"lift"
    Doc
"Lift pitch and drop `dyn`. This is the same as `drop`, except that it\
    \ defaults to going up instead of down."
    PitchDirection
PitchLift

make_pitch_fade :: Derive.CallName -> Doc.Doc -> PitchDirection
    -> Derive.Generator Derive.Pitch
make_pitch_fade :: CallName -> Doc -> PitchDirection -> Generator PSignal
make_pitch_fade CallName
name Doc
doc PitchDirection
pitch_dir =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
name Tags
Tags.cmod Doc
doc
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call Parser
  (Either Transpose Pitch, DefaultReal, Maybe DefaultReal, Curve)
fade_args
    forall a b. (a -> b) -> a -> b
$ \(Either Transpose Pitch
interval, Typecheck.DefaultReal Duration
time, Maybe DefaultReal
maybe_fade, Curve
curve) PassedArgs PSignal
args -> do
        let fade :: Duration
fade = case Maybe DefaultReal
maybe_fade of
                Maybe DefaultReal
Nothing -> Duration
time
                Just (Typecheck.DefaultReal Duration
t) -> Duration
t
        case PassedArgs PSignal -> Maybe (X, Pitch)
Args.prev_pitch PassedArgs PSignal
args of
            Maybe (X, Pitch)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
            Just (X
_, Pitch
prev_pitch) -> do
                (PSignal
slide, Control
dyn) <- Align
-> Curve
-> Pitch
-> PitchDirection
-> Either Transpose Pitch
-> ((X, X), (X, X))
-> Deriver (PSignal, Control)
pitch_fade Align
AlignEnd Curve
curve Pitch
prev_pitch PitchDirection
pitch_dir
                    Either Transpose Pitch
interval forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Align
-> Align
-> Duration
-> Duration
-> ScoreTime
-> ScoreTime
-> Deriver ((X, X), (X, X))
pitch_fade_ranges Align
AlignStart Align
AlignStart
                        Duration
fade Duration
time (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs PSignal
args) (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs PSignal
args)
                X
next <- forall a. Time a => a -> Deriver X
Derive.real (forall a. PassedArgs a -> ScoreTime
Args.next PassedArgs PSignal
args)
                X -> Control -> Deriver ()
ControlUtil.multiply_dyn X
next Control
dyn
                forall (m :: * -> *) a. Monad m => a -> m a
return PSignal
slide

c_approach_dyn :: Derive.Generator Derive.Pitch
c_approach_dyn :: Generator PSignal
c_approach_dyn = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
"approach-dyn"
    (Tags
Tags.cmod forall a. Semigroup a => a -> a -> a
<> Tags
Tags.next)
    Doc
"Like `approach`, slide to the next pitch, but also drop the `dyn`."
    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" (X -> DefaultReal
Typecheck.real X
0.2)
        Doc
"Time to get to destination pitch and dyn."
    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
"dyn" (Y
0.25 :: Double) Doc
"Drop `dyn` by this factor."
    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, Y
dyn, Curve
curve) PassedArgs PSignal
args -> do
        (X
start, X
end) <- forall t d. Time t => PassedArgs d -> t -> Deriver (X, X)
Call.duration_from_start PassedArgs PSignal
args Duration
time
        X -> Control -> Deriver ()
ControlUtil.multiply_dyn X
end
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Curve -> X -> Y -> X -> Y -> Deriver Control
ControlUtil.make_segment Curve
ControlUtil.Linear X
start Y
1 X
end Y
dyn
        PassedArgs PSignal -> Curve -> X -> X -> Deriver PSignal
Call.Pitch.approach PassedArgs PSignal
args Curve
curve X
start X
end

-- * fade implementation

data Align = AlignStart | AlignEnd deriving (Int -> Align -> ShowS
[Align] -> ShowS
Align -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Align] -> ShowS
$cshowList :: [Align] -> ShowS
show :: Align -> String
$cshow :: Align -> String
showsPrec :: Int -> Align -> ShowS
$cshowsPrec :: Int -> Align -> ShowS
Show)
data PitchDirection = PitchDrop | PitchLift deriving (Int -> PitchDirection -> ShowS
[PitchDirection] -> ShowS
PitchDirection -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PitchDirection] -> ShowS
$cshowList :: [PitchDirection] -> ShowS
show :: PitchDirection -> String
$cshow :: PitchDirection -> String
showsPrec :: Int -> PitchDirection -> ShowS
$cshowsPrec :: Int -> PitchDirection -> ShowS
Show)

pitch_fade :: Align -> ControlUtil.Curve -> PSignal.Pitch -> PitchDirection
    -> Either Pitch.Transpose PSignal.Pitch
    -> ((RealTime, RealTime), (RealTime, RealTime))
    -> Derive.Deriver (PSignal.PSignal, Signal.Control)
pitch_fade :: Align
-> Curve
-> Pitch
-> PitchDirection
-> Either Transpose Pitch
-> ((X, X), (X, X))
-> Deriver (PSignal, Control)
pitch_fade Align
align Curve
curve Pitch
pitch PitchDirection
pitch_dir Either Transpose Pitch
interval
        ((X
pitch_start, X
pitch_end), (X
fade_start, X
fade_end)) =
    (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Align
-> Curve
-> X
-> X
-> X
-> Pitch
-> Either Transpose Pitch
-> PitchDirection
-> Deriver PSignal
pitch_segment Align
align Curve
curve (forall a. Ord a => a -> a -> a
min X
pitch_start X
fade_start) X
pitch_start
                X
pitch_end Pitch
pitch Either Transpose Pitch
interval PitchDirection
pitch_dir
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Curve -> X -> Y -> X -> Y -> Deriver Control
segment Curve
ControlUtil.Linear X
fade_start Y
dyn1 X
fade_end Y
dyn2
    where
    (Y
dyn1, Y
dyn2) = case Align
align of
        Align
AlignStart -> (Y
0, Y
1)
        Align
AlignEnd -> (Y
1, Y
0)

-- | Create envelope start and end times for pitch and fade as follows:
--
-- @
--     --------     align   align_fade
--     ffff         Start   Start
--     pp-->
--     ffff         Start   End
--     <-pp
--         ffff     End     Start
--        <pp--
--         ffff     End     End
--        <--pp
-- @
pitch_fade_ranges :: Align -> Align
    -> DeriveT.Duration -> DeriveT.Duration
    -> ScoreTime -> ScoreTime
    -> Derive.Deriver ((RealTime, RealTime), (RealTime, RealTime))
pitch_fade_ranges :: Align
-> Align
-> Duration
-> Duration
-> ScoreTime
-> ScoreTime
-> Deriver ((X, X), (X, X))
pitch_fade_ranges Align
align Align
align_fade Duration
fade_time Duration
pitch_time ScoreTime
start ScoreTime
end = do
    let dur_from :: ScoreTime
dur_from = case Align
align of
            Align
AlignStart -> ScoreTime
start
            Align
AlignEnd -> ScoreTime
end
    X
fade_time <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver X
Call.real_duration ScoreTime
dur_from Duration
fade_time
    X
pitch_time <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver X
Call.real_duration ScoreTime
dur_from Duration
pitch_time
    (X
fade_start, X
fade_end) <- case Align
align of
        Align
AlignStart -> (\X
p -> (X
p, X
p forall a. Num a => a -> a -> a
+ X
fade_time)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Time a => a -> Deriver X
Derive.real ScoreTime
start
        Align
AlignEnd -> (\X
p -> (X
p forall a. Num a => a -> a -> a
- X
fade_time, X
p)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Time a => a -> Deriver X
Derive.real ScoreTime
end
    let (X
pitch_start, X
pitch_end) = case Align
align_fade of
            Align
AlignStart ->
                -- Since there's no point doing anything after the fade is
                -- done, extend backwards if pitch is longer than fade.
                forall a. Ord a => a -> a -> a
min (X
fade_start, X
fade_start forall a. Num a => a -> a -> a
+ X
pitch_time)
                    (X
fade_end forall a. Num a => a -> a -> a
- X
pitch_time, X
fade_end)
            Align
AlignEnd ->
                forall a. Ord a => a -> a -> a
max (X
fade_end forall a. Num a => a -> a -> a
- X
pitch_time, X
fade_end)
                    (X
fade_start, X
fade_start forall a. Num a => a -> a -> a
+ X
pitch_time)
    forall (m :: * -> *) a. Monad m => a -> m a
return ((X
pitch_start, X
pitch_end), (X
fade_start, X
fade_end))

segment :: ControlUtil.Curve -> RealTime -> Signal.Y -> RealTime
    -> Signal.Y -> Derive.Deriver Signal.Control
segment :: Curve -> X -> Y -> X -> Y -> Deriver Control
segment Curve
curve X
x1 Y
y1 X
x2 Y
y2 = do
    Control
sig <- Curve -> X -> Y -> X -> Y -> Deriver Control
ControlUtil.make_segment Curve
curve X
x1 Y
y1 X
x2 Y
y2
    -- TODO why do I need this leading sample?
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). X -> Y -> Signal kind
Signal.from_sample X
0 Y
y1 forall a. Semigroup a => a -> a -> a
<> Control
sig

pitch_segment :: Align -> ControlUtil.Curve
    -> RealTime -- ^ start pitch at this time
    -> RealTime -- ^ start segment
    -> RealTime -- ^ end segment
    -> PSignal.Pitch
    -> Either Pitch.Transpose PSignal.Pitch -> PitchDirection
    -> Derive.Deriver PSignal.PSignal
pitch_segment :: Align
-> Curve
-> X
-> X
-> X
-> Pitch
-> Either Transpose Pitch
-> PitchDirection
-> Deriver PSignal
pitch_segment Align
align Curve
curve X
start0 X
start X
end Pitch
pitch Either Transpose Pitch
interval PitchDirection
pitch_dir =
    case Align
align of
        -- If the pitch segment is at the start of the note, then I may need to
        -- override its base pitch with a flat segment.
        Align
AlignStart -> (Pitch -> PSignal
initial Pitch
dest <>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Curve -> X -> Pitch -> X -> Pitch -> Deriver PSignal
PitchUtil.make_segment Curve
curve X
start Pitch
dest X
end Pitch
pitch
        Align
AlignEnd -> Curve -> X -> Pitch -> X -> Pitch -> Deriver PSignal
PitchUtil.make_segment Curve
curve X
start Pitch
pitch X
end Pitch
dest
    where
    initial :: Pitch -> PSignal
initial Pitch
p = X -> Pitch -> PSignal
PSignal.from_sample X
start0 Pitch
p
    dest :: Pitch
dest = case Either Transpose Pitch
interval of
        Left Transpose
degrees -> forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose (Transpose -> Transpose
negate_interval Transpose
degrees) Pitch
pitch
        Right Pitch
p -> Pitch
p
    negate_interval :: Transpose -> Transpose
negate_interval = case PitchDirection
pitch_dir of
        PitchDirection
PitchDrop -> (Y -> Y) -> Transpose -> Transpose
Pitch.modify_transpose forall a. Num a => a -> a
negate
        PitchDirection
PitchLift -> forall a. a -> a
id