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

{-# LANGUAGE CPP #-}
-- | Convert Meter.Meter into a low level marklist.
module Ui.Meter.Make (
    make_marklist
    , to_rank_durations -- used by Perform.Lilypond.Meter
    , big_label
    , count_from
#ifdef TESTING
    , module Ui.Meter.Make
#endif
) where
import qualified Data.List as List
import qualified Data.Ratio as Ratio
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Num as Num
import qualified Util.Regex as Regex
import qualified Ui.Color as Color
import qualified Ui.Meter.Mark as Mark
import qualified Ui.Meter.Meter as Meter
import           Ui.Meter.Meter (AbstractMeter(..), Duration, Label, Measures)
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


-- TODO If I port this to c++, then I can just marshal Config instead of the
-- vector.  Then, I could only materialize marks that are visible and stop
-- paying for the micro divisions I hardly ever see.
--
-- On the other hand, paying for them once on ruler creation sounds better
-- than paying for them on every zoom change.
make_marklist :: Meter.Meter -> Mark.Marklist
make_marklist :: Meter -> Marklist
make_marklist = [PosMark] -> Marklist
Mark.marklist ([PosMark] -> Marklist)
-> (Meter -> [PosMark]) -> Meter -> Marklist
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meter -> [PosMark]
make_measures

-- | Repeat each measure for the given count.
-- This can't express unaligned beats.  If you want a cut-off measure
-- like 4/4 - 1/16, you would have to create a special measure for it.
-- If I want that, I can make a function on AbstractMeter.
make_measures :: Meter.Meter -> [(TrackTime, Mark.Mark)]
make_measures :: Meter -> [PosMark]
make_measures Meter
meter =
    Duration -> [LabeledMark] -> [PosMark]
labeled_marklist Duration
0 ([LabeledMark] -> [PosMark]) -> [LabeledMark] -> [PosMark]
forall a b. (a -> b) -> a -> b
$
    Config -> Int -> [(Rank, Duration)] -> [LabeledMark]
label_ranks Config
config (Config -> Int
Meter.config_start_measure Config
config) ([(Rank, Duration)] -> [LabeledMark])
-> [(Rank, Duration)] -> [LabeledMark]
forall a b. (a -> b) -> a -> b
$
    [(Duration, AbstractMeter)] -> [(Rank, Duration)]
to_rank_durations ([(Duration, AbstractMeter)] -> [(Rank, Duration)])
-> [(Duration, AbstractMeter)] -> [(Rank, Duration)]
forall a b. (a -> b) -> a -> b
$
    (MSection -> (Duration, AbstractMeter))
-> [MSection] -> [(Duration, AbstractMeter)]
forall a b. (a -> b) -> [a] -> [b]
map MSection -> (Duration, AbstractMeter)
expand (Meter -> [MSection]
Meter.meter_sections Meter
meter)
    where
    config :: Config
config = Meter -> Config
Meter.meter_config Meter
meter
    expand :: MSection -> (Duration, AbstractMeter)
expand (Meter.MSection Int
count Duration
dur AbstractMeter
measure) =
        (Duration
tdur, [AbstractMeter] -> AbstractMeter
D (Int -> AbstractMeter -> [AbstractMeter]
forall a. Int -> a -> [a]
replicate Int
count AbstractMeter
measure))
        where tdur :: Duration
tdur = Duration
dur Duration -> Duration -> Duration
forall a. Fractional a => a -> a -> a
/ Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AbstractMeter -> Int
Meter.meter_length AbstractMeter
measure)

-- | The AbstractMeters are concatenated, and each one defines a rank 0.
-- Each T level gets the given Duration.
to_rank_durations :: [(Duration, AbstractMeter)] -> [(Meter.Rank, Duration)]
to_rank_durations :: [(Duration, AbstractMeter)] -> [(Rank, Duration)]
to_rank_durations = [(Rank, Duration)] -> [(Rank, Duration)]
forall {b} {a}.
(Num b, Ord a, Bounded a, Eq b) =>
[(a, b)] -> [(a, b)]
group0 ([(Rank, Duration)] -> [(Rank, Duration)])
-> ([(Duration, AbstractMeter)] -> [(Rank, Duration)])
-> [(Duration, AbstractMeter)]
-> [(Rank, Duration)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Duration, AbstractMeter) -> [(Rank, Duration)])
-> [(Duration, AbstractMeter)] -> [(Rank, Duration)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Duration -> AbstractMeter -> [(Rank, Duration)])
-> (Duration, AbstractMeter) -> [(Rank, Duration)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Rank -> Duration -> AbstractMeter -> [(Rank, Duration)]
forall {t}. Num t => Rank -> t -> AbstractMeter -> [(Rank, t)]
convert Rank
forall a. Bounded a => a
minBound))
    where
    -- Convert returns an intermediate format where all the ranks coexist at
    -- the same time, by giving them 0 dur.
    group0 :: [(a, b)] -> [(a, b)]
group0 [(a, b)]
rank_dur = case ((a, b) -> Bool) -> [(a, b)] -> ([(a, b)], [(a, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==b
0) (b -> Bool) -> ((a, b) -> b) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> b
forall a b. (a, b) -> b
snd) [(a, b)]
rank_dur of
        ([(a, b)]
zeros, (a
rank, b
dur) : [(a, b)]
rest) ->
            ([a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (a
rank a -> [a] -> [a]
forall a. a -> [a] -> [a]
: ((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
zeros), b
dur) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, b)]
group0 [(a, b)]
rest
        ([(a, b)]
_, []) -> [(a
forall a. Bounded a => a
minBound, b
0)]
    convert :: Rank -> t -> AbstractMeter -> [(Rank, t)]
convert Rank
rank t
dur AbstractMeter
meter = case AbstractMeter
meter of
        AbstractMeter
T -> [(Rank
rank, t
dur)]
        D [AbstractMeter]
ms -> (Rank
rank, t
0) (Rank, t) -> [(Rank, t)] -> [(Rank, t)]
forall a. a -> [a] -> [a]
: (AbstractMeter -> [(Rank, t)]) -> [AbstractMeter] -> [(Rank, t)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Rank -> t -> AbstractMeter -> [(Rank, t)]
convert (Rank -> Rank
next_rank Rank
rank) t
dur) [AbstractMeter]
ms

next_rank :: Meter.Rank -> Meter.Rank
next_rank :: Rank -> Rank
next_rank Rank
r
    | Rank
r Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
forall a. Bounded a => a
maxBound = Rank
r
    | Bool
otherwise = Rank -> Rank
forall a. Enum a => a -> a
succ Rank
r

data LabeledMark = LabeledMark {
    LabeledMark -> Rank
m_rank :: !Meter.Rank
    , LabeledMark -> Duration
m_duration :: !Duration
    , LabeledMark -> Label
m_label :: !Label
    } deriving (LabeledMark -> LabeledMark -> Bool
(LabeledMark -> LabeledMark -> Bool)
-> (LabeledMark -> LabeledMark -> Bool) -> Eq LabeledMark
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LabeledMark -> LabeledMark -> Bool
$c/= :: LabeledMark -> LabeledMark -> Bool
== :: LabeledMark -> LabeledMark -> Bool
$c== :: LabeledMark -> LabeledMark -> Bool
Eq, Int -> LabeledMark -> ShowS
[LabeledMark] -> ShowS
LabeledMark -> String
(Int -> LabeledMark -> ShowS)
-> (LabeledMark -> String)
-> ([LabeledMark] -> ShowS)
-> Show LabeledMark
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LabeledMark] -> ShowS
$cshowList :: [LabeledMark] -> ShowS
show :: LabeledMark -> String
$cshow :: LabeledMark -> String
showsPrec :: Int -> LabeledMark -> ShowS
$cshowsPrec :: Int -> LabeledMark -> ShowS
Show)

type RankNum = Int

rank_num :: Meter.Rank -> RankNum
rank_num :: Rank -> Int
rank_num = Rank -> Int
forall a. Enum a => a -> Int
fromEnum

instance Pretty LabeledMark where
    pretty :: LabeledMark -> Label
pretty (LabeledMark Rank
rank Duration
dur Label
label) = (Rank, Duration, Label) -> Label
forall a. Pretty a => a -> Label
pretty (Rank
rank, Duration
dur, Label
label)

-- | Add Labels to the given ruler ranks.
label_ranks :: Meter.Config -> Measures -> [(Meter.Rank, Duration)]
    -> [LabeledMark]
label_ranks :: Config -> Int -> [(Rank, Duration)] -> [LabeledMark]
label_ranks Config
config Int
start_measure [(Rank, Duration)]
rank_durs =
    [ Rank -> Duration -> Label -> LabeledMark
LabeledMark Rank
rank Duration
dur Label
label
    | (Rank
rank, Duration
dur, Label
label) <- [Rank] -> [Duration] -> [Label] -> [(Rank, Duration, Label)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
List.zip3 [Rank]
ranks [Duration]
ps [Label]
labels
    ]
    where
    ([Rank]
ranks, [Duration]
ps) = [(Rank, Duration)] -> ([Rank], [Duration])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Rank, Duration)]
rank_durs
    labels :: [Label]
labels = ([Label] -> Label) -> [[Label]] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map [Label] -> Label
join_label ([[Label]] -> [Label]) -> [[Label]] -> [Label]
forall a b. (a -> b) -> a -> b
$
        Label -> Int -> [[Label]] -> [[Label]]
strip_prefixes Label
"" (Config -> Int
Meter.config_strip_depth Config
config) ([[Label]] -> [[Label]]) -> [[Label]] -> [[Label]]
forall a b. (a -> b) -> a -> b
$
        Int -> LabelComponents -> Int -> [Int] -> [[Label]]
convert_labels (Config -> Int
Meter.config_min_depth Config
config)
            (LabelConfig -> LabelComponents
label_components (Config -> LabelConfig
Meter.config_label Config
config))
            Int
start_measure
            ([Rank] -> [Rank] -> [Int]
collapse_ranks [Rank]
unlabeled [Rank]
ranks)
    unlabeled :: [Rank]
unlabeled = Set Rank -> [Rank]
labeled_to_unlabeled_ranks (Config -> Set Rank
Meter.config_labeled_ranks Config
config)

labeled_to_unlabeled_ranks :: Set Meter.Rank -> [Meter.Rank]
labeled_to_unlabeled_ranks :: Set Rank -> [Rank]
labeled_to_unlabeled_ranks Set Rank
labeled =
    [Rank
r | Rank
r <- [Rank]
Meter.all_ranks, Bool -> Bool
not (Rank
r Rank -> Set Rank -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Rank
labeled)]

-- | Create marks from a labeled meter.
labeled_marklist :: TrackTime -> [LabeledMark] -> [(TrackTime, Mark.Mark)]
labeled_marklist :: Duration -> [LabeledMark] -> [PosMark]
labeled_marklist Duration
start [LabeledMark]
marks =
    [ (Rational -> Duration
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
pos, Duration -> Rank -> Label -> Mark
mark Duration
dur Rank
rank Label
label)
    | (Rank
rank, Rational
pos, Label
label, Duration
dur) <- [Rank]
-> [Rational]
-> [Label]
-> [Duration]
-> [(Rank, Rational, Label, Duration)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
List.zip4 [Rank]
ranks [Rational]
starts ((LabeledMark -> Label) -> [LabeledMark] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map LabeledMark -> Label
m_label [LabeledMark]
marks) [Duration]
durs
    ]
    where
    starts :: [Rational]
starts = (Rational -> Rational -> Rational)
-> Rational -> [Rational] -> [Rational]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
(+) (Duration -> Rational
forall {a}. RealFrac a => a -> Rational
to_rational Duration
start)
        ((LabeledMark -> Rational) -> [LabeledMark] -> [Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Duration -> Rational
forall {a}. RealFrac a => a -> Rational
to_rational (Duration -> Rational)
-> (LabeledMark -> Duration) -> LabeledMark -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabeledMark -> Duration
m_duration) [LabeledMark]
marks)
    -- Avoid accumulating error, as per 'Duration'.
    to_rational :: a -> Rational
to_rational a
t = a -> a -> Rational
forall a. RealFrac a => a -> a -> Rational
Ratio.approxRational a
t a
0.0000001
    durs :: [Duration]
durs = [(Rank, Duration)] -> [Duration]
rank_durs ([Rank] -> [Duration] -> [(Rank, Duration)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Rank]
ranks ((LabeledMark -> Duration) -> [LabeledMark] -> [Duration]
forall a b. (a -> b) -> [a] -> [b]
map LabeledMark -> Duration
m_duration [LabeledMark]
marks))
    ranks :: [Rank]
ranks = (LabeledMark -> Rank) -> [LabeledMark] -> [Rank]
forall a b. (a -> b) -> [a] -> [b]
map LabeledMark -> Rank
m_rank [LabeledMark]
marks
    mark :: Duration -> Rank -> Label -> Mark
mark Duration
rank_dur Rank
rank Label
name = Mark.Mark
        { mark_rank :: Rank
mark_rank = Rank
rank
        , mark_width :: Int
mark_width = Int
width
        , mark_color :: Color
mark_color = Color
color
        , mark_name :: Label
mark_name = Label
name
        , mark_name_zoom_level :: Double
mark_name_zoom_level = Double
zoom Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2
        , mark_zoom_level :: Double
mark_zoom_level = Double
zoom
        }
        where
        (Color
color, Int
width, Int
pixels) = [(Color, Int, Int)]
meter_ranks [(Color, Int, Int)] -> Int -> (Color, Int, Int)
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Rank -> Int
rank_num Rank
rank) Int
ranks_len
        zoom :: Double
zoom = Duration -> Int -> Double
pixels_to_zoom Duration
rank_dur Int
pixels
    ranks_len :: Int
ranks_len = [(Color, Int, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Color, Int, Int)]
meter_ranks


-- * labels

-- TODO make LabelConfig into a general description, eliminate LabelComponents
label_components :: Meter.LabelConfig -> LabelComponents
label_components :: LabelConfig -> LabelComponents
label_components = \case
    Meter.BigNumber Int
sub_start -> Int -> LabelComponents
big_number_components Int
sub_start
    Meter.Cycle [Label]
labels -> [[Label]] -> LabelComponents
LabelComponents
        [ [Label] -> [Label]
forall a. [a] -> [a]
cycle [Label]
labels
        , [Label]
numbers -- nadai / gati
        , [Label]
numbers, [Label]
numbers, [Label]
numbers, [Label]
numbers
        ]
        where numbers :: [Label]
numbers = Int -> [Label]
count_from Int
1

-- | This is the prototype for how to draw labels.  The outer list is indexed
-- by rank, while the inner is has the sequence of labels at that rank.
-- 'convert_labels' will take from a given level each time it sees that rank,
-- and reset back to the beginning when the rank becomes less than that level.
-- The inner list should be infinite to so it won't run out of labels no matter
-- how many consecutive ranks are at that level.
newtype LabelComponents = LabelComponents [[Label]]

instance Show LabelComponents where
    show :: LabelComponents -> String
show (LabelComponents [[Label]]
labels) = [[Label]] -> String
forall a. Show a => a -> String
show ([[Label]] -> String) -> [[Label]] -> String
forall a b. (a -> b) -> a -> b
$ ([Label] -> [Label]) -> [[Label]] -> [[Label]]
forall a b. (a -> b) -> [a] -> [b]
map (([Label] -> [Label] -> [Label]
forall a. [a] -> [a] -> [a]
++[Label
"..."]) ([Label] -> [Label]) -> ([Label] -> [Label]) -> [Label] -> [Label]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Label] -> [Label]
forall a. Int -> [a] -> [a]
take Int
10) [[Label]]
labels
instance Pretty LabelComponents where pretty :: LabelComponents -> Label
pretty = LabelComponents -> Label
forall a. Show a => a -> Label
showt

-- | Like 'number_components', but the first two are bigger.
big_number_components :: Int -> LabelComponents
big_number_components :: Int -> LabelComponents
big_number_components Int
sub_start = [[Label]] -> LabelComponents
LabelComponents ([[Label]] -> LabelComponents) -> [[Label]] -> LabelComponents
forall a b. (a -> b) -> a -> b
$ Int -> [[Label]] -> [[Label]]
forall a. Int -> [a] -> [a]
take Int
max_label_depth ([[Label]] -> [[Label]]) -> [[Label]] -> [[Label]]
forall a b. (a -> b) -> a -> b
$
    (Label -> Label) -> [Label] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map Label -> Label
big_label (Int -> [Label]
count_from Int
sub_start) [Label] -> [[Label]] -> [[Label]]
forall a. a -> [a] -> [a]
: [Label] -> [[Label]]
forall a. a -> [a]
List.repeat (Int -> [Label]
count_from Int
sub_start)
    where
    -- | Limit label component depth.  I'll never take more than this anyway so
    -- it probably doesn't matter, but let's avoid too many infinite lists.
    max_label_depth :: Int
    max_label_depth :: Int
max_label_depth = Int
10

big_label :: Label -> Label
big_label :: Label -> Label
big_label Label
t = Label
"`+2/" Label -> Label -> Label
forall a. Semigroup a => a -> a -> a
<> Label
t Label -> Label -> Label
forall a. Semigroup a => a -> a -> a
<> Label
"`"

biggest_label :: Label -> Label
biggest_label :: Label -> Label
biggest_label Label
t = Label
"`+4/" Label -> Label -> Label
forall a. Semigroup a => a -> a -> a
<> Label
t Label -> Label -> Label
forall a. Semigroup a => a -> a -> a
<> Label
"`"

strip_markup :: Label -> Label
strip_markup :: Label -> Label
strip_markup = Regex -> Label -> Label -> Label
Regex.substitute (HasCallStack => String -> Regex
String -> Regex
Regex.compileUnsafe String
"`(\\+\\d+/)?") Label
""

join_label :: [Label] -> Label
join_label :: [Label] -> Label
join_label = Label -> [Label] -> Label
Text.intercalate Label
"."

split_label :: Label -> [Label]
split_label :: Label -> [Label]
split_label = (Char -> Bool) -> Label -> [Label]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.')

-- | Convert label components to label lists based on the given ranks.
convert_labels :: Int -- ^ Labels have at least this many sections.  Otherwise,
    -- trailing sections are omitted.
    -> LabelComponents -> Measures -> [RankNum] -> [[Label]]
convert_labels :: Int -> LabelComponents -> Int -> [Int] -> [[Label]]
convert_labels Int
min_depth (LabelComponents [[Label]]
components) Int
start_measure [Int]
ranks =
    [[Label]] -> [[Label]]
forall {a}. [[a]] -> [[a]]
strip ([[Label]] -> [[Label]]) -> [[Label]] -> [[Label]]
forall a b. (a -> b) -> a -> b
$ ([Label] -> [Label]) -> [[Label]] -> [[Label]]
forall a b. (a -> b) -> [a] -> [b]
map ((Label -> Label) -> [Label] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map Label -> Label
replace) ([[Label]] -> [[Label]]) -> [[Label]] -> [[Label]]
forall a b. (a -> b) -> a -> b
$
        [[Label]] -> [Int] -> [[Label]]
apply_labels (Int -> [Label] -> [Label]
forall a. Int -> [a] -> [a]
drop Int
start_measure [Label]
measure_labels [Label] -> [[Label]] -> [[Label]]
forall a. a -> [a] -> [a]
: [[Label]]
components) [Int]
ranks
    where
    strip :: [[a]] -> [[a]]
strip = (Int -> [a] -> [a]) -> [Int] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
min_depth (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) [Int]
ranks)
    replace :: Label -> Label
replace Label
t = if Label -> Bool
Text.null Label
t then Label
"-" else Label
t

measure_labels :: [Label]
measure_labels :: [Label]
measure_labels = (Label -> Label) -> [Label] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map Label -> Label
biggest_label (Int -> [Label]
count_from Int
0)

count_from :: Int -> [Label]
count_from :: Int -> [Label]
count_from Int
n = (Int -> Label) -> [Int] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Label
forall a. Show a => a -> Label
showt [Int
n..]

-- | The ruler gets cluttered if I label every single rank, so combine the ones
-- in the given list with the following rank.
collapse_ranks :: [Meter.Rank] -> [Meter.Rank] -> [RankNum]
collapse_ranks :: [Rank] -> [Rank] -> [Int]
collapse_ranks [Rank]
omit = (Rank -> Int) -> [Rank] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Rank
r -> Rank -> Int
rank_num Rank
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Rank -> Int
below Rank
r)
    where below :: Rank -> Int
below Rank
r = [Rank] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Rank -> Bool) -> [Rank] -> [Rank]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Rank -> Rank -> Bool
forall a. Ord a => a -> a -> Bool
<Rank
r) [Rank]
omit)

-- | When labels are created, many of them have the same components as the
-- previous label, e.g. @1.1.1@, @1.1.2@.  Replace leading components up to
-- a certain depth with a placeholder to make the difference more apparent:
-- @1.1.1@, @-.-.2@.
--
-- This doesn't actually look that nice on the UI because it does it for all
-- labels, not just the visible ones.
strip_prefixes :: Text -> Int -> [[Label]] -> [[Label]]
strip_prefixes :: Label -> Int -> [[Label]] -> [[Label]]
strip_prefixes Label
replacement Int
depth = ([Label] -> [Label]) -> [[Label]] -> [[Label]]
forall a b. (a -> b) -> [a] -> [b]
map [Label] -> [Label]
strip
    where
    strip :: [Label] -> [Label]
strip [Label]
labels = Int -> Label -> [Label]
forall a. Int -> a -> [a]
replicate Int
prefix Label
replacement [Label] -> [Label] -> [Label]
forall a. [a] -> [a] -> [a]
++ [Label]
post
        where (Int
prefix, [Label]
post) = Int -> [Label] -> (Int, [Label])
forall {t} {a} {a}. (Ord t, Num t, Num a) => t -> [a] -> (a, [a])
split1 Int
depth [Label]
labels
    -- Like splitAt, but don't take the final one, because then I'd replace
    -- everything in shorter labels.
    split1 :: t -> [a] -> (a, [a])
split1 t
n [a]
xs | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = (a
0, [a]
xs)
    split1 t
_ [] = (a
0, [])
    split1 t
_ [a
x] = (a
0, [a
x])
    split1 t
n (a
_:[a]
xs) = (a -> a) -> (a, [a]) -> (a, [a])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (a -> a -> a
forall a. Num a => a -> a -> a
+a
1) (t -> [a] -> (a, [a])
split1 (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [a]
xs)

-- | Apply the labels according to the ranks.  Each Rank input has
-- a corresponding @[Label]@ output.  Each rank advances the label at the rank's
-- index in the labels, and resets all the labels beneath it.  If a rank runs
-- out of labels, @\"\"@ is emitted.
--
-- The first rank doesn't matter since it always emits the initial state of the
-- labels.
apply_labels :: [[Label]] -> [RankNum] -> [[Label]]
apply_labels :: [[Label]] -> [Int] -> [[Label]]
apply_labels [[Label]]
labels =
    (([Label] -> Label) -> [[Label]] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map [Label] -> Label
forall {a}. IsString a => [a] -> a
hd [[Label]]
labels :) ([[Label]] -> [[Label]])
-> ([Int] -> [[Label]]) -> [Int] -> [[Label]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Label]], [[Label]]) -> [[Label]]
forall a b. (a, b) -> b
snd (([[Label]], [[Label]]) -> [[Label]])
-> ([Int] -> ([[Label]], [[Label]])) -> [Int] -> [[Label]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Label]] -> Int -> ([[Label]], [Label]))
-> [[Label]] -> [Int] -> ([[Label]], [[Label]])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL [[Label]] -> Int -> ([[Label]], [Label])
mk [[Label]]
labels ([Int] -> ([[Label]], [[Label]]))
-> ([Int] -> [Int]) -> [Int] -> ([[Label]], [[Label]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1
    where
    mk :: [[Label]] -> Int -> ([[Label]], [Label])
mk [[Label]]
state Int
rank = ([[Label]]
next, ([Label] -> Label) -> [[Label]] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map [Label] -> Label
forall {a}. IsString a => [a] -> a
hd [[Label]]
next)
        where next :: [[Label]]
next = Int -> [[Label]] -> [[Label]]
split Int
rank [[Label]]
state
    split :: Int -> [[Label]] -> [[Label]]
split Int
rank [[Label]]
state = [[Label]]
above [[Label]] -> [[Label]] -> [[Label]]
forall a. [a] -> [a] -> [a]
++ [Label]
cur [Label] -> [[Label]] -> [[Label]]
forall a. a -> [a] -> [a]
: Int -> [[Label]] -> [[Label]]
forall a. Int -> [a] -> [a]
drop (Int
rank Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [[Label]]
labels
        where
        ([[Label]]
above, [[Label]]
below) = Int -> [[Label]] -> ([[Label]], [[Label]])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
rank [[Label]]
state
        cur :: [Label]
cur = case [[Label]]
below of
            (Label
_ : cur :: [Label]
cur@(Label
_:[Label]
_)) : [[Label]]
_ -> [Label]
cur
            [[Label]]
_ -> [Label
""]
    hd :: [a] -> a
hd [] = a
""
    hd (a
x:[a]
_) = a
x

-- ** meter constants

-- | The mark color defaults to mostly transparent so it looks nice on overlay
-- rulers.
color1, color2 :: Double -> Double -> Double -> Color.Color
color1 :: Double -> Double -> Double -> Color
color1 Double
r Double
g Double
b = Double -> Double -> Double -> Double -> Color
Color.rgba Double
r Double
g Double
b Double
0.5
color2 :: Double -> Double -> Double -> Color
color2 Double
r Double
g Double
b = Double -> Double -> Double -> Double -> Color
Color.rgba Double
r Double
g Double
b Double
0.3

type MarkWidth = Int

-- | Configs for marks in order of increasing rank.
-- @(color, width, zoom_pixels)@
--
-- @zoom_pixels@ is how many pixels of space a mark at this rank must have
-- between its neighbors before it appears.
meter_ranks :: [(Color.Color, MarkWidth, Int)]
meter_ranks :: [(Color, Int, Int)]
meter_ranks =
    [ (Double -> Double -> Double -> Color
a3 Double
0.0 Double
0.0 Double
0.0, Int
3, Int
8)    -- section
    , (Double -> Double -> Double -> Color
a3 Double
0.2 Double
0.1 Double
0.0, Int
2, Int
8)    -- measure / whole

    , (Double -> Double -> Double -> Color
a3 Double
1.0 Double
0.4 Double
0.2, Int
2, Int
8)    -- half
    , (Double -> Double -> Double -> Color
a2 Double
1.0 Double
0.4 Double
0.2, Int
2, Int
8)    -- quarter

    , (Double -> Double -> Double -> Color
a3 Double
1.0 Double
0.4 Double
0.9, Int
1, Int
8)    -- 8th
    , (Double -> Double -> Double -> Color
a2 Double
1.0 Double
0.4 Double
0.9, Int
1, Int
8)    -- 16th

    , (Double -> Double -> Double -> Color
a2 Double
0.1 Double
0.5 Double
0.1, Int
1, Int
8)    -- 32nd
    , (Double -> Double -> Double -> Color
a1 Double
0.1 Double
0.5 Double
0.1, Int
1, Int
8)    -- 64th

    , (Double -> Double -> Double -> Color
a2 Double
0.0 Double
0.0 Double
0.0, Int
1, Int
8)    -- 128th
    , (Double -> Double -> Double -> Color
a1 Double
0.0 Double
0.0 Double
0.0, Int
1, Int
8)    -- 256th
    ]
    where
    a1 :: Double -> Double -> Double -> Color
a1 = Double -> Double -> Double -> Double -> Color
alpha Double
0.2
    a2 :: Double -> Double -> Double -> Color
a2 = Double -> Double -> Double -> Double -> Color
alpha Double
0.4
    a3 :: Double -> Double -> Double -> Color
a3 = Double -> Double -> Double -> Double -> Color
alpha Double
0.55
    alpha :: Double -> Double -> Double -> Double -> Color
alpha Double
a Double
r Double
g Double
b = Double -> Double -> Double -> Double -> Color
Color.rgba Double
r Double
g Double
b Double
a

-- | The rank duration is the duration until the next mark of equal or greater
-- (lower) rank.
rank_durs :: [(Meter.Rank, Duration)] -> [Duration]
rank_durs :: [(Rank, Duration)] -> [Duration]
rank_durs = ([(Rank, Duration)] -> Duration)
-> [[(Rank, Duration)]] -> [Duration]
forall a b. (a -> b) -> [a] -> [b]
map [(Rank, Duration)] -> Duration
forall {a} {a}. (Num a, Ord a) => [(a, a)] -> a
rank_dur ([[(Rank, Duration)]] -> [Duration])
-> ([(Rank, Duration)] -> [[(Rank, Duration)]])
-> [(Rank, Duration)]
-> [Duration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Rank, Duration)] -> [[(Rank, Duration)]]
forall a. [a] -> [[a]]
List.tails
    where
    rank_dur :: [(a, a)] -> a
rank_dur [] = a
0
    rank_dur ((a
rank, a
dur) : [(a, a)]
meter) = a
total
        where total :: a
total = a
dur a -> a -> a
forall a. Num a => a -> a -> a
+ [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (((a, a) -> a) -> [(a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> b
snd (((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>a
rank) (a -> Bool) -> ((a, a) -> a) -> (a, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> a
forall a b. (a, b) -> a
fst) [(a, a)]
meter))

-- | Given a mark duration and the number of pixels it needs to display,
-- return the appropriate zoom factor.
pixels_to_zoom :: Duration -> Int -> Double
pixels_to_zoom :: Duration -> Int -> Double
pixels_to_zoom Duration
dur Int
pixels
    | Duration
dur Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
== Duration
0 = Double
0
    | Bool
otherwise = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pixels Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Duration -> Double
ScoreTime.to_double Duration
dur