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

{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-- | Calls for Carnatic gamakam.
module Derive.C.India.Gamakam5 (
    library
#ifdef TESTING
    , module Derive.C.India.Gamakam5
#endif
) where
import qualified Control.Monad.State as State
import qualified Data.Attoparsec.Text as A
import qualified Data.Char as Char
import qualified Data.DList as DList
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Maps as Maps
import qualified Util.Num as Num
import qualified Util.ParseText as ParseText
import qualified Util.Pretty as Pretty
import qualified Util.Segment as Segment

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.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Parse as Parse
import qualified Derive.Pitches as Pitches
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal
import qualified Ui.Event as Event
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


module_ :: Module.Module
module_ :: Module
module_ = Module
"india" forall a. Semigroup a => a -> a -> a
<> Module
"gamakam5"

library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [ (Symbol
Parse.unparsed_call, Generator Control
c_pitch_sequence)
        , (Symbol
Parse.unparsed_call, Generator Control
c_dyn_sequence)
        ]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"gamak", Transformer Control
c_import_pitch)
        , (Symbol
"dyn", Transformer Control
c_import_dyn)
        ]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"sahitya", forall a. Taggable a => Transformer a
c_sahitya :: Derive.Transformer Derive.Note)
        ]
    ]

-- * sequence

c_import_pitch :: Derive.Transformer Derive.Control
c_import_pitch :: Transformer Control
c_import_pitch = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"gamak" forall a. Monoid a => a
mempty
    Doc
"Import calls for a gamakam track."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Control
_args -> forall a. Bool -> Module -> Deriver a -> Deriver a
Derive.with_imported Bool
False (Module
module_ forall a. Semigroup a => a -> a -> a
<> Module
"pitch")

c_import_dyn :: Derive.Transformer Derive.Control
c_import_dyn :: Transformer Control
c_import_dyn = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"dyn" forall a. Monoid a => a
mempty
    Doc
"Import calls for a dyn track."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Control
_args -> forall a. Bool -> Module -> Deriver a -> Deriver a
Derive.with_imported Bool
False (Module
module_ forall a. Semigroup a => a -> a -> a
<> Module
"dyn")

c_pitch_sequence :: Derive.Generator Derive.Control
c_pitch_sequence :: Generator Control
c_pitch_sequence = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 (Module
module_ forall a. Semigroup a => a -> a -> a
<> Module
"pitch")
    CallName
"sequence" forall a. Monoid a => a
mempty Doc
pitch_sequence_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 ((,,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"sequence" Doc
"Pitch calls."
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Normalized
transition_env
        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.environ ArgName
"gamakam-above" EnvironDefault
Sig.Unprefixed Bool
False
            Doc
"Expect pitch and gamakam tracks above the note track."
    ) forall a b. (a -> b) -> a -> b
$ \(Text
text, Normalized
transition, Bool
pitch_above) PassedArgs Control
args -> do
        (ScoreTime
start, ScoreTime
end) <- if Bool
pitch_above
            then (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Control
args,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PassedArgs a -> Deriver ScoreTime
infer_end PassedArgs Control
args
            else forall a.
PassedArgs a -> Deriver State Error (ScoreTime, ScoreTime)
Args.range_or_note_end PassedArgs Control
args
        Maybe PitchState
maybe_state <- Bool
-> Normalized -> PassedArgs Control -> Deriver (Maybe PitchState)
initial_pitch_state Bool
pitch_above Normalized
transition PassedArgs Control
args
        case Maybe PitchState
maybe_state of
            Maybe PitchState
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
            Just PitchState
state -> do
                Result DList Control
signals <- forall a. ScoreTime -> Deriver a -> Deriver a
Derive.at ScoreTime
start forall a b. (a -> b) -> a -> b
$
                    ScoreTime -> PitchState -> Text -> Deriver Result
pitch_sequence (ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
start) PitchState
state Text
text
                RealTime
real_end <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
                -- End is the next pitch sample.  So if the next event
                -- coincides with or precedes it, it will want to come from
                -- this pitch, so don't append a 0.  Otherwise, the pitch is
                -- not "attached" to a gamakam, so I add a 0, otherwise it's
                -- out of tune.
                --
                -- I have to subtract ScoreTime.eta because the pitch sample
                -- has been warped back from RealTime, so it will lose some
                -- precision.  TODO ugh.
                let next_gamakam :: Bool
next_gamakam = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
                        ((forall a. Ord a => a -> a -> Bool
<=ScoreTime
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract ScoreTime
ScoreTime.eta) (forall a. PassedArgs a -> Maybe ScoreTime
next_event PassedArgs Control
args)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat (forall a. DList a -> [a]
DList.toList DList Control
signals)
                    forall a. Semigroup a => a -> a -> a
<> if Bool
next_gamakam then forall a. Monoid a => a
mempty
                        else forall {k} (kind :: k). RealTime -> Double -> Signal kind
Signal.from_sample RealTime
real_end Double
0
    where
    transition_env :: Sig.Parser Typecheck.Normalized
    transition_env :: Parser Normalized
transition_env =
        forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"transition" EnvironDefault
Sig.Both (Double -> Normalized
Typecheck.Normalized Double
0.5) forall a b. (a -> b) -> a -> b
$
            Doc
"Time for each pitch movement, in proportion of the total time"
            forall a. Semigroup a => a -> a -> a
<> Doc
" available."

-- | Start of the next event.  'Args.next' gets the end of the block if there
-- is no next event, but I don't want that.
next_event :: Derive.PassedArgs a -> Maybe TrackTime
next_event :: forall a. PassedArgs a -> Maybe ScoreTime
next_event = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> ScoreTime
Event.start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PassedArgs a -> [Event]
Args.next_events

-- | Infer the end time for the gamakam as the next pitch in the pitch signal,
-- which should correspond to the next explicit swaram.
infer_end :: Derive.PassedArgs a -> Derive.Deriver TrackTime
infer_end :: forall a. PassedArgs a -> Deriver ScoreTime
infer_end PassedArgs a
args
    | forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs a
args forall a. Eq a => a -> a -> Bool
/= forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs a
args
    | Bool
otherwise = do
        Pitch
pitch <- Deriver Pitch
Derive.get_pitch
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs a
args
        case RealTime -> Pitch -> Maybe (RealTime, Pitch)
next_sample RealTime
start Pitch
pitch of
            Maybe (RealTime, Pitch)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args
            Just (RealTime
x, Pitch
_) -> do
                -- x could be the final sample at RealTime.large, so I need to
                -- limit it.
                ScoreTime
end <- forall a. Typecheck a => Text -> Deriver a
Derive.get_val Text
EnvKey.block_end
                forall a. Ord a => a -> a -> a
min ScoreTime
end forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Time a => a -> Deriver ScoreTime
Derive.score RealTime
x

initial_pitch_state :: Bool -> Typecheck.Normalized
    -> Derive.PassedArgs Derive.Control
    -> Derive.Deriver (Maybe PitchState)
initial_pitch_state :: Bool
-> Normalized -> PassedArgs Control -> Deriver (Maybe PitchState)
initial_pitch_state Bool
pitch_above Normalized
transition PassedArgs Control
args = do
    RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args
    -- If there's no pitch then this is likely at the edge of a slice, and can
    -- be ignored.  TODO I think?
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (RealTime -> Deriver (Maybe Transposed)
lookup_pitch RealTime
start) forall a b. (a -> b) -> a -> b
$ \Transposed
current -> do
        (Maybe Pitch
prev, Maybe Pitch
next, Maybe Pitch
from) <- if Bool
pitch_above
            then RealTime -> Deriver (Maybe Pitch, Maybe Pitch, Maybe Pitch)
get_neighbor_pitches_above RealTime
start
            else ScoreTime -> Deriver (Maybe Pitch, Maybe Pitch, Maybe Pitch)
get_neighbor_pitches (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Control
args)

        let prev_step :: Double
prev_step = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ PassedArgs Control -> Maybe (RealTime, Double)
Args.prev_control PassedArgs Control
args
        let steps_from_current :: Maybe Pitch -> Deriver State Error Double
steps_from_current = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe Double
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                ((Transposed -> Transposed -> Deriver State Error Double
`step_difference` Transposed
current) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start)
        Double
prev <- Maybe Pitch -> Deriver State Error Double
steps_from_current Maybe Pitch
prev
        Double
from <- Maybe Pitch -> Deriver State Error Double
steps_from_current forall a b. (a -> b) -> a -> b
$
            forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (forall a. Real a => a -> NoteNumber
Pitch.nn Double
prev_step) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Pitch
from
        Double
next <- Maybe Pitch -> Deriver State Error Double
steps_from_current Maybe Pitch
next

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PitchState
            { _swaram :: Transposed
_swaram = Transposed
current
            , _from :: Double
_from = Double
from
            , _prev :: Double
_prev = Double
prev
            , _next :: Double
_next = Double
next
            , _transition :: Normalized
_transition = Normalized
transition
            }
    where
    lookup_pitch :: RealTime -> Deriver (Maybe Transposed)
lookup_pitch = RealTime -> Deriver (Maybe Transposed)
Call.transposed

get_neighbor_pitches :: ScoreTime -> Derive.Deriver
    (Maybe PSignal.Pitch, Maybe PSignal.Pitch, Maybe PSignal.Pitch)
get_neighbor_pitches :: ScoreTime -> Deriver (Maybe Pitch, Maybe Pitch, Maybe Pitch)
get_neighbor_pitches ScoreTime
start = (,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScoreTime -> Deriver (Maybe Pitch)
Args.lookup_prev_note_pitch ScoreTime
start
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScoreTime -> Deriver (Maybe Pitch)
Args.lookup_next_note_pitch ScoreTime
start
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RealTime -> Deriver (Maybe Pitch)
get_prev_pitch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start)

get_neighbor_pitches_above :: RealTime -> Derive.Deriver
    (Maybe PSignal.Pitch, Maybe PSignal.Pitch, Maybe PSignal.Pitch)
get_neighbor_pitches_above :: RealTime -> Deriver (Maybe Pitch, Maybe Pitch, Maybe Pitch)
get_neighbor_pitches_above RealTime
start = do
    Pitch
pitch <- Deriver Pitch
Derive.get_pitch
    let prev :: Maybe Pitch
prev = Pitch -> RealTime -> Maybe Pitch
PSignal.at_negative Pitch
pitch RealTime
start
    let next :: Maybe Pitch
next = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Pitch -> Maybe (RealTime, Pitch)
next_sample RealTime
start Pitch
pitch
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pitch
prev, Maybe Pitch
next, Maybe Pitch
prev)

next_sample :: RealTime -> PSignal.PSignal -> Maybe (RealTime, PSignal.Pitch)
next_sample :: RealTime -> Pitch -> Maybe (RealTime, Pitch)
next_sample RealTime
x Pitch
pitch = do
    Segment.Segment RealTime
_ Pitch
_ RealTime
x2 Pitch
_ <- Pitch -> RealTime -> Maybe (Segment Pitch)
PSignal.segment_at Pitch
pitch RealTime
x
    (RealTime
x2,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pitch -> RealTime -> Maybe Pitch
PSignal.at Pitch
pitch RealTime
x2

get_prev_pitch :: RealTime -> Derive.Deriver (Maybe PSignal.Pitch)
get_prev_pitch :: RealTime -> Deriver (Maybe Pitch)
get_prev_pitch = RealTime -> Deriver (Maybe Pitch)
Args.prev_note_pitch

-- TODO this is how it used to work, which is complicated, and only mostly
-- worked.  If I move to *_above, then maybe I can get rid of this entirely.
-- get_prev_pitch_old :: RealTime -> Derive.Deriver (Maybe PSignal.Pitch)
-- get_prev_pitch_old start = do
--     -- If this is the first call in this note, then I have to look in the
--     -- previous slice.
--     prev_event_pitch <- Args.prev_note_pitch start
--     -- TODO gives different results for test_prev_pitch, but I don't understand
--     -- which is right.
--     -- pitch_signal <- PSignal.last . PSignal.drop_after start <$> Derive.get_pitch
--     pitch_signal <- before start <$> Derive.get_pitch
--     return $ case (prev_event_pitch, pitch_signal) of
--         (Just a, Just b) -> Just $ snd $ Lists.maxOn fst a b
--         (a, b) -> snd <$> (a <|> b)
--     -- Getting the previous pitch is kind of ridiculously complicated.
--     -- First, Args.prev_pitch means there was a preceding pitch call, so
--     -- I take that one if present.  Otherwise, the pitch can come from
--     -- either the previous event, or the previous pitch on the current
--     -- pitch signal, whichever is newer.  The current pitch signal will
--     -- be newer if there is a pitch on the parent pitch track with no
--     -- corresponding gamakam on this one.

before :: RealTime -> PSignal.PSignal -> Maybe (RealTime, PSignal.Pitch)
before :: RealTime -> Pitch -> Maybe (RealTime, Pitch)
before RealTime
x Pitch
sig = case Pitch -> RealTime -> Maybe (Segment Pitch)
PSignal.segment_at Pitch
sig RealTime
x of
    Just (Segment.Segment RealTime
x Pitch
y RealTime
_ Pitch
_) -> forall a. a -> Maybe a
Just (RealTime
x, Pitch
y)
    Maybe (Segment Pitch)
Nothing -> forall a. Maybe a
Nothing

step_difference :: PSignal.Transposed -> PSignal.Transposed
    -> Derive.Deriver Step
step_difference :: Transposed -> Transposed -> Deriver State Error Double
step_difference Transposed
p1 Transposed
p2 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Real a, Fractional b) => a -> b
realToFrac forall a b. (a -> b) -> a -> b
$
    (-) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transposed -> Deriver State Error NoteNumber
Pitches.pitch_nn Transposed
p1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Transposed -> Deriver State Error NoteNumber
Pitches.pitch_nn Transposed
p2

pitch_sequence_doc :: Doc.Doc
pitch_sequence_doc :: Doc
pitch_sequence_doc = Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$
    Text
"This is a mini-language, where each one or two characters is a call.\
    \ An upper-case call will take a single character argument. A special\
    \ parsing rule means that `-` and its following character is considered\
    \ a single character, so `-1` is a valid call or argument.\
    \ Most of these calls represent a pitch movement:"
    forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines (forall a b. (a -> b) -> [a] -> [b]
map (Char, [PitchCall]) -> Text
pitch_call_doc (forall k a. Map k a -> [(k, a)]
Map.toAscList Map Char [PitchCall]
pitch_call_map))
    forall a. Semigroup a => a -> a -> a
<> Text
"Currently the transition curve is hardcoded to a sigmoid curve, but\
    \ I could add a curve env var if necessary."

pitch_call_doc :: (Char, [PitchCall]) -> Text
pitch_call_doc :: (Char, [PitchCall]) -> Text
pitch_call_doc (Char
name, [PitchCall]
pcalls) =
    Text
"`" forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
name forall a. Semigroup a => a -> a -> a
<> Text
"` - "
        forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"; " (forall a b. (a -> b) -> [a] -> [b]
map PitchCall -> Text
doc_of [PitchCall]
pcalls)
    where
    doc_of :: PitchCall -> Text
doc_of PitchCall
pcall = PitchCall -> Text
pcall_doc PitchCall
pcall
        forall a. Semigroup a => a -> a -> a
<> if PitchCall -> Double
pcall_duration PitchCall
pcall forall a. Eq a => a -> a -> Bool
/= Double
1
            then Text
" (dur " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (PitchCall -> Double
pcall_duration PitchCall
pcall) forall a. Semigroup a => a -> a -> a
<> Text
")" else Text
""

pitch_call_map :: Map Char [PitchCall]
pitch_call_map :: Map Char [PitchCall]
pitch_call_map = forall {b} {b}.
Show b =>
(Map Char (Either (Double, [Text]) PitchCall), [(b, b)])
-> Map Char [PitchCall]
resolve forall a b. (a -> b) -> a -> b
$ forall a b. Ord a => [(a, b)] -> (Map a b, [(a, b)])
Maps.unique forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
'=' Text
"Hold flat pitch." PCall
pc_flat]
    -- relative motion
    , [forall {a} {a}. (a, Either a PitchCall) -> (a, Either a PitchCall)
parse_name forall a b. (a -> b) -> a -> b
$ forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
c Text
"Relative motion." PCall
pc_relative | Char
c <- [Char]
"0123456789"]
    , [forall {a} {a}. (a, Either a PitchCall) -> (a, Either a PitchCall)
parse_name forall a b. (a -> b) -> a -> b
$ forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
'-' Text
"Negative relative motion." PCall
pc_relative]
    , [forall {a} {a} {b} {b}. a -> a -> b -> (a, Either (a, b) b)
alias Char
c Double
1 [forall a. Show a => a -> Text
showt Integer
n] | (Char
c, Integer
n) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Char]
"abc" [-Integer
1, -Integer
2 ..]]

    , [forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
'e' Text
"Pitch up by 1nn." (Transpose -> PCall
pc_relative_move (Double -> Transpose
Pitch.Nn Double
1))]
    , [forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
'f' Text
"Pitch down by 1nn." (Transpose -> PCall
pc_relative_move (Double -> Transpose
Pitch.Nn (-Double
1)))]
    , [forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
'g' Text
"Pitch up by .5nn." (Transpose -> PCall
pc_relative_move (Double -> Transpose
Pitch.Nn Double
0.5))]
    , [forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
'h' Text
"Pitch down by .5nn." (Transpose -> PCall
pc_relative_move (Double -> Transpose
Pitch.Nn (-Double
0.5)))]
    , [forall {a} {a} {b} {b}. a -> a -> b -> (a, Either (a, b) b)
alias Char
'n' Double
0.5 [Text
"e", Text
"f"]]
    , [forall {a} {a} {b} {b}. a -> a -> b -> (a, Either (a, b) b)
alias Char
'u' Double
0.5 [Text
"f", Text
"e"]]

    , [ forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
'v' Text
"Absolute motion to next pitch." (PitchDirection -> PCall
pc_move_direction PitchDirection
Next)
      -- set config
      , forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
config Char
'<' Text
"Set from pitch to previous." (PitchDirection -> PCall
pc_set_pitch_from PitchDirection
Previous)
      , forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
config Char
'^' Text
"Set from pitch to current." (PitchDirection -> PCall
pc_set_pitch_from PitchDirection
Current)
      , forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
config Char
'&' Text
"Set from pitch to next." (PitchDirection -> PCall
pc_set_pitch_from PitchDirection
Next)
      , forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
config Char
'T' Text
"Set from pitch relative to swaram." PCall
pc_set_pitch
      , forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
config Char
'F' Text
"Fast transition time." (TransitionTime -> PCall
pc_set_transition_time TransitionTime
Fast)
      , forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
config Char
'M' Text
"Medium transition time." (TransitionTime -> PCall
pc_set_transition_time TransitionTime
Medium)
      , forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
config Char
'S' Text
"Slow transition time." (TransitionTime -> PCall
pc_set_transition_time TransitionTime
Slow)
      ]
    -- Just a placeholder, effects are actually applied by 'resolve_postfix'.
    , [ forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
config Char
c Text
postfix_doc (forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$ \() Context
_ctx -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty)
      | Char
c <- forall k a. Map k a -> [k]
Map.keys Map Char (Double -> Double)
postfix_calls
      ]
    ]
    where
    resolve :: (Map Char (Either (Double, [Text]) PitchCall), [(b, b)])
-> Map Char [PitchCall]
resolve (Map Char (Either (Double, [Text]) PitchCall)
calls, [(b, b)]
duplicates)
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(b, b)]
duplicates = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => Text -> a
errorStack forall a. a -> a
id (Map Char (Either (Double, [Text]) PitchCall)
-> Either Text (Map Char [PitchCall])
resolve_aliases Map Char (Either (Double, [Text]) PitchCall)
calls)
        | Bool
otherwise =
            forall a. HasCallStack => Text -> a
errorStack forall a b. (a -> b) -> a -> b
$ Text
"duplicate calls: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(b, b)]
duplicates)
    parse_name :: (a, Either a PitchCall) -> (a, Either a PitchCall)
parse_name = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a -> b) -> a -> b
$ \PitchCall
g -> PitchCall
g { pcall_parse_call_name :: Bool
pcall_parse_call_name = Bool
True }
    alias :: a -> a -> b -> (a, Either (a, b) b)
alias a
name a
duration b
to = (a
name, forall a b. a -> Either a b
Left (a
duration, b
to))
    pcall :: a -> Text -> PCall -> (a, Either a PitchCall)
pcall a
name Text
doc PCall
c = (a
name, forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Double -> Bool -> PCall -> PitchCall
PitchCall Text
doc Double
1 Bool
False PCall
c)
    config :: a -> Text -> PCall -> (a, Either a PitchCall)
config a
name Text
doc PCall
c = (a
name, forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Double -> Bool -> PCall -> PitchCall
PitchCall Text
doc Double
0 Bool
False PCall
c)

-- * dyn-sequence

c_dyn_sequence :: Derive.Generator Derive.Control
c_dyn_sequence :: Generator Control
c_dyn_sequence = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 (Module
module_ forall a. Semigroup a => a -> a -> a
<> Module
"dyn") CallName
"dyn-sequence" forall a. Monoid a => a
mempty 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 (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"sequence" Doc
"Dyn calls.")
    forall a b. (a -> b) -> a -> b
$ \Text
text PassedArgs Control
args -> do
        (ScoreTime
start, ScoreTime
end) <- forall a.
PassedArgs a -> Deriver State Error (ScoreTime, ScoreTime)
Args.range_or_note_end PassedArgs Control
args
        let state :: DynState
state = DynState
                { state_from_dyn :: Double
state_from_dyn = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 forall a b. (a, b) -> b
snd (PassedArgs Control -> Maybe (RealTime, Double)
Args.prev_control PassedArgs Control
args) }
        forall a. ScoreTime -> Deriver a -> Deriver a
Derive.at ScoreTime
start forall a b. (a -> b) -> a -> b
$ ScoreTime -> DynState -> Text -> Deriver Control
dyn_sequence (ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
start) DynState
state Text
text
    where
    doc :: Doc
doc = Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$
        Text
"This is a mini-language, where each one or two characters is a call.\
        \ Each character can take an argument, which can only be a single\
        \ digit. Typically this represents a dyn level / 9, so 0 is 0 and\
        \ 9 is 1.  Calls:"
        forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines (forall a b. (a -> b) -> [a] -> [b]
map (Char, DynCall) -> Text
dyn_call_doc (forall k a. Map k a -> [(k, a)]
Map.toAscList Map Char DynCall
dyn_call_map))

dyn_call_doc :: (Char, DynCall) -> Text
dyn_call_doc :: (Char, DynCall) -> Text
dyn_call_doc (Char
name, DynCall
dcall) = Text
"`" forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
name forall a. Semigroup a => a -> a -> a
<> Text
"` - "
    forall a. Semigroup a => a -> a -> a
<> DynCall -> Text
dcall_doc DynCall
dcall

dyn_call_map :: Map Char DynCall
dyn_call_map :: Map Char DynCall
dyn_call_map = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
    [ (Char
'=', DynCall
dc_flat)
    , (Char
'<', DynCall
dc_attack)
    , (Char
'a', DynCall
dc_attack_from)
    , (Char
'>', Double -> Double -> DynCall
dc_decay Double
0.8 Double
0)
    , (Char
'd', Double -> Double -> DynCall
dc_decay Double
0 Double
0.8)
    , (Char
'T', DynCall
dc_set_dyn)
    , (Char
'.', DynCall
dc_move_to)
    ]

newtype DynState = DynState { DynState -> Double
state_from_dyn :: Signal.Y }
    deriving (Int -> DynState -> ShowS
[DynState] -> ShowS
DynState -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DynState] -> ShowS
$cshowList :: [DynState] -> ShowS
show :: DynState -> [Char]
$cshow :: DynState -> [Char]
showsPrec :: Int -> DynState -> ShowS
$cshowsPrec :: Int -> DynState -> ShowS
Show)

instance Pretty DynState where
    format :: DynState -> Doc
format (DynState Double
from_dyn) = Text -> [(Text, Doc)] -> Doc
Pretty.recordTitle Text
"DynState"
        [ (Text
"from_dyn", forall a. Pretty a => a -> Doc
Pretty.format Double
from_dyn)
        ]

dyn_sequence :: ScoreTime -> DynState -> Text -> Derive.Deriver Signal.Control
dyn_sequence :: ScoreTime -> DynState -> Text -> Deriver Control
dyn_sequence ScoreTime
dur DynState
state Text
arg = do
    [Call (DynCall, Char)]
exprs <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right ((Text
"parsing " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
arg forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) forall a b. (a -> b) -> a -> b
$
        [Call Char] -> Either Text [Call (DynCall, Char)]
resolve_dyn_calls forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Either Text [Call Char]
parse_dyn_sequence Text
arg
    let starts :: [ScoreTime]
starts = ScoreTime -> [Double] -> [ScoreTime]
slice_time ScoreTime
dur (forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Call (DynCall, Char)]
exprs) Double
1)
        ranges :: [(ScoreTime, ScoreTime)]
ranges = forall a b. [a] -> [b] -> [(a, b)]
zip [ScoreTime]
starts (forall a. Int -> [a] -> [a]
drop Int
1 [ScoreTime]
starts)
    ([Control]
results, DynState
_) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ScoreTime, ScoreTime), Call (DynCall, Char))
-> M DynState Control
eval_dyn (forall a b. [a] -> [b] -> [(a, b)]
zip [(ScoreTime, ScoreTime)]
ranges [Call (DynCall, Char)]
exprs)) DynState
state
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Control]
results

eval_dyn :: ((ScoreTime, ScoreTime), Call (DynCall, Char))
    -> M DynState Signal.Control
eval_dyn :: ((ScoreTime, ScoreTime), Call (DynCall, Char))
-> M DynState Control
eval_dyn ((ScoreTime
start, ScoreTime
end), (Call (DynCall Text
_ Parser a
sig a -> Context -> M DynState Control
func, Char
name) Text
arg)) = do
    let ctx :: Context
ctx = Context
            { ctx_start :: ScoreTime
ctx_start = ScoreTime
start
            , ctx_end :: ScoreTime
ctx_end = ScoreTime
end
            , ctx_call_name :: CallName
ctx_call_name = Text -> CallName
Derive.CallName forall a b. (a -> b) -> a -> b
$ Char -> Text
Text.singleton Char
name
            }
    a
parsed_arg <- forall (m :: (* -> *) -> * -> *) a.
MonadTrans m =>
CallName -> Text -> Parser a -> m Deriver a
parse_args (Text -> CallName
Derive.CallName (Char -> Text
Text.singleton Char
name)) Text
arg Parser a
sig
    a -> Context -> M DynState Control
func a
parsed_arg Context
ctx

-- ** parse

parse_dyn_sequence :: Text -> Either Text [Call Char]
parse_dyn_sequence :: Text -> Either Text [Call Char]
parse_dyn_sequence = forall a. Parser a -> Text -> Either Text a
ParseText.parse1 Parser [Call Char]
p_dyn_calls

p_dyn_calls :: Parser [Call Char]
p_dyn_calls :: Parser [Call Char]
p_dyn_calls = Parser ()
A.skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 (Parser Text (Call Char)
p_dyn_call forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
A.skipSpace)

p_dyn_call :: Parser (Call Char)
p_dyn_call :: Parser Text (Call Char)
p_dyn_call = do
    Char
c <- Parser Char
A.anyChar
    Text
arg <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Text
"" (Char -> Text
Text.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
A.digit)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall call. call -> Text -> Call call
Call Char
c Text
arg

resolve_dyn_calls :: [Call Char] -> Either Text [Call (DynCall, Char)]
resolve_dyn_calls :: [Call Char] -> Either Text [Call (DynCall, Char)]
resolve_dyn_calls = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a b. (a -> b) -> a -> b
$ \(Call Char
name Text
arg) ->
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
name Map Char DynCall
dyn_call_map of
        Maybe DynCall
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"dyn call not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Char
name
        Just DynCall
call -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall call. call -> Text -> Call call
Call (DynCall
call, Char
name) Text
arg

-- * State

type M s a = State.StateT s Derive.Deriver a

data PitchState = PitchState {
    -- # maintained automatically
    -- | Absolute pitch of the underlying note.  The Steps are relative to
    -- this.
    PitchState -> Transposed
_swaram :: !PSignal.Transposed
    -- | Current pitch value.  Starts as the pitch at the end of the previous
    -- note.
    , PitchState -> Double
_from :: !Step
    -- | Previous swaram.
    , PitchState -> Double
_prev :: !Step
    -- | Next swaram.
    , PitchState -> Double
_next :: !Step

    -- # maintained automatically
    -- | Transition time between pitch movements.
    , PitchState -> Normalized
_transition :: !Typecheck.Normalized
    } deriving (Int -> PitchState -> ShowS
[PitchState] -> ShowS
PitchState -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PitchState] -> ShowS
$cshowList :: [PitchState] -> ShowS
show :: PitchState -> [Char]
$cshow :: PitchState -> [Char]
showsPrec :: Int -> PitchState -> ShowS
$cshowsPrec :: Int -> PitchState -> ShowS
Show)

-- | Relative NoteNumbers.
type Step = Double

instance Pretty PitchState where
    format :: PitchState -> Doc
format (PitchState Transposed
swaram Double
from Double
prev Double
next Normalized
transition) =
        Text -> [(Text, Doc)] -> Doc
Pretty.recordTitle Text
"PitchState"
            [ (Text
"swaram", forall a. Pretty a => a -> Doc
Pretty.format Transposed
swaram)
            , (Text
"from", forall a. Pretty a => a -> Doc
Pretty.format Double
from)
            , (Text
"prev", forall a. Pretty a => a -> Doc
Pretty.format Double
prev)
            , (Text
"next", forall a. Pretty a => a -> Doc
Pretty.format Double
next)
            , (Text
"transition", forall a. Pretty a => a -> Doc
Pretty.format Normalized
transition)
            ]

set_pitch :: PSignal.Transposed -> M PitchState ()
set_pitch :: Transposed -> M PitchState ()
set_pitch Transposed
p = do
    Transposed
swaram <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
    Double
steps <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Transposed -> Transposed -> Deriver State Error Double
step_difference Transposed
p Transposed
swaram
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify forall a b. (a -> b) -> a -> b
$ \PitchState
state -> PitchState
state { _from :: Double
_from = Double
steps }

get_from :: M PitchState PSignal.Transposed
get_from :: M PitchState Transposed
get_from = do
    Double
steps <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Double
_from
    Transposed
swaram <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (forall a. Real a => a -> NoteNumber
Pitch.nn Double
steps) Transposed
swaram

-- * sequence

newtype Result = Result (DList.DList Signal.Control)
    deriving (Int -> Result -> ShowS
[Result] -> ShowS
Result -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> [Char]
$cshow :: Result -> [Char]
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show, NonEmpty Result -> Result
Result -> Result -> Result
forall b. Integral b => b -> Result -> Result
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Result -> Result
$cstimes :: forall b. Integral b => b -> Result -> Result
sconcat :: NonEmpty Result -> Result
$csconcat :: NonEmpty Result -> Result
<> :: Result -> Result -> Result
$c<> :: Result -> Result -> Result
Semigroup, Semigroup Result
Result
[Result] -> Result
Result -> Result -> Result
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Result] -> Result
$cmconcat :: [Result] -> Result
mappend :: Result -> Result -> Result
$cmappend :: Result -> Result -> Result
mempty :: Result
$cmempty :: Result
Monoid)

pitch_sequence :: ScoreTime -> PitchState -> Text -> Derive.Deriver Result
pitch_sequence :: ScoreTime -> PitchState -> Text -> Deriver Result
pitch_sequence ScoreTime
dur PitchState
state Text
arg = do
    [Call (PitchCall, Char)]
calls <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right ((Text
"parsing " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
arg forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) forall a b. (a -> b) -> a -> b
$
        [Call (PitchCall, Char)] -> Either Text [Call (PitchCall, Char)]
resolve_postfix forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ParsedPitch] -> Either Text [Call (PitchCall, Char)]
resolve_pitch_calls forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Either Text [ParsedPitch]
parse_pitch_sequence Text
arg
    let starts :: [ScoreTime]
starts = ScoreTime -> [Double] -> [ScoreTime]
slice_time ScoreTime
dur (forall a. [Call (PitchCall, a)] -> [Double]
call_durations [Call (PitchCall, Char)]
calls)
        ranges :: [(ScoreTime, ScoreTime)]
ranges = forall a b. [a] -> [b] -> [(a, b)]
zip [ScoreTime]
starts (forall a. Int -> [a] -> [a]
drop Int
1 [ScoreTime]
starts)
    ([Result]
results, PitchState
_) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Call ((ScoreTime, ScoreTime), (PitchCall, Char))
-> M PitchState Result
eval_pitch (forall a b. [a] -> [Call b] -> [Call (a, b)]
zip_calls [(ScoreTime, ScoreTime)]
ranges [Call (PitchCall, Char)]
calls))
        PitchState
state
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Result]
results

slice_time :: ScoreTime -> [Double] -> [ScoreTime]
slice_time :: ScoreTime -> [Double] -> [ScoreTime]
slice_time ScoreTime
dur [Double]
slices =
    forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) ScoreTime
0 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
*ScoreTime
one) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> ScoreTime
ScoreTime.from_double) [Double]
slices
    where one :: ScoreTime
one = ScoreTime
dur forall a. Fractional a => a -> a -> a
/ Double -> ScoreTime
ScoreTime.from_double (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [Double]
slices)

eval_pitch :: Call ((ScoreTime, ScoreTime), (PitchCall, Char))
    -> M PitchState Result
eval_pitch :: Call ((ScoreTime, ScoreTime), (PitchCall, Char))
-> M PitchState Result
eval_pitch (Call ((ScoreTime
start, ScoreTime
end), (PitchCall
pcall, Char
name)) Text
arg_) = case PitchCall -> PCall
pcall_call PitchCall
pcall of
    PCall Parser a
signature a -> Context -> M PitchState Control
func -> do
        a
parsed_arg <- forall (m :: (* -> *) -> * -> *) a.
MonadTrans m =>
CallName -> Text -> Parser a -> m Deriver a
parse_args (Context -> CallName
ctx_call_name Context
ctx) (PitchCall -> Char -> Text -> Text
pcall_arg PitchCall
pcall Char
name Text
arg_)
            Parser a
signature
        (DList Control -> Result
Result forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> DList a
DList.singleton) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Context -> M PitchState Control
func a
parsed_arg Context
ctx
    where
    ctx :: Context
ctx = Context
        { ctx_start :: ScoreTime
ctx_start = ScoreTime
start
        , ctx_end :: ScoreTime
ctx_end = ScoreTime
end
        , ctx_call_name :: CallName
ctx_call_name = Text -> CallName
Derive.CallName forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
Text.cons Char
name Text
arg_
        }

data Call call = Call !call !Text
    deriving (Call call -> Call call -> Bool
forall call. Eq call => Call call -> Call call -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Call call -> Call call -> Bool
$c/= :: forall call. Eq call => Call call -> Call call -> Bool
== :: Call call -> Call call -> Bool
$c== :: forall call. Eq call => Call call -> Call call -> Bool
Eq, Int -> Call call -> ShowS
forall call. Show call => Int -> Call call -> ShowS
forall call. Show call => [Call call] -> ShowS
forall call. Show call => Call call -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Call call] -> ShowS
$cshowList :: forall call. Show call => [Call call] -> ShowS
show :: Call call -> [Char]
$cshow :: forall call. Show call => Call call -> [Char]
showsPrec :: Int -> Call call -> ShowS
$cshowsPrec :: forall call. Show call => Int -> Call call -> ShowS
Show, forall a b. a -> Call b -> Call a
forall a b. (a -> b) -> Call a -> Call b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Call b -> Call a
$c<$ :: forall a b. a -> Call b -> Call a
fmap :: forall a b. (a -> b) -> Call a -> Call b
$cfmap :: forall a b. (a -> b) -> Call a -> Call b
Functor)

call_durations :: [Call (PitchCall, a)] -> [Double]
call_durations :: forall a. [Call (PitchCall, a)] -> [Double]
call_durations = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ PitchCall -> Double
pcall_duration forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Call (PitchCall
pcall, a
_) Text
_) -> PitchCall
pcall)

zip_calls :: [a] -> [Call b] -> [Call (a, b)]
zip_calls :: forall a b. [a] -> [Call b] -> [Call (a, b)]
zip_calls [a]
xs [Call b]
calls = [forall call. call -> Text -> Call call
Call (a
x, b
c) Text
arg | (a
x, Call b
c Text
arg) <- forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [Call b]
calls]

parse_pitch_sequence :: Text -> Either Text [ParsedPitch]
parse_pitch_sequence :: Text -> Either Text [ParsedPitch]
parse_pitch_sequence = forall a. Parser a -> Text -> Either Text a
ParseText.parse1 Parser [ParsedPitch]
p_exprs

resolve_pitch_calls :: [ParsedPitch] -> Either Text [Call (PitchCall, Char)]
resolve_pitch_calls :: [ParsedPitch] -> Either Text [Call (PitchCall, Char)]
resolve_pitch_calls = forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM ParsedPitch -> Either Text [Call (PitchCall, Char)]
resolve
    where
    resolve :: ParsedPitch -> Either Text [Call (PitchCall, Char)]
resolve (PitchGroup [ParsedPitch]
calls) =
        forall a b. (a -> b) -> [a] -> [b]
map (forall a.
(Double -> Double) -> Call (PitchCall, a) -> Call (PitchCall, a)
modify_duration (forall a. Num a => a -> a -> a
* (Double
1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ParsedPitch]
calls)))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM ParsedPitch -> Either Text [Call (PitchCall, Char)]
resolve [ParsedPitch]
calls
    resolve (CallArg Char
name Text
arg) = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
name Map Char [PitchCall]
pitch_call_map of
        Maybe [PitchCall]
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"pitch call not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Char
name
        -- Apply the same argument to all of them.  But I should only get
        -- multiple PitchExprs for aliases, which expect no argument.
        Just [PitchCall]
calls -> forall a b. b -> Either a b
Right [forall call. call -> Text -> Call call
Call (PitchCall
c, Char
name) Text
arg | PitchCall
c <- [PitchCall]
calls]

resolve_postfix :: [Call (PitchCall, Char)]
    -> Either Text [Call (PitchCall, Char)]
resolve_postfix :: [Call (PitchCall, Char)] -> Either Text [Call (PitchCall, Char)]
resolve_postfix = forall {a}.
IsString a =>
[Call (PitchCall, Char)] -> Either a [Call (PitchCall, Char)]
resolve forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall {t :: * -> *} {a}.
Foldable t =>
t (Call (a, Char)) -> Either Text (t (Call (a, Char)))
ensure_no_args
    where
    resolve :: [Call (PitchCall, Char)] -> Either a [Call (PitchCall, Char)]
resolve [] = forall a b. b -> Either a b
Right []
    resolve (Call (PitchCall, Char)
call : [Call (PitchCall, Char)]
calls)
        | forall a. Maybe a -> Bool
Maybe.isJust (forall {a}. Call (a, Char) -> Maybe (Double -> Double)
is_postfix Call (PitchCall, Char)
call) =
            forall a b. a -> Either a b
Left a
"postfix call with no preceding call"
        | Bool
otherwise = (forall a.
(Double -> Double) -> Call (PitchCall, a) -> Call (PitchCall, a)
modify_duration Double -> Double
modify Call (PitchCall, Char)
call :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Call (PitchCall, Char)] -> Either a [Call (PitchCall, Char)]
resolve [Call (PitchCall, Char)]
post
        where
        ([Double -> Double]
pre, [Call (PitchCall, Char)]
post) = forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Lists.spanWhile forall {a}. Call (a, Char) -> Maybe (Double -> Double)
is_postfix [Call (PitchCall, Char)]
calls
        modify :: Double -> Double
modify Double
dur = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)) Double
dur [Double -> Double]
pre
    -- The parser shouldn't look for args, but let's check anyway.
    ensure_no_args :: t (Call (a, Char)) -> Either Text (t (Call (a, Char)))
ensure_no_args t (Call (a, Char))
calls
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs = forall a b. b -> Either a b
Right t (Call (a, Char))
calls
        | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
            Text
"postfix calls can't have args: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
errs
        where errs :: [Text]
errs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Call (a, Char) -> [Text]
has_arg t (Call (a, Char))
calls
    has_arg :: Call (a, Char) -> [Text]
has_arg call :: Call (a, Char)
call@(Call (a, Char)
_ Text
arg)
        | forall a. Maybe a -> Bool
Maybe.isJust (forall {a}. Call (a, Char) -> Maybe (Double -> Double)
is_postfix Call (a, Char)
call) Bool -> Bool -> Bool
&& Text
arg forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty = [Text
arg]
        | Bool
otherwise = []
    is_postfix :: Call (a, Char) -> Maybe (Double -> Double)
is_postfix (Call (a
_, Char
name) Text
_) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
name Map Char (Double -> Double)
postfix_calls

postfix_calls :: Map Char (Double -> Double)
postfix_calls :: Map Char (Double -> Double)
postfix_calls = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Char
'_', (forall a. Num a => a -> a -> a
+Double
1)), (Char
'.', (forall a. Fractional a => a -> a -> a
/Double
2))]

postfix_doc :: Text
postfix_doc :: Text
postfix_doc = Text
"Postfix call that modifies the duration of the previous call."
    forall a. Semigroup a => a -> a -> a
<> Text
" `_` adds 1 to it, `.` divides by 2."

modify_duration :: (Double -> Double) -> Call (PitchCall, a)
    -> Call (PitchCall, a)
modify_duration :: forall a.
(Double -> Double) -> Call (PitchCall, a) -> Call (PitchCall, a)
modify_duration Double -> Double
modify = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ \PitchCall
call ->
    if PitchCall -> Double
pcall_duration PitchCall
call forall a. Ord a => a -> a -> Bool
> Double
0
        then PitchCall
call { pcall_duration :: Double
pcall_duration = Double -> Double
modify (PitchCall -> Double
pcall_duration PitchCall
call) }
        else PitchCall
call

-- * DynCall

data DynCall = forall a. DynCall {
    DynCall -> Text
dcall_doc :: Text
    , ()
_dcall_signature :: Sig.Parser a
    , ()
_dcall_func :: a -> Context -> M DynState Signal.Control
    }

dc_flat :: DynCall
dc_flat :: DynCall
dc_flat = forall a.
Text -> Parser a -> (a -> Context -> M DynState Control) -> DynCall
DynCall Text
"No movement." Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$ \() Context
ctx -> do
    Double
prev <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets DynState -> Double
state_from_dyn
    RealTime
start <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Time a => a -> Deriver RealTime
Derive.real (Context -> ScoreTime
ctx_start Context
ctx)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). RealTime -> Double -> Signal kind
Signal.from_sample RealTime
start Double
prev

dc_attack :: DynCall
dc_attack :: DynCall
dc_attack = forall a.
Text -> Parser a -> (a -> Context -> M DynState Control) -> DynCall
DynCall Text
doc Parser (Maybe Double)
dyn_arg forall a b. (a -> b) -> a -> b
$ \Maybe Double
maybe_to Context
ctx ->
    Curve -> Double -> Double -> Context -> M DynState Control
make_dyn_curve (Double -> Double -> Curve
dyn_curve Double
0 Double
0.8) Double
0 (forall a. a -> Maybe a -> a
fromMaybe Double
1 Maybe Double
maybe_to) Context
ctx
    where doc :: Text
doc = Text
"Attack from 0."

dc_attack_from :: DynCall
dc_attack_from :: DynCall
dc_attack_from = forall a.
Text -> Parser a -> (a -> Context -> M DynState Control) -> DynCall
DynCall Text
doc Parser (Maybe Double)
dyn_arg forall a b. (a -> b) -> a -> b
$ \Maybe Double
maybe_to Context
ctx -> do
    Double
from <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets DynState -> Double
state_from_dyn
    Curve -> Double -> Double -> Context -> M DynState Control
make_dyn_curve (Double -> Double -> Curve
dyn_curve Double
0 Double
0.8) Double
from (forall a. a -> Maybe a -> a
fromMaybe Double
1 Maybe Double
maybe_to) Context
ctx
    where doc :: Text
doc = Text
"Attack from previous value."

dc_decay :: Double -> Double -> DynCall
dc_decay :: Double -> Double -> DynCall
dc_decay Double
w1 Double
w2 = forall a.
Text -> Parser a -> (a -> Context -> M DynState Control) -> DynCall
DynCall Text
doc Parser (Maybe Double)
dyn_arg forall a b. (a -> b) -> a -> b
$ \Maybe Double
maybe_to Context
ctx -> do
    Double
from <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets DynState -> Double
state_from_dyn
    Curve -> Double -> Double -> Context -> M DynState Control
make_dyn_curve (Double -> Double -> Curve
dyn_curve Double
w1 Double
w2) Double
from (forall a. a -> Maybe a -> a
fromMaybe Double
0 Maybe Double
maybe_to) Context
ctx
    where doc :: Text
doc = Text
"Decay to 0, with curve weights: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Double
w1, Double
w2)

dc_move_to :: DynCall
dc_move_to :: DynCall
dc_move_to = forall a.
Text -> Parser a -> (a -> Context -> M DynState Control) -> DynCall
DynCall Text
"Move to dyn." Parser Double
required_dyn_arg forall a b. (a -> b) -> a -> b
$ \Double
to Context
ctx -> do
    Double
from <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets DynState -> Double
state_from_dyn
    Curve -> Double -> Double -> Context -> M DynState Control
make_dyn_curve (Double -> Double -> Curve
dyn_curve Double
0.5 Double
0.5) Double
from Double
to Context
ctx

make_dyn_curve :: ControlUtil.Curve -> Signal.Y -> Signal.Y -> Context
    -> M DynState Signal.Control
make_dyn_curve :: Curve -> Double -> Double -> Context -> M DynState Control
make_dyn_curve Curve
curve Double
from Double
to Context
ctx = do
    (RealTime
start, RealTime
end) <- forall s. Context -> M s (RealTime, RealTime)
ctx_range Context
ctx
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify forall a b. (a -> b) -> a -> b
$ \DynState
state -> DynState
state { state_from_dyn :: Double
state_from_dyn = Double
to }
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Curve
-> RealTime -> Double -> RealTime -> Double -> Deriver Control
ControlUtil.make_segment Curve
curve RealTime
start Double
from RealTime
end Double
to

dyn_curve :: Double -> Double -> ControlUtil.Curve
dyn_curve :: Double -> Double -> Curve
dyn_curve Double
w1 Double
w2 = (Double -> Double) -> Curve
ControlUtil.Function forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Double
ControlUtil.sigmoid Double
w1 Double
w2

dc_set_dyn :: DynCall
dc_set_dyn :: DynCall
dc_set_dyn = forall a.
Text -> Parser a -> (a -> Context -> M DynState Control) -> DynCall
DynCall Text
"Set from dyn." Parser Double
required_dyn_arg forall a b. (a -> b) -> a -> b
$ \Double
to Context
_ctx -> do
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify forall a b. (a -> b) -> a -> b
$ \DynState
state -> DynState
state { state_from_dyn :: Double
state_from_dyn = Double
to }
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

dyn_arg :: Sig.Parser (Maybe Signal.Y)
dyn_arg :: Parser (Maybe Double)
dyn_arg = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Double
arg_to_dyn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"move" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
    Doc
"Move to n/9."

required_dyn_arg :: Sig.Parser Signal.Y
required_dyn_arg :: Parser Double
required_dyn_arg = Int -> Double
arg_to_dyn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"move" Doc
"Move to n/9."

arg_to_dyn :: Int -> Signal.Y
arg_to_dyn :: Int -> Double
arg_to_dyn = (forall a. Fractional a => a -> a -> a
/Double
9) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- * PitchCall

data PitchCall = PitchCall {
    PitchCall -> Text
pcall_doc :: !Text
    , PitchCall -> Double
pcall_duration :: !Double
    -- | If True, cons the call's name on to the arg before parsing it.
    , PitchCall -> Bool
pcall_parse_call_name :: !Bool
    , PitchCall -> PCall
pcall_call :: !PCall
    }

-- | Argument parser and call function.
data PCall = forall a. PCall
    (Sig.Parser a) (a -> Context -> M PitchState Signal.Control)

pcall_arg :: PitchCall -> Char -> Text -> Text
pcall_arg :: PitchCall -> Char -> Text -> Text
pcall_arg PitchCall
pcall Char
name Text
arg
    | PitchCall -> Bool
pcall_parse_call_name PitchCall
pcall = Char -> Text -> Text
Text.cons Char
name Text
arg
    | Bool
otherwise = Text
arg

resolve_aliases :: Map Char (Either (Double, [Text]) PitchCall)
    -> Either Text (Map Char [PitchCall])
resolve_aliases :: Map Char (Either (Double, [Text]) PitchCall)
-> Either Text (Map Char [PitchCall])
resolve_aliases Map Char (Either (Double, [Text]) PitchCall)
call_map = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}.
(a, Either (Double, [Text]) PitchCall)
-> Either Text (a, [PitchCall])
resolve (forall k a. Map k a -> [(k, a)]
Map.toList Map Char (Either (Double, [Text]) PitchCall)
call_map)
    where
    resolve :: (a, Either (Double, [Text]) PitchCall)
-> Either Text (a, [PitchCall])
resolve (a
name, Right PitchCall
call) = forall a b. b -> Either a b
Right (a
name, [PitchCall
call])
    resolve (a
name, Left (Double
duration, [Text]
calls)) =
        (,) a
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Double -> PitchCall -> PitchCall
set_dur Double
duration) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Either Text PitchCall
resolve1 [Text]
calls
    set_dur :: Double -> PitchCall -> PitchCall
set_dur Double
dur PitchCall
pcall = PitchCall
pcall { pcall_duration :: Double
pcall_duration = Double
dur }
    resolve1 :: Text -> Either Text PitchCall
resolve1 Text
to = do
        (Char
c, Text
arg) <- forall err a. err -> Maybe a -> Either err a
justErr Text
"empty alias" forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
Text.uncons Text
to
        Either (Double, [Text]) PitchCall
call <- forall err a. err -> Maybe a -> Either err a
justErr (Text
"not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Char
c) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
c Map Char (Either (Double, [Text]) PitchCall)
call_map
        PitchCall
call <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"alias to alias: "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
showt) Either (Double, [Text]) PitchCall
call
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PitchCall -> Char -> Text -> PitchCall
apply_arg PitchCall
call Char
c Text
arg

apply_arg :: PitchCall -> Char -> Text -> PitchCall
apply_arg :: PitchCall -> Char -> Text -> PitchCall
apply_arg PitchCall
call Char
name Text
arg = PitchCall
call
    { pcall_call :: PCall
pcall_call = case PitchCall -> PCall
pcall_call PitchCall
call of
        PCall Parser a
signature a -> Context -> M PitchState Control
func -> forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser Val
ignore forall a b. (a -> b) -> a -> b
$ \Val
_ Context
ctx -> do
            a
parsed <- forall (m :: (* -> *) -> * -> *) a.
MonadTrans m =>
CallName -> Text -> Parser a -> m Deriver a
parse_args (Context -> CallName
ctx_call_name Context
ctx) (PitchCall -> Char -> Text -> Text
pcall_arg PitchCall
call Char
name Text
arg)
                Parser a
signature
            a -> Context -> M PitchState Control
func a
parsed Context
ctx
    }
    where
    -- Accept anything for an argument but ignore it.  This is because
    -- I've already hardcoded the argument, but 'eval_pitch' will want to apply
    -- it anyway, since it can't tell the difference from an alias call and
    -- a normal call.
    ignore :: Sig.Parser DeriveT.Val
    ignore :: Parser Val
ignore = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"ignore" (Double -> Val
DeriveT.num Double
0) Doc
""

-- ** PitchCall implementation

parse_args :: State.MonadTrans m => Derive.CallName -> Text -> Sig.Parser a
    -> m Derive.Deriver a
parse_args :: forall (m :: (* -> *) -> * -> *) a.
MonadTrans m =>
CallName -> Text -> Parser a -> m Deriver a
parse_args CallName
name Text
arg Parser a
sig = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
    [Val]
vals <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right ((Text
"parsing " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty CallName
name forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) forall a b. (a -> b) -> a -> b
$
        if Text -> Bool
Text.null Text
arg then forall (m :: * -> *) a. Monad m => a -> m a
return [] else (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Val
Parse.parse_val Text
arg
    forall a. Either Error a -> Deriver a
Sig.require_right
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
Parser a
-> Context Tagged -> CallName -> [Val] -> Deriver (Either Error a)
Sig.parse_vals Parser a
sig (forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
0 ScoreTime
1 (forall a. Pretty a => a -> Text
pretty CallName
name))
            CallName
name [Val]
vals

-- | Here I am reinventing Derive.Call yet again.  This is the equivalent of
-- 'Derive.Context' and 'Derive.PassedArgs'.
data Context = Context {
    Context -> ScoreTime
ctx_start :: !ScoreTime
    , Context -> ScoreTime
ctx_end :: !ScoreTime
    -- | Complete call name, first char consed to arg.
    , Context -> CallName
ctx_call_name :: !Derive.CallName
    } deriving (Int -> Context -> ShowS
[Context] -> ShowS
Context -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Context] -> ShowS
$cshowList :: [Context] -> ShowS
show :: Context -> [Char]
$cshow :: Context -> [Char]
showsPrec :: Int -> Context -> ShowS
$cshowsPrec :: Int -> Context -> ShowS
Show)

ctx_range :: Context -> M s (RealTime, RealTime)
ctx_range :: forall s. Context -> M s (RealTime, RealTime)
ctx_range Context
ctx = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
    (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Time a => a -> Deriver RealTime
Derive.real (Context -> ScoreTime
ctx_start Context
ctx) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Time a => a -> Deriver RealTime
Derive.real (Context -> ScoreTime
ctx_end Context
ctx)

pc_flat :: PCall
pc_flat :: PCall
pc_flat = forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$ \() Context
ctx -> do
    Double
step <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Double
_from
    RealTime
start <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ Context -> ScoreTime
ctx_start Context
ctx
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). RealTime -> Double -> Signal kind
Signal.from_sample RealTime
start Double
step

-- | Move relative to the note's swaram.
pc_relative :: PCall
pc_relative :: PCall
pc_relative = forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"to" Doc
"To pitch.") forall a b. (a -> b) -> a -> b
$
    \(Typecheck.DefaultDiatonic Transpose
transpose) Context
ctx -> do
        Transposed
from <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
        Context -> Transposed -> M PitchState Control
move_to Context
ctx (forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Transpose
transpose Transposed
from)

-- | Move relative to the current pitch.
pc_relative_move :: Pitch.Transpose -> PCall
pc_relative_move :: Transpose -> PCall
pc_relative_move Transpose
transpose = forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$ \() Context
ctx -> do
    Transposed
from_pitch <- M PitchState Transposed
get_from
    Context -> Transposed -> M PitchState Control
move_to Context
ctx (forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Transpose
transpose Transposed
from_pitch)

data PitchDirection = Previous | Current | Next deriving (Int -> PitchDirection -> ShowS
[PitchDirection] -> ShowS
PitchDirection -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PitchDirection] -> ShowS
$cshowList :: [PitchDirection] -> ShowS
show :: PitchDirection -> [Char]
$cshow :: PitchDirection -> [Char]
showsPrec :: Int -> PitchDirection -> ShowS
$cshowsPrec :: Int -> PitchDirection -> ShowS
Show, PitchDirection -> PitchDirection -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PitchDirection -> PitchDirection -> Bool
$c/= :: PitchDirection -> PitchDirection -> Bool
== :: PitchDirection -> PitchDirection -> Bool
$c== :: PitchDirection -> PitchDirection -> Bool
Eq)
instance Pretty PitchDirection where pretty :: PitchDirection -> Text
pretty = forall a. Show a => a -> Text
showt

pc_move_direction :: PitchDirection -> PCall
pc_move_direction :: PitchDirection -> PCall
pc_move_direction PitchDirection
dir = forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$ \() Context
ctx ->
    Context -> Transposed -> M PitchState Control
move_to Context
ctx forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PitchDirection -> M PitchState Transposed
get_direction_pitch PitchDirection
dir

pc_set_pitch_from :: PitchDirection -> PCall
pc_set_pitch_from :: PitchDirection -> PCall
pc_set_pitch_from PitchDirection
dir = forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$ \() Context
_ctx -> do
    Transposed -> M PitchState ()
set_pitch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PitchDirection -> M PitchState Transposed
get_direction_pitch PitchDirection
dir
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

get_direction_pitch :: PitchDirection -> M PitchState PSignal.Transposed
get_direction_pitch :: PitchDirection -> M PitchState Transposed
get_direction_pitch PitchDirection
dir = case PitchDirection
dir of
    PitchDirection
Previous -> forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Real a => a -> NoteNumber
Pitch.nn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Double
_prev)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
    PitchDirection
Current -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
    PitchDirection
Next -> forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Real a => a -> NoteNumber
Pitch.nn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Double
_next)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram

pc_set_pitch :: PCall
pc_set_pitch :: PCall
pc_set_pitch = forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"to" Doc
"To pitch.") forall a b. (a -> b) -> a -> b
$
    \Either Transpose Str
arg Context
_ctx -> do
        Transpose
transpose <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Either Transpose Str -> Deriver Transpose
parse_transpose Either Transpose Str
arg
        Transposed -> M PitchState ()
set_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Transpose
transpose forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

parse_transpose :: Either Pitch.Transpose Expr.Str
    -> Derive.Deriver Pitch.Transpose
parse_transpose :: Either Transpose Str -> Deriver Transpose
parse_transpose (Left Transpose
t) = forall (m :: * -> *) a. Monad m => a -> m a
return Transpose
t
parse_transpose (Right (Expr.Str Text
sym)) = case Text -> [Char]
untxt Text
sym of
    [Char
c] | Char
'a' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double -> Transpose
Pitch.Diatonic forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$
        forall a. Enum a => a -> Int
fromEnum Char
'a' forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum Char
c forall a. Num a => a -> a -> a
- Int
1
    [Char]
_ -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"expected a lowercase letter: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
sym

data TransitionTime = Slow | Medium | Fast deriving (Int -> TransitionTime -> ShowS
[TransitionTime] -> ShowS
TransitionTime -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TransitionTime] -> ShowS
$cshowList :: [TransitionTime] -> ShowS
show :: TransitionTime -> [Char]
$cshow :: TransitionTime -> [Char]
showsPrec :: Int -> TransitionTime -> ShowS
$cshowsPrec :: Int -> TransitionTime -> ShowS
Show, TransitionTime -> TransitionTime -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransitionTime -> TransitionTime -> Bool
$c/= :: TransitionTime -> TransitionTime -> Bool
== :: TransitionTime -> TransitionTime -> Bool
$c== :: TransitionTime -> TransitionTime -> Bool
Eq)

pc_set_transition_time :: TransitionTime -> PCall
pc_set_transition_time :: TransitionTime -> PCall
pc_set_transition_time TransitionTime
time = forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$ \() Context
_ctx -> do
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify forall a b. (a -> b) -> a -> b
$ \PitchState
state -> PitchState
state { _transition :: Normalized
_transition = Normalized
ttime }
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
    where
    -- TODO these could come from an environ value
    ttime :: Normalized
ttime = Double -> Normalized
Typecheck.Normalized forall a b. (a -> b) -> a -> b
$ case TransitionTime
time of
        TransitionTime
Fast -> Double
0.1
        TransitionTime
Medium -> Double
0.5
        TransitionTime
Slow -> Double
0.9

-- ** util

move_to :: Context -> PSignal.Transposed -> M PitchState Signal.Control
move_to :: Context -> Transposed -> M PitchState Control
move_to Context
ctx Transposed
to = do
    (RealTime
start, RealTime
end) <- forall s. Context -> M s (RealTime, RealTime)
ctx_range Context
ctx
    Transposed
from <- M PitchState Transposed
get_from
    RealTime
-> Transposed -> RealTime -> Transposed -> M PitchState Control
move_pitch RealTime
start Transposed
from RealTime
end Transposed
to

move_pitch :: RealTime -> PSignal.Transposed -> RealTime -> PSignal.Transposed
    -> M PitchState Signal.Control
move_pitch :: RealTime
-> Transposed -> RealTime -> Transposed -> M PitchState Control
move_pitch RealTime
start Transposed
from RealTime
end Transposed
to = do
    Typecheck.Normalized Double
transition <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Normalized
_transition
    let curve :: Curve
curve = (Double -> Double) -> Curve
ControlUtil.Function forall a b. (a -> b) -> a -> b
$
            Double -> Double -> Double -> Double
ControlUtil.sigmoid (Double
1forall a. Num a => a -> a -> a
-Double
transition) (Double
1forall a. Num a => a -> a -> a
-Double
transition)
    Transposed -> M PitchState ()
set_pitch Transposed
to
    Transposed
swaram <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
    Double
from <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Transposed -> Transposed -> Deriver State Error Double
step_difference Transposed
from Transposed
swaram
    Double
to <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Transposed -> Transposed -> Deriver State Error Double
step_difference Transposed
to Transposed
swaram
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Curve
-> RealTime -> Double -> RealTime -> Double -> Deriver Control
ControlUtil.make_segment Curve
curve RealTime
start Double
from RealTime
end Double
to

-- * parser

data ParsedPitch = CallArg !Char !Text | PitchGroup ![ParsedPitch]
    deriving (Int -> ParsedPitch -> ShowS
[ParsedPitch] -> ShowS
ParsedPitch -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ParsedPitch] -> ShowS
$cshowList :: [ParsedPitch] -> ShowS
show :: ParsedPitch -> [Char]
$cshow :: ParsedPitch -> [Char]
showsPrec :: Int -> ParsedPitch -> ShowS
$cshowsPrec :: Int -> ParsedPitch -> ShowS
Show, ParsedPitch -> ParsedPitch -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParsedPitch -> ParsedPitch -> Bool
$c/= :: ParsedPitch -> ParsedPitch -> Bool
== :: ParsedPitch -> ParsedPitch -> Bool
$c== :: ParsedPitch -> ParsedPitch -> Bool
Eq)

type Parser a = A.Parser a

p_exprs :: Parser [ParsedPitch]
p_exprs :: Parser [ParsedPitch]
p_exprs = Parser ()
A.skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 (Parser Text ParsedPitch
p_expr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
A.skipSpace)

p_expr :: Parser ParsedPitch
p_expr :: Parser Text ParsedPitch
p_expr = Parser Text ParsedPitch
p_group forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text ParsedPitch
p_pitch_expr

p_pitch_expr :: Parser ParsedPitch
p_pitch_expr :: Parser Text ParsedPitch
p_pitch_expr = do
    Char
c <- (Char -> Bool) -> Parser Char
A.satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/=Char
' ' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'[' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
']'
    if Char -> Bool
pitch_has_argument Char
c
        then Char -> Text -> ParsedPitch
CallArg Char
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
p_pitch_expr_arg
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Char -> Text -> ParsedPitch
CallArg Char
c Text
""

p_group :: Parser ParsedPitch
p_group :: Parser Text ParsedPitch
p_group = [ParsedPitch] -> ParsedPitch
PitchGroup forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
A.char Char
'[' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser [ParsedPitch]
p_exprs forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
']')

p_pitch_expr_arg :: Parser Text
p_pitch_expr_arg :: Parser Text Text
p_pitch_expr_arg = do
    Bool
minus <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Bool
False (Char -> Parser Char
A.char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
    Char
c <- (Char -> Bool) -> Parser Char
A.satisfy (forall a. Eq a => a -> a -> Bool
/=Char
' ')
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (if Bool
minus then (Text
"-"<>) else forall a. a -> a
id) (Char -> Text
Text.singleton Char
c)

pitch_has_argument :: Char -> Bool
pitch_has_argument :: Char -> Bool
pitch_has_argument Char
c = Char -> Bool
Char.isUpper Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-'



-- * misc

c_sahitya :: Derive.Taggable a => Derive.Transformer a
c_sahitya :: forall a. Taggable a => Transformer a
c_sahitya = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"sahitya" forall a. Monoid a => a
mempty
    Doc
"Ignore the transformed deriver. Put this on a track to ignore its\
    \ contents, and put in sahitya."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs a
_args Deriver (Stream a)
_deriver -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty