-- Copyright 2018 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

-- | Utilities shared among formatting backends.
module Solkattu.Format.Format (
    Abstraction, isAbstract
    , abstract, named, unnamed
    , defaultAbstraction, allAbstract
    , Highlight(..)
    -- * score
    , scoreInstruments
    -- * group
    , Flat
    , convertGroups, mapGroups
    -- * normalize speed
    , NormalizedFlat
    , makeGroupsAbstract, makeGroupsAbstractScore, normalizeSpeed
    -- * tala
    , breakAvartanams, formatFinalAvartanam
    , onSam, onAnga, onAkshara, angaSet
    -- * ruler
    , Ruler, PrevRuler, pairWithRuler
    , inferRuler
    -- * metadata
    , showTags
    -- * util
    , mapSnd
) where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Seq as Seq

import qualified Solkattu.Korvai as Korvai
import qualified Solkattu.Realize as Realize
import qualified Solkattu.S as S
import qualified Solkattu.Solkattu as Solkattu
import qualified Solkattu.Tags as Tags
import qualified Solkattu.Tala as Tala

import           Global


-- | Control what is rendered as strokes, and what is rendered as abstract
-- groups with durations.
newtype Abstraction = Abstraction (Set (Solkattu.GroupType, Named))
    deriving (Abstraction -> Abstraction -> Bool
(Abstraction -> Abstraction -> Bool)
-> (Abstraction -> Abstraction -> Bool) -> Eq Abstraction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Abstraction -> Abstraction -> Bool
$c/= :: Abstraction -> Abstraction -> Bool
== :: Abstraction -> Abstraction -> Bool
$c== :: Abstraction -> Abstraction -> Bool
Eq, Int -> Abstraction -> ShowS
[Abstraction] -> ShowS
Abstraction -> String
(Int -> Abstraction -> ShowS)
-> (Abstraction -> String)
-> ([Abstraction] -> ShowS)
-> Show Abstraction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Abstraction] -> ShowS
$cshowList :: [Abstraction] -> ShowS
show :: Abstraction -> String
$cshow :: Abstraction -> String
showsPrec :: Int -> Abstraction -> ShowS
$cshowsPrec :: Int -> Abstraction -> ShowS
Show, NonEmpty Abstraction -> Abstraction
Abstraction -> Abstraction -> Abstraction
(Abstraction -> Abstraction -> Abstraction)
-> (NonEmpty Abstraction -> Abstraction)
-> (forall b. Integral b => b -> Abstraction -> Abstraction)
-> Semigroup Abstraction
forall b. Integral b => b -> Abstraction -> Abstraction
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Abstraction -> Abstraction
$cstimes :: forall b. Integral b => b -> Abstraction -> Abstraction
sconcat :: NonEmpty Abstraction -> Abstraction
$csconcat :: NonEmpty Abstraction -> Abstraction
<> :: Abstraction -> Abstraction -> Abstraction
$c<> :: Abstraction -> Abstraction -> Abstraction
Semigroup, Semigroup Abstraction
Abstraction
Semigroup Abstraction
-> Abstraction
-> (Abstraction -> Abstraction -> Abstraction)
-> ([Abstraction] -> Abstraction)
-> Monoid Abstraction
[Abstraction] -> Abstraction
Abstraction -> Abstraction -> Abstraction
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Abstraction] -> Abstraction
$cmconcat :: [Abstraction] -> Abstraction
mappend :: Abstraction -> Abstraction -> Abstraction
$cmappend :: Abstraction -> Abstraction -> Abstraction
mempty :: Abstraction
$cmempty :: Abstraction
Monoid)

data Named = Unnamed | Named deriving (Named -> Named -> Bool
(Named -> Named -> Bool) -> (Named -> Named -> Bool) -> Eq Named
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Named -> Named -> Bool
$c/= :: Named -> Named -> Bool
== :: Named -> Named -> Bool
$c== :: Named -> Named -> Bool
Eq, Eq Named
Eq Named
-> (Named -> Named -> Ordering)
-> (Named -> Named -> Bool)
-> (Named -> Named -> Bool)
-> (Named -> Named -> Bool)
-> (Named -> Named -> Bool)
-> (Named -> Named -> Named)
-> (Named -> Named -> Named)
-> Ord Named
Named -> Named -> Bool
Named -> Named -> Ordering
Named -> Named -> Named
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 :: Named -> Named -> Named
$cmin :: Named -> Named -> Named
max :: Named -> Named -> Named
$cmax :: Named -> Named -> Named
>= :: Named -> Named -> Bool
$c>= :: Named -> Named -> Bool
> :: Named -> Named -> Bool
$c> :: Named -> Named -> Bool
<= :: Named -> Named -> Bool
$c<= :: Named -> Named -> Bool
< :: Named -> Named -> Bool
$c< :: Named -> Named -> Bool
compare :: Named -> Named -> Ordering
$ccompare :: Named -> Named -> Ordering
Ord, Int -> Named -> ShowS
[Named] -> ShowS
Named -> String
(Int -> Named -> ShowS)
-> (Named -> String) -> ([Named] -> ShowS) -> Show Named
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Named] -> ShowS
$cshowList :: [Named] -> ShowS
show :: Named -> String
$cshow :: Named -> String
showsPrec :: Int -> Named -> ShowS
$cshowsPrec :: Int -> Named -> ShowS
Show)

isAbstract :: Abstraction -> Solkattu.Meta -> Bool
isAbstract :: Abstraction -> Meta -> Bool
isAbstract (Abstraction Set (GroupType, Named)
abstract) Meta
group = (GroupType, Named) -> Set (GroupType, Named) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (GroupType
gtype, Named
isNamed) Set (GroupType, Named)
abstract
    where
    gtype :: GroupType
gtype = Meta -> GroupType
Solkattu._type Meta
group
    isNamed :: Named
isNamed = case Meta -> Maybe Text
Solkattu._name Meta
group of
        Maybe Text
Nothing -> Named
Unnamed
        Just Text
_ -> Named
Named

abstract, named, unnamed :: Solkattu.GroupType -> Abstraction
abstract :: GroupType -> Abstraction
abstract GroupType
gtype = Set (GroupType, Named) -> Abstraction
Abstraction (Set (GroupType, Named) -> Abstraction)
-> Set (GroupType, Named) -> Abstraction
forall a b. (a -> b) -> a -> b
$ [(GroupType, Named)] -> Set (GroupType, Named)
forall a. Ord a => [a] -> Set a
Set.fromList [(GroupType
gtype, Named
Named), (GroupType
gtype, Named
Unnamed)]
named :: GroupType -> Abstraction
named GroupType
gtype = Set (GroupType, Named) -> Abstraction
Abstraction (Set (GroupType, Named) -> Abstraction)
-> Set (GroupType, Named) -> Abstraction
forall a b. (a -> b) -> a -> b
$ (GroupType, Named) -> Set (GroupType, Named)
forall a. a -> Set a
Set.singleton (GroupType
gtype, Named
Named)
unnamed :: GroupType -> Abstraction
unnamed GroupType
gtype = Set (GroupType, Named) -> Abstraction
Abstraction (Set (GroupType, Named) -> Abstraction)
-> Set (GroupType, Named) -> Abstraction
forall a b. (a -> b) -> a -> b
$ (GroupType, Named) -> Set (GroupType, Named)
forall a. a -> Set a
Set.singleton (GroupType
gtype, Named
Unnamed)

defaultAbstraction :: Abstraction
defaultAbstraction :: Abstraction
defaultAbstraction = [Abstraction] -> Abstraction
forall a. Monoid a => [a] -> a
mconcat
    [ GroupType -> Abstraction
abstract GroupType
Solkattu.GPattern
    , GroupType -> Abstraction
abstract GroupType
Solkattu.GSarva
    , GroupType -> Abstraction
named GroupType
Solkattu.GGroup
    ]

allAbstract :: Abstraction
allAbstract :: Abstraction
allAbstract = Set (GroupType, Named) -> Abstraction
Abstraction (Set (GroupType, Named) -> Abstraction)
-> Set (GroupType, Named) -> Abstraction
forall a b. (a -> b) -> a -> b
$ [(GroupType, Named)] -> Set (GroupType, Named)
forall a. Ord a => [a] -> Set a
Set.fromList
    [ (GroupType
gtype, Named
named)
    | GroupType
gtype <- [GroupType]
Solkattu.groupTypes, Named
named <- [Named
Unnamed, Named
Named]
    ]

data Highlight = StartHighlight | Highlight | EndHighlight
    deriving (Highlight -> Highlight -> Bool
(Highlight -> Highlight -> Bool)
-> (Highlight -> Highlight -> Bool) -> Eq Highlight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Highlight -> Highlight -> Bool
$c/= :: Highlight -> Highlight -> Bool
== :: Highlight -> Highlight -> Bool
$c== :: Highlight -> Highlight -> Bool
Eq, Int -> Highlight -> ShowS
[Highlight] -> ShowS
Highlight -> String
(Int -> Highlight -> ShowS)
-> (Highlight -> String)
-> ([Highlight] -> ShowS)
-> Show Highlight
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Highlight] -> ShowS
$cshowList :: [Highlight] -> ShowS
show :: Highlight -> String
$cshow :: Highlight -> String
showsPrec :: Int -> Highlight -> ShowS
$cshowsPrec :: Int -> Highlight -> ShowS
Show)

-- * score

scoreInstruments :: Korvai.Score -> [Korvai.GInstrument]
scoreInstruments :: Score -> [GInstrument]
scoreInstruments =
    (GInstrument -> Text) -> [GInstrument] -> [GInstrument]
forall k a. Eq k => (a -> k) -> [a] -> [a]
Seq.drop_dups GInstrument -> Text
name ([GInstrument] -> [GInstrument])
-> (Score -> [GInstrument]) -> Score -> [GInstrument]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GInstrument -> (Int, Text)) -> [GInstrument] -> [GInstrument]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on (Text -> (Int, Text)
forall {b}. (Eq b, IsString b) => b -> (Int, b)
order (Text -> (Int, Text))
-> (GInstrument -> Text) -> GInstrument -> (Int, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GInstrument -> Text
name)
        ([GInstrument] -> [GInstrument])
-> (Score -> [GInstrument]) -> Score -> [GInstrument]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Korvai -> [GInstrument]) -> [Korvai] -> [GInstrument]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Korvai -> [GInstrument]
Korvai.korvaiInstruments ([Korvai] -> [GInstrument])
-> (Score -> [Korvai]) -> Score -> [GInstrument]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Score -> [Korvai]
Korvai.scoreKorvais
    where
    name :: GInstrument -> Text
name = GInstrument -> Text
Korvai.ginstrumentName
    order :: b -> (Int, b)
order b
name = (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
999 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ b -> [b] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex b
name [b]
prio, b
name)
        where prio :: [b]
prio = [b
"konnakol", b
"mridangam"]

-- * group

type Flat stroke = S.Flat Solkattu.Meta (Realize.Note stroke)

-- | Reduce 'Realize.Group's to local 'Group's.
convertGroups :: [Either Korvai.Error ([Korvai.Flat stroke], warnings)]
    -> [Either Korvai.Error ([Flat stroke], warnings)]
convertGroups :: forall stroke warnings.
[Either Text ([Flat stroke], warnings)]
-> [Either Text ([Flat stroke], warnings)]
convertGroups = (Either Text ([Flat stroke], warnings)
 -> Either Text ([Flat stroke], warnings))
-> [Either Text ([Flat stroke], warnings)]
-> [Either Text ([Flat stroke], warnings)]
forall a b. (a -> b) -> [a] -> [b]
map ((([Flat stroke], warnings) -> ([Flat stroke], warnings))
-> Either Text ([Flat stroke], warnings)
-> Either Text ([Flat stroke], warnings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Flat stroke] -> [Flat stroke])
-> ([Flat stroke], warnings) -> ([Flat stroke], warnings)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Flat stroke] -> [Flat stroke]
forall stroke a. [Flat (Group stroke) a] -> [Flat Meta a]
mapGroups))

mapGroups :: [S.Flat (Realize.Group stroke) a] -> [S.Flat Solkattu.Meta a]
mapGroups :: forall stroke a. [Flat (Group stroke) a] -> [Flat Meta a]
mapGroups = (Group stroke -> Meta) -> [Flat (Group stroke) a] -> [Flat Meta a]
forall g h a. (g -> h) -> [Flat g a] -> [Flat h a]
S.mapGroupFlat Group stroke -> Meta
forall stroke. Group stroke -> Meta
groupToMeta

groupToMeta :: Realize.Group stroke -> Solkattu.Meta
groupToMeta :: forall stroke. Group stroke -> Meta
groupToMeta (Realize.GReduction Reduction stroke
_) = Solkattu.Meta
    { _matras :: Maybe Int
_matras = Maybe Int
forall a. Maybe a
Nothing -- TODO pick a real duration?
    , _name :: Maybe Text
_name = Maybe Text
forall a. Maybe a
Nothing
    , _type :: GroupType
_type = GroupType
Solkattu.GReductionT
    }
groupToMeta (Realize.GMeta Meta
meta) = Meta
meta

-- * normalize speed

-- | 'Flat' after 'normalizeSpeed'.
type NormalizedFlat stroke =
    S.Flat Solkattu.Meta (S.State, S.Stroke (Realize.Note stroke))

makeGroupsAbstract :: Abstraction
    -> [NormalizedFlat stroke] -> [NormalizedFlat stroke]
makeGroupsAbstract :: forall stroke.
Abstraction -> [NormalizedFlat stroke] -> [NormalizedFlat stroke]
makeGroupsAbstract Abstraction
abstraction = (NormalizedFlat stroke -> [NormalizedFlat stroke])
-> [NormalizedFlat stroke] -> [NormalizedFlat stroke]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NormalizedFlat stroke -> [NormalizedFlat stroke]
forall {a} {stroke}.
Flat Meta (a, Stroke (Note stroke))
-> [Flat Meta (a, Stroke (Note stroke))]
combine
    where
    combine :: Flat Meta (a, Stroke (Note stroke))
-> [Flat Meta (a, Stroke (Note stroke))]
combine (S.FGroup Tempo
tempo Meta
group [Flat Meta (a, Stroke (Note stroke))]
children)
        | Abstraction -> Meta -> Bool
isAbstract Abstraction
abstraction Meta
group =
            ((Tempo, (a, Stroke (Note stroke)))
 -> Flat Meta (a, Stroke (Note stroke)))
-> ((Tempo, (a, Stroke (Note stroke)))
    -> Flat Meta (a, Stroke (Note stroke)))
-> [(Tempo, (a, Stroke (Note stroke)))]
-> [Flat Meta (a, Stroke (Note stroke))]
forall a b. (a -> b) -> (a -> b) -> [a] -> [b]
Seq.map_head_tail ((Note stroke -> Stroke (Note stroke))
-> (Tempo, (a, Stroke (Note stroke)))
-> Flat Meta (a, Stroke (Note stroke))
forall {stroke} {b} {a} {b} {g}.
(Note stroke -> b) -> (Tempo, (a, b)) -> Flat g (a, b)
abstract Note stroke -> Stroke (Note stroke)
forall a. a -> Stroke a
S.Attack) ((Note stroke -> Stroke (Note stroke))
-> (Tempo, (a, Stroke (Note stroke)))
-> Flat Meta (a, Stroke (Note stroke))
forall {stroke} {b} {a} {b} {g}.
(Note stroke -> b) -> (Tempo, (a, b)) -> Flat g (a, b)
abstract Note stroke -> Stroke (Note stroke)
forall a. a -> Stroke a
S.Sustain)
                [(Tempo, (a, Stroke (Note stroke)))]
tempoNotes
        | Bool
otherwise = [Tempo
-> Meta
-> [Flat Meta (a, Stroke (Note stroke))]
-> Flat Meta (a, Stroke (Note stroke))
forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo Meta
group ((Flat Meta (a, Stroke (Note stroke))
 -> [Flat Meta (a, Stroke (Note stroke))])
-> [Flat Meta (a, Stroke (Note stroke))]
-> [Flat Meta (a, Stroke (Note stroke))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Flat Meta (a, Stroke (Note stroke))
-> [Flat Meta (a, Stroke (Note stroke))]
combine [Flat Meta (a, Stroke (Note stroke))]
children)]
        where
        gtype :: GroupType
gtype = Meta -> GroupType
Solkattu._type Meta
group
        tempoNotes :: [(Tempo, (a, Stroke (Note stroke)))]
tempoNotes  = [Flat Meta (a, Stroke (Note stroke))]
-> [(Tempo, (a, Stroke (Note stroke)))]
forall g a. [Flat g a] -> [(Tempo, a)]
S.tempoNotes [Flat Meta (a, Stroke (Note stroke))]
children
        abstract :: (Note stroke -> b) -> (Tempo, (a, b)) -> Flat g (a, b)
abstract Note stroke -> b
c = b -> (Tempo, (a, b)) -> Flat g (a, b)
forall {b} {a} {b} {g}. b -> (Tempo, (a, b)) -> Flat g (a, b)
replace (b -> (Tempo, (a, b)) -> Flat g (a, b))
-> b -> (Tempo, (a, b)) -> Flat g (a, b)
forall a b. (a -> b) -> a -> b
$ Note stroke -> b
c (Note stroke -> b) -> Note stroke -> b
forall a b. (a -> b) -> a -> b
$ Meta -> Note stroke
forall stroke. Meta -> Note stroke
Realize.Abstract (Meta -> Note stroke) -> Meta -> Note stroke
forall a b. (a -> b) -> a -> b
$
            -- Some groups are named by their duration.  Since the next stop is
            -- the HasMatras instance, I put them name on here, when I still
            -- have access to the children duration.
            if Meta -> Maybe Text
Solkattu._name Meta
group Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& GroupType
gtype GroupType -> [GroupType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GroupType]
nameFromDur
                then Meta
group
                    { _name :: Maybe Text
Solkattu._name = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
                        Bool -> FMatra -> Text
forall a. (RealFrac a, Pretty a) => Bool -> a -> Text
Pretty.fraction Bool
True FMatra
fmatras Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupType -> Text
Realize.typeName GroupType
gtype
                    }
                else Meta
group
        fmatras :: FMatra
fmatras = Tempo -> Duration -> FMatra
S.durationFMatra Tempo
tempo (Duration -> FMatra) -> Duration -> FMatra
forall a b. (a -> b) -> a -> b
$
            [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
$ ((Tempo, (a, Stroke (Note stroke))) -> Duration)
-> [(Tempo, (a, Stroke (Note stroke)))] -> [Duration]
forall a b. (a -> b) -> [a] -> [b]
map (Tempo -> Duration
S.matraDuration (Tempo -> Duration)
-> ((Tempo, (a, Stroke (Note stroke))) -> Tempo)
-> (Tempo, (a, Stroke (Note stroke)))
-> Duration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tempo, (a, Stroke (Note stroke))) -> Tempo
forall a b. (a, b) -> a
fst) [(Tempo, (a, Stroke (Note stroke)))]
tempoNotes
        replace :: b -> (Tempo, (a, b)) -> Flat g (a, b)
replace b
n (Tempo
tempo, (a
state, b
_)) = Tempo -> (a, b) -> Flat g (a, b)
forall g a. Tempo -> a -> Flat g a
S.FNote Tempo
tempo (a
state, b
n)
    combine Flat Meta (a, Stroke (Note stroke))
n = [Flat Meta (a, Stroke (Note stroke))
n]
    nameFromDur :: [GroupType]
nameFromDur =
        [GroupType
Solkattu.GGroup, GroupType
Solkattu.GReductionT, GroupType
Solkattu.GExplicitPattern]

-- | Like 'makeGroupsAbstract' except for non-normalized 'Realize.realize'
-- output.  This is used by LSol, not Format, but is defined here since it's
-- doing the same thing.
makeGroupsAbstractScore :: Abstraction
    -> [S.Flat (Realize.Group a) (Realize.Note stroke)]
    -> [S.Flat (Realize.Group a) (Realize.Note stroke)]
makeGroupsAbstractScore :: forall a stroke.
Abstraction
-> [Flat (Group a) (Note stroke)] -> [Flat (Group a) (Note stroke)]
makeGroupsAbstractScore Abstraction
abstraction = (Flat (Group a) (Note stroke) -> [Flat (Group a) (Note stroke)])
-> [Flat (Group a) (Note stroke)] -> [Flat (Group a) (Note stroke)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Flat (Group a) (Note stroke) -> [Flat (Group a) (Note stroke)]
forall {stroke} {stroke}.
Flat (Group stroke) (Note stroke)
-> [Flat (Group stroke) (Note stroke)]
combine
    where
    combine :: Flat (Group stroke) (Note stroke)
-> [Flat (Group stroke) (Note stroke)]
combine (S.FGroup Tempo
tempo Group stroke
group [Flat (Group stroke) (Note stroke)]
children)
        | Abstraction -> Meta -> Bool
isAbstract Abstraction
abstraction Meta
meta = (Flat (Group stroke) (Note stroke)
-> [Flat (Group stroke) (Note stroke)]
-> [Flat (Group stroke) (Note stroke)]
forall a. a -> [a] -> [a]
:[]) (Flat (Group stroke) (Note stroke)
 -> [Flat (Group stroke) (Note stroke)])
-> Flat (Group stroke) (Note stroke)
-> [Flat (Group stroke) (Note stroke)]
forall a b. (a -> b) -> a -> b
$
            Tempo -> Note stroke -> Flat (Group stroke) (Note stroke)
forall g a. Tempo -> a -> Flat g a
S.FNote Tempo
tempo (Note stroke -> Flat (Group stroke) (Note stroke))
-> Note stroke -> Flat (Group stroke) (Note stroke)
forall a b. (a -> b) -> a -> b
$ Meta -> Note stroke
forall stroke. Meta -> Note stroke
Realize.Abstract Meta
meta
        | Bool
otherwise = [Tempo
-> Group stroke
-> [Flat (Group stroke) (Note stroke)]
-> Flat (Group stroke) (Note stroke)
forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo Group stroke
group ((Flat (Group stroke) (Note stroke)
 -> [Flat (Group stroke) (Note stroke)])
-> [Flat (Group stroke) (Note stroke)]
-> [Flat (Group stroke) (Note stroke)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Flat (Group stroke) (Note stroke)
-> [Flat (Group stroke) (Note stroke)]
combine [Flat (Group stroke) (Note stroke)]
children)]
        where meta :: Meta
meta = Group stroke -> Meta
forall stroke. Group stroke -> Meta
groupToMeta Group stroke
group
    combine Flat (Group stroke) (Note stroke)
n = [Flat (Group stroke) (Note stroke)
n]

normalizeSpeed :: S.Speed -> Tala.Tala -> [Flat stroke]
    -> [NormalizedFlat stroke]
normalizeSpeed :: forall stroke.
Int -> Tala -> [Flat stroke] -> [NormalizedFlat stroke]
normalizeSpeed Int
toSpeed Tala
tala =
    (Flat Meta (State, Stroke (Note stroke))
 -> Flat Meta (State, Stroke (Note stroke)))
-> [Flat Meta (State, Stroke (Note stroke))]
-> [Flat Meta (State, Stroke (Note stroke))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((State, Stroke (Note stroke)) -> (State, Stroke (Note stroke)))
-> Flat Meta (State, Stroke (Note stroke))
-> Flat Meta (State, Stroke (Note stroke))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Stroke (Note stroke) -> Stroke (Note stroke))
-> (State, Stroke (Note stroke)) -> (State, Stroke (Note stroke))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stroke (Note stroke) -> Stroke (Note stroke)
forall a. Stroke (Note a) -> Stroke (Note a)
normalizeRest)) ([Flat Meta (State, Stroke (Note stroke))]
 -> [Flat Meta (State, Stroke (Note stroke))])
-> ([Flat stroke] -> [Flat Meta (State, Stroke (Note stroke))])
-> [Flat stroke]
-> [Flat Meta (State, Stroke (Note stroke))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Tala
-> [Flat stroke]
-> [Flat Meta (State, Stroke (Note stroke))]
forall a g.
HasMatras a =>
Int -> Tala -> [Flat g a] -> [Flat g (State, Stroke a)]
S.normalizeSpeed Int
toSpeed Tala
tala
    ([Flat stroke] -> [Flat Meta (State, Stroke (Note stroke))])
-> ([Flat stroke] -> [Flat stroke])
-> [Flat stroke]
-> [Flat Meta (State, Stroke (Note stroke))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Note stroke -> Bool) -> [Flat stroke] -> [Flat stroke]
forall a g. (a -> Bool) -> [Flat g a] -> [Flat g a]
S.filterFlat (Bool -> Bool
not (Bool -> Bool) -> (Note stroke -> Bool) -> Note stroke -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note stroke -> Bool
forall {stroke}. Note stroke -> Bool
isAlignment)
    where
    isAlignment :: Note stroke -> Bool
isAlignment (Realize.Alignment {}) = Bool
True
    isAlignment Note stroke
_ = Bool
False

-- | Rests are special in that S.normalizeSpeed can produce them.  Normalize
-- them to force them to all be treated the same way.
normalizeRest :: S.Stroke (Realize.Note a) -> S.Stroke (Realize.Note a)
normalizeRest :: forall a. Stroke (Note a) -> Stroke (Note a)
normalizeRest (S.Attack (Realize.Space Space
Solkattu.Rest)) = Stroke (Note a)
forall a. Stroke a
S.Rest
normalizeRest (S.Sustain (Realize.Space Space
Solkattu.Rest)) = Stroke (Note a)
forall a. Stroke a
S.Rest
normalizeRest Stroke (Note a)
a = Stroke (Note a)
a

-- * tala

-- | Split on sam.
breakAvartanams :: [(S.State, a)] -> [[(S.State, a)]]
breakAvartanams :: forall a. [(State, a)] -> [[(State, a)]]
breakAvartanams = ([(State, a)] -> Bool) -> [[(State, a)]] -> [[(State, a)]]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile [(State, a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[(State, a)]] -> [[(State, a)]])
-> ([(State, a)] -> [[(State, a)]])
-> [(State, a)]
-> [[(State, a)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((State, a) -> Bool) -> [(State, a)] -> [[(State, a)]]
forall a. (a -> Bool) -> [a] -> [[a]]
Seq.split_before (State -> Bool
onSam (State -> Bool) -> ((State, a) -> State) -> (State, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State, a) -> State
forall a b. (a, b) -> a
fst)

-- | If the final non-rest is at sam, drop trailing rests, and don't wrap it
-- onto the next line.
formatFinalAvartanam :: (note -> Bool) -> [[[(a, note)]]]
    -- ^ [avartanams], broken by lines
    -> [[[(a, note)]]]
formatFinalAvartanam :: forall note a. (note -> Bool) -> [[[(a, note)]]] -> [[[(a, note)]]]
formatFinalAvartanam note -> Bool
isRest [[[(a, note)]]]
avartanams = case [[[(a, note)]]] -> [[[(a, note)]]]
forall a. [a] -> [a]
reverse [[[(a, note)]]]
avartanams of
    [(a, note)
final : [(a, note)]
rests] : [[(a, note)]]
penultimate : [[[(a, note)]]]
prevs
        | Bool -> Bool
not (note -> Bool
isRest ((a, note) -> note
forall a b. (a, b) -> b
snd (a, note)
final)) Bool -> Bool -> Bool
&& ((a, note) -> Bool) -> [(a, note)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (note -> Bool
isRest (note -> Bool) -> ((a, note) -> note) -> (a, note) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, note) -> note
forall a b. (a, b) -> b
snd) [(a, note)]
rests ->
            [[[(a, note)]]] -> [[[(a, note)]]]
forall a. [a] -> [a]
reverse ([[[(a, note)]]] -> [[[(a, note)]]])
-> [[[(a, note)]]] -> [[[(a, note)]]]
forall a b. (a -> b) -> a -> b
$ (([(a, note)] -> [(a, note)]) -> [[(a, note)]] -> [[(a, note)]]
forall a. (a -> a) -> [a] -> [a]
Seq.map_last ([(a, note)] -> [(a, note)] -> [(a, note)]
forall a. [a] -> [a] -> [a]
++[(a, note)
final]) [[(a, note)]]
penultimate) [[(a, note)]] -> [[[(a, note)]]] -> [[[(a, note)]]]
forall a. a -> [a] -> [a]
: [[[(a, note)]]]
prevs
        | Bool
otherwise -> [[[(a, note)]]]
avartanams
    [[[(a, note)]]]
_ -> [[[(a, note)]]]
avartanams

onSam :: S.State -> Bool
onSam :: State -> Bool
onSam State
state = State -> Duration
S.stateMatra State
state Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
== Duration
0 Bool -> Bool -> Bool
&& State -> Int
S.stateAkshara State
state Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

onAnga :: Set Tala.Akshara -> S.State -> Bool
onAnga :: Set Int -> State -> Bool
onAnga Set Int
angas State
state =
    State -> Duration
S.stateMatra State
state Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
== Duration
0 Bool -> Bool -> Bool
&& Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (State -> Int
S.stateAkshara State
state) Set Int
angas

onAkshara :: S.State -> Bool
onAkshara :: State -> Bool
onAkshara State
state = State -> Duration
S.stateMatra State
state Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
== Duration
0

angaSet :: Tala.Tala -> Set Tala.Akshara
angaSet :: Tala -> Set Int
angaSet = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> Set Int) -> (Tala -> [Int]) -> Tala -> Set Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 ([Int] -> [Int]) -> (Tala -> [Int]) -> Tala -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tala -> [Int]
Tala.tala_angas

-- * ruler

-- | (mark, width)
type Ruler = [(Text, Int)]

-- | (prevRuler, linesSinceLastRuler)
type PrevRuler = (Maybe Ruler, Int)
type Line sym = [(S.State, sym)]

pairWithRuler :: Int -> PrevRuler -> Tala.Tala -> Int
    -> [[Line sym]] -> (PrevRuler, [[(Maybe Ruler, Line sym)]])
pairWithRuler :: forall sym.
Int
-> PrevRuler
-> Tala
-> Int
-> [[Line sym]]
-> (PrevRuler, [[(Maybe Ruler, Line sym)]])
pairWithRuler Int
rulerEach PrevRuler
prevRuler Tala
tala Int
strokeWidth =
    (PrevRuler
 -> [(Ruler, Line sym)] -> (PrevRuler, [(Maybe Ruler, Line sym)]))
-> PrevRuler
-> [[(Ruler, Line sym)]]
-> (PrevRuler, [[(Maybe Ruler, Line sym)]])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL ((PrevRuler
 -> (Ruler, Line sym) -> (PrevRuler, (Maybe Ruler, Line sym)))
-> PrevRuler
-> [(Ruler, Line sym)]
-> (PrevRuler, [(Maybe Ruler, Line sym)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL PrevRuler
-> (Ruler, Line sym) -> (PrevRuler, (Maybe Ruler, Line sym))
forall {b} {b}.
(Num b, Eq b) =>
(Maybe [(Text, b)], Int)
-> ([(Text, b)], b)
-> ((Maybe [(Text, b)], Int), (Maybe [(Text, b)], b))
strip) PrevRuler
prevRuler
    ([[(Ruler, Line sym)]] -> (PrevRuler, [[(Maybe Ruler, Line sym)]]))
-> ([[Line sym]] -> [[(Ruler, Line sym)]])
-> [[Line sym]]
-> (PrevRuler, [[(Maybe Ruler, Line sym)]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Ruler, [[(Ruler, Line sym)]]) -> [[(Ruler, Line sym)]]
forall a b. (a, b) -> b
snd ((Maybe Ruler, [[(Ruler, Line sym)]]) -> [[(Ruler, Line sym)]])
-> ([[Line sym]] -> (Maybe Ruler, [[(Ruler, Line sym)]]))
-> [[Line sym]]
-> [[(Ruler, Line sym)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Ruler
 -> [(Ruler, Line sym)] -> (Maybe Ruler, [(Ruler, Line sym)]))
-> Maybe Ruler
-> [[(Ruler, Line sym)]]
-> (Maybe Ruler, [[(Ruler, Line sym)]])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL ((Maybe Ruler
 -> (Ruler, Line sym) -> (Maybe Ruler, (Ruler, Line sym)))
-> Maybe Ruler
-> [(Ruler, Line sym)]
-> (Maybe Ruler, [(Ruler, Line sym)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Maybe Ruler
-> (Ruler, Line sym) -> (Maybe Ruler, (Ruler, Line sym))
forall {b}. Maybe Ruler -> (Ruler, b) -> (Maybe Ruler, (Ruler, b))
inherit) (PrevRuler -> Maybe Ruler
forall a b. (a, b) -> a
fst PrevRuler
prevRuler)
    ([[(Ruler, Line sym)]] -> (Maybe Ruler, [[(Ruler, Line sym)]]))
-> ([[Line sym]] -> [[(Ruler, Line sym)]])
-> [[Line sym]]
-> (Maybe Ruler, [[(Ruler, Line sym)]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Line sym] -> [(Ruler, Line sym)])
-> [[Line sym]] -> [[(Ruler, Line sym)]]
forall a b. (a -> b) -> [a] -> [b]
map ((Line sym -> (Ruler, Line sym))
-> [Line sym] -> [(Ruler, Line sym)]
forall a b. (a -> b) -> [a] -> [b]
map Line sym -> (Ruler, Line sym)
forall {b}. [(State, b)] -> (Ruler, [(State, b)])
addRuler)
    where
    addRuler :: [(State, b)] -> (Ruler, [(State, b)])
addRuler [(State, b)]
line =
        ( Int -> Tala -> Int -> [State] -> Ruler
inferRuler Int
akshara Tala
tala Int
strokeWidth (((State, b) -> State) -> [(State, b)] -> [State]
forall a b. (a -> b) -> [a] -> [b]
map (State, b) -> State
forall a b. (a, b) -> a
fst [(State, b)]
line)
        , [(State, b)]
line
        )
        where akshara :: Int
akshara = Int -> ((State, b) -> Int) -> Maybe (State, b) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (State -> Int
S.stateAkshara (State -> Int) -> ((State, b) -> State) -> (State, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State, b) -> State
forall a b. (a, b) -> a
fst) (Maybe (State, b) -> Int) -> Maybe (State, b) -> Int
forall a b. (a -> b) -> a -> b
$ [(State, b)] -> Maybe (State, b)
forall a. [a] -> Maybe a
Seq.head [(State, b)]
line

    inherit :: Maybe Ruler -> (Ruler, b) -> (Maybe Ruler, (Ruler, b))
inherit Maybe Ruler
Nothing (Ruler
ruler, b
line) = (Ruler -> Maybe Ruler
forall a. a -> Maybe a
Just Ruler
ruler, (Ruler
ruler, b
line))
    inherit (Just Ruler
prev) (Ruler
ruler, b
line) = (Ruler -> Maybe Ruler
forall a. a -> Maybe a
Just Ruler
cur, (Ruler
cur, b
line))
        where !cur :: Ruler
cur = Ruler -> Ruler -> Ruler
inheritRuler Ruler
prev Ruler
ruler
    -- Strip rulers when they are unchanged.  "Changed" is by structure, not
    -- mark text, so a wrapped ruler with the same structure will also be
    -- suppressed.
    strip :: (Maybe [(Text, b)], Int)
-> ([(Text, b)], b)
-> ((Maybe [(Text, b)], Int), (Maybe [(Text, b)], b))
strip (Maybe [(Text, b)]
prev, Int
lineNumber) ([(Text, b)]
ruler, b
line) =
        ( ([(Text, b)] -> Maybe [(Text, b)]
forall a. a -> Maybe a
Just [(Text, b)]
ruler, Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Bool
wanted then Int
0 else Int
lineNumber)
        , (if Bool
wanted then [(Text, b)] -> Maybe [(Text, b)]
forall a. a -> Maybe a
Just ([(Text, b)]
ruler [(Text, b)] -> [(Text, b)] -> [(Text, b)]
forall a. [a] -> [a] -> [a]
++ [(Text
"|", b
0)]) else Maybe [(Text, b)]
forall a. Maybe a
Nothing, b
line)
        )
        where
        wanted :: Bool
wanted =  Int
lineNumber Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
rulerEach Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
            Bool -> Bool -> Bool
|| [(Bool, b)] -> Maybe [(Bool, b)]
forall a. a -> Maybe a
Just ([(Text, b)] -> [(Bool, b)]
forall {b}. [(Text, b)] -> [(Bool, b)]
structure [(Text, b)]
ruler) Maybe [(Bool, b)] -> Maybe [(Bool, b)] -> Bool
forall a. Eq a => a -> a -> Bool
/= ([(Text, b)] -> [(Bool, b)]
forall {b}. [(Text, b)] -> [(Bool, b)]
structure ([(Text, b)] -> [(Bool, b)])
-> Maybe [(Text, b)] -> Maybe [(Bool, b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [(Text, b)]
prev)
    structure :: [(Text, b)] -> [(Bool, b)]
structure = ((Text, b) -> (Bool, b)) -> [(Text, b)] -> [(Bool, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
mark, b
width) -> (Text
mark Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
".", b
width))

-- | Fix the problem in 'inferRuler' by re-using the previous ruler if this one
-- is a subset of it.
inheritRuler :: Ruler -> Ruler -> Ruler
inheritRuler :: Ruler -> Ruler -> Ruler
inheritRuler Ruler
prev Ruler
cur
    | Ruler -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Ruler
cur Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Ruler -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Ruler
prev Bool -> Bool -> Bool
&& ((Text, Int) -> Int) -> Ruler -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Int) -> Int
forall a b. (a, b) -> b
snd Ruler
cur [Int] -> [Int] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` ((Text, Int) -> Int) -> Ruler -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Int) -> Int
forall a b. (a, b) -> b
snd Ruler
prev =
        Ruler
prev
    | Bool
otherwise = Ruler
cur

-- | Rather than generating the ruler purely from the Tala, I use the States
-- to figure out the mark spacing.  Otherwise I wouldn't know where nadai
-- changes occur.  But it does mean I can't generate ruler if I run out of
-- strokes, which is a bit annoying for incomplete korvais or ones with eddupu.
inferRuler :: Tala.Akshara -> Tala.Tala -> Int -> [S.State] -> Ruler
inferRuler :: Int -> Tala -> Int -> [State] -> Ruler
inferRuler Int
startAkshara Tala
tala Int
strokeWidth =
    Ruler -> Ruler
forall {b} {a}. (Eq b, Num b, Semigroup a) => [(a, b)] -> [(a, b)]
merge
    (Ruler -> Ruler) -> ([State] -> Ruler) -> [State] -> Ruler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [State]) -> (Text, Int)) -> [(Text, [State])] -> Ruler
forall a b. (a -> b) -> [a] -> [b]
map (([State] -> Int) -> (Text, [State]) -> (Text, Int)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [State] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)
    ([(Text, [State])] -> Ruler)
-> ([State] -> [(Text, [State])]) -> [State] -> Ruler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Text, [State])]] -> [(Text, [State])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Text, [State])]] -> [(Text, [State])])
-> ([State] -> [[(Text, [State])]]) -> [State] -> [(Text, [State])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [[(Text, [State])]]) -> [[(Text, [State])]]
forall a b. (a, b) -> b
snd ((Int, [[(Text, [State])]]) -> [[(Text, [State])]])
-> ([State] -> (Int, [[(Text, [State])]]))
-> [State]
-> [[(Text, [State])]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> (Text, [State]) -> (Int, [(Text, [State])]))
-> Int -> [(Text, [State])] -> (Int, [[(Text, [State])]])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Int -> (Text, [State]) -> (Int, [(Text, [State])])
insertNadai Int
0
    ([(Text, [State])] -> (Int, [[(Text, [State])]]))
-> ([State] -> [(Text, [State])])
-> [State]
-> (Int, [[(Text, [State])]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [State]) -> [(Text, [State])])
-> [(Text, [State])] -> [(Text, [State])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, [State]) -> [(Text, [State])]
forall {a} {a}. IsString a => (a, [a]) -> [(a, [a])]
insertDots
    ([(Text, [State])] -> [(Text, [State])])
-> ([State] -> [(Text, [State])]) -> [State] -> [(Text, [State])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [[State]] -> [(Text, [State])]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
startAkshara (Tala -> [Text]
Tala.tala_labels Tala
tala))
    ([[State]] -> [(Text, [State])])
-> ([State] -> [[State]]) -> [State] -> [(Text, [State])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([State] -> Bool) -> [[State]] -> [[State]]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile [State] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
    ([[State]] -> [[State]])
-> ([State] -> [[State]]) -> [State] -> [[State]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> Bool) -> [State] -> [[State]]
forall a. (a -> Bool) -> [a] -> [[a]]
Seq.split_before State -> Bool
onAkshara
    where
    -- Merge 0 dur marks with the next mark.  HTML output puts one mark per
    -- matra, so it can't have 0 dur marks.
    merge :: [(a, b)] -> [(a, b)]
merge ((a
n1, b
0) : (a
n2, b
spaces) : [(a, b)]
xs) = [(a, b)] -> [(a, b)]
merge ((a
n1a -> a -> a
forall a. Semigroup a => a -> a -> a
<>a
n2, b
spaces) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
xs)
    merge ((a
n, b
spaces) : [(a, b)]
xs) = (a
n, b
spaces) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, b)]
merge [(a, b)]
xs
    merge [(a, b)]
xs = [(a, b)]
xs
    insertNadai :: S.Nadai -> (Text, [S.State])
        -> (S.Nadai, [(Text, [S.State])])
    insertNadai :: Int -> (Text, [State]) -> (Int, [(Text, [State])])
insertNadai Int
prevNadai (Text
label, [State]
states) =
        ( Int -> ((Int, [State]) -> Int) -> Maybe (Int, [State]) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
prevNadai (Int, [State]) -> Int
forall a b. (a, b) -> a
fst ([(Int, [State])] -> Maybe (Int, [State])
forall a. [a] -> Maybe a
Seq.last [(Int, [State])]
groups)
        , case [(Int, [State])]
groups of
            (Int
nadai, [State]
states) : [(Int, [State])]
rest | Int
nadai Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
prevNadai ->
                (Text
label, [State]
states) (Text, [State]) -> [(Text, [State])] -> [(Text, [State])]
forall a. a -> [a] -> [a]
: ((Int, [State]) -> (Text, [State]))
-> [(Int, [State])] -> [(Text, [State])]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Text) -> (Int, [State]) -> (Text, [State])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Text
forall {a}. Show a => a -> Text
nadaiChange) [(Int, [State])]
rest
            [(Int, [State])]
_ -> (Text
label, []) (Text, [State]) -> [(Text, [State])] -> [(Text, [State])]
forall a. a -> [a] -> [a]
: ((Int, [State]) -> (Text, [State]))
-> [(Int, [State])] -> [(Text, [State])]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Text) -> (Int, [State]) -> (Text, [State])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Text
forall {a}. Show a => a -> Text
nadaiChange) [(Int, [State])]
groups
        )
        where
        groups :: [(Int, [State])]
groups = (State -> Int) -> [State] -> [(Int, [State])]
forall key a. Eq key => (a -> key) -> [a] -> [(key, [a])]
Seq.keyed_group_adjacent State -> Int
nadaiOf [State]
states
        nadaiOf :: State -> Int
nadaiOf = Tempo -> Int
S._nadai (Tempo -> Int) -> (State -> Tempo) -> State -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Tempo
S.stateTempo
    -- Marker for a nadai change.  It has a colon to separate it from the ruler
    -- mark, in case it coincides with one.
    nadaiChange :: a -> Text
nadaiChange a
n = Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall {a}. Show a => a -> Text
showt a
n
    -- Mark mark midpoints with dots if they're far enough apart, and do in
    -- fact have an integral midpoint.
    insertDots :: (a, [a]) -> [(a, [a])]
insertDots (a
label, [a]
states)
        | (Int
spaces Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strokeWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8) Bool -> Bool -> Bool
&& Int
spaces Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
            [(a
label, [a]
pre) , (a
".", [a]
post)]
        | Bool
otherwise = [(a
label, [a]
states)]
        where
        ([a]
pre, [a]
post) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
spaces Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [a]
states
        spaces :: Int
spaces = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
states

-- * metadata

showTags :: Tags.Tags -> Text
showTags :: Tags -> Text
showTags Tags
tags = case Text -> Map Text [Text] -> Maybe [Text]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
Tags.times (Tags -> Map Text [Text]
Tags.untags Tags
tags) of
    Just [Text
n] -> Text
"x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n
    Maybe [Text]
_ -> Text
""

-- * util

-- | This assumes the function doesn't change the length of the list!
mapSnd :: ([a] -> [b]) -> [(x, a)] -> [(x, b)]
mapSnd :: forall a b x. ([a] -> [b]) -> [(x, a)] -> [(x, b)]
mapSnd [a] -> [b]
f [(x, a)]
xas = [x] -> [b] -> [(x, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [x]
xs ([a] -> [b]
f [a]
as)
    where ([x]
xs, [a]
as) = [(x, a)] -> ([x], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip [(x, a)]
xas