-- 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 DeriveFunctor #-}
-- | This is the basic interface for slicing.  This also includes 'inverting',
-- which is a special case of slicing.
module Derive.Call.Sub (
    -- * inversion
    under_invert
    , inverting, inverting_args
    -- ** events
    , sub_events, sub_events_negative
    , sub_tracks
    , assert_no_subs
    , modify_notes
    , derive_subs, derive, derive_tracks, derive_pitch, fit
    -- ** RestEvent
    , RestEvent, sub_rest_events
    , fit_rests, strip_rests
    -- * reapply
    , reapply, reapply_call
) where
import qualified Data.Map as Map
import qualified Data.Tree as Tree

import qualified Util.Lists as Lists
import qualified Derive.Args as Args
import qualified Derive.Call.BlockUtil as BlockUtil
import qualified Derive.Call.SubT as SubT
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Score as Score
import qualified Derive.Slice as Slice
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream

import qualified Perform.Pitch as Pitch
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.TrackTree as TrackTree

import           Global
import           Types


-- * inversion

{- | Cause this transformer to apply only after inversion.
    'Derive.Call.Tags.under_invert' documents this, also see
    NOTE [under-invert].

    Normally when a call is inverted, the transformers run outside the
    inversion, while only the generator runs underneath.  However, some
    transformers rely on per-note controls, such as pitch and dyn, and
    therefore need to go under the invert.  So this saves the transformer, and
    applies it only after all the inversion has happened.

    If there are no sub-tracks, then inversion won't happen, and the transform
    is run right here.  However, if there are sub-tracks, but the generator
    doesn't want to run, then the transform will be lost.

    TODO I could probably fix it by making Eval.eval_generator apply the
    transform, but it would have to clear it out too to avoid evaluating more
    than once.  Not sure which way is right.
-}
under_invert :: (Derive.NoteArgs -> Derive.NoteDeriver -> Derive.NoteDeriver)
    -> Derive.NoteArgs -> Derive.NoteDeriver -> Derive.NoteDeriver
under_invert :: (NoteArgs -> NoteDeriver -> NoteDeriver)
-> NoteArgs -> NoteDeriver -> NoteDeriver
under_invert NoteArgs -> NoteDeriver -> NoteDeriver
transformer NoteArgs
args NoteDeriver
deriver
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall val. Context val -> EventsTree
Derive.ctx_sub_tracks forall a b. (a -> b) -> a -> b
$ forall val. PassedArgs val -> Context val
Derive.passed_ctx NoteArgs
args =
        NoteArgs -> NoteDeriver -> NoteDeriver
transformer NoteArgs
args NoteDeriver
deriver
    | Bool
otherwise = forall {a}. Deriver a -> Deriver a
with NoteDeriver
deriver
    where
    with :: Deriver a -> Deriver a
with = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local forall a b. (a -> b) -> a -> b
$ \Dynamic
state -> Dynamic
state
        { state_under_invert :: NoteDeriver -> NoteDeriver
Derive.state_under_invert =
            Dynamic -> NoteDeriver -> NoteDeriver
Derive.state_under_invert Dynamic
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteArgs -> NoteDeriver -> NoteDeriver
transformer NoteArgs
args
        }

-- | Convert a call into an inverting call.  Documented in
-- @doc/slicing-inverting.md@.
run_invert :: Derive.PassedArgs d -> Derive.NoteDeriver -> Derive.NoteDeriver
run_invert :: forall d. PassedArgs d -> NoteDeriver -> NoteDeriver
run_invert PassedArgs d
args NoteDeriver
call = do
    Dynamic
dyn <- forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic forall a. a -> a
id
    case (Dynamic -> Inversion
Derive.state_inversion Dynamic
dyn, forall val. Context val -> EventsTree
Derive.ctx_sub_tracks Context d
ctx) of
        (Derive.InversionInProgress {}, EventsTree
_) ->
            forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"tried to invert while inverting"
        (Inversion
Derive.NotInverted, subs :: EventsTree
subs@(EventsNode
_:EventsTree
_)) -> do
            EventsTree
sliced <- EventsTree
-> Event -> ScoreTime -> ([Event], [Event]) -> Deriver EventsTree
invert EventsTree
subs Event
event (forall a. PassedArgs a -> ScoreTime
Args.next PassedArgs d
args)
                (forall val. Context val -> [Event]
Derive.ctx_prev_events Context d
ctx, forall val. Context val -> [Event]
Derive.ctx_next_events Context d
ctx)
            forall {a}. Deriver a -> Deriver a
with_inversion forall a b. (a -> b) -> a -> b
$ EventsTree -> NoteDeriver
BlockUtil.derive_tracks EventsTree
sliced
        (Inversion
Derive.NotInverted, []) -> NoteDeriver
call
    where
    with_inversion :: Deriver a -> Deriver a
with_inversion = forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local forall a b. (a -> b) -> a -> b
$ \Dynamic
dyn -> Dynamic
dyn
        { state_inversion :: Inversion
Derive.state_inversion = NoteDeriver -> Inversion
Derive.InversionInProgress NoteDeriver
call }
    event :: Event
event = forall val. Context val -> Event
Derive.ctx_event Context d
ctx
    ctx :: Context d
ctx = forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args

-- | Convert a call into an inverting call.  This is designed to be convenient
-- to insert after the signature arg in a call definition.  The args passed
-- to the call have been stripped of their sub tracks to avoid another
-- inversion.
inverting :: (Derive.PassedArgs d -> Derive.NoteDeriver) -> Derive.PassedArgs d
    -> Derive.NoteDeriver
inverting :: forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
inverting PassedArgs d -> NoteDeriver
call PassedArgs d
args = forall d. PassedArgs d -> NoteDeriver -> NoteDeriver
run_invert PassedArgs d
args (PassedArgs d -> NoteDeriver
call PassedArgs d
stripped)
    where
    stripped :: PassedArgs d
stripped = PassedArgs d
args
        { passed_ctx :: Context d
Derive.passed_ctx = (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args)
            { ctx_sub_tracks :: EventsTree
Derive.ctx_sub_tracks = forall a. Monoid a => a
mempty
            , ctx_sub_events :: Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Derive.ctx_sub_events = forall a. Maybe a
Nothing
            }
        }

-- | 'inverting' with its arguments flipped.  This is useful for calls that
-- want to do stuff with the args before inverting.  Make sure to shadow the
-- old 'Derive.PassedArgs' with the ones passed to the call, for the reason
-- documented in 'inverting'.
inverting_args :: Derive.PassedArgs d
    -> (Derive.PassedArgs d -> Derive.NoteDeriver) -> Derive.NoteDeriver
inverting_args :: forall d.
PassedArgs d -> (PassedArgs d -> NoteDeriver) -> NoteDeriver
inverting_args = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
inverting

-- When I invert, I call derive_tracks again, which means the inverted bottom
-- is going to expect to see the current prev val.  TODO but evidently I don't
-- need this?  Try to make a problem without it.
save_prev_val :: Derive.Taggable a => Derive.PassedArgs a -> Derive.Deriver ()
save_prev_val :: forall a. Taggable a => PassedArgs a -> Deriver ()
save_prev_val PassedArgs a
args = case forall a. PassedArgs a -> Maybe a
Args.prev_val PassedArgs a
args of
    Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just a
val -> Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver Stack
Internal.get_stack forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (BlockId, TrackId)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (BlockId, TrackId)
block_track -> forall {err}. (Threaded -> Threaded) -> Deriver State err ()
modify_threaded forall a b. (a -> b) -> a -> b
$ \Threaded
th -> Threaded
th
            { state_prev_val :: Map (BlockId, TrackId) Tagged
Derive.state_prev_val = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (BlockId, TrackId)
block_track
                (forall a. Taggable a => a -> Tagged
Derive.to_tagged a
val) (Threaded -> Map (BlockId, TrackId) Tagged
Derive.state_prev_val Threaded
th)
            }
    where
    modify_threaded :: (Threaded -> Threaded) -> Deriver State err ()
modify_threaded Threaded -> Threaded
modify = forall st err. (st -> st) -> Deriver st err ()
Derive.modify forall a b. (a -> b) -> a -> b
$
        \State
st -> State
st { state_threaded :: Threaded
Derive.state_threaded = Threaded -> Threaded
modify (State -> Threaded
Derive.state_threaded State
st) }

invert :: TrackTree.EventsTree -> Event.Event -> ScoreTime
    -> ([Event.Event], [Event.Event]) -> Derive.Deriver TrackTree.EventsTree
invert :: EventsTree
-> Event -> ScoreTime -> ([Event], [Event]) -> Deriver EventsTree
invert EventsTree
subs Event
event ScoreTime
next_start ([Event], [Event])
events_around = do
    -- Pick the current TrackId out of the stack, and give that to the track
    -- created by inversion.
    -- TODO I'm not 100% comfortable with this, I don't like putting implicit
    -- dependencies on the stack like this.  Too many of these and someday
    -- I change how the stack works and all sorts of things break.  It would be
    -- more explicit to put TrackId into Context.
    Maybe TrackId
track_id <- Deriver (Maybe TrackId)
stack_track_id
    let sliced :: EventsTree
sliced = Maybe TrackId -> EventsTree
slice Maybe TrackId
track_id
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (EventsTree -> Maybe Track
non_bottom_note_track EventsTree
sliced) forall a b. (a -> b) -> a -> b
$ \Track
track -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$
        Text
"inverting below a note track will lead to an endless loop: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Track -> Maybe TrackId
TrackTree.track_id Track
track)
    forall (m :: * -> *) a. Monad m => a -> m a
return EventsTree
sliced
    where
    slice :: Maybe TrackId -> EventsTree
slice Maybe TrackId
track_id =
        forall a b. (a -> b) -> [a] -> [b]
map (Bool
-> ScoreTime
-> ScoreTime
-> Maybe InsertEvent
-> EventsNode
-> EventsNode
Slice.slice Bool
False (Event -> ScoreTime
Event.start Event
event) ScoreTime
next_start
            (forall a. a -> Maybe a
Just (Maybe TrackId -> InsertEvent
insert Maybe TrackId
track_id))) EventsTree
subs
    -- Use 'next_start' instead of track_end because in the absence of a next
    -- note, the track end becomes next note and clips controls.
    insert :: Maybe TrackId -> InsertEvent
insert Maybe TrackId
track_id = Slice.InsertEvent
        { event_duration :: ScoreTime
event_duration = Event -> ScoreTime
Event.duration Event
event
        , event_orientation :: Orientation
event_orientation = Event -> Orientation
Event.orientation Event
event
        , event_around :: ([Event], [Event])
event_around = ([Event], [Event])
events_around
        , event_track_id :: Maybe TrackId
event_track_id = Maybe TrackId
track_id
        }

stack_track_id :: Derive.Deriver (Maybe TrackId)
stack_track_id :: Deriver (Maybe TrackId)
stack_track_id = forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Frame -> Maybe TrackId
Stack.track_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
Stack.innermost
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver Stack
Internal.get_stack

-- | An inverting call above another note track will lead to an infinite loop
-- if there are overlapping sub-events that also invert, or confusing results
-- if there are non-overlapping or non-inverting sub-events.  Either way, I
-- don't think I want it.
--
-- An exception is if the note track is empty, since I can be sure there are
-- no inverting calls in that case.
non_bottom_note_track :: TrackTree.EventsTree -> Maybe TrackTree.Track
non_bottom_note_track :: EventsTree -> Maybe Track
non_bottom_note_track EventsTree
tree = forall a. [a] -> Maybe a
Lists.head (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventsNode -> [Track]
go EventsTree
tree)
    where
    go :: EventsNode -> [Track]
go (Tree.Node Track
track EventsTree
subs)
        | Text -> Bool
ParseTitle.is_note_track (Track -> Text
TrackTree.track_title Track
track)
            Bool -> Bool -> Bool
&& Bool -> Bool
not (Events -> Bool
Events.null (Track -> Events
TrackTree.track_events Track
track))
            Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null EventsTree
subs) = [Track
track]
        | Bool
otherwise = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventsNode -> [Track]
go EventsTree
subs

-- * sub tracks

-- | Get the Events of subtracks, if any, returning one list of events per sub
-- note track.  This is the top-level utility for note calls that take other
-- note calls as arguments.
sub_events :: Derive.PassedArgs d -> Derive.Deriver [[SubT.Event]]
sub_events :: forall d. PassedArgs d -> Deriver [[Event]]
sub_events = forall d. Bool -> PassedArgs d -> Deriver [[Event]]
sub_events_ Bool
False

-- | TODO maybe this should replace 'sub_events'
sub_tracks :: Derive.PassedArgs d -> Derive.Deriver [SubT.Track]
sub_tracks :: forall d. PassedArgs d -> Deriver [Track]
sub_tracks = forall d. Bool -> PassedArgs d -> Deriver [Track]
sub_tracks_ Bool
False

-- | Like 'sub_events', but exclude events at the start time, and include
-- events at the end time.  Presumably suitable for 'Event.Negative' calls.
sub_events_negative :: Derive.PassedArgs d -> Derive.Deriver [[SubT.Event]]
sub_events_negative :: forall d. PassedArgs d -> Deriver [[Event]]
sub_events_negative = forall d. Bool -> PassedArgs d -> Deriver [[Event]]
sub_events_ Bool
True

-- | Throw an exception if there are sub-events.
assert_no_subs :: Derive.PassedArgs d -> Derive.Deriver ()
assert_no_subs :: forall d. PassedArgs d -> Deriver ()
assert_no_subs PassedArgs d
args = do
    -- Due to laziness, checking null shouldn't require any actual slicing.
    [[Event]]
events <- forall d. PassedArgs d -> Deriver [[Event]]
sub_events PassedArgs d
args
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Event]]
events then forall (m :: * -> *) a. Monad m => a -> m a
return () else case forall val.
Context val -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Derive.ctx_sub_events Context d
ctx of
        Just [[(ScoreTime, ScoreTime, NoteDeriver)]]
subs -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"expected no sub events, but got "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (\(ScoreTime
s, ScoreTime
d, NoteDeriver
_) -> (ScoreTime
s, ScoreTime
d))) [[(ScoreTime, ScoreTime, NoteDeriver)]]
subs)
        Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Nothing -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"expected no sub events, but got "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Track -> (Text, Maybe TrackId)
extract_track) (forall val. Context val -> EventsTree
Derive.ctx_sub_tracks Context d
ctx))
    where
    ctx :: Context d
ctx = forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args
    extract_track :: Track -> (Text, Maybe TrackId)
extract_track Track
t = (Track -> Text
TrackTree.track_title Track
t, Track -> Maybe TrackId
TrackTree.track_id Track
t)

sub_events_ :: Bool -> Derive.PassedArgs d -> Derive.Deriver [[SubT.Event]]
sub_events_ :: forall d. Bool -> PassedArgs d -> Deriver [[Event]]
sub_events_ Bool
include_end PassedArgs d
args = forall a b. (a -> b) -> [a] -> [b]
map Track -> [Event]
SubT._events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall d. Bool -> PassedArgs d -> Deriver [Track]
sub_tracks_ Bool
include_end PassedArgs d
args

sub_tracks_ :: Bool -> Derive.PassedArgs d -> Derive.Deriver [SubT.Track]
sub_tracks_ :: forall d. Bool -> PassedArgs d -> Deriver [Track]
sub_tracks_ Bool
include_end PassedArgs d
args =
    case forall val.
Context val -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Derive.ctx_sub_events (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args) of
        Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Nothing -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => Text -> Deriver a
Derive.throw (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Track -> Maybe Track
mktrack) forall a b. (a -> b) -> a -> b
$
            Bool -> ScoreTime -> ScoreTime -> EventsTree -> Either Text [Track]
Slice.checked_slice_notes Bool
include_end ScoreTime
start ScoreTime
end forall a b. (a -> b) -> a -> b
$
                forall val. Context val -> EventsTree
Derive.ctx_sub_tracks (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args)
        Just [[(ScoreTime, ScoreTime, NoteDeriver)]]
tracks -> forall (m :: * -> *) a. Monad m => a -> m a
return
            [ Either Text TrackId -> [Event] -> Track
SubT.Track (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"subevent:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Integer
i) forall a b. (a -> b) -> a -> b
$
                forall a b. (a -> b) -> [a] -> [b]
map (\(ScoreTime
s, ScoreTime
d, NoteDeriver
n) -> forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
s ScoreTime
d NoteDeriver
n) [(ScoreTime, ScoreTime, NoteDeriver)]
track
            | (Integer
i, [(ScoreTime, ScoreTime, NoteDeriver)]
track) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [[(ScoreTime, ScoreTime, NoteDeriver)]]
tracks
            ]
    where
    mktrack :: Track -> Maybe Track
mktrack (Slice.Track Maybe TrackId
track_id [Note]
notes) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        -- 'TrackTree.track_id' can be Nothing.  Presumably this happens for
        -- a constructed block.
        Either Text TrackId -> [Event] -> Track
SubT.Track (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Text
"no-track-id") forall a b. b -> Either a b
Right Maybe TrackId
track_id)
            (forall a b. (a -> b) -> [a] -> [b]
map Note -> Event
mkevent [Note]
notes)
    (ScoreTime
start, ScoreTime
end) = forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs d
args
    -- The events have been shifted back to 0 by 'Slice.checked_slice_notes',
    -- but are still their original lengths.  Stretch them back to 1 so Events
    -- are normalized.
    mkevent :: Note -> Event
mkevent (ScoreTime
shift, ScoreTime
stretch, EventsTree
tree) = SubT.EventT
        { _start :: ScoreTime
_start = ScoreTime
shift
        , _duration :: ScoreTime
_duration = ScoreTime
stretch
        , _note :: NoteDeriver
_note = forall a. ScoreTime -> Deriver a -> Deriver a
Derive.stretch
            (if ScoreTime
stretch forall a. Eq a => a -> a -> Bool
== ScoreTime
0 then ScoreTime
1 else forall a. Fractional a => a -> a
recip ScoreTime
stretch)
            (EventsTree -> NoteDeriver
BlockUtil.derive_tracks EventsTree
tree)
        }

-- | Modify the text of sub note tracks before deriving them.  This can be
-- used to implement an ad-hoc new language.
modify_notes :: ([SubT.EventT Text] -> Either Text [SubT.EventT Text])
    -> Derive.PassedArgs a -> Either Text (Derive.PassedArgs a)
modify_notes :: forall a.
([EventT Text] -> Either Text [EventT Text])
-> PassedArgs a -> Either Text (PassedArgs a)
modify_notes [EventT Text] -> Either Text [EventT Text]
modify =
    forall a.
(EventsTree -> Either Text EventsTree)
-> PassedArgs a -> Either Text (PassedArgs a)
modify_sub_tracks forall a b. (a -> b) -> a -> b
$ (Events -> Either Text Events)
-> EventsTree -> Either Text EventsTree
modify_sub_notes (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [EventT Text] -> Events
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EventT Text] -> Either Text [EventT Text]
modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> [EventT Text]
from)
    where
    from :: Events -> [EventT Text]
from = forall a b. (a -> b) -> [a] -> [b]
map Event -> EventT Text
make forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> [Event]
Events.ascending
    make :: Event -> EventT Text
make Event
e = SubT.EventT
        { _start :: ScoreTime
_start = Event -> ScoreTime
Event.start Event
e
        , _duration :: ScoreTime
_duration = Event -> ScoreTime
Event.duration Event
e
        , _note :: Text
_note = Event -> Text
Event.text Event
e
        }
    to :: [EventT Text] -> Events
to = [Event] -> Events
Events.from_list
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(SubT.EventT ScoreTime
start ScoreTime
dur Text
text) -> ScoreTime -> ScoreTime -> Text -> Event
Event.event ScoreTime
start ScoreTime
dur Text
text)

modify_sub_notes :: (Events.Events -> Either Text Events.Events)
    -> TrackTree.EventsTree -> Either Text TrackTree.EventsTree
modify_sub_notes :: (Events -> Either Text Events)
-> EventsTree -> Either Text EventsTree
modify_sub_notes Events -> Either Text Events
modify = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ \Track
track ->
    if Text -> Bool
ParseTitle.is_note_track (Track -> Text
TrackTree.track_title Track
track)
        then do
            Events
events <- Events -> Either Text Events
modify (Track -> Events
TrackTree.track_events Track
track)
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Track
track { track_events :: Events
TrackTree.track_events = Events
events }
        else forall a b. b -> Either a b
Right Track
track

modify_sub_tracks :: (TrackTree.EventsTree -> Either Text TrackTree.EventsTree)
    -> Derive.PassedArgs a -> Either Text (Derive.PassedArgs a)
modify_sub_tracks :: forall a.
(EventsTree -> Either Text EventsTree)
-> PassedArgs a -> Either Text (PassedArgs a)
modify_sub_tracks EventsTree -> Either Text EventsTree
modify PassedArgs a
args = do
    EventsTree
tracks <- EventsTree -> Either Text EventsTree
modify forall a b. (a -> b) -> a -> b
$ forall val. Context val -> EventsTree
Derive.ctx_sub_tracks (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs a
args)
    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PassedArgs a
args
        { passed_ctx :: Context a
Derive.passed_ctx = (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs a
args)
            { ctx_sub_tracks :: EventsTree
Derive.ctx_sub_tracks = EventsTree
tracks }
        }

derive_subs :: Derive.PassedArgs d -> Derive.NoteDeriver
derive_subs :: forall d. PassedArgs d -> NoteDeriver
derive_subs = [[Event]] -> NoteDeriver
derive_tracks forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall d. PassedArgs d -> Deriver [[Event]]
sub_events

-- | Derive and merge Events.
derive :: [SubT.Event] -> Derive.NoteDeriver
derive :: [Event] -> NoteDeriver
derive = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (\(SubT.EventT ScoreTime
s ScoreTime
d NoteDeriver
n) -> forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
s ScoreTime
d NoteDeriver
n)

derive_tracks :: [[SubT.Event]] -> Derive.NoteDeriver
derive_tracks :: [[Event]] -> NoteDeriver
derive_tracks = [Event] -> NoteDeriver
derive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Lists.mergeLists forall a. EventT a -> ScoreTime
SubT._start

-- | Get the pitch of an Event.  Useful for debugging.
derive_pitch :: SubT.Event -> Derive.Deriver (SubT.EventT (Maybe Pitch.Note))
derive_pitch :: Event -> Deriver (EventT (Maybe Note))
derive_pitch Event
event = do
    Stream Event
stream <- forall a. EventT a -> a
SubT._note Event
event
    let note :: Maybe Note
note = Event -> Maybe Note
Score.initial_note forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. [a] -> Maybe a
Lists.head (forall a. Stream a -> [a]
Stream.events_of Stream Event
stream)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Event
event { _note :: Maybe Note
SubT._note = Maybe Note
note }

-- | Re-fit the events from one range to another.
fit :: (ScoreTime, ScoreTime) -- ^ fit this range
    -> (ScoreTime, ScoreTime) -- ^ into this range
    -> [SubT.Event] -> Derive.NoteDeriver
fit :: (ScoreTime, ScoreTime)
-> (ScoreTime, ScoreTime) -> [Event] -> NoteDeriver
fit (ScoreTime
from_start, ScoreTime
from_end) (ScoreTime
to_start, ScoreTime
to_end) [Event]
events =
    forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
to_start ScoreTime
factor forall a b. (a -> b) -> a -> b
$ [Event] -> NoteDeriver
derive
        [Event
e { _start :: ScoreTime
SubT._start = forall a. EventT a -> ScoreTime
SubT._start Event
e forall a. Num a => a -> a -> a
- ScoreTime
from_start } | Event
e <- [Event]
events]
    -- Subtract from_start because Derive.place is going to add the start back
    -- on again in the form of to_start.
    where factor :: ScoreTime
factor = (ScoreTime
to_end forall a. Num a => a -> a -> a
- ScoreTime
to_start) forall a. Fractional a => a -> a -> a
/ (ScoreTime
from_end forall a. Num a => a -> a -> a
- ScoreTime
from_start)

-- ** RestEvent

-- | A Nothing represents a rest.
type RestEvent = SubT.EventT (Maybe Derive.NoteDeriver)

-- | This is like 'sub_events', but gaps between the events are returned as
-- explicit rests.
sub_rest_events :: Bool -- ^ end bias
    -> Bool -- ^ if True, include the trailing gap as a rest
    -> Derive.PassedArgs d -> Derive.Deriver [[RestEvent]]
sub_rest_events :: forall d. Bool -> Bool -> PassedArgs d -> Deriver [[RestEvent]]
sub_rest_events Bool
include_end Bool
want_final_rest PassedArgs d
args =
    forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a.
Bool -> ScoreTime -> ScoreTime -> [EventT a] -> [EventT (Maybe a)]
find_gaps Bool
want_final_rest) (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs d
args)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall d. Bool -> PassedArgs d -> Deriver [[Event]]
sub_events_ Bool
include_end PassedArgs d
args

find_gaps :: Bool -> ScoreTime -> ScoreTime -> [SubT.EventT a]
    -> [SubT.EventT (Maybe a)]
find_gaps :: forall a.
Bool -> ScoreTime -> ScoreTime -> [EventT a] -> [EventT (Maybe a)]
find_gaps Bool
want_final_rest ScoreTime
start ScoreTime
end (EventT a
event : [EventT a]
events)
    | ScoreTime
gap forall a. Ord a => a -> a -> Bool
> ScoreTime
0 = forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
start ScoreTime
gap forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: [EventT (Maybe a)]
rest
    | Bool
otherwise = [EventT (Maybe a)]
rest
    where
    gap :: ScoreTime
gap = forall a. EventT a -> ScoreTime
SubT._start EventT a
event forall a. Num a => a -> a -> a
- ScoreTime
start
    rest :: [EventT (Maybe a)]
rest = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventT a
event)
        forall a. a -> [a] -> [a]
: forall a.
Bool -> ScoreTime -> ScoreTime -> [EventT a] -> [EventT (Maybe a)]
find_gaps Bool
want_final_rest (forall a. EventT a -> ScoreTime
SubT.end EventT a
event) ScoreTime
end [EventT a]
events
find_gaps Bool
want_final_rest ScoreTime
start ScoreTime
end []
    | Bool
want_final_rest Bool -> Bool -> Bool
&& ScoreTime
start forall a. Ord a => a -> a -> Bool
< ScoreTime
end = [forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
start (ScoreTime
endforall a. Num a => a -> a -> a
-ScoreTime
start) forall a. Maybe a
Nothing]
    | Bool
otherwise = []

-- | 'fit' for 'RestEvent's.
fit_rests :: (ScoreTime, ScoreTime) -> (ScoreTime, ScoreTime)
    -> [RestEvent] -> Derive.NoteDeriver
fit_rests :: (ScoreTime, ScoreTime)
-> (ScoreTime, ScoreTime) -> [RestEvent] -> NoteDeriver
fit_rests (ScoreTime
from_start, ScoreTime
from_end) (ScoreTime
to_start, ScoreTime
to_end) [RestEvent]
events =
    forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
to_start ScoreTime
factor forall a b. (a -> b) -> a -> b
$
        [Event] -> NoteDeriver
derive [Event
e { _start :: ScoreTime
SubT._start = forall a. EventT a -> ScoreTime
SubT._start Event
e forall a. Num a => a -> a -> a
- ScoreTime
from_start } |
            Event
e <- [RestEvent] -> [Event]
strip_rests [RestEvent]
events]
    where factor :: ScoreTime
factor = (ScoreTime
to_end forall a. Num a => a -> a -> a
- ScoreTime
to_start) forall a. Fractional a => a -> a -> a
/ (ScoreTime
from_end forall a. Num a => a -> a -> a
- ScoreTime
from_start)

strip_rests :: [RestEvent] -> [SubT.Event]
strip_rests :: [RestEvent] -> [Event]
strip_rests [RestEvent]
events = [forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
s ScoreTime
d NoteDeriver
n | SubT.EventT ScoreTime
s ScoreTime
d (Just NoteDeriver
n) <- [RestEvent]
events]

-- * reapply

-- | Call a note parent with sub-events.  While you can easily call other
-- kinds of calls with 'Eval.reapply', note parents are more tricky
-- because they expect a track structure in 'Derive.ctx_sub_tracks'.  This
-- bypasses that and directly passes 'SubT.EventT's to the note parent,
-- courtesy of 'Derive.ctx_sub_events'.
reapply :: Derive.Context Score.Event -> DeriveT.Expr -> [[SubT.Event]]
    -> Derive.NoteDeriver
reapply :: Context Event -> Expr -> [[Event]] -> NoteDeriver
reapply Context Event
ctx Expr
expr [[Event]]
notes = forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
Eval.reapply Context Event
subs Expr
expr
    where
    subs :: Context Event
subs = Context Event
ctx
        { ctx_sub_events :: Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Derive.ctx_sub_events =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (\(SubT.EventT ScoreTime
s ScoreTime
d NoteDeriver
n) -> (ScoreTime
s, ScoreTime
d, NoteDeriver
n))) [[Event]]
notes
        }

reapply_call :: Derive.Context Score.Event -> Expr.Symbol
    -> [DeriveT.Term] -> [[SubT.Event]] -> Derive.NoteDeriver
reapply_call :: Context Event -> Symbol -> [Term] -> [[Event]] -> NoteDeriver
reapply_call Context Event
ctx Symbol
sym [Term]
call_args =
    Context Event -> Expr -> [[Event]] -> NoteDeriver
reapply Context Event
ctx forall a b. (a -> b) -> a -> b
$ forall val. Call val -> Expr val
Expr.generator forall a b. (a -> b) -> a -> b
$ forall val. Symbol -> [Term val] -> Call val
Expr.Call Symbol
sym [Term]
call_args

{- NOTE [under-invert]
    . To make 'lift' to an absolute pitch work outside of inversion, I'd need
      an abstract way (e.g. like a transpose signal) to say "pitch midway to
      (4c)"
    . It's better to have the lift under the pitch.  The only reason it isn't
      is that inversion assumes all transformers go above.  So either make it
      a generator (at which point it can't compose), or have some way to put
      transformers under the inversion, e.g. 'delay | Drop $ lift $ gen' under
      inversion is 'delay' -> 'Drop' 'lift' 'gen'.
    . Another way would be to put that in the call itself, so 'lift' has a flag
      that says it likes to be under the inversion.  Then the invert function
      has to go look all those up.  But that can't work, because invert is
      called by a generator, and that's too late.
    . So call all the transformers pre and post invert.  Normally they check
      if they're under inversion, and if so do nothing, but ones that would
      rather be inverted do the inverse.

    Cons:
      1. Instead of transformers always happening before inversion, they can
      now vary internally, which is one more subtle thing about inversion.
      I'll need to expose it in documentation at least, via a tag.

      2. Call stacks get even messier in the presence of inversion, since
      every transformer appears twice.

      3. Transformers can have their order change, e.g. given
      'below | above | gen', below is actually called below above, if it
      wants to be under inversion.

    . It seems like I could improve these by driving them from a tag.  E.g.
      if the call has a under-inversion tag, Call.eval_transformers will skip
      or not skip, as appropriate.  This solves #1 and #2, but not #3.

    . This is all just to get lift working under inversion.  Is it that
      important?
      . Everything should work under inversion.  It's a hassle to suddenly
        have to rearrange the pitch track, and now 'd' doesn't work.
      . This will come up for every note transformer that wants to know the
        pitch.
-}