-- 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.Lists as Lists
import qualified Util.Num as Num
import qualified Util.ParseText as ParseText
import qualified Util.Segment as Segment

import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.Module as Module
import qualified Derive.Derive as Derive
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Parse as Parse
import qualified Derive.Pitches as Pitches
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

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

import           Global
import           Types


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

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

-- * 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
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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Real a, Fractional b) => a -> b
realToFrac forall a b. (a -> b) -> a -> b
$
    (-) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transposed -> Deriver State Error NoteNumber
Pitches.pitch_nn Transposed
p1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Transposed -> Deriver State Error NoteNumber
Pitches.pitch_nn Transposed
p2

get_pitch :: (PitchState -> Nn) -> M PSignal.Transposed
get_pitch :: (PitchState -> Nn) -> M Transposed
get_pitch PitchState -> Nn
get = do
    Nn
nn <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Nn
get
    Transposed
cur <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_current
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (forall a. Real a => a -> NoteNumber
Pitch.nn 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 <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args
    -- If there's no pitch then this is likely at the edge of a slice, and can
    -- be ignored.  TODO I think?
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (RealTime -> Deriver (Maybe Transposed)
lookup_pitch RealTime
start) forall a b. (a -> b) -> a -> b
$ \Transposed
current -> do
        (Maybe Pitch
prev, Maybe Pitch
next, Maybe Pitch
from) <- RealTime -> Deriver (Maybe Pitch, Maybe Pitch, Maybe Pitch)
get_neighbor_pitches RealTime
start
        let prev_step :: Nn
prev_step = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Nn
0 forall a b. (a, b) -> b
snd 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe Nn
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                ((Transposed -> Transposed -> Deriver Nn
`nn_difference` Transposed
current) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start)
        Nn
prev <- Maybe Pitch -> Deriver Nn
steps_from_current Maybe Pitch
prev
        Nn
from <- Maybe Pitch -> Deriver Nn
steps_from_current forall a b. (a -> b) -> a -> b
$
            forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (forall a. Real a => a -> NoteNumber
Pitch.nn Nn
prev_step) 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

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PitchState
            { _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 (Maybe Transposed)
lookup_pitch = RealTime -> Deriver (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 = Pitch -> RealTime -> Maybe Pitch
PSignal.at_negative Pitch
pitch RealTime
start
    let next :: Maybe Pitch
next = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Pitch -> Maybe (RealTime, Pitch)
next_sample RealTime
start Pitch
pitch
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pitch
prev, Maybe Pitch
next, Maybe Pitch
prev)

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

-- * pitch sequence

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

c_pitch_sequence :: Derive.Generator Derive.Control
c_pitch_sequence :: Generator Control
c_pitch_sequence = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 (Module
module_ forall a. Semigroup a => a -> a -> a
<> Module
"pitch")
    CallName
"sequence" forall a. Monoid a => a
mempty Doc
pitch_sequence_doc
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"sequence" Doc
"Pitch calls."
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Normalized
transition_env
    ) forall a b. (a -> b) -> a -> b
$ \(Text
code, Normalized
transition) PassedArgs Control
args -> do
        ScoreTime
end <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
            Just PitchState
state -> do
                [Control]
transpose <- forall a. ScoreTime -> Deriver a -> Deriver a
Derive.at (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Control
args) forall a b. (a -> b) -> a -> b
$
                    PitchState -> ScoreTime -> Text -> Deriver [Control]
pitch_sequence PitchState
state (ScoreTime
end forall a. Num a => a -> a -> a
- forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Control
args) Text
code
                -- Debug.tracepM "transpose" (Args.start args, end, transpose)
                RealTime
real_end <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
                -- End is the next pitch sample.  So if the next event
                -- coincides with or precedes it, it will want to come from
                -- this pitch, so don't append a 0.  Otherwise, the pitch is
                -- not "attached" to a gamakam, so I add a 0, otherwise it's
                -- out of tune.
                --
                -- I have to subtract ScoreTime.eta because the pitch sample
                -- has been warped back from RealTime, so it will lose some
                -- precision.  TODO ugh.
                let next_gamakam :: Bool
next_gamakam = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
                        ((forall a. Ord a => a -> a -> Bool
<=ScoreTime
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract ScoreTime
ScoreTime.eta) (forall a. PassedArgs a -> Maybe ScoreTime
next_event PassedArgs Control
args)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ [Control]
transpose
                    forall a. [a] -> [a] -> [a]
++ if Bool
next_gamakam then []
                        else [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 =
        forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"transition" EnvironDefault
Sig.Both (Nn -> Normalized
Typecheck.Normalized Nn
0.5) forall a b. (a -> b) -> a -> b
$
            Doc
"Time for each pitch movement, in proportion of the total time"
            forall a. Semigroup a => a -> a -> a
<> Doc
" available."

pitch_sequence_doc :: Doc.Doc
pitch_sequence_doc :: Doc
pitch_sequence_doc = Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$
    Text
"This is a mini-language 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"
    forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines [Char -> Text
char Char
k forall a. Semigroup a => a -> a -> a
<> Text
" - " forall a. Semigroup a => a -> a -> a
<> Text
v | (Char
k, Text
v) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Char Text
aliases]
    where
    char :: Char -> Text
char Char
c = Text
"`" forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
c 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> ScoreTime
Event.start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PassedArgs a -> [Event]
Args.next_events

-- | Infer the end time for the gamakam as the next pitch in the pitch signal,
-- which should correspond to the next explicit swaram.
infer_end :: Derive.PassedArgs a -> Derive.Deriver TrackTime
infer_end :: forall a. PassedArgs a -> Deriver ScoreTime
infer_end PassedArgs a
args
    | forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs a
args forall a. Eq a => a -> a -> Bool
/= forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs a
args
    | Bool
otherwise = do
        Pitch
pitch <- Deriver Pitch
Derive.get_pitch
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs a
args
        Maybe ScoreTime
next_pitch <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a. Time a => a -> Deriver ScoreTime
Derive.score forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (RealTime -> Pitch -> Maybe (RealTime, Pitch)
next_sample RealTime
start Pitch
pitch)
        let next :: ScoreTime
next = forall a. PassedArgs a -> ScoreTime
Args.next PassedArgs a
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScoreTime
next (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 <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right ((Text
"parsing " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
code forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) forall a b. (a -> b) -> a -> b
$
        Text -> Either Text [Either Alias Call]
parse Text
code
    [Call]
calls <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [Either Alias Call] -> Either Text [Call]
resolve_aliases [Either Alias Call]
calls
    [RealTime]
starts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ ScoreTime -> [Nn] -> [ScoreTime]
slice_time ScoreTime
total_dur forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Call -> Nn
call_duration [Call]
calls
    let ranges :: [(RealTime, RealTime)]
ranges = forall a b. [a] -> [b] -> [(a, b)]
zip [RealTime]
starts (forall a. Int -> [a] -> [a]
drop Int
1 [RealTime]
starts)
    ([Control]
sigs, PitchState
_) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((RealTime, RealTime), Call) -> M Control
eval_call (forall a b. [a] -> [b] -> [(a, b)]
zip [(RealTime, RealTime)]
ranges [Call]
calls)) PitchState
state
    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 =
    forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) ScoreTime
0 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
*ScoreTime
one) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nn -> ScoreTime
ScoreTime.from_double) [Nn]
slices
    where one :: ScoreTime
one = ScoreTime
dur forall a. Fractional a => a -> a -> a
/ Nn -> ScoreTime
ScoreTime.from_double (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) -> M Control
eval_call ((RealTime
start, RealTime
end), Call
call) = case Call
call of
    SetFrom Pitch
pitch -> do
        Transposed -> StateT PitchState (Deriver State Error) ()
set_from forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pitch -> M Transposed
resolve_pitch Pitch
pitch
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> StateT PitchState (Deriver State Error) ()
set_from Transposed
to
        RealTime -> Transposed -> RealTime -> Transposed -> M Control
move_pitch RealTime
start Transposed
from RealTime
end Transposed
to

set_from :: PSignal.Transposed -> M ()
set_from :: Transposed -> StateT PitchState (Deriver State Error) ()
set_from Transposed
pitch = do
    Transposed
cur <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_current
    Nn
nn <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Transposed -> Transposed -> Deriver Nn
nn_difference Transposed
pitch Transposed
cur
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' 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 -> 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {t} {a}. (Eq t, Num t) => (t -> a -> a) -> t -> a -> a
apply (forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nn -> Transpose
Pitch.Diatonic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) Int
steps forall a b. (a -> b) -> a -> b
$
        forall {t} {a}. (Eq t, Num t) => (t -> a -> a) -> t -> a -> a
apply forall a. NoteNumber -> RawPitch a -> RawPitch a
Pitches.transpose_nn (forall a. Real a => a -> NoteNumber
Pitch.nn Nn
nn) 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 forall a. Eq a => a -> a -> Bool
== t
0 = 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 -> M Control
move_pitch RealTime
start Transposed
from RealTime
end Transposed
to = do
    Typecheck.Normalized Nn
transition <- 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 forall a b. (a -> b) -> a -> b
$
            Nn -> Nn -> Nn -> Nn
ControlUtil.sigmoid (Nn
1forall a. Num a => a -> a -> a
-Nn
transition) (Nn
1forall a. Num a => a -> a -> a
-Nn
transition)
    Transposed
cur <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets PitchState -> Transposed
_current
    Nn
from <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Transposed -> Transposed -> Deriver Nn
nn_difference Transposed
from Transposed
cur
    Nn
to <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Transposed -> Transposed -> Deriver Nn
nn_difference Transposed
to Transposed
cur
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 = forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (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) = forall (m :: * -> *) a. Monad m => a -> m a
return [Call
call]
    resolve t
depth (Left (Alias Char
alias))
        | t
depth forall a. Ord a => a -> a -> Bool
>= t
5 = forall a b. a -> Either a b
Left Text
"too many levels of aliases"
        | Bool
otherwise = do
            Text
expr <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"unknown alias: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Char
alias) forall a b. (a -> b) -> a -> b
$
                forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
alias Map Char Text
aliases
            [Either Alias Call]
calls <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"in alias " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Char
alias forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) forall a b. (a -> b) -> a -> b
$ Text -> Either Text [Either Alias Call]
parse Text
expr
            forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (t -> Either Alias Call -> Either Text [Call]
resolve (t
depthforall a. Num a => a -> a -> a
+t
1)) [Either Alias Call]
calls

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

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

p_alias :: Parser Alias
p_alias :: Parser Alias
p_alias = Char -> Alias
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 forall a. Ord a => a -> a -> Bool
< Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z'
        Bool -> Bool -> Bool
|| Char
'A' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'Z'

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

p_duration :: Parser Duration
p_duration :: Parser Duration
p_duration = Parser Duration
p_longer forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Duration
p_shorter
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. [(Char, a)] -> Parser a
choose_char [(Char
':', Duration
AbsoluteShort), (Char
';', Duration
AbsoluteLong)]
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nn -> Duration
Relative Nn
1)
    where
    p_longer :: Parser Duration
p_longer = do
        Text
n <- (Char -> Bool) -> Parser Text
A.takeWhile1 (forall a. Eq a => a -> a -> Bool
==Char
'_')
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Nn -> Duration
Relative forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Text -> Int
Text.length Text
n forall a. Num a => a -> a -> a
+ Int
1
    p_shorter :: Parser Duration
p_shorter = do
        Text
n <- (Char -> Bool) -> Parser Text
A.takeWhile1 (forall a. Eq a => a -> a -> Bool
==Char
'.')
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Nn -> Duration
Relative forall a b. (a -> b) -> a -> b
$ Nn
1 forall a. Fractional a => a -> a -> a
/ Nn
2forall a b. (Num a, Integral b) => a -> b -> a
^(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) <- forall a. Parser a -> Parser (Text, a)
A.match forall a b. (a -> b) -> a -> b
$ Parser Text Pitch
p_pitch_from
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (From -> Int -> Nn -> Pitch
Pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser From
p_from forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Text Int
p_steps forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Nn
p_nn)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
Text.null Text
matched) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser From
from forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Nn
p_nn
    where
    from :: Parser From
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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Int
p_letter_negative

p_nn :: Parser Nn
p_nn :: Parser Nn
p_nn = forall a. [(Char, a)] -> Parser a
choose_char
    [ (Char
'+', Nn
1)
    , (Char
'\\', -Nn
1)
    , (Char
'^', Nn
0.5)
    , (Char
'v', -Nn
0.5)
    ] forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 From
p_from = forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option From
Current (Char -> Parser Char
A.char Char
'#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Int
1 (Char -> Parser Char
A.char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
1))
    Char
digit <- (Char -> Bool) -> Parser Char
A.satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
'0' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
sign forall a. Num a => a -> a -> a
* (forall a. Enum a => a -> Int
fromEnum Char
digit forall a. Num a => a -> a -> a
- 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 forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
'a' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
last_letter_negative
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum Char
'a' forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum Char
digit 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 = forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Char
c, a
a) -> Char -> Parser Char
A.char Char
c forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"sahitya" forall a. Monoid a => a
mempty
    (Doc
"Ignore the transformed deriver. Put this on a track to ignore its"
    forall a. Semigroup a => a -> a -> a
<> Doc
" contents, and put in sahitya.")
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs a
_args Deriver (Stream a)
_deriver -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty