-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
{- | Slicing is chopping the block horizontally, so that the horizontal chunks
    can act like their own little blocks.

    For the sake of convenient notation, this is done in several places.

    1. A note with subtracks will slice out the subevents within its range.
    This allows a note to take another note (or notes) as arguments, e.g.
    a tuplet.  This is what 'slice_notes' is for.

    2. A note with controls as subtracks can invert itself so it has control
    over the evaluation of the controls.  Documented further in
    "Derive.Call.Note".

    3. #1 above is a convenient way to apply a transformation to multiple
    notes: group the tracks under another, and put the transformations in the
    parent.  However, notes that have no transformation (aka orphans) must be
    extracted from underneath the empty parent, otherwise they will not be
    evaluated at all.  This is done by 'Derive.Call.derive_note_track'.

    This is a nasty tricky bit of work, but is depended on by all the high
    level notation, e.g. calls that can manipulate the results of other
    calls, aka parent calls.  I'd still love to figure out a better way
    to do it though!
-}
module Derive.Slice (
    InsertEvent(..), Track(..), slice
    , checked_slice_notes
    , slice_orphans
#ifdef TESTING
    , strip_empty_tracks
    , slice_notes
#endif
) where
import qualified Data.List as List
import qualified Data.Monoid as Monoid
import qualified Data.Text as Text
import qualified Data.Tree as Tree

import qualified Util.Lists as Lists
import qualified Util.Then as Then

import qualified Derive.ParseTitle as ParseTitle
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Types as Types
import qualified Ui.Ui as Ui

import           Global
import           Types


-- | Ask 'slice' to synthesize a note track and insert it at the leaves of
-- the sliced tree.
data InsertEvent = InsertEvent {
    InsertEvent -> TrackTime
event_duration :: !ScoreTime
    -- | A Negative orientation means that the controls at the Event.end time
    -- are not trimmed off.
    , InsertEvent -> Orientation
event_orientation :: !Types.Orientation
    , InsertEvent -> ([Event], [Event])
event_around :: !([Event.Event], [Event.Event])
    -- | The TrackId for the track created for this event.  This is required
    -- so it can collect a TrackDynamic and when the Cmd level looks at at
    -- track with inverted note calls, it sees the environ established by the
    -- tracks that the calls are inverted beneath.  E.g., if the pitch track
    -- sets a scale, the Cmd layer should see the note track as having that
    -- scale.
    , InsertEvent -> Maybe TrackId
event_track_id :: !(Maybe TrackId)
    } deriving (Int -> InsertEvent -> ShowS
[InsertEvent] -> ShowS
InsertEvent -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InsertEvent] -> ShowS
$cshowList :: [InsertEvent] -> ShowS
show :: InsertEvent -> String
$cshow :: InsertEvent -> String
showsPrec :: Int -> InsertEvent -> ShowS
$cshowsPrec :: Int -> InsertEvent -> ShowS
Show)

{- | Slice a track between start and end, and optionally put a note track with
    a single event of given string at the bottom.  Sliced control tracks
    usually get events beyond the slice boundaries for context.
-}
slice :: Bool -- ^ Omit events than begin at the start.
    -- 'slice_notes' documents why this is necessary.
    -> ScoreTime -> ScoreTime -> Maybe InsertEvent
    -- ^ If given, insert an event at the bottom with the given text and dur.
    -- The created track will have the given track_range, so it can create
    -- a Stack.Region entry.
    -> TrackTree.EventsNode -> TrackTree.EventsNode
slice :: Bool
-> TrackTime
-> TrackTime
-> Maybe InsertEvent
-> EventsNode
-> EventsNode
slice Bool
exclude_start TrackTime
start TrackTime
end Maybe InsertEvent
insert_event (Tree.Node Track
track [EventsNode]
subs) =
    forall a. a -> [Tree a] -> Tree a
Tree.Node (Track -> Track
slice_t Track
track) forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EventsNode]
subs
        then TrackTime -> Maybe BlockId -> [EventsNode]
insert (Track -> TrackTime
TrackTree.track_shifted Track
track)
            (Track -> Maybe BlockId
TrackTree.track_block_id Track
track)
        else forall a b. (a -> b) -> [a] -> [b]
map (Bool
-> TrackTime
-> TrackTime
-> Maybe InsertEvent
-> EventsNode
-> EventsNode
slice Bool
exclude_start TrackTime
start TrackTime
end Maybe InsertEvent
insert_event) [EventsNode]
subs
    where
    insert :: TrackTime -> Maybe BlockId -> [EventsNode]
insert TrackTime
shift Maybe BlockId
block_id = case Maybe InsertEvent
insert_event of
        Maybe InsertEvent
Nothing -> []
        Just InsertEvent
insert_event -> [forall a. a -> [Tree a] -> Tree a
Tree.Node (TrackTime -> Maybe BlockId -> InsertEvent -> Track
make TrackTime
shift Maybe BlockId
block_id InsertEvent
insert_event) []]
    -- The synthesized bottom track.  Since slicing only happens within
    -- a block, I assume the BlockId is the same as the parent.  I need
    -- a BlockId to look up the previous val in 'Derive.Threaded'.
    make :: TrackTime -> Maybe BlockId -> InsertEvent -> Track
make TrackTime
shift Maybe BlockId
block_id (InsertEvent TrackTime
dur Orientation
_ ([Event], [Event])
around Maybe TrackId
track_id) = TrackTree.Track
        { track_title :: Text
track_title = Text
">"
        , track_events :: Events
track_events = Event -> Events
Events.singleton (TrackTime -> TrackTime -> Text -> Event
Event.event TrackTime
start TrackTime
dur Text
"")
        , track_id :: Maybe TrackId
track_id = Maybe TrackId
track_id
        , track_block_id :: Maybe BlockId
track_block_id = Maybe BlockId
block_id
        , track_start :: TrackTime
track_start = TrackTime
start
        , track_end :: TrackTime
track_end = TrackTime
end
        , track_sliced :: Sliced
track_sliced = Sliced
TrackTree.Inversion
        , track_around :: ([Event], [Event])
track_around = ([Event], [Event])
around
        -- Since a note may be inverted and inserted after 'slice_notes'
        -- and its shifting, I have to get the shift from the parent track.
        , track_shifted :: TrackTime
track_shifted = TrackTime
shift
        , track_voice :: Maybe Int
track_voice = forall a. Maybe a
Nothing
        }
    slice_t :: Track -> Track
slice_t Track
track = Track
track
        { track_events :: Events
TrackTree.track_events = Events
within
        , track_start :: TrackTime
TrackTree.track_start = TrackTime
start
        , track_end :: TrackTime
TrackTree.track_end = TrackTime
end
        , track_sliced :: Sliced
TrackTree.track_sliced = case Track -> Sliced
TrackTree.track_sliced Track
track of
            Sliced
TrackTree.Inversion -> Sliced
TrackTree.Inversion
            -- This might already be Sliced Positive because of orphan
            -- slicing, so make sure to update the orientation for both
            -- Sliced and NotSliced.
            Sliced
_ -> Orientation -> Sliced
TrackTree.Sliced
                (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Orientation
Types.Positive InsertEvent -> Orientation
event_orientation Maybe InsertEvent
insert_event)
        , track_around :: ([Event], [Event])
TrackTree.track_around = ([Event]
before, [Event]
after)
        }
        where ([Event]
before, Events
within, [Event]
after) = Track -> ([Event], Events, [Event])
extract_events Track
track
    -- Extract events from an intermediate track.
    extract_events :: Track -> ([Event], Events, [Event])
extract_events Track
track
        | Text -> Bool
ParseTitle.is_note_track Text
title =
            Bool
-> TrackTime -> TrackTime -> Events -> ([Event], Events, [Event])
extract_note_events Bool
exclude_start TrackTime
start TrackTime
end Events
events
        | Bool
otherwise = TrackTime -> TrackTime -> Events -> ([Event], Events, [Event])
extract_control_events TrackTime
start TrackTime
end Events
events
        where
        events :: Events
events = Track -> Events
TrackTree.track_events Track
track
        title :: Text
title = Track -> Text
TrackTree.track_title Track
track

-- | Note tracks don't include pre and post events like control tracks.
extract_note_events :: Bool -> ScoreTime -> ScoreTime
    -> Events.Events -> ([Event.Event], Events.Events, [Event.Event])
extract_note_events :: Bool
-> TrackTime -> TrackTime -> Events -> ([Event], Events, [Event])
extract_note_events Bool
exclude_start TrackTime
start TrackTime
end Events
events =
    (if Bool
exclude_start then forall {c}. ([Event], Events, c) -> ([Event], Events, c)
exclude_s else forall a. a -> a
id)
        (Events -> [Event]
Events.descending Events
pre, Events
within, Events -> [Event]
Events.ascending Events
post)
    where
    -- TODO pass Events.Range instead of (start, end) so I can get -0 slices
    -- right.
    range :: Range
range
        | TrackTime
start forall a. Eq a => a -> a -> Bool
== TrackTime
end = TrackTime -> Orientation -> Range
Events.Point TrackTime
start Orientation
Types.Positive
        | Bool
otherwise = TrackTime -> TrackTime -> Range
Events.Range TrackTime
start TrackTime
end
    (Events
pre, Events
within, Events
post) = Range -> Events -> (Events, Events, Events)
Events.split_range Range
range Events
events
    exclude_s :: ([Event], Events, c) -> ([Event], Events, c)
exclude_s ([Event]
pre, Events
within, c
post) =
        case TrackTime -> Orientation -> Events -> Maybe Event
Events.at TrackTime
start Orientation
Types.Positive Events
within of
            Just Event
event ->
                ( Event
event forall a. a -> [a] -> [a]
: [Event]
pre
                , Range -> Events -> Events
Events.remove (TrackTime -> Orientation -> Range
Events.Point TrackTime
start Orientation
Types.Positive) Events
within
                , c
post
                )
            Maybe Event
Nothing -> ([Event]
pre, Events
within, c
post)

extract_control_events :: ScoreTime -> ScoreTime
    -> Events.Events -> ([Event.Event], Events.Events, [Event.Event])
    -- ^ (descending_pre, within, ascending_post)
extract_control_events :: TrackTime -> TrackTime -> Events -> ([Event], Events, [Event])
extract_control_events TrackTime
start TrackTime
end Events
events = ([Event]
pre, [Event] -> Events
Events.from_list [Event]
within, [Event]
post2)
    where
    ([Event]
pre, [Event]
post1) = case TrackTime -> Events -> ([Event], [Event])
Events.split_lists TrackTime
start Events
events of
        (Event
at_1:[Event]
pre, Event
at:[Event]
post) | Event -> TrackTime
Event.start Event
at forall a. Ord a => a -> a -> Bool
> TrackTime
start -> ([Event]
pre, Event
at_1forall a. a -> [a] -> [a]
:Event
atforall a. a -> [a] -> [a]
:[Event]
post)
        (Event
at_1:[Event]
pre, []) -> ([Event]
pre, [Event
at_1])
        ([Event], [Event])
a -> ([Event], [Event])
a
    -- Collect events until one at or after 'end'.
    ([Event]
within, [Event]
post2) = forall a rest.
(a -> Bool) -> ([a] -> ([a], rest)) -> [a] -> ([a], rest)
Then.span ((forall a. Ord a => a -> a -> Bool
<TrackTime
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> TrackTime
Event.start) (forall a. Int -> [a] -> ([a], [a])
splitAt Int
1) [Event]
post1

{- | Expect a note track somewhere in the tree.  Slice the tracks above and
    below it to each of its events.

    The shift of each Event will be subtracted from the track events, so they
    start at 0.  Control tracks caught in the middle are extended one event on
    either edge of the slice boundary courtesy of the 'slice' function.  Note
    that there will be control events at negative ScoreTime if they lie before
    the note.

    Technically the children of the note track don't need to be sliced, since
    if it is inverting it will do that anyway.  But slicing lets me shift fewer
    events, so it's probably a good idea anyway.
-}
slice_notes :: Bool -- ^ include a note at the end
    -> ScoreTime -> ScoreTime -> TrackTree.EventsTree
    -> [Track] -- ^ One Track per non-empty sub note track, in TrackNum order.
slice_notes :: Bool -> TrackTime -> TrackTime -> [EventsNode] -> [Track]
slice_notes Bool
include_end TrackTime
start TrackTime
end [EventsNode]
tracks
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EventsNode]
tracks Bool -> Bool -> Bool
|| TrackTime
start forall a. Ord a => a -> a -> Bool
> TrackTime
end = []
    | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe TrackId -> [Note] -> Track
Track) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Note -> Maybe Note
strip_note) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sliced -> (Maybe TrackId, [Note])
slice_track) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventsNode -> [Sliced]
note_tracks [EventsNode]
tracks
    where
    note_tracks :: TrackTree.EventsNode -> [Sliced]
    note_tracks :: EventsNode -> [Sliced]
note_tracks node :: EventsNode
node@(Tree.Node Track
track [EventsNode]
subs)
        | Track -> Bool
is_note Track
track =
            [([], Track
track, Bool
-> TrackTime
-> TrackTime
-> EventsNode
-> [(TrackTime, TrackTime, TrackTime)]
event_ranges Bool
include_end TrackTime
start TrackTime
end EventsNode
node, [EventsNode]
subs)]
        | Bool
otherwise =
            [ (Track
track forall a. a -> [a] -> [a]
: [Track]
parents, Track
ntrack, [(TrackTime, TrackTime, TrackTime)]
slices, [EventsNode]
nsubs)
            | ([Track]
parents, Track
ntrack, [(TrackTime, TrackTime, TrackTime)]
slices, [EventsNode]
nsubs) <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventsNode -> [Sliced]
note_tracks [EventsNode]
subs
            ]
    -- For each note track, slice out each event.
    slice_track :: Sliced -> (Maybe TrackId, [Note])
    slice_track :: Sliced -> (Maybe TrackId, [Note])
slice_track ([Track]
parents, Track
note_track, [(TrackTime, TrackTime, TrackTime)]
slices, [EventsNode]
subs) =
        ( Track -> Maybe TrackId
TrackTree.track_id Track
note_track
        , forall a b. (a -> b) -> [a] -> [b]
map (forall {c}.
[EventsNode]
-> (Maybe (TrackTime, TrackTime, c),
    (TrackTime, TrackTime, TrackTime))
-> Note
slice1 ([Track] -> [EventsNode]
make_tree [Track]
parents)) (forall a. [a] -> [(Maybe a, a)]
Lists.zipPrev [(TrackTime, TrackTime, TrackTime)]
slices)
        )
        where
        make_tree :: [Track] -> [EventsNode]
make_tree (Track
p:[Track]
ps) = [forall a. a -> [Tree a] -> Tree a
Tree.Node Track
p ([Track] -> [EventsNode]
make_tree [Track]
ps)]
        make_tree [] = [forall a. a -> [Tree a] -> Tree a
Tree.Node Track
note_track [EventsNode]
subs]
    slice1 :: [EventsNode]
-> (Maybe (TrackTime, TrackTime, c),
    (TrackTime, TrackTime, TrackTime))
-> Note
slice1 [EventsNode]
tree (Maybe (TrackTime, TrackTime, c)
prev, (TrackTime
n_start, TrackTime
n_end, TrackTime
n_next)) =
        ( TrackTime
n_start
        , TrackTime
n_end forall a. Num a => a -> a -> a
- TrackTime
n_start
        , forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TrackTime -> TrackTime -> Track -> Track
shift_tree TrackTime
n_start TrackTime
n_next)) forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map (Bool
-> TrackTime
-> TrackTime
-> Maybe InsertEvent
-> EventsNode
-> EventsNode
slice Bool
prev_zero TrackTime
n_start TrackTime
n_end forall a. Maybe a
Nothing) [EventsNode]
tree
        )
        where
        -- exclude_start if 's' is still the original 'start', or if the
        -- previous slice was zero dur and is the same as 'start', which means
        -- it already consumed any event at 'start'.
        prev_zero :: Bool
prev_zero = case Maybe (TrackTime, TrackTime, c)
prev of
            Maybe (TrackTime, TrackTime, c)
Nothing -> Bool
False
            Just (TrackTime
s, TrackTime
e, c
_) -> TrackTime
s forall a. Eq a => a -> a -> Bool
== TrackTime
e Bool -> Bool -> Bool
&& TrackTime
s forall a. Eq a => a -> a -> Bool
== TrackTime
n_start
    shift_tree :: TrackTime -> TrackTime -> Track -> Track
shift_tree TrackTime
shift TrackTime
next Track
track = Track
track
        { track_events :: Events
TrackTree.track_events =
            (Event -> Event) -> Events -> Events
Events.map_events Event -> Event
move (Track -> Events
TrackTree.track_events Track
track)
        , track_start :: TrackTime
TrackTree.track_start = Track -> TrackTime
TrackTree.track_start Track
track forall a. Num a => a -> a -> a
- TrackTime
shift
        , track_end :: TrackTime
TrackTree.track_end = TrackTime
next forall a. Num a => a -> a -> a
- TrackTime
shift
        , track_around :: ([Event], [Event])
TrackTree.track_around =
            let ([Event]
prev, [Event]
next) = Track -> ([Event], [Event])
TrackTree.track_around Track
track
            in (forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
move [Event]
prev, forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
move [Event]
next)
        , track_shifted :: TrackTime
TrackTree.track_shifted = Track -> TrackTime
TrackTree.track_shifted Track
track forall a. Num a => a -> a -> a
+ TrackTime
shift
        }
        where move :: Event -> Event
move = Lens Event TrackTime
Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f
%= forall a. Num a => a -> a -> a
subtract TrackTime
shift

-- | (parents, note_track, 'event_ranges', subs)
type Sliced =
    ( [TrackTree.Track]
    , TrackTree.Track
    , [(ScoreTime, ScoreTime, ScoreTime)]
    , TrackTree.EventsTree
    )

-- | (start, dur, tracks)
type Note = (ScoreTime, ScoreTime, [TrackTree.EventsNode])

data Track = Track {
    Track -> Maybe TrackId
_track_id :: Maybe TrackId
    , Track -> [Note]
_notes :: [Note]
    } deriving (Int -> Track -> ShowS
[Track] -> ShowS
Track -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Track] -> ShowS
$cshowList :: [Track] -> ShowS
show :: Track -> String
$cshow :: Track -> String
showsPrec :: Int -> Track -> ShowS
$cshowsPrec :: Int -> Track -> ShowS
Show)

-- | Get slice ranges for a track.  This gets the non-overlapping ranges of all
-- the note tracks events below.
event_ranges :: Bool -> TrackTime -> TrackTime -> TrackTree.EventsNode
    -> [(TrackTime, TrackTime, TrackTime)]
    -- ^ [(start, end, next_start)]
event_ranges :: Bool
-> TrackTime
-> TrackTime
-> EventsNode
-> [(TrackTime, TrackTime, TrackTime)]
event_ranges Bool
include_end TrackTime
start TrackTime
end = forall {a} {c}. Ord a => [(a, a, c)] -> [(a, a, c)]
nonoverlapping forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventsNode -> [(TrackTime, TrackTime, TrackTime)]
to_ranges
    where
    to_ranges :: EventsNode -> [(TrackTime, TrackTime, TrackTime)]
to_ranges = forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Lists.mergeLists (\(TrackTime
s, TrackTime
_, TrackTime
_) -> TrackTime
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Track -> [(TrackTime, TrackTime, TrackTime)]
track_events
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Track -> Bool
is_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> [a]
Tree.flatten
    track_events :: Track -> [(TrackTime, TrackTime, TrackTime)]
track_events = forall a b. (a -> b) -> [a] -> [b]
map (Event, Maybe Event) -> (TrackTime, TrackTime, TrackTime)
range forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, Maybe a)]
Lists.zipNext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> [Event]
Events.ascending
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> TrackTime -> TrackTime -> Events -> Events
events_in_range Bool
include_end TrackTime
start TrackTime
end
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Events
TrackTree.track_events
    range :: (Event, Maybe Event) -> (TrackTime, TrackTime, TrackTime)
range (Event
event, Maybe Event
next) =
        ( Event -> TrackTime
Event.min Event
event, Event -> TrackTime
Event.max Event
event
        , forall a. Ord a => a -> a -> a
max (Event -> TrackTime
Event.max Event
event) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe TrackTime
end Event -> TrackTime
Event.min Maybe Event
next)
        )
    nonoverlapping :: [(a, a, c)] -> [(a, a, c)]
nonoverlapping [] = []
    nonoverlapping ((a, a, c)
r:[(a, a, c)]
rs) = (a, a, c)
r forall a. a -> [a] -> [a]
: [(a, a, c)] -> [(a, a, c)]
nonoverlapping (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall {a} {a} {c} {c}.
(Ord a, Ord a) =>
(a, a, c) -> (a, a, c) -> Bool
overlaps (a, a, c)
r) [(a, a, c)]
rs)
    overlaps :: (a, a, c) -> (a, a, c) -> Bool
overlaps (a
s1, a
e1, c
_) (a
s2, a
e2, c
_) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ a
e1 forall a. Ord a => a -> a -> Bool
<= a
s2 Bool -> Bool -> Bool
|| a
e2 forall a. Ord a => a -> a -> Bool
<= a
s1

-- TODO maybe I can remove include_end if I require the next event to be
-- negative.
events_in_range :: Bool -> TrackTime -> TrackTime -> Events.Events
    -> Events.Events
events_in_range :: Bool -> TrackTime -> TrackTime -> Events -> Events
events_in_range Bool
include_end TrackTime
start TrackTime
end Events
events
    | Bool
include_end = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Events
within (\Event
e -> [Event] -> Events -> Events
Events.insert [Event
e] Events
within)
        (TrackTime -> Orientation -> Events -> Maybe Event
Events.at TrackTime
end Orientation
Types.Positive Events
post)
    | Bool
otherwise = Events
within
    where
    (Events
_, Events
within, Events
post) = Range -> Events -> (Events, Events, Events)
Events.split_range Range
range Events
events
    -- TODO since this is Positive I think it doesn't treat -0 events
    -- correctly.  I could pass Events.Range from the caller.
    range :: Range
range = if TrackTime
start forall a. Eq a => a -> a -> Bool
== TrackTime
end then TrackTime -> Orientation -> Range
Events.Point TrackTime
start Orientation
Types.Positive
        else TrackTime -> TrackTime -> Range
Events.Range TrackTime
start TrackTime
end

-- | Remove empty tracks from the Note tree, and the entire Note if it was all
-- empty tracks.
strip_note :: Note -> Maybe Note
strip_note :: Note -> Maybe Note
strip_note (TrackTime
start, TrackTime
dur, [EventsNode]
tree)
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EventsNode]
stripped = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just (TrackTime
start, TrackTime
dur, [EventsNode]
tree)
    where stripped :: [EventsNode]
stripped = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventsNode -> [EventsNode]
strip_empty_tracks [EventsNode]
tree

-- | If a branch has no note track children with events, there's no way it can
-- produce any events, so it can be dropped before derivation.
--
-- The branch has to have no notes from top to bottom, because any note in the
-- middle could invert below.
strip_empty_tracks :: TrackTree.EventsNode -> [TrackTree.EventsNode]
strip_empty_tracks :: EventsNode -> [EventsNode]
strip_empty_tracks (Tree.Node Track
track [EventsNode]
subs)
    | Bool -> Bool
not (Track -> Bool
is_note Track
track) Bool -> Bool -> Bool
|| Track -> Bool
track_empty Track
track =
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EventsNode]
stripped then [] else [forall a. a -> [Tree a] -> Tree a
Tree.Node Track
track [EventsNode]
stripped]
    | Bool
otherwise = [forall a. a -> [Tree a] -> Tree a
Tree.Node Track
track [EventsNode]
subs]
    where stripped :: [EventsNode]
stripped = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventsNode -> [EventsNode]
strip_empty_tracks [EventsNode]
subs

-- | This is 'slice_notes', but throw an error if 'find_overlapping' complains.
--
-- TODO I think I don't want to allow sub-events larger than their slice, but
-- currently I do.  Actually I think overlap checking needs an overhaul in
-- general.
checked_slice_notes :: Bool -- ^ TODO change this to Event.Orientation?
    -> ScoreTime -> ScoreTime -> TrackTree.EventsTree -> Either Text [Track]
checked_slice_notes :: Bool
-> TrackTime -> TrackTime -> [EventsNode] -> Either Text [Track]
checked_slice_notes Bool
include_end TrackTime
start TrackTime
end [EventsNode]
tree = case Maybe Text
maybe_err of
    Maybe Text
Nothing -> forall a b. b -> Either a b
Right [Track]
tracks
    Just Text
err -> forall a b. a -> Either a b
Left Text
err
    where
    maybe_err :: Maybe Text
maybe_err = if TrackTime
start forall a. Eq a => a -> a -> Bool
== TrackTime
end
        then TrackTime -> [[EventsNode]] -> Maybe Text
check_greater_than TrackTime
0 [[EventsNode]]
check_tracks
        else Bool -> TrackTime -> [[EventsNode]] -> Maybe Text
check_overlapping Bool
include_end TrackTime
0 [[EventsNode]]
check_tracks
    tracks :: [Track]
tracks = Bool -> TrackTime -> TrackTime -> [EventsNode] -> [Track]
slice_notes Bool
include_end TrackTime
start TrackTime
end [EventsNode]
tree
    -- Only check the first note of each slice.  Since the notes are
    -- increasing, this is the one which might start before the slice.  Since
    -- the events have been shifted back by the slice start, an event that
    -- extends over 0 means it overlaps the beginning of the slice.
    check_tracks :: [[EventsNode]]
check_tracks = forall a b. (a -> b) -> [a] -> [b]
map (\(TrackTime
_, TrackTime
_, [EventsNode]
subs) -> [EventsNode]
subs) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> [Note]
_notes) [Track]
tracks

check_greater_than :: ScoreTime -> [[TrackTree.EventsNode]] -> Maybe Text
check_greater_than :: TrackTime -> [[EventsNode]] -> Maybe Text
check_greater_than TrackTime
start [[EventsNode]]
tracks
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Event]
events = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"zero duration slice has note events >"
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackTime
start forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty [Event]
events)
    where events :: [Event]
events = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TrackTime -> [EventsNode] -> Maybe Event
find_greater_than TrackTime
start) [[EventsNode]]
tracks

find_greater_than :: ScoreTime -> [TrackTree.EventsNode] -> Maybe Event.Event
find_greater_than :: TrackTime -> [EventsNode] -> Maybe Event
find_greater_than TrackTime
start = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
find (Track -> Maybe Event
has_gt forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Track -> Maybe Track
note_track))
    where
    note_track :: Track -> Maybe Track
note_track Track
track
        | Track -> Bool
is_note Track
track = forall a. a -> Maybe a
Just Track
track
        | Bool
otherwise = forall a. Maybe a
Nothing
    has_gt :: Track -> Maybe Event
has_gt = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Ord a => a -> a -> Bool
>TrackTime
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> TrackTime
Event.start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> [Event]
Events.ascending
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Events
TrackTree.track_events

check_overlapping :: Bool -> ScoreTime -> [[TrackTree.EventsNode]]
    -> Maybe Text
check_overlapping :: Bool -> TrackTime -> [[EventsNode]] -> Maybe Text
check_overlapping Bool
include_end TrackTime
start [[EventsNode]]
tracks
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe TrackId, (TrackTime, TrackTime))]
overlaps = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"slice has overlaps: "
        forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map (Maybe TrackId, (TrackTime, TrackTime)) -> Text
show_overlap [(Maybe TrackId, (TrackTime, TrackTime))]
overlaps)
    -- TODO 'include_end' is used incorrectly, it becomes 'exclude_start'
    -- need to fix find_overlapping
    where overlaps :: [(Maybe TrackId, (TrackTime, TrackTime))]
overlaps = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Bool
-> TrackTime
-> [EventsNode]
-> Maybe (Maybe TrackId, (TrackTime, TrackTime))
find_overlapping Bool
include_end TrackTime
start) [[EventsNode]]
tracks

{- | Slice overlaps are when an event overlaps the start of the slice range,
    or extends past the end.  They're bad because they tend to cause notes to
    get doubled.  This is because a slice is expanded by larger sub-events, so
    the events under the overlapping event have likely already be evaluated by
    the previous slice.

    From a certain point of view, slices represent nested function calls.  An
    overlapping event would then represent a function that somehow exists in
    two call branches simultaneously, and there's no way to make sense of that
    without duplicating the call branches.  E.g., visually:

    > a-b-
    > c---
    > 1-2-

    The call @c@ overlaps @b@.  To make this into a call graph, you have to
    either omit @c@ even though it looks like it has scope over @2@:

    > a (c 1) (b 2)

    Or duplicate it:

    > a (c 1) (b (c 2))

    Duplication is reasonable for some calls, i.e. ones that treat all their
    sub-events uniformly, but not the rest.  Besides, when @a@ slices, @c@ will
    expand it to include @1@ and @2@, so the actual result is

    > a (c 1 2) (b ...?)

    It's ok for a sub-event to be larger than its caller, because there are
    zero-duration note parents that take non-zero-duration sub-events.

    This check also requires me to delay stripping out empty tracks until after
    the check has been done, because otherwise @b@ wouldn't notice that @c@
    overlaps.
-}
find_overlapping :: Bool -> ScoreTime -> [TrackTree.EventsNode]
    -> Maybe (Maybe TrackId, (TrackTime, TrackTime))
find_overlapping :: Bool
-> TrackTime
-> [EventsNode]
-> Maybe (Maybe TrackId, (TrackTime, TrackTime))
find_overlapping Bool
exclude_start TrackTime
start = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
find Track -> Maybe (Maybe TrackId, (TrackTime, TrackTime))
has_overlap)
    where
    -- This relies on the 'strip_empty_tracks' having been called.  The
    -- problem is that a zero duration slice after (0, 0) looks like (0, n).
    -- I want to emit an error if and only if there are events starting at >0
    -- in the (0, n) slice.  Those events will be evaluated twice if the (0, 0)
    -- slice also got them.  But 'find_overlapping' only looks to see if prev
    -- events overlap 0, which means it emits an error for both the case with
    -- no events at >0, and with events >0.  Stripping empty tracks eliminates
    -- the false positive for no events at >0, while leaving the true positive
    -- for events at >0.
    --
    -- This seems pretty obscure and indirect, and I tried to come up with an
    -- algorithm that didn't rely on 'strip_empty_tracks', but failed.
    has_overlap :: Track -> Maybe (Maybe TrackId, (TrackTime, TrackTime))
has_overlap Track
track = case Track -> ([Event], [Event])
TrackTree.track_around Track
track of
        (Event
prev : [Event]
_, [Event]
_) | Track -> Bool
is_note Track
track Bool -> Bool -> Bool
&& Event -> TrackTime
edge Event
prev forall a. Ord a => a -> a -> Bool
> TrackTime
start ->
            forall a. a -> Maybe a
Just (Track -> Maybe TrackId
TrackTree.track_id Track
track,
                (TrackTime -> TrackTime
shifted (Event -> TrackTime
Event.start Event
prev), TrackTime -> TrackTime
shifted (Event -> TrackTime
Event.end Event
prev)))
        ([Event], [Event])
_ -> forall a. Maybe a
Nothing
        where shifted :: TrackTime -> TrackTime
shifted = (forall a. Num a => a -> a -> a
+ Track -> TrackTime
TrackTree.track_shifted Track
track)
    -- This works but I don't know why.  It's probably wrong, and the whole
    -- overlap checking strategy probably needs a redo, but it's defeated
    -- me for the moment so I'm letting it be.
    edge :: Event -> TrackTime
edge = if Bool
exclude_start then Event -> TrackTime
Event.min else Event -> TrackTime
Event.max

show_overlap :: (Maybe TrackId, (TrackTime, TrackTime)) -> Text
show_overlap :: (Maybe TrackId, (TrackTime, TrackTime)) -> Text
show_overlap (Maybe TrackId
Nothing, (TrackTime
start, TrackTime
end)) =
    forall a. Pretty a => a -> Text
pretty TrackTime
start forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackTime
end
show_overlap (Just TrackId
track_id, (TrackTime
start, TrackTime
end)) =
    forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ Maybe BlockId -> TrackId -> TrackTime -> TrackTime -> Range
Ui.Range forall a. Maybe a
Nothing TrackId
track_id TrackTime
start TrackTime
end

-- * orphans

-- | This is a variant of 'slice' used by note track evaluation to derive
-- orphan events.
slice_orphans :: Bool -> ScoreTime -> ScoreTime -> [TrackTree.EventsNode]
    -> Either Text [TrackTree.EventsNode]
slice_orphans :: Bool
-> TrackTime
-> TrackTime
-> [EventsNode]
-> Either Text [EventsNode]
slice_orphans Bool
exclude_start TrackTime
start TrackTime
end [EventsNode]
subs =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. b -> Either a b
Right [EventsNode]
slices) forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Bool -> TrackTime -> [[EventsNode]] -> Maybe Text
check_overlapping Bool
exclude_start TrackTime
start [[EventsNode]
slices]
    where
    slices :: [EventsNode]
slices = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventsNode -> [EventsNode]
strip_empty_tracks forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (Bool
-> TrackTime
-> TrackTime
-> Maybe InsertEvent
-> EventsNode
-> EventsNode
slice Bool
exclude_start TrackTime
start TrackTime
end forall a. Maybe a
Nothing) [EventsNode]
subs

-- * util

is_note :: TrackTree.Track -> Bool
is_note :: Track -> Bool
is_note = Text -> Bool
ParseTitle.is_note_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Text
TrackTree.track_title

track_empty :: TrackTree.Track -> Bool
track_empty :: Track -> Bool
track_empty = Events -> Bool
Events.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Events
TrackTree.track_events

-- | Get the first Just from the structure.
find :: Foldable t => (a -> Maybe b) -> t a -> Maybe b
find :: forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
find a -> Maybe b
f = forall a. First a -> Maybe a
Monoid.getFirst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Maybe a -> First a
Monoid.First forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
f)