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

{- | Master control for playing blocks.

    Here's how it works:

    - Find the relevant block to play.

    - Deriver generates a performable score and an inverse tempo map.

    - The score is preprocessed by adding the current absolute time to it
    and skipping notes based on the start offset.

    - Create a 'Transport.PlayControl' to tell players when to stop, and a
    'Transport.ActivePlayers' to track the number of players still running.
    Start players for each kind of backend: 'Perform.Midi.Play.player_thread'
    for MIDI and im-via-MIDI, one for SC if appropriate, and an audio streaming
    thread if play_im_direct is enabled.

    - The ActivePlayers and tempo map are passed to
    'Cmd.PlayC.play_monitor_thread', which uses the tempo map to display the
    play position in the various blocks.  It stops when it runs out of tempo
    map (which corresponds with running off the end of the score), or when
    the PlayControl goes to Stop.  It's not synchronized to the play threads in
    any way, but of course they are both working from the same score.

    - A stop from the user sets 'Transport.stop_player'.  All the players
    and the play_monitor_thread are polling it and will quit.

    - Another thread is watching the ActivePlayers.  It sent Transport.Playing
    to the responder when they started, and will send Transport.Stopped when
    they go to zero.  This control's the UI's idea of whether it's playing or
    not.  If it's playing, it still has the PlayControl, so it won't accept
    another play, but will accept a stop.  So player threads should only exit
    when there's nothing left for them to cancel, so MIDI and OSC, being
    scheduled in advance, will hang around even after they scheduled their last
    message.  If a player never sends Transport.player_stopped, ActivePlayers
    will never go to 0, and we get stuck.  So they should do the stop in a
    finally block.

    The im backend complicates things a bit.  See NOTE [play-im].

    repeat_at, the play speed multiplier, and the negative start adjustment
    also complicate things.
-}
module Cmd.Play where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified Util.Audio.AudioT as AudioT
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Num as Num
import qualified Util.Vector

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Perf as Perf
import qualified Cmd.PlayUtil as PlayUtil
import qualified Cmd.Selection as Selection
import qualified Cmd.StepPlay as StepPlay
import qualified Cmd.TimeStep as TimeStep

import qualified Derive.Cache as Cache
import qualified Derive.LEvent as LEvent
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack

import qualified Midi.Midi as Midi
import qualified Perform.Im.Play as Im.Play
import qualified Perform.Midi.Patch as Patch
import qualified Perform.RealTime as RealTime
import qualified Perform.Sc.Note as Sc.Note
import qualified Perform.Sc.Play as Sc.Play
import qualified Perform.Transport as Transport

import qualified Synth.Shared.Config as Shared.Config
import qualified Ui.Block as Block
import qualified Ui.Id as Id
import qualified Ui.Sel as Sel
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig
import qualified Ui.Zoom as Zoom

import           Global
import           Types


modify_play_multiplier :: Cmd.M m => (RealTime -> RealTime) -> m ()
modify_play_multiplier :: forall (m :: * -> *). M m => (RealTime -> RealTime) -> m ()
modify_play_multiplier RealTime -> RealTime
f = do
    forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
Cmd.modify_play_state forall a b. (a -> b) -> a -> b
$ \PlayState
st -> PlayState
st
        { state_play_multiplier :: RealTime
Cmd.state_play_multiplier = RealTime -> RealTime
to_1 forall a b. (a -> b) -> a -> b
$ RealTime -> RealTime
f (PlayState -> RealTime
Cmd.state_play_multiplier PlayState
st) }
    -- A change in state_play_multiplier is not damage for MIDI because it only
    -- affects playback, but it is damage for im, which needs to rerender
    -- audio.  Since there is no change to Ui.State, I have to force a rederive
    -- here.
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall (m :: * -> *). M m => m Bool
has_im forall (m :: * -> *). M m => m ()
Cmd.invalidate_performances
    where
    -- Set to 1 if I'm this close.  Otherwise repeated multiplies don't
    -- necessarily come back exactly.
    to_1 :: RealTime -> RealTime
to_1 RealTime
val
        | forall a. Num a => a -> a
abs (RealTime
1 forall a. Num a => a -> a -> a
- RealTime
val) forall a. Ord a => a -> a -> Bool
<= RealTime
threshold = RealTime
1
        | Bool
otherwise = RealTime
val
    threshold :: RealTime
threshold = RealTime
0.01

-- * stop

-- | Context sensitive stop that stops whatever is going on.  First it stops
-- realtime play, then step play, and then it just sends all notes off.  If
-- it does the last one, it returns False in case you want to go stop something
-- else.
cmd_context_stop :: Cmd.CmdT IO Bool
cmd_context_stop :: CmdT IO Bool
cmd_context_stop = forall (m :: * -> *) a. M m => (PlayState -> a) -> m a
gets PlayState -> [PlayControl]
Cmd.state_play_control forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> do
        Bool
step_playing <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$
            forall a. Maybe a -> Bool
Maybe.isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayState -> Maybe StepState
Cmd.state_step forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
Cmd.state_play
        if Bool
step_playing
            then forall (m :: * -> *). M m => m ()
StepPlay.cmd_clear forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            -- play_cache may still be streaming after the karya transport
            -- stops.
            else do
                forall (m :: * -> *). M m => m ()
Cmd.all_notes_off
                CmdT IO ()
stop_im
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
Sc.Play.force_stop
                forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    [PlayControl]
ctls -> [PlayControl] -> CmdT IO ()
stop [PlayControl]
ctls forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

cmd_stop :: Cmd.CmdT IO Cmd.Status
cmd_stop :: CmdT IO Status
cmd_stop = do
    [PlayControl] -> CmdT IO ()
stop forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (PlayState -> a) -> m a
gets PlayState -> [PlayControl]
Cmd.state_play_control
    forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done

stop :: [Transport.PlayControl] -> Cmd.CmdT IO ()
stop :: [PlayControl] -> CmdT IO ()
stop [PlayControl]
ctls = do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PlayControl -> IO ()
Transport.stop_player [PlayControl]
ctls
    CmdT IO ()
stop_im

-- | Stop im stream, if playing.  See NOTE [play-im].
stop_im :: Cmd.CmdT IO ()
stop_im :: CmdT IO ()
stop_im = forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM forall (m :: * -> *). M m => m (Maybe Addr)
im_addr forall a b. (a -> b) -> a -> b
$ \(WriteDevice
wdev, Channel
chan) ->
    forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi WriteDevice
wdev forall a b. (a -> b) -> a -> b
$ Channel -> ChannelMessage -> Message
Midi.ChannelMessage Channel
chan ChannelMessage
Im.Play.stop

im_addr :: Cmd.M m => m (Maybe Patch.Addr)
im_addr :: forall (m :: * -> *). M m => m (Maybe Addr)
im_addr = do
    Map Instrument Allocation
allocs <- Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Config (Map Instrument Allocation)
UiConfig.allocations_map forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Map Instrument Allocation
-> Either (Maybe Text) (Set Instrument, Maybe Addr)
lookup_im_config Map Instrument Allocation
allocs of
        Right (Set Instrument
_, Just Addr
addr) -> forall a. a -> Maybe a
Just Addr
addr
        Either (Maybe Text) (Set Instrument, Maybe Addr)
_ -> forall a. Maybe a
Nothing

has_im :: Cmd.M m => m Bool
has_im :: forall (m :: * -> *). M m => m Bool
has_im = forall a. Maybe a -> Bool
Maybe.isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m (Maybe Addr)
im_addr

-- * play

set_previous_play :: Cmd.M m => Text -> Cmd.CmdId Cmd.PlayArgs -> m ()
set_previous_play :: forall (m :: * -> *). M m => Text -> CmdId PlayArgs -> m ()
set_previous_play Text
name CmdId PlayArgs
cmd = forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
Cmd.modify_play_state forall a b. (a -> b) -> a -> b
$ \PlayState
st ->
    PlayState
st { state_previous_play :: Maybe PlayCmd
Cmd.state_previous_play = forall a. a -> Maybe a
Just (Text -> CmdId PlayArgs -> PlayCmd
Cmd.PlayCmd Text
name CmdId PlayArgs
cmd) }

-- | Play the local block from its beginning.
local_block :: Cmd.M m => m Cmd.PlayArgs
local_block :: forall (m :: * -> *). M m => m PlayArgs
local_block = do
    BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    forall (m :: * -> *).
M m =>
BlockId
-> Maybe TrackId -> ScoreTime -> Maybe ScoreTime -> m PlayArgs
from_score BlockId
block_id forall a. Maybe a
Nothing ScoreTime
0 forall a. Maybe a
Nothing

-- | Start playing from the point selection on the local block.  If the
-- selection is a range, loop that range forever.
local_selection :: Cmd.M m => m Cmd.PlayArgs
local_selection :: forall (m :: * -> *). M m => m PlayArgs
local_selection = do
    (BlockId
block_id, TrackNum
_, TrackId
track_id, ScoreTime
_) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, ScoreTime)
Selection.get_insert
    Selection
sel <- forall (m :: * -> *). M m => m Selection
Selection.get
    let (ScoreTime
pos, Maybe ScoreTime
repeat_at) = if Selection -> Bool
Sel.is_point Selection
sel
            then (Selection -> ScoreTime
Sel.start_pos Selection
sel, forall a. Maybe a
Nothing)
            else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Selection -> (ScoreTime, ScoreTime)
Sel.range Selection
sel
    forall (m :: * -> *).
M m =>
BlockId
-> Maybe TrackId -> ScoreTime -> Maybe ScoreTime -> m PlayArgs
from_score BlockId
block_id (forall a. a -> Maybe a
Just TrackId
track_id) ScoreTime
pos Maybe ScoreTime
repeat_at

-- | Play the current block's performance from the previous
-- 'Cmd.state_play_step'.
local_previous :: Cmd.M m => m Cmd.PlayArgs
local_previous :: forall (m :: * -> *). M m => m PlayArgs
local_previous = do
    TimeStep
step <- forall (m :: * -> *) a. M m => (PlayState -> a) -> m a
gets PlayState -> TimeStep
Cmd.state_play_step
    (BlockId
block_id, TrackNum
tracknum, TrackId
track_id, ScoreTime
pos) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, ScoreTime)
Selection.get_insert
    Maybe ScoreTime
prev <- forall (m :: * -> *).
M m =>
TimeStep -> BlockId -> TrackNum -> ScoreTime -> m (Maybe ScoreTime)
TimeStep.rewind TimeStep
step BlockId
block_id TrackNum
tracknum ScoreTime
pos
    forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m PlayArgs
local_from BlockId
block_id TrackId
track_id (forall a. a -> Maybe a -> a
fromMaybe ScoreTime
0 Maybe ScoreTime
prev)

-- | Play the current block's performance from the top of the window.
local_top :: Cmd.M m => m Cmd.PlayArgs
local_top :: forall (m :: * -> *). M m => m PlayArgs
local_top = do
    (BlockId
block_id, TrackId
track_id, ScoreTime
top) <- forall (m :: * -> *). M m => m (BlockId, TrackId, ScoreTime)
top_of_block
    forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m PlayArgs
local_from BlockId
block_id TrackId
track_id ScoreTime
top

local_from :: Cmd.M m => BlockId -> TrackId -> TrackTime -> m Cmd.PlayArgs
local_from :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m PlayArgs
local_from BlockId
block_id TrackId
track_id ScoreTime
pos =
    forall (m :: * -> *).
M m =>
BlockId
-> Maybe TrackId -> ScoreTime -> Maybe ScoreTime -> m PlayArgs
from_score BlockId
block_id (forall a. a -> Maybe a
Just TrackId
track_id) ScoreTime
pos forall a. Maybe a
Nothing

-- | Play the root block from its beginning.
root_block :: Cmd.M m => m Cmd.PlayArgs
root_block :: forall (m :: * -> *). M m => m PlayArgs
root_block = do
    forall (m :: * -> *). M m => m (Maybe BlockId)
Ui.lookup_root_id forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe BlockId
Nothing -> forall (m :: * -> *). M m => m PlayArgs
local_block
        Just BlockId
root_id -> forall (m :: * -> *).
M m =>
BlockId
-> Maybe TrackId -> ScoreTime -> Maybe ScoreTime -> m PlayArgs
from_score BlockId
root_id forall a. Maybe a
Nothing ScoreTime
0 forall a. Maybe a
Nothing

-- | Play the root performance from the selection on the root block.  This
-- is useful to manually set a point to start playing.
root_from_root_selection :: Cmd.M m => m Cmd.PlayArgs
root_from_root_selection :: forall (m :: * -> *). M m => m PlayArgs
root_from_root_selection = do
    (BlockId
block_id, TrackNum
_, TrackId
track_id, ScoreTime
pos) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, ScoreTime)
Selection.get_root_insert
    forall (m :: * -> *).
M m =>
BlockId
-> Maybe TrackId -> ScoreTime -> Maybe ScoreTime -> m PlayArgs
from_score BlockId
block_id (forall a. a -> Maybe a
Just TrackId
track_id) ScoreTime
pos forall a. Maybe a
Nothing

-- | The same as 'local_selection', but use the root performance.
root_selection :: Cmd.M m => m Cmd.PlayArgs
root_selection :: forall (m :: * -> *). M m => m PlayArgs
root_selection = do
    (BlockId
block_id, TrackNum
_, TrackId
track_id, ScoreTime
_) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, ScoreTime)
Selection.get_insert
    Selection
sel <- forall (m :: * -> *). M m => m Selection
Selection.get
    let (ScoreTime
pos, Maybe ScoreTime
repeat_at)
            | Selection -> Bool
Sel.is_point Selection
sel = (Selection -> ScoreTime
Sel.start_pos Selection
sel, forall a. Maybe a
Nothing)
            | Bool
otherwise = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Selection -> (ScoreTime, ScoreTime)
Sel.range Selection
sel
    forall (m :: * -> *). M m => m (Maybe BlockId)
Ui.lookup_root_id forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe BlockId
Nothing -> forall (m :: * -> *). M m => m PlayArgs
local_selection
        Just BlockId
root_id -> do
            Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
get_performance BlockId
root_id
            let realtime_at :: ScoreTime -> m (Maybe RealTime)
realtime_at = forall (m :: * -> *).
M m =>
Performance
-> BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
Perf.lookup_realtime Performance
perf BlockId
block_id (forall a. a -> Maybe a
Just TrackId
track_id)
            Maybe RealTime
real_repeat_at <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) ScoreTime -> m (Maybe RealTime)
realtime_at Maybe ScoreTime
repeat_at
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). M m => m PlayArgs
local_selection (forall (m :: * -> *).
M m =>
BlockId -> Maybe RealTime -> RealTime -> m PlayArgs
from_realtime BlockId
root_id Maybe RealTime
real_repeat_at)
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScoreTime -> m (Maybe RealTime)
realtime_at ScoreTime
pos

-- | Find the previous step on the focused block, get its RealTime, and play
-- from the root at that RealTime.  If this block isn't linked from the root,
-- then fall back on 'local_previous'.
root_previous :: Cmd.M m => m Cmd.PlayArgs
root_previous :: forall (m :: * -> *). M m => m PlayArgs
root_previous = do
    (BlockId
block_id, TrackNum
tracknum, TrackId
track_id, ScoreTime
pos) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, ScoreTime)
Selection.get_insert
    TimeStep
step <- forall (m :: * -> *) a. M m => (PlayState -> a) -> m a
gets PlayState -> TimeStep
Cmd.state_play_step
    ScoreTime
prev <- forall a. a -> Maybe a -> a
fromMaybe ScoreTime
pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
TimeStep -> BlockId -> TrackNum -> ScoreTime -> m (Maybe ScoreTime)
TimeStep.rewind TimeStep
step BlockId
block_id TrackNum
tracknum ScoreTime
pos
    forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m PlayArgs
root_from BlockId
block_id TrackId
track_id ScoreTime
prev

-- | Like 'root_previous', but play from the top of the selected block.
root_top :: Cmd.M m => m Cmd.PlayArgs
root_top :: forall (m :: * -> *). M m => m PlayArgs
root_top = do
    (BlockId
block_id, TrackId
track_id, ScoreTime
top) <- forall (m :: * -> *). M m => m (BlockId, TrackId, ScoreTime)
top_of_block
    forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m PlayArgs
root_from BlockId
block_id TrackId
track_id ScoreTime
top

top_of_block :: Cmd.M m => m (BlockId, TrackId, TrackTime)
top_of_block :: forall (m :: * -> *). M m => m (BlockId, TrackId, ScoreTime)
top_of_block = do
    (BlockId
block_id, TrackNum
_, TrackId
track_id, ScoreTime
_) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, ScoreTime)
Selection.get_insert
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    ScoreTime
top <- Zoom -> ScoreTime
Zoom.offset forall b c a. (b -> c) -> (a -> b) -> a -> c
. View -> Zoom
Block.view_zoom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
    forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, TrackId
track_id, ScoreTime
top)

root_from :: Cmd.M m => BlockId -> TrackId -> TrackTime -> m Cmd.PlayArgs
root_from :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m PlayArgs
root_from BlockId
block_id TrackId
track_id ScoreTime
pos = do
    Maybe PlayArgs
play_root <- forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m (Maybe PlayArgs)
maybe_root_from BlockId
block_id TrackId
track_id ScoreTime
pos
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m PlayArgs
local_from BlockId
block_id TrackId
track_id ScoreTime
pos) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PlayArgs
play_root

maybe_root_from :: Cmd.M m => BlockId -> TrackId -> ScoreTime
    -> m (Maybe Cmd.PlayArgs)
maybe_root_from :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m (Maybe PlayArgs)
maybe_root_from BlockId
block_id TrackId
track_id ScoreTime
pos =
    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 -> do
        Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
get_performance BlockId
root_id
        forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *).
M m =>
Performance
-> BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
Perf.lookup_realtime Performance
perf BlockId
block_id (forall a. a -> Maybe a
Just TrackId
track_id) ScoreTime
pos) forall a b. (a -> b) -> a -> b
$
            \RealTime
start -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
BlockId -> Maybe RealTime -> RealTime -> m PlayArgs
from_realtime BlockId
root_id forall a. Maybe a
Nothing RealTime
start

from_score :: Cmd.M m => BlockId
    -> Maybe TrackId -- ^ Track to play from.  Since different tracks can have
    -- different tempos, a track is needed to convert to RealTime.  If not
    -- given, use the first track that has tempo information.
    -> ScoreTime -- ^ Convert to RealTime and start playing from this time.
    -> Maybe ScoreTime
    -> m Cmd.PlayArgs
from_score :: forall (m :: * -> *).
M m =>
BlockId
-> Maybe TrackId -> ScoreTime -> Maybe ScoreTime -> m PlayArgs
from_score BlockId
block_id Maybe TrackId
start_track ScoreTime
start_pos Maybe ScoreTime
repeat_at = do
    RealTime
start <- forall (m :: * -> *).
M m =>
BlockId -> BlockId -> Maybe TrackId -> ScoreTime -> m RealTime
get_realtime BlockId
block_id BlockId
block_id Maybe TrackId
start_track ScoreTime
start_pos
    Maybe RealTime
repeat_at <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
M m =>
BlockId -> BlockId -> Maybe TrackId -> ScoreTime -> m RealTime
get_realtime BlockId
block_id BlockId
block_id Maybe TrackId
start_track) Maybe ScoreTime
repeat_at
    forall (m :: * -> *).
M m =>
BlockId -> Maybe RealTime -> RealTime -> m PlayArgs
from_realtime BlockId
block_id Maybe RealTime
repeat_at RealTime
start

get_realtime :: Cmd.M m => BlockId
    -- ^ Lookup realtime according to the performance of this block.
    -> BlockId
    -- ^ Lookup realtime at the position (TrackId, ScoreTime) within this block.
    -> Maybe TrackId -> ScoreTime
    -> m RealTime
get_realtime :: forall (m :: * -> *).
M m =>
BlockId -> BlockId -> Maybe TrackId -> ScoreTime -> m RealTime
get_realtime BlockId
perf_block BlockId
play_block Maybe TrackId
maybe_track_id ScoreTime
pos = do
    Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
get_performance BlockId
perf_block
    Maybe RealTime
maybe_start <- forall (m :: * -> *).
M m =>
Performance
-> BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
Perf.lookup_realtime Performance
perf BlockId
play_block Maybe TrackId
maybe_track_id ScoreTime
pos
    case Maybe RealTime
maybe_start of
        Maybe RealTime
Nothing -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
"play " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt BlockId
perf_block
            forall a. Semigroup a => a -> a -> a
<> Text
" has no tempo information"
        Just RealTime
start -> forall (m :: * -> *) a. Monad m => a -> m a
return RealTime
start

get_performance :: Cmd.M m => BlockId -> m Cmd.Performance
get_performance :: forall (m :: * -> *). M m => BlockId -> m Performance
get_performance BlockId
block_id = do
    Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
Perf.get_current BlockId
block_id
    forall (m :: * -> *). M m => BlockId -> Performance -> m ()
write_logs BlockId
block_id Performance
perf
    forall (m :: * -> *) a. Monad m => a -> m a
return Performance
perf

write_logs :: Cmd.M m => BlockId -> Cmd.Performance -> m ()
write_logs :: forall (m :: * -> *). M m => BlockId -> Performance -> m ()
write_logs BlockId
block_id Performance
perf = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Performance -> Bool
Cmd.perf_logs_written Performance
perf) forall a b. (a -> b) -> a -> b
$ do
    -- There are so many cache msgs it clogs up logview.  I'm writing a summary
    -- anyway so I can filter them out.
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Bool
Cache.is_cache_log) (Performance -> [Msg]
Cmd.perf_logs Performance
perf)
    -- Logview can only display one set of stats, so only show the root block.
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just BlockId
block_id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m (Maybe BlockId)
Ui.lookup_root_id) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => [Msg] -> m ()
record_cache_stats (Performance -> [Msg]
Cmd.perf_logs Performance
perf)
    forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
Cmd.modify_play_state forall a b. (a -> b) -> a -> b
$ \PlayState
st -> PlayState
st
        { state_current_performance :: Map BlockId Performance
Cmd.state_current_performance = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BlockId
block_id
            (Performance
perf { perf_logs_written :: Bool
Cmd.perf_logs_written = Bool
True })
            (PlayState -> Map BlockId Performance
Cmd.state_current_performance PlayState
st)
        }

-- | Summarize the cache stats and emit them as global status msgs.
--
-- The output looks like
--
-- > ~C: [34 / 6742] bid bid bid... || ~X control damage: [104] bid bid ... ||
-- > ~X trock block damage: [1] bid
--
-- This means that 34 blocks were cached, totally 6742 events.  104 blocks
-- were not cached due to control damage, and 1 more due to track block damage.
-- The reasons are from 'Derive.Cache.find_generator_cache'.  They keys are
-- prefixed with a tilde to make them sort last in the logview status line.
--
-- 'Cmd.Repl.LPerf.cache_stats' gives a more complete summary.
record_cache_stats :: Cmd.M m => [Log.Msg] -> m ()
record_cache_stats :: forall (m :: * -> *). M m => [Msg] -> m ()
record_cache_stats [Msg]
logs = do
    let ([(Text, [BlockId])]
rederived, [(BlockId, TrackNum)]
cached) = forall k.
(Msg -> Maybe k) -> [Msg] -> ([(Text, [k])], [(k, TrackNum)])
extract_cache_stats Msg -> Maybe BlockId
get_block_id [Msg]
logs
    forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"~C" forall a b. (a -> b) -> a -> b
$ Text
"[" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [(BlockId, TrackNum)]
cached) forall a. Semigroup a => a -> a -> a
<> Text
" / "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(BlockId, TrackNum)]
cached)) forall a. Semigroup a => a -> a -> a
<> Text
"] "
        forall a. Semigroup a => a -> a -> a
<> Text -> Text
elide ([Text] -> Text
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ident a => a -> Text
Id.ident_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(BlockId, TrackNum)]
cached))
    Set Text
status_keys <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map Text Text
Cmd.state_global_status)
    let keys :: [Text]
keys = forall a b. (a -> b) -> [a] -> [b]
map ((Text
"~X "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, [BlockId])]
rederived
        gone :: Set Text
gone = forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Text
"~X " `Text.isPrefixOf`) forall a b. (a -> b) -> a -> b
$
            Set Text
status_keys forall a. Ord a => Set a -> Set a -> Set a
Set.\\ forall a. Ord a => [a] -> Set a
Set.fromList [Text]
keys
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
keys (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Text, [BlockId])]
rederived)) forall a b. (a -> b) -> a -> b
$ \(Text
key, [BlockId]
block_ids) ->
        forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
key forall a b. (a -> b) -> a -> b
$ Text
"[" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [BlockId]
block_ids) forall a. Semigroup a => a -> a -> a
<> Text
"] "
            forall a. Semigroup a => a -> a -> a
<> Text -> Text
elide ([Text] -> Text
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. Ident a => a -> Text
Id.ident_name [BlockId]
block_ids))
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Set a -> [a]
Set.toList Set Text
gone) forall a b. (a -> b) -> a -> b
$ \Text
key -> forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
key Text
""
    where
    max_chars :: TrackNum
max_chars = TrackNum
45
    elide :: Text -> Text
elide Text
s
        | Text -> TrackNum
Text.length Text
s forall a. Ord a => a -> a -> Bool
> TrackNum
max_chars = TrackNum -> Text -> Text
Text.take (TrackNum
max_charsforall a. Num a => a -> a -> a
-TrackNum
3) Text
s forall a. Semigroup a => a -> a -> a
<> Text
"..."
        | Bool
otherwise = Text
s

extract_cache_stats :: (Log.Msg -> Maybe k) -> [Log.Msg]
    -> ([(Text, [k])], [(k, Int)])
    -- ^ (cache misses, cache hits):
    -- ([(because, [key])], [(key, cached_vals)])
extract_cache_stats :: forall k.
(Msg -> Maybe k) -> [Msg] -> ([(Text, [k])], [(k, TrackNum)])
extract_cache_stats Msg -> Maybe k
key [Msg]
logs = ([(Text, [k])]
rederived, [(k, TrackNum)]
cached)
    where
    -- [("because xyz", [bid, bid, bid, ...])]
    rederived :: [(Text, [k])]
rederived = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst)) forall a b. (a -> b) -> a -> b
$ forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort forall a b. (a, b) -> b
snd
        [(k
block_id, Text
because) | (k
block_id, Left Text
because) <- [(k, Either Text TrackNum)]
stats]
    -- [(bid1, 42), (bid2, 32), ...]
    cached :: [(k, TrackNum)]
cached = [(k
block_id, TrackNum
vals) | (k
block_id, Right TrackNum
vals) <- [(k, Either Text TrackNum)]
stats]
    stats :: [(k, Either Text TrackNum)]
stats = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Msg -> Maybe (k, Either Text TrackNum)
extract [Msg]
logs
    extract :: Msg -> Maybe (k, Either Text TrackNum)
extract Msg
log = case Msg -> Maybe k
key Msg
log of
        Maybe k
Nothing -> forall a. Maybe a
Nothing
        Just k
block_id
            | Just Text
because <- Msg -> Maybe Text
Cache.cache_miss_reason Msg
log ->
                forall a. a -> Maybe a
Just (k
block_id, forall a b. a -> Either a b
Left Text
because)
            | Just TrackNum
vals <- Msg -> Maybe TrackNum
Cache.cache_hit_events Msg
log ->
                forall a. a -> Maybe a
Just (k
block_id, forall a b. b -> Either a b
Right TrackNum
vals)
            | Bool
otherwise -> forall a. Maybe a
Nothing

-- | Get block cache stats.
get_block_id :: Log.Msg -> Maybe BlockId
get_block_id :: Msg -> Maybe BlockId
get_block_id = Frame -> Maybe BlockId
Stack.block_of forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
Stack.innermost forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Msg -> Maybe Stack
Log.msg_stack

-- | Get track cache stats.
get_track_id :: Log.Msg -> Maybe (BlockId, TrackId)
get_track_id :: Msg -> Maybe (BlockId, TrackId)
get_track_id = Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Msg -> Maybe Stack
Log.msg_stack

-- | Play the performance of the given block starting from the given time.
from_realtime :: Cmd.M m => BlockId -> Maybe RealTime -> RealTime
    -> m Cmd.PlayArgs
from_realtime :: forall (m :: * -> *).
M m =>
BlockId -> Maybe RealTime -> RealTime -> m PlayArgs
from_realtime BlockId
block_id Maybe RealTime
repeat_at RealTime
start_ = do
    -- Since 0 is considered "the beginning", even if that happens to be before
    -- 0, there's no point asking for something before 0, and will just cause
    -- play to seem to wedge for a moment.  'PlayUtil.perform_from' has
    -- a special hack to notice and include notes < 0.
    let start :: RealTime
start = forall a. Ord a => a -> a -> a
max RealTime
0 RealTime
start_
    Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
Perf.get_current BlockId
block_id
    RealTime
multiplier <- forall (m :: * -> *) a. M m => (PlayState -> a) -> m a
gets (forall a. Fractional a => a -> a
recip forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayState -> RealTime
Cmd.state_play_multiplier)

    Maybe SyncConfig
maybe_sync <- forall (m :: * -> *) a. M m => (PlayState -> a) -> m a
gets PlayState -> Maybe SyncConfig
Cmd.state_sync
    case Maybe SyncConfig
maybe_sync of
        -- Don't bother with a MMC Goto if I'm going to send MTC.
        Just SyncConfig
sync | Bool -> Bool
not (SyncConfig -> Bool
Cmd.sync_mtc SyncConfig
sync) ->
            forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi (SyncConfig -> WriteDevice
Cmd.sync_device SyncConfig
sync) forall a b. (a -> b) -> a -> b
$ SyncConfig -> RealTime -> Message
Selection.mmc_goto SyncConfig
sync RealTime
start
        Maybe SyncConfig
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    -- MTC rounds up to the previous whole frame, so the mtc might start
    -- slightly before the notes.
    -- TODO actually DAWs need a bit of time to sync, so maybe I should start
    -- further in advance.
    let mtc :: MidiEvents
mtc = RealTime -> RealTime -> MidiEvents -> MidiEvents
PlayUtil.shift_midi RealTime
1 RealTime
start forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event forall a b. (a -> b) -> a -> b
$
            Maybe SyncConfig -> RealTime -> [WriteMessage]
generate_mtc Maybe SyncConfig
maybe_sync RealTime
start

    Map Instrument Allocation
allocs <- Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Config (Map Instrument Allocation)
UiConfig.allocations_map forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    Bool
im_play_direct <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ Config -> Bool
Cmd.config_im_play_direct forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Cmd.state_config
    (Set Instrument
im_insts, Maybe Addr
mb_play_cache_addr) <- case Map Instrument Allocation
-> Either (Maybe Text) (Set Instrument, Maybe Addr)
lookup_im_config Map Instrument Allocation
allocs of
        Right (Set Instrument
im_insts, Maybe Addr
_) | Bool
im_play_direct -> forall (m :: * -> *) a. Monad m => a -> m a
return (Set Instrument
im_insts, forall a. Maybe a
Nothing)
        Right (Set Instrument
im_insts, Just Addr
play_cache_addr) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (Set Instrument
im_insts, forall a. a -> Maybe a
Just Addr
play_cache_addr)
        Right (Set Instrument
_, Maybe Addr
Nothing) -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw
            Text
"im allocations but no play-cache alloc, so they\
            \ won't play, allocate with LInst.add_play_cache,\
            \ or set Cmd.config_im_play_direct"
        Left Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, forall a. Maybe a
Nothing)
        Left (Just Text
msg) -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw Text
msg
    Set Instrument
muted <- forall (m :: * -> *). M m => BlockId -> m (Set Instrument)
Perf.muted_im_instruments BlockId
block_id
    FilePath
score_path <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> FilePath
Cmd.score_path
    let im_msgs :: MidiEvents
im_msgs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
            (FilePath
-> BlockId -> Set Instrument -> RealTime -> Addr -> MidiEvents
im_play_msgs FilePath
score_path BlockId
block_id Set Instrument
muted (RealTime
start forall a. Num a => a -> a -> a
* RealTime
multiplier))
            Maybe Addr
mb_play_cache_addr

    (MidiEvents
midi_msgs, Notes
sc_msgs) <- forall (m :: * -> *).
M m =>
RealTime -> Vector Event -> m (MidiEvents, Notes)
PlayUtil.perform_from RealTime
start (Performance -> Vector Event
Cmd.perf_events Performance
perf)
    let adjust0 :: RealTime
adjust0 = RealTime -> Bool -> MidiEvents -> Vector Event -> RealTime
get_adjust0 RealTime
start (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null MidiEvents
im_msgs)) MidiEvents
midi_msgs
            (Performance -> Vector Event
Cmd.perf_events Performance
perf)
    MidiEvents
midi_msgs <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> RealTime -> MidiEvents -> MidiEvents
PlayUtil.shift_midi RealTime
multiplier RealTime
adjust0 MidiEvents
midi_msgs

    -- See doc for "Cmd.PlayC" for why I return a magic value.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Cmd.PlayArgs
        { play_sync :: Maybe SyncConfig
play_sync = Maybe SyncConfig
maybe_sync
        , play_name :: Text
play_name = forall a. Pretty a => a -> Text
pretty BlockId
block_id
        , play_midi :: MidiEvents
play_midi = MidiEvents
im_msgs forall a. [a] -> [a] -> [a]
++ MidiEvents -> MidiEvents -> MidiEvents
merge_midi MidiEvents
midi_msgs MidiEvents
mtc
        , play_sc :: PlayNotes
play_sc = Sc.Note.PlayNotes
            { shift :: RealTime
shift = RealTime
adjust0, stretch :: RealTime
stretch = RealTime
multiplier, notes :: Notes
notes = Notes
sc_msgs }
        , play_inv_tempo :: Maybe InverseTempoFunction
play_inv_tempo = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \Stop
stop ->
            Performance -> InverseTempoFunction
Cmd.perf_inv_tempo Performance
perf Stop
stop forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+RealTime
adjust0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/RealTime
multiplier)
        , play_repeat_at :: Maybe RealTime
play_repeat_at = (forall a. Num a => a -> a -> a
*RealTime
multiplier) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract RealTime
start forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RealTime
repeat_at
        , play_im_end :: Maybe RealTime
play_im_end = if forall a. Set a -> Bool
Set.null Set Instrument
im_insts then forall a. Maybe a
Nothing
            else forall a. Num a => a -> a -> a
subtract RealTime
adjust0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_end forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (v :: * -> *) a. Vector v a => (a -> Bool) -> v a -> Maybe a
Util.Vector.find_end
                ((forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Instrument
im_insts) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument)
                (Performance -> Vector Event
Cmd.perf_events Performance
perf)
        , play_im_direct :: Maybe PlayDirectArgs
play_im_direct = if forall a. Set a -> Bool
Set.null Set Instrument
im_insts Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
im_play_direct
            then forall a. Maybe a
Nothing
            else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Cmd.PlayDirectArgs
                { play_score_path :: FilePath
play_score_path = FilePath
score_path
                , play_block_id :: BlockId
play_block_id = BlockId
block_id
                , play_muted :: Set Instrument
play_muted = Set Instrument
muted
                , play_start :: RealTime
play_start = RealTime
start forall a. Num a => a -> a -> a
* RealTime
multiplier
                }
        }

get_adjust0 :: RealTime -> Bool -> [LEvent.LEvent Midi.WriteMessage]
    -> Vector.Vector Score.Event -> RealTime
get_adjust0 :: RealTime -> Bool -> MidiEvents -> Vector Event -> RealTime
get_adjust0 RealTime
start Bool
has_im MidiEvents
midi_msgs Vector Event
events = RealTime
negative_start forall a. Num a => a -> a -> a
- RealTime
im_latency
    where
    -- Events can wind up before 0, say if there's a grace note on a note at 0.
    -- To have them play correctly, perform_from will give me negative events
    -- when starting from 0, and then I have to shift the start time back to
    -- consider the first event the new 0.
    negative_start :: RealTime
negative_start
        | RealTime
start forall a. Eq a => a -> a -> Bool
== RealTime
0 Bool -> Bool -> Bool
&& RealTime
fst_msg forall a. Ord a => a -> a -> Bool
< RealTime
0 = RealTime
fst_msg
        | Bool
otherwise = RealTime
start
    -- The first MIDI msg will incorporate any possible leading controls.
    -- The first Score.Event should be after that, unless there's an im
    -- event at negative time.
    fst_msg :: RealTime
fst_msg = forall a. Ord a => a -> a -> a
min RealTime
first_score (MidiEvents -> RealTime
PlayUtil.first_time MidiEvents
midi_msgs)
    first_score :: RealTime
first_score = forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
0 Event -> RealTime
Score.event_start forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.head forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
Vector.toList forall a b. (a -> b) -> a -> b
$
        forall a. TrackNum -> Vector a -> Vector a
Vector.take TrackNum
1 Vector Event
events
    im_latency :: RealTime
im_latency = if Bool
has_im
        then Frames -> RealTime
toSeconds Frames
Shared.Config.startLatency else RealTime
0
    -- This duplicates AUtil.toSeconds, but AUtil winds up importing
    -- Audio.Audio, and hence VectorC, which incurs a dep on vector.cc.o.
    toSeconds :: Frames -> RealTime
toSeconds = Double -> RealTime
RealTime.seconds
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackNum -> Frames -> Double
AudioT.framesToSeconds TrackNum
Shared.Config.samplingRate

lookup_im_config :: Map ScoreT.Instrument UiConfig.Allocation
    -> Either (Maybe Text) (Set ScoreT.Instrument, Maybe Patch.Addr)
lookup_im_config :: Map Instrument Allocation
-> Either (Maybe Text) (Set Instrument, Maybe Addr)
lookup_im_config Map Instrument Allocation
allocs = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Set a -> Bool
Set.null Set Instrument
im_insts) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a. Maybe a
Nothing
    case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find Allocation -> Bool
is_play_cache (forall k a. Map k a -> [a]
Map.elems Map Instrument Allocation
allocs) of
        Maybe Allocation
Nothing -> forall a b. b -> Either a b
Right (Set Instrument
im_insts, forall a. Maybe a
Nothing)
        Just Allocation
alloc -> case Allocation -> Backend
UiConfig.alloc_backend Allocation
alloc of
            UiConfig.Midi Config
config -> case Config -> [Addr]
Patch.config_addrs Config
config of
                [Addr
addr] -> forall (m :: * -> *) a. Monad m => a -> m a
return (Set Instrument
im_insts, forall a. a -> Maybe a
Just Addr
addr)
                [] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                    forall a. Pretty a => a -> Text
pretty Qualified
UiConfig.play_cache forall a. Semigroup a => a -> a -> a
<> Text
" allocation with no addrs"
                [Addr]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                    forall a. Pretty a => a -> Text
pretty Qualified
UiConfig.play_cache forall a. Semigroup a => a -> a -> a
<> Text
" allocation with >1 addrs"
            Backend
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                forall a. Pretty a => a -> Text
pretty Qualified
UiConfig.play_cache forall a. Semigroup a => a -> a -> a
<> Text
" with non-MIDI allocation"
    where
    is_play_cache :: Allocation -> Bool
is_play_cache = (forall a. Eq a => a -> a -> Bool
==Qualified
UiConfig.play_cache) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> Qualified
UiConfig.alloc_qualified
    im_insts :: Set Instrument
im_insts = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter (Allocation -> Bool
UiConfig.is_im_allocation 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 k a. Map k a -> [(k, a)]
Map.toList Map Instrument Allocation
allocs

im_play_msgs :: FilePath -> BlockId -> Set ScoreT.Instrument -> RealTime
    -> Patch.Addr -> [LEvent.LEvent Midi.WriteMessage]
im_play_msgs :: FilePath
-> BlockId -> Set Instrument -> RealTime -> Addr -> MidiEvents
im_play_msgs FilePath
score_path BlockId
block_id Set Instrument
muted RealTime
start (WriteDevice
wdev, Channel
chan) =
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith RealTime -> ChannelMessage -> LEvent WriteMessage
msg [RealTime]
ts forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ RealTime -> [ChannelMessage]
Im.Play.encode_time RealTime
start
        , FilePath -> BlockId -> Set Instrument -> [ChannelMessage]
Im.Play.encode_play_config FilePath
score_path BlockId
block_id Set Instrument
muted
        , [ChannelMessage
Im.Play.start]
        ]
    where
    msg :: RealTime -> ChannelMessage -> LEvent WriteMessage
msg RealTime
t = forall a. a -> LEvent a
LEvent.Event forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage WriteDevice
wdev RealTime
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> ChannelMessage -> Message
Midi.ChannelMessage Channel
chan
    -- 'encode_time' includes the bit position so it doesn't depend on order,
    -- but encode_play_config has to transmit text, so it does depend on order.
    -- With CoreMIDI it seems msgs stay in order even when they have the same
    -- timestamp, I'll put on a timestamp just in case.  They're all in the
    -- past, so they should still be "as fast as possible", and not 10ms, or
    -- whatever it winds up being.
    ts :: [RealTime]
ts = forall a b. (a -> b) -> [a] -> [b]
map Integer -> RealTime
RealTime.milliseconds [Integer
0..]

-- | Merge a finite list of notes with an infinite list of MTC.
merge_midi :: [LEvent.LEvent Midi.WriteMessage]
    -> [LEvent.LEvent Midi.WriteMessage] -> [LEvent.LEvent Midi.WriteMessage]
merge_midi :: MidiEvents -> MidiEvents -> MidiEvents
merge_midi = forall k a. Ord k => (a -> k) -> [a] -> [a] -> [a]
merge_until (forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a
LEvent.either WriteMessage -> RealTime
Midi.wmsg_ts (forall a b. a -> b -> a
const RealTime
0))

-- | Merge until the leftmost list runs out.
merge_until :: Ord k => (a -> k) -> [a] -> [a] -> [a]
merge_until :: forall k a. Ord k => (a -> k) -> [a] -> [a] -> [a]
merge_until a -> k
key = [a] -> [a] -> [a]
go
    where
    go :: [a] -> [a] -> [a]
go [a]
xs [] = [a]
xs
    go [] [a]
_ = []
    go (a
x:[a]
xs) (a
y:[a]
ys)
        | a -> k
key a
x forall a. Ord a => a -> a -> Bool
<= a -> k
key a
y = a
x forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
go [a]
xs (a
yforall a. a -> [a] -> [a]
:[a]
ys)
        | Bool
otherwise = a
y forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
go (a
xforall a. a -> [a] -> [a]
:[a]
xs) [a]
ys

generate_mtc :: Maybe Cmd.SyncConfig -> RealTime -> [Midi.WriteMessage]
generate_mtc :: Maybe SyncConfig -> RealTime -> [WriteMessage]
generate_mtc (Just SyncConfig
sync) RealTime
start | SyncConfig -> Bool
Cmd.sync_mtc SyncConfig
sync =
    forall a b. (a -> b) -> [a] -> [b]
map (Double, Message) -> WriteMessage
make forall a b. (a -> b) -> a -> b
$ (Double
0, FrameRate -> Smpte -> Message
Midi.mtc_sync FrameRate
rate Smpte
smpte) forall a. a -> [a] -> [a]
: FrameRate -> TrackNum -> [(Double, Message)]
Midi.generate_mtc FrameRate
rate TrackNum
frame
    where
    smpte :: Smpte
smpte = FrameRate -> TrackNum -> Smpte
Midi.frame_to_smpte FrameRate
rate TrackNum
frame
    frame :: TrackNum
frame = FrameRate -> Double -> TrackNum
Midi.seconds_to_frame FrameRate
rate (RealTime -> Double
RealTime.to_seconds RealTime
start)
    rate :: FrameRate
rate = SyncConfig -> FrameRate
Cmd.sync_frame_rate SyncConfig
sync
    make :: (Double, Message) -> WriteMessage
make (Double
secs, Message
msg) =
        WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage (SyncConfig -> WriteDevice
Cmd.sync_device SyncConfig
sync) (Double -> RealTime
RealTime.seconds Double
secs) Message
msg
generate_mtc Maybe SyncConfig
_ RealTime
_ = []

lookup_current_performance :: Cmd.M m => BlockId -> m (Maybe Cmd.Performance)
lookup_current_performance :: forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
lookup_current_performance BlockId
block_id =
    forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (PlayState -> a) -> m a
gets PlayState -> Map BlockId Performance
Cmd.state_current_performance

-- * implementation

gets :: Cmd.M m => (Cmd.PlayState -> a) -> m a
gets :: forall (m :: * -> *) a. M m => (PlayState -> a) -> m a
gets PlayState -> a
f = forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (PlayState -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
Cmd.state_play)


{- NOTE [play-im]

    Im is the general name for the offline synthesizer framework.  The overall
    setup is that when the sequencer wants to play notes with an im allocation,
    it serializes them to a file and invokes the external synthesizer.  Said
    synthesizer then renders sound to the audio cache, which is a directory of
    sound files.  Those sound files will be played by the PlayCache VST, which
    just streams them into whatever VST host is in use.

    When it's time to play, and 'lookup_im_config' notices im events, it adds
    a specially formatted MIDI msgs to tell PlayCache where to start playing.
    Since the play_monitor_thread can't get any signals from the vst, it
    assumes PlayCache is playing until time passes the last im event, or
    there is a stop request via 'Transport.stop_player'.  TODO Come to think of
    it, this would probably work for MIDI events too, so maybe I could simplify
    things by getting rid of all the monitor and player communication.

    The sequencer sends AllNotesOff when the user requests a stop, which means
    PlayCache should stop playing right away.  Otherwise, it keeps playing
    until the end of the sample, because who knows how much decay that last
    note may have.  The sequencer also sends ResetAllControllers on a stop when
    already stopped, so I can use that too as a signal to stop even if there is
    decay.
-}