-- 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.
-}