-- 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)