-- Copyright 2013 Evan Laforge -- This program is distributed under the terms of the GNU General Public -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt {-# LANGUAGE CPP #-} {- | Slicing is chopping the block horizontally, so that the horizontal chunks can act like their own little blocks. For the sake of convenient notation, this is done in several places. 1. A note with subtracks will slice out the subevents within its range. This allows a note to take another note (or notes) as arguments, e.g. a tuplet. This is what 'slice_notes' is for. 2. A note with controls as subtracks can invert itself so it has control over the evaluation of the controls. Documented further in "Derive.Call.Note". 3. #1 above is a convenient way to apply a transformation to multiple notes: group the tracks under another, and put the transformations in the parent. However, notes that have no transformation (aka orphans) must be extracted from underneath the empty parent, otherwise they will not be evaluated at all. This is done by 'Derive.Call.derive_note_track'. This is a nasty tricky bit of work, but is depended on by all the high level notation, e.g. calls that can manipulate the results of other calls, aka parent calls. I'd still love to figure out a better way to do it though! -} module Derive.Slice ( InsertEvent(..), Track(..), slice , checked_slice_notes , slice_orphans #ifdef TESTING , strip_empty_tracks , slice_notes #endif ) where import qualified Data.List as List import qualified Data.Monoid as Monoid import qualified Data.Text as Text import qualified Data.Tree as Tree import qualified Util.Lists as Lists import qualified Util.Then as Then import qualified Derive.ParseTitle as ParseTitle import qualified Ui.Event as Event import qualified Ui.Events as Events import qualified Ui.TrackTree as TrackTree import qualified Ui.Types as Types import qualified Ui.Ui as Ui import Global import Types -- | Ask 'slice' to synthesize a note track and insert it at the leaves of -- the sliced tree. data InsertEvent = InsertEvent { InsertEvent -> TrackTime event_duration :: !ScoreTime -- | A Negative orientation means that the controls at the Event.end time -- are not trimmed off. , InsertEvent -> Orientation event_orientation :: !Types.Orientation , InsertEvent -> ([Event], [Event]) event_around :: !([Event.Event], [Event.Event]) -- | The TrackId for the track created for this event. This is required -- so it can collect a TrackDynamic and when the Cmd level looks at at -- track with inverted note calls, it sees the environ established by the -- tracks that the calls are inverted beneath. E.g., if the pitch track -- sets a scale, the Cmd layer should see the note track as having that -- scale. , InsertEvent -> Maybe TrackId event_track_id :: !(Maybe TrackId) } deriving (Int -> InsertEvent -> ShowS [InsertEvent] -> ShowS InsertEvent -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [InsertEvent] -> ShowS $cshowList :: [InsertEvent] -> ShowS show :: InsertEvent -> String $cshow :: InsertEvent -> String showsPrec :: Int -> InsertEvent -> ShowS $cshowsPrec :: Int -> InsertEvent -> ShowS Show) {- | Slice a track between start and end, and optionally put a note track with a single event of given string at the bottom. Sliced control tracks usually get events beyond the slice boundaries for context. -} slice :: Bool -- ^ Omit events than begin at the start. -- 'slice_notes' documents why this is necessary. -> ScoreTime -> ScoreTime -> Maybe InsertEvent -- ^ If given, insert an event at the bottom with the given text and dur. -- The created track will have the given track_range, so it can create -- a Stack.Region entry. -> TrackTree.EventsNode -> TrackTree.EventsNode slice :: Bool -> TrackTime -> TrackTime -> Maybe InsertEvent -> EventsNode -> EventsNode slice Bool exclude_start TrackTime start TrackTime end Maybe InsertEvent insert_event (Tree.Node Track track [EventsNode] subs) = forall a. a -> [Tree a] -> Tree a Tree.Node (Track -> Track slice_t Track track) forall a b. (a -> b) -> a -> b $ if forall (t :: * -> *) a. Foldable t => t a -> Bool null [EventsNode] subs then TrackTime -> Maybe BlockId -> [EventsNode] insert (Track -> TrackTime TrackTree.track_shifted Track track) (Track -> Maybe BlockId TrackTree.track_block_id Track track) else forall a b. (a -> b) -> [a] -> [b] map (Bool -> TrackTime -> TrackTime -> Maybe InsertEvent -> EventsNode -> EventsNode slice Bool exclude_start TrackTime start TrackTime end Maybe InsertEvent insert_event) [EventsNode] subs where insert :: TrackTime -> Maybe BlockId -> [EventsNode] insert TrackTime shift Maybe BlockId block_id = case Maybe InsertEvent insert_event of Maybe InsertEvent Nothing -> [] Just InsertEvent insert_event -> [forall a. a -> [Tree a] -> Tree a Tree.Node (TrackTime -> Maybe BlockId -> InsertEvent -> Track make TrackTime shift Maybe BlockId block_id InsertEvent insert_event) []] -- The synthesized bottom track. Since slicing only happens within -- a block, I assume the BlockId is the same as the parent. I need -- a BlockId to look up the previous val in 'Derive.Threaded'. make :: TrackTime -> Maybe BlockId -> InsertEvent -> Track make TrackTime shift Maybe BlockId block_id (InsertEvent TrackTime dur Orientation _ ([Event], [Event]) around Maybe TrackId track_id) = TrackTree.Track { track_title :: Text track_title = Text ">" , track_events :: Events track_events = Event -> Events Events.singleton (TrackTime -> TrackTime -> Text -> Event Event.event TrackTime start TrackTime dur Text "") , track_id :: Maybe TrackId track_id = Maybe TrackId track_id , track_block_id :: Maybe BlockId track_block_id = Maybe BlockId block_id , track_start :: TrackTime track_start = TrackTime start , track_end :: TrackTime track_end = TrackTime end , track_sliced :: Sliced track_sliced = Sliced TrackTree.Inversion , track_around :: ([Event], [Event]) track_around = ([Event], [Event]) around -- Since a note may be inverted and inserted after 'slice_notes' -- and its shifting, I have to get the shift from the parent track. , track_shifted :: TrackTime track_shifted = TrackTime shift , track_voice :: Maybe Int track_voice = forall a. Maybe a Nothing } slice_t :: Track -> Track slice_t Track track = Track track { track_events :: Events TrackTree.track_events = Events within , track_start :: TrackTime TrackTree.track_start = TrackTime start , track_end :: TrackTime TrackTree.track_end = TrackTime end , track_sliced :: Sliced TrackTree.track_sliced = case Track -> Sliced TrackTree.track_sliced Track track of Sliced TrackTree.Inversion -> Sliced TrackTree.Inversion -- This might already be Sliced Positive because of orphan -- slicing, so make sure to update the orientation for both -- Sliced and NotSliced. Sliced _ -> Orientation -> Sliced TrackTree.Sliced (forall b a. b -> (a -> b) -> Maybe a -> b maybe Orientation Types.Positive InsertEvent -> Orientation event_orientation Maybe InsertEvent insert_event) , track_around :: ([Event], [Event]) TrackTree.track_around = ([Event] before, [Event] after) } where ([Event] before, Events within, [Event] after) = Track -> ([Event], Events, [Event]) extract_events Track track -- Extract events from an intermediate track. extract_events :: Track -> ([Event], Events, [Event]) extract_events Track track | Text -> Bool ParseTitle.is_note_track Text title = Bool -> TrackTime -> TrackTime -> Events -> ([Event], Events, [Event]) extract_note_events Bool exclude_start TrackTime start TrackTime end Events events | Bool otherwise = TrackTime -> TrackTime -> Events -> ([Event], Events, [Event]) extract_control_events TrackTime start TrackTime end Events events where events :: Events events = Track -> Events TrackTree.track_events Track track title :: Text title = Track -> Text TrackTree.track_title Track track -- | Note tracks don't include pre and post events like control tracks. extract_note_events :: Bool -> ScoreTime -> ScoreTime -> Events.Events -> ([Event.Event], Events.Events, [Event.Event]) extract_note_events :: Bool -> TrackTime -> TrackTime -> Events -> ([Event], Events, [Event]) extract_note_events Bool exclude_start TrackTime start TrackTime end Events events = (if Bool exclude_start then forall {c}. ([Event], Events, c) -> ([Event], Events, c) exclude_s else forall a. a -> a id) (Events -> [Event] Events.descending Events pre, Events within, Events -> [Event] Events.ascending Events post) where -- TODO pass Events.Range instead of (start, end) so I can get -0 slices -- right. range :: Range range | TrackTime start forall a. Eq a => a -> a -> Bool == TrackTime end = TrackTime -> Orientation -> Range Events.Point TrackTime start Orientation Types.Positive | Bool otherwise = TrackTime -> TrackTime -> Range Events.Range TrackTime start TrackTime end (Events pre, Events within, Events post) = Range -> Events -> (Events, Events, Events) Events.split_range Range range Events events exclude_s :: ([Event], Events, c) -> ([Event], Events, c) exclude_s ([Event] pre, Events within, c post) = case TrackTime -> Orientation -> Events -> Maybe Event Events.at TrackTime start Orientation Types.Positive Events within of Just Event event -> ( Event event forall a. a -> [a] -> [a] : [Event] pre , Range -> Events -> Events Events.remove (TrackTime -> Orientation -> Range Events.Point TrackTime start Orientation Types.Positive) Events within , c post ) Maybe Event Nothing -> ([Event] pre, Events within, c post) extract_control_events :: ScoreTime -> ScoreTime -> Events.Events -> ([Event.Event], Events.Events, [Event.Event]) -- ^ (descending_pre, within, ascending_post) extract_control_events :: TrackTime -> TrackTime -> Events -> ([Event], Events, [Event]) extract_control_events TrackTime start TrackTime end Events events = ([Event] pre, [Event] -> Events Events.from_list [Event] within, [Event] post2) where ([Event] pre, [Event] post1) = case TrackTime -> Events -> ([Event], [Event]) Events.split_lists TrackTime start Events events of (Event at_1:[Event] pre, Event at:[Event] post) | Event -> TrackTime Event.start Event at forall a. Ord a => a -> a -> Bool > TrackTime start -> ([Event] pre, Event at_1forall a. a -> [a] -> [a] :Event atforall a. a -> [a] -> [a] :[Event] post) (Event at_1:[Event] pre, []) -> ([Event] pre, [Event at_1]) ([Event], [Event]) a -> ([Event], [Event]) a -- Collect events until one at or after 'end'. ([Event] within, [Event] post2) = forall a rest. (a -> Bool) -> ([a] -> ([a], rest)) -> [a] -> ([a], rest) Then.span ((forall a. Ord a => a -> a -> Bool <TrackTime end) forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> TrackTime Event.start) (forall a. Int -> [a] -> ([a], [a]) splitAt Int 1) [Event] post1 {- | Expect a note track somewhere in the tree. Slice the tracks above and below it to each of its events. The shift of each Event will be subtracted from the track events, so they start at 0. Control tracks caught in the middle are extended one event on either edge of the slice boundary courtesy of the 'slice' function. Note that there will be control events at negative ScoreTime if they lie before the note. Technically the children of the note track don't need to be sliced, since if it is inverting it will do that anyway. But slicing lets me shift fewer events, so it's probably a good idea anyway. -} slice_notes :: Bool -- ^ include a note at the end -> ScoreTime -> ScoreTime -> TrackTree.EventsTree -> [Track] -- ^ One Track per non-empty sub note track, in TrackNum order. slice_notes :: Bool -> TrackTime -> TrackTime -> [EventsNode] -> [Track] slice_notes Bool include_end TrackTime start TrackTime end [EventsNode] tracks | forall (t :: * -> *) a. Foldable t => t a -> Bool null [EventsNode] tracks Bool -> Bool -> Bool || TrackTime start forall a. Ord a => a -> a -> Bool > TrackTime end = [] | Bool otherwise = forall a b. (a -> b) -> [a] -> [b] map (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Maybe TrackId -> [Note] -> Track Track) forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) a. Foldable t => t a -> Bool null forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second (forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe Note -> Maybe Note strip_note) forall b c a. (b -> c) -> (a -> b) -> a -> c . Sliced -> (Maybe TrackId, [Note]) slice_track) forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap EventsNode -> [Sliced] note_tracks [EventsNode] tracks where note_tracks :: TrackTree.EventsNode -> [Sliced] note_tracks :: EventsNode -> [Sliced] note_tracks node :: EventsNode node@(Tree.Node Track track [EventsNode] subs) | Track -> Bool is_note Track track = [([], Track track, Bool -> TrackTime -> TrackTime -> EventsNode -> [(TrackTime, TrackTime, TrackTime)] event_ranges Bool include_end TrackTime start TrackTime end EventsNode node, [EventsNode] subs)] | Bool otherwise = [ (Track track forall a. a -> [a] -> [a] : [Track] parents, Track ntrack, [(TrackTime, TrackTime, TrackTime)] slices, [EventsNode] nsubs) | ([Track] parents, Track ntrack, [(TrackTime, TrackTime, TrackTime)] slices, [EventsNode] nsubs) <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap EventsNode -> [Sliced] note_tracks [EventsNode] subs ] -- For each note track, slice out each event. slice_track :: Sliced -> (Maybe TrackId, [Note]) slice_track :: Sliced -> (Maybe TrackId, [Note]) slice_track ([Track] parents, Track note_track, [(TrackTime, TrackTime, TrackTime)] slices, [EventsNode] subs) = ( Track -> Maybe TrackId TrackTree.track_id Track note_track , forall a b. (a -> b) -> [a] -> [b] map (forall {c}. [EventsNode] -> (Maybe (TrackTime, TrackTime, c), (TrackTime, TrackTime, TrackTime)) -> Note slice1 ([Track] -> [EventsNode] make_tree [Track] parents)) (forall a. [a] -> [(Maybe a, a)] Lists.zipPrev [(TrackTime, TrackTime, TrackTime)] slices) ) where make_tree :: [Track] -> [EventsNode] make_tree (Track p:[Track] ps) = [forall a. a -> [Tree a] -> Tree a Tree.Node Track p ([Track] -> [EventsNode] make_tree [Track] ps)] make_tree [] = [forall a. a -> [Tree a] -> Tree a Tree.Node Track note_track [EventsNode] subs] slice1 :: [EventsNode] -> (Maybe (TrackTime, TrackTime, c), (TrackTime, TrackTime, TrackTime)) -> Note slice1 [EventsNode] tree (Maybe (TrackTime, TrackTime, c) prev, (TrackTime n_start, TrackTime n_end, TrackTime n_next)) = ( TrackTime n_start , TrackTime n_end forall a. Num a => a -> a -> a - TrackTime n_start , forall a b. (a -> b) -> [a] -> [b] map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (TrackTime -> TrackTime -> Track -> Track shift_tree TrackTime n_start TrackTime n_next)) forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (Bool -> TrackTime -> TrackTime -> Maybe InsertEvent -> EventsNode -> EventsNode slice Bool prev_zero TrackTime n_start TrackTime n_end forall a. Maybe a Nothing) [EventsNode] tree ) where -- exclude_start if 's' is still the original 'start', or if the -- previous slice was zero dur and is the same as 'start', which means -- it already consumed any event at 'start'. prev_zero :: Bool prev_zero = case Maybe (TrackTime, TrackTime, c) prev of Maybe (TrackTime, TrackTime, c) Nothing -> Bool False Just (TrackTime s, TrackTime e, c _) -> TrackTime s forall a. Eq a => a -> a -> Bool == TrackTime e Bool -> Bool -> Bool && TrackTime s forall a. Eq a => a -> a -> Bool == TrackTime n_start shift_tree :: TrackTime -> TrackTime -> Track -> Track shift_tree TrackTime shift TrackTime next Track track = Track track { track_events :: Events TrackTree.track_events = (Event -> Event) -> Events -> Events Events.map_events Event -> Event move (Track -> Events TrackTree.track_events Track track) , track_start :: TrackTime TrackTree.track_start = Track -> TrackTime TrackTree.track_start Track track forall a. Num a => a -> a -> a - TrackTime shift , track_end :: TrackTime TrackTree.track_end = TrackTime next forall a. Num a => a -> a -> a - TrackTime shift , track_around :: ([Event], [Event]) TrackTree.track_around = let ([Event] prev, [Event] next) = Track -> ([Event], [Event]) TrackTree.track_around Track track in (forall a b. (a -> b) -> [a] -> [b] map Event -> Event move [Event] prev, forall a b. (a -> b) -> [a] -> [b] map Event -> Event move [Event] next) , track_shifted :: TrackTime TrackTree.track_shifted = Track -> TrackTime TrackTree.track_shifted Track track forall a. Num a => a -> a -> a + TrackTime shift } where move :: Event -> Event move = Lens Event TrackTime Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f %= forall a. Num a => a -> a -> a subtract TrackTime shift -- | (parents, note_track, 'event_ranges', subs) type Sliced = ( [TrackTree.Track] , TrackTree.Track , [(ScoreTime, ScoreTime, ScoreTime)] , TrackTree.EventsTree ) -- | (start, dur, tracks) type Note = (ScoreTime, ScoreTime, [TrackTree.EventsNode]) data Track = Track { Track -> Maybe TrackId _track_id :: Maybe TrackId , Track -> [Note] _notes :: [Note] } deriving (Int -> Track -> ShowS [Track] -> ShowS Track -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Track] -> ShowS $cshowList :: [Track] -> ShowS show :: Track -> String $cshow :: Track -> String showsPrec :: Int -> Track -> ShowS $cshowsPrec :: Int -> Track -> ShowS Show) -- | Get slice ranges for a track. This gets the non-overlapping ranges of all -- the note tracks events below. event_ranges :: Bool -> TrackTime -> TrackTime -> TrackTree.EventsNode -> [(TrackTime, TrackTime, TrackTime)] -- ^ [(start, end, next_start)] event_ranges :: Bool -> TrackTime -> TrackTime -> EventsNode -> [(TrackTime, TrackTime, TrackTime)] event_ranges Bool include_end TrackTime start TrackTime end = forall {a} {c}. Ord a => [(a, a, c)] -> [(a, a, c)] nonoverlapping forall b c a. (b -> c) -> (a -> b) -> a -> c . EventsNode -> [(TrackTime, TrackTime, TrackTime)] to_ranges where to_ranges :: EventsNode -> [(TrackTime, TrackTime, TrackTime)] to_ranges = forall k a. Ord k => (a -> k) -> [[a]] -> [a] Lists.mergeLists (\(TrackTime s, TrackTime _, TrackTime _) -> TrackTime s) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Track -> [(TrackTime, TrackTime, TrackTime)] track_events forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] filter Track -> Bool is_note forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Tree a -> [a] Tree.flatten track_events :: Track -> [(TrackTime, TrackTime, TrackTime)] track_events = forall a b. (a -> b) -> [a] -> [b] map (Event, Maybe Event) -> (TrackTime, TrackTime, TrackTime) range forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> [(a, Maybe a)] Lists.zipNext forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> [Event] Events.ascending forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> TrackTime -> TrackTime -> Events -> Events events_in_range Bool include_end TrackTime start TrackTime end forall b c a. (b -> c) -> (a -> b) -> a -> c . Track -> Events TrackTree.track_events range :: (Event, Maybe Event) -> (TrackTime, TrackTime, TrackTime) range (Event event, Maybe Event next) = ( Event -> TrackTime Event.min Event event, Event -> TrackTime Event.max Event event , forall a. Ord a => a -> a -> a max (Event -> TrackTime Event.max Event event) (forall b a. b -> (a -> b) -> Maybe a -> b maybe TrackTime end Event -> TrackTime Event.min Maybe Event next) ) nonoverlapping :: [(a, a, c)] -> [(a, a, c)] nonoverlapping [] = [] nonoverlapping ((a, a, c) r:[(a, a, c)] rs) = (a, a, c) r forall a. a -> [a] -> [a] : [(a, a, c)] -> [(a, a, c)] nonoverlapping (forall a. (a -> Bool) -> [a] -> [a] dropWhile (forall {a} {a} {c} {c}. (Ord a, Ord a) => (a, a, c) -> (a, a, c) -> Bool overlaps (a, a, c) r) [(a, a, c)] rs) overlaps :: (a, a, c) -> (a, a, c) -> Bool overlaps (a s1, a e1, c _) (a s2, a e2, c _) = Bool -> Bool not forall a b. (a -> b) -> a -> b $ a e1 forall a. Ord a => a -> a -> Bool <= a s2 Bool -> Bool -> Bool || a e2 forall a. Ord a => a -> a -> Bool <= a s1 -- TODO maybe I can remove include_end if I require the next event to be -- negative. events_in_range :: Bool -> TrackTime -> TrackTime -> Events.Events -> Events.Events events_in_range :: Bool -> TrackTime -> TrackTime -> Events -> Events events_in_range Bool include_end TrackTime start TrackTime end Events events | Bool include_end = forall b a. b -> (a -> b) -> Maybe a -> b maybe Events within (\Event e -> [Event] -> Events -> Events Events.insert [Event e] Events within) (TrackTime -> Orientation -> Events -> Maybe Event Events.at TrackTime end Orientation Types.Positive Events post) | Bool otherwise = Events within where (Events _, Events within, Events post) = Range -> Events -> (Events, Events, Events) Events.split_range Range range Events events -- TODO since this is Positive I think it doesn't treat -0 events -- correctly. I could pass Events.Range from the caller. range :: Range range = if TrackTime start forall a. Eq a => a -> a -> Bool == TrackTime end then TrackTime -> Orientation -> Range Events.Point TrackTime start Orientation Types.Positive else TrackTime -> TrackTime -> Range Events.Range TrackTime start TrackTime end -- | Remove empty tracks from the Note tree, and the entire Note if it was all -- empty tracks. strip_note :: Note -> Maybe Note strip_note :: Note -> Maybe Note strip_note (TrackTime start, TrackTime dur, [EventsNode] tree) | forall (t :: * -> *) a. Foldable t => t a -> Bool null [EventsNode] stripped = forall a. Maybe a Nothing | Bool otherwise = forall a. a -> Maybe a Just (TrackTime start, TrackTime dur, [EventsNode] tree) where stripped :: [EventsNode] stripped = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap EventsNode -> [EventsNode] strip_empty_tracks [EventsNode] tree -- | If a branch has no note track children with events, there's no way it can -- produce any events, so it can be dropped before derivation. -- -- The branch has to have no notes from top to bottom, because any note in the -- middle could invert below. strip_empty_tracks :: TrackTree.EventsNode -> [TrackTree.EventsNode] strip_empty_tracks :: EventsNode -> [EventsNode] strip_empty_tracks (Tree.Node Track track [EventsNode] subs) | Bool -> Bool not (Track -> Bool is_note Track track) Bool -> Bool -> Bool || Track -> Bool track_empty Track track = if forall (t :: * -> *) a. Foldable t => t a -> Bool null [EventsNode] stripped then [] else [forall a. a -> [Tree a] -> Tree a Tree.Node Track track [EventsNode] stripped] | Bool otherwise = [forall a. a -> [Tree a] -> Tree a Tree.Node Track track [EventsNode] subs] where stripped :: [EventsNode] stripped = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap EventsNode -> [EventsNode] strip_empty_tracks [EventsNode] subs -- | This is 'slice_notes', but throw an error if 'find_overlapping' complains. -- -- TODO I think I don't want to allow sub-events larger than their slice, but -- currently I do. Actually I think overlap checking needs an overhaul in -- general. checked_slice_notes :: Bool -- ^ TODO change this to Event.Orientation? -> ScoreTime -> ScoreTime -> TrackTree.EventsTree -> Either Text [Track] checked_slice_notes :: Bool -> TrackTime -> TrackTime -> [EventsNode] -> Either Text [Track] checked_slice_notes Bool include_end TrackTime start TrackTime end [EventsNode] tree = case Maybe Text maybe_err of Maybe Text Nothing -> forall a b. b -> Either a b Right [Track] tracks Just Text err -> forall a b. a -> Either a b Left Text err where maybe_err :: Maybe Text maybe_err = if TrackTime start forall a. Eq a => a -> a -> Bool == TrackTime end then TrackTime -> [[EventsNode]] -> Maybe Text check_greater_than TrackTime 0 [[EventsNode]] check_tracks else Bool -> TrackTime -> [[EventsNode]] -> Maybe Text check_overlapping Bool include_end TrackTime 0 [[EventsNode]] check_tracks tracks :: [Track] tracks = Bool -> TrackTime -> TrackTime -> [EventsNode] -> [Track] slice_notes Bool include_end TrackTime start TrackTime end [EventsNode] tree -- Only check the first note of each slice. Since the notes are -- increasing, this is the one which might start before the slice. Since -- the events have been shifted back by the slice start, an event that -- extends over 0 means it overlaps the beginning of the slice. check_tracks :: [[EventsNode]] check_tracks = forall a b. (a -> b) -> [a] -> [b] map (\(TrackTime _, TrackTime _, [EventsNode] subs) -> [EventsNode] subs) forall a b. (a -> b) -> a -> b $ forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe (forall a. [a] -> Maybe a Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c . Track -> [Note] _notes) [Track] tracks check_greater_than :: ScoreTime -> [[TrackTree.EventsNode]] -> Maybe Text check_greater_than :: TrackTime -> [[EventsNode]] -> Maybe Text check_greater_than TrackTime start [[EventsNode]] tracks | forall (t :: * -> *) a. Foldable t => t a -> Bool null [Event] events = forall a. Maybe a Nothing | Bool otherwise = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Text "zero duration slice has note events >" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty TrackTime start forall a. Semigroup a => a -> a -> a <> Text ": " forall a. Semigroup a => a -> a -> a <> Text -> [Text] -> Text Text.intercalate Text ", " (forall a b. (a -> b) -> [a] -> [b] map forall a. Pretty a => a -> Text pretty [Event] events) where events :: [Event] events = forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe (TrackTime -> [EventsNode] -> Maybe Event find_greater_than TrackTime start) [[EventsNode]] tracks find_greater_than :: ScoreTime -> [TrackTree.EventsNode] -> Maybe Event.Event find_greater_than :: TrackTime -> [EventsNode] -> Maybe Event find_greater_than TrackTime start = forall (t :: * -> *) (m :: * -> *) a. (Foldable t, MonadPlus m) => t (m a) -> m a msum forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (forall (t :: * -> *) a b. Foldable t => (a -> Maybe b) -> t a -> Maybe b find (Track -> Maybe Event has_gt forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< Track -> Maybe Track note_track)) where note_track :: Track -> Maybe Track note_track Track track | Track -> Bool is_note Track track = forall a. a -> Maybe a Just Track track | Bool otherwise = forall a. Maybe a Nothing has_gt :: Track -> Maybe Event has_gt = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a List.find ((forall a. Ord a => a -> a -> Bool >TrackTime start) forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> TrackTime Event.start) forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> [Event] Events.ascending forall b c a. (b -> c) -> (a -> b) -> a -> c . Track -> Events TrackTree.track_events check_overlapping :: Bool -> ScoreTime -> [[TrackTree.EventsNode]] -> Maybe Text check_overlapping :: Bool -> TrackTime -> [[EventsNode]] -> Maybe Text check_overlapping Bool include_end TrackTime start [[EventsNode]] tracks | forall (t :: * -> *) a. Foldable t => t a -> Bool null [(Maybe TrackId, (TrackTime, TrackTime))] overlaps = forall a. Maybe a Nothing | Bool otherwise = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Text "slice has overlaps: " forall a. Semigroup a => a -> a -> a <> Text -> [Text] -> Text Text.intercalate Text ", " (forall a b. (a -> b) -> [a] -> [b] map (Maybe TrackId, (TrackTime, TrackTime)) -> Text show_overlap [(Maybe TrackId, (TrackTime, TrackTime))] overlaps) -- TODO 'include_end' is used incorrectly, it becomes 'exclude_start' -- need to fix find_overlapping where overlaps :: [(Maybe TrackId, (TrackTime, TrackTime))] overlaps = forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe (Bool -> TrackTime -> [EventsNode] -> Maybe (Maybe TrackId, (TrackTime, TrackTime)) find_overlapping Bool include_end TrackTime start) [[EventsNode]] tracks {- | Slice overlaps are when an event overlaps the start of the slice range, or extends past the end. They're bad because they tend to cause notes to get doubled. This is because a slice is expanded by larger sub-events, so the events under the overlapping event have likely already be evaluated by the previous slice. From a certain point of view, slices represent nested function calls. An overlapping event would then represent a function that somehow exists in two call branches simultaneously, and there's no way to make sense of that without duplicating the call branches. E.g., visually: > a-b- > c--- > 1-2- The call @c@ overlaps @b@. To make this into a call graph, you have to either omit @c@ even though it looks like it has scope over @2@: > a (c 1) (b 2) Or duplicate it: > a (c 1) (b (c 2)) Duplication is reasonable for some calls, i.e. ones that treat all their sub-events uniformly, but not the rest. Besides, when @a@ slices, @c@ will expand it to include @1@ and @2@, so the actual result is > a (c 1 2) (b ...?) It's ok for a sub-event to be larger than its caller, because there are zero-duration note parents that take non-zero-duration sub-events. This check also requires me to delay stripping out empty tracks until after the check has been done, because otherwise @b@ wouldn't notice that @c@ overlaps. -} find_overlapping :: Bool -> ScoreTime -> [TrackTree.EventsNode] -> Maybe (Maybe TrackId, (TrackTime, TrackTime)) find_overlapping :: Bool -> TrackTime -> [EventsNode] -> Maybe (Maybe TrackId, (TrackTime, TrackTime)) find_overlapping Bool exclude_start TrackTime start = forall (t :: * -> *) (m :: * -> *) a. (Foldable t, MonadPlus m) => t (m a) -> m a msum forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (forall (t :: * -> *) a b. Foldable t => (a -> Maybe b) -> t a -> Maybe b find Track -> Maybe (Maybe TrackId, (TrackTime, TrackTime)) has_overlap) where -- This relies on the 'strip_empty_tracks' having been called. The -- problem is that a zero duration slice after (0, 0) looks like (0, n). -- I want to emit an error if and only if there are events starting at >0 -- in the (0, n) slice. Those events will be evaluated twice if the (0, 0) -- slice also got them. But 'find_overlapping' only looks to see if prev -- events overlap 0, which means it emits an error for both the case with -- no events at >0, and with events >0. Stripping empty tracks eliminates -- the false positive for no events at >0, while leaving the true positive -- for events at >0. -- -- This seems pretty obscure and indirect, and I tried to come up with an -- algorithm that didn't rely on 'strip_empty_tracks', but failed. has_overlap :: Track -> Maybe (Maybe TrackId, (TrackTime, TrackTime)) has_overlap Track track = case Track -> ([Event], [Event]) TrackTree.track_around Track track of (Event prev : [Event] _, [Event] _) | Track -> Bool is_note Track track Bool -> Bool -> Bool && Event -> TrackTime edge Event prev forall a. Ord a => a -> a -> Bool > TrackTime start -> forall a. a -> Maybe a Just (Track -> Maybe TrackId TrackTree.track_id Track track, (TrackTime -> TrackTime shifted (Event -> TrackTime Event.start Event prev), TrackTime -> TrackTime shifted (Event -> TrackTime Event.end Event prev))) ([Event], [Event]) _ -> forall a. Maybe a Nothing where shifted :: TrackTime -> TrackTime shifted = (forall a. Num a => a -> a -> a + Track -> TrackTime TrackTree.track_shifted Track track) -- This works but I don't know why. It's probably wrong, and the whole -- overlap checking strategy probably needs a redo, but it's defeated -- me for the moment so I'm letting it be. edge :: Event -> TrackTime edge = if Bool exclude_start then Event -> TrackTime Event.min else Event -> TrackTime Event.max show_overlap :: (Maybe TrackId, (TrackTime, TrackTime)) -> Text show_overlap :: (Maybe TrackId, (TrackTime, TrackTime)) -> Text show_overlap (Maybe TrackId Nothing, (TrackTime start, TrackTime end)) = forall a. Pretty a => a -> Text pretty TrackTime start forall a. Semigroup a => a -> a -> a <> Text "--" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty TrackTime end show_overlap (Just TrackId track_id, (TrackTime start, TrackTime end)) = forall a. Pretty a => a -> Text pretty forall a b. (a -> b) -> a -> b $ Maybe BlockId -> TrackId -> TrackTime -> TrackTime -> Range Ui.Range forall a. Maybe a Nothing TrackId track_id TrackTime start TrackTime end -- * orphans -- | This is a variant of 'slice' used by note track evaluation to derive -- orphan events. slice_orphans :: Bool -> ScoreTime -> ScoreTime -> [TrackTree.EventsNode] -> Either Text [TrackTree.EventsNode] slice_orphans :: Bool -> TrackTime -> TrackTime -> [EventsNode] -> Either Text [EventsNode] slice_orphans Bool exclude_start TrackTime start TrackTime end [EventsNode] subs = forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall a b. b -> Either a b Right [EventsNode] slices) forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ Bool -> TrackTime -> [[EventsNode]] -> Maybe Text check_overlapping Bool exclude_start TrackTime start [[EventsNode] slices] where slices :: [EventsNode] slices = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap EventsNode -> [EventsNode] strip_empty_tracks forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (Bool -> TrackTime -> TrackTime -> Maybe InsertEvent -> EventsNode -> EventsNode slice Bool exclude_start TrackTime start TrackTime end forall a. Maybe a Nothing) [EventsNode] subs -- * util is_note :: TrackTree.Track -> Bool is_note :: Track -> Bool is_note = Text -> Bool ParseTitle.is_note_track forall b c a. (b -> c) -> (a -> b) -> a -> c . Track -> Text TrackTree.track_title track_empty :: TrackTree.Track -> Bool track_empty :: Track -> Bool track_empty = Events -> Bool Events.null forall b c a. (b -> c) -> (a -> b) -> a -> c . Track -> Events TrackTree.track_events -- | Get the first Just from the structure. find :: Foldable t => (a -> Maybe b) -> t a -> Maybe b find :: forall (t :: * -> *) a b. Foldable t => (a -> Maybe b) -> t a -> Maybe b find a -> Maybe b f = forall a. First a -> Maybe a Monoid.getFirst forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) m a. (Foldable t, Monoid m) => (a -> m) -> t a -> m foldMap (forall a. Maybe a -> First a Monoid.First forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Maybe b f)