-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
-- | Calls for reyong and trompong techniques.
--
-- >   1        2     3        4
-- >  /-------\/----\/-------\/----\--\
-- > 4e 4u 4a 5i 5o 5e 5u 5a 6i 6o 6e 6u
-- > 3  5  6  1  2  3  5  6  1  2  3  5
module Derive.C.Bali.Reyong (
    library
    , cek
#ifdef TESTING
    , module Derive.C.Bali.Reyong
#endif
) where
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Num as Num

import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.C.Bali.Gangsa as Gangsa
import qualified Derive.C.Bali.Gender as Gender
import qualified Derive.C.Post.Postproc as Postproc
import qualified Derive.Call as Call
import qualified Derive.Call.GraceUtil as GraceUtil
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Call.StaticMacro as StaticMacro
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Flags as Flags
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
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.RealTime as RealTime
import qualified Perform.Signal as Signal

import qualified Ui.Types as Types

import           Global
import           Types


{-
    Kotekan uses separate calls for the cycle and the \"pickup\" preparation.
    It would be nicer to do it automatically, but sometimes pickups appear in
    irregular places, so I still need a manual option.

    The pickup is actually a transitition, since it may be different depending
    on source and destination pitches.

       3<------2<------1<------1
    +++3<--3+++2<--2+++1<------1
    3353535322323232112121212121
-}

module_ :: Module.Module
module_ :: Module
module_ = Module
"bali" forall a. Semigroup a => a -> a -> a
<> Module
"reyong"

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
"kilit", Pattern -> Generator Note
realize_pattern Pattern
norot_patterns)
        , (Symbol
">kilit", Pattern -> Generator Note
realize_pattern Pattern
norot_prepare_patterns)
        -- kilit is probably redundant now that I have norot.
        , (Symbol
"norot", Maybe Bool -> Generator Note
c_norot forall a. Maybe a
Nothing)
        , (Symbol
"nt", Maybe Bool -> Generator Note
c_norot forall a. Maybe a
Nothing)
        , (Symbol
"nt>", Maybe Bool -> Generator Note
c_norot (forall a. a -> Maybe a
Just Bool
True))
        , (Symbol
"nt-", Maybe Bool -> Generator Note
c_norot (forall a. a -> Maybe a
Just Bool
False))
        , (Symbol
"k//", Bool -> Maybe Text -> Maybe UpDown -> Generator Note
c_kotekan_regular Bool
False (forall a. a -> Maybe a
Just Text
"-12-12-1") (forall a. a -> Maybe a
Just UpDown
Call.Down))
        , (Symbol
"k\\\\", Bool -> Maybe Text -> Maybe UpDown -> Generator Note
c_kotekan_regular Bool
False (forall a. a -> Maybe a
Just Text
"-21-21-21") (forall a. a -> Maybe a
Just UpDown
Call.Up))
        , (Symbol
"k_\\", Pattern -> Generator Note
realize_pattern forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Pattern
reyong_pattern [Char]
"-44-43-4" [Char]
"-11-1-21")
        , (Symbol
"k//\\\\", Pattern -> Generator Note
realize_pattern forall a b. (a -> b) -> a -> b
$
            [Char] -> [Char] -> Pattern
reyong_pattern [Char]
"-4-34-3-43-434-3" [Char]
"-12-12-21-21-12-")
        , (Symbol
"k", Bool -> Maybe Text -> Maybe UpDown -> Generator Note
c_kotekan_regular Bool
False forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
        , (Symbol
"k^", Bool -> Maybe Text -> Maybe UpDown -> Generator Note
c_kotekan_regular Bool
True forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
        , (Symbol
"t", Generator Note
c_tumpuk)
        , (Symbol
"a", Generator Note
c_tumpuk_auto)
        , (Symbol
"o", Generator Note
c_byong)
        , (Symbol
":", [Pitch] -> Generator Note
c_pitches [forall pc. Enum pc => Int -> pc -> Pitch
Pitch.pitch Int
4 Integer
2, forall pc. Enum pc => Int -> pc -> Pitch
Pitch.pitch Int
5 Integer
0])
        , (Symbol
"/", CallName -> (Position -> [Pitch]) -> Attributes -> Generator Note
articulation CallName
"cek-loose" ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Pitch
pos_cek) (Attributes
cek forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.open))
        , (Symbol
"//", CallName -> (Position -> [Pitch]) -> Attributes -> Generator Note
articulation CallName
"cek-loose"
            (forall a. Int -> a -> [a]
replicate Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Pitch
pos_cek) (Attributes
cek forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.open))
        , (Symbol
"X", CallName -> (Position -> [Pitch]) -> Attributes -> Generator Note
articulation CallName
"cek" ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Pitch
pos_cek) Attributes
cek)
        , (Symbol
"XX", CallName -> (Position -> [Pitch]) -> Attributes -> Generator Note
articulation CallName
"cek" (forall a. Int -> a -> [a]
replicate Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Pitch
pos_cek) Attributes
cek)
        , (Symbol
"O", CallName -> (Position -> [Pitch]) -> Attributes -> Generator Note
articulation CallName
"byong" Position -> [Pitch]
pos_byong forall a. Monoid a => a
mempty)
        , (Symbol
"-", CallName -> (Position -> [Pitch]) -> Attributes -> Generator Note
articulation CallName
"byut-loose" Position -> [Pitch]
pos_byong (Attributes
Attrs.mute forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.open))
        , (Symbol
"+", CallName -> (Position -> [Pitch]) -> Attributes -> Generator Note
articulation CallName
"byut" Position -> [Pitch]
pos_byong Attributes
Attrs.mute)

        , (Symbol
"n1", [Int] -> Generator Note
c_solkattu_note [Int
0])
        , (Symbol
"n2", [Int] -> Generator Note
c_solkattu_note [Int
1])
        , (Symbol
"n3", [Int] -> Generator Note
c_solkattu_note [Int
2])
        , (Symbol
"n4", [Int] -> Generator Note
c_solkattu_note [Int
3])
        , (Symbol
"n14", [Int] -> Generator Note
c_solkattu_note [Int
0, Int
3])
        ]
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators forall a b. (a -> b) -> a -> b
$ forall call. (Parser (Maybe Transpose) -> call) -> [(Symbol, call)]
Gender.ngoret_variations Parser (Maybe Transpose) -> Generator Note
c_ngoret
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"infer-damp", Transformer Note
c_infer_damp)
        , (Symbol
"hand-damp", Transformer Note
c_hand_damp)
        , (Symbol
"cancel-kotekan", Transformer Note
c_cancel_kotekan)
        , (Symbol
"realize-ngoret", forall f. Module -> Call f -> Call f
Derive.set_module Module
module_ Transformer Note
Gender.c_realize_ngoret)
        , (Symbol
"realize-reyong", Transformer Note
c_realize_reyong)
        , (Symbol
"realize-trompong", Transformer Note
c_realize_trompong)
        , (Symbol
"vv", Transformer Note
c_lower_octave_note)
        ]
    , forall d.
(ToLibrary (Generator d), ToLibrary (Transformer d)) =>
[(Symbol, Calls d)] -> Library
Library.both
        [ (Symbol
"lv", Module -> Attributes -> Calls Note
Make.attributed_note Module
module_ Attributes
undamped)
        , (Symbol
"upper", Calls Note
c_upper)
        ]
    ]
    where articulation :: CallName -> (Position -> [Pitch]) -> Attributes -> Generator Note
articulation = [Position]
-> CallName
-> (Position -> [Pitch])
-> Attributes
-> Generator Note
make_articulation [Position]
reyong_positions

cek :: Attrs.Attributes
cek :: Attributes
cek = Text -> Attributes
Attrs.attr Text
"cek"

reyong_pattern :: [Char] -> [Char] -> Pattern
reyong_pattern :: [Char] -> [Char] -> Pattern
reyong_pattern [Char]
above [Char]
below = KotekanPattern -> Pattern
make_pattern forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> KotekanPattern
parse_kotekan [Char]
above [Char]
below

c_ngoret :: Sig.Parser (Maybe Pitch.Transpose) -> Derive.Generator Derive.Note
c_ngoret :: Parser (Maybe Transpose) -> Generator Note
c_ngoret = Module
-> Bool
-> Parser RealTimeFunction
-> Parser (Maybe Transpose)
-> Generator Note
Gender.ngoret Module
module_ Bool
False
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (RealTime -> Duration) -> RealTimeFunction
Typecheck.RealTimeFunction forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (RealTime -> Duration
DeriveT.RealDuration RealTime
0))

voices_env :: Sig.Parser [Voice]
voices_env :: Parser [Int]
voices_env = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"voices" EnvironDefault
Sig.Both ([] :: [Sig.Dummy])
    Doc
"Only emit notes for these positions, from 1 to 4. Empty means all of them."

-- * tumpuk

c_tumpuk :: Derive.Generator Derive.Note
c_tumpuk :: Generator Note
c_tumpuk = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"tumpuk" Tags
Tags.inst Doc
"Pile up notes together."
    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
"notes"
        (Doc
"Articulations, from " forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Doc.literal ([Char] -> Text
txt (forall k a. Map k a -> [k]
Map.keys Map Char (Attributes, Y)
articulations))
        forall a. Semigroup a => a -> a -> a
<> Doc
", pitches from `edcba0123456789`, or a space for a rest.")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dur" (Y
0.1 :: Double) Doc
"Duration of each note."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Normalized
place_env
    ) forall a b. (a -> b) -> a -> b
$ \(Text
notes, RealTime
dur, Normalized
place) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        [TumpukNote]
notes <- forall err a. Stack => (err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [Char] -> Either Text [TumpukNote]
parse_tumpuk (Text -> [Char]
untxt Text
notes)
        PassedArgs Note
-> Normalized -> RealTime -> [TumpukNote] -> NoteDeriver
tumpuk PassedArgs Note
args Normalized
place RealTime
dur [TumpukNote]
notes

tumpuk :: Derive.PassedArgs Score.Event -> Typecheck.Normalized -> RealTime
    -> [TumpukNote] -> Derive.NoteDeriver
tumpuk :: PassedArgs Note
-> Normalized -> RealTime -> [TumpukNote] -> NoteDeriver
tumpuk PassedArgs Note
args Normalized
place RealTime
dur [TumpukNote]
notes = do
    (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range PassedArgs Note
args
    Maybe RealTime
prev <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ forall a. PassedArgs a -> Maybe TrackTime
Args.prev_start PassedArgs Note
args
    Pitch
pitch <- RealTime -> Deriver Pitch
Call.get_pitch RealTime
start
    Maybe RealTime
-> RealTime
-> RealTime
-> Normalized
-> Maybe Pitch
-> Pitch
-> RealTime
-> [TumpukNote]
-> NoteDeriver
realize_tumpuk Maybe RealTime
prev RealTime
start RealTime
end Normalized
place (PassedArgs Note -> Maybe Pitch
Args.prev_event_pitch PassedArgs Note
args) Pitch
pitch RealTime
dur
        [TumpukNote]
notes

place_env :: Sig.Parser Typecheck.Normalized
place_env :: Parser Normalized
place_env = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"place" EnvironDefault
Sig.Both (Y
1 :: Double)
    Doc
"At 0, grace notes fall before their base note.  At 1, grace notes fall on\
    \ the base note, and the base note is delayed."

-- | Dyn 0 means a rest.
type TumpukNote = (TumpukPitch, Attrs.Attributes, Dyn)
data TumpukPitch = Transpose Pitch.Step | Prev deriving (TumpukPitch -> TumpukPitch -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TumpukPitch -> TumpukPitch -> Bool
$c/= :: TumpukPitch -> TumpukPitch -> Bool
== :: TumpukPitch -> TumpukPitch -> Bool
$c== :: TumpukPitch -> TumpukPitch -> Bool
Eq, Int -> TumpukPitch -> ShowS
[TumpukPitch] -> ShowS
TumpukPitch -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TumpukPitch] -> ShowS
$cshowList :: [TumpukPitch] -> ShowS
show :: TumpukPitch -> [Char]
$cshow :: TumpukPitch -> [Char]
showsPrec :: Int -> TumpukPitch -> ShowS
$cshowsPrec :: Int -> TumpukPitch -> ShowS
Show)
type Dyn = Signal.Y

realize_tumpuk :: Maybe RealTime -> RealTime -> RealTime
    -> Typecheck.Normalized -> Maybe PSignal.Pitch -> PSignal.Pitch
    -> RealTime -> [TumpukNote] -> Derive.NoteDeriver
realize_tumpuk :: Maybe RealTime
-> RealTime
-> RealTime
-> Normalized
-> Maybe Pitch
-> Pitch
-> RealTime
-> [TumpukNote]
-> NoteDeriver
realize_tumpuk Maybe RealTime
prev RealTime
event_start RealTime
event_end Normalized
place Maybe Pitch
prev_pitch Pitch
event_pitch RealTime
dur
        [TumpukNote]
notes =
    forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap forall {a}. (Time a, Num a) => (TumpukNote, (a, a)) -> NoteDeriver
realize forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>Y
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> c
note_dyn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [TumpukNote]
notes [(RealTime, RealTime)]
extents
    where
    extents :: [(RealTime, RealTime)]
extents = forall a.
(Fractional a, Ord a) =>
Normalized -> Maybe a -> a -> a -> Int -> a -> [(a, a)]
GraceUtil.fit_grace_durs Normalized
place
        Maybe RealTime
prev RealTime
event_start RealTime
event_end (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TumpukNote]
notes) RealTime
dur
    note_dyn :: (a, b, c) -> c
note_dyn (a
_, b
_, c
dyn) = c
dyn
    realize :: (TumpukNote, (a, a)) -> NoteDeriver
realize ((TumpukPitch
tpitch, Attributes
attrs, Y
dyn), (a
real_start, a
dur)) = do
        TrackTime
start <- forall a. Time a => a -> Deriver TrackTime
Derive.score a
real_start
        TrackTime
end <- forall a. Time a => a -> Deriver TrackTime
Derive.score (a
real_start forall a. Num a => a -> a -> a
+ a
dur)
        Pitch
pitch <- case TumpukPitch
tpitch of
            Transpose Int
steps -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> RawPitch a -> RawPitch a
Pitches.transpose_d Int
steps Pitch
event_pitch
            TumpukPitch
Prev -> forall a. Stack => Text -> Maybe a -> Deriver a
Derive.require Text
"no prev pitch" Maybe Pitch
prev_pitch
        forall a. TrackTime -> TrackTime -> Deriver a -> Deriver a
Derive.place TrackTime
start (TrackTime
endforall a. Num a => a -> a -> a
-TrackTime
start) forall a b. (a -> b) -> a -> b
$ forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic Y
dyn forall a b. (a -> b) -> a -> b
$
            forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs forall a b. (a -> b) -> a -> b
$ Pitch -> NoteDeriver
Call.pitched_note Pitch
pitch

parse_tumpuk :: [Char] -> Either Text [TumpukNote]
parse_tumpuk :: [Char] -> Either Text [TumpukNote]
parse_tumpuk =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [Maybe a] -> [a]
Maybe.catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) state x y.
Monad m =>
(state -> x -> m (state, y)) -> state -> [x] -> m (state, [y])
Lists.mapAccumLM TumpukPitch -> Char -> Either Text (TumpukPitch, Maybe TumpukNote)
parse (Int -> TumpukPitch
Transpose Int
0)
    where
    parse :: TumpukPitch -> Char -> Either Text (TumpukPitch, Maybe TumpukNote)
parse TumpukPitch
pitch Char
c = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
c Map Char (Attributes, Y)
articulations of
        Just (Attributes
attrs, Y
dyn) -> forall a b. b -> Either a b
Right (TumpukPitch
pitch, forall a. a -> Maybe a
Just (TumpukPitch
pitch, Attributes
attrs, Y
dyn))
        Maybe (Attributes, Y)
Nothing -> case Char -> Maybe Int
Num.readDigit Char
c forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c [(Char, Int)]
negative of
            Just Int
steps -> forall a b. b -> Either a b
Right (Int -> TumpukPitch
Transpose Int
steps, forall a. Maybe a
Nothing)
            Maybe Int
Nothing
                | Char
c forall a. Eq a => a -> a -> Bool
== Char
'p' -> forall a b. b -> Either a b
Right (TumpukPitch
Prev, forall a. Maybe a
Nothing)
                | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"unknown articulation: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Char
c
    negative :: [(Char, Int)]
negative = [(Char
'a', -Int
1), (Char
'b', -Int
2), (Char
'c', -Int
3), (Char
'd', -Int
4), (Char
'e', -Int
5)]

-- | These more or less correspond to the group articulations:
--
-- > /   X   -   +   o
-- >         m-  nx  .o
articulations :: Map Char (Attrs.Attributes, Dyn)
articulations :: Map Char (Attributes, Y)
articulations = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Char
' ', (forall a. Monoid a => a
mempty, Y
0))
    , (Char
'.', (forall a. Monoid a => a
mempty, Y
0.75))
    , (Char
'o', (forall a. Monoid a => a
mempty, Y
1))
    , (Char
'm', (Attributes
Attrs.mute forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.open, Y
0.75))
    , (Char
'-', (Attributes
Attrs.mute forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.open, Y
1))
    , (Char
'n', (Attributes
Attrs.mute, Y
0.75))
    -- I would use +, but if you start with one it parses as an attr.
    , (Char
'x', (Attributes
Attrs.mute, Y
1))
    ]

c_tumpuk_auto :: Derive.Generator Derive.Note
c_tumpuk_auto :: Generator Note
c_tumpuk_auto = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"tumpuk-auto" Tags
Tags.inst
    Doc
"A variant of `tumpuk` that randomly picks a pattern."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call Parser Normalized
place_env forall a b. (a -> b) -> a -> b
$ \Normalized
place -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        [Y]
randoms <- forall a. Random a => Deriver [a]
Call.randoms
        let Y
rnd1 : Y
rnd2 : [Y]
_ = [Y]
randoms -- randoms is infinite
        RealTime
event_dur <- forall a. PassedArgs a -> Deriver RealTime
Args.real_duration PassedArgs Note
args
        ([TumpukNote]
notes, RealTime
dur) <- forall err a. Stack => (err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
            RealTime -> Y -> Y -> Either Text ([TumpukNote], RealTime)
select_pattern RealTime
event_dur Y
rnd1 Y
rnd2
        PassedArgs Note
-> Normalized -> RealTime -> [TumpukNote] -> NoteDeriver
tumpuk PassedArgs Note
args Normalized
place RealTime
dur [TumpukNote]
notes

-- | If dur is long, use the slow end of the patterns.  If dur is short, try to
-- fit the pattern in the first 2/3, dropping patterns if they exceed that at
-- their fastest.
select_pattern :: RealTime -> Double -> Double
    -> Either Text ([TumpukNote], RealTime)
select_pattern :: RealTime -> Y -> Y -> Either Text ([TumpukNote], RealTime)
select_pattern RealTime
dur Y
rnd1 Y
rnd2 = forall err a. err -> Maybe a -> Either err a
justErr Text
err forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}.
Foldable t =>
[(t a, (RealTime, RealTime))] -> Maybe (t a, RealTime)
select [([TumpukNote], (RealTime, RealTime))]
fits_well forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {t :: * -> *} {a}.
Foldable t =>
[(t a, (RealTime, RealTime))] -> Maybe (t a, RealTime)
select [([TumpukNote], (RealTime, RealTime))]
fits
    where
    select :: [(t a, (RealTime, RealTime))] -> Maybe (t a, RealTime)
select [(t a, (RealTime, RealTime))]
ps = case forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [(t a, (RealTime, RealTime))]
ps of
        Maybe (NonEmpty (t a, (RealTime, RealTime)))
Nothing -> forall a. Maybe a
Nothing
        Just NonEmpty (t a, (RealTime, RealTime))
ps -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}.
Foldable t =>
(t a, (RealTime, RealTime)) -> (t a, RealTime)
pick_dur (forall a. NonEmpty a -> Y -> a
Call.pick NonEmpty (t a, (RealTime, RealTime))
ps Y
rnd1)
    pick_dur :: (t a, (RealTime, RealTime)) -> (t a, RealTime)
pick_dur (t a
p, (RealTime
slow, RealTime
fast)) = (t a
p, RealTime
dur)
        where
        dur :: RealTime
dur = forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale (forall a. Ord a => a -> a -> a -> a
Num.clamp RealTime
slow RealTime
fast RealTime
min_slow) RealTime
fast
            (Y -> RealTime
RealTime.seconds Y
rnd2)
        min_slow :: RealTime
min_slow = RealTime
desired_dur forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
p)
    err :: Text
err = Text
"no patterns fit duration " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
dur
    -- Try to take up only this much dur with tumpuk notes, but take up to
    -- the full duration if nothing fits.
    desired_dur :: RealTime
desired_dur = RealTime
dur forall a. Num a => a -> a -> a
* (RealTime
2forall a. Fractional a => a -> a -> a
/RealTime
3)
    fits_well :: [([TumpukNote], (RealTime, RealTime))]
fits_well = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<= RealTime
desired_dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {t :: * -> *} {a} {a}.
(Num a, Foldable t) =>
(t a, (a, a)) -> a
pattern_dur) [([TumpukNote], (RealTime, RealTime))]
tumpuk_patterns
    fits :: [([TumpukNote], (RealTime, RealTime))]
fits = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<= RealTime
dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {t :: * -> *} {a} {a}.
(Num a, Foldable t) =>
(t a, (a, a)) -> a
pattern_dur) [([TumpukNote], (RealTime, RealTime))]
tumpuk_patterns
    pattern_dur :: (t a, (a, a)) -> a
pattern_dur (t a
p, (a
_, a
fast)) = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
p) forall a. Num a => a -> a -> a
* a
fast

-- | Pattern and usable time range.
-- TODO probably I can vary -=, nx, and .o, or just randomize the dyn for
-- non-final notes.
tumpuk_patterns :: [([TumpukNote], (RealTime, RealTime))]
tumpuk_patterns :: [([TumpukNote], (RealTime, RealTime))]
tumpuk_patterns = forall {c}. Either Text c -> c
expect_right forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {f :: * -> *} {t} {a} {a}.
Applicative f =>
(t -> f a) -> (t, a) -> f (a, a)
firstA [Char] -> Either Text [TumpukNote]
parse_tumpuk)
    [ ([Char]
"p-0o", (RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
10, RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
14))
    , ([Char]
"p-0.o", (RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
12, RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
18))
    , ([Char]
"p.0.o", (RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
14, RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
18))
    , ([Char]
"1.0.o", (RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
12, RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
18))
    , ([Char]
"p.0.pm0o", (RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
18, RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
20))
    ]
    where
    expect_right :: Either Text c -> c
expect_right = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Stack => Text -> a
errorStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"tumpuk_patterns: "<>)) forall a. a -> a
id
    firstA :: (t -> f a) -> (t, a) -> f (a, a)
firstA t -> f a
f (t
a, a
c) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> f a
f t
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
c

-- * c_byong

c_byong :: Derive.Generator Derive.Note
c_byong :: Generator Note
c_byong = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"byong" Tags
Tags.inst
    Doc
"Play the byong notes, but only for the current voice, and following\
    \ normal damping rules."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Int
voice <- forall a. Typecheck a => Text -> Deriver a
Derive.get_val Text
EnvKey.voice
        Position
position <- forall a. Stack => Text -> Maybe a -> Deriver a
Derive.require (Text
"unknown position: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
voice) forall a b. (a -> b) -> a -> b
$
            forall a. [a] -> Int -> Maybe a
Lists.at [Position]
reyong_positions (Int
voice forall a. Num a => a -> a -> a
- Int
1 :: Int)
        (Note -> Maybe Pitch
_, Pitch -> Maybe Note
show_pitch, Transposition -> Int -> Pitch -> Maybe Pitch
_) <- Deriver
  (Note -> Maybe Pitch, Pitch -> Maybe Note,
   Transposition -> Int -> Pitch -> Maybe Pitch)
Call.get_pitch_functions
        let realize :: Note -> NoteDeriver
realize = forall d a. PassedArgs d -> Deriver a -> Deriver a
Call.place PassedArgs Note
args
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pitch -> Maybe Note) -> Int -> TrackTime -> Note -> NoteDeriver
realize_note Pitch -> Maybe Note
show_pitch Int
voice (forall a. PassedArgs a -> TrackTime
Args.start PassedArgs Note
args)
        forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (Note -> NoteDeriver
realize forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, forall a. Monoid a => a
mempty)) (Position -> [Pitch]
pos_byong Position
position)

c_pitches :: [Pitch.Pitch] -> Derive.Generator Derive.Note
c_pitches :: [Pitch] -> Generator Note
c_pitches [Pitch]
pitches = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"pitches" Tags
Tags.inst
    (Doc
"Play notes for each pitch: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc [Pitch]
pitches
        forall a. Semigroup a => a -> a -> a
<> Doc
". Really only for `4e` and `5i` for the penyorog.")
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args ->
        forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (forall d a. PassedArgs d -> Deriver a -> Deriver a
Call.place PassedArgs Note
args forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Pitch -> NoteDeriver
realize (forall a. PassedArgs a -> TrackTime
Args.start PassedArgs Note
args)) [Pitch]
pitches
    where
    realize :: TrackTime -> Pitch -> NoteDeriver
realize TrackTime
start Pitch
pitch =
        Transposed -> NoteDeriver
Call.transposed_pitched_note forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TrackTime -> Pitch -> Deriver Transposed
Call.eval_pitch_ TrackTime
start Pitch
pitch

-- * cancel

c_cancel_kotekan :: Derive.Transformer Derive.Note
c_cancel_kotekan :: Transformer Note
c_cancel_kotekan = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"cancel-kotekan" Tags
Tags.postproc
    Doc
"This is like the `cancel` call, except it understands flags set by\
    \ kotekan, and cancels based on reyong voice." forall a b. (a -> b) -> a -> b
$
    forall key.
Ord key =>
Cancel -> Key key -> WithArgDoc (TransformerF Note)
Postproc.make_cancel Cancel
Gangsa.cancel_strong_final Note -> (Instrument, Int)
Post.voice_key

-- * kilitan

c_norot :: Maybe Bool -> Derive.Generator Derive.Note
c_norot :: Maybe Bool -> Generator Note
c_norot Maybe Bool
default_prepare =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"norot" Tags
Tags.inst Doc
"Reyong norot."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"prepare" Maybe Bool
default_prepare
        Doc
"Whether or not to prepare for the next pitch. If Nothing, infer based\
        \ on the next note."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TrackTime
Gangsa.dur_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
Gangsa.infer_initial_final_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Int]
voices_env
    ) forall a b. (a -> b) -> a -> b
$ \(Maybe Bool
prepare, TrackTime
note_dur, (Maybe Bool, Bool)
initial_final, [Int]
voices) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$
    \PassedArgs Note
args -> do
        (Pitch
pitch, Pitch -> Maybe Note
show_pitch) <- forall a. PassedArgs a -> Deriver (Pitch, Pitch -> Maybe Note)
get_parsed_pitch PassedArgs Note
args
        Maybe Pitch
next_pitch <- forall a. PassedArgs a -> Maybe Bool -> Deriver (Maybe Pitch)
infer_prepare PassedArgs Note
args Maybe Bool
prepare
        let orientation :: Orientation
orientation = forall a. PassedArgs a -> Orientation
Args.orientation PassedArgs Note
args
        let (Maybe ((Bool, Bool), (TrackTime, TrackTime))
sustain_params, Maybe ((Bool, Bool), (TrackTime, TrackTime))
prepare_params) = Bool
-> TrackTime
-> (Maybe Bool, Bool)
-> Orientation
-> (TrackTime, TrackTime)
-> (Maybe ((Bool, Bool), (TrackTime, TrackTime)),
    Maybe ((Bool, Bool), (TrackTime, TrackTime)))
Gangsa.prepare_sustain
                (forall a. Maybe a -> Bool
Maybe.isJust Maybe Pitch
next_pitch) TrackTime
note_dur (Maybe Bool, Bool)
initial_final
                Orientation
orientation (forall a. PassedArgs a -> (TrackTime, TrackTime)
Args.range PassedArgs Note
args)
        NoteDeriver
sustain <- case Maybe ((Bool, Bool), (TrackTime, TrackTime))
sustain_params of
            Maybe ((Bool, Bool), (TrackTime, TrackTime))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
            Just ((Bool, Bool)
initial_final, (TrackTime, TrackTime)
range) ->
                forall note.
((Int, note) -> NoteDeriver)
-> [Int]
-> Map Int [note]
-> Pitch
-> Deriver State Error NoteDeriver
realize_positions
                    ((TrackTime, TrackTime)
-> Orientation
-> (Bool, Bool)
-> (Pitch -> Maybe Note)
-> Repeat
-> TrackTime
-> (Int, [Chord])
-> NoteDeriver
realize_notes (TrackTime, TrackTime)
range Orientation
orientation (Bool, Bool)
initial_final
                        Pitch -> Maybe Note
show_pitch Repeat
Gangsa.Repeat TrackTime
note_dur)
                    [Int]
voices Pattern
norot_patterns Pitch
pitch
        Maybe NoteDeriver
prepare <- case (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Pitch
next_pitch forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ((Bool, Bool), (TrackTime, TrackTime))
prepare_params of
            Maybe (Pitch, ((Bool, Bool), (TrackTime, TrackTime)))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just (Pitch
next, ((Bool, Bool)
initial_final, (TrackTime, TrackTime)
range)) ->
                forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall note.
((Int, note) -> NoteDeriver)
-> [Int]
-> Map Int [note]
-> Pitch
-> Deriver State Error NoteDeriver
realize_positions
                    ((TrackTime, TrackTime)
-> Orientation
-> (Bool, Bool)
-> (Pitch -> Maybe Note)
-> Repeat
-> TrackTime
-> (Int, [Chord])
-> NoteDeriver
realize_notes (TrackTime, TrackTime)
range Orientation
orientation (Bool, Bool)
initial_final
                        Pitch -> Maybe Note
show_pitch Repeat
Gangsa.Once TrackTime
note_dur)
                    [Int]
voices Pattern
norot_prepare_patterns Pitch
next
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe NoteDeriver
sustain (NoteDeriver
sustain<>) Maybe NoteDeriver
prepare

realize_positions :: ((Voice, note) -> Derive.NoteDeriver)
    -> [Voice] -> Map Pitch.PitchClass [note]
    -> Pitch.Pitch -> Derive.Deriver Derive.NoteDeriver
realize_positions :: forall note.
((Int, note) -> NoteDeriver)
-> [Int]
-> Map Int [note]
-> Pitch
-> Deriver State Error NoteDeriver
realize_positions (Int, note) -> NoteDeriver
realize [Int]
voices Map Int [note]
patterns Pitch
pitch = do
    [note]
positions <- forall a. Stack => Text -> Maybe a -> Deriver a
Derive.require
        (Text
"no pattern for pitch: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Pitch
pitch)
        (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Pitch -> Int
Pitch.pitch_pc Pitch
pitch) Map Int [note]
patterns)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (Int, note) -> NoteDeriver
realize (forall a. [Int] -> [a] -> [(Int, a)]
filter_voices [Int]
voices [note]
positions)

-- | Kilitan is implemented as a set of patterns indexed by an absolute pitch
-- degree.  The patterns are similar to kotekan, except with absolute pitches,
-- and without a polos \/ sangsih division.
realize_pattern :: Pattern -> Derive.Generator Derive.Note
realize_pattern :: Pattern -> Generator Note
realize_pattern Pattern
pattern =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"reyong" Tags
Tags.inst Doc
"Emit reyong pattern."
    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
<$> Parser TrackTime
Gangsa.dur_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
Gangsa.infer_initial_final_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Int]
voices_env)
    forall a b. (a -> b) -> a -> b
$ \(TrackTime
dur, (Maybe Bool, Bool)
initial_final, [Int]
voices) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        (Pitch
pitch, Pitch -> Maybe Note
show_pitch) <- forall a. PassedArgs a -> Deriver (Pitch, Pitch -> Maybe Note)
get_parsed_pitch PassedArgs Note
args
        [[Chord]]
positions <- forall a. Stack => Text -> Maybe a -> Deriver a
Derive.require (Text
"no pattern for pitch: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Pitch
pitch)
            (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Pitch -> Int
Pitch.pitch_pc Pitch
pitch) Pattern
pattern)
        forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap
            (forall a.
PassedArgs a
-> (Maybe Bool, Bool)
-> (Pitch -> Maybe Note)
-> Repeat
-> TrackTime
-> (Int, [Chord])
-> NoteDeriver
realize_notes_args PassedArgs Note
args (Maybe Bool, Bool)
initial_final Pitch -> Maybe Note
show_pitch Repeat
Gangsa.Repeat TrackTime
dur)
            (forall a. [Int] -> [a] -> [(Int, a)]
filter_voices [Int]
voices [[Chord]]
positions)

-- | Select the given Voice indices.
filter_voices :: [Voice] -> [a] -> [(Voice, a)]
filter_voices :: forall a. [Int] -> [a] -> [(Int, a)]
filter_voices [Int]
voices [a]
positions
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
voices = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
positions
    | Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
voices) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
positions)

-- * kotekan

c_kotekan_regular :: Bool -> Maybe Text -> Maybe Call.UpDown
    -> Derive.Generator Derive.Note
c_kotekan_regular :: Bool -> Maybe Text -> Maybe UpDown -> Generator Note
c_kotekan_regular Bool
inverted Maybe Text
maybe_kernel Maybe UpDown
maybe_dir =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"kotekan" Tags
Tags.inst
    (Doc
"Render a kotekan pattern from a kernel representing the polos.\
    \ The sangsih is inferred. This can emit notes at both the beginning and\
    \ end of the event, so use `cancel-kotekan` to cancel the extras.")
    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 b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"kernel" EnvironDefault
Sig.Both (Text
"k-12-1-21" :: Text) Doc
kernel_doc)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
maybe_kernel
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dir" UpDown
Call.Up
            Doc
"Inferred part is above or below the explicit one.")
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UpDown
maybe_dir
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TrackTime
Gangsa.dur_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
Gangsa.infer_initial_final_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Int]
voices_env
    ) forall a b. (a -> b) -> a -> b
$ \(Text
kernel_s, UpDown
dir, TrackTime
dur, (Maybe Bool, Bool)
initial_final, [Int]
voices) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$
    \PassedArgs Note
args -> do
        Kernel
kernel <- forall err a. Stack => (err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [Char] -> Either Text Kernel
Gangsa.make_kernel (Text -> [Char]
untxt Text
kernel_s)
        (Pitch
pitch, Pitch -> Maybe Note
show_pitch) <- forall a. PassedArgs a -> Deriver (Pitch, Pitch -> Maybe Note)
get_parsed_pitch PassedArgs Note
args
        KotekanPattern
pattern <- forall a. Stack => Text -> Maybe a -> Deriver a
Derive.require Text
"empty pattern" forall a b. (a -> b) -> a -> b
$
            UpDown -> Kernel -> Maybe KotekanPattern
kernel_to_pattern UpDown
dir
                (if Bool
inverted then Kernel -> Kernel
Gangsa.invert Kernel
kernel else Kernel
kernel)
        let positions :: [[Chord]]
positions = Int -> [Pitch] -> KotekanPattern -> Int -> [[Chord]]
kotekan_pattern Int
per_octave
                (forall a b. (a -> b) -> [a] -> [b]
map Position -> Pitch
pos_cek [Position]
reyong_positions) KotekanPattern
pattern (Pitch -> Int
Pitch.pitch_pc Pitch
pitch)
        forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap
            (forall a.
PassedArgs a
-> (Maybe Bool, Bool)
-> (Pitch -> Maybe Note)
-> Repeat
-> TrackTime
-> (Int, [Chord])
-> NoteDeriver
realize_notes_args PassedArgs Note
args (Maybe Bool, Bool)
initial_final Pitch -> Maybe Note
show_pitch Repeat
Gangsa.Repeat TrackTime
dur)
            (forall a. [Int] -> [a] -> [(Int, a)]
filter_voices [Int]
voices [[Chord]]
positions)
    where per_octave :: Int
per_octave = Int
5

kernel_doc :: Doc.Doc
kernel_doc :: Doc
kernel_doc = Doc
"Transposition steps for the part that ends on the destination\
    \ pitch. It should consist of `-`, `1`, and `2`. You can start with `k` to\
    \ avoid needing quotes. Starting with `k` will also require the length to\
    \ be a multiple of 4."

realize_notes_args :: Derive.PassedArgs a -> (Maybe Bool, Bool)
    -> (Pitch.Pitch -> Maybe Pitch.Note) -> Gangsa.Repeat -> ScoreTime
    -> (Voice, [[Note]]) -> Derive.NoteDeriver
realize_notes_args :: forall a.
PassedArgs a
-> (Maybe Bool, Bool)
-> (Pitch -> Maybe Note)
-> Repeat
-> TrackTime
-> (Int, [Chord])
-> NoteDeriver
realize_notes_args PassedArgs a
args (Maybe Bool, Bool)
initial_final =
    (TrackTime, TrackTime)
-> Orientation
-> (Bool, Bool)
-> (Pitch -> Maybe Note)
-> Repeat
-> TrackTime
-> (Int, [Chord])
-> NoteDeriver
realize_notes (forall a. PassedArgs a -> (TrackTime, TrackTime)
Args.range PassedArgs a
args) (forall a. PassedArgs a -> Orientation
Args.orientation PassedArgs a
args)
        (forall a. PassedArgs a -> (Maybe Bool, Bool) -> (Bool, Bool)
Gangsa.infer_initial PassedArgs a
args (Maybe Bool, Bool)
initial_final)

realize_notes :: (ScoreTime, ScoreTime) -> Types.Orientation -> (Bool, Bool)
    -> (Pitch.Pitch -> Maybe Pitch.Note) -> Gangsa.Repeat -> ScoreTime
    -> (Voice, [Chord]) -> Derive.NoteDeriver
realize_notes :: (TrackTime, TrackTime)
-> Orientation
-> (Bool, Bool)
-> (Pitch -> Maybe Note)
-> Repeat
-> TrackTime
-> (Int, [Chord])
-> NoteDeriver
realize_notes (TrackTime
start, TrackTime
end) Orientation
orientation (Bool, Bool)
initial_final Pitch -> Maybe Note
show_pitch Repeat
repeat TrackTime
dur
        (Int
voice, [Chord]
position) =
    forall a. (a -> NoteDeriver) -> [Note a] -> NoteDeriver
Gangsa.realize_notes ((Pitch -> Maybe Note) -> Int -> TrackTime -> Note -> NoteDeriver
realize_note Pitch -> Maybe Note
show_pitch Int
voice TrackTime
start) forall a b. (a -> b) -> a -> b
$
        forall a.
Repeat
-> Orientation
-> (Bool, Bool)
-> TrackTime
-> TrackTime
-> TrackTime
-> (TrackTime -> [[a]])
-> [Note a]
Gangsa.realize_pattern Repeat
repeat Orientation
orientation (Bool, Bool)
initial_final TrackTime
start TrackTime
end TrackTime
dur
            (forall a b. a -> b -> a
const [Chord]
position)

kernel_to_pattern :: Call.UpDown -> Gangsa.Kernel -> Maybe KotekanPattern
kernel_to_pattern :: UpDown -> Kernel -> Maybe KotekanPattern
kernel_to_pattern UpDown
direction Kernel
kernel = do
    -- Reyong doesn't really have polos and sangsih, so here polos is the
    -- one that has the destination.
    let polos :: [Maybe Int]
polos = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+Int
offset) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Num a => Atom -> Maybe a
to_steps) Kernel
kernel
        sangsih :: [Maybe Int]
sangsih = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+Int
offset) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Num a => Atom -> Maybe a
infer_sangsih) Kernel
kernel
    Int
sangsih_last <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a. [a] -> [a]
reverse [Maybe Int]
sangsih)
    Int
polos_last <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a. [a] -> [a]
reverse [Maybe Int]
polos)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case UpDown
direction of
        UpDown
Call.Up -> KotekanPattern
            { kotekan_above :: ([Maybe Int], Int)
kotekan_above = ([Maybe Int]
sangsih, Int
sangsih_last)
            , kotekan_below :: ([Maybe Int], Int)
kotekan_below = ([Maybe Int]
polos, Int
polos_last)
            }
        UpDown
Call.Down -> KotekanPattern
            { kotekan_above :: ([Maybe Int], Int)
kotekan_above = ([Maybe Int]
polos, Int
polos_last)
            , kotekan_below :: ([Maybe Int], Int)
kotekan_below = ([Maybe Int]
sangsih, Int
sangsih_last)
            }
    where
    -- I want the final note to end on the destination, whether it be polos or
    -- sangsih.  So shift everything to make that happen.  If it's Gap then I
    -- have no idea, leave it alone.
    offset :: Int
offset = forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ case forall a. [a] -> Maybe a
Lists.last Kernel
kernel of
        Just Atom
Gangsa.Gap -> forall {a}. Num a => Atom -> Maybe a
infer_sangsih Atom
Gangsa.Gap
        Just Atom
a -> forall {a}. Num a => Atom -> Maybe a
to_steps Atom
a
        Maybe Atom
Nothing -> forall a. Maybe a
Nothing
    to_steps :: Atom -> Maybe a
to_steps Atom
a = case Atom
a of
        Atom
Gangsa.Gap -> forall a. Maybe a
Nothing
        Atom
Gangsa.Rest -> forall a. Maybe a
Nothing
        Atom
Gangsa.Low -> forall a. a -> Maybe a
Just a
0
        Atom
Gangsa.High -> forall a. a -> Maybe a
Just a
1
    infer_sangsih :: Atom -> Maybe a
infer_sangsih Atom
a = case UpDown
direction of
        UpDown
Call.Up -> case Atom
a of
            Atom
Gangsa.Gap -> forall a. Maybe a
Nothing
            Atom
Gangsa.Rest -> forall a. a -> Maybe a
Just a
2
            Atom
Gangsa.Low -> forall a. a -> Maybe a
Just a
3
            Atom
Gangsa.High -> forall a. Maybe a
Nothing
        UpDown
Call.Down -> case Atom
a of
            Atom
Gangsa.Gap -> forall a. Maybe a
Nothing
            Atom
Gangsa.Rest -> forall a. a -> Maybe a
Just (-a
1)
            Atom
Gangsa.Low -> forall a. Maybe a
Nothing
            Atom
Gangsa.High -> forall a. a -> Maybe a
Just (-a
2)

-- | Like 'Gangsa.get_pitch', but get the symbolic pitch.
get_parsed_pitch :: Derive.PassedArgs a
    -> Derive.Deriver (Pitch.Pitch, Pitch.Pitch -> Maybe Pitch.Note)
get_parsed_pitch :: forall a. PassedArgs a -> Deriver (Pitch, Pitch -> Maybe Note)
get_parsed_pitch PassedArgs a
args = do
    (Note -> Maybe Pitch
parse_pitch, Pitch -> Maybe Note
show_pitch, Transposition -> Int -> Pitch -> Maybe Pitch
_) <- Deriver
  (Note -> Maybe Pitch, Pitch -> Maybe Note,
   Transposition -> Int -> Pitch -> Maybe Pitch)
Call.get_pitch_functions
    Pitch
pitch <- (Note -> Maybe Pitch) -> RealTime -> Deriver State Error Pitch
Call.get_parsed_pitch Note -> Maybe Pitch
parse_pitch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs a
args
    forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch
pitch, Pitch -> Maybe Note
show_pitch)

-- | Like 'Gangsa.infer_prepare', except return a parsed Pitch.Pitch.
infer_prepare :: Derive.PassedArgs a -> Maybe Bool
    -> Derive.Deriver (Maybe Pitch.Pitch)
infer_prepare :: forall a. PassedArgs a -> Maybe Bool -> Deriver (Maybe Pitch)
infer_prepare PassedArgs a
args Maybe Bool
prepare = do
    (Note -> Maybe Pitch
parse_pitch, Pitch -> Maybe Note
_, Transposition -> Int -> Pitch -> Maybe Pitch
_) <- Deriver
  (Note -> Maybe Pitch, Pitch -> Maybe Note,
   Transposition -> Int -> Pitch -> Maybe Pitch)
Call.get_pitch_functions
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall a. PassedArgs a -> Maybe Bool -> Deriver (Maybe Pitch)
Gangsa.infer_prepare PassedArgs a
args Maybe Bool
prepare) forall a b. (a -> b) -> a -> b
$ \Pitch
_ ->
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall a. (Note -> Maybe a) -> TrackTime -> Deriver (Maybe a)
Args.lookup_parsed_pitch_at Note -> Maybe Pitch
parse_pitch)
            (forall a. PassedArgs a -> Maybe TrackTime
Args.next_start PassedArgs a
args)

-- * articulation

make_articulation :: [Position] -> Derive.CallName
    -> (Position -> [Pitch.Pitch]) -> Attrs.Attributes
    -> Derive.Generator Derive.Note
make_articulation :: [Position]
-> CallName
-> (Position -> [Pitch])
-> Attributes
-> Generator Note
make_articulation [Position]
positions CallName
name Position -> [Pitch]
get_notes Attributes
attrs =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
name Tags
Tags.inst
    Doc
"Reyong articulation. The doubled variants emit two notes, and rely on\
    \ start time randomization so they're not exactly simultaneous." forall a b. (a -> b) -> a -> b
$
    forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call Parser [Int]
voices_env forall a b. (a -> b) -> a -> b
$ \[Int]
voices -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        (Note -> Maybe Pitch
_, Pitch -> Maybe Note
show_pitch, Transposition -> Int -> Pitch -> Maybe Pitch
_) <- Deriver
  (Note -> Maybe Pitch, Pitch -> Maybe Note,
   Transposition -> Int -> Pitch -> Maybe Pitch)
Call.get_pitch_functions
        forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {a}.
(Pitch -> Maybe Note)
-> PassedArgs a -> (Int, Position) -> NoteDeriver
realize Pitch -> Maybe Note
show_pitch PassedArgs Note
args) (forall a. [Int] -> [a] -> [(Int, a)]
filter_voices [Int]
voices [Position]
positions)
    where
    realize :: (Pitch -> Maybe Note)
-> PassedArgs a -> (Int, Position) -> NoteDeriver
realize Pitch -> Maybe Note
show_pitch PassedArgs a
args (Int
voice, Position
position) = forall {a}. Monoid (Deriver a) => [Deriver a] -> Deriver a
hands forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
        (forall d a. PassedArgs d -> Deriver a -> Deriver a
Call.place PassedArgs a
args forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pitch -> Maybe Note) -> Int -> TrackTime -> Note -> NoteDeriver
realize_note Pitch -> Maybe Note
show_pitch Int
voice (forall a. PassedArgs a -> TrackTime
Args.start PassedArgs a
args)) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (\Pitch
p -> (Pitch
p, Attributes
attrs)) (Position -> [Pitch]
get_notes Position
position)
    hands :: [Deriver a] -> Deriver a
hands [Deriver a
n] = Deriver a
n
    hands [Deriver a
n1, Deriver a
n2] = forall {a}. Hand -> Deriver a -> Deriver a
hand Hand
Call.L Deriver a
n1 forall a. Semigroup a => a -> a -> a
<> forall {a}. Hand -> Deriver a -> Deriver a
hand Hand
Call.R Deriver a
n2
        where hand :: Hand -> Deriver a -> Deriver a
hand = forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
EnvKey.hand forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowVal a => a -> Text
ShowVal.show_val
    hands [Deriver a]
ns = forall a. Monoid a => [a] -> a
mconcat [Deriver a]
ns

type Voice = Int

realize_note :: (Pitch.Pitch -> Maybe Pitch.Note) -> Voice -> ScoreTime
    -> Note -> Derive.NoteDeriver
realize_note :: (Pitch -> Maybe Note) -> Int -> TrackTime -> Note -> NoteDeriver
realize_note Pitch -> Maybe Note
show_pitch Int
voice TrackTime
start (Pitch
pitch, Attributes
attrs) =
    -- TODO I could maybe get rid of all the show_pitch args by using
    -- Call.eval_pitch_, but would that be inefficient?
    forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs forall a b. (a -> b) -> a -> b
$ forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
EnvKey.voice Int
voice forall a b. (a -> b) -> a -> b
$
        Transposed -> NoteDeriver
Call.transposed_pitched_note forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Pitch -> Maybe Note) -> TrackTime -> Pitch -> Deriver Transposed
Call.eval_pitch Pitch -> Maybe Note
show_pitch TrackTime
start Pitch
pitch


-- * kotekan

data KotekanPattern = KotekanPattern {
    -- | Pair relative steps with the final note's distance from the
    -- destination pitch.  This is used to find this line's distance from
    -- a given position.
    KotekanPattern -> ([Maybe Int], Int)
kotekan_above :: !([Maybe Pitch.Step], Pitch.Step)
    , KotekanPattern -> ([Maybe Int], Int)
kotekan_below :: !([Maybe Pitch.Step], Pitch.Step)
    } deriving (Int -> KotekanPattern -> ShowS
[KotekanPattern] -> ShowS
KotekanPattern -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [KotekanPattern] -> ShowS
$cshowList :: [KotekanPattern] -> ShowS
show :: KotekanPattern -> [Char]
$cshow :: KotekanPattern -> [Char]
showsPrec :: Int -> KotekanPattern -> ShowS
$cshowsPrec :: Int -> KotekanPattern -> ShowS
Show)

{- What about the high ding?

    I still want to do high ding automatically, but it depends on the speed.
    How about leave it out for now, and add it later.

    "44-34-3- 43-434-3" "-12-12-2 1-21-12(3)"
    Says to play the (3) if someone else isn't playing it, e.g. if it's
    being played on the top position.

    Or I could write both and filter out duplicate notes in favor of the
    lower position.  But that makes above and below have the same 'last',
    where the polos part should be considered closer.
-}

type Pattern = Map Pitch.PitchClass [[Chord]]
type Chord = [Note]
type Note = (Pitch.Pitch, Attrs.Attributes)

-- | Figure out a pattern for each note of the scale.
make_pattern :: KotekanPattern -> Pattern
make_pattern :: KotekanPattern -> Pattern
make_pattern KotekanPattern
pattern = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Int
pc, Int -> [Pitch] -> KotekanPattern -> Int -> [[Chord]]
kotekan_pattern Int
per_octave (forall a b. (a -> b) -> [a] -> [b]
map Position -> Pitch
pos_cek [Position]
reyong_positions) KotekanPattern
pattern Int
pc)
    | Int
pc <- [Int]
pcs
    ]
    where
    per_octave :: Int
per_octave = Int
5
    pcs :: [Int]
pcs = [Int
0 .. Int
per_octave forall a. Num a => a -> a -> a
- Int
1]

kotekan_pattern :: Pitch.PitchClass -> [Pitch.Pitch] -> KotekanPattern
    -> Pitch.PitchClass -> [[Chord]]
kotekan_pattern :: Int -> [Pitch] -> KotekanPattern -> Int -> [[Chord]]
kotekan_pattern Int
per_octave [Pitch]
centers KotekanPattern
pattern Int
pc =
    forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Maybe a -> [(a, Attributes)]
convert) forall a b. (a -> b) -> a -> b
$ KotekanPattern -> Int -> Int -> [Pitch] -> [[Maybe Pitch]]
assign_positions KotekanPattern
pattern Int
per_octave Int
pc [Pitch]
centers
    where convert :: Maybe a -> [(a, Attributes)]
convert = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\a
p -> [(a
p, forall a. Monoid a => a
mempty)])

assign_positions :: KotekanPattern -> Pitch.PitchClass -> Pitch.PitchClass
    -> [Pitch.Pitch] -> [[Maybe Pitch.Pitch]]
assign_positions :: KotekanPattern -> Int -> Int -> [Pitch] -> [[Maybe Pitch]]
assign_positions (KotekanPattern ([Maybe Int], Int)
above ([Maybe Int], Int)
below) Int
per_octave Int
destination =
    forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {b}. ((a, b), b) -> a
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a b.
Ord key =>
(a -> b -> key) -> [a] -> [b] -> [(a, b)]
assign_closest forall {a}. (a, Pitch) -> Pitch -> Int
distance [([Maybe Pitch], Pitch)]
absolute
    where
    -- Kotekan at theoretical positions in every octave.
    absolute :: [([Maybe Pitch], Pitch)]
absolute = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Pitch
dest -> forall a b. (a -> b) -> [a] -> [b]
map (forall {f :: * -> *}.
Functor f =>
Pitch -> ([f Int], Int) -> ([f Pitch], Pitch)
transpose Pitch
dest) [([Maybe Int], Int)
below, ([Maybe Int], Int)
above])
        [Int -> Degree -> Pitch
Pitch.Pitch Int
oct (Int -> Int -> Degree
Pitch.Degree Int
destination Int
0) | Int
oct <- [Int
0..]]
    transpose :: Pitch -> ([f Int], Int) -> ([f Pitch], Pitch)
transpose Pitch
pitch ([f Int]
steps, Int
last) =
        (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pitch -> Int -> Pitch
add Pitch
pitch)) [f Int]
steps, Pitch -> Int -> Pitch
add Pitch
pitch Int
last)
    add :: Pitch -> Int -> Pitch
add Pitch
pitch Int
steps = Int -> Int -> Pitch -> Pitch
Pitch.add_pc Int
per_octave Int
steps Pitch
pitch
    extract :: ((a, b), b) -> a
extract ((a
steps, b
_), b
_) = a
steps
    distance :: (a, Pitch) -> Pitch -> Int
distance (a
_, Pitch
last) Pitch
center = forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ Int -> Pitch -> Pitch -> Int
Pitch.diff_pc Int
per_octave Pitch
last Pitch
center

-- | Find the value from the first list that is closest to the first element of
-- the first list, and then zip them up.
assign_closest :: Ord key => (a -> b -> key) -> [a] -> [b] -> [(a, b)]
assign_closest :: forall key a b.
Ord key =>
(a -> b -> key) -> [a] -> [b] -> [(a, b)]
assign_closest a -> b -> key
distance = [a] -> [b] -> [(a, b)]
go
    where
    go :: [a] -> [b] -> [(a, b)]
go [] [b]
_ = []
    go [a]
_ [] = []
    go (a
x1 : xs :: [a]
xs@(a
x2:[a]
_)) (b
y:[b]
ys)
        | a -> b -> key
distance a
x1 b
y forall a. Ord a => a -> a -> Bool
< a -> b -> key
distance a
x2 b
y = (a
x1, b
y) forall a. a -> [a] -> [a]
: forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [b]
ys
        | Bool
otherwise = [a] -> [b] -> [(a, b)]
go [a]
xs (b
yforall a. a -> [a] -> [a]
:[b]
ys)
    go [a
x] (b
y:[b]
_) = [(a
x, b
y)]

parse_kotekan :: [Char] -> [Char] -> KotekanPattern
parse_kotekan :: [Char] -> [Char] -> KotekanPattern
parse_kotekan [Char]
above [Char]
below = KotekanPattern
    { kotekan_above :: ([Maybe Int], Int)
kotekan_above = (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
subtract Int
dest)) [Maybe Int]
abovep, Int
above_last forall a. Num a => a -> a -> a
- Int
dest)
    , kotekan_below :: ([Maybe Int], Int)
kotekan_below = (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
subtract Int
dest)) [Maybe Int]
belowp, Int
below_last forall a. Num a => a -> a -> a
- Int
dest)
    }
    where
    ([Maybe Int]
abovep, [Maybe Int]
belowp) = ([Char] -> [Maybe Int]
parse_relative [Char]
above, [Char] -> [Maybe Int]
parse_relative [Char]
below)
    Just Int
above_last = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a. [a] -> [a]
reverse [Maybe Int]
abovep)
    Just Int
below_last = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a. [a] -> [a]
reverse [Maybe Int]
belowp)
    Just Int
dest = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. [a] -> Maybe a
Lists.last [[Maybe Int]
belowp, [Maybe Int]
abovep]

parse_relative :: [Char] -> [Maybe Pitch.Step]
parse_relative :: [Char] -> [Maybe Int]
parse_relative = forall a b. (a -> b) -> [a] -> [b]
map Char -> Maybe Int
parse1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Char
' ')
    where
    parse1 :: Char -> Maybe Int
parse1 Char
'-' = forall a. Maybe a
Nothing
    parse1 Char
c = forall a. a -> Maybe a
Just (Char -> Int
digit Char
c)
    digit :: Char -> Int
digit Char
c = forall a. a -> Maybe a -> a
fromMaybe
        (forall a. Stack => Text -> a
errorStack forall a b. (a -> b) -> a -> b
$ Text
"Reyong.parse_kotekan: not a digit: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Char
c)
        (Char -> Maybe Int
Num.readDigit Char
c)

-- ** absolute

-- | Map a char to the notes it represents for a certain position.  Each
-- position has different set of notes available.  This is just to interpret a
-- mini-notation for each position.
type NoteTable = Map Char Chord

-- | Saih lima pitch degree.
data Degree = I | O | E | U | A deriving (Degree -> Degree -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Degree -> Degree -> Bool
$c/= :: Degree -> Degree -> Bool
== :: Degree -> Degree -> Bool
$c== :: Degree -> Degree -> Bool
Eq, Eq Degree
Degree -> Degree -> Bool
Degree -> Degree -> Ordering
Degree -> Degree -> Degree
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Degree -> Degree -> Degree
$cmin :: Degree -> Degree -> Degree
max :: Degree -> Degree -> Degree
$cmax :: Degree -> Degree -> Degree
>= :: Degree -> Degree -> Bool
$c>= :: Degree -> Degree -> Bool
> :: Degree -> Degree -> Bool
$c> :: Degree -> Degree -> Bool
<= :: Degree -> Degree -> Bool
$c<= :: Degree -> Degree -> Bool
< :: Degree -> Degree -> Bool
$c< :: Degree -> Degree -> Bool
compare :: Degree -> Degree -> Ordering
$ccompare :: Degree -> Degree -> Ordering
Ord, Int -> Degree
Degree -> Int
Degree -> [Degree]
Degree -> Degree
Degree -> Degree -> [Degree]
Degree -> Degree -> Degree -> [Degree]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Degree -> Degree -> Degree -> [Degree]
$cenumFromThenTo :: Degree -> Degree -> Degree -> [Degree]
enumFromTo :: Degree -> Degree -> [Degree]
$cenumFromTo :: Degree -> Degree -> [Degree]
enumFromThen :: Degree -> Degree -> [Degree]
$cenumFromThen :: Degree -> Degree -> [Degree]
enumFrom :: Degree -> [Degree]
$cenumFrom :: Degree -> [Degree]
fromEnum :: Degree -> Int
$cfromEnum :: Degree -> Int
toEnum :: Int -> Degree
$ctoEnum :: Int -> Degree
pred :: Degree -> Degree
$cpred :: Degree -> Degree
succ :: Degree -> Degree
$csucc :: Degree -> Degree
Enum, Int -> Degree -> ShowS
[Degree] -> ShowS
Degree -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Degree] -> ShowS
$cshowList :: [Degree] -> ShowS
show :: Degree -> [Char]
$cshow :: Degree -> [Char]
showsPrec :: Int -> Degree -> ShowS
$cshowsPrec :: Int -> Degree -> ShowS
Show)
instance Pretty Degree where pretty :: Degree -> Text
pretty = forall a. Show a => a -> Text
showt

to_pc :: Degree -> Pitch.PitchClass
to_pc :: Degree -> Int
to_pc = forall a. Enum a => a -> Int
fromEnum

parse_absolute :: NoteTable -> [Char] -> [Chord]
parse_absolute :: NoteTable -> [Char] -> [Chord]
parse_absolute NoteTable
table = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \Char
c -> forall a. a -> Maybe a -> a
fromMaybe
    (forall a. Stack => Text -> a
errorStack forall a b. (a -> b) -> a -> b
$ Text
"parse_absolute: not in table: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Char
c)
    (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
c NoteTable
table)

parse_note :: NoteTable -> Char -> Note
parse_note :: NoteTable -> Char -> Note
parse_note NoteTable
table = forall {a}. Pretty a => [a] -> a
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteTable -> [Char] -> [Chord]
parse_absolute NoteTable
table forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])
    where
    extract :: [a] -> a
extract [a
x] = a
x
    extract [a]
xs = forall a. Stack => Text -> a
errorStack forall a b. (a -> b) -> a -> b
$ Text
"parse_note: expected only one: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [a]
xs

{-
    1 penyorog        3 ponggang
             2 pengenter    4 pemetit
    |------|---       |---|---
             |------|---    |---------|
    4e 4u 4a 5i 5o 5e 5u 5a 6i 6o 6e 6u 6a 7i
-}
norot_prepare_patterns :: Map Pitch.PitchClass [[Chord]]
norot_prepare_patterns :: Pattern
norot_prepare_patterns = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [[Char]] -> [[Chord]]
parse [[[Char]]]
by_degree
    where
    parse :: [[Char]] -> [[Chord]]
parse = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith NoteTable -> [Char] -> [Chord]
parse_absolute (forall a b. (a -> b) -> [a] -> [b]
map Position -> NoteTable
pos_table [Position]
reyong_positions)
    by_degree :: [[[Char]]]
by_degree =
        -- 1       2       3       4
        [ [[Char]
"eua-", [Char]
"Iioi", [Char]
"Uua-", [Char]
"Iioi"] -- i
        , [[Char]
"ua:-", [Char]
"Ooeo", [Char]
"uai-", [Char]
"Ooeo"] -- o
        , [[Char]
"Eeue", [Char]
"Eeie", [Char]
"uau-", [Char]
"Eeue"] -- e
        , [[Char]
"Uuau", [Char]
"ioe-", [Char]
"Uuau", [Char]
"ioeu"] -- u
        , [[Char]
"Aaea", [Char]
"Eeie", [Char]
"Aa-a", [Char]
"Eeie"] -- a
        ]

norot_patterns :: Map Pitch.PitchClass [[Chord]]
norot_patterns :: Pattern
norot_patterns = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [[Char]] -> [[Chord]]
parse [[[Char]]]
by_degree
    where
    parse :: [[Char]] -> [[Chord]]
parse = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith NoteTable -> [Char] -> [Chord]
parse_absolute (forall a b. (a -> b) -> [a] -> [b]
map Position -> NoteTable
pos_table [Position]
reyong_positions)
    by_degree :: [[[Char]]]
by_degree =
        -- 1       2       3       4
        [ [[Char]
"aua-", [Char]
"oioi", [Char]
"aua-", [Char]
"oioi"] -- i
               -- i oeio
        , [[Char]
":-:-", [Char]
"eoeo", [Char]
"iai-", [Char]
"eoeo"] -- o
        , [[Char]
"ueue", [Char]
"ieie", [Char]
"u-u-", [Char]
"ueue"] -- e
        , [[Char]
"auau", [Char]
"eoe-", [Char]
"auau", [Char]
"eueu"] -- u
        , [[Char]
"eaea", [Char]
"ieie", [Char]
"-a-a", [Char]
"ieie"] -- a
        ]

-- | Map letters to chords, starting from the given octave and Degree.  Capital
-- letters get 'Attrs.mute'.
note_table :: Pitch.Octave -> Degree -> NoteTable
note_table :: Int -> Degree -> NoteTable
note_table Int
octave Degree
start = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
    (Char
'-', []) forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
notes) (forall a. Int -> [a] -> [a]
drop (Degree -> Int
to_pc Degree
start) [(Char, Chord)]
pitches)
        forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
notes) [(Char, Chord)]
muted
    where
    pitches :: [(Char, Chord)]
pitches =
        [ (Char
char, [(Int -> Degree -> Pitch
Pitch.Pitch Int
oct (Int -> Int -> Degree
Pitch.Degree Int
pc Int
0), forall a. Monoid a => a
mempty)])
        | Int
oct <- [Int
octave..], (Int
pc, Char
char) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Char]
notes
        ]
    muted :: [(Char, Chord)]
muted = [(Char -> Char
Char.toUpper Char
char, Chord -> Chord
mute Chord
notes) | (Char
char, Chord
notes) <- [(Char, Chord)]
pitches]
    mute :: Chord -> Chord
mute = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Semigroup a => a -> a -> a
<>Attributes
Attrs.mute))
    notes :: [Char]
notes = [Char]
"ioeua"

data Position = Position {
    Position -> Pitch
pos_cek :: !Pitch.Pitch
    , Position -> [Pitch]
pos_byong :: ![Pitch.Pitch]
    , Position -> NoteTable
pos_table :: !NoteTable
    } deriving (Position -> Position -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c== :: Position -> Position -> Bool
Eq, Int -> Position -> ShowS
[Position] -> ShowS
Position -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> [Char]
$cshow :: Position -> [Char]
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
Show)

reyong_positions :: [Position]
reyong_positions :: [Position]
reyong_positions = [Position
position1, Position
position2, Position
position3, Position
position4]

position1 :: Position
position1 :: Position
position1 = NoteTable -> Char -> [Char] -> Position
make_position NoteTable
ptable Char
'u' [Char]
"ea"
    where
    ptable :: NoteTable
ptable = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Char
':' (forall a b. (a -> b) -> [a] -> [b]
map (NoteTable -> Char -> Note
parse_note NoteTable
table) [Char]
"ei") NoteTable
table
        where table :: NoteTable
table = Int -> Degree -> NoteTable
note_table Int
4 Degree
E

position2 :: Position
position2 :: Position
position2 = NoteTable -> Char -> [Char] -> Position
make_position (Int -> Degree -> NoteTable
note_table Int
5 Degree
I) Char
'o' [Char]
"ie"

position3 :: Position
position3 :: Position
position3 = NoteTable -> Char -> [Char] -> Position
make_position (Int -> Degree -> NoteTable
note_table Int
5 Degree
U) Char
'a' [Char]
"ui"

position4 :: Position
position4 :: Position
position4 = NoteTable -> Char -> [Char] -> Position
make_position (Int -> Degree -> NoteTable
note_table Int
6 Degree
I) Char
'e' [Char]
"ou"

make_position :: NoteTable -> Char -> [Char] -> Position
make_position :: NoteTable -> Char -> [Char] -> Position
make_position NoteTable
table Char
cek [Char]
byong = Position
    { pos_cek :: Pitch
pos_cek = Char -> Pitch
parse Char
cek
    , pos_byong :: [Pitch]
pos_byong = forall a b. (a -> b) -> [a] -> [b]
map Char -> Pitch
parse [Char]
byong
    , pos_table :: NoteTable
pos_table = NoteTable
table
    }
    where parse :: Char -> Pitch
parse = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteTable -> Char -> Note
parse_note NoteTable
table

-- * damping

c_hand_damp :: Derive.Transformer Derive.Note
c_hand_damp :: Transformer Note
c_hand_damp = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"hand-damp" Tags
Tags.postproc
    Doc
"Damping when the parts are already divided by hand."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt ((,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"insts" Doc
"Apply damping to these instruments."
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dur" (RealTime
0.15 :: RealTime)
            Doc
"There must be at least this much time between the end of a note\
            \ and the start of the next to damp."
    ) forall a b. (a -> b) -> a -> b
$ \([Instrument]
insts, RealTime -> RealTime
dur) PassedArgs Note
_args NoteDeriver
deriver ->
        Set Instrument
-> (RealTime -> RealTime) -> Stream Note -> Stream Note
hand_damp (forall a. Ord a => [a] -> Set a
Set.fromList [Instrument]
insts) RealTime -> RealTime
dur forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NoteDeriver
deriver

hand_damp :: Set ScoreT.Instrument -> (RealTime -> RealTime)
    -> Stream.Stream Score.Event -> Stream.Stream Score.Event
hand_damp :: Set Instrument
-> (RealTime -> RealTime) -> Stream Note -> Stream Note
hand_damp Set Instrument
damped_insts RealTime -> RealTime
dur_at =
    forall a. (a -> [Note]) -> Stream a -> Stream Note
Post.emap_asc_ (Note, Maybe Note) -> [Note]
infer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (a, Maybe a)
Post.next_by Note -> (Instrument, Maybe Text)
Post.hand_key
    where
    infer :: (Note, Maybe Note) -> [Note]
infer (Note
event, Maybe Note
_)
        | Note -> Instrument
Score.event_instrument Note
event forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Instrument
damped_insts = [Note
event]
    infer (Note
event, Just Note
next) | Note -> Note -> Bool
too_close Note
event Note
next = [Note
event]
    infer (Note
event, Maybe Note
_) = Note -> [Note]
damp Note
event
    damp :: Note -> [Note]
damp Note
event = [Note
event, RealTime -> Note -> Note
make_damp RealTime
0 Note
event]
    too_close :: Note -> Note -> Bool
too_close Note
event Note
next =
        (Note -> RealTime
Score.event_start Note
next forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_end Note
event)
            forall a. Ord a => a -> a -> Bool
<= RealTime -> RealTime
dur_at (Note -> RealTime
Score.event_end Note
event)

c_infer_damp :: Derive.Transformer Derive.Note
c_infer_damp :: Transformer Note
c_infer_damp = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"infer-damp" Tags
Tags.postproc
    (Doc
"Add damping for reyong parts based on a simulation of the hand technique.\
    \ The " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Attributes
damped forall a. Semigroup a => a -> a -> a
<> Doc
" attribute will force a damp, while "
    forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Attributes
undamped forall a. Semigroup a => a -> a -> a
<> Doc
" will prevent damping. The latter can cause a\
    \ previously undamped note to become damped because the hand is now freed\
    \ up.\
    \\nThe output is additional notes with `+mute` and zero duration at note\
    \ end.")
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt ((,,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"insts" Doc
"Apply damping to these instruments."
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dur" (RealTime
0.15 :: RealTime)
            Doc
"This is how fast the player is able to damp. A note is only damped\
            \ if there is a hand available which has this much time to move\
            \ into position for the damp stroke, and then move into position\
            \ for its next note afterwards."
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"early" (RealTime
0.025 :: RealTime)
            Doc
"Damp this much before the next note, if it would be simultaneous\
            \ with the next start."
    ) forall a b. (a -> b) -> a -> b
$ \([Instrument]
insts, RealTime -> RealTime
dur, RealTime -> RealTime
early) PassedArgs Note
_args NoteDeriver
deriver ->
        -- infer_damp preserves order, so Post.apply is safe.  TODO Is there a
        -- way to express this statically?
        forall (f :: * -> *) a b.
Functor f =>
([a] -> f [b]) -> Stream a -> f (Stream b)
Post.apply_m
            (forall a. LogId a -> Deriver a
Derive.run_logs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Instrument
-> (RealTime -> RealTime)
-> (RealTime -> RealTime)
-> [Note]
-> LogId [Note]
infer_damp_voices (forall a. Ord a => [a] -> Set a
Set.fromList [Instrument]
insts) RealTime -> RealTime
dur RealTime -> RealTime
early)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NoteDeriver
deriver

-- | Multiply this by 'Controls.dynamic' for the dynamic of +mute notes created
-- by infer-damp.
damp_control :: ScoreT.Control
damp_control :: Control
damp_control = Control
"damp"

-- | Divide notes into voices.  Assign each note to a hand.  The end of each
-- note needs a free hand to damp.  That can be the same hand if the next note
-- with that hand is a sufficiently long time from now, or the opposite hand if
-- it is not too busy.
infer_damp_voices :: Set ScoreT.Instrument
    -> (RealTime -> RealTime) -- ^ duration required to damp
    -> (RealTime -> RealTime) -> [Score.Event] -> Log.LogId [Score.Event]
infer_damp_voices :: Set Instrument
-> (RealTime -> RealTime)
-> (RealTime -> RealTime)
-> [Note]
-> LogId [Note]
infer_damp_voices Set Instrument
damped_insts RealTime -> RealTime
dur_at RealTime -> RealTime
early_at [Note]
events = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
skipped) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"skipped events without pitch: "
            forall a. Semigroup a => a -> a -> a
<> [Note] -> Text
Score.short_events [Note]
skipped
    forall (m :: * -> *) a. Monad m => a -> m a
return [Note]
damped
    where
    ([Note]
skipped, [Note]
damped) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Note]] -> [Note]
Post.merge_asc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [[Note]] -> [Note]
Post.merge_asc)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {b}. ((Instrument, b), [Note]) -> ([Note], [[Note]])
infer_voice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort Note -> (Instrument, Int)
Post.voice_key forall a b. (a -> b) -> a -> b
$
        [Note]
events
    infer_voice :: ((Instrument, b), [Note]) -> ([Note], [[Note]])
infer_voice ((Instrument
inst, b
_voice), [Note]
events)
        | Instrument
inst forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Instrument
damped_insts = ([], [[Note]
events])
        | Bool
otherwise =
            ([Note]
skipped, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. ToVal a => (a, Bool) -> (Note, Maybe Note) -> [Note]
infer_event [(Hand, Bool)]
damps (forall a. [a] -> [(a, Maybe a)]
Lists.zipNext [Note]
events))
        where ([(Hand, Bool)]
damps, [Note]
skipped) = (RealTime -> RealTime) -> [Note] -> ([(Hand, Bool)], [Note])
infer_damp RealTime -> RealTime
dur_at [Note]
events
    infer_event :: (a, Bool) -> (Note, Maybe Note) -> [Note]
infer_event (a
hand, Bool
damped) (Note
event, Maybe Note
next) =
        forall a b. (a -> b) -> [a] -> [b]
map (forall a. ToVal a => Text -> a -> Note -> Note
Post.add_environ Text
EnvKey.hand a
hand) forall a b. (a -> b) -> a -> b
$ if Bool
damped
            then [(RealTime -> RealTime) -> Note -> Note
Score.duration (forall a. Num a => a -> a -> a
subtract RealTime
early) Note
event, RealTime -> Note -> Note
make_damp RealTime
early Note
event]
            else [Note
event]
        where
        early :: RealTime
early = case Maybe Note
next of
            Just Note
n | Note -> RealTime
Score.event_end Note
event forall a. Ord a => a -> a -> Bool
>= Note -> RealTime
Score.event_start Note
n ->
                RealTime -> RealTime
early_at (Note -> RealTime
Score.event_start Note
event)
            Maybe Note
_ -> RealTime
0

-- | Create a damped note at the end of the given note.
make_damp :: RealTime -> Score.Event -> Score.Event
make_damp :: RealTime -> Note -> Note
make_damp RealTime
early Note
event =
    Attributes -> Note -> Note
Score.add_attributes Attributes
Attrs.mute forall a b. (a -> b) -> a -> b
$ Y -> Note -> Note
Score.set_dynamic Y
damp forall a b. (a -> b) -> a -> b
$
    Note
event
        { event_start :: RealTime
Score.event_start = Note -> RealTime
Score.event_end Note
event forall a. Num a => a -> a -> a
- RealTime
early
        , event_duration :: RealTime
Score.event_duration = RealTime
0
        }
    where
    damp :: Y
damp = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Y
0.35 forall a. Typed a -> a
ScoreT.val_of
        (RealTime -> Control -> Note -> Maybe (Typed Y)
Score.control_at (Note -> RealTime
Score.event_end Note
event) Control
damp_control Note
event)

infer_damp :: (RealTime -> RealTime) -> [Score.Event]
    -> ([(Call.Hand, Bool)], [Score.Event])
    -- ^ (True if corresponding input event should be damped, skipped)
infer_damp :: (RealTime -> RealTime) -> [Note] -> ([(Hand, Bool)], [Note])
infer_damp RealTime -> RealTime
dur_at =
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL (RealTime, RealTime)
-> ((Hand, Note), [(Hand, Note)])
-> ((RealTime, RealTime), (Hand, Bool))
infer (RealTime
0, RealTime
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, [a])]
Lists.zipNexts) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Note] -> ([(Hand, Note)], [Note])
assign_hands
    where
    infer :: (RealTime, RealTime)
-> ((Hand, Note), [(Hand, Note)])
-> ((RealTime, RealTime), (Hand, Bool))
infer (RealTime, RealTime)
prev ((Hand
hand, Note
event), [(Hand, Note)]
nexts) = ((RealTime, RealTime)
hands_state, (Hand
hand, Bool
damp))
        where
        damp :: Bool
damp = Attributes -> Note -> Bool
Score.has_attribute Attributes
damped Note
event
            Bool -> Bool -> Bool
|| (Note -> Bool
could_damp Note
event
                Bool -> Bool -> Bool
&& (Bool
same_hand_can_damp Bool -> Bool -> Bool
|| Bool
other_hand_can_damp))
        -- The same hand can damp if its next strike is sufficiently distant.
        same_hand_can_damp :: Bool
same_hand_can_damp = forall {a}. Maybe (a, Note) -> Bool
enough_time (Hand -> Maybe (Hand, Note)
next Hand
hand)
        -- The other hand can damp if it has enough time from its previous
        -- strike to move, and the current hand has moved out of the way by
        -- changing pitches.
        -- TODO maybe doesn't need a full dur from prev strike?
        other_hand_can_damp :: Bool
other_hand_can_damp = forall (t :: * -> *). Foldable t => t Bool -> Bool
and
            [ (RealTime
now forall a. Num a => a -> a -> a
- Hand -> RealTime
prev_strike (Hand -> Hand
Call.other_hand Hand
hand)) forall a. Ord a => a -> a -> Bool
>= RealTime
dur
            , forall {a}. Maybe (a, Note) -> Bool
enough_time (Hand -> Maybe (Hand, Note)
next (Hand -> Hand
Call.other_hand Hand
hand))
            , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((forall a. Eq a => a -> a -> Bool
/= Note -> Maybe NoteNumber
Score.initial_nn Note
event) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Maybe NoteNumber
Score.initial_nn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
                (Hand -> Maybe (Hand, Note)
next Hand
hand)
            ]
        now :: RealTime
now = Note -> RealTime
Score.event_end Note
event
        prev_strike :: Hand -> RealTime
prev_strike Hand
Call.L = forall a b. (a, b) -> a
fst (RealTime, RealTime)
prev
        prev_strike Hand
Call.R = forall a b. (a, b) -> b
snd (RealTime, RealTime)
prev
        hands_state :: (RealTime, RealTime)
hands_state
            | Bool
damp = case Hand
hand of
                Hand
Call.L -> (RealTime
now, forall a b. (a, b) -> b
snd (RealTime, RealTime)
prev)
                Hand
Call.R -> (forall a b. (a, b) -> a
fst (RealTime, RealTime)
prev, RealTime
now)
            | Bool
otherwise = (RealTime, RealTime)
prev
        next :: Hand -> Maybe (Hand, Note)
next Hand
hand = forall a. [a] -> Maybe a
Lists.head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
==Hand
hand) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Hand, Note)]
nexts
        enough_time :: Maybe (a, Note) -> Bool
enough_time = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True
            ((forall a. Ord a => a -> a -> Bool
>=RealTime
dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract RealTime
now forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> RealTime
Score.event_start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
        dur :: RealTime
dur = RealTime -> RealTime
dur_at (Note -> RealTime
Score.event_start Note
event)

-- | True for events which could get an inferred damp.
could_damp :: Score.Event -> Bool
could_damp :: Note -> Bool
could_damp Note
event =
    Note -> RealTime
Score.event_duration Note
event forall a. Ord a => a -> a -> Bool
> RealTime
0
        Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs) [Attributes
undamped, Attributes
cek, Attributes
Attrs.mute])
    where attrs :: Attributes
attrs = Note -> Attributes
Score.event_attributes Note
event

damped :: Attrs.Attributes
damped :: Attributes
damped = Text -> Attributes
Attrs.attr Text
"damped"

undamped :: Attrs.Attributes
undamped :: Attributes
undamped = Text -> Attributes
Attrs.attr Text
"undamped"

-- | Assign hands based on the direction of the pitches.  This is a bit
-- simplistic but hopefully works well enough.
assign_hands :: [Score.Event] -> ([(Call.Hand, Score.Event)], [Score.Event])
assign_hands :: [Note] -> ([(Hand, Note)], [Note])
assign_hands =
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL forall {b} {b}.
Ord b =>
(Hand, b) -> (b, b) -> ((Hand, b), (Hand, b))
assign (Hand
Call.L, NoteNumber
999))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Lists.partitionOn (\Note
e -> (,Note
e) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Note -> Maybe NoteNumber
Score.initial_nn Note
e)
    where
    assign :: (Hand, b) -> (b, b) -> ((Hand, b), (Hand, b))
assign (Hand
prev_hand, b
prev_pitch) (b
pitch, b
event) =
        ((Hand
hand, b
pitch), (Hand
hand, b
event))
        where
        hand :: Hand
hand
            | b
pitch forall a. Eq a => a -> a -> Bool
== b
prev_pitch = Hand
prev_hand
            | b
pitch forall a. Ord a => a -> a -> Bool
> b
prev_pitch = Hand
Call.R
            | Bool
otherwise = Hand
Call.L

-- * patterns

baris :: [([Char], [Char])]
baris :: [([Char], [Char])]
baris =
    [ ( [Char]
"-e-oe-eo-eo-oe-oeo-eo-oe-oe-eo-e"
      , [Char]
"-ai-aia-ia-i-ai-a-ia-i-ai-aia-ia"
      )
    ]

-- * realize-reyong

c_realize_reyong :: Derive.Transformer Derive.Note
c_realize_reyong :: Transformer Note
c_realize_reyong = forall a. Stack => Text -> Either Text a -> a
StaticMacro.check Text
"c_realize_reyong" forall a b. (a -> b) -> a -> b
$
    forall d.
CallableExpr d =>
Module
-> CallName
-> Tags
-> Doc
-> [Call (Transformer d)]
-> Either Text (Transformer d)
StaticMacro.transformer Module
module_ CallName
"realize-reyong" Tags
Tags.postproc Doc
doc
        -- infer-damp relies on having the ngoret pitches and will get confused
        -- by uncalled notes, so it has to go after those.
        [ forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
c_infer_damp [Arg
StaticMacro.Var, Arg
StaticMacro.Var]
        , forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
c_cancel_kotekan [Arg
StaticMacro.Var]
        , forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
Gender.c_realize_ngoret []
        ]
    where doc :: Doc
doc = Doc
"Combine the reyong realize calls in the right order."

c_realize_trompong :: Derive.Transformer Derive.Note
c_realize_trompong :: Transformer Note
c_realize_trompong = forall a. Stack => Text -> Either Text a -> a
StaticMacro.check Text
"c_realize_trompong" forall a b. (a -> b) -> a -> b
$
    forall d.
CallableExpr d =>
Module
-> CallName
-> Tags
-> Doc
-> [Call (Transformer d)]
-> Either Text (Transformer d)
StaticMacro.transformer Module
module_ CallName
"realize-trompong" Tags
Tags.postproc Doc
doc
        -- infer-damp relies on having the ngoret pitches and will get confused
        -- by uncalled notes, so it has to go after those.
        [ forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
c_hand_damp [Arg
StaticMacro.Var, Arg
StaticMacro.Var]
        , forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
Gender.c_realize_ngoret []
        ]
    where doc :: Doc
doc = Doc
"Combine the reyong realize calls in the right order."

-- * octave transposition

c_lower_octave_note :: Derive.Transformer Derive.Note
c_lower_octave_note :: Transformer Note
c_lower_octave_note = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"lower-octave-note"
    (Tags
Tags.postproc forall a. Semigroup a => a -> a -> a
<> Tags
Tags.under_invert)
    Doc
"Double a note with a single note one octave down, and add\
    \ 'Derive.Flags.infer_duration'."
    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
$ TransformerF Note -> TransformerF Note
Sub.under_invert forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args NoteDeriver
deriver -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        Pitch
pitch <- RealTime -> Deriver Pitch
Call.get_pitch RealTime
start
        let note :: NoteDeriver
note = Flags -> NoteDeriver -> NoteDeriver
Call.add_flags Flags
Flags.infer_duration forall a b. (a -> b) -> a -> b
$
                forall a. TrackTime -> Deriver a -> Deriver a
Derive.at (forall a. PassedArgs a -> TrackTime
Args.start PassedArgs Note
args) forall a b. (a -> b) -> a -> b
$ Pitch -> NoteDeriver
Call.pitched_note forall a b. (a -> b) -> a -> b
$
                forall a. Control -> Y -> RawPitch a -> RawPitch a
PSignal.add_control Control
Controls.octave (-Y
1) Pitch
pitch
        -- The transposed goes second so realize-ngoret infers to the upper
        -- pitch rather than the lower one.  This is kind of subtle and
        -- unsatisfying, but works.
        NoteDeriver
deriver forall a. Semigroup a => a -> a -> a
<> NoteDeriver
note

c_upper :: Library.Calls Derive.Note
c_upper :: Calls Note
c_upper = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
module_ CallName
"upper" Tags
Tags.inst
    (Doc
"Double a part with `" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty Control
Controls.octave
        forall a. Semigroup a => a -> a -> a
<> Doc
"=+1` and `" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty Text
EnvKey.voice
        forall a. Semigroup a => a -> a -> a
<> Doc
"=2`. If reyong subtracks have `v=+1` and `v=+2` respectively,\
        \ they'll wind up with the right voices.")
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$ \() NoteDeriver
deriver ->
        NoteDeriver
deriver forall a. Semigroup a => a -> a -> a
<> forall a. Control -> Y -> Deriver a -> Deriver a
Call.add_constant Control
Controls.octave Y
1
            (forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
EnvKey.voice (Int
2 :: Int) NoteDeriver
deriver)

-- * solkattu

solkattu_module :: Module.Module
solkattu_module :: Module
solkattu_module = Module
module_ forall a. Semigroup a => a -> a -> a
<> Module
"solkattu"

-- | These calls are used by the 'Derive.Solkattu.Instrument.Reyong'
-- realization.
c_solkattu_note :: [Pitch.Step] -> Derive.Generator Derive.Note
c_solkattu_note :: [Int] -> Generator Note
c_solkattu_note [Int]
steps = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
solkattu_module CallName
"solkattu-note"
    Tags
Tags.inst Doc
"A pitched note, as generated by reyong solkattu."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args ->
        forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (forall {a}.
Integral a =>
TrackTime -> TrackTime -> a -> NoteDeriver
realize (forall a. PassedArgs a -> TrackTime
Args.start PassedArgs Note
args) (forall a. PassedArgs a -> TrackTime
Args.next PassedArgs Note
args)) [Int]
steps
    where
    realize :: TrackTime -> TrackTime -> a -> NoteDeriver
realize TrackTime
start TrackTime
next a
step =
        forall a. TrackTime -> TrackTime -> Deriver a -> Deriver a
Derive.place TrackTime
start (TrackTime
next forall a. Num a => a -> a -> a
- TrackTime
start) forall a b. (a -> b) -> a -> b
$
        forall a. Control -> Y -> Deriver a -> Deriver a
Call.add_constant Control
Controls.diatonic (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
step)
        NoteDeriver
Call.note