-- 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 {-# LANGUAGE CPP #-} {- | Utilities for "Derive.Call.Block". Derivation of a block is much more complicated than it might first appear. This can cause score code to be evaluated more times than you think it should be. One culprit is evaluating tracks for control signals for signal render. Under some circumstances, the track's normal control output can be directly reused as the signal render, but in many cases it has to be evaluated again. This is further complicated by the presence of inversion and orphans. -} module Derive.Call.BlockUtil ( note_deriver, control_deriver , capture_null_control , derive_tracks , has_top_tempo_track #ifdef TESTING , derive_tree #endif ) where import qualified Data.Tree as Tree import qualified Util.Log as Log import qualified Util.Seq as Seq import qualified Util.Trees as Trees import qualified Derive.Cache as Cache import qualified Derive.Control as Control import qualified Derive.Controls as Controls import qualified Derive.Derive as Derive import qualified Derive.Deriver.Internal as Internal import qualified Derive.EnvKey as EnvKey import qualified Derive.EvalTrack as EvalTrack import qualified Derive.Expr as Expr import qualified Derive.LEvent as LEvent import qualified Derive.Note as Note import qualified Derive.PSignal as PSignal import qualified Derive.ParseTitle as ParseTitle import qualified Derive.Score as Score import qualified Derive.ScoreT as ScoreT import qualified Derive.ShowVal as ShowVal import qualified Derive.Stack as Stack import qualified Derive.Stream as Stream import qualified Derive.Tempo as Tempo import qualified Perform.Signal as Signal import qualified Ui.Event as Event import qualified Ui.Events as Events import qualified Ui.TrackTree as TrackTree import qualified Ui.Ui as Ui import qualified Ui.UiConfig as UiConfig import Global import Types note_deriver :: BlockId -> Derive.NoteDeriver note_deriver :: BlockId -> NoteDeriver note_deriver BlockId block_id = do (EventsTree tree, (TrackTime, TrackTime) block_range) <- StateId (EventsTree, (TrackTime, TrackTime)) -> Deriver (EventsTree, (TrackTime, TrackTime)) forall a. HasCallStack => StateId a -> Deriver a Derive.eval_ui (StateId (EventsTree, (TrackTime, TrackTime)) -> Deriver (EventsTree, (TrackTime, TrackTime))) -> StateId (EventsTree, (TrackTime, TrackTime)) -> Deriver (EventsTree, (TrackTime, TrackTime)) forall a b. (a -> b) -> a -> b $ (,) (EventsTree -> (TrackTime, TrackTime) -> (EventsTree, (TrackTime, TrackTime))) -> StateT Identity EventsTree -> StateT Identity ((TrackTime, TrackTime) -> (EventsTree, (TrackTime, TrackTime))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> BlockId -> StateT Identity EventsTree forall (m :: * -> *). M m => BlockId -> m EventsTree TrackTree.block_events_tree BlockId block_id StateT Identity ((TrackTime, TrackTime) -> (EventsTree, (TrackTime, TrackTime))) -> StateT Identity (TrackTime, TrackTime) -> StateId (EventsTree, (TrackTime, TrackTime)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> BlockId -> StateT Identity (TrackTime, TrackTime) forall (m :: * -> *). M m => BlockId -> m (TrackTime, TrackTime) Ui.block_logical_range BlockId block_id TrackTime -> NoteDeriver -> NoteDeriver forall a. TrackTime -> Deriver a -> Deriver a with_per_block_state ((TrackTime, TrackTime) -> TrackTime forall a b. (a, b) -> b snd (TrackTime, TrackTime) block_range) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ (TrackTime, TrackTime) -> EventsTree -> NoteDeriver derive_tree (TrackTime, TrackTime) block_range EventsTree tree -- | Reset Dynamic state for a new block. with_per_block_state :: TrackTime -> Derive.Deriver a -> Derive.Deriver a with_per_block_state :: forall a. TrackTime -> Deriver a -> Deriver a with_per_block_state TrackTime end = Deriver a -> Deriver a forall {a}. Deriver a -> Deriver a clear (Deriver a -> Deriver a) -> (Deriver a -> Deriver a) -> Deriver a -> Deriver a forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> TrackTime -> Deriver a -> Deriver a forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a Derive.with_val Text EnvKey.block_end TrackTime end where clear :: Deriver a -> Deriver a clear = (Dynamic -> Dynamic) -> Deriver a -> Deriver a forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a) -> (Dynamic -> Dynamic) -> Deriver a -> Deriver a forall a b. (a -> b) -> a -> b $ \Dynamic state -> Dynamic state { state_note_track :: Maybe (BlockId, TrackId) Derive.state_note_track = Maybe (BlockId, TrackId) forall a. Maybe a Nothing , state_pitch_map :: Maybe (Maybe PSignal, [Msg]) Derive.state_pitch_map = Maybe (Maybe PSignal, [Msg]) forall a. Maybe a Nothing -- set by 'with_pitch_map' below } -- * control deriver -- | Control blocks are very restricted: they should consist of a single -- branch ending in a track with a @%@ title, which is the default control, -- which should have been set by the calling track. If the requirements are -- met, a fake note track will be appended to make this a valid note block, -- with a single note event whose only job is to collect the the default -- control. control_deriver :: BlockId -> Ui.StateId Derive.ControlDeriver control_deriver :: BlockId -> StateId ControlDeriver control_deriver BlockId block_id = do EventsTree tree <- BlockId -> StateT Identity EventsTree forall (m :: * -> *). M m => BlockId -> m EventsTree TrackTree.block_events_tree BlockId block_id (TrackTime, TrackTime) block_range <- BlockId -> StateT Identity (TrackTime, TrackTime) forall (m :: * -> *). M m => BlockId -> m (TrackTime, TrackTime) Ui.block_logical_range BlockId block_id case TrackTime -> EventsTree -> Either Text EventsTree check_control_tree ((TrackTime, TrackTime) -> TrackTime forall a b. (a, b) -> b snd (TrackTime, TrackTime) block_range) EventsTree tree of Left Text err -> Text -> StateId ControlDeriver forall (m :: * -> *) a. (HasCallStack, M m) => Text -> m a Ui.throw (Text -> StateId ControlDeriver) -> Text -> StateId ControlDeriver forall a b. (a -> b) -> a -> b $ Text "control block skeleton malformed: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text err Right EventsTree tree -> ControlDeriver -> StateId ControlDeriver forall (m :: * -> *) a. Monad m => a -> m a return (ControlDeriver -> StateId ControlDeriver) -> ControlDeriver -> StateId ControlDeriver forall a b. (a -> b) -> a -> b $ TrackTime -> ControlDeriver -> ControlDeriver forall a. TrackTime -> Deriver a -> Deriver a with_per_block_state ((TrackTime, TrackTime) -> TrackTime forall a b. (a, b) -> b snd (TrackTime, TrackTime) block_range) (ControlDeriver -> ControlDeriver) -> ControlDeriver -> ControlDeriver forall a b. (a -> b) -> a -> b $ (TrackTime, TrackTime) -> EventsTree -> ControlDeriver derive_control_tree (TrackTime, TrackTime) block_range EventsTree tree -- | Name of the call for the control deriver hack. capture_null_control :: Expr.Symbol capture_null_control :: Symbol capture_null_control = Symbol "capture-null-control" -- | Ensure the tree meets the requirements documented by 'control_deriver' -- and append the fake note track if it does. check_control_tree :: ScoreTime -> TrackTree.EventsTree -> Either Text TrackTree.EventsTree check_control_tree :: TrackTime -> EventsTree -> Either Text EventsTree check_control_tree TrackTime block_end EventsTree forest = case EventsTree forest of [] -> Text -> Either Text EventsTree forall a b. a -> Either a b Left Text "empty block" [Tree.Node Track track []] | Track -> Text TrackTree.track_title Track track Text -> Text -> Bool forall a. Eq a => a -> a -> Bool == Text "%" -> EventsTree -> Either Text EventsTree forall a b. b -> Either a b Right [Track -> EventsTree -> Tree Track forall a. a -> [Tree a] -> Tree a Tree.Node Track track [Track -> EventsTree -> Tree Track forall a. a -> [Tree a] -> Tree a Tree.Node Track capture_track []]] | Bool otherwise -> Text -> Either Text EventsTree forall a b. a -> Either a b Left (Text -> Either Text EventsTree) -> Text -> Either Text EventsTree forall a b. (a -> b) -> a -> b $ Text "skeleton must end in % track, ends with " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text -> Text forall a. Show a => a -> Text showt (Track -> Text TrackTree.track_title Track track) [Tree.Node Track track EventsTree subs] -> do EventsTree subs <- TrackTime -> EventsTree -> Either Text EventsTree check_control_tree TrackTime block_end EventsTree subs EventsTree -> Either Text EventsTree forall (m :: * -> *) a. Monad m => a -> m a return [Track -> EventsTree -> Tree Track forall a. a -> [Tree a] -> Tree a Tree.Node Track track EventsTree subs] EventsTree tracks -> Text -> Either Text EventsTree forall a b. a -> Either a b Left (Text -> Either Text EventsTree) -> Text -> Either Text EventsTree forall a b. (a -> b) -> a -> b $ Text "skeleton must have only a single branch, " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text "but there are multiple children: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> [Text] -> Text forall a. Show a => a -> Text showt ((Tree Track -> Text) -> EventsTree -> [Text] forall a b. (a -> b) -> [a] -> [b] map (Track -> Text TrackTree.track_title (Track -> Text) -> (Tree Track -> Track) -> Tree Track -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . Tree Track -> Track forall a. Tree a -> a Tree.rootLabel) EventsTree tracks) where events :: Events events = Event -> Events Events.singleton (Event -> Events) -> Event -> Events forall a b. (a -> b) -> a -> b $ TrackTime -> TrackTime -> Text -> Event Event.event TrackTime 0 TrackTime block_end (Symbol -> Text Expr.unsym Symbol capture_null_control) capture_track :: Track capture_track = Text -> Events -> TrackTime -> Track TrackTree.make_track Text ">" Events events TrackTime block_end derive_control_tree :: (ScoreTime, ScoreTime) -> TrackTree.EventsTree -> Derive.ControlDeriver derive_control_tree :: (TrackTime, TrackTime) -> EventsTree -> ControlDeriver derive_control_tree (TrackTime, TrackTime) block_range EventsTree tree = do -- There are an awful lot of things that can go wrong. I guess that's why -- this is a hack. Stream Event events <- (TrackTime, TrackTime) -> EventsTree -> NoteDeriver derive_tree (TrackTime, TrackTime) block_range EventsTree tree case Stream Event -> ([Event], [Msg]) forall a. Stream a -> ([a], [Msg]) Stream.partition Stream Event events of ([Event event], [Msg] logs) -> case Control -> Event -> Maybe (Typed Control) Score.event_control Control Controls.null Event event of Maybe (Typed Control) Nothing -> Text -> ControlDeriver forall a. HasCallStack => Text -> Deriver a Derive.throw Text "control call didn't emit Controls.null" Just Typed Control signal -> Stream Control -> ControlDeriver forall (m :: * -> *) a. Monad m => a -> m a return (Stream Control -> ControlDeriver) -> Stream Control -> ControlDeriver forall a b. (a -> b) -> a -> b $ [LEvent Control] -> Stream Control forall a. [LEvent a] -> Stream a Stream.from_sorted_list ([LEvent Control] -> Stream Control) -> [LEvent Control] -> Stream Control forall a b. (a -> b) -> a -> b $ -- The calling control itself will be providing the type since -- types are at the level of the signal as a whole. Control -> LEvent Control forall a. a -> LEvent a LEvent.Event (Typed Control -> Control forall a. Typed a -> a ScoreT.typed_val Typed Control signal) LEvent Control -> [LEvent Control] -> [LEvent Control] forall a. a -> [a] -> [a] : (Msg -> LEvent Control) -> [Msg] -> [LEvent Control] forall a b. (a -> b) -> [a] -> [b] map Msg -> LEvent Control forall a. Msg -> LEvent a LEvent.Log [Msg] logs ([Event] events, [Msg] logs) -> do Msg msg <- [Event] -> Deriver Msg forall {a}. Show a => a -> Deriver Msg complain [Event] events Stream Control -> ControlDeriver forall (m :: * -> *) a. Monad m => a -> m a return (Stream Control -> ControlDeriver) -> Stream Control -> ControlDeriver forall a b. (a -> b) -> a -> b $ [Msg] -> Stream Control forall a. [Msg] -> Stream a Stream.from_logs ([Msg] -> Stream Control) -> [Msg] -> Stream Control forall a b. (a -> b) -> a -> b $ Msg msg Msg -> [Msg] -> [Msg] forall a. a -> [a] -> [a] : [Msg] logs where -- Or I could throw, but this way any other logs the block emitted will -- also be visible, and they might have something interesting. complain :: a -> Deriver Msg complain a events = Msg -> Deriver Msg Derive.initialize_log_msg (Msg -> Deriver Msg) -> Msg -> Deriver Msg forall a b. (a -> b) -> a -> b $ HasCallStack => Priority -> Maybe Stack -> Text -> Msg Priority -> Maybe Stack -> Text -> Msg Log.msg Priority Log.Warn Maybe Stack forall a. Maybe a Nothing (Text -> Msg) -> Text -> Msg forall a b. (a -> b) -> a -> b $ Text "control call should have emitted a single call to " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Symbol -> Text forall a. ShowVal a => a -> Text ShowVal.show_val Symbol capture_null_control Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text " which produces a single event, but got events: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> a -> Text forall a. Show a => a -> Text showt a events -- ** implementation derive_tree :: (ScoreTime, ScoreTime) -> TrackTree.EventsTree -> Derive.NoteDeriver derive_tree :: (TrackTime, TrackTime) -> EventsTree -> NoteDeriver derive_tree (TrackTime, TrackTime) block_range EventsTree tree | Just Tree Track node <- EventsTree -> Maybe (Tree Track) has_top_tempo_track EventsTree tree = Bool -> Tree Track -> NoteDeriver derive_track Bool True Tree Track node | Bool otherwise = do -- Every block must have a tempo track as the topmost track. This is -- because Tempo.with_tempo sets up some stuff that every block needs, -- and because I need a TrackWarp for the tracks below. Y tempo <- Deriver State Error Y get_tempo Bool -> Maybe (TrackTime, TrackTime) -> Maybe TrackId -> Tempo -> NoteDeriver -> NoteDeriver forall a. Monoid a => Bool -> Maybe (TrackTime, TrackTime) -> Maybe TrackId -> Tempo -> Deriver a -> Deriver a Tempo.with_tempo Bool True ((TrackTime, TrackTime) -> Maybe (TrackTime, TrackTime) forall a. a -> Maybe a Just (TrackTime, TrackTime) block_range) Maybe TrackId forall a. Maybe a Nothing (Y -> Tempo forall {k} (kind :: k). Y -> Signal kind Signal.constant Y tempo) (EventsTree -> NoteDeriver derive_tracks EventsTree tree) where get_tempo :: Deriver State Error Y get_tempo = Text -> Deriver (Maybe Y) forall a. Typecheck a => Text -> Deriver (Maybe a) Derive.lookup_val Text EnvKey.tempo Deriver (Maybe Y) -> (Maybe Y -> Deriver State Error Y) -> Deriver State Error Y forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Maybe Y Nothing -> (Config -> Y) -> Deriver State Error Y forall a. (Config -> a) -> Deriver a Derive.get_ui_config ((Config -> Y) -> Deriver State Error Y) -> (Config -> Y) -> Deriver State Error Y forall a b. (a -> b) -> a -> b $ Default -> Y UiConfig.default_tempo (Default -> Y) -> (Config -> Default) -> Config -> Y forall b c a. (b -> c) -> (a -> b) -> a -> c . Config -> Default UiConfig.config_default Just Y tempo -> Y -> Deriver State Error Y forall (m :: * -> *) a. Monad m => a -> m a return Y tempo -- | Derive an EventsTree. derive_tracks :: TrackTree.EventsTree -> Derive.NoteDeriver derive_tracks :: EventsTree -> NoteDeriver derive_tracks = (Tree Track -> NoteDeriver) -> EventsTree -> NoteDeriver forall b a. Monoid b => (a -> b) -> [a] -> b mconcatMap (Bool -> Tree Track -> NoteDeriver derive_track Bool False) -- | Derive a single track node and any tracks below it. derive_track :: Bool -- ^ True if this is the single topmost track and is -- a tempo track. Ultimately this flag gets threaded all the way down to -- "Derive.Tempo". -> TrackTree.EventsNode -> Derive.NoteDeriver derive_track :: Bool -> Tree Track -> NoteDeriver derive_track Bool toplevel node :: Tree Track node@(Tree.Node Track track EventsTree subs) | Text -> Bool ParseTitle.is_note_track (Track -> Text TrackTree.track_title Track track) = NoteDeriver -> NoteDeriver forall {a}. Deriver a -> Deriver a with_stack (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ Track -> Set TrackId -> NoteDeriver -> NoteDeriver forall d. Cacheable d => Track -> Set TrackId -> Deriver (Stream d) -> Deriver (Stream d) Cache.track Track track (Tree Track -> Set TrackId TrackTree.track_children Tree Track node) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ do Stream Event events <- Track -> NoteDeriver -> NoteDeriver forall {a}. Track -> Deriver a -> Deriver a with_voice Track track (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ Track -> EventsTree -> NoteDeriver -> NoteDeriver forall a. Track -> EventsTree -> Deriver a -> Deriver a with_pitch_map Track track EventsTree subs (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ (NoteDeriver -> NoteDeriver) -> (TrackId -> NoteDeriver -> NoteDeriver) -> Maybe TrackId -> NoteDeriver -> NoteDeriver forall b a. b -> (a -> b) -> Maybe a -> b maybe NoteDeriver -> NoteDeriver forall a. a -> a id TrackId -> NoteDeriver -> NoteDeriver forall a. TrackId -> Deriver a -> Deriver a with_note_track (Track -> Maybe TrackId TrackTree.track_id Track track) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ (EventsTree -> NoteDeriver) -> Tree Track -> NoteDeriver Note.d_note_track EventsTree -> NoteDeriver derive_tracks Tree Track node Bool -> Deriver State Error () -> Deriver State Error () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Track -> Sliced TrackTree.track_sliced Track track Sliced -> Sliced -> Bool forall a. Eq a => a -> a -> Bool == Sliced TrackTree.NotSliced) Deriver State Error () defragment (Track -> Deriver State Error ()) -> [Track] -> Deriver State Error () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (Stream Event -> Track -> Deriver State Error () Note.stash_signal_if_wanted Stream Event events) (Track -> EventsTree -> [Track] note_signal_tracks Track track EventsTree subs) Stream Event -> NoteDeriver forall (m :: * -> *) a. Monad m => a -> m a return Stream Event events | Bool otherwise = NoteDeriver -> NoteDeriver forall {a}. Deriver a -> Deriver a with_stack (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ Config -> Track -> NoteDeriver -> NoteDeriver Control.d_control_track (Bool -> Bool -> Config Control.Config Bool toplevel Bool True) Track track (EventsTree -> NoteDeriver derive_tracks EventsTree subs) where with_voice :: Track -> Deriver a -> Deriver a with_voice = (Deriver a -> Deriver a) -> (Int -> Deriver a -> Deriver a) -> Maybe Int -> Deriver a -> Deriver a forall b a. b -> (a -> b) -> Maybe a -> b maybe Deriver a -> Deriver a forall a. a -> a id (Text -> Int -> Deriver a -> Deriver a forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a Derive.with_val Text EnvKey.track_voice) (Maybe Int -> Deriver a -> Deriver a) -> (Track -> Maybe Int) -> Track -> Deriver a -> Deriver a forall b c a. (b -> c) -> (a -> b) -> a -> c . Track -> Maybe Int TrackTree.track_voice defragment :: Deriver State Error () defragment = do Warp warp <- Deriver Warp Internal.get_warp (Collect -> Collect) -> Deriver State Error () Internal.modify_collect ((Collect -> Collect) -> Deriver State Error ()) -> (Collect -> Collect) -> Deriver State Error () forall a b. (a -> b) -> a -> b $ Warp -> Collect -> Collect EvalTrack.defragment_track_signals Warp warp with_stack :: Deriver a -> Deriver a with_stack = (Deriver a -> Deriver a) -> (TrackId -> Deriver a -> Deriver a) -> Maybe TrackId -> Deriver a -> Deriver a forall b a. b -> (a -> b) -> Maybe a -> b maybe Deriver a -> Deriver a forall a. a -> a id TrackId -> Deriver a -> Deriver a forall a. TrackId -> Deriver a -> Deriver a Internal.with_stack_track (Track -> Maybe TrackId TrackTree.track_id Track track) with_note_track :: TrackId -> Derive.Deriver a -> Derive.Deriver a with_note_track :: forall a. TrackId -> Deriver a -> Deriver a with_note_track TrackId track_id Deriver a deriver = do Maybe BlockId maybe_block_id <- [Maybe BlockId] -> Maybe BlockId forall (t :: * -> *) (m :: * -> *) a. (Foldable t, MonadPlus m) => t (m a) -> m a msum ([Maybe BlockId] -> Maybe BlockId) -> (Stack -> [Maybe BlockId]) -> Stack -> Maybe BlockId forall b c a. (b -> c) -> (a -> b) -> a -> c . (Frame -> Maybe BlockId) -> [Frame] -> [Maybe BlockId] forall a b. (a -> b) -> [a] -> [b] map Frame -> Maybe BlockId Stack.block_of ([Frame] -> [Maybe BlockId]) -> (Stack -> [Frame]) -> Stack -> [Maybe BlockId] forall b c a. (b -> c) -> (a -> b) -> a -> c . Stack -> [Frame] Stack.innermost (Stack -> Maybe BlockId) -> Deriver State Error Stack -> Deriver State Error (Maybe BlockId) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Deriver State Error Stack Internal.get_stack (Deriver a -> Deriver a) -> (BlockId -> Deriver a -> Deriver a) -> Maybe BlockId -> Deriver a -> Deriver a forall b a. b -> (a -> b) -> Maybe a -> b maybe Deriver a -> Deriver a forall a. a -> a id BlockId -> Deriver a -> Deriver a forall {a}. BlockId -> Deriver a -> Deriver a with Maybe BlockId maybe_block_id Deriver a deriver where with :: BlockId -> Deriver a -> Deriver a with BlockId block_id = (Dynamic -> Dynamic) -> Deriver a -> Deriver a forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a) -> (Dynamic -> Dynamic) -> Deriver a -> Deriver a forall a b. (a -> b) -> a -> b $ \Dynamic state -> Dynamic state { state_note_track :: Maybe (BlockId, TrackId) Derive.state_note_track = (BlockId, TrackId) -> Maybe (BlockId, TrackId) forall a. a -> Maybe a Just (BlockId block_id, TrackId track_id) } -- | Extract tracks that might want to stash a signal. -- -- A note track can display a signal, extracted from the events it generates. -- But if the track has orphan sub-tracks, its events will be evaluated -- separately, either directly as orphans, or indirectly as the children of the -- non-orphan sections. At the moment it seems simpler to collect all the -- events of the whole set of tracks and consider them the output of all of -- them. note_signal_tracks :: TrackTree.Track -> TrackTree.EventsTree -> [TrackTree.Track] note_signal_tracks :: Track -> EventsTree -> [Track] note_signal_tracks Track track EventsTree subs = case Track -> Sliced TrackTree.track_sliced Track track of Sliced TrackTree.NotSliced -> Track track Track -> [Track] -> [Track] forall a. a -> [a] -> [a] : (Track -> Bool) -> [Track] -> [Track] forall a. (a -> Bool) -> [a] -> [a] filter Track -> Bool is_note ((Tree Track -> [Track]) -> EventsTree -> [Track] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Tree Track -> [Track] forall a. Tree a -> [a] Tree.flatten EventsTree subs) Sliced _ -> [] where is_note :: Track -> Bool is_note = Text -> Bool ParseTitle.is_note_track (Text -> Bool) -> (Track -> Text) -> Track -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Track -> Text TrackTree.track_title -- | The tempo track, if the top level track is a tempo track. has_top_tempo_track :: [Tree.Tree TrackTree.Track] -> Maybe (Tree.Tree TrackTree.Track) has_top_tempo_track :: EventsTree -> Maybe (Tree Track) has_top_tempo_track EventsTree tree = case EventsTree tree of [node :: Tree Track node@(Tree.Node Track track EventsTree _)] | Track -> Bool is_tempo Track track -> Tree Track -> Maybe (Tree Track) forall a. a -> Maybe a Just Tree Track node EventsTree _ -> Maybe (Tree Track) forall a. Maybe a Nothing where is_tempo :: Track -> Bool is_tempo = Text -> Bool ParseTitle.is_tempo_track (Text -> Bool) -> (Track -> Text) -> Track -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Track -> Text TrackTree.track_title -- * track pitch map -- | Given an event track, look for a pitch track below it, and derive it -- standalone. If there is none, then take 'Derive.state_pitch'. Put this -- into 'Derive.state_pitch_map'. with_pitch_map :: TrackTree.Track -> TrackTree.EventsTree -> Derive.Deriver a -> Derive.Deriver a with_pitch_map :: forall a. Track -> EventsTree -> Deriver a -> Deriver a with_pitch_map Track track EventsTree subs Deriver a deriver = case Track -> Sliced TrackTree.track_sliced Track track of Sliced TrackTree.NotSliced -> do (Maybe PSignal, [Msg]) pmap <- EventsTree -> Deriver (Maybe PSignal, [Msg]) get_pitch_map EventsTree subs (Dynamic -> Dynamic) -> Deriver a -> Deriver a forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a Internal.local (\Dynamic state -> Dynamic state { state_pitch_map :: Maybe (Maybe PSignal, [Msg]) Derive.state_pitch_map = (Maybe PSignal, [Msg]) -> Maybe (Maybe PSignal, [Msg]) forall a. a -> Maybe a Just (Maybe PSignal, [Msg]) pmap }) Deriver a deriver Sliced _ -> Deriver a deriver get_pitch_map :: TrackTree.EventsTree -> Derive.Deriver (Maybe PSignal.PSignal, [Log.Msg]) get_pitch_map :: EventsTree -> Deriver (Maybe PSignal, [Msg]) get_pitch_map EventsTree subs = case EventsTree -> Maybe Track pitch_map_track EventsTree subs of Just Track pitch_track -> do State state <- Deriver State Error State forall st err. Deriver st err st Derive.get (Maybe PSignal, [Msg]) -> Deriver (Maybe PSignal, [Msg]) forall (m :: * -> *) a. Monad m => a -> m a return ((Maybe PSignal, [Msg]) -> Deriver (Maybe PSignal, [Msg])) -> (Maybe PSignal, [Msg]) -> Deriver (Maybe PSignal, [Msg]) forall a b. (a -> b) -> a -> b $ State -> Track -> (Maybe PSignal, [Msg]) derive_pitch_map State state Track pitch_track Maybe Track Nothing -> do PSignal sig <- (Dynamic -> PSignal) -> Deriver PSignal forall a. (Dynamic -> a) -> Deriver a Internal.get_dynamic Dynamic -> PSignal Derive.state_pitch (Maybe PSignal, [Msg]) -> Deriver (Maybe PSignal, [Msg]) forall (m :: * -> *) a. Monad m => a -> m a return (PSignal -> Maybe PSignal forall a. a -> Maybe a Just PSignal sig, []) -- | Derive the given pitch track lazily. -- -- It uses a hack similar to control blocks, e.g. 'derive_control_tree'. derive_pitch_map :: Derive.State -> TrackTree.Track -> (Maybe PSignal.PSignal, [Log.Msg]) derive_pitch_map :: State -> Track -> (Maybe PSignal, [Msg]) derive_pitch_map State state Track pitch_track = case Either Error PSignal result of Right PSignal sig -> (PSignal -> Maybe PSignal forall a. a -> Maybe a Just PSignal sig, [Msg] logs) Left Error err -> (Maybe PSignal forall a. Maybe a Nothing, Error -> Msg Derive.error_to_warn Error err Msg -> [Msg] -> [Msg] forall a. a -> [a] -> [a] : [Msg] logs) where (Either Error PSignal result, State _, [Msg] logs) = State -> Deriver PSignal -> (Either Error PSignal, State, [Msg]) forall st err a. st -> Deriver st err a -> RunResult st err a Derive.run State stripped (Track -> Deriver PSignal derive Track pitch_track) stripped :: State stripped = State state { state_dynamic :: Dynamic Derive.state_dynamic = (State -> Dynamic Derive.state_dynamic State state) -- As documented by 'Derive.state_pitch_map'. { state_pitch_map :: Maybe (Maybe PSignal, [Msg]) Derive.state_pitch_map = Maybe (Maybe PSignal, [Msg]) forall a. Maybe a Nothing } } derive :: Track -> Deriver PSignal derive Track pitch_track = do ([Event] events, [Msg] logs) <- Stream Event -> ([Event], [Msg]) forall a. Stream a -> ([a], [Msg]) Stream.partition (Stream Event -> ([Event], [Msg])) -> NoteDeriver -> Deriver State Error ([Event], [Msg]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> NoteDeriver -> NoteDeriver forall {a}. Deriver a -> Deriver a Internal.in_real_time (Config -> Track -> NoteDeriver -> NoteDeriver Control.d_control_track Config config Track pitch_track NoteDeriver capture) (Msg -> Deriver State Error ()) -> [Msg] -> Deriver State Error () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ Msg -> Deriver State Error () forall (m :: * -> *). LogMonad m => Msg -> m () Log.write [Msg] logs Text -> Maybe PSignal -> Deriver PSignal forall a. HasCallStack => Text -> Maybe a -> Deriver a Derive.require Text "get_pitch_map: no event" (Maybe PSignal -> Deriver PSignal) -> Maybe PSignal -> Deriver PSignal forall a b. (a -> b) -> a -> b $ Event -> PSignal Score.event_pitch (Event -> PSignal) -> Maybe Event -> Maybe PSignal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Event] -> Maybe Event forall a. [a] -> Maybe a Seq.head [Event] events config :: Config config = Control.Config { config_toplevel_tempo :: Bool config_toplevel_tempo = Bool False , config_use_cache :: Bool config_use_cache = Bool False } capture :: Derive.NoteDeriver capture :: NoteDeriver capture = do PSignal pitch <- (Dynamic -> PSignal) -> Deriver PSignal forall a. (Dynamic -> a) -> Deriver a Internal.get_dynamic Dynamic -> PSignal Derive.state_pitch Stream Event -> NoteDeriver forall (m :: * -> *) a. Monad m => a -> m a return (Stream Event -> NoteDeriver) -> Stream Event -> NoteDeriver forall a b. (a -> b) -> a -> b $ Event -> Stream Event forall a. a -> Stream a Stream.from_event (Event -> Stream Event) -> Event -> Stream Event forall a b. (a -> b) -> a -> b $ Event Score.empty_event { event_pitch :: PSignal Score.event_pitch = PSignal pitch } pitch_map_track :: TrackTree.EventsTree -> Maybe TrackTree.Track pitch_map_track :: EventsTree -> Maybe Track pitch_map_track = (Tree Track -> Track) -> Maybe (Tree Track) -> Maybe Track forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Tree Track -> Track forall a. Tree a -> a Tree.rootLabel (Maybe (Tree Track) -> Maybe Track) -> (EventsTree -> Maybe (Tree Track)) -> EventsTree -> Maybe Track forall b c a. (b -> c) -> (a -> b) -> a -> c . (Track -> Bool) -> EventsTree -> Maybe (Tree Track) forall a. (a -> Bool) -> [Tree a] -> Maybe (Tree a) Trees.find Track -> Bool is_pitch where is_pitch :: Track -> Bool is_pitch = Text -> Bool ParseTitle.is_pitch_track (Text -> Bool) -> (Track -> Text) -> Track -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Track -> Text TrackTree.track_title