-- 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, run_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.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
1Y -> Y -> Y
forall 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 Attributes
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 <- BlockId -> m (Maybe Performance)
forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
Cmd.lookup_performance BlockId
block_id
    case Maybe Performance
maybe_perf of
        Maybe Performance
Nothing -> BlockId -> m Result
forall (m :: * -> *). M m => BlockId -> m Result
uncached_derive BlockId
block_id
        Just Performance
perf -> Cache -> ScoreDamage -> BlockId -> m Result
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 = Cache -> ScoreDamage -> BlockId -> m Result
forall (m :: * -> *).
M m =>
Cache -> ScoreDamage -> BlockId -> m Result
derive_block Cache
forall a. Monoid a => a
mempty ScoreDamage
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 =
    (RunResult (Stream Event) -> Result)
-> m (RunResult (Stream Event)) -> m Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RunResult (Stream Event) -> Result
Derive.extract_result (m (RunResult (Stream Event)) -> m Result)
-> m (RunResult (Stream Event)) -> m Result
forall a b. (a -> b) -> a -> b
$ Cache
-> ScoreDamage
-> Deriver (Stream Event)
-> m (RunResult (Stream Event))
forall (m :: * -> *) a.
M m =>
Cache -> ScoreDamage -> Deriver a -> m (RunResult a)
run Cache
cache ScoreDamage
damage (Deriver (Stream Event) -> m (RunResult (Stream Event)))
-> Deriver (Stream Event) -> m (RunResult (Stream Event))
forall a b. (a -> b) -> a -> b
$ do
        Bool -> Deriver State Error () -> Deriver State Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ScoreDamage
damage ScoreDamage -> ScoreDamage -> Bool
forall a. Eq a => a -> a -> Bool
== ScoreDamage
forall a. Monoid a => a
mempty) (Deriver State Error () -> Deriver State Error ())
-> Deriver State Error () -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$
            Text -> Deriver State Error ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.debug (Text -> Deriver State Error ()) -> Text -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Text
"score damage for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
forall a. Show a => a -> Text
showt BlockId
block_id Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScoreDamage -> Text
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`) (Text -> Bool) -> (Msg -> Text) -> Msg -> Bool
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 <- m State
forall (m :: * -> *). M m => m State
Ui.get
    (Constant
constant, InstrumentAliases
aliases) <- State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
forall (m :: * -> *).
M m =>
State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
get_constant State
ui_state Cache
cache ScoreDamage
damage
    RunResult a -> m (RunResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult a -> m (RunResult a)) -> RunResult a -> m (RunResult a)
forall a b. (a -> b) -> a -> b
$ Constant -> Dynamic -> Deriver a -> RunResult a
forall a. Constant -> Dynamic -> Deriver a -> RunResult a
Derive.derive Constant
constant (InstrumentAliases -> Dynamic
initial_dynamic InstrumentAliases
aliases) Deriver a
deriver

-- | 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 <- m State
forall (m :: * -> *). M m => m State
Ui.get
    -- Trust they already put the ky aliases in.
    (Constant
constant, InstrumentAliases
_aliases) <- State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
forall (m :: * -> *).
M m =>
State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
get_constant State
ui_state Cache
forall a. Monoid a => a
mempty ScoreDamage
forall a. Monoid a => a
mempty
    let 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 = Collect
forall a. Monoid a => a
mempty
            , state_constant :: Constant
state_constant = Constant
constant
            }
    RunResult a -> m (RunResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult a -> m (RunResult a)) -> RunResult a -> m (RunResult a)
forall a b. (a -> b) -> a -> b
$ State -> Deriver a -> RunResult a
forall st err a. st -> Deriver st err a -> RunResult st err a
Derive.run State
state Deriver a
deriver

run_with_constant :: Derive.InstrumentAliases -> Derive.Constant
    -> Derive.Deriver a -> Derive.RunResult a
run_with_constant :: forall a. InstrumentAliases -> Constant -> Deriver a -> RunResult a
run_with_constant InstrumentAliases
aliases Constant
constant = State -> Deriver State Error a -> RunResult State Error a
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 = InstrumentAliases -> Dynamic
initial_dynamic InstrumentAliases
aliases
        , state_collect :: Collect
state_collect = 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 <- m 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 -> (Builtins, InstrumentAliases) -> m (Builtins, InstrumentAliases)
forall (m :: * -> *) a. Monad m => a -> m a
return (Builtins
forall a. Monoid a => a
mempty, InstrumentAliases
forall a. Monoid a => a
mempty)
        Just KyCache
ky_cache -> (Text -> Text)
-> Either Text (Builtins, InstrumentAliases)
-> m (Builtins, InstrumentAliases)
forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right Text -> Text
forall a. a -> a
id (Either Text (Builtins, InstrumentAliases)
 -> m (Builtins, InstrumentAliases))
-> Either Text (Builtins, InstrumentAliases)
-> m (Builtins, InstrumentAliases)
forall a b. (a -> b) -> a -> b
$ KyCache -> Either Text (Builtins, InstrumentAliases)
ky_builtins KyCache
ky_cache
    (Constant, InstrumentAliases) -> m (Constant, InstrumentAliases)
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 = Constant
constant
    where
    constant :: Constant
constant = State
-> Builtins
-> LookupScale
-> (Instrument -> Either Text Instrument)
-> Cache
-> ScoreDamage
-> Constant
Derive.initial_constant State
ui_state
        (Builtins
builtins Builtins -> Builtins -> Builtins
forall a. Semigroup a => a -> a -> a
<> Builtins
config_builtins) LookupScale
Cmd.lookup_scale
        ((ResolvedInstrument -> Instrument)
-> Either Text ResolvedInstrument -> Either Text Instrument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ResolvedInstrument -> Instrument
Cmd.make_derive_instrument (Either Text ResolvedInstrument -> Either Text Instrument)
-> (Instrument -> Either Text ResolvedInstrument)
-> Instrument
-> Either Text Instrument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instrument -> Either Text ResolvedInstrument
lookup_inst) Cache
cache ScoreDamage
damage
    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
_ -> Text -> Either Text (Builtins, InstrumentAliases)
forall a b. a -> Either a b
Left (Text -> Either Text (Builtins, InstrumentAliases))
-> Text -> Either Text (Builtins, InstrumentAliases)
forall a b. (a -> b) -> a -> b
$ Text
"parsing ky: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
    Cmd.KyCache (Right (Builtins, InstrumentAliases)
builtins) Fingerprint
_ -> (Builtins, InstrumentAliases)
-> Either Text (Builtins, InstrumentAliases)
forall a b. b -> Either a b
Right (Builtins, InstrumentAliases)
builtins
    Cmd.PermanentKy (Builtins, InstrumentAliases)
builtins -> (Builtins, InstrumentAliases)
-> Either Text (Builtins, InstrumentAliases)
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 <- (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
    Instrument -> Maybe ResolvedInstrument
lookup_inst <- m (Instrument -> Maybe ResolvedInstrument)
forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
Cmd.get_lookup_instrument
    let insts :: [Instrument]
insts = Map Instrument Allocation -> [Instrument]
forall k a. Map k a -> [k]
Map.keys (Map Instrument Allocation -> [Instrument])
-> Map Instrument Allocation -> [Instrument]
forall a b. (a -> b) -> a -> b
$ Allocations -> Map Instrument Allocation
UiConfig.unallocations Allocations
allocs
    let resume_insts :: Set Instrument
resume_insts = [Instrument] -> Set Instrument
forall a. Ord a => [a] -> Set a
Set.fromList ([Instrument] -> Set Instrument) -> [Instrument] -> Set Instrument
forall a b. (a -> b) -> a -> b
$
            (Instrument -> Bool) -> [Instrument] -> [Instrument]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Instrument -> Maybe ResolvedInstrument)
-> Flag -> Instrument -> Bool
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) <- ([Event], Vector Event) -> m ([Event], Vector Event)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Event], Vector Event) -> m ([Event], Vector Event))
-> ([Event], Vector Event) -> m ([Event], Vector Event)
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 <- m (Set TrackId)
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 ([Event] -> [Event]) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$
            Allocations -> [Event] -> [Event]
filter_instrument_muted Allocations
allocs ([Event] -> [Event]) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$
            [Event]
extra [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++ Vector Event -> [Event]
forall a. Vector a -> [a]
Vector.toList Vector Event
events
    (MidiEvents, Notes) -> m (MidiEvents, Notes)
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 (ResolvedInstrument -> Maybe (Patch, Config))
-> Maybe ResolvedInstrument -> Maybe (Patch, Config)
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 <- (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
    Instrument -> Maybe ResolvedInstrument
lookup_inst <- m (Instrument -> Maybe ResolvedInstrument)
forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
Cmd.get_lookup_instrument
    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
$ (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 =
        (MidiEvents, State) -> MidiEvents
forall a b. (a, b) -> a
fst ((MidiEvents, State) -> MidiEvents)
-> (MidiEvents, State) -> MidiEvents
forall a b. (a -> b) -> a -> b
$ State -> Configs -> Events -> (MidiEvents, State)
Perform.perform State
Perform.initial_state Configs
configs (Events -> (MidiEvents, State)) -> Events -> (MidiEvents, State)
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 = MidiEvents
forall a. Monoid a => a
mempty
    where
    configs :: Configs
configs = Config -> Config
Perform.config (Config -> Config) -> Map Instrument Config -> Configs
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 = RealTime -> MidiEvents -> MidiEvents
forall {f :: * -> *}.
Functor f =>
RealTime -> [f WriteMessage] -> [f WriteMessage]
shift RealTime
start MidiEvents
events
    where
    shift :: RealTime -> [f WriteMessage] -> [f WriteMessage]
shift RealTime
offset = (f WriteMessage -> f WriteMessage)
-> [f WriteMessage] -> [f WriteMessage]
forall a b. (a -> b) -> [a] -> [b]
map ((f WriteMessage -> f WriteMessage)
 -> [f WriteMessage] -> [f WriteMessage])
-> (f WriteMessage -> f WriteMessage)
-> [f WriteMessage]
-> [f WriteMessage]
forall a b. (a -> b) -> a -> b
$ (WriteMessage -> WriteMessage) -> f WriteMessage -> f WriteMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((WriteMessage -> WriteMessage)
 -> f WriteMessage -> f WriteMessage)
-> (WriteMessage -> WriteMessage)
-> f WriteMessage
-> f WriteMessage
forall a b. (a -> b) -> a -> b
$
        (RealTime -> RealTime) -> WriteMessage -> WriteMessage
Midi.modify_timestamp ((RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
* RealTime
multiplier) (RealTime -> RealTime)
-> (RealTime -> RealTime) -> RealTime -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> RealTime -> RealTime
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 = [Event] -> Notes
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 MidiEvents -> [WriteMessage]
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 RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<= RealTime
0 = ([], Vector Event
events)
    | Bool
otherwise = ([Event]
starts, Int -> Vector Event -> Vector Event
forall a. Int -> Vector a -> Vector a
Vector.drop Int
index Vector Event
events)
    where
    index :: Int
index = (Event -> RealTime) -> RealTime -> Vector Event -> Int
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 RealTime -> RealTime -> RealTime
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 =
    [Event] -> [Event]
forall a. [a] -> [a]
reverse ([Event] -> [Event]) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$ (Event -> Maybe Event) -> [Event] -> [Event]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime -> RealTime -> Event -> Maybe Event
set_start RealTime
scan_back RealTime
pos) ([Event] -> [Event]) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$
        Set Instrument -> [Event] -> [Event]
scan (Set Instrument
resume_insts Set Instrument -> Set Instrument -> Set Instrument
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Instrument
present_here) [Event]
back
    where
    here :: Vector Event
here = (Event -> Bool) -> Vector Event -> Vector Event
forall a. (a -> Bool) -> Vector a -> Vector a
Vector.takeWhile ((RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
==RealTime
pos) (RealTime -> Bool) -> (Event -> RealTime) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start) (Vector Event -> Vector Event) -> Vector Event -> Vector Event
forall a b. (a -> b) -> a -> b
$
        Int -> Vector Event -> Vector Event
forall a. Int -> Vector a -> Vector a
Vector.drop Int
index Vector Event
events
    present_here :: Set Instrument
present_here = (Set Instrument -> Event -> Set Instrument)
-> Set Instrument -> Vector Event -> Set Instrument
forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (\Set Instrument
s Event
e -> Instrument -> Set Instrument -> Set Instrument
forall a. Ord a => a -> Set a -> Set a
Set.insert (Event -> Instrument
inst Event
e) Set Instrument
s) Set Instrument
forall a. Monoid a => a
mempty Vector Event
here
    back :: [Event]
back = Vector Event -> [Event]
forall (v :: * -> *) a. Vector v a => v a -> [a]
Util.Vector.to_reverse_list (Vector Event -> [Event]) -> Vector Event -> [Event]
forall a b. (a -> b) -> a -> b
$ Int -> Vector Event -> Vector Event
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 RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>= RealTime
until = Event
e Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: Set Instrument -> [Event] -> [Event]
scan Set Instrument
insts2 [Event]
es
        | Set Instrument -> Bool
forall a. Set a -> Bool
Set.null Set Instrument
insts = []
        | Event -> Instrument
inst Event
e Instrument -> Set Instrument -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Instrument
insts = Event
e Event -> [Event] -> [Event]
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 = Instrument -> Set Instrument -> Set Instrument
forall a. Ord a => a -> Set a -> Set a
Set.delete (Event -> Instrument
inst Event
e) Set Instrument
insts
    until :: RealTime
until = RealTime
pos RealTime -> RealTime -> RealTime
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 RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>= RealTime
pos RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
scan_back = Event -> Maybe Event
forall a. a -> Maybe a
Just Event
event
    | RealTime
dur RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<= RealTime
0 = Maybe Event
forall a. Maybe a
Nothing
    | Bool
otherwise =
        Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
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 RealTime -> RealTime -> RealTime
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 = ([Event] -> Event -> [Event]) -> [Event] -> Vector Event -> [Event]
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 RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<= RealTime
pos Bool -> Bool -> Bool
|| Event -> RealTime
Score.event_start Event
event RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
> RealTime
pos =
            [Event]
overlap
        | Bool
otherwise = Event
event Event -> [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 =
    (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Instrument -> Set Instrument -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Instrument
muted) (Instrument -> Bool) -> (Event -> Instrument) -> Event -> Bool
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 ([Instrument] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Instrument]
soloed) = Set Instrument
instruments Set Instrument -> Set Instrument -> Set Instrument
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ [Instrument] -> Set Instrument
forall a. Ord a => [a] -> Set a
Set.fromList [Instrument]
soloed
    | Bool
otherwise = [Instrument] -> Set Instrument
forall a. Ord a => [a] -> Set a
Set.fromList [Instrument]
muted
    where
    configs :: [(Instrument, Config)]
configs = ((Instrument, Allocation) -> (Instrument, Config))
-> [(Instrument, Allocation)] -> [(Instrument, Config)]
forall a b. (a -> b) -> [a] -> [b]
map ((Allocation -> Config)
-> (Instrument, Allocation) -> (Instrument, Config)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Allocation -> Config
UiConfig.alloc_config) (Map Instrument Allocation -> [(Instrument, Allocation)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Instrument Allocation
allocs)
    instruments :: Set Instrument
instruments = [Instrument] -> Set Instrument
forall a. Ord a => [a] -> Set a
Set.fromList ([Instrument] -> Set Instrument) -> [Instrument] -> Set Instrument
forall a b. (a -> b) -> a -> b
$ ((Instrument, Config) -> Instrument)
-> [(Instrument, Config)] -> [Instrument]
forall a b. (a -> b) -> [a] -> [b]
map (Instrument, Config) -> Instrument
forall a b. (a, b) -> a
fst [(Instrument, Config)]
configs
    soloed :: [Instrument]
soloed = ((Instrument, Config) -> Instrument)
-> [(Instrument, Config)] -> [Instrument]
forall a b. (a -> b) -> [a] -> [b]
map (Instrument, Config) -> Instrument
forall a b. (a, b) -> a
fst ([(Instrument, Config)] -> [Instrument])
-> [(Instrument, Config)] -> [Instrument]
forall a b. (a -> b) -> a -> b
$ ((Instrument, Config) -> Bool)
-> [(Instrument, Config)] -> [(Instrument, Config)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Config -> Bool
Common.config_solo (Config -> Bool)
-> ((Instrument, Config) -> Config) -> (Instrument, Config) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Instrument, Config) -> Config
forall a b. (a, b) -> b
snd) [(Instrument, Config)]
configs
    muted :: [Instrument]
muted = ((Instrument, Config) -> Instrument)
-> [(Instrument, Config)] -> [Instrument]
forall a b. (a -> b) -> [a] -> [b]
map (Instrument, Config) -> Instrument
forall a b. (a, b) -> a
fst ([(Instrument, Config)] -> [Instrument])
-> [(Instrument, Config)] -> [Instrument]
forall a b. (a -> b) -> a -> b
$ ((Instrument, Config) -> Bool)
-> [(Instrument, Config)] -> [(Instrument, Config)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Config -> Bool
Common.config_mute (Config -> Bool)
-> ((Instrument, Config) -> Config) -> (Instrument, Config) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Instrument, Config) -> Config
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
    | Set TrackId -> Bool
forall a. Set a -> Bool
Set.null Set TrackId
muted = [Event] -> [Event]
forall a. a -> a
id
    | Bool
otherwise = (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Event -> Bool) -> Event -> Bool
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 = (TrackId -> Bool) -> [TrackId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TrackId -> Set TrackId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
track_ids) ([TrackId] -> Bool) -> (Event -> [TrackId]) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> [TrackId]
stack_tracks
    stack_tracks :: Event -> [TrackId]
stack_tracks = (Frame -> Maybe TrackId) -> [Frame] -> [TrackId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Frame -> Maybe TrackId
Stack.track_of ([Frame] -> [TrackId]) -> (Event -> [Frame]) -> Event -> [TrackId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
Stack.innermost (Stack -> [Frame]) -> (Event -> Stack) -> Event -> [Frame]
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 <- (State -> [(BlockId, Block)]) -> m [(BlockId, Block)]
forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (Map BlockId Block -> [(BlockId, Block)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map BlockId Block -> [(BlockId, Block)])
-> (State -> Map BlockId Block) -> State -> [(BlockId, Block)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
Ui.state_blocks)
    [Tree TrackInfo]
tree <- [[Tree TrackInfo]] -> [Tree TrackInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Tree TrackInfo]] -> [Tree TrackInfo])
-> m [[Tree TrackInfo]] -> m [Tree TrackInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((BlockId, Block) -> m [Tree TrackInfo])
-> [(BlockId, Block)] -> m [[Tree TrackInfo]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BlockId -> m [Tree TrackInfo]
forall (m :: * -> *). M m => BlockId -> m [Tree TrackInfo]
TrackTree.track_tree_of (BlockId -> m [Tree TrackInfo])
-> ((BlockId, Block) -> BlockId)
-> (BlockId, Block)
-> m [Tree TrackInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockId, Block) -> BlockId
forall a b. (a, b) -> a
fst) [(BlockId, Block)]
blocks
    Set TrackId -> m (Set TrackId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set TrackId -> m (Set TrackId)) -> Set TrackId -> m (Set TrackId)
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 (Set TrackId -> Bool
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 = [TrackId] -> Set TrackId
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 TrackFlag -> Set TrackFlag -> Bool
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 = [TrackId] -> Set TrackId
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 TrackId -> Set TrackId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TrackId
soloed
    , BlockId
block_id BlockId -> Set BlockId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BlockId
soloed_blocks
    , TrackId
track_id TrackId -> Set TrackId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TrackId
has_soloed_relatives
    ]
    where
    has_soloed_relatives :: Set TrackId
has_soloed_relatives = [TrackId] -> Set TrackId
forall a. Ord a => [a] -> Set a
Set.fromList (((TrackInfo, [TrackInfo], [TrackInfo]) -> Maybe TrackId)
-> [(TrackInfo, [TrackInfo], [TrackInfo])] -> [TrackId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TrackInfo, [TrackInfo], [TrackInfo]) -> Maybe TrackId
get ([Tree TrackInfo] -> [(TrackInfo, [TrackInfo], [TrackInfo])]
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)
            | (TrackId -> Bool) -> [TrackId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TrackId -> Set TrackId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
soloed) ((TrackInfo -> TrackId) -> [TrackInfo] -> [TrackId]
forall a b. (a -> b) -> [a] -> [b]
map TrackInfo -> TrackId
Ui.track_id [TrackInfo]
children)
                    Bool -> Bool -> Bool
|| (TrackId -> Bool) -> [TrackId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TrackId -> Set TrackId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
soloed) ((TrackInfo -> TrackId) -> [TrackInfo] -> [TrackId]
forall a b. (a -> b) -> [a] -> [b]
map TrackInfo -> TrackId
Ui.track_id [TrackInfo]
parents) =
                TrackId -> Maybe TrackId
forall a. a -> Maybe a
Just (TrackInfo -> TrackId
Ui.track_id TrackInfo
track)
            | Bool
otherwise = Maybe TrackId
forall a. Maybe a
Nothing
    soloed_blocks :: Set BlockId
soloed_blocks = [BlockId] -> Set BlockId
forall a. Ord a => [a] -> Set a
Set.fromList
        [ BlockId
block_id
        | (BlockId
block_id, Block
block) <- [(BlockId, Block)]
blocks
        , (Track -> Bool) -> [Track] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((TrackFlag
Block.Solo `Set.member`) (Set TrackFlag -> Bool)
-> (Track -> Set TrackFlag) -> Track -> Bool
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) = [(Instrument, Config)] -> Map Instrument Config
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
    [ (Instrument
inst, Config
config)
    | (Instrument
inst, Allocation
alloc) <- Map Instrument Allocation -> [(Instrument, Allocation)]
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) = Config -> Maybe Config
forall a. a -> Maybe a
Just Config
a
midi_config Backend
_ = Maybe Config
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 -> Map Control Y -> Maybe (Map Control Y) -> Map Control Y
forall a. a -> Maybe a -> a
fromMaybe Map Control Y
forall a. Monoid a => a
mempty (Maybe (Map Control Y) -> Map Control Y)
-> Maybe (Map Control Y) -> Map Control Y
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 (Settings -> Maybe (Map Control Y))
-> Settings -> Maybe (Map Control Y)
forall a b. (a -> b) -> a -> b
$
                Config -> Settings
Patch.config_settings Config
config
            Backend
_ -> Maybe (Map Control Y)
forall a. Maybe a
Nothing
        Map Control Y -> Maybe (Map Control Y)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Control Y
defaults
    }