-- 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 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.Log as Log
import qualified Util.Regex as Regex
import qualified Util.Seq as Seq
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.DeriveT as DeriveT
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 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.Ruler as Ruler
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
(Int -> Source -> ShowS)
-> (Source -> String) -> ([Source] -> ShowS) -> Show Source
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 = m Performance
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 = BlockId -> m Performance
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 = Text -> Maybe Performance -> m Performance
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"no performance for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
forall a. Pretty a => a -> Text
pretty BlockId
block_id)
    (Maybe Performance -> m Performance)
-> m (Maybe Performance) -> m Performance
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId -> Map BlockId Performance -> Maybe Performance
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id (Map BlockId Performance -> Maybe Performance)
-> m (Map BlockId Performance) -> m (Maybe Performance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (State -> Map BlockId Performance) -> m (Map BlockId Performance)
forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (PlayState -> Map BlockId Performance
Cmd.state_current_performance (PlayState -> Map BlockId Performance)
-> (State -> PlayState) -> State -> Map BlockId Performance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
Cmd.state_play)

-- * info

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

-- | Controls in scope at the insert point.
controls :: Cmd.M m => Source -> m DeriveT.ControlMap
controls :: forall (m :: * -> *). M m => Source -> m ControlMap
controls Source
source = Dynamic -> ControlMap
Derive.state_controls (Dynamic -> ControlMap) -> m Dynamic -> m ControlMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Source -> m Dynamic
forall (m :: * -> *). M m => Source -> m Dynamic
dynamic Source
source

-- | 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
    (BlockId
block_id, Int
tracknum, TrackId
_, TrackTime
_) <- m (BlockId, Int, TrackId, TrackTime)
forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    RulerId
ruler_id <- RulerId -> Maybe RulerId -> RulerId
forall a. a -> Maybe a -> a
fromMaybe RulerId
Ui.no_ruler (Maybe RulerId -> RulerId) -> m (Maybe RulerId) -> m RulerId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        BlockId -> Int -> m (Maybe RulerId)
forall (m :: * -> *). M m => BlockId -> Int -> m (Maybe RulerId)
Ui.ruler_track_at BlockId
block_id Int
tracknum
    Marklists
mlists <- Ruler -> Marklists
Ruler.ruler_marklists (Ruler -> Marklists) -> m Ruler -> m Marklists
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RulerId -> m Ruler
forall (m :: * -> *). M m => RulerId -> m Ruler
Ui.get_ruler RulerId
ruler_id
    Dynamic
dyn <- Source -> m Dynamic
forall (m :: * -> *). M m => Source -> m Dynamic
dynamic Source
source
    RealTime
pos <- Source -> m RealTime
forall (m :: * -> *). M m => Source -> m RealTime
get_realtime Source
source
    -- I can't get 'Derive.state_event_serial' back, so the randomization will
    -- likely be different.
    ControlValMap -> m ControlValMap
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlValMap -> m ControlValMap)
-> ControlValMap -> m ControlValMap
forall a b. (a -> b) -> a -> b
$ RealTime -> Marklists -> Dynamic -> Int -> ControlValMap
Derive.state_controls_at RealTime
pos Marklists
mlists Dynamic
dyn Int
0

-- | 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 <- Source -> m Dynamic
forall (m :: * -> *). M m => Source -> m Dynamic
dynamic Source
source
    RealTime
pos <- Source -> m RealTime
forall (m :: * -> *). M m => Source -> m RealTime
get_realtime Source
source
    TypedControlValMap -> m TypedControlValMap
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedControlValMap -> m TypedControlValMap)
-> TypedControlValMap -> m TypedControlValMap
forall a b. (a -> b) -> a -> b
$ (Typed (Signal ControlSig) -> Typed Y)
-> ControlMap -> TypedControlValMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Signal ControlSig -> Y) -> Typed (Signal ControlSig) -> Typed Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> Signal ControlSig -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
pos)) (Dynamic -> ControlMap
Derive.state_controls Dynamic
dyn)

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 (Dynamic -> Map Instrument Instrument)
-> m Dynamic -> m (Map Instrument Instrument)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Source -> m Dynamic
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 (Dynamic -> Warp) -> m Dynamic -> m Warp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Source -> m Dynamic
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 <- m Track
forall (m :: * -> *). M m => m Track
Selection.track
    Text -> Maybe Dynamic -> m Dynamic
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"no dynamic for track " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Track -> Text
forall a. Pretty a => a -> Text
pretty Track
track) (Maybe Dynamic -> m Dynamic) -> m (Maybe Dynamic) -> m Dynamic
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Source
source of
        Source
Root -> Track -> m (Maybe Dynamic)
forall (m :: * -> *). M m => Track -> m (Maybe Dynamic)
Perf.lookup_root_dynamic Track
track
        Source
Local -> BlockId -> Track -> m (Maybe Dynamic)
forall (m :: * -> *). M m => BlockId -> Track -> m (Maybe Dynamic)
Perf.lookup_dynamic (Track -> BlockId
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) <- m (BlockId, Int, TrackId, TrackTime)
forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    TempoFunction
tempo <- Performance -> TempoFunction
Cmd.perf_tempo (Performance -> TempoFunction) -> m Performance -> m TempoFunction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m Performance
forall (m :: * -> *). M m => BlockId -> m Performance
get BlockId
block_id
    [RealTime] -> m [RealTime]
forall (m :: * -> *) a. Monad m => a -> m a
return ([RealTime] -> m [RealTime]) -> [RealTime] -> m [RealTime]
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) <- m (BlockId, Int, TrackId, TrackTime)
forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    Performance
perf <- case Source
source of
        Source
Root -> m Performance
forall (m :: * -> *). M m => m Performance
get_root
        Source
Local -> BlockId -> m Performance
forall (m :: * -> *). M m => BlockId -> m Performance
get BlockId
block_id
    Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
forall (m :: * -> *).
M m =>
Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
Perf.get_realtime Performance
perf BlockId
block_id (TrackId -> Maybe TrackId
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 =
    (Map Instrument ControlVals -> Event -> Map Instrument ControlVals)
-> Map Instrument ControlVals
-> [Event]
-> Map Instrument ControlVals
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Instrument ControlVals -> Event -> Map Instrument ControlVals
merge Map Instrument ControlVals
forall a. Monoid a => a
mempty ([Event] -> Map Instrument ControlVals)
-> ([LEvent Event] -> [Event])
-> [LEvent Event]
-> Map Instrument ControlVals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LEvent Event] -> [Event]
forall d. [LEvent d] -> [d]
LEvent.events_of ([LEvent Event] -> Map Instrument ControlVals)
-> m [LEvent Event] -> m (Map Instrument ControlVals)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m [LEvent Event]
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 =
        (ControlVals -> ControlVals -> ControlVals)
-> Instrument
-> ControlVals
-> Map Instrument ControlVals
-> Map Instrument ControlVals
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((((RealTime, Y), (RealTime, Y))
 -> ((RealTime, Y), (RealTime, Y))
 -> ((RealTime, Y), (RealTime, Y)))
-> ControlVals -> ControlVals -> ControlVals
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((RealTime, Y), (RealTime, Y))
-> ((RealTime, Y), (RealTime, Y)) -> ((RealTime, Y), (RealTime, Y))
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)
            (Map Control Signal -> ControlVals
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 = (Signal -> Maybe ((RealTime, Y), (RealTime, Y)))
-> Map k Signal -> Map k ((RealTime, Y), (RealTime, Y))
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((Signal -> Maybe ((RealTime, Y), (RealTime, Y)))
 -> Map k Signal -> Map k ((RealTime, Y), (RealTime, Y)))
-> (Signal -> Maybe ((RealTime, Y), (RealTime, Y)))
-> Map k Signal
-> Map k ((RealTime, Y), (RealTime, Y))
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) -> ((RealTime, Y), (RealTime, Y))
-> Maybe ((RealTime, Y), (RealTime, Y))
forall a. a -> Maybe a
Just ((RealTime, Y)
a, (RealTime, Y)
b)
            (Maybe (RealTime, Y), Maybe (RealTime, Y))
_ -> Maybe ((RealTime, Y), (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) =
        (((k, b) -> k) -> (k, b) -> (k, b) -> (k, b)
forall k a. Ord k => (a -> k) -> a -> a -> a
Seq.min_on (k, b) -> k
forall a b. (a, b) -> a
fst (k, b)
start1 (k, b)
start2, ((k, b) -> k) -> (k, b) -> (k, b) -> (k, b)
forall k a. Ord k => (a -> k) -> a -> a -> a
Seq.max_on (k, b) -> k
forall a b. (a, b) -> a
fst (k, b)
end1 (k, b)
end2)
    event_inst :: Event -> Instrument
event_inst = Patch -> Instrument
Types.patch_name (Patch -> Instrument) -> (Event -> Patch) -> Event -> Instrument
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
    CmdT IO ()
Cmd.invalidate_performances
    BlockId -> CmdT IO ()
Cmd.clear_im_cache (BlockId -> CmdT IO ()) -> CmdT IO BlockId -> CmdT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmdT IO BlockId
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 <- BlockId -> m Result
forall (m :: * -> *). M m => BlockId -> m Result
PlayUtil.uncached_derive BlockId
block_id
    Result
cached <- BlockId -> m Result
forall (m :: * -> *). M m => BlockId -> m Result
PlayUtil.cached_derive BlockId
block_id
    [Either ScoreEvent ScoreEvent] -> m [Either ScoreEvent ScoreEvent]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either ScoreEvent ScoreEvent]
 -> m [Either ScoreEvent ScoreEvent])
-> [Either ScoreEvent ScoreEvent]
-> m [Either ScoreEvent ScoreEvent]
forall a b. (a -> b) -> a -> b
$ [Event] -> [Event] -> [Either ScoreEvent ScoreEvent]
diff (Stream Event -> [Event]
forall a. Stream a -> [a]
Stream.events_of (Result -> Stream Event
Derive.r_events Result
cached))
        (Stream Event -> [Event]
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 = (ScoreEvent -> ScoreEvent -> Bool)
-> [ScoreEvent] -> [ScoreEvent] -> [Either ScoreEvent ScoreEvent]
forall a b. (a -> b -> Bool) -> [a] -> [b] -> [Either a b]
Seq.diff_either ScoreEvent -> ScoreEvent -> Bool
forall a. Eq a => a -> a -> Bool
(==)
        ((Event -> ScoreEvent) -> [Event] -> [ScoreEvent]
forall a b. (a -> b) -> [a] -> [b]
map Event -> ScoreEvent
Simple.score_event [Event]
e1) ((Event -> ScoreEvent) -> [Event] -> [ScoreEvent]
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 = BlockId -> m Result
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 = BlockId -> m Result
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 <- BlockId -> m Performance
forall (m :: * -> *). M m => BlockId -> m Performance
get (BlockId -> m Performance) -> m BlockId -> m Performance
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m BlockId
forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    [(BlockId, [(TrackId, TrackTime)])]
-> m [(BlockId, [(TrackId, TrackTime)])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(BlockId, [(TrackId, TrackTime)])]
 -> m [(BlockId, [(TrackId, TrackTime)])])
-> [(BlockId, [(TrackId, TrackTime)])]
-> m [(BlockId, [(TrackId, TrackTime)])]
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 = ([LEvent Event] -> [LEvent Event])
-> m [LEvent Event] -> m [LEvent Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [LEvent Event] -> [LEvent Event]
normalize_events (m [LEvent Event] -> m [LEvent Event])
-> (BlockId -> m [LEvent Event]) -> BlockId -> m [LEvent Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> m [LEvent Event]
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 =
    Stream Event -> [LEvent Event]
forall a. Stream a -> [LEvent a]
Stream.to_list (Stream Event -> [LEvent Event])
-> (Result -> Stream Event) -> Result -> [LEvent Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Stream Event
Derive.r_events (Result -> [LEvent Event]) -> m Result -> m [LEvent Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m Result
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 ([LEvent Event] -> [LEvent Event])
-> (Result -> [LEvent Event]) -> Result -> [LEvent Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream Event -> [LEvent Event]
forall a. Stream a -> [LEvent a]
Stream.to_list
    (Stream Event -> [LEvent Event])
-> (Result -> Stream Event) -> Result -> [LEvent Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Stream Event
Derive.r_events (Result -> [LEvent Event]) -> m Result -> m [LEvent Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m Result
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 = (LEvent Event -> LEvent Event) -> [LEvent Event] -> [LEvent Event]
forall a b. (a -> b) -> [a] -> [b]
map ((Event -> Event) -> LEvent Event -> LEvent Event
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 =
    [Event] -> m [LEvent Event]
forall (m :: * -> *). M m => [Event] -> m [LEvent Event]
midi_convert ([Event] -> m [LEvent Event])
-> ([LEvent Event] -> [Event])
-> [LEvent Event]
-> m [LEvent Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LEvent Event] -> [Event]
forall d. [LEvent d] -> [d]
LEvent.events_of ([LEvent Event] -> m [LEvent Event])
-> m [LEvent Event] -> m [LEvent Event]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId -> m [LEvent Event]
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 <- m State
forall (m :: * -> *). M m => m State
Ui.get
    Performance
perf <- State -> Result -> Performance
Performance.performance State
state (Result -> Performance) -> m Result -> m Performance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m Result
forall (m :: * -> *). M m => BlockId -> m Result
PlayUtil.cached_derive BlockId
block_id
    [Event] -> m MidiEvents
forall (m :: * -> *). M m => [Event] -> m MidiEvents
PlayUtil.perform_raw ([Event] -> m MidiEvents) -> [Event] -> m MidiEvents
forall a b. (a -> b) -> a -> b
$ Vector Event -> [Event]
forall a. Vector a -> [a]
Vector.toList (Vector Event -> [Event]) -> Vector Event -> [Event]
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 = Source -> (BlockId -> m [LEvent Event]) -> m [Event]
forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Local BlockId -> m [LEvent Event]
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 =
    [Event] -> m [LEvent Event]
forall (m :: * -> *). M m => [Event] -> m [LEvent Event]
midi_convert ([Event] -> m [LEvent Event]) -> m [Event] -> m [LEvent Event]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Source -> (BlockId -> m [LEvent Event]) -> m [Event]
forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Local BlockId -> m [LEvent Event]
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 <- m BlockId
forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    BlockId -> [Event] -> m [LEvent Note]
forall (m :: * -> *). M m => BlockId -> [Event] -> m [LEvent Note]
im_convert BlockId
block_id ([Event] -> m [LEvent Note]) -> m [Event] -> m [LEvent Note]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Source -> (BlockId -> m [LEvent Event]) -> m [Event]
forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Local BlockId -> m [LEvent Event]
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 = [Event] -> m [LEvent Note]
forall (m :: * -> *). M m => [Event] -> m [LEvent Note]
sc_convert ([Event] -> m [LEvent Note]) -> m [Event] -> m [LEvent Note]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Source -> (BlockId -> m [LEvent Event]) -> m [Event]
forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Local BlockId -> m [LEvent Event]
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) <- Source -> CmdT IO (BlockId, [TrackId], RealTime, RealTime)
forall (m :: * -> *).
M m =>
Source -> m (BlockId, [TrackId], RealTime, RealTime)
get_sel_ranges Source
source
    String
im_dir <- (State -> String) -> CmdT IO String
forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets ((State -> String) -> CmdT IO String)
-> (State -> String) -> CmdT IO String
forall a b. (a -> b) -> a -> b
$ Config -> String
Shared.Config.imDir (Config -> String) -> (State -> Config) -> State -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Config
Cmd.config_im (Config -> Config) -> (State -> Config) -> State -> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Cmd.state_config
    String
score_path <- (State -> String) -> CmdT IO String
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", RealTime -> String
forall a. Show a => a -> String
show RealTime
start String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"," String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RealTime -> String
forall a. Show a => a -> String
show RealTime
end
            , String
"--tracks", Text -> String
untxt (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
                Text -> [Text] -> Text
Text.intercalate Text
"," ((TrackId -> Text) -> [TrackId] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TrackId -> Text
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
    Text -> CmdT IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> CmdT IO Text) -> Text -> CmdT IO Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords (Text
"%" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"build/opt/sampler-im" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
txt [String]
args) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
        Text -> Text -> Text
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 = Source -> (BlockId -> m [LEvent Event]) -> m [Event]
forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Root BlockId -> m [LEvent Event]
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 =
    [Event] -> m [LEvent Event]
forall (m :: * -> *). M m => [Event] -> m [LEvent Event]
midi_convert ([Event] -> m [LEvent Event]) -> m [Event] -> m [LEvent Event]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Source -> (BlockId -> m [LEvent Event]) -> m [Event]
forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Root BlockId -> m [LEvent Event]
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 <- m BlockId
forall (m :: * -> *). M m => m BlockId
Ui.get_root_id
    BlockId -> [Event] -> m [LEvent Note]
forall (m :: * -> *). M m => BlockId -> [Event] -> m [LEvent Note]
im_convert BlockId
block_id ([Event] -> m [LEvent Note]) -> m [Event] -> m [LEvent Note]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Source -> (BlockId -> m [LEvent Event]) -> m [Event]
forall (m :: * -> *).
M m =>
Source -> (BlockId -> m [LEvent Event]) -> m [Event]
get_sel_events Source
Root BlockId -> m [LEvent Event]
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 =
    ((Text, [Event]) -> (Text, [Event]))
-> [(Text, [Event])] -> [(Text, [Event])]
forall a b. (a -> b) -> [a] -> [b]
map (([Event] -> [Event]) -> (Text, [Event]) -> (Text, [Event])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> [Event] -> [Event]
with_insts [Text]
insts ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> [Event]
strip_stack)) ([(Text, [Event])] -> [(Text, [Event])])
-> m [(Text, [Event])] -> m [(Text, [Event])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> Text -> m [(Text, [Event])]
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 <- [LEvent Event] -> [Msg]
forall d. [LEvent d] -> [Msg]
LEvent.logs_of ([LEvent Event] -> [Msg]) -> m [LEvent Event] -> m [Msg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m [LEvent Event]
forall (m :: * -> *). M m => BlockId -> m [LEvent Event]
block_events BlockId
block_id
    [(Text, [Event])] -> m [(Text, [Event])]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (Msg -> Text
stack Msg
log, [Event]
events)
        | (Msg
log, Just [Event]
events) <- [Msg] -> [Maybe [Event]] -> [(Msg, Maybe [Event])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Msg]
logs ((Msg -> Maybe [Event]) -> [Msg] -> [Maybe [Event]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Msg -> Maybe [Event]
forall a. Typeable a => Text -> Msg -> Maybe a
Log.lookup_dyn Text
tag) [Msg]
logs)
        ]
    where
    stack :: Msg -> Text
stack = Text -> (Stack -> Text) -> Maybe Stack -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Stack -> Text
Stack.pretty_ui (Maybe Stack -> Text) -> (Msg -> Maybe Stack) -> Msg -> Text
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_controls :: [ScoreT.Control] -> [LEvent.LEvent Score.Event]
    -> [Score.Event]
only_controls :: [Control] -> [LEvent Event] -> [Event]
only_controls [Control]
controls = (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
strip ([Event] -> [Event])
-> ([LEvent Event] -> [Event]) -> [LEvent Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LEvent Event] -> [Event]
forall d. [LEvent d] -> [d]
LEvent.events_of
    where
    strip :: Event -> Event
strip Event
e = Event
e
        { event_controls :: ControlMap
Score.event_controls =
            (Control -> Typed (Signal ControlSig) -> Bool)
-> ControlMap -> ControlMap
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Control
c Typed (Signal ControlSig)
_ -> Control
c Control -> [Control] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Control]
controls)
                (Event -> ControlMap
Score.event_controls Event
e)
        }

with_insts :: [Text] -> [Score.Event] -> [Score.Event]
with_insts :: [Text] -> [Event] -> [Event]
with_insts [Text]
instruments = (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Instrument -> [Instrument] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Instrument]
is) (Instrument -> Bool) -> (Event -> Instrument) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument)
    where is :: [Instrument]
is = (Text -> Instrument) -> [Text] -> [Instrument]
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 = (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map ((Event -> Event) -> [Event] -> [Event])
-> (Event -> Event) -> [Event] -> [Event]
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 = (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map ((Event -> Event) -> [Event] -> [Event])
-> (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$ \Event
event -> Event
event { event_environ :: Environ
Score.event_environ = Environ
forall a. Monoid a => a
mempty }

strip_controls :: [Score.Event] -> [Score.Event]
strip_controls :: [Event] -> [Event]
strip_controls = (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map ((Event -> Event) -> [Event] -> [Event])
-> (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$ \Event
event -> Event
event { event_controls :: ControlMap
Score.event_controls = ControlMap
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 ([Text] -> Text) -> ([Event] -> [Text]) -> [Event] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[Text]] -> [Text]
Texts.columns Int
1
    ([[Text]] -> [Text]) -> ([Event] -> [[Text]]) -> [Event] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> [Text]) -> [Event] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map (\Event
event -> ((Event -> Text) -> Text) -> Fmt -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Event -> Text) -> Event -> Text
forall a b. (a -> b) -> a -> b
$Event
event) ([Fmt] -> Fmt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Fmt]
extract))

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 Fmt -> Fmt -> Fmt
forall a. [a] -> [a] -> [a]
++ [Text -> Text
forall a. Pretty a => a -> Text
pretty (Text -> Text) -> (Event -> Text) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Text
Score.event_text]
e_sd :: Fmt
e_sd = [RealTime -> Text
forall a. Pretty a => a -> Text
pretty (RealTime -> Text) -> (Event -> RealTime) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start, RealTime -> Text
forall a. Pretty a => a -> Text
pretty (RealTime -> Text) -> (Event -> RealTime) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_duration]
e_sp :: Fmt
e_sp = Fmt
e_s Fmt -> Fmt -> Fmt
forall a. [a] -> [a] -> [a]
++ Fmt
e_pitch
e_s :: Fmt
e_s = [RealTime -> Text
forall a. Pretty a => a -> Text
pretty (RealTime -> Text) -> (Event -> RealTime) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start]

e_pitch, e_attr, e_inst, e_env :: Fmt
e_pitch :: Fmt
e_pitch = [Text
-> (RawPitch Transposed_ -> Text)
-> Maybe (RawPitch Transposed_)
-> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"?" RawPitch Transposed_ -> Text
forall a. RawPitch a -> Text
PSignal.symbolic_pitch (Maybe (RawPitch Transposed_) -> Text)
-> (Event -> Maybe (RawPitch Transposed_)) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Maybe (RawPitch Transposed_)
Score.initial_pitch]
e_attr :: Fmt
e_attr = [Attributes -> Text
forall a. Pretty a => a -> Text
pretty (Attributes -> Text) -> (Event -> Attributes) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Attributes
Score.event_attributes]
e_inst :: Fmt
e_inst = [Instrument -> Text
forall a. Pretty a => a -> Text
pretty (Instrument -> Text) -> (Event -> Instrument) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument]
e_env :: Fmt
e_env = [Environ -> Text
forall a. Pretty a => a -> Text
pretty (Environ -> Text) -> (Event -> Environ) -> Event -> Text
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 = [[(Text, Val)] -> Text
forall a. Pretty a => a -> Text
pretty ([(Text, Val)] -> Text)
-> (Event -> [(Text, Val)]) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Val) -> Bool) -> [(Text, Val)] -> [(Text, Val)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text
key `Text.isInfixOf`) (Text -> Bool) -> ((Text, Val) -> Text) -> (Text, Val) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Val) -> Text
forall a b. (a, b) -> a
fst) ([(Text, Val)] -> [(Text, Val)])
-> (Event -> [(Text, Val)]) -> Event -> [(Text, Val)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> [(Text, Val)]
Env.to_list
    (Environ -> [(Text, Val)])
-> (Event -> Environ) -> Event -> [(Text, Val)]
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 = [Maybe Val -> Text
forall a. Pretty a => a -> Text
pretty (Maybe Val -> Text) -> (Event -> Maybe Val) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Environ -> Maybe Val
Env.lookup Text
key (Environ -> Maybe Val) -> (Event -> Environ) -> Event -> Maybe Val
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) <- m (BlockId, Int, TrackId, TrackTime)
forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    Performance
perf <- BlockId -> m Performance
forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    RealTime
start <- Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
forall (m :: * -> *).
M m =>
Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
Perf.get_realtime Performance
perf BlockId
block_id (TrackId -> Maybe TrackId
forall a. a -> Maybe a
Just TrackId
track_id) TrackTime
pos
    Vector Event -> m (Vector Event)
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector Event -> m (Vector Event))
-> Vector Event -> m (Vector Event)
forall a b. (a -> b) -> a -> b
$ ([Event], Vector Event) -> Vector Event
forall a b. (a, b) -> b
snd (([Event], Vector Event) -> Vector Event)
-> ([Event], Vector Event) -> Vector Event
forall a b. (a -> b) -> a -> b
$ Set Instrument
-> RealTime -> Vector Event -> ([Event], Vector Event)
PlayUtil.events_from Set Instrument
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) <- m (BlockId, Int, TrackId, TrackTime)
forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    Performance
perf <- BlockId -> m Performance
forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    RealTime
start <- Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
forall (m :: * -> *).
M m =>
Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
Perf.get_realtime Performance
perf BlockId
block_id (TrackId -> Maybe TrackId
forall a. a -> Maybe a
Just TrackId
track_id) TrackTime
pos
    RealTime -> Vector Event -> m (MidiEvents, [LEvent Note])
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 =
    [LEvent Event] -> m [Event]
forall (m :: * -> *) d. LogMonad m => [LEvent d] -> m [d]
LEvent.write_logs ([LEvent Event] -> m [Event])
-> ((BlockId -> m [LEvent Event]) -> m [LEvent Event])
-> (BlockId -> m [LEvent Event])
-> m [Event]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Event -> RealTime)
-> (Event -> Stack)
-> Source
-> (BlockId -> m [LEvent Event])
-> m [LEvent Event]
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 = (Event -> RealTime)
-> (Event -> Stack)
-> Source
-> (BlockId -> m [LEvent Event])
-> m [LEvent Event]
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) <- Source -> m (BlockId, [TrackId], RealTime, RealTime)
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
    [LEvent d] -> m [LEvent d]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LEvent d] -> m [LEvent d]) -> [LEvent d] -> m [LEvent d]
forall a b. (a -> b) -> a -> b
$ (d -> Stack) -> [TrackId] -> [LEvent d] -> [LEvent d]
forall d. (d -> Stack) -> [TrackId] -> [LEvent d] -> [LEvent d]
in_tracks d -> Stack
event_stack [TrackId]
track_ids ([LEvent d] -> [LEvent d]) -> [LEvent d] -> [LEvent d]
forall a b. (a -> b) -> a -> b
$
        (d -> RealTime) -> RealTime -> RealTime -> [LEvent d] -> [LEvent d]
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 -> m (BlockId, RealTime, RealTime)
forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.realtime
        Source
Local -> m (BlockId, RealTime, RealTime)
forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.local_realtime
    [TrackId]
track_ids <- m [TrackId]
forall (m :: * -> *). M m => m [TrackId]
Selection.track_ids
    (BlockId, [TrackId], RealTime, RealTime)
-> m (BlockId, [TrackId], RealTime, RealTime)
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 =
    (Event -> Stack) -> [TrackId] -> [LEvent Event] -> [LEvent Event]
forall d. (d -> Stack) -> [TrackId] -> [LEvent d] -> [LEvent d]
in_tracks Event -> Stack
Score.event_stack [TrackId]
track_ids
    ([LEvent Event] -> [LEvent Event])
-> ([LEvent Event] -> [LEvent Event])
-> [LEvent Event]
-> [LEvent Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> RealTime)
-> RealTime -> RealTime -> [LEvent Event] -> [LEvent Event]
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 =
    (LEvent d -> Bool) -> [LEvent d] -> [LEvent d]
forall a. (a -> Bool) -> [a] -> [a]
filter ((LEvent d -> Bool) -> [LEvent d] -> [LEvent d])
-> (LEvent d -> Bool) -> [LEvent d] -> [LEvent d]
forall a b. (a -> b) -> a -> b
$ (d -> Bool) -> LEvent d -> Bool
forall d. (d -> Bool) -> LEvent d -> Bool
LEvent.log_or ([TrackId] -> Bool
forall {t :: * -> *}. Foldable t => t TrackId -> Bool
has ([TrackId] -> Bool) -> (d -> [TrackId]) -> d -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [TrackId]
tracks_of (Stack -> [TrackId]) -> (d -> Stack) -> d -> [TrackId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Stack
event_stack)
    where
    tracks_of :: Stack -> [TrackId]
tracks_of = (Frame -> Maybe TrackId) -> [Frame] -> [TrackId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Frame -> Maybe TrackId
Stack.track_of ([Frame] -> [TrackId]) -> (Stack -> [Frame]) -> Stack -> [TrackId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
Stack.innermost
    has :: t TrackId -> Bool
has t TrackId
tids = (TrackId -> Bool) -> [TrackId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TrackId -> t TrackId -> Bool
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 =
    (a -> Bool) -> [LEvent a] -> [LEvent a]
forall a. (a -> Bool) -> [LEvent a] -> [LEvent a]
LEvent.take_while ((RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<RealTime
end) (RealTime -> Bool) -> (a -> RealTime) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RealTime
start_of)
    ([LEvent a] -> [LEvent a])
-> ([LEvent a] -> [LEvent a]) -> [LEvent a] -> [LEvent a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [LEvent a] -> [LEvent a]
forall a. (a -> Bool) -> [LEvent a] -> [LEvent a]
LEvent.drop_while (RealTime -> RealTime -> Bool
forall {a}. (Num a, Ord a) => a -> a -> Bool
before RealTime
start (RealTime -> Bool) -> (a -> RealTime) -> a -> Bool
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = Bool
False
        | Bool
otherwise = a
ts a -> a -> Bool
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 = (LEvent a -> Bool) -> [LEvent a] -> [LEvent a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((LEvent a -> Bool) -> [LEvent a] -> [LEvent a])
-> (LEvent a -> Bool) -> [LEvent a] -> [LEvent a]
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> LEvent a -> Bool
forall d. (d -> Bool) -> LEvent d -> Bool
LEvent.log_or ((a -> Bool) -> LEvent a -> Bool)
-> (a -> Bool) -> LEvent a -> Bool
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 (Stack -> Bool) -> (a -> Stack) -> a -> Bool
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 = ((Maybe BlockId, Maybe TrackId, Maybe (TrackTime, TrackTime))
 -> Bool)
-> [(Maybe BlockId, Maybe TrackId, Maybe (TrackTime, TrackTime))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe BlockId, Maybe TrackId, Maybe (TrackTime, TrackTime))
-> Bool
match ([(Maybe BlockId, Maybe TrackId, Maybe (TrackTime, TrackTime))]
 -> Bool)
-> (Stack
    -> [(Maybe BlockId, Maybe TrackId, Maybe (TrackTime, TrackTime))])
-> Stack
-> Bool
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 BlockId -> [BlockId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BlockId]
block_ids Bool -> Bool -> Bool
&& TrackId
track_id TrackId -> [TrackId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TrackId]
track_ids
        Bool -> Bool -> Bool
&& Bool -> Bool
not (TrackTime
end TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
<= TrackTime
s Bool -> Bool -> Bool
|| TrackTime
start TrackTime -> TrackTime -> Bool
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 <- m (Instrument -> Maybe ResolvedInstrument)
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
    [LEvent Event] -> m [LEvent Event]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LEvent Event] -> m [LEvent Event])
-> [LEvent Event] -> m [LEvent Event]
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 <- m (Instrument -> Maybe ResolvedInstrument)
forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
Cmd.get_lookup_instrument
    [LEvent Note] -> m [LEvent Note]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LEvent Note] -> m [LEvent Note])
-> [LEvent Note] -> m [LEvent Note]
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 <- m (Instrument -> Maybe ResolvedInstrument)
forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
Cmd.get_lookup_instrument
    [LEvent Note] -> m [LEvent Note]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LEvent Note] -> m [LEvent Note])
-> [LEvent Note] -> m [LEvent Note]
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 (Instrument -> Text) -> (Event -> Instrument) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Instrument
Types.patch_name (Patch -> Instrument) -> (Event -> Patch) -> Event -> Instrument
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 = [Event] -> m MidiEvents
forall (m :: * -> *). M m => [Event] -> m MidiEvents
PlayUtil.perform_raw ([Event] -> m MidiEvents)
-> ([LEvent Event] -> [Event]) -> [LEvent Event] -> m MidiEvents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LEvent Event] -> [Event]
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 <- (State -> Allocations) -> m Allocations
forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets ((State -> Allocations) -> m Allocations)
-> (State -> Allocations) -> m Allocations
forall a b. (a -> b) -> a -> b
$ Config -> Allocations
UiConfig.config_allocations (Config -> Allocations)
-> (State -> Config) -> State -> 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 (Config -> Config)
-> Map Instrument Config -> Map Instrument Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Allocations -> Map Instrument Config
PlayUtil.midi_configs Allocations
allocs
    MidiEvents -> m MidiEvents
forall (m :: * -> *) a. Monad m => a -> m a
return (MidiEvents -> m MidiEvents) -> MidiEvents -> m MidiEvents
forall a b. (a -> b) -> a -> b
$ (MidiEvents, State) -> MidiEvents
forall a b. (a, b) -> a
fst ((MidiEvents, State) -> MidiEvents)
-> (MidiEvents, State) -> MidiEvents
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 = Source -> m MidiEvents
forall (m :: * -> *). M m => Source -> m MidiEvents
get_sel_midi Source
Local

root_sel_midi :: Cmd.M m => m Perform.MidiEvents
root_sel_midi :: forall (m :: * -> *). M m => m MidiEvents
root_sel_midi = Source -> m MidiEvents
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 -> m (BlockId, RealTime, RealTime)
forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.realtime
        Source
Local -> m (BlockId, RealTime, RealTime)
forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.local_realtime
    MidiEvents
events <- BlockId -> m MidiEvents
forall (m :: * -> *). M m => BlockId -> m MidiEvents
block_midi BlockId
block_id
    MidiEvents -> m MidiEvents
forall (m :: * -> *) a. Monad m => a -> m a
return (MidiEvents -> m MidiEvents) -> MidiEvents -> m MidiEvents
forall a b. (a -> b) -> a -> b
$ (WriteMessage -> RealTime)
-> RealTime -> RealTime -> MidiEvents -> MidiEvents
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 <- MidiEvents -> [Msg]
forall d. [LEvent d] -> [Msg]
LEvent.logs_of (MidiEvents -> [Msg]) -> m MidiEvents -> m [Msg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m MidiEvents
forall (m :: * -> *). M m => BlockId -> m MidiEvents
block_midi BlockId
block_id
    let reg :: Regex
reg = Stack => String -> Regex
String -> Regex
Regex.compileUnsafe String
regex
    [Msg] -> m [Msg]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Msg] -> m [Msg]) -> [Msg] -> m [Msg]
forall a b. (a -> b) -> a -> b
$ (Msg -> Bool) -> [Msg] -> [Msg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Regex -> Text -> Bool
Regex.matches Regex
reg (Text -> Bool) -> (Msg -> Text) -> Msg -> Bool
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 <- MidiEvents -> [Msg]
forall d. [LEvent d] -> [Msg]
LEvent.logs_of (MidiEvents -> [Msg]) -> m MidiEvents -> m [Msg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m MidiEvents
forall (m :: * -> *). M m => BlockId -> m MidiEvents
block_midi BlockId
perf_block
    let pattern :: (Maybe BlockId, Maybe (Set TrackId), Maybe (TrackTime, TrackTime))
pattern = (BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
block_id, Set TrackId -> Maybe (Set TrackId)
forall a. a -> Maybe a
Just ([TrackId] -> Set TrackId
forall a. Ord a => [a] -> Set a
Set.fromList [TrackId]
track_ids),
            (TrackTime, TrackTime) -> Maybe (TrackTime, TrackTime)
forall a. a -> Maybe a
Just (TrackTime
start, TrackTime
end))
        match :: Msg -> Bool
match = Bool -> (Stack -> Bool) -> Maybe Stack -> Bool
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) (Maybe Stack -> Bool) -> (Msg -> Maybe Stack) -> Msg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Maybe Stack
Log.msg_stack
    [Msg] -> m [Msg]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Msg] -> m [Msg]) -> [Msg] -> m [Msg]
forall a b. (a -> b) -> a -> b
$ (Msg -> Bool) -> [Msg] -> [Msg]
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 = (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify ((State -> State) -> m ()) -> (State -> State) -> m ()
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 (PlayArgs -> Status) -> PlayArgs -> Status
forall a b. (a -> b) -> a -> b
$ Cmd.PlayArgs
        { play_sync :: Maybe SyncConfig
play_sync = Maybe SyncConfig
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 = Maybe InverseTempoFunction
forall a. Maybe a
Nothing
        , play_repeat_at :: Maybe RealTime
play_repeat_at = Maybe RealTime
forall a. Maybe a
Nothing
        , play_im_end :: Maybe RealTime
play_im_end = Maybe RealTime
forall a. Maybe a
Nothing
        , play_im_direct :: Maybe PlayDirectArgs
play_im_direct = Maybe PlayDirectArgs
forall a. Maybe a
Nothing
        }

-- ** extract

with_chans :: [Midi.Channel] -> [Midi.WriteMessage] -> [Midi.WriteMessage]
with_chans :: [Channel] -> [WriteMessage] -> [WriteMessage]
with_chans [Channel]
chans = (WriteMessage -> Bool) -> [WriteMessage] -> [WriteMessage]
forall a. (a -> Bool) -> [a] -> [a]
filter ((WriteMessage -> Bool) -> [WriteMessage] -> [WriteMessage])
-> (WriteMessage -> Bool) -> [WriteMessage] -> [WriteMessage]
forall a b. (a -> b) -> a -> b
$ (Maybe Channel -> [Maybe Channel] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Channel -> Maybe Channel) -> [Channel] -> [Maybe Channel]
forall a b. (a -> b) -> [a] -> [b]
map Channel -> Maybe Channel
forall a. a -> Maybe a
Just [Channel]
chans) (Maybe Channel -> Bool)
-> (WriteMessage -> Maybe Channel) -> WriteMessage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Maybe Channel
Midi.message_channel
    (Message -> Maybe Channel)
-> (WriteMessage -> Message) -> WriteMessage -> Maybe 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 = (WriteMessage -> (RealTime, Message))
-> [WriteMessage] -> [(RealTime, Message)]
forall a b. (a -> b) -> [a] -> [b]
map ((WriteMessage -> (RealTime, Message))
 -> [WriteMessage] -> [(RealTime, Message)])
-> (WriteMessage -> (RealTime, Message))
-> [WriteMessage]
-> [(RealTime, Message)]
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 (Performance -> Cache) -> m Performance -> m Cache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        BlockId -> m Performance
forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    Map CacheKey Cached -> m (Map CacheKey Cached)
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 <- BlockId -> m (Map CacheKey Cached)
forall (m :: * -> *). M m => BlockId -> m (Map CacheKey Cached)
get_cache BlockId
block_id
    Map CacheKey [LEvent d] -> m (Map CacheKey [LEvent d])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map CacheKey [LEvent d] -> m (Map CacheKey [LEvent d]))
-> Map CacheKey [LEvent d] -> m (Map CacheKey [LEvent d])
forall a b. (a -> b) -> a -> b
$ (Stream d -> [LEvent d])
-> Map CacheKey (Stream d) -> Map CacheKey [LEvent d]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stream d -> [LEvent d]
forall a. Stream a -> [LEvent a]
Stream.to_list (Map CacheKey (Stream d) -> Map CacheKey [LEvent d])
-> Map CacheKey (Stream d) -> Map CacheKey [LEvent d]
forall a b. (a -> b) -> a -> b
$ (Cached -> Maybe (Stream d))
-> Map CacheKey Cached -> Map CacheKey (Stream d)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Cached -> Maybe (Stream d)
forall {d}. Cacheable d => Cached -> Maybe (Stream d)
get Map CacheKey Cached
cache
    where
    get :: Cached -> Maybe (Stream d)
get Cached
Derive.Invalid = Maybe (Stream d)
forall a. Maybe a
Nothing
    get (Derive.Cached CacheEntry
c) = case CacheEntry -> Maybe (CallType d)
forall d. Cacheable d => CacheEntry -> Maybe (CallType d)
Cache.from_cache_entry CacheEntry
c of
        Maybe (CallType d)
Nothing -> Maybe (Stream d)
forall a. Maybe a
Nothing
        Just (Derive.CallType Collect
_ Stream d
events) -> Stream d -> Maybe (Stream d)
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 <- BlockId -> m Performance
forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
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) -> Stream Event -> Int
forall a. Stream a -> Int
Stream.length Stream Event
events
    Derive.CachedControl (Derive.CallType Collect
_ Stream (Signal ControlSig)
events) -> Stream (Signal ControlSig) -> Int
forall a. Stream a -> Int
Stream.length Stream (Signal ControlSig)
events
    Derive.CachedPitch (Derive.CallType Collect
_ Stream PSignal
events) -> Stream PSignal -> Int
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 = ((ViewId, Maybe TrackSelection) -> m ())
-> [(ViewId, Maybe TrackSelection)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ViewId -> Maybe TrackSelection -> m ())
-> (ViewId, Maybe TrackSelection) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ViewId -> Maybe TrackSelection -> m ()
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) <- m (ViewId, Selection)
forall (m :: * -> *). M m => m (ViewId, Selection)
Selection.get_view_sel
    BlockId
block_id <- ViewId -> m BlockId
forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    Maybe TrackId
maybe_track_id <- BlockId -> Int -> m (Maybe TrackId)
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 ([(NoteNumber, Note, Ratio)] -> Text)
-> m [(NoteNumber, Note, Ratio)] -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId
-> Maybe TrackId -> TrackTime -> m [(NoteNumber, Note, Ratio)]
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
", " ([Text] -> Text)
-> ([(NoteNumber, Note, Ratio)] -> [Text])
-> [(NoteNumber, Note, Ratio)]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((NoteNumber, Note, Ratio) -> Text)
-> [(NoteNumber, Note, Ratio)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (NoteNumber, Note, Ratio) -> Text
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ratio -> Text
show_ratio Ratio
ratio

show_ratio :: Ratio -> Text
show_ratio :: Ratio -> Text
show_ratio = Integer -> Ratio -> Text
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 Ratio a -> Ratio a -> Bool
forall a. Ord a => a -> a -> Bool
>= Ratio a
2 = a -> Ratio a -> Text
go (a
octa -> a -> a
forall a. Num a => a -> a -> a
+a
1) (Ratio a
ratioRatio a -> Ratio a -> Ratio a
forall a. Fractional a => a -> a -> a
/Ratio a
2)
        | Ratio a
ratio Ratio a -> Ratio a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
%a
2 = a -> Ratio a -> Text
go (a
octa -> a -> a
forall a. Num a => a -> a -> a
-a
1) (Ratio a
ratioRatio a -> Ratio a -> Ratio a
forall a. Num a => a -> a -> a
*Ratio a
2)
        | a
oct a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = Ratio a -> Text
forall {a}. Show a => Ratio a -> Text
pretty Ratio a
ratio
        | Bool
otherwise = a -> Text
forall a. Show a => a -> Text
showt a
oct Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"+" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ratio a -> Text
forall {a}. Show a => Ratio a -> Text
pretty Ratio a
ratio
    pretty :: Ratio a -> Text
pretty Ratio a
ratio =
        a -> Text
forall a. Show a => a -> Text
showt (Ratio a -> a
forall a. Ratio a -> a
Ratio.numerator Ratio a
ratio) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt (Ratio a -> a
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 Maybe Text
forall a. Maybe a
Nothing
    Just (Selection
sel, BlockId
block_id, Maybe TrackId
maybe_track_id) ->
        Maybe Text -> m ()
set (Maybe Text -> m ())
-> ([(NoteNumber, Note, Ratio)] -> Maybe Text)
-> [(NoteNumber, Note, Ratio)]
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> ([(NoteNumber, Note, Ratio)] -> Text)
-> [(NoteNumber, Note, Ratio)]
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(NoteNumber, Note, Ratio)] -> Text
show_chord
            ([(NoteNumber, Note, Ratio)] -> m ())
-> m [(NoteNumber, Note, Ratio)] -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId
-> Maybe TrackId -> TrackTime -> m [(NoteNumber, Note, Ratio)]
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 = ViewId -> (Int, Text) -> Maybe Text -> m ()
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 <- m Performance
forall (m :: * -> *). M m => m Performance
Perf.get_root
    RealTime
pos <- Performance -> BlockId -> Maybe TrackId -> TrackTime -> m RealTime
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 (Vector Event -> [Event])
-> (Performance -> Vector Event) -> Performance -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Performance -> Vector Event
Cmd.perf_events (Performance -> [Event]) -> m Performance -> m [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m Performance
forall (m :: * -> *). M m => BlockId -> m Performance
get BlockId
block_id
    [Event]
events <- BlockId -> [Event] -> m [Event]
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
            (Event -> Bool) -> [Event] -> Maybe Event
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 = (Event -> Maybe NoteNumber) -> [Event] -> [NoteNumber]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime -> Event -> Maybe NoteNumber
Score.nn_at RealTime
pos) [Event]
events
        notes :: [Note]
notes = (Event -> Maybe Note) -> [Event] -> [Note]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime -> Event -> Maybe Note
Score.note_at RealTime
pos) [Event]
events
    [(NoteNumber, Note, Ratio)] -> m [(NoteNumber, Note, Ratio)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(NoteNumber, Note, Ratio)] -> m [(NoteNumber, Note, Ratio)])
-> [(NoteNumber, Note, Ratio)] -> m [(NoteNumber, Note, Ratio)]
forall a b. (a -> b) -> a -> b
$ [NoteNumber] -> [Note] -> [Ratio] -> [(NoteNumber, Note, Ratio)]
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 (Event -> Maybe NoteNumber) -> Maybe Event -> Maybe NoteNumber
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 = (Maybe TrackId -> Maybe TrackId -> Bool
forall a. Eq a => a -> a -> Bool
== TrackId -> Maybe TrackId
forall a. a -> Maybe a
Just TrackId
track_id) (Maybe TrackId -> Bool)
-> (Event -> Maybe TrackId) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BlockId, TrackId) -> TrackId)
-> Maybe (BlockId, TrackId) -> Maybe TrackId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlockId, TrackId) -> TrackId
forall a b. (a, b) -> b
snd (Maybe (BlockId, TrackId) -> Maybe TrackId)
-> (Event -> Maybe (BlockId, TrackId)) -> Event -> Maybe TrackId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of
        (Stack -> Maybe (BlockId, TrackId))
-> (Event -> Stack) -> Event -> Maybe (BlockId, TrackId)
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 = (Event -> Maybe TrackId) -> [Event] -> [(TrackId, Event)]
forall a k. (a -> Maybe k) -> [a] -> [(k, a)]
Seq.key_on_just
            (((BlockId, TrackId) -> TrackId)
-> Maybe (BlockId, TrackId) -> Maybe TrackId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlockId, TrackId) -> TrackId
forall a b. (a, b) -> b
snd (Maybe (BlockId, TrackId) -> Maybe TrackId)
-> (Event -> Maybe (BlockId, TrackId)) -> Event -> Maybe TrackId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of (Stack -> Maybe (BlockId, TrackId))
-> (Event -> Stack) -> Event -> Maybe (BlockId, TrackId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Stack
Score.event_stack) [Event]
events
    [Maybe Int]
tracknums <- ((TrackId, Event) -> m (Maybe Int))
-> [(TrackId, Event)] -> m [Maybe Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BlockId -> TrackId -> m (Maybe Int)
forall (m :: * -> *). M m => BlockId -> TrackId -> m (Maybe Int)
Ui.tracknum_of BlockId
block_id (TrackId -> m (Maybe Int))
-> ((TrackId, Event) -> TrackId)
-> (TrackId, Event)
-> m (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TrackId, Event) -> TrackId
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) <- [Maybe Int] -> [Event] -> [(Maybe Int, Event)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe Int]
tracknums (((TrackId, Event) -> Event) -> [(TrackId, Event)] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map (TrackId, Event) -> Event
forall a b. (a, b) -> b
snd [(TrackId, Event)]
by_track)]
    [Event] -> m [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Event] -> m [Event]) -> [Event] -> m [Event]
forall a b. (a -> b) -> a -> b
$ ((Int, Event) -> Event) -> [(Int, Event)] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Event) -> Event
forall a b. (a, b) -> b
snd ([(Int, Event)] -> [Event]) -> [(Int, Event)] -> [Event]
forall a b. (a -> b) -> a -> b
$ ((Int, Event) -> Int) -> [(Int, Event)] -> [(Int, Event)]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on (Int, Event) -> Int
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 = (NoteNumber -> Ratio) -> [NoteNumber] -> [Ratio]
forall a b. (a -> b) -> [a] -> [b]
map ((Y -> Y -> Ratio) -> Y -> Y -> Ratio
forall a b c. (a -> b -> c) -> b -> a -> c
flip Y -> Y -> Ratio
forall a. RealFrac a => a -> a -> Ratio
Ratio.approxRational Y
0.01 (Y -> Ratio) -> (NoteNumber -> Y) -> NoteNumber -> Ratio
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ NoteNumber -> Y
hz NoteNumber
unity) (Y -> Y) -> (NoteNumber -> Y) -> NoteNumber -> Y
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 -> m (BlockId, RealTime, RealTime)
forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.realtime
        Source
Local -> m (BlockId, RealTime, RealTime)
forall (m :: * -> *). M m => m (BlockId, RealTime, RealTime)
Selection.local_realtime
    [Event]
events <- RealTime -> Vector Event -> [Event]
PlayUtil.overlapping_events RealTime
start (Vector Event -> [Event])
-> (Performance -> Vector Event) -> Performance -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Performance -> Vector Event
Cmd.perf_events (Performance -> [Event]) -> m Performance -> m [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        BlockId -> m Performance
forall (m :: * -> *). M m => BlockId -> m Performance
get BlockId
block_id
    (RealTime, [Event]) -> m (RealTime, [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime
start, [Event]
events)