-- 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_val -- ** 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 , event_controls , control_at, event_control, initial_dynamic, modify_dynamic, set_dynamic , modify_control_vals, modify_control, modify_signal , 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.List as List 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.Lists as Lists 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 -> Key event_text :: !Text -- | If the event is integrated back to a Ui.Event, use this text. This is -- so calls can explicitly set how they would like their events to be -- integrated. Otherwise, Integrate.Convert will try to infer something. , Event -> Key event_integrate :: !Text , Event -> PSignal event_pitch :: !PSignal.PSignal -- | 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 Key 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 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 -> Key short_event Event e = [Key] -> Key Text.unwords forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ [forall a. Pretty a => a -> Key pretty (Event -> RealTime event_start Event e, Event -> RealTime event_duration Event e)] , [Key "\"" forall a. Semigroup a => a -> a -> a <> Event -> Key event_text Event e forall a. Semigroup a => a -> a -> a <> Key "\"" | Event -> Key event_text Event e forall a. Eq a => a -> a -> Bool /= Key ""] , [Key "'" forall a. Semigroup a => a -> a -> a <> Event -> Key event_integrate Event e forall a. Semigroup a => a -> a -> a <> Key "'" | Event -> Key event_integrate Event e forall a. Eq a => a -> a -> Bool /= Key ""] , [forall a. Pretty a => a -> Key pretty (Event -> Instrument event_instrument Event e)] , [forall a. Pretty a => a -> Key pretty Note n | Just Note n <- [Event -> Maybe Note initial_note Event e]] , [forall a. Pretty a => a -> Key pretty Attributes attrs | Attributes attrs forall a. Eq a => a -> a -> Bool /= forall a. Monoid a => a mempty] , [Key stack | Just Key stack <- [Stack -> Maybe Key Stack.pretty_ui_inner (Event -> Stack event_stack Event e)]] ] where attrs :: Attributes attrs = Event -> Attributes event_attributes Event e short_events :: [Event] -> Text short_events :: [Event] -> Key short_events [Event] events = forall a. Monoid a => [a] -> a mconcat forall a b. (a -> b) -> a -> b $ Key "[" forall a. a -> [a] -> [a] : forall a. a -> [a] -> [a] List.intersperse Key ", " (forall a b. (a -> b) -> [a] -> [b] map Event -> Key short_event [Event] events) forall a. [a] -> [a] -> [a] ++ [Key "]"] 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 :: Key event_text = forall a. Monoid a => a mempty , event_integrate :: Key event_integrate = forall a. Monoid a => a mempty , event_pitch :: PSignal event_pitch = 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 = forall a. Monoid a => a mempty , event_flags :: Flags event_flags = forall a. Monoid a => a mempty , event_delayed_args :: Map Key Dynamic event_delayed_args = 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 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 = 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 = 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 forall a b. (a -> b) -> a -> b $ Event -> RealTime event_end Event e1 forall a. Ord a => a -> a -> Bool <= Event -> RealTime event_end Event e2 Bool -> Bool -> Bool || Event -> RealTime event_start Event e1 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 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 = 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 forall a b. (a -> b) -> a -> b $ Event -> PSignal event_pitch Event event } where apply :: PSignal -> PSignal apply = ControlMap -> PSignal -> PSignal PSignal.apply_controls ControlMap controls 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) 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 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 forall a. Ord a => Set a -> Set a -> Set a Set.\\ Flags flags } -- ** logs add_log :: CallStack.Stack => Text -> Event -> Event add_log :: Stack => Key -> Event -> Event add_log Key msg = Msg -> Event -> Event add_log_msg (Stack => Priority -> Maybe Stack -> Key -> Msg Log.msg Priority Log.Debug forall a. Maybe a Nothing Key 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 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_val :: EnvKey.Key -> (Maybe DeriveT.Val -> DeriveT.Val) -> Event -> Event modify_val :: Key -> (Maybe Val -> Val) -> Event -> Event modify_val Key key Maybe Val -> Val modify = (Environ -> Environ) -> Event -> Event modify_environ forall a b. (a -> b) -> a -> b $ \(DeriveT.Environ Map Key Val env) -> Map Key Val -> Environ DeriveT.Environ forall a b. (a -> b) -> a -> b $ forall k a. Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a Map.alter (forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe Val -> Val modify) Key key Map Key Val env put_val :: EnvKey.Key -> DeriveT.Val -> Event -> Event put_val :: Key -> Val -> Event -> Event put_val Key key = Key -> (Maybe Val -> Val) -> Event -> Event modify_val Key key forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. a -> b -> a const lookup_val :: EnvKey.Key -> Event -> Maybe DeriveT.Val lookup_val :: Key -> Event -> Maybe Val lookup_val Key key = Key -> Environ -> Maybe Val DeriveT.lookup Key key forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Environ event_environ -- ** attributes event_attributes :: Event -> Attrs.Attributes event_attributes :: Event -> Attributes event_attributes = Environ -> Attributes DeriveT.environ_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) 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) forall a. Eq a => a -> a -> Bool /= 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 forall a b. (a -> b) -> a -> b $ \Environ env -> Key -> Val -> Environ -> Environ DeriveT.insert Key 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 forall a. Eq a => a -> a -> Bool == forall a. Monoid a => a mempty = forall a. a -> a id | Bool otherwise = (Attributes -> Attributes) -> Event -> Event modify_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 forall a. Eq a => a -> a -> Bool == 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 Key _text Key _integrate PSignal pitch Stack _ Highlight _ Instrument _ Environ _ Flags flags Map Key Dynamic _delayed_args [Msg] logs) = -- I can't force Dynamic, so leave off _delayed_args. forall a. NFData a => a -> () rnf (RealTime start, RealTime dur, PSignal pitch, Flags flags, [Msg] logs) instance Pretty Event where format :: Event -> Doc format e :: Event e@(Event RealTime start RealTime dur Key text Key integrate PSignal pitch Stack stack Highlight highlight Instrument inst Environ env Flags flags Map Key Dynamic delayed_args [Msg] logs) = Doc -> [(Key, Doc)] -> Doc Pretty.record (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a foldr1 Doc -> Doc -> Doc (Pretty.<+>) forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ [Doc "Event", forall a. Pretty a => a -> Doc Pretty.format (RealTime start, RealTime dur)] , [Key -> Doc Pretty.text forall a b. (a -> b) -> a -> b $ Key "\"" forall a. Semigroup a => a -> a -> a <> Key text forall a. Semigroup a => a -> a -> a <> Key "\"" | Key text forall a. Eq a => a -> a -> Bool /= Key ""] , [Key -> Doc Pretty.text forall a b. (a -> b) -> a -> b $ Key "'" forall a. Semigroup a => a -> a -> a <> Key integrate forall a. Semigroup a => a -> a -> a <> Key "'" | Key integrate forall a. Eq a => a -> a -> Bool /= Key ""] , [forall a. Pretty a => a -> Doc Pretty.format Note n | Just Note n <- [Event -> Maybe Note initial_note Event e]] , [ forall a. Pretty a => a -> Doc Pretty.format Attributes attrs | let attrs :: Attributes attrs = Environ -> Attributes DeriveT.environ_attributes Environ env, Attributes attrs forall a. Eq a => a -> a -> Bool /= forall a. Monoid a => a mempty ] ]) forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ [(Key "instrument", forall a. Pretty a => a -> Doc Pretty.format Instrument inst)] , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)] g Key "pitch" PSignal pitch PSignal -> Bool PSignal.null , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)] g Key "stack" Stack stack (forall a. Eq a => a -> a -> Bool == Stack Stack.empty) , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)] g Key "highlight" Highlight highlight (forall a. Eq a => a -> a -> Bool == Highlight Color.NoHighlight) , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)] g Key "environ" Environ env Environ -> Bool DeriveT.null , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)] g Key "flags" Flags flags forall a. Set a -> Bool Set.null , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)] g Key "delayed_args" Map Key Dynamic delayed_args forall k a. Map k a -> Bool Map.null , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)] g Key "logs" [Msg] logs forall (t :: * -> *) a. Foldable t => t a -> Bool null ] where g :: a -> a -> (a -> Bool) -> [(a, Doc)] g a name a val a -> Bool empty = [(a name, forall a. Pretty a => a -> Doc Pretty.format a val) | Bool -> Bool not (a -> Bool empty a val)] -- ** delayed args put_arg :: Typeable.Typeable a => Text -> a -> Event -> Event put_arg :: forall a. Typeable a => Key -> a -> Event -> Event put_arg Key key a arg Event event = Event event { event_delayed_args :: Map Key Dynamic event_delayed_args = forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert Key key (forall a. Typeable a => a -> Dynamic Dynamic.toDyn a arg) (Event -> Map Key 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 => Key -> Event -> Either Key (Event, Maybe a) take_arg Key key Event event = case forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Key key (Event -> Map Key Dynamic event_delayed_args Event event) of Maybe Dynamic Nothing -> forall a b. b -> Either a b Right (Event event, forall a. Maybe a Nothing) Just Dynamic arg -> case forall a. Typeable a => Dynamic -> Maybe a Dynamic.fromDynamic Dynamic arg of Maybe a Nothing -> forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ Key "incorrect delayed arg type for " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Key showt Key key forall a. Semigroup a => a -> a -> a <> Key ": " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Key pretty Dynamic arg Just a a -> forall a b. b -> Either a b Right (Key -> Event -> Event delete_arg Key key Event event, forall a. a -> Maybe a Just a a) delete_arg :: Text -> Event -> Event delete_arg :: Key -> Event -> Event delete_arg Key key Event event = Event event { event_delayed_args :: Map Key Dynamic event_delayed_args = forall k a. Ord k => k -> Map k a -> Map k a Map.delete Key key (Event -> Map Key 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 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_environ :: Environ event_environ = ([(Key, Val)] -> [(Key, Val)]) -> Environ -> Environ modify_env (forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second Val -> Val shift)) (Event -> Environ event_environ Event event) , event_pitch :: PSignal event_pitch = RealTime -> PSignal -> PSignal PSignal.shift RealTime delta forall a b. (a -> b) -> a -> b $ Event -> PSignal event_pitch Event event } where shift :: Val -> Val shift = \case DeriveT.VSignal Typed Control sig -> Typed Control -> Val DeriveT.VSignal forall a b. (a -> b) -> a -> b $ forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind Signal.shift RealTime delta forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Typed Control sig DeriveT.VPSignal PSignal sig -> PSignal -> Val DeriveT.VPSignal forall a b. (a -> b) -> a -> b $ RealTime -> PSignal -> PSignal PSignal.shift RealTime delta PSignal sig Val val -> Val val pos :: RealTime pos = RealTime -> RealTime modify (Event -> RealTime event_start Event event) delta :: RealTime delta = RealTime pos forall a. Num a => a -> a -> a - Event -> RealTime event_start Event event modify_env :: ([(EnvKey.Key, DeriveT.Val)] -> [(EnvKey.Key, DeriveT.Val)]) -> DeriveT.Environ -> DeriveT.Environ modify_env :: ([(Key, Val)] -> [(Key, Val)]) -> Environ -> Environ modify_env [(Key, Val)] -> [(Key, Val)] modify (DeriveT.Environ Map Key Val env) = Map Key Val -> Environ DeriveT.Environ forall a b. (a -> b) -> a -> b $ forall k a. Eq k => [(k, a)] -> Map k a Map.fromAscList forall a b. (a -> b) -> a -> b $ [(Key, Val)] -> [(Key, Val)] modify forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [(k, a)] Map.toAscList Map Key Val env place :: RealTime -> RealTime -> Event -> Event place :: RealTime -> RealTime -> Event -> Event place RealTime start RealTime dur Event event = ((RealTime -> RealTime) -> Event -> Event move (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 forall a. Eq a => a -> a -> Bool == RealTime 0 = forall a. a -> a id | Bool otherwise = (RealTime -> RealTime) -> Event -> Event duration (forall a. Ord a => a -> a -> a max RealTime min_duration forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Num a => a -> a -> a subtract RealTime offset) forall b c a. (b -> c) -> (a -> b) -> a -> c . (RealTime -> RealTime) -> Event -> Event move (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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c . 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 forall a. Semigroup a => a -> a -> a <> Event -> Environ event_environ Event event } -- *** control event_controls :: Event -> ScoreT.ControlMap event_controls :: Event -> ControlMap event_controls = Environ -> ControlMap get forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Environ event_environ where get :: Environ -> ControlMap get (DeriveT.Environ Map Key Val env) = forall k a. Eq k => [(k, a)] -> Map k a Map.fromAscList forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first Key -> Control ScoreT.Control) forall a b. (a -> b) -> a -> b $ forall b b2 a. (b -> Maybe b2) -> [(a, b)] -> [(a, b2)] Lists.mapMaybeSnd Val -> Maybe (Typed Control) is_signal forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [(k, a)] Map.toAscList Map Key Val env is_signal :: Val -> Maybe (Typed Control) is_signal (DeriveT.VSignal Typed Control sig) = forall a. a -> Maybe a Just Typed Control sig is_signal Val _ = forall a. Maybe a Nothing -- | 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall {k} (kind :: k). Signal kind -> RealTime -> Y `Signal.at` RealTime pos)) forall b c a. (b -> c) -> (a -> b) -> a -> c . Control -> Event -> Maybe (Typed Control) event_control Control control event_control :: ScoreT.Control -> Event -> Maybe (ScoreT.Typed Signal.Control) event_control :: Control -> Event -> Maybe (Typed Control) event_control (ScoreT.Control Key control) = Val -> Maybe (Typed Control) as_signal forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< Key -> Event -> Maybe Val lookup_val Key control initial_dynamic :: Event -> Signal.Y initial_dynamic :: Event -> Y initial_dynamic Event event = forall b a. b -> (a -> b) -> Maybe a -> b maybe Y 0 forall a. Typed a -> a ScoreT.val_of 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 = Control -> (Y -> Y) -> Event -> Event modify_control_vals (Key -> Control ScoreT.Control Key EnvKey.dynamic_val) Y -> Y modify forall b c a. (b -> c) -> (a -> b) -> a -> c . Control -> (Y -> Y) -> Event -> Event modify_control_vals Control Controls.dynamic Y -> Y modify -- | 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 = Key -> Val -> Event -> Event put_val Key EnvKey.dynamic_val Val sig forall b c a. (b -> c) -> (a -> b) -> a -> c . Key -> Val -> Event -> Event put_val (Control -> Key ScoreT.control_name Control Controls.dynamic) Val sig where sig :: Val sig = Y -> Val DeriveT.num 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 = case Control -> Event -> Maybe (Typed Control) event_control Control control Event event of Maybe (Typed Control) Nothing -> Event event Just Typed Control sig -> Key -> Val -> Event -> Event put_val (Control -> Key ScoreT.control_name Control control) (Typed Control -> Val DeriveT.VSignal (forall {k} (kind :: k). (Y -> Y) -> Signal kind -> Signal kind Signal.map_y_linear Y -> Y modify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Typed Control sig)) Event event -- | Like 'modify_control', but default to an empty control and retain any -- type the original had. modify_signal :: ScoreT.Control -> (Signal.Control -> Signal.Control) -> Event -> Event modify_signal :: Control -> (Control -> Control) -> Event -> Event modify_signal Control control Control -> Control modify = Control -> (Maybe (Typed Control) -> Typed Control) -> Event -> Event modify_control Control control (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Control -> Control modify forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> Maybe a -> a fromMaybe (forall a. a -> Typed a ScoreT.untyped forall a. Monoid a => a mempty)) modify_control :: ScoreT.Control -> (Maybe ScoreT.TypedSignal -> ScoreT.TypedSignal) -> Event -> Event modify_control :: Control -> (Maybe (Typed Control) -> Typed Control) -> Event -> Event modify_control (ScoreT.Control Key control) Maybe (Typed Control) -> Typed Control modify = Key -> (Maybe Val -> Val) -> Event -> Event modify_val Key control (Typed Control -> Val DeriveT.VSignal forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe (Typed Control) -> Typed Control modify forall b c a. (b -> c) -> (a -> b) -> a -> c . (Val -> Maybe (Typed Control) as_signal =<<)) as_signal :: DeriveT.Val -> Maybe ScoreT.TypedSignal as_signal :: Val -> Maybe (Typed Control) as_signal = \case DeriveT.VSignal Typed Control sig -> forall a. a -> Maybe a Just Typed Control sig Val _ -> forall a. Maybe a Nothing set_control :: ScoreT.Control -> ScoreT.Typed Signal.Control -> Event -> Event set_control :: Control -> Typed Control -> Event -> Event set_control (ScoreT.Control Key control) = Key -> (Maybe Val -> Val) -> Event -> Event modify_val Key control forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. a -> b -> a const forall b c a. (b -> c) -> (a -> b) -> a -> c . Typed Control -> Val DeriveT.VSignal event_controls_at :: RealTime -> Event -> ScoreT.ControlValMap event_controls_at :: RealTime -> Event -> ControlValMap event_controls_at RealTime t Event event = forall a. Typed a -> a ScoreT.val_of forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall {k} (kind :: k). Signal kind -> RealTime -> Y `Signal.at` RealTime t) 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 PSignal sig Event event = Event event { event_pitch :: PSignal event_pitch = PSignal sig } 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 forall a. Eq a => a -> a -> Bool == PControl ScoreT.default_pitch = Event event { event_pitch :: PSignal event_pitch = PSignal signal } | Bool otherwise = Key -> (Maybe Val -> Val) -> Event -> Event modify_val (PControl -> Key ScoreT.pcontrol_name PControl pcontrol) (forall a b. a -> b -> a const forall a b. (a -> b) -> a -> b $ PSignal -> Val DeriveT.VPSignal PSignal signal) Event event event_named_pitch :: ScoreT.PControl -> Event -> Maybe PSignal.PSignal event_named_pitch :: PControl -> Event -> Maybe PSignal event_named_pitch PControl pcontrol Event event | PControl pcontrol forall a. Eq a => a -> a -> Bool == PControl ScoreT.default_pitch = forall a. a -> Maybe a Just (Event -> PSignal event_pitch Event event) | Bool otherwise = case Key -> Event -> Maybe Val lookup_val (PControl -> Key ScoreT.pcontrol_name PControl pcontrol) Event event of Just (DeriveT.VPSignal PSignal sig) -> forall a. a -> Maybe a Just PSignal sig Maybe Val _ -> forall a. Maybe a Nothing -- | 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 = forall a b. PitchConfig -> RawPitch a -> RawPitch b PSignal.apply_config PitchConfig config forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RealTime -> Event -> Maybe Pitch 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 Pitch pitch_at RealTime pos Event event = PSignal -> RealTime -> Maybe Pitch PSignal.at (Event -> PSignal event_pitch Event event) RealTime pos apply_controls :: Event -> RealTime -> PSignal.Pitch -> PSignal.Transposed apply_controls :: Event -> RealTime -> Pitch -> Transposed apply_controls Event event RealTime pos = ControlValMap -> Pitch -> 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a b. a -> b -> a const forall a. Maybe a Nothing) forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . Transposed -> Either PitchError NoteNumber PSignal.pitch_nn 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a b. a -> b -> a const forall a. Maybe a Nothing) forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . Transposed -> Either PitchError Note PSignal.pitch_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, Text)]) nn_signal :: Event -> (NoteNumber, [(RealTime, Key)]) nn_signal Event event = PSignal -> (NoteNumber, [(RealTime, Key)]) PSignal.to_nn forall a b. (a -> b) -> a -> b $ ControlMap -> PSignal -> PSignal PSignal.apply_controls (Event -> ControlMap event_controls Event event) forall a b. (a -> b) -> a -> b $ Environ -> PSignal -> PSignal PSignal.apply_environ (Event -> Environ event_environ Event event) forall a b. (a -> b) -> a -> b $ Event -> PSignal event_pitch Event event