-- 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.Lists as Lists
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty

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 qualified Solkattu.Talas as Talas

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
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
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
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
[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
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
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
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 = 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a. a -> Set a
Set.singleton (GroupType
gtype, Named
Named)
unnamed :: GroupType -> Abstraction
unnamed GroupType
gtype = Set (GroupType, Named) -> Abstraction
Abstraction forall a b. (a -> b) -> a -> b
$ forall a. a -> Set a
Set.singleton (GroupType
gtype, Named
Unnamed)

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

allAbstract :: Abstraction
allAbstract :: Abstraction
allAbstract = Set (GroupType, Named) -> Abstraction
Abstraction forall a b. (a -> b) -> a -> b
$ 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
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
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 =
    forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropDups GInstrument -> Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn (forall {b}. (Eq b, IsString b) => b -> (Int, b)
order forall b c a. (b -> c) -> (a -> b) -> a -> c
. GInstrument -> Text
name)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Korvai -> [GInstrument]
Korvai.korvaiInstruments 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 = (forall a. a -> Maybe a -> a
fromMaybe Int
999 forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall 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 = forall g h a. (g -> h) -> [Flat g a] -> [Flat h a]
S.mapGroupFlat 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 = forall a. Maybe a
Nothing -- TODO pick a real duration?
    , _name :: Maybe Text
_name = 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 =
            forall a b. (a -> b) -> (a -> b) -> [a] -> [b]
Lists.mapHeadTail (forall {stroke} {b} {a} {b} {g}.
(Note stroke -> b) -> (Tempo, (a, b)) -> Flat g (a, b)
abstract forall a. a -> Stroke a
S.Attack) (forall {stroke} {b} {a} {b} {g}.
(Note stroke -> b) -> (Tempo, (a, b)) -> Flat g (a, b)
abstract forall a. a -> Stroke a
S.Sustain)
                [(Tempo, (a, Stroke (Note stroke)))]
tempoNotes
        | Bool
otherwise = [forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo Meta
group (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  = 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 = forall {b} {a} {b} {g}. b -> (Tempo, (a, b)) -> Flat g (a, b)
replace forall a b. (a -> b) -> a -> b
$ Note stroke -> b
c forall a b. (a -> b) -> a -> b
$ forall stroke. Meta -> Note stroke
Realize.Abstract 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 forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& GroupType
gtype forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GroupType]
nameFromDur
                then Meta
group
                    { _name :: Maybe Text
Solkattu._name = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                        forall a. (RealFrac a, Pretty a) => Bool -> a -> Text
Pretty.fraction Bool
True FMatra
fmatras 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 forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Tempo -> Duration
S.matraDuration forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_)) = 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 = (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$
            forall g a. Tempo -> a -> Flat g a
S.FNote Tempo
tempo forall a b. (a -> b) -> a -> b
$ forall stroke. Meta -> Note stroke
Realize.Abstract Meta
meta
        | Bool
otherwise = [forall g a. Tempo -> g -> [Flat g a] -> Flat g a
S.FGroup Tempo
tempo Group stroke
group (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 = 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.Akshara -> [Flat stroke]
    -> [NormalizedFlat stroke]
normalizeSpeed :: forall stroke.
Int -> Int -> [Flat stroke] -> [NormalizedFlat stroke]
normalizeSpeed Int
toSpeed Int
talaAksharas =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Stroke (Note a) -> Stroke (Note a)
normalizeRest)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a g.
HasMatras a =>
Int -> Int -> [Flat g a] -> [Flat g (State, Stroke a)]
S.normalizeSpeed Int
toSpeed Int
talaAksharas
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a g. (a -> Bool) -> [Flat g a] -> [Flat g a]
S.filterFlat (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)) = forall a. Stroke a
S.Rest
normalizeRest (S.Sustain (Realize.Space Space
Solkattu.Rest)) = 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 = forall a. (a -> Bool) -> [a] -> [a]
dropWhile forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [[a]]
Lists.splitBefore (State -> Bool
onSam forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) -> (note -> Bool)
    -> [[[(a, note)]]] -- ^ [avartanams], broken by lines
    -> [[[(a, note)]]]
formatFinalAvartanam :: forall note a.
(note -> Bool)
-> (note -> Bool) -> [[[(a, note)]]] -> [[[(a, note)]]]
formatFinalAvartanam note -> Bool
isRest note -> Bool
isOverlap [[[(a, note)]]]
avartanams = case forall a. [a] -> [a]
reverse [[[(a, note)]]]
avartanams of
    [[(a, note)]
final] : [[(a, note)]]
penultimate : [[[(a, note)]]]
prevs
        | Just [(a, note)]
extra <- forall {a}. [(a, note)] -> Maybe [(a, note)]
isTail [(a, note)]
final ->
            forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ (forall a. (a -> a) -> [a] -> [a]
Lists.mapLast (forall a. [a] -> [a] -> [a]
++[(a, note)]
extra) [[(a, note)]]
penultimate) forall a. a -> [a] -> [a]
: [[[(a, note)]]]
prevs
    [[[(a, note)]]]
_ -> [[[(a, note)]]]
avartanams
    where
    -- A tail is one non-rest, n overlapSymbols, n rests.
    isTail :: [(a, note)] -> Maybe [(a, note)]
isTail ((a, note)
n : [(a, note)]
ns)
        | Bool -> Bool
not (note -> Bool
isRest (forall a b. (a, b) -> b
snd (a, note)
n)) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (note -> Bool
isRest forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, note)]
post = forall a. a -> Maybe a
Just ((a, note)
n forall a. a -> [a] -> [a]
: [(a, note)]
pre)
        where ([(a, note)]
pre, [(a, note)]
post) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (note -> Bool
isOverlap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, note)]
ns
    isTail [(a, note)]
_ = forall a. Maybe a
Nothing


onSam :: S.State -> Bool
onSam :: State -> Bool
onSam State
state = State -> Duration
S.stateMatra State
state forall a. Eq a => a -> a -> Bool
== Duration
0 Bool -> Bool -> Bool
&& State -> Int
S.stateAkshara State
state 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 forall a. Eq a => a -> a -> Bool
== Duration
0 Bool -> Bool -> 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 forall a. Eq a => a -> a -> Bool
== Duration
0

angaSet :: Tala.Tala -> Set Tala.Akshara
angaSet :: Tala -> Set Int
angaSet = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) Int
0 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 -> Talas.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 =
    forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL (forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL 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
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL (forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL forall {b}. Maybe Ruler -> (Ruler, b) -> (Maybe Ruler, (Ruler, b))
inherit) (forall a b. (a, b) -> a
fst PrevRuler
prevRuler)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map 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 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(State, b)]
line)
        , [(State, b)]
line
        )
        where akshara :: Int
akshara = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (State -> Int
S.stateAkshara forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.head [(State, b)]
line

    inherit :: Maybe Ruler -> (Ruler, b) -> (Maybe Ruler, (Ruler, b))
inherit Maybe Ruler
Nothing (Ruler
ruler, b
line) = (forall a. a -> Maybe a
Just Ruler
ruler, (Ruler
ruler, b
line))
    inherit (Just Ruler
prev) (Ruler
ruler, b
line) = (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) =
        ( (forall a. a -> Maybe a
Just [(Text, b)]
ruler, Int
1 forall a. Num a => a -> a -> a
+ if Bool
wanted then Int
0 else Int
lineNumber)
        , (if Bool
wanted then forall a. a -> Maybe a
Just ([(Text, b)]
ruler forall a. [a] -> [a] -> [a]
++ [(Text
"|", b
0)]) else forall a. Maybe a
Nothing, b
line)
        )
        where
        wanted :: Bool
wanted =  Int
lineNumber forall a. Integral a => a -> a -> a
`mod` Int
rulerEach forall a. Eq a => a -> a -> Bool
== Int
0
            Bool -> Bool -> Bool
|| forall a. a -> Maybe a
Just (forall {b}. [(Text, b)] -> [(Bool, b)]
structure [(Text, b)]
ruler) forall a. Eq a => a -> a -> Bool
/= (forall {b}. [(Text, b)] -> [(Bool, b)]
structure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [(Text, b)]
prev)
    structure :: [(Text, b)] -> [(Bool, b)]
structure = forall a b. (a -> b) -> [a] -> [b]
map (\(Text
mark, b
width) -> (Text
mark 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
    | forall (t :: * -> *) a. Foldable t => t a -> Int
length Ruler
cur forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length Ruler
prev Bool -> Bool -> Bool
&& forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd Ruler
cur forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` forall a b. (a -> b) -> [a] -> [b]
map 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 -> Talas.Tala -> Int -> [S.State] -> Ruler
inferRuler :: Int -> Tala -> Int -> [State] -> Ruler
inferRuler Int
startAkshara Tala
tala Int
strokeWidth =
    forall {b} {a}. (Eq b, Num b, Semigroup a) => [(a, b)] -> [(a, b)]
merge
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall (t :: * -> *) a. Foldable t => t a -> Int
length)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {a}. IsString a => (a, [a]) -> [(a, [a])]
insertDots
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Int -> [a] -> [a]
drop Int
startAkshara (Tala -> [Text]
Talas.labels Tala
tala))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile forall (t :: * -> *) a. Foldable t => t a -> Bool
null
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [[a]]
Lists.splitBefore 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
n1forall a. Semigroup a => a -> a -> a
<>a
n2, b
spaces) forall a. a -> [a] -> [a]
: [(a, b)]
xs)
    merge ((a
n, b
spaces) : [(a, b)]
xs) = (a
n, b
spaces) 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) =
        ( forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
prevNadai forall a b. (a, b) -> a
fst (forall a. [a] -> Maybe a
Lists.last [(Int, [State])]
groups)
        , case [(Int, [State])]
groups of
            (Int
nadai, [State]
states) : [(Int, [State])]
rest | Int
nadai forall a. Eq a => a -> a -> Bool
== Int
prevNadai ->
                (Text
label, [State]
states) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall {a}. Show a => a -> Text
nadaiChange) [(Int, [State])]
rest
            [(Int, [State])]
_ -> (Text
label, []) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall {a}. Show a => a -> Text
nadaiChange) [(Int, [State])]
groups
        )
        where
        groups :: [(Int, [State])]
groups = forall key a. Eq key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupAdjacent State -> Int
nadaiOf [State]
states
        nadaiOf :: State -> Int
nadaiOf = Tempo -> Int
S._nadai 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
":" forall a. Semigroup a => a -> a -> a
<> 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 forall a. Num a => a -> a -> a
* Int
strokeWidth forall a. Ord a => a -> a -> Bool
> Int
8) Bool -> Bool -> Bool
&& Int
spaces forall a. Integral a => a -> a -> a
`mod` Int
2 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) = forall a. Int -> [a] -> ([a], [a])
splitAt (Int
spaces forall a. Integral a => a -> a -> a
`div` Int
2) [a]
states
        spaces :: Int
spaces = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
states

-- * metadata

showTags :: Tags.Tags -> Text
showTags :: Tags -> Text
showTags Tags
tags = case 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" 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 = forall a b. [a] -> [b] -> [(a, b)]
zip [x]
xs ([a] -> [b]
f [a]
as)
    where ([x]
xs, [a]
as) = forall a b. [(a, b)] -> ([a], [b])
unzip [(x, a)]
xas