-- 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.Maps as Maps
import qualified Util.Pretty as Pretty
import qualified Util.Seq as Seq
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
(Range -> Range -> Bool) -> (Range -> Range -> Bool) -> Eq Range
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
(Int -> Range -> ShowS)
-> (Range -> String) -> ([Range] -> ShowS) -> Show Range
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 -> TrackTime -> Text
forall a. Pretty a => a -> Text
pretty TrackTime
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackTime -> Text
forall a. Pretty a => a -> Text
pretty TrackTime
e
        Point TrackTime
p Orientation
orient ->
            Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackTime -> Text
forall a. Pretty a => a -> Text
pretty TrackTime
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Orientation
orient Orientation -> Orientation -> Bool
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 TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
end = TrackTime -> Orientation -> Range
Point TrackTime
start (Orientation -> Range) -> Orientation -> Range
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 TrackTime -> TrackTime -> Bool
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 = (TrackTime -> TrackTime -> Range)
-> (TrackTime, TrackTime) -> Range
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 = (TrackTime, TrackTime) -> TrackTime
forall a b. (a, b) -> a
fst ((TrackTime, TrackTime) -> TrackTime)
-> (Range -> (TrackTime, TrackTime)) -> Range -> TrackTime
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 = (TrackTime, TrackTime) -> TrackTime
forall a b. (a, b) -> b
snd ((TrackTime, TrackTime) -> TrackTime)
-> (Range -> (TrackTime, TrackTime)) -> Range -> TrackTime
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 TrackTime -> TrackTime -> TrackTime
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 EventMap
forall k a. Map k a
Map.empty

null :: Events -> Bool
null :: Events -> Bool
null (Events EventMap
m) = EventMap -> Bool
forall k a. Map k a -> Bool
Map.null EventMap
m

length :: Events -> Int
length :: Events -> Int
length = EventMap -> Int
forall k a. Map k a -> Int
Map.size (EventMap -> Int) -> (Events -> EventMap) -> Events -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> EventMap
get

time_begin :: Events -> ScoreTime
time_begin :: Events -> TrackTime
time_begin = TrackTime -> (Event -> TrackTime) -> Maybe Event -> TrackTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TrackTime
0 Event -> TrackTime
Event.min (Maybe Event -> TrackTime)
-> (Events -> Maybe Event) -> Events -> TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> Maybe Event
head

time_end :: Events -> ScoreTime
time_end :: Events -> TrackTime
time_end = TrackTime -> (Event -> TrackTime) -> Maybe Event -> TrackTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TrackTime
0 Event -> TrackTime
Event.max (Maybe Event -> TrackTime)
-> (Events -> Maybe Event) -> Events -> TrackTime
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 (EventMap -> Events) -> EventMap -> Events
forall a b. (a -> b) -> a -> b
$ Key -> Event -> EventMap
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 (EventMap -> [Event]) -> (Events -> EventMap) -> Events -> [Event]
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 ([Event] -> Events) -> (Events -> [Event]) -> Events -> Events
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
f ([Event] -> [Event]) -> (Events -> [Event]) -> Events -> [Event]
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 (EventMap -> Events)
-> (EventMap -> EventMap) -> EventMap -> Events
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Event)] -> EventMap
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([(Key, Event)] -> EventMap)
-> (EventMap -> [(Key, Event)]) -> EventMap -> EventMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Event) -> (Key, Event)) -> [(Key, Event)] -> [(Key, Event)]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Event) -> (Key, Event)
m ([(Key, Event)] -> [(Key, Event)])
-> (EventMap -> [(Key, Event)]) -> EventMap -> [(Key, Event)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventMap -> [(Key, Event)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (EventMap -> Events) -> EventMap -> Events
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
tTrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
+TrackTime
delta) Orientation
orient, Lens Event TrackTime
Event.start_ Lens Event TrackTime -> (TrackTime -> TrackTime) -> Event -> Event
forall f a. Lens f a -> (a -> a) -> f -> f
%= (TrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
+TrackTime
delta) (Event -> Event) -> Event -> Event
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 ([Event] -> Events) -> (Events -> [Event]) -> Events -> Events
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> TrackTime -> [Event] -> [Event]
clip_list Bool
allow_zero TrackTime
end ([Event] -> [Event]) -> (Events -> [Event]) -> Events -> [Event]
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 TrackTime -> TrackTime -> Bool
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 TrackTime -> TrackTime -> Bool
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 TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
>= TrackTime
end Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
allow_zero = []
    | Event -> TrackTime
Event.end Event
event TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
> TrackTime
end = [TrackTime -> Event -> Event
Event.set_end TrackTime
end Event
event]
    | Bool
otherwise = Event
event Event -> [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 (EventMap -> Events) -> EventMap -> Events
forall a b. (a -> b) -> a -> b
$ [EventMap] -> EventMap
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 = ((Key, Event) -> Key) -> [(Key, Event)] -> [(Key, Event)]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on (Key, Event) -> Key
forall a b. (a, b) -> a
fst ([(Key, Event)] -> [(Key, Event)])
-> [(Key, Event)] -> [(Key, Event)]
forall a b. (a -> b) -> a -> b
$ (Event -> Key) -> [Event] -> [(Key, Event)]
forall a k. (a -> k) -> [a] -> [(k, a)]
Seq.key_on Event -> Key
event_key ([Event] -> [(Key, Event)]) -> [Event] -> [(Key, Event)]
forall a b. (a -> b) -> a -> b
$
        (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
Event.round [Event]
unsorted_events
    start :: TrackTime
start = Event -> TrackTime
Event.min (Event -> TrackTime) -> Event -> TrackTime
forall a b. (a -> b) -> a -> b
$ (Key, Event) -> Event
forall a b. (a, b) -> b
snd ((Key, Event) -> Event) -> (Key, Event) -> Event
forall a b. (a -> b) -> a -> b
$ [(Key, Event)] -> (Key, Event)
forall a. [a] -> a
Prelude.head [(Key, Event)]
new_events
    end :: TrackTime
end = Event -> TrackTime
Event.max (Event -> TrackTime) -> Event -> TrackTime
forall a b. (a -> b) -> a -> b
$ (Key, Event) -> Event
forall a b. (a, b) -> b
snd ((Key, Event) -> Event) -> (Key, Event) -> Event
forall a b. (a -> b) -> a -> b
$ [(Key, Event)] -> (Key, Event)
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 (EventMap -> [(Key, Event)]
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 (Key -> EventMap -> EventMap
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 (EventMap -> EventMap -> EventMap
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 = Key -> EventMap -> Maybe Event
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TrackTime -> Orientation -> Key
Key TrackTime
pos Orientation
orient) (EventMap -> Maybe Event)
-> (Events -> EventMap) -> Events -> Maybe Event
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 TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
pos Bool -> Bool -> Bool
|| Event -> TrackTime
Event.end Event
next TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
< TrackTime
pos =
        Event -> Maybe Event
forall a. a -> Maybe a
Just Event
next
    | Event
prev : [Event]
_ <- [Event]
pre, Event -> TrackTime
Event.end Event
prev TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
> TrackTime
pos = Event -> Maybe Event
forall a. a -> Maybe a
Just Event
prev
    | Bool
otherwise = Maybe Event
forall a. Maybe a
Nothing
    where ([Event]
pre, [Event]
post) = (Events -> [Event])
-> (Events -> [Event]) -> (Events, Events) -> ([Event], [Event])
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 ((Events, Events) -> ([Event], [Event]))
-> (Events, Events) -> ([Event], [Event])
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) = (Key, Event) -> Event
forall a b. (a, b) -> b
snd ((Key, Event) -> Event) -> Maybe (Key, Event) -> Maybe Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventMap -> Maybe (Key, Event)
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) = (Key, Event) -> Event
forall a b. (a, b) -> b
snd ((Key, Event) -> Event) -> Maybe (Key, Event) -> Maybe Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventMap -> Maybe (Key, Event)
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, Events -> (Event -> Events) -> Maybe Event -> Events
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Events
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) = Key -> EventMap -> (EventMap, Maybe Event, EventMap)
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) =
        Key -> Key -> EventMap -> (EventMap, EventMap, EventMap)
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) = Key -> EventMap -> (EventMap, EventMap)
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 (Key -> EventMap -> EventMap
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) = Key -> EventMap -> (EventMap, EventMap)
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 (EventMap -> Events) -> EventMap -> Events
forall a b. (a -> b) -> a -> b
$ EventMap -> EventMap
above (EventMap -> EventMap) -> EventMap -> EventMap
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
_) <- EventMap -> Maybe (Key, Event)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMin EventMap
within, TrackTime
lowest TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
start = EventMap
m
        | Bool
otherwise = EventMap
-> ((Key, Event) -> EventMap) -> Maybe (Key, Event) -> EventMap
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EventMap
m (\(Key
k, Event
e) -> Key -> Event -> EventMap -> EventMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Key
k Event
e EventMap
m) (EventMap -> Maybe (Key, Event)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax EventMap
pre)
    above :: EventMap -> EventMap
above EventMap
m = EventMap
-> ((Key, Event) -> EventMap) -> Maybe (Key, Event) -> EventMap
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EventMap
m (\(Key
k, Event
e) -> Key -> Event -> EventMap -> EventMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Key
k Event
e EventMap
m) (EventMap -> Maybe (Key, Event)
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 = (Events -> [Event])
-> (Events -> [Event]) -> (Events, Events) -> ([Event], [Event])
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 ((Events, Events) -> ([Event], [Event]))
-> (Events -> (Events, Events)) -> Events -> ([Event], [Event])
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 = ([Event], [Event]) -> [Event]
forall a b. (a, b) -> b
snd (([Event], [Event]) -> [Event])
-> (Events -> ([Event], [Event])) -> Events -> [Event]
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 TrackTime -> TrackTime -> Bool
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 = ([Event], [Event]) -> [Event]
forall a b. (a, b) -> a
fst (([Event], [Event]) -> [Event])
-> (Events -> ([Event], [Event])) -> Events -> [Event]
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 TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
pos = Event
next Event -> [Event] -> [Event]
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 TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
pos = ([Event]
pre, [Event]
post)
    | Event
before : [Event]
prepre <- [Event]
pre = ([Event]
prepre, Event
before Event -> [Event] -> [Event]
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 -> ()
(Events -> ()) -> NFData Events
forall a. (a -> ()) -> NFData a
rnf :: Events -> ()
$crnf :: Events -> ()
DeepSeq.NFData, Events -> Events -> Bool
(Events -> Events -> Bool)
-> (Events -> Events -> Bool) -> Eq Events
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
(Int -> Events -> ShowS)
-> (Events -> String) -> ([Events] -> ShowS) -> Show Events
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, ReadPrec [Events]
ReadPrec Events
Int -> ReadS Events
ReadS [Events]
(Int -> ReadS Events)
-> ReadS [Events]
-> ReadPrec Events
-> ReadPrec [Events]
-> Read Events
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Events]
$creadListPrec :: ReadPrec [Events]
readPrec :: ReadPrec Events
$creadPrec :: ReadPrec Events
readList :: ReadS [Events]
$creadList :: ReadS [Events]
readsPrec :: Int -> ReadS Events
$creadsPrec :: Int -> ReadS Events
Read)

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
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
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
Eq Key
-> (Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord 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
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
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, ReadPrec [Key]
ReadPrec Key
Int -> ReadS Key
ReadS [Key]
(Int -> ReadS Key)
-> ReadS [Key] -> ReadPrec Key -> ReadPrec [Key] -> Read Key
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Key]
$creadListPrec :: ReadPrec [Key]
readPrec :: ReadPrec Key
$creadPrec :: ReadPrec Key
readList :: ReadS [Key]
$creadList :: ReadS [Key]
readsPrec :: Int -> ReadS Key
$creadsPrec :: Int -> ReadS Key
Read)

instance DeepSeq.NFData Key where rnf :: Key -> ()
rnf Key
_ = ()

instance Pretty Key where
    pretty :: Key -> Text
pretty (Key TrackTime
t Orientation
o) = TrackTime -> Text
forall a. Pretty a => a -> Text
pretty TrackTime
t Text -> Text -> Text
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 (EventMap -> Events) -> ([Event] -> EventMap) -> [Event] -> Events
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Event)] -> EventMap
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([(Key, Event)] -> EventMap)
-> ([Event] -> [(Key, Event)]) -> [Event] -> EventMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> Key) -> [Event] -> [(Key, Event)]
forall a k. (a -> k) -> [a] -> [(k, a)]
Seq.key_on Event -> Key
event_key

to_asc_list :: Events -> [Event.Event]
to_asc_list :: Events -> [Event]
to_asc_list = ((Key, Event) -> Event) -> [(Key, Event)] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Event) -> Event
forall a b. (a, b) -> b
snd ([(Key, Event)] -> [Event])
-> (Events -> [(Key, Event)]) -> Events -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventMap -> [(Key, Event)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (EventMap -> [(Key, Event)])
-> (Events -> EventMap) -> Events -> [(Key, Event)]
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 = ((Key, Event) -> Event) -> [(Key, Event)] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Event) -> Event
forall a b. (a, b) -> b
snd ([(Key, Event)] -> [Event])
-> (EventMap -> [(Key, Event)]) -> EventMap -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventMap -> [(Key, Event)]
forall k a. Map k a -> [(k, a)]
Map.toDescList

instance Pretty Events where
    format :: Events -> Doc
format = [Doc] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ([Doc] -> Doc) -> (Events -> [Doc]) -> Events -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> Doc) -> [Event] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Event -> Doc
event ([Event] -> [Doc]) -> (Events -> [Event]) -> Events -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> [Event]
ascending
        where
        event :: Event -> Doc
event Event
e = Text -> Doc
Pretty.text (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$
            (TrackTime, TrackTime, Text) -> Text
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 = Events -> Events -> Events
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 EventMap -> Maybe (Key, Event)
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 ->
            (Key -> EventMap -> EventMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Key
k EventMap
pre, Key -> Event -> EventMap -> EventMap
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 EventMap -> Maybe (Key, Event)
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 ->
            (Key -> EventMap -> EventMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Key
k EventMap
post, Key -> Event -> EventMap -> EventMap
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)
    | EventMap -> Bool
forall k a. Map k a -> Bool
Map.null EventMap
evts1 = EventMap -> Events
Events EventMap
evts2
    | EventMap -> Bool
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 (EventMap -> [(Key, Event)]
forall k a. Map k a -> [(k, a)]
Map.toAscList EventMap
evts2) (EventMap -> [(Key, Event)]
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 ([Event] -> Events) -> [Event] -> Events
forall a b. (a -> b) -> a -> b
$ [Event] -> [Event]
clip_events ([Event] -> [Event]) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$ (((Key, Bool), Event) -> Event)
-> [((Key, Bool), Event)] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map ((Key, Bool), Event) -> Event
forall a b. (a, b) -> b
snd ([((Key, Bool), Event)] -> [Event])
-> [((Key, Bool), Event)] -> [Event]
forall a b. (a -> b) -> a -> b
$
    (((Key, Bool), Event) -> (Key, Bool))
-> [((Key, Bool), Event)]
-> [((Key, Bool), Event)]
-> [((Key, Bool), Event)]
forall k a. Ord k => (a -> k) -> [a] -> [a] -> [a]
Seq.merge_on ((Key, Bool), Event) -> (Key, Bool)
forall a b. (a, b) -> a
fst (((Key, Event) -> ((Key, Bool), Event))
-> [(Key, Event)] -> [((Key, Bool), Event)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> (Key, Bool)) -> (Key, Event) -> ((Key, Bool), Event)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (,Bool
False)) [(Key, Event)]
old) (((Key, Event) -> ((Key, Bool), Event))
-> [(Key, Event)] -> [((Key, Bool), Event)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> (Key, Bool)) -> (Key, Event) -> ((Key, Bool), Event)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (,Bool
True)) [(Key, Event)]
new)
    -- Seq.merge_on 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 =
    ((Maybe Event, Event, Maybe Event) -> Event)
-> [(Maybe Event, Event, Maybe Event)] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Event, Event, Maybe Event) -> Event
clip ([(Maybe Event, Event, Maybe Event)] -> [Event])
-> ([Event] -> [(Maybe Event, Event, Maybe Event)])
-> [Event]
-> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> [(Maybe Event, Event, Maybe Event)]
forall a. [a] -> [(Maybe a, a, Maybe a)]
Seq.zip_neighbors
        ([Event] -> [(Maybe Event, Event, Maybe Event)])
-> ([Event] -> [Event])
-> [Event]
-> [(Maybe Event, Event, Maybe Event)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> (TrackTime, Orientation)) -> [Event] -> [Event]
forall k a. Eq k => (a -> k) -> [a] -> [a]
Seq.drop_initial_dups (\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 TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
< Event -> TrackTime
Event.end Event
prev
                    then Lens Event TrackTime
Event.end_ Lens Event TrackTime -> TrackTime -> Event -> Event
forall f a. Lens f a -> a -> f -> f
#= Event -> Event -> TrackTime
midpoint Event
prev Event
cur (Event -> Event) -> Event -> Event
forall a b. (a -> b) -> a -> b
$ Event
cur
                    else Event
cur
                -- prev <---|
                -- cur    <---|
                | Event -> TrackTime
Event.start Event
prev TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
> Event -> TrackTime
Event.end Event
cur ->
                    Lens Event TrackTime
Event.end_ Lens Event TrackTime -> TrackTime -> Event -> Event
forall f a. Lens f a -> a -> f -> f
#= Event -> TrackTime
Event.start Event
prev (Event -> Event) -> Event -> Event
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 TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
< Event -> TrackTime
Event.end Event
cur
                    then Lens Event TrackTime
Event.end_ Lens Event TrackTime -> TrackTime -> Event -> Event
forall f a. Lens f a -> a -> f -> f
#= Event -> Event -> TrackTime
midpoint Event
cur Event
next (Event -> Event) -> Event -> Event
forall a b. (a -> b) -> a -> b
$ Event
cur
                    else Event
cur
                -- cur  |--->
                -- next    |--->
                | Event -> TrackTime
Event.start Event
next TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
< Event -> TrackTime
Event.end Event
cur ->
                    Lens Event TrackTime
Event.end_ Lens Event TrackTime -> TrackTime -> Event -> Event
forall f a. Lens f a -> a -> f -> f
#= Event -> TrackTime
Event.start Event
next (Event -> Event) -> Event -> Event
forall a b. (a -> b) -> a -> b
$ Event
cur
                | Bool
otherwise -> Event
cur
    midpoint :: Event -> Event -> TrackTime
midpoint Event
pos Event
neg =
        (TrackTime -> TrackTime -> TrackTime
forall a. Ord a => a -> a -> a
max (Event -> TrackTime
Event.start Event
pos) (Event -> TrackTime
Event.end Event
neg)
            TrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
+ TrackTime -> TrackTime -> TrackTime
forall a. Ord a => a -> a -> a
min (Event -> TrackTime
Event.end Event
pos) (Event -> TrackTime
Event.start Event
neg))
        TrackTime -> TrackTime -> TrackTime
forall a. Fractional a => a -> a -> a
/ TrackTime
2

-- * serialize

instance Serialize.Serialize Events where
    put :: Putter Events
put (Events EventMap
a) = Word8 -> Put
Serialize.put_version Word8
4 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter EventMap
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 <- Get (Map TrackTime Event)
forall a. Serialize a => Get a
Serialize.get
                Events -> Get Events
forall (m :: * -> *) a. Monad m => a -> m a
return (Events -> Get Events) -> Events -> Get Events
forall a b. (a -> b) -> a -> b
$ [Event] -> Events
from_asc_list ([Event] -> Events) -> [Event] -> Events
forall a b. (a -> b) -> a -> b
$ Map TrackTime Event -> [Event]
forall k a. Map k a -> [a]
Map.elems Map TrackTime Event
events
            Word8
4 -> do
                EventMap
events :: Map Key Event.Event <- Get EventMap
forall a. Serialize a => Get a
Serialize.get
                Events -> Get Events
forall (m :: * -> *) a. Monad m => a -> m a
return (Events -> Get Events) -> Events -> Get Events
forall a b. (a -> b) -> a -> b
$ EventMap -> Events
Events EventMap
events
            Word8
_ -> String -> Word8 -> Get Events
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) = Putter TrackTime
forall a. Serialize a => Putter a
Serialize.put TrackTime
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Orientation
forall a. Serialize a => Putter a
Serialize.put Orientation
b
    get :: Get Key
get = TrackTime -> Orientation -> Key
Key (TrackTime -> Orientation -> Key)
-> Get TrackTime -> Get (Orientation -> Key)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get TrackTime
forall a. Serialize a => Get a
Serialize.get Get (Orientation -> Key) -> Get Orientation -> Get Key
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Orientation
forall a. Serialize a => Get a
Serialize.get