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

{-# LANGUAGE ViewPatterns #-}
{- | Cmds to add notes to a note track.

    This module is sister to "Derive.Note" since it edits events that
    Derive.Note parses.

    Note events are usually given a duration of the current time step.  If a
    "trigger only" instrument (e.g. percussion) is in scope, they are created
    with zero duration.  Also, starting a raw edit with space will create a
    zero duration event.
-}
module Cmd.NoteTrack (
    ControlTrack(..)
    , cmd_val_edit
    , cmd_method_edit
) where
import qualified Data.List as List
import qualified Data.Map as Map

import qualified Util.Seq as Seq
import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.ControlTrack as ControlTrack
import qualified Cmd.Create as Create
import qualified Cmd.EditUtil as EditUtil
import qualified Cmd.Info as Info
import qualified Cmd.InputNote as InputNote
import qualified Cmd.Msg as Msg
import qualified Cmd.PitchTrack as PitchTrack
import qualified Cmd.Selection as Selection

import qualified Derive.Controls as Controls
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.ScoreT as ScoreT

import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Sel as Sel
import qualified Ui.Types as Types
import qualified Ui.Ui as Ui

import           Global
import           Types


-- * val edit

-- | A control track belonging to the note track.  This can be a pitch track,
-- or a dyn track.
data ControlTrack = ControlTrack {
    ControlTrack -> TrackNum
track_note :: TrackNum
    , ControlTrack -> TrackNum
track_control :: TrackNum
    } deriving (TrackNum -> ControlTrack -> ShowS
[ControlTrack] -> ShowS
ControlTrack -> String
(TrackNum -> ControlTrack -> ShowS)
-> (ControlTrack -> String)
-> ([ControlTrack] -> ShowS)
-> Show ControlTrack
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlTrack] -> ShowS
$cshowList :: [ControlTrack] -> ShowS
show :: ControlTrack -> String
$cshow :: ControlTrack -> String
showsPrec :: TrackNum -> ControlTrack -> ShowS
$cshowsPrec :: TrackNum -> ControlTrack -> ShowS
Show, ControlTrack -> ControlTrack -> Bool
(ControlTrack -> ControlTrack -> Bool)
-> (ControlTrack -> ControlTrack -> Bool) -> Eq ControlTrack
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ControlTrack -> ControlTrack -> Bool
$c/= :: ControlTrack -> ControlTrack -> Bool
== :: ControlTrack -> ControlTrack -> Bool
$c== :: ControlTrack -> ControlTrack -> Bool
Eq)

-- | The val edit for note tracks edits its pitch track (possibly creating one
-- if necessary), and creates a blank event on the note track.  It may also
-- edit multiple pitch tracks for chords, or record velocity in addition to
-- pitch.
--
-- If I'm in chord mode, try to find the next track and put notes there.  If
-- there is no appropriate next track, the cmd will throw an error.
cmd_val_edit :: Cmd.M m => Msg.Msg -> m Cmd.Status
cmd_val_edit :: forall (m :: * -> *). M m => Msg -> m Status
cmd_val_edit Msg
msg = EditMode -> Text -> m Status -> m Status
forall (m :: * -> *) a. M m => EditMode -> Text -> m a -> m a
Cmd.suppress_history EditMode
Cmd.ValEdit Text
"note track val edit" (m Status -> m Status) -> m Status -> m Status
forall a b. (a -> b) -> a -> b
$ do
    Fallthrough -> Msg -> m ()
forall (m :: * -> *). M m => Fallthrough -> Msg -> m ()
EditUtil.fallthrough Fallthrough
EditUtil.NoBackspace Msg
msg
    EditUtil.Pos BlockId
block_id TrackNum
sel_tracknum TrackTime
pos TrackTime
dur <- m Pos
forall (m :: * -> *). M m => m Pos
EditUtil.get_pos
    case Msg
msg of
        Msg.InputNote Input
input_note -> case Input
input_note of
            InputNote.NoteOn NoteId
note_id Input
input Y
vel -> do
                Note
note <- Input -> m Note
forall (m :: * -> *). M m => Input -> m Note
EditUtil.input_to_note Input
input
                BlockId
-> TrackNum
-> TrackTime
-> TrackTime
-> NoteId
-> Note
-> Y
-> m ()
forall {m :: * -> *}.
M m =>
BlockId
-> TrackNum
-> TrackTime
-> TrackTime
-> NoteId
-> Note
-> Y
-> m ()
note_on BlockId
block_id TrackNum
sel_tracknum TrackTime
pos TrackTime
dur NoteId
note_id Note
note Y
vel
            InputNote.PitchChange NoteId
note_id Input
input -> do
                (TrackNum
pitch_tracknum, TrackId
track_id) <- Text -> Maybe (TrackNum, TrackId) -> m (TrackNum, TrackId)
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require
                    (Text
"no track for note_id " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NoteId -> Text
forall a. Show a => a -> Text
showt NoteId
note_id)
                    (Maybe (TrackNum, TrackId) -> m (TrackNum, TrackId))
-> m (Maybe (TrackNum, TrackId)) -> m (TrackNum, TrackId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NoteId -> m (Maybe (TrackNum, TrackId))
forall (m :: * -> *).
M m =>
NoteId -> m (Maybe (TrackNum, TrackId))
find_pitch_track NoteId
note_id
                Note
note <- Input -> m Note
forall (m :: * -> *). M m => Input -> m Note
EditUtil.input_to_note Input
input
                -- If advance is set, the selection may have advanced past
                -- the pitch's position, so look for a previous event.
                TrackTime
pos <- TrackId -> TrackTime -> m TrackTime
forall (m :: * -> *). M m => TrackId -> TrackTime -> m TrackTime
event_pos_at_or_before TrackId
track_id TrackTime
pos
                Pos -> Note -> m ()
forall (m :: * -> *). M m => Pos -> Note -> m ()
PitchTrack.val_edit_at
                    (BlockId -> TrackNum -> TrackTime -> TrackTime -> Pos
EditUtil.Pos BlockId
block_id TrackNum
pitch_tracknum TrackTime
pos TrackTime
dur) Note
note
            InputNote.NoteOff NoteId
note_id Y
_vel -> do
                NoteId -> m ()
forall {m :: * -> *}. M m => NoteId -> m ()
dissociate_note_id NoteId
note_id
                Bool
chord_done <- [m Bool] -> m Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM [(EditState -> Bool) -> m Bool
forall (m :: * -> *) a. M m => (EditState -> a) -> m a
get_state EditState -> Bool
Cmd.state_chord, m Bool
forall (m :: * -> *). M m => m Bool
all_keys_up]
                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
chord_done (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ TrackTime -> Maybe TrackNum -> m ()
forall {m :: * -> *}. M m => TrackTime -> Maybe TrackNum -> m ()
set_temp_sel TrackTime
pos Maybe TrackNum
forall a. Maybe a
Nothing
                m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ([m Bool] -> m Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM [Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
chord_done, (EditState -> Bool) -> m Bool
forall (m :: * -> *) a. M m => (EditState -> a) -> m a
get_state EditState -> Bool
Cmd.state_advance])
                    m ()
forall (m :: * -> *). M m => m ()
Selection.advance
            InputNote.Control {} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Msg
_ -> m ()
forall (m :: * -> *) a. M m => m a
Cmd.abort
    Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
    where
    -- NoteOn handling is especially complicated.
    note_on :: BlockId
-> TrackNum
-> TrackTime
-> TrackTime
-> NoteId
-> Note
-> Y
-> m ()
note_on BlockId
block_id TrackNum
sel_tracknum TrackTime
pos TrackTime
dur NoteId
note_id Note
note Y
vel = do
        Bool
chord_mode <- (EditState -> Bool) -> m Bool
forall (m :: * -> *) a. M m => (EditState -> a) -> m a
get_state EditState -> Bool
Cmd.state_chord
        -- Pitch track.
        (ControlTrack
ctrack, Bool
create) <- if Bool
chord_mode
            then do
                (ControlTrack
ctrack, Bool
create, Maybe TrackNum
maybe_next) <-
                    BlockId
-> TrackNum
-> (Text -> Bool)
-> m (ControlTrack, Bool, Maybe TrackNum)
forall (m :: * -> *).
M m =>
BlockId
-> TrackNum
-> (Text -> Bool)
-> m (ControlTrack, Bool, Maybe TrackNum)
next_control_track BlockId
block_id TrackNum
sel_tracknum Text -> Bool
is_pitch
                TrackTime -> Maybe TrackNum -> m ()
forall {m :: * -> *}. M m => TrackTime -> Maybe TrackNum -> m ()
set_temp_sel TrackTime
pos Maybe TrackNum
maybe_next
                (ControlTrack, Bool) -> m (ControlTrack, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlTrack
ctrack, Bool
create)
            else BlockId -> TrackNum -> (Text -> Bool) -> m (ControlTrack, Bool)
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Text -> Bool) -> m (ControlTrack, Bool)
this_control_track BlockId
block_id TrackNum
sel_tracknum Text -> Bool
is_pitch
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
create (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ BlockId -> ControlTrack -> m ()
forall (m :: * -> *). M m => BlockId -> ControlTrack -> m ()
create_pitch_track BlockId
block_id ControlTrack
ctrack
        BlockId -> TrackNum -> NoteId -> m ()
forall {m :: * -> *}. M m => BlockId -> TrackNum -> NoteId -> m ()
associate_note_id BlockId
block_id (ControlTrack -> TrackNum
track_control ControlTrack
ctrack) NoteId
note_id
        Orientation
orient <- (State -> Orientation) -> m Orientation
forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (EditState -> Orientation
Cmd.state_note_orientation (EditState -> Orientation)
-> (State -> EditState) -> State -> Orientation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit)
        let pitch_pos :: Pos
pitch_pos = BlockId -> TrackNum -> TrackTime -> TrackTime -> Pos
EditUtil.Pos BlockId
block_id (ControlTrack -> TrackNum
track_control ControlTrack
ctrack)
                TrackTime
pos (if Orientation
orient Orientation -> Orientation -> Bool
forall a. Eq a => a -> a -> Bool
== Orientation
Types.Positive then TrackTime
0 else -TrackTime
0)
        Pos -> Note -> m ()
forall (m :: * -> *). M m => Pos -> Note -> m ()
PitchTrack.val_edit_at Pos
pitch_pos Note
note
        -- Dyn track.
        m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((EditState -> Bool) -> m Bool
forall (m :: * -> *) a. M m => (EditState -> a) -> m a
get_state EditState -> Bool
Cmd.state_record_velocity) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            (ControlTrack
dtrack, Bool
create) <- if Bool
chord_mode
                then (\(ControlTrack
a, Bool
b, Maybe TrackNum
_) -> (ControlTrack
a, Bool
b)) ((ControlTrack, Bool, Maybe TrackNum) -> (ControlTrack, Bool))
-> m (ControlTrack, Bool, Maybe TrackNum) -> m (ControlTrack, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    BlockId
-> TrackNum
-> (Text -> Bool)
-> m (ControlTrack, Bool, Maybe TrackNum)
forall (m :: * -> *).
M m =>
BlockId
-> TrackNum
-> (Text -> Bool)
-> m (ControlTrack, Bool, Maybe TrackNum)
next_control_track BlockId
block_id TrackNum
sel_tracknum Text -> Bool
is_dyn
                else BlockId -> TrackNum -> (Text -> Bool) -> m (ControlTrack, Bool)
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Text -> Bool) -> m (ControlTrack, Bool)
this_control_track BlockId
block_id TrackNum
sel_tracknum Text -> Bool
is_dyn
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
create (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ BlockId -> ControlTrack -> m ()
forall (m :: * -> *). M m => BlockId -> ControlTrack -> m ()
create_dyn_track BlockId
block_id ControlTrack
dtrack
            Pos -> Y -> m ()
forall (m :: * -> *). M m => Pos -> Y -> m ()
ControlTrack.val_edit_at
                (BlockId -> TrackNum -> TrackTime -> TrackTime -> Pos
EditUtil.Pos BlockId
block_id (ControlTrack -> TrackNum
track_control ControlTrack
dtrack) TrackTime
pos TrackTime
0) Y
vel

        -- Create note and advance.
        Pos -> m ()
forall (m :: * -> *). M m => Pos -> m ()
ensure_note_event (BlockId -> TrackNum -> TrackTime -> TrackTime -> Pos
EditUtil.Pos BlockId
block_id (ControlTrack -> TrackNum
track_note ControlTrack
ctrack) TrackTime
pos TrackTime
dur)
        Bool
advance_mode <- (EditState -> Bool) -> m Bool
forall (m :: * -> *) a. M m => (EditState -> a) -> m a
get_state EditState -> Bool
Cmd.state_advance
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
advance_mode Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
chord_mode) m ()
forall (m :: * -> *). M m => m ()
Selection.advance

    is_pitch :: Text -> Bool
is_pitch = Text -> Bool
ParseTitle.is_pitch_track
    is_dyn :: Text -> Bool
is_dyn = (Maybe Control -> Maybe Control -> Bool
forall a. Eq a => a -> a -> Bool
== Control -> Maybe Control
forall a. a -> Maybe a
Just Control
Controls.dynamic) (Maybe Control -> Bool) -> (Text -> Maybe Control) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Control
ParseTitle.title_to_control
    set_temp_sel :: TrackTime -> Maybe TrackNum -> m ()
set_temp_sel TrackTime
pos Maybe TrackNum
maybe_tracknum = TrackNum -> Maybe Selection -> m ()
forall (m :: * -> *). M m => TrackNum -> Maybe Selection -> m ()
Selection.set_current
        TrackNum
Config.temporary_insert_selnum (Maybe Selection -> m ()) -> Maybe Selection -> m ()
forall a b. (a -> b) -> a -> b
$
            (TrackNum -> Selection) -> Maybe TrackNum -> Maybe Selection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\TrackNum
num -> TrackNum -> TrackTime -> Orientation -> Selection
Sel.point TrackNum
num TrackTime
pos Orientation
Sel.Positive) Maybe TrackNum
maybe_tracknum
    dissociate_note_id :: NoteId -> m ()
dissociate_note_id NoteId
note_id = (WriteDeviceState -> WriteDeviceState) -> m ()
forall (m :: * -> *).
M m =>
(WriteDeviceState -> WriteDeviceState) -> m ()
Cmd.modify_wdev_state ((WriteDeviceState -> WriteDeviceState) -> m ())
-> (WriteDeviceState -> WriteDeviceState) -> m ()
forall a b. (a -> b) -> a -> b
$ \WriteDeviceState
st -> WriteDeviceState
st
        { wdev_pitch_track :: Map NoteId (BlockId, TrackNum)
Cmd.wdev_pitch_track = NoteId
-> Map NoteId (BlockId, TrackNum) -> Map NoteId (BlockId, TrackNum)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete NoteId
note_id (WriteDeviceState -> Map NoteId (BlockId, TrackNum)
Cmd.wdev_pitch_track WriteDeviceState
st) }
    associate_note_id :: BlockId -> TrackNum -> NoteId -> m ()
associate_note_id BlockId
block_id TrackNum
tracknum NoteId
note_id = (WriteDeviceState -> WriteDeviceState) -> m ()
forall (m :: * -> *).
M m =>
(WriteDeviceState -> WriteDeviceState) -> m ()
Cmd.modify_wdev_state ((WriteDeviceState -> WriteDeviceState) -> m ())
-> (WriteDeviceState -> WriteDeviceState) -> m ()
forall a b. (a -> b) -> a -> b
$
        \WriteDeviceState
st -> WriteDeviceState
st { wdev_pitch_track :: Map NoteId (BlockId, TrackNum)
Cmd.wdev_pitch_track =
            NoteId
-> (BlockId, TrackNum)
-> Map NoteId (BlockId, TrackNum)
-> Map NoteId (BlockId, TrackNum)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NoteId
note_id (BlockId
block_id, TrackNum
tracknum) (WriteDeviceState -> Map NoteId (BlockId, TrackNum)
Cmd.wdev_pitch_track WriteDeviceState
st) }

-- | Find the next available control track.  Available means it is the given
-- track or is to its right, has either the same instrument or has the default
-- instrument, and doesn't already have a note_id associated with it.
--
-- If none is found, return the tracknum at which one should be created.
next_control_track :: Cmd.M m => BlockId -> TrackNum -> (Text -> Bool)
    -> m (ControlTrack, Bool, Maybe TrackNum)
    -- ^ (selected_track_pair, should_create, next_control_track)
next_control_track :: forall (m :: * -> *).
M m =>
BlockId
-> TrackNum
-> (Text -> Bool)
-> m (ControlTrack, Bool, Maybe TrackNum)
next_control_track BlockId
block_id TrackNum
tracknum Text -> Bool
is_control = do
    WriteDeviceState
wdev <- m WriteDeviceState
forall (m :: * -> *). M m => m WriteDeviceState
Cmd.get_wdev_state
    let associated :: [TrackNum]
associated =
            [TrackNum
tracknum | (BlockId
_, TrackNum
tracknum) <- Map NoteId (BlockId, TrackNum) -> [(BlockId, TrackNum)]
forall k a. Map k a -> [a]
Map.elems (WriteDeviceState -> Map NoteId (BlockId, TrackNum)
Cmd.wdev_pitch_track WriteDeviceState
wdev)]
    [Track]
tracks <- BlockId -> m [Track]
forall (m :: * -> *). M m => BlockId -> m [Track]
Info.block_tracks BlockId
block_id
    Instrument
inst <- BlockId -> TrackNum -> m Instrument
forall (m :: * -> *). M m => BlockId -> TrackNum -> m Instrument
Info.get_instrument_of BlockId
block_id TrackNum
tracknum
    let find :: TrackNum -> m (Maybe Track)
find TrackNum
right_of = (Track -> m Bool) -> [Track] -> m (Maybe Track)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM (Instrument -> [TrackNum] -> TrackNum -> Track -> m Bool
forall {m :: * -> *} {t :: * -> *}.
(Foldable t, M m) =>
Instrument -> t TrackNum -> TrackNum -> Track -> m Bool
candidate Instrument
inst [TrackNum]
associated TrackNum
right_of) [Track]
tracks
    Maybe Track
found <- TrackNum -> m (Maybe Track)
forall {m :: * -> *}. M m => TrackNum -> m (Maybe Track)
find TrackNum
tracknum
    case Maybe Track
found of
        Maybe Track
Nothing -> Text -> m (ControlTrack, Bool, Maybe TrackNum)
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw (Text -> m (ControlTrack, Bool, Maybe TrackNum))
-> Text -> m (ControlTrack, Bool, Maybe TrackNum)
forall a b. (a -> b) -> a -> b
$ Text
"no next note track in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
forall a. Show a => a -> Text
showt BlockId
block_id
        Just Track
track -> do
            (ControlTrack
ctrack, Bool
create) <- BlockId -> Track -> (Text -> Bool) -> m (ControlTrack, Bool)
forall (m :: * -> *).
M m =>
BlockId -> Track -> (Text -> Bool) -> m (ControlTrack, Bool)
should_create_control BlockId
block_id Track
track Text -> Bool
is_control
            Maybe Track
next <- TrackNum -> m (Maybe Track)
forall {m :: * -> *}. M m => TrackNum -> m (Maybe Track)
find (ControlTrack -> TrackNum
track_control ControlTrack
ctrack TrackNum -> TrackNum -> TrackNum
forall a. Num a => a -> a -> a
+ TrackNum
1)
            (ControlTrack, Bool, Maybe TrackNum)
-> m (ControlTrack, Bool, Maybe TrackNum)
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlTrack
ctrack, Bool
create,
                TrackInfo -> TrackNum
Ui.track_tracknum (TrackInfo -> TrackNum)
-> (Track -> TrackInfo) -> Track -> TrackNum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> TrackInfo
Info.track_info (Track -> TrackNum) -> Maybe Track -> Maybe TrackNum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Track
next)
    where
    -- Wow, monads can be awkward.
    candidate :: Instrument -> t TrackNum -> TrackNum -> Track -> m Bool
candidate Instrument
inst t TrackNum
associated TrackNum
right_of
            (Info.Track TrackInfo
track (Info.Note [TrackInfo]
controls [TrackInfo]
_)) =
        [m Bool] -> m Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM
            [ Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ TrackNum
tracknum TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
>= TrackNum
right_of
            , Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (TrackNum -> Bool) -> Maybe TrackNum -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (TrackNum -> t TrackNum -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t TrackNum
associated) Maybe TrackNum
pitch_tracknum
            , (Maybe Instrument -> Maybe Instrument -> Bool
forall a. Eq a => a -> a -> Bool
== Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just Instrument
inst) (Maybe Instrument -> Bool) -> m (Maybe Instrument) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> TrackNum -> m (Maybe Instrument)
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe Instrument)
Info.lookup_instrument_of BlockId
block_id TrackNum
tracknum
            ]
        where
        tracknum :: TrackNum
tracknum = TrackInfo -> TrackNum
Ui.track_tracknum TrackInfo
track
        pitch_tracknum :: Maybe TrackNum
pitch_tracknum = TrackInfo -> TrackNum
Ui.track_tracknum (TrackInfo -> TrackNum) -> Maybe TrackInfo -> Maybe TrackNum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (TrackInfo -> Bool) -> [TrackInfo] -> Maybe TrackInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Text -> Bool
is_control (Text -> Bool) -> (TrackInfo -> Text) -> TrackInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> Text
Ui.track_title) [TrackInfo]
controls
    candidate Instrument
_ t TrackNum
_ TrackNum
_ Track
_ = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | The given track should be a note track.  Figure out if it has a control
-- track, or if one should be created.
this_control_track :: Cmd.M m => BlockId -> TrackNum -> (Text -> Bool)
    -> m (ControlTrack, Bool)
this_control_track :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Text -> Bool) -> m (ControlTrack, Bool)
this_control_track BlockId
block_id TrackNum
tracknum Text -> Bool
is_control = do
    Track
track <- BlockId -> TrackNum -> m Track
forall (m :: * -> *). M m => BlockId -> TrackNum -> m Track
Info.get_track_type BlockId
block_id TrackNum
tracknum
    BlockId -> Track -> (Text -> Bool) -> m (ControlTrack, Bool)
forall (m :: * -> *).
M m =>
BlockId -> Track -> (Text -> Bool) -> m (ControlTrack, Bool)
should_create_control BlockId
block_id Track
track Text -> Bool
is_control

-- | Find the ControlTrack of the given note Track.  If there is none, return
-- the tracknum where you should create one.
should_create_control :: Cmd.M m => BlockId -> Info.Track
    -> (Text -> Bool) -> m (ControlTrack, Bool)
should_create_control :: forall (m :: * -> *).
M m =>
BlockId -> Track -> (Text -> Bool) -> m (ControlTrack, Bool)
should_create_control BlockId
block_id Track
track Text -> Bool
is_control = case Track -> TrackType
Info.track_type Track
track of
    Info.Note [TrackInfo]
controls [TrackInfo]
_ -> case [TrackInfo] -> Maybe TrackInfo
find [TrackInfo]
controls of
        Maybe TrackInfo
Nothing -> (ControlTrack, Bool) -> m (ControlTrack, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackNum -> TrackNum -> ControlTrack
ControlTrack TrackNum
tracknum (TrackNum
tracknumTrackNum -> TrackNum -> TrackNum
forall a. Num a => a -> a -> a
+TrackNum
1), Bool
True)
        Just TrackInfo
control ->
            (ControlTrack, Bool) -> m (ControlTrack, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackNum -> TrackNum -> ControlTrack
ControlTrack TrackNum
tracknum (TrackInfo -> TrackNum
Ui.track_tracknum TrackInfo
control), Bool
False)
    TrackType
ttype -> Text -> m (ControlTrack, Bool)
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw (Text -> m (ControlTrack, Bool)) -> Text -> m (ControlTrack, Bool)
forall a b. (a -> b) -> a -> b
$ Text
"expected a note track for "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (BlockId, TrackNum) -> Text
forall a. Show a => a -> Text
showt (BlockId
block_id, TrackNum
tracknum) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackType -> Text
forall a. Show a => a -> Text
showt TrackType
ttype
    where
    find :: [TrackInfo] -> Maybe TrackInfo
find = (TrackInfo -> Bool) -> [TrackInfo] -> Maybe TrackInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Text -> Bool
is_control (Text -> Bool) -> (TrackInfo -> Text) -> TrackInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> Text
Ui.track_title)
    tracknum :: TrackNum
tracknum = TrackInfo -> TrackNum
Ui.track_tracknum (Track -> TrackInfo
Info.track_info Track
track)

event_pos_at_or_before :: Cmd.M m => TrackId -> ScoreTime -> m ScoreTime
event_pos_at_or_before :: forall (m :: * -> *). M m => TrackId -> TrackTime -> m TrackTime
event_pos_at_or_before TrackId
track_id TrackTime
pos = do
    ([Event]
_, [Event]
events) <- TrackTime -> Events -> ([Event], [Event])
Events.split_at_before TrackTime
pos (Events -> ([Event], [Event])) -> m Events -> m ([Event], [Event])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackId -> m Events
forall (m :: * -> *). M m => TrackId -> m Events
Ui.get_events TrackId
track_id
    TrackTime -> m TrackTime
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime -> m TrackTime) -> TrackTime -> m TrackTime
forall a b. (a -> b) -> a -> b
$ TrackTime -> (Event -> TrackTime) -> Maybe Event -> TrackTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TrackTime
pos Event -> TrackTime
Event.start ([Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head [Event]
events)

all_keys_up :: Cmd.M m => m Bool
all_keys_up :: forall (m :: * -> *). M m => m Bool
all_keys_up = do
    WriteDeviceState
st <- m WriteDeviceState
forall (m :: * -> *). M m => m WriteDeviceState
Cmd.get_wdev_state
    Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Map NoteId (BlockId, TrackNum) -> Bool
forall k a. Map k a -> Bool
Map.null (WriteDeviceState -> Map NoteId (BlockId, TrackNum)
Cmd.wdev_pitch_track WriteDeviceState
st))

-- | Find the pitch track associated with the given NoteId, if one exists.
find_pitch_track :: Cmd.M m => InputNote.NoteId
    -> m (Maybe (TrackNum, TrackId))
find_pitch_track :: forall (m :: * -> *).
M m =>
NoteId -> m (Maybe (TrackNum, TrackId))
find_pitch_track NoteId
note_id = do
    WriteDeviceState
st <- m WriteDeviceState
forall (m :: * -> *). M m => m WriteDeviceState
Cmd.get_wdev_state
    let maybe_track :: Maybe (BlockId, TrackNum)
maybe_track = NoteId
-> Map NoteId (BlockId, TrackNum) -> Maybe (BlockId, TrackNum)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NoteId
note_id (WriteDeviceState -> Map NoteId (BlockId, TrackNum)
Cmd.wdev_pitch_track WriteDeviceState
st)
    case Maybe (BlockId, TrackNum)
maybe_track of
        Maybe (BlockId, TrackNum)
Nothing -> Maybe (TrackNum, TrackId) -> m (Maybe (TrackNum, TrackId))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TrackNum, TrackId)
forall a. Maybe a
Nothing
        Just (BlockId
block_id, TrackNum
tracknum) -> do
            TrackId
track_id <- BlockId -> TrackNum -> m TrackId
forall (m :: * -> *). M m => BlockId -> TrackNum -> m TrackId
Ui.get_event_track_at BlockId
block_id TrackNum
tracknum
            Maybe (TrackNum, TrackId) -> m (Maybe (TrackNum, TrackId))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (TrackNum, TrackId) -> m (Maybe (TrackNum, TrackId)))
-> Maybe (TrackNum, TrackId) -> m (Maybe (TrackNum, TrackId))
forall a b. (a -> b) -> a -> b
$ (TrackNum, TrackId) -> Maybe (TrackNum, TrackId)
forall a. a -> Maybe a
Just (TrackNum
tracknum, TrackId
track_id)


-- * method edit

-- | Method edit is redirected to the pitch track, creating one if necessary.
cmd_method_edit :: Cmd.M m => Msg.Msg -> m Cmd.Status
cmd_method_edit :: forall (m :: * -> *). M m => Msg -> m Status
cmd_method_edit Msg
msg =
    EditMode -> Text -> m Status -> m Status
forall (m :: * -> *) a. M m => EditMode -> Text -> m a -> m a
Cmd.suppress_history EditMode
Cmd.MethodEdit Text
"note track method edit" (m Status -> m Status) -> m Status -> m Status
forall a b. (a -> b) -> a -> b
$ do
    Fallthrough -> Msg -> m ()
forall (m :: * -> *). M m => Fallthrough -> Msg -> m ()
EditUtil.fallthrough Fallthrough
EditUtil.WantBackspace Msg
msg
    case Msg
msg of
        (Msg -> Maybe Key
EditUtil.method_key -> Just Key
key) -> do
            (BlockId
block_id, TrackNum
tracknum, TrackId
_, TrackTime
pos) <- m (BlockId, TrackNum, TrackId, TrackTime)
forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, TrackTime)
Selection.get_insert
            (ControlTrack
ctrack, Bool
create) <- BlockId -> TrackNum -> (Text -> Bool) -> m (ControlTrack, Bool)
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Text -> Bool) -> m (ControlTrack, Bool)
this_control_track BlockId
block_id TrackNum
tracknum
                Text -> Bool
ParseTitle.is_pitch_track
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
create (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ BlockId -> ControlTrack -> m ()
forall (m :: * -> *). M m => BlockId -> ControlTrack -> m ()
create_pitch_track BlockId
block_id ControlTrack
ctrack
            Pos -> Key -> m ()
forall (m :: * -> *). M m => Pos -> Key -> m ()
PitchTrack.method_edit_at
                (BlockId -> TrackNum -> TrackTime -> TrackTime -> Pos
EditUtil.Pos BlockId
block_id (ControlTrack -> TrackNum
track_control ControlTrack
ctrack) TrackTime
pos TrackTime
0) Key
key
            Pos -> m ()
forall (m :: * -> *). M m => Pos -> m ()
ensure_note_event (BlockId -> TrackNum -> TrackTime -> TrackTime -> Pos
EditUtil.Pos BlockId
block_id (ControlTrack -> TrackNum
track_note ControlTrack
ctrack) TrackTime
pos TrackTime
0)
        Msg
_ -> m ()
forall (m :: * -> *) a. M m => m a
Cmd.abort
    Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done

-- * implementation

-- | Create a pitch track.
create_pitch_track :: Cmd.M m => BlockId -> ControlTrack -> m ()
create_pitch_track :: forall (m :: * -> *). M m => BlockId -> ControlTrack -> m ()
create_pitch_track BlockId
block_id (ControlTrack TrackNum
note TrackNum
pitch) = do
    BlockId -> TrackNum -> Text -> m ()
forall (m :: * -> *). M m => BlockId -> TrackNum -> Text -> m ()
create_track BlockId
block_id TrackNum
pitch Text
"*"
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TrackNum
pitch TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
== TrackNum
note TrackNum -> TrackNum -> TrackNum
forall a. Num a => a -> a -> a
+ TrackNum
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ BlockId -> TrackNum -> TrackNum -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
Ui.merge_track BlockId
block_id TrackNum
note TrackNum
pitch
    ViewId -> m ()
forall (m :: * -> *). M m => ViewId -> m ()
Create.widen (ViewId -> m ()) -> m ViewId -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m ViewId
forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    -- Link note track underneath newly created pitch track.
    m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (BlockId -> m Bool
forall (m :: * -> *). M m => BlockId -> m Bool
Ui.has_explicit_skeleton BlockId
block_id) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        BlockId -> TrackNum -> TrackNum -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
Ui.splice_skeleton_below BlockId
block_id TrackNum
pitch TrackNum
note

create_dyn_track :: Cmd.M m => BlockId -> ControlTrack -> m ()
create_dyn_track :: forall (m :: * -> *). M m => BlockId -> ControlTrack -> m ()
create_dyn_track BlockId
block_id (ControlTrack TrackNum
note TrackNum
dyn) = do
    BlockId -> TrackNum -> Text -> m ()
forall (m :: * -> *). M m => BlockId -> TrackNum -> Text -> m ()
create_track BlockId
block_id TrackNum
dyn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Typed Control -> Text
ParseTitle.control_to_title (Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped Control
Controls.dynamic)
    ViewId -> m ()
forall (m :: * -> *). M m => ViewId -> m ()
Create.widen (ViewId -> m ()) -> m ViewId -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m ViewId
forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (BlockId -> m Bool
forall (m :: * -> *). M m => BlockId -> m Bool
Ui.has_explicit_skeleton BlockId
block_id) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        BlockId -> TrackNum -> TrackNum -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
Ui.splice_skeleton_below BlockId
block_id TrackNum
dyn TrackNum
note

create_track :: Cmd.M m => BlockId -> TrackNum -> Text -> m ()
create_track :: forall (m :: * -> *). M m => BlockId -> TrackNum -> Text -> m ()
create_track BlockId
block_id TrackNum
tracknum Text
title =
    m TrackId -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m TrackId -> m ()) -> m TrackId -> m ()
forall a b. (a -> b) -> a -> b
$ BlockId -> TrackNum -> Text -> Events -> m TrackId
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> Text -> Events -> m TrackId
Create.track BlockId
block_id TrackNum
tracknum Text
title Events
Events.empty

-- | Ensure that a note event exists at the given spot.  An existing event is
-- left alone, but if there is no existing event a new one will be created.
ensure_note_event :: Cmd.M m => EditUtil.Pos -> m ()
ensure_note_event :: forall (m :: * -> *). M m => Pos -> m ()
ensure_note_event Pos
pos = do
    Text
text <- (State -> Text) -> m Text
forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (EditState -> Text
Cmd.state_note_text (EditState -> Text) -> (State -> EditState) -> State -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit)
    Pos -> Bool -> Bool -> Modify -> m ()
forall (m :: * -> *). M m => Pos -> Bool -> Bool -> Modify -> m ()
EditUtil.modify_event_at_trigger Pos
pos Bool
False Bool
False (Modify -> m ()) -> Modify -> m ()
forall a b. (a -> b) -> a -> b
$
        (Maybe Text, Bool) -> (Text -> (Maybe Text, Bool)) -> Modify
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
text, Bool
False) (\Text
old -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
old, Bool
False))

get_state :: Cmd.M m => (Cmd.EditState -> a) -> m a
get_state :: forall (m :: * -> *) a. M m => (EditState -> a) -> m a
get_state EditState -> a
f = (State -> a) -> m a
forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (EditState -> a
f (EditState -> a) -> (State -> EditState) -> State -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit)