-- 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 #-} -- | The 'convert' function and support. module Cmd.Integrate.Convert ( Track(..), Tracks , convert #ifdef TESTING , module Cmd.Integrate.Convert #endif ) where import qualified Data.Either as Either import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified Util.Lists as Lists import qualified Util.Log as Log import qualified Util.Pretty as Pretty import qualified Util.Texts as Texts import qualified Cmd.Cmd as Cmd import qualified Cmd.Perf as Perf import qualified Derive.Call as Call import qualified Derive.Controls as Controls import qualified Derive.Derive as Derive import qualified Derive.Env as Env import qualified Derive.EnvKey as EnvKey import qualified Derive.Expr as Expr 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 Instrument.Common as Common import qualified Perform.Pitch as Pitch import qualified Perform.RealTime as RealTime import qualified Perform.Signal as Signal import qualified Ui.Event as Event import qualified Ui.Ui as Ui import Global import Types -- | Include flags as a comment in generated events, for debugging. It -- clutters the output though. TODO: need a better way debug :: Bool debug :: Bool debug = Bool False type Error = Text type Title = Text -- | A simplified description of a UI track, as collected by -- "Derive.Call.Integrate". data Track = Track { Track -> Text track_title :: !Title , Track -> [Event] track_events :: ![Event.Event] } deriving (Track -> Track -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Track -> Track -> Bool $c/= :: Track -> Track -> Bool == :: Track -> Track -> Bool $c== :: Track -> Track -> Bool Eq, Voice -> Track -> ShowS [Track] -> ShowS Track -> String forall a. (Voice -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Track] -> ShowS $cshowList :: [Track] -> ShowS show :: Track -> String $cshow :: Track -> String showsPrec :: Voice -> Track -> ShowS $cshowsPrec :: Voice -> Track -> ShowS Show) instance Pretty Track where format :: Track -> Doc format (Track Text title [Event] events) = Doc -> [(Text, Doc)] -> Doc Pretty.record Doc "Track" [ (Text "title", forall a. Pretty a => a -> Doc Pretty.format Text title) , (Text "events", forall a. Pretty a => a -> Doc Pretty.format [Event] events) ] -- | (note track, control tracks) type Tracks = [(Track, [Track])] type Config = (GetCallMap, Pitch.ScaleId) type GetCallMap = ScoreT.Instrument -> Common.CallMap -- | Convert 'Score.Event's to 'Tracks'. This involves splitting overlapping -- events into tracks, and trying to map low level notation back to high level. convert :: Cmd.M m => BlockId -> Stream.Stream Score.Event -> m Tracks convert :: forall (m :: * -> *). M m => BlockId -> Stream Event -> m Tracks convert BlockId source_block Stream Event stream = do Instrument -> Maybe ResolvedInstrument lookup_inst <- forall (m :: * -> *). M m => m (Instrument -> Maybe ResolvedInstrument) Cmd.get_lookup_instrument let get_call_map :: Instrument -> CallMap get_call_map = forall b a. b -> (a -> b) -> Maybe a -> b maybe forall a. Monoid a => a mempty (forall code. Common code -> CallMap Common.common_call_map forall b c a. (b -> c) -> (a -> b) -> a -> c . ResolvedInstrument -> Common InstrumentCode Cmd.inst_common) forall b c a. (b -> c) -> (a -> b) -> a -> c . Instrument -> Maybe ResolvedInstrument lookup_inst ScaleId default_scale_id <- forall (m :: * -> *). M m => m ScaleId Perf.default_scale_id Map TrackId Voice tracknums <- forall k a. Ord k => [(k, a)] -> Map k a Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> m [(TrackId, Voice)] Ui.tracknums_of BlockId source_block let ([Event] events, [Msg] logs) = forall a. Stream a -> ([a], [Msg]) Stream.partition Stream Event stream ([Text] errs, Tracks tracks) = Config -> Map TrackId Voice -> [Event] -> ([Text], Tracks) integrate (Instrument -> CallMap get_call_map, ScaleId default_scale_id) Map TrackId Voice tracknums [Event] events forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (forall (m :: * -> *). LogMonad m => Msg -> m () Log.write forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> Msg -> Msg Log.add_prefix Text "integrate") [Msg] logs -- If something failed to derive I shouldn't integrate that into the block. forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any ((forall a. Ord a => a -> a -> Bool >=Priority Log.Warn) forall b c a. (b -> c) -> (a -> b) -> a -> c . Msg -> Priority Log.msg_priority) [Msg] logs) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. (Stack, M m) => Text -> m a Cmd.throw Text "aborting integrate due to warnings" forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (forall (t :: * -> *) a. Foldable t => t a -> Bool null [Text] errs) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. (Stack, M m) => Text -> m a Cmd.throw forall a b. (a -> b) -> a -> b $ Text "integrating events: " forall a. Semigroup a => a -> a -> a <> Text -> [Text] -> Text Text.intercalate Text "; " [Text] errs forall (m :: * -> *) a. Monad m => a -> m a return Tracks tracks -- | Convert derived score events back into UI events. integrate :: Config -> Map TrackId TrackNum -> [Score.Event] -> ([Error], Tracks) integrate :: Config -> Map TrackId Voice -> [Event] -> ([Text], Tracks) integrate Config config Map TrackId Voice tracknums = forall a b. [Either a b] -> ([a], [b]) Either.partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (Config -> (TrackKey, [Event]) -> Either Text (Track, [Track]) integrate_track Config config) forall b c a. (b -> c) -> (a -> b) -> a -> c . Map TrackId Voice -> [Event] -> [(TrackKey, [Event])] allocate_tracks Map TrackId Voice tracknums -- | Allocate the events to separate tracks. allocate_tracks :: Map TrackId TrackNum -> [Score.Event] -> [(TrackKey, [Score.Event])] allocate_tracks :: Map TrackId Voice -> [Event] -> [(TrackKey, [Event])] allocate_tracks Map TrackId Voice tracknums = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall {a}. (a, [Event]) -> [(a, [Event])] overlap forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])] Lists.keyedGroupSort Event -> TrackKey group_key where overlap :: (a, [Event]) -> [(a, [Event])] overlap (a key, [Event] events) = forall a b. (a -> b) -> [a] -> [b] map ((,) a key) ([Event] -> [[Event]] split_overlapping [Event] events) -- Sort by tracknum so an integrated block's tracks come out in the same -- order as the original. group_key :: Score.Event -> TrackKey group_key :: Event -> TrackKey group_key Event event = ( TrackId -> Maybe Voice tracknum_of forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Event -> Maybe TrackId track_of Event event , Event -> Instrument Score.event_instrument Event event , PSignal -> ScaleId PSignal.sig_scale_id (Event -> PSignal Score.event_pitch Event event) , Event -> Maybe Voice event_voice Event event , Event -> Maybe Hand event_hand Event event ) tracknum_of :: TrackId -> Maybe Voice tracknum_of TrackId tid = forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup TrackId tid Map TrackId Voice tracknums -- | Split events into separate lists of non-overlapping events. split_overlapping :: [Score.Event] -> [[Score.Event]] split_overlapping :: [Event] -> [[Event]] split_overlapping [] = [] split_overlapping [Event] events = [Event] track forall a. a -> [a] -> [a] : [Event] -> [[Event]] split_overlapping [Event] rest where -- Go through the track and collect non-overlapping events, then do it -- recursively until there are none left. ([Event] track, [Event] rest) = forall a b. [Either a b] -> ([a], [b]) Either.partitionEithers ([Event] -> [Either Event Event] strip [Event] events) strip :: [Event] -> [Either Event Event] strip [] = [] strip (Event event:[Event] events) = forall a b. a -> Either a b Left Event event forall a. a -> [a] -> [a] : forall a b. (a -> b) -> [a] -> [b] map forall a b. b -> Either a b Right [Event] overlapping forall a. [a] -> [a] -> [a] ++ [Event] -> [Either Event Event] strip [Event] rest where ([Event] overlapping, [Event] rest) = forall a. (a -> Bool) -> [a] -> ([a], [a]) span (Event -> Event -> Bool overlaps Event event) [Event] events overlaps :: Score.Event -> Score.Event -> Bool overlaps :: Event -> Event -> Bool overlaps Event e1 Event e2 = Event -> RealTime Score.event_start Event e2 forall a. Ord a => a -> a -> Bool < Event -> RealTime Score.event_end Event e1 Bool -> Bool -> Bool || Event -> RealTime Score.event_start Event e1 forall a. Eq a => a -> a -> Bool == Event -> RealTime Score.event_start Event e2 event_voice :: Score.Event -> Maybe Voice event_voice :: Event -> Maybe Voice event_voice = forall a. Typecheck a => Text -> Environ -> Maybe a Env.maybe_val Text EnvKey.voice forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Environ Score.event_environ event_hand :: Score.Event -> Maybe Call.Hand event_hand :: Event -> Maybe Hand event_hand = forall a. Typecheck a => Text -> Environ -> Maybe a Env.maybe_val Text EnvKey.hand forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Environ Score.event_environ track_of :: Score.Event -> Maybe TrackId track_of :: Event -> Maybe TrackId track_of = forall a. [a] -> Maybe a Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c . 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 -- | This determines how tracks are split when integration recreates track -- structure. type TrackKey = ( Maybe TrackNum, ScoreT.Instrument, Pitch.ScaleId , Maybe Voice, Maybe Call.Hand ) type Voice = Int integrate_track :: Config -> (TrackKey, [Score.Event]) -> Either Error (Track, [Track]) integrate_track :: Config -> (TrackKey, [Event]) -> Either Text (Track, [Track]) integrate_track (Instrument -> CallMap get_call_map, ScaleId default_scale_id) ((Maybe Voice _, Instrument inst, ScaleId scale_id, Maybe Voice voice, Maybe Hand hand), [Event] events) = do [Track] pitch_track <- if [Event] -> Bool no_pitch_signals [Event] events Bool -> Bool -> Bool || Bool no_scale then forall (m :: * -> *) a. Monad m => a -> m a return [] else case ScaleId -> [Event] -> (Track, [Text]) pitch_events ScaleId sid forall a b. (a -> b) -> a -> b $ [Event] events of (Track track, []) -> forall (m :: * -> *) a. Monad m => a -> m a return [Track track] (Track _, [Text] errs) -> forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ Text -> [Text] -> Text Text.intercalate Text "; " [Text] errs forall (m :: * -> *) a. Monad m => a -> m a return ( Instrument -> (Maybe Voice, Maybe Hand) -> CallMap -> [Event] -> Track note_events Instrument inst (Maybe Voice voice, Maybe Hand hand) (Instrument -> CallMap get_call_map Instrument inst) [Event] events , [Track] pitch_track forall a. [a] -> [a] -> [a] ++ [Event] -> [Track] control_events [Event] events ) where -- Instruments like mridangam '(natural)' call use this for ambient pitch. no_scale :: Bool no_scale = ScaleId scale_id forall a. Eq a => a -> a -> Bool == Scale -> ScaleId PSignal.pscale_scale_id Scale PSignal.no_scale sid :: ScaleId sid = if ScaleId scale_id forall a. Eq a => a -> a -> Bool == ScaleId default_scale_id then ScaleId Pitch.empty_scale else ScaleId scale_id -- ** note note_events :: ScoreT.Instrument -> (Maybe Voice, Maybe Call.Hand) -> Common.CallMap -> [Score.Event] -> Track note_events :: Instrument -> (Maybe Voice, Maybe Hand) -> CallMap -> [Event] -> Track note_events Instrument inst (Maybe Voice voice, Maybe Hand hand) CallMap call_map [Event] events = Text -> [Event] -> Track make_track Text note_title (forall a b. (a -> b) -> [a] -> [b] map (CallMap -> Event -> Event note_event CallMap call_map) [Event] events) where note_title :: Text note_title = Text -> [Text] -> Text Text.intercalate Text " | " forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] filter (forall a. Eq a => a -> a -> Bool /=Text "") [ Instrument -> Text ParseTitle.instrument_to_title Instrument inst , forall {a}. ShowVal a => Text -> Maybe a -> Text add_env Text EnvKey.voice Maybe Voice voice , forall {a}. ShowVal a => Text -> Maybe a -> Text add_env Text EnvKey.hand Maybe Hand hand ] add_env :: Text -> Maybe a -> Text add_env Text key = forall b a. b -> (a -> b) -> Maybe a -> b maybe Text "" (((Text key forall a. Semigroup a => a -> a -> a <> Text "=")<>) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. ShowVal a => a -> Text ShowVal.show_val) note_event :: Common.CallMap -> Score.Event -> Event.Event note_event :: CallMap -> Event -> Event note_event CallMap call_map Event event = Stack -> TrackTime -> TrackTime -> Text -> Event ui_event (Event -> Stack Score.event_stack Event event) (RealTime -> TrackTime RealTime.to_score (Event -> RealTime Score.event_start Event event)) (RealTime -> TrackTime RealTime.to_score (Event -> RealTime Score.event_duration Event event)) (CallMap -> Event -> Text note_call CallMap call_map Event event) note_call :: Common.CallMap -> Score.Event -> Text note_call :: CallMap -> Event -> Text note_call CallMap call_map Event event = forall a. Textlike a => a -> a -> a -> a Texts.join2 Text " -- " Text text Text comment where text :: Text text | Event -> Text Score.event_integrate Event event forall a. Eq a => a -> a -> Bool /= Text "" = Event -> Text Score.event_integrate Event event | Just Symbol sym <- forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Attributes attrs CallMap call_map = Symbol -> Text Expr.unsym Symbol sym | Attributes attrs forall a. Eq a => a -> a -> Bool /= forall a. Monoid a => a mempty = forall a. ShowVal a => a -> Text ShowVal.show_val Attributes attrs | Bool otherwise = Text "" where attrs :: Attributes attrs = Event -> Attributes Score.event_attributes Event event -- Append flags to help with debugging. The presence of a flag -- probably means some postproc step wasn't applied. comment :: Text comment | Bool debug Bool -> Bool -> Bool && Flags flags forall a. Eq a => a -> a -> Bool /= forall a. Monoid a => a mempty = forall a. Pretty a => a -> Text pretty Flags flags | Bool otherwise = Text "" where flags :: Flags flags = Event -> Flags Score.event_flags Event event -- ** pitch -- | Unlike 'control_events', this only drops dups that occur within the same -- event. This is because it's more normal to think of each note as -- establishing a new pitch, even if it's the same as the last one. pitch_events :: Pitch.ScaleId -> [Score.Event] -> (Track, [Error]) pitch_events :: ScaleId -> [Event] -> (Track, [Text]) pitch_events ScaleId scale_id [Event] events = (Text -> [Event] -> Track make_track Text pitch_title ([[Event]] -> [Event] tidy_pitches [[Event]] ui_events), forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [[Text]] errs) where pitch_title :: Text pitch_title = ScaleId -> Text ParseTitle.scale_to_title ScaleId scale_id ([[Event]] ui_events, [[Text]] errs) = forall a b. [(a, b)] -> ([a], [b]) unzip forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map Event -> ([Event], [Text]) pitch_signal_events [Event] events tidy_pitches :: [[Event]] -> [Event] tidy_pitches = [Event] -> [Event] clip_to_zero forall b c a. (b -> c) -> (a -> b) -> a -> c . [[Event]] -> [Event] clip_concat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map [Event] -> [Event] drop_dups no_pitch_signals :: [Score.Event] -> Bool no_pitch_signals :: [Event] -> Bool no_pitch_signals = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all (PSignal -> Bool PSignal.null forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> PSignal Score.event_pitch) -- | Convert an event's pitch signal to symbolic note names. This uses -- 'PSignal.pitch_note', which handles a constant transposition, but not -- continuous pitch changes (it's not even clear how to spell those). I could -- try to convert back from NoteNumbers, but I still have the problem of how -- to convert the curve back to high level pitches. pitch_signal_events :: Score.Event -> ([Event.Event], [Error]) pitch_signal_events :: Event -> ([Event], [Text]) pitch_signal_events Event event = ([Event] ui_events, [Text] pitch_errs) where start :: RealTime start = Event -> RealTime Score.event_start Event event ([RealTime] xs, [Pitch] ys) = forall a b. [(a, b)] -> ([a], [b]) unzip forall a b. (a -> b) -> a -> b $ PSignal -> [(RealTime, Pitch)] PSignal.to_pairs forall a b. (a -> b) -> a -> b $ RealTime -> PSignal -> PSignal PSignal.clip_before RealTime start forall a b. (a -> b) -> a -> b $ Event -> PSignal Score.event_pitch Event event pitches :: [(RealTime, Pitch, Either PitchError Note)] pitches = forall a b c. [a] -> [b] -> [c] -> [(a, b, c)] zip3 [RealTime] xs [Pitch] ys (forall a b. (a -> b) -> [a] -> [b] map (Transposed -> Either PitchError Note PSignal.pitch_note forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> RealTime -> Pitch -> Transposed Score.apply_controls Event event RealTime start) [Pitch] ys) pitch_errs :: [Text] pitch_errs = [ forall a. Pretty a => a -> Text pretty RealTime x forall a. Semigroup a => a -> a -> a <> Text ": converting " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Pitch p forall a. Semigroup a => a -> a -> a <> Text " " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty PitchError err | (RealTime x, Pitch p, Left PitchError err) <- [(RealTime, Pitch, Either PitchError Note)] pitches ] ui_events :: [Event] ui_events = [ Stack -> TrackTime -> TrackTime -> Text -> Event ui_event (Event -> Stack Score.event_stack Event event) (RealTime -> TrackTime RealTime.to_score RealTime x) TrackTime 0 (Note -> Text Pitch.note_text Note note) | (RealTime x, Pitch _, Right Note note) <- [(RealTime, Pitch, Either PitchError Note)] pitches ] -- ** control control_events :: [Score.Event] -> [Track] control_events :: [Event] -> [Track] control_events [Event] events = forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . Track -> Bool empty_track) forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map ([Event] -> Typed Control -> Track control_track [Event] events) [Typed Control] controls where controls :: [Typed Control] controls = forall a. Ord a => [a] -> [a] List.sort forall a b. (a -> b) -> a -> b $ forall a. Ord a => [a] -> [a] Lists.unique forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap (forall a b. (a -> b) -> [a] -> [b] map forall {a} {a}. (a, Typed a) -> Typed a typed_control forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] filter forall {b}. (Control, b) -> Bool wanted forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Map k a -> [(k, a)] Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> ControlMap Score.event_controls) [Event] events -- The integrate calls always include these because they affect the -- pitches. 'pitch_signal_events' will have already applied them though, -- so we don't need to have them again. -- TODO: technically they should be from pscale_transposers, but that's -- so much work to collect, let's just assume the standards. wanted :: (Control, b) -> Bool wanted = (forall a. Ord a => a -> Set a -> Bool `Set.notMember` Set Control Controls.integrate_keep) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst typed_control :: (a, Typed a) -> Typed a typed_control (a control, Typed a sig) = forall a. Type -> a -> Typed a ScoreT.Typed (forall a. Typed a -> Type ScoreT.type_of Typed a sig) a control control_track :: [Score.Event] -> ScoreT.Typed ScoreT.Control -> Track control_track :: [Event] -> Typed Control -> Track control_track [Event] events Typed Control control = Text -> [Event] -> Track make_track (Typed Control -> Text ParseTitle.control_to_title Typed Control control) [Event] ui_events where ui_events :: [Event] ui_events = [Event] -> [Event] drop_dyn forall a b. (a -> b) -> a -> b $ [[Event]] -> [Event] tidy_controls forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (Control -> Event -> [Event] signal_events Control c) [Event] events -- Don't emit a dyn track if it's just the default. drop_dyn :: [Event] -> [Event] drop_dyn [Event] events = case forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Control c Map Control Y Derive.initial_control_vals of Just Y val | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all ((forall a. Eq a => a -> a -> Bool ==Text t) forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Text Event.text) [Event] events -> [] where t :: Text t = Y -> Text ShowVal.show_hex_val Y val Maybe Y _ -> [Event] events tidy_controls :: [[Event]] -> [Event] tidy_controls = [Event] -> [Event] clip_to_zero forall b c a. (b -> c) -> (a -> b) -> a -> c . [Event] -> [Event] drop_dups forall b c a. (b -> c) -> (a -> b) -> a -> c . [[Event]] -> [Event] clip_concat c :: Control c = forall a. Typed a -> a ScoreT.val_of Typed Control control signal_events :: ScoreT.Control -> Score.Event -> [Event.Event] signal_events :: Control -> Event -> [Event] signal_events Control control Event event = case Control -> Event -> Maybe (Typed Control) Score.event_control Control control Event event of Maybe (Typed Control) Nothing -> [] Just Typed Control sig -> forall a b. (a -> b) -> [a] -> [b] map (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry RealTime -> Y -> Event mk) forall a b. (a -> b) -> a -> b $ forall {k} (kind :: k). Signal kind -> [(RealTime, Y)] Signal.to_pairs forall a b. (a -> b) -> a -> b $ forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind Signal.clip_before RealTime start (forall a. Typed a -> a ScoreT.val_of Typed Control sig) where -- Suppose ambient dyn is .75, but then post integrate it is set to .6. -- Since the dyn track multiplies by default, this would wind up doubly -- applying the .75, for .75*.6. So the integrate call saves its ambient -- dyn so we can invert it here. invert :: Y invert | Control control forall a. Eq a => a -> a -> Bool == Control Controls.dynamic = forall a. a -> Maybe a -> a fromMaybe Y 1 forall a b. (a -> b) -> a -> b $ forall a. Typecheck a => Text -> Environ -> Maybe a Env.maybe_val (Control -> Text ScoreT.control_name Control Controls.dynamic_integrate) forall a b. (a -> b) -> a -> b $ Event -> Environ Score.event_environ Event event | Bool otherwise = Y 1 start :: RealTime start = Event -> RealTime Score.event_start Event event mk :: RealTime -> Y -> Event mk RealTime x Y y = Stack -> TrackTime -> TrackTime -> Text -> Event ui_event (Event -> Stack Score.event_stack Event event) (RealTime -> TrackTime RealTime.to_score RealTime x) TrackTime 0 (Y -> Text ShowVal.show_hex_val (Y y forall a. Fractional a => a -> a -> a / Y invert)) -- * util ui_event :: Stack.Stack -> ScoreTime -> ScoreTime -> Text -> Event.Event ui_event :: Stack -> TrackTime -> TrackTime -> Text -> Event ui_event Stack stack TrackTime pos TrackTime dur Text text = Lens Event (Maybe Stack) Event.stack_ forall f a. Lens f a -> a -> f -> f #= forall a. a -> Maybe a Just (Stack -> TrackTime -> Stack Event.Stack Stack stack TrackTime pos) forall a b. (a -> b) -> a -> b $ TrackTime -> TrackTime -> Text -> Event Event.event TrackTime pos TrackTime dur Text text -- | Concatenate the events, dropping ones that are out of order. The -- durations are not modified, so they still might overlap in duration, but the -- start times will be increasing. clip_concat :: [[Event.Event]] -> [Event.Event] clip_concat :: [[Event]] -> [Event] clip_concat = forall a. (a -> a -> Bool) -> [a] -> [a] Lists.dropWith Event -> Event -> Bool out_of_order forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat where out_of_order :: Event -> Event -> Bool out_of_order Event e1 Event e2 = Event -> TrackTime Event.start Event e2 forall a. Ord a => a -> a -> Bool <= Event -> TrackTime Event.start Event e1 -- | Drop subsequent events with the same text, since those are redundant for -- controls. drop_dups :: [Event.Event] -> [Event.Event] drop_dups :: [Event] -> [Event] drop_dups = forall k a. Eq k => (a -> k) -> [a] -> [a] Lists.dropDups Event -> Text Event.text -- | Drop events before 0, keeping at least one at 0. Controls can wind up -- with samples before 0 (e.g. after using 'Derive.Score.move'), but events -- can't start before 0. clip_to_zero :: [Event.Event] -> [Event.Event] clip_to_zero :: [Event] -> [Event] clip_to_zero (Event e1 : rest :: [Event] rest@(Event e2 : [Event] _)) | Event -> TrackTime Event.start Event e1 forall a. Ord a => a -> a -> Bool <= TrackTime 0 Bool -> Bool -> Bool && Event -> TrackTime Event.start Event e2 forall a. Ord a => a -> a -> Bool <= TrackTime 0 = [Event] -> [Event] clip_to_zero [Event] rest | Bool otherwise = (Lens Event TrackTime Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f %= forall a. Ord a => a -> a -> a max TrackTime 0 forall a b. (a -> b) -> a -> b $ Event e1) forall a. a -> [a] -> [a] : [Event] rest clip_to_zero [Event e] = [Lens Event TrackTime Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f %= forall a. Ord a => a -> a -> a max TrackTime 0 forall a b. (a -> b) -> a -> b $ Event e] clip_to_zero [] = [] make_track :: Title -> [Event.Event] -> Track make_track :: Text -> [Event] -> Track make_track Text title [Event] events = Text -> [Event] -> Track Track Text title (forall k a. Ord k => (a -> k) -> [a] -> [a] Lists.sortOn Event -> TrackTime Event.start [Event] events) empty_track :: Track -> Bool empty_track :: Track -> Bool empty_track (Track Text _ []) = Bool True empty_track Track _ = Bool False