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

-- | Library of standard mridangam patterns.
module Derive.C.India.Mridangam where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified Util.Test.ApproxEq as ApproxEq

import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Flags as Flags
import qualified Derive.Library as Library
import qualified Derive.Score as Score
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Typecheck as Typecheck

import qualified Solkattu.Instrument.Mridangam as Mridangam
import qualified Solkattu.Instrument.ToScore as ToScore
import qualified Solkattu.Realize as Realize
import qualified Solkattu.S as S
import qualified Solkattu.Solkattu as Solkattu

import qualified Ui.Types as Types

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
    [ (Symbol
"seq", Parser [Stroke] -> Generator Event
c_sequence Parser [Stroke]
sequence_arg)
    , (Symbol
"p", Generator Event
c_pattern)
    , (Symbol
"tir", Generator Event
c_tirmanam)

    -- standard sequences
    -- dikutarikitataka - There are various other ways to play this.
    , (Symbol
"8n", Parser [Stroke] -> Generator Event
c_sequence (Text -> Parser [Stroke]
p Text
"n+u+kt+k"))
    , (Symbol
"tk", Parser [Stroke] -> Generator Event
c_sequence (Text -> Parser [Stroke]
p Text
"k+"))
    , (Symbol
"tknk", Parser [Stroke] -> Generator Event
c_sequence (Text -> Parser [Stroke]
p Text
"k+n+"))
    ]
    where
    p :: Text -> Parser [Stroke]
p = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Stroke]
parse_sequence

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

c_sequence :: Sig.Parser [Stroke] -> Derive.Generator Derive.Note
c_sequence :: Parser [Stroke] -> Generator Event
c_sequence Parser [Stroke]
sequence_arg = forall d.
(PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
Derive.with_score_duration forall {a}.
Taggable a =>
PassedArgs a -> Deriver (CallDuration ScoreTime)
score_duration forall a b. (a -> b) -> a -> b
$
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"sequence" Tags
Tags.inst
    Doc
"Play a sequence of mridangam strokes. Each one takes the given `dur`, and\
    \ if the event is longer than the sequence, it is repeated to fill up\
    \ available space. If a whole cycle doesn't fit, clip from the end for a\
    \ positive event, or from the beginning for a negative one.\
    \ If `dur` is 0, then stretch to the sequence to fit the event."
    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 ([Stroke], ScoreTime)
signature forall a b. (a -> b) -> a -> b
$ \([Stroke]
sequence, ScoreTime
dur) ->
    forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> do
        let seq :: [(Duration, Maybe NoteDeriver)]
seq = forall a b. (a -> b) -> [a] -> [b]
map (Duration
1,) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Context Event -> Stroke -> Maybe NoteDeriver
realize_stroke (forall a. PassedArgs a -> Context a
Args.context PassedArgs Event
args)) [Stroke]
sequence
        [(Duration, Maybe NoteDeriver)]
-> ScoreTime
-> (ScoreTime, ScoreTime)
-> Orientation
-> NoteDeriver
m_sequence [(Duration, Maybe NoteDeriver)]
seq ScoreTime
dur (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Event
args) (forall a. PassedArgs a -> Orientation
Args.orientation PassedArgs Event
args)
    where
    signature :: Parser ([Stroke], ScoreTime)
signature = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Stroke]
sequence_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_arg
    score_duration :: PassedArgs a -> Deriver (CallDuration ScoreTime)
score_duration PassedArgs a
args = do
        ([Stroke]
sequence, ScoreTime
matra_dur) <- forall d a. Taggable d => Parser a -> PassedArgs d -> Deriver a
Sig.parse_or_throw Parser ([Stroke], ScoreTime)
signature PassedArgs a
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> CallDuration a
Derive.CallDuration forall a b. (a -> b) -> a -> b
$ if
            | ScoreTime
matra_dur forall a. Eq a => a -> a -> Bool
== ScoreTime
0 -> forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs a
args
            | Bool
otherwise -> (if forall a. PassedArgs a -> Bool
Args.negative PassedArgs a
args then forall a. Num a => a -> a
negate else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
                forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stroke]
sequence) forall a. Num a => a -> a -> a
* ScoreTime
matra_dur

sequence_arg :: Sig.Parser [Stroke]
sequence_arg :: Parser [Stroke]
sequence_arg = Text -> [Stroke]
parse_sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"sequence" EnvironDefault
Sig.Unprefixed
    Doc
"Single letter stroke names.  `_` or space is a rest."

dur_arg :: Sig.Parser ScoreTime
dur_arg :: Parser ScoreTime
dur_arg = forall a. NonNegative a -> a
Typecheck.non_negative forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"dur" EnvironDefault
Sig.Both (ScoreTime
0 :: ScoreTime)
        Doc
"Duration for each letter in the sequence. If 0, the sequence will\
        \ stretch to the event's duration."

m_sequence :: [(S.Duration, Maybe Derive.NoteDeriver)] -> ScoreTime
    -> (TrackTime, TrackTime) -> Types.Orientation -> Derive.NoteDeriver
m_sequence :: [(Duration, Maybe NoteDeriver)]
-> ScoreTime
-> (ScoreTime, ScoreTime)
-> Orientation
-> NoteDeriver
m_sequence [(Duration, Maybe NoteDeriver)]
notes ScoreTime
dur (ScoreTime
start, ScoreTime
end) Orientation
orientation = forall {a}.
Monoid (Deriver a) =>
[(ScoreTime, Deriver a)] -> Deriver a
realize forall a b. (a -> b) -> a -> b
$ case Orientation
orientation of
    Orientation
_ | ScoreTime
dur forall a. Eq a => a -> a -> Bool
== ScoreTime
0 -> forall a.
(ScoreTime, ScoreTime) -> [(Duration, Maybe a)] -> [(ScoreTime, a)]
stretch_to_range (ScoreTime
start, ScoreTime
end) [(Duration, Maybe NoteDeriver)]
notes
    Orientation
Types.Positive -> forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((forall a. Ord a => a -> a -> Bool
<ScoreTime
end) 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} {a} {b2}.
(Real a, Fractional a) =>
a -> a -> [(a, Maybe b2)] -> [(a, b2)]
place ScoreTime
start ScoreTime
dur (forall a. [a] -> [a]
cycle [(Duration, Maybe NoteDeriver)]
notes)
    Orientation
Types.Negative -> forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((forall a. Ord a => a -> a -> Bool
>=ScoreTime
start) 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} {a} {b2}.
(Real a, Fractional a) =>
a -> a -> [(a, Maybe b2)] -> [(a, b2)]
place ScoreTime
end (-ScoreTime
dur) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
cycle (forall a. [a] -> [a]
reverse [(Duration, Maybe NoteDeriver)]
notes)
    where
    place :: a -> a -> [(a, Maybe b2)] -> [(a, b2)]
place a
from a
step = forall b b2 a. (b -> Maybe b2) -> [(a, b)] -> [(a, b2)]
Lists.mapMaybeSnd forall a. a -> a
id 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 (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL forall {a} {b}. Real a => a -> (a, b) -> (a, (a, b))
note a
from
        where note :: a -> (a, b) -> (a, (a, b))
note a
t (a
d, b
n) = (a
t forall a. Num a => a -> a -> a
+ forall a b. (Real a, Fractional b) => a -> b
realToFrac a
d forall a. Num a => a -> a -> a
* a
step, (a
t, b
n))
    realize :: [(ScoreTime, Deriver a)] -> Deriver a
realize [(ScoreTime, Deriver a)]
notes =
        forall a. Monoid a => [a] -> a
mconcat [forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
0 Deriver a
note | (ScoreTime
start, Deriver a
note) <- [(ScoreTime, Deriver a)]
notes]

stretch_to_range :: (ScoreTime, ScoreTime) -> [(S.Duration, Maybe a)]
    -> [(ScoreTime, a)]
stretch_to_range :: forall a.
(ScoreTime, ScoreTime) -> [(Duration, Maybe a)] -> [(ScoreTime, a)]
stretch_to_range (ScoreTime
start, ScoreTime
end) [(Duration, Maybe a)]
dur_notes =
    [(ScoreTime
t, a
note) | (ScoreTime
t, Just a
note) <- forall a b. [a] -> [b] -> [(a, b)]
zip [ScoreTime]
starts [Maybe a]
notes]
    where
    starts :: [ScoreTime]
starts = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) ScoreTime
start forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
*ScoreTime
factor) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac) [Duration]
durs
    ([Duration]
durs, [Maybe a]
notes) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Duration, Maybe a)]
dur_notes
    factor :: ScoreTime
factor = (ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
start) forall a. Fractional a => a -> a -> a
/ forall a b. (Real a, Fractional b) => a -> b
realToFrac (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [Duration]
durs)

-- TODO make this into a Typecheck
-- actually I think I maybe don't support that?
parse_sequence :: Text -> [Stroke]
parse_sequence :: Text -> [Stroke]
parse_sequence = forall a b. (a -> b) -> [a] -> [b]
map Char -> Stroke
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
    where
    parse :: Char -> Stroke
parse Char
c
        | Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' = Stroke
Rest
        | Bool
otherwise = Char -> Stroke
Stroke Char
c

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

instance Pretty Stroke where pretty :: Stroke -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val
instance ShowVal.ShowVal Stroke where
    show_val :: Stroke -> Text
show_val Stroke
Rest = Text
"_"
    show_val (Stroke Char
c) = Char -> Text
Text.singleton Char
c

-- * c_pattern

c_pattern :: Derive.Generator Derive.Note
c_pattern :: Generator Event
c_pattern = forall d.
(PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
Derive.with_score_duration forall {a}.
Taggable a =>
PassedArgs a -> Deriver (CallDuration ScoreTime)
score_duration forall a b. (a -> b) -> a -> b
$
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"pattern" Tags
Tags.inst
    Doc
"Like `seq`, but pick a standard 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 (Maybe Int, Text, ScoreTime)
signature forall a b. (a -> b) -> a -> b
$ \(Maybe Int
maybe_strokes, Text
variation, ScoreTime
matra_dur) ->
    forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> do
        Int
strokes <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ScoreTime -> ScoreTime -> Deriver Int
infer_strokes ScoreTime
matra_dur (forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Event
args)) forall (m :: * -> *) a. Monad m => a -> m a
return
            Maybe Int
maybe_strokes
        [(Duration, Note Stroke)]
notes <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Int -> Text -> Either Text [(Duration, Note Stroke)]
infer_pattern Int
strokes Text
variation
        [(Duration, Maybe NoteDeriver)]
notes <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Context Event -> Note Stroke -> Maybe NoteDeriver
realize_mstroke (forall a. PassedArgs a -> Context a
Args.context PassedArgs Event
args))) [(Duration, Note Stroke)]
notes
        [(Duration, Maybe NoteDeriver)]
-> ScoreTime
-> (ScoreTime, ScoreTime)
-> Orientation
-> NoteDeriver
m_sequence [(Duration, Maybe NoteDeriver)]
notes ScoreTime
matra_dur (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Event
args) (forall a. PassedArgs a -> Orientation
Args.orientation PassedArgs Event
args)
    where
    signature :: Parser (Maybe Int, Text, ScoreTime)
signature = (,,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Positive a -> a
Typecheck.positive
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"n" Doc
"Number of strokes. If not given, and\
                \ dur > 0, then infer the number of strokes as the\
                \ event_duration / dur.")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"var" EnvironDefault
Sig.Both Text
default_variation
            (Doc
"Variation name. Possibilities are: "
                forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
Doc.commas (forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
Doc.literal (forall k a. Map k a -> [k]
Map.keys Map Text (PatternMap Stroke)
variations)))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_arg
    score_duration :: PassedArgs a -> Deriver (CallDuration ScoreTime)
score_duration PassedArgs a
args = do
        (Maybe Int
maybe_strokes, Text
_, ScoreTime
matra_dur) <- forall d a. Taggable d => Parser a -> PassedArgs d -> Deriver a
Sig.parse_or_throw Parser (Maybe Int, Text, ScoreTime)
signature PassedArgs a
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> CallDuration a
Derive.CallDuration forall a b. (a -> b) -> a -> b
$ case Maybe Int
maybe_strokes of
            Maybe Int
Nothing -> forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs a
args
            Just Int
strokes -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
strokes forall a. Num a => a -> a -> a
* ScoreTime
matra_dur

infer_pattern :: S.Matra -> Text
    -> Either Text [(S.Duration, Realize.Note Mridangam.Stroke)]
infer_pattern :: Int -> Text -> Either Text [(Duration, Note Stroke)]
infer_pattern Int
dur Text
variation = do
    PatternMap Stroke
patterns <- forall err a. err -> Maybe a -> Either err a
justErr (Text
"unknown variation " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
variation) forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
variation Map Text (PatternMap Stroke)
variations
    [SNote Stroke]
notes <- forall err a. err -> Maybe a -> Either err a
justErr
        (Text
"variation " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
variation forall a. Semigroup a => a -> a -> a
<> Text
" doesn't have duration: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
dur)
        (forall stroke. Pattern -> PatternMap stroke -> Maybe [SNote stroke]
Realize.lookupPattern (Int -> Pattern
Solkattu.pattern Int
dur) PatternMap Stroke
patterns)
    -- (*4) because each note is 1 matra, which is 1/4 Duration, and I want
    -- duration in matras.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Num a => a -> a -> a
*Duration
4)) forall a b. (a -> b) -> a -> b
$ forall g a. [Flat g a] -> [a]
S.flattenedNotes forall a b. (a -> b) -> a -> b
$
        forall a g. HasMatras a => [Flat g a] -> [Flat g (Duration, a)]
S.withDurations forall a b. (a -> b) -> a -> b
$ forall g a. [Note g a] -> [Flat g a]
S.flatten [SNote Stroke]
notes

realize_mstroke :: Derive.Context Score.Event -> Realize.Note Mridangam.Stroke
    -> Maybe Derive.NoteDeriver
realize_mstroke :: Context Event -> Note Stroke -> Maybe NoteDeriver
realize_mstroke Context Event
ctx = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall d.
CallableExpr d =>
Context d -> Expr MiniVal -> Deriver (Stream d)
Eval.eval_expr_val Context Event
ctx) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stroke.
ToExpr (Stroke stroke) =>
Note stroke -> Maybe (Expr MiniVal)
ToScore.toExpr

infer_strokes :: ScoreTime -> ScoreTime -> Derive.Deriver Int
infer_strokes :: ScoreTime -> ScoreTime -> Deriver Int
infer_strokes ScoreTime
dur ScoreTime
event_dur
    | ScoreTime
dur forall a. Ord a => a -> a -> Bool
> ScoreTime
0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor (ScoreTime
event_dur forall a. Fractional a => a -> a -> a
/ ScoreTime
dur)
    | Bool
otherwise = forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"can't infer both number of strokes and\
        \ duration of strokes simultaneously"

default_variation :: Text
default_variation :: Text
default_variation = Text
"d"

variations :: Map Text (Realize.PatternMap Mridangam.Stroke)
variations :: Map Text (PatternMap Stroke)
variations = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
    [ (Text
default_variation,  PatternMap Stroke
Mridangam.defaultPatterns)
    , (Text
"kt_kn_o", PatternMap Stroke
Mridangam.kt_kn_o)
    ] forall a. [a] -> [a] -> [a]
++
    [ (Text
"f567-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Integer
n, PatternMap Stroke
p) | (Integer
n, PatternMap Stroke
p) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [PatternMap Stroke]
Mridangam.families567]

-- * c_tirmanam

c_tirmanam :: Derive.Generator Derive.Note
c_tirmanam :: Generator Event
c_tirmanam = forall d.
(PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
Derive.with_score_duration forall {a}.
Taggable a =>
PassedArgs a -> Deriver (CallDuration ScoreTime)
score_duration forall a b. (a -> b) -> a -> b
$
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"tir" Tags
Tags.inst
    Doc
"Repeat a sequence three times. If the duration is negative, put the first\
    \ stroke of the karvai at the end time with `{strong}`."
    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 ([Stroke], [Stroke], ScoreTime)
signature forall a b. (a -> b) -> a -> b
$ \([Stroke]
sequence, [Stroke]
karvai, ScoreTime
matra_dur) ->
    forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> do
        [(ScoreTime, Stroke)]
sequence3 <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
            [Stroke]
-> [Stroke]
-> ScoreTime
-> ScoreTime
-> Either Text [(ScoreTime, Stroke)]
tirmanam [Stroke]
sequence [Stroke]
karvai ScoreTime
matra_dur (forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Event
args)
        Context Event
-> (ScoreTime, ScoreTime) -> [(ScoreTime, Stroke)] -> NoteDeriver
realize_sequence (forall a. PassedArgs a -> Context a
Args.context PassedArgs Event
args) (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Event
args) [(ScoreTime, Stroke)]
sequence3
    where
    signature :: Parser ([Stroke], [Stroke], ScoreTime)
signature = (,,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Stroke]
sequence_arg
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> [Stroke]
parse_sequence 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
"karvai" (Text
"" :: Text)
        Doc
"Separates each sequence. If it's empty or a single non-rest, then the\
        \ gap can stretch to an integral number of matras.")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_arg -- TODO nadai arg?
    score_duration :: PassedArgs a -> Deriver (CallDuration ScoreTime)
score_duration PassedArgs a
args = do
        ([Stroke]
sequence, [Stroke]
karvai, ScoreTime
matra_dur) <- forall d a. Taggable d => Parser a -> PassedArgs d -> Deriver a
Sig.parse_or_throw Parser ([Stroke], [Stroke], ScoreTime)
signature PassedArgs a
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> CallDuration a
Derive.CallDuration forall a b. (a -> b) -> a -> b
$ if
            | ScoreTime
matra_dur forall a. Eq a => a -> a -> Bool
== ScoreTime
0 -> forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs a
args
            | Bool
otherwise -> (if forall a. PassedArgs a -> Bool
Args.negative PassedArgs a
args then forall a. Num a => a -> a
negate else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
                forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stroke]
sequence forall a. Num a => a -> a -> a
* Int
3 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stroke]
karvai forall a. Num a => a -> a -> a
* Int
2)
                    forall a. Num a => a -> a -> a
* ScoreTime
matra_dur

realize_sequence :: Derive.Context Score.Event -> (ScoreTime, ScoreTime)
    -> [(ScoreTime, Stroke)] -> Derive.NoteDeriver
realize_sequence :: Context Event
-> (ScoreTime, ScoreTime) -> [(ScoreTime, Stroke)] -> NoteDeriver
realize_sequence Context Event
ctx (ScoreTime
start, ScoreTime
end) [(ScoreTime, Stroke)]
dur_strokes = forall a. Monoid a => [a] -> a
mconcat
    [forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
t ScoreTime
0 (ScoreTime -> NoteDeriver -> NoteDeriver
add_flag ScoreTime
t NoteDeriver
note) | (ScoreTime
t, Just NoteDeriver
note) <- forall a b. [a] -> [b] -> [(a, b)]
zip [ScoreTime]
starts [Maybe NoteDeriver]
notes]
    where
    add_flag :: ScoreTime -> NoteDeriver -> NoteDeriver
add_flag ScoreTime
t NoteDeriver
note
        | ScoreTime
t forall a. Eq a => a -> a -> Bool
== ScoreTime
end = Flags -> NoteDeriver -> NoteDeriver
Call.add_flags Flags
Flags.strong NoteDeriver
note
        | Bool
otherwise = NoteDeriver
note
    notes :: [Maybe NoteDeriver]
notes = forall a b. (a -> b) -> [a] -> [b]
map (Context Event -> Stroke -> Maybe NoteDeriver
realize_stroke Context Event
ctx) [Stroke]
strokes
    ([ScoreTime]
durs, [Stroke]
strokes) = forall a b. [(a, b)] -> ([a], [b])
unzip [(ScoreTime, Stroke)]
dur_strokes
    starts :: [ScoreTime]
starts = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) ScoreTime
start [ScoreTime]
durs

tirmanam :: [Stroke] -> [Stroke] -> ScoreTime -> ScoreTime
    -> Either Text [(ScoreTime, Stroke)]
tirmanam :: [Stroke]
-> [Stroke]
-> ScoreTime
-> ScoreTime
-> Either Text [(ScoreTime, Stroke)]
tirmanam [Stroke]
sequence [Stroke]
karvai ScoreTime
matra_dur ScoreTime
event_dur = (forall {a} {a}.
(Num a, IsString a) =>
[(a, Stroke)] -> Either a [(a, Stroke)]
add_final=<<) forall a b. (a -> b) -> a -> b
$ if
    | ScoreTime
matra_dur forall a. Eq a => a -> a -> Bool
== ScoreTime
0 ->
        let p :: [Stroke]
p = [Stroke]
sequence forall a. [a] -> [a] -> [a]
++ [Stroke]
karvai forall a. [a] -> [a] -> [a]
++ [Stroke]
sequence forall a. [a] -> [a] -> [a]
++ [Stroke]
karvai forall a. [a] -> [a] -> [a]
++ [Stroke]
sequence
        in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a
abs ScoreTime
event_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 [Stroke]
p),) [Stroke]
p
    | Bool
otherwise -> do
        [(ScoreTime, Stroke)]
karvai_durs <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"event dur " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ScoreTime
event_dur forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) forall a b. (a -> b) -> a -> b
$
            [Stroke]
-> [Stroke]
-> ScoreTime
-> ScoreTime
-> Either Text [(ScoreTime, Stroke)]
stretch_karvai [Stroke]
sequence [Stroke]
karvai ScoreTime
matra_dur (forall a. Num a => a -> a
abs ScoreTime
event_dur)
        let p :: [(ScoreTime, Stroke)]
p = forall a b. (a -> b) -> [a] -> [b]
map (ScoreTime
matra_dur,) [Stroke]
sequence
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(ScoreTime, Stroke)]
p forall a. [a] -> [a] -> [a]
++ [(ScoreTime, Stroke)]
karvai_durs forall a. [a] -> [a] -> [a]
++ [(ScoreTime, Stroke)]
p forall a. [a] -> [a] -> [a]
++ [(ScoreTime, Stroke)]
karvai_durs forall a. [a] -> [a] -> [a]
++ [(ScoreTime, Stroke)]
p
    where
    add_final :: [(a, Stroke)] -> Either a [(a, Stroke)]
add_final [(a, Stroke)]
sequence
        | ScoreTime
event_dur forall a. Ord a => a -> a -> Bool
< ScoreTime
0 = case forall a. [a] -> Maybe a
Lists.head [Stroke]
karvai of
            Just Stroke
s | Stroke
s forall a. Eq a => a -> a -> Bool
/= Stroke
Rest -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(a, Stroke)]
sequence forall a. [a] -> [a] -> [a]
++ [(a
0, Stroke
s)]
            Maybe Stroke
_ -> forall a b. a -> Either a b
Left a
"karvai should start with non-rest for a negative event"
        | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return [(a, Stroke)]
sequence

realize_stroke :: Derive.Context Score.Event -> Stroke
    -> Maybe Derive.NoteDeriver
realize_stroke :: Context Event -> Stroke -> Maybe NoteDeriver
realize_stroke Context Event
_ Stroke
Rest = forall a. Maybe a
Nothing
realize_stroke Context Event
ctx (Stroke Char
c) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
    Generator Event
call <- forall d. Callable (Generator d) => Symbol -> Deriver (Generator d)
Eval.get_generator (Text -> Symbol
Expr.Symbol (Char -> Text
Text.singleton Char
c))
    forall d. Context d -> Generator d -> [Val] -> Deriver (Stream d)
Eval.apply_generator Context Event
ctx Generator Event
call []

stretch_karvai :: [Stroke] -> [Stroke] -> ScoreTime -> ScoreTime
    -> Either Text [(ScoreTime, Stroke)]
stretch_karvai :: [Stroke]
-> [Stroke]
-> ScoreTime
-> ScoreTime
-> Either Text [(ScoreTime, Stroke)]
stretch_karvai [Stroke]
sequence [Stroke]
karvai ScoreTime
matra_dur ScoreTime
event_dur = if
    | ScoreTime
matra_dur forall a. Eq a => a -> a -> Bool
== ScoreTime
0 -> forall a b. a -> Either a b
Left Text
"matra dur of 0" -- caller should stretch
    | Bool
stretch -> if
        | ScoreTime
stretch_dur forall a. Ord a => a -> a -> Bool
< ScoreTime
0 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"would have to stretch karvai to "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ScoreTime
stretch_dur
        | Bool -> Bool
not (forall a. RealFrac a => a -> Bool
Num.integral (ScoreTime
karvai_dur forall a. Fractional a => a -> a -> a
/ ScoreTime
matra_dur)) ->
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"karvai would have to be " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (ScoreTime
karvai_dur forall a. Fractional a => a -> a -> a
/ ScoreTime
matra_dur)
                forall a. Semigroup a => a -> a -> a
<> Text
" matras"
        | Bool
otherwise -> case forall a. [a] -> Maybe ([a], a)
Lists.unsnoc [Stroke]
karvai of
            Maybe ([Stroke], Stroke)
Nothing -> forall a b. b -> Either a b
Right [(ScoreTime
karvai_dur, Stroke
Rest)]
            Just ([Stroke]
ks, Stroke
k) ->
                forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ScoreTime
matra_dur,) [Stroke]
ks forall a. [a] -> [a] -> [a]
++ [(ScoreTime
stretch_dur, Stroke
k)]
    | forall a. ApproxEq a => Double -> a -> a -> Bool
ApproxEq.neq Double
0.001 (Int -> ScoreTime
to_dur Int
strokes) ScoreTime
event_dur ->
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Int
strokes forall a. Semigroup a => a -> a -> a
<> Text
"*" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ScoreTime
matra_dur
            forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Int -> ScoreTime
to_dur Int
strokes)
    | Bool
otherwise -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ScoreTime
matra_dur,) [Stroke]
karvai
    where
    strokes :: Int
strokes = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stroke]
sequence forall a. Num a => a -> a -> a
* Int
3 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stroke]
karvai forall a. Num a => a -> a -> a
* Int
2
    -- Total duration of one karvai.
    karvai_dur :: ScoreTime
karvai_dur = (ScoreTime
event_dur forall a. Num a => a -> a -> a
- Int -> ScoreTime
to_dur (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stroke]
sequence forall a. Num a => a -> a -> a
* Int
3)) forall a. Fractional a => a -> a -> a
/ ScoreTime
2
    -- The final karvai stroke must be this duration.
    stretch_dur :: ScoreTime
stretch_dur = ScoreTime
karvai_dur forall a. Num a => a -> a -> a
- Int -> ScoreTime
to_dur (forall a. Ord a => a -> a -> a
max Int
0 (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stroke]
karvai forall a. Num a => a -> a -> a
- Int
1))
    stretch :: Bool
stretch = case [Stroke]
karvai of
        [] -> Bool
True
        [Stroke
s] | Stroke
s forall a. Eq a => a -> a -> Bool
/= Stroke
Rest -> Bool
True
        [Stroke]
_ -> Bool
False
    to_dur :: Int -> ScoreTime
to_dur = (forall a. Num a => a -> a -> a
*ScoreTime
matra_dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral