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

{- | The FFI-using part of "Cmd.Play".  It uses the FFI because the play
    monitor wants to directly call to the UI to update the playback indicator,
    which is much more efficient than going through the whole "Ui.Diff" thing.

    But that means "Cmd.Play" would import FFI-using modules, which causes
    a problem for ghci, and, since I want the Cmd.Play functions to be
    available there, for the REPL as well.  So I engage in a hack: the play cmd
    returns a special 'Cmd.Play' value which contains the arguments for the
    play monitor thread.  The responder treats it as a Done but will call
    'play' with the given args.

    Actually since I have *Stub modules now I think this hack is no longer
    needed.  But I'll leave it in place for now since it doesn't seem to
    be hurting anything and it's nice to divide play into low and high level.
-}
{-# LANGUAGE CPP #-}
module Cmd.PlayC (cmd_play_msg, play) where
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Exception as Exception
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Vector as Vector

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Thread as Thread

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 Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack

import qualified Perform.Midi.Play as Midi.Play
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.ImGc as ImGc
import qualified Ui.Block as Block
import qualified Ui.Color as Color
import qualified Ui.Fltk as Fltk
import qualified Ui.Sync as Sync
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types

-- This is just so I don't incur a Util.Audio dependency when I don't have im.
-- If I just merge all the im hackage deps into the basic deps then I can lose
-- this.
#include "hsconfig.h"
#ifdef ENABLE_IM
import qualified Synth.StreamAudio as StreamAudio
#endif


-- * cmd_play_msg

-- | Respond to msgs about derivation and playing status.
cmd_play_msg :: Fltk.Channel -> Msg.Msg -> Cmd.CmdT IO Cmd.Status
cmd_play_msg :: Channel -> Msg -> CmdT IO Status
cmd_play_msg Channel
ui_chan Msg
msg = do
    case Msg
msg of
        Msg.Transport Status
status -> forall {m :: * -> *}. M m => Status -> m ()
transport_msg Status
status
        Msg.DeriveStatus BlockId
block_id DeriveStatus
status -> BlockId -> DeriveStatus -> CmdT IO ()
derive_status_msg BlockId
block_id DeriveStatus
status
        Msg
_ -> forall (m :: * -> *) a. M m => m a
Cmd.abort
    forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
    where
    transport_msg :: Status -> m ()
transport_msg Status
status = case Status
status of
        Status
Transport.Playing -> forall (m :: * -> *). M m => Color -> m ()
set_all_play_boxes Color
Config.play_color
        -- Either the performer has declared itself stopped, or the play
        -- monitor has declared it stopped.  In any case, I don't need
        -- a transport to tell it what to do anymore.  Note that I just forget
        -- about the the play_ctl, I don't mark it stopped.  This is because
        -- Transport.Stopped comes out when I run out of score to play, but
        -- I may well still be playing the decay of the last note, so I don't
        -- want to send a stop to cut it off.  For MIDI that probably has
        -- no effect anyway, but it would cut off play_cache or play_im_direct.
        Transport.Stopped PlayControl
play_ctl -> 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_control :: [PlayControl]
Cmd.state_play_control =
                    forall a. Eq a => a -> [a] -> [a]
List.delete PlayControl
play_ctl (PlayState -> [PlayControl]
Cmd.state_play_control PlayState
st)
                }
            -- This will cover up derive status info, but that should be ok.
            -- And play normally only comes after derive is completed.
            forall (m :: * -> *). M m => Color -> m ()
set_all_play_boxes Color
Config.box_color
    derive_status_msg :: BlockId -> DeriveStatus -> CmdT IO ()
derive_status_msg BlockId
block_id DeriveStatus
status = do
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (DeriveStatus -> Maybe Color
derive_status_color DeriveStatus
status) (forall (m :: * -> *). M m => BlockId -> Color -> m ()
Ui.set_play_box BlockId
block_id)
        -- When I get word that a performance is complete, I promote it from
        -- state_current_performance to state_performance.  Previously I used
        -- the performance in the DeriveComplete, but Play may have flipped
        -- the 'Cmd.perf_logs_written' bit.  More subtle, I don't want to
        -- have different versions of the same Performance kicking around
        -- because it has lazy fields, and a less-forced version could keep
        -- data alive.
        case DeriveStatus
status of
            Msg.DeriveComplete {} -> do
                Map BlockId Performance
current <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$
                    PlayState -> Map BlockId Performance
Cmd.state_current_performance forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
Cmd.state_play
                forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId Performance
current) forall a b. (a -> b) -> a -> b
$ \Performance
perf -> do
                    forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
Cmd.modify_play_state forall a b. (a -> b) -> a -> b
$ \PlayState
st -> PlayState
st
                        { state_performance :: Map BlockId Performance
Cmd.state_performance = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BlockId
block_id
                            Performance
perf (PlayState -> Map BlockId Performance
Cmd.state_performance PlayState
st)
                        }
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Channel -> BlockId -> State -> TrackSignals -> IO ()
update_track_signals Channel
ui_chan BlockId
block_id
                        (Performance -> State
Cmd.perf_ui_state Performance
perf) (Performance -> TrackSignals
Cmd.perf_track_signals Performance
perf)
                    Channel -> BlockId -> Vector Event -> CmdT IO ()
update_highlights Channel
ui_chan BlockId
block_id (Performance -> Vector Event
Cmd.perf_events Performance
perf)
            DeriveStatus
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Channel -> BlockId -> DeriveStatus -> CmdT IO ()
handle_im_status Channel
ui_chan BlockId
block_id DeriveStatus
status
    derive_status_color :: DeriveStatus -> Maybe Color
derive_status_color DeriveStatus
status = case DeriveStatus
status of
        Msg.OutOfDate {} -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> Color -> Color
Color.brightness Double
1.5 Color
Config.busy_color
        Msg.Deriving {} -> forall a. a -> Maybe a
Just Color
Config.busy_color
        Msg.DeriveComplete Performance
_ ImStarted
Msg.ImStarted ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> Color -> Color
Color.brightness Double
0.5 Color
Config.busy_color
        Msg.DeriveComplete Performance
_ ImStarted
Msg.ImUnnecessary -> forall a. a -> Maybe a
Just Color
Config.box_color
        Msg.ImStatus BlockId
_ Set TrackId
_ (Msg.ImComplete {}) -> forall a. a -> Maybe a
Just Color
Config.box_color
        Msg.ImStatus {} -> forall a. Maybe a
Nothing

set_all_play_boxes :: Ui.M m => Color.Color -> m ()
set_all_play_boxes :: forall (m :: * -> *). M m => Color -> m ()
set_all_play_boxes Color
color =
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *). M m => BlockId -> Color -> m ()
Ui.set_play_box Color
color) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [BlockId]
Ui.all_block_ids

type Range = (TrackTime, TrackTime)

-- ** handle im status

handle_im_status :: Fltk.Channel -> BlockId -> Msg.DeriveStatus
    -> Cmd.CmdT IO ()
handle_im_status :: Channel -> BlockId -> DeriveStatus -> CmdT IO ()
handle_im_status Channel
ui_chan BlockId
root_block_id = \case
    Msg.DeriveComplete Performance
_ ImStarted
Msg.ImStarted ->
        Channel -> BlockId -> CmdT IO ()
start_im_progress Channel
ui_chan BlockId
root_block_id
    Msg.DeriveComplete Performance
_ ImStarted
Msg.ImUnnecessary -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Msg.ImStatus BlockId
block_id Set TrackId
track_ids ImStatus
status -> case ImStatus
status of
        Msg.ImWaveformsCompleted [WaveformChunk]
waveforms ->
            Channel -> BlockId -> Set TrackId -> [WaveformChunk] -> CmdT IO ()
im_waveforms_completed Channel
ui_chan BlockId
block_id Set TrackId
track_ids [WaveformChunk]
waveforms
        Msg.ImRenderingRange Instrument
instrument RealTime
start RealTime
end ->
            Channel
-> BlockId
-> Set TrackId
-> Instrument
-> (RealTime, RealTime)
-> CmdT IO ()
im_rendering_range Channel
ui_chan BlockId
block_id Set TrackId
track_ids Instrument
instrument
                (RealTime
start, RealTime
end)
        Msg.ImComplete Bool
failed Maybe Stats
mb_stats -> do
            -- If it failed, leave the the progress highlight in place, to
            -- indicate where it crashed.
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
failed forall a b. (a -> b) -> a -> b
$
                Channel -> BlockId -> CmdT IO ()
clear_im_progress Channel
ui_chan BlockId
root_block_id
            -- I can only GC if the last im thread completed.  This is because
            -- cache entries don't have BlockId, so I don't want to clear the
            -- entries of another block while it's still running.  It seems a
            -- bit sketchy though, since the evaluation thread could get
            -- pre-empted arbitrarily long before exiting.
            [BlockId]
running <- CmdT IO [BlockId]
Cmd.running_threads
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
running) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Channel -> IO ()
Sync.gc_waveforms Channel
ui_chan
            -- Only show the GC stats when rendering the root block.
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Stats
mb_stats forall a b. (a -> b) -> a -> b
$ \Stats
stats ->
                forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM forall (m :: * -> *). M m => m (Maybe BlockId)
Ui.lookup_root_id forall a b. (a -> b) -> a -> b
$ \BlockId
score_root ->
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockId
score_root forall a. Eq a => a -> a -> Bool
== BlockId
root_block_id) forall a b. (a -> b) -> a -> b
$
                        -- TODO put this at the end?  Or just delete it.
                        forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"im cache" forall a b. (a -> b) -> a -> b
$
                            TrackNum -> TrackNum -> Text
Pretty.bytes TrackNum
0 (Stats -> TrackNum
ImGc._remaining Stats
stats)
    DeriveStatus
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

start_im_progress :: Fltk.Channel -> BlockId -> Cmd.CmdT IO ()
start_im_progress :: Channel -> BlockId -> CmdT IO ()
start_im_progress Channel
ui_chan BlockId
block_id = do
    [TrackId]
track_ids <- forall (m :: * -> *). M m => BlockId -> m [TrackId]
get_im_instrument_tracks BlockId
block_id
    let pending :: (Range, Color)
pending = ((TrackTime
0, TrackTime
end_of_track), Color
Config.im_pending_color)
    [((ViewId, TrackNum), (Range, Color))]
sels <- forall (m :: * -> *) a.
M m =>
[((BlockId, TrackId), a)] -> m [((ViewId, TrackNum), a)]
resolve_tracks
        [((BlockId
block_id, TrackId
track_id), (Range, Color)
pending) | TrackId
track_id <- [TrackId]
track_ids]
    [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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Channel -> [ViewId] -> IO ()
Sync.clear_waveforms Channel
ui_chan [ViewId]
view_ids
        Channel -> [((ViewId, TrackNum), (Range, Color))] -> IO ()
Sync.set_im_progress Channel
ui_chan [((ViewId, TrackNum), (Range, Color))]
sels

get_im_instrument_tracks :: Cmd.M m => BlockId -> m [TrackId]
get_im_instrument_tracks :: forall (m :: * -> *). M m => BlockId -> m [TrackId]
get_im_instrument_tracks BlockId
block_id = do
    [TrackId]
track_ids <- forall (m :: * -> *). M m => BlockId -> m [TrackId]
Ui.track_ids_of BlockId
block_id
    -- TODO This is inaccurate since it doesn't understand dummy instruments.
    -- But good enough for now?  I avoid perf_track_instruments to avoid
    -- crashing before the first performance exists.
    [Maybe Instrument]
insts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). M m => TrackId -> m (Maybe Instrument)
Perf.infer_instrument [TrackId]
track_ids
    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
    let is_im :: Instrument -> Bool
is_im Instrument
inst = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Allocation -> Bool
UiConfig.is_im_allocation forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Instrument
inst Map Instrument Allocation
allocs
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Instrument -> Bool
is_im 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 b. [a] -> [b] -> [(a, b)]
zip [TrackId]
track_ids [Maybe Instrument]
insts

im_waveforms_completed :: Fltk.Channel -> BlockId -> Set TrackId
    -> [Track.WaveformChunk] -> Cmd.CmdT IO ()
im_waveforms_completed :: Channel -> BlockId -> Set TrackId -> [WaveformChunk] -> CmdT IO ()
im_waveforms_completed Channel
ui_chan BlockId
block_id Set TrackId
track_ids [WaveformChunk]
waveforms = do
    [((ViewId, TrackNum), [WaveformChunk])]
by_view <- forall (m :: * -> *) a.
M m =>
[((BlockId, TrackId), a)] -> m [((ViewId, TrackNum), a)]
resolve_tracks
        [ ((BlockId
block_id, TrackId
track_id), [WaveformChunk]
waveforms)
        | TrackId
track_id <- forall a. Set a -> [a]
Set.toList Set TrackId
track_ids
        ]
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Channel -> [((ViewId, TrackNum), [WaveformChunk])] -> IO ()
Sync.set_waveforms Channel
ui_chan [((ViewId, TrackNum), [WaveformChunk])]
by_view

-- *** progress

clear_im_progress :: Fltk.Channel -> BlockId -> Cmd.CmdT IO ()
clear_im_progress :: Channel -> BlockId -> CmdT IO ()
clear_im_progress Channel
ui_chan BlockId
block_id = do
    forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
Cmd.modify_play_state forall a b. (a -> b) -> a -> b
$ \PlayState
st -> PlayState
st
        { state_im_progress :: Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime)))
Cmd.state_im_progress = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete BlockId
block_id (PlayState
-> Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime)))
Cmd.state_im_progress PlayState
st)
        }
    [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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Channel -> [ViewId] -> IO ()
Sync.clear_im_progress Channel
ui_chan [ViewId]
view_ids

im_rendering_range :: Fltk.Channel -> BlockId -> Set TrackId
    -> ScoreT.Instrument -> (RealTime, RealTime) -> Cmd.CmdT IO ()
im_rendering_range :: Channel
-> BlockId
-> Set TrackId
-> Instrument
-> (RealTime, RealTime)
-> CmdT IO ()
im_rendering_range Channel
ui_chan BlockId
block_id Set TrackId
track_ids Instrument
instrument (RealTime, RealTime)
range = do
    [(TrackId, (RealTime, RealTime))]
ranges <- forall (m :: * -> *).
M m =>
BlockId
-> [TrackId]
-> Instrument
-> (RealTime, RealTime)
-> m [(TrackId, (RealTime, RealTime))]
update_rendering_ranges BlockId
block_id (forall a. Set a -> [a]
Set.toList Set TrackId
track_ids)
        Instrument
instrument (RealTime, RealTime)
range
    -- I could be fancy by setting the color shade based on how many
    -- instruments are rendering in each range, but let's leave it be for now.
    [((ViewId, TrackNum), (Range, Color))]
sels <- forall (m :: * -> *) a.
M m =>
[((BlockId, TrackId), a)] -> m [((ViewId, TrackNum), a)]
resolve_tracks forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (forall (m :: * -> *).
M m =>
BlockId
-> (TrackId, (RealTime, RealTime))
-> m [((BlockId, TrackId), (Range, Color))]
range_to_selection BlockId
block_id) [(TrackId, (RealTime, RealTime))]
ranges
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Channel -> [((ViewId, TrackNum), (Range, Color))] -> IO ()
Sync.set_im_progress Channel
ui_chan [((ViewId, TrackNum), (Range, Color))]
sels

update_rendering_ranges :: Cmd.M m => BlockId -> [TrackId]
    -> ScoreT.Instrument -> (RealTime, RealTime)
    -> m [(TrackId, (RealTime, RealTime))]
update_rendering_ranges :: forall (m :: * -> *).
M m =>
BlockId
-> [TrackId]
-> Instrument
-> (RealTime, RealTime)
-> m [(TrackId, (RealTime, RealTime))]
update_rendering_ranges BlockId
block_id [TrackId]
track_ids Instrument
instrument (RealTime, RealTime)
range = do
    Map TrackId (Map Instrument (RealTime, RealTime))
tracks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty BlockId
block_id
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayState
-> Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime)))
Cmd.state_im_progress forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
Cmd.state_play
    let new :: Map TrackId (Map Instrument (RealTime, RealTime))
new = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [(TrackId
track_id, forall k a. k -> a -> Map k a
Map.singleton Instrument
instrument (RealTime, RealTime)
range) | TrackId
track_id <- [TrackId]
track_ids]
    let merged :: Map TrackId (Map Instrument (RealTime, RealTime))
merged = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>) Map TrackId (Map Instrument (RealTime, RealTime))
new Map TrackId (Map Instrument (RealTime, RealTime))
tracks
    forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
Cmd.modify_play_state forall a b. (a -> b) -> a -> b
$ \PlayState
st -> PlayState
st
        { state_im_progress :: Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime)))
Cmd.state_im_progress =
            forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BlockId
block_id Map TrackId (Map Instrument (RealTime, RealTime))
merged forall a b. (a -> b) -> a -> b
$ PlayState
-> Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime)))
Cmd.state_im_progress PlayState
st
        }
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Map TrackId (Map Instrument (RealTime, RealTime))
-> [TrackId] -> [(TrackId, (RealTime, RealTime))]
track_ranges Map TrackId (Map Instrument (RealTime, RealTime))
merged [TrackId]
track_ids

track_ranges :: Map TrackId (Map ScoreT.Instrument (RealTime, RealTime))
    -> [TrackId] -> [(TrackId, (RealTime, RealTime))]
track_ranges :: Map TrackId (Map Instrument (RealTime, RealTime))
-> [TrackId] -> [(TrackId, (RealTime, RealTime))]
track_ranges Map TrackId (Map Instrument (RealTime, RealTime))
tracks = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {a} {b}. (Ord a, Ord b) => [(a, b)] -> Maybe (a, b)
expand forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TrackId -> Maybe (TrackId, Map Instrument (RealTime, RealTime))
get
    where
    get :: TrackId -> Maybe (TrackId, Map Instrument (RealTime, RealTime))
get TrackId
track_id = (TrackId
track_id,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
track_id Map TrackId (Map Instrument (RealTime, RealTime))
tracks
    expand :: [(a, b)] -> Maybe (a, b)
expand [] = forall a. Maybe a
Nothing
    expand [(a, b)]
ranges = forall a. a -> Maybe a
Just (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, b)]
ranges), forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, b)]
ranges))

-- | Convert a track level RealTime range to lower level per-view TrackTime
-- ranges.
range_to_selection :: Cmd.M m => BlockId -> (TrackId, (RealTime, RealTime))
    -> m [((BlockId, TrackId), ((ScoreTime, ScoreTime), Color.Color))]
range_to_selection :: forall (m :: * -> *).
M m =>
BlockId
-> (TrackId, (RealTime, RealTime))
-> m [((BlockId, TrackId), (Range, Color))]
range_to_selection BlockId
block_id (TrackId
track_id, (RealTime
start, RealTime
end)) = do
    InverseTempoFunction
inv_tempo <- forall (m :: * -> *). M m => BlockId -> m InverseTempoFunction
Perf.get_inverse_tempo BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
        TrackTime
start <- InverseTempoFunction
-> BlockId -> TrackId -> RealTime -> Maybe TrackTime
to_score InverseTempoFunction
inv_tempo BlockId
block_id TrackId
track_id RealTime
start
        TrackTime
end <- InverseTempoFunction
-> BlockId -> TrackId -> RealTime -> Maybe TrackTime
to_score InverseTempoFunction
inv_tempo BlockId
block_id TrackId
track_id RealTime
end
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((BlockId
block_id, TrackId
track_id),)
            [ ((TrackTime
start, TrackTime
end), Color
Config.im_working_color)
            , ((TrackTime
end, TrackTime
end_of_track), Color
Config.im_pending_color)
            ]

end_of_track :: TrackTime
end_of_track :: TrackTime
end_of_track = TrackTime
99999 -- TODO use a special to-end value?

to_score :: Transport.InverseTempoFunction -> BlockId -> TrackId -> RealTime
    -> Maybe ScoreTime
to_score :: InverseTempoFunction
-> BlockId -> TrackId -> RealTime -> Maybe TrackTime
to_score InverseTempoFunction
inv_tempo BlockId
block_id TrackId
track_id =
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TrackId
track_id forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup BlockId
block_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. InverseTempoFunction
inv_tempo Stop
Transport.NoStop

-- ** track signals

-- | This takes the Ui.State from 'Cmd.perf_ui_state' because the current
-- Ui.State may have changes which haven't yet been synced to the UI.
update_track_signals :: Fltk.Channel -> BlockId -> Ui.State
    -> Track.TrackSignals -> IO ()
update_track_signals :: Channel -> BlockId -> State -> TrackSignals -> IO ()
update_track_signals Channel
ui_chan BlockId
block_id State
state TrackSignals
tsigs =
    case BlockId
-> State -> Either Error [(ViewId, TrackId, TrackNum, Bool)]
rendering_tracks BlockId
block_id State
state of
        -- This means a bad BlockId or bug in rendering_tracks.
        Left Error
err -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Error
err
        Right [(ViewId, TrackId, TrackNum, Bool)]
tracks -> Channel -> [(ViewId, TrackNum, TrackSignal)] -> IO ()
Sync.set_track_signals Channel
ui_chan forall a b. (a -> b) -> a -> b
$
            [ (ViewId
view_id, TrackNum
tracknum, if Bool
wants_tsig
                then forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault TrackSignal
empty (BlockId
block_id, TrackId
track_id) TrackSignals
tsigs
                else TrackSignal
empty)
            | (ViewId
view_id, TrackId
track_id, TrackNum
tracknum, Bool
wants_tsig) <- [(ViewId, TrackId, TrackNum, Bool)]
tracks
            ]
    where
    -- If there's no recorded signal, I send an empty one, to make sure that if
    -- there used to be one I will clear it out.  This is because "removed an
    -- existing track signal" and "never had a track signal" look the same
    -- from here, and always sending an empty seems less error-prone than
    -- trying to figure out the distinction.
    empty :: TrackSignal
empty = TrackSignal
Track.empty_track_signal

-- | Get the tracks of this block and whether they want to render a signal.
rendering_tracks :: BlockId -> Ui.State
    -> Either Ui.Error [(ViewId, TrackId, TrackNum, Bool)]
rendering_tracks :: BlockId
-> State -> Either Error [(ViewId, TrackId, TrackNum, Bool)]
rendering_tracks BlockId
block_id State
state = forall a. State -> StateId a -> Either Error a
Ui.eval State
state forall a b. (a -> b) -> a -> b
$ 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
    [Block]
blocks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). M m => ViewId -> m Block
Ui.block_of [ViewId]
view_ids
    [[((TrackNum, TrackId, Set TrackFlag), Track)]]
btracks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {f :: * -> *} {a}.
(M f, Num a, Enum a) =>
Block -> f [((a, TrackId, Set TrackFlag), Track)]
get_tracks [Block]
blocks
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        (ViewId
view_id, [((TrackNum, TrackId, Set TrackFlag), Track)]
tracks) <- forall a b. [a] -> [b] -> [(a, b)]
zip [ViewId]
view_ids [[((TrackNum, TrackId, Set TrackFlag), Track)]]
btracks
        ((TrackNum
tracknum, TrackId
track_id, Set TrackFlag
flags), Track
track) <- [((TrackNum, TrackId, Set TrackFlag), Track)]
tracks
        -- I don't want to send even an empty signal to these.
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Set TrackFlag -> Bool
Block.is_collapsed Set TrackFlag
flags
        forall (m :: * -> *) a. Monad m => a -> m a
return
            ( ViewId
view_id, TrackId
track_id, TrackNum
tracknum
            , Set TrackFlag -> Track -> Bool
Block.track_wants_signal Set TrackFlag
flags Track
track
            )
    where
    get_tracks :: Block -> f [((a, TrackId, Set TrackFlag), Track)]
get_tracks Block
block = forall a b. [a] -> [b] -> [(a, b)]
zip [(a, TrackId, Set TrackFlag)]
triples 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 Track
Ui.get_track [TrackId]
track_ids
        where
        track_ids :: [TrackId]
track_ids = [TrackId
tid | (a
_, TrackId
tid, Set TrackFlag
_) <- [(a, TrackId, Set TrackFlag)]
triples]
        triples :: [(a, TrackId, Set TrackFlag)]
triples =
            [ (a
tracknum, TrackId
tid, Track -> Set TrackFlag
Block.track_flags Track
track)
            | (a
tracknum,
                track :: Track
track@(Block.Track { tracklike_id :: Track -> TracklikeId
Block.tracklike_id = Block.TId TrackId
tid RulerId
_ }))
                <- forall a b. [a] -> [b] -> [(a, b)]
zip [a
0..] (Block -> [Track]
Block.block_tracks Block
block)
            ]

-- ** highlights

-- | Get highlights from the events, clear old highlights, and set the new ones.
update_highlights :: Fltk.Channel -> BlockId -> Vector.Vector Score.Event
    -> Cmd.CmdT IO ()
update_highlights :: Channel -> BlockId -> Vector Event -> CmdT IO ()
update_highlights Channel
ui_chan BlockId
block_id Vector Event
events = do
    [((ViewId, TrackNum), (Range, Color))]
sels <- forall (m :: * -> *).
M m =>
BlockId -> Vector Event -> m [((ViewId, TrackNum), (Range, Color))]
get_event_highlights BlockId
block_id Vector Event
events
    Set ViewId
view_ids <- forall k a. Map k a -> Set k
Map.keysSet 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
    let used_view_ids :: Set ViewId
used_view_ids = forall a. Ord a => [a] -> Set a
Set.fromList [ViewId
view_id | ((ViewId
view_id, TrackNum
_), (Range, Color)
_) <- [((ViewId, TrackNum), (Range, Color))]
sels]
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Channel -> [ViewId] -> IO ()
Sync.clear_highlights Channel
ui_chan forall a b. (a -> b) -> a -> b
$
            forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Set ViewId
view_ids forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ViewId
used_view_ids
        Channel -> [((ViewId, TrackNum), (Range, Color))] -> IO ()
Sync.set_highlights Channel
ui_chan [((ViewId, TrackNum), (Range, Color))]
sels

-- | Get highlight selections from the events.
get_event_highlights :: Cmd.M m => BlockId
    -- ^ only get highlights for events on this block
    -> Vector.Vector Score.Event
    -> m [((ViewId, TrackNum), (Range, Color.Color))]
get_event_highlights :: forall (m :: * -> *).
M m =>
BlockId -> Vector Event -> m [((ViewId, TrackNum), (Range, Color))]
get_event_highlights BlockId
block_id Vector Event
events = do
    Map Highlight Color
colors <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ Config -> Map Highlight Color
Cmd.config_highlight_colors forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Cmd.state_config
    forall (m :: * -> *) a.
M m =>
[((BlockId, TrackId), a)] -> m [((ViewId, TrackNum), a)]
resolve_tracks forall a b. (a -> b) -> a -> b
$ BlockId
-> Map Highlight Color
-> Vector Event
-> [((BlockId, TrackId), (Range, Color))]
event_highlights BlockId
block_id Map Highlight Color
colors Vector Event
events

resolve_tracks :: Ui.M m => [((BlockId, TrackId), a)]
    -> m [((ViewId, TrackNum), a)]
resolve_tracks :: forall (m :: * -> *) a.
M m =>
[((BlockId, TrackId), a)] -> m [((ViewId, TrackNum), a)]
resolve_tracks = forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM forall {m :: * -> *} {b}.
M m =>
((BlockId, TrackId), b) -> m [((ViewId, TrackNum), b)]
resolve
    where
    resolve :: ((BlockId, TrackId), b) -> m [((ViewId, TrackNum), b)]
resolve ((BlockId
block_id, TrackId
track_id), b
val) = do
        TrackNum
tracknum <- forall (m :: * -> *). M m => BlockId -> TrackId -> m TrackNum
Ui.get_tracknum_of BlockId
block_id TrackId
track_id
        [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 (m :: * -> *) a. Monad m => a -> m a
return [((ViewId
view_id, TrackNum
tracknum), b
val) | ViewId
view_id <- [ViewId]
view_ids]

event_highlights :: BlockId -> Map Color.Highlight Color.Color
    -> Vector.Vector Score.Event
    -> [((BlockId, TrackId), (Range, Color.Color))]
event_highlights :: BlockId
-> Map Highlight Color
-> Vector Event
-> [((BlockId, TrackId), (Range, Color))]
event_highlights BlockId
derived_block_id Map Highlight Color
colors
    | forall k a. Map k a -> Bool
Map.null Map Highlight Color
colors = forall a b. a -> b -> a
const []
    | Bool
otherwise = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.uniqueOn forall {a} {b} {b}. (a, (b, b)) -> (a, b)
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b -> b) -> b -> Vector a -> b
Vector.foldr Event
-> [((BlockId, TrackId), (Range, Color))]
-> [((BlockId, TrackId), (Range, Color))]
collect []
    where
    key :: (a, (b, b)) -> (a, b)
key (a
track, (b
range, b
_)) = (a
track, b
range)
    collect :: Event
-> [((BlockId, TrackId), (Range, Color))]
-> [((BlockId, TrackId), (Range, Color))]
collect Event
event [((BlockId, TrackId), (Range, Color))]
accum
        | Highlight
highlight forall a. Eq a => a -> a -> Bool
/= Highlight
Color.NoHighlight,
                Just (BlockId
block_id, TrackId
track_id, Range
range) <- Maybe (BlockId, TrackId, Range)
maybe_pos,
                BlockId
block_id forall a. Eq a => a -> a -> Bool
== BlockId
derived_block_id,
                Just Color
color <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Highlight
highlight Map Highlight Color
colors =
            ((BlockId
block_id, TrackId
track_id), (Range
range, Color
color)) forall a. a -> [a] -> [a]
: [((BlockId, TrackId), (Range, Color))]
accum
        | Bool
otherwise = [((BlockId, TrackId), (Range, Color))]
accum
        where
        highlight :: Highlight
highlight = Event -> Highlight
Score.event_highlight Event
event
        maybe_pos :: Maybe (BlockId, TrackId, Range)
maybe_pos = Stack -> Maybe (BlockId, TrackId, Range)
Stack.block_track_region_of forall a b. (a -> b) -> a -> b
$ Event -> Stack
Score.event_stack Event
event

-- * play

-- | This actually kicks off a MIDI play thread, and if an inverse tempo
-- function is given, a play monitor thread.
play :: Fltk.Channel -> Ui.State -> Transport.Info
    -> Cmd.PlayArgs -> IO Transport.PlayControl
play :: Channel -> State -> Info -> PlayArgs -> IO PlayControl
play Channel
ui_chan State
ui_state Info
transport_info
        (Cmd.PlayArgs Maybe SyncConfig
mmc Text
name MidiEvents
midi_msgs PlayNotes
sc_msgs Maybe InverseTempoFunction
maybe_inv_tempo Maybe RealTime
repeat_at
            Maybe RealTime
im_end Maybe PlayDirectArgs
play_im_direct) = do
    PlayControl
play_ctl <- IO PlayControl
Transport.play_control
    ActivePlayers
players <- IO ActivePlayers
Transport.active_players
    let midi_state :: State
midi_state = Midi.Play.State
            { _play_control :: PlayControl
_play_control = PlayControl
play_ctl
            , _players :: ActivePlayers
_players = ActivePlayers
players
            , _info :: Info
_info = Info
transport_info
            , _im_end :: Maybe RealTime
_im_end = Maybe RealTime
im_end
            }
    State
-> Maybe SyncConfig
-> Text
-> MidiEvents
-> Maybe RealTime
-> IO ()
Midi.Play.play State
midi_state Maybe SyncConfig
mmc Text
name MidiEvents
midi_msgs Maybe RealTime
repeat_at
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PlayNotes -> Notes
Sc.Note.notes PlayNotes
sc_msgs)) forall a b. (a -> b) -> a -> b
$ do
        let sc_state :: State
sc_state = Sc.Play.State
                { _play_control :: PlayControl
_play_control = PlayControl
play_ctl, _players :: ActivePlayers
_players = ActivePlayers
players }
        State -> PlayNotes -> Maybe RealTime -> IO ()
Sc.Play.play State
sc_state PlayNotes
sc_msgs Maybe RealTime
repeat_at
    -- Pass the current state in the MVar.  ResponderSync will keep it up
    -- to date afterwards, but only if blocks are added or removed.
    forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ (Info -> MVar State
Transport.info_state Info
transport_info) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return State
ui_state)
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe PlayDirectArgs
play_im_direct forall a b. (a -> b) -> a -> b
$ \PlayDirectArgs
args -> do
        ActivePlayers -> IO ()
Transport.player_started ActivePlayers
players
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
Thread.start forall a b. (a -> b) -> a -> b
$ PlayControl -> PlayDirectArgs -> IO ()
play_im_direct_thread PlayControl
play_ctl PlayDirectArgs
args
            forall a b. IO a -> IO b -> IO a
`Exception.finally` ActivePlayers -> IO ()
Transport.player_stopped ActivePlayers
players
    IO () -> IO ThreadId
Thread.start forall a b. (a -> b) -> a -> b
$ case Maybe InverseTempoFunction
maybe_inv_tempo of
        Just InverseTempoFunction
inv_tempo -> do
            MonitorState
state <- Channel
-> Info
-> PlayControl
-> ActivePlayers
-> InverseTempoFunction
-> Maybe RealTime
-> IO MonitorState
monitor_state Channel
ui_chan Info
transport_info PlayControl
play_ctl ActivePlayers
players
                InverseTempoFunction
inv_tempo Maybe RealTime
repeat_at
            MonitorState -> IO ()
play_monitor_thread MonitorState
state
        Maybe InverseTempoFunction
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IO () -> IO ThreadId
Thread.start forall a b. (a -> b) -> a -> b
$ PlayControl -> (Status -> IO ()) -> ActivePlayers -> IO ()
wait_for_players PlayControl
play_ctl
        (Info -> Status -> IO ()
Transport.info_send_status Info
transport_info) ActivePlayers
players
    forall (m :: * -> *) a. Monad m => a -> m a
return PlayControl
play_ctl

wait_for_players :: Transport.PlayControl -> (Transport.Status -> IO ())
    -> Transport.ActivePlayers -> IO ()
wait_for_players :: PlayControl -> (Status -> IO ()) -> ActivePlayers -> IO ()
wait_for_players PlayControl
play_ctl Status -> IO ()
send_status ActivePlayers
players = do
    Status -> IO ()
send_status Status
Transport.Playing
    ActivePlayers -> IO ()
Transport.wait_player_stopped ActivePlayers
players
    Status -> IO ()
send_status forall a b. (a -> b) -> a -> b
$ PlayControl -> Status
Transport.Stopped PlayControl
play_ctl

-- | Start streaming audio from the given start time, until the PlayControl
-- says to stop.
play_im_direct_thread :: Transport.PlayControl -> Cmd.PlayDirectArgs -> IO ()
#ifdef ENABLE_IM
play_im_direct_thread :: PlayControl -> PlayDirectArgs -> IO ()
play_im_direct_thread (Transport.PlayControl Flag
quit)
        (Cmd.PlayDirectArgs FilePath
score_path BlockId
block_id Set Instrument
muted RealTime
start) =
    Maybe Device
-> Flag
-> FilePath
-> BlockId
-> Set Instrument
-> RealTime
-> IO ()
StreamAudio.play forall a. Maybe a
Nothing Flag
quit FilePath
score_path BlockId
block_id Set Instrument
muted RealTime
start
#else
play_im_direct_thread _ _ =
    errorIO "can't play_im_direct_thread when im is not linked in"
#endif

-- | Run along the InverseTempoMap and update the play position selection.
-- Note that this goes directly to the UI through Sync, bypassing the usual
-- state diff folderol.
play_monitor_thread :: MonitorState -> IO ()
play_monitor_thread :: MonitorState -> IO ()
play_monitor_thread MonitorState
state = do
    State
ui_state <- forall a. MVar a -> IO a
MVar.readMVar (MonitorState -> MVar State
monitor_ui_state MonitorState
state)
    Channel -> [ViewId] -> IO ()
Sync.clear_play_position (MonitorState -> Channel
monitor_ui_channel MonitorState
state) forall a b. (a -> b) -> a -> b
$
        forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ State -> Map ViewId View
Ui.state_views State
ui_state
    MonitorState -> IO ()
monitor_loop MonitorState
state

monitor_state :: Fltk.Channel -> Transport.Info
    -> Transport.PlayControl
    -> Transport.ActivePlayers
    -> Transport.InverseTempoFunction
    -> Maybe RealTime
    -> IO MonitorState
monitor_state :: Channel
-> Info
-> PlayControl
-> ActivePlayers
-> InverseTempoFunction
-> Maybe RealTime
-> IO MonitorState
monitor_state Channel
ui_chan Info
transport_info PlayControl
play_ctl ActivePlayers
players InverseTempoFunction
inv_tempo_func
        Maybe RealTime
repeat_at = do
    let get_now :: IO RealTime
get_now = Info -> IO RealTime
Transport.info_get_current_time Info
transport_info
    -- This won't be exactly the same as the renderer's ts offset, but
    -- it's probably close enough.
    RealTime
offset <- IO RealTime
get_now
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MonitorState
        { monitor_players :: ActivePlayers
monitor_players = ActivePlayers
players
        , monitor_play_ctl :: PlayControl
monitor_play_ctl = PlayControl
play_ctl
        , monitor_offset :: RealTime
monitor_offset = RealTime
offset
        , monitor_get_now :: IO RealTime
monitor_get_now = IO RealTime
get_now
        , monitor_inv_tempo_func :: InverseTempoFunction
monitor_inv_tempo_func = InverseTempoFunction
inv_tempo_func
        , monitor_active_sels :: Set (ViewId, [TrackNum])
monitor_active_sels = forall a. Set a
Set.empty
        , monitor_ui_state :: MVar State
monitor_ui_state = Info -> MVar State
Transport.info_state Info
transport_info
        , monitor_repeat_at :: Maybe RealTime
monitor_repeat_at = Maybe RealTime
repeat_at
        , monitor_ui_channel :: Channel
monitor_ui_channel = Channel
ui_chan
        }

data MonitorState = MonitorState {
    MonitorState -> ActivePlayers
monitor_players :: !Transport.ActivePlayers
    , MonitorState -> PlayControl
monitor_play_ctl :: !Transport.PlayControl
    -- | When the monitor thread started.
    , MonitorState -> RealTime
monitor_offset :: !RealTime
    , MonitorState -> IO RealTime
monitor_get_now :: !(IO RealTime)
    , MonitorState -> InverseTempoFunction
monitor_inv_tempo_func :: !Transport.InverseTempoFunction
    , MonitorState -> Set (ViewId, [TrackNum])
monitor_active_sels :: !(Set (ViewId, [TrackNum]))
    , MonitorState -> MVar State
monitor_ui_state :: !(MVar.MVar Ui.State)
    , MonitorState -> Maybe RealTime
monitor_repeat_at :: !(Maybe RealTime)
    , MonitorState -> Channel
monitor_ui_channel :: !Fltk.Channel
    }

monitor_loop :: MonitorState -> IO ()
monitor_loop :: MonitorState -> IO ()
monitor_loop MonitorState
state = do
    -- This is play time, relative to when play started.  It is not RealTime
    -- position in the score, because we might have started in the middle.
    -- The inv_tempo_func must have had this offset already applied.
    RealTime
now <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Real a => a -> a -> a
Num.fmod) (MonitorState -> Maybe RealTime
monitor_repeat_at MonitorState
state)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract (MonitorState -> RealTime
monitor_offset MonitorState
state) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MonitorState -> IO RealTime
monitor_get_now MonitorState
state
    let fail :: a -> m [a]
fail a
err = forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error (Text
"state error in play monitor: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
err)
            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
    State
ui_state <- forall a. MVar a -> IO a
MVar.readMVar (MonitorState -> MVar State
monitor_ui_state MonitorState
state)
    let block_pos :: [(BlockId, [(TrackId, TrackTime)])]
block_pos = MonitorState -> InverseTempoFunction
monitor_inv_tempo_func MonitorState
state Stop
Transport.StopAtEnd RealTime
now
    [(ViewId, [(TrackNum, TrackTime)])]
play_pos <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ViewId, [(TrackNum, TrackTime)])]
-> [(ViewId, [(TrackNum, TrackTime)])]
extend_to_track_0 forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {m :: * -> *} {a} {a}. (LogMonad m, Show a) => a -> m [a]
fail forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall a. State -> StateId a -> Either Error a
Ui.eval State
ui_state forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
M m =>
[(BlockId, [(TrackId, TrackTime)])]
-> m [(ViewId, [(TrackNum, TrackTime)])]
Perf.block_pos_to_play_pos [(BlockId, [(TrackId, TrackTime)])]
block_pos
    Channel -> [(ViewId, [(TrackNum, TrackTime)])] -> IO ()
Sync.set_play_position (MonitorState -> Channel
monitor_ui_channel MonitorState
state) [(ViewId, [(TrackNum, TrackTime)])]
play_pos

    let active_sels :: Set (ViewId, [TrackNum])
active_sels = forall a. Ord a => [a] -> Set a
Set.fromList
            [(ViewId
view_id, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TrackNum, TrackTime)]
num_pos) | (ViewId
view_id, [(TrackNum, TrackTime)]
num_pos) <- [(ViewId, [(TrackNum, TrackTime)])]
play_pos]
    Channel -> [ViewId] -> IO ()
Sync.clear_play_position (MonitorState -> Channel
monitor_ui_channel MonitorState
state) 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. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
        forall a. Ord a => Set a -> Set a -> Set a
Set.difference (MonitorState -> Set (ViewId, [TrackNum])
monitor_active_sels MonitorState
state) Set (ViewId, [TrackNum])
active_sels
    MonitorState
state <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MonitorState
state { monitor_active_sels :: Set (ViewId, [TrackNum])
monitor_active_sels = Set (ViewId, [TrackNum])
active_sels }

    Bool
done <- forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM
        -- out of score
        -- If repeat_at is on, then the players will never stop on their own,
        -- even if I run out of tempo map (which happens if the repeat point is
        -- at or past the end of the score).  When the monitor thread stops, it
        -- sends Stopped on the transport, which clears out the player ctl
        -- which will make the player unstoppable, if it's still going.
        [ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(BlockId, [(TrackId, TrackTime)])]
block_pos Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
Maybe.isNothing (MonitorState -> Maybe RealTime
monitor_repeat_at MonitorState
state)
        -- stop requested
        , Seconds -> PlayControl -> IO Bool
Transport.poll_stop_player Seconds
0 (MonitorState -> PlayControl
monitor_play_ctl MonitorState
state)
        -- all players stopped, after this Transport.Stopped is emitted,
        -- Cmd.state_play_control is cleared, and it's no longer possible to
        -- do a Transport.stop_player.
        , Seconds -> ActivePlayers -> IO Bool
Transport.poll_player_stopped Seconds
0 (MonitorState -> ActivePlayers
monitor_players MonitorState
state)
        ]
    if Bool
done
        then Channel -> [ViewId] -> IO ()
Sync.clear_play_position (MonitorState -> Channel
monitor_ui_channel MonitorState
state) 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. Set a -> [a]
Set.toList (MonitorState -> Set (ViewId, [TrackNum])
monitor_active_sels MonitorState
state)
        else Seconds -> IO ()
Thread.delay Seconds
0.05 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MonitorState -> IO ()
monitor_loop MonitorState
state

-- | If there's a playback on track 1 but not on track 0, then track 0 is
-- probably a ruler.  If I put a playback there too, then the playback position
-- will be more obvious on a narrow block.
extend_to_track_0 :: [(ViewId, [(TrackNum, ScoreTime)])]
    -> [(ViewId, [(TrackNum, ScoreTime)])]
extend_to_track_0 :: [(ViewId, [(TrackNum, TrackTime)])]
-> [(ViewId, [(TrackNum, TrackTime)])]
extend_to_track_0 = 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}. (Eq a, Num a) => [(a, b)] -> [(a, b)]
extend)
    where
    extend :: [(a, b)] -> [(a, b)]
extend ((a
tracknum, b
t) : [(a, b)]
tracks)
        | a
tracknum forall a. Eq a => a -> a -> Bool
== a
1 = (a
0, b
t) forall a. a -> [a] -> [a]
: (a
1, b
t) forall a. a -> [a] -> [a]
: [(a, b)]
tracks
    extend [(a, b)]
tracks = [(a, b)]
tracks