-- 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