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

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-- | Functions to realize pakhawaj bols.
module Derive.C.India.Pakhawaj where
import qualified Data.Foldable as Foldable
import qualified Data.Text as Text
import qualified Data.Traversable as Traversable

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Texts as Texts

import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.SubT as SubT
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.Library as Library
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators [(Symbol
"bols", Generator Note
c_bols)]

-- * calls

c_bols :: Derive.Generator Derive.Note
c_bols :: Generator Note
c_bols = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator (Module
"india" forall a. Semigroup a => a -> a -> a
<> Module
"pakhawaj") CallName
"bols"
    (Tags
Tags.inst forall a. Semigroup a => a -> a -> a
<> Tags
Tags.subs)
    (Doc
"Interpret pakhawaj bols in sub events.  Bols: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Textlike a => a -> [a] -> a
Texts.join Doc
" / " (forall a b. (a -> b) -> [a] -> [b]
map (Syllable -> Doc
Doc.Doc forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Syllable] -> Syllable
Text.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [([Syllable], [Note Bol])]
all_bols))
    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 a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"flam" (Double
0.15 :: Double)
            Doc
"Time between flam type bols like `kre`."
    ) forall a b. (a -> b) -> a -> b
$ \ScoreTime
flam_dur  PassedArgs Note
args -> do
        PassedArgs Note
args <- forall err a.
HasCallStack =>
(err -> Syllable) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
            forall a.
([EventT Syllable] -> Either Syllable [EventT Syllable])
-> PassedArgs a -> Either Syllable (PassedArgs a)
Sub.modify_notes (ScoreTime
-> ScoreTime
-> [EventT Syllable]
-> Either Syllable [EventT Syllable]
realize_events (forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs Note
args) ScoreTime
flam_dur) PassedArgs Note
args
        [[Event]]
events <- forall d. PassedArgs d -> Deriver [[Event]]
Sub.sub_events PassedArgs Note
args
        forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap [Event] -> Deriver State Error (Stream Note)
Sub.derive [[Event]]
events

realize_events :: ScoreTime -> ScoreTime -> [SubT.EventT Text]
    -> Either Text [SubT.EventT Text]
realize_events :: ScoreTime
-> ScoreTime
-> [EventT Syllable]
-> Either Syllable [EventT Syllable]
realize_events ScoreTime
end ScoreTime
flam_dur =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. ShowVal a => (ScoreTime, a) -> EventT Syllable
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> [(ScoreTime, Bol)] -> [(ScoreTime, Attributes)]
bols_to_attribute ScoreTime
flam_dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime
-> [(ScoreTime, Syllable)] -> Either Syllable [(ScoreTime, Bol)]
realize_bols ScoreTime
end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {b}. EventT b -> (ScoreTime, b)
from
    where
    from :: EventT b -> (ScoreTime, b)
from EventT b
e = (forall a. EventT a -> ScoreTime
SubT._start EventT b
e, forall a. EventT a -> a
SubT._note EventT b
e)
    -- TODO this is a bit sketchy since I'm relying on the +attr lookup call.
    -- But to directly add the call I would have to be able to return
    -- a NoteDeriver, not just text.  Of course, if I wind up using a score
    -- integrate, then of course I'd need text again.
    to :: (ScoreTime, a) -> EventT Syllable
to (ScoreTime
t, a
attrs) = forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
t ScoreTime
0 (forall a. ShowVal a => a -> Syllable
ShowVal.show_val a
attrs)

bols_to_attribute :: ScoreTime -> [(ScoreTime, Bol)]
    -> [(ScoreTime, Attrs.Attributes)]
bols_to_attribute :: ScoreTime -> [(ScoreTime, Bol)] -> [(ScoreTime, Attributes)]
bols_to_attribute ScoreTime
flam [(ScoreTime, Bol)]
notes =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ScoreTime -> ScoreTime -> Bol -> [(ScoreTime, Attributes)]
bol_to_attribute ScoreTime
flam) [ScoreTime]
ts ([Bol] -> [Bol]
infer_tette [Bol]
bols)
    where ([ScoreTime]
ts, [Bol]
bols) = forall a b. [(a, b)] -> ([a], [b])
unzip [(ScoreTime, Bol)]
notes

realize_bols :: ScoreTime -- ^ End time, which is used for the duration of the
    -- final note.  This is needed if the last bol is a sequence.
    -> [(ScoreTime, Text)] -> Either Text [(ScoreTime, Bol)]
realize_bols :: ScoreTime
-> [(ScoreTime, Syllable)] -> Either Syllable [(ScoreTime, Bol)]
realize_bols ScoreTime
end = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {b}. [(ScoreTime, Note b)] -> [(ScoreTime, b)]
realize_notes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(a, Syllable)] -> Either Syllable [(a, Note Bol)]
match_syllables
    where
    realize_notes :: [(ScoreTime, Note b)] -> [(ScoreTime, b)]
realize_notes = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((ScoreTime, Note b), Maybe (ScoreTime, Note b))
-> [(ScoreTime, b)]
realize_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, Maybe a)]
Lists.zipNext
    realize_note :: ((ScoreTime, Note b), Maybe (ScoreTime, Note b))
-> [(ScoreTime, b)]
realize_note ((ScoreTime
t, Note b
note), Maybe (ScoreTime, Note b)
next) = case Note b
note of
        Note b
Rest -> []
        Note b
bol -> [(ScoreTime
t, b
bol)]
        Notes [Note b]
notes -> [(ScoreTime, Note b)] -> [(ScoreTime, b)]
realize_notes forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [ScoreTime]
ts [Note b]
notes
            where ts :: [ScoreTime]
ts = forall a. Num a => a -> a -> [a]
Lists.range_ ScoreTime
t (ScoreTime
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 [Note b]
notes))
        where dur :: ScoreTime
dur = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScoreTime
end forall a b. (a, b) -> a
fst Maybe (ScoreTime, Note b)
next forall a. Num a => a -> a -> a
- ScoreTime
t

bol_to_attribute :: ScoreTime -> ScoreTime -> Bol
    -> [(ScoreTime, Attrs.Attributes)]
bol_to_attribute :: ScoreTime -> ScoreTime -> Bol -> [(ScoreTime, Attributes)]
bol_to_attribute ScoreTime
flam ScoreTime
t Bol
bol = case Bol
bol of
    One Stroke
s -> [(ScoreTime
t, Stroke -> Attributes
stroke_to_attribute Stroke
s)]
    Together Stroke
s1 Stroke
s2 -> [(ScoreTime
t, Stroke -> Attributes
stroke_to_attribute Stroke
s1), (ScoreTime
t, Stroke -> Attributes
stroke_to_attribute Stroke
s2)]
    Flam Stroke
s1 Stroke
s2 ->
        [(ScoreTime
t, Stroke -> Attributes
stroke_to_attribute Stroke
s1), (ScoreTime
t forall a. Num a => a -> a -> a
+ ScoreTime
flam, Stroke -> Attributes
stroke_to_attribute Stroke
s2)]

stroke_to_attribute :: Stroke -> Attrs.Attributes
stroke_to_attribute :: Stroke -> Attributes
stroke_to_attribute Stroke
s = case Stroke
s of
    -- This should have already been eliminated by 'infer_tette'.
    Stroke
Tette -> Syllable -> Attributes
Attrs.attr Syllable
"tet"
    Stroke
_ -> Syllable -> Attributes
Attrs.attr (Syllable -> Syllable
Text.toLower (forall a. Show a => a -> Syllable
showt Stroke
s))

-- * implementation

data Stroke =
    Tet | Te | Tette -- ^ either tet or te, whichever is more convenient
    | Ne -- ^ tet with two fingers
    | Na | Ta | Di
    | Di1 -- ^ di with one finger
    | Di3 -- ^ di with three fingers
    -- bayan
    | Ka | Ge
    deriving (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, 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)

instance Pretty Stroke where pretty :: Stroke -> Syllable
pretty = Syllable -> Syllable
Text.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Syllable
showt

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

data Note a = Rest | Note a | Notes [Note a]
    deriving (Int -> Note a -> ShowS
forall a. Show a => Int -> Note a -> ShowS
forall a. Show a => [Note a] -> ShowS
forall a. Show a => Note a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Note a] -> ShowS
$cshowList :: forall a. Show a => [Note a] -> ShowS
show :: Note a -> String
$cshow :: forall a. Show a => Note a -> String
showsPrec :: Int -> Note a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Note a -> ShowS
Show, Note a -> Note a -> Bool
forall a. Eq a => Note a -> Note a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Note a -> Note a -> Bool
$c/= :: forall a. Eq a => Note a -> Note a -> Bool
== :: Note a -> Note a -> Bool
$c== :: forall a. Eq a => Note a -> Note a -> Bool
Eq, forall a b. a -> Note b -> Note a
forall a b. (a -> b) -> Note a -> Note b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Note b -> Note a
$c<$ :: forall a b. a -> Note b -> Note a
fmap :: forall a b. (a -> b) -> Note a -> Note b
$cfmap :: forall a b. (a -> b) -> Note a -> Note b
Functor, forall a. Eq a => a -> Note a -> Bool
forall a. Num a => Note a -> a
forall a. Ord a => Note a -> a
forall m. Monoid m => Note m -> m
forall a. Note a -> Bool
forall a. Note a -> Int
forall a. Note a -> [a]
forall a. (a -> a -> a) -> Note a -> a
forall m a. Monoid m => (a -> m) -> Note a -> m
forall b a. (b -> a -> b) -> b -> Note a -> b
forall a b. (a -> b -> b) -> b -> Note a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Note a -> a
$cproduct :: forall a. Num a => Note a -> a
sum :: forall a. Num a => Note a -> a
$csum :: forall a. Num a => Note a -> a
minimum :: forall a. Ord a => Note a -> a
$cminimum :: forall a. Ord a => Note a -> a
maximum :: forall a. Ord a => Note a -> a
$cmaximum :: forall a. Ord a => Note a -> a
elem :: forall a. Eq a => a -> Note a -> Bool
$celem :: forall a. Eq a => a -> Note a -> Bool
length :: forall a. Note a -> Int
$clength :: forall a. Note a -> Int
null :: forall a. Note a -> Bool
$cnull :: forall a. Note a -> Bool
toList :: forall a. Note a -> [a]
$ctoList :: forall a. Note a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Note a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Note a -> a
foldr1 :: forall a. (a -> a -> a) -> Note a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Note a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Note a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Note a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Note a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Note a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Note a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Note a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Note a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Note a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Note a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Note a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Note a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Note a -> m
fold :: forall m. Monoid m => Note m -> m
$cfold :: forall m. Monoid m => Note m -> m
Foldable, Functor Note
Foldable Note
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Note (m a) -> m (Note a)
forall (f :: * -> *) a. Applicative f => Note (f a) -> f (Note a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Note a -> m (Note b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
sequence :: forall (m :: * -> *) a. Monad m => Note (m a) -> m (Note a)
$csequence :: forall (m :: * -> *) a. Monad m => Note (m a) -> m (Note a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Note a -> m (Note b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Note a -> m (Note b)
sequenceA :: forall (f :: * -> *) a. Applicative f => Note (f a) -> f (Note a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Note (f a) -> f (Note a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
Traversable)

map_stroke :: (Stroke -> Stroke) -> Bol -> Bol
map_stroke :: (Stroke -> Stroke) -> Bol -> Bol
map_stroke Stroke -> Stroke
f Bol
bol = case Bol
bol of
    One Stroke
b -> Stroke -> Bol
One (Stroke -> Stroke
f Stroke
b)
    Together Stroke
b1 Stroke
b2 -> Stroke -> Stroke -> Bol
Together (Stroke -> Stroke
f Stroke
b1) (Stroke -> Stroke
f Stroke
b2)
    Flam Stroke
b1 Stroke
b2 -> Stroke -> Stroke -> Bol
Flam (Stroke -> Stroke
f Stroke
b1) (Stroke -> Stroke
f Stroke
b2)

strokes_of :: Bol -> [Stroke]
strokes_of :: Bol -> [Stroke]
strokes_of Bol
bol = case Bol
bol of
    One Stroke
b -> [Stroke
b]
    Together Stroke
b1 Stroke
b2 -> [Stroke
b1, Stroke
b2]
    Flam Stroke
b1 Stroke
b2 -> [Stroke
b1, Stroke
b2]

instance Pretty Bol where
    pretty :: Bol -> Syllable
pretty Bol
bol = case Bol
bol of
        One Stroke
b -> forall a. Pretty a => a -> Syllable
pretty Stroke
b
        Together Stroke
b1 Stroke
b2 -> forall a. Pretty a => a -> Syllable
pretty Stroke
b1 forall a. Semigroup a => a -> a -> a
<> Syllable
"+" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Syllable
pretty Stroke
b2
        Flam Stroke
b1 Stroke
b2 -> forall a. Pretty a => a -> Syllable
pretty Stroke
b1 forall a. Semigroup a => a -> a -> a
<> Syllable
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Syllable
pretty Stroke
b2

instance Pretty a => Pretty (Note a) where
    pretty :: Note a -> Syllable
pretty Note a
Rest = Syllable
"-"
    pretty (Note a
bol) = forall a. Pretty a => a -> Syllable
pretty a
bol
    pretty (Notes [Note a]
note) = Syllable
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Syllable
pretty [Note a]
note forall a. Semigroup a => a -> a -> a
<> Syllable
")"

-- | Textual representation of a bol.
type Syllable = Text

all_bols :: [([Syllable], [Note Bol])]
all_bols :: [([Syllable], [Note Bol])]
all_bols =
    [([Syllable
name], [forall a. a -> Note a
Note Bol
bol]) | ([Syllable]
names, Bol
bol) <- [([Syllable], Bol)]
single_bols, Syllable
name <- [Syllable]
names]
    forall a. [a] -> [a] -> [a]
++ [([Syllable], [Note Bol])]
sequences

-- Single strokes.
single_bols :: [([Syllable], Bol)]
single_bols :: [([Syllable], Bol)]
single_bols =
    [ ([Syllable
"tet"], Stroke -> Bol
One Stroke
Tet)
    , ([Syllable
"te"], Stroke -> Bol
One Stroke
Te)
    , ([Syllable
"ne", Syllable
"re"], Stroke -> Bol
One Stroke
Ne)
    , ([Syllable
"na"], Stroke -> Bol
One Stroke
Na)
    , ([Syllable
"ta"], Stroke -> Bol
One Stroke
Ta)
    , ([Syllable
"di", Syllable
"din"], Stroke -> Bol
One Stroke
Di)
    -- bayan
    , ([Syllable
"ka", Syllable
"kat", Syllable
"ki"], Stroke -> Bol
One Stroke
Ka)
    , ([Syllable
"ge", Syllable
"gen", Syllable
"ga"], Stroke -> Bol
One Stroke
Ge)
    -- both
    , ([Syllable
"dha"], Stroke -> Stroke -> Bol
Together Stroke
Ge Stroke
Ta)
    , ([Syllable
"dhin"], Stroke -> Stroke -> Bol
Together Stroke
Ge Stroke
Di)
    , ([Syllable
"dhet"], Stroke -> Stroke -> Bol
Together Stroke
Ge Stroke
Tette)
    ]

-- TODO the length of the syllables should be the same as the length of the
-- bols or the extras will be silently dropped.
sequences :: [([Syllable], [Note Bol])]
sequences :: [([Syllable], [Note Bol])]
sequences =
    [ ([Syllable
"kre"], forall {a}. a -> [Note a]
note forall a b. (a -> b) -> a -> b
$ Stroke -> Stroke -> Bol
Flam Stroke
Ka Stroke
Tet)
    , ([Syllable
"gre"], forall {a}. a -> [Note a]
note forall a b. (a -> b) -> a -> b
$ Stroke -> Stroke -> Bol
Flam Stroke
Ge Stroke
Tet)
    , ([Syllable
"te", Syllable
"re", Syllable
"ki", Syllable
"ta"], [Stroke] -> [Note Bol]
notes [Stroke
Tet, Stroke
Te, Stroke
Ka, Stroke
Tet])
    , ([Syllable
"ki", Syllable
"ta", Syllable
"ta", Syllable
"ka"], [Stroke] -> [Note Bol]
notes [Stroke
Tet, Stroke
Te, Stroke
Ka, Stroke
Tet])
    , ([Syllable
"tr", Syllable
"kt"], [[Stroke]] -> [Note Bol]
notes2 [[Stroke
Tet, Stroke
Te], [Stroke
Ka, Stroke
Tet]])
    , ([Syllable
"te", Syllable
"re", Syllable
"ki", Syllable
"ta", Syllable
"ta", Syllable
"ka"], [Stroke] -> [Note Bol]
notes [Stroke
Tet, Stroke
Te, Stroke
Ka, Stroke
Tet, Stroke
Te, Stroke
Ka])
    , ([Syllable
"tr", Syllable
"kt", Syllable
"tk"], [[Stroke]] -> [Note Bol]
notes2 [[Stroke
Tet, Stroke
Te], [Stroke
Ka, Stroke
Tet], [Stroke
Te, Stroke
Ka]])
    , ([Syllable
"kt", Syllable
"tk"], [[Stroke]] -> [Note Bol]
notes2 [[Stroke
Tet, Stroke
Te], [Stroke
Ka, Stroke
Tet]])
    , ([Syllable
"ta", Syllable
"ki"], [Stroke] -> [Note Bol]
notes [Stroke
Tet, Stroke
Ka])
    , ([Syllable
"te", Syllable
"ran"], [Stroke] -> [Note Bol]
notes [Stroke
Di3, Stroke
Di1])
    , ([Syllable
"dhu", Syllable
"ma"], forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Note a
Note [Stroke -> Stroke -> Bol
Together Stroke
Ge Stroke
Di, Stroke -> Bol
One Stroke
Te])
    -- Abbreviations.
    , ([Syllable
"tetekata"], [forall a. [Note a] -> Note a
Notes forall a b. (a -> b) -> a -> b
$ [Stroke] -> [Note Bol]
notes [Stroke
Tet, Stroke
Te, Stroke
Ka, Stroke
Ta, Stroke
Ge, Stroke
Di, Stroke
Ge, Stroke
Ne]])
    ]
    where
    note :: a -> [Note a]
note = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Note a
Note
    notes :: [Stroke] -> [Note Bol]
notes = forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Note a
Note forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stroke -> Bol
One)
    notes2 :: [[Stroke]] -> [Note Bol]
notes2 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. [Note a] -> Note a
Notes forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stroke] -> [Note Bol]
notes)

-- | Parse scores from "Derive.Call.India.PakhawajScore".
parse :: ScoreTime -> Text -> Either Text [(ScoreTime, Bol)]
parse :: ScoreTime -> Syllable -> Either Syllable [(ScoreTime, Bol)]
parse ScoreTime
dur = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. [(a, Bol)] -> [(a, Bol)]
infer forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime
-> [(ScoreTime, Syllable)] -> Either Syllable [(ScoreTime, Bol)]
realize_bols ScoreTime
dur forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ ScoreTime
0 ScoreTime
dur)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syllable -> [Syllable]
Text.words forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Syllable -> Syllable -> Syllable -> Syllable
Text.replace Syllable
"|" Syllable
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syllable -> Syllable
Text.toLower
    where
    infer :: [(a, Bol)] -> [(a, Bol)]
infer [(a, Bol)]
notes = forall a b. [a] -> [b] -> [(a, b)]
zip [a]
ts ([Bol] -> [Bol]
infer_tette [Bol]
bols)
        where ([a]
ts, [Bol]
bols) = forall a b. [(a, b)] -> ([a], [b])
unzip [(a, Bol)]
notes

match_syllables :: [(a, Syllable)] -> Either Text [(a, Note Bol)]
match_syllables :: forall a. [(a, Syllable)] -> Either Syllable [(a, Note Bol)]
match_syllables = forall a. [(a, Syllable)] -> Either Syllable [(a, Note Bol)]
go
    where
    go :: [(a, Syllable)] -> Either Syllable [(a, Note Bol)]
go [] = forall a b. b -> Either a b
Right []
    go syllables :: [(a, Syllable)]
syllables@((a
annot, Syllable
w) : [(a, Syllable)]
ws)
        | Syllable
w forall a. Eq a => a -> a -> Bool
== Syllable
"-" = ((a
annot, forall a. Note a
Rest) :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Syllable)] -> Either Syllable [(a, Note Bol)]
go [(a, Syllable)]
ws
        | Just ([(a, Syllable)]
rest, [(a, Note Bol)]
bols) <- forall {a}.
[(a, Syllable)] -> Maybe ([(a, Syllable)], [(a, Note Bol)])
best_match [(a, Syllable)]
syllables = ([(a, Note Bol)]
bols++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Syllable)] -> Either Syllable [(a, Note Bol)]
go [(a, Syllable)]
rest
        | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Syllable
"unknown bol: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Syllable
showt Syllable
w
    best_match :: [(a, Syllable)] -> Maybe ([(a, Syllable)], [(a, Note Bol)])
best_match [(a, Syllable)]
syllables = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.maximumOn forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a.
[(a, Syllable)]
-> ([Syllable], [Note Bol])
-> Maybe (Int, ([(a, Syllable)], [(a, Note Bol)]))
match_bols [(a, Syllable)]
syllables) [([Syllable], [Note Bol])]
all_bols
    match_bols :: [(a, Syllable)] -> ([Syllable], [Note Bol])
        -> Maybe (Int, ([(a, Syllable)], [(a, Note Bol)]))
    match_bols :: forall a.
[(a, Syllable)]
-> ([Syllable], [Note Bol])
-> Maybe (Int, ([(a, Syllable)], [(a, Note Bol)]))
match_bols [(a, Syllable)]
syllables ([Syllable]
bol_syllables, [Note Bol]
bols)
        | [Syllable]
pre forall a. Eq a => a -> a -> Bool
== [Syllable]
bol_syllables =
            forall a. a -> Maybe a
Just (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Syllable]
bol_syllables, ([(a, Syllable)]
post, forall a b. [a] -> [b] -> [(a, b)]
zip [a]
annots [Note Bol]
bols))
        | Bool
otherwise = forall a. Maybe a
Nothing
        where
        (([a]
annots, [Syllable]
pre), [(a, Syllable)]
post) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$
            forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Syllable]
bol_syllables) [(a, Syllable)]
syllables

-- | Replace 'Tette' with either Tet or Te, based on its neighbors.
infer_tette :: [Bol] -> [Bol]
infer_tette :: [Bol] -> [Bol]
infer_tette = forall (t :: * -> *) b a.
Traversable t =>
(Maybe b -> a -> Maybe a -> b) -> t a -> t b
map_neighbors Maybe Bol -> Bol -> Maybe Bol -> Bol
infer
    where
    infer :: Maybe Bol -> Bol -> Maybe Bol -> Bol
infer Maybe Bol
prev Bol
bol Maybe Bol
next
        | Stroke
Tette forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Bol -> [Stroke]
strokes_of Bol
bol = (Stroke -> Stroke) -> Bol -> Bol
map_stroke (Stroke -> Stroke -> Stroke
replace Stroke
replacement) Bol
bol
        | Bool
otherwise = Bol
bol
        where
        replacement :: Stroke
replacement = case (Maybe Bol
prev, Maybe Bol
next) of
            (Just Bol
p, Maybe Bol
_) | Stroke
Tet forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Bol -> [Stroke]
strokes_of Bol
p -> Stroke
Te
            (Maybe Bol
_, Just Bol
n) | Stroke
Tet  forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Bol -> [Stroke]
strokes_of Bol
n -> Stroke
Te
            (Maybe Bol, Maybe Bol)
_ -> Stroke
Tet
    replace :: Stroke -> Stroke -> Stroke
replace Stroke
stroke Stroke
Tette = Stroke
stroke
    replace Stroke
_ Stroke
stroke = Stroke
stroke

-- | This is different from @map f . Lists.zipNeighbors@ in that you can see
-- whatever change @f@ made to the previous value.
map_neighbors :: Traversable t => (Maybe b -> a -> Maybe a -> b)
    -> t a -> t b
map_neighbors :: forall (t :: * -> *) b a.
Traversable t =>
(Maybe b -> a -> Maybe a -> b) -> t a -> t b
map_neighbors Maybe b -> a -> Maybe a -> b
f t a
xs =
    forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
Traversable.mapAccumL (Maybe b, [a]) -> a -> ((Maybe b, [a]), b)
go (forall a. Maybe a
Nothing, forall a. Int -> [a] -> [a]
drop Int
1 (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList t a
xs)) t a
xs
    where
    go :: (Maybe b, [a]) -> a -> ((Maybe b, [a]), b)
go (Maybe b
prev, [a]
nexts) a
x = ((forall a. a -> Maybe a
Just b
y, forall a. Int -> [a] -> [a]
drop Int
1 [a]
nexts), b
y)
        where y :: b
y = Maybe b -> a -> Maybe a -> b
f Maybe b
prev a
x (forall a. [a] -> Maybe a
Lists.head [a]
nexts)