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

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveFunctor #-}
{-# LANGUAGE NamedFieldPuns #-}
-- | Realize abstract solkattu 'S.Note's to concrete instrument-dependent
-- 'Note's.
module Solkattu.Realize (
    Error
    , SNote
    , Note(..)
    , mapStroke
    , Stroke(..)
    , Emphasis(..)
    , toExpr
    , noteOf, strokeOf, stroke, rest, strokeToSequence
    , typeName
    , doubleRest
    -- * checkAlignment
    , Warning(..)
    , checkAlignment
    , checkDuration
    -- * StrokeMap
    , StrokeMap(..)
    , smapKeys
    , strokeMap
    , solkattuToRealize
    , isInstrumentEmpty
    -- ** PatternMap
    , PatternMap
    , patternMap
    , lookupPattern
    -- ** SolluMap
    , SolluMapKey
    , verifySolluKey
    , prettyKey

    -- * realize
    , RealizePattern
    , realizePattern
    , Group(..)
    , Reduction(..)
    , realize, realize_
    , formatError
    -- ** ToStroke
    , ToStrokes
    , realizeStroke, realizeSollu
    -- * text util
    , justifyLeft
    , textLength

    -- * DEBUG
    , SolluMap(..)
    , solluMap
    , Realized
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Control.Monad.Trans.Writer.CPS as Writer
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified GHC.Generics as Generics

import qualified Util.Lists as Lists
import qualified Util.Logger as Logger
import qualified Util.Maps as Maps
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Styled as Styled
import qualified Util.Texts as Texts
import qualified Util.UF as UF

import qualified Derive.Expr as Expr
import qualified Derive.Symbols as Symbols
import qualified Solkattu.S as S
import qualified Solkattu.Solkattu as Solkattu
import qualified Solkattu.Tala as Tala

import           Global


type Error = Text

-- | The group is () because I don't need groups in the stroke map keys.
type SNote stroke = S.Note () (Note stroke)

-- * Note

-- | The 'Solkattu.Sollu's have been reduced to concrete strokes.
data Note stroke =
    Note !(Stroke stroke)
    | Space !Solkattu.Space
    -- | A pattern that has been made abstract.  This is a group that has been
    -- abstracted away.  That means it can have a name, but also it doesn't
    -- have to have an integral matra duration.  Since Abstract comes from
    -- Notes, the abstract duration is a series of 1-matra Abstracts, where
    -- each Note used to be.
    --
    -- These are created at the Format level, not here.
    | Abstract !Solkattu.Meta
    -- | This is 'Solkattu.Alignment'.  It shouldn't be here, but since I now
    -- drop groups in realize via 'convertGroups', I have to do
    -- 'checkAlignment' on the output of 'realize', which means I need to
    -- preserve the Alignments.
    | Alignment !Tala.Akshara
    deriving (Note stroke -> Note stroke -> Bool
forall stroke. Eq stroke => Note stroke -> Note stroke -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Note stroke -> Note stroke -> Bool
$c/= :: forall stroke. Eq stroke => Note stroke -> Note stroke -> Bool
== :: Note stroke -> Note stroke -> Bool
$c== :: forall stroke. Eq stroke => Note stroke -> Note stroke -> Bool
Eq, Int -> Note stroke -> ShowS
forall stroke. Show stroke => Int -> Note stroke -> ShowS
forall stroke. Show stroke => [Note stroke] -> ShowS
forall stroke. Show stroke => Note stroke -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Note stroke] -> ShowS
$cshowList :: forall stroke. Show stroke => [Note stroke] -> ShowS
show :: Note stroke -> String
$cshow :: forall stroke. Show stroke => Note stroke -> String
showsPrec :: Int -> Note stroke -> ShowS
$cshowsPrec :: forall stroke. Show stroke => Int -> Note stroke -> 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)

mapStroke :: Applicative f => (Stroke a -> f (Stroke b)) -> Note a -> f (Note b)
mapStroke :: forall (f :: * -> *) a b.
Applicative f =>
(Stroke a -> f (Stroke b)) -> Note a -> f (Note b)
mapStroke Stroke a -> f (Stroke b)
f = \case
    Note Stroke a
stroke -> forall stroke. Stroke stroke -> Note stroke
Note forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stroke a -> f (Stroke b)
f Stroke a
stroke
    Space Space
space -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall stroke. Space -> Note stroke
Space Space
space
    Abstract Meta
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall stroke. Meta -> Note stroke
Abstract Meta
a
    Alignment Int
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall stroke. Int -> Note stroke
Alignment Int
a

instance DeepSeq.NFData (Note stroke) where rnf :: Note stroke -> ()
rnf Note stroke
_ = ()

data Stroke stroke = Stroke {
    forall stroke. Stroke stroke -> Emphasis
_emphasis :: !Emphasis
    , forall stroke. Stroke stroke -> stroke
_stroke :: !stroke
    } deriving (Stroke stroke -> Stroke stroke -> Bool
forall stroke. Eq stroke => Stroke stroke -> Stroke stroke -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stroke stroke -> Stroke stroke -> Bool
$c/= :: forall stroke. Eq stroke => Stroke stroke -> Stroke stroke -> Bool
== :: Stroke stroke -> Stroke stroke -> Bool
$c== :: forall stroke. Eq stroke => Stroke stroke -> Stroke stroke -> Bool
Eq, Stroke stroke -> Stroke stroke -> Bool
Stroke stroke -> Stroke stroke -> 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 {stroke}. Ord stroke => Eq (Stroke stroke)
forall stroke. Ord stroke => Stroke stroke -> Stroke stroke -> Bool
forall stroke.
Ord stroke =>
Stroke stroke -> Stroke stroke -> Ordering
forall stroke.
Ord stroke =>
Stroke stroke -> Stroke stroke -> Stroke stroke
min :: Stroke stroke -> Stroke stroke -> Stroke stroke
$cmin :: forall stroke.
Ord stroke =>
Stroke stroke -> Stroke stroke -> Stroke stroke
max :: Stroke stroke -> Stroke stroke -> Stroke stroke
$cmax :: forall stroke.
Ord stroke =>
Stroke stroke -> Stroke stroke -> Stroke stroke
>= :: Stroke stroke -> Stroke stroke -> Bool
$c>= :: forall stroke. Ord stroke => Stroke stroke -> Stroke stroke -> Bool
> :: Stroke stroke -> Stroke stroke -> Bool
$c> :: forall stroke. Ord stroke => Stroke stroke -> Stroke stroke -> Bool
<= :: Stroke stroke -> Stroke stroke -> Bool
$c<= :: forall stroke. Ord stroke => Stroke stroke -> Stroke stroke -> Bool
< :: Stroke stroke -> Stroke stroke -> Bool
$c< :: forall stroke. Ord stroke => Stroke stroke -> Stroke stroke -> Bool
compare :: Stroke stroke -> Stroke stroke -> Ordering
$ccompare :: forall stroke.
Ord stroke =>
Stroke stroke -> Stroke stroke -> Ordering
Ord, Int -> Stroke stroke -> ShowS
forall stroke. Show stroke => Int -> Stroke stroke -> ShowS
forall stroke. Show stroke => [Stroke stroke] -> ShowS
forall stroke. Show stroke => Stroke stroke -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stroke stroke] -> ShowS
$cshowList :: forall stroke. Show stroke => [Stroke stroke] -> ShowS
show :: Stroke stroke -> String
$cshow :: forall stroke. Show stroke => Stroke stroke -> String
showsPrec :: Int -> Stroke stroke -> ShowS
$cshowsPrec :: forall stroke. Show stroke => Int -> Stroke stroke -> ShowS
Show, forall a b. a -> Stroke b -> Stroke a
forall a b. (a -> b) -> Stroke a -> Stroke 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 -> Stroke b -> Stroke a
$c<$ :: forall a b. a -> Stroke b -> Stroke a
fmap :: forall a b. (a -> b) -> Stroke a -> Stroke b
$cfmap :: forall a b. (a -> b) -> Stroke a -> Stroke b
Functor, forall a. Eq a => a -> Stroke a -> Bool
forall a. Num a => Stroke a -> a
forall a. Ord a => Stroke a -> a
forall m. Monoid m => Stroke m -> m
forall a. Stroke a -> Bool
forall a. Stroke a -> Int
forall a. Stroke a -> [a]
forall a. (a -> a -> a) -> Stroke a -> a
forall m a. Monoid m => (a -> m) -> Stroke a -> m
forall b a. (b -> a -> b) -> b -> Stroke a -> b
forall a b. (a -> b -> b) -> b -> Stroke 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 => Stroke a -> a
$cproduct :: forall a. Num a => Stroke a -> a
sum :: forall a. Num a => Stroke a -> a
$csum :: forall a. Num a => Stroke a -> a
minimum :: forall a. Ord a => Stroke a -> a
$cminimum :: forall a. Ord a => Stroke a -> a
maximum :: forall a. Ord a => Stroke a -> a
$cmaximum :: forall a. Ord a => Stroke a -> a
elem :: forall a. Eq a => a -> Stroke a -> Bool
$celem :: forall a. Eq a => a -> Stroke a -> Bool
length :: forall a. Stroke a -> Int
$clength :: forall a. Stroke a -> Int
null :: forall a. Stroke a -> Bool
$cnull :: forall a. Stroke a -> Bool
toList :: forall a. Stroke a -> [a]
$ctoList :: forall a. Stroke a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Stroke a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Stroke a -> a
foldr1 :: forall a. (a -> a -> a) -> Stroke a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Stroke a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Stroke a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Stroke a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Stroke a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Stroke a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Stroke a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Stroke a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Stroke a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Stroke a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Stroke a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Stroke a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Stroke a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Stroke a -> m
fold :: forall m. Monoid m => Stroke m -> m
$cfold :: forall m. Monoid m => Stroke m -> m
Foldable, Functor Stroke
Foldable Stroke
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 => Stroke (m a) -> m (Stroke a)
forall (f :: * -> *) a.
Applicative f =>
Stroke (f a) -> f (Stroke a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stroke a -> m (Stroke b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stroke a -> f (Stroke b)
sequence :: forall (m :: * -> *) a. Monad m => Stroke (m a) -> m (Stroke a)
$csequence :: forall (m :: * -> *) a. Monad m => Stroke (m a) -> m (Stroke a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stroke a -> m (Stroke b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stroke a -> m (Stroke b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Stroke (f a) -> f (Stroke a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Stroke (f a) -> f (Stroke a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stroke a -> f (Stroke b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stroke a -> f (Stroke b)
Traversable)

toExpr :: Expr.ToExpr a => Stroke a -> Expr.Expr Expr.MiniVal
toExpr :: forall a. ToExpr a => Stroke a -> Expr MiniVal
toExpr (Stroke Emphasis
emphasis a
stroke) = case Emphasis
emphasis of
    Emphasis
Normal -> forall a. ToExpr a => a -> Expr MiniVal
Expr.to_expr a
stroke
    Emphasis
Light -> forall a. ToExpr a => Symbol -> a -> Expr MiniVal
Expr.with Symbol
Symbols.weak a
stroke
    Emphasis
Heavy -> forall a. ToExpr a => Symbol -> a -> Expr MiniVal
Expr.with Symbol
Symbols.accent a
stroke

instance Solkattu.Notation stroke => Solkattu.Notation (Stroke stroke) where
    notation :: Stroke stroke -> (Style, Text)
notation (Stroke Emphasis
emphasis stroke
stroke) = (Style
style forall a. Semigroup a => a -> a -> a
<> Style
strokeStyle, Text
strokeText)
        where
        -- The stroke shouldn't use a style, but if it does, emphasis overrides
        -- it.
        (Style
strokeStyle, Text
strokeText) = forall a. Notation a => a -> (Style, Text)
Solkattu.notation stroke
stroke
        style :: Style
style = case Emphasis
emphasis of
            Emphasis
Light -> forall a. Monoid a => a
mempty { _foreground :: Maybe Color
Styled._foreground = forall a. a -> Maybe a
Just (Float -> Color
Styled.rgbGray Float
0.5) }
            Emphasis
Normal -> forall a. Monoid a => a
mempty
            Emphasis
Heavy -> forall a. Monoid a => a
mempty { _bold :: Bool
Styled._bold = Bool
True }

instance Pretty stroke => Pretty (Stroke stroke) where
    pretty :: Stroke stroke -> Text
pretty (Stroke Emphasis
emphasis stroke
stroke) = (forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty stroke
stroke) forall a b. (a -> b) -> a -> b
$ case Emphasis
emphasis of
        Emphasis
Heavy -> Text
"hv "
        Emphasis
Normal -> Text
""
        Emphasis
Light -> Text
"lt "

noteOf :: Note a -> Maybe (Stroke a)
noteOf :: forall a. Note a -> Maybe (Stroke a)
noteOf (Note Stroke a
stroke) = forall a. a -> Maybe a
Just Stroke a
stroke
noteOf Note a
_ = forall a. Maybe a
Nothing

strokeOf :: Note a -> Maybe a
strokeOf :: forall a. Note a -> Maybe a
strokeOf = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall stroke. Stroke stroke -> stroke
_stroke forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Note a -> Maybe (Stroke a)
noteOf

stroke :: stroke -> Stroke stroke
stroke :: forall stroke. stroke -> Stroke stroke
stroke = forall stroke. Emphasis -> stroke -> Stroke stroke
Stroke Emphasis
Normal

rest :: SNote stroke
rest :: forall stroke. SNote stroke
rest = forall g a. a -> Note g a
S.Note (forall stroke. Space -> Note stroke
Space Space
Solkattu.Rest)

strokeToSequence :: stroke -> S.Sequence g (Solkattu.Note (Stroke stroke))
strokeToSequence :: forall stroke g. stroke -> Sequence g (Note (Stroke stroke))
strokeToSequence = forall g a. Note g a -> Sequence g a
S.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g a. a -> Note g a
S.Note forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall sollu. NoteT sollu -> Note sollu
Solkattu.Note forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall sollu. sollu -> NoteT sollu
Solkattu.note forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stroke. stroke -> Stroke stroke
stroke

-- There's no general ToCall instance for Stroke because individual instruments
-- may have special cases.

-- | The emphasis will be propagated to the underlying stroke.
data Emphasis = Light | Normal | Heavy deriving (Emphasis -> Emphasis -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Emphasis -> Emphasis -> Bool
$c/= :: Emphasis -> Emphasis -> Bool
== :: Emphasis -> Emphasis -> Bool
$c== :: Emphasis -> Emphasis -> Bool
Eq, Eq Emphasis
Emphasis -> Emphasis -> Bool
Emphasis -> Emphasis -> Ordering
Emphasis -> Emphasis -> Emphasis
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 :: Emphasis -> Emphasis -> Emphasis
$cmin :: Emphasis -> Emphasis -> Emphasis
max :: Emphasis -> Emphasis -> Emphasis
$cmax :: Emphasis -> Emphasis -> Emphasis
>= :: Emphasis -> Emphasis -> Bool
$c>= :: Emphasis -> Emphasis -> Bool
> :: Emphasis -> Emphasis -> Bool
$c> :: Emphasis -> Emphasis -> Bool
<= :: Emphasis -> Emphasis -> Bool
$c<= :: Emphasis -> Emphasis -> Bool
< :: Emphasis -> Emphasis -> Bool
$c< :: Emphasis -> Emphasis -> Bool
compare :: Emphasis -> Emphasis -> Ordering
$ccompare :: Emphasis -> Emphasis -> Ordering
Ord, Int -> Emphasis -> ShowS
[Emphasis] -> ShowS
Emphasis -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Emphasis] -> ShowS
$cshowList :: [Emphasis] -> ShowS
show :: Emphasis -> String
$cshow :: Emphasis -> String
showsPrec :: Int -> Emphasis -> ShowS
$cshowsPrec :: Int -> Emphasis -> ShowS
Show)

instance Semigroup Emphasis where <> :: Emphasis -> Emphasis -> Emphasis
(<>) = forall a. Ord a => a -> a -> a
max
instance Monoid Emphasis where
    mempty :: Emphasis
mempty = Emphasis
Normal
    mappend :: Emphasis -> Emphasis -> Emphasis
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Pretty Emphasis where
    pretty :: Emphasis -> Text
pretty Emphasis
Light = Text
"^"
    pretty Emphasis
Normal = Text
""
    pretty Emphasis
Heavy = Text
"v"

instance S.HasMatras (Note stroke) where
    matrasOf :: Note stroke -> Int
matrasOf = \case
        Note {} -> Int
1
        Space {} -> Int
1
        Abstract Meta
meta -> forall a. a -> Maybe a -> a
fromMaybe Int
1 forall a b. (a -> b) -> a -> b
$ Meta -> Maybe Int
Solkattu._matras Meta
meta
        Alignment {} -> Int
0
    hasSustain :: Note stroke -> Bool
hasSustain = \case
        Note {} -> Bool
False
        Space {} -> Bool
True
        Abstract {} -> Bool
True
        Alignment {} -> Bool
False

instance Solkattu.Notation stroke => Solkattu.Notation (Note stroke) where
    notation :: Note stroke -> (Style, Text)
notation = \case
        Space Space
Solkattu.Rest -> Text -> (Style, Text)
Solkattu.textNotation Text
"_"
        Space Space
Solkattu.Offset -> Text -> (Style, Text)
Solkattu.textNotation Text
" "
        Note Stroke stroke
s -> forall a. Notation a => a -> (Style, Text)
Solkattu.notation Stroke stroke
s
        Abstract Meta
meta -> Text -> (Style, Text)
Solkattu.textNotation forall a b. (a -> b) -> a -> b
$ Meta -> Text
metaNotation Meta
meta
        -- this should be filtered out prior to render
        Alignment Int
_ -> Text -> (Style, Text)
Solkattu.textNotation Text
""
    extension :: Note stroke -> Char
extension = \case
        Space Space
Solkattu.Rest -> Char
' '
        Abstract Meta
meta -> case Meta -> GroupType
Solkattu._type Meta
meta of
            GroupType
Solkattu.GSarva -> Char
'='
            GroupType
_ -> Char
'-'
        Note stroke
_ -> Char
' '

metaNotation :: Solkattu.Meta -> Text
metaNotation :: Meta -> Text
metaNotation (Solkattu.Meta Maybe Int
_ (Just Text
name) GroupType
_) = Text
name
metaNotation (Solkattu.Meta Maybe Int
matras Maybe Text
Nothing GroupType
gtype) = case GroupType
gtype of
    GroupType
Solkattu.GSarva -> Text
"="
    GroupType
_ -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" forall a. Show a => a -> Text
showt Maybe Int
matras forall a. Semigroup a => a -> a -> a
<> GroupType -> Text
typeName GroupType
gtype

typeName :: Solkattu.GroupType -> Text
typeName :: GroupType -> Text
typeName = \case
    GroupType
Solkattu.GGroup -> Text
""
    GroupType
Solkattu.GReductionT -> Text
""
    GroupType
Solkattu.GFiller -> Text
"f"
    GroupType
Solkattu.GPattern -> Text
"p"
    GroupType
Solkattu.GExplicitPattern -> Text
"p"
    GroupType
Solkattu.GSarva -> Text
"sarva"
    -- This should have been filtered out by 'checkDuration', and shouldn't
    -- make it to render.
    Solkattu.GCheckDuration Duration
_ -> Text
"check"

-- | Used to replace two rests.
doubleRest :: Char
doubleRest :: Char
doubleRest = Char
'‗' -- DOUBLE LOW LINE U+2017

instance Pretty stroke => Pretty (Note stroke) where
    pretty :: Note stroke -> Text
pretty Note stroke
n = case Note stroke
n of
        Space Space
Solkattu.Rest -> Text
"_"
        Space Space
Solkattu.Offset -> Text
"."
        Note Stroke stroke
s -> forall a. Pretty a => a -> Text
pretty Stroke stroke
s
        Abstract Meta
a -> forall a. Pretty a => a -> Text
pretty Meta
a
        Alignment Int
n -> Text
"@" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
n

-- * checkAlignment

-- | Stroke index and warning text.
data Warning = Warning (Maybe Int) !Text
    deriving (Int -> Warning -> ShowS
[Warning] -> ShowS
Warning -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Warning] -> ShowS
$cshowList :: [Warning] -> ShowS
show :: Warning -> String
$cshow :: Warning -> String
showsPrec :: Int -> Warning -> ShowS
$cshowsPrec :: Int -> Warning -> ShowS
Show, Warning -> Warning -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Warning -> Warning -> Bool
$c/= :: Warning -> Warning -> Bool
== :: Warning -> Warning -> Bool
$c== :: Warning -> Warning -> Bool
Eq)

-- | Verify that the notes start and end at sam, and the given Alignments
-- fall where expected.
checkAlignment :: Tala.Akshara -> S.Duration -> S.Duration
    -> [(S.Tempo, Note stroke)] -> Maybe Warning
checkAlignment :: forall stroke.
Int
-> Duration -> Duration -> [(Tempo, Note stroke)] -> Maybe Warning
checkAlignment Int
talaAksharas Duration
startOn Duration
endOn [(Tempo, Note stroke)]
notes =
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map forall {stroke}. (Int, (State, Note stroke)) -> Maybe Warning
verify (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(State, Note stroke)]
states)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Warning
checkEnd
    where
    (State
finalState, [(State, Note stroke)]
states) = forall a.
HasMatras a =>
Int -> Duration -> [(Tempo, a)] -> (State, [(State, a)])
S.tempoToState Int
talaAksharas Duration
startOn [(Tempo, Note stroke)]
notes
    -- If finalState is at 0, the section is up to but not including the end,
    -- if the finalNote is, then there is an extra note that lands on 0.
    checkEnd :: Maybe Warning
checkEnd
        | State -> Bool
atEnd State
finalState Bool -> Bool -> Bool
|| forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False State -> Bool
atEnd Maybe State
finalNote = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Int -> Text -> Warning
Warning forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
            Text
"should end on sam" forall a. Semigroup a => a -> a -> a
<> Text
endMsg forall a. Semigroup a => a -> a -> a
<> Text
", actually ends on "
            forall a. Semigroup a => a -> a -> a
<> State -> Text
S.showPosition State
finalState forall a. Semigroup a => a -> a -> a
<> Text
", or sam - " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Duration
left
        where
        endMsg :: Text
endMsg
            | Duration
endOn forall a. Eq a => a -> a -> Bool
== Duration
0 = Text
""
            | Duration
endOn forall a. Ord a => a -> a -> Bool
> Duration
0 = Text
"+" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Duration
endOn
            | Bool
otherwise = forall a. Pretty a => a -> Text
pretty Duration
endOn
        finalNote :: Maybe State
finalNote = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Note a -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall a. [a] -> [a]
reverse [(State, Note stroke)]
states)
        left :: Duration
left = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
talaAksharas forall a. Num a => a -> a -> a
- State -> Duration
S.stateMatraPosition State
finalState
    verify :: (Int, (State, Note stroke)) -> Maybe Warning
verify (Int
i, (State
state, Alignment Int
akshara))
        | Int -> State -> Bool
atAkshara Int
akshara State
state = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Int -> Text -> Warning
Warning (forall a. a -> Maybe a
Just Int
i) forall a b. (a -> b) -> a -> b
$
            Text
"expected akshara " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
akshara forall a. Semigroup a => a -> a -> a
<> Text
", but at "
            forall a. Semigroup a => a -> a -> a
<> State -> Text
S.showPosition State
state
    verify (Int, (State, Note stroke))
_ = forall a. Maybe a
Nothing
    isSpace :: Note stroke -> Bool
isSpace (Space Space
_) = Bool
True
    isSpace Note stroke
_ = Bool
False
    atEnd :: State -> Bool
atEnd State
state
        | Duration
endOn forall a. Ord a => a -> a -> Bool
>= Duration
0 = Duration
akshara forall a. Eq a => a -> a -> Bool
== Duration
endOn
        | Bool
otherwise = Duration
akshara forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
talaAksharas forall a. Eq a => a -> a -> Bool
== Duration
endOn
        where akshara :: Duration
akshara = State -> Duration
S.stateMatraPosition State
state
    atAkshara :: Int -> State -> Bool
atAkshara Int
akshara State
state =
        State -> Int
S.stateAkshara State
state forall a. Eq a => a -> a -> Bool
== Int
akshara Bool -> Bool -> Bool
&& State -> Duration
S.stateMatra State
state forall a. Eq a => a -> a -> Bool
== Duration
0

-- | Check 'Solkattu.GCheckDuration', and filter them out.
checkDuration :: [Realized stroke] -> ([Realized stroke], [Warning])
checkDuration :: forall stroke. [Realized stroke] -> ([Realized stroke], [Warning])
checkDuration = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. (a, b) -> b
snd forall a. [a] -> [a]
List.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w a. Logger w a -> (a, [w])
Logger.runId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *} {stroke}.
MonadLogger Warning m =>
Int
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
go Int
0
    where
    go :: Int
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
go Int
i [] = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [])
    go Int
i (Flat (Group (Stroke stroke)) (Note stroke)
n : [Flat (Group (Stroke stroke)) (Note stroke)]
ns) = case Flat (Group (Stroke stroke)) (Note stroke)
n of
        S.FNote {} -> forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Flat (Group (Stroke stroke)) (Note stroke)
n:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
go (Int
iforall a. Num a => a -> a -> a
+Int
1) [Flat (Group (Stroke stroke)) (Note stroke)]
ns
        S.FGroup Tempo
_tempo
                (GMeta (Solkattu.Meta { _type :: Meta -> GroupType
_type = Solkattu.GCheckDuration Duration
dur }))
                [Flat (Group (Stroke stroke)) (Note stroke)]
children -> do
            let actual :: Duration
actual = forall stroke. [Realized stroke] -> Duration
flatDuration [Flat (Group (Stroke stroke)) (Note stroke)]
children
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Duration
actual forall a. Eq a => a -> a -> Bool
== Duration
dur) forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadLogger w m => w -> m ()
Logger.log forall a b. (a -> b) -> a -> b
$ Maybe Int -> Text -> Warning
Warning (forall a. a -> Maybe a
Just Int
i) forall a b. (a -> b) -> a -> b
$
                Text
"expected " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Duration
dur forall a. Semigroup a => a -> a -> a
<> Text
" aksharas, but was "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Duration
actual
            (Int
i, [Flat (Group (Stroke stroke)) (Note stroke)]
children) <- Int
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
go Int
i [Flat (Group (Stroke stroke)) (Note stroke)]
children
            forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([Flat (Group (Stroke stroke)) (Note stroke)]
children++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
go Int
i [Flat (Group (Stroke stroke)) (Note stroke)]
ns
        S.FGroup Tempo
tempo Group (Stroke stroke)
g [Flat (Group (Stroke stroke)) (Note stroke)]
children -> do
            (Int
i, [Flat (Group (Stroke stroke)) (Note stroke)]
children) <- Int
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
go Int
i [Flat (Group (Stroke stroke)) (Note stroke)]
children
            forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo Group (Stroke stroke)
g [Flat (Group (Stroke stroke)) (Note stroke)]
children :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
go Int
i [Flat (Group (Stroke stroke)) (Note stroke)]
ns

-- | Like 'Solkattu.flatDuration', but much simpler because for 'Realized'
-- I don't need the groups for duration.
flatDuration :: [Realized stroke] -> S.Duration
flatDuration :: forall stroke. [Realized stroke] -> Duration
flatDuration = 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 (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. HasMatras a => Tempo -> a -> Duration
S.noteDuration) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g a. [Flat g a] -> [(Tempo, a)]
S.tempoNotes

-- * StrokeMap

{- | Sollu to instrument stroke mapping.

    I considered integrating both strokes and patterns into SolluMap, but
    I kind of like how the types for 'SolluMap' and 'PatternMap' can be more
    specific.  Namely, SolluMap has only strokes and rests, because it gets
    substituted for sollus, regardless of their rhythm, while PatternMap can
    have tempo changes since they always substitute a single Solkattu.Note.
    If I ever have a use for e.g. (taka.p5, ...) then I could reconsider.
-}
data StrokeMap sollu stroke = StrokeMap {
    forall sollu stroke.
StrokeMap sollu stroke -> SolluMap sollu stroke
smapSolluMap :: SolluMap sollu stroke
    -- | Shadowed SolluMapKeys, saved here to warn about them later.
    , forall sollu stroke.
StrokeMap sollu stroke
-> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
smapSolluShadows :: [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
    , forall sollu stroke. StrokeMap sollu stroke -> PatternMap stroke
smapPatternMap :: PatternMap stroke
    } deriving (StrokeMap sollu stroke -> StrokeMap sollu stroke -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall sollu stroke.
(Eq sollu, Eq stroke) =>
StrokeMap sollu stroke -> StrokeMap sollu stroke -> Bool
/= :: StrokeMap sollu stroke -> StrokeMap sollu stroke -> Bool
$c/= :: forall sollu stroke.
(Eq sollu, Eq stroke) =>
StrokeMap sollu stroke -> StrokeMap sollu stroke -> Bool
== :: StrokeMap sollu stroke -> StrokeMap sollu stroke -> Bool
$c== :: forall sollu stroke.
(Eq sollu, Eq stroke) =>
StrokeMap sollu stroke -> StrokeMap sollu stroke -> Bool
Eq, Int -> StrokeMap sollu stroke -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall sollu stroke.
(Show sollu, Show stroke) =>
Int -> StrokeMap sollu stroke -> ShowS
forall sollu stroke.
(Show sollu, Show stroke) =>
[StrokeMap sollu stroke] -> ShowS
forall sollu stroke.
(Show sollu, Show stroke) =>
StrokeMap sollu stroke -> String
showList :: [StrokeMap sollu stroke] -> ShowS
$cshowList :: forall sollu stroke.
(Show sollu, Show stroke) =>
[StrokeMap sollu stroke] -> ShowS
show :: StrokeMap sollu stroke -> String
$cshow :: forall sollu stroke.
(Show sollu, Show stroke) =>
StrokeMap sollu stroke -> String
showsPrec :: Int -> StrokeMap sollu stroke -> ShowS
$cshowsPrec :: forall sollu stroke.
(Show sollu, Show stroke) =>
Int -> StrokeMap sollu stroke -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall sollu stroke x.
Rep (StrokeMap sollu stroke) x -> StrokeMap sollu stroke
forall sollu stroke x.
StrokeMap sollu stroke -> Rep (StrokeMap sollu stroke) x
$cto :: forall sollu stroke x.
Rep (StrokeMap sollu stroke) x -> StrokeMap sollu stroke
$cfrom :: forall sollu stroke x.
StrokeMap sollu stroke -> Rep (StrokeMap sollu stroke) x
Generics.Generic)

isInstrumentEmpty :: StrokeMap sollu stroke -> Bool
isInstrumentEmpty :: forall sollu stroke. StrokeMap sollu stroke -> Bool
isInstrumentEmpty (StrokeMap (SolluMap Map (SolluMapKey sollu) [Maybe (Stroke stroke)]
smap) [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
_ (PatternMap Map Pattern [SNote stroke]
patternMap)) =
    forall k a. Map k a -> Bool
Map.null Map (SolluMapKey sollu) [Maybe (Stroke stroke)]
smap Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Map.null Map Pattern [SNote stroke]
patternMap

smapKeys :: StrokeMap sollu stroke -> Set (SolluMapKey sollu)
smapKeys :: forall sollu stroke.
StrokeMap sollu stroke -> Set (SolluMapKey sollu)
smapKeys StrokeMap sollu stroke
smap = forall k a. Map k a -> Set k
Map.keysSet Map (SolluMapKey sollu) [Maybe (Stroke stroke)]
m
    where SolluMap Map (SolluMapKey sollu) [Maybe (Stroke stroke)]
m = forall sollu stroke.
StrokeMap sollu stroke -> SolluMap sollu stroke
smapSolluMap StrokeMap sollu stroke
smap

instance Ord sollu => Semigroup (StrokeMap sollu stroke) where
    StrokeMap SolluMap sollu stroke
a1 [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
b1 PatternMap stroke
c1 <> :: StrokeMap sollu stroke
-> StrokeMap sollu stroke -> StrokeMap sollu stroke
<> StrokeMap SolluMap sollu stroke
a2 [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
b2 PatternMap stroke
c2 =
        forall sollu stroke.
SolluMap sollu stroke
-> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
-> PatternMap stroke
-> StrokeMap sollu stroke
StrokeMap (SolluMap sollu stroke
a1forall a. Semigroup a => a -> a -> a
<>SolluMap sollu stroke
a2) ([(SolluMapKey sollu, [Maybe (Stroke stroke)])]
b1forall a. Semigroup a => a -> a -> a
<>[(SolluMapKey sollu, [Maybe (Stroke stroke)])]
b2) (PatternMap stroke
c1forall a. Semigroup a => a -> a -> a
<>PatternMap stroke
c2)
instance Ord sollu => Monoid (StrokeMap sollu stroke) where
    mempty :: StrokeMap sollu stroke
mempty = forall sollu stroke.
SolluMap sollu stroke
-> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
-> PatternMap stroke
-> StrokeMap sollu stroke
StrokeMap forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    mappend :: StrokeMap sollu stroke
-> StrokeMap sollu stroke -> StrokeMap sollu stroke
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance (Pretty sollu, Pretty stroke) => Pretty (StrokeMap sollu stroke) where
    format :: StrokeMap sollu stroke -> Doc
format = forall a. (PrettyG (Rep a), Generic a) => a -> Doc
Pretty.formatGCamel

-- | Verify a list of pairs stroke map and put them in an 'StrokeMap'.
strokeMap :: (Pretty sollu, Ord sollu, Pretty stroke) => PatternMap stroke
    -> [ ( S.Sequence g (Solkattu.Note sollu)
         , S.Sequence g (Solkattu.Note (Stroke stroke))
         )
       ]
    -> Either Error (StrokeMap sollu stroke)
strokeMap :: forall sollu stroke g.
(Pretty sollu, Ord sollu, Pretty stroke) =>
PatternMap stroke
-> [(Sequence g (Note sollu), Sequence g (Note (Stroke stroke)))]
-> Either Text (StrokeMap sollu stroke)
strokeMap PatternMap stroke
pmap [(Sequence g (Note sollu), Sequence g (Note (Stroke stroke)))]
strokes = do
    [(Sequence g (Note sollu), [Note () (Note stroke)])]
strokes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall g stroke.
Sequence g (Note (Stroke stroke))
-> Either Text [Note () (Note stroke)]
solkattuToRealize) [(Sequence g (Note sollu), Sequence g (Note (Stroke stroke)))]
strokes
    (SolluMap sollu stroke
smap, [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
solluShadows) <- forall stroke sollu g.
(Pretty stroke, Pretty sollu, Ord sollu) =>
[(Sequence g (Note sollu), [SNote stroke])]
-> Either
     Text
     (SolluMap sollu stroke,
      [(SolluMapKey sollu, [Maybe (Stroke stroke)])])
solluMap [(Sequence g (Note sollu), [Note () (Note stroke)])]
strokes
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ StrokeMap
        { smapSolluMap :: SolluMap sollu stroke
smapSolluMap = SolluMap sollu stroke
smap
        , smapSolluShadows :: [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
smapSolluShadows = [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
solluShadows
        , smapPatternMap :: PatternMap stroke
smapPatternMap = PatternMap stroke
pmap
        }

-- | Stroke maps use 'Solkattu.Notes', so they can use the same language in
-- "Solkattu.Dsl".  But since they don't go through a realization step
-- (being used to implement the realization step for sollus), I can directly
-- map them to 'Realize.Note's before storing them in 'StrokeMap'.
solkattuToRealize :: S.Sequence g (Solkattu.Note (Stroke stroke))
    -> Either Error [S.Note () (Note stroke)]
solkattuToRealize :: forall g stroke.
Sequence g (Note (Stroke stroke))
-> Either Text [Note () (Note stroke)]
solkattuToRealize = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {stroke}. Note (Stroke stroke) -> Either Text (Note stroke)
convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g h a. (g -> h) -> Note g a -> Note h a
S.mapGroup (forall a b. a -> b -> a
const ())) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g a. Sequence g a -> [Note g a]
S.toList
    where
    convert :: Note (Stroke stroke) -> Either Text (Note stroke)
convert = \case
        Solkattu.Note NoteT (Stroke stroke)
n -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall stroke. Stroke stroke -> Note stroke
Note (forall sollu. NoteT sollu -> sollu
Solkattu._sollu NoteT (Stroke stroke)
n)
        Solkattu.Space Space
a -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall stroke. Space -> Note stroke
Space Space
a
        Solkattu.Pattern Pattern
p -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"can't convert pattern: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Pattern
p
        Solkattu.Alignment Int
a -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall stroke. Int -> Note stroke
Alignment Int
a

-- ** PatternMap

-- | This maps a 'Pattern' of a certain duration to a realization.  The
-- 'S.Matra's should the same duration as the the list in the default tempo.
-- This is enforced in the constructor 'patternMap'.
newtype PatternMap stroke = PatternMap (Map Solkattu.Pattern [SNote stroke])
    deriving (PatternMap stroke -> PatternMap stroke -> Bool
forall stroke.
Eq stroke =>
PatternMap stroke -> PatternMap stroke -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PatternMap stroke -> PatternMap stroke -> Bool
$c/= :: forall stroke.
Eq stroke =>
PatternMap stroke -> PatternMap stroke -> Bool
== :: PatternMap stroke -> PatternMap stroke -> Bool
$c== :: forall stroke.
Eq stroke =>
PatternMap stroke -> PatternMap stroke -> Bool
Eq, Int -> PatternMap stroke -> ShowS
forall stroke. Show stroke => Int -> PatternMap stroke -> ShowS
forall stroke. Show stroke => [PatternMap stroke] -> ShowS
forall stroke. Show stroke => PatternMap stroke -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PatternMap stroke] -> ShowS
$cshowList :: forall stroke. Show stroke => [PatternMap stroke] -> ShowS
show :: PatternMap stroke -> String
$cshow :: forall stroke. Show stroke => PatternMap stroke -> String
showsPrec :: Int -> PatternMap stroke -> ShowS
$cshowsPrec :: forall stroke. Show stroke => Int -> PatternMap stroke -> ShowS
Show, [PatternMap stroke] -> Doc
PatternMap stroke -> Text
PatternMap stroke -> Doc
forall stroke. Pretty stroke => [PatternMap stroke] -> Doc
forall stroke. Pretty stroke => PatternMap stroke -> Text
forall stroke. Pretty stroke => PatternMap stroke -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [PatternMap stroke] -> Doc
$cformatList :: forall stroke. Pretty stroke => [PatternMap stroke] -> Doc
format :: PatternMap stroke -> Doc
$cformat :: forall stroke. Pretty stroke => PatternMap stroke -> Doc
pretty :: PatternMap stroke -> Text
$cpretty :: forall stroke. Pretty stroke => PatternMap stroke -> Text
Pretty, NonEmpty (PatternMap stroke) -> PatternMap stroke
PatternMap stroke -> PatternMap stroke -> PatternMap stroke
forall b. Integral b => b -> PatternMap stroke -> PatternMap stroke
forall stroke. NonEmpty (PatternMap stroke) -> PatternMap stroke
forall stroke.
PatternMap stroke -> PatternMap stroke -> PatternMap stroke
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall stroke b.
Integral b =>
b -> PatternMap stroke -> PatternMap stroke
stimes :: forall b. Integral b => b -> PatternMap stroke -> PatternMap stroke
$cstimes :: forall stroke b.
Integral b =>
b -> PatternMap stroke -> PatternMap stroke
sconcat :: NonEmpty (PatternMap stroke) -> PatternMap stroke
$csconcat :: forall stroke. NonEmpty (PatternMap stroke) -> PatternMap stroke
<> :: PatternMap stroke -> PatternMap stroke -> PatternMap stroke
$c<> :: forall stroke.
PatternMap stroke -> PatternMap stroke -> PatternMap stroke
Semigroup, PatternMap stroke
[PatternMap stroke] -> PatternMap stroke
PatternMap stroke -> PatternMap stroke -> PatternMap stroke
forall stroke. Semigroup (PatternMap stroke)
forall stroke. PatternMap stroke
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall stroke. [PatternMap stroke] -> PatternMap stroke
forall stroke.
PatternMap stroke -> PatternMap stroke -> PatternMap stroke
mconcat :: [PatternMap stroke] -> PatternMap stroke
$cmconcat :: forall stroke. [PatternMap stroke] -> PatternMap stroke
mappend :: PatternMap stroke -> PatternMap stroke -> PatternMap stroke
$cmappend :: forall stroke.
PatternMap stroke -> PatternMap stroke -> PatternMap stroke
mempty :: PatternMap stroke
$cmempty :: forall stroke. PatternMap stroke
Monoid)

-- | Make a PatternMap while checking that the durations match.  Analogous to
-- 'solluMap'.
patternMap :: [(Solkattu.Pattern, S.Sequence () (Note stroke))]
    -> Either Error (PatternMap stroke)
patternMap :: forall stroke.
[(Pattern, Sequence () (Note stroke))]
-> Either Text (PatternMap stroke)
patternMap [(Pattern, Sequence () (Note stroke))]
pairs
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errors = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall stroke. Map Pattern [SNote stroke] -> PatternMap stroke
PatternMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall g a. Sequence g a -> [Note g a]
S.toList) [(Pattern, Sequence () (Note stroke))]
pairs
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"; " [Text]
errors
    where
    errors :: [Text]
errors = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {a} {g}.
(HasMatras a, Show a, HasMatras a) =>
(a, Sequence g a) -> Maybe Text
check [(Pattern, Sequence () (Note stroke))]
pairs
    check :: (a, Sequence g a) -> Maybe Text
check (a
p, Sequence g a
notes)
        | Duration
notesMatras forall a. Eq a => a -> a -> Bool
/= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. HasMatras a => a -> Int
S.matrasOf a
p) =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"pattern matras " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a. HasMatras a => a -> Int
S.matrasOf a
p)
                forall a. Semigroup a => a -> a -> a
<> Text
" /= realization matras " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Duration
notesMatras
                forall a. Semigroup a => a -> a -> a
<> Text
" for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
p
        | Bool
otherwise = forall a. Maybe a
Nothing
        where
        notesMatras :: Duration
notesMatras = Duration
notesDuration forall a. Fractional a => a -> a -> a
/ Tempo -> Duration
S.matraDuration Tempo
S.defaultTempo
        notesDuration :: Duration
notesDuration = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a g. HasMatras a => Tempo -> Note g a -> Duration
S.durationOf Tempo
S.defaultTempo) forall a b. (a -> b) -> a -> b
$
            forall g a. Sequence g a -> [Note g a]
S.toList Sequence g a
notes

lookupPattern :: Solkattu.Pattern -> PatternMap stroke -> Maybe [SNote stroke]
lookupPattern :: forall stroke. Pattern -> PatternMap stroke -> Maybe [SNote stroke]
lookupPattern Pattern
p (PatternMap Map Pattern [SNote stroke]
pmap) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Pattern
p Map Pattern [SNote stroke]
pmap

-- ** SolluMap

-- | Sollus and Strokes should be the same length.  This is enforced in the
-- constructor 'solluMap'.  Nothing is a rest, which means a sollu can map
-- to silence, which actually happens in practice.
newtype SolluMap sollu stroke =
    SolluMap (Map (SolluMapKey sollu) [Maybe (Stroke stroke)])
    deriving (SolluMap sollu stroke -> SolluMap sollu stroke -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall sollu stroke.
(Eq sollu, Eq stroke) =>
SolluMap sollu stroke -> SolluMap sollu stroke -> Bool
/= :: SolluMap sollu stroke -> SolluMap sollu stroke -> Bool
$c/= :: forall sollu stroke.
(Eq sollu, Eq stroke) =>
SolluMap sollu stroke -> SolluMap sollu stroke -> Bool
== :: SolluMap sollu stroke -> SolluMap sollu stroke -> Bool
$c== :: forall sollu stroke.
(Eq sollu, Eq stroke) =>
SolluMap sollu stroke -> SolluMap sollu stroke -> Bool
Eq, Int -> SolluMap sollu stroke -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall sollu stroke.
(Show sollu, Show stroke) =>
Int -> SolluMap sollu stroke -> ShowS
forall sollu stroke.
(Show sollu, Show stroke) =>
[SolluMap sollu stroke] -> ShowS
forall sollu stroke.
(Show sollu, Show stroke) =>
SolluMap sollu stroke -> String
showList :: [SolluMap sollu stroke] -> ShowS
$cshowList :: forall sollu stroke.
(Show sollu, Show stroke) =>
[SolluMap sollu stroke] -> ShowS
show :: SolluMap sollu stroke -> String
$cshow :: forall sollu stroke.
(Show sollu, Show stroke) =>
SolluMap sollu stroke -> String
showsPrec :: Int -> SolluMap sollu stroke -> ShowS
$cshowsPrec :: forall sollu stroke.
(Show sollu, Show stroke) =>
Int -> SolluMap sollu stroke -> ShowS
Show, [SolluMap sollu stroke] -> Doc
SolluMap sollu stroke -> Text
SolluMap sollu stroke -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
forall sollu stroke.
(Pretty sollu, Pretty stroke) =>
[SolluMap sollu stroke] -> Doc
forall sollu stroke.
(Pretty sollu, Pretty stroke) =>
SolluMap sollu stroke -> Text
forall sollu stroke.
(Pretty sollu, Pretty stroke) =>
SolluMap sollu stroke -> Doc
formatList :: [SolluMap sollu stroke] -> Doc
$cformatList :: forall sollu stroke.
(Pretty sollu, Pretty stroke) =>
[SolluMap sollu stroke] -> Doc
format :: SolluMap sollu stroke -> Doc
$cformat :: forall sollu stroke.
(Pretty sollu, Pretty stroke) =>
SolluMap sollu stroke -> Doc
pretty :: SolluMap sollu stroke -> Text
$cpretty :: forall sollu stroke.
(Pretty sollu, Pretty stroke) =>
SolluMap sollu stroke -> Text
Pretty, NonEmpty (SolluMap sollu stroke) -> SolluMap sollu stroke
SolluMap sollu stroke
-> SolluMap sollu stroke -> SolluMap sollu stroke
forall b.
Integral b =>
b -> SolluMap sollu stroke -> SolluMap sollu stroke
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall sollu stroke.
Ord sollu =>
NonEmpty (SolluMap sollu stroke) -> SolluMap sollu stroke
forall sollu stroke.
Ord sollu =>
SolluMap sollu stroke
-> SolluMap sollu stroke -> SolluMap sollu stroke
forall sollu stroke b.
(Ord sollu, Integral b) =>
b -> SolluMap sollu stroke -> SolluMap sollu stroke
stimes :: forall b.
Integral b =>
b -> SolluMap sollu stroke -> SolluMap sollu stroke
$cstimes :: forall sollu stroke b.
(Ord sollu, Integral b) =>
b -> SolluMap sollu stroke -> SolluMap sollu stroke
sconcat :: NonEmpty (SolluMap sollu stroke) -> SolluMap sollu stroke
$csconcat :: forall sollu stroke.
Ord sollu =>
NonEmpty (SolluMap sollu stroke) -> SolluMap sollu stroke
<> :: SolluMap sollu stroke
-> SolluMap sollu stroke -> SolluMap sollu stroke
$c<> :: forall sollu stroke.
Ord sollu =>
SolluMap sollu stroke
-> SolluMap sollu stroke -> SolluMap sollu stroke
Semigroup, SolluMap sollu stroke
[SolluMap sollu stroke] -> SolluMap sollu stroke
SolluMap sollu stroke
-> SolluMap sollu stroke -> SolluMap sollu stroke
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall sollu stroke. Ord sollu => Semigroup (SolluMap sollu stroke)
forall sollu stroke. Ord sollu => SolluMap sollu stroke
forall sollu stroke.
Ord sollu =>
[SolluMap sollu stroke] -> SolluMap sollu stroke
forall sollu stroke.
Ord sollu =>
SolluMap sollu stroke
-> SolluMap sollu stroke -> SolluMap sollu stroke
mconcat :: [SolluMap sollu stroke] -> SolluMap sollu stroke
$cmconcat :: forall sollu stroke.
Ord sollu =>
[SolluMap sollu stroke] -> SolluMap sollu stroke
mappend :: SolluMap sollu stroke
-> SolluMap sollu stroke -> SolluMap sollu stroke
$cmappend :: forall sollu stroke.
Ord sollu =>
SolluMap sollu stroke
-> SolluMap sollu stroke -> SolluMap sollu stroke
mempty :: SolluMap sollu stroke
$cmempty :: forall sollu stroke. Ord sollu => SolluMap sollu stroke
Monoid)
type SolluMapKey sollu = (Maybe Solkattu.Tag, [sollu])

prettyKey :: Pretty sollu => SolluMapKey sollu -> Text
prettyKey :: forall sollu. Pretty sollu => SolluMapKey sollu -> Text
prettyKey (Maybe Tag
tag, [sollu]
sollus) = 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) Maybe Tag
tag forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [sollu]
sollus

-- | Verify and costruct a SolluMap from a list of pairs.  Later pairs win over
-- earlier ones.
solluMap :: (Pretty stroke, Pretty sollu, Ord sollu)
    => [(S.Sequence g (Solkattu.Note sollu), [SNote stroke])]
    -> Either Error (SolluMap sollu stroke,
        [(SolluMapKey sollu, [Maybe (Stroke stroke)])])
solluMap :: forall stroke sollu g.
(Pretty stroke, Pretty sollu, Ord sollu) =>
[(Sequence g (Note sollu), [SNote stroke])]
-> Either
     Text
     (SolluMap sollu stroke,
      [(SolluMapKey sollu, [Maybe (Stroke stroke)])])
solluMap = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall sollu stroke.
Map (SolluMapKey sollu) [Maybe (Stroke stroke)]
-> SolluMap sollu stroke
SolluMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ord a => [(a, b)] -> (Map a b, [(a, b)])
Maps.unique forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse) 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 forall stroke sollu g.
(Pretty stroke, Pretty sollu) =>
(Sequence g (Note sollu), [SNote stroke])
-> Either Text (SolluMapKey sollu, [Maybe (Stroke stroke)])
verifySolluMap

-- | A sollu can map to a rest stroke: tang.ga, where ga is silent Or
-- taka.tarikita played N_ktpk.  But I don't think a rest sollu can map to
-- a stroke, and in fact it won't work since I look up by sollus only.
verifySolluMap :: (Pretty stroke, Pretty sollu)
    => (S.Sequence g (Solkattu.Note sollu), [SNote stroke])
    -> Either Error (SolluMapKey sollu, [Maybe (Stroke stroke)])
verifySolluMap :: forall stroke sollu g.
(Pretty stroke, Pretty sollu) =>
(Sequence g (Note sollu), [SNote stroke])
-> Either Text (SolluMapKey sollu, [Maybe (Stroke stroke)])
verifySolluMap (Sequence g (Note sollu)
sollus, [SNote stroke]
strokes) = do
    (Maybe Tag
tag, [Maybe sollu]
mbSollus) <- forall sollu g.
Pretty sollu =>
[Note g (Note sollu)] -> Either Text (SolluMapKey (Maybe sollu))
verifySolluKey forall a b. (a -> b) -> a -> b
$ forall g a. Sequence g a -> [Note g a]
S.toList Sequence g (Note sollu)
sollus

    let pSollus :: [Maybe sollu] -> Text
pSollus = Text -> [Text] -> Text
Text.intercalate Text
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"__" forall a. Pretty a => a -> Text
pretty)
        pStrokes :: [SNote stroke] -> Text
pStrokes = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty
    let throw :: Text -> Either Text b
throw = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
pref<>)
            where pref :: Text
pref = [Maybe sollu] -> Text
pSollus [Maybe sollu]
mbSollus forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> [SNote stroke] -> Text
pStrokes [SNote stroke]
strokes forall a. Semigroup a => a -> a -> a
<> Text
": "
    -- TODO enable strictCheck somehow.  Maybe on by default, and disable via
    -- tag on strokes?
    let strictCheck :: Bool
strictCheck = Bool
False
    [Maybe (Maybe (Stroke stroke))]
strokes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [([a], [b])]
zipTails [Maybe sollu]
mbSollus [SNote stroke]
strokes) forall a b. (a -> b) -> a -> b
$ \case
        (Just sollu
sollu : [Maybe sollu]
_, S.Note (Space {}) : [SNote stroke]
_)
            | Bool
strictCheck ->
                forall {b}. Text -> Either Text b
throw forall a b. (a -> b) -> a -> b
$ Text
"sollu '" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty sollu
sollu forall a. Semigroup a => a -> a -> a
<> Text
"' given rest stroke"
            | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
        (Maybe sollu
Nothing : [Maybe sollu]
_, S.Note (Note Stroke stroke
stroke) : [SNote stroke]
_) ->
            forall {b}. Text -> Either Text b
throw forall a b. (a -> b) -> a -> b
$ Text
"rest sollu given non-rest stroke '" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Stroke stroke
stroke forall a. Semigroup a => a -> a -> a
<> Text
"'"
        (Maybe sollu
Nothing : [Maybe sollu]
_, S.Note (Space {}) : [SNote stroke]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        (Just sollu
_ : [Maybe sollu]
_, S.Note (Note Stroke stroke
stroke) : [SNote stroke]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Stroke stroke
stroke
        ([Maybe sollu]
sollus, []) ->
            forall {b}. Text -> Either Text b
throw forall a b. (a -> b) -> a -> b
$ Text
"more sollus than strokes at " forall a. Semigroup a => a -> a -> a
<> [Maybe sollu] -> Text
pSollus [Maybe sollu]
sollus
        ([], [SNote stroke]
strokes) ->
            forall {b}. Text -> Either Text b
throw forall a b. (a -> b) -> a -> b
$ Text
"more strokes than sollus at " forall a. Semigroup a => a -> a -> a
<> [SNote stroke] -> Text
pStrokes [SNote stroke]
strokes
        (Maybe sollu
sollu : [Maybe sollu]
_, SNote stroke
stroke : [SNote stroke]
_) ->
            forall {b}. Text -> Either Text b
throw forall a b. (a -> b) -> a -> b
$ Text
"should have plain sollus and strokes: "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Maybe sollu
sollu, SNote stroke
stroke)
    forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe Tag
tag, forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe sollu]
mbSollus), forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe (Maybe (Stroke stroke))]
strokes)

zipTails :: [a] -> [b] -> [([a], [b])]
zipTails :: forall a b. [a] -> [b] -> [([a], [b])]
zipTails [a]
as [b]
bs = forall a. (a -> Bool) -> [a] -> [a]
filter (\([a]
as, [b]
bs) -> Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
as Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
bs)) forall a b. (a -> b) -> a -> b
$
    forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [[a]]
List.tails [a]
as) (forall a. [a] -> [[a]]
List.tails [b]
bs)

verifySolluKey :: Pretty sollu => [S.Note g (Solkattu.Note sollu)]
    -> Either Error (SolluMapKey (Maybe sollu))
verifySolluKey :: forall sollu g.
Pretty sollu =>
[Note g (Note sollu)] -> Either Text (SolluMapKey (Maybe sollu))
verifySolluKey [Note g (Note sollu)]
sollus_ = do
    let sollus :: [Note () (Note sollu)]
sollus = forall a b. (a -> b) -> [a] -> [b]
map (forall g h a. (g -> h) -> Note g a -> Note h a
S.mapGroup (forall a b. a -> b -> a
const ())) [Note g (Note sollu)]
sollus_
    let throw :: Text -> Either Text b
throw = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. Pretty a => a -> Text
pretty [Note () (Note sollu)]
sollus forall a. Semigroup a => a -> a -> a
<> Text
": ")<>)
    ([Maybe Tag]
tags, [Maybe sollu]
sollus) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
Maybe.catMaybes) forall a b. (a -> b) -> a -> b
$
        -- Allow but ignore TempoChanges.  This makes it convenient to use
        -- a sequence like 'nakataka = su (na.ka.ta.ka)' in both notation
        -- and the stroke map.
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall g a. [Note g a] -> [a]
S.notes [Note () (Note sollu)]
sollus) forall a b. (a -> b) -> a -> b
$ \case
            Solkattu.Note NoteT sollu
note ->
                forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall sollu. NoteT sollu -> Maybe Tag
Solkattu._tag NoteT sollu
note, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall sollu. NoteT sollu -> sollu
Solkattu._sollu NoteT sollu
note)
            Solkattu.Space {} -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
            Note sollu
s -> forall {b}. Text -> Either Text b
throw forall a b. (a -> b) -> a -> b
$ Text
"should only have plain sollus: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Note sollu
s
    -- TODO warn if there are inconsistent tags?
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Maybe a
Lists.head (forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe Tag]
tags), [Maybe sollu]
sollus)


-- * realize

type RealizePattern tempo stroke =
    tempo -> Solkattu.Pattern -> Either Error [(tempo, Note stroke)]

realizePattern :: PatternMap stroke -> RealizePattern S.Tempo stroke
realizePattern :: forall stroke. PatternMap stroke -> RealizePattern Tempo stroke
realizePattern PatternMap stroke
pmap Tempo
tempo Pattern
pattern = case forall stroke. Pattern -> PatternMap stroke -> Maybe [SNote stroke]
lookupPattern Pattern
pattern PatternMap stroke
pmap of
    Maybe [SNote stroke]
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"no pattern for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Pattern
pattern
    Just [SNote stroke]
notes -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall g a. [Flat g a] -> [(Tempo, a)]
S.tempoNotes forall a b. (a -> b) -> a -> b
$ forall g a. Tempo -> [Note g a] -> [Flat g a]
S.flattenWith Tempo
tempo [SNote stroke]
notes

-- | This is the realized version of 'Solkattu.Group'.  I retain the dropped
-- strokes so "Solkattu.Technique" can use them.
data Group stroke =
    GReduction !(Reduction stroke)
    | GMeta !Solkattu.Meta
    deriving (Group stroke -> Group stroke -> Bool
forall stroke. Eq stroke => Group stroke -> Group stroke -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Group stroke -> Group stroke -> Bool
$c/= :: forall stroke. Eq stroke => Group stroke -> Group stroke -> Bool
== :: Group stroke -> Group stroke -> Bool
$c== :: forall stroke. Eq stroke => Group stroke -> Group stroke -> Bool
Eq, Group stroke -> Group stroke -> Bool
Group stroke -> Group stroke -> 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 {stroke}. Ord stroke => Eq (Group stroke)
forall stroke. Ord stroke => Group stroke -> Group stroke -> Bool
forall stroke.
Ord stroke =>
Group stroke -> Group stroke -> Ordering
forall stroke.
Ord stroke =>
Group stroke -> Group stroke -> Group stroke
min :: Group stroke -> Group stroke -> Group stroke
$cmin :: forall stroke.
Ord stroke =>
Group stroke -> Group stroke -> Group stroke
max :: Group stroke -> Group stroke -> Group stroke
$cmax :: forall stroke.
Ord stroke =>
Group stroke -> Group stroke -> Group stroke
>= :: Group stroke -> Group stroke -> Bool
$c>= :: forall stroke. Ord stroke => Group stroke -> Group stroke -> Bool
> :: Group stroke -> Group stroke -> Bool
$c> :: forall stroke. Ord stroke => Group stroke -> Group stroke -> Bool
<= :: Group stroke -> Group stroke -> Bool
$c<= :: forall stroke. Ord stroke => Group stroke -> Group stroke -> Bool
< :: Group stroke -> Group stroke -> Bool
$c< :: forall stroke. Ord stroke => Group stroke -> Group stroke -> Bool
compare :: Group stroke -> Group stroke -> Ordering
$ccompare :: forall stroke.
Ord stroke =>
Group stroke -> Group stroke -> Ordering
Ord, Int -> Group stroke -> ShowS
forall stroke. Show stroke => Int -> Group stroke -> ShowS
forall stroke. Show stroke => [Group stroke] -> ShowS
forall stroke. Show stroke => Group stroke -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Group stroke] -> ShowS
$cshowList :: forall stroke. Show stroke => [Group stroke] -> ShowS
show :: Group stroke -> String
$cshow :: forall stroke. Show stroke => Group stroke -> String
showsPrec :: Int -> Group stroke -> ShowS
$cshowsPrec :: forall stroke. Show stroke => Int -> Group stroke -> ShowS
Show, forall a b. a -> Group b -> Group a
forall a b. (a -> b) -> Group a -> Group 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 -> Group b -> Group a
$c<$ :: forall a b. a -> Group b -> Group a
fmap :: forall a b. (a -> b) -> Group a -> Group b
$cfmap :: forall a b. (a -> b) -> Group a -> Group b
Functor)

data Reduction stroke = Reduction {
    forall stroke. Reduction stroke -> [stroke]
_dropped :: ![stroke]
    , forall stroke. Reduction stroke -> Side
_side :: !Solkattu.Side
    } deriving (Reduction stroke -> Reduction stroke -> Bool
forall stroke.
Eq stroke =>
Reduction stroke -> Reduction stroke -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Reduction stroke -> Reduction stroke -> Bool
$c/= :: forall stroke.
Eq stroke =>
Reduction stroke -> Reduction stroke -> Bool
== :: Reduction stroke -> Reduction stroke -> Bool
$c== :: forall stroke.
Eq stroke =>
Reduction stroke -> Reduction stroke -> Bool
Eq, Reduction stroke -> Reduction stroke -> Bool
Reduction stroke -> Reduction stroke -> 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 {stroke}. Ord stroke => Eq (Reduction stroke)
forall stroke.
Ord stroke =>
Reduction stroke -> Reduction stroke -> Bool
forall stroke.
Ord stroke =>
Reduction stroke -> Reduction stroke -> Ordering
forall stroke.
Ord stroke =>
Reduction stroke -> Reduction stroke -> Reduction stroke
min :: Reduction stroke -> Reduction stroke -> Reduction stroke
$cmin :: forall stroke.
Ord stroke =>
Reduction stroke -> Reduction stroke -> Reduction stroke
max :: Reduction stroke -> Reduction stroke -> Reduction stroke
$cmax :: forall stroke.
Ord stroke =>
Reduction stroke -> Reduction stroke -> Reduction stroke
>= :: Reduction stroke -> Reduction stroke -> Bool
$c>= :: forall stroke.
Ord stroke =>
Reduction stroke -> Reduction stroke -> Bool
> :: Reduction stroke -> Reduction stroke -> Bool
$c> :: forall stroke.
Ord stroke =>
Reduction stroke -> Reduction stroke -> Bool
<= :: Reduction stroke -> Reduction stroke -> Bool
$c<= :: forall stroke.
Ord stroke =>
Reduction stroke -> Reduction stroke -> Bool
< :: Reduction stroke -> Reduction stroke -> Bool
$c< :: forall stroke.
Ord stroke =>
Reduction stroke -> Reduction stroke -> Bool
compare :: Reduction stroke -> Reduction stroke -> Ordering
$ccompare :: forall stroke.
Ord stroke =>
Reduction stroke -> Reduction stroke -> Ordering
Ord, Int -> Reduction stroke -> ShowS
forall stroke. Show stroke => Int -> Reduction stroke -> ShowS
forall stroke. Show stroke => [Reduction stroke] -> ShowS
forall stroke. Show stroke => Reduction stroke -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Reduction stroke] -> ShowS
$cshowList :: forall stroke. Show stroke => [Reduction stroke] -> ShowS
show :: Reduction stroke -> String
$cshow :: forall stroke. Show stroke => Reduction stroke -> String
showsPrec :: Int -> Reduction stroke -> ShowS
$cshowsPrec :: forall stroke. Show stroke => Int -> Reduction stroke -> ShowS
Show, forall a b. a -> Reduction b -> Reduction a
forall a b. (a -> b) -> Reduction a -> Reduction 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 -> Reduction b -> Reduction a
$c<$ :: forall a b. a -> Reduction b -> Reduction a
fmap :: forall a b. (a -> b) -> Reduction a -> Reduction b
$cfmap :: forall a b. (a -> b) -> Reduction a -> Reduction b
Functor)

instance Pretty stroke => Pretty (Group stroke) where
    pretty :: Group stroke -> Text
pretty (GReduction Reduction stroke
r) = forall a. Pretty a => a -> Text
pretty Reduction stroke
r
    pretty (GMeta Meta
m) = forall a. Pretty a => a -> Text
pretty Meta
m

instance Pretty stroke => Pretty (Reduction stroke) where
    pretty :: Reduction stroke -> Text
pretty (Reduction [stroke]
dropped Side
side) = forall a. Pretty a => a -> Text
pretty ([stroke]
dropped, Side
side)

type Realized stroke = S.Flat (Group (Stroke stroke)) (Note stroke)

realize :: (Pretty sollu, Ord sollu)
    => StrokeMap Solkattu.Sollu stroke -> ToStrokes sollu stroke
    -> Tala.Akshara -> [S.Flat Solkattu.Group (Solkattu.Note sollu)]
    -> (UF.UntilFail Error (Realized stroke), Set (SolluMapKey sollu))
realize :: forall sollu stroke.
(Pretty sollu, Ord sollu) =>
StrokeMap Sollu stroke
-> ToStrokes sollu stroke
-> Int
-> [Flat Group (Note sollu)]
-> (UntilFail Text (Realized stroke), Set (SolluMapKey sollu))
realize StrokeMap Sollu stroke
smap = forall sollu stroke.
(Pretty sollu, Ord sollu) =>
RealizePattern Tempo stroke
-> ToStrokes sollu stroke
-> Int
-> [Flat Group (Note sollu)]
-> (UntilFail Text (Realized stroke), Set (SolluMapKey sollu))
realize_ (forall stroke. PatternMap stroke -> RealizePattern Tempo stroke
realizePattern (forall sollu stroke. StrokeMap sollu stroke -> PatternMap stroke
smapPatternMap StrokeMap Sollu stroke
smap))
    -- TODO just pass PatternMap, since I don't parameterize anymore.
    -- Well, except Korvai.matchedSollus.

realize_ :: (Pretty sollu, Ord sollu)
    => RealizePattern S.Tempo stroke -> ToStrokes sollu stroke
    -> Tala.Akshara -> [S.Flat Solkattu.Group (Solkattu.Note sollu)]
    -> (UF.UntilFail Error (Realized stroke), Set (SolluMapKey sollu))
realize_ :: forall sollu stroke.
(Pretty sollu, Ord sollu) =>
RealizePattern Tempo stroke
-> ToStrokes sollu stroke
-> Int
-> [Flat Group (Note sollu)]
-> (UntilFail Text (Realized stroke), Set (SolluMapKey sollu))
realize_ RealizePattern Tempo stroke
realizePattern ToStrokes sollu stroke
toStrokes Int
talaAksharas =
    -- The writer keeps track of the set of sollu patterns I've used, so I can
    -- warn about unused ones.
    forall w a. Monoid w => Writer w a -> (a, w)
Writer.runWriter
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a err b.
(a -> UntilFail err b) -> UntilFail err a -> UntilFail err b
UF.concatMap forall stroke.
Flat Group (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
convertGroups)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a err b.
Monad m =>
(a -> [a] -> m (UntilFail err b, [a]))
-> [a] -> m (UntilFail err b)
UF.processM forall {m :: * -> *}.
Monad m =>
(State, Flat Group (Note sollu))
-> [(State, Flat Group (Note sollu))]
-> WriterT
     (Set (SolluMapKey sollu))
     m
     (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
realize1
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
HasMatras a =>
State -> [Flat Group a] -> [(State, Flat Group a)]
flatToState (Int -> Duration -> State
S.stateFrom Int
talaAksharas Duration
0) -- TODO use eddupu
    where
    flatToState :: State -> [Flat Group a] -> [(State, Flat Group a)]
flatToState State
state =
        forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g a.
(Flat g a -> Duration)
-> Int -> State -> [Flat g a] -> (State, [(State, Flat g a)])
S.flatToState forall a. HasMatras a => Flat Group a -> Duration
Solkattu.flatDuration Int
talaAksharas State
state
    realize1 :: (State, Flat Group (Note sollu))
-> [(State, Flat Group (Note sollu))]
-> WriterT
     (Set (SolluMapKey sollu))
     m
     (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
realize1 (State
state, note :: Flat Group (Note sollu)
note@(S.FNote Tempo
tempo Note sollu
n)) [(State, Flat Group (Note sollu))]
notes = case Note sollu
n of
        Solkattu.Alignment Int
n -> forall (m :: * -> *) a. Monad m => a -> m a
return
            (forall a err. a -> UntilFail err a
UF.singleton forall a b. (a -> b) -> a -> b
$ forall g a. Tempo -> a -> Flat g a
S.FNote Tempo
tempo (forall stroke. Int -> Note stroke
Alignment Int
n), [(State, Flat Group (Note sollu))]
notes)
        Solkattu.Space Space
space -> forall (m :: * -> *) a. Monad m => a -> m a
return
            (forall a err. a -> UntilFail err a
UF.singleton forall a b. (a -> b) -> a -> b
$ forall g a. Tempo -> a -> Flat g a
S.FNote Tempo
tempo (forall stroke. Space -> Note stroke
Space Space
space), [(State, Flat Group (Note sollu))]
notes)
        Solkattu.Pattern p :: Pattern
p@(Solkattu.PatternM Int
matras) -> forall (m :: * -> *) a. Monad m => a -> m a
return
            ( case RealizePattern Tempo stroke
realizePattern Tempo
tempo Pattern
p of
                Left Text
err -> forall err a. err -> UntilFail err a
UF.Fail Text
err
                Right [(Tempo, Note stroke)]
tempoNotes -> forall a err. a -> UntilFail err a
UF.singleton forall a b. (a -> b) -> a -> b
$ forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo Group
group forall a b. (a -> b) -> a -> b
$
                    forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall g a. Tempo -> a -> Flat g a
S.FNote) [(Tempo, Note stroke)]
tempoNotes
            , [(State, Flat Group (Note sollu))]
notes
            )
            where
            group :: Group
group = Meta -> Group
Solkattu.GMeta forall a b. (a -> b) -> a -> b
$ Solkattu.Meta
                { _matras :: Maybe Int
_matras = forall a. a -> Maybe a
Just Int
matras
                , _name :: Maybe Text
_name = forall a. Maybe a
Nothing
                , _type :: GroupType
_type = GroupType
Solkattu.GPattern
                }
        Solkattu.Note {} ->
            case forall sollu stroke state g.
Pretty sollu =>
ToStrokes sollu stroke
-> [(state, Flat g (Note sollu))]
-> Either
     Text
     (SolluMapKey sollu,
      ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))]))
findSequence ToStrokes sollu stroke
toStrokes ((State
state, Flat Group (Note sollu)
note) forall a. a -> [a] -> [a]
: [(State, Flat Group (Note sollu))]
notes) of
                Left Text
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall err a. err -> UntilFail err a
UF.Fail Text
err, [(State, Flat Group (Note sollu))]
notes)
                Right (SolluMapKey sollu
matched, ([(Tempo, Note stroke)]
strokes, [(State, Flat Group (Note sollu))]
remain)) -> do
                    forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
Writer.tell forall a b. (a -> b) -> a -> b
$ forall a. a -> Set a
Set.singleton SolluMapKey sollu
matched
                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a err. [a] -> UntilFail err a
UF.fromList (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall g a. Tempo -> a -> Flat g a
S.FNote) [(Tempo, Note stroke)]
strokes), [(State, Flat Group (Note sollu))]
remain)
    realize1 (State
state, S.FGroup Tempo
tempo Group
group [Flat Group (Note sollu)]
children) [(State, Flat Group (Note sollu))]
notes =
        (,[(State, Flat Group (Note sollu))]
notes) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tempo
-> Group
-> [(State, Flat Group (Note sollu))]
-> WriterT
     (Set (SolluMapKey sollu))
     m
     (UntilFail Text (Flat Group (Note stroke)))
realizeGroup Tempo
tempo Group
group (forall {a}.
HasMatras a =>
State -> [Flat Group a] -> [(State, Flat Group a)]
flatToState State
state [Flat Group (Note sollu)]
children)
    realizeGroup :: Tempo
-> Group
-> [(State, Flat Group (Note sollu))]
-> WriterT
     (Set (SolluMapKey sollu))
     m
     (UntilFail Text (Flat Group (Note stroke)))
realizeGroup Tempo
tempo
            (Solkattu.GMeta m :: Meta
m@(Solkattu.Meta (Just Int
matras) Maybe Text
_ GroupType
Solkattu.GSarva))
            [(State, Flat Group (Note sollu))]
children
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(State, Flat Group (Note sollu))]
children = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            -- The metadata is already in the group, but ToScore at least
            -- relies on an explicit Abstract since it flattens out groups.
            forall a err. a -> UntilFail err a
UF.singleton forall a b. (a -> b) -> a -> b
$ forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo (Meta -> Group
Solkattu.GMeta Meta
m)
                [forall g a. Tempo -> a -> Flat g a
S.FNote Tempo
tempo (forall stroke. Meta -> Note stroke
Abstract Meta
m)]
        | Bool
otherwise =
            case forall sollu stroke.
Pretty sollu =>
ToStrokes sollu stroke
-> Int
-> Tempo
-> Int
-> [(State, Flat Group (Note sollu))]
-> Either Text (SolluMapKey sollu, [Flat Group (Note stroke)])
realizeSarva ToStrokes sollu stroke
toStrokes Int
talaAksharas Tempo
tempo Int
matras [(State, Flat Group (Note sollu))]
children of
                Left Text
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall err a. err -> UntilFail err a
UF.Fail forall a b. (a -> b) -> a -> b
$ Text
"sarva: " forall a. Semigroup a => a -> a -> a
<> Text
err
                Right (SolluMapKey sollu
matched, [Flat Group (Note stroke)]
strokes) -> do
                    forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
Writer.tell forall a b. (a -> b) -> a -> b
$ forall a. a -> Set a
Set.singleton SolluMapKey sollu
matched
                    -- I keep this as a group so format can highlight it.  Also,
                    -- even though I realized the sarva, I might as well leave
                    -- the duration on.
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a err. a -> UntilFail err a
UF.singleton forall a b. (a -> b) -> a -> b
$
                        forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo (Meta -> Group
Solkattu.GMeta Meta
m) [Flat Group (Note stroke)]
strokes
    realizeGroup Tempo
tempo Group
group [(State, Flat Group (Note sollu))]
children = do
        ([Flat Group (Note stroke)], Maybe Text)
rest <- forall err a. UntilFail err a -> ([a], Maybe err)
UF.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a err b.
Monad m =>
(a -> [a] -> m (UntilFail err b, [a]))
-> [a] -> m (UntilFail err b)
UF.processM (State, Flat Group (Note sollu))
-> [(State, Flat Group (Note sollu))]
-> WriterT
     (Set (SolluMapKey sollu))
     m
     (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
realize1 [(State, Flat Group (Note sollu))]
children
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case ([Flat Group (Note stroke)], Maybe Text)
rest of
            -- I drop the group, so there will be extra notes in the output.
            -- But if I emit a partial group, then convertGroup may get an
            -- error, which will conceal the real one here.
            ([Flat Group (Note stroke)]
children, Just Text
err) -> forall a err. [a] -> err -> UntilFail err a
UF.fromListFail [Flat Group (Note stroke)]
children Text
err
            ([Flat Group (Note stroke)]
children, Maybe Text
Nothing) -> forall a err. a -> UntilFail err a
UF.singleton forall a b. (a -> b) -> a -> b
$ forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo Group
group [Flat Group (Note stroke)]
children

-- | Realize a 'Solkattu.GSarva' group, by matching the sollus, and then
-- cycling the strokes for the given duration.
realizeSarva :: Pretty sollu => ToStrokes sollu stroke -> Tala.Akshara
    -> S.Tempo -> S.Matra
    -> [(S.State, S.Flat Solkattu.Group (Solkattu.Note sollu))]
    -> Either Error (SolluMapKey sollu, [S.Flat Solkattu.Group (Note stroke)])
realizeSarva :: forall sollu stroke.
Pretty sollu =>
ToStrokes sollu stroke
-> Int
-> Tempo
-> Int
-> [(State, Flat Group (Note sollu))]
-> Either Text (SolluMapKey sollu, [Flat Group (Note stroke)])
realizeSarva ToStrokes sollu stroke
_ Int
_ Tempo
_ Int
_ [] = forall a b. a -> Either a b
Left Text
"empty sarva group"
realizeSarva ToStrokes sollu stroke
toStrokes Int
talaAksharas Tempo
tempo Int
matras children :: [(State, Flat Group (Note sollu))]
children@((State
state, Flat Group (Note sollu)
_) : [(State, Flat Group (Note sollu))]
_) = do
    (SolluMapKey sollu
matched, ([(Tempo, Note stroke)]
strokes, [(State, Flat Group (Note sollu))]
left)) <- forall sollu stroke state g.
Pretty sollu =>
ToStrokes sollu stroke
-> [(state, Flat g (Note sollu))]
-> Either
     Text
     (SolluMapKey sollu,
      ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))]))
findSequence ToStrokes sollu stroke
toStrokes [(State, Flat Group (Note sollu))]
children
    -- Trailing rests are ok, as long as I include them in the output.
    [(Tempo, Note stroke)]
rests <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust
        (Text
"incomplete match: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty SolluMapKey sollu
matched
            forall a. Semigroup a => a -> a -> a
<> Text
", left: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall g a. [Flat g a] -> [a]
S.flattenedNotes (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(State, Flat Group (Note sollu))]
left)))
        (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {g} {sollu} {stroke}.
Flat g (Note sollu) -> Maybe (Tempo, Note stroke)
getRest forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(State, Flat Group (Note sollu))]
left)
    let cycleDur :: Duration
cycleDur = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. HasMatras a => Tempo -> a -> Duration
S.noteDuration) [(Tempo, Note stroke)]
strokes)
            forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. HasMatras a => Tempo -> a -> Duration
S.noteDuration) [(Tempo, Note stroke)]
rests)
    -- Sarva should be relative to sam, so shift the cycle by the offset from
    -- sam.  The fmod isn't necessary, but should be more efficient if the
    -- cycle is short because then I don't have to generate and throw away
    -- extra cycles.
    (Duration
_, ([Flat Group (Note stroke)]
_, [Flat Group (Note stroke)]
strokes)) <- forall g stroke.
Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
splitStrokes (Duration
offset forall a. Real a => a -> a -> a
`Num.fmod` Duration
cycleDur) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall g a. Tempo -> a -> Flat g a
S.FNote) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
cycle ([(Tempo, Note stroke)]
strokes forall a. [a] -> [a] -> [a]
++ [(Tempo, Note stroke)]
rests)
    (Duration
_, ([Flat Group (Note stroke)]
strokes, [Flat Group (Note stroke)]
_)) <- forall g stroke.
Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
splitStrokes Duration
dur [Flat Group (Note stroke)]
strokes
    forall (m :: * -> *) a. Monad m => a -> m a
return (SolluMapKey sollu
matched, [Flat Group (Note stroke)]
strokes)
    where
    offset :: Duration
offset = Int -> State -> Duration
S.stateAbsoluteAkshara Int
talaAksharas State
state
    getRest :: Flat g (Note sollu) -> Maybe (Tempo, Note stroke)
getRest (S.FNote Tempo
tempo (Solkattu.Space Space
space)) = forall a. a -> Maybe a
Just (Tempo
tempo, forall stroke. Space -> Note stroke
Space Space
space)
    getRest Flat g (Note sollu)
_ = forall a. Maybe a
Nothing
    dur :: Duration
dur = 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

formatError :: Solkattu.Notation a => UF.UntilFail Error (S.Flat g a)
    -> Either Error [S.Flat g a]
formatError :: forall a g.
Notation a =>
UntilFail Text (Flat g a) -> Either Text [Flat g a]
formatError = forall {g}. ([Flat g a], Maybe Text) -> Either Text [Flat g a]
format forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err a. UntilFail err a -> ([a], Maybe err)
UF.toList
    where
    format :: ([Flat g a], Maybe Text) -> Either Text [Flat g a]
format ([Flat g a]
result, Maybe Text
Nothing) = forall a b. b -> Either a b
Right [Flat g a]
result
    format ([Flat g a]
pre, Just Text
err) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        forall a. Textlike a => a -> a -> a
Texts.unlines2 ([a] -> Text
errorNotation (forall g a. [Flat g a] -> [a]
S.flattenedNotes [Flat g a]
pre)) Text
err
    errorNotation :: [a] -> Text
errorNotation = [Text] -> Text
Text.unwords
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> Text -> Text
justifyLeft Int
2 Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Notation a => a -> Text
Solkattu.notationText)

{- | Given a group like

    > [S.FGroup (Solkatttu.Reduction 1 Before) [a, b], c]

    collect dropped strokes into a Realize.'Reduction':

    > [S.FGroup (Reduction [a] Before) [b], c]
-}
convertGroups :: S.Flat Solkattu.Group (Note stroke)
    -> UF.UntilFail Error (S.Flat (Group (Stroke stroke)) (Note stroke))
convertGroups :: forall stroke.
Flat Group (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
convertGroups (S.FNote Tempo
tempo Note stroke
note) = forall a err. a -> UntilFail err a
UF.singleton forall a b. (a -> b) -> a -> b
$ forall g a. Tempo -> a -> Flat g a
S.FNote Tempo
tempo Note stroke
note
convertGroups (S.FGroup Tempo
tempo Group
g [Flat Group (Note stroke)]
children) =
    case forall err a. UntilFail err a -> ([a], Maybe err)
UF.toList forall a b. (a -> b) -> a -> b
$ forall a err b.
(a -> UntilFail err b) -> UntilFail err a -> UntilFail err b
UF.concatMap forall stroke.
Flat Group (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
convertGroups (forall a err. [a] -> UntilFail err a
UF.fromList [Flat Group (Note stroke)]
children) of
        -- The convertGroup is unlikely to succeed if the children aren't
        -- complete, and even if it did it would probably be confusing.
        -- So flatten this group and append an error.
        ([Flat (Group (Stroke stroke)) (Note stroke)]
children, Just Text
err) -> forall a err. [a] -> err -> UntilFail err a
UF.fromListFail [Flat (Group (Stroke stroke)) (Note stroke)]
children Text
err
        ([Flat (Group (Stroke stroke)) (Note stroke)]
children, Maybe Text
Nothing) -> forall {stroke}.
Tempo
-> Group
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
convertGroup Tempo
tempo Group
g [Flat (Group (Stroke stroke)) (Note stroke)]
children
    where
    convertGroup :: Tempo
-> Group
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
convertGroup Tempo
tempo (Solkattu.GReduction (Solkattu.Reduction FMatra
split Side
side))
            [Flat (Group (Stroke stroke)) (Note stroke)]
children =
        case forall g stroke.
Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
splitStrokes (Tempo -> FMatra -> Duration
S.fmatraDuration Tempo
tempo FMatra
split) [Flat (Group (Stroke stroke)) (Note stroke)]
children of
            Left Text
err -> forall err a. err -> UntilFail err a
UF.Fail Text
err
            Right (Duration
left, ([Flat (Group (Stroke stroke)) (Note stroke)]
pre, [Flat (Group (Stroke stroke)) (Note stroke)]
post))
                | Duration
left forall a. Ord a => a -> a -> Bool
> Duration
0 -> forall err a. err -> UntilFail err a
UF.Fail forall a b. (a -> b) -> a -> b
$ Text
"group split too long, duration left: "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Duration
left
                | Bool
otherwise -> forall a err. a -> UntilFail err a
UF.singleton forall a b. (a -> b) -> a -> b
$ forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo Group (Stroke stroke)
group [Flat (Group (Stroke stroke)) (Note stroke)]
kept
                    where
                    group :: Group (Stroke stroke)
group = forall stroke. Reduction stroke -> Group stroke
GReduction forall a b. (a -> b) -> a -> b
$ Reduction
                        { _dropped :: [Stroke stroke]
_dropped = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. Note a -> Maybe (Stroke a)
noteOf forall a b. (a -> b) -> a -> b
$ forall g a. [Flat g a] -> [a]
S.flattenedNotes [Flat (Group (Stroke stroke)) (Note stroke)]
dropped
                        , _side :: Side
_side = Side
side
                        }
                    ([Flat (Group (Stroke stroke)) (Note stroke)]
kept, [Flat (Group (Stroke stroke)) (Note stroke)]
dropped) = case Side
side of
                        Side
Solkattu.Before -> ([Flat (Group (Stroke stroke)) (Note stroke)]
post, [Flat (Group (Stroke stroke)) (Note stroke)]
pre)
                        Side
Solkattu.After -> ([Flat (Group (Stroke stroke)) (Note stroke)]
pre, [Flat (Group (Stroke stroke)) (Note stroke)]
post)
    convertGroup Tempo
tempo (Solkattu.GMeta Meta
meta) [Flat (Group (Stroke stroke)) (Note stroke)]
children =
        forall a err. a -> UntilFail err a
UF.singleton forall a b. (a -> b) -> a -> b
$ forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo (forall stroke. Meta -> Group stroke
GMeta Meta
meta) [Flat (Group (Stroke stroke)) (Note stroke)]
children

splitStrokes :: S.Duration -> [S.Flat g (Note stroke)]
    -> Either Error
        ( S.Duration
        , ([S.Flat g (Note stroke)], [S.Flat g (Note stroke)])
        )
        -- ^ (unusedDur, (pre, post))
splitStrokes :: forall g stroke.
Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
splitStrokes Duration
dur [] = forall a b. b -> Either a b
Right (Duration
dur, ([], []))
splitStrokes Duration
dur [Flat g (Note stroke)]
notes | Duration
dur forall a. Ord a => a -> a -> Bool
<= Duration
0 = forall a b. b -> Either a b
Right (Duration
dur, ([], [Flat g (Note stroke)]
notes))
splitStrokes Duration
dur (Flat g (Note stroke)
note : [Flat g (Note stroke)]
notes) = case Flat g (Note stroke)
note of
    -- TODO I could check for SarvaGroup here.  It means I have sarva nested
    -- inside a group, which I guess I should shorten.  I'll wait until I'm
    -- more sure about my approach to sarva.
    S.FGroup Tempo
tempo g
g [Flat g (Note stroke)]
children -> case forall g stroke.
Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
splitStrokes Duration
dur [Flat g (Note stroke)]
children of
        Left Text
err -> forall a b. a -> Either a b
Left Text
err
        Right (Duration
left, ([Flat g (Note stroke)]
_pre, [])) -> forall {a} {b} {a} {c}.
(a -> b) -> Either Text (a, (a, c)) -> Either Text (a, (b, c))
add (Flat g (Note stroke)
note:) forall a b. (a -> b) -> a -> b
$ forall g stroke.
Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
splitStrokes Duration
left [Flat g (Note stroke)]
notes
        Right (Duration
left, ([Flat g (Note stroke)]
pre, [Flat g (Note stroke)]
post)) -> forall a b. b -> Either a b
Right
            ( Duration
left
            , ( [forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo g
g [Flat g (Note stroke)]
pre]
              , forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo g
g [Flat g (Note stroke)]
post forall a. a -> [a] -> [a]
: [Flat g (Note stroke)]
notes
              )
            )
    S.FNote Tempo
tempo Note stroke
n
        | Duration
noteDur forall a. Ord a => a -> a -> Bool
<= Duration
dur -> forall {a} {b} {a} {c}.
(a -> b) -> Either Text (a, (a, c)) -> Either Text (a, (b, c))
add (Flat g (Note stroke)
note:) forall a b. (a -> b) -> a -> b
$ forall g stroke.
Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
splitStrokes (Duration
dur forall a. Num a => a -> a -> a
- Duration
noteDur) [Flat g (Note stroke)]
notes
        | Bool
otherwise -> case Note stroke
n of
            Note Stroke stroke
_ -> forall a b. a -> Either a b
Left Text
"can't split a stroke"
            Abstract Meta
a -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"can't split Abstract " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Meta
a
            Alignment Int
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"not reached: alignment should have 0 dur"
            Space Space
space -> do
                let make :: Duration -> Either Text [Flat g (Note stroke)]
make = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall g a. Tempo -> a -> Flat g a
S.FNote)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stroke.
Tempo -> Space -> Duration -> Either Text [(Tempo, Note stroke)]
makeSpace Tempo
tempo Space
space
                [Flat g (Note stroke)]
pre <- forall {g} {stroke}. Duration -> Either Text [Flat g (Note stroke)]
make Duration
dur
                [Flat g (Note stroke)]
post <- forall {g} {stroke}. Duration -> Either Text [Flat g (Note stroke)]
make (Duration
dur forall a. Num a => a -> a -> a
- Duration
noteDur)
                forall (m :: * -> *) a. Monad m => a -> m a
return (Duration
0, ([Flat g (Note stroke)]
pre, [Flat g (Note stroke)]
post forall a. [a] -> [a] -> [a]
++ [Flat g (Note stroke)]
notes))
        where
        noteDur :: Duration
noteDur = forall a. HasMatras a => Tempo -> a -> Duration
S.noteDuration Tempo
tempo Note stroke
n
    where
    add :: (a -> b) -> Either Text (a, (a, c)) -> Either Text (a, (b, c))
add = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first

-- | Try to produce Spaces of the given Duration.  Based on Notation.spaceD.
makeSpace :: S.Tempo -> Solkattu.Space -> S.Duration
    -> Either Error [(S.Tempo, Note stroke)]
makeSpace :: forall stroke.
Tempo -> Space -> Duration -> Either Text [(Tempo, Note stroke)]
makeSpace Tempo
tempo Space
space Duration
dur = forall a b. (a -> b) -> [a] -> [b]
map forall {stroke}. Int -> (Tempo, Note stroke)
make forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Duration -> Either Text [Int]
S.decompose Duration
s0_matras
    where
    make :: Int -> (Tempo, Note stroke)
make Int
speed = (Tempo
tempo { _speed :: Int
S._speed = Int
speed }, forall stroke. Space -> Note stroke
Space Space
space)
    s0_matras :: Duration
s0_matras = Duration
dur forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (Tempo -> Int
S._nadai Tempo
tempo)

-- | Find the longest matching sequence and return the match and unconsumed
-- notes.
findSequence :: Pretty sollu => ToStrokes sollu stroke
    -> [(state, S.Flat g (Solkattu.Note sollu))]
    -> Either Error
        ( SolluMapKey sollu
        , ( [(S.Tempo, Note stroke)]
          , [(state, S.Flat g (Solkattu.Note sollu))]
          )
        )
        -- ^ (matched, (strokes, remaining))
findSequence :: forall sollu stroke state g.
Pretty sollu =>
ToStrokes sollu stroke
-> [(state, Flat g (Note sollu))]
-> Either
     Text
     (SolluMapKey sollu,
      ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))]))
findSequence ToStrokes sollu stroke
toStrokes [(state, Flat g (Note sollu))]
notes =
    case forall sollu stroke.
Maybe Tag
-> [sollu]
-> ToStrokes sollu stroke
-> Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
bestMatch Maybe Tag
tag [sollu]
sollus ToStrokes sollu stroke
toStrokes of
        Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"sequence not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [sollu]
sollus
        Just (SolluMapKey sollu
matched, [Maybe (Stroke stroke)]
strokes) ->
            forall a b. b -> Either a b
Right (SolluMapKey sollu
matched, forall stroke state g sollu.
[Maybe (Stroke stroke)]
-> [(state, Flat g (Note sollu))]
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
replaceSollus [Maybe (Stroke stroke)]
strokes [(state, Flat g (Note sollu))]
notes)
    where
    -- Collect only sollus and rests.  This stops at a group boundary.
    pre :: [(Tempo, Maybe (NoteT sollu))]
pre = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Lists.spanWhile (forall {g} {sollu}.
Flat g (Note sollu) -> Maybe (Tempo, Maybe (NoteT sollu))
noteOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(state, Flat g (Note sollu))]
notes
    sollus :: [sollu]
sollus = forall a b. (a -> b) -> [a] -> [b]
map forall sollu. NoteT sollu -> sollu
Solkattu._sollu forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> b
snd [(Tempo, Maybe (NoteT sollu))]
pre
    noteOf :: Flat g (Note sollu) -> Maybe (Tempo, Maybe (NoteT sollu))
noteOf (S.FNote Tempo
tempo Note sollu
n) = (Tempo
tempo,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Note sollu
n of
        Solkattu.Note NoteT sollu
n -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just NoteT sollu
n
        Solkattu.Space {} -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
        Solkattu.Alignment {} -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
        Solkattu.Pattern {} -> forall a. Maybe a
Nothing
    noteOf (S.FGroup {}) = forall a. Maybe a
Nothing
    tag :: Maybe Tag
tag = forall sollu. NoteT sollu -> Maybe Tag
Solkattu._tag forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. [a] -> Maybe a
Lists.head (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> b
snd [(Tempo, Maybe (NoteT sollu))]
pre)

-- | Match each stroke to a Sollu, copying over Rests without consuming
-- a stroke.
replaceSollus :: [Maybe (Stroke stroke)] -- ^ Nothing means a rest
    -> [(state, S.Flat g (Solkattu.Note sollu))]
    -> ([(S.Tempo, Note stroke)], [(state, S.Flat g (Solkattu.Note sollu))])
replaceSollus :: forall stroke state g sollu.
[Maybe (Stroke stroke)]
-> [(state, Flat g (Note sollu))]
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
replaceSollus [] [(state, Flat g (Note sollu))]
ns = ([], [(state, Flat g (Note sollu))]
ns)
    -- I should be out of strokes before I get here, so this shouldn't happen.
    -- I could pass [(S.Tempo, Solkattu.Note sollu)], but then I have to
    -- recreate a S.FGroup for everything in the tail, which is potentially
    -- quadratic.
replaceSollus (Maybe (Stroke stroke)
_ : [Maybe (Stroke stroke)]
_) ns :: [(state, Flat g (Note sollu))]
ns@((state
_, S.FGroup {}) : [(state, Flat g (Note sollu))]
_) = ([], [(state, Flat g (Note sollu))]
ns)
replaceSollus (Maybe (Stroke stroke)
stroke : [Maybe (Stroke stroke)]
strokes) ((state
_, S.FNote Tempo
tempo Note sollu
n) : [(state, Flat g (Note sollu))]
ns) = case Note sollu
n of
    Solkattu.Note NoteT sollu
_ -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Tempo
tempo, Note stroke
rnote) :) forall a b. (a -> b) -> a -> b
$ forall stroke state g sollu.
[Maybe (Stroke stroke)]
-> [(state, Flat g (Note sollu))]
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
replaceSollus [Maybe (Stroke stroke)]
strokes [(state, Flat g (Note sollu))]
ns
        where rnote :: Note stroke
rnote = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall stroke. Space -> Note stroke
Space Space
Solkattu.Rest) forall stroke. Stroke stroke -> Note stroke
Note Maybe (Stroke stroke)
stroke
    Solkattu.Space Space
space -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Tempo
tempo, forall stroke. Space -> Note stroke
Space Space
space) :) ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
next
    Solkattu.Alignment Int
a -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Tempo
tempo, forall stroke. Int -> Note stroke
Alignment Int
a) :) ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
next
    -- This shouldn't happen because Lists.spanWhile noteOf should have
    -- stopped when it saw this.
    Solkattu.Pattern {} -> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
next
    where
    -- Continue without consuming this stroke.
    next :: ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
next = forall stroke state g sollu.
[Maybe (Stroke stroke)]
-> [(state, Flat g (Note sollu))]
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
replaceSollus (Maybe (Stroke stroke)
stroke forall a. a -> [a] -> [a]
: [Maybe (Stroke stroke)]
strokes) [(state, Flat g (Note sollu))]
ns
replaceSollus (Maybe (Stroke stroke)
_:[Maybe (Stroke stroke)]
_) [] = ([], [])
    -- This shouldn't happen because strokes from the SolluMap should be
    -- the same length as the RealizedNotes used to find them.

-- ** ToStrokes

-- | Find strokes for a sequence of sollus.
data ToStrokes sollu stroke = ToStrokes {
    -- | The longest [sollu] key in the whole SolluMap, so I know when to give
    -- up looking for the longest prefix.
    forall sollu stroke. ToStrokes sollu stroke -> Int
_longestKey :: !Int
    , forall sollu stroke.
ToStrokes sollu stroke
-> Maybe Tag -> [sollu] -> Maybe [Maybe (Stroke stroke)]
_getStrokes :: Maybe Solkattu.Tag -> [sollu]
        -> Maybe [Maybe (Stroke stroke)]
    }

-- | If the sollu and stroke are the same, I can just copy the sollu.  This is
-- for "monomorphic" single instrument scores, such as for mridangam.
realizeStroke :: ToStrokes (Stroke stroke) stroke
realizeStroke :: forall stroke. ToStrokes (Stroke stroke) stroke
realizeStroke = ToStrokes
    -- realizeSarva wants a match that uses all the sollus, so convert as many
    -- as given, assuming sarva sollus don't get longer than this.
    -- TODO this is pretty ugly, isn't there a better way?
    { _longestKey :: Int
_longestKey = Int
100
    , _getStrokes :: Maybe Tag -> [Stroke stroke] -> Maybe [Maybe (Stroke stroke)]
_getStrokes = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
    }

-- | Convert Sollus to strokes.  The input Sollus have an extra Stroke wrapper.
-- The Stroke is extraneous and is ignored, it's just for uniformity with
-- 'realizeStroke', since 'Korvai.KorvaiSections' no longer has a separate
-- case for Sollu which allowed it to omit the Realize.Stroke.
realizeSollu :: Ord sollu => SolluMap sollu stroke
    -> ToStrokes (Stroke sollu) stroke
realizeSollu :: forall sollu stroke.
Ord sollu =>
SolluMap sollu stroke -> ToStrokes (Stroke sollu) stroke
realizeSollu (SolluMap Map (Maybe Tag, [sollu]) [Maybe (Stroke stroke)]
smap) = ToStrokes
    { _longestKey :: Int
_longestKey =
        forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Maybe a
Lists.maximum (forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall k a. Map k a -> [k]
Map.keys Map (Maybe Tag, [sollu]) [Maybe (Stroke stroke)]
smap))
    , _getStrokes :: Maybe Tag -> [Stroke sollu] -> Maybe [Maybe (Stroke stroke)]
_getStrokes = \Maybe Tag
tag [Stroke sollu]
sollus -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Maybe Tag
tag, forall a b. (a -> b) -> [a] -> [b]
map forall stroke. Stroke stroke -> stroke
_stroke [Stroke sollu]
sollus) Map (Maybe Tag, [sollu]) [Maybe (Stroke stroke)]
smap
    }

-- | Convert sollus to strokes.
bestMatch :: Maybe Solkattu.Tag -> [sollu] -> ToStrokes sollu stroke
    -> Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
    -- ^ Nothing means no match, [Nothing] is a rest
bestMatch :: forall sollu stroke.
Maybe Tag
-> [sollu]
-> ToStrokes sollu stroke
-> Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
bestMatch Maybe Tag
tag [sollu]
sollus ToStrokes sollu stroke
toStrokes =
    -- Try with the specific tag, otherwise fall back to no tag.
    forall a. [a] -> Maybe a
Lists.head (Maybe Tag
-> [[sollu]] -> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
find Maybe Tag
tag [[sollu]]
prefixes) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. [a] -> Maybe a
Lists.head (Maybe Tag
-> [[sollu]] -> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
find forall a. Maybe a
Nothing [[sollu]]
prefixes)
    where
    find :: Maybe Tag
-> [[sollu]] -> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
find Maybe Tag
tag = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\[sollu]
s -> ((Maybe Tag
tag, [sollu]
s),) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall sollu stroke.
ToStrokes sollu stroke
-> Maybe Tag -> [sollu] -> Maybe [Maybe (Stroke stroke)]
_getStrokes ToStrokes sollu stroke
toStrokes Maybe Tag
tag [sollu]
s)
    prefixes :: [[sollu]]
prefixes = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
List.inits forall a b. (a -> b) -> a -> b
$
        forall a. Int -> [a] -> [a]
take (forall sollu stroke. ToStrokes sollu stroke -> Int
_longestKey ToStrokes sollu stroke
toStrokes) [sollu]
sollus


-- * text util

justifyLeft :: Int -> Char -> Text -> Text
justifyLeft :: Int -> Char -> Text -> Text
justifyLeft Int
n Char
c Text
text
    | Int
len forall a. Ord a => a -> a -> Bool
>= Int
n = Text
text
    | Bool
otherwise = Text
text forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate (Int
n forall a. Num a => a -> a -> a
- Int
len) (Char -> Text
Text.singleton Char
c)
    where len :: Int
len = Text -> Int
textLength Text
text

textLength :: Text -> Int
textLength :: Text -> Int
textLength = 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 forall {a}. Num a => Char -> a
len forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
untxt
    where
    -- Combining characters don't contribute to the width.  I'm sure it's way
    -- more complicated than this, but for the moment this seems to work.
    len :: Char -> a
len Char
c
        | Char -> Bool
Char.isMark Char
c = a
0
        | Bool
otherwise = a
1