-- 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 DeriveDataTypeable #-} {- | This has Score.Event, which is the main output of the deriver. The events here are generated from UI Events, and will eventually be transformed into Perform Events, which are specific to the performance backend. -} module Derive.Score ( -- * Event Event(..) , short_event, short_events , empty_event, event_end, event_min, event_max , events_overlap , event_scale_id , copy, normalize -- ** flags , has_flags, add_flags, remove_flags -- ** logs , add_log, add_log_msg -- ** environ , modify_environ, modify_environ_key -- ** attributes , event_attributes, has_attribute, intersecting_attributes , modify_attributes, add_attributes, remove_attributes -- ** delayed args , put_arg, take_arg -- ** modify events , move, place, move_start, duration, set_duration, set_instrument -- *** control , control_at, event_control, initial_dynamic, modify_dynamic, set_dynamic , modify_control , set_control, event_controls_at -- *** pitch , set_pitch, set_named_pitch, event_named_pitch , transposed_at, pitch_at, apply_controls , initial_pitch, nn_at, initial_nn, note_at, initial_note , nn_signal ) where import qualified Control.DeepSeq as DeepSeq import Control.DeepSeq (rnf) import qualified Data.Dynamic as Dynamic import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Typeable as Typeable import qualified Util.CallStack as CallStack import qualified Util.Log as Log import qualified Util.Pretty as Pretty import qualified Derive.Attrs as Attrs import qualified Derive.Controls as Controls import qualified Derive.DeriveT as DeriveT import qualified Derive.EnvKey as EnvKey import qualified Derive.Flags as Flags import qualified Derive.PSignal as PSignal import qualified Derive.ScoreT as ScoreT import qualified Derive.Stack as Stack import qualified Perform.Pitch as Pitch import qualified Perform.Signal as Signal import qualified Ui.Color as Color import Global import Types -- * Event data Event = Event { Event -> RealTime event_start :: !RealTime , Event -> RealTime event_duration :: !RealTime -- | This is the text of the call that created the event. It's basically -- just for debugging. , Event -> Text event_text :: !Text , Event -> ControlMap event_controls :: !DeriveT.ControlMap , Event -> PSignal event_pitch :: !PSignal.PSignal -- | Named pitch signals. , Event -> PitchMap event_pitches :: !DeriveT.PitchMap -- | Keep track of where this event originally came from. That way, if an -- error or warning is emitted concerning this event, its position on the -- UI can be highlighted. , Event -> Stack event_stack :: !Stack.Stack , Event -> Highlight event_highlight :: !Color.Highlight , Event -> Instrument event_instrument :: !ScoreT.Instrument , Event -> Environ event_environ :: !DeriveT.Environ -- | Flags have their own field rather than being in 'event_environ', this -- emphasizes that they're meant to be used by calls and not from the -- score. , Event -> Flags event_flags :: !Flags.Flags -- | This has arguments passed from a call that applies an attribute to one -- which is meant to later realize the attribute. This happens when a call -- needs to be configured at the track level, but also needs some -- information only available later, such as the real start time or pitch -- of the next note. They are indexed by attribute because there may be -- multiple delayed calls on a single note, and the realize postproc may -- want to ignore some, e.g. if they are overidden by another attribute. -- -- I couldn't think of a type safe way to do this, but Dynamic should be -- safe enough if you use a shared type declaration in both writer and -- reader. , Event -> Map Text Dynamic event_delayed_args :: !(Map Text Dynamic.Dynamic) -- | Keep track of interesting things that have happened to this event. -- Postproc transforms that alter it should prefix a note. , Event -> [Msg] event_logs :: ![Log.Msg] } deriving (Int -> Event -> ShowS [Event] -> ShowS Event -> String (Int -> Event -> ShowS) -> (Event -> String) -> ([Event] -> ShowS) -> Show Event forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Event] -> ShowS $cshowList :: [Event] -> ShowS show :: Event -> String $cshow :: Event -> String showsPrec :: Int -> Event -> ShowS $cshowsPrec :: Int -> Event -> ShowS Show, Typeable.Typeable) -- | Format an event in a way suitable for including inline in log messages. -- It's short, but hopefully enough information to identify the event in -- question. -- -- This is the derive equivalent to 'Cmd.Cmd.log_event'. short_event :: Event -> Text short_event :: Event -> Text short_event Event e = Doc -> Text forall a. Pretty a => a -> Text pretty (Doc -> Text) -> Doc -> Text forall a b. (a -> b) -> a -> b $ (Doc -> Doc -> Doc) -> [Doc] -> Doc forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a foldr1 Doc -> Doc -> Doc (Pretty.<+>) ([Doc] -> Doc) -> [Doc] -> Doc forall a b. (a -> b) -> a -> b $ [[Doc]] -> [Doc] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat ([[Doc]] -> [Doc]) -> [[Doc]] -> [Doc] forall a b. (a -> b) -> a -> b $ ([Doc] -> Bool) -> [[Doc]] -> [[Doc]] forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not (Bool -> Bool) -> ([Doc] -> Bool) -> [Doc] -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . [Doc] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null) [ [(RealTime, RealTime) -> Doc forall a. Pretty a => a -> Doc Pretty.format (Event -> RealTime event_start Event e, Event -> RealTime event_duration Event e)] , [Instrument -> Doc forall a. Pretty a => a -> Doc Pretty.format (Event -> Instrument event_instrument Event e)] , [Note -> Doc forall a. Pretty a => a -> Doc Pretty.format Note n | Just Note n <- [Event -> Maybe Note initial_note Event e]] , [Text -> Doc forall a. Pretty a => a -> Doc Pretty.format (Event -> Text event_text Event e) | Bool -> Bool not (Text -> Bool Text.null (Event -> Text event_text Event e))] , [Text -> Doc Pretty.text Text stack | Just Text stack <- [Stack -> Maybe Text Stack.pretty_ui_inner (Event -> Stack event_stack Event e)]] ] short_events :: [Event] -> Text short_events :: [Event] -> Text short_events = Doc -> Text forall a. Pretty a => a -> Text pretty (Doc -> Text) -> ([Event] -> Doc) -> [Event] -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . Char -> Char -> [Doc] -> Doc forall a. Pretty a => Char -> Char -> [a] -> Doc Pretty.formattedList Char '[' Char ']' ([Doc] -> Doc) -> ([Event] -> [Doc]) -> [Event] -> Doc forall b c a. (b -> c) -> (a -> b) -> a -> c . (Event -> Doc) -> [Event] -> [Doc] forall a b. (a -> b) -> [a] -> [b] map (Text -> Doc Pretty.text (Text -> Doc) -> (Event -> Text) -> Event -> Doc forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Text short_event) empty_event :: Event empty_event :: Event empty_event = Event { event_start :: RealTime event_start = RealTime 0 , event_duration :: RealTime event_duration = RealTime 0 , event_text :: Text event_text = Text forall a. Monoid a => a mempty , event_controls :: ControlMap event_controls = ControlMap forall a. Monoid a => a mempty , event_pitch :: PSignal event_pitch = PSignal forall a. Monoid a => a mempty , event_pitches :: PitchMap event_pitches = PitchMap forall a. Monoid a => a mempty , event_stack :: Stack event_stack = Stack Stack.empty , event_highlight :: Highlight event_highlight = Highlight Color.NoHighlight , event_instrument :: Instrument event_instrument = Instrument ScoreT.empty_instrument , event_environ :: Environ event_environ = Environ forall a. Monoid a => a mempty , event_flags :: Flags event_flags = Flags forall a. Monoid a => a mempty , event_delayed_args :: Map Text Dynamic event_delayed_args = Map Text Dynamic forall a. Monoid a => a mempty , event_logs :: [Msg] event_logs = [] } event_end :: Event -> RealTime event_end :: Event -> RealTime event_end Event event = Event -> RealTime event_start Event event RealTime -> RealTime -> RealTime forall a. Num a => a -> a -> a + Event -> RealTime event_duration Event event -- | Get minimum and maximum edges of the event. 'event_start' isn't -- necessarily the minimum because of negative durations. event_min, event_max :: Event -> RealTime event_min :: Event -> RealTime event_min Event event = RealTime -> RealTime -> RealTime forall a. Ord a => a -> a -> a min (Event -> RealTime event_start Event event) (Event -> RealTime event_end Event event) event_max :: Event -> RealTime event_max Event event = RealTime -> RealTime -> RealTime forall a. Ord a => a -> a -> a max (Event -> RealTime event_start Event event) (Event -> RealTime event_end Event event) events_overlap :: Event -> Event -> Bool events_overlap :: Event -> Event -> Bool events_overlap Event e1 Event e2 = Bool -> Bool not (Bool -> Bool) -> Bool -> Bool forall a b. (a -> b) -> a -> b $ Event -> RealTime event_end Event e1 RealTime -> RealTime -> Bool forall a. Ord a => a -> a -> Bool <= Event -> RealTime event_end Event e2 Bool -> Bool -> Bool || Event -> RealTime event_start Event e1 RealTime -> RealTime -> Bool forall a. Ord a => a -> a -> Bool >= Event -> RealTime event_end Event e2 event_scale_id :: Event -> Pitch.ScaleId event_scale_id :: Event -> ScaleId event_scale_id = PSignal -> ScaleId PSignal.sig_scale_id (PSignal -> ScaleId) -> (Event -> PSignal) -> Event -> ScaleId forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> PSignal event_pitch -- | If you use an event to create another event, call this to clear out -- data that shouldn't go with the copy. copy :: Event -> Event copy :: Event -> Event copy Event event = Event event { event_flags :: Flags event_flags = Flags forall a. Monoid a => a mempty, event_logs :: [Msg] event_logs = [] } -- | Apply environ and controls to pitches. -- -- Normally this is done by Convert, but if you want to see an event for -- debugging it can be nicer to see the normalized version. -- -- Unlike "Perform.Midi.Convert", this doesn't trim the controls, so it applies -- out-of-range transpositions. normalize :: Event -> Event normalize :: Event -> Event normalize Event event = Event event { event_pitch :: PSignal event_pitch = PSignal -> PSignal apply (PSignal -> PSignal) -> PSignal -> PSignal forall a b. (a -> b) -> a -> b $ Event -> PSignal event_pitch Event event , event_pitches :: PitchMap event_pitches = PSignal -> PSignal apply (PSignal -> PSignal) -> PitchMap -> PitchMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Event -> PitchMap event_pitches Event event } where apply :: PSignal -> PSignal apply = ControlMap -> PSignal -> PSignal PSignal.apply_controls ControlMap controls (PSignal -> PSignal) -> (PSignal -> PSignal) -> PSignal -> PSignal forall b c a. (b -> c) -> (a -> b) -> a -> c . Environ -> PSignal -> PSignal PSignal.apply_environ (Event -> Environ event_environ Event event) controls :: ControlMap controls = Event -> ControlMap event_controls Event event -- ** flags has_flags :: Flags.Flags -> Event -> Bool has_flags :: Flags -> Event -> Bool has_flags Flags flags = (Flags -> Flags -> Bool `Flags.has` Flags flags) (Flags -> Bool) -> (Event -> Flags) -> Event -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Flags event_flags add_flags :: Flags.Flags -> Event -> Event add_flags :: Flags -> Event -> Event add_flags Flags flags Event event = Event event { event_flags :: Flags event_flags = Flags flags Flags -> Flags -> Flags forall a. Semigroup a => a -> a -> a <> Event -> Flags event_flags Event event } remove_flags :: Flags.Flags -> Event -> Event remove_flags :: Flags -> Event -> Event remove_flags Flags flags Event event = Event event { event_flags :: Flags event_flags = Event -> Flags event_flags Event event Flags -> Flags -> Flags forall a. Ord a => Set a -> Set a -> Set a Set.\\ Flags flags } -- ** logs add_log :: CallStack.Stack => Text -> Event -> Event add_log :: Stack => Text -> Event -> Event add_log Text msg = Msg -> Event -> Event add_log_msg (Stack => Priority -> Maybe Stack -> Text -> Msg Priority -> Maybe Stack -> Text -> Msg Log.msg Priority Log.Debug Maybe Stack forall a. Maybe a Nothing Text msg) add_log_msg :: Log.Msg -> Event -> Event add_log_msg :: Msg -> Event -> Event add_log_msg Msg msg Event event = Event event { event_logs :: [Msg] event_logs = Msg msg Msg -> [Msg] -> [Msg] forall a. a -> [a] -> [a] : Event -> [Msg] event_logs Event event } -- ** environ modify_environ :: (DeriveT.Environ -> DeriveT.Environ) -> Event -> Event modify_environ :: (Environ -> Environ) -> Event -> Event modify_environ Environ -> Environ f Event event = Event event { event_environ :: Environ event_environ = Environ -> Environ f (Event -> Environ event_environ Event event) } -- | Modify the value at the given key. modify_environ_key :: EnvKey.Key -> (Maybe DeriveT.Val -> DeriveT.Val) -> Event -> Event modify_environ_key :: Text -> (Maybe Val -> Val) -> Event -> Event modify_environ_key Text key Maybe Val -> Val modify = (Environ -> Environ) -> Event -> Event modify_environ ((Environ -> Environ) -> Event -> Event) -> (Environ -> Environ) -> Event -> Event forall a b. (a -> b) -> a -> b $ \(DeriveT.Environ Map Text Val env) -> Map Text Val -> Environ DeriveT.Environ (Map Text Val -> Environ) -> Map Text Val -> Environ forall a b. (a -> b) -> a -> b $ (Maybe Val -> Maybe Val) -> Text -> Map Text Val -> Map Text Val forall k a. Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a Map.alter (Val -> Maybe Val forall a. a -> Maybe a Just (Val -> Maybe Val) -> (Maybe Val -> Val) -> Maybe Val -> Maybe Val forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe Val -> Val modify) Text key Map Text Val env -- ** attributes event_attributes :: Event -> Attrs.Attributes event_attributes :: Event -> Attributes event_attributes = Environ -> Attributes DeriveT.environ_attributes (Environ -> Attributes) -> (Event -> Environ) -> Event -> Attributes forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Environ event_environ has_attribute :: Attrs.Attributes -> Event -> Bool has_attribute :: Attributes -> Event -> Bool has_attribute Attributes attr = (Attributes -> Attributes -> Bool `Attrs.contain` Attributes attr) (Attributes -> Bool) -> (Event -> Attributes) -> Event -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Attributes event_attributes intersecting_attributes :: Attrs.Attributes -> Event -> Bool intersecting_attributes :: Attributes -> Event -> Bool intersecting_attributes Attributes attrs Event event = Attributes -> Attributes -> Attributes Attrs.intersection Attributes attrs (Event -> Attributes event_attributes Event event) Attributes -> Attributes -> Bool forall a. Eq a => a -> a -> Bool /= Attributes forall a. Monoid a => a mempty modify_attributes :: (Attrs.Attributes -> Attrs.Attributes) -> Event -> Event modify_attributes :: (Attributes -> Attributes) -> Event -> Event modify_attributes Attributes -> Attributes modify = (Environ -> Environ) -> Event -> Event modify_environ ((Environ -> Environ) -> Event -> Event) -> (Environ -> Environ) -> Event -> Event forall a b. (a -> b) -> a -> b $ \Environ env -> Text -> Val -> Environ -> Environ DeriveT.insert Text EnvKey.attributes (Attributes -> Val DeriveT.VAttributes (Attributes -> Attributes modify (Environ -> Attributes DeriveT.environ_attributes Environ env))) Environ env add_attributes :: Attrs.Attributes -> Event -> Event add_attributes :: Attributes -> Event -> Event add_attributes Attributes attrs | Attributes attrs Attributes -> Attributes -> Bool forall a. Eq a => a -> a -> Bool == Attributes forall a. Monoid a => a mempty = Event -> Event forall a. a -> a id | Bool otherwise = (Attributes -> Attributes) -> Event -> Event modify_attributes (Attributes -> Attributes -> Attributes forall a. Semigroup a => a -> a -> a <>Attributes attrs) remove_attributes :: Attrs.Attributes -> Event -> Event remove_attributes :: Attributes -> Event -> Event remove_attributes Attributes attrs Event event | Attributes attrs Attributes -> Attributes -> Bool forall a. Eq a => a -> a -> Bool == Attributes forall a. Monoid a => a mempty Bool -> Bool -> Bool || Bool -> Bool not (Attributes -> Event -> Bool has_attribute Attributes attrs Event event) = Event event | Bool otherwise = (Attributes -> Attributes) -> Event -> Event modify_attributes (Attributes -> Attributes -> Attributes Attrs.remove Attributes attrs) Event event instance DeepSeq.NFData Event where rnf :: Event -> () rnf (Event RealTime start RealTime dur Text text ControlMap controls PSignal pitch PitchMap pitches Stack _ Highlight _ Instrument _ Environ _ Flags flags Map Text Dynamic _delayed_args [Msg] logs) = -- I can't force Dynamic, so leave off _delayed_args. (RealTime, RealTime, Text, ControlMap, PSignal, PitchMap, Flags, [Msg]) -> () forall a. NFData a => a -> () rnf (RealTime start, RealTime dur, Text text, ControlMap controls, PSignal pitch, PitchMap pitches, Flags flags, [Msg] logs) instance Pretty Event where format :: Event -> Doc format (Event RealTime start RealTime dur Text text ControlMap controls PSignal pitch PitchMap pitches Stack stack Highlight highlight Instrument inst Environ env Flags flags Map Text Dynamic delayed_args [Msg] logs) = Doc -> [(Text, Doc)] -> Doc Pretty.record (Doc "Event" Doc -> Doc -> Doc Pretty.<+> (RealTime, RealTime) -> Doc forall a. Pretty a => a -> Doc Pretty.format (RealTime start, RealTime dur) Doc -> Doc -> Doc Pretty.<+> Text -> Doc forall a. Pretty a => a -> Doc Pretty.format Text text) [ (Text "instrument", Instrument -> Doc forall a. Pretty a => a -> Doc Pretty.format Instrument inst) , (Text "pitch", PSignal -> Doc forall a. Pretty a => a -> Doc Pretty.format PSignal pitch) , (Text "pitches", PitchMap -> Doc forall a. Pretty a => a -> Doc Pretty.format PitchMap pitches) , (Text "controls", ControlMap -> Doc forall a. Pretty a => a -> Doc Pretty.format ControlMap controls) , (Text "stack", Stack -> Doc forall a. Pretty a => a -> Doc Pretty.format Stack stack) , (Text "highlight", Text -> Doc Pretty.text (Text -> Doc) -> Text -> Doc forall a b. (a -> b) -> a -> b $ Highlight -> Text forall a. Show a => a -> Text showt Highlight highlight) , (Text "environ", Environ -> Doc forall a. Pretty a => a -> Doc Pretty.format Environ env) , (Text "flags", Flags -> Doc forall a. Pretty a => a -> Doc Pretty.format Flags flags) , (Text "delayed_args", Map Text Dynamic -> Doc forall a. Pretty a => a -> Doc Pretty.format Map Text Dynamic delayed_args) , (Text "logs", [Msg] -> Doc forall a. Pretty a => a -> Doc Pretty.format [Msg] logs) ] -- ** delayed args put_arg :: Typeable.Typeable a => Text -> a -> Event -> Event put_arg :: forall a. Typeable a => Text -> a -> Event -> Event put_arg Text key a arg Event event = Event event { event_delayed_args :: Map Text Dynamic event_delayed_args = Text -> Dynamic -> Map Text Dynamic -> Map Text Dynamic forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert Text key (a -> Dynamic forall a. Typeable a => a -> Dynamic Dynamic.toDyn a arg) (Event -> Map Text Dynamic event_delayed_args Event event) } -- | Find an arg in 'event_delayed_args', and remove it from the event if it -- existed. Throw an error if it existed but had an unexpected type. take_arg :: Typeable.Typeable a => Text -> Event -> Either Text (Event, Maybe a) take_arg :: forall a. Typeable a => Text -> Event -> Either Text (Event, Maybe a) take_arg Text key Event event = case Text -> Map Text Dynamic -> Maybe Dynamic forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Text key (Event -> Map Text Dynamic event_delayed_args Event event) of Maybe Dynamic Nothing -> (Event, Maybe a) -> Either Text (Event, Maybe a) forall a b. b -> Either a b Right (Event event, Maybe a forall a. Maybe a Nothing) Just Dynamic arg -> case Dynamic -> Maybe a forall a. Typeable a => Dynamic -> Maybe a Dynamic.fromDynamic Dynamic arg of Maybe a Nothing -> Text -> Either Text (Event, Maybe a) forall a b. a -> Either a b Left (Text -> Either Text (Event, Maybe a)) -> Text -> Either Text (Event, Maybe a) forall a b. (a -> b) -> a -> b $ Text "incorrect delayed arg type for " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text -> Text forall a. Show a => a -> Text showt Text key Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text ": " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Dynamic -> Text forall a. Pretty a => a -> Text pretty Dynamic arg Just a a -> (Event, Maybe a) -> Either Text (Event, Maybe a) forall a b. b -> Either a b Right (Text -> Event -> Event delete_arg Text key Event event, a -> Maybe a forall a. a -> Maybe a Just a a) delete_arg :: Text -> Event -> Event delete_arg :: Text -> Event -> Event delete_arg Text key Event event = Event event { event_delayed_args :: Map Text Dynamic event_delayed_args = Text -> Map Text Dynamic -> Map Text Dynamic forall k a. Ord k => k -> Map k a -> Map k a Map.delete Text key (Event -> Map Text Dynamic event_delayed_args Event event) } -- ** modify events -- These operate directly on events, so we are in RealTime at this point. -- | Change the start time of an event and move its controls along with it. move :: (RealTime -> RealTime) -> Event -> Event move :: (RealTime -> RealTime) -> Event -> Event move RealTime -> RealTime modify Event event | RealTime pos RealTime -> RealTime -> Bool forall a. Eq a => a -> a -> Bool == Event -> RealTime event_start Event event = Event event | Bool otherwise = Event event { event_start :: RealTime event_start = RealTime pos , event_controls :: ControlMap event_controls = (Control -> Control) -> Typed Control -> Typed Control forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (RealTime -> Control -> Control forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind Signal.shift RealTime delta) (Typed Control -> Typed Control) -> ControlMap -> ControlMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Event -> ControlMap event_controls Event event , event_pitch :: PSignal event_pitch = RealTime -> PSignal -> PSignal PSignal.shift RealTime delta (PSignal -> PSignal) -> PSignal -> PSignal forall a b. (a -> b) -> a -> b $ Event -> PSignal event_pitch Event event , event_pitches :: PitchMap event_pitches = RealTime -> PSignal -> PSignal PSignal.shift RealTime delta (PSignal -> PSignal) -> PitchMap -> PitchMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Event -> PitchMap event_pitches Event event } where pos :: RealTime pos = RealTime -> RealTime modify (Event -> RealTime event_start Event event) delta :: RealTime delta = RealTime pos RealTime -> RealTime -> RealTime forall a. Num a => a -> a -> a - Event -> RealTime event_start Event event place :: RealTime -> RealTime -> Event -> Event place :: RealTime -> RealTime -> Event -> Event place RealTime start RealTime dur Event event = ((RealTime -> RealTime) -> Event -> Event move (RealTime -> RealTime -> RealTime forall a b. a -> b -> a const RealTime start) Event event) { event_duration :: RealTime event_duration = RealTime dur } move_start :: RealTime -> RealTime -> Event -> Event move_start :: RealTime -> RealTime -> Event -> Event move_start RealTime min_duration RealTime offset | RealTime offset RealTime -> RealTime -> Bool forall a. Eq a => a -> a -> Bool == RealTime 0 = Event -> Event forall a. a -> a id | Bool otherwise = (RealTime -> RealTime) -> Event -> Event duration (RealTime -> RealTime -> RealTime forall a. Ord a => a -> a -> a max RealTime min_duration (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) (Event -> Event) -> (Event -> Event) -> Event -> Event forall b c a. (b -> c) -> (a -> b) -> a -> c . (RealTime -> RealTime) -> Event -> Event move (RealTime -> RealTime -> RealTime forall a. Num a => a -> a -> a +RealTime offset) duration :: (RealTime -> RealTime) -> Event -> Event duration :: (RealTime -> RealTime) -> Event -> Event duration RealTime -> RealTime modify Event event | RealTime dur RealTime -> RealTime -> Bool forall a. Eq a => a -> a -> Bool == Event -> RealTime event_duration Event event = Event event | Bool otherwise = Event event { event_duration :: RealTime event_duration = RealTime dur } where dur :: RealTime dur = RealTime -> RealTime modify (Event -> RealTime event_duration Event event) set_duration :: RealTime -> Event -> Event set_duration :: RealTime -> Event -> Event set_duration = (RealTime -> RealTime) -> Event -> Event duration ((RealTime -> RealTime) -> Event -> Event) -> (RealTime -> RealTime -> RealTime) -> RealTime -> Event -> Event forall b c a. (b -> c) -> (a -> b) -> a -> c . RealTime -> RealTime -> RealTime forall a b. a -> b -> a const -- | Set the instrument on an event, and also update its environ from the -- instrument. You should really rederive with the new instrument, but this -- way can be more convenient, if somewhat sketchy. set_instrument :: ScoreT.Instrument -> DeriveT.Environ -> Event -> Event set_instrument :: Instrument -> Environ -> Event -> Event set_instrument Instrument score_inst Environ inst_environ Event event = Event event { event_instrument :: Instrument event_instrument = Instrument score_inst , event_environ :: Environ event_environ = Environ inst_environ Environ -> Environ -> Environ forall a. Semigroup a => a -> a -> a <> Event -> Environ event_environ Event event } -- *** control -- | Get a control value from the event, or Nothing if that control isn't -- present. control_at :: RealTime -> ScoreT.Control -> Event -> Maybe (ScoreT.Typed Signal.Y) control_at :: RealTime -> Control -> Event -> Maybe (Typed Y) control_at RealTime pos Control control Event event = (Control -> Y) -> Typed Control -> Typed Y forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (RealTime -> Control -> Y forall {k} (kind :: k). RealTime -> Signal kind -> Y Signal.at RealTime pos) (Typed Control -> Typed Y) -> Maybe (Typed Control) -> Maybe (Typed Y) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Control -> ControlMap -> Maybe (Typed Control) forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Control control (Event -> ControlMap event_controls Event event) event_control :: ScoreT.Control -> Event -> Maybe (ScoreT.Typed Signal.Control) event_control :: Control -> Event -> Maybe (Typed Control) event_control Control control = Control -> ControlMap -> Maybe (Typed Control) forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Control control (ControlMap -> Maybe (Typed Control)) -> (Event -> ControlMap) -> Event -> Maybe (Typed Control) forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> ControlMap event_controls initial_dynamic :: Event -> Signal.Y initial_dynamic :: Event -> Y initial_dynamic Event event = Y -> (Typed Y -> Y) -> Maybe (Typed Y) -> Y forall b a. b -> (a -> b) -> Maybe a -> b maybe Y 0 Typed Y -> Y forall a. Typed a -> a ScoreT.typed_val (Maybe (Typed Y) -> Y) -> Maybe (Typed Y) -> Y forall a b. (a -> b) -> a -> b $ -- Derive.initial_controls should mean this is never Nothing. RealTime -> Control -> Event -> Maybe (Typed Y) control_at (Event -> RealTime event_start Event event) Control Controls.dynamic Event event -- | Use this instead of 'modify_control_vals' because it also sets -- 'EnvKey.dynamic_val'. This is only valid for linear functions like (+) or -- (*). modify_dynamic :: (Signal.Y -> Signal.Y) -> Event -> Event modify_dynamic :: (Y -> Y) -> Event -> Event modify_dynamic Y -> Y modify = Text -> (Maybe Val -> Val) -> Event -> Event modify_environ_key Text EnvKey.dynamic_val (Typed Y -> Val DeriveT.VNum (Typed Y -> Val) -> (Maybe Val -> Typed Y) -> Maybe Val -> Val forall b c a. (b -> c) -> (a -> b) -> a -> c . Y -> Typed Y forall a. a -> Typed a ScoreT.untyped (Y -> Typed Y) -> (Maybe Val -> Y) -> Maybe Val -> Typed Y forall b c a. (b -> c) -> (a -> b) -> a -> c . Y -> Y modify (Y -> Y) -> (Maybe Val -> Y) -> Maybe Val -> Y forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe Val -> Y num_of) (Event -> Event) -> (Event -> Event) -> Event -> Event forall b c a. (b -> c) -> (a -> b) -> a -> c . Control -> (Y -> Y) -> Event -> Event modify_control_vals Control Controls.dynamic Y -> Y modify where num_of :: Maybe Val -> Y num_of (Just (DeriveT.VNum Typed Y n)) = Typed Y -> Y forall a. Typed a -> a ScoreT.typed_val Typed Y n num_of Maybe Val _ = Y 0 -- | Use this instead of 'set_control' because it also sets -- 'EnvKey.dynamic_val'. set_dynamic :: Signal.Y -> Event -> Event set_dynamic :: Y -> Event -> Event set_dynamic Y dyn = Text -> (Maybe Val -> Val) -> Event -> Event modify_environ_key Text EnvKey.dynamic_val (Val -> Maybe Val -> Val forall a b. a -> b -> a const (Val -> Maybe Val -> Val) -> Val -> Maybe Val -> Val forall a b. (a -> b) -> a -> b $ Typed Y -> Val DeriveT.VNum (Typed Y -> Val) -> Typed Y -> Val forall a b. (a -> b) -> a -> b $ Y -> Typed Y forall a. a -> Typed a ScoreT.untyped Y dyn) (Event -> Event) -> (Event -> Event) -> Event -> Event forall b c a. (b -> c) -> (a -> b) -> a -> c . Control -> Typed Control -> Event -> Event set_control Control Controls.dynamic (Control -> Typed Control forall a. a -> Typed a ScoreT.untyped (Y -> Control forall {k} (kind :: k). Y -> Signal kind Signal.constant Y dyn)) modify_control_vals :: ScoreT.Control -> (Signal.Y -> Signal.Y) -> Event -> Event modify_control_vals :: Control -> (Y -> Y) -> Event -> Event modify_control_vals Control control Y -> Y modify Event event = Event event { event_controls :: ControlMap event_controls = (Typed Control -> Typed Control) -> Control -> ControlMap -> ControlMap forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a Map.adjust ((Control -> Control) -> Typed Control -> Typed Control forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((Y -> Y) -> Control -> Control forall {k} (kind :: k). (Y -> Y) -> Signal kind -> Signal kind Signal.map_y_linear Y -> Y modify)) Control control (Event -> ControlMap event_controls Event event) } -- | Modify a control. If there is no existing control, the modify function -- gets an empty signal. modify_control :: ScoreT.Control -> (Signal.Control -> Signal.Control) -> Event -> Event modify_control :: Control -> (Control -> Control) -> Event -> Event modify_control Control control Control -> Control modify Event event = Event event { event_controls :: ControlMap event_controls = (Maybe (Typed Control) -> Maybe (Typed Control)) -> Control -> ControlMap -> ControlMap forall k a. Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a Map.alter (Typed Control -> Maybe (Typed Control) forall a. a -> Maybe a Just (Typed Control -> Maybe (Typed Control)) -> (Maybe (Typed Control) -> Typed Control) -> Maybe (Typed Control) -> Maybe (Typed Control) forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe (Typed Control) -> Typed Control forall {f :: * -> *}. (Functor f, Monoid (f Control)) => Maybe (f Control) -> f Control alter) Control control (Event -> ControlMap event_controls Event event) } where alter :: Maybe (f Control) -> f Control alter Maybe (f Control) old = Control -> Control modify (Control -> Control) -> f Control -> f Control forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f Control -> Maybe (f Control) -> f Control forall a. a -> Maybe a -> a fromMaybe f Control forall a. Monoid a => a mempty Maybe (f Control) old set_control :: ScoreT.Control -> ScoreT.Typed Signal.Control -> Event -> Event set_control :: Control -> Typed Control -> Event -> Event set_control Control control Typed Control signal Event event = Event event { event_controls :: ControlMap event_controls = Control -> Typed Control -> ControlMap -> ControlMap forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert Control control Typed Control signal (Event -> ControlMap event_controls Event event) } event_controls_at :: RealTime -> Event -> ScoreT.ControlValMap event_controls_at :: RealTime -> Event -> ControlValMap event_controls_at RealTime t Event event = Typed Y -> Y forall a. Typed a -> a ScoreT.typed_val (Typed Y -> Y) -> (Typed Control -> Typed Y) -> Typed Control -> Y forall b c a. (b -> c) -> (a -> b) -> a -> c . (Control -> Y) -> Typed Control -> Typed Y forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (RealTime -> Control -> Y forall {k} (kind :: k). RealTime -> Signal kind -> Y Signal.at RealTime t) (Typed Control -> Y) -> ControlMap -> ControlValMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Event -> ControlMap event_controls Event event -- *** pitch set_pitch :: PSignal.PSignal -> Event -> Event set_pitch :: PSignal -> Event -> Event set_pitch = PControl -> PSignal -> Event -> Event set_named_pitch PControl ScoreT.default_pitch set_named_pitch :: ScoreT.PControl -> PSignal.PSignal -> Event -> Event set_named_pitch :: PControl -> PSignal -> Event -> Event set_named_pitch PControl pcontrol PSignal signal Event event | PControl pcontrol PControl -> PControl -> Bool forall a. Eq a => a -> a -> Bool == PControl ScoreT.default_pitch = Event event { event_pitch :: PSignal event_pitch = PSignal signal } | Bool otherwise = Event event { event_pitches :: PitchMap event_pitches = PControl -> PSignal -> PitchMap -> PitchMap forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert PControl pcontrol PSignal signal (Event -> PitchMap event_pitches Event event) } event_named_pitch :: ScoreT.PControl -> Event -> Maybe PSignal.PSignal event_named_pitch :: PControl -> Event -> Maybe PSignal event_named_pitch PControl pcontrol | PControl pcontrol PControl -> PControl -> Bool forall a. Eq a => a -> a -> Bool == PControl ScoreT.default_pitch = PSignal -> Maybe PSignal forall a. a -> Maybe a Just (PSignal -> Maybe PSignal) -> (Event -> PSignal) -> Event -> Maybe PSignal forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> PSignal event_pitch | Bool otherwise = PControl -> PitchMap -> Maybe PSignal forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup PControl pcontrol (PitchMap -> Maybe PSignal) -> (Event -> PitchMap) -> Event -> Maybe PSignal forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> PitchMap event_pitches -- | Unlike 'Derive.Derive.pitch_at', the transposition has already been -- applied. This is because callers expect to get the actual pitch, not the -- pitch plus some homework to do on the pitch. If you use this pitch to emit -- another pitch you proabbly need the raw pitch, but so far everyone doing -- that is at the Derive level, not postproc, so they use Derive.pitch_at. {-# SCC transposed_at #-} transposed_at :: RealTime -> Event -> Maybe PSignal.Transposed transposed_at :: RealTime -> Event -> Maybe Transposed transposed_at RealTime pos Event event = PitchConfig -> RawPitch Untransposed_ -> Transposed forall a b. PitchConfig -> RawPitch a -> RawPitch b PSignal.apply_config PitchConfig config (RawPitch Untransposed_ -> Transposed) -> Maybe (RawPitch Untransposed_) -> Maybe Transposed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RealTime -> Event -> Maybe (RawPitch Untransposed_) pitch_at RealTime pos Event event where config :: PitchConfig config = Environ -> ControlValMap -> PitchConfig PSignal.PitchConfig (Event -> Environ event_environ Event event) (RealTime -> Event -> ControlValMap event_controls_at RealTime pos Event event) pitch_at :: RealTime -> Event -> Maybe PSignal.Pitch pitch_at :: RealTime -> Event -> Maybe (RawPitch Untransposed_) pitch_at RealTime pos Event event = RealTime -> PSignal -> Maybe (RawPitch Untransposed_) PSignal.at RealTime pos (PSignal -> Maybe (RawPitch Untransposed_)) -> PSignal -> Maybe (RawPitch Untransposed_) forall a b. (a -> b) -> a -> b $ Event -> PSignal event_pitch Event event apply_controls :: Event -> RealTime -> PSignal.Pitch -> PSignal.Transposed apply_controls :: Event -> RealTime -> RawPitch Untransposed_ -> Transposed apply_controls Event event RealTime pos = ControlValMap -> RawPitch Untransposed_ -> Transposed PSignal.apply (RealTime -> Event -> ControlValMap event_controls_at RealTime pos Event event) initial_pitch :: Event -> Maybe PSignal.Transposed initial_pitch :: Event -> Maybe Transposed initial_pitch Event event = RealTime -> Event -> Maybe Transposed transposed_at (Event -> RealTime event_start Event event) Event event nn_at :: RealTime -> Event -> Maybe Pitch.NoteNumber nn_at :: RealTime -> Event -> Maybe NoteNumber nn_at RealTime pos Event event = (PitchError -> Maybe NoteNumber) -> (NoteNumber -> Maybe NoteNumber) -> Either PitchError NoteNumber -> Maybe NoteNumber forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (Maybe NoteNumber -> PitchError -> Maybe NoteNumber forall a b. a -> b -> a const Maybe NoteNumber forall a. Maybe a Nothing) NoteNumber -> Maybe NoteNumber forall a. a -> Maybe a Just (Either PitchError NoteNumber -> Maybe NoteNumber) -> (Transposed -> Either PitchError NoteNumber) -> Transposed -> Maybe NoteNumber forall b c a. (b -> c) -> (a -> b) -> a -> c . Transposed -> Either PitchError NoteNumber PSignal.pitch_nn (Transposed -> Maybe NoteNumber) -> Maybe Transposed -> Maybe NoteNumber forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< RealTime -> Event -> Maybe Transposed transposed_at RealTime pos Event event {-# SCC initial_nn #-} initial_nn :: Event -> Maybe Pitch.NoteNumber initial_nn :: Event -> Maybe NoteNumber initial_nn Event event = RealTime -> Event -> Maybe NoteNumber nn_at (Event -> RealTime event_start Event event) Event event note_at :: RealTime -> Event -> Maybe Pitch.Note note_at :: RealTime -> Event -> Maybe Note note_at RealTime pos Event event = (PitchError -> Maybe Note) -> (Note -> Maybe Note) -> Either PitchError Note -> Maybe Note forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (Maybe Note -> PitchError -> Maybe Note forall a b. a -> b -> a const Maybe Note forall a. Maybe a Nothing) Note -> Maybe Note forall a. a -> Maybe a Just (Either PitchError Note -> Maybe Note) -> (Transposed -> Either PitchError Note) -> Transposed -> Maybe Note forall b c a. (b -> c) -> (a -> b) -> a -> c . Transposed -> Either PitchError Note PSignal.pitch_note (Transposed -> Maybe Note) -> Maybe Transposed -> Maybe Note forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< RealTime -> Event -> Maybe Transposed transposed_at RealTime pos Event event initial_note :: Event -> Maybe Pitch.Note initial_note :: Event -> Maybe Note initial_note Event event = RealTime -> Event -> Maybe Note note_at (Event -> RealTime event_start Event event) Event event {-# SCC nn_signal #-} nn_signal :: Event -> (Signal.NoteNumber, [(RealTime, PSignal.PitchError)]) nn_signal :: Event -> (NoteNumber, [(RealTime, PitchError)]) nn_signal Event event = PSignal -> (NoteNumber, [(RealTime, PitchError)]) PSignal.to_nn (PSignal -> (NoteNumber, [(RealTime, PitchError)])) -> PSignal -> (NoteNumber, [(RealTime, PitchError)]) forall a b. (a -> b) -> a -> b $ ControlMap -> PSignal -> PSignal PSignal.apply_controls (Event -> ControlMap event_controls Event event) (PSignal -> PSignal) -> PSignal -> PSignal forall a b. (a -> b) -> a -> b $ Environ -> PSignal -> PSignal PSignal.apply_environ (Event -> Environ event_environ Event event) (PSignal -> PSignal) -> PSignal -> PSignal forall a b. (a -> b) -> a -> b $ Event -> PSignal event_pitch Event event