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