-- 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.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 Util.Seq as Seq

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" Module -> Module -> Module
forall a. Semigroup a => a -> a -> a
<> Module
"gamakam5"

library :: Library.Library
library :: Library
library = [Library] -> Library
forall a. Monoid a => [a] -> a
mconcat
    [ [(Symbol, Generator Control)] -> Library
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)
        ]
    , [(Symbol, Transformer Control)] -> Library
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)
        ]
    , [(Symbol, Transformer Note)] -> Library
forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"sahitya", Transformer Note
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 = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF Control)
-> Transformer Control
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"gamak" Tags
forall a. Monoid a => a
mempty
    Doc
"Import calls for a gamakam track."
    (WithArgDoc (TransformerF Control) -> Transformer Control)
-> WithArgDoc (TransformerF Control) -> Transformer Control
forall a b. (a -> b) -> a -> b
$ TransformerF Control -> WithArgDoc (TransformerF Control)
forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t (TransformerF Control -> WithArgDoc (TransformerF Control))
-> TransformerF Control -> WithArgDoc (TransformerF Control)
forall a b. (a -> b) -> a -> b
$ \PassedArgs Control
_args -> Bool
-> Module -> Deriver (Stream Control) -> Deriver (Stream Control)
forall a. Bool -> Module -> Deriver a -> Deriver a
Derive.with_imported Bool
False (Module
module_ Module -> 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 = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF Control)
-> Transformer Control
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"dyn" Tags
forall a. Monoid a => a
mempty
    Doc
"Import calls for a dyn track."
    (WithArgDoc (TransformerF Control) -> Transformer Control)
-> WithArgDoc (TransformerF Control) -> Transformer Control
forall a b. (a -> b) -> a -> b
$ TransformerF Control -> WithArgDoc (TransformerF Control)
forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t (TransformerF Control -> WithArgDoc (TransformerF Control))
-> TransformerF Control -> WithArgDoc (TransformerF Control)
forall a b. (a -> b) -> a -> b
$ \PassedArgs Control
_args -> Bool
-> Module -> Deriver (Stream Control) -> Deriver (Stream Control)
forall a. Bool -> Module -> Deriver a -> Deriver a
Derive.with_imported Bool
False (Module
module_ Module -> 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 = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Control -> Deriver Control)
-> Generator Control
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 (Module
module_ Module -> Module -> Module
forall a. Semigroup a => a -> a -> a
<> Module
"pitch")
    CallName
"sequence" Tags
forall a. Monoid a => a
mempty Doc
pitch_sequence_doc
    (WithArgDoc (PassedArgs Control -> Deriver Control)
 -> Generator Control)
-> WithArgDoc (PassedArgs Control -> Deriver Control)
-> Generator Control
forall a b. (a -> b) -> a -> b
$ Parser (Text, Normalized, Bool)
-> ((Text, Normalized, Bool)
    -> PassedArgs Control -> Deriver Control)
-> WithArgDoc (PassedArgs Control -> Deriver Control)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,)
        (Text -> Normalized -> Bool -> (Text, Normalized, Bool))
-> Parser Text
-> Parser (Normalized -> Bool -> (Text, Normalized, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Doc -> Parser Text
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"sequence" Doc
"Pitch calls."
        Parser (Normalized -> Bool -> (Text, Normalized, Bool))
-> Parser Normalized -> Parser (Bool -> (Text, Normalized, Bool))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Normalized
transition_env
        Parser (Bool -> (Text, Normalized, Bool))
-> Parser Bool -> Parser (Text, Normalized, Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> Bool -> Doc -> Parser Bool
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"gamakam-above" EnvironDefault
Sig.Unprefixed Bool
False
            Doc
"Expect pitch and gamakam tracks above the note track."
    ) (((Text, Normalized, Bool)
  -> PassedArgs Control -> Deriver Control)
 -> WithArgDoc (PassedArgs Control -> Deriver Control))
-> ((Text, Normalized, Bool)
    -> PassedArgs Control -> Deriver Control)
-> WithArgDoc (PassedArgs Control -> Deriver Control)
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 (PassedArgs Control -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Control
args,) (ScoreTime -> (ScoreTime, ScoreTime))
-> Deriver State Error ScoreTime
-> Deriver State Error (ScoreTime, ScoreTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassedArgs Control -> Deriver State Error ScoreTime
forall a. PassedArgs a -> Deriver State Error ScoreTime
infer_end PassedArgs Control
args
            else PassedArgs Control -> Deriver State Error (ScoreTime, ScoreTime)
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 -> Control -> Deriver Control
forall (m :: * -> *) a. Monad m => a -> m a
return Control
forall a. Monoid a => a
mempty
            Just PitchState
state -> do
                Result DList Control
signals <- ScoreTime -> Deriver Result -> Deriver Result
forall a. ScoreTime -> Deriver a -> Deriver a
Derive.at ScoreTime
start (Deriver Result -> Deriver Result)
-> Deriver Result -> Deriver Result
forall a b. (a -> b) -> a -> b
$
                    ScoreTime -> PitchState -> Text -> Deriver Result
pitch_sequence (ScoreTime
end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
start) PitchState
state Text
text
                RealTime
real_end <- ScoreTime -> Deriver RealTime
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 = Bool -> (ScoreTime -> Bool) -> Maybe ScoreTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
                        ((ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
<=ScoreTime
end) (ScoreTime -> Bool)
-> (ScoreTime -> ScoreTime) -> ScoreTime -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
subtract ScoreTime
ScoreTime.eta) (PassedArgs Control -> Maybe ScoreTime
forall a. PassedArgs a -> Maybe ScoreTime
next_event PassedArgs Control
args)
                Control -> Deriver Control
forall (m :: * -> *) a. Monad m => a -> m a
return (Control -> Deriver Control) -> Control -> Deriver Control
forall a b. (a -> b) -> a -> b
$ [Control] -> Control
forall a. Monoid a => [a] -> a
mconcat (DList Control -> [Control]
forall a. DList a -> [a]
DList.toList DList Control
signals)
                    Control -> Control -> Control
forall a. Semigroup a => a -> a -> a
<> if Bool
next_gamakam then Control
forall a. Monoid a => a
mempty
                        else RealTime -> Double -> Control
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 =
        ArgName -> EnvironDefault -> Normalized -> Doc -> Parser Normalized
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"transition" EnvironDefault
Sig.Both (Double -> Normalized
Typecheck.Normalized Double
0.5) (Doc -> Parser Normalized) -> Doc -> Parser Normalized
forall a b. (a -> b) -> a -> b
$
            Doc
"Time for each pitch movement, in proportion of the total time"
            Doc -> Doc -> Doc
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 = (Event -> ScoreTime) -> Maybe Event -> Maybe ScoreTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> ScoreTime
Event.start (Maybe Event -> Maybe ScoreTime)
-> (PassedArgs a -> Maybe Event) -> PassedArgs a -> Maybe ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head ([Event] -> Maybe Event)
-> (PassedArgs a -> [Event]) -> PassedArgs a -> Maybe Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> [Event]
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 State Error ScoreTime
infer_end PassedArgs a
args
    | PassedArgs a -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs a
args ScoreTime -> ScoreTime -> Bool
forall a. Eq a => a -> a -> Bool
/= PassedArgs a -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args = ScoreTime -> Deriver State Error ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ScoreTime -> Deriver State Error ScoreTime)
-> ScoreTime -> Deriver State Error ScoreTime
forall a b. (a -> b) -> a -> b
$ PassedArgs a -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs a
args
    | Bool
otherwise = do
        Pitch
pitch <- Deriver Pitch
Derive.get_pitch
        RealTime
start <- PassedArgs a -> Deriver RealTime
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 -> ScoreTime -> Deriver State Error ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ScoreTime -> Deriver State Error ScoreTime)
-> ScoreTime -> Deriver State Error ScoreTime
forall a b. (a -> b) -> a -> b
$ PassedArgs a -> ScoreTime
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 <- Text -> Deriver State Error ScoreTime
forall a. Typecheck a => Text -> Deriver a
Derive.get_val Text
EnvKey.block_end
                ScoreTime -> ScoreTime -> ScoreTime
forall a. Ord a => a -> a -> a
min ScoreTime
end (ScoreTime -> ScoreTime)
-> Deriver State Error ScoreTime -> Deriver State Error ScoreTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Deriver State Error ScoreTime
forall a. Time a => a -> Deriver State Error 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 <- PassedArgs Control -> Deriver RealTime
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?
    Deriver State Error (Maybe Transposed)
-> (Transposed -> Deriver (Maybe PitchState))
-> Deriver (Maybe PitchState)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (RealTime -> Deriver State Error (Maybe Transposed)
lookup_pitch RealTime
start) ((Transposed -> Deriver (Maybe PitchState))
 -> Deriver (Maybe PitchState))
-> (Transposed -> Deriver (Maybe PitchState))
-> Deriver (Maybe PitchState)
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 (PassedArgs Control -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Control
args)

        let prev_step :: Double
prev_step = Double
-> ((RealTime, Double) -> Double)
-> Maybe (RealTime, Double)
-> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 (RealTime, Double) -> Double
forall a b. (a, b) -> b
snd (Maybe (RealTime, Double) -> Double)
-> Maybe (RealTime, Double) -> Double
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 = (Maybe Double -> Double)
-> Deriver State Error (Maybe Double) -> Deriver State Error Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0) (Deriver State Error (Maybe Double) -> Deriver State Error Double)
-> (Maybe Pitch -> Deriver State Error (Maybe Double))
-> Maybe Pitch
-> Deriver State Error Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pitch -> Deriver State Error Double)
-> Maybe Pitch -> Deriver State Error (Maybe Double)
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) (Transposed -> Deriver State Error Double)
-> (Pitch -> Deriver State Error Transposed)
-> Pitch
-> Deriver State Error Double
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< RealTime -> Pitch -> Deriver State Error 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 (Maybe Pitch -> Deriver State Error Double)
-> Maybe Pitch -> Deriver State Error Double
forall a b. (a -> b) -> a -> b
$
            NoteNumber -> Pitch -> Pitch
forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (Double -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn Double
prev_step) (Pitch -> Pitch) -> Maybe Pitch -> Maybe Pitch
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

        Maybe PitchState -> Deriver (Maybe PitchState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PitchState -> Deriver (Maybe PitchState))
-> Maybe PitchState -> Deriver (Maybe PitchState)
forall a b. (a -> b) -> a -> b
$ PitchState -> Maybe PitchState
forall a. a -> Maybe a
Just (PitchState -> Maybe PitchState) -> PitchState -> Maybe PitchState
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 State Error (Maybe Transposed)
lookup_pitch = RealTime -> Deriver State Error (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 = (,,)
    (Maybe Pitch
 -> Maybe Pitch
 -> Maybe Pitch
 -> (Maybe Pitch, Maybe Pitch, Maybe Pitch))
-> Deriver State Error (Maybe Pitch)
-> Deriver
     State
     Error
     (Maybe Pitch
      -> Maybe Pitch -> (Maybe Pitch, Maybe Pitch, Maybe Pitch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScoreTime -> Deriver State Error (Maybe Pitch)
Args.lookup_prev_note_pitch ScoreTime
start
    Deriver
  State
  Error
  (Maybe Pitch
   -> Maybe Pitch -> (Maybe Pitch, Maybe Pitch, Maybe Pitch))
-> Deriver State Error (Maybe Pitch)
-> Deriver
     State
     Error
     (Maybe Pitch -> (Maybe Pitch, Maybe Pitch, Maybe Pitch))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScoreTime -> Deriver State Error (Maybe Pitch)
Args.lookup_next_note_pitch ScoreTime
start
    Deriver
  State
  Error
  (Maybe Pitch -> (Maybe Pitch, Maybe Pitch, Maybe Pitch))
-> Deriver State Error (Maybe Pitch)
-> Deriver (Maybe Pitch, Maybe Pitch, Maybe Pitch)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RealTime -> Deriver State Error (Maybe Pitch)
get_prev_pitch (RealTime -> Deriver State Error (Maybe Pitch))
-> Deriver RealTime -> Deriver State Error (Maybe Pitch)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScoreTime -> Deriver RealTime
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 = RealTime -> Pitch -> Maybe Pitch
PSignal.at_negative RealTime
start Pitch
pitch
    let next :: Maybe Pitch
next = (RealTime, Pitch) -> Pitch
forall a b. (a, b) -> b
snd ((RealTime, Pitch) -> Pitch)
-> Maybe (RealTime, Pitch) -> Maybe Pitch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Pitch -> Maybe (RealTime, Pitch)
next_sample RealTime
start Pitch
pitch
    (Maybe Pitch, Maybe Pitch, Maybe Pitch)
-> Deriver (Maybe Pitch, Maybe Pitch, Maybe 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
_ <- RealTime -> Pitch -> Maybe (Segment Pitch)
PSignal.segment_at RealTime
x Pitch
pitch
    (RealTime
x2,) (Pitch -> (RealTime, Pitch))
-> Maybe Pitch -> Maybe (RealTime, Pitch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Pitch -> Maybe Pitch
PSignal.at RealTime
x2 Pitch
pitch

get_prev_pitch :: RealTime -> Derive.Deriver (Maybe PSignal.Pitch)
get_prev_pitch :: RealTime -> Deriver State Error (Maybe Pitch)
get_prev_pitch = RealTime -> Deriver State Error (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 $ Seq.max_on 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 RealTime -> Pitch -> Maybe (Segment Pitch)
PSignal.segment_at RealTime
x Pitch
sig of
    Just (Segment.Segment RealTime
x Pitch
y RealTime
_ Pitch
_) -> (RealTime, Pitch) -> Maybe (RealTime, Pitch)
forall a. a -> Maybe a
Just (RealTime
x, Pitch
y)
    Maybe (Segment Pitch)
Nothing -> Maybe (RealTime, Pitch)
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 = (NoteNumber -> Double)
-> Deriver State Error NoteNumber -> Deriver State Error Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NoteNumber -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Deriver State Error NoteNumber -> Deriver State Error Double)
-> Deriver State Error NoteNumber -> Deriver State Error Double
forall a b. (a -> b) -> a -> b
$
    (-) (NoteNumber -> NoteNumber -> NoteNumber)
-> Deriver State Error NoteNumber
-> Deriver State Error (NoteNumber -> NoteNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transposed -> Deriver State Error NoteNumber
Pitches.pitch_nn Transposed
p1 Deriver State Error (NoteNumber -> NoteNumber)
-> Deriver State Error NoteNumber -> Deriver State Error NoteNumber
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 (Text -> Doc) -> Text -> 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:"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines (((Char, [PitchCall]) -> Text) -> [(Char, [PitchCall])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Char, [PitchCall]) -> Text
pitch_call_doc (Map Char [PitchCall] -> [(Char, [PitchCall])]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Char [PitchCall]
pitch_call_map))
    Text -> Text -> Text
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
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` - "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"; " ((PitchCall -> Text) -> [PitchCall] -> [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
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if PitchCall -> Double
pcall_duration PitchCall
pcall Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
1
            then Text
" (dur " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Double -> Text
forall a. Pretty a => a -> Text
pretty (PitchCall -> Double
pcall_duration PitchCall
pcall) Text -> Text -> Text
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 = (Map Char (Either (Double, [Text]) PitchCall),
 [(Char, Either (Double, [Text]) PitchCall)])
-> Map Char [PitchCall]
forall {b} {b}.
Show b =>
(Map Char (Either (Double, [Text]) PitchCall), [(b, b)])
-> Map Char [PitchCall]
resolve ((Map Char (Either (Double, [Text]) PitchCall),
  [(Char, Either (Double, [Text]) PitchCall)])
 -> Map Char [PitchCall])
-> (Map Char (Either (Double, [Text]) PitchCall),
    [(Char, Either (Double, [Text]) PitchCall)])
-> Map Char [PitchCall]
forall a b. (a -> b) -> a -> b
$ [(Char, Either (Double, [Text]) PitchCall)]
-> (Map Char (Either (Double, [Text]) PitchCall),
    [(Char, Either (Double, [Text]) PitchCall)])
forall a b. Ord a => [(a, b)] -> (Map a b, [(a, b)])
Maps.unique ([(Char, Either (Double, [Text]) PitchCall)]
 -> (Map Char (Either (Double, [Text]) PitchCall),
     [(Char, Either (Double, [Text]) PitchCall)]))
-> [(Char, Either (Double, [Text]) PitchCall)]
-> (Map Char (Either (Double, [Text]) PitchCall),
    [(Char, Either (Double, [Text]) PitchCall)])
forall a b. (a -> b) -> a -> b
$ [[(Char, Either (Double, [Text]) PitchCall)]]
-> [(Char, Either (Double, [Text]) PitchCall)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
'=' Text
"Hold flat pitch." PCall
pc_flat]
    -- relative motion
    , [(Char, Either (Double, [Text]) PitchCall)
-> (Char, Either (Double, [Text]) PitchCall)
forall {a} {a}. (a, Either a PitchCall) -> (a, Either a PitchCall)
parse_name ((Char, Either (Double, [Text]) PitchCall)
 -> (Char, Either (Double, [Text]) PitchCall))
-> (Char, Either (Double, [Text]) PitchCall)
-> (Char, Either (Double, [Text]) PitchCall)
forall a b. (a -> b) -> a -> b
$ Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
c Text
"Relative motion." PCall
pc_relative | Char
c <- [Char]
"0123456789"]
    , [(Char, Either (Double, [Text]) PitchCall)
-> (Char, Either (Double, [Text]) PitchCall)
forall {a} {a}. (a, Either a PitchCall) -> (a, Either a PitchCall)
parse_name ((Char, Either (Double, [Text]) PitchCall)
 -> (Char, Either (Double, [Text]) PitchCall))
-> (Char, Either (Double, [Text]) PitchCall)
-> (Char, Either (Double, [Text]) PitchCall)
forall a b. (a -> b) -> a -> b
$ Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
pcall Char
'-' Text
"Negative relative motion." PCall
pc_relative]
    , [Char
-> Double -> [Text] -> (Char, Either (Double, [Text]) PitchCall)
forall {a} {a} {b} {b}. a -> a -> b -> (a, Either (a, b) b)
alias Char
c Double
1 [Integer -> Text
forall a. Show a => a -> Text
showt Integer
n] | (Char
c, Integer
n) <- [Char] -> [Integer] -> [(Char, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Char]
"abc" [-Integer
1, -Integer
2 ..]]

    , [Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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))]
    , [Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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)))]
    , [Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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))]
    , [Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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)))]
    , [Char
-> Double -> [Text] -> (Char, Either (Double, [Text]) PitchCall)
forall {a} {a} {b} {b}. a -> a -> b -> (a, Either (a, b) b)
alias Char
'n' Double
0.5 [Text
"e", Text
"f"]]
    , [Char
-> Double -> [Text] -> (Char, Either (Double, [Text]) PitchCall)
forall {a} {a} {b} {b}. a -> a -> b -> (a, Either (a, b) b)
alias Char
'u' Double
0.5 [Text
"f", Text
"e"]]

    , [ Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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
      , Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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)
      , Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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)
      , Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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)
      , Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
config Char
'T' Text
"Set from pitch relative to swaram." PCall
pc_set_pitch
      , Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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)
      , Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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)
      , Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
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'.
    , [ Char -> Text -> PCall -> (Char, Either (Double, [Text]) PitchCall)
forall {a} {a}. a -> Text -> PCall -> (a, Either a PitchCall)
config Char
c Text
postfix_doc (Parser () -> (() -> Context -> M PitchState Control) -> PCall
forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser ()
Sig.no_args ((() -> Context -> M PitchState Control) -> PCall)
-> (() -> Context -> M PitchState Control) -> PCall
forall a b. (a -> b) -> a -> b
$ \() Context
_ctx -> Control -> M PitchState Control
forall (m :: * -> *) a. Monad m => a -> m a
return Control
forall a. Monoid a => a
mempty)
      | Char
c <- Map Char (Double -> Double) -> [Char]
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)
        | [(b, b)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(b, b)]
duplicates = (Text -> Map Char [PitchCall])
-> (Map Char [PitchCall] -> Map Char [PitchCall])
-> Either Text (Map Char [PitchCall])
-> Map Char [PitchCall]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Map Char [PitchCall]
forall a. HasCallStack => Text -> a
errorStack Map Char [PitchCall] -> Map Char [PitchCall]
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 =
            Text -> Map Char [PitchCall]
forall a. HasCallStack => Text -> a
errorStack (Text -> Map Char [PitchCall]) -> Text -> Map Char [PitchCall]
forall a b. (a -> b) -> a -> b
$ Text
"duplicate calls: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [b] -> Text
forall a. Show a => a -> Text
showt (((b, b) -> b) -> [(b, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, b) -> b
forall a b. (a, b) -> a
fst [(b, b)]
duplicates)
    parse_name :: (a, Either a PitchCall) -> (a, Either a PitchCall)
parse_name = (Either a PitchCall -> Either a PitchCall)
-> (a, Either a PitchCall) -> (a, Either a PitchCall)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Either a PitchCall -> Either a PitchCall)
 -> (a, Either a PitchCall) -> (a, Either a PitchCall))
-> (Either a PitchCall -> Either a PitchCall)
-> (a, Either a PitchCall)
-> (a, Either a PitchCall)
forall a b. (a -> b) -> a -> b
$ (PitchCall -> PitchCall)
-> Either a PitchCall -> Either a PitchCall
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((PitchCall -> PitchCall)
 -> Either a PitchCall -> Either a PitchCall)
-> (PitchCall -> PitchCall)
-> Either a PitchCall
-> Either a PitchCall
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, (a, b) -> Either (a, b) b
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, PitchCall -> Either a PitchCall
forall a b. b -> Either a b
Right (PitchCall -> Either a PitchCall)
-> PitchCall -> Either a PitchCall
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, PitchCall -> Either a PitchCall
forall a b. b -> Either a b
Right (PitchCall -> Either a PitchCall)
-> PitchCall -> Either a PitchCall
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 = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Control -> Deriver Control)
-> Generator Control
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 (Module
module_ Module -> Module -> Module
forall a. Semigroup a => a -> a -> a
<> Module
"dyn") CallName
"dyn-sequence" Tags
forall a. Monoid a => a
mempty Doc
doc
    (WithArgDoc (PassedArgs Control -> Deriver Control)
 -> Generator Control)
-> WithArgDoc (PassedArgs Control -> Deriver Control)
-> Generator Control
forall a b. (a -> b) -> a -> b
$ Parser Text
-> (Text -> PassedArgs Control -> Deriver Control)
-> WithArgDoc (PassedArgs Control -> Deriver Control)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser Text
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"sequence" Doc
"Dyn calls.")
    ((Text -> PassedArgs Control -> Deriver Control)
 -> WithArgDoc (PassedArgs Control -> Deriver Control))
-> (Text -> PassedArgs Control -> Deriver Control)
-> WithArgDoc (PassedArgs Control -> Deriver Control)
forall a b. (a -> b) -> a -> b
$ \Text
text PassedArgs Control
args -> do
        (ScoreTime
start, ScoreTime
end) <- PassedArgs Control -> Deriver State Error (ScoreTime, ScoreTime)
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 = Double
-> ((RealTime, Double) -> Double)
-> Maybe (RealTime, Double)
-> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 (RealTime, Double) -> Double
forall a b. (a, b) -> b
snd (PassedArgs Control -> Maybe (RealTime, Double)
Args.prev_control PassedArgs Control
args) }
        ScoreTime -> Deriver Control -> Deriver Control
forall a. ScoreTime -> Deriver a -> Deriver a
Derive.at ScoreTime
start (Deriver Control -> Deriver Control)
-> Deriver Control -> Deriver Control
forall a b. (a -> b) -> a -> b
$ ScoreTime -> DynState -> Text -> Deriver Control
dyn_sequence (ScoreTime
end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
start) DynState
state Text
text
    where
    doc :: Doc
doc = Text -> Doc
Doc.Doc (Text -> Doc) -> Text -> 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:"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines (((Char, DynCall) -> Text) -> [(Char, DynCall)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Char, DynCall) -> Text
dyn_call_doc (Map Char DynCall -> [(Char, DynCall)]
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
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` - "
    Text -> Text -> 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 = [(Char, DynCall)] -> Map Char DynCall
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Char, DynCall)] -> Map Char DynCall)
-> [(Char, DynCall)] -> Map Char DynCall
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]
(Int -> DynState -> ShowS)
-> (DynState -> [Char]) -> ([DynState] -> ShowS) -> Show DynState
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", Double -> Doc
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 <- (Text -> Text)
-> Either Text [Call (DynCall, Char)]
-> Deriver [Call (DynCall, Char)]
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right ((Text
"parsing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showt Text
arg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) (Either Text [Call (DynCall, Char)]
 -> Deriver [Call (DynCall, Char)])
-> Either Text [Call (DynCall, Char)]
-> Deriver [Call (DynCall, Char)]
forall a b. (a -> b) -> a -> b
$
        [Call Char] -> Either Text [Call (DynCall, Char)]
resolve_dyn_calls ([Call Char] -> Either Text [Call (DynCall, Char)])
-> Either Text [Call Char] -> Either Text [Call (DynCall, Char)]
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 (Int -> Double -> [Double]
forall a. Int -> a -> [a]
replicate ([Call (DynCall, Char)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Call (DynCall, Char)]
exprs) Double
1)
        ranges :: [(ScoreTime, ScoreTime)]
ranges = [ScoreTime] -> [ScoreTime] -> [(ScoreTime, ScoreTime)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ScoreTime]
starts (Int -> [ScoreTime] -> [ScoreTime]
forall a. Int -> [a] -> [a]
drop Int
1 [ScoreTime]
starts)
    ([Control]
results, DynState
_) <- StateT DynState Deriver [Control]
-> DynState -> Deriver State Error ([Control], DynState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT ((((ScoreTime, ScoreTime), Call (DynCall, Char))
 -> StateT DynState Deriver Control)
-> [((ScoreTime, ScoreTime), Call (DynCall, Char))]
-> StateT DynState Deriver [Control]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ScoreTime, ScoreTime), Call (DynCall, Char))
-> StateT DynState Deriver Control
eval_dyn ([(ScoreTime, ScoreTime)]
-> [Call (DynCall, Char)]
-> [((ScoreTime, ScoreTime), Call (DynCall, Char))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(ScoreTime, ScoreTime)]
ranges [Call (DynCall, Char)]
exprs)) DynState
state
    Control -> Deriver Control
forall (m :: * -> *) a. Monad m => a -> m a
return (Control -> Deriver Control) -> Control -> Deriver Control
forall a b. (a -> b) -> a -> b
$ [Control] -> Control
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))
-> StateT DynState Deriver Control
eval_dyn ((ScoreTime
start, ScoreTime
end), (Call (DynCall Text
_ Parser a
sig a -> Context -> StateT DynState Deriver 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 (Text -> CallName) -> Text -> CallName
forall a b. (a -> b) -> a -> b
$ Char -> Text
Text.singleton Char
name
            }
    a
parsed_arg <- CallName -> Text -> Parser a -> StateT DynState Deriver a
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 -> StateT DynState Deriver 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 = Parser [Call Char] -> Text -> Either Text [Call Char]
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 Parser () -> Parser [Call Char] -> Parser [Call Char]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text (Call Char) -> Parser [Call Char]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 (Parser Text (Call Char)
p_dyn_call Parser Text (Call Char) -> Parser () -> Parser Text (Call Char)
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 <- Text -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Text
"" (Char -> Text
Text.singleton (Char -> Text) -> Parser Char -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
A.digit)
    Call Char -> Parser Text (Call Char)
forall (m :: * -> *) a. Monad m => a -> m a
return (Call Char -> Parser Text (Call Char))
-> Call Char -> Parser Text (Call Char)
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Call Char
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 = (Call Char -> Either Text (Call (DynCall, Char)))
-> [Call Char] -> Either Text [Call (DynCall, Char)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Call Char -> Either Text (Call (DynCall, Char)))
 -> [Call Char] -> Either Text [Call (DynCall, Char)])
-> (Call Char -> Either Text (Call (DynCall, Char)))
-> [Call Char]
-> Either Text [Call (DynCall, Char)]
forall a b. (a -> b) -> a -> b
$ \(Call Char
name Text
arg) ->
    case Char -> Map Char DynCall -> Maybe DynCall
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 -> Text -> Either Text (Call (DynCall, Char))
forall a b. a -> Either a b
Left (Text -> Either Text (Call (DynCall, Char)))
-> Text -> Either Text (Call (DynCall, Char))
forall a b. (a -> b) -> a -> b
$ Text
"dyn call not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
forall a. Show a => a -> Text
showt Char
name
        Just DynCall
call -> Call (DynCall, Char) -> Either Text (Call (DynCall, Char))
forall (m :: * -> *) a. Monad m => a -> m a
return (Call (DynCall, Char) -> Either Text (Call (DynCall, Char)))
-> Call (DynCall, Char) -> Either Text (Call (DynCall, Char))
forall a b. (a -> b) -> a -> b
$ (DynCall, Char) -> Text -> Call (DynCall, Char)
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]
(Int -> PitchState -> ShowS)
-> (PitchState -> [Char])
-> ([PitchState] -> ShowS)
-> Show PitchState
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", Transposed -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Transposed
swaram)
            , (Text
"from", Double -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Double
from)
            , (Text
"prev", Double -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Double
prev)
            , (Text
"next", Double -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Double
next)
            , (Text
"transition", Normalized -> Doc
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 <- (PitchState -> Transposed) -> StateT PitchState Deriver Transposed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
    Double
steps <- Deriver State Error Double -> StateT PitchState Deriver Double
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver State Error Double -> StateT PitchState Deriver Double)
-> Deriver State Error Double -> StateT PitchState Deriver Double
forall a b. (a -> b) -> a -> b
$ Transposed -> Transposed -> Deriver State Error Double
step_difference Transposed
p Transposed
swaram
    (PitchState -> PitchState) -> M PitchState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((PitchState -> PitchState) -> M PitchState ())
-> (PitchState -> PitchState) -> M PitchState ()
forall a b. (a -> b) -> a -> b
$ \PitchState
state -> PitchState
state { _from :: Double
_from = Double
steps }

get_from :: M PitchState PSignal.Transposed
get_from :: StateT PitchState Deriver Transposed
get_from = do
    Double
steps <- (PitchState -> Double) -> StateT PitchState Deriver Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Double
_from
    Transposed
swaram <- (PitchState -> Transposed) -> StateT PitchState Deriver Transposed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
    Transposed -> StateT PitchState Deriver Transposed
forall (m :: * -> *) a. Monad m => a -> m a
return (Transposed -> StateT PitchState Deriver Transposed)
-> Transposed -> StateT PitchState Deriver Transposed
forall a b. (a -> b) -> a -> b
$ NoteNumber -> Transposed -> Transposed
forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (Double -> NoteNumber
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]
(Int -> Result -> ShowS)
-> (Result -> [Char]) -> ([Result] -> ShowS) -> Show Result
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
(Result -> Result -> Result)
-> (NonEmpty Result -> Result)
-> (forall b. Integral b => b -> Result -> Result)
-> Semigroup 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
Semigroup Result
-> Result
-> (Result -> Result -> Result)
-> ([Result] -> Result)
-> Monoid 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 <- (Text -> Text)
-> Either Text [Call (PitchCall, Char)]
-> Deriver [Call (PitchCall, Char)]
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right ((Text
"parsing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
pretty Text
arg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) (Either Text [Call (PitchCall, Char)]
 -> Deriver [Call (PitchCall, Char)])
-> Either Text [Call (PitchCall, Char)]
-> Deriver [Call (PitchCall, Char)]
forall a b. (a -> b) -> a -> b
$
        [Call (PitchCall, Char)] -> Either Text [Call (PitchCall, Char)]
resolve_postfix ([Call (PitchCall, Char)] -> Either Text [Call (PitchCall, Char)])
-> Either Text [Call (PitchCall, Char)]
-> Either Text [Call (PitchCall, Char)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ParsedPitch] -> Either Text [Call (PitchCall, Char)]
resolve_pitch_calls ([ParsedPitch] -> Either Text [Call (PitchCall, Char)])
-> Either Text [ParsedPitch]
-> Either Text [Call (PitchCall, Char)]
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 ([Call (PitchCall, Char)] -> [Double]
forall a. [Call (PitchCall, a)] -> [Double]
call_durations [Call (PitchCall, Char)]
calls)
        ranges :: [(ScoreTime, ScoreTime)]
ranges = [ScoreTime] -> [ScoreTime] -> [(ScoreTime, ScoreTime)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ScoreTime]
starts (Int -> [ScoreTime] -> [ScoreTime]
forall a. Int -> [a] -> [a]
drop Int
1 [ScoreTime]
starts)
    ([Result]
results, PitchState
_) <- StateT PitchState Deriver [Result]
-> PitchState -> Deriver State Error ([Result], PitchState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT ((Call ((ScoreTime, ScoreTime), (PitchCall, Char))
 -> StateT PitchState Deriver Result)
-> [Call ((ScoreTime, ScoreTime), (PitchCall, Char))]
-> StateT PitchState Deriver [Result]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Call ((ScoreTime, ScoreTime), (PitchCall, Char))
-> StateT PitchState Deriver Result
eval_pitch ([(ScoreTime, ScoreTime)]
-> [Call (PitchCall, Char)]
-> [Call ((ScoreTime, ScoreTime), (PitchCall, Char))]
forall a b. [a] -> [Call b] -> [Call (a, b)]
zip_calls [(ScoreTime, ScoreTime)]
ranges [Call (PitchCall, Char)]
calls))
        PitchState
state
    Result -> Deriver Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> Deriver Result) -> Result -> Deriver Result
forall a b. (a -> b) -> a -> b
$ [Result] -> Result
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 =
    (ScoreTime -> ScoreTime -> ScoreTime)
-> ScoreTime -> [ScoreTime] -> [ScoreTime]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
(+) ScoreTime
0 ([ScoreTime] -> [ScoreTime]) -> [ScoreTime] -> [ScoreTime]
forall a b. (a -> b) -> a -> b
$ (Double -> ScoreTime) -> [Double] -> [ScoreTime]
forall a b. (a -> b) -> [a] -> [b]
map ((ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
*ScoreTime
one) (ScoreTime -> ScoreTime)
-> (Double -> ScoreTime) -> Double -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> ScoreTime
ScoreTime.from_double) [Double]
slices
    where one :: ScoreTime
one = ScoreTime
dur ScoreTime -> ScoreTime -> ScoreTime
forall a. Fractional a => a -> a -> a
/ Double -> ScoreTime
ScoreTime.from_double ([Double] -> 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))
-> StateT PitchState Deriver 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 <- CallName -> Text -> Parser a -> StateT PitchState Deriver a
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 (DList Control -> Result)
-> (Control -> DList Control) -> Control -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> DList Control
forall a. a -> DList a
DList.singleton) (Control -> Result)
-> M PitchState Control -> StateT PitchState Deriver Result
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 (Text -> CallName) -> Text -> 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
(Call call -> Call call -> Bool)
-> (Call call -> Call call -> Bool) -> Eq (Call call)
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
[Call call] -> ShowS
Call call -> [Char]
(Int -> Call call -> ShowS)
-> (Call call -> [Char])
-> ([Call call] -> ShowS)
-> Show (Call call)
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 -> b) -> Call a -> Call b)
-> (forall a b. a -> Call b -> Call a) -> Functor Call
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 = (Call (PitchCall, a) -> Double)
-> [Call (PitchCall, a)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ((Call (PitchCall, a) -> Double)
 -> [Call (PitchCall, a)] -> [Double])
-> (Call (PitchCall, a) -> Double)
-> [Call (PitchCall, a)]
-> [Double]
forall a b. (a -> b) -> a -> b
$ PitchCall -> Double
pcall_duration (PitchCall -> Double)
-> (Call (PitchCall, a) -> PitchCall)
-> Call (PitchCall, a)
-> Double
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 = [(a, b) -> Text -> Call (a, b)
forall call. call -> Text -> Call call
Call (a
x, b
c) Text
arg | (a
x, Call b
c Text
arg) <- [a] -> [Call b] -> [(a, Call b)]
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 = Parser [ParsedPitch] -> Text -> Either Text [ParsedPitch]
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 = (ParsedPitch -> Either Text [Call (PitchCall, Char)])
-> [ParsedPitch] -> Either Text [Call (PitchCall, Char)]
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) =
        (Call (PitchCall, Char) -> Call (PitchCall, Char))
-> [Call (PitchCall, Char)] -> [Call (PitchCall, Char)]
forall a b. (a -> b) -> [a] -> [b]
map ((Double -> Double)
-> Call (PitchCall, Char) -> Call (PitchCall, Char)
forall a.
(Double -> Double) -> Call (PitchCall, a) -> Call (PitchCall, a)
modify_duration (Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([ParsedPitch] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ParsedPitch]
calls)))) ([Call (PitchCall, Char)] -> [Call (PitchCall, Char)])
-> Either Text [Call (PitchCall, Char)]
-> Either Text [Call (PitchCall, Char)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (ParsedPitch -> Either Text [Call (PitchCall, Char)])
-> [ParsedPitch] -> Either Text [Call (PitchCall, Char)]
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 Char -> Map Char [PitchCall] -> Maybe [PitchCall]
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 -> Text -> Either Text [Call (PitchCall, Char)]
forall a b. a -> Either a b
Left (Text -> Either Text [Call (PitchCall, Char)])
-> Text -> Either Text [Call (PitchCall, Char)]
forall a b. (a -> b) -> a -> b
$ Text
"pitch call not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
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 -> [Call (PitchCall, Char)] -> Either Text [Call (PitchCall, Char)]
forall a b. b -> Either a b
Right [(PitchCall, Char) -> Text -> Call (PitchCall, Char)
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 = [Call (PitchCall, Char)] -> Either Text [Call (PitchCall, Char)]
forall {a}.
IsString a =>
[Call (PitchCall, Char)] -> Either a [Call (PitchCall, Char)]
resolve ([Call (PitchCall, Char)] -> Either Text [Call (PitchCall, Char)])
-> ([Call (PitchCall, Char)]
    -> Either Text [Call (PitchCall, Char)])
-> [Call (PitchCall, Char)]
-> Either Text [Call (PitchCall, Char)]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Call (PitchCall, Char)] -> Either Text [Call (PitchCall, Char)]
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 [] = [Call (PitchCall, Char)] -> Either a [Call (PitchCall, Char)]
forall a b. b -> Either a b
Right []
    resolve (Call (PitchCall, Char)
call : [Call (PitchCall, Char)]
calls)
        | Maybe (Double -> Double) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Call (PitchCall, Char) -> Maybe (Double -> Double)
forall {a}. Call (a, Char) -> Maybe (Double -> Double)
is_postfix Call (PitchCall, Char)
call) =
            a -> Either a [Call (PitchCall, Char)]
forall a b. a -> Either a b
Left a
"postfix call with no preceding call"
        | Bool
otherwise = ((Double -> Double)
-> Call (PitchCall, Char) -> Call (PitchCall, Char)
forall a.
(Double -> Double) -> Call (PitchCall, a) -> Call (PitchCall, a)
modify_duration Double -> Double
modify Call (PitchCall, Char)
call :) ([Call (PitchCall, Char)] -> [Call (PitchCall, Char)])
-> Either a [Call (PitchCall, Char)]
-> Either a [Call (PitchCall, Char)]
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) = (Call (PitchCall, Char) -> Maybe (Double -> Double))
-> [Call (PitchCall, Char)]
-> ([Double -> Double], [Call (PitchCall, Char)])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Seq.span_while Call (PitchCall, Char) -> Maybe (Double -> Double)
forall {a}. Call (a, Char) -> Maybe (Double -> Double)
is_postfix [Call (PitchCall, Char)]
calls
        modify :: Double -> Double
modify Double
dur = (Double -> (Double -> Double) -> Double)
-> Double -> [Double -> Double] -> Double
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((Double -> Double) -> Double -> Double)
-> Double -> (Double -> Double) -> Double
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Double -> Double) -> Double -> Double
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
        | [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs = t (Call (a, Char)) -> Either Text (t (Call (a, Char)))
forall a b. b -> Either a b
Right t (Call (a, Char))
calls
        | Bool
otherwise = Text -> Either Text (t (Call (a, Char)))
forall a b. a -> Either a b
Left (Text -> Either Text (t (Call (a, Char))))
-> Text -> Either Text (t (Call (a, Char)))
forall a b. (a -> b) -> a -> b
$
            Text
"postfix calls can't have args: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
errs
        where errs :: [Text]
errs = (Call (a, Char) -> [Text]) -> t (Call (a, Char)) -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Call (a, Char) -> [Text]
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)
        | Maybe (Double -> Double) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Call (a, Char) -> Maybe (Double -> Double)
forall {a}. Call (a, Char) -> Maybe (Double -> Double)
is_postfix Call (a, Char)
call) Bool -> Bool -> Bool
&& Text
arg Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
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
_) = Char -> Map Char (Double -> Double) -> Maybe (Double -> Double)
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 = [(Char, Double -> Double)] -> Map Char (Double -> Double)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Char
'_', (Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
1)), (Char
'.', (Double -> Double -> Double
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."
    Text -> Text -> Text
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 = ((PitchCall, a) -> (PitchCall, a))
-> Call (PitchCall, a) -> Call (PitchCall, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((PitchCall, a) -> (PitchCall, a))
 -> Call (PitchCall, a) -> Call (PitchCall, a))
-> ((PitchCall, a) -> (PitchCall, a))
-> Call (PitchCall, a)
-> Call (PitchCall, a)
forall a b. (a -> b) -> a -> b
$ (PitchCall -> PitchCall) -> (PitchCall, a) -> (PitchCall, a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((PitchCall -> PitchCall) -> (PitchCall, a) -> (PitchCall, a))
-> (PitchCall -> PitchCall) -> (PitchCall, a) -> (PitchCall, a)
forall a b. (a -> b) -> a -> b
$ \PitchCall
call ->
    if PitchCall -> Double
pcall_duration PitchCall
call Double -> Double -> Bool
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 = Text
-> Parser ()
-> (() -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a.
Text
-> Parser a
-> (a -> Context -> StateT DynState Deriver Control)
-> DynCall
DynCall Text
"No movement." Parser ()
Sig.no_args ((() -> Context -> StateT DynState Deriver Control) -> DynCall)
-> (() -> Context -> StateT DynState Deriver Control) -> DynCall
forall a b. (a -> b) -> a -> b
$ \() Context
ctx -> do
    Double
prev <- (DynState -> Double) -> StateT DynState Deriver Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets DynState -> Double
state_from_dyn
    RealTime
start <- Deriver RealTime -> StateT DynState Deriver RealTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver RealTime -> StateT DynState Deriver RealTime)
-> Deriver RealTime -> StateT DynState Deriver RealTime
forall a b. (a -> b) -> a -> b
$ ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (Context -> ScoreTime
ctx_start Context
ctx)
    Control -> StateT DynState Deriver Control
forall (m :: * -> *) a. Monad m => a -> m a
return (Control -> StateT DynState Deriver Control)
-> Control -> StateT DynState Deriver Control
forall a b. (a -> b) -> a -> b
$ RealTime -> Double -> Control
forall {k} (kind :: k). RealTime -> Double -> Signal kind
Signal.from_sample RealTime
start Double
prev

dc_attack :: DynCall
dc_attack :: DynCall
dc_attack = Text
-> Parser (Maybe Double)
-> (Maybe Double -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a.
Text
-> Parser a
-> (a -> Context -> StateT DynState Deriver Control)
-> DynCall
DynCall Text
doc Parser (Maybe Double)
dyn_arg ((Maybe Double -> Context -> StateT DynState Deriver Control)
 -> DynCall)
-> (Maybe Double -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a b. (a -> b) -> a -> b
$ \Maybe Double
maybe_to Context
ctx ->
    Curve
-> Double -> Double -> Context -> StateT DynState Deriver Control
make_dyn_curve (Double -> Double -> Curve
dyn_curve Double
0 Double
0.8) Double
0 (Double -> Maybe Double -> Double
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 = Text
-> Parser (Maybe Double)
-> (Maybe Double -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a.
Text
-> Parser a
-> (a -> Context -> StateT DynState Deriver Control)
-> DynCall
DynCall Text
doc Parser (Maybe Double)
dyn_arg ((Maybe Double -> Context -> StateT DynState Deriver Control)
 -> DynCall)
-> (Maybe Double -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a b. (a -> b) -> a -> b
$ \Maybe Double
maybe_to Context
ctx -> do
    Double
from <- (DynState -> Double) -> StateT DynState Deriver Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets DynState -> Double
state_from_dyn
    Curve
-> Double -> Double -> Context -> StateT DynState Deriver Control
make_dyn_curve (Double -> Double -> Curve
dyn_curve Double
0 Double
0.8) Double
from (Double -> Maybe Double -> Double
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 = Text
-> Parser (Maybe Double)
-> (Maybe Double -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a.
Text
-> Parser a
-> (a -> Context -> StateT DynState Deriver Control)
-> DynCall
DynCall Text
doc Parser (Maybe Double)
dyn_arg ((Maybe Double -> Context -> StateT DynState Deriver Control)
 -> DynCall)
-> (Maybe Double -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a b. (a -> b) -> a -> b
$ \Maybe Double
maybe_to Context
ctx -> do
    Double
from <- (DynState -> Double) -> StateT DynState Deriver Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets DynState -> Double
state_from_dyn
    Curve
-> Double -> Double -> Context -> StateT DynState Deriver Control
make_dyn_curve (Double -> Double -> Curve
dyn_curve Double
w1 Double
w2) Double
from (Double -> Maybe Double -> Double
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: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Double, Double) -> Text
forall a. Pretty a => a -> Text
pretty (Double
w1, Double
w2)

dc_move_to :: DynCall
dc_move_to :: DynCall
dc_move_to = Text
-> Parser Double
-> (Double -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a.
Text
-> Parser a
-> (a -> Context -> StateT DynState Deriver Control)
-> DynCall
DynCall Text
"Move to dyn." Parser Double
required_dyn_arg ((Double -> Context -> StateT DynState Deriver Control) -> DynCall)
-> (Double -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a b. (a -> b) -> a -> b
$ \Double
to Context
ctx -> do
    Double
from <- (DynState -> Double) -> StateT DynState Deriver Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets DynState -> Double
state_from_dyn
    Curve
-> Double -> Double -> Context -> StateT DynState Deriver 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 -> StateT DynState Deriver Control
make_dyn_curve Curve
curve Double
from Double
to Context
ctx = do
    (RealTime
start, RealTime
end) <- Context -> M DynState (RealTime, RealTime)
forall s. Context -> M s (RealTime, RealTime)
ctx_range Context
ctx
    (DynState -> DynState) -> StateT DynState Deriver ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((DynState -> DynState) -> StateT DynState Deriver ())
-> (DynState -> DynState) -> StateT DynState Deriver ()
forall a b. (a -> b) -> a -> b
$ \DynState
state -> DynState
state { state_from_dyn :: Double
state_from_dyn = Double
to }
    Deriver Control -> StateT DynState Deriver Control
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver Control -> StateT DynState Deriver Control)
-> Deriver Control -> StateT DynState Deriver Control
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 ((Double -> Double) -> Curve) -> (Double -> Double) -> Curve
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 = Text
-> Parser Double
-> (Double -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a.
Text
-> Parser a
-> (a -> Context -> StateT DynState Deriver Control)
-> DynCall
DynCall Text
"Set from dyn." Parser Double
required_dyn_arg ((Double -> Context -> StateT DynState Deriver Control) -> DynCall)
-> (Double -> Context -> StateT DynState Deriver Control)
-> DynCall
forall a b. (a -> b) -> a -> b
$ \Double
to Context
_ctx -> do
    (DynState -> DynState) -> StateT DynState Deriver ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((DynState -> DynState) -> StateT DynState Deriver ())
-> (DynState -> DynState) -> StateT DynState Deriver ()
forall a b. (a -> b) -> a -> b
$ \DynState
state -> DynState
state { state_from_dyn :: Double
state_from_dyn = Double
to }
    Control -> StateT DynState Deriver Control
forall (m :: * -> *) a. Monad m => a -> m a
return Control
forall a. Monoid a => a
mempty

dyn_arg :: Sig.Parser (Maybe Signal.Y)
dyn_arg :: Parser (Maybe Double)
dyn_arg = (Int -> Double) -> Maybe Int -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Double
arg_to_dyn (Maybe Int -> Maybe Double)
-> Parser (Maybe Int) -> Parser (Maybe Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Maybe Int -> Doc -> Parser (Maybe Int)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"move" Maybe Int
forall a. Maybe a
Nothing 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 (Int -> Double) -> Parser Int -> Parser Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Doc -> Parser Int
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 = (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
9) (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
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 = [(Char, [PitchCall])] -> Map Char [PitchCall]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Char, [PitchCall])] -> Map Char [PitchCall])
-> Either Text [(Char, [PitchCall])]
-> Either Text (Map Char [PitchCall])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Char, Either (Double, [Text]) PitchCall)
 -> Either Text (Char, [PitchCall]))
-> [(Char, Either (Double, [Text]) PitchCall)]
-> Either Text [(Char, [PitchCall])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Char, Either (Double, [Text]) PitchCall)
-> Either Text (Char, [PitchCall])
forall {a}.
(a, Either (Double, [Text]) PitchCall)
-> Either Text (a, [PitchCall])
resolve (Map Char (Either (Double, [Text]) PitchCall)
-> [(Char, Either (Double, [Text]) PitchCall)]
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) = (a, [PitchCall]) -> Either Text (a, [PitchCall])
forall a b. b -> Either a b
Right (a
name, [PitchCall
call])
    resolve (a
name, Left (Double
duration, [Text]
calls)) =
        (,) a
name ([PitchCall] -> (a, [PitchCall]))
-> ([PitchCall] -> [PitchCall]) -> [PitchCall] -> (a, [PitchCall])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PitchCall -> PitchCall) -> [PitchCall] -> [PitchCall]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> PitchCall -> PitchCall
set_dur Double
duration) ([PitchCall] -> (a, [PitchCall]))
-> Either Text [PitchCall] -> Either Text (a, [PitchCall])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Either Text PitchCall)
-> [Text] -> Either Text [PitchCall]
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) <- Text -> Maybe (Char, Text) -> Either Text (Char, Text)
forall err a. err -> Maybe a -> Either err a
justErr Text
"empty alias" (Maybe (Char, Text) -> Either Text (Char, Text))
-> Maybe (Char, Text) -> Either Text (Char, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
Text.uncons Text
to
        Either (Double, [Text]) PitchCall
call <- Text
-> Maybe (Either (Double, [Text]) PitchCall)
-> Either Text (Either (Double, [Text]) PitchCall)
forall err a. err -> Maybe a -> Either err a
justErr (Text
"not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
forall a. Show a => a -> Text
showt Char
c) (Maybe (Either (Double, [Text]) PitchCall)
 -> Either Text (Either (Double, [Text]) PitchCall))
-> Maybe (Either (Double, [Text]) PitchCall)
-> Either Text (Either (Double, [Text]) PitchCall)
forall a b. (a -> b) -> a -> b
$ Char
-> Map Char (Either (Double, [Text]) PitchCall)
-> Maybe (Either (Double, [Text]) PitchCall)
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 <- ((Double, [Text]) -> Text)
-> Either (Double, [Text]) PitchCall -> Either Text PitchCall
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"alias to alias: "<>) (Text -> Text)
-> ((Double, [Text]) -> Text) -> (Double, [Text]) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, [Text]) -> Text
forall a. Show a => a -> Text
showt) Either (Double, [Text]) PitchCall
call
        PitchCall -> Either Text PitchCall
forall a b. b -> Either a b
Right (PitchCall -> Either Text PitchCall)
-> PitchCall -> Either Text PitchCall
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 -> Parser Val -> (Val -> Context -> M PitchState Control) -> PCall
forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser Val
ignore ((Val -> Context -> M PitchState Control) -> PCall)
-> (Val -> Context -> M PitchState Control) -> PCall
forall a b. (a -> b) -> a -> b
$ \Val
_ Context
ctx -> do
            a
parsed <- CallName -> Text -> Parser a -> StateT PitchState Deriver a
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 :: Parser Val
ignore = ArgName -> Val -> Doc -> Parser Val
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> 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 = Deriver a -> m Deriver a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver a -> m Deriver a) -> Deriver a -> m Deriver a
forall a b. (a -> b) -> a -> b
$ do
    [Val]
vals <- (Text -> Text) -> Either Text [Val] -> Deriver [Val]
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right ((Text
"parsing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CallName -> Text
forall a. Pretty a => a -> Text
pretty CallName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) (Either Text [Val] -> Deriver [Val])
-> Either Text [Val] -> Deriver [Val]
forall a b. (a -> b) -> a -> b
$
        if Text -> Bool
Text.null Text
arg then [Val] -> Either Text [Val]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else (Val -> [Val] -> [Val]
forall a. a -> [a] -> [a]
:[]) (Val -> [Val]) -> Either Text Val -> Either Text [Val]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Val
Parse.parse_val Text
arg
    Either Error a -> Deriver a
forall a. Either Error a -> Deriver a
Sig.require_right
        (Either Error a -> Deriver a)
-> Deriver State Error (Either Error a) -> Deriver a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser a
-> Context Tagged
-> CallName
-> [Val]
-> Deriver State Error (Either Error a)
forall a.
Parser a
-> Context Tagged -> CallName -> [Val] -> Deriver (Either Error a)
Sig.parse_vals Parser a
sig (ScoreTime -> ScoreTime -> Text -> Context Tagged
forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
0 ScoreTime
1 (CallName -> Text
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]
(Int -> Context -> ShowS)
-> (Context -> [Char]) -> ([Context] -> ShowS) -> Show Context
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 = Deriver (RealTime, RealTime)
-> StateT s Deriver (RealTime, RealTime)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver (RealTime, RealTime)
 -> StateT s Deriver (RealTime, RealTime))
-> Deriver (RealTime, RealTime)
-> StateT s Deriver (RealTime, RealTime)
forall a b. (a -> b) -> a -> b
$
    (,) (RealTime -> RealTime -> (RealTime, RealTime))
-> Deriver RealTime
-> Deriver State Error (RealTime -> (RealTime, RealTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (Context -> ScoreTime
ctx_start Context
ctx) Deriver State Error (RealTime -> (RealTime, RealTime))
-> Deriver RealTime -> Deriver (RealTime, RealTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (Context -> ScoreTime
ctx_end Context
ctx)

pc_flat :: PCall
pc_flat :: PCall
pc_flat = Parser () -> (() -> Context -> M PitchState Control) -> PCall
forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser ()
Sig.no_args ((() -> Context -> M PitchState Control) -> PCall)
-> (() -> Context -> M PitchState Control) -> PCall
forall a b. (a -> b) -> a -> b
$ \() Context
ctx -> do
    Double
step <- (PitchState -> Double) -> StateT PitchState Deriver Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Double
_from
    RealTime
start <- Deriver RealTime -> StateT PitchState Deriver RealTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver RealTime -> StateT PitchState Deriver RealTime)
-> Deriver RealTime -> StateT PitchState Deriver RealTime
forall a b. (a -> b) -> a -> b
$ ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (ScoreTime -> Deriver RealTime) -> ScoreTime -> Deriver RealTime
forall a b. (a -> b) -> a -> b
$ Context -> ScoreTime
ctx_start Context
ctx
    Control -> M PitchState Control
forall (m :: * -> *) a. Monad m => a -> m a
return (Control -> M PitchState Control)
-> Control -> M PitchState Control
forall a b. (a -> b) -> a -> b
$ RealTime -> Double -> Control
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 = Parser DefaultDiatonic
-> (DefaultDiatonic -> Context -> M PitchState Control) -> PCall
forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall (ArgName -> Doc -> Parser DefaultDiatonic
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"to" Doc
"To pitch.") ((DefaultDiatonic -> Context -> M PitchState Control) -> PCall)
-> (DefaultDiatonic -> Context -> M PitchState Control) -> PCall
forall a b. (a -> b) -> a -> b
$
    \(Typecheck.DefaultDiatonic Transpose
transpose) Context
ctx -> do
        Transposed
from <- (PitchState -> Transposed) -> StateT PitchState Deriver Transposed
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 (Transpose -> Transposed -> Transposed
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 = Parser () -> (() -> Context -> M PitchState Control) -> PCall
forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser ()
Sig.no_args ((() -> Context -> M PitchState Control) -> PCall)
-> (() -> Context -> M PitchState Control) -> PCall
forall a b. (a -> b) -> a -> b
$ \() Context
ctx -> do
    Transposed
from_pitch <- StateT PitchState Deriver Transposed
get_from
    Context -> Transposed -> M PitchState Control
move_to Context
ctx (Transpose -> Transposed -> Transposed
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]
(Int -> PitchDirection -> ShowS)
-> (PitchDirection -> [Char])
-> ([PitchDirection] -> ShowS)
-> Show PitchDirection
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
(PitchDirection -> PitchDirection -> Bool)
-> (PitchDirection -> PitchDirection -> Bool) -> Eq PitchDirection
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 = PitchDirection -> Text
forall a. Show a => a -> Text
showt

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

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

get_direction_pitch :: PitchDirection -> M PitchState PSignal.Transposed
get_direction_pitch :: PitchDirection -> StateT PitchState Deriver Transposed
get_direction_pitch PitchDirection
dir = case PitchDirection
dir of
    PitchDirection
Previous -> NoteNumber -> Transposed -> Transposed
forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (NoteNumber -> Transposed -> Transposed)
-> StateT PitchState Deriver NoteNumber
-> StateT PitchState Deriver (Transposed -> Transposed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn (Double -> NoteNumber)
-> StateT PitchState Deriver Double
-> StateT PitchState Deriver NoteNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PitchState -> Double) -> StateT PitchState Deriver Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Double
_prev)
        StateT PitchState Deriver (Transposed -> Transposed)
-> StateT PitchState Deriver Transposed
-> StateT PitchState Deriver Transposed
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (PitchState -> Transposed) -> StateT PitchState Deriver Transposed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
    PitchDirection
Current -> (PitchState -> Transposed) -> StateT PitchState Deriver Transposed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
    PitchDirection
Next -> NoteNumber -> Transposed -> Transposed
forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (NoteNumber -> Transposed -> Transposed)
-> StateT PitchState Deriver NoteNumber
-> StateT PitchState Deriver (Transposed -> Transposed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn (Double -> NoteNumber)
-> StateT PitchState Deriver Double
-> StateT PitchState Deriver NoteNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PitchState -> Double) -> StateT PitchState Deriver Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Double
_next)
        StateT PitchState Deriver (Transposed -> Transposed)
-> StateT PitchState Deriver Transposed
-> StateT PitchState Deriver Transposed
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (PitchState -> Transposed) -> StateT PitchState Deriver Transposed
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 = Parser (Either Transpose Str)
-> (Either Transpose Str -> Context -> M PitchState Control)
-> PCall
forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall (ArgName -> Doc -> Parser (Either Transpose Str)
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"to" Doc
"To pitch.") ((Either Transpose Str -> Context -> M PitchState Control)
 -> PCall)
-> (Either Transpose Str -> Context -> M PitchState Control)
-> PCall
forall a b. (a -> b) -> a -> b
$
    \Either Transpose Str
arg Context
_ctx -> do
        Transpose
transpose <- Deriver State Error Transpose
-> StateT PitchState Deriver Transpose
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver State Error Transpose
 -> StateT PitchState Deriver Transpose)
-> Deriver State Error Transpose
-> StateT PitchState Deriver Transpose
forall a b. (a -> b) -> a -> b
$ Either Transpose Str -> Deriver State Error Transpose
parse_transpose Either Transpose Str
arg
        Transposed -> M PitchState ()
set_pitch (Transposed -> M PitchState ())
-> (Transposed -> Transposed) -> Transposed -> M PitchState ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transpose -> Transposed -> Transposed
forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Transpose
transpose (Transposed -> M PitchState ())
-> StateT PitchState Deriver Transposed -> M PitchState ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (PitchState -> Transposed) -> StateT PitchState Deriver Transposed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
        Control -> M PitchState Control
forall (m :: * -> *) a. Monad m => a -> m a
return Control
forall a. Monoid a => a
mempty

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

data TransitionTime = Slow | Medium | Fast deriving (Int -> TransitionTime -> ShowS
[TransitionTime] -> ShowS
TransitionTime -> [Char]
(Int -> TransitionTime -> ShowS)
-> (TransitionTime -> [Char])
-> ([TransitionTime] -> ShowS)
-> Show TransitionTime
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
(TransitionTime -> TransitionTime -> Bool)
-> (TransitionTime -> TransitionTime -> Bool) -> Eq TransitionTime
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 = Parser () -> (() -> Context -> M PitchState Control) -> PCall
forall a.
Parser a -> (a -> Context -> M PitchState Control) -> PCall
PCall Parser ()
Sig.no_args ((() -> Context -> M PitchState Control) -> PCall)
-> (() -> Context -> M PitchState Control) -> PCall
forall a b. (a -> b) -> a -> b
$ \() Context
_ctx -> do
    (PitchState -> PitchState) -> M PitchState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((PitchState -> PitchState) -> M PitchState ())
-> (PitchState -> PitchState) -> M PitchState ()
forall a b. (a -> b) -> a -> b
$ \PitchState
state -> PitchState
state { _transition :: Normalized
_transition = Normalized
ttime }
    Control -> M PitchState Control
forall (m :: * -> *) a. Monad m => a -> m a
return Control
forall a. Monoid a => a
mempty
    where
    -- TODO these could come from an environ value
    ttime :: Normalized
ttime = Double -> Normalized
Typecheck.Normalized (Double -> Normalized) -> Double -> 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) <- Context -> M PitchState (RealTime, RealTime)
forall s. Context -> M s (RealTime, RealTime)
ctx_range Context
ctx
    Transposed
from <- StateT PitchState Deriver 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 <- (PitchState -> Normalized) -> StateT PitchState Deriver Normalized
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 ((Double -> Double) -> Curve) -> (Double -> Double) -> Curve
forall a b. (a -> b) -> a -> b
$
            Double -> Double -> Double -> Double
ControlUtil.sigmoid (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
transition) (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
transition)
    Transposed -> M PitchState ()
set_pitch Transposed
to
    Transposed
swaram <- (PitchState -> Transposed) -> StateT PitchState Deriver Transposed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_swaram
    Double
from <- Deriver State Error Double -> StateT PitchState Deriver Double
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver State Error Double -> StateT PitchState Deriver Double)
-> Deriver State Error Double -> StateT PitchState Deriver Double
forall a b. (a -> b) -> a -> b
$ Transposed -> Transposed -> Deriver State Error Double
step_difference Transposed
from Transposed
swaram
    Double
to <- Deriver State Error Double -> StateT PitchState Deriver Double
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver State Error Double -> StateT PitchState Deriver Double)
-> Deriver State Error Double -> StateT PitchState Deriver Double
forall a b. (a -> b) -> a -> b
$ Transposed -> Transposed -> Deriver State Error Double
step_difference Transposed
to Transposed
swaram
    Deriver Control -> M PitchState Control
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver Control -> M PitchState Control)
-> Deriver Control -> M PitchState Control
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]
(Int -> ParsedPitch -> ShowS)
-> (ParsedPitch -> [Char])
-> ([ParsedPitch] -> ShowS)
-> Show ParsedPitch
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
(ParsedPitch -> ParsedPitch -> Bool)
-> (ParsedPitch -> ParsedPitch -> Bool) -> Eq ParsedPitch
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 Parser () -> Parser [ParsedPitch] -> Parser [ParsedPitch]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ParsedPitch -> Parser [ParsedPitch]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 (Parser Text ParsedPitch
p_expr Parser Text ParsedPitch -> Parser () -> Parser Text ParsedPitch
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 Parser Text ParsedPitch
-> Parser Text ParsedPitch -> Parser Text ParsedPitch
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 ((Char -> Bool) -> Parser Char) -> (Char -> Bool) -> Parser Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
' ' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'[' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']'
    if Char -> Bool
pitch_has_argument Char
c
        then Char -> Text -> ParsedPitch
CallArg Char
c (Text -> ParsedPitch)
-> Parser Text Text -> Parser Text ParsedPitch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
p_pitch_expr_arg
        else ParsedPitch -> Parser Text ParsedPitch
forall (m :: * -> *) a. Monad m => a -> m a
return (ParsedPitch -> Parser Text ParsedPitch)
-> ParsedPitch -> Parser Text ParsedPitch
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 ([ParsedPitch] -> ParsedPitch)
-> Parser [ParsedPitch] -> Parser Text ParsedPitch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
A.char Char
'[' Parser Char -> Parser [ParsedPitch] -> Parser [ParsedPitch]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser [ParsedPitch]
p_exprs Parser [ParsedPitch] -> Parser Char -> Parser [ParsedPitch]
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 <- Bool -> Parser Text Bool -> Parser Text Bool
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Bool
False (Char -> Parser Char
A.char Char
'-' Parser Char -> Parser Text Bool -> Parser Text Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Text Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
    Char
c <- (Char -> Bool) -> Parser Char
A.satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
' ')
    Text -> Parser Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text Text) -> Text -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ (if Bool
minus then (Text
"-"<>) else Text -> Text
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 Char -> Char -> Bool
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 = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF a)
-> Transformer a
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"sahitya" Tags
forall a. Monoid a => a
mempty
    Doc
"Ignore the transformed deriver. Put this on a track to ignore its\
    \ contents, and put in sahitya."
    (WithArgDoc (TransformerF a) -> Transformer a)
-> WithArgDoc (TransformerF a) -> Transformer a
forall a b. (a -> b) -> a -> b
$ TransformerF a -> WithArgDoc (TransformerF a)
forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t (TransformerF a -> WithArgDoc (TransformerF a))
-> TransformerF a -> WithArgDoc (TransformerF a)
forall a b. (a -> b) -> a -> b
$ \PassedArgs a
_args Deriver (Stream a)
_deriver -> Stream a -> Deriver (Stream a)
forall (m :: * -> *) a. Monad m => a -> m a
return Stream a
forall a. Stream a
Stream.empty