-- Copyright 2013 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 #-}
{- | A TimeStep is an abstract description of a ScoreTime interval.

    It's used to advance a cursor, snap a selection, set a note duration, etc.
-}
module Cmd.TimeStep (
    -- * TimeStep
    TimeStep, time_step, event_step, from_list, to_list
    , modify_rank
    , match_meter
    , event_edge
    , rank
    , Step(..), Tracks(..)
    , MarklistMatch(..)
    , Direction(..)
    , show_time_step, parse_time_step, show_direction
    , parse_rank

    -- * step
    , snap
    , step_from, rewind, advance, direction
    , duration_at
    , get_points_from

#ifdef TESTING
    , ascending_points, descending_points
#endif
) where
import qualified Data.List.Ordered as Ordered
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Util.P as P
import qualified Util.Parse as Parse
import qualified Util.Seq as Seq

import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Meter.Mark as Mark
import qualified Ui.Meter.Meter as Meter
import qualified Ui.Ruler as Ruler
import qualified Ui.ScoreTime as ScoreTime
import qualified Ui.Ui as Ui

import           Global
import           Types


-- | A TimeStep is the union of a set of Steps.
newtype TimeStep = TimeStep [Step]
    deriving (TimeStep -> TimeStep -> Bool
(TimeStep -> TimeStep -> Bool)
-> (TimeStep -> TimeStep -> Bool) -> Eq TimeStep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeStep -> TimeStep -> Bool
$c/= :: TimeStep -> TimeStep -> Bool
== :: TimeStep -> TimeStep -> Bool
$c== :: TimeStep -> TimeStep -> Bool
Eq, Int -> TimeStep -> ShowS
[TimeStep] -> ShowS
TimeStep -> String
(Int -> TimeStep -> ShowS)
-> (TimeStep -> String) -> ([TimeStep] -> ShowS) -> Show TimeStep
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeStep] -> ShowS
$cshowList :: [TimeStep] -> ShowS
show :: TimeStep -> String
$cshow :: TimeStep -> String
showsPrec :: Int -> TimeStep -> ShowS
$cshowsPrec :: Int -> TimeStep -> ShowS
Show)

time_step :: Step -> TimeStep
time_step :: Step -> TimeStep
time_step = [Step] -> TimeStep
TimeStep ([Step] -> TimeStep) -> (Step -> [Step]) -> Step -> TimeStep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step -> [Step] -> [Step]
forall a. a -> [a] -> [a]
:[])

-- | Step to start and end of events.
event_step :: TimeStep
event_step :: TimeStep
event_step = [Step] -> TimeStep
from_list [Tracks -> Step
EventStart Tracks
CurrentTrack, Tracks -> Step
EventEnd Tracks
CurrentTrack]

from_list :: [Step] -> TimeStep
from_list :: [Step] -> TimeStep
from_list = [Step] -> TimeStep
TimeStep

to_list :: TimeStep -> [Step]
to_list :: TimeStep -> [Step]
to_list (TimeStep [Step]
steps) = [Step]
steps

modify_rank :: (Meter.Rank -> Meter.Rank) -> TimeStep -> TimeStep
modify_rank :: (Rank -> Rank) -> TimeStep -> TimeStep
modify_rank Rank -> Rank
f = [Step] -> TimeStep
from_list ([Step] -> TimeStep)
-> (TimeStep -> [Step]) -> TimeStep -> TimeStep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step -> Step) -> [Step] -> [Step]
forall a b. (a -> b) -> [a] -> [b]
map Step -> Step
modify ([Step] -> [Step]) -> (TimeStep -> [Step]) -> TimeStep -> [Step]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeStep -> [Step]
to_list
    where
    modify :: Step -> Step
modify (AbsoluteMark MarklistMatch
m Rank
r) = MarklistMatch -> Rank -> Step
AbsoluteMark MarklistMatch
m (Rank -> Rank
f Rank
r)
    modify (RelativeMark MarklistMatch
m Rank
r) = MarklistMatch -> Rank -> Step
RelativeMark MarklistMatch
m (Rank -> Rank
f Rank
r)
    modify Step
step = Step
step

-- | Match on the meter marklist, which is the usual thing to do.
match_meter :: MarklistMatch
match_meter :: MarklistMatch
match_meter = [Text] -> MarklistMatch
NamedMarklists [Text
Ruler.meter_name]

event_edge :: TimeStep
event_edge :: TimeStep
event_edge =
    [Step] -> TimeStep
TimeStep [Tracks -> Step
EventStart Tracks
CurrentTrack, Tracks -> Step
EventEnd Tracks
CurrentTrack, Step
BlockEdge]

rank :: Meter.Rank -> TimeStep
rank :: Rank -> TimeStep
rank = Step -> TimeStep
time_step (Step -> TimeStep) -> (Rank -> Step) -> Rank -> TimeStep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarklistMatch -> Rank -> Step
AbsoluteMark MarklistMatch
match_meter

-- | The possible matchers for a TimeStep.
data Step =
     -- | Step a certain amount of time.  It's measured relative to the current
     -- selection, rather than absolute from the beginning of the block.
    Duration ScoreTime
    -- | Until the next mark that matches.
    | AbsoluteMark MarklistMatch Meter.Rank
    -- | Until next matching mark + offset from previous mark.
    | RelativeMark MarklistMatch Meter.Rank
    -- | Until the end or beginning of the block.
    | BlockEdge
    -- | Until event edges.  EventStart is after EventEnd if the duration is
    -- negative.
    | EventStart Tracks
    | EventEnd Tracks
    deriving (Step -> Step -> Bool
(Step -> Step -> Bool) -> (Step -> Step -> Bool) -> Eq Step
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Step -> Step -> Bool
$c/= :: Step -> Step -> Bool
== :: Step -> Step -> Bool
$c== :: Step -> Step -> Bool
Eq, Int -> Step -> ShowS
[Step] -> ShowS
Step -> String
(Int -> Step -> ShowS)
-> (Step -> String) -> ([Step] -> ShowS) -> Show Step
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Step] -> ShowS
$cshowList :: [Step] -> ShowS
show :: Step -> String
$cshow :: Step -> String
showsPrec :: Int -> Step -> ShowS
$cshowsPrec :: Int -> Step -> ShowS
Show)

-- | Events of which tracks the event time step should use.
data Tracks = CurrentTrack | AllTracks | TrackNums [TrackNum]
    deriving (Tracks -> Tracks -> Bool
(Tracks -> Tracks -> Bool)
-> (Tracks -> Tracks -> Bool) -> Eq Tracks
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tracks -> Tracks -> Bool
$c/= :: Tracks -> Tracks -> Bool
== :: Tracks -> Tracks -> Bool
$c== :: Tracks -> Tracks -> Bool
Eq, Int -> Tracks -> ShowS
[Tracks] -> ShowS
Tracks -> String
(Int -> Tracks -> ShowS)
-> (Tracks -> String) -> ([Tracks] -> ShowS) -> Show Tracks
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tracks] -> ShowS
$cshowList :: [Tracks] -> ShowS
show :: Tracks -> String
$cshow :: Tracks -> String
showsPrec :: Int -> Tracks -> ShowS
$cshowsPrec :: Int -> Tracks -> ShowS
Show)

data MarklistMatch = AllMarklists | NamedMarklists [Ruler.Name]
    deriving (MarklistMatch -> MarklistMatch -> Bool
(MarklistMatch -> MarklistMatch -> Bool)
-> (MarklistMatch -> MarklistMatch -> Bool) -> Eq MarklistMatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MarklistMatch -> MarklistMatch -> Bool
$c/= :: MarklistMatch -> MarklistMatch -> Bool
== :: MarklistMatch -> MarklistMatch -> Bool
$c== :: MarklistMatch -> MarklistMatch -> Bool
Eq, Int -> MarklistMatch -> ShowS
[MarklistMatch] -> ShowS
MarklistMatch -> String
(Int -> MarklistMatch -> ShowS)
-> (MarklistMatch -> String)
-> ([MarklistMatch] -> ShowS)
-> Show MarklistMatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MarklistMatch] -> ShowS
$cshowList :: [MarklistMatch] -> ShowS
show :: MarklistMatch -> String
$cshow :: MarklistMatch -> String
showsPrec :: Int -> MarklistMatch -> ShowS
$cshowsPrec :: Int -> MarklistMatch -> ShowS
Show)

-- | Another way to express a 'step_from' of 1 or -1.
data Direction = Advance | Rewind deriving (Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq, Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show)

-- | Convert a TimeStep to a compact and yet somehow still somewhat readable
-- representation.
show_time_step :: TimeStep -> Text
show_time_step :: TimeStep -> Text
show_time_step (TimeStep [Step]
steps)
    -- Abbreviate to keep the status line shorter.
    | [Step] -> TimeStep
TimeStep [Step]
steps TimeStep -> TimeStep -> Bool
forall a. Eq a => a -> a -> Bool
== TimeStep
event_edge = Text
"E"
    | Bool
otherwise = Text -> [Text] -> Text
Text.intercalate Text
";" ((Step -> Text) -> [Step] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Step -> Text
show_step [Step]
steps)
    where
    -- The keywords and symbols are chosen carefully to allow unambiguous
    -- parsing.
    show_step :: Step -> Text
show_step Step
step = case Step
step of
        Duration TrackTime
pos -> Text
"d:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackTime -> Text
forall a. Pretty a => a -> Text
pretty TrackTime
pos
        RelativeMark MarklistMatch
mlists Rank
rank ->
            Text
"r:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MarklistMatch -> Text
show_marklists MarklistMatch
mlists Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Rank -> Text
Meter.rank_name Rank
rank
        Step
BlockEdge -> Text
"END"
        EventStart Tracks
tracks -> Text
"start" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tracks -> Text
show_tracks Tracks
tracks
        EventEnd Tracks
tracks -> Text
"end" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tracks -> Text
show_tracks Tracks
tracks
        AbsoluteMark MarklistMatch
mlists Rank
rank ->
            MarklistMatch -> Text
show_marklists MarklistMatch
mlists Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Rank -> Text
Meter.rank_name Rank
rank
    show_marklists :: MarklistMatch -> Text
show_marklists MarklistMatch
AllMarklists = Text
""
    show_marklists (NamedMarklists [Text]
mlists) = Text -> [Text] -> Text
Text.intercalate Text
"," [Text]
mlists Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"|"
    show_tracks :: Tracks -> Text
show_tracks Tracks
CurrentTrack = Text
""
    show_tracks Tracks
AllTracks = Text
"s"
    show_tracks (TrackNums [Int]
tracks) =
        Text
"s:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"," ((Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
forall a. Show a => a -> Text
showt [Int]
tracks)

-- | Parse that curiously somewhat readable representation back to a TimeStep.
parse_time_step :: Text -> Either Text TimeStep
parse_time_step :: Text -> Either Text TimeStep
parse_time_step = Parser TimeStep -> Text -> Either Text TimeStep
forall a. Parser a -> Text -> Either Text a
Parse.parse Parser TimeStep
p_time_step
    where
    p_time_step :: Parser TimeStep
p_time_step = [Step] -> TimeStep
TimeStep ([Step] -> TimeStep)
-> ParsecT Void Text Identity [Step] -> Parser TimeStep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Step
-> ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity [Step]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy ParsecT Void Text Identity Step
p_step (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
';')
    -- P.choice must backtrack because AbsoluteMark parses can overlap.
    p_step :: ParsecT Void Text Identity Step
p_step = [ParsecT Void Text Identity Step]
-> ParsecT Void Text Identity Step
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice ([ParsecT Void Text Identity Step]
 -> ParsecT Void Text Identity Step)
-> [ParsecT Void Text Identity Step]
-> ParsecT Void Text Identity Step
forall a b. (a -> b) -> a -> b
$ (ParsecT Void Text Identity Step
 -> ParsecT Void Text Identity Step)
-> [ParsecT Void Text Identity Step]
-> [ParsecT Void Text Identity Step]
forall a b. (a -> b) -> [a] -> [b]
map ParsecT Void Text Identity Step -> ParsecT Void Text Identity Step
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try
        [ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str Tokens Text
"d:" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Step
-> ParsecT Void Text Identity Step
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (TrackTime -> Step
Duration (TrackTime -> Step)
-> ParsecT Void Text Identity TrackTime
-> ParsecT Void Text Identity Step
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (Double -> TrackTime
ScoreTime.from_double
                (Double -> TrackTime)
-> ParsecT Void Text Identity Double
-> ParsecT Void Text Identity TrackTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity Double
forall (m :: * -> *). ParserT m Double
Parse.p_float ParsecT Void Text Identity Double
-> ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
ScoreTime.suffix)))
        , Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str Tokens Text
"r:" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Step
-> ParsecT Void Text Identity Step
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (MarklistMatch -> Rank -> Step
RelativeMark (MarklistMatch -> Rank -> Step)
-> ParsecT Void Text Identity MarklistMatch
-> ParsecT Void Text Identity (Rank -> Step)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity MarklistMatch
p_marklists ParsecT Void Text Identity (Rank -> Step)
-> ParsecT Void Text Identity Rank
-> ParsecT Void Text Identity Step
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Rank
parse_rank)
        , Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str Tokens Text
"END" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Step
-> ParsecT Void Text Identity Step
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Step -> ParsecT Void Text Identity Step
forall (m :: * -> *) a. Monad m => a -> m a
return Step
BlockEdge
        , Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str Tokens Text
"start" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Step
-> ParsecT Void Text Identity Step
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Tracks -> Step
EventStart (Tracks -> Step)
-> ParsecT Void Text Identity Tracks
-> ParsecT Void Text Identity Step
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Tracks
p_tracks)
        , Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str Tokens Text
"end" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Step
-> ParsecT Void Text Identity Step
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Tracks -> Step
EventEnd (Tracks -> Step)
-> ParsecT Void Text Identity Tracks
-> ParsecT Void Text Identity Step
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Tracks
p_tracks)
        , MarklistMatch -> Rank -> Step
AbsoluteMark (MarklistMatch -> Rank -> Step)
-> ParsecT Void Text Identity MarklistMatch
-> ParsecT Void Text Identity (Rank -> Step)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity MarklistMatch
p_marklists ParsecT Void Text Identity (Rank -> Step)
-> ParsecT Void Text Identity Rank
-> ParsecT Void Text Identity Step
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Rank
parse_rank
        ]
    p_marklists :: ParsecT Void Text Identity MarklistMatch
p_marklists =
        ParsecT Void Text Identity MarklistMatch
-> ParsecT Void Text Identity MarklistMatch
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (([Text] -> MarklistMatch
NamedMarklists ([Text] -> MarklistMatch)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity MarklistMatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity [Text]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy ParsecT Void Text Identity Text
p_name (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
',')) ParsecT Void Text Identity MarklistMatch
-> ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity MarklistMatch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'|')
        ParsecT Void Text Identity MarklistMatch
-> ParsecT Void Text Identity MarklistMatch
-> ParsecT Void Text Identity MarklistMatch
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MarklistMatch -> ParsecT Void Text Identity MarklistMatch
forall (m :: * -> *) a. Monad m => a -> m a
return MarklistMatch
AllMarklists
    p_name :: ParsecT Void Text Identity Text
p_name = String -> Text
txt (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some (ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.lowerChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'-')
    p_tracks :: ParsecT Void Text Identity Tracks
p_tracks = Tracks
-> ParsecT Void Text Identity Tracks
-> ParsecT Void Text Identity Tracks
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option Tracks
CurrentTrack (ParsecT Void Text Identity Tracks
 -> ParsecT Void Text Identity Tracks)
-> ParsecT Void Text Identity Tracks
-> ParsecT Void Text Identity Tracks
forall a b. (a -> b) -> a -> b
$
        ParsecT Void Text Identity Tracks
-> ParsecT Void Text Identity Tracks
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try ([Int] -> Tracks
TrackNums ([Int] -> Tracks)
-> ParsecT Void Text Identity [Int]
-> ParsecT Void Text Identity Tracks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str Tokens Text
"s:" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity [Int]
-> ParsecT Void Text Identity [Int]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity [Int]
forall {m :: * -> *}. ParsecT Void Text m [Int]
p_tracknums))
        ParsecT Void Text Identity Tracks
-> ParsecT Void Text Identity Tracks
-> ParsecT Void Text Identity Tracks
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
's' ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity Tracks
-> ParsecT Void Text Identity Tracks
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Tracks -> ParsecT Void Text Identity Tracks
forall (m :: * -> *) a. Monad m => a -> m a
return Tracks
AllTracks
    p_tracknums :: ParsecT Void Text m [Int]
p_tracknums = ParsecT Void Text m Int
-> ParsecT Void Text m (Token Text) -> ParsecT Void Text m [Int]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy ParsecT Void Text m Int
forall (m :: * -> *). ParserT m Int
Parse.p_nat (Token Text -> ParsecT Void Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
',')
    str :: Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string

parse_rank :: Parse.Parser Meter.Rank
parse_rank :: ParsecT Void Text Identity Rank
parse_rank = [ParsecT Void Text Identity Rank]
-> ParsecT Void Text Identity Rank
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice ([ParsecT Void Text Identity Rank]
 -> ParsecT Void Text Identity Rank)
-> [ParsecT Void Text Identity Rank]
-> ParsecT Void Text Identity Rank
forall a b. (a -> b) -> a -> b
$ (ParsecT Void Text Identity Rank
 -> ParsecT Void Text Identity Rank)
-> [ParsecT Void Text Identity Rank]
-> [ParsecT Void Text Identity Rank]
forall a b. (a -> b) -> [a] -> [b]
map ParsecT Void Text Identity Rank -> ParsecT Void Text Identity Rank
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try
    [Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string Text
Tokens Text
name ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Rank
-> ParsecT Void Text Identity Rank
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Rank -> ParsecT Void Text Identity Rank
forall (m :: * -> *) a. Monad m => a -> m a
return Rank
rank | (Rank
rank, Text
name) <- [(Rank, Text)]
Meter.rank_names]

show_direction :: Direction -> Text
show_direction :: Direction -> Text
show_direction Direction
Advance = Text
"+"
show_direction Direction
Rewind = Text
"-"

-- * snap

-- | Given a pos, the point on a timestep at or previous to that pos.  If
-- there was no snap point, the pos is return unchanged.
snap :: Ui.M m => TimeStep -> BlockId -> TrackNum
    -> Maybe TrackTime -- ^ Last sel pos, needed to snap relative steps like
    -- 'Duration' and 'RelativeMark'.
    -> TrackTime -> m TrackTime
snap :: forall (m :: * -> *).
M m =>
TimeStep
-> BlockId -> Int -> Maybe TrackTime -> TrackTime -> m TrackTime
snap TimeStep
tstep BlockId
block_id Int
tracknum Maybe TrackTime
prev_pos TrackTime
pos =
    -- I only need to step from prev_pos if there's a RelativeMark in the tstep.
    -- Otherwise, I can be a bit more efficient and snap pos directly.
    TrackTime -> Maybe TrackTime -> TrackTime
forall a. a -> Maybe a -> a
fromMaybe TrackTime
pos (Maybe TrackTime -> TrackTime)
-> m (Maybe TrackTime) -> m TrackTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackTime -> m (Maybe TrackTime)
forall {f :: * -> *}. M f => TrackTime -> f (Maybe TrackTime)
snap_from (if (Step -> Bool) -> [Step] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Step -> Bool
is_relative (TimeStep -> [Step]
to_list TimeStep
tstep)
        then TrackTime -> Maybe TrackTime -> TrackTime
forall a. a -> Maybe a -> a
fromMaybe TrackTime
pos Maybe TrackTime
prev_pos else TrackTime
pos)
    where
    snap_from :: TrackTime -> f (Maybe TrackTime)
snap_from TrackTime
p
        | TrackTime
pos TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
> TrackTime
p = -- Advance p until one before pos.
            [TrackTime] -> Maybe TrackTime
forall a. [a] -> Maybe a
Seq.head ([TrackTime] -> Maybe TrackTime)
-> ([TrackTime] -> [TrackTime]) -> [TrackTime] -> Maybe TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TrackTime -> TrackTime) -> TrackTime -> [TrackTime] -> [TrackTime]
forall key a. Ord key => (a -> key) -> key -> [a] -> [a]
Seq.drop_before TrackTime -> TrackTime
forall a. a -> a
id TrackTime
pos ([TrackTime] -> Maybe TrackTime)
-> f [TrackTime] -> f (Maybe TrackTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> f [TrackTime]
forall (m :: * -> *).
M m =>
Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> m [TrackTime]
get_points_from Direction
Advance BlockId
block_id Int
tracknum TrackTime
p TimeStep
tstep
        | Bool
otherwise = -- Rewind p until before pos.
            [TrackTime] -> Maybe TrackTime
forall a. [a] -> Maybe a
Seq.head ([TrackTime] -> Maybe TrackTime)
-> ([TrackTime] -> [TrackTime]) -> [TrackTime] -> Maybe TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TrackTime -> Bool) -> [TrackTime] -> [TrackTime]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
>TrackTime
pos) ([TrackTime] -> Maybe TrackTime)
-> f [TrackTime] -> f (Maybe TrackTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> f [TrackTime]
forall (m :: * -> *).
M m =>
Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> m [TrackTime]
get_points_from Direction
Rewind BlockId
block_id Int
tracknum TrackTime
p TimeStep
tstep
    is_relative :: Step -> Bool
is_relative (Duration {}) = Bool
True
    is_relative (RelativeMark {}) = Bool
True
    is_relative Step
_ = Bool
False

-- * step

rewind :: Ui.M m => TimeStep -> BlockId -> TrackNum -> TrackTime
    -> m (Maybe TrackTime)
rewind :: forall (m :: * -> *).
M m =>
TimeStep -> BlockId -> Int -> TrackTime -> m (Maybe TrackTime)
rewind = Int
-> TimeStep -> BlockId -> Int -> TrackTime -> m (Maybe TrackTime)
forall (m :: * -> *).
M m =>
Int
-> TimeStep -> BlockId -> Int -> TrackTime -> m (Maybe TrackTime)
step_from (-Int
1)

advance :: Ui.M m => TimeStep -> BlockId -> TrackNum -> TrackTime
    -> m (Maybe TrackTime)
advance :: forall (m :: * -> *).
M m =>
TimeStep -> BlockId -> Int -> TrackTime -> m (Maybe TrackTime)
advance = Int
-> TimeStep -> BlockId -> Int -> TrackTime -> m (Maybe TrackTime)
forall (m :: * -> *).
M m =>
Int
-> TimeStep -> BlockId -> Int -> TrackTime -> m (Maybe TrackTime)
step_from Int
1

direction :: Direction -> Int
direction :: Direction -> Int
direction Direction
Advance = Int
1
direction Direction
Rewind = -Int
1

duration_at :: Ui.M m => BlockId -> TrackNum -> TrackTime -> TimeStep
    -> m (Maybe ScoreTime)
duration_at :: forall (m :: * -> *).
M m =>
BlockId -> Int -> TrackTime -> TimeStep -> m (Maybe TrackTime)
duration_at BlockId
block_id Int
tracknum TrackTime
pos TimeStep
tstep = do
    [TrackTime]
pre <- Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> m [TrackTime]
forall (m :: * -> *).
M m =>
Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> m [TrackTime]
get_points_from Direction
Rewind BlockId
block_id Int
tracknum TrackTime
pos TimeStep
tstep
    [TrackTime]
post <- Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> m [TrackTime]
forall (m :: * -> *).
M m =>
Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> m [TrackTime]
get_points_from Direction
Advance BlockId
block_id Int
tracknum TrackTime
pos TimeStep
tstep
    Maybe TrackTime -> m (Maybe TrackTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TrackTime -> m (Maybe TrackTime))
-> Maybe TrackTime -> m (Maybe TrackTime)
forall a b. (a -> b) -> a -> b
$ case ([TrackTime]
pre, (TrackTime -> Bool) -> [TrackTime] -> [TrackTime]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
==TrackTime
pos) [TrackTime]
post) of
        (TrackTime
t0 : [TrackTime]
_, TrackTime
t1 : [TrackTime]
_) -> TrackTime -> Maybe TrackTime
forall a. a -> Maybe a
Just (TrackTime
t1 TrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
- TrackTime
t0)
        ([TrackTime], [TrackTime])
_ -> Maybe TrackTime
forall a. Maybe a
Nothing

-- | Step in the given direction from the given position, or Nothing if
-- there is no step from that point.  This may return a point past the end of
-- the ruler, or before 0, so if the caller wants to step the selection it
-- should make sure to limit the value.  The reason is that this is also used
-- to get e.g. the duration of a whole note at a given point, and that should
-- work even if the given point is near the end of the ruler.
step_from :: Ui.M m => Int -> TimeStep -> BlockId -> TrackNum
    -> TrackTime -> m (Maybe TrackTime)
step_from :: forall (m :: * -> *).
M m =>
Int
-> TimeStep -> BlockId -> Int -> TrackTime -> m (Maybe TrackTime)
step_from Int
steps TimeStep
tstep BlockId
block_id Int
tracknum TrackTime
start = [TrackTime] -> Maybe TrackTime
extract ([TrackTime] -> Maybe TrackTime)
-> m [TrackTime] -> m (Maybe TrackTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> m [TrackTime]
forall (m :: * -> *).
M m =>
Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> m [TrackTime]
get_points_from (if Int
steps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 then Direction
Advance else Direction
Rewind) BlockId
block_id Int
tracknum
        TrackTime
start TimeStep
tstep
    where
    extract :: [TrackTime] -> Maybe TrackTime
extract = [TrackTime] -> Maybe TrackTime
forall a. [a] -> Maybe a
Seq.head
        ([TrackTime] -> Maybe TrackTime)
-> ([TrackTime] -> [TrackTime]) -> [TrackTime] -> Maybe TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Int
steps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [TrackTime] -> [TrackTime]
forall a. a -> a
id else Int -> [TrackTime] -> [TrackTime]
forall a. Int -> [a] -> [a]
drop (Int -> Int
forall a. Num a => a -> a
abs Int
steps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([TrackTime] -> [TrackTime])
-> ([TrackTime] -> [TrackTime]) -> [TrackTime] -> [TrackTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TrackTime -> Bool) -> [TrackTime] -> [TrackTime]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
==TrackTime
start)

get_points_from :: Ui.M m => Direction -> BlockId -> TrackNum -> TrackTime
    -> TimeStep -> m [TrackTime]
get_points_from :: forall (m :: * -> *).
M m =>
Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> m [TrackTime]
get_points_from Direction
dir BlockId
block_id Int
tracknum TrackTime
start TimeStep
tstep =
    Direction -> [[TrackTime]] -> [TrackTime]
merge_points Direction
dir ([[TrackTime]] -> [TrackTime]) -> m [[TrackTime]] -> m [TrackTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Step -> m [TrackTime]) -> [Step] -> m [[TrackTime]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BlockId -> Int -> TrackTime -> Step -> m [TrackTime]
get BlockId
block_id Int
tracknum TrackTime
start) (TimeStep -> [Step]
to_list TimeStep
tstep)
    where
    get :: BlockId -> Int -> TrackTime -> Step -> m [TrackTime]
get = case Direction
dir of
        Direction
Advance -> BlockId -> Int -> TrackTime -> Step -> m [TrackTime]
forall (m :: * -> *).
M m =>
BlockId -> Int -> TrackTime -> Step -> m [TrackTime]
ascending_points
        Direction
Rewind -> BlockId -> Int -> TrackTime -> Step -> m [TrackTime]
forall (m :: * -> *).
M m =>
BlockId -> Int -> TrackTime -> Step -> m [TrackTime]
descending_points

-- | Step points ascending from the given time.  Includes the start
-- point.
ascending_points :: Ui.M m => BlockId -> TrackNum -> TrackTime -> Step
    -> m [TrackTime]
ascending_points :: forall (m :: * -> *).
M m =>
BlockId -> Int -> TrackTime -> Step -> m [TrackTime]
ascending_points BlockId
block_id Int
tracknum TrackTime
start Step
step =
    (TrackTime -> Bool) -> [TrackTime] -> [TrackTime]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
<TrackTime
start) ([TrackTime] -> [TrackTime]) -> m [TrackTime] -> m [TrackTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Step
step of
        Duration TrackTime
t -> do
            TrackTime
end <- BlockId -> m TrackTime
forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_ruler_end BlockId
block_id
            [TrackTime] -> m [TrackTime]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TrackTime] -> m [TrackTime]) -> [TrackTime] -> m [TrackTime]
forall a b. (a -> b) -> a -> b
$ TrackTime -> TrackTime -> TrackTime -> [TrackTime]
forall a. (Num a, Ord a) => a -> a -> a -> [a]
Seq.range TrackTime
start TrackTime
end TrackTime
t
        AbsoluteMark MarklistMatch
match Rank
rank ->
            Direction
-> Bool
-> MarklistMatch
-> Rank
-> TrackTime
-> Marklists
-> [TrackTime]
get_marks Direction
Advance Bool
False MarklistMatch
match Rank
rank TrackTime
start (Marklists -> [TrackTime]) -> m Marklists -> m [TrackTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                BlockId -> Int -> m Marklists
forall (m :: * -> *). M m => BlockId -> Int -> m Marklists
get_ruler BlockId
block_id Int
tracknum
        RelativeMark MarklistMatch
match Rank
rank ->
            [TrackTime] -> [TrackTime]
shift ([TrackTime] -> [TrackTime])
-> (Marklists -> [TrackTime]) -> Marklists -> [TrackTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction
-> Bool
-> MarklistMatch
-> Rank
-> TrackTime
-> Marklists
-> [TrackTime]
get_marks Direction
Advance Bool
True MarklistMatch
match Rank
rank TrackTime
start (Marklists -> [TrackTime]) -> m Marklists -> m [TrackTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                BlockId -> Int -> m Marklists
forall (m :: * -> *). M m => BlockId -> Int -> m Marklists
get_ruler BlockId
block_id Int
tracknum
        Step
BlockEdge -> do
            TrackTime
end <- BlockId -> m TrackTime
forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_ruler_end BlockId
block_id
            [TrackTime] -> m [TrackTime]
forall (m :: * -> *) a. Monad m => a -> m a
return [TrackTime
0, TrackTime
end]
        EventStart Tracks
tracks ->
            Direction
-> Bool -> BlockId -> Int -> TrackTime -> Tracks -> m [TrackTime]
forall (m :: * -> *).
M m =>
Direction
-> Bool -> BlockId -> Int -> TrackTime -> Tracks -> m [TrackTime]
track_events Direction
Advance Bool
True BlockId
block_id Int
tracknum TrackTime
start Tracks
tracks
        EventEnd Tracks
tracks ->
            Direction
-> Bool -> BlockId -> Int -> TrackTime -> Tracks -> m [TrackTime]
forall (m :: * -> *).
M m =>
Direction
-> Bool -> BlockId -> Int -> TrackTime -> Tracks -> m [TrackTime]
track_events Direction
Advance Bool
False BlockId
block_id Int
tracknum TrackTime
start Tracks
tracks
    where
    shift :: [TrackTime] -> [TrackTime]
shift [] = []
    shift (TrackTime
p:[TrackTime]
ps)
        | TrackTime
p TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
start = TrackTime
p TrackTime -> [TrackTime] -> [TrackTime]
forall a. a -> [a] -> [a]
: [TrackTime]
ps
        | Bool
otherwise = (TrackTime -> TrackTime) -> [TrackTime] -> [TrackTime]
forall a b. (a -> b) -> [a] -> [b]
map (TrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
+ (TrackTime
startTrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
-TrackTime
p)) (TrackTime
pTrackTime -> [TrackTime] -> [TrackTime]
forall a. a -> [a] -> [a]
:[TrackTime]
ps)

-- | Step points descending from the given time.  Includes the start
-- point.
descending_points :: Ui.M m => BlockId -> TrackNum -> TrackTime -> Step
    -> m [TrackTime]
descending_points :: forall (m :: * -> *).
M m =>
BlockId -> Int -> TrackTime -> Step -> m [TrackTime]
descending_points BlockId
block_id Int
tracknum TrackTime
start Step
step =
    (TrackTime -> Bool) -> [TrackTime] -> [TrackTime]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
>TrackTime
start) ([TrackTime] -> [TrackTime]) -> m [TrackTime] -> m [TrackTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Step
step of
        Duration TrackTime
t -> [TrackTime] -> m [TrackTime]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TrackTime] -> m [TrackTime]) -> [TrackTime] -> m [TrackTime]
forall a b. (a -> b) -> a -> b
$ TrackTime -> TrackTime -> TrackTime -> [TrackTime]
forall a. (Num a, Ord a) => a -> a -> a -> [a]
Seq.range TrackTime
start TrackTime
0 (-TrackTime
t)
        AbsoluteMark MarklistMatch
match Rank
rank ->
            Direction
-> Bool
-> MarklistMatch
-> Rank
-> TrackTime
-> Marklists
-> [TrackTime]
get_marks Direction
Rewind Bool
True MarklistMatch
match Rank
rank TrackTime
start (Marklists -> [TrackTime]) -> m Marklists -> m [TrackTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                BlockId -> Int -> m Marklists
forall (m :: * -> *). M m => BlockId -> Int -> m Marklists
get_ruler BlockId
block_id Int
tracknum
        RelativeMark MarklistMatch
match Rank
rank ->
            [TrackTime] -> [TrackTime]
shift ([TrackTime] -> [TrackTime])
-> (Marklists -> [TrackTime]) -> Marklists -> [TrackTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction
-> Bool
-> MarklistMatch
-> Rank
-> TrackTime
-> Marklists
-> [TrackTime]
get_marks Direction
Rewind Bool
True MarklistMatch
match Rank
rank TrackTime
start (Marklists -> [TrackTime]) -> m Marklists -> m [TrackTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                BlockId -> Int -> m Marklists
forall (m :: * -> *). M m => BlockId -> Int -> m Marklists
get_ruler BlockId
block_id Int
tracknum
        Step
BlockEdge -> do
            TrackTime
end <- BlockId -> m TrackTime
forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_ruler_end BlockId
block_id
            [TrackTime] -> m [TrackTime]
forall (m :: * -> *) a. Monad m => a -> m a
return [TrackTime
end, TrackTime
0]
        EventStart Tracks
tracks ->
            Direction
-> Bool -> BlockId -> Int -> TrackTime -> Tracks -> m [TrackTime]
forall (m :: * -> *).
M m =>
Direction
-> Bool -> BlockId -> Int -> TrackTime -> Tracks -> m [TrackTime]
track_events Direction
Rewind Bool
True BlockId
block_id Int
tracknum TrackTime
start Tracks
tracks
        EventEnd Tracks
tracks ->
            Direction
-> Bool -> BlockId -> Int -> TrackTime -> Tracks -> m [TrackTime]
forall (m :: * -> *).
M m =>
Direction
-> Bool -> BlockId -> Int -> TrackTime -> Tracks -> m [TrackTime]
track_events Direction
Rewind Bool
False BlockId
block_id Int
tracknum TrackTime
start Tracks
tracks
    where
    shift :: [TrackTime] -> [TrackTime]
shift [] = []
    shift (TrackTime
p:[TrackTime]
ps)
        | TrackTime
p TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
start = TrackTime
p TrackTime -> [TrackTime] -> [TrackTime]
forall a. a -> [a] -> [a]
: [TrackTime]
ps
        | Bool
otherwise = (TrackTime -> TrackTime) -> [TrackTime] -> [TrackTime]
forall a b. (a -> b) -> [a] -> [b]
map (TrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
+ (TrackTime
startTrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
-TrackTime
p)) (TrackTime
pTrackTime -> [TrackTime] -> [TrackTime]
forall a. a -> [a] -> [a]
:[TrackTime]
ps)

track_events :: Ui.M m => Direction -> Bool
    -> BlockId -> TrackNum -> TrackTime -> Tracks -> m [TrackTime]
track_events :: forall (m :: * -> *).
M m =>
Direction
-> Bool -> BlockId -> Int -> TrackTime -> Tracks -> m [TrackTime]
track_events Direction
dir Bool
event_start BlockId
block_id Int
tracknum TrackTime
start = \case
    Tracks
AllTracks -> do
        [TrackId]
track_ids <- BlockId -> m [TrackId]
forall (m :: * -> *). M m => BlockId -> m [TrackId]
Ui.track_ids_of BlockId
block_id
        Direction -> [[TrackTime]] -> [TrackTime]
merge_points Direction
dir ([[TrackTime]] -> [TrackTime]) -> m [[TrackTime]] -> m [TrackTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TrackId -> m [TrackTime]) -> [TrackId] -> m [[TrackTime]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TrackId -> m [TrackTime]
get_times [TrackId]
track_ids
    Tracks
CurrentTrack -> TrackId -> m [TrackTime]
get_times (TrackId -> m [TrackTime]) -> m TrackId -> m [TrackTime]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId -> Int -> m TrackId
forall (m :: * -> *). M m => BlockId -> Int -> m TrackId
Ui.get_event_track_at BlockId
block_id Int
tracknum
    TrackNums [Int]
tracknums -> do
        [TrackId]
track_ids <- (Int -> m TrackId) -> [Int] -> m [TrackId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BlockId -> Int -> m TrackId
forall (m :: * -> *). M m => BlockId -> Int -> m TrackId
Ui.get_event_track_at BlockId
block_id) [Int]
tracknums
        Direction -> [[TrackTime]] -> [TrackTime]
merge_points Direction
dir ([[TrackTime]] -> [TrackTime]) -> m [[TrackTime]] -> m [TrackTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TrackId -> m [TrackTime]) -> [TrackId] -> m [[TrackTime]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TrackId -> m [TrackTime]
get_times [TrackId]
track_ids
    where
    event_time :: Event -> TrackTime
event_time = if Bool
event_start then Event -> TrackTime
Event.start else Event -> TrackTime
Event.end
    get_times :: TrackId -> m [TrackTime]
get_times = (Events -> [TrackTime]) -> m Events -> m [TrackTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Event -> TrackTime) -> [Event] -> [TrackTime]
forall a b. (a -> b) -> [a] -> [b]
map Event -> TrackTime
event_time ([Event] -> [TrackTime])
-> (Events -> [Event]) -> Events -> [TrackTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> [Event]
get_events) (m Events -> m [TrackTime])
-> (TrackId -> m Events) -> TrackId -> m [TrackTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackId -> m Events
forall (m :: * -> *). M m => TrackId -> m Events
Ui.get_events
    get_events :: Events -> [Event]
get_events = case Direction
dir of
        Direction
Advance -> if Bool
event_start then TrackTime -> Events -> [Event]
Events.at_after TrackTime
start
            else ([Event], [Event]) -> [Event]
forall a b. (a, b) -> b
snd (([Event], [Event]) -> [Event])
-> (Events -> ([Event], [Event])) -> Events -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Events -> ([Event], [Event])
Events.split_at_before TrackTime
start
        Direction
Rewind -> TrackTime -> Events -> [Event]
at_before TrackTime
start
    at_before :: TrackTime -> Events -> [Event]
at_before TrackTime
p Events
events = case [Event]
post of
            Event
e : [Event]
_ | Event -> TrackTime
Event.start Event
e TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
p -> Event
e Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
pre
            [Event]
_ -> [Event]
pre
        where ([Event]
pre, [Event]
post) = TrackTime -> Events -> ([Event], [Event])
Events.split_lists TrackTime
p Events
events

merge_points :: Direction -> [[TrackTime]] -> [TrackTime]
merge_points :: Direction -> [[TrackTime]] -> [TrackTime]
merge_points Direction
Advance = (TrackTime -> TrackTime) -> [TrackTime] -> [TrackTime]
forall k a. Eq k => (a -> k) -> [a] -> [a]
Seq.drop_dups TrackTime -> TrackTime
forall a. a -> a
id ([TrackTime] -> [TrackTime])
-> ([[TrackTime]] -> [TrackTime]) -> [[TrackTime]] -> [TrackTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TrackTime -> TrackTime) -> [[TrackTime]] -> [TrackTime]
forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Seq.merge_lists TrackTime -> TrackTime
forall a. a -> a
id
merge_points Direction
Rewind = (TrackTime -> TrackTime) -> [TrackTime] -> [TrackTime]
forall k a. Eq k => (a -> k) -> [a] -> [a]
Seq.drop_dups TrackTime -> TrackTime
forall a. a -> a
id ([TrackTime] -> [TrackTime])
-> ([[TrackTime]] -> [TrackTime]) -> [[TrackTime]] -> [TrackTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TrackTime]] -> [TrackTime]
merge_desc

merge_desc :: [[TrackTime]] -> [TrackTime]
merge_desc :: [[TrackTime]] -> [TrackTime]
merge_desc = ([TrackTime] -> [TrackTime] -> [TrackTime])
-> [TrackTime] -> [[TrackTime]] -> [TrackTime]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((TrackTime -> TrackTime -> Ordering)
-> [TrackTime] -> [TrackTime] -> [TrackTime]
forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
Ordered.mergeBy ((TrackTime -> TrackTime -> Ordering)
-> TrackTime -> TrackTime -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip TrackTime -> TrackTime -> Ordering
forall a. Ord a => a -> a -> Ordering
compare)) []

-- | Get all marks from the marklists that match the proper names and
-- merge their marks into one list.
get_marks :: Direction -> Bool -> MarklistMatch -> Meter.Rank -> TrackTime
    -> Ruler.Marklists -> [TrackTime]
get_marks :: Direction
-> Bool
-> MarklistMatch
-> Rank
-> TrackTime
-> Marklists
-> [TrackTime]
get_marks Direction
dir Bool
minus1 MarklistMatch
match Rank
rank TrackTime
start Marklists
marklists =
    Direction -> [[TrackTime]] -> [TrackTime]
merge_points Direction
dir ([[TrackTime]] -> [TrackTime]) -> [[TrackTime]] -> [TrackTime]
forall a b. (a -> b) -> a -> b
$ (Marklist -> [TrackTime]) -> [Marklist] -> [[TrackTime]]
forall a b. (a -> b) -> [a] -> [b]
map Marklist -> [TrackTime]
extract [Marklist]
matching
    where
    extract :: Marklist -> [TrackTime]
extract = case Direction
dir of
        Direction
Advance
            | Bool
minus1 -> Marklist -> [TrackTime]
ascending1
            | Bool
otherwise -> [(TrackTime, Mark)] -> [TrackTime]
forall {b}. [(b, Mark)] -> [b]
with_rank ([(TrackTime, Mark)] -> [TrackTime])
-> (Marklist -> [(TrackTime, Mark)]) -> Marklist -> [TrackTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Marklist -> [(TrackTime, Mark)]
Mark.ascending TrackTime
start
        Direction
Rewind
            | Bool
minus1 -> Marklist -> [TrackTime]
descending1
            | Bool
otherwise -> [(TrackTime, Mark)] -> [TrackTime]
forall {b}. [(b, Mark)] -> [b]
with_rank ([(TrackTime, Mark)] -> [TrackTime])
-> (Marklist -> [(TrackTime, Mark)]) -> Marklist -> [TrackTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Marklist -> [(TrackTime, Mark)]
Mark.descending TrackTime
start
    matching :: [Marklist]
matching = ((Maybe Meter, Marklist) -> Marklist)
-> [(Maybe Meter, Marklist)] -> [Marklist]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Meter, Marklist) -> Marklist
forall a b. (a, b) -> b
snd ([(Maybe Meter, Marklist)] -> [Marklist])
-> [(Maybe Meter, Marklist)] -> [Marklist]
forall a b. (a -> b) -> a -> b
$ case MarklistMatch
match of
        MarklistMatch
AllMarklists -> Marklists -> [(Maybe Meter, Marklist)]
forall k a. Map k a -> [a]
Map.elems Marklists
marklists
        NamedMarklists [Text]
names -> (Text -> Maybe (Maybe Meter, Marklist))
-> [Text] -> [(Maybe Meter, Marklist)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Text -> Marklists -> Maybe (Maybe Meter, Marklist))
-> Marklists -> Text -> Maybe (Maybe Meter, Marklist)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Marklists -> Maybe (Maybe Meter, Marklist)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Marklists
marklists) [Text]
names
    ascending1 :: Marklist -> [TrackTime]
ascending1 Marklist
mlist
        | Just TrackTime
p <- [TrackTime] -> Maybe TrackTime
forall a. [a] -> Maybe a
Seq.head [TrackTime]
marks, TrackTime
p TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
start = [TrackTime]
marks
        | Bool
otherwise = [TrackTime]
-> (TrackTime -> [TrackTime]) -> Maybe TrackTime -> [TrackTime]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TrackTime]
marks (TrackTime -> [TrackTime] -> [TrackTime]
forall a. a -> [a] -> [a]
:[TrackTime]
marks) (Maybe TrackTime -> [TrackTime]) -> Maybe TrackTime -> [TrackTime]
forall a b. (a -> b) -> a -> b
$
            [TrackTime] -> Maybe TrackTime
forall a. [a] -> Maybe a
Seq.head ([(TrackTime, Mark)] -> [TrackTime]
forall {b}. [(b, Mark)] -> [b]
with_rank ([(TrackTime, Mark)] -> [TrackTime])
-> [(TrackTime, Mark)] -> [TrackTime]
forall a b. (a -> b) -> a -> b
$ TrackTime -> Marklist -> [(TrackTime, Mark)]
Mark.descending TrackTime
start Marklist
mlist)
        where marks :: [TrackTime]
marks = [(TrackTime, Mark)] -> [TrackTime]
forall {b}. [(b, Mark)] -> [b]
with_rank ([(TrackTime, Mark)] -> [TrackTime])
-> [(TrackTime, Mark)] -> [TrackTime]
forall a b. (a -> b) -> a -> b
$ TrackTime -> Marklist -> [(TrackTime, Mark)]
Mark.ascending TrackTime
start Marklist
mlist
    descending1 :: Marklist -> [TrackTime]
descending1 Marklist
mlist = [TrackTime]
-> (TrackTime -> [TrackTime]) -> Maybe TrackTime -> [TrackTime]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TrackTime]
marks (TrackTime -> [TrackTime] -> [TrackTime]
forall a. a -> [a] -> [a]
:[TrackTime]
marks) (Maybe TrackTime -> [TrackTime]) -> Maybe TrackTime -> [TrackTime]
forall a b. (a -> b) -> a -> b
$
        [TrackTime] -> Maybe TrackTime
forall a. [a] -> Maybe a
Seq.head ([(TrackTime, Mark)] -> [TrackTime]
forall {b}. [(b, Mark)] -> [b]
with_rank ([(TrackTime, Mark)] -> [TrackTime])
-> [(TrackTime, Mark)] -> [TrackTime]
forall a b. (a -> b) -> a -> b
$ TrackTime -> Marklist -> [(TrackTime, Mark)]
Mark.ascending TrackTime
start Marklist
mlist)
        where marks :: [TrackTime]
marks = [(TrackTime, Mark)] -> [TrackTime]
forall {b}. [(b, Mark)] -> [b]
with_rank ([(TrackTime, Mark)] -> [TrackTime])
-> [(TrackTime, Mark)] -> [TrackTime]
forall a b. (a -> b) -> a -> b
$ TrackTime -> Marklist -> [(TrackTime, Mark)]
Mark.descending TrackTime
start Marklist
mlist
    with_rank :: [(b, Mark)] -> [b]
with_rank = ((b, Mark) -> b) -> [(b, Mark)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, Mark) -> b
forall a b. (a, b) -> a
fst ([(b, Mark)] -> [b])
-> ([(b, Mark)] -> [(b, Mark)]) -> [(b, Mark)] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, Mark) -> Bool) -> [(b, Mark)] -> [(b, Mark)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Rank -> Rank -> Bool
forall a. Ord a => a -> a -> Bool
<=Rank
rank) (Rank -> Bool) -> ((b, Mark) -> Rank) -> (b, Mark) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mark -> Rank
Mark.mark_rank (Mark -> Rank) -> ((b, Mark) -> Mark) -> (b, Mark) -> Rank
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, Mark) -> Mark
forall a b. (a, b) -> b
snd)

get_ruler :: Ui.M m => BlockId -> TrackNum -> m Ruler.Marklists
get_ruler :: forall (m :: * -> *). M m => BlockId -> Int -> m Marklists
get_ruler BlockId
block_id Int
tracknum = do
    RulerId
ruler_id <- RulerId -> Maybe RulerId -> RulerId
forall a. a -> Maybe a -> a
fromMaybe RulerId
Ui.no_ruler (Maybe RulerId -> RulerId) -> m (Maybe RulerId) -> m RulerId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> Int -> m (Maybe RulerId)
forall (m :: * -> *). M m => BlockId -> Int -> m (Maybe RulerId)
Ui.ruler_track_at BlockId
block_id Int
tracknum
    Ruler -> Marklists
Ruler.ruler_marklists (Ruler -> Marklists) -> m Ruler -> m Marklists
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RulerId -> m Ruler
forall (m :: * -> *). M m => RulerId -> m Ruler
Ui.get_ruler RulerId
ruler_id