-- 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 DeriveFunctor #-} -- | This is the basic interface for slicing. This also includes 'inverting', -- which is a special case of slicing. module Derive.Call.Sub ( -- * inversion under_invert , inverting, inverting_args -- ** events , sub_events, sub_events_negative , sub_tracks , assert_no_subs , modify_notes , derive_subs, derive, derive_tracks, derive_pitch, fit -- ** RestEvent , RestEvent, sub_rest_events , fit_rests, strip_rests -- * reapply , reapply, reapply_call ) where import qualified Data.Map as Map import qualified Data.Tree as Tree import qualified Util.Lists as Lists import qualified Derive.Args as Args import qualified Derive.Call.BlockUtil as BlockUtil import qualified Derive.Call.SubT as SubT import qualified Derive.Derive as Derive import qualified Derive.DeriveT as DeriveT import qualified Derive.Deriver.Internal as Internal import qualified Derive.Eval as Eval import qualified Derive.Expr as Expr import qualified Derive.ParseTitle as ParseTitle import qualified Derive.Score as Score import qualified Derive.Slice as Slice import qualified Derive.Stack as Stack import qualified Derive.Stream as Stream import qualified Perform.Pitch as Pitch import qualified Ui.Event as Event import qualified Ui.Events as Events import qualified Ui.TrackTree as TrackTree import Global import Types -- * inversion {- | Cause this transformer to apply only after inversion. 'Derive.Call.Tags.under_invert' documents this, also see NOTE [under-invert]. Normally when a call is inverted, the transformers run outside the inversion, while only the generator runs underneath. However, some transformers rely on per-note controls, such as pitch and dyn, and therefore need to go under the invert. So this saves the transformer, and applies it only after all the inversion has happened. If there are no sub-tracks, then inversion won't happen, and the transform is run right here. However, if there are sub-tracks, but the generator doesn't want to run, then the transform will be lost. TODO I could probably fix it by making Eval.eval_generator apply the transform, but it would have to clear it out too to avoid evaluating more than once. Not sure which way is right. -} under_invert :: (Derive.NoteArgs -> Derive.NoteDeriver -> Derive.NoteDeriver) -> Derive.NoteArgs -> Derive.NoteDeriver -> Derive.NoteDeriver under_invert :: (NoteArgs -> NoteDeriver -> NoteDeriver) -> NoteArgs -> NoteDeriver -> NoteDeriver under_invert NoteArgs -> NoteDeriver -> NoteDeriver transformer NoteArgs args NoteDeriver deriver | forall (t :: * -> *) a. Foldable t => t a -> Bool null forall a b. (a -> b) -> a -> b $ forall val. Context val -> EventsTree Derive.ctx_sub_tracks forall a b. (a -> b) -> a -> b $ forall val. PassedArgs val -> Context val Derive.passed_ctx NoteArgs args = NoteArgs -> NoteDeriver -> NoteDeriver transformer NoteArgs args NoteDeriver deriver | Bool otherwise = forall {a}. Deriver a -> Deriver a with NoteDeriver deriver where with :: Deriver a -> Deriver a with = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a Internal.local forall a b. (a -> b) -> a -> b $ \Dynamic state -> Dynamic state { state_under_invert :: NoteDeriver -> NoteDeriver Derive.state_under_invert = Dynamic -> NoteDeriver -> NoteDeriver Derive.state_under_invert Dynamic state forall b c a. (b -> c) -> (a -> b) -> a -> c . NoteArgs -> NoteDeriver -> NoteDeriver transformer NoteArgs args } -- | Convert a call into an inverting call. Documented in -- @doc/slicing-inverting.md@. run_invert :: Derive.PassedArgs d -> Derive.NoteDeriver -> Derive.NoteDeriver run_invert :: forall d. PassedArgs d -> NoteDeriver -> NoteDeriver run_invert PassedArgs d args NoteDeriver call = do Dynamic dyn <- forall a. (Dynamic -> a) -> Deriver a Internal.get_dynamic forall a. a -> a id case (Dynamic -> Inversion Derive.state_inversion Dynamic dyn, forall val. Context val -> EventsTree Derive.ctx_sub_tracks Context d ctx) of (Derive.InversionInProgress {}, EventsTree _) -> forall a. HasCallStack => Text -> Deriver a Derive.throw Text "tried to invert while inverting" (Inversion Derive.NotInverted, subs :: EventsTree subs@(EventsNode _:EventsTree _)) -> do EventsTree sliced <- EventsTree -> Event -> ScoreTime -> ([Event], [Event]) -> Deriver EventsTree invert EventsTree subs Event event (forall a. PassedArgs a -> ScoreTime Args.next PassedArgs d args) (forall val. Context val -> [Event] Derive.ctx_prev_events Context d ctx, forall val. Context val -> [Event] Derive.ctx_next_events Context d ctx) forall {a}. Deriver a -> Deriver a with_inversion forall a b. (a -> b) -> a -> b $ EventsTree -> NoteDeriver BlockUtil.derive_tracks EventsTree sliced (Inversion Derive.NotInverted, []) -> NoteDeriver call where with_inversion :: Deriver a -> Deriver a with_inversion = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a Internal.local forall a b. (a -> b) -> a -> b $ \Dynamic dyn -> Dynamic dyn { state_inversion :: Inversion Derive.state_inversion = NoteDeriver -> Inversion Derive.InversionInProgress NoteDeriver call } event :: Event event = forall val. Context val -> Event Derive.ctx_event Context d ctx ctx :: Context d ctx = forall val. PassedArgs val -> Context val Derive.passed_ctx PassedArgs d args -- | Convert a call into an inverting call. This is designed to be convenient -- to insert after the signature arg in a call definition. The args passed -- to the call have been stripped of their sub tracks to avoid another -- inversion. inverting :: (Derive.PassedArgs d -> Derive.NoteDeriver) -> Derive.PassedArgs d -> Derive.NoteDeriver inverting :: forall d. (PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver inverting PassedArgs d -> NoteDeriver call PassedArgs d args = forall d. PassedArgs d -> NoteDeriver -> NoteDeriver run_invert PassedArgs d args (PassedArgs d -> NoteDeriver call PassedArgs d stripped) where stripped :: PassedArgs d stripped = PassedArgs d args { passed_ctx :: Context d Derive.passed_ctx = (forall val. PassedArgs val -> Context val Derive.passed_ctx PassedArgs d args) { ctx_sub_tracks :: EventsTree Derive.ctx_sub_tracks = forall a. Monoid a => a mempty , ctx_sub_events :: Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]] Derive.ctx_sub_events = forall a. Maybe a Nothing } } -- | 'inverting' with its arguments flipped. This is useful for calls that -- want to do stuff with the args before inverting. Make sure to shadow the -- old 'Derive.PassedArgs' with the ones passed to the call, for the reason -- documented in 'inverting'. inverting_args :: Derive.PassedArgs d -> (Derive.PassedArgs d -> Derive.NoteDeriver) -> Derive.NoteDeriver inverting_args :: forall d. PassedArgs d -> (PassedArgs d -> NoteDeriver) -> NoteDeriver inverting_args = forall a b c. (a -> b -> c) -> b -> a -> c flip forall d. (PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver inverting -- When I invert, I call derive_tracks again, which means the inverted bottom -- is going to expect to see the current prev val. TODO but evidently I don't -- need this? Try to make a problem without it. save_prev_val :: Derive.Taggable a => Derive.PassedArgs a -> Derive.Deriver () save_prev_val :: forall a. Taggable a => PassedArgs a -> Deriver () save_prev_val PassedArgs a args = case forall a. PassedArgs a -> Maybe a Args.prev_val PassedArgs a args of Maybe a Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return () Just a val -> Stack -> Maybe (BlockId, TrackId) Stack.block_track_of forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Deriver Stack Internal.get_stack forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Maybe (BlockId, TrackId) Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return () Just (BlockId, TrackId) block_track -> forall {err}. (Threaded -> Threaded) -> Deriver State err () modify_threaded forall a b. (a -> b) -> a -> b $ \Threaded th -> Threaded th { state_prev_val :: Map (BlockId, TrackId) Tagged Derive.state_prev_val = forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert (BlockId, TrackId) block_track (forall a. Taggable a => a -> Tagged Derive.to_tagged a val) (Threaded -> Map (BlockId, TrackId) Tagged Derive.state_prev_val Threaded th) } where modify_threaded :: (Threaded -> Threaded) -> Deriver State err () modify_threaded Threaded -> Threaded modify = forall st err. (st -> st) -> Deriver st err () Derive.modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_threaded :: Threaded Derive.state_threaded = Threaded -> Threaded modify (State -> Threaded Derive.state_threaded State st) } invert :: TrackTree.EventsTree -> Event.Event -> ScoreTime -> ([Event.Event], [Event.Event]) -> Derive.Deriver TrackTree.EventsTree invert :: EventsTree -> Event -> ScoreTime -> ([Event], [Event]) -> Deriver EventsTree invert EventsTree subs Event event ScoreTime next_start ([Event], [Event]) events_around = do -- Pick the current TrackId out of the stack, and give that to the track -- created by inversion. -- TODO I'm not 100% comfortable with this, I don't like putting implicit -- dependencies on the stack like this. Too many of these and someday -- I change how the stack works and all sorts of things break. It would be -- more explicit to put TrackId into Context. Maybe TrackId track_id <- Deriver (Maybe TrackId) stack_track_id let sliced :: EventsTree sliced = Maybe TrackId -> EventsTree slice Maybe TrackId track_id forall (m :: * -> *) a. Applicative m => Maybe a -> (a -> m ()) -> m () whenJust (EventsTree -> Maybe Track non_bottom_note_track EventsTree sliced) forall a b. (a -> b) -> a -> b $ \Track track -> forall a. HasCallStack => Text -> Deriver a Derive.throw forall a b. (a -> b) -> a -> b $ Text "inverting below a note track will lead to an endless loop: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (Track -> Maybe TrackId TrackTree.track_id Track track) forall (m :: * -> *) a. Monad m => a -> m a return EventsTree sliced where slice :: Maybe TrackId -> EventsTree slice Maybe TrackId track_id = forall a b. (a -> b) -> [a] -> [b] map (Bool -> ScoreTime -> ScoreTime -> Maybe InsertEvent -> EventsNode -> EventsNode Slice.slice Bool False (Event -> ScoreTime Event.start Event event) ScoreTime next_start (forall a. a -> Maybe a Just (Maybe TrackId -> InsertEvent insert Maybe TrackId track_id))) EventsTree subs -- Use 'next_start' instead of track_end because in the absence of a next -- note, the track end becomes next note and clips controls. insert :: Maybe TrackId -> InsertEvent insert Maybe TrackId track_id = Slice.InsertEvent { event_duration :: ScoreTime event_duration = Event -> ScoreTime Event.duration Event event , event_orientation :: Orientation event_orientation = Event -> Orientation Event.orientation Event event , event_around :: ([Event], [Event]) event_around = ([Event], [Event]) events_around , event_track_id :: Maybe TrackId event_track_id = Maybe TrackId track_id } stack_track_id :: Derive.Deriver (Maybe TrackId) stack_track_id :: Deriver (Maybe TrackId) stack_track_id = 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Deriver Stack Internal.get_stack -- | An inverting call above another note track will lead to an infinite loop -- if there are overlapping sub-events that also invert, or confusing results -- if there are non-overlapping or non-inverting sub-events. Either way, I -- don't think I want it. -- -- An exception is if the note track is empty, since I can be sure there are -- no inverting calls in that case. non_bottom_note_track :: TrackTree.EventsTree -> Maybe TrackTree.Track non_bottom_note_track :: EventsTree -> Maybe Track non_bottom_note_track EventsTree tree = forall a. [a] -> Maybe a Lists.head (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap EventsNode -> [Track] go EventsTree tree) where go :: EventsNode -> [Track] go (Tree.Node Track track EventsTree subs) | Text -> Bool ParseTitle.is_note_track (Track -> Text TrackTree.track_title Track track) Bool -> Bool -> Bool && Bool -> Bool not (Events -> Bool Events.null (Track -> Events TrackTree.track_events Track track)) Bool -> Bool -> Bool && Bool -> Bool not (forall (t :: * -> *) a. Foldable t => t a -> Bool null EventsTree subs) = [Track track] | Bool otherwise = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap EventsNode -> [Track] go EventsTree subs -- * sub tracks -- | Get the Events of subtracks, if any, returning one list of events per sub -- note track. This is the top-level utility for note calls that take other -- note calls as arguments. sub_events :: Derive.PassedArgs d -> Derive.Deriver [[SubT.Event]] sub_events :: forall d. PassedArgs d -> Deriver [[Event]] sub_events = forall d. Bool -> PassedArgs d -> Deriver [[Event]] sub_events_ Bool False -- | TODO maybe this should replace 'sub_events' sub_tracks :: Derive.PassedArgs d -> Derive.Deriver [SubT.Track] sub_tracks :: forall d. PassedArgs d -> Deriver [Track] sub_tracks = forall d. Bool -> PassedArgs d -> Deriver [Track] sub_tracks_ Bool False -- | Like 'sub_events', but exclude events at the start time, and include -- events at the end time. Presumably suitable for 'Event.Negative' calls. sub_events_negative :: Derive.PassedArgs d -> Derive.Deriver [[SubT.Event]] sub_events_negative :: forall d. PassedArgs d -> Deriver [[Event]] sub_events_negative = forall d. Bool -> PassedArgs d -> Deriver [[Event]] sub_events_ Bool True -- | Throw an exception if there are sub-events. assert_no_subs :: Derive.PassedArgs d -> Derive.Deriver () assert_no_subs :: forall d. PassedArgs d -> Deriver () assert_no_subs PassedArgs d args = do -- Due to laziness, checking null shouldn't require any actual slicing. [[Event]] events <- forall d. PassedArgs d -> Deriver [[Event]] sub_events PassedArgs d args if forall (t :: * -> *) a. Foldable t => t a -> Bool null [[Event]] events then forall (m :: * -> *) a. Monad m => a -> m a return () else case forall val. Context val -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]] Derive.ctx_sub_events Context d ctx of Just [[(ScoreTime, ScoreTime, NoteDeriver)]] subs -> forall a. HasCallStack => Text -> Deriver a Derive.throw forall a b. (a -> b) -> a -> b $ Text "expected no sub events, but got " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (forall a b. (a -> b) -> [a] -> [b] map (forall a b. (a -> b) -> [a] -> [b] map (\(ScoreTime s, ScoreTime d, NoteDeriver _) -> (ScoreTime s, ScoreTime d))) [[(ScoreTime, ScoreTime, NoteDeriver)]] subs) Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]] Nothing -> forall a. HasCallStack => Text -> Deriver a Derive.throw forall a b. (a -> b) -> a -> b $ Text "expected no sub events, but got " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (forall a b. (a -> b) -> [a] -> [b] map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Track -> (Text, Maybe TrackId) extract_track) (forall val. Context val -> EventsTree Derive.ctx_sub_tracks Context d ctx)) where ctx :: Context d ctx = forall val. PassedArgs val -> Context val Derive.passed_ctx PassedArgs d args extract_track :: Track -> (Text, Maybe TrackId) extract_track Track t = (Track -> Text TrackTree.track_title Track t, Track -> Maybe TrackId TrackTree.track_id Track t) sub_events_ :: Bool -> Derive.PassedArgs d -> Derive.Deriver [[SubT.Event]] sub_events_ :: forall d. Bool -> PassedArgs d -> Deriver [[Event]] sub_events_ Bool include_end PassedArgs d args = forall a b. (a -> b) -> [a] -> [b] map Track -> [Event] SubT._events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall d. Bool -> PassedArgs d -> Deriver [Track] sub_tracks_ Bool include_end PassedArgs d args sub_tracks_ :: Bool -> Derive.PassedArgs d -> Derive.Deriver [SubT.Track] sub_tracks_ :: forall d. Bool -> PassedArgs d -> Deriver [Track] sub_tracks_ Bool include_end PassedArgs d args = case forall val. Context val -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]] Derive.ctx_sub_events (forall val. PassedArgs val -> Context val Derive.passed_ctx PassedArgs d args) of Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]] Nothing -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either forall a. HasCallStack => Text -> Deriver a Derive.throw (forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe Track -> Maybe Track mktrack) forall a b. (a -> b) -> a -> b $ Bool -> ScoreTime -> ScoreTime -> EventsTree -> Either Text [Track] Slice.checked_slice_notes Bool include_end ScoreTime start ScoreTime end forall a b. (a -> b) -> a -> b $ forall val. Context val -> EventsTree Derive.ctx_sub_tracks (forall val. PassedArgs val -> Context val Derive.passed_ctx PassedArgs d args) Just [[(ScoreTime, ScoreTime, NoteDeriver)]] tracks -> forall (m :: * -> *) a. Monad m => a -> m a return [ Either Text TrackId -> [Event] -> Track SubT.Track (forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ Text "subevent:" forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Integer i) forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (\(ScoreTime s, ScoreTime d, NoteDeriver n) -> forall a. ScoreTime -> ScoreTime -> a -> EventT a SubT.EventT ScoreTime s ScoreTime d NoteDeriver n) [(ScoreTime, ScoreTime, NoteDeriver)] track | (Integer i, [(ScoreTime, ScoreTime, NoteDeriver)] track) <- forall a b. [a] -> [b] -> [(a, b)] zip [Integer 0..] [[(ScoreTime, ScoreTime, NoteDeriver)]] tracks ] where mktrack :: Track -> Maybe Track mktrack (Slice.Track Maybe TrackId track_id [Note] notes) = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ -- 'TrackTree.track_id' can be Nothing. Presumably this happens for -- a constructed block. Either Text TrackId -> [Event] -> Track SubT.Track (forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall a b. a -> Either a b Left Text "no-track-id") forall a b. b -> Either a b Right Maybe TrackId track_id) (forall a b. (a -> b) -> [a] -> [b] map Note -> Event mkevent [Note] notes) (ScoreTime start, ScoreTime end) = forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range PassedArgs d args -- The events have been shifted back to 0 by 'Slice.checked_slice_notes', -- but are still their original lengths. Stretch them back to 1 so Events -- are normalized. mkevent :: Note -> Event mkevent (ScoreTime shift, ScoreTime stretch, EventsTree tree) = SubT.EventT { _start :: ScoreTime _start = ScoreTime shift , _duration :: ScoreTime _duration = ScoreTime stretch , _note :: NoteDeriver _note = forall a. ScoreTime -> Deriver a -> Deriver a Derive.stretch (if ScoreTime stretch forall a. Eq a => a -> a -> Bool == ScoreTime 0 then ScoreTime 1 else forall a. Fractional a => a -> a recip ScoreTime stretch) (EventsTree -> NoteDeriver BlockUtil.derive_tracks EventsTree tree) } -- | Modify the text of sub note tracks before deriving them. This can be -- used to implement an ad-hoc new language. modify_notes :: ([SubT.EventT Text] -> Either Text [SubT.EventT Text]) -> Derive.PassedArgs a -> Either Text (Derive.PassedArgs a) modify_notes :: forall a. ([EventT Text] -> Either Text [EventT Text]) -> PassedArgs a -> Either Text (PassedArgs a) modify_notes [EventT Text] -> Either Text [EventT Text] modify = forall a. (EventsTree -> Either Text EventsTree) -> PassedArgs a -> Either Text (PassedArgs a) modify_sub_tracks forall a b. (a -> b) -> a -> b $ (Events -> Either Text Events) -> EventsTree -> Either Text EventsTree modify_sub_notes (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [EventT Text] -> Events to forall b c a. (b -> c) -> (a -> b) -> a -> c . [EventT Text] -> Either Text [EventT Text] modify forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> [EventT Text] from) where from :: Events -> [EventT Text] from = forall a b. (a -> b) -> [a] -> [b] map Event -> EventT Text make forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> [Event] Events.ascending make :: Event -> EventT Text make Event e = SubT.EventT { _start :: ScoreTime _start = Event -> ScoreTime Event.start Event e , _duration :: ScoreTime _duration = Event -> ScoreTime Event.duration Event e , _note :: Text _note = Event -> Text Event.text Event e } to :: [EventT Text] -> Events to = [Event] -> Events Events.from_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (\(SubT.EventT ScoreTime start ScoreTime dur Text text) -> ScoreTime -> ScoreTime -> Text -> Event Event.event ScoreTime start ScoreTime dur Text text) modify_sub_notes :: (Events.Events -> Either Text Events.Events) -> TrackTree.EventsTree -> Either Text TrackTree.EventsTree modify_sub_notes :: (Events -> Either Text Events) -> EventsTree -> Either Text EventsTree modify_sub_notes Events -> Either Text Events modify = forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse forall a b. (a -> b) -> a -> b $ \Track track -> if Text -> Bool ParseTitle.is_note_track (Track -> Text TrackTree.track_title Track track) then do Events events <- Events -> Either Text Events modify (Track -> Events TrackTree.track_events Track track) forall a b. b -> Either a b Right forall a b. (a -> b) -> a -> b $ Track track { track_events :: Events TrackTree.track_events = Events events } else forall a b. b -> Either a b Right Track track modify_sub_tracks :: (TrackTree.EventsTree -> Either Text TrackTree.EventsTree) -> Derive.PassedArgs a -> Either Text (Derive.PassedArgs a) modify_sub_tracks :: forall a. (EventsTree -> Either Text EventsTree) -> PassedArgs a -> Either Text (PassedArgs a) modify_sub_tracks EventsTree -> Either Text EventsTree modify PassedArgs a args = do EventsTree tracks <- EventsTree -> Either Text EventsTree modify forall a b. (a -> b) -> a -> b $ forall val. Context val -> EventsTree Derive.ctx_sub_tracks (forall val. PassedArgs val -> Context val Derive.passed_ctx PassedArgs a args) forall a b. b -> Either a b Right forall a b. (a -> b) -> a -> b $ PassedArgs a args { passed_ctx :: Context a Derive.passed_ctx = (forall val. PassedArgs val -> Context val Derive.passed_ctx PassedArgs a args) { ctx_sub_tracks :: EventsTree Derive.ctx_sub_tracks = EventsTree tracks } } derive_subs :: Derive.PassedArgs d -> Derive.NoteDeriver derive_subs :: forall d. PassedArgs d -> NoteDeriver derive_subs = [[Event]] -> NoteDeriver derive_tracks forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< forall d. PassedArgs d -> Deriver [[Event]] sub_events -- | Derive and merge Events. derive :: [SubT.Event] -> Derive.NoteDeriver derive :: [Event] -> NoteDeriver derive = forall b a. Monoid b => (a -> b) -> [a] -> b mconcatMap (\(SubT.EventT ScoreTime s ScoreTime d NoteDeriver n) -> forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a Derive.place ScoreTime s ScoreTime d NoteDeriver n) derive_tracks :: [[SubT.Event]] -> Derive.NoteDeriver derive_tracks :: [[Event]] -> NoteDeriver derive_tracks = [Event] -> NoteDeriver derive forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Ord k => (a -> k) -> [[a]] -> [a] Lists.mergeLists forall a. EventT a -> ScoreTime SubT._start -- | Get the pitch of an Event. Useful for debugging. derive_pitch :: SubT.Event -> Derive.Deriver (SubT.EventT (Maybe Pitch.Note)) derive_pitch :: Event -> Deriver (EventT (Maybe Note)) derive_pitch Event event = do Stream Event stream <- forall a. EventT a -> a SubT._note Event event let note :: Maybe Note note = Event -> Maybe Note Score.initial_note forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall a. [a] -> Maybe a Lists.head (forall a. Stream a -> [a] Stream.events_of Stream Event stream) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Event event { _note :: Maybe Note SubT._note = Maybe Note note } -- | Re-fit the events from one range to another. fit :: (ScoreTime, ScoreTime) -- ^ fit this range -> (ScoreTime, ScoreTime) -- ^ into this range -> [SubT.Event] -> Derive.NoteDeriver fit :: (ScoreTime, ScoreTime) -> (ScoreTime, ScoreTime) -> [Event] -> NoteDeriver fit (ScoreTime from_start, ScoreTime from_end) (ScoreTime to_start, ScoreTime to_end) [Event] events = forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a Derive.place ScoreTime to_start ScoreTime factor forall a b. (a -> b) -> a -> b $ [Event] -> NoteDeriver derive [Event e { _start :: ScoreTime SubT._start = forall a. EventT a -> ScoreTime SubT._start Event e forall a. Num a => a -> a -> a - ScoreTime from_start } | Event e <- [Event] events] -- Subtract from_start because Derive.place is going to add the start back -- on again in the form of to_start. where factor :: ScoreTime factor = (ScoreTime to_end forall a. Num a => a -> a -> a - ScoreTime to_start) forall a. Fractional a => a -> a -> a / (ScoreTime from_end forall a. Num a => a -> a -> a - ScoreTime from_start) -- ** RestEvent -- | A Nothing represents a rest. type RestEvent = SubT.EventT (Maybe Derive.NoteDeriver) -- | This is like 'sub_events', but gaps between the events are returned as -- explicit rests. sub_rest_events :: Bool -- ^ end bias -> Bool -- ^ if True, include the trailing gap as a rest -> Derive.PassedArgs d -> Derive.Deriver [[RestEvent]] sub_rest_events :: forall d. Bool -> Bool -> PassedArgs d -> Deriver [[RestEvent]] sub_rest_events Bool include_end Bool want_final_rest PassedArgs d args = forall a b. (a -> b) -> [a] -> [b] map (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry (forall a. Bool -> ScoreTime -> ScoreTime -> [EventT a] -> [EventT (Maybe a)] find_gaps Bool want_final_rest) (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range PassedArgs d args)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall d. Bool -> PassedArgs d -> Deriver [[Event]] sub_events_ Bool include_end PassedArgs d args find_gaps :: Bool -> ScoreTime -> ScoreTime -> [SubT.EventT a] -> [SubT.EventT (Maybe a)] find_gaps :: forall a. Bool -> ScoreTime -> ScoreTime -> [EventT a] -> [EventT (Maybe a)] find_gaps Bool want_final_rest ScoreTime start ScoreTime end (EventT a event : [EventT a] events) | ScoreTime gap forall a. Ord a => a -> a -> Bool > ScoreTime 0 = forall a. ScoreTime -> ScoreTime -> a -> EventT a SubT.EventT ScoreTime start ScoreTime gap forall a. Maybe a Nothing forall a. a -> [a] -> [a] : [EventT (Maybe a)] rest | Bool otherwise = [EventT (Maybe a)] rest where gap :: ScoreTime gap = forall a. EventT a -> ScoreTime SubT._start EventT a event forall a. Num a => a -> a -> a - ScoreTime start rest :: [EventT (Maybe a)] rest = (forall a. a -> Maybe a Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> EventT a event) forall a. a -> [a] -> [a] : forall a. Bool -> ScoreTime -> ScoreTime -> [EventT a] -> [EventT (Maybe a)] find_gaps Bool want_final_rest (forall a. EventT a -> ScoreTime SubT.end EventT a event) ScoreTime end [EventT a] events find_gaps Bool want_final_rest ScoreTime start ScoreTime end [] | Bool want_final_rest Bool -> Bool -> Bool && ScoreTime start forall a. Ord a => a -> a -> Bool < ScoreTime end = [forall a. ScoreTime -> ScoreTime -> a -> EventT a SubT.EventT ScoreTime start (ScoreTime endforall a. Num a => a -> a -> a -ScoreTime start) forall a. Maybe a Nothing] | Bool otherwise = [] -- | 'fit' for 'RestEvent's. fit_rests :: (ScoreTime, ScoreTime) -> (ScoreTime, ScoreTime) -> [RestEvent] -> Derive.NoteDeriver fit_rests :: (ScoreTime, ScoreTime) -> (ScoreTime, ScoreTime) -> [RestEvent] -> NoteDeriver fit_rests (ScoreTime from_start, ScoreTime from_end) (ScoreTime to_start, ScoreTime to_end) [RestEvent] events = forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a Derive.place ScoreTime to_start ScoreTime factor forall a b. (a -> b) -> a -> b $ [Event] -> NoteDeriver derive [Event e { _start :: ScoreTime SubT._start = forall a. EventT a -> ScoreTime SubT._start Event e forall a. Num a => a -> a -> a - ScoreTime from_start } | Event e <- [RestEvent] -> [Event] strip_rests [RestEvent] events] where factor :: ScoreTime factor = (ScoreTime to_end forall a. Num a => a -> a -> a - ScoreTime to_start) forall a. Fractional a => a -> a -> a / (ScoreTime from_end forall a. Num a => a -> a -> a - ScoreTime from_start) strip_rests :: [RestEvent] -> [SubT.Event] strip_rests :: [RestEvent] -> [Event] strip_rests [RestEvent] events = [forall a. ScoreTime -> ScoreTime -> a -> EventT a SubT.EventT ScoreTime s ScoreTime d NoteDeriver n | SubT.EventT ScoreTime s ScoreTime d (Just NoteDeriver n) <- [RestEvent] events] -- * reapply -- | Call a note parent with sub-events. While you can easily call other -- kinds of calls with 'Eval.reapply', note parents are more tricky -- because they expect a track structure in 'Derive.ctx_sub_tracks'. This -- bypasses that and directly passes 'SubT.EventT's to the note parent, -- courtesy of 'Derive.ctx_sub_events'. reapply :: Derive.Context Score.Event -> DeriveT.Expr -> [[SubT.Event]] -> Derive.NoteDeriver reapply :: Context Event -> Expr -> [[Event]] -> NoteDeriver reapply Context Event ctx Expr expr [[Event]] notes = forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d) Eval.reapply Context Event subs Expr expr where subs :: Context Event subs = Context Event ctx { ctx_sub_events :: Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]] Derive.ctx_sub_events = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (forall a b. (a -> b) -> [a] -> [b] map (\(SubT.EventT ScoreTime s ScoreTime d NoteDeriver n) -> (ScoreTime s, ScoreTime d, NoteDeriver n))) [[Event]] notes } reapply_call :: Derive.Context Score.Event -> Expr.Symbol -> [DeriveT.Term] -> [[SubT.Event]] -> Derive.NoteDeriver reapply_call :: Context Event -> Symbol -> [Term] -> [[Event]] -> NoteDeriver reapply_call Context Event ctx Symbol sym [Term] call_args = Context Event -> Expr -> [[Event]] -> NoteDeriver reapply Context Event ctx forall a b. (a -> b) -> a -> b $ forall val. Call val -> Expr val Expr.generator forall a b. (a -> b) -> a -> b $ forall val. Symbol -> [Term val] -> Call val Expr.Call Symbol sym [Term] call_args {- NOTE [under-invert] . To make 'lift' to an absolute pitch work outside of inversion, I'd need an abstract way (e.g. like a transpose signal) to say "pitch midway to (4c)" . It's better to have the lift under the pitch. The only reason it isn't is that inversion assumes all transformers go above. So either make it a generator (at which point it can't compose), or have some way to put transformers under the inversion, e.g. 'delay | Drop $ lift $ gen' under inversion is 'delay' -> 'Drop' 'lift' 'gen'. . Another way would be to put that in the call itself, so 'lift' has a flag that says it likes to be under the inversion. Then the invert function has to go look all those up. But that can't work, because invert is called by a generator, and that's too late. . So call all the transformers pre and post invert. Normally they check if they're under inversion, and if so do nothing, but ones that would rather be inverted do the inverse. Cons: 1. Instead of transformers always happening before inversion, they can now vary internally, which is one more subtle thing about inversion. I'll need to expose it in documentation at least, via a tag. 2. Call stacks get even messier in the presence of inversion, since every transformer appears twice. 3. Transformers can have their order change, e.g. given 'below | above | gen', below is actually called below above, if it wants to be under inversion. . It seems like I could improve these by driving them from a tag. E.g. if the call has a under-inversion tag, Call.eval_transformers will skip or not skip, as appropriate. This solves #1 and #2, but not #3. . This is all just to get lift working under inversion. Is it that important? . Everything should work under inversion. It's a hassle to suddenly have to rearrange the pitch track, and now 'd' doesn't work. . This will come up for every note transformer that wants to know the pitch. -}