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

{- | Commands dealing with selection and cursor movement.

    As is typical, when it comes to selecting events, the selection represents
    a half-open range.  However, reflecting the orientation of events,
    a negative event at the start of the range won't be included, and
    a negative event at he end of the range will be included.  This is natural
    for events with negative duration, since they are weighted at the end.

    This behaviour is actually implemented in the low level "Ui.Events"
    functions.
-}
module Cmd.Selection where
import           Prelude hiding (lookup)
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Msg as Msg
import qualified Cmd.Perf as Perf
import qualified Cmd.TimeStep as TimeStep

import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Warp as Warp
import qualified Midi.Midi as Midi
import qualified Midi.Mmc as Mmc
import qualified Perform.RealTime as RealTime
import qualified Perform.Transport as Transport
import qualified Ui.Block as Block
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.ScoreTime as ScoreTime
import qualified Ui.Sel as Sel
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Types as Types
import qualified Ui.Ui as Ui
import qualified Ui.UiMsg as UiMsg
import qualified Ui.Zoom as Zoom

import           Global
import           Types


-- * cmds

get_view :: Cmd.M m => ViewId -> m Sel.Selection
get_view :: forall (m :: * -> *). M m => ViewId -> m Selection
get_view = forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *). M m => ViewId -> m (Maybe Selection)
lookup_view

lookup_view :: Ui.M m => ViewId -> m (Maybe Sel.Selection)
lookup_view :: forall (m :: * -> *). M m => ViewId -> m (Maybe Selection)
lookup_view ViewId
view_id = forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> m (Maybe Selection)
Ui.get_selection ViewId
view_id TrackNum
Config.insert_selnum

set_view :: Ui.M m => ViewId -> Maybe Sel.Selection -> m ()
set_view :: forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set_view ViewId
view_id = forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> Maybe Selection -> m ()
Ui.set_selection ViewId
view_id TrackNum
Config.insert_selnum

{- | Set or unset the selection.

    This is the Cmd level of Ui.set_selection and should be called by
    any Cmd that wants to set the selection.

    The insert selnum always has an orientation, so if 'Sel.orientation' is
    'Sel.None', default to 'Cmd.state_note_orientation'.  Otherwise, update
    the note orientation, so the visible orientation and actual orientation stay
    in sync.
-}
set :: Cmd.M m => ViewId -> Maybe Sel.Selection -> m ()
set :: forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set ViewId
view_id Maybe Selection
maybe_sel = do
    forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> Maybe Selection -> m ()
set_selnum ViewId
view_id TrackNum
Config.insert_selnum Maybe Selection
maybe_sel
    forall (m :: * -> *). M m => m ()
record_history

set_without_history :: Cmd.M m => ViewId -> Maybe Sel.Selection -> m ()
set_without_history :: forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set_without_history ViewId
view_id = forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> Maybe Selection -> m ()
set_selnum ViewId
view_id TrackNum
Config.insert_selnum

set_selnum :: Cmd.M m => ViewId -> Sel.Num -> Maybe Sel.Selection -> m ()
set_selnum :: forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> Maybe Selection -> m ()
set_selnum ViewId
view_id TrackNum
selnum Maybe Selection
maybe_sel
    | TrackNum
selnum forall a. Eq a => a -> a -> Bool
== TrackNum
Config.insert_selnum = do
        Maybe Selection
maybe_sel <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}. M m => Selection -> m Selection
infer_orientation Maybe Selection
maybe_sel
        forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> Maybe Selection -> m ()
Ui.set_selection ViewId
view_id TrackNum
selnum Maybe Selection
maybe_sel
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Selection
maybe_sel forall a b. (a -> b) -> a -> b
$ \Selection
sel -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Selection -> Bool
Sel.is_point Selection
sel) forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *). M m => ViewId -> Selection -> m ()
set_subs ViewId
view_id Selection
sel
            forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (PlayState -> Maybe SyncConfig
Cmd.state_sync forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
Cmd.state_play)) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *).
M m =>
ViewId -> Selection -> SyncConfig -> m ()
mmc_goto_sel ViewId
view_id Selection
sel
    | Bool
otherwise = forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> Maybe Selection -> m ()
Ui.set_selection ViewId
view_id TrackNum
selnum Maybe Selection
maybe_sel
    where
    -- If the new selection has an opinion about orientation, update
    -- Cmd.state_note_orientation.
    infer_orientation :: Selection -> m Selection
infer_orientation Selection
sel = case Selection -> Orientation
Sel.orientation Selection
sel of
        Orientation
Sel.None -> do
            Orientation
o <- forall (m :: * -> *). M m => m Orientation
get_orientation
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Selection
sel { orientation :: Orientation
Sel.orientation = Orientation
o }
        Orientation
Sel.Positive -> do
            forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
Cmd.modify_edit_state forall a b. (a -> b) -> a -> b
$ \EditState
state ->
                EditState
state { state_note_orientation :: Orientation
Cmd.state_note_orientation = Orientation
Types.Positive }
            forall (m :: * -> *) a. Monad m => a -> m a
return Selection
sel
        Orientation
Sel.Negative -> do
            forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
Cmd.modify_edit_state forall a b. (a -> b) -> a -> b
$ \EditState
state ->
                EditState
state { state_note_orientation :: Orientation
Cmd.state_note_orientation = Orientation
Types.Negative }
            forall (m :: * -> *) a. Monad m => a -> m a
return Selection
sel

get_orientation :: Cmd.M m => m Sel.Orientation
get_orientation :: forall (m :: * -> *). M m => m Orientation
get_orientation =
    forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ Orientation -> Orientation
convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditState -> Orientation
Cmd.state_note_orientation forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit
    where
    convert :: Orientation -> Orientation
convert Orientation
Types.Positive = Orientation
Sel.Positive
    convert Orientation
Types.Negative = Orientation
Sel.Negative

mmc_goto_sel :: Cmd.M m => ViewId -> Sel.Selection -> Cmd.SyncConfig -> m ()
mmc_goto_sel :: forall (m :: * -> *).
M m =>
ViewId -> Selection -> SyncConfig -> m ()
mmc_goto_sel ViewId
view_id Selection
sel SyncConfig
sync = do
    BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    Maybe TrackId
maybe_track_id <- forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id (Selection -> TrackNum
Sel.cur_track Selection
sel)
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (forall (m :: * -> *).
M m =>
BlockId -> Maybe TrackId -> TrackTime -> m (Maybe RealTime)
root_realtime BlockId
block_id Maybe TrackId
maybe_track_id (Selection -> TrackTime
Sel.cur_pos Selection
sel)) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi (SyncConfig -> WriteDevice
Cmd.sync_device SyncConfig
sync) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SyncConfig -> RealTime -> Message
mmc_goto SyncConfig
sync

mmc_goto :: Cmd.SyncConfig -> RealTime -> Midi.Message
mmc_goto :: SyncConfig -> RealTime -> Message
mmc_goto SyncConfig
sync RealTime
pos = DeviceId -> Mmc -> Message
Mmc.encode (SyncConfig -> DeviceId
Cmd.sync_device_id SyncConfig
sync) forall a b. (a -> b) -> a -> b
$
    FrameRate -> Double -> Mmc
Mmc.goto_seconds (SyncConfig -> FrameRate
Cmd.sync_frame_rate SyncConfig
sync) (RealTime -> Double
RealTime.to_seconds RealTime
pos)

-- | Set a selection in the current view.
set_current :: Cmd.M m => Sel.Num -> Maybe Sel.Selection -> m ()
set_current :: forall (m :: * -> *). M m => TrackNum -> Maybe Selection -> m ()
set_current TrackNum
selnum Maybe Selection
maybe_sel = do
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> Maybe Selection -> m ()
set_selnum ViewId
view_id TrackNum
selnum Maybe Selection
maybe_sel

-- | For point selections, set a play position selection on the equivalent
-- time in sub-blocks.  This makes it easier to edit the super-block relative
-- to the sub-block.
--
-- TODO if multiple calls overlap, I should draw multiple selections, but
-- Ui.set_selection doesn't support that, even though the underlying
-- BlockC.set_selection does.
set_subs :: Cmd.M m => ViewId -> Sel.Selection -> m ()
set_subs :: forall (m :: * -> *). M m => ViewId -> Selection -> m ()
set_subs ViewId
view_id Selection
sel = do
    [ViewId]
view_ids <- forall (m :: * -> *). M m => m [ViewId]
Ui.all_view_ids
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ViewId]
view_ids forall a b. (a -> b) -> a -> b
$ \ViewId
vid ->
        forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> Maybe Selection -> m ()
Ui.set_selection ViewId
vid TrackNum
Config.play_position_selnum forall a. Maybe a
Nothing
    BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    Maybe TrackId
maybe_track_id <- forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id (Selection -> TrackNum
Sel.cur_track Selection
sel)
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe TrackId
maybe_track_id forall a b. (a -> b) -> a -> b
$ \TrackId
track_id ->
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *).
M m =>
BlockId -> [(TrackId, TrackTime)] -> m ()
set_block) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            forall (m :: * -> *).
M m =>
BlockId
-> TrackId -> TrackTime -> m [(BlockId, [(TrackId, TrackTime)])]
Perf.sub_pos BlockId
block_id TrackId
track_id (Selection -> TrackTime
Sel.cur_pos Selection
sel)

set_block :: Ui.M m => BlockId -> [(TrackId, TrackTime)] -> m ()
set_block :: forall (m :: * -> *).
M m =>
BlockId -> [(TrackId, TrackTime)] -> m ()
set_block BlockId
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
set_block BlockId
block_id ((TrackId
_, TrackTime
pos) : [(TrackId, TrackTime)]
_) = do
    [ViewId]
view_ids <- forall k a. Map k a -> [k]
Map.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
Ui.views_of BlockId
block_id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ViewId]
view_ids forall a b. (a -> b) -> a -> b
$ \ViewId
view_id ->
        forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> Maybe Selection -> m ()
Ui.set_selection ViewId
view_id TrackNum
Config.play_position_selnum forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Sel.Selection
                { start_track :: TrackNum
start_track = TrackNum
0, start_pos :: TrackTime
start_pos = TrackTime
pos
                , cur_track :: TrackNum
cur_track = TrackNum
999, cur_pos :: TrackTime
cur_pos = TrackTime
pos
                , orientation :: Orientation
orientation = Orientation
Sel.Positive
                }

-- ** modify existing selection

-- | Update the selection's orientation to match 'Cmd.state_note_orientation'.
update_orientation :: Cmd.M m => m ()
update_orientation :: forall (m :: * -> *). M m => m ()
update_orientation = forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM forall (m :: * -> *). M m => m (Maybe Context)
lookup_context forall a b. (a -> b) -> a -> b
$ \(Context ViewId
view_id BlockId
_ Selection
sel) ->
    forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set ViewId
view_id forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Selection
sel { orientation :: Orientation
Sel.orientation = Orientation
Sel.None }

-- | Collapse the selection to a point at its (cur_track, cur_pos).
to_point :: Cmd.M m => Bool -> m ()
to_point :: forall (m :: * -> *). M m => Bool -> m ()
to_point Bool
to_cur_pos = do
    (ViewId
view_id, Selection
old) <- forall (m :: * -> *). M m => m (ViewId, Selection)
get_view_sel
    [TrackNum]
selectable <- Block -> [TrackNum]
Ui.selectable_tracks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id)
    let closest :: TrackNum
closest = forall a. a -> Maybe a -> a
fromMaybe (Selection -> TrackNum
Sel.cur_track Selection
old) forall a b. (a -> b) -> a -> b
$
            forall a. Ord a => a -> [a] -> Maybe a
find_at_before (Selection -> TrackNum
Sel.cur_track Selection
old) [TrackNum]
selectable
    let new :: Selection
new
            | Bool
to_cur_pos = Selection
old
                { start_track :: TrackNum
Sel.start_track = TrackNum
closest, cur_track :: TrackNum
Sel.cur_track = TrackNum
closest
                , start_pos :: TrackTime
Sel.start_pos = Selection -> TrackTime
Sel.cur_pos Selection
old
                }
            | Bool
otherwise = Selection
old
                { start_track :: TrackNum
Sel.start_track = TrackNum
closest, cur_track :: TrackNum
Sel.cur_track = TrackNum
closest
                , cur_pos :: TrackTime
Sel.cur_pos = Selection -> TrackTime
Sel.start_pos Selection
old
                }
    -- auto_scroll doesn't scroll if Sel.cur_pos hasn't moved, but in this
    -- case I do want it to move, so I jump to it when collapsing to_cur_pos.
    -- So trick auto_scroll by pretending the old cur_pos was different.
    let old2 :: Selection
old2 = if Selection -> TrackTime
Sel.cur_pos Selection
old forall a. Eq a => a -> a -> Bool
== Selection -> TrackTime
Sel.cur_pos Selection
new
        then Selection
old { cur_pos :: TrackTime
Sel.cur_pos = Selection -> TrackTime
Sel.start_pos Selection
old } else Selection
old
    forall (m :: * -> *).
M m =>
ViewId -> Maybe Selection -> Selection -> m ()
auto_scroll ViewId
view_id (forall a. a -> Maybe a
Just Selection
old2) Selection
new
    forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set ViewId
view_id (forall a. a -> Maybe a
Just Selection
new)

find_at_before :: Ord a => a -> [a] -> Maybe a
find_at_before :: forall a. Ord a => a -> [a] -> Maybe a
find_at_before a
n = forall a. [a] -> Maybe a
Lists.last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Ord a => a -> a -> Bool
<=a
n)

-- | Advance the insert selection by the current step, which is a popular thing
-- to do.
advance :: Cmd.M m => m ()
advance :: forall (m :: * -> *). M m => m ()
advance = forall (m :: * -> *). M m => Direction -> Move -> m ()
step Direction
TimeStep.Advance Move
default_move

-- | How to move a selection.
data Move =
    Extend -- ^ Extend the existing selection.
    | Move -- ^ Move the existing selection by the step amount.
    | Replace -- ^ Replace the existing selection with a point selection.
    deriving (TrackNum -> Move -> ShowS
[Move] -> ShowS
Move -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Move] -> ShowS
$cshowList :: [Move] -> ShowS
show :: Move -> String
$cshow :: Move -> String
showsPrec :: TrackNum -> Move -> ShowS
$cshowsPrec :: TrackNum -> Move -> ShowS
Show)

-- | Use this Move mode when you don't have a more specific idea.
default_move :: Move
default_move :: Move
default_move = Move
Move

-- | Advance the given selection by the current step.
--
-- The selection will maintain its current track span, be set to a point, and
-- advance to the next relevant mark.  "next relevant mark" is the next visible
-- mark in the ruler to the left.
step :: Cmd.M m => TimeStep.Direction -> Move -> m ()
step :: forall (m :: * -> *). M m => Direction -> Move -> m ()
step Direction
dir Move
move = do
    TimeStep
st <- forall (m :: * -> *). M m => m TimeStep
Cmd.get_current_step
    forall (m :: * -> *). M m => TrackNum -> Move -> TimeStep -> m ()
step_with (Direction -> TrackNum
TimeStep.direction Direction
dir) Move
move TimeStep
st

step_with :: Cmd.M m => Int -> Move -> TimeStep.TimeStep -> m ()
step_with :: forall (m :: * -> *). M m => TrackNum -> Move -> TimeStep -> m ()
step_with TrackNum
steps Move
move TimeStep
step = do
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    old :: Selection
old@(Sel.Selection TrackNum
start_track TrackTime
start_pos TrackNum
cur_track TrackTime
cur_pos Orientation
_) <-
        forall (m :: * -> *). M m => ViewId -> m Selection
get_view ViewId
view_id
    TrackTime
new_pos <- forall (m :: * -> *).
M m =>
TrackNum -> TrackTime -> TrackNum -> TimeStep -> m TrackTime
step_from TrackNum
cur_track TrackTime
cur_pos TrackNum
steps TimeStep
step
    let new_sel :: Selection
new_sel = case Move
move of
            Move
Extend -> Sel.Selection
                { start_track :: TrackNum
start_track = TrackNum
start_track, start_pos :: TrackTime
start_pos = TrackTime
start_pos
                , cur_track :: TrackNum
cur_track = TrackNum
cur_track, cur_pos :: TrackTime
cur_pos = TrackTime
new_pos
                , orientation :: Orientation
orientation = Orientation
Sel.None
                }
            Move
Move -> TrackTime -> Selection -> Selection
Sel.move (TrackTime
new_pos forall a. Num a => a -> a -> a
- TrackTime
cur_pos) Selection
old
            Move
Replace -> TrackNum -> TrackTime -> Orientation -> Selection
Sel.point TrackNum
cur_track TrackTime
new_pos Orientation
Sel.None
    forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set_without_history ViewId
view_id (forall a. a -> Maybe a
Just Selection
new_sel)
    forall (m :: * -> *).
M m =>
ViewId -> Maybe Selection -> Selection -> m ()
auto_scroll ViewId
view_id (forall a. a -> Maybe a
Just Selection
old) Selection
new_sel

-- | Move the selection across tracks by @shift@, possibly skipping non-event
-- tracks and collapsed tracks.
shift :: Cmd.M m => Bool -> Move -> Int -> m ()
shift :: forall (m :: * -> *). M m => Bool -> Move -> TrackNum -> m ()
shift Bool
skip_unselectable Move
move TrackNum
shift = forall (m :: * -> *).
M m =>
(Block -> Selection -> Selection) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \Block
block Selection
old ->
    let new :: Selection
new = Bool -> Block -> TrackNum -> Selection -> Selection
Ui.shift_selection Bool
skip_unselectable Block
block TrackNum
shift Selection
old
    in case Move
move of
        Move
Extend -> Selection -> Selection -> Selection
Sel.merge Selection
old Selection
new
        Move
Move -> Selection
new
        Move
Replace -> TrackNum -> TrackTime -> Orientation -> Selection
Sel.point (Selection -> TrackNum
Sel.cur_track Selection
new) (Selection -> TrackTime
Sel.cur_pos Selection
new)
            (Selection -> Orientation
Sel.orientation Selection
new)

-- | Unlike 'shift', this uses 'Sel.union', which means that the selection will
-- always expand, instead of only expanding if the current track is moving away
-- from the start track.  This is because I use this as a way to expand the
-- selection rather than move it.
jump_to_track :: Cmd.M m => Move -> TrackNum -> m ()
jump_to_track :: forall (m :: * -> *). M m => Move -> TrackNum -> m ()
jump_to_track Move
move TrackNum
tracknum = forall (m :: * -> *).
M m =>
(Block -> Selection -> Selection) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \Block
_ Selection
old ->
    let new :: Selection
new = (TrackNum -> TrackNum) -> Selection -> Selection
Sel.modify_tracks (forall a. Num a => a -> a -> a
+ (TrackNum
tracknum forall a. Num a => a -> a -> a
- Selection -> TrackNum
Sel.cur_track Selection
old)) Selection
old
    in case Move
move of
        Move
Extend -> Selection -> Selection -> Selection
Sel.union Selection
old ((TrackNum -> TrackNum) -> Selection -> Selection
Sel.modify_tracks (forall a b. a -> b -> a
const TrackNum
tracknum) Selection
old)
        Move
Move -> Selection
new
        Move
Replace -> TrackNum -> TrackTime -> Orientation -> Selection
Sel.point (Selection -> TrackNum
Sel.cur_track Selection
new) (Selection -> TrackTime
Sel.cur_pos Selection
new)
            (Selection -> Orientation
Sel.orientation Selection
new)

modify :: Cmd.M m => (Block.Block -> Sel.Selection -> Sel.Selection) -> m ()
modify :: forall (m :: * -> *).
M m =>
(Block -> Selection -> Selection) -> m ()
modify Block -> Selection -> Selection
f = do
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    Block
block <- forall (m :: * -> *). M m => ViewId -> m Block
Ui.block_of ViewId
view_id
    Selection
sel <- forall (m :: * -> *). M m => ViewId -> m Selection
get_view ViewId
view_id
    let new :: Selection
new = Block -> Selection -> Selection
f Block
block Selection
sel
    forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set_without_history ViewId
view_id (forall a. a -> Maybe a
Just Selection
new)
    forall (m :: * -> *).
M m =>
ViewId -> Maybe Selection -> Selection -> m ()
auto_scroll ViewId
view_id (forall a. a -> Maybe a
Just Selection
sel) Selection
new

data Direction = R | L 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, TrackNum -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: TrackNum -> Direction -> ShowS
$cshowsPrec :: TrackNum -> Direction -> ShowS
Show)

find_note_track :: Cmd.M m => Direction -> Bool -> m (Maybe TrackNum)
find_note_track :: forall (m :: * -> *).
M m =>
Direction -> Bool -> m (Maybe TrackNum)
find_note_track Direction
dir Bool
one_before  = do
    [TrackInfo]
tracks <- forall (m :: * -> *). M m => Bool -> Direction -> m [TrackInfo]
get_tracks_from_selection Bool
one_before Direction
dir
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TrackInfo -> TrackNum
Ui.track_tracknum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall {a}. (a -> Bool) -> [a] -> Maybe a
find (Text -> Bool
ParseTitle.is_note_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> Text
Ui.track_title) [TrackInfo]
tracks
    where
    find :: (a -> Bool) -> [a] -> Maybe a
find a -> Bool
f
        | Bool
one_before = if Direction
dir forall a. Eq a => a -> a -> Bool
== Direction
R then forall {a}. (a -> Bool) -> [a] -> Maybe a
find_before a -> Bool
f else forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find a -> Bool
f
        | Bool
otherwise = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find a -> Bool
f

-- | Find the element before the predicate matches, or the last element if it
-- never matches.
find_before :: (a -> Bool) -> [a] -> Maybe a
find_before :: forall {a}. (a -> Bool) -> [a] -> Maybe a
find_before a -> Bool
p = [a] -> Maybe a
go
    where
    go :: [a] -> Maybe a
go (a
x1 : xs :: [a]
xs@(a
x2 : [a]
_))
        | a -> Bool
p a
x2 = forall a. a -> Maybe a
Just a
x1
        | Bool
otherwise = [a] -> Maybe a
go [a]
xs
    go [a
x] = forall a. a -> Maybe a
Just a
x
    go [] = forall a. Maybe a
Nothing

-- | Get tracks either starting from the right of the selection, or the left.
-- Unselectable tracks are omitted.
get_tracks_from_selection :: Cmd.M m => Bool -- ^ If True, start from the R or
    -- L edge of the selection, rather than 'Sel.cur_track'.
    -> Direction -> m [Ui.TrackInfo]
get_tracks_from_selection :: forall (m :: * -> *). M m => Bool -> Direction -> m [TrackInfo]
get_tracks_from_selection Bool
from_edge Direction
dir = do
    (ViewId
view_id, Selection
sel) <- forall (m :: * -> *). M m => m (ViewId, Selection)
get_view_sel
    let tracknum :: TrackNum
tracknum = if Bool
from_edge
            then (if Direction
dir forall a. Eq a => a -> a -> Bool
== Direction
R then forall a b. (a, b) -> b
snd else forall a b. (a, b) -> a
fst) (Selection -> (TrackNum, TrackNum)
Sel.track_range Selection
sel)
            else Selection -> TrackNum
Sel.cur_track Selection
sel
    BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    [TrackInfo]
tracks <- forall a. (a -> Bool) -> [a] -> [a]
filter (Track -> Bool
Block.track_selectable forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> Track
Ui.track_block) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *). M m => BlockId -> m [TrackInfo]
TrackTree.tracks_of BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Direction
dir of
        Direction
R -> forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
<= TrackNum
tracknum) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> TrackNum
Ui.track_tracknum) [TrackInfo]
tracks
        Direction
L -> forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
>= TrackNum
tracknum) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> TrackNum
Ui.track_tracknum) (forall a. [a] -> [a]
reverse [TrackInfo]
tracks)

-- | Progressive selection: select the rest of the track, then the entire
-- track, then the whole block.
--
-- TrackNum 0, assumed to be a ruler, is omitted, since selecting the ruler is
-- not only not useful, it tends to make cmds that want to get a TrackId abort.
cmd_track_all :: Cmd.M m => m ()
cmd_track_all :: forall (m :: * -> *). M m => m ()
cmd_track_all = do
    (ViewId
view_id, Selection
sel) <- forall (m :: * -> *). M m => m (ViewId, Selection)
get_view_sel
    BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    TrackTime
block_end <- forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_end BlockId
block_id
    TrackNum
tracks <- forall (m :: * -> *). M m => BlockId -> m TrackNum
Ui.track_count BlockId
block_id
    forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set ViewId
view_id forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (TrackTime -> TrackNum -> Selection -> Selection
select_track_all TrackTime
block_end TrackNum
tracks Selection
sel)

select_track_all :: TrackTime -> TrackNum -> Sel.Selection -> Sel.Selection
select_track_all :: TrackTime -> TrackNum -> Selection -> Selection
select_track_all TrackTime
block_end TrackNum
tracks Selection
sel
    | Selection
sel forall a. Eq a => a -> a -> Bool
== Selection
select_tracks = Selection
select_all
    | Selection
sel forall a. Eq a => a -> a -> Bool
== Selection
select_rest = Selection
select_tracks
    | Bool
otherwise = Selection
select_rest
    where
    select_rest :: Selection
select_rest = Selection -> Selection
until_end forall a b. (a -> b) -> a -> b
$ Selection
sel { cur_pos :: TrackTime
Sel.cur_pos = Selection -> TrackTime
Sel.min Selection
sel }
    select_tracks :: Selection
select_tracks = Selection -> Selection
until_end forall a b. (a -> b) -> a -> b
$ Selection
sel { cur_pos :: TrackTime
Sel.cur_pos = TrackTime
0 }
    select_all :: Selection
select_all = Selection -> Selection
until_end forall a b. (a -> b) -> a -> b
$ TrackNum -> TrackNum -> Selection
track_selection TrackNum
1 (TrackNum
tracks forall a. Num a => a -> a -> a
- TrackNum
1)
    until_end :: Selection -> Selection
until_end = TrackTime -> Selection -> Selection
select_until_end TrackTime
block_end
    track_selection :: TrackNum -> TrackNum -> Selection
track_selection TrackNum
from TrackNum
to = Sel.Selection
        { start_track :: TrackNum
start_track = TrackNum
from, start_pos :: TrackTime
start_pos = TrackTime
0
        , cur_track :: TrackNum
cur_track = TrackNum
to, cur_pos :: TrackTime
cur_pos = TrackTime
0
        , orientation :: Orientation
orientation = Selection -> Orientation
Sel.orientation Selection
sel
        }

-- | Extend the selection horizontally to encompass all tracks.  If it already
-- does, reset the track selection to the previous one.
cmd_toggle_extend_tracks :: Cmd.M m => m ()
cmd_toggle_extend_tracks :: forall (m :: * -> *). M m => m ()
cmd_toggle_extend_tracks = do
    (ViewId
view_id, Selection
sel) <- forall (m :: * -> *). M m => m (ViewId, Selection)
get_view_sel
    TrackNum
tracks <- forall (m :: * -> *). M m => BlockId -> m TrackNum
Ui.track_count forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    let expanded :: Selection
expanded = Selection
sel { cur_track :: TrackNum
Sel.cur_track = TrackNum
1, start_track :: TrackNum
Sel.start_track = TrackNum
tracks forall a. Num a => a -> a -> a
- TrackNum
1 }
    if Selection
sel forall a. Eq a => a -> a -> Bool
/= Selection
expanded
        then forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set ViewId
view_id forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Selection
expanded
        else forall (m :: * -> *). M m => Bool -> m ()
previous_selection Bool
False

-- ** set selection from clicks

-- | Select clicked on track.
cmd_select_track :: Cmd.M m => Types.MouseButton -> Msg.Msg -> m ()
cmd_select_track :: forall (m :: * -> *). M m => TrackNum -> Msg -> m ()
cmd_select_track TrackNum
btn Msg
msg = do
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    ((TrackNum
down_tracknum, Track
_), (TrackNum
mouse_tracknum, Track
_)) <- forall (m :: * -> *).
M m =>
TrackNum -> Msg -> m ((TrackNum, Track), (TrackNum, Track))
mouse_drag TrackNum
btn Msg
msg
    forall (m :: * -> *). M m => ViewId -> TrackNum -> TrackNum -> m ()
select_tracks ViewId
view_id TrackNum
down_tracknum TrackNum
mouse_tracknum

select_tracks :: Cmd.M m => ViewId -> TrackNum -> TrackNum -> m ()
select_tracks :: forall (m :: * -> *). M m => ViewId -> TrackNum -> TrackNum -> m ()
select_tracks ViewId
view_id TrackNum
from TrackNum
to = do
    TrackTime
block_end <- forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_end forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set ViewId
view_id forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TrackTime -> Selection -> Selection
select_until_end TrackTime
block_end forall a b. (a -> b) -> a -> b
$
        Sel.Selection
            { start_track :: TrackNum
start_track = TrackNum
from, start_pos :: TrackTime
start_pos = TrackTime
0
            , cur_track :: TrackNum
cur_track = TrackNum
to, cur_pos :: TrackTime
cur_pos = TrackTime
0
            , orientation :: Orientation
orientation = Orientation
Sel.Positive
            }

-- | Extend the selection to the end of then block.  This sets 'Sel.start_pos',
-- with the assumption that 'Sel.cur_pos' is onscreen.  This is so
-- 'auto_scroll' won't jump to the bottom of the block.
select_until_end :: TrackTime -> Sel.Selection -> Sel.Selection
select_until_end :: TrackTime -> Selection -> Selection
select_until_end TrackTime
block_end Selection
sel =
    Selection
sel { start_pos :: TrackTime
Sel.start_pos = TrackTime
block_end forall a. Num a => a -> a -> a
+ TrackTime
ScoreTime.eta }
    -- Without ScoreTime.eta, a select-all won't include an event at the end of
    -- the block.

-- | Set the selection based on a click or drag.
cmd_mouse_selection :: Cmd.M m => Types.MouseButton -> Bool -> Msg.Msg -> m ()
cmd_mouse_selection :: forall (m :: * -> *). M m => TrackNum -> Bool -> Msg -> m ()
cmd_mouse_selection TrackNum
btn Bool
extend Msg
msg = do
    ((TrackNum
down_tracknum, TrackTime
down_pos), (TrackNum
mouse_tracknum, TrackTime
mouse_pos))
        <- forall (m :: * -> *).
M m =>
TrackNum -> Msg -> m ((TrackNum, TrackTime), (TrackNum, TrackTime))
mouse_drag_pos TrackNum
btn Msg
msg
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    Maybe Selection
old_sel <- forall (m :: * -> *). M m => ViewId -> m (Maybe Selection)
lookup_view ViewId
view_id
    let (TrackNum
start_tracknum, TrackTime
start_pos) = case (Bool
extend, Maybe Selection
old_sel) of
            (Bool
True, Just (Sel.Selection TrackNum
tracknum TrackTime
pos TrackNum
_ TrackTime
_ Orientation
_)) -> (TrackNum
tracknum, TrackTime
pos)
            (Bool, Maybe Selection)
_ -> (TrackNum
down_tracknum, TrackTime
down_pos)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Msg -> Bool
Msg.mouse_down Msg
msg) forall (m :: * -> *). M m => m ()
record_history
    let sel :: Selection
sel = Sel.Selection
            { start_track :: TrackNum
start_track = TrackNum
start_tracknum, start_pos :: TrackTime
start_pos = TrackTime
start_pos
            , cur_track :: TrackNum
cur_track = TrackNum
mouse_tracknum, cur_pos :: TrackTime
cur_pos = TrackTime
mouse_pos
            , orientation :: Orientation
orientation = Orientation
Sel.None
            }
    forall (m :: * -> *). M m => ViewId -> Selection -> m ()
set_and_scroll ViewId
view_id Selection
sel

-- | Like 'cmd_mouse_selection', but snap the selection to the current time
-- step.
cmd_snap_selection :: Cmd.M m => Types.MouseButton -> Bool -> Msg.Msg -> m ()
cmd_snap_selection :: forall (m :: * -> *). M m => TrackNum -> Bool -> Msg -> m ()
cmd_snap_selection TrackNum
btn Bool
extend Msg
msg = do
    ((TrackNum
down_tracknum, TrackTime
_), (TrackNum
mouse_tracknum, TrackTime
mouse_pos)) <- forall (m :: * -> *).
M m =>
TrackNum -> Msg -> m ((TrackNum, TrackTime), (TrackNum, TrackTime))
mouse_drag_pos TrackNum
btn Msg
msg
    BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    TimeStep
step <- forall (m :: * -> *). M m => m TimeStep
Cmd.get_current_step
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    Maybe Selection
old_sel <- forall (m :: * -> *). M m => ViewId -> m (Maybe Selection)
lookup_view ViewId
view_id
    TrackTime
snap_pos <- forall (m :: * -> *).
M m =>
TimeStep
-> BlockId
-> TrackNum
-> Maybe TrackTime
-> TrackTime
-> m TrackTime
TimeStep.snap TimeStep
step BlockId
block_id TrackNum
mouse_tracknum
        (Selection -> TrackTime
Sel.cur_pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Selection
old_sel) TrackTime
mouse_pos
    TrackTime
snap_pos <- forall {m :: * -> *}.
M m =>
ViewId -> BlockId -> TrackTime -> TrackTime -> m TrackTime
snap_over_threshold ViewId
view_id BlockId
block_id TrackTime
mouse_pos TrackTime
snap_pos
    let sel :: Selection
sel = case Maybe Selection
old_sel of
            Maybe Selection
_ | Maybe Selection
old_sel forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
|| Msg -> Bool
Msg.mouse_down Msg
msg Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
extend ->
                Sel.Selection
                    { start_track :: TrackNum
start_track = TrackNum
down_tracknum, start_pos :: TrackTime
start_pos = TrackTime
snap_pos
                    , cur_track :: TrackNum
cur_track = TrackNum
mouse_tracknum, cur_pos :: TrackTime
cur_pos = TrackTime
snap_pos
                    , orientation :: Orientation
orientation = Orientation
Sel.None
                    }
            Just (Sel.Selection TrackNum
tracknum TrackTime
pos TrackNum
_ TrackTime
_ Orientation
_) -> Sel.Selection
                { start_track :: TrackNum
start_track = TrackNum
tracknum, start_pos :: TrackTime
start_pos = TrackTime
pos
                , cur_track :: TrackNum
cur_track = TrackNum
mouse_tracknum, cur_pos :: TrackTime
cur_pos = TrackTime
snap_pos
                , orientation :: Orientation
orientation = Orientation
Sel.None
                }
            -- ghc doesn't realize it is exhaustive
            Maybe Selection
_ -> forall a. HasCallStack => String -> a
error String
"Cmd.Selection: not reached"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Msg -> Bool
Msg.mouse_down Msg
msg) forall (m :: * -> *). M m => m ()
record_history
    forall (m :: * -> *). M m => ViewId -> Selection -> m ()
set_and_scroll ViewId
view_id Selection
sel
    where
    -- If I'm dragging, only snap if I'm close to a snap point.  Otherwise,
    -- it's easy for the selection to jump way off screen while dragging.
    snap_over_threshold :: ViewId -> BlockId -> TrackTime -> TrackTime -> m TrackTime
snap_over_threshold ViewId
view_id BlockId
block_id TrackTime
pos TrackTime
snap = do
        Zoom
zoom <- forall (m :: * -> *). M m => ViewId -> m Zoom
Ui.get_zoom ViewId
view_id
        let over :: Bool
over = Zoom -> TrackTime -> TrackNum
Zoom.to_pixels Zoom
zoom (forall a. Num a => a -> a
abs (TrackTime
snap forall a. Num a => a -> a -> a
- TrackTime
pos)) forall a. Ord a => a -> a -> Bool
> TrackNum
threshold
        -- Don't go past the end of the ruler.  Otherwise it's easy to
        -- accidentally select too much by dragging to the end of the block.
        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
$ if Bool -> Bool
not (Msg -> Bool
Msg.mouse_down Msg
msg) Bool -> Bool -> Bool
&& Bool
over Bool -> Bool -> Bool
&& TrackTime
pos forall a. Ord a => a -> a -> Bool
< TrackTime
end
            then TrackTime
pos else TrackTime
snap
    threshold :: TrackNum
threshold = TrackNum
20

-- | Like 'mouse_drag' but specialized for drags on the track.
mouse_drag_pos :: Cmd.M m => Types.MouseButton -> Msg.Msg
    -> m ((TrackNum, TrackTime), (TrackNum, TrackTime))
mouse_drag_pos :: forall (m :: * -> *).
M m =>
TrackNum -> Msg -> m ((TrackNum, TrackTime), (TrackNum, TrackTime))
mouse_drag_pos TrackNum
btn Msg
msg = do
    ((TrackNum
num1, Track
t1), (TrackNum
num2, Track
t2)) <- forall (m :: * -> *).
M m =>
TrackNum -> Msg -> m ((TrackNum, Track), (TrackNum, Track))
mouse_drag TrackNum
btn Msg
msg
    case (Track
t1, Track
t2) of
        (UiMsg.Track TrackTime
p1, UiMsg.Track TrackTime
p2) -> forall (m :: * -> *) a. Monad m => a -> m a
return ((TrackNum
num1, TrackTime
p1), (TrackNum
num2, TrackTime
p2))
        (Track, Track)
_ -> forall (m :: * -> *) a. M m => m a
Cmd.abort

-- | Get the clicked or dragged range, or abort if this isn't a drag Msg.
-- This accepts clicks as well, and considers them an empty range.
mouse_drag :: Cmd.M m => Types.MouseButton -> Msg.Msg
    -> m ((TrackNum, UiMsg.Track), (TrackNum, UiMsg.Track))
    -- ^ (mouse down at, mouse currently at)
mouse_drag :: forall (m :: * -> *).
M m =>
TrackNum -> Msg -> m ((TrackNum, Track), (TrackNum, Track))
mouse_drag TrackNum
btn Msg
msg = do
    (Bool
is_down, Modifier
mod, (TrackNum, Track)
mouse_at) <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless (Msg -> Maybe (Bool, Modifier, (TrackNum, Track))
mouse_mod Msg
msg)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
is_down Bool -> Bool -> Bool
&& forall a b. (a, b) -> a
fst (TrackNum, Track)
mouse_at forall a. Eq a => a -> a -> Bool
== TrackNum
0) forall (m :: * -> *) a. M m => m a
Cmd.abort
    TrackNum
msg_btn <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless (Modifier -> Maybe TrackNum
Cmd.mouse_mod_btn Modifier
mod)
    -- The button down should be the same one as expected.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TrackNum
msg_btn forall a. Eq a => a -> a -> Bool
/= TrackNum
btn) forall (m :: * -> *) a. M m => m a
Cmd.abort
    Map Modifier Modifier
keys_down <- forall (m :: * -> *). M m => m (Map Modifier Modifier)
Cmd.keys_down
    let mouse_down :: Maybe Modifier
mouse_down = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Modifier -> Modifier
Cmd.strip_modifier Modifier
mod) Map Modifier Modifier
keys_down
    let down_at :: (TrackNum, Track)
down_at = case (Bool
is_down, Maybe Modifier
mouse_down) of
            (Bool
False, Just (Cmd.MouseMod TrackNum
_ (Just (TrackNum, Track)
track))) -> (TrackNum, Track)
track
            -- If it's not already held down, it starts here.
            (Bool, Maybe Modifier)
_ -> (TrackNum, Track)
mouse_at
    -- MsgCollector is back to clamping at track-1, but leave this in in
    -- case I change my mind again.
    -- -- Clip a drag past the last track to the last track, callers here treat
    -- -- it as the same.
    -- tracks <- Ui.track_count =<< Cmd.get_focused_block
    -- let clamp (tnum, track) = (min (tracks-1) tnum, track)
    -- return (clamp down_at, clamp mouse_at)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Ord a => a -> a -> a
max TrackNum
1) (TrackNum, Track)
down_at, forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Ord a => a -> a -> a
max TrackNum
1) (TrackNum, Track)
mouse_at)

-- * implementation

-- ** auto scroll

-- | Figure out how much to scroll to keep the selection visible and with
-- reasonable space around it.
--
-- Anyone who wants to set a selection and automatically scroll the window to
-- follow the selection should use this function.
set_and_scroll :: Cmd.M m => ViewId -> Sel.Selection -> m ()
set_and_scroll :: forall (m :: * -> *). M m => ViewId -> Selection -> m ()
set_and_scroll ViewId
view_id Selection
sel = do
    Maybe Selection
old <- forall (m :: * -> *). M m => ViewId -> m (Maybe Selection)
lookup_view ViewId
view_id
    forall (m :: * -> *).
M m =>
ViewId -> Maybe Selection -> Selection -> m ()
auto_scroll ViewId
view_id Maybe Selection
old Selection
sel
    forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set ViewId
view_id (forall a. a -> Maybe a
Just Selection
sel)

-- | If the selection has scrolled off the edge of the window, automatically
-- scroll it so that the \"current\" end of the selection is in view.
auto_scroll :: Cmd.M m => ViewId -> Maybe Sel.Selection -> Sel.Selection -> m ()
auto_scroll :: forall (m :: * -> *).
M m =>
ViewId -> Maybe Selection -> Selection -> m ()
auto_scroll ViewId
view_id Maybe Selection
old Selection
new = do
    View
view <- forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block (View -> BlockId
Block.view_block View
view)
    TrackTime
end <- forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_end (View -> BlockId
Block.view_block View
view)
    let time_offset :: TrackTime
time_offset = forall a. Ord a => a -> a -> a -> a
Num.clamp TrackTime
0 (TrackTime
end forall a. Num a => a -> a -> a
- View -> TrackTime
Block.visible_time View
view) forall a b. (a -> b) -> a -> b
$
            View -> Maybe TrackTime -> TrackTime -> TrackTime
auto_time_scroll View
view (Selection -> TrackTime
Sel.cur_pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Selection
old) (Selection -> TrackTime
Sel.cur_pos Selection
new)
        track_offset :: TrackNum
track_offset = Block -> View -> Selection -> TrackNum
auto_track_scroll Block
block View
view Selection
new
    forall (m :: * -> *). M m => ViewId -> (Zoom -> Zoom) -> m ()
Ui.modify_zoom ViewId
view_id forall a b. (a -> b) -> a -> b
$ \Zoom
zoom -> Zoom
zoom { offset :: TrackTime
Zoom.offset = TrackTime
time_offset }
    forall (m :: * -> *). M m => ViewId -> TrackNum -> m ()
Ui.set_track_scroll ViewId
view_id TrackNum
track_offset

-- TODO this scrolls too fast when dragging.  Detect a drag and scroll at
-- a rate determined by how far past the bottom the pointer is.
auto_time_scroll :: Block.View -> Maybe TrackTime -> TrackTime -> TrackTime
auto_time_scroll :: View -> Maybe TrackTime -> TrackTime -> TrackTime
auto_time_scroll View
view Maybe TrackTime
prev_pos TrackTime
pos
    -- Don't scroll if the cur pos hasn't changed.  Otherwise, selecting the
    -- whole track and shifting tracks scrolls the block down to the bottom.
    | forall a. a -> Maybe a
Just TrackTime
pos forall a. Eq a => a -> a -> Bool
== Maybe TrackTime
prev_pos = TrackTime
view_start
    | TrackTime
pos forall a. Ord a => a -> a -> Bool
>= TrackTime
view_end = TrackTime
pos forall a. Num a => a -> a -> a
- TrackTime
visible forall a. Num a => a -> a -> a
+ TrackTime
space
    | TrackTime
pos forall a. Ord a => a -> a -> Bool
< TrackTime
view_start = TrackTime
pos forall a. Num a => a -> a -> a
- TrackTime
space
    | Bool
otherwise = TrackTime
view_start
    where
    visible :: TrackTime
visible = View -> TrackTime
Block.visible_time View
view
    view_start :: TrackTime
view_start = Zoom -> TrackTime
Zoom.offset (View -> Zoom
Block.view_zoom View
view)
    view_end :: TrackTime
view_end = TrackTime
view_start forall a. Num a => a -> a -> a
+ TrackTime
visible
    space :: TrackTime
space = Double -> TrackTime
ScoreTime.from_double forall a b. (a -> b) -> a -> b
$
        Double
visible_pixels forall a. Fractional a => a -> a -> a
/ Zoom -> Double
Zoom.factor (View -> Zoom
Block.view_zoom View
view)
    visible_pixels :: Double
visible_pixels = Double
30

-- | Find the track scroll that would put the given selection into view.
auto_track_scroll :: Block.Block -> Block.View -> Sel.Selection -> Types.Width
auto_track_scroll :: Block -> View -> Selection -> TrackNum
auto_track_scroll Block
block View
view Selection
sel
    | TrackNum
track_end forall a. Ord a => a -> a -> Bool
> TrackNum
view_end = TrackNum
track_end forall a. Num a => a -> a -> a
- TrackNum
visible
    | TrackNum
track_start forall a. Ord a => a -> a -> Bool
< TrackNum
view_start = TrackNum
track_start
    | Bool
otherwise = TrackNum
view_start
    where
    -- Pesky ruler track doesn't count towards the track scroll.
    widths :: [TrackNum]
widths = forall a b. (a -> b) -> [a] -> [b]
map Track -> TrackNum
Block.display_track_width (forall a. TrackNum -> [a] -> [a]
drop TrackNum
1 (Block -> [Track]
Block.block_tracks Block
block))
    track_start :: TrackNum
track_start = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (forall a. TrackNum -> [a] -> [a]
take (TrackNum
cur_tracknumforall a. Num a => a -> a -> a
-TrackNum
1) [TrackNum]
widths)
    track_end :: TrackNum
track_end = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (forall a. TrackNum -> [a] -> [a]
take TrackNum
cur_tracknum [TrackNum]
widths)
    view_start :: TrackNum
view_start = View -> TrackNum
Block.view_track_scroll View
view
    view_end :: TrackNum
view_end = TrackNum
view_start forall a. Num a => a -> a -> a
+ TrackNum
visible
    -- Visible does include the pesky ruler.
    visible :: TrackNum
visible = View -> TrackNum
Block.visible_track View
view forall a. Num a => a -> a -> a
- forall b a. b -> (a -> b) -> Maybe a -> b
maybe TrackNum
0
        Track -> TrackNum
Block.display_track_width (forall a. [a] -> Maybe a
Lists.head (Block -> [Track]
Block.block_tracks Block
block))
    cur_tracknum :: TrackNum
cur_tracknum = Selection -> TrackNum
Sel.cur_track Selection
sel


-- ** mouse

-- | (mouse_down, mouse_modifier, (mouse_track, mouse_pos))
mouse_mod :: Msg.Msg -> Maybe (Bool, Cmd.Modifier, (TrackNum, UiMsg.Track))
mouse_mod :: Msg -> Maybe (Bool, Modifier, (TrackNum, Track))
mouse_mod Msg
msg = do
    MouseEvent
mouse <- Msg -> Maybe MouseEvent
Msg.mouse Msg
msg
    (Bool
down, TrackNum
btn) <- case MouseEvent -> MouseState
UiMsg.mouse_state MouseEvent
mouse of
        UiMsg.MouseDown TrackNum
btn -> forall a. a -> Maybe a
Just (Bool
True, TrackNum
btn)
        UiMsg.MouseDrag TrackNum
btn -> forall a. a -> Maybe a
Just (Bool
False, TrackNum
btn)
        UiMsg.MouseUp TrackNum
btn -> forall a. a -> Maybe a
Just (Bool
False, TrackNum
btn)
        MouseState
_ -> forall a. Maybe a
Nothing
    (TrackNum, Track)
track <- Msg -> Maybe (TrackNum, Track)
Msg.context_track Msg
msg
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
down, TrackNum -> Maybe (TrackNum, Track) -> Modifier
Cmd.MouseMod TrackNum
btn (forall a. a -> Maybe a
Just (TrackNum, Track)
track), (TrackNum, Track)
track)

-- * util

step_from :: Cmd.M m => TrackNum -> TrackTime -> Int -> TimeStep.TimeStep
    -> m TrackTime
step_from :: forall (m :: * -> *).
M m =>
TrackNum -> TrackTime -> TrackNum -> TimeStep -> m TrackTime
step_from TrackNum
tracknum TrackTime
pos TrackNum
steps TimeStep
step = do
    BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    TrackTime
end <- forall a. Ord a => a -> a -> a
max forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_ruler_end BlockId
block_id forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_event_end BlockId
block_id
    Maybe TrackTime
next <- forall (m :: * -> *).
M m =>
TrackNum
-> TimeStep
-> BlockId
-> TrackNum
-> TrackTime
-> m (Maybe TrackTime)
TimeStep.step_from TrackNum
steps TimeStep
step BlockId
block_id TrackNum
tracknum TrackTime
pos
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe TrackTime
next of
        Just TrackTime
next | TrackTime
0 forall a. Ord a => a -> a -> Bool
<= TrackTime
next Bool -> Bool -> Bool
&& TrackTime
next forall a. Ord a => a -> a -> Bool
<= TrackTime
end -> TrackTime
next
        Maybe TrackTime
_ -> TrackTime
pos

-- | Get the ruler that applies to the given track.  Search left for the
-- closest ruler that has all the given marklist names.  This includes ruler
-- tracks and the rulers of event tracks.
relevant_ruler :: Block.Block -> TrackNum -> Maybe RulerId
relevant_ruler :: Block -> TrackNum -> Maybe RulerId
relevant_ruler Block
block TrackNum
tracknum = forall a. [a] -> TrackNum -> Maybe a
Lists.at ([TracklikeId] -> [RulerId]
Block.ruler_ids_of [TracklikeId]
in_order) TrackNum
0
    where
    in_order :: [TracklikeId]
in_order = forall a b. (a -> b) -> [a] -> [b]
map (Track -> TracklikeId
Block.tracklike_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Eq a => a -> a -> Bool
/=TrackNum
tracknum) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
0..] (Block -> [Track]
Block.block_tracks Block
block)

-- * get selection info

{- Getting the selection may seem pretty simple, but there are a number of
    orthogonal flavors:

    - Return a raw Sel.Selection, or return its
    (ViewId, BlockId, TrackId, TrackTime) context.

    - Get a single point from a selection, or a range on a single track, or
    a range of tracks.

    - Get an arbitrary Sel.Num or use the Config.insert_selnum.

    - Return a Maybe or abort on Nothing.

    - Return for any track, or return a TrackId and abort if it's not an event
    track.

    - Used an arbitrary ViewId, BlockId, or use the focused view.

    And then there is a whole other dimension of converting selections, which
    are in TrackTime, to RealTime.  The selection can be converted either
    relative to its block's tempo, or relative to a calling block's tempo,
    namely the root block.

    Also, when a selection is interpreted as a point (for instance, for
    operations like \"play from selection\"), there is a choice of taking the
    point from the beginning of the selection, the end, or the 'sel_cur_pos',
    which is the dragged-to point.  The convention, established by
    'sel_point' and 'sel_point_track', is to use the active end of the
    selection.
-}

-- | Get the \"point\" position of a Selection.
sel_point :: Sel.Selection -> TrackTime
sel_point :: Selection -> TrackTime
sel_point = Selection -> TrackTime
Sel.cur_pos

-- | When multiple tracks are selected, only one can be the point.  This
-- is 'Sel.cur_track', and in fact must be, because 'Sel.start_track' may
-- be an invalid tracknum.  That is so a selection can maintain its shape even
-- if it momentarily goes out of bounds.
sel_point_track :: Sel.Selection -> TrackNum
sel_point_track :: Selection -> TrackNum
sel_point_track = Selection -> TrackNum
Sel.cur_track

-- | A point on a track.
type Point = (BlockId, TrackNum, TrackId, TrackTime)
type AnyPoint = (BlockId, TrackNum, TrackTime)

-- | Get the "insert position", which is the start track and position of the
-- insert selection.  Abort if it's not an event track.
get_insert :: Cmd.M m => m Point
get_insert :: forall (m :: * -> *). M m => m Point
get_insert = forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe Point)
lookup_insert

lookup_insert :: Cmd.M m => m (Maybe Point)
lookup_insert :: forall (m :: * -> *). M m => m (Maybe Point)
lookup_insert = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => TrackNum -> m (Maybe (ViewId, Point))
lookup_selnum_insert TrackNum
Config.insert_selnum

lookup_selnum_insert :: Cmd.M m => Sel.Num -> m (Maybe (ViewId, Point))
lookup_selnum_insert :: forall (m :: * -> *). M m => TrackNum -> m (Maybe (ViewId, Point))
lookup_selnum_insert TrackNum
selnum =
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *).
M m =>
TrackNum -> m (Maybe (ViewId, AnyPoint))
lookup_any_selnum_insert TrackNum
selnum) forall a b. (a -> b) -> a -> b
$
    \(ViewId
view_id, (BlockId
block_id, TrackNum
tracknum, TrackTime
pos)) ->
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id TrackNum
tracknum) forall a b. (a -> b) -> a -> b
$ \TrackId
track_id ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ViewId
view_id, (BlockId
block_id, TrackNum
tracknum, TrackId
track_id, TrackTime
pos))

-- | Return the leftmost tracknum and trackpos, even if it's not an event
-- track.
get_any_insert :: Cmd.M m => m (ViewId, AnyPoint)
get_any_insert :: forall (m :: * -> *). M m => m (ViewId, AnyPoint)
get_any_insert = forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe (ViewId, AnyPoint))
lookup_any_insert

lookup_any_insert :: Cmd.M m => m (Maybe (ViewId, AnyPoint))
lookup_any_insert :: forall (m :: * -> *). M m => m (Maybe (ViewId, AnyPoint))
lookup_any_insert = forall (m :: * -> *).
M m =>
TrackNum -> m (Maybe (ViewId, AnyPoint))
lookup_any_selnum_insert TrackNum
Config.insert_selnum

-- | The most general insertion point function.
lookup_any_selnum_insert :: Cmd.M m => Sel.Num -> m (Maybe (ViewId, AnyPoint))
lookup_any_selnum_insert :: forall (m :: * -> *).
M m =>
TrackNum -> m (Maybe (ViewId, AnyPoint))
lookup_any_selnum_insert TrackNum
selnum =
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *). M m => TrackNum -> m (Maybe Context)
lookup_context_selnum TrackNum
selnum) forall a b. (a -> b) -> a -> b
$ \(Context ViewId
view_id BlockId
block_id Selection
sel) ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ViewId
view_id, (BlockId
block_id, Selection -> TrackNum
sel_point_track Selection
sel, Selection -> TrackTime
sel_point Selection
sel))

-- | Given a block, get the selection on it, if any.  If there are multiple
-- views, take the one with the alphabetically first ViewId.
--
-- I'm not sure how to choose, but the first one seems reasonable for now.
lookup_block_insert :: Ui.M m => BlockId -> m (Maybe Point)
lookup_block_insert :: forall (m :: * -> *). M m => BlockId -> m (Maybe Point)
lookup_block_insert BlockId
block_id = do
    [ViewId]
view_ids <- forall k a. Map k a -> [k]
Map.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
Ui.views_of BlockId
block_id
    case [ViewId]
view_ids of
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        ViewId
view_id : [ViewId]
_ ->
            forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *). M m => ViewId -> m (Maybe Selection)
lookup_view ViewId
view_id) forall a b. (a -> b) -> a -> b
$ \Selection
sel ->
            forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *).
M m =>
BlockId -> Selection -> m (Maybe TrackId)
sel_track BlockId
block_id Selection
sel) forall a b. (a -> b) -> a -> b
$ \TrackId
track_id ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just
                (BlockId
block_id, Selection -> TrackNum
sel_point_track Selection
sel, TrackId
track_id, Selection -> TrackTime
sel_point Selection
sel)

-- | Get the point track of a selection.
sel_track :: Ui.M m => BlockId -> Sel.Selection -> m (Maybe TrackId)
sel_track :: forall (m :: * -> *).
M m =>
BlockId -> Selection -> m (Maybe TrackId)
sel_track BlockId
block_id Selection
sel = forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id (Selection -> TrackNum
sel_point_track Selection
sel)

-- ** plain Selection

-- | The selection is in the Ui.State, but focused view is in Cmd.State.
-- Extracting it out lets me depend only on Ui.M, not Cmd.M.  Also it decouples
-- selection functions from the current Ui.State and Cmd.State.
data Context = Context {
    Context -> ViewId
ctx_view_id :: !ViewId
    , Context -> BlockId
ctx_block_id :: !BlockId
    , Context -> Selection
ctx_selection :: !Sel.Selection
    } deriving (TrackNum -> Context -> ShowS
[Context] -> ShowS
Context -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Context] -> ShowS
$cshowList :: [Context] -> ShowS
show :: Context -> String
$cshow :: Context -> String
showsPrec :: TrackNum -> Context -> ShowS
$cshowsPrec :: TrackNum -> Context -> ShowS
Show)

ctx_view_selection :: Context -> (ViewId, Sel.Selection)
ctx_view_selection :: Context -> (ViewId, Selection)
ctx_view_selection Context
ctx = (Context -> ViewId
ctx_view_id Context
ctx, Context -> Selection
ctx_selection Context
ctx)

context :: Cmd.M m => m Context
context :: forall (m :: * -> *). M m => m Context
context = forall (m :: * -> *). M m => TrackNum -> m Context
context_selnum TrackNum
Config.insert_selnum

context_selnum :: Cmd.M m => Sel.Num -> m Context
context_selnum :: forall (m :: * -> *). M m => TrackNum -> m Context
context_selnum TrackNum
selnum = forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => TrackNum -> m (Maybe Context)
lookup_context_selnum TrackNum
selnum

lookup_context :: Cmd.M m => m (Maybe Context)
lookup_context :: forall (m :: * -> *). M m => m (Maybe Context)
lookup_context = forall (m :: * -> *). M m => TrackNum -> m (Maybe Context)
lookup_context_selnum TrackNum
Config.insert_selnum

lookup_context_selnum :: Cmd.M m => Sel.Num -> m (Maybe Context)
lookup_context_selnum :: forall (m :: * -> *). M m => TrackNum -> m (Maybe Context)
lookup_context_selnum TrackNum
selnum =
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm forall (m :: * -> *). M m => m (Maybe ViewId)
Cmd.lookup_focused_view forall a b. (a -> b) -> a -> b
$ \ViewId
view_id ->
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> m (Maybe Selection)
Ui.get_selection ViewId
view_id TrackNum
selnum) forall a b. (a -> b) -> a -> b
$ \Selection
sel -> do
        BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ViewId -> BlockId -> Selection -> Context
Context ViewId
view_id BlockId
block_id Selection
sel

get :: Cmd.M m => m Sel.Selection
get :: forall (m :: * -> *). M m => m Selection
get = forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe Selection)
lookup

lookup :: Cmd.M m => m (Maybe Sel.Selection)
lookup :: forall (m :: * -> *). M m => m (Maybe Selection)
lookup = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Context -> Selection
ctx_selection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m (Maybe Context)
lookup_context

get_view_sel :: Cmd.M m => m (ViewId, Sel.Selection)
get_view_sel :: forall (m :: * -> *). M m => m (ViewId, Selection)
get_view_sel = Context -> (ViewId, Selection)
ctx_view_selection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m Context
context

range :: Cmd.M m => m Events.Range
range :: forall (m :: * -> *). M m => m Range
range = Selection -> Range
Events.selection_range forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m Selection
get

point :: Cmd.M m => m TrackTime
point :: forall (m :: * -> *). M m => m TrackTime
point = Selection -> TrackTime
sel_point forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m Selection
get

start, end :: Cmd.M m => m TrackTime
start :: forall (m :: * -> *). M m => m TrackTime
start = Selection -> TrackTime
Sel.min forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m Selection
get
end :: forall (m :: * -> *). M m => m TrackTime
end = Selection -> TrackTime
Sel.max forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m Selection
get

-- ** selections in RealTime

-- | Get the real time range of the focused selection.  If there's a root
-- block, then it will be in relative to that root, otherwise it's equivalent
-- to 'local_realtime'.
realtime :: Cmd.M m => m (BlockId, RealTime, RealTime)
realtime :: forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
realtime = do
    Maybe BlockId
maybe_root_id <- forall (m :: * -> *). M m => m (Maybe BlockId)
Ui.lookup_root_id
    case Maybe BlockId
maybe_root_id of
        Maybe BlockId
Nothing -> forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
local_realtime
        Just BlockId
root_id -> do
            (RealTime
s, RealTime
e) <- forall (m :: * -> *). M m => BlockId -> m (RealTime, RealTime)
relative_realtime BlockId
root_id
            forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
root_id, RealTime
s, RealTime
e)

-- | RealTime of the given ScoreTime, relative to the root block.  This is
-- the closest we get to an absolute real time.
root_realtime :: Cmd.M m => BlockId -> Maybe TrackId -> ScoreTime
    -> m (Maybe RealTime)
root_realtime :: forall (m :: * -> *).
M m =>
BlockId -> Maybe TrackId -> TrackTime -> m (Maybe RealTime)
root_realtime BlockId
block_id Maybe TrackId
maybe_track_id TrackTime
pos =
    forall (m :: * -> *). M m => m BlockId
Ui.get_root_id forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \BlockId
root_block ->
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
Cmd.lookup_performance BlockId
root_block) forall a b. (a -> b) -> a -> b
$ \Performance
perf ->
    forall (m :: * -> *).
M m =>
Performance
-> BlockId -> Maybe TrackId -> TrackTime -> m (Maybe RealTime)
Perf.lookup_realtime Performance
perf BlockId
block_id Maybe TrackId
maybe_track_id TrackTime
pos

-- | This is like 'get_insert', except get the selection on the root block,
-- falling back to the current one if there is none.
get_root_insert :: Cmd.M m => m Point
get_root_insert :: forall (m :: * -> *). M m => m Point
get_root_insert = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). M m => m Point
get_insert forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe Point)
rootsel
    where
    rootsel :: m (Maybe Point)
rootsel = forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm forall (m :: * -> *). M m => m (Maybe BlockId)
Ui.lookup_root_id forall a b. (a -> b) -> a -> b
$ \BlockId
root_id ->
        forall (m :: * -> *). M m => BlockId -> m (Maybe Point)
lookup_block_insert BlockId
root_id

-- | Get the current selection in RealTime relative to another block.
--
-- If a block is called in multiple places, a score time on it may occur at
-- multiple real times.  Pick the real time from the given selection which is
-- closest to the real time of the selection on the given root block.
--
-- If there's no selection on the root block then return the RealTime from the
-- block's first occurrance.
relative_realtime :: Cmd.M m => BlockId -> m (RealTime, RealTime)
relative_realtime :: forall (m :: * -> *). M m => BlockId -> m (RealTime, RealTime)
relative_realtime BlockId
root_id = do
    (ViewId
view_id, Selection
sel) <- forall (m :: * -> *). M m => m (ViewId, Selection)
get_view_sel
    BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    TrackId
track_id <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
BlockId -> Selection -> m (Maybe TrackId)
sel_track BlockId
block_id Selection
sel
    Maybe Point
maybe_root_sel <- forall (m :: * -> *). M m => BlockId -> m (Maybe Point)
lookup_block_insert BlockId
root_id
    Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
root_id
    let root_pos :: RealTime
root_pos = TempoFunction -> Maybe Point -> RealTime
point_to_real (Performance -> TempoFunction
Cmd.perf_tempo Performance
perf) Maybe Point
maybe_root_sel
    let warp :: Warp
warp = Performance -> ClosestWarpFunction
Cmd.perf_closest_warp Performance
perf BlockId
block_id TrackId
track_id RealTime
root_pos
    let (TrackTime
start, TrackTime
end) = Selection -> (TrackTime, TrackTime)
Sel.range Selection
sel
    forall (m :: * -> *) a. Monad m => a -> m a
return (Warp -> TrackTime -> RealTime
Warp.warp Warp
warp TrackTime
start, Warp -> TrackTime -> RealTime
Warp.warp Warp
warp TrackTime
end)

-- | Get the RealTime range of the current selection, as derived from current
-- selection's block.  This means that the top should be 0.
local_realtime :: Cmd.M m => m (BlockId, RealTime, RealTime)
local_realtime :: forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
local_realtime = do
    (ViewId
view_id, Selection
sel) <- forall (m :: * -> *). M m => m (ViewId, Selection)
get_view_sel
    BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    TrackId
track_id <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
BlockId -> Selection -> m (Maybe TrackId)
sel_track BlockId
block_id Selection
sel
    Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    let (TrackTime
start, TrackTime
end) = Selection -> (TrackTime, TrackTime)
Sel.range Selection
sel
    let warp :: Warp
warp = Performance -> ClosestWarpFunction
Cmd.perf_closest_warp Performance
perf BlockId
block_id TrackId
track_id RealTime
0
    forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, Warp -> TrackTime -> RealTime
Warp.warp Warp
warp TrackTime
start, Warp -> TrackTime -> RealTime
Warp.warp Warp
warp TrackTime
end)

-- | This is like 'relative_realtime' but gets a RealTime relative to a Point,
-- not a range.
relative_realtime_point :: Cmd.Performance -> Maybe Point -> Point -> RealTime
relative_realtime_point :: Performance -> Maybe Point -> Point -> RealTime
relative_realtime_point Performance
perf Maybe Point
maybe_root_sel (BlockId
block_id, TrackNum
_, TrackId
track_id, TrackTime
pos) =
    Warp -> TrackTime -> RealTime
Warp.warp Warp
warp TrackTime
pos
    where
    root_pos :: RealTime
root_pos = TempoFunction -> Maybe Point -> RealTime
point_to_real (Performance -> TempoFunction
Cmd.perf_tempo Performance
perf) Maybe Point
maybe_root_sel
    warp :: Warp
warp = Performance -> ClosestWarpFunction
Cmd.perf_closest_warp Performance
perf BlockId
block_id TrackId
track_id RealTime
root_pos

point_to_real :: Transport.TempoFunction -> Maybe Point -> RealTime
point_to_real :: TempoFunction -> Maybe Point -> RealTime
point_to_real TempoFunction
_ Maybe Point
Nothing = RealTime
0
point_to_real TempoFunction
tempo (Just (BlockId
block_id, TrackNum
_, TrackId
track_id, TrackTime
pos)) =
    forall a. a -> Maybe a -> a
fromMaybe RealTime
0 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.head forall a b. (a -> b) -> a -> b
$ TempoFunction
tempo BlockId
block_id TrackId
track_id TrackTime
pos

-- ** select events

-- | Selected events per track.  Gives events before, within, and after the
-- selection.  As usual, previous events are in descending order.
type SelectedAround = [(TrackId, ([Event.Event], [Event.Event], [Event.Event]))]
type SelectedEvents = [(TrackId, [Event.Event])]

around_to_events :: SelectedAround -> SelectedEvents
around_to_events :: SelectedAround -> SelectedEvents
around_to_events = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \(TrackId
track_id, ([Event]
_, [Event]
within, [Event]
_)) -> (TrackId
track_id, [Event]
within)

-- | All selected events.  'events_around' is the default selection behaviour.
events :: Cmd.M m => m SelectedEvents
events :: forall (m :: * -> *). M m => m SelectedEvents
events = forall (m :: * -> *). M m => Context -> m SelectedEvents
ctx_events forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m Context
context

ctx_events :: Ui.M m => Context -> m SelectedEvents
ctx_events :: forall (m :: * -> *). M m => Context -> m SelectedEvents
ctx_events Context
ctx = SelectedAround -> SelectedEvents
around_to_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => Context -> m SelectedAround
ctx_events_around Context
ctx

-- | Like 'events', but only for the 'sel_point_track'.
track_events :: Cmd.M m => m (TrackId, [Event.Event])
track_events :: forall (m :: * -> *). M m => m (TrackId, [Event])
track_events = forall (m :: * -> *). M m => Context -> m (TrackId, [Event])
ctx_track_events forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m Context
context

ctx_track_events :: Ui.M m => Context -> m (TrackId, [Event.Event])
ctx_track_events :: forall (m :: * -> *). M m => Context -> m (TrackId, [Event])
ctx_track_events Context
ctx = do
    SelectedEvents
events <- SelectedAround -> SelectedEvents
around_to_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => Context -> m SelectedAround
ctx_events_around Context
ctx
    forall (m :: * -> *) a.
(HasCallStack, M m) =>
Text -> Maybe a -> m a
Ui.require Text
"ctx_events_around output should be 1:1 with TrackIds" forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> Maybe a
Lists.head SelectedEvents
events

events_around :: Cmd.M m => m SelectedAround
events_around :: forall (m :: * -> *). M m => m SelectedAround
events_around = forall (m :: * -> *). M m => Context -> m SelectedAround
ctx_events_around forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m Context
context

-- | Get events exactly at the point.  This gets both positive and negative
-- events, so each track may have up to 2 events.
events_at_point :: Cmd.M m => m SelectedEvents
events_at_point :: forall (m :: * -> *). M m => m SelectedEvents
events_at_point = do
    [TrackId]
track_ids <- forall (m :: * -> *). M m => m [TrackId]
track_ids
    TrackTime
pos <- forall (m :: * -> *). M m => m TrackTime
point
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TrackId]
track_ids forall a b. (a -> b) -> a -> b
$ \TrackId
track_id -> do
        Events
events <- forall (m :: * -> *). M m => TrackId -> m Events
Ui.get_events TrackId
track_id
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (TrackId
track_id,) forall a b. (a -> b) -> a -> b
$
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) (TrackTime -> Orientation -> Events -> Maybe Event
Events.at TrackTime
pos Orientation
Types.Negative Events
events)
            forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) (TrackTime -> Orientation -> Events -> Maybe Event
Events.at TrackTime
pos Orientation
Types.Positive Events
events)

-- -- | Like 'event_around', but select as if the selection were a point.
-- -- Suitable for cmds that logically only work on a single event per-track.
-- events_around_point :: Cmd.M m => m SelectedAround
-- events_around_point = do
--     ctx <- context
--     let sel = ctx_selection ctx
--     ctx_events_around $ ctx
--         { ctx_selection = sel
--             { Sel.start_pos = sel_point sel
--             , Sel.cur_pos = sel_point sel
--             }
--         }

-- | Get events in the selection, but if no events are selected, expand it
-- to include a neighboring event, as documented in 'select_neighbor'.
--
-- Normally the range is half-open by event orientation, so a positive event at
-- the end of the selection won't be included.  But there's a special hack
-- where if the end of the selection happens to be the end of the block,
-- a positive event there will be included anyway.  Otherwise it's annoying to
-- select a final event (unless it's negative).
--
-- This is the standard definition of a selection, and should be used in all
-- standard selection using commands.
ctx_events_around :: Ui.M m => Context -> m SelectedAround
ctx_events_around :: forall (m :: * -> *). M m => Context -> m SelectedAround
ctx_events_around Context
ctx = do
    (BlockId
block_id, [TrackNum]
_, [TrackId]
track_ids, Range
_) <- forall (m :: * -> *).
M m =>
Context -> m (BlockId, [TrackNum], [TrackId], Range)
ctx_tracks Context
ctx
    TrackTime
block_end <- forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_end BlockId
block_id
    forall {a} {a} {a}.
TrackTime -> [(a, (a, [a], [a]))] -> [(a, (a, [a], [a]))]
extend TrackTime
block_end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [TrackId]
track_ids forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Selection -> Events -> ([Event], [Event], [Event])
split_events_around Selection
sel) 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 forall (m :: * -> *). M m => TrackId -> m Events
Ui.get_events [TrackId]
track_ids
    where
    extend :: TrackTime -> [(a, (a, [a], [a]))] -> [(a, (a, [a], [a]))]
extend TrackTime
block_end
        | TrackTime
block_end forall a. Eq a => a -> a -> Bool
== Selection -> TrackTime
Sel.max Selection
sel = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {a} {a}. (a, (a, [a], [a])) -> (a, (a, [a], [a]))
until_end
        | Bool
otherwise = forall a. a -> a
id
    sel :: Selection
sel = Context -> Selection
ctx_selection Context
ctx
    until_end :: (a, (a, [a], [a])) -> (a, (a, [a], [a]))
until_end (a
track_id, (a
pre, [a]
within, [a]
post)) =
        (a
track_id, (a
pre, [a]
within forall a. [a] -> [a] -> [a]
++ [a]
post, []))

split_events_around :: Sel.Selection -> Events.Events
    -> ([Event.Event], [Event.Event], [Event.Event])
split_events_around :: Selection -> Events -> ([Event], [Event], [Event])
split_events_around Selection
sel Events
events
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Event]
within = Selection -> ([Event], [Event]) -> ([Event], [Event], [Event])
select_neighbor Selection
sel ([Event]
pre, [Event]
post)
    | Bool
otherwise = ([Event]
pre, [Event]
within, [Event]
post)
    where
    ([Event]
pre, [Event]
within, [Event]
post) =
        (Events -> [Event]
Events.descending Events
pre, Events -> [Event]
Events.ascending Events
within, Events -> [Event]
Events.ascending Events
post)
        where
        (Events
pre, Events
within, Events
post) =
            Range -> Events -> (Events, Events, Events)
Events.split_range (Selection -> Range
Events.selection_range Selection
sel) Events
events

select_neighbor :: Sel.Selection -> ([Event.Event], [Event.Event])
    -> ([Event.Event], [Event.Event], [Event.Event])
select_neighbor :: Selection -> ([Event], [Event]) -> ([Event], [Event], [Event])
select_neighbor Selection
sel ([Event], [Event])
pair = case ([Event], [Event])
pair of
    -- Always pick an overlapping event.
    (Event
pre:[Event]
pres, [Event]
posts) | TrackTime -> Event -> Bool
Event.overlaps TrackTime
p Event
pre -> ([Event]
pres, [Event
pre], [Event]
posts)
    ([Event]
pres, Event
post:[Event]
posts) | TrackTime -> Event -> Bool
Event.overlaps TrackTime
p Event
post -> ([Event]
pres, [Event
post], [Event]
posts)
    --  |--->    <---| => take based on orientation
    (Event
pre:[Event]
pres, Event
post:[Event]
posts)
        | Event -> Bool
Event.is_positive Event
pre Bool -> Bool -> Bool
&& Event -> Bool
Event.is_negative Event
post -> case Orientation
orient of
            Orientation
Types.Positive -> ([Event]
pres, [Event
pre], Event
postforall a. a -> [a] -> [a]
:[Event]
posts)
            Orientation
Types.Negative -> (Event
preforall a. a -> [a] -> [a]
:[Event]
pres, [Event
post], [Event]
posts)
    --  |--->          => take pre
    (Event
pre:[Event]
pres, [Event]
posts) | Event -> Bool
Event.is_positive Event
pre -> ([Event]
pres, [Event
pre], [Event]
posts)
    --           <---| => take post
    ([Event]
pres, Event
post:[Event]
posts) | Event -> Bool
Event.is_negative Event
post -> ([Event]
pres, [Event
post], [Event]
posts)
    --  <---|    |---> => in the middle, do nothing
    ([Event]
pres, [Event]
posts) -> ([Event]
pres, [], [Event]
posts)
    where
    p :: TrackTime
p = Selection -> TrackTime
sel_point Selection
sel
    orient :: Orientation
orient = Selection -> Orientation
Sel.event_orientation Selection
sel

-- | This is similar to 'events_around', except that the direction is reversed:
-- it favors the next positive event, or the previous negative one.  Also this
-- assumes a point selection and only selects one event per track.
opposite_neighbor :: Cmd.M m => m [(TrackId, Event.Event)]
opposite_neighbor :: forall (m :: * -> *). M m => m [(TrackId, Event)]
opposite_neighbor = do
    [TrackId]
tids <- forall (m :: * -> *). M m => m [TrackId]
track_ids
    Selection
sel <- forall (m :: * -> *). M m => m Selection
get
    [Maybe Event]
events <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TrackId]
tids forall a b. (a -> b) -> a -> b
$ \TrackId
track_id ->
        TrackTime -> Orientation -> Events -> Maybe Event
select_opposite_neighbor (Selection -> TrackTime
sel_point Selection
sel) (Selection -> Orientation
Sel.event_orientation Selection
sel) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall (m :: * -> *). M m => TrackId -> m Events
Ui.get_events TrackId
track_id
    forall (m :: * -> *) a. Monad m => a -> m a
return [(TrackId
track_id, Event
event) | (TrackId
track_id, Just Event
event) <- forall a b. [a] -> [b] -> [(a, b)]
zip [TrackId]
tids [Maybe Event]
events]

select_opposite_neighbor :: ScoreTime -> Types.Orientation -> Events.Events
    -> Maybe Event.Event
select_opposite_neighbor :: TrackTime -> Orientation -> Events -> Maybe Event
select_opposite_neighbor TrackTime
pos Orientation
orient Events
events =
    case TrackTime -> Events -> ([Event], [Event])
Events.split_lists TrackTime
pos Events
events of
        -- TODO should select overlapping like before
        -- except this messes up zero dur
        -- How did this work before?  It didn't!
        -- (pre:_, _) | Event.overlaps pos pre -> Just pre
        -- (_, post:_) | Event.overlaps pos post -> Just post
        (Event
pre:[Event]
_, Event
post:[Event]
_)
            | Event -> Bool
Event.is_positive Event
post Bool -> Bool -> Bool
&& Event -> Bool
Event.is_negative Event
pre -> case Orientation
orient of
                Orientation
Types.Positive -> forall a. a -> Maybe a
Just Event
post
                Orientation
Types.Negative -> forall a. a -> Maybe a
Just Event
pre
        ([Event]
_, Event
post:[Event]
_) | Event -> Bool
Event.is_positive Event
post -> forall a. a -> Maybe a
Just Event
post
        (Event
pre:[Event]
_, [Event]
_) | Event -> Bool
Event.is_negative Event
pre -> forall a. a -> Maybe a
Just Event
pre
        ([Event], [Event])
_ -> forall a. Maybe a
Nothing

-- ** select tracks

-- | Per-track selection info.
--
-- The TrackNums are sorted, and the TrackIds are likewise in left-to-right
-- order.  Only TrackNums for event tracks are returned, so both lists should
-- have the same length and correspond if you zip them up.
type Tracks = (BlockId, [TrackNum], [TrackId], Events.Range)

-- | Get selected event tracks along with the selection.  The tracks are
-- returned in ascending order.  Only event tracks are returned, and tracks
-- merged into the selected tracks are included.
tracks :: Cmd.M m => m Tracks
tracks :: forall (m :: * -> *).
M m =>
m (BlockId, [TrackNum], [TrackId], Range)
tracks = forall (m :: * -> *).
M m =>
Context -> m (BlockId, [TrackNum], [TrackId], Range)
ctx_tracks forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m Context
context

-- | Just the TrackIds part of 'tracks'.
track_ids :: Cmd.M m => m [TrackId]
track_ids :: forall (m :: * -> *). M m => m [TrackId]
track_ids = do
    (BlockId
_, [TrackNum]
_, [TrackId]
track_ids, Range
_) <- forall (m :: * -> *).
M m =>
m (BlockId, [TrackNum], [TrackId], Range)
tracks
    forall (m :: * -> *) a. Monad m => a -> m a
return [TrackId]
track_ids

tracknums :: Cmd.M m => m (BlockId, [TrackNum])
tracknums :: forall (m :: * -> *). M m => m (BlockId, [TrackNum])
tracknums = do
    (BlockId
block_id, [TrackNum]
tracknums, [TrackId]
_, Range
_) <- forall (m :: * -> *).
M m =>
m (BlockId, [TrackNum], [TrackId], Range)
tracks
    forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, [TrackNum]
tracknums)

event_track :: Cmd.M m => m (BlockId, TrackId)
event_track :: forall (m :: * -> *). M m => m (BlockId, TrackId)
event_track = forall (m :: * -> *). M m => Context -> m (BlockId, TrackId)
ctx_event_track forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m Context
context

ctx_event_track :: Ui.M m => Context -> m (BlockId, TrackId)
ctx_event_track :: forall (m :: * -> *). M m => Context -> m (BlockId, TrackId)
ctx_event_track Context
ctx = do
    (BlockId
block_id, Maybe TrackId
mb_track_id) <- forall (m :: * -> *). M m => Context -> m (BlockId, Maybe TrackId)
ctx_track Context
ctx
    TrackId
track_id <- forall (m :: * -> *) a.
(HasCallStack, M m) =>
Text -> Maybe a -> m a
Ui.require Text
"must select an event track" Maybe TrackId
mb_track_id
    forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, TrackId
track_id)

track :: Cmd.M m => m (BlockId, Maybe TrackId)
track :: forall (m :: * -> *). M m => m (BlockId, Maybe TrackId)
track = forall (m :: * -> *). M m => Context -> m (BlockId, Maybe TrackId)
ctx_track forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m Context
context

ctx_track :: Ui.M m => Context -> m (BlockId, Maybe TrackId)
ctx_track :: forall (m :: * -> *). M m => Context -> m (BlockId, Maybe TrackId)
ctx_track Context
ctx = do
    let block_id :: BlockId
block_id = Context -> BlockId
ctx_block_id Context
ctx
    Maybe TrackId
maybe_track_id <-
        forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id (Selection -> TrackNum
sel_point_track (Context -> Selection
ctx_selection Context
ctx))
    forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, Maybe TrackId
maybe_track_id)

-- | Selected tracks, including merged tracks.
ctx_tracks :: Ui.M m => Context -> m Tracks
ctx_tracks :: forall (m :: * -> *).
M m =>
Context -> m (BlockId, [TrackNum], [TrackId], Range)
ctx_tracks Context
ctx = do
    (BlockId
block_id, [TrackNum]
tracknums, [TrackId]
track_ids, Range
range) <- forall (m :: * -> *).
M m =>
Context -> m (BlockId, [TrackNum], [TrackId], Range)
ctx_strict_tracks Context
ctx
    [Track]
tracks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). M m => BlockId -> TrackNum -> m Track
Ui.get_block_track_at BlockId
block_id) [TrackNum]
tracknums
    let merged_track_ids :: Set TrackId
merged_track_ids = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap Track -> Set TrackId
Block.track_merged [Track]
tracks
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    let merged :: [(TrackNum, TrackId)]
merged = Block -> [TrackId] -> [(TrackNum, TrackId)]
tracknums_of Block
block (forall a. Set a -> [a]
Set.toList Set TrackId
merged_track_ids)
    let ([TrackNum]
all_tracknums, [TrackId]
all_track_ids) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
Lists.uniqueSort forall a b. (a -> b) -> a -> b
$
            [(TrackNum, TrackId)]
merged forall a. [a] -> [a] -> [a]
++ forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum]
tracknums [TrackId]
track_ids
    forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, [TrackNum]
all_tracknums, [TrackId]
all_track_ids, Range
range)

-- | Selected tracks, not including merged tracks.
ctx_strict_tracks :: Ui.M m => Context -> m Tracks
ctx_strict_tracks :: forall (m :: * -> *).
M m =>
Context -> m (BlockId, [TrackNum], [TrackId], Range)
ctx_strict_tracks Context
ctx = do
    let block_id :: BlockId
block_id = Context -> BlockId
ctx_block_id Context
ctx
    TrackNum
tracks <- forall (m :: * -> *). M m => BlockId -> m TrackNum
Ui.track_count BlockId
block_id
    let tracknums :: [TrackNum]
tracknums = TrackNum -> Selection -> [TrackNum]
Sel.tracknums TrackNum
tracks (Context -> Selection
ctx_selection Context
ctx)
    [Maybe TracklikeId]
tracklikes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TracklikeId)
Ui.track_at BlockId
block_id) [TrackNum]
tracknums
    ([TrackNum]
tracknums, [TrackId]
track_ids) <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip
        [ (TrackNum
i, TrackId
track_id)
        | (TrackNum
i, Just (Block.TId TrackId
track_id RulerId
_)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum]
tracknums [Maybe TracklikeId]
tracklikes
        ]
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( BlockId
block_id, [TrackNum]
tracknums, [TrackId]
track_ids
        , Selection -> Range
Events.selection_range (Context -> Selection
ctx_selection Context
ctx)
        )

tracknums_of :: Block.Block -> [TrackId] -> [(TrackNum, TrackId)]
tracknums_of :: Block -> [TrackId] -> [(TrackNum, TrackId)]
tracknums_of Block
block [TrackId]
track_ids = do
    (TrackNum
tracknum, Block.TId TrackId
tid RulerId
_) <-
        forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
0..] (Block -> [TracklikeId]
Block.block_tracklike_ids Block
block)
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TrackId
tid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TrackId]
track_ids)
    forall (m :: * -> *) a. Monad m => a -> m a
return (TrackNum
tracknum, TrackId
tid)

-- * history

-- | Keep only this many selection history entries.  This is hardcoded and low
-- since I'm probably not interested in ancient selections.
keep_history :: Int
keep_history :: TrackNum
keep_history = TrackNum
10

record_history :: Cmd.M m => m ()
record_history :: forall (m :: * -> *). M m => m ()
record_history =
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM forall (m :: * -> *). M m => m (Maybe Context)
lookup_context (forall (m :: * -> *).
M m =>
(SelectionHistory -> SelectionHistory) -> m ()
modify_history forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ViewId, Selection) -> SelectionHistory -> SelectionHistory
record forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> (ViewId, Selection)
ctx_view_selection)
    where
    -- Only record the current position if it has changed.
    record :: (ViewId, Selection) -> SelectionHistory -> SelectionHistory
record (ViewId, Selection)
view_sel SelectionHistory
hist
        | forall a. TrackNum -> [a] -> [a]
take TrackNum
1 (SelectionHistory -> [(ViewId, Selection)]
Cmd.sel_past SelectionHistory
hist) forall a. Eq a => a -> a -> Bool
/= [(ViewId, Selection)
view_sel] = Cmd.SelectionHistory
            { sel_past :: [(ViewId, Selection)]
sel_past = forall a. TrackNum -> [a] -> [a]
take TrackNum
keep_history forall a b. (a -> b) -> a -> b
$ (ViewId, Selection)
view_sel forall a. a -> [a] -> [a]
: SelectionHistory -> [(ViewId, Selection)]
Cmd.sel_past SelectionHistory
hist
            , sel_future :: [(ViewId, Selection)]
sel_future = []
            }
        | Bool
otherwise = SelectionHistory
hist

previous_selection :: Cmd.M m => Bool -> m ()
previous_selection :: forall (m :: * -> *). M m => Bool -> m ()
previous_selection Bool
change_views = do
    ViewId
old_view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    Maybe (ViewId, Selection)
cur <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Context -> (ViewId, Selection)
ctx_view_selection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m (Maybe Context)
lookup_context
    SelectionHistory
hist <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> SelectionHistory
Cmd.state_selection_history
    case forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Eq a => a -> a -> Bool
==Maybe (ViewId, Selection)
cur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ SelectionHistory -> [(ViewId, Selection)]
Cmd.sel_past SelectionHistory
hist of
        (ViewId
view_id, Selection
sel) : [(ViewId, Selection)]
past | Bool
change_views Bool -> Bool -> Bool
|| ViewId
view_id forall a. Eq a => a -> a -> Bool
== ViewId
old_view_id -> do
            forall (m :: * -> *).
M m =>
(SelectionHistory -> SelectionHistory) -> m ()
modify_history forall a b. (a -> b) -> a -> b
$ \SelectionHistory
hist -> SelectionHistory
hist
                { sel_past :: [(ViewId, Selection)]
Cmd.sel_past = [(ViewId, Selection)]
past
                , sel_future :: [(ViewId, Selection)]
Cmd.sel_future = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe (ViewId, Selection)
cur (SelectionHistory -> [(ViewId, Selection)]
Cmd.sel_future SelectionHistory
hist)
                }
            forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set_without_history ViewId
view_id (forall a. a -> Maybe a
Just Selection
sel)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ViewId
view_id forall a. Eq a => a -> a -> Bool
/= ViewId
old_view_id) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => ViewId -> m ()
Cmd.focus ViewId
view_id
        [(ViewId, Selection)]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

next_selection :: Cmd.M m => Bool -> m ()
next_selection :: forall (m :: * -> *). M m => Bool -> m ()
next_selection Bool
change_views = do
    ViewId
old_view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    Maybe (ViewId, Selection)
cur <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Context -> (ViewId, Selection)
ctx_view_selection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m (Maybe Context)
lookup_context
    SelectionHistory
hist <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> SelectionHistory
Cmd.state_selection_history
    case forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Eq a => a -> a -> Bool
==Maybe (ViewId, Selection)
cur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ SelectionHistory -> [(ViewId, Selection)]
Cmd.sel_future SelectionHistory
hist of
        (ViewId
view_id, Selection
sel) : [(ViewId, Selection)]
future | Bool
change_views Bool -> Bool -> Bool
|| ViewId
view_id forall a. Eq a => a -> a -> Bool
== ViewId
old_view_id -> do
            forall (m :: * -> *).
M m =>
(SelectionHistory -> SelectionHistory) -> m ()
modify_history forall a b. (a -> b) -> a -> b
$ \SelectionHistory
hist -> SelectionHistory
hist
                { sel_past :: [(ViewId, Selection)]
Cmd.sel_past = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe (ViewId, Selection)
cur (SelectionHistory -> [(ViewId, Selection)]
Cmd.sel_past SelectionHistory
hist)
                , sel_future :: [(ViewId, Selection)]
Cmd.sel_future = [(ViewId, Selection)]
future
                }
            forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
set_without_history ViewId
view_id (forall a. a -> Maybe a
Just Selection
sel)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ViewId
view_id forall a. Eq a => a -> a -> Bool
/= ViewId
old_view_id) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => ViewId -> m ()
Cmd.focus ViewId
view_id
        [(ViewId, Selection)]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

modify_history :: Cmd.M m => (Cmd.SelectionHistory -> Cmd.SelectionHistory)
    -> m ()
modify_history :: forall (m :: * -> *).
M m =>
(SelectionHistory -> SelectionHistory) -> m ()
modify_history SelectionHistory -> SelectionHistory
f = forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
state -> State
state
    { state_selection_history :: SelectionHistory
Cmd.state_selection_history = SelectionHistory -> SelectionHistory
f (State -> SelectionHistory
Cmd.state_selection_history State
state) }