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

-- | Cmds to deal with Cmd.Performance, derivation, and performance.
module Cmd.Repl.LPerf where
import qualified Control.Concurrent.Async as Async
import qualified Control.Exception as Exception
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Ratio as Ratio
import           Data.Ratio ((%))
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Regex as Regex
import qualified Util.Texts as Texts

import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.CmdUtil as CmdUtil
import qualified Cmd.Perf as Perf
import qualified Cmd.Performance as Performance
import qualified Cmd.PlayUtil as PlayUtil
import qualified Cmd.Repl.Util as Util
import qualified Cmd.Selection as Selection
import qualified Cmd.Simple as Simple

import qualified Derive.Cache as Cache
import qualified Derive.Derive as Derive
import qualified Derive.Env as Env
import qualified Derive.LEvent as LEvent
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream
import qualified Derive.TrackWarp as TrackWarp
import qualified Derive.Warp as Warp

import qualified Midi.Midi as Midi
import qualified Midi.Synth as Synth
import qualified Perform.Im.Convert as Im.Convert
import qualified Perform.Midi.Convert as Midi.Convert
import qualified Perform.Midi.MSignal as MSignal
import qualified Perform.Midi.Perform as Perform
import qualified Perform.Midi.Types as Types
import qualified Perform.Pitch as Pitch
import qualified Perform.Sc.Convert as Sc.Convert
import qualified Perform.Sc.Note as Sc.Note
import qualified Perform.Signal as Signal
import qualified Perform.Transport as Transport

import qualified Synth.Shared.Config as Shared.Config
import qualified Synth.Shared.Note as Shared.Note
import qualified Ui.Id as Id
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


-- | Whether the events come from the selected block as toplevel, or from the
-- root block's derivation, assuming the local block is called from the root.
data Source = Local | Root deriving (Int -> Source -> ShowS
[Source] -> ShowS
Source -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Source] -> ShowS
$cshowList :: [Source] -> ShowS
show :: Source -> String
$cshow :: Source -> String
showsPrec :: Int -> Source -> ShowS
$cshowsPrec :: Int -> Source -> ShowS
Show)

get_root :: Cmd.M m => m Cmd.Performance
get_root :: forall (m :: * -> *). M m => m Performance
get_root = forall (m :: * -> *). M m => m Performance
Perf.get_root

get :: Cmd.M m => BlockId -> m Cmd.Performance
get :: forall (m :: * -> *). M m => BlockId -> m Performance
get = forall (m :: * -> *). M m => BlockId -> m Performance
Perf.get

get_current :: Cmd.M m => BlockId -> m Cmd.Performance
get_current :: forall (m :: * -> *). M m => BlockId -> m Performance
get_current BlockId
block_id = forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"no performance for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 => (State -> a) -> m a
Cmd.gets (PlayState -> Map BlockId Performance
Cmd.state_current_performance forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
Cmd.state_play)

poll_threads :: Cmd.CmdT IO
    (Map BlockId (Maybe (Either Exception.SomeException ())))
poll_threads :: CmdT IO (Map BlockId (Maybe (Either SomeException ())))
poll_threads = do
    Map BlockId Thread
threads <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (PlayState -> Map BlockId Thread
Cmd.state_performance_threads  forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
Cmd.state_play)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. Async a -> IO (Maybe (Either SomeException a))
Async.poll forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Cmd.Thread Async ()
t) -> Async ()
t) Map BlockId Thread
threads

-- * info

environ :: Cmd.M m => m (Maybe Env.Environ)
environ :: forall (m :: * -> *). M m => m (Maybe Environ)
environ = forall (m :: * -> *). M m => Track -> m (Maybe Environ)
Perf.lookup_environ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m Track
Selection.track

-- | Controls in scope at the insert point.
controls :: Cmd.M m => Source -> m ScoreT.ControlMap
controls :: forall (m :: * -> *). M m => Source -> m ControlMap
controls Source
source = do
    Dynamic
dyn <- forall (m :: * -> *). M m => Source -> m Dynamic
dynamic Source
source
    forall (m :: * -> *) a. M m => Dynamic -> Deriver a -> m a
PlayUtil.eval_with_dynamic Dynamic
dyn Deriver ControlMap
Derive.get_control_map

-- | The control vals at the insertion point, taking the control functions into
-- account.
control_vals :: Cmd.M m => Source -> m ScoreT.ControlValMap
control_vals :: forall (m :: * -> *). M m => Source -> m ControlValMap
control_vals Source
source = do
    Dynamic
dyn <- forall (m :: * -> *). M m => Source -> m Dynamic
dynamic Source
source
    RealTime
pos <- forall (m :: * -> *). M m => Source -> m RealTime
get_realtime Source
source
    -- Dynamic doesn't record 'Derive.state_event_serial', so the randomization
    -- will likely be different.
    forall (m :: * -> *) a. M m => Dynamic -> Deriver a -> m a
PlayUtil.eval_with_dynamic Dynamic
dyn (RealTime -> Deriver ControlValMap
Derive.controls_at RealTime
pos)

-- | Like 'control_vals', but without control functions.
raw_control_vals :: Cmd.M m => Source -> m ScoreT.TypedControlValMap
raw_control_vals :: forall (m :: * -> *). M m => Source -> m TypedControlValMap
raw_control_vals Source
source = do
    Dynamic
dyn <- forall (m :: * -> *). M m => Source -> m Dynamic
dynamic Source
source
    RealTime
pos <- forall (m :: * -> *). M m => Source -> m RealTime
get_realtime Source
source
    ControlMap
cmap <- forall (m :: * -> *) a. M m => Dynamic -> Deriver a -> m a
PlayUtil.eval_with_dynamic Dynamic
dyn Deriver ControlMap
Derive.get_control_map
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} (kind :: k). Signal kind -> RealTime -> Y
`Signal.at` RealTime
pos)) ControlMap
cmap

aliases :: Cmd.M m => m (Map ScoreT.Instrument ScoreT.Instrument)
aliases :: forall (m :: * -> *). M m => m (Map Instrument Instrument)
aliases = Dynamic -> Map Instrument Instrument
Derive.state_instrument_aliases forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => Source -> m Dynamic
dynamic Source
Root

warp :: Cmd.M m => Source -> m Warp.Warp
warp :: forall (m :: * -> *). M m => Source -> m Warp
warp Source
source = Dynamic -> Warp
Derive.state_warp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => Source -> m Dynamic
dynamic Source
source

dynamic :: Cmd.M m => Source -> m Derive.Dynamic
dynamic :: forall (m :: * -> *). M m => Source -> m Dynamic
dynamic Source
source = do
    Track
track <- forall (m :: * -> *). M m => m Track
Selection.track
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"no dynamic for track " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Track
track) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Source
source of
        Source
Root -> forall (m :: * -> *). M m => Track -> m (Maybe Dynamic)
Perf.lookup_root_dynamic Track
track
        Source
Local -> forall (m :: * -> *). M m => BlockId -> Track -> m (Maybe Dynamic)
Perf.lookup_dynamic (forall a b. (a, b) -> a
fst Track
track) Track
track

sel_to_real :: Cmd.M m => m [RealTime]
sel_to_real :: forall (m :: * -> *). M m => m [RealTime]
sel_to_real = do
    (BlockId
block_id, Int
_, TrackId
track_id, TrackTime
pos) <- forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    TempoFunction
tempo <- Performance -> TempoFunction
Cmd.perf_tempo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Performance
get BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TempoFunction
tempo BlockId
block_id TrackId
track_id TrackTime
pos

get_realtime :: Cmd.M m => Source -> m RealTime
get_realtime :: forall (m :: * -> *). M m => Source -> m RealTime
get_realtime Source
source = do
    (BlockId
block_id, Int
_, TrackId
track_id, TrackTime
pos) <- forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    Performance
perf <- case Source
source of
        Source
Root -> forall (m :: * -> *). M m => m Performance
get_root
        Source
Local -> forall (m :: * -> *). M m => BlockId -> m Performance
get BlockId
block_id
    forall (m :: * -> *).
M m =>
Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
Perf.get_realtime Performance
perf BlockId
block_id (forall a. a -> Maybe a
Just TrackId
track_id) TrackTime
pos

-- * analysis

type ControlVals =
    Map ScoreT.Control ((RealTime, Signal.Y), (RealTime, Signal.Y))

-- | Get the first and last values for each instrument.  This can be used to
-- show which controls the each instrument uses, which in turn can be used
-- to set its 'Instrument.config_controls', to make sure it is always
-- initialized consistently.
inst_controls :: Cmd.M m => BlockId -> m (Map ScoreT.Instrument ControlVals)
inst_controls :: forall (m :: * -> *).
M m =>
BlockId -> m (Map Instrument ControlVals)
inst_controls BlockId
block_id =
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Instrument ControlVals -> Event -> Map Instrument ControlVals
merge forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. [LEvent d] -> [d]
LEvent.events_of forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_midi_events BlockId
block_id
    where
    merge :: Map Instrument ControlVals -> Event -> Map Instrument ControlVals
merge Map Instrument ControlVals
insts Event
event =
        forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall {k} {k} {b} {b}.
(Ord k, Ord k) =>
((k, b), (k, b)) -> ((k, b), (k, b)) -> ((k, b), (k, b))
merge1) (Event -> Instrument
event_inst Event
event)
            (forall {k}. Map k Signal -> Map k ((RealTime, Y), (RealTime, Y))
control_vals (Event -> Map Control Signal
Types.event_controls Event
event))
            Map Instrument ControlVals
insts
    control_vals :: Map k Signal -> Map k ((RealTime, Y), (RealTime, Y))
control_vals = forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe forall a b. (a -> b) -> a -> b
$ \Signal
sig ->
        case (Signal -> Maybe (RealTime, Y)
MSignal.head Signal
sig, Signal -> Maybe (RealTime, Y)
MSignal.last Signal
sig) of
            (Just (RealTime, Y)
a, Just (RealTime, Y)
b) -> forall a. a -> Maybe a
Just ((RealTime, Y)
a, (RealTime, Y)
b)
            (Maybe (RealTime, Y), Maybe (RealTime, Y))
_ -> forall a. Maybe a
Nothing
    merge1 :: ((k, b), (k, b)) -> ((k, b), (k, b)) -> ((k, b), (k, b))
merge1 ((k, b)
start1, (k, b)
end1) ((k, b)
start2, (k, b)
end2) =
        (forall k a. Ord k => (a -> k) -> a -> a -> a
Lists.minOn forall a b. (a, b) -> a
fst (k, b)
start1 (k, b)
start2, forall k a. Ord k => (a -> k) -> a -> a -> a
Lists.maxOn forall a b. (a, b) -> a
fst (k, b)
end1 (k, b)
end2)
    event_inst :: Event -> Instrument
event_inst = Patch -> Instrument
Types.patch_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Patch
Types.event_patch

-- * derive

-- These are mostly for testing, to find problems in performer output.

-- | Clear out all caches and rederive from scratch.
rederive :: Cmd.CmdT IO ()
rederive :: CmdT IO ()
rederive = do
    forall (m :: * -> *). M m => m ()
Cmd.invalidate_performances
    BlockId -> CmdT IO ()
Cmd.clear_im_cache forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block

compare_cached_events :: Cmd.M m => BlockId
    -> m [Either Simple.ScoreEvent Simple.ScoreEvent]
compare_cached_events :: forall (m :: * -> *).
M m =>
BlockId -> m [Either ScoreEvent ScoreEvent]
compare_cached_events BlockId
block_id = do
    Result
uncached <- forall (m :: * -> *). M m => BlockId -> m Result
PlayUtil.uncached_derive BlockId
block_id
    Result
cached <- forall (m :: * -> *). M m => BlockId -> m Result
PlayUtil.cached_derive BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Event] -> [Event] -> [Either ScoreEvent ScoreEvent]
diff (forall a. Stream a -> [a]
Stream.events_of (Result -> Stream Event
Derive.r_events Result
cached))
        (forall a. Stream a -> [a]
Stream.events_of (Result -> Stream Event
Derive.r_events Result
uncached))
    where
    diff :: [Event] -> [Event] -> [Either ScoreEvent ScoreEvent]
diff [Event]
e1 [Event]
e2 = forall a b. (a -> b -> Bool) -> [a] -> [b] -> [Either a b]
Lists.diffEither forall a. Eq a => a -> a -> Bool
(==)
        (forall a b. (a -> b) -> [a] -> [b]
map Event -> ScoreEvent
Simple.score_event [Event]
e1) (forall a b. (a -> b) -> [a] -> [b]
map Event -> ScoreEvent
Simple.score_event [Event]
e2)

derive :: Cmd.M m => BlockId -> m Derive.Result
derive :: forall (m :: * -> *). M m => BlockId -> m Result
derive = forall (m :: * -> *). M m => BlockId -> m Result
PlayUtil.cached_derive

uncached_derive :: Cmd.M m => BlockId -> m Derive.Result
uncached_derive :: forall (m :: * -> *). M m => BlockId -> m Result
uncached_derive = forall (m :: * -> *). M m => BlockId -> m Result
PlayUtil.uncached_derive

inverse_tempo_func :: Cmd.M m => RealTime
    -> m [(BlockId, [(TrackId, ScoreTime)])]
inverse_tempo_func :: forall (m :: * -> *).
M m =>
RealTime -> m [(BlockId, [(TrackId, TrackTime)])]
inverse_tempo_func RealTime
time = do
    Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
get forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [TrackWarp] -> InverseTempoFunction
TrackWarp.inverse_tempo_func (Performance -> [TrackWarp]
Cmd.perf_warps Performance
perf)
        Stop
Transport.StopAtEnd RealTime
time

-- * block

-- | Get this block's performance from the cache.
block_events :: Cmd.M m => BlockId -> m [LEvent.LEvent Score.Event]
block_events :: forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [LEvent Event] -> [LEvent Event]
normalize_events forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events_unnormalized

-- | 'normalize_events' is important for display, but I can't do it if I'm
-- going to pass to 'convert', because convert should do the normalization
-- itself.
block_events_unnormalized :: Cmd.M m => BlockId -> m [LEvent.LEvent Score.Event]
block_events_unnormalized :: forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events_unnormalized BlockId
block_id =
    forall a. Stream a -> [LEvent a]
Stream.to_list forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Stream Event
Derive.r_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Result
PlayUtil.cached_derive BlockId
block_id

block_uncached_events :: Cmd.M m => BlockId -> m [LEvent.LEvent Score.Event]
block_uncached_events :: forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_uncached_events BlockId
block_id = [LEvent Event] -> [LEvent Event]
normalize_events forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [LEvent a]
Stream.to_list
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Stream Event
Derive.r_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Result
uncached_derive BlockId
block_id

-- | Apply 'Score.normalize' to the events, so that they have their final
-- control positions and pitches.  Normally 'convert' does this, but if you
-- display it before convert it's nice to see the \"cooked\" versions.
normalize_events :: [LEvent.LEvent Score.Event] -> [LEvent.LEvent Score.Event]
normalize_events :: [LEvent Event] -> [LEvent Event]
normalize_events = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> Event
Score.normalize)

-- | Get 'block_events' from the cache and convert to MIDI performer events.
block_midi_events :: Cmd.M m => BlockId -> m [LEvent.LEvent Types.Event]
block_midi_events :: forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_midi_events BlockId
block_id =
    forall (m :: * -> *). M m => [Event] -> m [LEvent Event]
midi_convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. [LEvent d] -> [d]
LEvent.events_of forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events_unnormalized BlockId
block_id

-- | Derive all the way to MIDI.  This uses the cache.
block_midi :: Cmd.M m => BlockId -> m Perform.MidiEvents
block_midi :: forall (m :: * -> *). M m => BlockId -> m MidiEvents
block_midi BlockId
block_id = do
    State
state <- forall (m :: * -> *). M m => m State
Ui.get
    Performance
perf <- State -> Result -> Performance
Performance.performance State
state forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Result
PlayUtil.cached_derive BlockId
block_id
    forall (m :: * -> *). M m => [Event] -> m MidiEvents
PlayUtil.perform_raw forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
Vector.toList forall a b. (a -> b) -> a -> b
$ Performance -> Vector Event
Cmd.perf_events Performance
perf

-- * selection

-- | Derive the current block from the cache and return events that fall within
-- the current selection.
sel_events :: Cmd.M m => m [Score.Event]
sel_events :: forall (m :: * -> *). M m => m [Event]
sel_events = forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Local forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events

sel_midi_events :: Cmd.M m => m [LEvent.LEvent Types.Event]
sel_midi_events :: forall (m :: * -> *). M m => m [LEvent Event]
sel_midi_events =
    forall (m :: * -> *). M m => [Event] -> m [LEvent Event]
midi_convert forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Local forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events_unnormalized

sel_im_events :: Cmd.M m => m [LEvent.LEvent Shared.Note.Note]
sel_im_events :: forall (m :: * -> *). M m => m [LEvent Note]
sel_im_events = do
    BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    forall (m :: * -> *). M m => BlockId -> [Event] -> m [LEvent Note]
im_convert BlockId
block_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Local forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events_unnormalized

sel_sc_events :: Cmd.M m => m [LEvent.LEvent Sc.Note.Note]
sel_sc_events :: forall (m :: * -> *). M m => m [LEvent Note]
sel_sc_events = forall (m :: * -> *). M m => [Event] -> m [LEvent Note]
sc_convert forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Local forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events_unnormalized

-- | Show the low level events as seen by the sampler backend.
sel_sampler_events :: Source -> Cmd.CmdT IO Text
sel_sampler_events :: Source -> CmdT IO Text
sel_sampler_events Source
source = do
    (BlockId
block_id, [TrackId]
track_ids, RealTime
start, RealTime
end) <- forall (m :: * -> *).
M m =>
Source -> m (BlockId, [TrackId], RealTime, RealTime)
get_sel_ranges Source
source
    String
im_dir <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ Config -> String
Shared.Config.imDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Config
Cmd.config_im forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Cmd.state_config
    String
score_path <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> String
Cmd.score_path
    let notes_file :: String
notes_file = String -> String -> BlockId -> Synth -> String
Shared.Config.notesFilename String
im_dir String
score_path BlockId
block_id
            Synth
Shared.Config.sampler
    let args :: [String]
args =
            [ String
"dump"
            , String
"--range", forall a. Show a => a -> String
show RealTime
start forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show RealTime
end
            , String
"--tracks", Text -> String
untxt forall a b. (a -> b) -> a -> b
$
                Text -> [Text] -> Text
Text.intercalate Text
"," (forall a b. (a -> b) -> [a] -> [b]
map forall a. Ident a => a -> Text
Id.ident_text [TrackId]
track_ids)
            , String
notes_file
            ]
    Text
out <- String -> [String] -> CmdT IO Text
CmdUtil.read_process String
"build/opt/sampler-im" [String]
args
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords (Text
"%" forall a. a -> [a] -> [a]
: Text
"build/opt/sampler-im" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map String -> Text
txt [String]
args) forall a. Semigroup a => a -> a -> a
<> Text
"\n"
        forall a. Semigroup a => a -> a -> a
<> Text
out

-- | Like 'sel_events' but take the root derivation.
root_sel_events :: Cmd.M m => m [Score.Event]
root_sel_events :: forall (m :: * -> *). M m => m [Event]
root_sel_events = forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Root forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events

root_sel_midi_events :: Cmd.M m => m [LEvent.LEvent Types.Event]
root_sel_midi_events :: forall (m :: * -> *). M m => m [LEvent Event]
root_sel_midi_events =
    forall (m :: * -> *). M m => [Event] -> m [LEvent Event]
midi_convert forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Root forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events_unnormalized

root_sel_im_events :: Cmd.M m => m [LEvent.LEvent Shared.Note.Note]
root_sel_im_events :: forall (m :: * -> *). M m => m [LEvent Note]
root_sel_im_events = do
    BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Ui.get_root_id
    forall (m :: * -> *). M m => BlockId -> [Event] -> m [LEvent Note]
im_convert BlockId
block_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Root forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events_unnormalized

-- ** extract

-- | Get logged events with the given tag and instruments.
extract_insts :: Cmd.M m => BlockId -> Text -> [Text]
    -> m [(Text, [Score.Event])]
extract_insts :: forall (m :: * -> *).
M m =>
BlockId -> Text -> [Text] -> m [(Text, [Event])]
extract_insts BlockId
block_id Text
tag [Text]
insts =
    forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> [Event] -> [Event]
with_insts [Text]
insts forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> [Event]
strip_stack)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> Text -> m [(Text, [Event])]
extract_debug BlockId
block_id Text
tag

-- | Extract events logged via the @debug@ call.
extract_debug :: Cmd.M m => BlockId -> Text -> m [(Text, [Score.Event])]
    -- ^ logged events by the stack where they were logged
extract_debug :: forall (m :: * -> *). M m => BlockId -> Text -> m [(Text, [Event])]
extract_debug BlockId
block_id Text
tag = do
    [Msg]
logs <- forall d. [LEvent d] -> [Msg]
LEvent.logs_of forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (Msg -> Text
stack Msg
log, [Event]
events)
        | (Msg
log, Just [Event]
events) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Msg]
logs (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Typeable a => Text -> Msg -> Maybe a
Log.lookup_dyn Text
tag) [Msg]
logs)
        ]
    where
    stack :: Msg -> Text
stack = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Stack -> Text
Stack.pretty_ui forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Maybe Stack
Log.msg_stack

control :: ScoreT.Control -> Score.Event -> Maybe (ScoreT.Typed Signal.Y)
control :: Control -> Event -> Maybe (Typed Y)
control Control
c Event
e = RealTime -> Control -> Event -> Maybe (Typed Y)
Score.control_at (Event -> RealTime
Score.event_start Event
e) Control
c Event
e

event_controls :: Score.Event -> ScoreT.ControlValMap
event_controls :: Event -> ControlValMap
event_controls Event
e = RealTime -> Event -> ControlValMap
Score.event_controls_at (Event -> RealTime
Score.event_start Event
e) Event
e

only_keys :: [Env.Key] -> [LEvent.LEvent Score.Event] -> [Score.Event]
only_keys :: [Text] -> [LEvent Event] -> [Event]
only_keys [Text]
keys = forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. [LEvent d] -> [d]
LEvent.events_of
    where
    strip :: Event -> Event
strip = (Environ -> Environ) -> Event -> Event
Score.modify_environ forall a b. (a -> b) -> a -> b
$
        Map Text Val -> Environ
Env.from_map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (forall a. Ord a => [a] -> Set a
Set.fromList [Text]
keys) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> Map Text Val
Env.to_map

with_insts :: [Text] -> [Score.Event] -> [Score.Event]
with_insts :: [Text] -> [Event] -> [Event]
with_insts [Text]
instruments = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Instrument]
is) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument)
    where is :: [Instrument]
is = forall a b. (a -> b) -> [a] -> [b]
map Text -> Instrument
Util.instrument [Text]
instruments

strip_stack :: [Score.Event] -> [Score.Event]
strip_stack :: [Event] -> [Event]
strip_stack = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \Event
event -> Event
event { event_stack :: Stack
Score.event_stack = Stack
Stack.empty }

strip_env :: [Score.Event] -> [Score.Event]
strip_env :: [Event] -> [Event]
strip_env = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \Event
event -> Event
event { event_environ :: Environ
Score.event_environ = forall a. Monoid a => a
mempty }

-- | Pretty-print events, presumably from 'sel_events'.  Extract the given
-- fields, and format them in columns.
--
-- There are a set of e_* functions designed for this.  E.g.
--
-- > LPerf.sel_events $> LPerf.e [LPerf.e_sp, LPerf.e_attr]
e :: [Fmt] -> [Score.Event] -> Text
e :: [Fmt] -> [Event] -> Text
e [Fmt]
extract = [Text] -> Text
Text.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[Text]] -> [Text]
Texts.columns Int
1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Event
event -> forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$Event
event) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Fmt]
extract))

-- | LPerf.en LPerf.sel_events
en :: Functor f => f [Score.Event] -> f Text
en :: forall (f :: * -> *). Functor f => f [Event] -> f Text
en = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Fmt] -> [Event] -> Text
e [Fmt
e_note])

type Fmt = [Score.Event -> Text]

-- Start, dur, text.
e_sdt, e_sd, e_sp, e_s :: Fmt
e_sdt :: Fmt
e_sdt = Fmt
e_sd forall a. [a] -> [a] -> [a]
++ [forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Text
Score.event_text]
e_sd :: Fmt
e_sd = [forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start, forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_duration]
e_sp :: Fmt
e_sp = Fmt
e_s forall a. [a] -> [a] -> [a]
++ Fmt
e_pitch
e_s :: Fmt
e_s = [forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start]

e_note :: Fmt
e_note :: Fmt
e_note = Fmt
e_sd forall a. [a] -> [a] -> [a]
++ Fmt
e_pitch forall a. [a] -> [a] -> [a]
++ Fmt
e_attr

e_pitch, e_attr, e_inst, e_env :: Fmt
e_pitch :: Fmt
e_pitch = [forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"?" forall a. RawPitch a -> Text
PSignal.symbolic_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Maybe Transposed
Score.initial_pitch]
e_attr :: Fmt
e_attr = [forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Attributes
Score.event_attributes]
e_inst :: Fmt
e_inst = [forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument]
e_env :: Fmt
e_env = [forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
Score.event_environ]

e_env_like, e_env_k :: Text -> Fmt
e_env_like :: Text -> Fmt
e_env_like Text
key = [forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((Text
key `Text.isInfixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> [(Text, Val)]
Env.to_list
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
Score.event_environ]
e_env_k :: Text -> Fmt
e_env_k Text
key = [forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Environ -> Maybe Val
Env.lookup Text
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
Score.event_environ]

-- * play from

events_from :: Cmd.M m => m (Vector.Vector Score.Event)
events_from :: forall (m :: * -> *). M m => m (Vector Event)
events_from = do
    (BlockId
block_id, Int
_, TrackId
track_id, TrackTime
pos) <- forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    RealTime
start <- forall (m :: * -> *).
M m =>
Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
Perf.get_realtime Performance
perf BlockId
block_id (forall a. a -> Maybe a
Just TrackId
track_id) TrackTime
pos
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Set Instrument
-> RealTime -> Vector Event -> ([Event], Vector Event)
PlayUtil.events_from forall a. Monoid a => a
mempty RealTime
start (Performance -> Vector Event
Cmd.perf_events Performance
perf)

perform_from :: Cmd.M m => m (Perform.MidiEvents, [LEvent.LEvent Sc.Note.Note])
perform_from :: forall (m :: * -> *). M m => m (MidiEvents, [LEvent Note])
perform_from = do
    (BlockId
block_id, Int
_, TrackId
track_id, TrackTime
pos) <- forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    RealTime
start <- forall (m :: * -> *).
M m =>
Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
Perf.get_realtime Performance
perf BlockId
block_id (forall a. a -> Maybe a
Just TrackId
track_id) TrackTime
pos
    forall (m :: * -> *).
M m =>
RealTime -> Vector Event -> m (MidiEvents, [LEvent Note])
PlayUtil.perform_from RealTime
start (Performance -> Vector Event
Cmd.perf_events Performance
perf)

-- ** implementation

-- | Like 'get_sel_events_logs', but filter out the LEvent.Logs.
get_sel_events :: Cmd.M m => Source
    -> (BlockId -> m [LEvent.LEvent Score.Event]) -> m [Score.Event]
get_sel_events :: forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
source =
    forall (m :: * -> *) d. LogMonad m => [LEvent d] -> m [d]
LEvent.write_logs forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) d.
M m =>
(d -> RealTime)
-> (d -> Stack)
-> Source
-> (BlockId -> m [LEvent d])
-> m [LEvent d]
get_sel Event -> RealTime
Score.event_start Event -> Stack
Score.event_stack Source
source


-- | Get events derived in the selected range.
get_sel_events_logs :: Cmd.M m => Source
    -> (BlockId -> m [LEvent.LEvent Score.Event]) -- ^ derive events in the
    -- given block, e.g. via 'block_events' or 'block_events_unnormalized'
    -> m [LEvent.LEvent Score.Event]
get_sel_events_logs :: forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [LEvent Event]
get_sel_events_logs = forall (m :: * -> *) d.
M m =>
(d -> RealTime)
-> (d -> Stack)
-> Source
-> (BlockId -> m [LEvent d])
-> m [LEvent d]
get_sel Event -> RealTime
Score.event_start Event -> Stack
Score.event_stack

get_sel :: Cmd.M m => (d -> RealTime) -> (d -> Stack.Stack)
    -> Source -> (BlockId -> m [LEvent.LEvent d]) -> m [LEvent.LEvent d]
get_sel :: forall (m :: * -> *) d.
M m =>
(d -> RealTime)
-> (d -> Stack)
-> Source
-> (BlockId -> m [LEvent d])
-> m [LEvent d]
get_sel d -> RealTime
event_start d -> Stack
event_stack Source
source BlockId -> m [LEvent d]
derive_events = do
    (BlockId
block_id, [TrackId]
track_ids, RealTime
start, RealTime
end) <- forall (m :: * -> *).
M m =>
Source -> m (BlockId, [TrackId], RealTime, RealTime)
get_sel_ranges Source
source
    [LEvent d]
events <- BlockId -> m [LEvent d]
derive_events BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall d. (d -> Stack) -> [TrackId] -> [LEvent d] -> [LEvent d]
in_tracks d -> Stack
event_stack [TrackId]
track_ids forall a b. (a -> b) -> a -> b
$
        forall a.
(a -> RealTime) -> RealTime -> RealTime -> [LEvent a] -> [LEvent a]
in_range d -> RealTime
event_start RealTime
start RealTime
end [LEvent d]
events

get_sel_ranges :: Cmd.M m => Source
    -> m (BlockId, [TrackId], RealTime, RealTime)
get_sel_ranges :: forall (m :: * -> *).
M m =>
Source -> m (BlockId, [TrackId], RealTime, RealTime)
get_sel_ranges Source
source = do
    (BlockId
block_id, RealTime
start, RealTime
end) <- case Source
source of
        Source
Root -> forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.realtime
        Source
Local -> forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.local_realtime
    [TrackId]
track_ids <- forall (m :: * -> *). M m => m [TrackId]
Selection.track_ids
    forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, [TrackId]
track_ids, RealTime
start, RealTime
end)

score_in_selection :: [TrackId] -> RealTime -> RealTime
    -> [LEvent.LEvent Score.Event] -> [LEvent.LEvent Score.Event]
score_in_selection :: [TrackId]
-> RealTime -> RealTime -> [LEvent Event] -> [LEvent Event]
score_in_selection [TrackId]
track_ids RealTime
start RealTime
end =
    forall d. (d -> Stack) -> [TrackId] -> [LEvent d] -> [LEvent d]
in_tracks Event -> Stack
Score.event_stack [TrackId]
track_ids
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(a -> RealTime) -> RealTime -> RealTime -> [LEvent a] -> [LEvent a]
in_range Event -> RealTime
Score.event_start RealTime
start RealTime
end

in_tracks :: (d -> Stack.Stack) -> [TrackId] -> [LEvent.LEvent d]
    -> [LEvent.LEvent d]
in_tracks :: forall d. (d -> Stack) -> [TrackId] -> [LEvent d] -> [LEvent d]
in_tracks d -> Stack
event_stack [TrackId]
track_ids =
    forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ forall d. (d -> Bool) -> LEvent d -> Bool
LEvent.log_or (forall {t :: * -> *}. Foldable t => t TrackId -> Bool
has forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [TrackId]
tracks_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Stack
event_stack)
    where
    tracks_of :: Stack -> [TrackId]
tracks_of = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Frame -> Maybe TrackId
Stack.track_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
Stack.innermost
    has :: t TrackId -> Bool
has t TrackId
tids = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t TrackId
tids) [TrackId]
track_ids

in_range :: (a -> RealTime) -> RealTime -> RealTime -> [LEvent.LEvent a]
    -> [LEvent.LEvent a]
in_range :: forall a.
(a -> RealTime) -> RealTime -> RealTime -> [LEvent a] -> [LEvent a]
in_range a -> RealTime
start_of RealTime
start RealTime
end =
    forall a. (a -> Bool) -> [LEvent a] -> [LEvent a]
LEvent.take_while ((forall a. Ord a => a -> a -> Bool
<RealTime
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RealTime
start_of)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [LEvent a] -> [LEvent a]
LEvent.drop_while (forall {a}. (Num a, Ord a) => a -> a -> Bool
before RealTime
start forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RealTime
start_of)
    where
    before :: a -> a -> Bool
before a
start a
ts
        -- I can't put a selection before 0, so assume that means I want
        -- everything before 0 too.
        | a
start forall a. Eq a => a -> a -> Bool
== a
0 = Bool
False
        | Bool
otherwise = a
ts forall a. Ord a => a -> a -> Bool
< a
start

-- | Like 'in_range', but use the stack to check for ScoreTime range.
in_score_range :: (a -> Stack.Stack) -> [BlockId] -> [TrackId]
    -> ScoreTime -> ScoreTime -> [LEvent.LEvent a] -> [LEvent.LEvent a]
in_score_range :: forall a.
(a -> Stack)
-> [BlockId]
-> [TrackId]
-> TrackTime
-> TrackTime
-> [LEvent a]
-> [LEvent a]
in_score_range a -> Stack
stack_of [BlockId]
block_ids [TrackId]
track_ids TrackTime
start TrackTime
end = forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ forall d. (d -> Bool) -> LEvent d -> Bool
LEvent.log_or forall a b. (a -> b) -> a -> b
$
    [BlockId] -> [TrackId] -> TrackTime -> TrackTime -> Stack -> Bool
stack_in_score_range [BlockId]
block_ids [TrackId]
track_ids TrackTime
start TrackTime
end forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Stack
stack_of

stack_in_score_range :: [BlockId] -> [TrackId] -> ScoreTime -> ScoreTime
    -> Stack.Stack -> Bool
stack_in_score_range :: [BlockId] -> [TrackId] -> TrackTime -> TrackTime -> Stack -> Bool
stack_in_score_range [BlockId]
block_ids [TrackId]
track_ids TrackTime
start TrackTime
end = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe BlockId, Maybe TrackId, Maybe (TrackTime, TrackTime))
-> Bool
match forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack
-> [(Maybe BlockId, Maybe TrackId, Maybe (TrackTime, TrackTime))]
Stack.to_ui
    where
    match :: (Maybe BlockId, Maybe TrackId, Maybe (TrackTime, TrackTime))
-> Bool
match (Just BlockId
block_id, Just TrackId
track_id, Just (TrackTime
s, TrackTime
e)) =
        BlockId
block_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BlockId]
block_ids Bool -> Bool -> Bool
&& TrackId
track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TrackId]
track_ids
        Bool -> Bool -> Bool
&& Bool -> Bool
not (TrackTime
end forall a. Ord a => a -> a -> Bool
<= TrackTime
s Bool -> Bool -> Bool
|| TrackTime
start forall a. Ord a => a -> a -> Bool
>= TrackTime
e)
    match (Maybe BlockId, Maybe TrackId, Maybe (TrackTime, TrackTime))
_ = Bool
False

-- * Midi.Types.Event

midi_convert :: Cmd.M m => [Score.Event] -> m [LEvent.LEvent Types.Event]
midi_convert :: forall (m :: * -> *). M m => [Event] -> m [LEvent Event]
midi_convert [Event]
events = do
    Instrument -> Maybe ResolvedInstrument
lookup_inst <- forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
Cmd.get_lookup_instrument
    let lookup :: MidiLookup
lookup = (Instrument -> Maybe ResolvedInstrument) -> MidiLookup
PlayUtil.make_midi_lookup Instrument -> Maybe ResolvedInstrument
lookup_inst
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime
-> MidiLookup
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> [LEvent Event]
Midi.Convert.convert RealTime
Midi.Convert.default_srate MidiLookup
lookup Instrument -> Maybe ResolvedInstrument
lookup_inst
        [Event]
events

im_convert :: Cmd.M m => BlockId -> [Score.Event]
    -> m [LEvent.LEvent Shared.Note.Note]
im_convert :: forall (m :: * -> *). M m => BlockId -> [Event] -> m [LEvent Note]
im_convert BlockId
block_id [Event]
events = do
    Instrument -> Maybe ResolvedInstrument
lookup_inst <- forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
Cmd.get_lookup_instrument
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BlockId
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> [LEvent Note]
Im.Convert.convert BlockId
block_id Instrument -> Maybe ResolvedInstrument
lookup_inst [Event]
events

sc_convert :: Cmd.M m => [Score.Event] -> m [LEvent.LEvent Sc.Note.Note]
sc_convert :: forall (m :: * -> *). M m => [Event] -> m [LEvent Note]
sc_convert [Event]
events = do
    Instrument -> Maybe ResolvedInstrument
lookup_inst <- forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
Cmd.get_lookup_instrument
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> [LEvent Note]
Sc.Convert.convert RealTime
Sc.Convert.default_srate Instrument -> Maybe ResolvedInstrument
lookup_inst [Event]
events

-- | Filter on events with a certain instrument.
midi_event_inst :: Types.Event -> Text
midi_event_inst :: Event -> Text
midi_event_inst = Instrument -> Text
ScoreT.instrument_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Instrument
Types.patch_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Patch
Types.event_patch

-- * midi

perform_events :: Cmd.M m => [LEvent.LEvent Score.Event] -> m Perform.MidiEvents
perform_events :: forall (m :: * -> *). M m => [LEvent Event] -> m MidiEvents
perform_events = forall (m :: * -> *). M m => [Event] -> m MidiEvents
PlayUtil.perform_raw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. [LEvent d] -> [d]
LEvent.events_of

perform_midi_events :: Ui.M m => [LEvent.LEvent Types.Event]
    -> m Perform.MidiEvents
perform_midi_events :: forall (m :: * -> *). M m => [LEvent Event] -> m MidiEvents
perform_midi_events [LEvent Event]
events = do
    Allocations
allocs <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets forall a b. (a -> b) -> a -> b
$ Config -> Allocations
UiConfig.config_allocations forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Ui.state_config
    let midi_allocs :: Map Instrument Config
midi_allocs = Config -> Config
Perform.config forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Allocations -> Map Instrument Config
PlayUtil.midi_configs Allocations
allocs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ State
-> Map Instrument Config -> [LEvent Event] -> (MidiEvents, State)
Perform.perform State
Perform.initial_state Map Instrument Config
midi_allocs [LEvent Event]
events

-- | This is the local block's performance, and the events are filtered to the
-- selection range, and the filtering is done post-derivation, so they reflect
-- what would actually be played.  I can't filter by selected track because
-- MIDI events don't retain the stack.
sel_midi :: Cmd.M m => m Perform.MidiEvents
sel_midi :: forall (m :: * -> *). M m => m MidiEvents
sel_midi = forall (m :: * -> *). M m => Source -> m MidiEvents
get_sel_midi Source
Local

-- | Analyze a section of MIDI for debugging.
analyze_midi :: [LEvent.LEvent Midi.WriteMessage] -> Text
analyze_midi :: MidiEvents -> Text
analyze_midi =
    State -> Text
Synth.pretty_state forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> [WriteMessage] -> State
Synth.run State
Synth.empty_state forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. [LEvent d] -> [d]
LEvent.events_of

root_sel_midi :: Cmd.M m => m Perform.MidiEvents
root_sel_midi :: forall (m :: * -> *). M m => m MidiEvents
root_sel_midi = forall (m :: * -> *). M m => Source -> m MidiEvents
get_sel_midi Source
Root

get_sel_midi :: Cmd.M m => Source -> m Perform.MidiEvents
get_sel_midi :: forall (m :: * -> *). M m => Source -> m MidiEvents
get_sel_midi Source
source = do
    (BlockId
block_id, RealTime
start, RealTime
end) <- case Source
source of
        Source
Root -> forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.realtime
        Source
Local -> forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.local_realtime
    MidiEvents
events <- forall (m :: * -> *). M m => BlockId -> m MidiEvents
block_midi BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
(a -> RealTime) -> RealTime -> RealTime -> [LEvent a] -> [LEvent a]
in_range WriteMessage -> RealTime
Midi.wmsg_ts RealTime
start RealTime
end MidiEvents
events

-- | Get all logs whose 'Log.msg_text' matches a regex.
logs_like :: Cmd.M m => BlockId -> String -> m [Log.Msg]
logs_like :: forall (m :: * -> *). M m => BlockId -> String -> m [Msg]
logs_like BlockId
block_id String
regex = do
    [Msg]
logs <- forall d. [LEvent d] -> [Msg]
LEvent.logs_of forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m MidiEvents
block_midi BlockId
block_id
    let reg :: Regex
reg = Stack => String -> Regex
Regex.compileUnsafe String
regex
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Regex -> Text -> Bool
Regex.matches Regex
reg forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Text
Log.msg_text) [Msg]
logs

-- | Get logs that include a stack frame that matches the given block, tracks,
-- and range.
logs_matching :: Cmd.M m => BlockId -> BlockId -> [TrackId] -> TrackTime
    -> TrackTime -> m [Log.Msg]
logs_matching :: forall (m :: * -> *).
M m =>
BlockId
-> BlockId -> [TrackId] -> TrackTime -> TrackTime -> m [Msg]
logs_matching BlockId
perf_block BlockId
block_id [TrackId]
track_ids TrackTime
start TrackTime
end = do
    [Msg]
logs <- forall d. [LEvent d] -> [Msg]
LEvent.logs_of forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m MidiEvents
block_midi BlockId
perf_block
    let pattern :: (Maybe BlockId, Maybe (Set TrackId), Maybe (TrackTime, TrackTime))
pattern = (forall a. a -> Maybe a
Just BlockId
block_id, forall a. a -> Maybe a
Just (forall a. Ord a => [a] -> Set a
Set.fromList [TrackId]
track_ids),
            forall a. a -> Maybe a
Just (TrackTime
start, TrackTime
end))
        match :: Msg -> Bool
match = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Maybe BlockId, Maybe (Set TrackId), Maybe (TrackTime, TrackTime))
-> Stack -> Bool
Stack.match (Maybe BlockId, Maybe (Set TrackId), Maybe (TrackTime, TrackTime))
pattern) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Maybe Stack
Log.msg_stack
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Msg -> Bool
match [Msg]
logs

play_midi :: Cmd.M m => Perform.MidiEvents -> m ()
play_midi :: forall (m :: * -> *). M m => MidiEvents -> m ()
play_midi MidiEvents
msgs = forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_repl_status :: Status
Cmd.state_repl_status = Status
status }
    where
    to_zero :: MidiEvents -> MidiEvents
to_zero MidiEvents
msgs = RealTime -> RealTime -> MidiEvents -> MidiEvents
PlayUtil.shift_midi RealTime
1 (MidiEvents -> RealTime
PlayUtil.first_time MidiEvents
msgs) MidiEvents
msgs
    status :: Status
status = PlayArgs -> Status
Cmd.Play forall a b. (a -> b) -> a -> b
$ Cmd.PlayArgs
        { play_sync :: Maybe SyncConfig
play_sync = forall a. Maybe a
Nothing
        , play_name :: Text
play_name = Text
"repl"
        , play_midi :: MidiEvents
play_midi = MidiEvents -> MidiEvents
to_zero MidiEvents
msgs
        , play_sc :: PlayNotes
play_sc = Sc.Note.PlayNotes { shift :: RealTime
shift = RealTime
0, stretch :: RealTime
stretch = RealTime
1, notes :: [LEvent Note]
notes =  [] }
        , play_inv_tempo :: Maybe InverseTempoFunction
play_inv_tempo = forall a. Maybe a
Nothing
        , play_repeat_at :: Maybe RealTime
play_repeat_at = forall a. Maybe a
Nothing
        , play_im_end :: Maybe RealTime
play_im_end = forall a. Maybe a
Nothing
        , play_im_direct :: Maybe PlayDirectArgs
play_im_direct = forall a. Maybe a
Nothing
        }

-- ** extract

with_chans :: [Midi.Channel] -> [Midi.WriteMessage] -> [Midi.WriteMessage]
with_chans :: [Channel] -> [WriteMessage] -> [WriteMessage]
with_chans [Channel]
chans = forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [Channel]
chans) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Maybe Channel
Midi.message_channel
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriteMessage -> Message
Midi.wmsg_msg

-- | Reduce MIDI to an easier to read form.
simple_midi :: [Midi.WriteMessage] -> [(RealTime, Midi.Message)]
simple_midi :: [WriteMessage] -> [(RealTime, Message)]
simple_midi = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \WriteMessage
wmsg -> (WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
wmsg, WriteMessage -> Message
Midi.wmsg_msg WriteMessage
wmsg)


-- ** cache contents

get_cache :: Cmd.M m => BlockId -> m (Map Derive.CacheKey Derive.Cached)
get_cache :: forall (m :: * -> *). M m => BlockId -> m (Map CacheKey Cached)
get_cache BlockId
block_id = do
    Derive.Cache Map CacheKey Cached
cache <- Performance -> Cache
Cmd.perf_derive_cache forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return Map CacheKey Cached
cache

get_cache_events :: (Cache.Cacheable d, Cmd.M m) => BlockId
    -> m (Map Derive.CacheKey [LEvent.LEvent d])
get_cache_events :: forall d (m :: * -> *).
(Cacheable d, M m) =>
BlockId -> m (Map CacheKey [LEvent d])
get_cache_events BlockId
block_id = do
    Map CacheKey Cached
cache <- forall (m :: * -> *). M m => BlockId -> m (Map CacheKey Cached)
get_cache BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Stream a -> [LEvent a]
Stream.to_list forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe forall {d}. Cacheable d => Cached -> Maybe (Stream d)
get Map CacheKey Cached
cache
    where
    get :: Cached -> Maybe (Stream d)
get Cached
Derive.Invalid = forall a. Maybe a
Nothing
    get (Derive.Cached CacheEntry
c) = case forall d. Cacheable d => CacheEntry -> Maybe (CallType d)
Cache.from_cache_entry CacheEntry
c of
        Maybe (CallType d)
Nothing -> forall a. Maybe a
Nothing
        Just (Derive.CallType Collect
_ Stream d
events) -> forall a. a -> Maybe a
Just Stream d
events

show_cache :: Cmd.M m => BlockId -> m Text
show_cache :: forall (m :: * -> *). M m => BlockId -> m Text
show_cache BlockId
block_id = do
    Performance
perf <- forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Cache -> Text
Cache.pretty_cache (Performance -> Cache
Cmd.perf_derive_cache Performance
perf)

entry_events :: Derive.CacheEntry -> Int
entry_events :: CacheEntry -> Int
entry_events CacheEntry
entry = case CacheEntry
entry of
    Derive.CachedEvents (Derive.CallType Collect
_ Stream Event
events) -> forall a. Stream a -> Int
Stream.length Stream Event
events
    Derive.CachedControl (Derive.CallType Collect
_ Stream (Signal ControlSig)
events) -> forall a. Stream a -> Int
Stream.length Stream (Signal ControlSig)
events
    Derive.CachedPitch (Derive.CallType Collect
_ Stream PSignal
events) -> forall a. Stream a -> Int
Stream.length Stream PSignal
events


-- * pitches

type Ratio = Ratio.Rational

-- | A hook for 'Cmd.hooks_selection'.
chord_hook :: Cmd.M m => [(ViewId, Maybe Cmd.TrackSelection)] -> m ()
chord_hook :: forall (m :: * -> *).
M m =>
[(ViewId, Maybe TrackSelection)] -> m ()
chord_hook = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *). M m => ViewId -> Maybe TrackSelection -> m ()
set_chord_status)

-- | Show chord ratios at current selection.
chord :: Cmd.M m => m Text
chord :: forall (m :: * -> *). M m => m Text
chord = do
    (ViewId
view_id, Selection
sel) <- forall (m :: * -> *). M m => m (ViewId, Selection)
Selection.get_view_sel
    BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    Maybe TrackId
maybe_track_id <- forall (m :: * -> *). M m => BlockId -> Int -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id (Selection -> Int
Selection.sel_point_track Selection
sel)
    [(NoteNumber, Note, Ratio)] -> Text
show_chord forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
BlockId
-> Maybe TrackId -> TrackTime -> m [(NoteNumber, Note, Ratio)]
chord_at BlockId
block_id Maybe TrackId
maybe_track_id (Selection -> TrackTime
Selection.sel_point Selection
sel)

show_chord :: [(Pitch.NoteNumber, Pitch.Note, Ratio)] -> Text
show_chord :: [(NoteNumber, Note, Ratio)] -> Text
show_chord = Text -> [Text] -> Text
Text.intercalate Text
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (a, Note, Ratio) -> Text
pretty
    where
    pretty :: (a, Note, Ratio) -> Text
pretty (a
_, Note
note, Ratio
ratio) = Note -> Text
Pitch.note_text Note
note forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Ratio -> Text
show_ratio Ratio
ratio

show_ratio :: Ratio -> Text
show_ratio :: Ratio -> Text
show_ratio = forall {a} {a}.
(Integral a, Num a, Show a, Show a, Eq a) =>
a -> Ratio a -> Text
go Integer
0
    where
    go :: a -> Ratio a -> Text
go a
oct Ratio a
ratio
        | Ratio a
ratio forall a. Ord a => a -> a -> Bool
>= Ratio a
2 = a -> Ratio a -> Text
go (a
octforall a. Num a => a -> a -> a
+a
1) (Ratio a
ratioforall a. Fractional a => a -> a -> a
/Ratio a
2)
        | Ratio a
ratio forall a. Ord a => a -> a -> Bool
<= a
1forall a. Integral a => a -> a -> Ratio a
%a
2 = a -> Ratio a -> Text
go (a
octforall a. Num a => a -> a -> a
-a
1) (Ratio a
ratioforall a. Num a => a -> a -> a
*Ratio a
2)
        | a
oct forall a. Eq a => a -> a -> Bool
== a
0 = forall {a}. Show a => Ratio a -> Text
pretty Ratio a
ratio
        | Bool
otherwise = forall a. Show a => a -> Text
showt a
oct forall a. Semigroup a => a -> a -> a
<> Text
"+" forall a. Semigroup a => a -> a -> a
<> forall {a}. Show a => Ratio a -> Text
pretty Ratio a
ratio
    pretty :: Ratio a -> Text
pretty Ratio a
ratio =
        forall a. Show a => a -> Text
showt (forall a. Ratio a -> a
Ratio.numerator Ratio a
ratio) forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall a. Ratio a -> a
Ratio.denominator Ratio a
ratio)

set_chord_status :: Cmd.M m => ViewId -> Maybe Cmd.TrackSelection -> m ()
set_chord_status :: forall (m :: * -> *). M m => ViewId -> Maybe TrackSelection -> m ()
set_chord_status ViewId
view_id Maybe TrackSelection
maybe_sel = case Maybe TrackSelection
maybe_sel of
    Maybe TrackSelection
Nothing -> Maybe Text -> m ()
set forall a. Maybe a
Nothing
    Just (Selection
sel, BlockId
block_id, Maybe TrackId
maybe_track_id) ->
        Maybe Text -> m ()
set forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(NoteNumber, Note, Ratio)] -> Text
show_chord
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
BlockId
-> Maybe TrackId -> TrackTime -> m [(NoteNumber, Note, Ratio)]
chord_at BlockId
block_id Maybe TrackId
maybe_track_id (Selection -> TrackTime
Selection.sel_point Selection
sel)
    where set :: Maybe Text -> m ()
set = forall (m :: * -> *).
M m =>
ViewId -> (Int, Text) -> Maybe Text -> m ()
Cmd.set_view_status ViewId
view_id (Int, Text)
Config.status_chord

-- | Show the ratios of the frequencies of the notes at the time of the current
-- selection.  They are sorted by their track-order, and the track with the
-- selection is considered unity.
chord_at :: Cmd.M m => BlockId -> Maybe TrackId -> ScoreTime
    -> m [(Pitch.NoteNumber, Pitch.Note, Ratio)]
chord_at :: forall (m :: * -> *).
M m =>
BlockId
-> Maybe TrackId -> TrackTime -> m [(NoteNumber, Note, Ratio)]
chord_at BlockId
block_id Maybe TrackId
maybe_track_id TrackTime
pos = do
    Performance
perf <- forall (m :: * -> *). M m => m Performance
Perf.get_root
    RealTime
pos <- forall (m :: * -> *).
M m =>
Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
Perf.get_realtime Performance
perf BlockId
block_id Maybe TrackId
maybe_track_id TrackTime
pos
    [Event]
events <- RealTime -> Vector Event -> [Event]
PlayUtil.overlapping_events RealTime
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. Performance -> Vector Event
Cmd.perf_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Performance
get BlockId
block_id
    [Event]
events <- forall (m :: * -> *). M m => BlockId -> [Event] -> m [Event]
sort_by_track BlockId
block_id [Event]
events
    let selected :: Maybe Event
selected = do
            TrackId
track_id <- Maybe TrackId
maybe_track_id
            forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (TrackId -> Event -> Bool
on_track TrackId
track_id) [Event]
events
    let nns :: [NoteNumber]
nns = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime -> Event -> Maybe NoteNumber
Score.nn_at RealTime
pos) [Event]
events
        notes :: [Note]
notes = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime -> Event -> Maybe Note
Score.note_at RealTime
pos) [Event]
events
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
List.zip3 [NoteNumber]
nns [Note]
notes (Maybe NoteNumber -> [NoteNumber] -> [Ratio]
nn_ratios (RealTime -> Event -> Maybe NoteNumber
Score.nn_at RealTime
pos forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Event
selected) [NoteNumber]
nns)
    where
    on_track :: TrackId -> Event -> Bool
on_track TrackId
track_id = (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TrackId
track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Stack
Score.event_stack

-- | Sort events by the tracknum of the tracks they fall on.  Filter out
-- events that don't directly originate from a track on the given block.
--
-- TODO I should look for the block anywhere in the stack, and sort it by the
-- corresponding track.
sort_by_track :: Ui.M m => BlockId -> [Score.Event] -> m [Score.Event]
sort_by_track :: forall (m :: * -> *). M m => BlockId -> [Event] -> m [Event]
sort_by_track BlockId
block_id [Event]
events = do
    let by_track :: [(TrackId, Event)]
by_track = forall a k. (a -> Maybe k) -> [a] -> [(k, a)]
Lists.keyOnJust
            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Stack
Score.event_stack) [Event]
events
    [Maybe Int]
tracknums <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). M m => BlockId -> TrackId -> m (Maybe Int)
Ui.tracknum_of BlockId
block_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(TrackId, Event)]
by_track
    let by_tracknum :: [(Int, Event)]
by_tracknum = [(Int
tracknum, Event
event)
            | (Just Int
tracknum, Event
event) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe Int]
tracknums (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(TrackId, Event)]
by_track)]
    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) -> b
snd forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn forall a b. (a, b) -> a
fst [(Int, Event)]
by_tracknum

nn_ratios :: Maybe Pitch.NoteNumber -> [Pitch.NoteNumber] -> [Ratio]
nn_ratios :: Maybe NoteNumber -> [NoteNumber] -> [Ratio]
nn_ratios Maybe NoteNumber
unity [NoteNumber]
nns = case (Maybe NoteNumber
unity, [NoteNumber]
nns) of
    (Just NoteNumber
unity, [NoteNumber]
nns) -> NoteNumber -> [NoteNumber] -> [Ratio]
ratios NoteNumber
unity [NoteNumber]
nns
    (Maybe NoteNumber
Nothing, NoteNumber
nn : [NoteNumber]
nns) -> NoteNumber -> [NoteNumber] -> [Ratio]
ratios NoteNumber
nn [NoteNumber]
nns
    (Maybe NoteNumber
_, []) -> []
    where
    ratios :: NoteNumber -> [NoteNumber] -> [Ratio]
ratios NoteNumber
unity = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. RealFrac a => a -> a -> Ratio
Ratio.approxRational Y
0.01 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/ NoteNumber -> Y
hz NoteNumber
unity) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteNumber -> Y
hz)
    hz :: NoteNumber -> Y
hz = NoteNumber -> Y
Pitch.nn_to_hz

overlapping_events :: Cmd.M m => Source -> m (RealTime, [Score.Event])
overlapping_events :: forall (m :: * -> *). M m => Source -> m (RealTime, [Event])
overlapping_events Source
source = do
    (BlockId
block_id, RealTime
start, RealTime
_) <- case Source
source of
        Source
Root -> forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.realtime
        Source
Local -> forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.local_realtime
    [Event]
events <- RealTime -> Vector Event -> [Event]
PlayUtil.overlapping_events RealTime
start forall b c a. (b -> c) -> (a -> b) -> a -> c
. Performance -> Vector Event
Cmd.perf_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *). M m => BlockId -> m Performance
get BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime
start, [Event]
events)