{-# LANGUAGE CPP #-}
module Cmd.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
, 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
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]
:[])
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_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
data Step =
Duration ScoreTime
| AbsoluteMark MarklistMatch Meter.Rank
| RelativeMark MarklistMatch Meter.Rank
| BlockEdge
| 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)
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)
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)
show_time_step :: TimeStep -> Text
show_time_step :: TimeStep -> Text
show_time_step (TimeStep [Step]
steps)
| [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
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_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_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 :: Ui.M m => TimeStep -> BlockId -> TrackNum
-> Maybe TrackTime
-> 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 =
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 =
[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 =
[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
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_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
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)
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_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