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

module Derive.C.India.Gamakam6 where
import qualified Control.Applicative as Applicative
import qualified Control.Monad.State as State
import qualified Data.Attoparsec.Text as A
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Util.Num as Num
import qualified Util.ParseText as ParseText
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.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
"gamakam6"

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)
        -- , (Parse.unparsed_call, 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)
        -- , ("dyn", 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)
        ]
    ]

-- * State

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

data PitchState = PitchState {
    -- # maintained automatically
    -- | Pitch of the underlying note.  The Nns below are relative to this.
    PitchState -> Transposed
_current :: !PSignal.Transposed
    -- | Current pitch value.  Starts as the pitch at the end of the previous
    -- note.
    , PitchState -> Nn
_from :: !Nn
    -- | Previous swaram.
    , PitchState -> Nn
_prev :: !Nn
    -- | Next swaram.
    , PitchState -> Nn
_next :: !Nn

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

nn_difference :: PSignal.Transposed -> PSignal.Transposed -> Derive.Deriver Nn
nn_difference :: Transposed -> Transposed -> Deriver Nn
nn_difference Transposed
p1 Transposed
p2 = (NoteNumber -> Nn) -> Deriver State Error NoteNumber -> Deriver Nn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NoteNumber -> Nn
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Deriver State Error NoteNumber -> Deriver Nn)
-> Deriver State Error NoteNumber -> Deriver Nn
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

get_pitch :: (PitchState -> Nn) -> M PSignal.Transposed
get_pitch :: (PitchState -> Nn) -> M Transposed
get_pitch PitchState -> Nn
get = do
    Nn
nn <- (PitchState -> Nn) -> StateT PitchState (Deriver State Error) Nn
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Nn
get
    Transposed
cur <- (PitchState -> Transposed) -> M Transposed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_current
    Transposed -> M Transposed
forall (m :: * -> *) a. Monad m => a -> m a
return (Transposed -> M Transposed) -> Transposed -> M Transposed
forall a b. (a -> b) -> a -> b
$ NoteNumber -> Transposed -> Transposed
forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (Nn -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn Nn
nn) Transposed
cur

-- ** initial state

initial_pitch_state :: Typecheck.Normalized
    -> Derive.PassedArgs Derive.Control
    -> Derive.Deriver (Maybe PitchState)
initial_pitch_state :: Normalized -> PassedArgs Control -> Deriver (Maybe PitchState)
initial_pitch_state 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) <- RealTime -> Deriver (Maybe Pitch, Maybe Pitch, Maybe Pitch)
get_neighbor_pitches RealTime
start
        let prev_step :: Nn
prev_step = Nn -> ((RealTime, Nn) -> Nn) -> Maybe (RealTime, Nn) -> Nn
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Nn
0 (RealTime, Nn) -> Nn
forall a b. (a, b) -> b
snd (Maybe (RealTime, Nn) -> Nn) -> Maybe (RealTime, Nn) -> Nn
forall a b. (a -> b) -> a -> b
$ PassedArgs Control -> Maybe (RealTime, Nn)
Args.prev_control PassedArgs Control
args
        let steps_from_current :: Maybe Pitch -> Deriver Nn
steps_from_current = (Maybe Nn -> Nn) -> Deriver State Error (Maybe Nn) -> Deriver Nn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Nn -> Maybe Nn -> Nn
forall a. a -> Maybe a -> a
fromMaybe Nn
0) (Deriver State Error (Maybe Nn) -> Deriver Nn)
-> (Maybe Pitch -> Deriver State Error (Maybe Nn))
-> Maybe Pitch
-> Deriver Nn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pitch -> Deriver Nn)
-> Maybe Pitch -> Deriver State Error (Maybe Nn)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                ((Transposed -> Transposed -> Deriver Nn
`nn_difference` Transposed
current) (Transposed -> Deriver Nn)
-> (Pitch -> Deriver State Error Transposed) -> Pitch -> Deriver Nn
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)
        Nn
prev <- Maybe Pitch -> Deriver Nn
steps_from_current Maybe Pitch
prev
        Nn
from <- Maybe Pitch -> Deriver Nn
steps_from_current (Maybe Pitch -> Deriver Nn) -> Maybe Pitch -> Deriver Nn
forall a b. (a -> b) -> a -> b
$
            NoteNumber -> Pitch -> Pitch
forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (Nn -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn Nn
prev_step) (Pitch -> Pitch) -> Maybe Pitch -> Maybe Pitch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Pitch
from
        Nn
next <- Maybe Pitch -> Deriver Nn
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
            { _current :: Transposed
_current = Transposed
current
            , _from :: Nn
_from = Nn
from
            , _prev :: Nn
_prev = Nn
prev
            , _next :: Nn
_next = Nn
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 :: RealTime -> Derive.Deriver
    (Maybe PSignal.Pitch, Maybe PSignal.Pitch, Maybe PSignal.Pitch)
get_neighbor_pitches :: RealTime -> Deriver (Maybe Pitch, Maybe Pitch, Maybe Pitch)
get_neighbor_pitches 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

-- * pitch 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_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)
-> ((Text, Normalized) -> 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 -> (Text, Normalized))
-> Parser Text -> Parser (Normalized -> (Text, Normalized))
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 -> (Text, Normalized))
-> Parser Normalized -> Parser (Text, Normalized)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Normalized
transition_env
    ) (((Text, Normalized) -> PassedArgs Control -> Deriver Control)
 -> WithArgDoc (PassedArgs Control -> Deriver Control))
-> ((Text, Normalized) -> PassedArgs Control -> Deriver Control)
-> WithArgDoc (PassedArgs Control -> Deriver Control)
forall a b. (a -> b) -> a -> b
$ \(Text
code, Normalized
transition) PassedArgs Control
args -> do
        ScoreTime
end <- PassedArgs Control -> Deriver ScoreTime
forall a. PassedArgs a -> Deriver ScoreTime
infer_end PassedArgs Control
args
        Maybe PitchState
maybe_state <- Normalized -> PassedArgs Control -> Deriver (Maybe PitchState)
initial_pitch_state 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
                [Control]
transpose <- ScoreTime -> Deriver [Control] -> Deriver [Control]
forall a. ScoreTime -> Deriver a -> Deriver a
Derive.at (PassedArgs Control -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Control
args) (Deriver [Control] -> Deriver [Control])
-> Deriver [Control] -> Deriver [Control]
forall a b. (a -> b) -> a -> b
$
                    PitchState -> ScoreTime -> Text -> Deriver [Control]
pitch_sequence PitchState
state (ScoreTime
end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- PassedArgs Control -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Control
args) Text
code
                -- Debug.tracepM "transpose" (Args.start args, end, transpose)
                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 ([Control] -> Control) -> [Control] -> Control
forall a b. (a -> b) -> a -> b
$ [Control]
transpose
                    [Control] -> [Control] -> [Control]
forall a. [a] -> [a] -> [a]
++ if Bool
next_gamakam then []
                        else [RealTime -> Nn -> Control
forall {k} (kind :: k). RealTime -> Nn -> Signal kind
Signal.from_sample RealTime
real_end Nn
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 (Nn -> Normalized
Typecheck.Normalized Nn
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."

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 that describes a transposition curve.\
    \ The grammar is a sequence of `Pitch Duration | ']' Pitch | Alias`.\
    \ A plain Pitch moves to that pitch, `]` Pitch sets the From running pitch\
    \ to the given Pitch, but has zero duration, and Alias is a single letter,\
    \ which is itself mapped to a sequence.\
    \\nPitch is `[=<>][+\\^v]? | #?[-9-9a-d]? [+\\^v]?`.  `=<>` are the running\
    \ From pitch, Prev pitch, or Next pitch, and [+\\^v] add or subtract\
    \ 1nn, or .5nn, respectively.  A number is steps from the current swaram,\
    \ and a-d are shorthand for -1 to -4.\
    \\nDuration is a sequence of `_` or `.`, where each one doubles or halves\
    \ the duration. `:` and `;` stand for short or long absolute duration.\
    \\nDefault aliases:\n"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines [Char -> Text
char Char
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v | (Char
k, Text
v) <- Map Char Text -> [(Char, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Char Text
aliases]
    where
    char :: Char -> Text
char Char
c = Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"

-- | 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 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 ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ScoreTime -> Deriver ScoreTime) -> ScoreTime -> Deriver 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
        Maybe ScoreTime
next_pitch <- ((RealTime, Pitch) -> Deriver ScoreTime)
-> Maybe (RealTime, Pitch) -> Deriver State Error (Maybe ScoreTime)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (RealTime -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
Derive.score (RealTime -> Deriver ScoreTime)
-> ((RealTime, Pitch) -> RealTime)
-> (RealTime, Pitch)
-> Deriver ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime, Pitch) -> RealTime
forall a b. (a, b) -> a
fst) (RealTime -> Pitch -> Maybe (RealTime, Pitch)
next_sample RealTime
start Pitch
pitch)
        let next :: ScoreTime
next = PassedArgs a -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.next PassedArgs a
args
        ScoreTime -> Deriver ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ScoreTime -> Deriver ScoreTime) -> ScoreTime -> Deriver ScoreTime
forall a b. (a -> b) -> a -> b
$ ScoreTime
-> (ScoreTime -> ScoreTime) -> Maybe ScoreTime -> ScoreTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScoreTime
next (ScoreTime -> ScoreTime -> ScoreTime
forall a. Ord a => a -> a -> a
min ScoreTime
next) Maybe ScoreTime
next_pitch

pitch_sequence :: PitchState -> ScoreTime -> Code
    -> Derive.Deriver [Signal.Control]
pitch_sequence :: PitchState -> ScoreTime -> Text -> Deriver [Control]
pitch_sequence PitchState
state ScoreTime
total_dur Text
code = do
    [Either Alias Call]
calls <- (Text -> Text)
-> Either Text [Either Alias Call] -> Deriver [Either Alias Call]
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
code Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) (Either Text [Either Alias Call] -> Deriver [Either Alias Call])
-> Either Text [Either Alias Call] -> Deriver [Either Alias Call]
forall a b. (a -> b) -> a -> b
$
        Text -> Either Text [Either Alias Call]
parse Text
code
    [Call]
calls <- (Text -> Text) -> Either Text [Call] -> Deriver [Call]
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right Text -> Text
forall a. a -> a
id (Either Text [Call] -> Deriver [Call])
-> Either Text [Call] -> Deriver [Call]
forall a b. (a -> b) -> a -> b
$ [Either Alias Call] -> Either Text [Call]
resolve_aliases [Either Alias Call]
calls
    [RealTime]
starts <- (ScoreTime -> Deriver RealTime)
-> [ScoreTime] -> Deriver State Error [RealTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real ([ScoreTime] -> Deriver State Error [RealTime])
-> [ScoreTime] -> Deriver State Error [RealTime]
forall a b. (a -> b) -> a -> b
$ ScoreTime -> [Nn] -> [ScoreTime]
slice_time ScoreTime
total_dur ([Nn] -> [ScoreTime]) -> [Nn] -> [ScoreTime]
forall a b. (a -> b) -> a -> b
$ (Call -> Nn) -> [Call] -> [Nn]
forall a b. (a -> b) -> [a] -> [b]
map Call -> Nn
call_duration [Call]
calls
    let ranges :: [(RealTime, RealTime)]
ranges = [RealTime] -> [RealTime] -> [(RealTime, RealTime)]
forall a b. [a] -> [b] -> [(a, b)]
zip [RealTime]
starts (Int -> [RealTime] -> [RealTime]
forall a. Int -> [a] -> [a]
drop Int
1 [RealTime]
starts)
    ([Control]
sigs, PitchState
_) <- StateT PitchState (Deriver State Error) [Control]
-> PitchState -> Deriver State Error ([Control], PitchState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT ((((RealTime, RealTime), Call)
 -> StateT PitchState (Deriver State Error) Control)
-> [((RealTime, RealTime), Call)]
-> StateT PitchState (Deriver State Error) [Control]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((RealTime, RealTime), Call)
-> StateT PitchState (Deriver State Error) Control
eval_call ([(RealTime, RealTime)] -> [Call] -> [((RealTime, RealTime), Call)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(RealTime, RealTime)]
ranges [Call]
calls)) PitchState
state
    [Control] -> Deriver [Control]
forall (m :: * -> *) a. Monad m => a -> m a
return [Control]
sigs

slice_time :: ScoreTime -> [Double] -> [ScoreTime]
slice_time :: ScoreTime -> [Nn] -> [ScoreTime]
slice_time ScoreTime
dur [Nn]
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
$ (Nn -> ScoreTime) -> [Nn] -> [ScoreTime]
forall a b. (a -> b) -> [a] -> [b]
map ((ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
*ScoreTime
one) (ScoreTime -> ScoreTime) -> (Nn -> ScoreTime) -> Nn -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nn -> ScoreTime
ScoreTime.from_double) [Nn]
slices
    where one :: ScoreTime
one = ScoreTime
dur ScoreTime -> ScoreTime -> ScoreTime
forall a. Fractional a => a -> a -> a
/ Nn -> ScoreTime
ScoreTime.from_double ([Nn] -> Nn
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [Nn]
slices)

eval_call :: ((RealTime, RealTime), Call) -> M Signal.Control
eval_call :: ((RealTime, RealTime), Call)
-> StateT PitchState (Deriver State Error) Control
eval_call ((RealTime
start, RealTime
end), Call
call) = case Call
call of
    SetFrom Pitch
pitch -> do
        Transposed -> M ()
set_from (Transposed -> M ()) -> M Transposed -> M ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pitch -> M Transposed
resolve_pitch Pitch
pitch
        Control -> StateT PitchState (Deriver State Error) Control
forall (m :: * -> *) a. Monad m => a -> m a
return Control
forall a. Monoid a => a
mempty
    Move (Movement Pitch
to Duration
_) -> do
        Transposed
to <- Pitch -> M Transposed
resolve_pitch Pitch
to
        Transposed
from <- (PitchState -> Nn) -> M Transposed
get_pitch PitchState -> Nn
_from
        Transposed -> M ()
set_from Transposed
to
        RealTime
-> Transposed
-> RealTime
-> Transposed
-> StateT PitchState (Deriver State Error) Control
move_pitch RealTime
start Transposed
from RealTime
end Transposed
to

set_from :: PSignal.Transposed -> M ()
set_from :: Transposed -> M ()
set_from Transposed
pitch = do
    Transposed
cur <- (PitchState -> Transposed) -> M Transposed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_current
    Nn
nn <- Deriver Nn -> StateT PitchState (Deriver State Error) Nn
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Deriver Nn -> StateT PitchState (Deriver State Error) Nn)
-> Deriver Nn -> StateT PitchState (Deriver State Error) Nn
forall a b. (a -> b) -> a -> b
$ Transposed -> Transposed -> Deriver Nn
nn_difference Transposed
pitch Transposed
cur
    (PitchState -> PitchState) -> M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' ((PitchState -> PitchState) -> M ())
-> (PitchState -> PitchState) -> M ()
forall a b. (a -> b) -> a -> b
$ \PitchState
state -> PitchState
state { _from :: Nn
_from = Nn
nn }

resolve_pitch :: Pitch -> M PSignal.Transposed
resolve_pitch :: Pitch -> M Transposed
resolve_pitch (Pitch From
from Int
steps Nn
nn) = do
    Transposed
base <- case From
from of
        From
Current -> (PitchState -> Transposed) -> M Transposed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_current
        From
From -> (PitchState -> Nn) -> M Transposed
get_pitch PitchState -> Nn
_from
        From
Prev -> (PitchState -> Nn) -> M Transposed
get_pitch PitchState -> Nn
_prev
        From
Next -> (PitchState -> Nn) -> M Transposed
get_pitch PitchState -> Nn
_next
    Transposed -> M Transposed
forall (m :: * -> *) a. Monad m => a -> m a
return (Transposed -> M Transposed) -> Transposed -> M Transposed
forall a b. (a -> b) -> a -> b
$ (Int -> Transposed -> Transposed)
-> Int -> Transposed -> Transposed
forall {t} {a}. (Eq t, Num t) => (t -> a -> a) -> t -> a -> a
apply (Transpose -> Transposed -> Transposed
forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose (Transpose -> Transposed -> Transposed)
-> (Int -> Transpose) -> Int -> Transposed -> Transposed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nn -> Transpose
Pitch.Diatonic (Nn -> Transpose) -> (Int -> Nn) -> Int -> Transpose
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Nn
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Int
steps (Transposed -> Transposed) -> Transposed -> Transposed
forall a b. (a -> b) -> a -> b
$
        (NoteNumber -> Transposed -> Transposed)
-> NoteNumber -> Transposed -> Transposed
forall {t} {a}. (Eq t, Num t) => (t -> a -> a) -> t -> a -> a
apply NoteNumber -> Transposed -> Transposed
forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (Nn -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn Nn
nn) (Transposed -> Transposed) -> Transposed -> Transposed
forall a b. (a -> b) -> a -> b
$
        Transposed
base
    where
    apply :: (t -> a -> a) -> t -> a -> a
apply t -> a -> a
f t
n
        | t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = a -> a
forall a. a -> a
id
        | Bool
otherwise = t -> a -> a
f t
n

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

-- * aliases

type Error = Text

resolve_aliases :: [Either Alias Call] -> Either Error [Call]
resolve_aliases :: [Either Alias Call] -> Either Text [Call]
resolve_aliases = (Either Alias Call -> Either Text [Call])
-> [Either Alias Call] -> Either Text [Call]
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (Integer -> Either Alias Call -> Either Text [Call]
forall {t}.
(Ord t, Num t) =>
t -> Either Alias Call -> Either Text [Call]
resolve Integer
0)
    where
    resolve :: t -> Either Alias Call -> Either Text [Call]
resolve t
_ (Right Call
call) = [Call] -> Either Text [Call]
forall (m :: * -> *) a. Monad m => a -> m a
return [Call
call]
    resolve t
depth (Left (Alias Char
alias))
        | t
depth t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
5 = Text -> Either Text [Call]
forall a b. a -> Either a b
Left Text
"too many levels of aliases"
        | Bool
otherwise = do
            Text
expr <- Text -> Maybe Text -> Either Text Text
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"unknown alias: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
forall a. Show a => a -> Text
showt Char
alias) (Maybe Text -> Either Text Text) -> Maybe Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$
                Char -> Map Char Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
alias Map Char Text
aliases
            [Either Alias Call]
calls <- (Text -> Text)
-> Either Text [Either Alias Call]
-> Either Text [Either Alias Call]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"in alias " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
forall a. Show a => a -> Text
showt Char
alias Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) (Either Text [Either Alias Call]
 -> Either Text [Either Alias Call])
-> Either Text [Either Alias Call]
-> Either Text [Either Alias Call]
forall a b. (a -> b) -> a -> b
$ Text -> Either Text [Either Alias Call]
parse Text
expr
            (Either Alias Call -> Either Text [Call])
-> [Either Alias Call] -> Either Text [Call]
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (t -> Either Alias Call -> Either Text [Call]
resolve (t
deptht -> t -> t
forall a. Num a => a -> a -> a
+t
1)) [Either Alias Call]
calls

aliases :: Map Char Text
aliases :: Map Char Text
aliases = [(Char, Text)] -> Map Char Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Char
'C', Text
"]0")
    , (Char
'N', Text
"#0+.#0\\")
    , (Char
'U', Text
"#0\\.#0+.")
    , (Char
'n', Text
"#0^.#0v.")
    , (Char
'u', Text
"#0v.#0^.")
    ]

-- * call types

type Parser a = A.Parser a

data Call = SetFrom !Pitch | Move !Movement
    deriving (Call -> Call -> Bool
(Call -> Call -> Bool) -> (Call -> Call -> Bool) -> Eq Call
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Call -> Call -> Bool
$c/= :: Call -> Call -> Bool
== :: Call -> Call -> Bool
$c== :: Call -> Call -> Bool
Eq, Int -> Call -> ShowS
[Call] -> ShowS
Call -> String
(Int -> Call -> ShowS)
-> (Call -> String) -> ([Call] -> ShowS) -> Show Call
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Call] -> ShowS
$cshowList :: [Call] -> ShowS
show :: Call -> String
$cshow :: Call -> String
showsPrec :: Int -> Call -> ShowS
$cshowsPrec :: Int -> Call -> ShowS
Show)

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

data Movement = Movement !Pitch !Duration
    deriving (Movement -> Movement -> Bool
(Movement -> Movement -> Bool)
-> (Movement -> Movement -> Bool) -> Eq Movement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Movement -> Movement -> Bool
$c/= :: Movement -> Movement -> Bool
== :: Movement -> Movement -> Bool
$c== :: Movement -> Movement -> Bool
Eq, Int -> Movement -> ShowS
[Movement] -> ShowS
Movement -> String
(Int -> Movement -> ShowS)
-> (Movement -> String) -> ([Movement] -> ShowS) -> Show Movement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Movement] -> ShowS
$cshowList :: [Movement] -> ShowS
show :: Movement -> String
$cshow :: Movement -> String
showsPrec :: Int -> Movement -> ShowS
$cshowsPrec :: Int -> Movement -> ShowS
Show)

data Pitch = Pitch !From !Steps !Nn
    deriving (Pitch -> Pitch -> Bool
(Pitch -> Pitch -> Bool) -> (Pitch -> Pitch -> Bool) -> Eq Pitch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pitch -> Pitch -> Bool
$c/= :: Pitch -> Pitch -> Bool
== :: Pitch -> Pitch -> Bool
$c== :: Pitch -> Pitch -> Bool
Eq, Int -> Pitch -> ShowS
[Pitch] -> ShowS
Pitch -> String
(Int -> Pitch -> ShowS)
-> (Pitch -> String) -> ([Pitch] -> ShowS) -> Show Pitch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pitch] -> ShowS
$cshowList :: [Pitch] -> ShowS
show :: Pitch -> String
$cshow :: Pitch -> String
showsPrec :: Int -> Pitch -> ShowS
$cshowsPrec :: Int -> Pitch -> ShowS
Show)
data From = From | Prev | Current | Next
    deriving (From -> From -> Bool
(From -> From -> Bool) -> (From -> From -> Bool) -> Eq From
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: From -> From -> Bool
$c/= :: From -> From -> Bool
== :: From -> From -> Bool
$c== :: From -> From -> Bool
Eq, Int -> From -> ShowS
[From] -> ShowS
From -> String
(Int -> From -> ShowS)
-> (From -> String) -> ([From] -> ShowS) -> Show From
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [From] -> ShowS
$cshowList :: [From] -> ShowS
show :: From -> String
$cshow :: From -> String
showsPrec :: Int -> From -> ShowS
$cshowsPrec :: Int -> From -> ShowS
Show)
-- | Relative scale degrees.
type Steps = Int
-- | Relative NoteNumbers.
type Nn = Double

-- | How much time the movement takes.
data Duration = Relative !Double | AbsoluteShort | AbsoluteLong
    deriving (Duration -> Duration -> Bool
(Duration -> Duration -> Bool)
-> (Duration -> Duration -> Bool) -> Eq Duration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Duration -> Duration -> Bool
$c/= :: Duration -> Duration -> Bool
== :: Duration -> Duration -> Bool
$c== :: Duration -> Duration -> Bool
Eq, Int -> Duration -> ShowS
[Duration] -> ShowS
Duration -> String
(Int -> Duration -> ShowS)
-> (Duration -> String) -> ([Duration] -> ShowS) -> Show Duration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Duration] -> ShowS
$cshowList :: [Duration] -> ShowS
show :: Duration -> String
$cshow :: Duration -> String
showsPrec :: Int -> Duration -> ShowS
$cshowsPrec :: Int -> Duration -> ShowS
Show)

-- | Text representing unparsed Calls.
type Code = Text

call_duration :: Call -> Double
call_duration :: Call -> Nn
call_duration (SetFrom Pitch
_) = Nn
0
call_duration (Move (Movement Pitch
_ Duration
dur)) = case Duration
dur of
    Relative Nn
dur -> Nn
dur
    -- TODO not implemented
    Duration
AbsoluteLong -> Nn
1
    Duration
AbsoluteShort -> Nn
1

-- * parse

parse :: Code -> Either Text [Either Alias Call]
parse :: Text -> Either Text [Either Alias Call]
parse = Parser [Either Alias Call]
-> Text -> Either Text [Either Alias Call]
forall a. Parser a -> Text -> Either Text a
ParseText.parse1 Parser [Either Alias Call]
p_calls

p_calls :: Parser [Either Alias Call]
p_calls :: Parser [Either Alias Call]
p_calls = Parser Text (Either Alias Call) -> Parser [Either Alias Call]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Applicative.many (Parser Text (Either Alias Call) -> Parser [Either Alias Call])
-> Parser Text (Either Alias Call) -> Parser [Either Alias Call]
forall a b. (a -> b) -> a -> b
$
    Alias -> Either Alias Call
forall a b. a -> Either a b
Left (Alias -> Either Alias Call)
-> Parser Text Alias -> Parser Text (Either Alias Call)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Alias
p_alias
    Parser Text (Either Alias Call)
-> Parser Text (Either Alias Call)
-> Parser Text (Either Alias Call)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Call -> Either Alias Call
forall a b. b -> Either a b
Right (Call -> Either Alias Call)
-> Parser Text Call -> Parser Text (Either Alias Call)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text Call
p_set_from Parser Text Call -> Parser Text Call -> Parser Text Call
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Movement -> Call
Move (Movement -> Call) -> Parser Text Movement -> Parser Text Call
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Movement
p_movement)

p_set_from :: Parser Call
p_set_from :: Parser Text Call
p_set_from = Pitch -> Call
SetFrom (Pitch -> Call) -> Parser Text Pitch -> Parser Text Call
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
A.char Char
']' Parser Char -> Parser Text Pitch -> Parser Text Pitch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Pitch
p_pitch)

p_alias :: Parser Alias
p_alias :: Parser Text Alias
p_alias = Char -> Alias
Alias (Char -> Alias) -> Parser Char -> Parser Text Alias
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Char
A.satisfy Char -> Bool
is_alias
    where
    is_alias :: Char -> Bool
is_alias Char
c = Char
last_letter_negative 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'
        Bool -> Bool -> Bool
|| 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'

p_movement :: Parser Movement
p_movement :: Parser Text Movement
p_movement = Pitch -> Duration -> Movement
Movement (Pitch -> Duration -> Movement)
-> Parser Text Pitch -> Parser Text (Duration -> Movement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Pitch
p_pitch Parser Text (Duration -> Movement)
-> Parser Text Duration -> Parser Text Movement
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Duration
p_duration

p_duration :: Parser Duration
p_duration :: Parser Text Duration
p_duration = Parser Text Duration
p_longer Parser Text Duration
-> Parser Text Duration -> Parser Text Duration
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Duration
p_shorter
    Parser Text Duration
-> Parser Text Duration -> Parser Text Duration
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(Char, Duration)] -> Parser Text Duration
forall a. [(Char, a)] -> Parser a
choose_char [(Char
':', Duration
AbsoluteShort), (Char
';', Duration
AbsoluteLong)]
    Parser Text Duration
-> Parser Text Duration -> Parser Text Duration
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Duration -> Parser Text Duration
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nn -> Duration
Relative Nn
1)
    where
    p_longer :: Parser Text Duration
p_longer = do
        Text
n <- (Char -> Bool) -> Parser Text
A.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_')
        Duration -> Parser Text Duration
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> Parser Text Duration)
-> Duration -> Parser Text Duration
forall a b. (a -> b) -> a -> b
$ Nn -> Duration
Relative (Nn -> Duration) -> Nn -> Duration
forall a b. (a -> b) -> a -> b
$ Int -> Nn
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Nn) -> Int -> Nn
forall a b. (a -> b) -> a -> b
$ Text -> Int
Text.length Text
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    p_shorter :: Parser Text Duration
p_shorter = do
        Text
n <- (Char -> Bool) -> Parser Text
A.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.')
        Duration -> Parser Text Duration
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> Parser Text Duration)
-> Duration -> Parser Text Duration
forall a b. (a -> b) -> a -> b
$ Nn -> Duration
Relative (Nn -> Duration) -> Nn -> Duration
forall a b. (a -> b) -> a -> b
$ Nn
1 Nn -> Nn -> Nn
forall a. Fractional a => a -> a -> a
/ Nn
2Nn -> Integer -> Nn
forall a b. (Num a, Integral b) => a -> b -> a
^(Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Text.length Text
n))

-- | [=<>] [+\^v]? | #?[0-9a-d]? [+\^v]?
p_pitch :: Parser Pitch
p_pitch :: Parser Text Pitch
p_pitch = do
    (Text
matched, Pitch
pitch) <- Parser Text Pitch -> Parser (Text, Pitch)
forall a. Parser a -> Parser (Text, a)
A.match (Parser Text Pitch -> Parser (Text, Pitch))
-> Parser Text Pitch -> Parser (Text, Pitch)
forall a b. (a -> b) -> a -> b
$ Parser Text Pitch
p_pitch_from
        Parser Text Pitch -> Parser Text Pitch -> Parser Text Pitch
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (From -> Int -> Nn -> Pitch
Pitch (From -> Int -> Nn -> Pitch)
-> Parser Text From -> Parser Text (Int -> Nn -> Pitch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text From
p_from Parser Text (Int -> Nn -> Pitch)
-> Parser Text Int -> Parser Text (Nn -> Pitch)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Text Int
p_steps Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0) Parser Text (Nn -> Pitch) -> Parser Text Nn -> Parser Text Pitch
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Nn
p_nn)
    Bool -> Parser Text () -> Parser Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
Text.null Text
matched) (Parser Text () -> Parser Text ())
-> Parser Text () -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ String -> Parser Text ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty pitch"
    Pitch -> Parser Text Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return Pitch
pitch

p_pitch_from :: Parser Pitch
p_pitch_from :: Parser Text Pitch
p_pitch_from = From -> Int -> Nn -> Pitch
Pitch (From -> Int -> Nn -> Pitch)
-> Parser Text From -> Parser Text (Int -> Nn -> Pitch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text From
from Parser Text (Int -> Nn -> Pitch)
-> Parser Text Int -> Parser Text (Nn -> Pitch)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0 Parser Text (Nn -> Pitch) -> Parser Text Nn -> Parser Text Pitch
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Nn
p_nn
    where
    from :: Parser Text From
from = [(Char, From)] -> Parser Text From
forall a. [(Char, a)] -> Parser a
choose_char
        [ (Char
'=', From
From)
        , (Char
'<', From
Prev)
        , (Char
'>', From
Next)
        ]

p_steps :: Parser Steps
p_steps :: Parser Text Int
p_steps = Parser Text Int
p_number Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Int
p_letter_negative

p_nn :: Parser Nn
p_nn :: Parser Text Nn
p_nn = [(Char, Nn)] -> Parser Text Nn
forall a. [(Char, a)] -> Parser a
choose_char
    [ (Char
'+', Nn
1)
    , (Char
'\\', -Nn
1)
    , (Char
'^', Nn
0.5)
    , (Char
'v', -Nn
0.5)
    ] Parser Text Nn -> Parser Text Nn -> Parser Text Nn
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Nn -> Parser Text Nn
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nn
0
-- TODO alternately, ^v and ',.  But , looks a lot like .
-- or maybe {} and []?  No, ] is taken.
-- +? and ^v?
-- p_nn = choose_char
--     [ ('^', 1)
--     , ('v', -1)
--     , ('\'', 0.5)
--     , (',', -0.5)
--     ] <|> pure 0

p_from :: Parser From
p_from :: Parser Text From
p_from = From -> Parser Text From -> Parser Text From
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option From
Current (Char -> Parser Char
A.char Char
'#' Parser Char -> Parser Text From -> Parser Text From
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> From -> Parser Text From
forall (f :: * -> *) a. Applicative f => a -> f a
pure From
From)

p_number :: Parser Int
p_number :: Parser Text Int
p_number = do
    Int
sign <- Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Int
1 (Char -> Parser Char
A.char Char
'-' Parser Char -> Parser Text Int -> Parser Text Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Parser Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
1))
    Char
digit <- (Char -> Bool) -> Parser Char
A.satisfy ((Char -> Bool) -> Parser Char) -> (Char -> Bool) -> Parser Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
'0' 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
'9'
    Int -> Parser Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Text Int) -> Int -> Parser Text Int
forall a b. (a -> b) -> a -> b
$ Int
sign Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
digit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0')

p_letter_negative :: Parser Int
p_letter_negative :: Parser Text Int
p_letter_negative = do
    Char
digit <- (Char -> Bool) -> Parser Char
A.satisfy ((Char -> Bool) -> Parser Char) -> (Char -> Bool) -> Parser Char
forall a b. (a -> b) -> a -> b
$ \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
last_letter_negative
    Int -> Parser Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Text Int) -> Int -> Parser Text Int
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
digit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

last_letter_negative :: Char
last_letter_negative :: Char
last_letter_negative = Char
'd'

choose_char :: [(Char, a)] -> Parser a
choose_char :: forall a. [(Char, a)] -> Parser a
choose_char = [Parser Text a] -> Parser Text a
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice ([Parser Text a] -> Parser Text a)
-> ([(Char, a)] -> [Parser Text a]) -> [(Char, a)] -> Parser Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char, a) -> Parser Text a) -> [(Char, a)] -> [Parser Text a]
forall a b. (a -> b) -> [a] -> [b]
map (\(Char
c, a
a) -> Char -> Parser Char
A.char Char
c Parser Char -> Parser Text a -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)


-- * 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"
    Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" 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