-- 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.Lists as Lists
import qualified Util.P as P
import qualified Util.Parse as Parse

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
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
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Step -> Step
modify 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 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
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
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
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
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
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
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
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
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 forall a. Eq a => a -> a -> Bool
== TimeStep
event_edge = Text
"E"
    | Bool
otherwise = Text -> [Text] -> Text
Text.intercalate 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:" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackTime
pos
        RelativeMark MarklistMatch
mlists Rank
rank ->
            Text
"r:" forall a. Semigroup a => a -> a -> a
<> MarklistMatch -> Text
show_marklists MarklistMatch
mlists forall a. Semigroup a => a -> a -> a
<> Rank -> Text
Meter.rank_name Rank
rank
        Step
BlockEdge -> Text
"END"
        EventStart Tracks
tracks -> Text
"start" forall a. Semigroup a => a -> a -> a
<> Tracks -> Text
show_tracks Tracks
tracks
        EventEnd Tracks
tracks -> Text
"end" forall a. Semigroup a => a -> a -> a
<> Tracks -> Text
show_tracks Tracks
tracks
        AbsoluteMark MarklistMatch
mlists Rank
rank ->
            MarklistMatch -> Text
show_marklists MarklistMatch
mlists 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 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:" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"," (forall a b. (a -> b) -> [a] -> [b]
map 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 = forall a. Parser a -> Text -> Either Text a
Parse.parse ParsecT Void Text Identity TimeStep
p_time_step
    where
    p_time_step :: ParsecT Void Text Identity TimeStep
p_time_step = [Step] -> TimeStep
TimeStep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy ParsecT Void Text Identity Step
p_step (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
';')
    -- P.choice must backtrack because AbsoluteMark parses can overlap.
    p_step :: ParsecT Void Text Identity Step
p_step = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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:" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (TrackTime -> Step
Duration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (Double -> TrackTime
ScoreTime.from_double
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). ParserT m Double
Parse.p_float forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
ScoreTime.suffix)))
        , Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str Tokens Text
"r:" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (MarklistMatch -> Rank -> Step
RelativeMark forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity MarklistMatch
p_marklists forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Rank
parse_rank)
        , Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str Tokens Text
"END" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return Step
BlockEdge
        , Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str Tokens Text
"start" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Tracks -> Step
EventStart 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" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Tracks -> Step
EventEnd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Tracks
p_tracks)
        , MarklistMatch -> Rank -> Step
AbsoluteMark forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity MarklistMatch
p_marklists forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Rank
parse_rank
        ]
    p_marklists :: ParsecT Void Text Identity MarklistMatch
p_marklists =
        forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (([Text] -> MarklistMatch
NamedMarklists forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy ParsecT Void Text Identity Text
p_name (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
',')) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'|')
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return MarklistMatch
AllMarklists
    p_name :: ParsecT Void Text Identity Text
p_name = String -> Text
txt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.lowerChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'-')
    p_tracks :: ParsecT Void Text Identity Tracks
p_tracks = forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option Tracks
CurrentTrack forall a b. (a -> b) -> a -> b
$
        forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try ([Int] -> Tracks
TrackNums forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str Tokens Text
"s:" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall {m :: * -> *}. ParsecT Void Text m [Int]
p_tracknums))
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
's' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return Tracks
AllTracks
    p_tracknums :: ParsecT Void Text m [Int]
p_tracknums = forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy forall (m :: * -> *). ParserT m Int
Parse.p_nat (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
',')
    str :: Tokens Text -> ParsecT Void Text Identity (Tokens Text)
str = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string

parse_rank :: Parse.Parser Meter.Rank
parse_rank :: Parser Rank
parse_rank = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try
    [forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string Text
name forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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.
    forall a. a -> Maybe a -> a
fromMaybe TrackTime
pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *}. M f => TrackTime -> f (Maybe TrackTime)
snap_from (if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Step -> Bool
is_relative (TimeStep -> [Step]
to_list TimeStep
tstep)
        then 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 forall a. Ord a => a -> a -> Bool
> TrackTime
p = -- Advance p until one before pos.
            forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Ord key => (a -> key) -> key -> [a] -> [a]
Lists.dropBefore forall a. a -> a
id TrackTime
pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                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.
            forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Ord a => a -> a -> Bool
>TrackTime
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                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 = 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 = 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 <- 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 <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case ([TrackTime]
pre, forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
==TrackTime
pos) [TrackTime]
post) of
        (TrackTime
t0 : [TrackTime]
_, TrackTime
t1 : [TrackTime]
_) -> forall a. a -> Maybe a
Just (TrackTime
t1 forall a. Num a => a -> a -> a
- TrackTime
t0)
        ([TrackTime], [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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (m :: * -> *).
M m =>
Direction
-> BlockId -> Int -> TrackTime -> TimeStep -> m [TrackTime]
get_points_from (if Int
steps 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 = forall a. [a] -> Maybe a
Lists.head
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Int
steps forall a. Eq a => a -> a -> Bool
== Int
0 then forall a. a -> a
id else forall a. Int -> [a] -> [a]
drop (forall a. Num a => a -> a
abs Int
steps forall a. Num a => a -> a -> a
- Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> forall (m :: * -> *).
M m =>
BlockId -> Int -> TrackTime -> Step -> m [TrackTime]
ascending_points
        Direction
Rewind -> 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 =
    forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Ord a => a -> a -> Bool
<TrackTime
start) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Step
step of
        Duration TrackTime
t -> do
            TrackTime
end <- forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_ruler_end BlockId
block_id
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall (m :: * -> *). M m => BlockId -> Int -> m Marklists
get_ruler BlockId
block_id Int
tracknum
        RelativeMark MarklistMatch
match Rank
rank ->
            [TrackTime] -> [TrackTime]
shift 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall (m :: * -> *). M m => BlockId -> Int -> m Marklists
get_ruler BlockId
block_id Int
tracknum
        Step
BlockEdge -> do
            TrackTime
end <- forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_ruler_end BlockId
block_id
            forall (m :: * -> *) a. Monad m => a -> m a
return [TrackTime
0, TrackTime
end]
        EventStart Tracks
tracks ->
            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 ->
            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 forall a. Eq a => a -> a -> Bool
== TrackTime
start = TrackTime
p forall a. a -> [a] -> [a]
: [TrackTime]
ps
        | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
+ (TrackTime
startforall a. Num a => a -> a -> a
-TrackTime
p)) (TrackTime
pforall 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 =
    forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Ord a => a -> a -> Bool
>TrackTime
start) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Step
step of
        Duration TrackTime
t -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall (m :: * -> *). M m => BlockId -> Int -> m Marklists
get_ruler BlockId
block_id Int
tracknum
        RelativeMark MarklistMatch
match Rank
rank ->
            [TrackTime] -> [TrackTime]
shift 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall (m :: * -> *). M m => BlockId -> Int -> m Marklists
get_ruler BlockId
block_id Int
tracknum
        Step
BlockEdge -> do
            TrackTime
end <- forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_ruler_end BlockId
block_id
            forall (m :: * -> *) a. Monad m => a -> m a
return [TrackTime
end, TrackTime
0]
        EventStart Tracks
tracks ->
            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 ->
            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 forall a. Eq a => a -> a -> Bool
== TrackTime
start = TrackTime
p forall a. a -> [a] -> [a]
: [TrackTime]
ps
        | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
+ (TrackTime
startforall a. Num a => a -> a -> a
-TrackTime
p)) (TrackTime
pforall 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 <- forall (m :: * -> *). M m => BlockId -> m [TrackId]
Ui.track_ids_of BlockId
block_id
        Direction -> [[TrackTime]] -> [TrackTime]
merge_points Direction
dir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map Event -> TrackTime
event_time forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> [Event]
get_events) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a, b) -> b
snd 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 forall a. Eq a => a -> a -> Bool
== TrackTime
p -> Event
e 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 = forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropDups forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Lists.mergeLists forall a. a -> a
id
merge_points Direction
Rewind = forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropDups forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TrackTime]] -> [TrackTime]
merge_desc

merge_desc :: [[TrackTime]] -> [TrackTime]
merge_desc :: [[TrackTime]] -> [TrackTime]
merge_desc = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
Ordered.mergeBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 forall a b. (a -> b) -> a -> b
$ 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 -> forall {b}. [(b, Mark)] -> [b]
with_rank forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Marklist -> [PosMark]
Mark.ascending TrackTime
start
        Direction
Rewind
            | Bool
minus1 -> Marklist -> [TrackTime]
descending1
            | Bool
otherwise -> forall {b}. [(b, Mark)] -> [b]
with_rank forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Marklist -> [PosMark]
Mark.descending TrackTime
start
    matching :: [Marklist]
matching = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ case MarklistMatch
match of
        MarklistMatch
AllMarklists -> forall k a. Map k a -> [a]
Map.elems Marklists
marklists
        NamedMarklists [Text]
names -> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 <- forall a. [a] -> Maybe a
Lists.head [TrackTime]
marks, TrackTime
p forall a. Eq a => a -> a -> Bool
== TrackTime
start = [TrackTime]
marks
        | Bool
otherwise = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TrackTime]
marks (forall a. a -> [a] -> [a]
:[TrackTime]
marks) forall a b. (a -> b) -> a -> b
$
            forall a. [a] -> Maybe a
Lists.head (forall {b}. [(b, Mark)] -> [b]
with_rank forall a b. (a -> b) -> a -> b
$ TrackTime -> Marklist -> [PosMark]
Mark.descending TrackTime
start Marklist
mlist)
        where marks :: [TrackTime]
marks = forall {b}. [(b, Mark)] -> [b]
with_rank forall a b. (a -> b) -> a -> b
$ TrackTime -> Marklist -> [PosMark]
Mark.ascending TrackTime
start Marklist
mlist
    descending1 :: Marklist -> [TrackTime]
descending1 Marklist
mlist = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TrackTime]
marks (forall a. a -> [a] -> [a]
:[TrackTime]
marks) forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> Maybe a
Lists.head (forall {b}. [(b, Mark)] -> [b]
with_rank forall a b. (a -> b) -> a -> b
$ TrackTime -> Marklist -> [PosMark]
Mark.ascending TrackTime
start Marklist
mlist)
        where marks :: [TrackTime]
marks = forall {b}. [(b, Mark)] -> [b]
with_rank forall a b. (a -> b) -> a -> b
$ TrackTime -> Marklist -> [PosMark]
Mark.descending TrackTime
start Marklist
mlist
    with_rank :: [(b, Mark)] -> [b]
with_rank = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<=Rank
rank) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mark -> Rank
Mark.mark_rank forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall a. a -> Maybe a -> a
fromMaybe RulerId
Ui.no_ruler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> Int -> m (Maybe RulerId)
Ui.ruler_track_at BlockId
block_id Int
tracknum
    Ruler -> Marklists
Ruler.ruler_marklists forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => RulerId -> m Ruler
Ui.get_ruler RulerId
ruler_id