-- Copyright 2017 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 -- | Utilities for the default note call. They're separated here so internal -- utilities can make events without importing "Derive.C.Prelude.Note". module Derive.Call.NoteUtil (make_event, make_event_control_vals) where import qualified Data.Map as Map import qualified Derive.Args as Args import qualified Derive.Call as Call import qualified Derive.Controls as Controls import qualified Derive.Derive as Derive import qualified Derive.DeriveT as DeriveT import qualified Derive.Deriver.Internal as Internal import qualified Derive.Env as Env import qualified Derive.EnvKey as EnvKey import qualified Derive.Flags as Flags import qualified Derive.PSignal as PSignal import qualified Derive.Score as Score import qualified Derive.ScoreT as ScoreT import qualified Perform.RealTime as RealTime import qualified Perform.Signal as Signal import qualified Ui.Color as Color import qualified Ui.Event as Event import qualified Ui.ScoreTime as ScoreTime import Global import Types -- | This is the canonical way to make a Score.Event. It handles all the -- control trimming and control function value stashing that the perform layer -- relies on. make_event :: Derive.PassedArgs a -> Derive.Dynamic -> RealTime -> RealTime -> Text -> Flags.Flags -> Derive.Deriver Score.Event make_event :: forall a. PassedArgs a -> Dynamic -> RealTime -> RealTime -> Text -> Flags -> Deriver Event make_event PassedArgs a args Dynamic dyn RealTime start RealTime dur Text integrate Flags flags = do ControlValMap cvmap <- RealTime -> Deriver ControlValMap Derive.controls_at RealTime start forall a. ControlValMap -> PassedArgs a -> Dynamic -> RealTime -> RealTime -> Text -> Flags -> Deriver Event make_event_control_vals ControlValMap cvmap PassedArgs a args Dynamic dyn RealTime start RealTime dur Text integrate Flags flags -- | Specialized version of 'make_event' just so I can avoid calling -- Derive.controls_at twice. make_event_control_vals :: ScoreT.ControlValMap -> Derive.PassedArgs a -> Derive.Dynamic -> RealTime -> RealTime -> Text -> Flags.Flags -> Derive.Deriver Score.Event make_event_control_vals :: forall a. ControlValMap -> PassedArgs a -> Dynamic -> RealTime -> RealTime -> Text -> Flags -> Deriver Event make_event_control_vals ControlValMap cvmap PassedArgs a args Dynamic dyn RealTime start RealTime dur Text integrate Flags flags = do RealTime offset <- RealTime -> Deriver RealTime get_start_offset RealTime start Deriver () Internal.increment_event_serial forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $! Score.Event { event_start :: RealTime event_start = RealTime start , event_duration :: RealTime event_duration = RealTime dur , event_text :: Text event_text = Event -> Text Event.text (forall a. PassedArgs a -> Event Args.event PassedArgs a args) , event_integrate :: Text event_integrate = Text integrate , event_pitch :: PSignal event_pitch = RealTime -> PSignal -> PSignal trim_pitch RealTime start (Dynamic -> PSignal Derive.state_pitch Dynamic dyn) , event_stack :: Stack event_stack = Dynamic -> Stack Derive.state_stack Dynamic dyn , event_highlight :: Highlight event_highlight = Highlight Color.NoHighlight , event_instrument :: Instrument event_instrument = forall a. a -> Maybe a -> a fromMaybe Instrument ScoreT.empty_instrument forall a b. (a -> b) -> a -> b $ forall a. Typecheck a => Text -> Environ -> Maybe a Env.maybe_val Text EnvKey.instrument Environ environ -- Put trimmed controls back into the environ. , event_environ :: Environ event_environ = (Val -> Val) -> Environ -> Environ Env.map (RealTime -> Val -> Val trim_control_vals RealTime start) forall a b. (a -> b) -> a -> b $ ControlValMap -> RealTime -> Environ -> Environ stash_convert_values ControlValMap cvmap RealTime offset Environ environ , event_flags :: Flags event_flags = Flags flags , event_delayed_args :: Map Text Dynamic event_delayed_args = forall a. Monoid a => a mempty , event_logs :: [Msg] event_logs = [] } where environ :: Environ environ = Dynamic -> Environ Derive.state_environ Dynamic dyn -- | Trim control signals. -- -- Previously I would also trim to the end of the note, but now I leave it -- as-is and rely on the performer to trim the end according to the -- instrument's decay time. This is so that a note whose decay persists -- outside of its block can still see control changes after its block ends. trim_control_vals :: RealTime -> DeriveT.Val -> DeriveT.Val trim_control_vals :: RealTime -> Val -> Val trim_control_vals RealTime start = \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.drop_before RealTime start 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.drop_before RealTime start PSignal sig Val val -> Val val -- | Stash the dynamic value from the ControlValMap in -- 'Controls.dynamic_function'. Gory details in NOTE [EnvKey.dynamic_val]. stash_convert_values :: ScoreT.ControlValMap -> RealTime -> Env.Environ -> Env.Environ stash_convert_values :: ControlValMap -> RealTime -> Environ -> Environ stash_convert_values ControlValMap vals RealTime offset = Environ -> Environ stash_start_offset forall b c a. (b -> c) -> (a -> b) -> a -> c . Control -> Text -> Environ -> Environ insert_if Control Controls.dynamic Text EnvKey.dynamic_val forall b c a. (b -> c) -> (a -> b) -> a -> c . Control -> Text -> Environ -> Environ insert_if Control Controls.attack_velocity Text EnvKey.attack_val -- Perhaps this should be sampled at the event end, but I don't want to -- get a whole new ControlValMap just for that. forall b c a. (b -> c) -> (a -> b) -> a -> c . Control -> Text -> Environ -> Environ insert_if Control Controls.release_velocity Text EnvKey.release_val where stash_start_offset :: Environ -> Environ stash_start_offset = forall a. ToVal a => Text -> a -> Environ -> Environ Env.insert_val Text EnvKey.start_offset_val RealTime offset insert_if :: Control -> Text -> Environ -> Environ insert_if Control control Text key = forall b a. b -> (a -> b) -> Maybe a -> b maybe forall a. a -> a id (forall a. ToVal a => Text -> a -> Environ -> Environ Env.insert_val Text key) forall a b. (a -> b) -> a -> b $ forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Control control ControlValMap vals get_start_offset :: RealTime -> Derive.Deriver RealTime get_start_offset :: RealTime -> Deriver RealTime get_start_offset RealTime start = do RealTime start_s <- forall b a. b -> (a -> b) -> Maybe a -> b maybe RealTime 0 Y -> RealTime RealTime.seconds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Control -> RealTime -> Deriver (Maybe Y) Derive.untyped_control_at Control Controls.start_s RealTime start ScoreTime start_t <- forall b a. b -> (a -> b) -> Maybe a -> b maybe ScoreTime 0 Y -> ScoreTime ScoreTime.from_double forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Control -> RealTime -> Deriver (Maybe Y) Derive.untyped_control_at Control Controls.start_t RealTime start RealTime start_t <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime Call.real_duration RealTime start ScoreTime start_t forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ RealTime start_s forall a. Num a => a -> a -> a + RealTime start_t -- | For inverted tracks, this trimming should already be done by -- 'Derive.Control.trim_signal'. trim_pitch :: RealTime -> PSignal.PSignal -> PSignal.PSignal trim_pitch :: RealTime -> PSignal -> PSignal trim_pitch = RealTime -> PSignal -> PSignal PSignal.drop_before