-- Copyright 2017 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 {- | Notation for Carnatic solkattu. This is actually a separate library that's independent of the rest of the sequencer. The only connection is that its final output can be stroke names for some instrument and thus easily inserted into a track. Solkattu is a general form of rhythmic notation. Since the syllables (sollus) are independent of any particular instrument, they can express general rhythmic structures, which can then be realized in a form idiomatic to different instruments. The system is split up in a somewhat complicated way to separate rhythmic handling from sollus, and separate realizations sollus to various instruments. The structure from low to high level is: "Solkattu.Tala" - General 'Tala.Tala' type. "Solkattu.S" - Generic rhythmic framework, where the "payload" note type is abstract. This can express rhythms in terms of 'S.Speed' and 'S.Nadai', check them against a Tala, and realize down to 'S.Duration' tagged notes. "Solkattu.Solkattu" - Fill in a Sequence's note with a Sollu type. This supports all of the notation in "Solkattu.Dsl". As Sequence leaves the note type abstract, this leaves the instrument-dependent stroke type abstract. "Solkattu.Realize" - This has an instrument-specific Stroke, which is the result of resolving the sollus. The stroke type is still abstract since it's polymorphic over the specific instrument. "Solkattu.Instrument.Mridangam", "Solkattu.Instrument.KendangTunggal", etc. - These describe specific instruments for Realize. "Solkattu.Korvai" - A Korvai unifies the instrument-specific Patterns and StrokeMaps together with Tala and a solkattu sequence. So I can support multiple instruments from one solkattu score, it merges the stroke types into a single type, and projects out the specific strokes depending on which instrument is being realized. "Solkattu.Dsl.Solkattu" - Functions for creating solkattu scores. It defines (or replaces) various operators to make scores look nicer. Solkattu.Score.Solkattu* - Instrument-independent korvais. "Solkattu.Dsl.Mridangam", Solkattu.Score.Mridangam* - These are similar to Dsl and Score.Solkattu*, except they use concrete mridangam strokes instead of abstract sollus. The naming convention is that \"Note\" is the level-specific value, which may have a \"Note\" constructor with the "next level" of value. \"SNote\" is an alias for composing Note with 'Sequence.Note', and \"Sequence\" is a newtype for a list of those, but is abstractly the monoid where you can put together notation to form a score. -} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} module Solkattu.Solkattu where import qualified Control.Exception as Exception import qualified Control.Monad.State.Strict as State import qualified Data.List as List import qualified Data.Text as Text import qualified Util.CallStack as CallStack import qualified Util.Num as Num import qualified Util.Lists as Lists import qualified Util.Styled as Styled import qualified Derive.Expr as Expr import qualified Solkattu.S as S import qualified Solkattu.Tala as Tala import Global {- | Render a concrete stroke to text representing it. This is used for ASCII output, so it should produce only a single character per matra duration. There could be exceptions for strokes which are both rare and almost always occur before a rest. The Show and Pretty superclasses are to make debugging more convenient. -} class (Show a, Pretty a) => Notation a where notation :: a -> (Styled.Style, Text) -- | Extend the note to fill its time with this character. extension :: a -> Char extension a _ = Char ' ' textNotation :: Text -> (Styled.Style, Text) textNotation :: Text -> (Style, Text) textNotation = (forall a. Monoid a => a mempty,) notationText :: Notation a => a -> Text notationText :: forall a. Notation a => a -> Text notationText = forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Notation a => a -> (Style, Text) notation type Error = Text data Note sollu = Note (NoteT sollu) | Space !Space | Pattern !Pattern | Alignment !Tala.Akshara deriving (Note sollu -> Note sollu -> Bool forall sollu. Eq sollu => Note sollu -> Note sollu -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Note sollu -> Note sollu -> Bool $c/= :: forall sollu. Eq sollu => Note sollu -> Note sollu -> Bool == :: Note sollu -> Note sollu -> Bool $c== :: forall sollu. Eq sollu => Note sollu -> Note sollu -> Bool Eq, Note sollu -> Note sollu -> Ordering 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 forall {sollu}. Ord sollu => Eq (Note sollu) forall sollu. Ord sollu => Note sollu -> Note sollu -> Bool forall sollu. Ord sollu => Note sollu -> Note sollu -> Ordering forall sollu. Ord sollu => Note sollu -> Note sollu -> Note sollu min :: Note sollu -> Note sollu -> Note sollu $cmin :: forall sollu. Ord sollu => Note sollu -> Note sollu -> Note sollu max :: Note sollu -> Note sollu -> Note sollu $cmax :: forall sollu. Ord sollu => Note sollu -> Note sollu -> Note sollu >= :: Note sollu -> Note sollu -> Bool $c>= :: forall sollu. Ord sollu => Note sollu -> Note sollu -> Bool > :: Note sollu -> Note sollu -> Bool $c> :: forall sollu. Ord sollu => Note sollu -> Note sollu -> Bool <= :: Note sollu -> Note sollu -> Bool $c<= :: forall sollu. Ord sollu => Note sollu -> Note sollu -> Bool < :: Note sollu -> Note sollu -> Bool $c< :: forall sollu. Ord sollu => Note sollu -> Note sollu -> Bool compare :: Note sollu -> Note sollu -> Ordering $ccompare :: forall sollu. Ord sollu => Note sollu -> Note sollu -> Ordering Ord, Int -> Note sollu -> ShowS forall sollu. Show sollu => Int -> Note sollu -> ShowS forall sollu. Show sollu => [Note sollu] -> ShowS forall sollu. Show sollu => Note sollu -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Note sollu] -> ShowS $cshowList :: forall sollu. Show sollu => [Note sollu] -> ShowS show :: Note sollu -> String $cshow :: forall sollu. Show sollu => Note sollu -> String showsPrec :: Int -> Note sollu -> ShowS $cshowsPrec :: forall sollu. Show sollu => Int -> Note sollu -> ShowS Show, 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) instance Pretty sollu => Pretty (Note sollu) where pretty :: Note sollu -> Text pretty Note sollu n = case Note sollu n of Note NoteT sollu note -> forall a. Pretty a => a -> Text pretty NoteT sollu note Space Space space -> forall a. Pretty a => a -> Text pretty Space space Pattern Pattern p -> forall a. Pretty a => a -> Text pretty Pattern p Alignment Int n -> Text "@" forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Int n -- | A Group is metadata stored alongside the nested sollus, but the actual -- nesting happens in 'S.Group'. See NOTE [nested-groups] for how I arrived at -- the design. data Group = GReduction !Reduction | GMeta !Meta deriving (Group -> Group -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Group -> Group -> Bool $c/= :: Group -> Group -> Bool == :: Group -> Group -> Bool $c== :: Group -> Group -> Bool Eq, Eq Group Group -> Group -> Bool Group -> Group -> Ordering Group -> Group -> Group 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 :: Group -> Group -> Group $cmin :: Group -> Group -> Group max :: Group -> Group -> Group $cmax :: Group -> Group -> Group >= :: Group -> Group -> Bool $c>= :: Group -> Group -> Bool > :: Group -> Group -> Bool $c> :: Group -> Group -> Bool <= :: Group -> Group -> Bool $c<= :: Group -> Group -> Bool < :: Group -> Group -> Bool $c< :: Group -> Group -> Bool compare :: Group -> Group -> Ordering $ccompare :: Group -> Group -> Ordering Ord, Int -> Group -> ShowS [Group] -> ShowS Group -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Group] -> ShowS $cshowList :: [Group] -> ShowS show :: Group -> String $cshow :: Group -> String showsPrec :: Int -> Group -> ShowS $cshowsPrec :: Int -> Group -> ShowS Show) data Reduction = Reduction { -- | Where to split the sollus. Reduction -> FMatra _split :: !S.FMatra , Reduction -> Side _side :: !Side } deriving (Reduction -> Reduction -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Reduction -> Reduction -> Bool $c/= :: Reduction -> Reduction -> Bool == :: Reduction -> Reduction -> Bool $c== :: Reduction -> Reduction -> Bool Eq, Eq Reduction Reduction -> Reduction -> Bool Reduction -> Reduction -> Ordering Reduction -> Reduction -> Reduction 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 :: Reduction -> Reduction -> Reduction $cmin :: Reduction -> Reduction -> Reduction max :: Reduction -> Reduction -> Reduction $cmax :: Reduction -> Reduction -> Reduction >= :: Reduction -> Reduction -> Bool $c>= :: Reduction -> Reduction -> Bool > :: Reduction -> Reduction -> Bool $c> :: Reduction -> Reduction -> Bool <= :: Reduction -> Reduction -> Bool $c<= :: Reduction -> Reduction -> Bool < :: Reduction -> Reduction -> Bool $c< :: Reduction -> Reduction -> Bool compare :: Reduction -> Reduction -> Ordering $ccompare :: Reduction -> Reduction -> Ordering Ord, Int -> Reduction -> ShowS [Reduction] -> ShowS Reduction -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Reduction] -> ShowS $cshowList :: [Reduction] -> ShowS show :: Reduction -> String $cshow :: Reduction -> String showsPrec :: Int -> Reduction -> ShowS $cshowsPrec :: Int -> Reduction -> ShowS Show) data Meta = Meta { -- | This is the logical number of Matras the group has. It has to be -- stored because the number of matras is only accurate relative to the -- tempo context. For GSarva, this actually defines the duration, which -- is pretty unfortunate. See 'flatDuration'. Meta -> Maybe Int _matras :: !(Maybe S.Matra) -- | Normally name is derived from _matras and _type, but some groups want -- to override that. , Meta -> Maybe Text _name :: !(Maybe Text) -- | This determines abstraction level and color highlight in the score. , Meta -> GroupType _type :: !GroupType } deriving (Meta -> Meta -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Meta -> Meta -> Bool $c/= :: Meta -> Meta -> Bool == :: Meta -> Meta -> Bool $c== :: Meta -> Meta -> Bool Eq, Eq Meta Meta -> Meta -> Bool Meta -> Meta -> Ordering Meta -> Meta -> Meta 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 :: Meta -> Meta -> Meta $cmin :: Meta -> Meta -> Meta max :: Meta -> Meta -> Meta $cmax :: Meta -> Meta -> Meta >= :: Meta -> Meta -> Bool $c>= :: Meta -> Meta -> Bool > :: Meta -> Meta -> Bool $c> :: Meta -> Meta -> Bool <= :: Meta -> Meta -> Bool $c<= :: Meta -> Meta -> Bool < :: Meta -> Meta -> Bool $c< :: Meta -> Meta -> Bool compare :: Meta -> Meta -> Ordering $ccompare :: Meta -> Meta -> Ordering Ord, Int -> Meta -> ShowS [Meta] -> ShowS Meta -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Meta] -> ShowS $cshowList :: [Meta] -> ShowS show :: Meta -> String $cshow :: Meta -> String showsPrec :: Int -> Meta -> ShowS $cshowsPrec :: Int -> Meta -> ShowS Show) meta :: GroupType -> Meta meta :: GroupType -> Meta meta = Maybe Int -> Maybe Text -> GroupType -> Meta Meta forall a. Maybe a Nothing forall a. Maybe a Nothing data GroupType = -- | A generic group, usually manually applied. GGroup -- | 'Reduction's get this automatically. | GReductionT -- | A bit of decorative filler, should be highlighted subtly if at all. | GFiller -- | A realized 'Pattern'. | GPattern -- | A pattern with sollus already given. | GExplicitPattern | GSarva -- | Check that this group has the duration in '_matras'. This group type -- should be stripped out after the check. | GCheckDuration !S.Duration deriving (GroupType -> GroupType -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: GroupType -> GroupType -> Bool $c/= :: GroupType -> GroupType -> Bool == :: GroupType -> GroupType -> Bool $c== :: GroupType -> GroupType -> Bool Eq, Eq GroupType GroupType -> GroupType -> Bool GroupType -> GroupType -> Ordering GroupType -> GroupType -> GroupType 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 :: GroupType -> GroupType -> GroupType $cmin :: GroupType -> GroupType -> GroupType max :: GroupType -> GroupType -> GroupType $cmax :: GroupType -> GroupType -> GroupType >= :: GroupType -> GroupType -> Bool $c>= :: GroupType -> GroupType -> Bool > :: GroupType -> GroupType -> Bool $c> :: GroupType -> GroupType -> Bool <= :: GroupType -> GroupType -> Bool $c<= :: GroupType -> GroupType -> Bool < :: GroupType -> GroupType -> Bool $c< :: GroupType -> GroupType -> Bool compare :: GroupType -> GroupType -> Ordering $ccompare :: GroupType -> GroupType -> Ordering Ord, Int -> GroupType -> ShowS [GroupType] -> ShowS GroupType -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [GroupType] -> ShowS $cshowList :: [GroupType] -> ShowS show :: GroupType -> String $cshow :: GroupType -> String showsPrec :: Int -> GroupType -> ShowS $cshowsPrec :: Int -> GroupType -> ShowS Show) -- | All GroupTypes that should be seen by render. GCheckDuration should -- have been removed by 'Realize.checkDuration'. I could express that in the -- type, but it seems too noisy for now. groupTypes :: [GroupType] groupTypes :: [GroupType] groupTypes = [GroupType GGroup, GroupType GReductionT, GroupType GFiller, GroupType GPattern, GroupType GExplicitPattern, GroupType GSarva] instance Pretty GroupType where pretty :: GroupType -> Text pretty = forall a. Show a => a -> Text showt -- | Before means drop the strokes before the '_split' split, After means -- drop the ones after. data Side = Before | After deriving (Side -> Side -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Side -> Side -> Bool $c/= :: Side -> Side -> Bool == :: Side -> Side -> Bool $c== :: Side -> Side -> Bool Eq, Eq Side Side -> Side -> Bool Side -> Side -> Ordering Side -> Side -> Side 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 :: Side -> Side -> Side $cmin :: Side -> Side -> Side max :: Side -> Side -> Side $cmax :: Side -> Side -> Side >= :: Side -> Side -> Bool $c>= :: Side -> Side -> Bool > :: Side -> Side -> Bool $c> :: Side -> Side -> Bool <= :: Side -> Side -> Bool $c<= :: Side -> Side -> Bool < :: Side -> Side -> Bool $c< :: Side -> Side -> Bool compare :: Side -> Side -> Ordering $ccompare :: Side -> Side -> Ordering Ord, Int -> Side -> ShowS [Side] -> ShowS Side -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Side] -> ShowS $cshowList :: [Side] -> ShowS show :: Side -> String $cshow :: Side -> String showsPrec :: Int -> Side -> ShowS $cshowsPrec :: Int -> Side -> ShowS Show) instance Pretty Side where pretty :: Side -> Text pretty = forall a. Show a => a -> Text showt instance Pretty Group where pretty :: Group -> Text pretty (GReduction Reduction r) = forall a. Pretty a => a -> Text pretty Reduction r pretty (GMeta Meta m) = forall a. Pretty a => a -> Text pretty Meta m instance Pretty Reduction where pretty :: Reduction -> Text pretty (Reduction FMatra split Side side) = forall a. Pretty a => a -> Text pretty (FMatra split, Side side) instance Pretty Meta where -- Shorthand that makes tests look nicer. pretty :: Meta -> Text pretty (Meta (Just Int matras) Maybe Text Nothing GroupType GSarva) = Text "==" forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Int matras pretty (Meta Maybe Int Nothing Maybe Text Nothing GroupType gtype) = forall a. Pretty a => a -> Text pretty GroupType gtype pretty (Meta Maybe Int matras Maybe Text name GroupType gtype) = forall a. Pretty a => a -> Text pretty (Maybe Int matras, Maybe Text name, GroupType gtype) -- | A note that can take up a variable amount of space. Since it doesn't have -- set strokes (or any, in the case of Rest), it can be arbitrarily divided. data Space = Rest -- | This is not actual rest time in the performance, but inserted in the -- score for a start offset. | Offset deriving (Space -> Space -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Space -> Space -> Bool $c/= :: Space -> Space -> Bool == :: Space -> Space -> Bool $c== :: Space -> Space -> Bool Eq, Eq Space Space -> Space -> Bool Space -> Space -> Ordering Space -> Space -> Space 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 :: Space -> Space -> Space $cmin :: Space -> Space -> Space max :: Space -> Space -> Space $cmax :: Space -> Space -> Space >= :: Space -> Space -> Bool $c>= :: Space -> Space -> Bool > :: Space -> Space -> Bool $c> :: Space -> Space -> Bool <= :: Space -> Space -> Bool $c<= :: Space -> Space -> Bool < :: Space -> Space -> Bool $c< :: Space -> Space -> Bool compare :: Space -> Space -> Ordering $ccompare :: Space -> Space -> Ordering Ord, Int -> Space -> ShowS [Space] -> ShowS Space -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Space] -> ShowS $cshowList :: [Space] -> ShowS show :: Space -> String $cshow :: Space -> String showsPrec :: Int -> Space -> ShowS $cshowsPrec :: Int -> Space -> ShowS Show) instance Pretty Space where pretty :: Space -> Text pretty Space Rest = Text "__" pretty Space Offset = Text ".." data NoteT sollu = NoteT { forall sollu. NoteT sollu -> sollu _sollu :: !sollu -- | If it's a karvai sollu, and it's followed by a rest, it will replace -- the rest. Otherwise, it will be replaced by a note. , forall sollu. NoteT sollu -> Bool _karvai :: !Bool -- | Tag a sequence for alternate realization. , forall sollu. NoteT sollu -> Maybe Tag _tag :: !(Maybe Tag) } deriving (NoteT sollu -> NoteT sollu -> Bool forall sollu. Eq sollu => NoteT sollu -> NoteT sollu -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: NoteT sollu -> NoteT sollu -> Bool $c/= :: forall sollu. Eq sollu => NoteT sollu -> NoteT sollu -> Bool == :: NoteT sollu -> NoteT sollu -> Bool $c== :: forall sollu. Eq sollu => NoteT sollu -> NoteT sollu -> Bool Eq, NoteT sollu -> NoteT sollu -> Bool NoteT sollu -> NoteT sollu -> Ordering 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 forall {sollu}. Ord sollu => Eq (NoteT sollu) forall sollu. Ord sollu => NoteT sollu -> NoteT sollu -> Bool forall sollu. Ord sollu => NoteT sollu -> NoteT sollu -> Ordering forall sollu. Ord sollu => NoteT sollu -> NoteT sollu -> NoteT sollu min :: NoteT sollu -> NoteT sollu -> NoteT sollu $cmin :: forall sollu. Ord sollu => NoteT sollu -> NoteT sollu -> NoteT sollu max :: NoteT sollu -> NoteT sollu -> NoteT sollu $cmax :: forall sollu. Ord sollu => NoteT sollu -> NoteT sollu -> NoteT sollu >= :: NoteT sollu -> NoteT sollu -> Bool $c>= :: forall sollu. Ord sollu => NoteT sollu -> NoteT sollu -> Bool > :: NoteT sollu -> NoteT sollu -> Bool $c> :: forall sollu. Ord sollu => NoteT sollu -> NoteT sollu -> Bool <= :: NoteT sollu -> NoteT sollu -> Bool $c<= :: forall sollu. Ord sollu => NoteT sollu -> NoteT sollu -> Bool < :: NoteT sollu -> NoteT sollu -> Bool $c< :: forall sollu. Ord sollu => NoteT sollu -> NoteT sollu -> Bool compare :: NoteT sollu -> NoteT sollu -> Ordering $ccompare :: forall sollu. Ord sollu => NoteT sollu -> NoteT sollu -> Ordering Ord, Int -> NoteT sollu -> ShowS forall sollu. Show sollu => Int -> NoteT sollu -> ShowS forall sollu. Show sollu => [NoteT sollu] -> ShowS forall sollu. Show sollu => NoteT sollu -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [NoteT sollu] -> ShowS $cshowList :: forall sollu. Show sollu => [NoteT sollu] -> ShowS show :: NoteT sollu -> String $cshow :: forall sollu. Show sollu => NoteT sollu -> String showsPrec :: Int -> NoteT sollu -> ShowS $cshowsPrec :: forall sollu. Show sollu => Int -> NoteT sollu -> ShowS Show, forall a b. a -> NoteT b -> NoteT a forall a b. (a -> b) -> NoteT a -> NoteT 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 -> NoteT b -> NoteT a $c<$ :: forall a b. a -> NoteT b -> NoteT a fmap :: forall a b. (a -> b) -> NoteT a -> NoteT b $cfmap :: forall a b. (a -> b) -> NoteT a -> NoteT b Functor, forall a. Eq a => a -> NoteT a -> Bool forall a. Num a => NoteT a -> a forall a. Ord a => NoteT a -> a forall m. Monoid m => NoteT m -> m forall sollu. NoteT sollu -> Bool forall a. NoteT a -> Int forall a. NoteT a -> [a] forall a. (a -> a -> a) -> NoteT a -> a forall m a. Monoid m => (a -> m) -> NoteT a -> m forall b a. (b -> a -> b) -> b -> NoteT a -> b forall a b. (a -> b -> b) -> b -> NoteT 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 => NoteT a -> a $cproduct :: forall a. Num a => NoteT a -> a sum :: forall a. Num a => NoteT a -> a $csum :: forall a. Num a => NoteT a -> a minimum :: forall a. Ord a => NoteT a -> a $cminimum :: forall a. Ord a => NoteT a -> a maximum :: forall a. Ord a => NoteT a -> a $cmaximum :: forall a. Ord a => NoteT a -> a elem :: forall a. Eq a => a -> NoteT a -> Bool $celem :: forall a. Eq a => a -> NoteT a -> Bool length :: forall a. NoteT a -> Int $clength :: forall a. NoteT a -> Int null :: forall sollu. NoteT sollu -> Bool $cnull :: forall sollu. NoteT sollu -> Bool toList :: forall a. NoteT a -> [a] $ctoList :: forall a. NoteT a -> [a] foldl1 :: forall a. (a -> a -> a) -> NoteT a -> a $cfoldl1 :: forall a. (a -> a -> a) -> NoteT a -> a foldr1 :: forall a. (a -> a -> a) -> NoteT a -> a $cfoldr1 :: forall a. (a -> a -> a) -> NoteT a -> a foldl' :: forall b a. (b -> a -> b) -> b -> NoteT a -> b $cfoldl' :: forall b a. (b -> a -> b) -> b -> NoteT a -> b foldl :: forall b a. (b -> a -> b) -> b -> NoteT a -> b $cfoldl :: forall b a. (b -> a -> b) -> b -> NoteT a -> b foldr' :: forall a b. (a -> b -> b) -> b -> NoteT a -> b $cfoldr' :: forall a b. (a -> b -> b) -> b -> NoteT a -> b foldr :: forall a b. (a -> b -> b) -> b -> NoteT a -> b $cfoldr :: forall a b. (a -> b -> b) -> b -> NoteT a -> b foldMap' :: forall m a. Monoid m => (a -> m) -> NoteT a -> m $cfoldMap' :: forall m a. Monoid m => (a -> m) -> NoteT a -> m foldMap :: forall m a. Monoid m => (a -> m) -> NoteT a -> m $cfoldMap :: forall m a. Monoid m => (a -> m) -> NoteT a -> m fold :: forall m. Monoid m => NoteT m -> m $cfold :: forall m. Monoid m => NoteT m -> m Foldable, Functor NoteT Foldable NoteT 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 => NoteT (m a) -> m (NoteT a) forall (f :: * -> *) a. Applicative f => NoteT (f a) -> f (NoteT a) forall (m :: * -> *) a b. Monad m => (a -> m b) -> NoteT a -> m (NoteT b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> NoteT a -> f (NoteT b) sequence :: forall (m :: * -> *) a. Monad m => NoteT (m a) -> m (NoteT a) $csequence :: forall (m :: * -> *) a. Monad m => NoteT (m a) -> m (NoteT a) mapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> NoteT a -> m (NoteT b) $cmapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> NoteT a -> m (NoteT b) sequenceA :: forall (f :: * -> *) a. Applicative f => NoteT (f a) -> f (NoteT a) $csequenceA :: forall (f :: * -> *) a. Applicative f => NoteT (f a) -> f (NoteT a) traverse :: forall (f :: * -> *) a b. Applicative f => (a -> f b) -> NoteT a -> f (NoteT b) $ctraverse :: forall (f :: * -> *) a b. Applicative f => (a -> f b) -> NoteT a -> f (NoteT b) Traversable) -- | A sollu can have a tag attached. This is used to map certain sets of -- sollus to a different realization. The idea is that even though the sollus -- are the same, they may be realized different ways in different contexts. data Tag = Tag !Int -- | Marks the middle karvai in a tirmanam. This is applied automatically, -- so it can have an alternate realization. | Middle -- | Marks a standard pattern. This isolates the "standard pattern" use -- of common sollus like taka. | Standard deriving (Tag -> Tag -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Tag -> Tag -> Bool $c/= :: Tag -> Tag -> Bool == :: Tag -> Tag -> Bool $c== :: Tag -> Tag -> Bool Eq, Eq Tag Tag -> Tag -> Bool Tag -> Tag -> Ordering Tag -> Tag -> Tag 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 :: Tag -> Tag -> Tag $cmin :: Tag -> Tag -> Tag max :: Tag -> Tag -> Tag $cmax :: Tag -> Tag -> Tag >= :: Tag -> Tag -> Bool $c>= :: Tag -> Tag -> Bool > :: Tag -> Tag -> Bool $c> :: Tag -> Tag -> Bool <= :: Tag -> Tag -> Bool $c<= :: Tag -> Tag -> Bool < :: Tag -> Tag -> Bool $c< :: Tag -> Tag -> Bool compare :: Tag -> Tag -> Ordering $ccompare :: Tag -> Tag -> Ordering Ord, Int -> Tag -> ShowS [Tag] -> ShowS Tag -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Tag] -> ShowS $cshowList :: [Tag] -> ShowS show :: Tag -> String $cshow :: Tag -> String showsPrec :: Int -> Tag -> ShowS $cshowsPrec :: Int -> Tag -> ShowS Show) instance Pretty Tag where pretty :: Tag -> Text pretty (Tag Int i) = forall a. Pretty a => a -> Text pretty Int i pretty Tag Middle = Text "mid" pretty Tag Standard = Text "standard" instance Num Tag where fromInteger :: Integer -> Tag fromInteger = Int -> Tag Tag forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Num a => Integer -> a fromInteger -- These are awkward, but I want fromInteger, but see no reason to allow -- math on tags. + :: Tag -> Tag -> Tag (+) = forall a. HasCallStack => String -> a error String "tags aren't numbers" (-) = forall a. HasCallStack => String -> a error String "tags aren't numbers" * :: Tag -> Tag -> Tag (*) = forall a. HasCallStack => String -> a error String "tags aren't numbers" negate :: Tag -> Tag negate = forall a. HasCallStack => String -> a error String "tags aren't numbers" abs :: Tag -> Tag abs = forall a. HasCallStack => String -> a error String "tags aren't numbers" signum :: Tag -> Tag signum = forall a. HasCallStack => String -> a error String "tags aren't numbers" note :: sollu -> NoteT sollu note :: forall sollu. sollu -> NoteT sollu note sollu sollu = NoteT { _sollu :: sollu _sollu = sollu sollu, _karvai :: Bool _karvai = Bool False, _tag :: Maybe Tag _tag = forall a. Maybe a Nothing } noteOf :: Note sollu -> Maybe (NoteT sollu) noteOf :: forall sollu. Note sollu -> Maybe (NoteT sollu) noteOf (Note NoteT sollu n) = forall a. a -> Maybe a Just NoteT sollu n noteOf Note sollu _ = forall a. Maybe a Nothing solluOf :: Note sollu -> Maybe sollu solluOf :: forall sollu. Note sollu -> Maybe sollu solluOf = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall sollu. NoteT sollu -> sollu _sollu forall b c a. (b -> c) -> (a -> b) -> a -> c . forall sollu. Note sollu -> Maybe (NoteT sollu) noteOf instance Pretty sollu => Pretty (NoteT sollu) where pretty :: NoteT sollu -> Text pretty (NoteT sollu sollu Bool karvai Maybe Tag tag) = forall a. Monoid a => [a] -> a mconcat [ Maybe Tag -> Text prettyTag Maybe Tag tag , forall a. Pretty a => a -> Text pretty sollu sollu , forall {a}. IsString a => Bool -> a prettyKarvai Bool karvai ] where prettyKarvai :: Bool -> a prettyKarvai Bool k = if Bool k then a "(k)" else a "" prettyTag :: Maybe Tag -> Text prettyTag = forall b a. b -> (a -> b) -> Maybe a -> b maybe Text "" ((forall a. Semigroup a => a -> a -> a <>Text "^") forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Pretty a => a -> Text pretty) modifyNote :: (NoteT a -> NoteT b) -> Note a -> Note b modifyNote :: forall a b. (NoteT a -> NoteT b) -> Note a -> Note b modifyNote NoteT a -> NoteT b f Note a n = case Note a n of Note NoteT a note -> forall sollu. NoteT sollu -> Note sollu Note (NoteT a -> NoteT b f NoteT a note) Space Space space -> forall sollu. Space -> Note sollu Space Space space Pattern Pattern p -> forall sollu. Pattern -> Note sollu Pattern Pattern p Alignment Int n -> forall sollu. Int -> Note sollu Alignment Int n instance S.HasMatras (Note sollu) where matrasOf :: Note sollu -> Int matrasOf Note sollu n = case Note sollu n of -- Karvai notes are cancelled out, so they logically have 0 duration. Note NoteT sollu note -> if forall sollu. NoteT sollu -> Bool _karvai NoteT sollu note then Int 0 else Int 1 Space {} -> Int 1 Pattern Pattern p -> forall a. HasMatras a => a -> Int S.matrasOf Pattern p Alignment {} -> Int 0 hasSustain :: Note sollu -> Bool hasSustain Note sollu n = case Note sollu n of Note {} -> Bool False Space {} -> Bool True Pattern {} -> Bool True Alignment {} -> Bool False newtype Pattern = PatternM S.Matra deriving (Pattern -> Pattern -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Pattern -> Pattern -> Bool $c/= :: Pattern -> Pattern -> Bool == :: Pattern -> Pattern -> Bool $c== :: Pattern -> Pattern -> Bool Eq, Eq Pattern Pattern -> Pattern -> Bool Pattern -> Pattern -> Ordering Pattern -> Pattern -> Pattern 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 :: Pattern -> Pattern -> Pattern $cmin :: Pattern -> Pattern -> Pattern max :: Pattern -> Pattern -> Pattern $cmax :: Pattern -> Pattern -> Pattern >= :: Pattern -> Pattern -> Bool $c>= :: Pattern -> Pattern -> Bool > :: Pattern -> Pattern -> Bool $c> :: Pattern -> Pattern -> Bool <= :: Pattern -> Pattern -> Bool $c<= :: Pattern -> Pattern -> Bool < :: Pattern -> Pattern -> Bool $c< :: Pattern -> Pattern -> Bool compare :: Pattern -> Pattern -> Ordering $ccompare :: Pattern -> Pattern -> Ordering Ord, Int -> Pattern -> ShowS [Pattern] -> ShowS Pattern -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Pattern] -> ShowS $cshowList :: [Pattern] -> ShowS show :: Pattern -> String $cshow :: Pattern -> String showsPrec :: Int -> Pattern -> ShowS $cshowsPrec :: Int -> Pattern -> ShowS Show) pattern :: S.Matra -> Pattern pattern :: Int -> Pattern pattern = Int -> Pattern PatternM instance S.HasMatras Pattern where matrasOf :: Pattern -> Int matrasOf (PatternM Int m) = Int m hasSustain :: Pattern -> Bool hasSustain Pattern _ = Bool True instance Pretty Pattern where pretty :: Pattern -> Text pretty = forall a. Notation a => a -> Text notationText instance Notation Pattern where notation :: Pattern -> (Style, Text) notation (PatternM Int matras) = Text -> (Style, Text) textNotation forall a b. (a -> b) -> a -> b $ forall a. Show a => a -> Text showt Int matras forall a. Semigroup a => a -> a -> a <> Text "p" extension :: Pattern -> Char extension Pattern _ = Char '-' instance Expr.ToExpr Pattern where to_expr :: Pattern -> Expr MiniVal to_expr Pattern p = case Pattern p of PatternM Int matras -> forall val. Call val -> Expr val Expr.generator forall a b. (a -> b) -> a -> b $ forall val. Symbol -> [val] -> Call val Expr.call Symbol "p" [forall a. ToVal a => a -> MiniVal Expr.to_val Int matras] data Karvai = Karvai | NotKarvai deriving (Karvai -> Karvai -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Karvai -> Karvai -> Bool $c/= :: Karvai -> Karvai -> Bool == :: Karvai -> Karvai -> Bool $c== :: Karvai -> Karvai -> Bool Eq, Eq Karvai Karvai -> Karvai -> Bool Karvai -> Karvai -> Ordering Karvai -> Karvai -> Karvai 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 :: Karvai -> Karvai -> Karvai $cmin :: Karvai -> Karvai -> Karvai max :: Karvai -> Karvai -> Karvai $cmax :: Karvai -> Karvai -> Karvai >= :: Karvai -> Karvai -> Bool $c>= :: Karvai -> Karvai -> Bool > :: Karvai -> Karvai -> Bool $c> :: Karvai -> Karvai -> Bool <= :: Karvai -> Karvai -> Bool $c<= :: Karvai -> Karvai -> Bool < :: Karvai -> Karvai -> Bool $c< :: Karvai -> Karvai -> Bool compare :: Karvai -> Karvai -> Ordering $ccompare :: Karvai -> Karvai -> Ordering Ord, Int -> Karvai -> ShowS [Karvai] -> ShowS Karvai -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Karvai] -> ShowS $cshowList :: [Karvai] -> ShowS show :: Karvai -> String $cshow :: Karvai -> String showsPrec :: Int -> Karvai -> ShowS $cshowsPrec :: Int -> Karvai -> ShowS Show) data Sollu = NoSollu -- ^ a dummy sollu for rests in Konnakol | Cham | Dheem | Dhom | Di | Dim | Din | Dit | Du | Ga | Gin | Gu | Jo | Ka | Ki | Ku | Kum | Lang | Mi | Na | Nam | Nang | Nu | Ri | Ta | Tam | Tang | Tong | Tat | Tha | Thom | Ti deriving (Sollu -> Sollu -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Sollu -> Sollu -> Bool $c/= :: Sollu -> Sollu -> Bool == :: Sollu -> Sollu -> Bool $c== :: Sollu -> Sollu -> Bool Eq, Eq Sollu Sollu -> Sollu -> Bool Sollu -> Sollu -> Ordering Sollu -> Sollu -> Sollu 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 :: Sollu -> Sollu -> Sollu $cmin :: Sollu -> Sollu -> Sollu max :: Sollu -> Sollu -> Sollu $cmax :: Sollu -> Sollu -> Sollu >= :: Sollu -> Sollu -> Bool $c>= :: Sollu -> Sollu -> Bool > :: Sollu -> Sollu -> Bool $c> :: Sollu -> Sollu -> Bool <= :: Sollu -> Sollu -> Bool $c<= :: Sollu -> Sollu -> Bool < :: Sollu -> Sollu -> Bool $c< :: Sollu -> Sollu -> Bool compare :: Sollu -> Sollu -> Ordering $ccompare :: Sollu -> Sollu -> Ordering Ord, Int -> Sollu Sollu -> Int Sollu -> [Sollu] Sollu -> Sollu Sollu -> Sollu -> [Sollu] Sollu -> Sollu -> Sollu -> [Sollu] 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 :: Sollu -> Sollu -> Sollu -> [Sollu] $cenumFromThenTo :: Sollu -> Sollu -> Sollu -> [Sollu] enumFromTo :: Sollu -> Sollu -> [Sollu] $cenumFromTo :: Sollu -> Sollu -> [Sollu] enumFromThen :: Sollu -> Sollu -> [Sollu] $cenumFromThen :: Sollu -> Sollu -> [Sollu] enumFrom :: Sollu -> [Sollu] $cenumFrom :: Sollu -> [Sollu] fromEnum :: Sollu -> Int $cfromEnum :: Sollu -> Int toEnum :: Int -> Sollu $ctoEnum :: Int -> Sollu pred :: Sollu -> Sollu $cpred :: Sollu -> Sollu succ :: Sollu -> Sollu $csucc :: Sollu -> Sollu Enum, Sollu forall a. a -> a -> Bounded a maxBound :: Sollu $cmaxBound :: Sollu minBound :: Sollu $cminBound :: Sollu Bounded, Int -> Sollu -> ShowS [Sollu] -> ShowS Sollu -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Sollu] -> ShowS $cshowList :: [Sollu] -> ShowS show :: Sollu -> String $cshow :: Sollu -> String showsPrec :: Int -> Sollu -> ShowS $cshowsPrec :: Int -> Sollu -> ShowS Show) instance Notation Sollu where notation :: Sollu -> (Style, Text) notation = Text -> (Style, Text) textNotation forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> Text Text.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Show a => a -> Text showt instance Pretty Sollu where pretty :: Sollu -> Text pretty = forall a. Notation a => a -> Text notationText -- ** parseSollus parseSollus :: Text -> Either Error [Maybe Sollu] parseSollus :: Text -> Either Text [Maybe Sollu] parseSollus = forall sollu. Show sollu => [(Text, sollu)] -> Text -> Either Text [Maybe sollu] parseSyllables [(Text, Sollu)] allSollus allSollus :: [(Text, Sollu)] allSollus :: [(Text, Sollu)] allSollus = forall a k. (a -> k) -> [a] -> [(k, a)] Lists.keyOn forall a. Notation a => a -> Text notationText forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] filter (forall a. Eq a => a -> a -> Bool /= Sollu NoSollu) [forall a. Bounded a => a minBound ..] parseSyllables :: Show sollu => [(Text, sollu)] -> Text -> Either Error [Maybe sollu] parseSyllables :: forall sollu. Show sollu => [(Text, sollu)] -> Text -> Either Text [Maybe sollu] parseSyllables [(Text, sollu)] solluMap = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Text -> Either Text [Maybe sollu] parse forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> [Text] Text.words where parse :: Text -> Either Text [Maybe sollu] parse Text w = case forall sollu. [(Text, sollu)] -> Text -> [[Maybe sollu]] parseSyllablesWord [(Text, sollu)] solluMap Text w of [] -> forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ Text "no parse for " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Text w [[Maybe sollu] sollus] -> forall a b. b -> Either a b Right [Maybe sollu] sollus [[Maybe sollu]] xs -> forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ Text "multiple parses for " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Text w forall a. Semigroup a => a -> a -> a <> Text ": " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt [[Maybe sollu]] xs parseSyllablesWord :: [(Text, sollu)] -> Text -> [[Maybe sollu]] parseSyllablesWord :: forall sollu. [(Text, sollu)] -> Text -> [[Maybe sollu]] parseSyllablesWord [(Text, sollu)] solluMap = Text -> [[Maybe sollu]] go where go :: Text -> [[Maybe sollu]] go Text prefix | Text -> Bool Text.null Text prefix = [[]] | Text -> Bool has Text "_" = forall a b. (a -> b) -> [a] -> [b] map (forall a. Maybe a Nothing :) (Text -> [[Maybe sollu]] go (Int -> Text -> Text Text.drop Int 1 Text prefix)) | Bool otherwise = do (Text str, sollu sollu) <- forall a. (a -> Bool) -> [a] -> [a] filter (Text -> Bool has forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) [(Text, sollu)] solluMap let suffix :: Text suffix = Int -> Text -> Text Text.drop (Text -> Int Text.length Text str) Text prefix -- Allow an elided n, e.g. tadinginathom vs. tadinginnathom. Text suffix <- Text suffix forall a. a -> [a] -> [a] : if Text "n" Text -> Text -> Bool `Text.isSuffixOf` Text str then [Text "n" forall a. Semigroup a => a -> a -> a <> Text suffix] else [] (forall a. a -> Maybe a Just sollu sollu :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Text -> [[Maybe sollu]] go Text suffix where has :: Text -> Bool has = (Text -> Text -> Bool `Text.isPrefixOf` Text prefix) -- * durations durationOf :: S.HasMatras a => S.Tempo -> S.Sequence Group a -> S.Duration durationOf :: forall a. HasMatras a => Tempo -> Sequence Group a -> Duration durationOf = forall a dur. (HasMatras a, Num dur, Ord dur) => (Tempo -> Duration -> dur) -> Tempo -> Sequence Group a -> dur _durationOf (\Tempo _ -> forall a. a -> a id) matrasOf :: S.HasMatras a => S.Tempo -> S.Sequence Group a -> S.FMatra matrasOf :: forall a. HasMatras a => Tempo -> Sequence Group a -> FMatra matrasOf = forall a dur. (HasMatras a, Num dur, Ord dur) => (Tempo -> Duration -> dur) -> Tempo -> Sequence Group a -> dur _durationOf forall {a} {b}. (Real a, Fractional b) => Tempo -> a -> b toMatras where toMatras :: Tempo -> a -> b toMatras Tempo tempo a dur = forall a b. (Real a, Fractional b) => a -> b realToFrac forall a b. (a -> b) -> a -> b $ a dur forall a. Num a => a -> a -> a * forall a b. (Integral a, Num b) => a -> b fromIntegral (Tempo -> Int S._nadai Tempo tempo) _durationOf :: (S.HasMatras a, Num dur, Ord dur) => (S.Tempo -> S.Duration -> dur) -> S.Tempo -> S.Sequence Group a -> dur _durationOf :: forall a dur. (HasMatras a, Num dur, Ord dur) => (Tempo -> Duration -> dur) -> Tempo -> Sequence Group a -> dur _durationOf Tempo -> Duration -> dur convert Tempo tempo = forall {a}. HasMatras a => Tempo -> [Note Group a] -> dur go Tempo tempo forall b c a. (b -> c) -> (a -> b) -> a -> c . forall g a. Sequence g a -> [Note g a] S.toList where go :: Tempo -> [Note Group a] -> dur go Tempo tempo = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a Num.sum forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (Tempo -> Note Group a -> dur get Tempo tempo) get :: Tempo -> Note Group a -> dur get Tempo tempo = \case S.Note a n -> Tempo -> Duration -> dur convert Tempo tempo forall a b. (a -> b) -> a -> b $ forall a. HasMatras a => Tempo -> a -> Duration S.noteDuration Tempo tempo a n S.TempoChange TempoChange change [Note Group a] notes -> Tempo -> [Note Group a] -> dur go (TempoChange -> Tempo -> Tempo S.changeTempo TempoChange change Tempo tempo) [Note Group a] notes S.Group (GReduction (Reduction FMatra splitAt Side side)) [Note Group a] notes -> case Side side of Side Before -> forall a. Ord a => a -> a -> a max dur 0 (Tempo -> [Note Group a] -> dur go Tempo tempo [Note Group a] notes forall a. Num a => a -> a -> a - dur split) Side After -> forall a. Ord a => a -> a -> a min dur split (Tempo -> [Note Group a] -> dur go Tempo tempo [Note Group a] notes) where split :: dur split = Tempo -> Duration -> dur convert Tempo tempo forall a b. (a -> b) -> a -> b $ Tempo -> FMatra -> Duration S.fmatraDuration Tempo tempo FMatra splitAt S.Group (GMeta (Meta (Just Int matras) Maybe Text _ GroupType _)) [Note Group a] _notes -> Tempo -> Duration -> dur convert Tempo tempo forall a b. (a -> b) -> a -> b $ Tempo -> Duration S.matraDuration Tempo tempo forall a. Num a => a -> a -> a * forall a b. (Integral a, Num b) => a -> b fromIntegral Int matras S.Group (GMeta (Meta Maybe Int Nothing Maybe Text _ GroupType _)) [Note Group a] notes -> Tempo -> [Note Group a] -> dur go Tempo tempo [Note Group a] notes -- | Unfortunately, with Reduction and GSarva groups, the notes don't reflect -- the actual durations, so for 'Group'-bearing 'S.Flat', I need a special -- function. I tried really hard to prevent this but failed. The sollus have -- to go in the note field, and with reductions and sarva, they no longer -- correspond exactly to realized strokes. I would have to two note slots, -- one for a space-filling @Group FMatras@, and another for the sollus, but -- since groups can be nested, it gets really head-hurting for my tiny brain. -- -- See NOTE [nested-groups] for chaotic details. flatDuration :: S.HasMatras a => S.Flat Group a -> S.Duration flatDuration :: forall a. HasMatras a => Flat Group a -> Duration flatDuration (S.FNote Tempo tempo a note) = forall a. HasMatras a => Tempo -> a -> Duration S.noteDuration Tempo tempo a note flatDuration (S.FGroup Tempo tempo Group group [Flat Group a] notes) = case Group group of GReduction (Reduction FMatra splitAt Side side) -> case Side side of Side Before -> forall a. Ord a => a -> a -> a max Duration 0 (Duration completeDur forall a. Num a => a -> a -> a - Duration split) Side After -> forall a. Ord a => a -> a -> a min Duration split Duration completeDur where split :: Duration split = Tempo -> FMatra -> Duration S.fmatraDuration Tempo tempo FMatra splitAt completeDur :: Duration completeDur = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a Num.sum (forall a b. (a -> b) -> [a] -> [b] map forall a. HasMatras a => Flat Group a -> Duration flatDuration [Flat Group a] notes) GMeta (Meta (Just Int matras) Maybe Text _ GroupType _) -> Tempo -> Duration S.matraDuration Tempo tempo forall a. Num a => a -> a -> a * forall a b. (Integral a, Num b) => a -> b fromIntegral Int matras GMeta (Meta Maybe Int Nothing Maybe Text _ GroupType _) -> forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a Num.sum (forall a b. (a -> b) -> [a] -> [b] map forall a. HasMatras a => Flat Group a -> Duration flatDuration [Flat Group a] notes) -- * functions -- | A Karvai Note followed by a Space will replace the rest, if followed by -- a Note or Pattern, the Karvai will be dropped. Since a 'Karvai' note -- logically has no duration, if it's the last note it will be dropped cancelKarvai :: [S.Flat g (Note sollu)] -> [S.Flat g (Note sollu)] cancelKarvai :: forall g sollu. [Flat g (Note sollu)] -> [Flat g (Note sollu)] cancelKarvai [Flat g (Note sollu)] ns = forall a b. (a, b) -> a fst forall a b. (a -> b) -> a -> b $ forall s a. State s a -> s -> (a, s) State.runState (forall {g} {sollu}. [Flat g (Note sollu)] -> [Flat g (Note sollu)] -> StateT Bool Identity [Flat g (Note sollu)] go [Flat g (Note sollu)] ns []) Bool False where -- This is way too complicated because Groups are nested. The problem is -- that I want to look at and possibly modify a future note. If Flat were -- really flat, then I could just look down the list and modify. Future is -- so the last note of a group can still see future notes. If I see a -- rest in the future, I emit the karvai note and turn on a "suppress next -- rest" bit. go :: [Flat g (Note sollu)] -> [Flat g (Note sollu)] -> StateT Bool Identity [Flat g (Note sollu)] go (S.FGroup Tempo tempo g g [Flat g (Note sollu)] children : [Flat g (Note sollu)] notes) [Flat g (Note sollu)] future = do [Flat g (Note sollu)] children <- [Flat g (Note sollu)] -> [Flat g (Note sollu)] -> StateT Bool Identity [Flat g (Note sollu)] go [Flat g (Note sollu)] children ([Flat g (Note sollu)] notes forall a. [a] -> [a] -> [a] ++ [Flat g (Note sollu)] future) (forall g a. Tempo -> g -> [Flat g a] -> Flat g a S.FGroup Tempo tempo g g [Flat g (Note sollu)] children :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Flat g (Note sollu)] -> [Flat g (Note sollu)] -> StateT Bool Identity [Flat g (Note sollu)] go [Flat g (Note sollu)] notes [Flat g (Note sollu)] future go (S.FNote Tempo tempo (Note NoteT sollu note) : [Flat g (Note sollu)] notes) [Flat g (Note sollu)] future | forall sollu. NoteT sollu -> Bool _karvai NoteT sollu note = if forall {sollu}. [Note sollu] -> Bool nextRest (forall g a. [Flat g a] -> [a] S.flattenedNotes ([Flat g (Note sollu)] notes forall a. [a] -> [a] -> [a] ++ [Flat g (Note sollu)] future)) then StateT Bool Identity () suppress forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> (forall g a. Tempo -> a -> Flat g a S.FNote Tempo tempo (forall sollu. NoteT sollu -> Note sollu Note (NoteT sollu note { _karvai :: Bool _karvai = Bool False })) :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Flat g (Note sollu)] -> [Flat g (Note sollu)] -> StateT Bool Identity [Flat g (Note sollu)] go [Flat g (Note sollu)] notes [Flat g (Note sollu)] future else [Flat g (Note sollu)] -> [Flat g (Note sollu)] -> StateT Bool Identity [Flat g (Note sollu)] go [Flat g (Note sollu)] notes [Flat g (Note sollu)] future go (note :: Flat g (Note sollu) note@(S.FNote Tempo _ (Space Space Rest)) : [Flat g (Note sollu)] notes) [Flat g (Note sollu)] future = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a ifM StateT Bool Identity Bool isSuppressed ([Flat g (Note sollu)] -> [Flat g (Note sollu)] -> StateT Bool Identity [Flat g (Note sollu)] go [Flat g (Note sollu)] notes [Flat g (Note sollu)] future) ((Flat g (Note sollu) note:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Flat g (Note sollu)] -> [Flat g (Note sollu)] -> StateT Bool Identity [Flat g (Note sollu)] go [Flat g (Note sollu)] notes [Flat g (Note sollu)] future) go (Flat g (Note sollu) n : [Flat g (Note sollu)] ns) [Flat g (Note sollu)] future = (Flat g (Note sollu) n:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Flat g (Note sollu)] -> [Flat g (Note sollu)] -> StateT Bool Identity [Flat g (Note sollu)] go [Flat g (Note sollu)] ns [Flat g (Note sollu)] future go [] [Flat g (Note sollu)] _ = forall (m :: * -> *) a. Monad m => a -> m a return [] suppress :: StateT Bool Identity () suppress = forall s (m :: * -> *). MonadState s m => s -> m () State.put Bool True isSuppressed :: StateT Bool Identity Bool isSuppressed = forall s (m :: * -> *). MonadState s m => m s State.get forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* forall s (m :: * -> *). MonadState s m => s -> m () State.put Bool False nextRest :: [Note sollu] -> Bool nextRest [] = Bool False nextRest (Note sollu n : [Note sollu] ns) = case Note sollu n of Space Space Rest -> Bool True Alignment {} -> [Note sollu] -> Bool nextRest [Note sollu] ns Note sollu _ -> Bool False -- * vary type Variations = [(S.Matra, S.Matra, S.Matra)] -- | Variation means replacing a triad of patterns of the same duration with a -- an increasing or decreasing sequence. For instance, 666 can become 567, -- 765, or 777 can become 678 or 579 or their inverses. -- -- TODO Variation on a higher order is also possible, so for instance 777, 777, -- 777 may become 666, 777, 888 -- -- TODO Also we have 5, 55, 555 -> 55, 55, 55 -> 555, 55, 5. This actually -- applies to more than just Patterns, e.g. 3 as tadin_. I think this is -- orthogonal and could get a different function. vary :: (S.Matra -> Variations) -- ^ variations allowed for this duration -> S.Sequence g (Note sollu) -> [S.Sequence g (Note sollu)] vary :: forall g sollu. (Int -> Variations) -> Sequence g (Note sollu) -> [Sequence g (Note sollu)] vary Int -> Variations allowedVariations Sequence g (Note sollu) notes | forall (t :: * -> *) a. Foldable t => t a -> Bool null [[((Int, Int, Int), (Int, Int, Int))]] modificationGroups = [Sequence g (Note sollu) notes] | Bool otherwise = forall a b. (a -> b) -> [a] -> [b] map forall {t :: * -> *}. Foldable t => t ((Int, Int, Int), (Int, Int, Int)) -> Sequence g (Note sollu) apply [[((Int, Int, Int), (Int, Int, Int))]] modificationGroups where -- List of sets of permutations. modificationGroups :: [[((Int, Int, Int), (Int, Int, Int))]] modificationGroups = forall a b x. (a -> [b]) -> [(a, x)] -> [[(b, x)]] permuteFst Int -> Variations allowedVariations (forall g sollu. Sequence g (Note sollu) -> [(Int, (Int, Int, Int))] findTriads Sequence g (Note sollu) notes) -- Apply a set of permutations to the original input. apply :: t ((Int, Int, Int), (Int, Int, Int)) -> Sequence g (Note sollu) apply t ((Int, Int, Int), (Int, Int, Int)) mods = forall g a. [Note g a] -> Sequence g a S.fromList forall a b. (a -> b) -> a -> b $ forall a mod. (a -> mod -> a) -> [(Int, mod)] -> [a] -> [a] applyModifications (\Note g (Note sollu) _ Int matras -> forall g a. a -> Note g a S.Note (forall sollu. Pattern -> Note sollu Pattern (Int -> Pattern PatternM Int matras))) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall {b} {a}. ((b, b, b), (a, a, a)) -> [(a, b)] extract t ((Int, Int, Int), (Int, Int, Int)) mods) (forall g a. Sequence g a -> [Note g a] S.toList Sequence g (Note sollu) notes) extract :: ((b, b, b), (a, a, a)) -> [(a, b)] extract ((b m1, b m2, b m3), (a i1, a i2, a i3)) = [(a i1, b m1), (a i2, b m2), (a i3, b m3)] variations :: [(S.Matra, S.Matra, S.Matra) -> Bool] -> (S.Matra -> Variations) variations :: [(Int, Int, Int) -> Bool] -> Int -> Variations variations [(Int, Int, Int) -> Bool] filters = forall a. (a -> Bool) -> [a] -> [a] filter (\(Int, Int, Int) v -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all (forall a b. (a -> b) -> a -> b $(Int, Int, Int) v) [(Int, Int, Int) -> Bool] filters) forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> Variations allVariations ascending, descending, standard :: (S.Matra, S.Matra, S.Matra) -> Bool ascending :: (Int, Int, Int) -> Bool ascending (Int m1, Int m2, Int m3) = Int m1 forall a. Ord a => a -> a -> Bool < Int m2 Bool -> Bool -> Bool && Int m2 forall a. Ord a => a -> a -> Bool < Int m3 descending :: (Int, Int, Int) -> Bool descending (Int m1, Int m2, Int m3) = Int m1 forall a. Ord a => a -> a -> Bool > Int m2 Bool -> Bool -> Bool && Int m2 forall a. Ord a => a -> a -> Bool > Int m3 standard :: (Int, Int, Int) -> Bool standard (Int m1, Int m2, Int m3) = Int m1 forall a. Eq a => a -> a -> Bool == Int m2 Bool -> Bool -> Bool && Int m2 forall a. Eq a => a -> a -> Bool == Int m3 Bool -> Bool -> Bool || forall a. Ord a => [a] -> [a] List.sort [Int m1, Int m2, Int m3] forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` [[Int 5, Int 6, Int 7], [Int 6, Int 7, Int 8], [Int 5, Int 7, Int 9]] allVariations :: S.Matra -> Variations allVariations :: Int -> Variations allVariations Int matras = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Int -> Variations vars [Int 0 .. forall a. Ord a => a -> a -> a max Int 1 (Int matras forall a. Num a => a -> a -> a - Int minDuration)] where vars :: Int -> Variations vars Int d | Int d forall a. Eq a => a -> a -> Bool == Int 0 = [(Int matras, Int matras, Int matras)] | Bool otherwise = [ (Int matras forall a. Num a => a -> a -> a - Int d, Int matras, Int matras forall a. Num a => a -> a -> a + Int d) , (Int matras forall a. Num a => a -> a -> a + Int d, Int matras, Int matras forall a. Num a => a -> a -> a - Int d) ] minDuration :: Int minDuration = Int 3 -- | Find triples of Patterns with the same length and return their indices. -- The indices are in ascending order. findTriads :: S.Sequence g (Note sollu) -> [(S.Matra, (Int, Int, Int))] findTriads :: forall g sollu. Sequence g (Note sollu) -> [(Int, (Int, Int, Int))] findTriads Sequence g (Note sollu) notes = [ (Int matras, (Int, Int, Int) triad) | (Int matras, [Int] indices) <- forall a b. Ord a => [(a, b)] -> [(a, NonNull b)] Lists.groupFst [ (Int matras, Int i) | (Int i, S.Note (Pattern (PatternM Int matras))) <- forall a b. [a] -> [b] -> [(a, b)] zip [Int 0..] (forall g a. Sequence g a -> [Note g a] S.toList Sequence g (Note sollu) notes) ] , (Int, Int, Int) triad <- forall {c}. [c] -> [(c, c, c)] triads [Int] indices ] where triads :: [c] -> [(c, c, c)] triads (c x1:c x2:c x3:[c] xs) = (c x1, c x2, c x3) forall a. a -> [a] -> [a] : [c] -> [(c, c, c)] triads [c] xs triads [c] _ = [] -- * exceptions -- | Yes, I use impure exceptions, because otherwise the DSL has to become -- monadic or at least applicative. But it seems less egregious because there -- isn't such a strong distinction between compiling and running anyway. -- -- But it does mean I have to be careful to force and catch at the boundaries. newtype Exception = Exception Text deriving (Exception -> Exception -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Exception -> Exception -> Bool $c/= :: Exception -> Exception -> Bool == :: Exception -> Exception -> Bool $c== :: Exception -> Exception -> Bool Eq) instance Exception.Exception Exception instance Show Exception where show :: Exception -> String show (Exception Text msg) = Text -> String Text.unpack Text msg throw :: CallStack.Stack => Text -> a throw :: forall a. HasCallStack => Text -> a throw = forall e a. (HasCallStack, Exception e) => (Text -> e) -> Text -> a CallStack.throw Text -> Exception Exception -- * util applyModifications :: (a -> mod -> a) -> [(Int, mod)] -- ^ modifications along with their indices, in ascending order -> [a] -> [a] applyModifications :: forall a mod. (a -> mod -> a) -> [(Int, mod)] -> [a] -> [a] applyModifications a -> mod -> a apply [(Int, mod)] mods = forall {a}. Ord a => [(a, mod)] -> [(a, a)] -> [a] go [(Int, mod)] mods forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. [a] -> [b] -> [(a, b)] zip [Int 0..] where go :: [(a, mod)] -> [(a, a)] -> [a] go [] [(a, a)] xs = forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> b snd [(a, a)] xs go [(a, mod)] _ [] = [] go ((a i1, mod mod) : [(a, mod)] mods) ((a i2, a x) : [(a, a)] xs) | a i1 forall a. Ord a => a -> a -> Bool < a i2 = [(a, mod)] -> [(a, a)] -> [a] go [(a, mod)] mods ((a i2, a x) forall a. a -> [a] -> [a] : [(a, a)] xs) | a i1 forall a. Eq a => a -> a -> Bool == a i2 = a -> mod -> a apply a x mod mod forall a. a -> [a] -> [a] : [(a, mod)] -> [(a, a)] -> [a] go [(a, mod)] mods [(a, a)] xs | Bool otherwise = a x forall a. a -> [a] -> [a] : [(a, mod)] -> [(a, a)] -> [a] go ((a i1, mod mod) forall a. a -> [a] -> [a] : [(a, mod)] mods) [(a, a)] xs permuteFst :: (a -> [b]) -> [(a, x)] -> [[(b, x)]] permuteFst :: forall a b x. (a -> [b]) -> [(a, x)] -> [[(b, x)]] permuteFst a -> [b] _ [] = [] permuteFst a -> [b] permutations ((a k, x x) : [(a, x)] xs) | forall (t :: * -> *) a. Foldable t => t a -> Bool null [(a, x)] xs = [[(b p, x x)] | b p <- a -> [b] permutations a k] | Bool otherwise = [(b p, x x) forall a. a -> [a] -> [a] : [(b, x)] rest | b p <- a -> [b] permutations a k, [(b, x)] rest <- forall {x}. [(a, x)] -> [[(b, x)]] go [(a, x)] xs] where go :: [(a, x)] -> [[(b, x)]] go = forall a b x. (a -> [b]) -> [(a, x)] -> [[(b, x)]] permuteFst a -> [b] permutations check :: CallStack.Stack => Either Error a -> a check :: forall a. HasCallStack => Either Text a -> a check = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either forall a. HasCallStack => Text -> a throw forall a. a -> a id checkMsg :: CallStack.Stack => Text -> Either Error a -> a checkMsg :: forall a. HasCallStack => Text -> Either Text a -> a checkMsg Text msg = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a. HasCallStack => Text -> a throw forall b c a. (b -> c) -> (a -> b) -> a -> c . ((Text msg forall a. Semigroup a => a -> a -> a <> Text ": ") <>)) forall a. a -> a id {- NOTE [nested-groups] I arrived at the design for groups after a lot of hassle and alternate implementations. Specifically, 'Group' used to have the dropped sollus while the remaining sollus were in 'S.Group'. This had the nice result that just summing up durations worked, with no knowledge of 'Group' needed. However, I was forced to switch to the current implementation where all sollus are in the sequence, and 'Group' simply documents how many sollus should be dropped after realization, due to difficulties dealing with nested groups. I'll include my notes below in case I'm ever tempted to revisit this, and don't understand why I wound up with such a weird design. * I have a problem with nested groups, e.g. dropM 1 . dropM 1. . I could try to simplify away nested groups. That means making each one absolute, so the outer one loses its sollus, and they go on the inner ones. Of course if there aren't inner ones, then I gave to give them the group, and it seems complicated. . I could try to simplify just simple nested groups, where all the children are groups. . I could try to not produce them in the first place, so splitD could do the simplification. I think it's the same, just built into splitD. . Or I could try to get realize to understand nested groups. I guess it would have to accumulate sollus when it sees a group, and put them on any sub-groups. Still I'd like to simplify for the same reason I simplify tempo changes, which is to make the intermediate data less hairy. . For now, just make reduce not produce them. Try simple simplification later. . The reason to make 'realize' understand nested groups is that then it works for other ways to wind up with them. For example? . dropM 1 (ta . dropM 1 (di . ki)) . But do I really want this to look for tadiki, or should it be taki? I need a realistic example. . Reduce a phrase, where one element has a replaceStart on it? No, because replaceStart explicitly doesn't use a group. . Nested reduction? reduce (reduce takita) => takita kita ta, kita kita ta, ta kita ta, kita ta, ta ta, ta . These should definitely use takita. . But on the other hand, what about simultaneous reduction: takita dhomdhomka thom kita dhomka thom ta ka thom . I could model this as: zipWith (.thom) (reduce takita) (reduce dhomdhomka) . Ok, then what about dropM 1 (takita . dropM 1 dhomdhomka) The least confusing would be to look for takita and dhomdhomka, but with nested groups this would look for takita and tadhomdhomka, which is definitely no good. . But dropM 1 (dropM 1 takita) should look for takita, not kita. . Of course I'd actually write dropM 1 takita . dropM 1 dhomdhomka but maybe there are cases where I get the nested one accidentally? . What exactly is the sandi error about? t4 t3 t2 are each groups. sandi (t3.t2) drops the first t3.t2 from the tri, which should reduce it to []. . How then does this become looking for t3 and t2 separately instead of t4? I should wind up with: dropM 1 t4 . dropM 2 t4 . dropM (5) (dropM 1 t4 . dropM 2 t4 . tat.__.tam.__ ...) . So the group winds up being (t3.t2.tat.__.tam.__) . Since in this case the t3.t2 is totally dropped, I could fix this by saying if I can find the suffix (tat.tam), then don't bother looking for the prefix (t3.t2). But this in turn would cause groups with identical tails to match wrong, e.g. dropM 1 takita would match kita. The key thing is I don't know if a match with the prefix would have included the suffix or not. . But not necessarily, because I first try with the prefix, and only try suffix only if there is no match with the prefix. . But even if this does work, it seems like a hack that will break as soon as I'm not happening to drop an entire group. E.g. I could sandi away a fragment: reduce3 (taka.takadinna.naka) . sandi naka (tri_ din (naka.dinna)) => taka.takadinna.naka takadinna.naka dinna{naka naka}dinna.din naka.dinna.din naka.dinna . This works though, it's just dropM 2 (naka.dinna). . But, if nested groups were implemented, then the dropM 5 add dropM 1 t4 . dropM 2 t4 back on, which in turn would turn into t4.t4, which matches on t4 as expected, even though they all wind up getting dropped. . It seems there are two ways to implement groups: distributed, and plain. Distributed means given group x (a . group y b . group z c), 'x' is distributed among the subgroups: a . group xy b . group xz c. Plain means it's just goes on the beginning: group x (a . group y b . group z c) group x a . group y b . group z c . If there's no 'a', i.e. directly nested groups, then the 'x' is lost. . Still, what about reduce (takita . dropM 1 theme . din)? It seems like it should match takita and theme. plain: match takita and theme ==> good. distributed: match takita . ta.theme ==> bogus. . But it also seems like nested drops should work: dropM 1 (dropM 1 nakita). plain: group [na]+ kita ==> group [ki]+ (group [na] ta) ==> bogus. distributed: group [ki]+ (group [na] ta) ==> group [na, ki]+ ta ==> good . Unless I could specifically looked for directly nested groups, so: group [na] kita ==> group [na, ki]+ ta which is now unnested and sensible. But it only works when both sides are the same, e.g.: group [na]+ kita ==> group +[ta] (group [na]+ ta) is back to needing distributed groups. . It's like I want distributed for directly nested groups, but not if there's something in between. But is that too ad-hoc and complicated? . How could I even implement it? That would be the hack in Notation.splitD. . Ok, since I don't know what to do, and I think plain groups are currently implemented, let's just do that. But: * Change Sequence._marks from Maybe (GroupMark g) to [GroupMark g] so I can represent directly nested groups at least. . realize looks for suffix if prefix++suffix doesn't match. . This should fix the sandi examples. . splitD implements the directly nested hack. . Actually it turns out the sandi situation is not what I thought: . Given (dropM 3 $ dropM 1 nakita <> nakita) . The dropM 3 drops the first group with the leading Na, so the fact that there was one is lost: group [na] [ki, ta] . [na, ki, ta] ==> group [ki, ta, na] [ki, ta] . Instead it could collect the [na] from the group at the front: ==> group [na, ki, ta, na] [ki, ta] . Alternately, I could omit the [ki, ta] from the dropped group from the prefix. I guess the rule would be don't include parts of other groups in a group's prefix. . Is there any reason prefer one over the other? The first would be better if I needed that prefix to match, and doesn't happen to drop a whole group, e.g. dropM 1 . dropM 1. . For both I need splitD_ to return something extra, either the extra prefix/suffix, or the number of sollus to leave off the prefix/suffix. . Another way is that the group prefix can have nested groups in it. Then they have to be expanded recursively. Then dropM 3 $ group na [ki, ta] . [na, ki, ta] ==> group (group [na] [ki, ta] . na) [ki, ta] . Expanding recursively might not be as scary as it sounds, because it's just a full SequenceT, so I just tack it on in 'Realize.realize_group', instead of faking up Solkattu.Notes. . Then I have Group sollu = [sollu] ==> [S.Note (Group sollu) sollu]. It's still not exactly a SequenceT, so I still have to do some faking up to get it to one, specifically: S.Note (Solkattu.Group sollu) sollu --> S.Note (Solkattu.Group sollu) (Solkattu.Note sollu) That's not bad at all, fmap (Solkattu.Note . Solkattu.note) should do it. . So it seems possible, but worth it? I think maybe so, because I don't need any ad-hoc rules like collect sollus from the first group... which breaks if there is a second group. . In fact, maybe this implements the non-distributed "plain" group technique already. Actually no, it just makes it work from inside the _dropped. I think it already works outside. / Change Solkattu._dropped to [S.Note (Group sollu) sollu]. . It turns out S.Note (Solkattu.Group sollu) sollu -> S.Note (Solkattu.Group sollu) (Solkattu.Note sollu) above is wrong. I need to go S.Note (Solkattu.Group sollu) sollu -> Solkattu.Note sollu It's because it's already flattened, so I need to flatten the _dropped. But the groups have also been flattened out, so I can't do it unless the caller can not do that. . Realize.realize gets them as [(Meta, Solkattu.Note sollu)], so I need to go to (Meta, Solkattu.Note) . Oh and it turns out 'reassociate_strokes' uses Meta == Nothing to identify the strokes from _dropped, and stuff them back in again. I'll need another way to do that. . Presumably the stroke groups should now also retain group structure, even though I don't think I actually care what's in there. Can I reassociate right after the realize and use the count? I know how long 'extras' is . reassociate_strokes might even be wrong, because it always puts Nothings into the following Meta, but that's assuming everything is a Front group. . What if the dropM splits a group? I'd have to put it back together, but if I make another S.Group the size has been lost. But if I put it in flattened, then I can just mash them back together. Well, except I'm still splitting the S.Group, so I lose the size anyway. . Maybe I can get around it by not splitting the group at all, just put in the complete sequence, along with a split point. Then the job of realize is to drop the extra strokes after realizing them, and emit the group boundaries. . Actually I could leave that to a later step, and in fact leaving it generic might be best because if I do this then pretty printing can get confusing because the extra dropped bits are still in there, and having a way to strip them out could be useful. * Change Solkattu._dropped to (Side, Duration). * The realized output needs dropped strokes, since Technique relies on it. * I have to make matrasOf understand Groups. * realize c_17_08_29 gets an alignment error, but it looks right? . Because verify_alignment is using pre-degrouped notes. * _dropped Durations are wrong. This is because they are taken as absolute, but of course they are relative. Maybe I should keep Duration as absolute, and use FMatra as an explicitly relative matra-level fractional duration. . The wrinkle is nadai as always. How can I know what a matra should be after a nadai change if I don't know the surrounding nadai? . It doesn't help that realize knows absolute timing, because I put the value in in the score, where I don't know. So the only way is that the duration unit is always relative to the current tempo. If I say it's N nadai at s0, then I think it works, but then I'm back to FMatra being nadai-independent. I think? . Realize.split_at can know that the _dropped is relative to the tempo in scope. So if it says 2, then we take it as matras and convert to Duration. . But currently it's matras/4, so should it still work out the same, just /4? . Wait, maybe the problem is entirely different. Both flatten the same: . su $ dropM 1 taka: [(1/4, Front)(s+1(ta ka))] [(([2 (1/4, Front)], s1n4), ta), (([], s1n4), ka)] . dropM 1 $ su taka: [s+1((1/4, Front)(ta ka))] [(([2 (1/4, Front)], s1n4), ta), (([], s1n4), ka)] . This is because both TempoChange and Group are merged into Meta, and the order is lost. I need to change the representation to fix this. . data Meta g a = TempoChange tempo | Group (GroupMark g) | Notes [a] . This would totally change all that MetaNote stuff, and maps would have to be mapAccumLs with state. But since I can now see that the TempoChange happens before the Group, I know the right tempo when stripping out group prefix/suffix. When I see Group, I scale _dropped by the current tempo. . One problem is that now the group counts don't work, because there are non-Notes in there. I suppose I could make the count be for non-meta events. . Why wasn't this a problem before? Because splitD used to work over the nested S.Note structure, so the order was still present. . Another way to fix this but preserve the pairs format is to have ([Meta], a), but it could have [] for no tempo, and I still lose order of notes with meta... so it doesn't really help. . This is still annoying because previous code could just pass through meta without caring about tempo or groups, but now it has to explicitly deal with groups. . What about making Group still be nested? The reason to flatten notes is so they all have tempo, and I can easily find sequences. But that doesn't hold for groups, because I don't match sequences across group boundaries anyway. . realize_patterns changes the number of notes, which makes the group count inaccurate. I have to update it. . Using a non-flat group means I wouldn't have worry about getting count wrong. . I feel like collect_group does adding dropped time wrong. It seems like I should be able to do all the groups recursively. . matrasOf is 12, should be 8*3 - 2 - 4 = 18/2 = 9 . It's because I don't take tempo into account when calculating dropped matras. * Implement Realize.format_table. * Clean out the Pretty etc. gunk and commented out code. * compile build/debug/seq, fix exports - Another side-effect is that "can't split" errors are only detected on realization. But if it's important to get them earlier, I could have splitD verify even if it doesn't use the result immediately. -}