-- 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.Writer as Writer
import qualified Control.Monad.Writer.CPS as Writer.CPS

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.Logger as Logger
import qualified Util.Maps as Maps
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Seq as Seq
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
(Note stroke -> Note stroke -> Bool)
-> (Note stroke -> Note stroke -> Bool) -> Eq (Note stroke)
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
[Note stroke] -> ShowS
Note stroke -> String
(Int -> Note stroke -> ShowS)
-> (Note stroke -> String)
-> ([Note stroke] -> ShowS)
-> Show (Note stroke)
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 -> b) -> Note a -> Note b)
-> (forall a b. a -> Note b -> Note a) -> Functor Note
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 m. Monoid m => Note m -> m)
-> (forall m a. Monoid m => (a -> m) -> Note a -> m)
-> (forall m a. Monoid m => (a -> m) -> Note a -> m)
-> (forall a b. (a -> b -> b) -> b -> Note a -> b)
-> (forall a b. (a -> b -> b) -> b -> Note a -> b)
-> (forall b a. (b -> a -> b) -> b -> Note a -> b)
-> (forall b a. (b -> a -> b) -> b -> Note a -> b)
-> (forall a. (a -> a -> a) -> Note a -> a)
-> (forall a. (a -> a -> a) -> Note a -> a)
-> (forall a. Note a -> [a])
-> (forall a. Note a -> Bool)
-> (forall a. Note a -> Int)
-> (forall a. Eq a => a -> Note a -> Bool)
-> (forall a. Ord a => Note a -> a)
-> (forall a. Ord a => Note a -> a)
-> (forall a. Num a => Note a -> a)
-> (forall a. Num a => Note a -> a)
-> Foldable Note
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
Functor Note
-> Foldable Note
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Note a -> f (Note b))
-> (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 (m :: * -> *) a. Monad m => Note (m a) -> m (Note a))
-> Traversable 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 -> Stroke b -> Note b
forall stroke. Stroke stroke -> Note stroke
Note (Stroke b -> Note b) -> f (Stroke b) -> f (Note b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stroke a -> f (Stroke b)
f Stroke a
stroke
    Space Space
space -> Note b -> f (Note b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note b -> f (Note b)) -> Note b -> f (Note b)
forall a b. (a -> b) -> a -> b
$ Space -> Note b
forall stroke. Space -> Note stroke
Space Space
space
    Abstract Meta
a -> Note b -> f (Note b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note b -> f (Note b)) -> Note b -> f (Note b)
forall a b. (a -> b) -> a -> b
$ Meta -> Note b
forall stroke. Meta -> Note stroke
Abstract Meta
a
    Alignment Int
a -> Note b -> f (Note b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note b -> f (Note b)) -> Note b -> f (Note b)
forall a b. (a -> b) -> a -> b
$ Int -> Note 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
(Stroke stroke -> Stroke stroke -> Bool)
-> (Stroke stroke -> Stroke stroke -> Bool) -> Eq (Stroke stroke)
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, Eq (Stroke stroke)
Eq (Stroke stroke)
-> (Stroke stroke -> Stroke stroke -> Ordering)
-> (Stroke stroke -> Stroke stroke -> Bool)
-> (Stroke stroke -> Stroke stroke -> Bool)
-> (Stroke stroke -> Stroke stroke -> Bool)
-> (Stroke stroke -> Stroke stroke -> Bool)
-> (Stroke stroke -> Stroke stroke -> Stroke stroke)
-> (Stroke stroke -> Stroke stroke -> Stroke stroke)
-> Ord (Stroke stroke)
Stroke stroke -> Stroke stroke -> Bool
Stroke stroke -> Stroke stroke -> Ordering
Stroke stroke -> Stroke stroke -> Stroke stroke
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
[Stroke stroke] -> ShowS
Stroke stroke -> String
(Int -> Stroke stroke -> ShowS)
-> (Stroke stroke -> String)
-> ([Stroke stroke] -> ShowS)
-> Show (Stroke stroke)
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 -> b) -> Stroke a -> Stroke b)
-> (forall a b. a -> Stroke b -> Stroke a) -> Functor Stroke
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 m. Monoid m => Stroke m -> m)
-> (forall m a. Monoid m => (a -> m) -> Stroke a -> m)
-> (forall m a. Monoid m => (a -> m) -> Stroke a -> m)
-> (forall a b. (a -> b -> b) -> b -> Stroke a -> b)
-> (forall a b. (a -> b -> b) -> b -> Stroke a -> b)
-> (forall b a. (b -> a -> b) -> b -> Stroke a -> b)
-> (forall b a. (b -> a -> b) -> b -> Stroke a -> b)
-> (forall a. (a -> a -> a) -> Stroke a -> a)
-> (forall a. (a -> a -> a) -> Stroke a -> a)
-> (forall a. Stroke a -> [a])
-> (forall a. Stroke a -> Bool)
-> (forall a. Stroke a -> Int)
-> (forall a. Eq a => a -> Stroke a -> Bool)
-> (forall a. Ord a => Stroke a -> a)
-> (forall a. Ord a => Stroke a -> a)
-> (forall a. Num a => Stroke a -> a)
-> (forall a. Num a => Stroke a -> a)
-> Foldable Stroke
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
Functor Stroke
-> Foldable Stroke
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Stroke a -> f (Stroke b))
-> (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 (m :: * -> *) a.
    Monad m =>
    Stroke (m a) -> m (Stroke a))
-> Traversable 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 -> a -> Expr MiniVal
forall a. ToExpr a => a -> Expr MiniVal
Expr.to_expr a
stroke
    Emphasis
Light -> Symbol -> a -> Expr MiniVal
forall a. ToExpr a => Symbol -> a -> Expr MiniVal
Expr.with Symbol
Symbols.weak a
stroke
    Emphasis
Heavy -> Symbol -> a -> Expr MiniVal
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 Style -> 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) = stroke -> (Style, Text)
forall a. Notation a => a -> (Style, Text)
Solkattu.notation stroke
stroke
        style :: Style
style = case Emphasis
emphasis of
            Emphasis
Light -> Style
forall a. Monoid a => a
mempty { _foreground :: Maybe Color
Styled._foreground = Color -> Maybe Color
forall a. a -> Maybe a
Just (Float -> Color
Styled.rgbGray Float
0.5) }
            Emphasis
Normal -> Style
forall a. Monoid a => a
mempty
            Emphasis
Heavy -> Style
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) = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> stroke -> Text
forall a. Pretty a => a -> Text
pretty stroke
stroke) (Text -> Text) -> Text -> Text
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) = Stroke a -> Maybe (Stroke a)
forall a. a -> Maybe a
Just Stroke a
stroke
noteOf Note a
_ = Maybe (Stroke a)
forall a. Maybe a
Nothing

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

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

rest :: SNote stroke
rest :: forall stroke. SNote stroke
rest = Note stroke -> Note () (Note stroke)
forall g a. a -> Note g a
S.Note (Space -> Note stroke
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 = Note g (Note (Stroke stroke)) -> Sequence g (Note (Stroke stroke))
forall g a. Note g a -> Sequence g a
S.singleton (Note g (Note (Stroke stroke))
 -> Sequence g (Note (Stroke stroke)))
-> (stroke -> Note g (Note (Stroke stroke)))
-> stroke
-> Sequence g (Note (Stroke stroke))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note (Stroke stroke) -> Note g (Note (Stroke stroke))
forall g a. a -> Note g a
S.Note (Note (Stroke stroke) -> Note g (Note (Stroke stroke)))
-> (stroke -> Note (Stroke stroke))
-> stroke
-> Note g (Note (Stroke stroke))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteT (Stroke stroke) -> Note (Stroke stroke)
forall sollu. NoteT sollu -> Note sollu
Solkattu.Note (NoteT (Stroke stroke) -> Note (Stroke stroke))
-> (stroke -> NoteT (Stroke stroke))
-> stroke
-> Note (Stroke stroke)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stroke stroke -> NoteT (Stroke stroke)
forall sollu. sollu -> NoteT sollu
Solkattu.note (Stroke stroke -> NoteT (Stroke stroke))
-> (stroke -> Stroke stroke) -> stroke -> NoteT (Stroke stroke)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. stroke -> Stroke stroke
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
(Emphasis -> Emphasis -> Bool)
-> (Emphasis -> Emphasis -> Bool) -> Eq Emphasis
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
Eq Emphasis
-> (Emphasis -> Emphasis -> Ordering)
-> (Emphasis -> Emphasis -> Bool)
-> (Emphasis -> Emphasis -> Bool)
-> (Emphasis -> Emphasis -> Bool)
-> (Emphasis -> Emphasis -> Bool)
-> (Emphasis -> Emphasis -> Emphasis)
-> (Emphasis -> Emphasis -> Emphasis)
-> Ord 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
(Int -> Emphasis -> ShowS)
-> (Emphasis -> String) -> ([Emphasis] -> ShowS) -> Show Emphasis
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
(<>) = 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 = Emphasis -> Emphasis -> Emphasis
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 -> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 (Maybe Int -> Int) -> Maybe Int -> Int
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 -> Stroke stroke -> (Style, Text)
forall a. Notation a => a -> (Style, Text)
Solkattu.notation Stroke stroke
s
        Abstract Meta
meta -> Text -> (Style, Text)
Solkattu.textNotation (Text -> (Style, Text)) -> Text -> (Style, Text)
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
_ -> Text -> (Int -> Text) -> Maybe Int -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Int -> Text
forall a. Show a => a -> Text
showt Maybe Int
matras Text -> Text -> Text
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 -> Stroke stroke -> Text
forall a. Pretty a => a -> Text
pretty Stroke stroke
s
        Abstract Meta
a -> Meta -> Text
forall a. Pretty a => a -> Text
pretty Meta
a
        Alignment Int
n -> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
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
(Int -> Warning -> ShowS)
-> (Warning -> String) -> ([Warning] -> ShowS) -> Show Warning
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
(Warning -> Warning -> Bool)
-> (Warning -> Warning -> Bool) -> Eq Warning
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.Tala -> S.Duration -> S.Duration
    -> [(S.Tempo, Note stroke)] -> Maybe Warning
checkAlignment :: forall stroke.
Tala
-> Duration -> Duration -> [(Tempo, Note stroke)] -> Maybe Warning
checkAlignment Tala
tala Duration
startOn Duration
endOn [(Tempo, Note stroke)]
notes
    | Tala
tala Tala -> Tala -> Bool
forall a. Eq a => a -> a -> Bool
== Tala
Tala.any_beats = Maybe Warning
forall a. Maybe a
Nothing
    | Bool
otherwise = [Maybe Warning] -> Maybe Warning
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (((Int, (State, Note stroke)) -> Maybe Warning)
-> [(Int, (State, Note stroke))] -> [Maybe Warning]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (State, Note stroke)) -> Maybe Warning
forall {stroke}. (Int, (State, Note stroke)) -> Maybe Warning
verify ([Int] -> [(State, Note stroke)] -> [(Int, (State, Note stroke))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(State, Note stroke)]
states)) Maybe Warning -> Maybe Warning -> Maybe Warning
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Warning
checkEnd
    where
    (State
finalState, [(State, Note stroke)]
states) = Tala
-> Duration
-> [(Tempo, Note stroke)]
-> (State, [(State, Note stroke)])
forall a.
HasMatras a =>
Tala -> Duration -> [(Tempo, a)] -> (State, [(State, a)])
S.tempoToState Tala
tala 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
|| Bool -> (State -> Bool) -> Maybe State -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False State -> Bool
atEnd Maybe State
finalNote = Maybe Warning
forall a. Maybe a
Nothing
        | Bool
otherwise = Warning -> Maybe Warning
forall a. a -> Maybe a
Just (Warning -> Maybe Warning) -> Warning -> Maybe Warning
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Text -> Warning
Warning Maybe Int
forall a. Maybe a
Nothing (Text -> Warning) -> Text -> Warning
forall a b. (a -> b) -> a -> b
$
            Text
"should end on sam" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
endMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", actually ends on "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> State -> Text
S.showPosition State
finalState Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", or sam - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Duration -> Text
forall a. Pretty a => a -> Text
pretty Duration
left
        where
        endMsg :: Text
endMsg
            | Duration
endOn Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
== Duration
0 = Text
""
            | Duration
endOn Duration -> Duration -> Bool
forall a. Ord a => a -> a -> Bool
> Duration
0 = Text
"+" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Duration -> Text
forall a. Pretty a => a -> Text
pretty Duration
endOn
            | Bool
otherwise = Duration -> Text
forall a. Pretty a => a -> Text
pretty Duration
endOn
        finalNote :: Maybe State
finalNote = (State, Note stroke) -> State
forall a b. (a, b) -> a
fst ((State, Note stroke) -> State)
-> Maybe (State, Note stroke) -> Maybe State
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((State, Note stroke) -> Bool)
-> [(State, Note stroke)] -> Maybe (State, Note stroke)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Bool -> Bool
not (Bool -> Bool)
-> ((State, Note stroke) -> Bool) -> (State, Note stroke) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note stroke -> Bool
forall a. Note a -> Bool
isSpace (Note stroke -> Bool)
-> ((State, Note stroke) -> Note stroke)
-> (State, Note stroke)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State, Note stroke) -> Note stroke
forall a b. (a, b) -> b
snd) ([(State, Note stroke)] -> [(State, Note stroke)]
forall a. [a] -> [a]
reverse [(State, Note stroke)]
states)
        left :: Duration
left = Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Tala -> Int
Tala.tala_aksharas Tala
tala)
            Duration -> Duration -> Duration
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 = Maybe Warning
forall a. Maybe a
Nothing
        | Bool
otherwise = Warning -> Maybe Warning
forall a. a -> Maybe a
Just (Warning -> Maybe Warning) -> Warning -> Maybe Warning
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Text -> Warning
Warning (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i) (Text -> Warning) -> Text -> Warning
forall a b. (a -> b) -> a -> b
$
            Text
"expected akshara " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
akshara Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but at "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> State -> Text
S.showPosition State
state
    verify (Int, (State, Note stroke))
_ = Maybe Warning
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 Duration -> Duration -> Bool
forall a. Ord a => a -> a -> Bool
>= Duration
0 = Duration
akshara Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
== Duration
endOn
        | Bool
otherwise = Duration
akshara Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
- Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Tala -> Int
Tala.tala_aksharas Tala
tala) Duration -> Duration -> Bool
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
akshara Bool -> Bool -> Bool
&& State -> Duration
S.stateMatra State
state Duration -> Duration -> Bool
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 = ((Int, [Realized stroke]) -> [Realized stroke])
-> ([Warning] -> [Warning])
-> ((Int, [Realized stroke]), [Warning])
-> ([Realized stroke], [Warning])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Int, [Realized stroke]) -> [Realized stroke]
forall a b. (a, b) -> b
snd [Warning] -> [Warning]
forall a. [a] -> [a]
List.reverse (((Int, [Realized stroke]), [Warning])
 -> ([Realized stroke], [Warning]))
-> ([Realized stroke] -> ((Int, [Realized stroke]), [Warning]))
-> [Realized stroke]
-> ([Realized stroke], [Warning])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger Warning (Int, [Realized stroke])
-> ((Int, [Realized stroke]), [Warning])
forall w a. Logger w a -> (a, [w])
Logger.runId (Logger Warning (Int, [Realized stroke])
 -> ((Int, [Realized stroke]), [Warning]))
-> ([Realized stroke] -> Logger Warning (Int, [Realized stroke]))
-> [Realized stroke]
-> ((Int, [Realized stroke]), [Warning])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Realized stroke] -> Logger Warning (Int, [Realized stroke])
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 [] = (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
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 {} -> ([Flat (Group (Stroke stroke)) (Note stroke)]
 -> [Flat (Group (Stroke stroke)) (Note stroke)])
-> (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
-> (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Flat (Group (Stroke stroke)) (Note stroke)
n:) ((Int, [Flat (Group (Stroke stroke)) (Note stroke)])
 -> (Int, [Flat (Group (Stroke stroke)) (Note stroke)]))
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
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
iInt -> Int -> Int
forall 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 = [Flat (Group (Stroke stroke)) (Note stroke)] -> Duration
forall stroke. [Realized stroke] -> Duration
flatDuration [Flat (Group (Stroke stroke)) (Note stroke)]
children
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Duration
actual Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
== Duration
dur) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Warning -> m ()
forall w (m :: * -> *). MonadLogger w m => w -> m ()
Logger.log (Warning -> m ()) -> Warning -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Text -> Warning
Warning (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i) (Text -> Warning) -> Text -> Warning
forall a b. (a -> b) -> a -> b
$
                Text
"expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Duration -> Text
forall a. Pretty a => a -> Text
pretty Duration
dur Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" aksharas, but was "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Duration -> Text
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
            ([Flat (Group (Stroke stroke)) (Note stroke)]
 -> [Flat (Group (Stroke stroke)) (Note stroke)])
-> (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
-> (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([Flat (Group (Stroke stroke)) (Note stroke)]
children++) ((Int, [Flat (Group (Stroke stroke)) (Note stroke)])
 -> (Int, [Flat (Group (Stroke stroke)) (Note stroke)]))
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
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
            ([Flat (Group (Stroke stroke)) (Note stroke)]
 -> [Flat (Group (Stroke stroke)) (Note stroke)])
-> (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
-> (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Tempo
-> Group (Stroke stroke)
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> Flat (Group (Stroke stroke)) (Note stroke)
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 :) ((Int, [Flat (Group (Stroke stroke)) (Note stroke)])
 -> (Int, [Flat (Group (Stroke stroke)) (Note stroke)]))
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
-> m (Int, [Flat (Group (Stroke stroke)) (Note stroke)])
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 = [Duration] -> Duration
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum ([Duration] -> Duration)
-> ([Realized stroke] -> [Duration])
-> [Realized stroke]
-> Duration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Tempo, Note stroke) -> Duration)
-> [(Tempo, Note stroke)] -> [Duration]
forall a b. (a -> b) -> [a] -> [b]
map ((Tempo -> Note stroke -> Duration)
-> (Tempo, Note stroke) -> Duration
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Tempo -> Note stroke -> Duration
forall a. HasMatras a => Tempo -> a -> Duration
S.noteDuration) ([(Tempo, Note stroke)] -> [Duration])
-> ([Realized stroke] -> [(Tempo, Note stroke)])
-> [Realized stroke]
-> [Duration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Realized stroke] -> [(Tempo, Note stroke)]
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 stroke = StrokeMap {
    forall stroke. StrokeMap stroke -> SolluMap stroke
smapSolluMap :: SolluMap stroke
    -- | Shadowed SolluMapKeys, saved here to warn about them later.
    , forall stroke.
StrokeMap stroke -> [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
smapSolluShadows ::
        [(SolluMapKey Solkattu.Sollu, [Maybe (Stroke stroke)])]
    , forall stroke. StrokeMap stroke -> PatternMap stroke
smapPatternMap :: PatternMap stroke
    } deriving (StrokeMap stroke -> StrokeMap stroke -> Bool
(StrokeMap stroke -> StrokeMap stroke -> Bool)
-> (StrokeMap stroke -> StrokeMap stroke -> Bool)
-> Eq (StrokeMap stroke)
forall stroke.
Eq stroke =>
StrokeMap stroke -> StrokeMap stroke -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StrokeMap stroke -> StrokeMap stroke -> Bool
$c/= :: forall stroke.
Eq stroke =>
StrokeMap stroke -> StrokeMap stroke -> Bool
== :: StrokeMap stroke -> StrokeMap stroke -> Bool
$c== :: forall stroke.
Eq stroke =>
StrokeMap stroke -> StrokeMap stroke -> Bool
Eq, Int -> StrokeMap stroke -> ShowS
[StrokeMap stroke] -> ShowS
StrokeMap stroke -> String
(Int -> StrokeMap stroke -> ShowS)
-> (StrokeMap stroke -> String)
-> ([StrokeMap stroke] -> ShowS)
-> Show (StrokeMap stroke)
forall stroke. Show stroke => Int -> StrokeMap stroke -> ShowS
forall stroke. Show stroke => [StrokeMap stroke] -> ShowS
forall stroke. Show stroke => StrokeMap stroke -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StrokeMap stroke] -> ShowS
$cshowList :: forall stroke. Show stroke => [StrokeMap stroke] -> ShowS
show :: StrokeMap stroke -> String
$cshow :: forall stroke. Show stroke => StrokeMap stroke -> String
showsPrec :: Int -> StrokeMap stroke -> ShowS
$cshowsPrec :: forall stroke. Show stroke => Int -> StrokeMap stroke -> ShowS
Show, (forall x. StrokeMap stroke -> Rep (StrokeMap stroke) x)
-> (forall x. Rep (StrokeMap stroke) x -> StrokeMap stroke)
-> Generic (StrokeMap stroke)
forall x. Rep (StrokeMap stroke) x -> StrokeMap stroke
forall x. StrokeMap stroke -> Rep (StrokeMap stroke) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall stroke x. Rep (StrokeMap stroke) x -> StrokeMap stroke
forall stroke x. StrokeMap stroke -> Rep (StrokeMap stroke) x
$cto :: forall stroke x. Rep (StrokeMap stroke) x -> StrokeMap stroke
$cfrom :: forall stroke x. StrokeMap stroke -> Rep (StrokeMap stroke) x
Generics.Generic)

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

smapKeys :: StrokeMap stroke -> Set (SolluMapKey Solkattu.Sollu)
smapKeys :: forall stroke. StrokeMap stroke -> Set (SolluMapKey Sollu)
smapKeys StrokeMap stroke
smap = Map (SolluMapKey Sollu) [Maybe (Stroke stroke)]
-> Set (SolluMapKey Sollu)
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 = StrokeMap stroke -> SolluMap stroke
forall stroke. StrokeMap stroke -> SolluMap stroke
smapSolluMap StrokeMap stroke
smap

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

instance Pretty stroke => Pretty (StrokeMap stroke) where
    format :: StrokeMap stroke -> Doc
format = StrokeMap stroke -> Doc
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 stroke => PatternMap stroke
    -> [ ( S.Sequence g (Solkattu.Note Solkattu.Sollu)
         , S.Sequence g (Solkattu.Note (Stroke stroke))
         )
       ]
    -> Either Error (StrokeMap stroke)
strokeMap :: forall stroke g.
Pretty stroke =>
PatternMap stroke
-> [(Sequence g (Note Sollu), Sequence g (Note (Stroke stroke)))]
-> Either Text (StrokeMap stroke)
strokeMap PatternMap stroke
pmap [(Sequence g (Note Sollu), Sequence g (Note (Stroke stroke)))]
strokes = do
    [(Sequence g (Note Sollu), [Note () (Note stroke)])]
strokes <- ((Sequence g (Note Sollu), Sequence g (Note (Stroke stroke)))
 -> Either Text (Sequence g (Note Sollu), [Note () (Note stroke)]))
-> [(Sequence g (Note Sollu), Sequence g (Note (Stroke stroke)))]
-> Either Text [(Sequence g (Note Sollu), [Note () (Note stroke)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Sequence g (Note (Stroke stroke))
 -> Either Text [Note () (Note stroke)])
-> (Sequence g (Note Sollu), Sequence g (Note (Stroke stroke)))
-> Either Text (Sequence g (Note Sollu), [Note () (Note stroke)])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Sequence g (Note (Stroke stroke))
-> Either Text [Note () (Note stroke)]
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 stroke
smap, [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
solluShadows) <- [(Sequence g (Note Sollu), [Note () (Note stroke)])]
-> Either
     Text
     (SolluMap stroke, [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
forall stroke g.
Pretty stroke =>
[(Sequence g (Note Sollu), [SNote stroke])]
-> Either
     Text
     (SolluMap stroke, [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
solluMap [(Sequence g (Note Sollu), [Note () (Note stroke)])]
strokes
    StrokeMap stroke -> Either Text (StrokeMap stroke)
forall (m :: * -> *) a. Monad m => a -> m a
return (StrokeMap stroke -> Either Text (StrokeMap stroke))
-> StrokeMap stroke -> Either Text (StrokeMap stroke)
forall a b. (a -> b) -> a -> b
$ StrokeMap
        { smapSolluMap :: SolluMap stroke
smapSolluMap = SolluMap 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 = (Note g (Note (Stroke stroke))
 -> Either Text (Note () (Note stroke)))
-> [Note g (Note (Stroke stroke))]
-> Either Text [Note () (Note stroke)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Note (Stroke stroke) -> Either Text (Note stroke))
-> Note () (Note (Stroke stroke))
-> Either Text (Note () (Note stroke))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Note (Stroke stroke) -> Either Text (Note stroke)
forall {stroke}. Note (Stroke stroke) -> Either Text (Note stroke)
convert (Note () (Note (Stroke stroke))
 -> Either Text (Note () (Note stroke)))
-> (Note g (Note (Stroke stroke))
    -> Note () (Note (Stroke stroke)))
-> Note g (Note (Stroke stroke))
-> Either Text (Note () (Note stroke))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g -> ())
-> Note g (Note (Stroke stroke)) -> Note () (Note (Stroke stroke))
forall g h a. (g -> h) -> Note g a -> Note h a
S.mapGroup (() -> g -> ()
forall a b. a -> b -> a
const ())) ([Note g (Note (Stroke stroke))]
 -> Either Text [Note () (Note stroke)])
-> (Sequence g (Note (Stroke stroke))
    -> [Note g (Note (Stroke stroke))])
-> Sequence g (Note (Stroke stroke))
-> Either Text [Note () (Note stroke)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence g (Note (Stroke stroke))
-> [Note g (Note (Stroke stroke))]
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 -> Note stroke -> Either Text (Note stroke)
forall a b. b -> Either a b
Right (Note stroke -> Either Text (Note stroke))
-> Note stroke -> Either Text (Note stroke)
forall a b. (a -> b) -> a -> b
$ Stroke stroke -> Note stroke
forall stroke. Stroke stroke -> Note stroke
Note (NoteT (Stroke stroke) -> Stroke stroke
forall sollu. NoteT sollu -> sollu
Solkattu._sollu NoteT (Stroke stroke)
n)
        Solkattu.Space Space
a -> Note stroke -> Either Text (Note stroke)
forall a b. b -> Either a b
Right (Note stroke -> Either Text (Note stroke))
-> Note stroke -> Either Text (Note stroke)
forall a b. (a -> b) -> a -> b
$ Space -> Note stroke
forall stroke. Space -> Note stroke
Space Space
a
        Solkattu.Pattern Pattern
p -> Text -> Either Text (Note stroke)
forall a b. a -> Either a b
Left (Text -> Either Text (Note stroke))
-> Text -> Either Text (Note stroke)
forall a b. (a -> b) -> a -> b
$ Text
"can't convert pattern: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Pattern -> Text
forall a. Pretty a => a -> Text
pretty Pattern
p
        Solkattu.Alignment Int
a -> Note stroke -> Either Text (Note stroke)
forall a b. b -> Either a b
Right (Note stroke -> Either Text (Note stroke))
-> Note stroke -> Either Text (Note stroke)
forall a b. (a -> b) -> a -> b
$ Int -> Note stroke
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
(PatternMap stroke -> PatternMap stroke -> Bool)
-> (PatternMap stroke -> PatternMap stroke -> Bool)
-> Eq (PatternMap stroke)
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
[PatternMap stroke] -> ShowS
PatternMap stroke -> String
(Int -> PatternMap stroke -> ShowS)
-> (PatternMap stroke -> String)
-> ([PatternMap stroke] -> ShowS)
-> Show (PatternMap stroke)
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
(PatternMap stroke -> Text)
-> (PatternMap stroke -> Doc)
-> ([PatternMap stroke] -> Doc)
-> Pretty (PatternMap stroke)
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
(PatternMap stroke -> PatternMap stroke -> PatternMap stroke)
-> (NonEmpty (PatternMap stroke) -> PatternMap stroke)
-> (forall b.
    Integral b =>
    b -> PatternMap stroke -> PatternMap stroke)
-> Semigroup (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, Semigroup (PatternMap stroke)
PatternMap stroke
Semigroup (PatternMap stroke)
-> PatternMap stroke
-> (PatternMap stroke -> PatternMap stroke -> PatternMap stroke)
-> ([PatternMap stroke] -> PatternMap stroke)
-> Monoid (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
    | [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errors = PatternMap stroke -> Either Text (PatternMap stroke)
forall a b. b -> Either a b
Right (PatternMap stroke -> Either Text (PatternMap stroke))
-> PatternMap stroke -> Either Text (PatternMap stroke)
forall a b. (a -> b) -> a -> b
$ Map Pattern [SNote stroke] -> PatternMap stroke
forall stroke. Map Pattern [SNote stroke] -> PatternMap stroke
PatternMap (Map Pattern [SNote stroke] -> PatternMap stroke)
-> Map Pattern [SNote stroke] -> PatternMap stroke
forall a b. (a -> b) -> a -> b
$ [(Pattern, [SNote stroke])] -> Map Pattern [SNote stroke]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Pattern, [SNote stroke])] -> Map Pattern [SNote stroke])
-> [(Pattern, [SNote stroke])] -> Map Pattern [SNote stroke]
forall a b. (a -> b) -> a -> b
$
        ((Pattern, Sequence () (Note stroke)) -> (Pattern, [SNote stroke]))
-> [(Pattern, Sequence () (Note stroke))]
-> [(Pattern, [SNote stroke])]
forall a b. (a -> b) -> [a] -> [b]
map ((Sequence () (Note stroke) -> [SNote stroke])
-> (Pattern, Sequence () (Note stroke))
-> (Pattern, [SNote stroke])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Sequence () (Note stroke) -> [SNote stroke]
forall g a. Sequence g a -> [Note g a]
S.toList) [(Pattern, Sequence () (Note stroke))]
pairs
    | Bool
otherwise = Text -> Either Text (PatternMap stroke)
forall a b. a -> Either a b
Left (Text -> Either Text (PatternMap stroke))
-> Text -> Either Text (PatternMap stroke)
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"; " [Text]
errors
    where
    errors :: [Text]
errors = ((Pattern, Sequence () (Note stroke)) -> Maybe Text)
-> [(Pattern, Sequence () (Note stroke))] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Pattern, Sequence () (Note stroke)) -> Maybe Text
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 Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
forall a. HasMatras a => a -> Int
S.matrasOf a
p) =
            Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"pattern matras " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Pretty a => a -> Text
pretty (a -> Int
forall a. HasMatras a => a -> Int
S.matrasOf a
p)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" /= realization matras " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Duration -> Text
forall a. Pretty a => a -> Text
pretty Duration
notesMatras
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
p
        | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing
        where
        notesMatras :: Duration
notesMatras = Duration
notesDuration Duration -> Duration -> Duration
forall a. Fractional a => a -> a -> a
/ Tempo -> Duration
S.matraDuration Tempo
S.defaultTempo
        notesDuration :: Duration
notesDuration = [Duration] -> Duration
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum ([Duration] -> Duration) -> [Duration] -> Duration
forall a b. (a -> b) -> a -> b
$ (Note g a -> Duration) -> [Note g a] -> [Duration]
forall a b. (a -> b) -> [a] -> [b]
map (Tempo -> Note g a -> Duration
forall a g. HasMatras a => Tempo -> Note g a -> Duration
S.durationOf Tempo
S.defaultTempo) ([Note g a] -> [Duration]) -> [Note g a] -> [Duration]
forall a b. (a -> b) -> a -> b
$
            Sequence g a -> [Note g a]
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) = Pattern -> Map Pattern [SNote stroke] -> Maybe [SNote stroke]
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 stroke =
    SolluMap (Map (SolluMapKey Solkattu.Sollu) [Maybe (Stroke stroke)])
    deriving (SolluMap stroke -> SolluMap stroke -> Bool
(SolluMap stroke -> SolluMap stroke -> Bool)
-> (SolluMap stroke -> SolluMap stroke -> Bool)
-> Eq (SolluMap stroke)
forall stroke.
Eq stroke =>
SolluMap stroke -> SolluMap stroke -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SolluMap stroke -> SolluMap stroke -> Bool
$c/= :: forall stroke.
Eq stroke =>
SolluMap stroke -> SolluMap stroke -> Bool
== :: SolluMap stroke -> SolluMap stroke -> Bool
$c== :: forall stroke.
Eq stroke =>
SolluMap stroke -> SolluMap stroke -> Bool
Eq, Int -> SolluMap stroke -> ShowS
[SolluMap stroke] -> ShowS
SolluMap stroke -> String
(Int -> SolluMap stroke -> ShowS)
-> (SolluMap stroke -> String)
-> ([SolluMap stroke] -> ShowS)
-> Show (SolluMap stroke)
forall stroke. Show stroke => Int -> SolluMap stroke -> ShowS
forall stroke. Show stroke => [SolluMap stroke] -> ShowS
forall stroke. Show stroke => SolluMap stroke -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SolluMap stroke] -> ShowS
$cshowList :: forall stroke. Show stroke => [SolluMap stroke] -> ShowS
show :: SolluMap stroke -> String
$cshow :: forall stroke. Show stroke => SolluMap stroke -> String
showsPrec :: Int -> SolluMap stroke -> ShowS
$cshowsPrec :: forall stroke. Show stroke => Int -> SolluMap stroke -> ShowS
Show, [SolluMap stroke] -> Doc
SolluMap stroke -> Text
SolluMap stroke -> Doc
(SolluMap stroke -> Text)
-> (SolluMap stroke -> Doc)
-> ([SolluMap stroke] -> Doc)
-> Pretty (SolluMap stroke)
forall stroke. Pretty stroke => [SolluMap stroke] -> Doc
forall stroke. Pretty stroke => SolluMap stroke -> Text
forall stroke. Pretty stroke => SolluMap stroke -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [SolluMap stroke] -> Doc
$cformatList :: forall stroke. Pretty stroke => [SolluMap stroke] -> Doc
format :: SolluMap stroke -> Doc
$cformat :: forall stroke. Pretty stroke => SolluMap stroke -> Doc
pretty :: SolluMap stroke -> Text
$cpretty :: forall stroke. Pretty stroke => SolluMap stroke -> Text
Pretty, NonEmpty (SolluMap stroke) -> SolluMap stroke
SolluMap stroke -> SolluMap stroke -> SolluMap stroke
(SolluMap stroke -> SolluMap stroke -> SolluMap stroke)
-> (NonEmpty (SolluMap stroke) -> SolluMap stroke)
-> (forall b.
    Integral b =>
    b -> SolluMap stroke -> SolluMap stroke)
-> Semigroup (SolluMap stroke)
forall b. Integral b => b -> SolluMap stroke -> SolluMap stroke
forall stroke. NonEmpty (SolluMap stroke) -> SolluMap stroke
forall stroke.
SolluMap stroke -> SolluMap stroke -> SolluMap stroke
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall stroke b.
Integral b =>
b -> SolluMap stroke -> SolluMap stroke
stimes :: forall b. Integral b => b -> SolluMap stroke -> SolluMap stroke
$cstimes :: forall stroke b.
Integral b =>
b -> SolluMap stroke -> SolluMap stroke
sconcat :: NonEmpty (SolluMap stroke) -> SolluMap stroke
$csconcat :: forall stroke. NonEmpty (SolluMap stroke) -> SolluMap stroke
<> :: SolluMap stroke -> SolluMap stroke -> SolluMap stroke
$c<> :: forall stroke.
SolluMap stroke -> SolluMap stroke -> SolluMap stroke
Semigroup, Semigroup (SolluMap stroke)
SolluMap stroke
Semigroup (SolluMap stroke)
-> SolluMap stroke
-> (SolluMap stroke -> SolluMap stroke -> SolluMap stroke)
-> ([SolluMap stroke] -> SolluMap stroke)
-> Monoid (SolluMap stroke)
[SolluMap stroke] -> SolluMap stroke
SolluMap stroke -> SolluMap stroke -> SolluMap stroke
forall stroke. Semigroup (SolluMap stroke)
forall stroke. SolluMap stroke
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall stroke. [SolluMap stroke] -> SolluMap stroke
forall stroke.
SolluMap stroke -> SolluMap stroke -> SolluMap stroke
mconcat :: [SolluMap stroke] -> SolluMap stroke
$cmconcat :: forall stroke. [SolluMap stroke] -> SolluMap stroke
mappend :: SolluMap stroke -> SolluMap stroke -> SolluMap stroke
$cmappend :: forall stroke.
SolluMap stroke -> SolluMap stroke -> SolluMap stroke
mempty :: SolluMap stroke
$cmempty :: forall stroke. SolluMap 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) = Text -> (Tag -> Text) -> Maybe Tag -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
""  ((Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"^") (Text -> Text) -> (Tag -> Text) -> Tag -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
forall a. Pretty a => a -> Text
pretty) Maybe Tag
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [sollu] -> Text
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 =>
    [(S.Sequence g (Solkattu.Note Solkattu.Sollu), [SNote stroke])]
    -> Either Error (SolluMap stroke,
        [(SolluMapKey Solkattu.Sollu, [Maybe (Stroke stroke)])])
solluMap :: forall stroke g.
Pretty stroke =>
[(Sequence g (Note Sollu), [SNote stroke])]
-> Either
     Text
     (SolluMap stroke, [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
solluMap = ([(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
 -> (SolluMap stroke,
     [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]))
-> Either Text [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
-> Either
     Text
     (SolluMap stroke, [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map (SolluMapKey Sollu) [Maybe (Stroke stroke)]
 -> SolluMap stroke)
-> (Map (SolluMapKey Sollu) [Maybe (Stroke stroke)],
    [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
-> (SolluMap stroke,
    [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Map (SolluMapKey Sollu) [Maybe (Stroke stroke)] -> SolluMap stroke
forall stroke.
Map (SolluMapKey Sollu) [Maybe (Stroke stroke)] -> SolluMap stroke
SolluMap ((Map (SolluMapKey Sollu) [Maybe (Stroke stroke)],
  [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
 -> (SolluMap stroke,
     [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]))
-> ([(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
    -> (Map (SolluMapKey Sollu) [Maybe (Stroke stroke)],
        [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]))
-> [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
-> (SolluMap stroke,
    [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
-> (Map (SolluMapKey Sollu) [Maybe (Stroke stroke)],
    [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
forall a b. Ord a => [(a, b)] -> (Map a b, [(a, b)])
Maps.unique ([(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
 -> (Map (SolluMapKey Sollu) [Maybe (Stroke stroke)],
     [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]))
-> ([(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
    -> [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
-> [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
-> (Map (SolluMapKey Sollu) [Maybe (Stroke stroke)],
    [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
-> [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
forall a. [a] -> [a]
reverse) (Either Text [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
 -> Either
      Text
      (SolluMap stroke, [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]))
-> ([(Sequence g (Note Sollu), [SNote stroke])]
    -> Either Text [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
-> [(Sequence g (Note Sollu), [SNote stroke])]
-> Either
     Text
     (SolluMap stroke, [(SolluMapKey Sollu, [Maybe (Stroke stroke)])])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Sequence g (Note Sollu), [SNote stroke])
 -> Either Text (SolluMapKey Sollu, [Maybe (Stroke stroke)]))
-> [(Sequence g (Note Sollu), [SNote stroke])]
-> Either Text [(SolluMapKey Sollu, [Maybe (Stroke stroke)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Sequence g (Note Sollu), [SNote stroke])
-> Either Text (SolluMapKey Sollu, [Maybe (Stroke stroke)])
forall stroke g.
Pretty stroke =>
(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
    => (S.Sequence g (Solkattu.Note Solkattu.Sollu), [SNote stroke])
    -> Either Error (SolluMapKey Solkattu.Sollu, [Maybe (Stroke stroke)])
verifySolluMap :: forall stroke g.
Pretty stroke =>
(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) <- [Note g (Note Sollu)] -> Either Text (Maybe Tag, [Maybe Sollu])
forall g.
[Note g (Note Sollu)] -> Either Text (Maybe Tag, [Maybe Sollu])
verifySolluKey ([Note g (Note Sollu)] -> Either Text (Maybe Tag, [Maybe Sollu]))
-> [Note g (Note Sollu)] -> Either Text (Maybe Tag, [Maybe Sollu])
forall a b. (a -> b) -> a -> b
$ Sequence g (Note Sollu) -> [Note g (Note Sollu)]
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
"." ([Text] -> Text)
-> ([Maybe Sollu] -> [Text]) -> [Maybe Sollu] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Sollu -> Text) -> [Maybe Sollu] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> (Sollu -> Text) -> Maybe Sollu -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"__" Sollu -> Text
forall a. Pretty a => a -> Text
pretty)
        pStrokes :: [SNote stroke] -> Text
pStrokes = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text)
-> ([SNote stroke] -> [Text]) -> [SNote stroke] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SNote stroke -> Text) -> [SNote stroke] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map SNote stroke -> Text
forall a. Pretty a => a -> Text
pretty
    let throw :: Text -> Either Text b
throw = Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b) -> (Text -> Text) -> Text -> Either Text b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
pref<>)
            where pref :: Text
pref = [Maybe Sollu] -> Text
pSollus [Maybe Sollu]
mbSollus Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [SNote stroke] -> Text
pStrokes [SNote stroke]
strokes Text -> Text -> Text
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 <- [([Maybe Sollu], [SNote stroke])]
-> (([Maybe Sollu], [SNote stroke])
    -> Either Text (Maybe (Maybe (Stroke stroke))))
-> Either Text [Maybe (Maybe (Stroke stroke))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Maybe Sollu]
-> [SNote stroke] -> [([Maybe Sollu], [SNote stroke])]
forall a b. [a] -> [b] -> [([a], [b])]
zipTails [Maybe Sollu]
mbSollus [SNote stroke]
strokes) ((([Maybe Sollu], [SNote stroke])
  -> Either Text (Maybe (Maybe (Stroke stroke))))
 -> Either Text [Maybe (Maybe (Stroke stroke))])
-> (([Maybe Sollu], [SNote stroke])
    -> Either Text (Maybe (Maybe (Stroke stroke))))
-> Either Text [Maybe (Maybe (Stroke stroke))]
forall a b. (a -> b) -> a -> b
$ \case
        (Just Sollu
sollu : [Maybe Sollu]
_, S.Note (Space {}) : [SNote stroke]
_)
            | Bool
strictCheck ->
                Text -> Either Text (Maybe (Maybe (Stroke stroke)))
forall {b}. Text -> Either Text b
throw (Text -> Either Text (Maybe (Maybe (Stroke stroke))))
-> Text -> Either Text (Maybe (Maybe (Stroke stroke)))
forall a b. (a -> b) -> a -> b
$ Text
"sollu '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sollu -> Text
forall a. Pretty a => a -> Text
pretty Sollu
sollu Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' given rest stroke"
            | Bool
otherwise -> Maybe (Maybe (Stroke stroke))
-> Either Text (Maybe (Maybe (Stroke stroke)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Maybe (Stroke stroke))
 -> Either Text (Maybe (Maybe (Stroke stroke))))
-> Maybe (Maybe (Stroke stroke))
-> Either Text (Maybe (Maybe (Stroke stroke)))
forall a b. (a -> b) -> a -> b
$ Maybe (Stroke stroke) -> Maybe (Maybe (Stroke stroke))
forall a. a -> Maybe a
Just Maybe (Stroke stroke)
forall a. Maybe a
Nothing
        (Maybe Sollu
Nothing : [Maybe Sollu]
_, S.Note (Note Stroke stroke
stroke) : [SNote stroke]
_) ->
            Text -> Either Text (Maybe (Maybe (Stroke stroke)))
forall {b}. Text -> Either Text b
throw (Text -> Either Text (Maybe (Maybe (Stroke stroke))))
-> Text -> Either Text (Maybe (Maybe (Stroke stroke)))
forall a b. (a -> b) -> a -> b
$ Text
"rest sollu given non-rest stroke '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Stroke stroke -> Text
forall a. Pretty a => a -> Text
pretty Stroke stroke
stroke Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
        (Maybe Sollu
Nothing : [Maybe Sollu]
_, S.Note (Space {}) : [SNote stroke]
_) -> Maybe (Maybe (Stroke stroke))
-> Either Text (Maybe (Maybe (Stroke stroke)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Maybe (Stroke stroke))
forall a. Maybe a
Nothing
        (Just Sollu
_ : [Maybe Sollu]
_, S.Note (Note Stroke stroke
stroke) : [SNote stroke]
_) -> Maybe (Maybe (Stroke stroke))
-> Either Text (Maybe (Maybe (Stroke stroke)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Maybe (Stroke stroke))
 -> Either Text (Maybe (Maybe (Stroke stroke))))
-> Maybe (Maybe (Stroke stroke))
-> Either Text (Maybe (Maybe (Stroke stroke)))
forall a b. (a -> b) -> a -> b
$ Maybe (Stroke stroke) -> Maybe (Maybe (Stroke stroke))
forall a. a -> Maybe a
Just (Maybe (Stroke stroke) -> Maybe (Maybe (Stroke stroke)))
-> Maybe (Stroke stroke) -> Maybe (Maybe (Stroke stroke))
forall a b. (a -> b) -> a -> b
$ Stroke stroke -> Maybe (Stroke stroke)
forall a. a -> Maybe a
Just Stroke stroke
stroke
        ([Maybe Sollu]
sollus, []) ->
            Text -> Either Text (Maybe (Maybe (Stroke stroke)))
forall {b}. Text -> Either Text b
throw (Text -> Either Text (Maybe (Maybe (Stroke stroke))))
-> Text -> Either Text (Maybe (Maybe (Stroke stroke)))
forall a b. (a -> b) -> a -> b
$ Text
"more sollus than strokes at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Maybe Sollu] -> Text
pSollus [Maybe Sollu]
sollus
        ([], [SNote stroke]
strokes) ->
            Text -> Either Text (Maybe (Maybe (Stroke stroke)))
forall {b}. Text -> Either Text b
throw (Text -> Either Text (Maybe (Maybe (Stroke stroke))))
-> Text -> Either Text (Maybe (Maybe (Stroke stroke)))
forall a b. (a -> b) -> a -> b
$ Text
"more strokes than sollus at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [SNote stroke] -> Text
pStrokes [SNote stroke]
strokes
        (Maybe Sollu
sollu : [Maybe Sollu]
_, SNote stroke
stroke : [SNote stroke]
_) ->
            Text -> Either Text (Maybe (Maybe (Stroke stroke)))
forall {b}. Text -> Either Text b
throw (Text -> Either Text (Maybe (Maybe (Stroke stroke))))
-> Text -> Either Text (Maybe (Maybe (Stroke stroke)))
forall a b. (a -> b) -> a -> b
$ Text
"should have plain sollus and strokes: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Maybe Sollu, SNote stroke) -> Text
forall a. Pretty a => a -> Text
pretty (Maybe Sollu
sollu, SNote stroke
stroke)
    (SolluMapKey Sollu, [Maybe (Stroke stroke)])
-> Either Text (SolluMapKey Sollu, [Maybe (Stroke stroke)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe Tag
tag, [Maybe Sollu] -> [Sollu]
forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe Sollu]
mbSollus), [Maybe (Maybe (Stroke stroke))] -> [Maybe (Stroke stroke)]
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 = (([a], [b]) -> Bool) -> [([a], [b])] -> [([a], [b])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\([a]
as, [b]
bs) -> Bool -> Bool
not ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
as Bool -> Bool -> Bool
&& [b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
bs)) ([([a], [b])] -> [([a], [b])]) -> [([a], [b])] -> [([a], [b])]
forall a b. (a -> b) -> a -> b
$
    [[a]] -> [[b]] -> [([a], [b])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [[a]]
forall a. [a] -> [[a]]
List.tails [a]
as) ([b] -> [[b]]
forall a. [a] -> [[a]]
List.tails [b]
bs)

verifySolluKey :: [S.Note g (Solkattu.Note Solkattu.Sollu)]
    -> Either Error (SolluMapKey (Maybe Solkattu.Sollu))
verifySolluKey :: forall g.
[Note g (Note Sollu)] -> Either Text (Maybe Tag, [Maybe Sollu])
verifySolluKey [Note g (Note Sollu)]
sollus_ = do
    let sollus :: [Note () (Note Sollu)]
sollus = (Note g (Note Sollu) -> Note () (Note Sollu))
-> [Note g (Note Sollu)] -> [Note () (Note Sollu)]
forall a b. (a -> b) -> [a] -> [b]
map ((g -> ()) -> Note g (Note Sollu) -> Note () (Note Sollu)
forall g h a. (g -> h) -> Note g a -> Note h a
S.mapGroup (() -> g -> ()
forall a b. a -> b -> a
const ())) [Note g (Note Sollu)]
sollus_
    let throw :: Text -> Either Text b
throw = Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b) -> (Text -> Text) -> Text -> Either Text b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Note () (Note Sollu)] -> Text
forall a. Pretty a => a -> Text
pretty [Note () (Note Sollu)]
sollus Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")<>)
    ([Maybe Tag]
tags, [Maybe Sollu]
sollus) <- ([Maybe (Maybe Tag, Maybe Sollu)] -> ([Maybe Tag], [Maybe Sollu]))
-> Either Text [Maybe (Maybe Tag, Maybe Sollu)]
-> Either Text ([Maybe Tag], [Maybe Sollu])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Maybe Tag, Maybe Sollu)] -> ([Maybe Tag], [Maybe Sollu])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Tag, Maybe Sollu)] -> ([Maybe Tag], [Maybe Sollu]))
-> ([Maybe (Maybe Tag, Maybe Sollu)] -> [(Maybe Tag, Maybe Sollu)])
-> [Maybe (Maybe Tag, Maybe Sollu)]
-> ([Maybe Tag], [Maybe Sollu])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Maybe Tag, Maybe Sollu)] -> [(Maybe Tag, Maybe Sollu)]
forall a. [Maybe a] -> [a]
Maybe.catMaybes) (Either Text [Maybe (Maybe Tag, Maybe Sollu)]
 -> Either Text ([Maybe Tag], [Maybe Sollu]))
-> Either Text [Maybe (Maybe Tag, Maybe Sollu)]
-> Either Text ([Maybe Tag], [Maybe Sollu])
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.
        [Note Sollu]
-> (Note Sollu -> Either Text (Maybe (Maybe Tag, Maybe Sollu)))
-> Either Text [Maybe (Maybe Tag, Maybe Sollu)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Note () (Note Sollu)] -> [Note Sollu]
forall g a. [Note g a] -> [a]
S.notes [Note () (Note Sollu)]
sollus) ((Note Sollu -> Either Text (Maybe (Maybe Tag, Maybe Sollu)))
 -> Either Text [Maybe (Maybe Tag, Maybe Sollu)])
-> (Note Sollu -> Either Text (Maybe (Maybe Tag, Maybe Sollu)))
-> Either Text [Maybe (Maybe Tag, Maybe Sollu)]
forall a b. (a -> b) -> a -> b
$ \case
            Solkattu.Note NoteT Sollu
note ->
                Maybe (Maybe Tag, Maybe Sollu)
-> Either Text (Maybe (Maybe Tag, Maybe Sollu))
forall a b. b -> Either a b
Right (Maybe (Maybe Tag, Maybe Sollu)
 -> Either Text (Maybe (Maybe Tag, Maybe Sollu)))
-> Maybe (Maybe Tag, Maybe Sollu)
-> Either Text (Maybe (Maybe Tag, Maybe Sollu))
forall a b. (a -> b) -> a -> b
$ (Maybe Tag, Maybe Sollu) -> Maybe (Maybe Tag, Maybe Sollu)
forall a. a -> Maybe a
Just (NoteT Sollu -> Maybe Tag
forall sollu. NoteT sollu -> Maybe Tag
Solkattu._tag NoteT Sollu
note, Sollu -> Maybe Sollu
forall a. a -> Maybe a
Just (Sollu -> Maybe Sollu) -> Sollu -> Maybe Sollu
forall a b. (a -> b) -> a -> b
$ NoteT Sollu -> Sollu
forall sollu. NoteT sollu -> sollu
Solkattu._sollu NoteT Sollu
note)
            Solkattu.Space {} -> Maybe (Maybe Tag, Maybe Sollu)
-> Either Text (Maybe (Maybe Tag, Maybe Sollu))
forall a b. b -> Either a b
Right (Maybe (Maybe Tag, Maybe Sollu)
 -> Either Text (Maybe (Maybe Tag, Maybe Sollu)))
-> Maybe (Maybe Tag, Maybe Sollu)
-> Either Text (Maybe (Maybe Tag, Maybe Sollu))
forall a b. (a -> b) -> a -> b
$ (Maybe Tag, Maybe Sollu) -> Maybe (Maybe Tag, Maybe Sollu)
forall a. a -> Maybe a
Just (Maybe Tag
forall a. Maybe a
Nothing, Maybe Sollu
forall a. Maybe a
Nothing)
            Note Sollu
s -> Text -> Either Text (Maybe (Maybe Tag, Maybe Sollu))
forall {b}. Text -> Either Text b
throw (Text -> Either Text (Maybe (Maybe Tag, Maybe Sollu)))
-> Text -> Either Text (Maybe (Maybe Tag, Maybe Sollu))
forall a b. (a -> b) -> a -> b
$ Text
"should only have plain sollus: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Note Sollu -> Text
forall a. Pretty a => a -> Text
pretty Note Sollu
s
    -- TODO warn if there are inconsistent tags?
    (Maybe Tag, [Maybe Sollu])
-> Either Text (Maybe Tag, [Maybe Sollu])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tag] -> Maybe Tag
forall a. [a] -> Maybe a
Seq.head ([Maybe Tag] -> [Tag]
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 Pattern -> PatternMap stroke -> Maybe [SNote stroke]
forall stroke. Pattern -> PatternMap stroke -> Maybe [SNote stroke]
lookupPattern Pattern
pattern PatternMap stroke
pmap of
    Maybe [SNote stroke]
Nothing -> Text -> Either Text [(Tempo, Note stroke)]
forall a b. a -> Either a b
Left (Text -> Either Text [(Tempo, Note stroke)])
-> Text -> Either Text [(Tempo, Note stroke)]
forall a b. (a -> b) -> a -> b
$ Text
"no pattern for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Pattern -> Text
forall a. Pretty a => a -> Text
pretty Pattern
pattern
    Just [SNote stroke]
notes -> [(Tempo, Note stroke)] -> Either Text [(Tempo, Note stroke)]
forall a b. b -> Either a b
Right ([(Tempo, Note stroke)] -> Either Text [(Tempo, Note stroke)])
-> [(Tempo, Note stroke)] -> Either Text [(Tempo, Note stroke)]
forall a b. (a -> b) -> a -> b
$ [Flat () (Note stroke)] -> [(Tempo, Note stroke)]
forall g a. [Flat g a] -> [(Tempo, a)]
S.tempoNotes ([Flat () (Note stroke)] -> [(Tempo, Note stroke)])
-> [Flat () (Note stroke)] -> [(Tempo, Note stroke)]
forall a b. (a -> b) -> a -> b
$ Tempo -> [SNote stroke] -> [Flat () (Note stroke)]
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
(Group stroke -> Group stroke -> Bool)
-> (Group stroke -> Group stroke -> Bool) -> Eq (Group stroke)
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, Eq (Group stroke)
Eq (Group stroke)
-> (Group stroke -> Group stroke -> Ordering)
-> (Group stroke -> Group stroke -> Bool)
-> (Group stroke -> Group stroke -> Bool)
-> (Group stroke -> Group stroke -> Bool)
-> (Group stroke -> Group stroke -> Bool)
-> (Group stroke -> Group stroke -> Group stroke)
-> (Group stroke -> Group stroke -> Group stroke)
-> Ord (Group stroke)
Group stroke -> Group stroke -> Bool
Group stroke -> Group stroke -> Ordering
Group stroke -> Group stroke -> Group stroke
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
[Group stroke] -> ShowS
Group stroke -> String
(Int -> Group stroke -> ShowS)
-> (Group stroke -> String)
-> ([Group stroke] -> ShowS)
-> Show (Group stroke)
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 -> b) -> Group a -> Group b)
-> (forall a b. a -> Group b -> Group a) -> Functor Group
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
(Reduction stroke -> Reduction stroke -> Bool)
-> (Reduction stroke -> Reduction stroke -> Bool)
-> Eq (Reduction stroke)
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, Eq (Reduction stroke)
Eq (Reduction stroke)
-> (Reduction stroke -> Reduction stroke -> Ordering)
-> (Reduction stroke -> Reduction stroke -> Bool)
-> (Reduction stroke -> Reduction stroke -> Bool)
-> (Reduction stroke -> Reduction stroke -> Bool)
-> (Reduction stroke -> Reduction stroke -> Bool)
-> (Reduction stroke -> Reduction stroke -> Reduction stroke)
-> (Reduction stroke -> Reduction stroke -> Reduction stroke)
-> Ord (Reduction stroke)
Reduction stroke -> Reduction stroke -> Bool
Reduction stroke -> Reduction stroke -> Ordering
Reduction stroke -> Reduction stroke -> Reduction stroke
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
[Reduction stroke] -> ShowS
Reduction stroke -> String
(Int -> Reduction stroke -> ShowS)
-> (Reduction stroke -> String)
-> ([Reduction stroke] -> ShowS)
-> Show (Reduction stroke)
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 -> b) -> Reduction a -> Reduction b)
-> (forall a b. a -> Reduction b -> Reduction a)
-> Functor Reduction
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) = Reduction stroke -> Text
forall a. Pretty a => a -> Text
pretty Reduction stroke
r
    pretty (GMeta Meta
m) = Meta -> Text
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) = ([stroke], Side) -> Text
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 stroke -> ToStrokes sollu stroke
    -> Tala.Tala -> [S.Flat Solkattu.Group (Solkattu.Note sollu)]
    -> (UF.UntilFail Error (Realized stroke), Set (SolluMapKey sollu))
realize :: forall sollu stroke.
(Pretty sollu, Ord sollu) =>
StrokeMap stroke
-> ToStrokes sollu stroke
-> Tala
-> [Flat Group (Note sollu)]
-> (UntilFail Text (Realized stroke), Set (SolluMapKey sollu))
realize StrokeMap stroke
smap = RealizePattern Tempo stroke
-> ToStrokes sollu stroke
-> Tala
-> [Flat Group (Note sollu)]
-> (UntilFail Text (Realized stroke), Set (SolluMapKey sollu))
forall sollu stroke.
(Pretty sollu, Ord sollu) =>
RealizePattern Tempo stroke
-> ToStrokes sollu stroke
-> Tala
-> [Flat Group (Note sollu)]
-> (UntilFail Text (Realized stroke), Set (SolluMapKey sollu))
realize_ (PatternMap stroke -> RealizePattern Tempo stroke
forall stroke. PatternMap stroke -> RealizePattern Tempo stroke
realizePattern (StrokeMap stroke -> PatternMap stroke
forall stroke. StrokeMap stroke -> PatternMap stroke
smapPatternMap StrokeMap 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.Tala -> [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
-> Tala
-> [Flat Group (Note sollu)]
-> (UntilFail Text (Realized stroke), Set (SolluMapKey sollu))
realize_ RealizePattern Tempo stroke
realizePattern ToStrokes sollu stroke
toStrokes Tala
tala =
    -- The writer keeps track of the set of sollu patterns I've used, so I can
    -- warn about unused ones.
    Writer (Set (SolluMapKey sollu)) (UntilFail Text (Realized stroke))
-> (UntilFail Text (Realized stroke), Set (SolluMapKey sollu))
forall w a. Monoid w => Writer w a -> (a, w)
Writer.CPS.runWriter
        (Writer
   (Set (SolluMapKey sollu)) (UntilFail Text (Realized stroke))
 -> (UntilFail Text (Realized stroke), Set (SolluMapKey sollu)))
-> ([Flat Group (Note sollu)]
    -> Writer
         (Set (SolluMapKey sollu)) (UntilFail Text (Realized stroke)))
-> [Flat Group (Note sollu)]
-> (UntilFail Text (Realized stroke), Set (SolluMapKey sollu))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UntilFail Text (Flat Group (Note stroke))
 -> UntilFail Text (Realized stroke))
-> WriterT
     (Set (SolluMapKey sollu))
     Identity
     (UntilFail Text (Flat Group (Note stroke)))
-> Writer
     (Set (SolluMapKey sollu)) (UntilFail Text (Realized stroke))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Flat Group (Note stroke) -> UntilFail Text (Realized stroke))
-> UntilFail Text (Flat Group (Note stroke))
-> UntilFail Text (Realized stroke)
forall a err b.
(a -> UntilFail err b) -> UntilFail err a -> UntilFail err b
UF.concatMap Flat Group (Note stroke) -> UntilFail Text (Realized stroke)
forall stroke.
Flat Group (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
convertGroups)
        (WriterT
   (Set (SolluMapKey sollu))
   Identity
   (UntilFail Text (Flat Group (Note stroke)))
 -> Writer
      (Set (SolluMapKey sollu)) (UntilFail Text (Realized stroke)))
-> ([Flat Group (Note sollu)]
    -> WriterT
         (Set (SolluMapKey sollu))
         Identity
         (UntilFail Text (Flat Group (Note stroke))))
-> [Flat Group (Note sollu)]
-> Writer
     (Set (SolluMapKey sollu)) (UntilFail Text (Realized stroke))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((State, Flat Group (Note sollu))
 -> [(State, Flat Group (Note sollu))]
 -> WriterT
      (Set (SolluMapKey sollu))
      Identity
      (UntilFail Text (Flat Group (Note stroke)),
       [(State, Flat Group (Note sollu))]))
-> [(State, Flat Group (Note sollu))]
-> WriterT
     (Set (SolluMapKey sollu))
     Identity
     (UntilFail Text (Flat Group (Note stroke)))
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))
     Identity
     (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
forall {m :: * -> *}.
MonadWriter (Set (SolluMapKey sollu)) m =>
(State, Flat Group (Note sollu))
-> [(State, Flat Group (Note sollu))]
-> m (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
realize1
        ([(State, Flat Group (Note sollu))]
 -> WriterT
      (Set (SolluMapKey sollu))
      Identity
      (UntilFail Text (Flat Group (Note stroke))))
-> ([Flat Group (Note sollu)]
    -> [(State, Flat Group (Note sollu))])
-> [Flat Group (Note sollu)]
-> WriterT
     (Set (SolluMapKey sollu))
     Identity
     (UntilFail Text (Flat Group (Note stroke)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State
-> [Flat Group (Note sollu)] -> [(State, Flat Group (Note sollu))]
forall {a}.
HasMatras a =>
State -> [Flat Group a] -> [(State, Flat Group a)]
flatToState (Tala -> Duration -> State
S.stateFrom Tala
tala Duration
0) -- TODO use eddupu
    where
    flatToState :: State -> [Flat Group a] -> [(State, Flat Group a)]
flatToState State
state = (State, [(State, Flat Group a)]) -> [(State, Flat Group a)]
forall a b. (a, b) -> b
snd ((State, [(State, Flat Group a)]) -> [(State, Flat Group a)])
-> ([Flat Group a] -> (State, [(State, Flat Group a)]))
-> [Flat Group a]
-> [(State, Flat Group a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Flat Group a -> Duration)
-> Tala
-> State
-> [Flat Group a]
-> (State, [(State, Flat Group a)])
forall g a.
(Flat g a -> Duration)
-> Tala -> State -> [Flat g a] -> (State, [(State, Flat g a)])
S.flatToState Flat Group a -> Duration
forall a. HasMatras a => Flat Group a -> Duration
Solkattu.flatDuration Tala
tala State
state
    realize1 :: (State, Flat Group (Note sollu))
-> [(State, Flat Group (Note 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 -> (UntilFail Text (Flat Group (Note stroke)),
 [(State, Flat Group (Note sollu))])
-> m (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a err. a -> UntilFail err a
UF.singleton (Flat Group (Note stroke)
 -> UntilFail Text (Flat Group (Note stroke)))
-> Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a b. (a -> b) -> a -> b
$ Tempo -> Note stroke -> Flat Group (Note stroke)
forall g a. Tempo -> a -> Flat g a
S.FNote Tempo
tempo (Int -> Note stroke
forall stroke. Int -> Note stroke
Alignment Int
n), [(State, Flat Group (Note sollu))]
notes)
        Solkattu.Space Space
space -> (UntilFail Text (Flat Group (Note stroke)),
 [(State, Flat Group (Note sollu))])
-> m (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a err. a -> UntilFail err a
UF.singleton (Flat Group (Note stroke)
 -> UntilFail Text (Flat Group (Note stroke)))
-> Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a b. (a -> b) -> a -> b
$ Tempo -> Note stroke -> Flat Group (Note stroke)
forall g a. Tempo -> a -> Flat g a
S.FNote Tempo
tempo (Space -> Note stroke
forall stroke. Space -> Note stroke
Space Space
space), [(State, Flat Group (Note sollu))]
notes)
        Solkattu.Pattern p :: Pattern
p@(Solkattu.PatternM Int
matras) -> (UntilFail Text (Flat Group (Note stroke)),
 [(State, Flat Group (Note sollu))])
-> m (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
forall (m :: * -> *) a. Monad m => a -> m a
return
            ( case RealizePattern Tempo stroke
realizePattern Tempo
tempo Pattern
p of
                Left Text
err -> Text -> UntilFail Text (Flat Group (Note stroke))
forall err a. err -> UntilFail err a
UF.Fail Text
err
                Right [(Tempo, Note stroke)]
tempoNotes -> Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a err. a -> UntilFail err a
UF.singleton (Flat Group (Note stroke)
 -> UntilFail Text (Flat Group (Note stroke)))
-> Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a b. (a -> b) -> a -> b
$ Tempo
-> Group -> [Flat Group (Note stroke)] -> Flat Group (Note stroke)
forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo Group
group ([Flat Group (Note stroke)] -> Flat Group (Note stroke))
-> [Flat Group (Note stroke)] -> Flat Group (Note stroke)
forall a b. (a -> b) -> a -> b
$
                    ((Tempo, Note stroke) -> Flat Group (Note stroke))
-> [(Tempo, Note stroke)] -> [Flat Group (Note stroke)]
forall a b. (a -> b) -> [a] -> [b]
map ((Tempo -> Note stroke -> Flat Group (Note stroke))
-> (Tempo, Note stroke) -> Flat Group (Note stroke)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Tempo -> Note stroke -> Flat Group (Note stroke)
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 (Meta -> Group) -> Meta -> Group
forall a b. (a -> b) -> a -> b
$ Solkattu.Meta
                { _matras :: Maybe Int
_matras = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
matras
                , _name :: Maybe Text
_name = Maybe Text
forall a. Maybe a
Nothing
                , _type :: GroupType
_type = GroupType
Solkattu.GPattern
                }
        Solkattu.Note {} ->
            case ToStrokes sollu stroke
-> [(State, Flat Group (Note sollu))]
-> Either
     Text
     (SolluMapKey sollu,
      ([(Tempo, Note stroke)], [(State, Flat Group (Note sollu))]))
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) (State, Flat Group (Note sollu))
-> [(State, Flat Group (Note sollu))]
-> [(State, Flat Group (Note sollu))]
forall a. a -> [a] -> [a]
: [(State, Flat Group (Note sollu))]
notes) of
                Left Text
err -> (UntilFail Text (Flat Group (Note stroke)),
 [(State, Flat Group (Note sollu))])
-> m (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> UntilFail Text (Flat Group (Note stroke))
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
                    Set (SolluMapKey sollu) -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell (Set (SolluMapKey sollu) -> m ())
-> Set (SolluMapKey sollu) -> m ()
forall a b. (a -> b) -> a -> b
$ SolluMapKey sollu -> Set (SolluMapKey sollu)
forall a. a -> Set a
Set.singleton SolluMapKey sollu
matched
                    (UntilFail Text (Flat Group (Note stroke)),
 [(State, Flat Group (Note sollu))])
-> m (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Flat Group (Note stroke)]
-> UntilFail Text (Flat Group (Note stroke))
forall a err. [a] -> UntilFail err a
UF.fromList (((Tempo, Note stroke) -> Flat Group (Note stroke))
-> [(Tempo, Note stroke)] -> [Flat Group (Note stroke)]
forall a b. (a -> b) -> [a] -> [b]
map ((Tempo -> Note stroke -> Flat Group (Note stroke))
-> (Tempo, Note stroke) -> Flat Group (Note stroke)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Tempo -> Note stroke -> Flat Group (Note stroke)
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) (UntilFail Text (Flat Group (Note stroke))
 -> (UntilFail Text (Flat Group (Note stroke)),
     [(State, Flat Group (Note sollu))]))
-> m (UntilFail Text (Flat Group (Note stroke)))
-> m (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tempo
-> Group
-> [(State, Flat Group (Note sollu))]
-> m (UntilFail Text (Flat Group (Note stroke)))
realizeGroup Tempo
tempo Group
group (State
-> [Flat Group (Note sollu)] -> [(State, Flat Group (Note sollu))]
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))]
-> 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
        | [(State, Flat Group (Note sollu))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(State, Flat Group (Note sollu))]
children = UntilFail Text (Flat Group (Note stroke))
-> m (UntilFail Text (Flat Group (Note stroke)))
forall (m :: * -> *) a. Monad m => a -> m a
return (UntilFail Text (Flat Group (Note stroke))
 -> m (UntilFail Text (Flat Group (Note stroke))))
-> UntilFail Text (Flat Group (Note stroke))
-> m (UntilFail Text (Flat Group (Note stroke)))
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.
            Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a err. a -> UntilFail err a
UF.singleton (Flat Group (Note stroke)
 -> UntilFail Text (Flat Group (Note stroke)))
-> Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a b. (a -> b) -> a -> b
$ Tempo
-> Group -> [Flat Group (Note stroke)] -> Flat Group (Note stroke)
forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo (Meta -> Group
Solkattu.GMeta Meta
m)
                [Tempo -> Note stroke -> Flat Group (Note stroke)
forall g a. Tempo -> a -> Flat g a
S.FNote Tempo
tempo (Meta -> Note stroke
forall stroke. Meta -> Note stroke
Abstract Meta
m)]
        | Bool
otherwise = case ToStrokes sollu stroke
-> Tala
-> Tempo
-> Int
-> [(State, Flat Group (Note sollu))]
-> Either Text (SolluMapKey sollu, [Flat Group (Note stroke)])
forall sollu stroke.
Pretty sollu =>
ToStrokes sollu stroke
-> Tala
-> Tempo
-> Int
-> [(State, Flat Group (Note sollu))]
-> Either Text (SolluMapKey sollu, [Flat Group (Note stroke)])
realizeSarva ToStrokes sollu stroke
toStrokes Tala
tala Tempo
tempo Int
matras [(State, Flat Group (Note sollu))]
children of
            Left Text
err -> UntilFail Text (Flat Group (Note stroke))
-> m (UntilFail Text (Flat Group (Note stroke)))
forall (m :: * -> *) a. Monad m => a -> m a
return (UntilFail Text (Flat Group (Note stroke))
 -> m (UntilFail Text (Flat Group (Note stroke))))
-> UntilFail Text (Flat Group (Note stroke))
-> m (UntilFail Text (Flat Group (Note stroke)))
forall a b. (a -> b) -> a -> b
$ Text -> UntilFail Text (Flat Group (Note stroke))
forall err a. err -> UntilFail err a
UF.Fail (Text -> UntilFail Text (Flat Group (Note stroke)))
-> Text -> UntilFail Text (Flat Group (Note stroke))
forall a b. (a -> b) -> a -> b
$ Text
"sarva: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
            Right (SolluMapKey sollu
matched, [Flat Group (Note stroke)]
strokes) -> do
                Set (SolluMapKey sollu) -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell (Set (SolluMapKey sollu) -> m ())
-> Set (SolluMapKey sollu) -> m ()
forall a b. (a -> b) -> a -> b
$ SolluMapKey sollu -> Set (SolluMapKey sollu)
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.
                UntilFail Text (Flat Group (Note stroke))
-> m (UntilFail Text (Flat Group (Note stroke)))
forall (m :: * -> *) a. Monad m => a -> m a
return (UntilFail Text (Flat Group (Note stroke))
 -> m (UntilFail Text (Flat Group (Note stroke))))
-> UntilFail Text (Flat Group (Note stroke))
-> m (UntilFail Text (Flat Group (Note stroke)))
forall a b. (a -> b) -> a -> b
$ Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a err. a -> UntilFail err a
UF.singleton (Flat Group (Note stroke)
 -> UntilFail Text (Flat Group (Note stroke)))
-> Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a b. (a -> b) -> a -> b
$
                    Tempo
-> Group -> [Flat Group (Note stroke)] -> Flat Group (Note stroke)
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 <- UntilFail Text (Flat Group (Note stroke))
-> ([Flat Group (Note stroke)], Maybe Text)
forall err a. UntilFail err a -> ([a], Maybe err)
UF.toList (UntilFail Text (Flat Group (Note stroke))
 -> ([Flat Group (Note stroke)], Maybe Text))
-> m (UntilFail Text (Flat Group (Note stroke)))
-> m ([Flat Group (Note stroke)], Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((State, Flat Group (Note sollu))
 -> [(State, Flat Group (Note sollu))]
 -> m (UntilFail Text (Flat Group (Note stroke)),
       [(State, Flat Group (Note sollu))]))
-> [(State, Flat Group (Note sollu))]
-> m (UntilFail Text (Flat Group (Note stroke)))
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))]
-> m (UntilFail Text (Flat Group (Note stroke)),
      [(State, Flat Group (Note sollu))])
realize1 [(State, Flat Group (Note sollu))]
children
        UntilFail Text (Flat Group (Note stroke))
-> m (UntilFail Text (Flat Group (Note stroke)))
forall (m :: * -> *) a. Monad m => a -> m a
return (UntilFail Text (Flat Group (Note stroke))
 -> m (UntilFail Text (Flat Group (Note stroke))))
-> UntilFail Text (Flat Group (Note stroke))
-> m (UntilFail Text (Flat Group (Note stroke)))
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) -> [Flat Group (Note stroke)]
-> Text -> UntilFail Text (Flat Group (Note stroke))
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) -> Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a err. a -> UntilFail err a
UF.singleton (Flat Group (Note stroke)
 -> UntilFail Text (Flat Group (Note stroke)))
-> Flat Group (Note stroke)
-> UntilFail Text (Flat Group (Note stroke))
forall a b. (a -> b) -> a -> b
$ Tempo
-> Group -> [Flat Group (Note stroke)] -> Flat Group (Note stroke)
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.Tala -> 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
-> Tala
-> Tempo
-> Int
-> [(State, Flat Group (Note sollu))]
-> Either Text (SolluMapKey sollu, [Flat Group (Note stroke)])
realizeSarva ToStrokes sollu stroke
_ Tala
_ Tempo
_ Int
_ [] = Text -> Either Text (SolluMapKey sollu, [Flat Group (Note stroke)])
forall a b. a -> Either a b
Left Text
"empty sarva group"
realizeSarva ToStrokes sollu stroke
toStrokes Tala
tala 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)) <- ToStrokes sollu stroke
-> [(State, Flat Group (Note sollu))]
-> Either
     Text
     (SolluMapKey sollu,
      ([(Tempo, Note stroke)], [(State, Flat Group (Note sollu))]))
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 <- Text
-> Maybe [(Tempo, Note stroke)]
-> Either Text [(Tempo, Note stroke)]
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust
        (Text
"incomplete match: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SolluMapKey sollu -> Text
forall a. Pretty a => a -> Text
pretty SolluMapKey sollu
matched
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", left: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Note sollu] -> Text
forall a. Pretty a => a -> Text
pretty ([Flat Group (Note sollu)] -> [Note sollu]
forall g a. [Flat g a] -> [a]
S.flattenedNotes (((State, Flat Group (Note sollu)) -> Flat Group (Note sollu))
-> [(State, Flat Group (Note sollu))] -> [Flat Group (Note sollu)]
forall a b. (a -> b) -> [a] -> [b]
map (State, Flat Group (Note sollu)) -> Flat Group (Note sollu)
forall a b. (a, b) -> b
snd [(State, Flat Group (Note sollu))]
left)))
        (((State, Flat Group (Note sollu)) -> Maybe (Tempo, Note stroke))
-> [(State, Flat Group (Note sollu))]
-> Maybe [(Tempo, Note stroke)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Flat Group (Note sollu) -> Maybe (Tempo, Note stroke)
forall {g} {sollu} {stroke}.
Flat g (Note sollu) -> Maybe (Tempo, Note stroke)
getRest (Flat Group (Note sollu) -> Maybe (Tempo, Note stroke))
-> ((State, Flat Group (Note sollu)) -> Flat Group (Note sollu))
-> (State, Flat Group (Note sollu))
-> Maybe (Tempo, Note stroke)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State, Flat Group (Note sollu)) -> Flat Group (Note sollu)
forall a b. (a, b) -> b
snd) [(State, Flat Group (Note sollu))]
left)
    let cycleDur :: Duration
cycleDur = [Duration] -> Duration
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (((Tempo, Note stroke) -> Duration)
-> [(Tempo, Note stroke)] -> [Duration]
forall a b. (a -> b) -> [a] -> [b]
map ((Tempo -> Note stroke -> Duration)
-> (Tempo, Note stroke) -> Duration
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Tempo -> Note stroke -> Duration
forall a. HasMatras a => Tempo -> a -> Duration
S.noteDuration) [(Tempo, Note stroke)]
strokes)
            Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
+ [Duration] -> Duration
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (((Tempo, Note stroke) -> Duration)
-> [(Tempo, Note stroke)] -> [Duration]
forall a b. (a -> b) -> [a] -> [b]
map ((Tempo -> Note stroke -> Duration)
-> (Tempo, Note stroke) -> Duration
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Tempo -> Note stroke -> Duration
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)) <- Duration
-> [Flat Group (Note stroke)]
-> Either
     Text
     (Duration,
      ([Flat Group (Note stroke)], [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
offset Duration -> Duration -> Duration
forall a. Real a => a -> a -> a
`Num.fmod` Duration
cycleDur) ([Flat Group (Note stroke)]
 -> Either
      Text
      (Duration,
       ([Flat Group (Note stroke)], [Flat Group (Note stroke)])))
-> [Flat Group (Note stroke)]
-> Either
     Text
     (Duration,
      ([Flat Group (Note stroke)], [Flat Group (Note stroke)]))
forall a b. (a -> b) -> a -> b
$
        ((Tempo, Note stroke) -> Flat Group (Note stroke))
-> [(Tempo, Note stroke)] -> [Flat Group (Note stroke)]
forall a b. (a -> b) -> [a] -> [b]
map ((Tempo -> Note stroke -> Flat Group (Note stroke))
-> (Tempo, Note stroke) -> Flat Group (Note stroke)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Tempo -> Note stroke -> Flat Group (Note stroke)
forall g a. Tempo -> a -> Flat g a
S.FNote) ([(Tempo, Note stroke)] -> [Flat Group (Note stroke)])
-> [(Tempo, Note stroke)] -> [Flat Group (Note stroke)]
forall a b. (a -> b) -> a -> b
$ [(Tempo, Note stroke)] -> [(Tempo, Note stroke)]
forall a. [a] -> [a]
cycle ([(Tempo, Note stroke)]
strokes [(Tempo, Note stroke)]
-> [(Tempo, Note stroke)] -> [(Tempo, Note stroke)]
forall a. [a] -> [a] -> [a]
++ [(Tempo, Note stroke)]
rests)
    (Duration
_, ([Flat Group (Note stroke)]
strokes, [Flat Group (Note stroke)]
_)) <- Duration
-> [Flat Group (Note stroke)]
-> Either
     Text
     (Duration,
      ([Flat Group (Note stroke)], [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
    (SolluMapKey sollu, [Flat Group (Note stroke)])
-> Either Text (SolluMapKey sollu, [Flat Group (Note stroke)])
forall (m :: * -> *) a. Monad m => a -> m a
return (SolluMapKey sollu
matched, [Flat Group (Note stroke)]
strokes)
    where
    offset :: Duration
offset = Tala -> State -> Duration
S.stateAbsoluteAkshara Tala
tala State
state
    getRest :: Flat g (Note sollu) -> Maybe (Tempo, Note stroke)
getRest (S.FNote Tempo
tempo (Solkattu.Space Space
space)) = (Tempo, Note stroke) -> Maybe (Tempo, Note stroke)
forall a. a -> Maybe a
Just (Tempo
tempo, Space -> Note stroke
forall stroke. Space -> Note stroke
Space Space
space)
    getRest Flat g (Note sollu)
_ = Maybe (Tempo, Note stroke)
forall a. Maybe a
Nothing
    dur :: Duration
dur = Tempo -> Duration
S.matraDuration Tempo
tempo Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Int -> Duration
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 = ([Flat g a], Maybe Text) -> Either Text [Flat g a]
forall {g}. ([Flat g a], Maybe Text) -> Either Text [Flat g a]
format (([Flat g a], Maybe Text) -> Either Text [Flat g a])
-> (UntilFail Text (Flat g a) -> ([Flat g a], Maybe Text))
-> UntilFail Text (Flat g a)
-> Either Text [Flat g a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UntilFail Text (Flat g a) -> ([Flat g a], Maybe Text)
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) = [Flat g a] -> Either Text [Flat g a]
forall a b. b -> Either a b
Right [Flat g a]
result
    format ([Flat g a]
pre, Just Text
err) = Text -> Either Text [Flat g a]
forall a b. a -> Either a b
Left (Text -> Either Text [Flat g a]) -> Text -> Either Text [Flat g a]
forall a b. (a -> b) -> a -> b
$
        Text -> Text -> Text
forall a. Textlike a => a -> a -> a
Texts.unlines2 ([a] -> Text
errorNotation ([Flat g a] -> [a]
forall g a. [Flat g a] -> [a]
S.flattenedNotes [Flat g a]
pre)) Text
err
    errorNotation :: [a] -> Text
errorNotation = [Text] -> Text
Text.unwords
        ([Text] -> Text) -> ([a] -> [Text]) -> [a] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> Text -> Text
justifyLeft Int
2 Char
' ' (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
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) = Flat (Group (Stroke stroke)) (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
forall a err. a -> UntilFail err a
UF.singleton (Flat (Group (Stroke stroke)) (Note stroke)
 -> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke)))
-> Flat (Group (Stroke stroke)) (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
forall a b. (a -> b) -> a -> b
$ Tempo -> Note stroke -> Flat (Group (Stroke stroke)) (Note stroke)
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 UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
-> ([Flat (Group (Stroke stroke)) (Note stroke)], Maybe Text)
forall err a. UntilFail err a -> ([a], Maybe err)
UF.toList (UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
 -> ([Flat (Group (Stroke stroke)) (Note stroke)], Maybe Text))
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
-> ([Flat (Group (Stroke stroke)) (Note stroke)], Maybe Text)
forall a b. (a -> b) -> a -> b
$ (Flat Group (Note stroke)
 -> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke)))
-> UntilFail Text (Flat Group (Note stroke))
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
forall a err b.
(a -> UntilFail err b) -> UntilFail err a -> UntilFail err b
UF.concatMap Flat Group (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
forall stroke.
Flat Group (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
convertGroups ([Flat Group (Note stroke)]
-> UntilFail Text (Flat Group (Note stroke))
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) -> [Flat (Group (Stroke stroke)) (Note stroke)]
-> Text
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
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) -> Tempo
-> Group
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
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 Duration
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> Either
     Text
     (Duration,
      ([Flat (Group (Stroke stroke)) (Note stroke)],
       [Flat (Group (Stroke stroke)) (Note stroke)]))
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 -> Text -> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
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 Duration -> Duration -> Bool
forall a. Ord a => a -> a -> Bool
> Duration
0 -> Text -> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
forall err a. err -> UntilFail err a
UF.Fail (Text
 -> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke)))
-> Text
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
forall a b. (a -> b) -> a -> b
$ Text
"group split too long, duration left: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Duration -> Text
forall a. Pretty a => a -> Text
pretty Duration
left
                | Bool
otherwise -> Flat (Group (Stroke stroke)) (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
forall a err. a -> UntilFail err a
UF.singleton (Flat (Group (Stroke stroke)) (Note stroke)
 -> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke)))
-> Flat (Group (Stroke stroke)) (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
forall a b. (a -> b) -> a -> b
$ Tempo
-> Group (Stroke stroke)
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> Flat (Group (Stroke stroke)) (Note stroke)
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 = Reduction (Stroke stroke) -> Group (Stroke stroke)
forall stroke. Reduction stroke -> Group stroke
GReduction (Reduction (Stroke stroke) -> Group (Stroke stroke))
-> Reduction (Stroke stroke) -> Group (Stroke stroke)
forall a b. (a -> b) -> a -> b
$ Reduction
                        { _dropped :: [Stroke stroke]
_dropped = (Note stroke -> Maybe (Stroke stroke))
-> [Note stroke] -> [Stroke stroke]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Note stroke -> Maybe (Stroke stroke)
forall a. Note a -> Maybe (Stroke a)
noteOf ([Note stroke] -> [Stroke stroke])
-> [Note stroke] -> [Stroke stroke]
forall a b. (a -> b) -> a -> b
$ [Flat (Group (Stroke stroke)) (Note stroke)] -> [Note stroke]
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 =
        Flat (Group (Stroke stroke)) (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
forall a err. a -> UntilFail err a
UF.singleton (Flat (Group (Stroke stroke)) (Note stroke)
 -> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke)))
-> Flat (Group (Stroke stroke)) (Note stroke)
-> UntilFail Text (Flat (Group (Stroke stroke)) (Note stroke))
forall a b. (a -> b) -> a -> b
$ Tempo
-> Group (Stroke stroke)
-> [Flat (Group (Stroke stroke)) (Note stroke)]
-> Flat (Group (Stroke stroke)) (Note stroke)
forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo (Meta -> Group (Stroke stroke)
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 [] = (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall a b. b -> Either a b
Right (Duration
dur, ([], []))
splitStrokes Duration
dur [Flat g (Note stroke)]
notes | Duration
dur Duration -> Duration -> Bool
forall a. Ord a => a -> a -> Bool
<= Duration
0 = (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
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 Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (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 g (Note stroke)]
children of
        Left Text
err -> Text
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall a b. a -> Either a b
Left Text
err
        Right (Duration
left, ([Flat g (Note stroke)]
_pre, [])) -> ([Flat g (Note stroke)] -> [Flat g (Note stroke)])
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall {a} {b} {a} {c}.
(a -> b) -> Either Text (a, (a, c)) -> Either Text (a, (b, c))
add (Flat g (Note stroke)
note:) (Either
   Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
 -> Either
      Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)])))
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall a b. (a -> b) -> a -> b
$ Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
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)) -> (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall a b. b -> Either a b
Right
            ( Duration
left
            , ( [Tempo -> g -> [Flat g (Note stroke)] -> Flat g (Note stroke)
forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo g
g [Flat g (Note stroke)]
pre]
              , Tempo -> g -> [Flat g (Note stroke)] -> Flat g (Note stroke)
forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo g
g [Flat g (Note stroke)]
post Flat g (Note stroke)
-> [Flat g (Note stroke)] -> [Flat g (Note stroke)]
forall a. a -> [a] -> [a]
: [Flat g (Note stroke)]
notes
              )
            )
    S.FNote Tempo
tempo Note stroke
n
        | Duration
noteDur Duration -> Duration -> Bool
forall a. Ord a => a -> a -> Bool
<= Duration
dur -> ([Flat g (Note stroke)] -> [Flat g (Note stroke)])
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall {a} {b} {a} {c}.
(a -> b) -> Either Text (a, (a, c)) -> Either Text (a, (b, c))
add (Flat g (Note stroke)
note:) (Either
   Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
 -> Either
      Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)])))
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall a b. (a -> b) -> a -> b
$ Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall g stroke.
Duration
-> [Flat g (Note stroke)]
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
splitStrokes (Duration
dur Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
- Duration
noteDur) [Flat g (Note stroke)]
notes
        | Bool
otherwise -> case Note stroke
n of
            Note Stroke stroke
_ -> Text
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall a b. a -> Either a b
Left Text
"can't split a stroke"
            Abstract Meta
a -> Text
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall a b. a -> Either a b
Left (Text
 -> Either
      Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)])))
-> Text
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall a b. (a -> b) -> a -> b
$ Text
"can't split Abstract " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Meta -> Text
forall a. Pretty a => a -> Text
pretty Meta
a
            Alignment Int
_ -> Text
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall a b. a -> Either a b
Left (Text
 -> Either
      Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)])))
-> Text
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
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 = ([(Tempo, Note stroke)] -> [Flat g (Note stroke)])
-> Either Text [(Tempo, Note stroke)]
-> Either Text [Flat g (Note stroke)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Tempo, Note stroke) -> Flat g (Note stroke))
-> [(Tempo, Note stroke)] -> [Flat g (Note stroke)]
forall a b. (a -> b) -> [a] -> [b]
map ((Tempo -> Note stroke -> Flat g (Note stroke))
-> (Tempo, Note stroke) -> Flat g (Note stroke)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Tempo -> Note stroke -> Flat g (Note stroke)
forall g a. Tempo -> a -> Flat g a
S.FNote)) (Either Text [(Tempo, Note stroke)]
 -> Either Text [Flat g (Note stroke)])
-> (Duration -> Either Text [(Tempo, Note stroke)])
-> Duration
-> Either Text [Flat g (Note stroke)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tempo -> Space -> Duration -> Either Text [(Tempo, Note stroke)]
forall stroke.
Tempo -> Space -> Duration -> Either Text [(Tempo, Note stroke)]
makeSpace Tempo
tempo Space
space
                [Flat g (Note stroke)]
pre <- Duration -> Either Text [Flat g (Note stroke)]
forall {g} {stroke}. Duration -> Either Text [Flat g (Note stroke)]
make Duration
dur
                [Flat g (Note stroke)]
post <- Duration -> Either Text [Flat g (Note stroke)]
forall {g} {stroke}. Duration -> Either Text [Flat g (Note stroke)]
make (Duration
dur Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
- Duration
noteDur)
                (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
-> Either
     Text (Duration, ([Flat g (Note stroke)], [Flat g (Note stroke)]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration
0, ([Flat g (Note stroke)]
pre, [Flat g (Note stroke)]
post [Flat g (Note stroke)]
-> [Flat g (Note stroke)] -> [Flat g (Note stroke)]
forall a. [a] -> [a] -> [a]
++ [Flat g (Note stroke)]
notes))
        where
        noteDur :: Duration
noteDur = Tempo -> Note stroke -> Duration
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 = ((a, (a, c)) -> (a, (b, c)))
-> Either Text (a, (a, c)) -> Either Text (a, (b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, (a, c)) -> (a, (b, c)))
 -> Either Text (a, (a, c)) -> Either Text (a, (b, c)))
-> ((a -> b) -> (a, (a, c)) -> (a, (b, c)))
-> (a -> b)
-> Either Text (a, (a, c))
-> Either Text (a, (b, c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, c) -> (b, c)) -> (a, (a, c)) -> (a, (b, c))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (((a, c) -> (b, c)) -> (a, (a, c)) -> (a, (b, c)))
-> ((a -> b) -> (a, c) -> (b, c))
-> (a -> b)
-> (a, (a, c))
-> (a, (b, c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> (a, c) -> (b, 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 = (Int -> (Tempo, Note stroke)) -> [Int] -> [(Tempo, Note stroke)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (Tempo, Note stroke)
forall {stroke}. Int -> (Tempo, Note stroke)
make ([Int] -> [(Tempo, Note stroke)])
-> Either Text [Int] -> Either Text [(Tempo, Note stroke)]
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 }, Space -> Note stroke
forall stroke. Space -> Note stroke
Space Space
space)
    s0_matras :: Duration
s0_matras = Duration
dur Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Int -> Duration
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 Maybe Tag
-> [sollu]
-> ToStrokes sollu stroke
-> Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
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 -> Text
-> Either
     Text
     (SolluMapKey sollu,
      ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))]))
forall a b. a -> Either a b
Left (Text
 -> Either
      Text
      (SolluMapKey sollu,
       ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])))
-> Text
-> Either
     Text
     (SolluMapKey sollu,
      ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))]))
forall a b. (a -> b) -> a -> b
$ Text
"sequence not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [sollu] -> Text
forall a. Pretty a => a -> Text
pretty [sollu]
sollus
        Just (SolluMapKey sollu
matched, [Maybe (Stroke stroke)]
strokes) ->
            (SolluMapKey sollu,
 ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))]))
-> Either
     Text
     (SolluMapKey sollu,
      ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))]))
forall a b. b -> Either a b
Right (SolluMapKey sollu
matched, [Maybe (Stroke stroke)]
-> [(state, Flat g (Note sollu))]
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
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 = ([(Tempo, Maybe (NoteT sollu))], [(state, Flat g (Note sollu))])
-> [(Tempo, Maybe (NoteT sollu))]
forall a b. (a, b) -> a
fst (([(Tempo, Maybe (NoteT sollu))], [(state, Flat g (Note sollu))])
 -> [(Tempo, Maybe (NoteT sollu))])
-> ([(Tempo, Maybe (NoteT sollu))], [(state, Flat g (Note sollu))])
-> [(Tempo, Maybe (NoteT sollu))]
forall a b. (a -> b) -> a -> b
$ ((state, Flat g (Note sollu))
 -> Maybe (Tempo, Maybe (NoteT sollu)))
-> [(state, Flat g (Note sollu))]
-> ([(Tempo, Maybe (NoteT sollu))], [(state, Flat g (Note sollu))])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Seq.span_while (Flat g (Note sollu) -> Maybe (Tempo, Maybe (NoteT sollu))
forall {g} {sollu}.
Flat g (Note sollu) -> Maybe (Tempo, Maybe (NoteT sollu))
noteOf (Flat g (Note sollu) -> Maybe (Tempo, Maybe (NoteT sollu)))
-> ((state, Flat g (Note sollu)) -> Flat g (Note sollu))
-> (state, Flat g (Note sollu))
-> Maybe (Tempo, Maybe (NoteT sollu))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (state, Flat g (Note sollu)) -> Flat g (Note sollu)
forall a b. (a, b) -> b
snd) [(state, Flat g (Note sollu))]
notes
    sollus :: [sollu]
sollus = (NoteT sollu -> sollu) -> [NoteT sollu] -> [sollu]
forall a b. (a -> b) -> [a] -> [b]
map NoteT sollu -> sollu
forall sollu. NoteT sollu -> sollu
Solkattu._sollu ([NoteT sollu] -> [sollu]) -> [NoteT sollu] -> [sollu]
forall a b. (a -> b) -> a -> b
$ ((Tempo, Maybe (NoteT sollu)) -> Maybe (NoteT sollu))
-> [(Tempo, Maybe (NoteT sollu))] -> [NoteT sollu]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Tempo, Maybe (NoteT sollu)) -> Maybe (NoteT sollu)
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,) (Maybe (NoteT sollu) -> (Tempo, Maybe (NoteT sollu)))
-> Maybe (Maybe (NoteT sollu))
-> Maybe (Tempo, Maybe (NoteT sollu))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Note sollu
n of
        Solkattu.Note NoteT sollu
n -> Maybe (NoteT sollu) -> Maybe (Maybe (NoteT sollu))
forall a. a -> Maybe a
Just (Maybe (NoteT sollu) -> Maybe (Maybe (NoteT sollu)))
-> Maybe (NoteT sollu) -> Maybe (Maybe (NoteT sollu))
forall a b. (a -> b) -> a -> b
$ NoteT sollu -> Maybe (NoteT sollu)
forall a. a -> Maybe a
Just NoteT sollu
n
        Solkattu.Space {} -> Maybe (NoteT sollu) -> Maybe (Maybe (NoteT sollu))
forall a. a -> Maybe a
Just Maybe (NoteT sollu)
forall a. Maybe a
Nothing
        Solkattu.Alignment {} -> Maybe (NoteT sollu) -> Maybe (Maybe (NoteT sollu))
forall a. a -> Maybe a
Just Maybe (NoteT sollu)
forall a. Maybe a
Nothing
        Solkattu.Pattern {} -> Maybe (Maybe (NoteT sollu))
forall a. Maybe a
Nothing
    noteOf (S.FGroup {}) = Maybe (Tempo, Maybe (NoteT sollu))
forall a. Maybe a
Nothing
    tag :: Maybe Tag
tag = NoteT sollu -> Maybe Tag
forall sollu. NoteT sollu -> Maybe Tag
Solkattu._tag (NoteT sollu -> Maybe Tag) -> Maybe (NoteT sollu) -> Maybe Tag
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [NoteT sollu] -> Maybe (NoteT sollu)
forall a. [a] -> Maybe a
Seq.head (((Tempo, Maybe (NoteT sollu)) -> Maybe (NoteT sollu))
-> [(Tempo, Maybe (NoteT sollu))] -> [NoteT sollu]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Tempo, Maybe (NoteT sollu)) -> Maybe (NoteT sollu)
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
_ -> ([(Tempo, Note stroke)] -> [(Tempo, Note stroke)])
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Tempo
tempo, Note stroke
rnote) :) (([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
 -> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))]))
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
forall a b. (a -> b) -> a -> b
$ [Maybe (Stroke stroke)]
-> [(state, Flat g (Note sollu))]
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
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 = Note stroke
-> (Stroke stroke -> Note stroke)
-> Maybe (Stroke stroke)
-> Note stroke
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Space -> Note stroke
forall stroke. Space -> Note stroke
Space Space
Solkattu.Rest) Stroke stroke -> Note stroke
forall stroke. Stroke stroke -> Note stroke
Note Maybe (Stroke stroke)
stroke
    Solkattu.Space Space
space -> ([(Tempo, Note stroke)] -> [(Tempo, Note stroke)])
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Tempo
tempo, Space -> Note stroke
forall stroke. Space -> Note stroke
Space Space
space) :) ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
next
    Solkattu.Alignment Int
a -> ([(Tempo, Note stroke)] -> [(Tempo, Note stroke)])
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Tempo
tempo, Int -> Note stroke
forall stroke. Int -> Note stroke
Alignment Int
a) :) ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
next
    -- This shouldn't happen because Seq.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 = [Maybe (Stroke stroke)]
-> [(state, Flat g (Note sollu))]
-> ([(Tempo, Note stroke)], [(state, Flat g (Note sollu))])
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 Maybe (Stroke stroke)
-> [Maybe (Stroke stroke)] -> [Maybe (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 = ([Stroke stroke] -> Maybe [Maybe (Stroke stroke)])
-> Maybe Tag -> [Stroke stroke] -> Maybe [Maybe (Stroke stroke)]
forall a b. a -> b -> a
const (([Stroke stroke] -> Maybe [Maybe (Stroke stroke)])
 -> Maybe Tag -> [Stroke stroke] -> Maybe [Maybe (Stroke stroke)])
-> ([Stroke stroke] -> Maybe [Maybe (Stroke stroke)])
-> Maybe Tag
-> [Stroke stroke]
-> Maybe [Maybe (Stroke stroke)]
forall a b. (a -> b) -> a -> b
$ [Maybe (Stroke stroke)] -> Maybe [Maybe (Stroke stroke)]
forall a. a -> Maybe a
Just ([Maybe (Stroke stroke)] -> Maybe [Maybe (Stroke stroke)])
-> ([Stroke stroke] -> [Maybe (Stroke stroke)])
-> [Stroke stroke]
-> Maybe [Maybe (Stroke stroke)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stroke stroke -> Maybe (Stroke stroke))
-> [Stroke stroke] -> [Maybe (Stroke stroke)]
forall a b. (a -> b) -> [a] -> [b]
map Stroke stroke -> Maybe (Stroke stroke)
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 :: SolluMap stroke -> ToStrokes (Stroke Solkattu.Sollu) stroke
realizeSollu :: forall stroke. SolluMap stroke -> ToStrokes (Stroke Sollu) stroke
realizeSollu (SolluMap Map (SolluMapKey Sollu) [Maybe (Stroke stroke)]
smap) = ToStrokes
    { _longestKey :: Int
_longestKey =
        Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Maybe Int
forall a. Ord a => [a] -> Maybe a
Seq.maximum ((SolluMapKey Sollu -> Int) -> [SolluMapKey Sollu] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Sollu] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Sollu] -> Int)
-> (SolluMapKey Sollu -> [Sollu]) -> SolluMapKey Sollu -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolluMapKey Sollu -> [Sollu]
forall a b. (a, b) -> b
snd) (Map (SolluMapKey Sollu) [Maybe (Stroke stroke)]
-> [SolluMapKey Sollu]
forall k a. Map k a -> [k]
Map.keys Map (SolluMapKey Sollu) [Maybe (Stroke stroke)]
smap))
    , _getStrokes :: Maybe Tag -> [Stroke Sollu] -> Maybe [Maybe (Stroke stroke)]
_getStrokes = \Maybe Tag
tag [Stroke Sollu]
sollus -> SolluMapKey Sollu
-> Map (SolluMapKey Sollu) [Maybe (Stroke stroke)]
-> Maybe [Maybe (Stroke stroke)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Maybe Tag
tag, (Stroke Sollu -> Sollu) -> [Stroke Sollu] -> [Sollu]
forall a b. (a -> b) -> [a] -> [b]
map Stroke Sollu -> Sollu
forall stroke. Stroke stroke -> stroke
_stroke [Stroke Sollu]
sollus) Map (SolluMapKey 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.
    [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
-> Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
forall a. [a] -> Maybe a
Seq.head (Maybe Tag
-> [[sollu]] -> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
find Maybe Tag
tag [[sollu]]
prefixes) Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
-> Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
-> Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
-> Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
forall a. [a] -> Maybe a
Seq.head (Maybe Tag
-> [[sollu]] -> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
find Maybe Tag
forall a. Maybe a
Nothing [[sollu]]
prefixes)
    where
    find :: Maybe Tag
-> [[sollu]] -> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
find Maybe Tag
tag = ([sollu] -> Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)]))
-> [[sollu]] -> [(SolluMapKey sollu, [Maybe (Stroke stroke)])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\[sollu]
s -> ((Maybe Tag
tag, [sollu]
s),) ([Maybe (Stroke stroke)]
 -> (SolluMapKey sollu, [Maybe (Stroke stroke)]))
-> Maybe [Maybe (Stroke stroke)]
-> Maybe (SolluMapKey sollu, [Maybe (Stroke stroke)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ToStrokes sollu stroke
-> Maybe Tag -> [sollu] -> Maybe [Maybe (Stroke stroke)]
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 = [[sollu]] -> [[sollu]]
forall a. [a] -> [a]
reverse ([[sollu]] -> [[sollu]]) -> [[sollu]] -> [[sollu]]
forall a b. (a -> b) -> a -> b
$ Int -> [[sollu]] -> [[sollu]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[sollu]] -> [[sollu]]) -> [[sollu]] -> [[sollu]]
forall a b. (a -> b) -> a -> b
$ [sollu] -> [[sollu]]
forall a. [a] -> [[a]]
List.inits ([sollu] -> [[sollu]]) -> [sollu] -> [[sollu]]
forall a b. (a -> b) -> a -> b
$
        Int -> [sollu] -> [sollu]
forall a. Int -> [a] -> [a]
take (ToStrokes sollu stroke -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Text
text
    | Bool
otherwise = Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate (Int
n Int -> Int -> Int
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 = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum ([Int] -> Int) -> (Text -> [Int]) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
forall {a}. Num a => Char -> a
len (String -> [Int]) -> (Text -> String) -> Text -> [Int]
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