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

-- | Functions to do with performance.  This is split off from "Cmd.Play",
-- which contains play Cmds and their direct support.
module Cmd.PlayUtil (
    initial_environ
    , cached_derive, uncached_derive
    , derive_block, run
    , eval_with_dynamic, run_with_constant
    , is_score_damage_log
    , get_constant, initial_constant, initial_dynamic
    -- * perform
    , perform_from
    , perform_raw
    , shift_midi
    , first_time
    , events_from, overlapping_events
    , make_midi_lookup
    , midi_configs
    -- * mute and solo
    , get_muted_tracks, muted_instruments
) where
import qualified Data.Map as Map
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.Trees as Trees
import qualified Util.Vector

import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Derive.C.Prelude.Block as Prelude.Block
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.LEvent as LEvent
import qualified Derive.Scale.All2 as Scale.All2
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack

import qualified Instrument.Common as Common
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Convert as Convert
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Midi.Perform as Perform
import qualified Perform.RealTime as RealTime
import qualified Perform.Sc.Convert as Sc.Convert
import qualified Perform.Sc.Note as Sc.Note

import qualified Ui.Block as Block
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


-- | There are a few environ values that almost everything relies on.
initial_environ :: Env.Environ
initial_environ :: Environ
initial_environ = [(Text, Val)] -> Environ
Env.from_list
    -- Control interpolators rely on this.
    -- TODO 66+2/3, change to a whole number when I'm ready to update verify
    [ (Text
EnvKey.srate, Y -> Val
DeriveT.num (Y
1forall a. Fractional a => a -> a -> a
/Y
0.015))
    -- Looking up any val call relies on having a scale in scope.
    , (Text
EnvKey.scale, Text -> Val
DeriveT.str Text
Config.default_scale_id)
    , (Text
EnvKey.attributes, Attributes -> Val
DeriveT.VAttributes forall a. Monoid a => a
mempty)
    , (Text
EnvKey.seed, Y -> Val
DeriveT.num Y
0)
    ]

-- | Derive with the cache.
cached_derive :: Cmd.M m => BlockId -> m Derive.Result
cached_derive :: forall (m :: * -> *). M m => BlockId -> m Result
cached_derive BlockId
block_id = do
    Maybe Performance
maybe_perf <- forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
Cmd.lookup_performance BlockId
block_id
    case Maybe Performance
maybe_perf of
        Maybe Performance
Nothing -> forall (m :: * -> *). M m => BlockId -> m Result
uncached_derive BlockId
block_id
        Just Performance
perf -> forall (m :: * -> *).
M m =>
Cache -> ScoreDamage -> BlockId -> m Result
derive_block (Performance -> Cache
Cmd.perf_derive_cache Performance
perf)
            (Performance -> ScoreDamage
Cmd.perf_damage Performance
perf) BlockId
block_id

uncached_derive :: Cmd.M m => BlockId -> m Derive.Result
uncached_derive :: forall (m :: * -> *). M m => BlockId -> m Result
uncached_derive = forall (m :: * -> *).
M m =>
Cache -> ScoreDamage -> BlockId -> m Result
derive_block forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

-- | Derive the contents of the given block to score events.
derive_block :: Cmd.M m => Derive.Cache -> Derive.ScoreDamage -> BlockId
    -> m Derive.Result
derive_block :: forall (m :: * -> *).
M m =>
Cache -> ScoreDamage -> BlockId -> m Result
derive_block Cache
cache ScoreDamage
damage BlockId
block_id =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RunResult (Stream Event) -> Result
Derive.extract_result forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
M m =>
Cache -> ScoreDamage -> Deriver a -> m (RunResult a)
run Cache
cache ScoreDamage
damage forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ScoreDamage
damage forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ Text
"score damage for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
": "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ScoreDamage
damage
        BlockId -> Deriver (Stream Event)
Prelude.Block.eval_root_block BlockId
block_id

is_score_damage_log :: Log.Msg -> Bool
is_score_damage_log :: Msg -> Bool
is_score_damage_log = (Text
"score damage for " `Text.isPrefixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Text
Log.msg_text

run :: Cmd.M m => Derive.Cache -> Derive.ScoreDamage -> Derive.Deriver a
    -> m (Derive.RunResult a)
run :: forall (m :: * -> *) a.
M m =>
Cache -> ScoreDamage -> Deriver a -> m (RunResult a)
run Cache
cache ScoreDamage
damage Deriver a
deriver = do
    State
ui_state <- forall (m :: * -> *). M m => m State
Ui.get
    (Constant
constant, InstrumentAliases
aliases) <- forall (m :: * -> *).
M m =>
State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
get_constant State
ui_state Cache
cache ScoreDamage
damage
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Constant -> Dynamic -> Deriver a -> RunResult a
Derive.derive Constant
constant (InstrumentAliases -> Dynamic
initial_dynamic InstrumentAliases
aliases) Deriver a
deriver

-- | 'run_with_dynamic' but extract just the value.
eval_with_dynamic :: Cmd.M m => Derive.Dynamic -> Derive.Deriver a -> m a
eval_with_dynamic :: forall (m :: * -> *) a. M m => Dynamic -> Deriver a -> m a
eval_with_dynamic Dynamic
dynamic Deriver a
deriver = do
    (Either Error a
err_a, State
_, [Msg]
logs) <- forall (m :: * -> *) a.
M m =>
Dynamic -> Deriver a -> m (RunResult a)
run_with_dynamic Dynamic
dynamic Deriver a
deriver
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. Pretty a => a -> Text
pretty Either Error a
err_a

-- | Run a derivation when you already know the Dynamic.  This is the case when
-- deriving at a certain point in the score via the TrackDynamic.
run_with_dynamic :: Cmd.M m => Derive.Dynamic -> Derive.Deriver a
    -> m (Derive.RunResult a)
run_with_dynamic :: forall (m :: * -> *) a.
M m =>
Dynamic -> Deriver a -> m (RunResult a)
run_with_dynamic Dynamic
dynamic Deriver a
deriver = do
    State
ui_state <- forall (m :: * -> *). M m => m State
Ui.get
    -- Trust they already put the ky aliases in.
    (Constant
constant, InstrumentAliases
_aliases) <- forall (m :: * -> *).
M m =>
State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
get_constant State
ui_state forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Constant -> Dynamic -> Deriver a -> RunResult a
run_with_constant Constant
constant Dynamic
dynamic Deriver a
deriver

run_with_constant :: Derive.Constant -> Derive.Dynamic
    -> Derive.Deriver a -> Derive.RunResult a
run_with_constant :: forall a. Constant -> Dynamic -> Deriver a -> RunResult a
run_with_constant Constant
constant Dynamic
dynamic = forall st err a. st -> Deriver st err a -> RunResult st err a
Derive.run State
state
    where
    state :: State
state = Derive.State
        { state_threaded :: Threaded
state_threaded = Threaded
Derive.initial_threaded
        , state_dynamic :: Dynamic
state_dynamic = Dynamic
dynamic
        , state_collect :: Collect
state_collect = forall a. Monoid a => a
mempty
        , state_constant :: Constant
state_constant = Constant
constant
        }

-- | Create deriver configuration.  This is the main place where Cmd level
-- configuration is adapted to the deriver.
get_constant :: Cmd.M m => Ui.State -> Derive.Cache -> Derive.ScoreDamage
    -> m (Derive.Constant, Derive.InstrumentAliases)
get_constant :: forall (m :: * -> *).
M m =>
State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
get_constant State
ui_state Cache
cache ScoreDamage
damage = do
    State
cmd_state <- forall (m :: * -> *). M m => m State
Cmd.get
    (Builtins
builtins, InstrumentAliases
aliases) <- case State -> Maybe KyCache
Cmd.state_ky_cache State
cmd_state of
        Maybe KyCache
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
        Just KyCache
ky_cache -> forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ KyCache -> Either Text (Builtins, InstrumentAliases)
ky_builtins KyCache
ky_cache
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( State -> Config -> Builtins -> Cache -> ScoreDamage -> Constant
initial_constant State
ui_state (State -> Config
Cmd.state_config State
cmd_state)
            Builtins
builtins Cache
cache ScoreDamage
damage
        , InstrumentAliases
aliases
        )

initial_constant :: Ui.State -> Cmd.Config -> Derive.Builtins -> Derive.Cache
    -> Derive.ScoreDamage -> Derive.Constant
initial_constant :: State -> Config -> Builtins -> Cache -> ScoreDamage -> Constant
initial_constant State
ui_state Config
cmd_config Builtins
builtins Cache
cache ScoreDamage
damage =
    State
-> Builtins
-> LookupScale
-> Map CallName ScaleCall
-> (Instrument -> Either Text Instrument)
-> Cache
-> ScoreDamage
-> Constant
Derive.initial_constant State
ui_state
        (Builtins
builtins forall a. Semigroup a => a -> a -> a
<> Builtins
config_builtins) LookupScale
Cmd.lookup_scale Map CallName ScaleCall
Scale.All2.scales
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ResolvedInstrument -> Instrument
Cmd.make_derive_instrument forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instrument -> Either Text ResolvedInstrument
lookup_inst) Cache
cache ScoreDamage
damage
    where
    lookup_inst :: Instrument -> Either Text ResolvedInstrument
lookup_inst = Allocations
-> InstrumentDb -> Instrument -> Either Text ResolvedInstrument
Cmd.memoized_instrument
        (Config -> Allocations
UiConfig.config_allocations (State -> Config
Ui.state_config State
ui_state))
        (Config -> InstrumentDb
Cmd.config_instrument_db Config
cmd_config)
    config_builtins :: Builtins
config_builtins = Config -> Builtins
Cmd.config_builtins Config
cmd_config

ky_builtins :: Cmd.KyCache
    -> Either Text (Derive.Builtins, Derive.InstrumentAliases)
ky_builtins :: KyCache -> Either Text (Builtins, InstrumentAliases)
ky_builtins = \case
    Cmd.KyCache (Left Text
err) Fingerprint
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"parsing ky: " forall a. Semigroup a => a -> a -> a
<> Text
err
    Cmd.KyCache (Right (Builtins, InstrumentAliases)
builtins) Fingerprint
_ -> forall a b. b -> Either a b
Right (Builtins, InstrumentAliases)
builtins
    Cmd.PermanentKy (Builtins, InstrumentAliases)
builtins -> forall a b. b -> Either a b
Right (Builtins, InstrumentAliases)
builtins

initial_dynamic :: Derive.InstrumentAliases -> Derive.Dynamic
initial_dynamic :: InstrumentAliases -> Dynamic
initial_dynamic InstrumentAliases
aliases = (Environ -> Dynamic
Derive.initial_dynamic Environ
initial_environ)
    { state_instrument_aliases :: InstrumentAliases
Derive.state_instrument_aliases = InstrumentAliases
aliases }

perform_from :: Cmd.M m => RealTime -> Vector.Vector Score.Event
    -> m (Perform.MidiEvents, Sc.Note.Notes)
perform_from :: forall (m :: * -> *).
M m =>
RealTime -> Vector Event -> m (MidiEvents, Notes)
perform_from RealTime
start Vector 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
    Instrument -> Maybe ResolvedInstrument
lookup_inst <- forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
Cmd.get_lookup_instrument
    let insts :: [Instrument]
insts = forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ Allocations -> Map Instrument Allocation
UiConfig.unallocations Allocations
allocs
    let resume_insts :: Set Instrument
resume_insts = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
            forall a. (a -> Bool) -> [a] -> [a]
filter (forall {t}. (t -> Maybe ResolvedInstrument) -> Flag -> t -> Bool
has_flag Instrument -> Maybe ResolvedInstrument
lookup_inst Flag
Patch.ResumePlay) [Instrument]
insts
    -- TODO no ResumePlay for SC, but why not?
    ([Event]
extra, Vector Event
events) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Set Instrument
-> RealTime -> Vector Event -> ([Event], Vector Event)
events_from Set Instrument
resume_insts RealTime
start Vector Event
events
    Set TrackId
muted <- forall (m :: * -> *). M m => m (Set TrackId)
get_muted_tracks
    -- Performance should be lazy, so converting to a list here means I can
    -- avoid doing work for the notes that never get played.
    let events_list :: [Event]
events_list = Set TrackId -> [Event] -> [Event]
filter_track_muted Set TrackId
muted forall a b. (a -> b) -> a -> b
$
            Allocations -> [Event] -> [Event]
filter_instrument_muted Allocations
allocs forall a b. (a -> b) -> a -> b
$
            [Event]
extra forall a. [a] -> [a] -> [a]
++ forall a. Vector a -> [a]
Vector.toList Vector Event
events
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( (Instrument -> Maybe ResolvedInstrument)
-> Allocations -> [Event] -> MidiEvents
perform_midi Instrument -> Maybe ResolvedInstrument
lookup_inst Allocations
allocs [Event]
events_list
        , (Instrument -> Maybe ResolvedInstrument)
-> Allocations -> [Event] -> Notes
perform_sc Instrument -> Maybe ResolvedInstrument
lookup_inst Allocations
allocs [Event]
events_list
        )
    where
    has_flag :: (t -> Maybe ResolvedInstrument) -> Flag -> t -> Bool
has_flag t -> Maybe ResolvedInstrument
lookup_inst Flag
flag t
inst =
        case ResolvedInstrument -> Maybe (Patch, Config)
Cmd.midi_patch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< t -> Maybe ResolvedInstrument
lookup_inst t
inst of
            Maybe (Patch, Config)
Nothing -> Bool
False
            Just (Patch
_, Config
config) -> Config -> Flag -> Bool
Patch.has_flag Config
config Flag
flag

-- | Perform midi only, from time 0, without mutes.
perform_raw :: Cmd.M m => [Score.Event] -> m Perform.MidiEvents
perform_raw :: forall (m :: * -> *). M m => [Event] -> m MidiEvents
perform_raw [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
    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
$ (Instrument -> Maybe ResolvedInstrument)
-> Allocations -> [Event] -> MidiEvents
perform_midi Instrument -> Maybe ResolvedInstrument
lookup_inst Allocations
allocs [Event]
events

perform_midi :: (ScoreT.Instrument -> Maybe Cmd.ResolvedInstrument)
    -> UiConfig.Allocations -> [Score.Event] -> Perform.MidiEvents
perform_midi :: (Instrument -> Maybe ResolvedInstrument)
-> Allocations -> [Event] -> MidiEvents
perform_midi Instrument -> Maybe ResolvedInstrument
lookup_inst Allocations
allocs [Event]
events
    | Allocations -> Bool
UiConfig.has_midi Allocations
allocs =
        forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ State -> Configs -> Events -> (MidiEvents, State)
Perform.perform State
Perform.initial_state Configs
configs forall a b. (a -> b) -> a -> b
$
            RealTime
-> MidiLookup
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> Events
Convert.convert RealTime
Convert.default_srate MidiLookup
midi_lookup Instrument -> Maybe ResolvedInstrument
lookup_inst [Event]
events
    | Bool
otherwise = forall a. Monoid a => a
mempty
    where
    configs :: Configs
configs = Config -> Config
Perform.config forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Allocations -> Map Instrument Config
midi_configs Allocations
allocs
    midi_lookup :: MidiLookup
midi_lookup = (Instrument -> Maybe ResolvedInstrument) -> MidiLookup
make_midi_lookup Instrument -> Maybe ResolvedInstrument
lookup_inst

shift_midi :: RealTime -> RealTime -> Perform.MidiEvents
    -> Perform.MidiEvents
shift_midi :: RealTime -> RealTime -> MidiEvents -> MidiEvents
shift_midi RealTime
multiplier RealTime
start MidiEvents
events = forall {f :: * -> *}.
Functor f =>
RealTime -> [f WriteMessage] -> [f WriteMessage]
shift RealTime
start MidiEvents
events
    where
    shift :: RealTime -> [f WriteMessage] -> [f WriteMessage]
shift RealTime
offset = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$
        (RealTime -> RealTime) -> WriteMessage -> WriteMessage
Midi.modify_timestamp ((forall a. Num a => a -> a -> a
* RealTime
multiplier) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract RealTime
offset)

perform_sc :: (ScoreT.Instrument -> Maybe Cmd.ResolvedInstrument)
    -> UiConfig.Allocations -> [Score.Event] -> Sc.Note.Notes
perform_sc :: (Instrument -> Maybe ResolvedInstrument)
-> Allocations -> [Event] -> Notes
perform_sc Instrument -> Maybe ResolvedInstrument
lookup_inst Allocations
allocs
    | Allocations -> Bool
UiConfig.has_sc Allocations
allocs =
        RealTime
-> (Instrument -> Maybe ResolvedInstrument) -> [Event] -> Notes
Sc.Convert.convert RealTime
Sc.Convert.default_srate Instrument -> Maybe ResolvedInstrument
lookup_inst
    | Bool
otherwise = forall a. Monoid a => a
mempty

-- | The first timestamp from the msgs.
first_time :: [LEvent.LEvent Midi.WriteMessage] -> RealTime
first_time :: MidiEvents -> RealTime
first_time MidiEvents
msgs = case forall d. [LEvent d] -> [d]
LEvent.events_of MidiEvents
msgs of
    WriteMessage
event : [WriteMessage]
_ -> WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
event
    [] -> RealTime
0

-- | As a special case, a start <= 0 will get all events, including negative
-- ones.  This is so notes pushed before 0 won't be clipped on a play from 0.
events_from :: Set ScoreT.Instrument -- ^ scan back for starts of these
    -> RealTime -> Vector.Vector Score.Event
    -> ([Score.Event], Vector.Vector Score.Event)
    -- ^ (extra events before start, events from start)
events_from :: Set Instrument
-> RealTime -> Vector Event -> ([Event], Vector Event)
events_from Set Instrument
resume_insts RealTime
start Vector Event
events
    | RealTime
start forall a. Ord a => a -> a -> Bool
<= RealTime
0 = ([], Vector Event
events)
    | Bool
otherwise = ([Event]
starts, forall a. Int -> Vector a -> Vector a
Vector.drop Int
index Vector Event
events)
    where
    index :: Int
index = forall key (v :: * -> *) a.
(Ord key, Vector v a) =>
(a -> key) -> key -> v a -> Int
Util.Vector.lowest_index Event -> RealTime
Score.event_start (RealTime
start forall a. Num a => a -> a -> a
- RealTime
RealTime.eta)
        Vector Event
events
    starts :: [Event]
starts = RealTime
-> Set Instrument -> Vector Event -> RealTime -> Int -> [Event]
scan_for_starts RealTime
default_scan_back Set Instrument
resume_insts Vector Event
events RealTime
start Int
index

-- | Look back from the play start time by this much.  This is convenient
-- because randomization can move events back from the ruler mark, and it's
-- annoying when play misses them.
default_scan_back :: RealTime
default_scan_back :: RealTime
default_scan_back = RealTime
0.075

-- | Starting from the index, look back for overlapping events in the given set.
scan_for_starts :: RealTime -> Set ScoreT.Instrument
    -> Vector.Vector Score.Event -> RealTime -> Int -> [Score.Event]
scan_for_starts :: RealTime
-> Set Instrument -> Vector Event -> RealTime -> Int -> [Event]
scan_for_starts RealTime
scan_back Set Instrument
resume_insts Vector Event
events RealTime
pos Int
index =
    forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime -> RealTime -> Event -> Maybe Event
set_start RealTime
scan_back RealTime
pos) forall a b. (a -> b) -> a -> b
$
        Set Instrument -> [Event] -> [Event]
scan (Set Instrument
resume_insts forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Instrument
present_here) [Event]
back
    where
    here :: Vector Event
here = forall a. (a -> Bool) -> Vector a -> Vector a
Vector.takeWhile ((forall a. Eq a => a -> a -> Bool
==RealTime
pos) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start) forall a b. (a -> b) -> a -> b
$
        forall a. Int -> Vector a -> Vector a
Vector.drop Int
index Vector Event
events
    present_here :: Set Instrument
present_here = forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (\Set Instrument
s Event
e -> forall a. Ord a => a -> Set a -> Set a
Set.insert (Event -> Instrument
inst Event
e) Set Instrument
s) forall a. Monoid a => a
mempty Vector Event
here
    back :: [Event]
back = forall (v :: * -> *) a. Vector v a => v a -> [a]
Util.Vector.to_reverse_list forall a b. (a -> b) -> a -> b
$ forall a. Int -> Vector a -> Vector a
Vector.take Int
index Vector Event
events
    scan :: Set Instrument -> [Event] -> [Event]
scan Set Instrument
_ [] = []
    scan !Set Instrument
insts (Event
e:[Event]
es)
        | Event -> RealTime
Score.event_start Event
e forall a. Ord a => a -> a -> Bool
>= RealTime
until = Event
e forall a. a -> [a] -> [a]
: Set Instrument -> [Event] -> [Event]
scan Set Instrument
insts2 [Event]
es
        | forall a. Set a -> Bool
Set.null Set Instrument
insts = []
        | Event -> Instrument
inst Event
e forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Instrument
insts = Event
e forall a. a -> [a] -> [a]
: Set Instrument -> [Event] -> [Event]
scan Set Instrument
insts2 [Event]
es
        | Bool
otherwise = Set Instrument -> [Event] -> [Event]
scan Set Instrument
insts [Event]
es
        where insts2 :: Set Instrument
insts2 = forall a. Ord a => a -> Set a -> Set a
Set.delete (Event -> Instrument
inst Event
e) Set Instrument
insts
    until :: RealTime
until = RealTime
pos forall a. Num a => a -> a -> a
- RealTime
scan_back
    inst :: Event -> Instrument
inst = Event -> Instrument
Score.event_instrument

set_start :: RealTime -> RealTime -> Score.Event -> Maybe Score.Event
set_start :: RealTime -> RealTime -> Event -> Maybe Event
set_start RealTime
scan_back RealTime
pos Event
event
    | Event -> RealTime
Score.event_start Event
event forall a. Ord a => a -> a -> Bool
>= RealTime
pos forall a. Num a => a -> a -> a
- RealTime
scan_back = forall a. a -> Maybe a
Just Event
event
    | RealTime
dur forall a. Ord a => a -> a -> Bool
<= RealTime
0 = forall a. Maybe a
Nothing
    | Bool
otherwise =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Event
event { event_start :: RealTime
Score.event_start = RealTime
pos, event_duration :: RealTime
Score.event_duration = RealTime
dur }
    where dur :: RealTime
dur = Event -> RealTime
Score.event_end Event
event forall a. Num a => a -> a -> a
- RealTime
pos

-- | How to know how far back to go?  Impossible to know!  Well, I could look
-- up overlapping ui events, then map the earliest time to RealTime, and start
-- searching there.  But for now scanning from the beginning should be fast
-- enough.
overlapping_events :: RealTime -> Vector.Vector Score.Event -> [Score.Event]
overlapping_events :: RealTime -> Vector Event -> [Event]
overlapping_events RealTime
pos = forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' [Event] -> Event -> [Event]
collect []
    where
    collect :: [Event] -> Event -> [Event]
collect [Event]
overlap Event
event
        | Event -> RealTime
Score.event_end Event
event forall a. Ord a => a -> a -> Bool
<= RealTime
pos Bool -> Bool -> Bool
|| Event -> RealTime
Score.event_start Event
event forall a. Ord a => a -> a -> Bool
> RealTime
pos =
            [Event]
overlap
        | Bool
otherwise = Event
event forall a. a -> [a] -> [a]
: [Event]
overlap

-- | Similar to the Solo and Mute track flags, individual instruments can be
-- soloed or muted.
filter_instrument_muted :: UiConfig.Allocations -> [Score.Event]
    -> [Score.Event]
filter_instrument_muted :: Allocations -> [Event] -> [Event]
filter_instrument_muted Allocations
allocs =
    forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Instrument
muted) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument)
    where muted :: Set Instrument
muted = Allocations -> Set Instrument
muted_instruments Allocations
allocs

muted_instruments :: UiConfig.Allocations -> Set ScoreT.Instrument
muted_instruments :: Allocations -> Set Instrument
muted_instruments (UiConfig.Allocations Map Instrument Allocation
allocs)
    | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Instrument]
soloed) = Set Instrument
instruments forall a. Ord a => Set a -> Set a -> Set a
Set.\\ forall a. Ord a => [a] -> Set a
Set.fromList [Instrument]
soloed
    | Bool
otherwise = forall a. Ord a => [a] -> Set a
Set.fromList [Instrument]
muted
    where
    configs :: [(Instrument, Config)]
configs = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Allocation -> Config
UiConfig.alloc_config) (forall k a. Map k a -> [(k, a)]
Map.toList Map Instrument Allocation
allocs)
    instruments :: Set Instrument
instruments = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Instrument, Config)]
configs
    soloed :: [Instrument]
soloed = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Config -> Bool
Common.config_solo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Instrument, Config)]
configs
    muted :: [Instrument]
muted = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Config -> Bool
Common.config_mute forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Instrument, Config)]
configs

-- | Filter events according to the Solo and Mute flags in the tracks of the
-- given blocks.
--
-- Solo only applies to the block on which the track is soloed.  So if you solo
-- a track on one block, other blocks will still play.
--
-- Solo takes priority over Mute.
filter_track_muted :: Set TrackId -> [Score.Event] -> [Score.Event]
filter_track_muted :: Set TrackId -> [Event] -> [Event]
filter_track_muted Set TrackId
muted
    | forall a. Set a -> Bool
Set.null Set TrackId
muted = forall a. a -> a
id
    | Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TrackId -> Event -> Bool
stack_contains Set TrackId
muted)
    where
    stack_contains :: Set TrackId -> Event -> Bool
stack_contains Set TrackId
track_ids = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
track_ids) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> [TrackId]
stack_tracks
    stack_tracks :: Event -> [TrackId]
stack_tracks = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Stack
Score.event_stack

get_muted_tracks :: Ui.M m => m (Set TrackId)
get_muted_tracks :: forall (m :: * -> *). M m => m (Set TrackId)
get_muted_tracks = do
    [(BlockId, Block)]
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
Ui.state_blocks)
    [Tree TrackInfo]
tree <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). M m => BlockId -> m [Tree TrackInfo]
TrackTree.track_tree_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(BlockId, Block)]
blocks
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Tree TrackInfo] -> [(BlockId, Block)] -> Set TrackId
muted_tracks [Tree TrackInfo]
tree [(BlockId, Block)]
blocks

muted_tracks :: TrackTree.TrackTree -> [(BlockId, Block.Block)] -> Set TrackId
muted_tracks :: [Tree TrackInfo] -> [(BlockId, Block)] -> Set TrackId
muted_tracks [Tree TrackInfo]
tree [(BlockId, Block)]
blocks
    | Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set TrackId
soloed) = [Tree TrackInfo]
-> [(BlockId, Block)] -> Set TrackId -> Set TrackId
solo_to_mute [Tree TrackInfo]
tree [(BlockId, Block)]
blocks Set TrackId
soloed
    | Bool
otherwise = Set TrackId
muted
    where
    soloed :: Set TrackId
soloed = TrackFlag -> Set TrackId
with_flag TrackFlag
Block.Solo
    muted :: Set TrackId
muted = TrackFlag -> Set TrackId
with_flag TrackFlag
Block.Mute
    with_flag :: TrackFlag -> Set TrackId
with_flag TrackFlag
flag = forall a. Ord a => [a] -> Set a
Set.fromList
        [ TrackId
track_id
        | (BlockId
_, Block
block) <- [(BlockId, Block)]
blocks
        , Track
track <- Block -> [Track]
Block.block_tracks Block
block
        , Just TrackId
track_id <- [Track -> Maybe TrackId
Block.track_id Track
track]
        , TrackFlag
flag forall a. Ord a => a -> Set a -> Bool
`Set.member` Track -> Set TrackFlag
Block.track_flags Track
track
        ]

-- | Solo is surprisingly tricky.  Solo means non soloed-tracks are muted,
-- unless there is no solo on the block, or the track is the parent or child of
-- a soloed track.
--
-- I've already rewritten this a bunch of times, hopefully this is the last
-- time.
solo_to_mute :: TrackTree.TrackTree -- ^ All the trees of the whole score,
    -- concatenated.  This is because I just need to know who is a child of
    -- who, and I don't care what block they're in.
    -> [(BlockId, Block.Block)] -> Set TrackId -> Set TrackId
solo_to_mute :: [Tree TrackInfo]
-> [(BlockId, Block)] -> Set TrackId -> Set TrackId
solo_to_mute [Tree TrackInfo]
tree [(BlockId, Block)]
blocks Set TrackId
soloed = forall a. Ord a => [a] -> Set a
Set.fromList
    [ TrackId
track_id
    | (BlockId
block_id, Block
block) <- [(BlockId, Block)]
blocks
    , Track
track <- Block -> [Track]
Block.block_tracks Block
block
    , Just TrackId
track_id <- [Track -> Maybe TrackId
Block.track_id Track
track]
    , TrackId
track_id forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TrackId
soloed
    , BlockId
block_id forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BlockId
soloed_blocks
    , TrackId
track_id forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TrackId
has_soloed_relatives
    ]
    where
    has_soloed_relatives :: Set TrackId
has_soloed_relatives = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TrackInfo, [TrackInfo], [TrackInfo]) -> Maybe TrackId
get (forall a. [Tree a] -> [(a, [a], [a])]
Trees.flatPaths [Tree TrackInfo]
tree))
        where
        get :: (TrackInfo, [TrackInfo], [TrackInfo]) -> Maybe TrackId
get (TrackInfo
track, [TrackInfo]
parents, [TrackInfo]
children)
            | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
soloed) (forall a b. (a -> b) -> [a] -> [b]
map TrackInfo -> TrackId
Ui.track_id [TrackInfo]
children)
                    Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
soloed) (forall a b. (a -> b) -> [a] -> [b]
map TrackInfo -> TrackId
Ui.track_id [TrackInfo]
parents) =
                forall a. a -> Maybe a
Just (TrackInfo -> TrackId
Ui.track_id TrackInfo
track)
            | Bool
otherwise = forall a. Maybe a
Nothing
    soloed_blocks :: Set BlockId
soloed_blocks = forall a. Ord a => [a] -> Set a
Set.fromList
        [ BlockId
block_id
        | (BlockId
block_id, Block
block) <- [(BlockId, Block)]
blocks
        , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((TrackFlag
Block.Solo `Set.member`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Set TrackFlag
Block.track_flags)
            (Block -> [Track]
Block.block_tracks Block
block)
        ]

midi_configs :: UiConfig.Allocations -> Map ScoreT.Instrument Patch.Config
midi_configs :: Allocations -> Map Instrument Config
midi_configs (UiConfig.Allocations Map Instrument Allocation
allocs) = forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
    [ (Instrument
inst, Config
config)
    | (Instrument
inst, Allocation
alloc) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map Instrument Allocation
allocs
    , Just Config
config <- [Backend -> Maybe Config
midi_config (Allocation -> Backend
UiConfig.alloc_backend Allocation
alloc)]
    ]

midi_config :: UiConfig.Backend -> Maybe Patch.Config
midi_config :: Backend -> Maybe Config
midi_config (UiConfig.Midi Config
a) = forall a. a -> Maybe a
Just Config
a
midi_config Backend
_ = forall a. Maybe a
Nothing

make_midi_lookup :: (ScoreT.Instrument -> Maybe Cmd.ResolvedInstrument)
    -> Convert.MidiLookup
make_midi_lookup :: (Instrument -> Maybe ResolvedInstrument) -> MidiLookup
make_midi_lookup Instrument -> Maybe ResolvedInstrument
lookup_inst = Convert.MidiLookup
    { lookup_scale :: LookupScale
lookup_scale = LookupScale
Cmd.lookup_scale
    , lookup_control_defaults :: Instrument -> Map Control Y
lookup_control_defaults = \Instrument
inst -> forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ do
        ResolvedInstrument
inst <- Instrument -> Maybe ResolvedInstrument
lookup_inst Instrument
inst
        Map Control Y
defaults <- case ResolvedInstrument -> Backend
Cmd.inst_backend ResolvedInstrument
inst of
            Cmd.Midi Patch
_ Config
config -> Settings -> Maybe (Map Control Y)
Patch.config_control_defaults forall a b. (a -> b) -> a -> b
$
                Config -> Settings
Patch.config_settings Config
config
            Backend
_ -> forall a. Maybe a
Nothing
        forall (m :: * -> *) a. Monad m => a -> m a
return Map Control Y
defaults
    }