-- 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 #-} {- | The 'Events' type contains the events of a track. This is the largest part of the score and also the part most often modified, so there is a plethora of access functions. -} module Ui.Events ( -- * range Range(..) , selection_range, event_range , range_times, range_start, range_end, range_duration -- * events , Events , empty, null, length, time_begin, time_end -- ** list conversion , singleton, from_list , ascending, descending -- ** transformation , map_events, move, clip, clip_list -- ** insert / remove , insert, remove , merge -- ** lookup , at, overlapping, head, last -- ** split -- *** events , split_range, split, split_exclude , in_range , around -- *** List [Event] , split_lists , at_after, after, before, at_before , split_at_before #ifdef TESTING , module Ui.Events #endif ) where import qualified Prelude import Prelude hiding (head, last, length, null) import qualified Control.DeepSeq as DeepSeq import qualified Data.Map as Map import qualified Util.Lists as Lists import qualified Util.Maps as Maps import qualified Util.Pretty as Pretty import qualified Util.Serialize as Serialize import qualified Ui.Event as Event import qualified Ui.Sel as Sel import qualified Ui.Types as Types import Global import Types -- * Range data Range = -- | A range between the given points. It will select a positive event at -- the start time, or a negative one at the end time. Effectively it's -- half-open from the start for Positive events, and half-open from the end -- for Negative ones. -- -- Start should be <= end. Range !TrackTime !TrackTime -- | Select an event at exactly the given time and orientation. | Point !TrackTime !Types.Orientation deriving (Range -> Range -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Range -> Range -> Bool $c/= :: Range -> Range -> Bool == :: Range -> Range -> Bool $c== :: Range -> Range -> Bool Eq, Int -> Range -> ShowS [Range] -> ShowS Range -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Range] -> ShowS $cshowList :: [Range] -> ShowS show :: Range -> String $cshow :: Range -> String showsPrec :: Int -> Range -> ShowS $cshowsPrec :: Int -> Range -> ShowS Show) instance Pretty Range where pretty :: Range -> Text pretty Range r = case Range r of Range TrackTime s TrackTime e -> forall a. Pretty a => a -> Text pretty TrackTime s forall a. Semigroup a => a -> a -> a <> Text "--" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty TrackTime e Point TrackTime p Orientation orient -> Text "@" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty TrackTime p forall a. Semigroup a => a -> a -> a <> (if Orientation orient forall a. Eq a => a -> a -> Bool == Orientation Types.Positive then Text "+" else Text "-") selection_range :: Sel.Selection -> Range selection_range :: Selection -> Range selection_range Selection sel | TrackTime start forall a. Eq a => a -> a -> Bool == TrackTime end = TrackTime -> Orientation -> Range Point TrackTime start forall a b. (a -> b) -> a -> b $ case Selection -> Orientation Sel.orientation Selection sel of Orientation Sel.Positive -> Orientation Types.Positive Orientation Sel.Negative -> Orientation Types.Negative -- The event selection shouldn't be None so this shouldn't happen. Orientation Sel.None -> Orientation Types.Positive | Bool otherwise = TrackTime -> TrackTime -> Range Range TrackTime start TrackTime end where (TrackTime start, TrackTime end) = Selection -> (TrackTime, TrackTime) Sel.range Selection sel event_range :: Event.Event -> Range event_range :: Event -> Range event_range Event event | Event -> TrackTime Event.duration Event event forall a. Eq a => a -> a -> Bool == TrackTime 0 = TrackTime -> Orientation -> Range Point (Event -> TrackTime Event.start Event event) (Event -> Orientation Event.orientation Event event) | Bool otherwise = forall a b c. (a -> b -> c) -> (a, b) -> c uncurry TrackTime -> TrackTime -> Range Range (Event -> (TrackTime, TrackTime) Event.range Event event) range_times :: Range -> (TrackTime, TrackTime) range_times :: Range -> (TrackTime, TrackTime) range_times (Range TrackTime s TrackTime e) = (TrackTime s, TrackTime e) range_times (Point TrackTime s Orientation _) = (TrackTime s, TrackTime s) range_start :: Range -> TrackTime range_start :: Range -> TrackTime range_start = forall a b. (a, b) -> a fst forall b c a. (b -> c) -> (a -> b) -> a -> c . Range -> (TrackTime, TrackTime) range_times range_end :: Range -> TrackTime range_end :: Range -> TrackTime range_end = forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . Range -> (TrackTime, TrackTime) range_times range_duration :: Range -> TrackTime range_duration :: Range -> TrackTime range_duration Range range = TrackTime end forall a. Num a => a -> a -> a - TrackTime start where (TrackTime start, TrackTime end) = Range -> (TrackTime, TrackTime) range_times Range range -- * events -- TODO Probably the ScoreTimes in here should be TrackTime. This module dates -- from before TrackTime existed. empty :: Events empty :: Events empty = EventMap -> Events Events forall k a. Map k a Map.empty null :: Events -> Bool null :: Events -> Bool null (Events EventMap m) = forall k a. Map k a -> Bool Map.null EventMap m length :: Events -> Int length :: Events -> Int length = forall k a. Map k a -> Int Map.size forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> EventMap get time_begin :: Events -> ScoreTime time_begin :: Events -> TrackTime time_begin = forall b a. b -> (a -> b) -> Maybe a -> b maybe TrackTime 0 Event -> TrackTime Event.min forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> Maybe Event head time_end :: Events -> ScoreTime time_end :: Events -> TrackTime time_end = forall b a. b -> (a -> b) -> Maybe a -> b maybe TrackTime 0 Event -> TrackTime Event.max forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> Maybe Event last -- ** list conversion singleton :: Event.Event -> Events singleton :: Event -> Events singleton Event event = EventMap -> Events Events forall a b. (a -> b) -> a -> b $ forall k a. k -> a -> Map k a Map.singleton (Event -> Key event_key Event event) Event event from_list :: [Event.Event] -> Events from_list :: [Event] -> Events from_list [Event] evts = [Event] -> Events -> Events insert [Event] evts Events empty -- | Get all events in ascending order. ascending :: Events -> [Event.Event] ascending :: Events -> [Event] ascending = Events -> [Event] to_asc_list descending :: Events -> [Event.Event] descending :: Events -> [Event] descending = EventMap -> [Event] to_desc_list forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> EventMap get -- ** transformation -- | Map a function across the events in Events. map_events :: (Event.Event -> Event.Event) -> Events -> Events map_events :: (Event -> Event) -> Events -> Events map_events Event -> Event f = [Event] -> Events from_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Event -> Event f forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> [Event] ascending -- | Move events by a constant amount. It's more efficient than 'map_events' -- because it doesn't have to sort and clip the events. move :: ScoreTime -> Events -> Events move :: TrackTime -> Events -> Events move TrackTime delta (Events EventMap events) = EventMap -> Events Events forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Eq k => [(k, a)] -> Map k a Map.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (Key, Event) -> (Key, Event) m forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Map k a -> [(k, a)] Map.toAscList forall a b. (a -> b) -> a -> b $ EventMap events where m :: (Key, Event) -> (Key, Event) m (Key TrackTime t Orientation orient, Event event) = (TrackTime -> Orientation -> Key Key (TrackTime tforall a. Num a => a -> a -> a +TrackTime delta) Orientation orient, Lens Event TrackTime Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f %= (forall a. Num a => a -> a -> a +TrackTime delta) forall a b. (a -> b) -> a -> b $ Event event) -- | Clip off the events after the given end time. Also shorten the last -- event so it doesn't cross the end, if necessary. clip :: Bool -> ScoreTime -> Events -> Events clip :: Bool -> TrackTime -> Events -> Events clip Bool allow_zero TrackTime end = [Event] -> Events from_asc_list forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> TrackTime -> [Event] -> [Event] clip_list Bool allow_zero TrackTime end forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> [Event] to_asc_list -- | Like 'clip', but works on a list. clip_list :: Bool -> ScoreTime -> [Event.Event] -> [Event.Event] clip_list :: Bool -> TrackTime -> [Event] -> [Event] clip_list Bool _ TrackTime _ [] = [] clip_list Bool allow_zero TrackTime end (Event event : [Event] events) | Bool allow_zero Bool -> Bool -> Bool && Event -> TrackTime Event.start Event event forall a. Ord a => a -> a -> Bool > TrackTime end = [] | Event -> Bool Event.is_negative Event event Bool -> Bool -> Bool && Event -> TrackTime Event.start Event event forall a. Ord a => a -> a -> Bool > TrackTime end = [] | Event -> Bool Event.is_positive Event event Bool -> Bool -> Bool && Event -> TrackTime Event.start Event event forall a. Ord a => a -> a -> Bool >= TrackTime end Bool -> Bool -> Bool && Bool -> Bool not Bool allow_zero = [] | Event -> TrackTime Event.end Event event forall a. Ord a => a -> a -> Bool > TrackTime end = [TrackTime -> Event -> Event Event.set_end TrackTime end Event event] | Bool otherwise = Event event forall a. a -> [a] -> [a] : Bool -> TrackTime -> [Event] -> [Event] clip_list Bool allow_zero TrackTime end [Event] events -- ** insert / remove -- | Merge events into the given Events. Events that overlap will have -- their tails clipped until they don't, and given events that start at the -- same place as existing events will replace the existing ones. -- -- This should be the the only way to create a 'Events', short of -- debugging, since it enforces that events don't overlap. insert :: [Event.Event] -> Events -> Events insert :: [Event] -> Events -> Events insert [] Events events = Events events insert [Event] unsorted_events (Events EventMap events) = EventMap -> Events Events forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) k a. (Foldable f, Ord k) => f (Map k a) -> Map k a Map.unions [EventMap pre, Events -> EventMap get Events overlapping, EventMap post] where new_events :: [(Key, Event)] new_events = forall k a. Ord k => (a -> k) -> [a] -> [a] Lists.sortOn forall a b. (a, b) -> a fst forall a b. (a -> b) -> a -> b $ forall a k. (a -> k) -> [a] -> [(k, a)] Lists.keyOn Event -> Key event_key forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map Event -> Event Event.round [Event] unsorted_events start :: TrackTime start = Event -> TrackTime Event.min forall a b. (a -> b) -> a -> b $ forall a b. (a, b) -> b snd forall a b. (a -> b) -> a -> b $ forall a. [a] -> a Prelude.head [(Key, Event)] new_events end :: TrackTime end = Event -> TrackTime Event.max forall a b. (a -> b) -> a -> b $ forall a b. (a, b) -> b snd forall a b. (a -> b) -> a -> b $ forall a. [a] -> a Prelude.last [(Key, Event)] new_events (EventMap pre, EventMap within, EventMap post) = TrackTime -> TrackTime -> EventMap -> (EventMap, EventMap, EventMap) _split_overlapping TrackTime start TrackTime end EventMap events overlapping :: Events overlapping = [(Key, Event)] -> [(Key, Event)] -> Events merge_and_clip (forall k a. Map k a -> [(k, a)] Map.toAscList EventMap within) [(Key, Event)] new_events -- | Remove events in the range. remove :: Range -> Events -> Events remove :: Range -> Events -> Events remove (Point TrackTime t Orientation orient) Events events = (EventMap -> EventMap) -> Events -> Events emap (forall k a. Ord k => k -> Map k a -> Map k a Map.delete (TrackTime -> Orientation -> Key Key TrackTime t Orientation orient)) Events events remove Range range Events events = (EventMap -> EventMap) -> Events -> Events emap (forall k a b. Ord k => Map k a -> Map k b -> Map k a `Map.difference` EventMap within) Events events where (Events _, Events EventMap within, Events _) = Range -> Events -> (Events, Events, Events) split_range Range range Events events -- ** lookup -- | An event exactly at the given pos, or Nothing. -- TODO this is just in_range (Point ...), merge them? at :: ScoreTime -> Types.Orientation -> Events -> Maybe Event.Event at :: TrackTime -> Orientation -> Events -> Maybe Event at TrackTime pos Orientation orient = forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup (TrackTime -> Orientation -> Key Key TrackTime pos Orientation orient) forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> EventMap get -- | Like 'at', but return an event that overlaps the given pos. overlapping :: ScoreTime -> Events -> Maybe Event.Event overlapping :: TrackTime -> Events -> Maybe Event overlapping TrackTime pos Events events | Event next : [Event] _ <- [Event] post, Event -> TrackTime Event.start Event next forall a. Eq a => a -> a -> Bool == TrackTime pos Bool -> Bool -> Bool || Event -> TrackTime Event.end Event next forall a. Ord a => a -> a -> Bool < TrackTime pos = forall a. a -> Maybe a Just Event next | Event prev : [Event] _ <- [Event] pre, Event -> TrackTime Event.end Event prev forall a. Ord a => a -> a -> Bool > TrackTime pos = forall a. a -> Maybe a Just Event prev | Bool otherwise = forall a. Maybe a Nothing where ([Event] pre, [Event] post) = forall (p :: * -> * -> *) a b c d. Bifunctor p => (a -> b) -> (c -> d) -> p a c -> p b d bimap Events -> [Event] descending Events -> [Event] ascending forall a b. (a -> b) -> a -> b $ TrackTime -> Events -> (Events, Events) split TrackTime pos Events events head :: Events -> Maybe Event.Event head :: Events -> Maybe Event head (Events EventMap events) = forall a b. (a, b) -> b snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall k a. Map k a -> Maybe (k, a) Map.lookupMin EventMap events -- | Final event, if there is one. last :: Events -> Maybe Event.Event last :: Events -> Maybe Event last (Events EventMap events) = forall a b. (a, b) -> b snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall k a. Map k a -> Maybe (k, a) Map.lookupMax EventMap events -- ** split -- *** events split_range :: Range -> Events -> (Events, Events, Events) split_range :: Range -> Events -> (Events, Events, Events) split_range (Point TrackTime t Orientation orient) (Events EventMap events) = (EventMap -> Events Events EventMap pre, forall b a. b -> (a -> b) -> Maybe a -> b maybe forall a. Monoid a => a mempty Event -> Events singleton Maybe Event at, EventMap -> Events Events EventMap post) where (EventMap pre, Maybe Event at, EventMap post) = forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a) Map.splitLookup (TrackTime -> Orientation -> Key Key TrackTime t Orientation orient) EventMap events split_range (Range TrackTime start TrackTime end) (Events EventMap events) = (EventMap -> Events Events EventMap pre, EventMap -> Events Events EventMap within, EventMap -> Events Events EventMap post) where (EventMap pre, EventMap within, EventMap post) = forall k a. Ord k => k -> k -> Map k a -> (Map k a, Map k a, Map k a) Maps.split3 (TrackTime -> Orientation -> Key Key TrackTime start Orientation Types.Positive) (TrackTime -> Orientation -> Key Key TrackTime end Orientation Types.Positive) EventMap events -- | Split at the given time. A positive event that starts at the given time -- will appear in the after events, a negative event in the previous events. split :: ScoreTime -> Events -> (Events, Events) split :: TrackTime -> Events -> (Events, Events) split TrackTime pos (Events EventMap events) = (EventMap -> Events Events EventMap pre, EventMap -> Events Events EventMap post) where (EventMap pre, EventMap post) = forall k a. Ord k => k -> Map k a -> (Map k a, Map k a) Maps.split2 (TrackTime -> Orientation -> Key Key TrackTime pos Orientation Types.Positive) EventMap events -- | Like 'split', but a positive event that matches exactly is excluded from -- the result. split_exclude :: ScoreTime -> Events -> (Events, Events) split_exclude :: TrackTime -> Events -> (Events, Events) split_exclude TrackTime pos (Events EventMap events) = (EventMap -> Events Events (forall k a. Ord k => k -> Map k a -> Map k a Map.delete (TrackTime -> Orientation -> Key Key TrackTime pos Orientation Types.Negative) EventMap pre), EventMap -> Events Events EventMap post) where (EventMap pre, EventMap post) = forall k a. Ord k => k -> Map k a -> (Map k a, Map k a) Map.split (TrackTime -> Orientation -> Key Key TrackTime pos Orientation Types.Positive) EventMap events -- | Like 'split_range', but only return the middle part. in_range :: Range -> Events -> Events in_range :: Range -> Events -> Events in_range Range range Events events = Events within where (Events _, Events within, Events _) = Range -> Events -> (Events, Events, Events) split_range Range range Events events -- | Get events in the given range, plus surrounding. If there is no event at -- @start@, the previous event will be included. The event after @end@ is -- always included. around :: ScoreTime -> ScoreTime -> Events -> Events around :: TrackTime -> TrackTime -> Events -> Events around TrackTime start TrackTime end Events events = EventMap -> Events Events forall a b. (a -> b) -> a -> b $ EventMap -> EventMap above forall a b. (a -> b) -> a -> b $ EventMap -> EventMap below EventMap within where (Events EventMap pre, Events EventMap within, Events EventMap post) = Range -> Events -> (Events, Events, Events) split_range (TrackTime -> TrackTime -> Range Range TrackTime start TrackTime end) Events events below :: EventMap -> EventMap below EventMap m | Just (Key TrackTime lowest Orientation _, Event _) <- forall k a. Map k a -> Maybe (k, a) Map.lookupMin EventMap within, TrackTime lowest forall a. Eq a => a -> a -> Bool == TrackTime start = EventMap m | Bool otherwise = forall b a. b -> (a -> b) -> Maybe a -> b maybe EventMap m (\(Key k, Event e) -> forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert Key k Event e EventMap m) (forall k a. Map k a -> Maybe (k, a) Map.lookupMax EventMap pre) above :: EventMap -> EventMap above EventMap m = forall b a. b -> (a -> b) -> Maybe a -> b maybe EventMap m (\(Key k, Event e) -> forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert Key k Event e EventMap m) (forall k a. Map k a -> Maybe (k, a) Map.lookupMin EventMap post) -- *** List [Event] split_lists :: ScoreTime -> Events -> ([Event.Event], [Event.Event]) split_lists :: TrackTime -> Events -> ([Event], [Event]) split_lists TrackTime pos = forall (p :: * -> * -> *) a b c d. Bifunctor p => (a -> b) -> (c -> d) -> p a c -> p b d bimap Events -> [Event] descending Events -> [Event] ascending forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackTime -> Events -> (Events, Events) split TrackTime pos -- | Events with start >= @pos@. at_after :: ScoreTime -> Events -> [Event.Event] at_after :: TrackTime -> Events -> [Event] at_after TrackTime pos = forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackTime -> Events -> ([Event], [Event]) split_lists TrackTime pos -- | Events with start > @pos@. after :: ScoreTime -> Events -> [Event.Event] after :: TrackTime -> Events -> [Event] after TrackTime pos Events events = case TrackTime -> Events -> [Event] at_after TrackTime pos Events events of Event next : [Event] rest | Event -> TrackTime Event.start Event next forall a. Eq a => a -> a -> Bool == TrackTime pos -> [Event] rest [Event] events -> [Event] events -- | Events with start < @pos@. before :: ScoreTime -> Events -> [Event.Event] before :: TrackTime -> Events -> [Event] before TrackTime pos = forall a b. (a, b) -> a fst forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackTime -> Events -> ([Event], [Event]) split_lists TrackTime pos -- | Events with start <= @pos@. at_before :: ScoreTime -> Events -> [Event.Event] at_before :: TrackTime -> Events -> [Event] at_before TrackTime pos Events events | Event next : [Event] _ <- [Event] post, Event -> TrackTime Event.start Event next forall a. Eq a => a -> a -> Bool == TrackTime pos = Event next forall a. a -> [a] -> [a] : [Event] pre | Bool otherwise = [Event] pre where ([Event] pre, [Event] post) = TrackTime -> Events -> ([Event], [Event]) split_lists TrackTime pos Events events -- | This is like 'split', but if there isn't an event exactly at the pos then -- put the previous one in the post list. split_at_before :: ScoreTime -> Events -> ([Event.Event], [Event.Event]) split_at_before :: TrackTime -> Events -> ([Event], [Event]) split_at_before TrackTime pos Events events | Event next : [Event] _ <- [Event] post, Event -> TrackTime Event.start Event next forall a. Eq a => a -> a -> Bool == TrackTime pos = ([Event] pre, [Event] post) | Event before : [Event] prepre <- [Event] pre = ([Event] prepre, Event before forall a. a -> [a] -> [a] : [Event] post) | Bool otherwise = ([Event] pre, [Event] post) where ([Event] pre, [Event] post) = TrackTime -> Events -> ([Event], [Event]) split_lists TrackTime pos Events events -- * implementation -- | This is the underlying storage for a sequence of events. The invariant -- is that events start + duration don't overlap. -- -- This type should remain abstract, and you should manipulate events using -- functions in this module. newtype Events = Events EventMap deriving (Events -> () forall a. (a -> ()) -> NFData a rnf :: Events -> () $crnf :: Events -> () DeepSeq.NFData, Events -> Events -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Events -> Events -> Bool $c/= :: Events -> Events -> Bool == :: Events -> Events -> Bool $c== :: Events -> Events -> Bool Eq, Int -> Events -> ShowS [Events] -> ShowS Events -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Events] -> ShowS $cshowList :: [Events] -> ShowS show :: Events -> String $cshow :: Events -> String showsPrec :: Int -> Events -> ShowS $cshowsPrec :: Int -> Events -> ShowS Show) type EventMap = Map Key Event.Event -- | This determines event order, and which events can coexist. -- -- Technically, since 'Event.start' is in here, it doesn't have to be in -- 'Event.Event'. I used to have them separate, but it was a pain to pass -- (ScoreTime, Event) pairs around everywhere. data Key = Key !TrackTime !Types.Orientation deriving (Key -> Key -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Key -> Key -> Bool $c/= :: Key -> Key -> Bool == :: Key -> Key -> Bool $c== :: Key -> Key -> Bool Eq, Eq Key Key -> Key -> Bool Key -> Key -> Ordering Key -> Key -> Key forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: Key -> Key -> Key $cmin :: Key -> Key -> Key max :: Key -> Key -> Key $cmax :: Key -> Key -> Key >= :: Key -> Key -> Bool $c>= :: Key -> Key -> Bool > :: Key -> Key -> Bool $c> :: Key -> Key -> Bool <= :: Key -> Key -> Bool $c<= :: Key -> Key -> Bool < :: Key -> Key -> Bool $c< :: Key -> Key -> Bool compare :: Key -> Key -> Ordering $ccompare :: Key -> Key -> Ordering Ord, Int -> Key -> ShowS [Key] -> ShowS Key -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Key] -> ShowS $cshowList :: [Key] -> ShowS show :: Key -> String $cshow :: Key -> String showsPrec :: Int -> Key -> ShowS $cshowsPrec :: Int -> Key -> ShowS Show) instance DeepSeq.NFData Key where rnf :: Key -> () rnf Key _ = () instance Pretty Key where pretty :: Key -> Text pretty (Key TrackTime t Orientation o) = forall a. Pretty a => a -> Text pretty TrackTime t forall a. Semigroup a => a -> a -> a <> case Orientation o of Orientation Types.Negative -> Text "-" Orientation Types.Positive -> Text "+" event_key :: Event.Event -> Key event_key :: Event -> Key event_key Event event = TrackTime -> Orientation -> Key Key (Event -> TrackTime Event.start Event event) (Event -> Orientation Event.orientation Event event) -- | This assumes the input is already sorted! from_asc_list :: [Event.Event] -> Events from_asc_list :: [Event] -> Events from_asc_list = EventMap -> Events Events forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Eq k => [(k, a)] -> Map k a Map.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a k. (a -> k) -> [a] -> [(k, a)] Lists.keyOn Event -> Key event_key to_asc_list :: Events -> [Event.Event] to_asc_list :: Events -> [Event] to_asc_list = forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Map k a -> [(k, a)] Map.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> EventMap get to_desc_list :: EventMap -> [Event.Event] to_desc_list :: EventMap -> [Event] to_desc_list = forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Map k a -> [(k, a)] Map.toDescList instance Pretty Events where format :: Events -> Doc format = forall a. Pretty a => a -> Doc Pretty.format forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Event -> Doc event forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> [Event] ascending where event :: Event -> Doc event Event e = Text -> Doc Pretty.text forall a b. (a -> b) -> a -> b $ forall a. Pretty a => a -> Text pretty (Event -> TrackTime Event.start Event e, Event -> TrackTime Event.duration Event e, Event -> Text Event.text Event e) instance Semigroup Events where <> :: Events -> Events -> Events (<>) = Events -> Events -> Events merge instance Monoid Events where mempty :: Events mempty = Events empty mappend :: Events -> Events -> Events mappend = forall a. Semigroup a => a -> a -> a (<>) get :: Events -> EventMap get :: Events -> EventMap get (Events EventMap evts) = EventMap evts emap :: (EventMap -> EventMap) -> Events -> Events emap :: (EventMap -> EventMap) -> Events -> Events emap EventMap -> EventMap f (Events EventMap evts) = EventMap -> Events Events (EventMap -> EventMap f EventMap evts) -- | Put events that overlap the range into within. _split_overlapping :: ScoreTime -> ScoreTime -> EventMap -> (EventMap, EventMap, EventMap) _split_overlapping :: TrackTime -> TrackTime -> EventMap -> (EventMap, EventMap, EventMap) _split_overlapping TrackTime start TrackTime end EventMap events = (EventMap pre2, EventMap within3, EventMap post2) where (Events EventMap pre, Events EventMap within, Events EventMap post) = Range -> Events -> (Events, Events, Events) split_range (TrackTime -> TrackTime -> Range Range TrackTime start TrackTime end) (EventMap -> Events Events EventMap events) (EventMap pre2, EventMap within2) = case forall k a. Map k a -> Maybe (k, a) Map.lookupMax EventMap pre of Just (Key k, Event e) | TrackTime -> Event -> Bool Event.overlaps TrackTime start Event e -> (forall k a. Ord k => k -> Map k a -> Map k a Map.delete Key k EventMap pre, forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert Key k Event e EventMap within) Maybe (Key, Event) _ -> (EventMap pre, EventMap within) (EventMap post2, EventMap within3) = case forall k a. Map k a -> Maybe (k, a) Map.lookupMin EventMap post of Just (Key k, Event e) | TrackTime -> Event -> Bool Event.overlaps TrackTime end Event e -> (forall k a. Ord k => k -> Map k a -> Map k a Map.delete Key k EventMap post, forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert Key k Event e EventMap within2) Maybe (Key, Event) _ -> (EventMap post, EventMap within2) {- | Merge @evts2@ into @evts1@. Events that overlap other events will be clipped so they don't overlap. If events occur simultaneously, the event from @evts1@ wins. -} merge :: Events -> Events -> Events merge :: Events -> Events -> Events merge (Events EventMap evts1) (Events EventMap evts2) | forall k a. Map k a -> Bool Map.null EventMap evts1 = EventMap -> Events Events EventMap evts2 | forall k a. Map k a -> Bool Map.null EventMap evts2 = EventMap -> Events Events EventMap evts1 | Bool otherwise = [(Key, Event)] -> [(Key, Event)] -> Events merge_and_clip (forall k a. Map k a -> [(k, a)] Map.toAscList EventMap evts2) (forall k a. Map k a -> [(k, a)] Map.toAscList EventMap evts1) -- Previously I would extract the overlapping sections and clip only those, -- but I moved that to 'insert'. Perhaps it's a bit more elegant here, but -- I think I'm never really merging large Events, just inserting small -- lists into a large EventMap. And in any case, EventMaps never get very -- big. Also, putting it in 'insert' avoids having to clip_events an extra -- time to create the new Events. merge_and_clip :: [(Key, Event.Event)] -> [(Key, Event.Event)] -> Events merge_and_clip :: [(Key, Event)] -> [(Key, Event)] -> Events merge_and_clip [(Key, Event)] old [(Key, Event)] new = [Event] -> Events from_asc_list forall a b. (a -> b) -> a -> b $ [Event] -> [Event] clip_events forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> b snd forall a b. (a -> b) -> a -> b $ forall k a. Ord k => (a -> k) -> [a] -> [a] -> [a] Lists.mergeOn forall a b. (a, b) -> a fst (forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first (,Bool False)) [(Key, Event)] old) (forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first (,Bool True)) [(Key, Event)] new) -- Lists.mergeOn should put elements from the first argument first, but -- it doesn't guarantee it, so let's be explicit. {- | Clip overlapping event durations. An event with duration overlapping another event will be clipped. Positive events are clipped by following events, and negative ones are clipped by previous ones. In the event of a conflict between positive and negative, they are both clipped to the middle of the overlap. This may seem a bit weird, but it has the nice properties that I never clip an event to 0, and never have to drop an event due to clipping. From an implementation point of view, it lets me write a single-pass algorithm. If there are multiple events with the same start and orientation, the last one wins. The precondition is that the input events are sorted by 'event_key', the postcondition is that they are still sorted and no [pos .. pos+dur) ranges will overlap. -} clip_events :: [Event.Event] -> [Event.Event] clip_events :: [Event] -> [Event] clip_events = forall a b. (a -> b) -> [a] -> [b] map (Maybe Event, Event, Maybe Event) -> Event clip forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> [(Maybe a, a, Maybe a)] Lists.zipNeighbors forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Eq k => (a -> k) -> [a] -> [a] Lists.dropInitialDups (\Event e -> (Event -> TrackTime Event.start Event e, Event -> Orientation Event.orientation Event e)) where clip :: (Maybe Event, Event, Maybe Event) -> Event clip (Maybe Event maybe_prev, Event cur, Maybe Event maybe_next) | Event -> Bool Event.is_negative Event cur = case Maybe Event maybe_prev of Maybe Event Nothing -> Event cur Just Event prev -- prev |---> -- cur <---| | Event -> Bool Event.is_positive Event prev -> if Event -> TrackTime Event.end Event cur forall a. Ord a => a -> a -> Bool < Event -> TrackTime Event.end Event prev then Lens Event TrackTime Event.end_ forall f a. Lens f a -> a -> f -> f #= Event -> Event -> TrackTime midpoint Event prev Event cur forall a b. (a -> b) -> a -> b $ Event cur else Event cur -- prev <---| -- cur <---| | Event -> TrackTime Event.start Event prev forall a. Ord a => a -> a -> Bool > Event -> TrackTime Event.end Event cur -> Lens Event TrackTime Event.end_ forall f a. Lens f a -> a -> f -> f #= Event -> TrackTime Event.start Event prev forall a b. (a -> b) -> a -> b $ Event cur | Bool otherwise -> Event cur | Bool otherwise = case Maybe Event maybe_next of Maybe Event Nothing -> Event cur Just Event next -- cur |---> -- next <---| | Event -> Bool Event.is_negative Event next -> if Event -> TrackTime Event.end Event next forall a. Ord a => a -> a -> Bool < Event -> TrackTime Event.end Event cur then Lens Event TrackTime Event.end_ forall f a. Lens f a -> a -> f -> f #= Event -> Event -> TrackTime midpoint Event cur Event next forall a b. (a -> b) -> a -> b $ Event cur else Event cur -- cur |---> -- next |---> | Event -> TrackTime Event.start Event next forall a. Ord a => a -> a -> Bool < Event -> TrackTime Event.end Event cur -> Lens Event TrackTime Event.end_ forall f a. Lens f a -> a -> f -> f #= Event -> TrackTime Event.start Event next forall a b. (a -> b) -> a -> b $ Event cur | Bool otherwise -> Event cur midpoint :: Event -> Event -> TrackTime midpoint Event pos Event neg = (forall a. Ord a => a -> a -> a max (Event -> TrackTime Event.start Event pos) (Event -> TrackTime Event.end Event neg) forall a. Num a => a -> a -> a + forall a. Ord a => a -> a -> a min (Event -> TrackTime Event.end Event pos) (Event -> TrackTime Event.start Event neg)) forall a. Fractional a => a -> a -> a / TrackTime 2 -- * serialize instance Serialize.Serialize Events where put :: Putter Events put (Events EventMap a) = Word8 -> PutM () Serialize.put_version Word8 4 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> forall a. Serialize a => Putter a Serialize.put EventMap a get :: Get Events get = do Word8 v <- Get Word8 Serialize.get_version case Word8 v of Word8 3 -> do Map TrackTime Event events :: Map ScoreTime Event.Event <- forall a. Serialize a => Get a Serialize.get forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ [Event] -> Events from_asc_list forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [a] Map.elems Map TrackTime Event events Word8 4 -> do EventMap events :: Map Key Event.Event <- forall a. Serialize a => Get a Serialize.get forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ EventMap -> Events Events EventMap events Word8 _ -> forall a. Stack => String -> Word8 -> a Serialize.bad_version String "Events" Word8 v -- Key has no version because there are a lot of them and they're all the same -- and Events has a version. instance Serialize.Serialize Key where put :: Putter Key put (Key TrackTime a Orientation b) = forall a. Serialize a => Putter a Serialize.put TrackTime a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> forall a. Serialize a => Putter a Serialize.put Orientation b get :: Get Key get = TrackTime -> Orientation -> Key Key forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Serialize a => Get a Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall a. Serialize a => Get a Serialize.get