-- 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.Seq as Seq
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
    | [EventsNode] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([EventsNode] -> Bool) -> [EventsNode] -> Bool
forall a b. (a -> b) -> a -> b
$ Context Event -> [EventsNode]
forall val. Context val -> [EventsNode]
Derive.ctx_sub_tracks (Context Event -> [EventsNode]) -> Context Event -> [EventsNode]
forall a b. (a -> b) -> a -> b
$ NoteArgs -> Context Event
forall val. PassedArgs val -> Context val
Derive.passed_ctx NoteArgs
args =
        NoteArgs -> NoteDeriver -> NoteDeriver
transformer NoteArgs
args NoteDeriver
deriver
    | Bool
otherwise = NoteDeriver -> NoteDeriver
forall {a}. Deriver a -> Deriver a
with NoteDeriver
deriver
    where
    with :: Deriver a -> Deriver a
with = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
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 (NoteDeriver -> NoteDeriver)
-> (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
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 <- (Dynamic -> Dynamic) -> Deriver Dynamic
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Dynamic
forall a. a -> a
id
    case (Dynamic -> Inversion
Derive.state_inversion Dynamic
dyn, Context d -> [EventsNode]
forall val. Context val -> [EventsNode]
Derive.ctx_sub_tracks Context d
ctx) of
        (Derive.InversionInProgress {}, [EventsNode]
_) ->
            Text -> NoteDeriver
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"tried to invert while inverting"
        (Inversion
Derive.NotInverted, subs :: [EventsNode]
subs@(EventsNode
_:[EventsNode]
_)) -> do
            [EventsNode]
sliced <- [EventsNode]
-> Event -> ScoreTime -> ([Event], [Event]) -> Deriver [EventsNode]
invert [EventsNode]
subs Event
event (PassedArgs d -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.next PassedArgs d
args)
                (Context d -> [Event]
forall val. Context val -> [Event]
Derive.ctx_prev_events Context d
ctx, Context d -> [Event]
forall val. Context val -> [Event]
Derive.ctx_next_events Context d
ctx)
            NoteDeriver -> NoteDeriver
forall {a}. Deriver a -> Deriver a
with_inversion (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ [EventsNode] -> NoteDeriver
BlockUtil.derive_tracks [EventsNode]
sliced
        (Inversion
Derive.NotInverted, []) -> NoteDeriver
call
    where
    with_inversion :: Deriver a -> Deriver a
with_inversion = (Dynamic -> Dynamic) -> Deriver a -> Deriver a
forall a. (Dynamic -> Dynamic) -> Deriver a -> Deriver a
Internal.local ((Dynamic -> Dynamic) -> Deriver a -> Deriver a)
-> (Dynamic -> Dynamic) -> Deriver a -> Deriver a
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 = Context d -> Event
forall val. Context val -> Event
Derive.ctx_event Context d
ctx
    ctx :: Context d
ctx = PassedArgs d -> Context d
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 = PassedArgs d -> NoteDeriver -> NoteDeriver
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 = (PassedArgs d -> Context d
forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args)
            { ctx_sub_tracks :: [EventsNode]
Derive.ctx_sub_tracks = [EventsNode]
forall a. Monoid a => a
mempty
            , ctx_sub_events :: Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Derive.ctx_sub_events = Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
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 = ((PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver)
-> PassedArgs d -> (PassedArgs d -> NoteDeriver) -> NoteDeriver
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
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 PassedArgs a -> Maybe a
forall a. PassedArgs a -> Maybe a
Args.prev_val PassedArgs a
args of
    Maybe a
Nothing -> () -> Deriver ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just a
val -> Stack -> Maybe (BlockId, TrackId)
Stack.block_track_of (Stack -> Maybe (BlockId, TrackId))
-> Deriver State Error Stack
-> Deriver State Error (Maybe (BlockId, TrackId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error Stack
Internal.get_stack Deriver State Error (Maybe (BlockId, TrackId))
-> (Maybe (BlockId, TrackId) -> Deriver ()) -> Deriver ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (BlockId, TrackId)
Nothing -> () -> Deriver ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (BlockId, TrackId)
block_track -> (Threaded -> Threaded) -> Deriver ()
forall {err}. (Threaded -> Threaded) -> Deriver State err ()
modify_threaded ((Threaded -> Threaded) -> Deriver ())
-> (Threaded -> Threaded) -> Deriver ()
forall a b. (a -> b) -> a -> b
$ \Threaded
th -> Threaded
th
            { state_prev_val :: Map (BlockId, TrackId) Tagged
Derive.state_prev_val = (BlockId, TrackId)
-> Tagged
-> Map (BlockId, TrackId) Tagged
-> Map (BlockId, TrackId) Tagged
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (BlockId, TrackId)
block_track
                (a -> Tagged
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 = (State -> State) -> Deriver State err ()
forall st err. (st -> st) -> Deriver st err ()
Derive.modify ((State -> State) -> Deriver State err ())
-> (State -> State) -> Deriver State err ()
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 :: [EventsNode]
-> Event -> ScoreTime -> ([Event], [Event]) -> Deriver [EventsNode]
invert [EventsNode]
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 :: [EventsNode]
sliced = Maybe TrackId -> [EventsNode]
slice Maybe TrackId
track_id
    Maybe Track -> (Track -> Deriver ()) -> Deriver ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([EventsNode] -> Maybe Track
non_bottom_note_track [EventsNode]
sliced) ((Track -> Deriver ()) -> Deriver ())
-> (Track -> Deriver ()) -> Deriver ()
forall a b. (a -> b) -> a -> b
$ \Track
track -> Text -> Deriver ()
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver ()) -> Text -> Deriver ()
forall a b. (a -> b) -> a -> b
$
        Text
"inverting below a note track will lead to an endless loop: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe TrackId -> Text
forall a. Pretty a => a -> Text
pretty (Track -> Maybe TrackId
TrackTree.track_id Track
track)
    [EventsNode] -> Deriver [EventsNode]
forall (m :: * -> *) a. Monad m => a -> m a
return [EventsNode]
sliced
    where
    slice :: Maybe TrackId -> [EventsNode]
slice Maybe TrackId
track_id =
        (EventsNode -> EventsNode) -> [EventsNode] -> [EventsNode]
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
            (InsertEvent -> Maybe InsertEvent
forall a. a -> Maybe a
Just (Maybe TrackId -> InsertEvent
insert Maybe TrackId
track_id))) [EventsNode]
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 = [TrackId] -> Maybe TrackId
forall a. [a] -> Maybe a
Seq.head ([TrackId] -> Maybe TrackId)
-> (Stack -> [TrackId]) -> Stack -> Maybe TrackId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Frame -> Maybe TrackId) -> [Frame] -> [TrackId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Frame -> Maybe TrackId
Stack.track_of ([Frame] -> [TrackId]) -> (Stack -> [Frame]) -> Stack -> [TrackId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
Stack.innermost
    (Stack -> Maybe TrackId)
-> Deriver State Error Stack -> Deriver (Maybe TrackId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error 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 :: [EventsNode] -> Maybe Track
non_bottom_note_track [EventsNode]
tree = [Track] -> Maybe Track
forall a. [a] -> Maybe a
Seq.head ((EventsNode -> [Track]) -> [EventsNode] -> [Track]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventsNode -> [Track]
go [EventsNode]
tree)
    where
    go :: EventsNode -> [Track]
go (Tree.Node Track
track [EventsNode]
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 ([EventsNode] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EventsNode]
subs) = [Track
track]
        | Bool
otherwise = (EventsNode -> [Track]) -> [EventsNode] -> [Track]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventsNode -> [Track]
go [EventsNode]
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 = Bool -> PassedArgs d -> Deriver [[Event]]
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 = Bool -> PassedArgs d -> Deriver [Track]
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 = Bool -> PassedArgs d -> Deriver [[Event]]
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 <- PassedArgs d -> Deriver [[Event]]
forall d. PassedArgs d -> Deriver [[Event]]
sub_events PassedArgs d
args
    if [[Event]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Event]]
events then () -> Deriver ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else case Context d -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
forall val.
Context val -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Derive.ctx_sub_events Context d
ctx of
        Just [[(ScoreTime, ScoreTime, NoteDeriver)]]
subs -> Text -> Deriver ()
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver ()) -> Text -> Deriver ()
forall a b. (a -> b) -> a -> b
$ Text
"expected no sub events, but got "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [[(ScoreTime, ScoreTime)]] -> Text
forall a. Pretty a => a -> Text
pretty (([(ScoreTime, ScoreTime, NoteDeriver)] -> [(ScoreTime, ScoreTime)])
-> [[(ScoreTime, ScoreTime, NoteDeriver)]]
-> [[(ScoreTime, ScoreTime)]]
forall a b. (a -> b) -> [a] -> [b]
map (((ScoreTime, ScoreTime, NoteDeriver) -> (ScoreTime, ScoreTime))
-> [(ScoreTime, ScoreTime, NoteDeriver)]
-> [(ScoreTime, ScoreTime)]
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 -> Text -> Deriver ()
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver ()) -> Text -> Deriver ()
forall a b. (a -> b) -> a -> b
$ Text
"expected no sub events, but got "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Tree (Text, Maybe TrackId)] -> Text
forall a. Pretty a => a -> Text
pretty ((EventsNode -> Tree (Text, Maybe TrackId))
-> [EventsNode] -> [Tree (Text, Maybe TrackId)]
forall a b. (a -> b) -> [a] -> [b]
map ((Track -> (Text, Maybe TrackId))
-> EventsNode -> Tree (Text, Maybe TrackId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Track -> (Text, Maybe TrackId)
extract_track) (Context d -> [EventsNode]
forall val. Context val -> [EventsNode]
Derive.ctx_sub_tracks Context d
ctx))
    where
    ctx :: Context d
ctx = PassedArgs d -> Context d
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 = (Track -> [Event]) -> [Track] -> [[Event]]
forall a b. (a -> b) -> [a] -> [b]
map Track -> [Event]
SubT._events ([Track] -> [[Event]]) -> Deriver [Track] -> Deriver [[Event]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> PassedArgs d -> Deriver [Track]
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 Context d -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
forall val.
Context val -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Derive.ctx_sub_events (PassedArgs d -> Context d
forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args) of
        Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
Nothing -> (Text -> Deriver [Track])
-> ([Track] -> Deriver [Track])
-> Either Text [Track]
-> Deriver [Track]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Deriver [Track]
forall a. HasCallStack => Text -> Deriver a
Derive.throw ([Track] -> Deriver [Track]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Track] -> Deriver [Track])
-> ([Track] -> [Track]) -> [Track] -> Deriver [Track]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Track -> Maybe Track) -> [Track] -> [Track]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Track -> Maybe Track
mktrack) (Either Text [Track] -> Deriver [Track])
-> Either Text [Track] -> Deriver [Track]
forall a b. (a -> b) -> a -> b
$
            Bool
-> ScoreTime -> ScoreTime -> [EventsNode] -> Either Text [Track]
Slice.checked_slice_notes Bool
include_end ScoreTime
start ScoreTime
end ([EventsNode] -> Either Text [Track])
-> [EventsNode] -> Either Text [Track]
forall a b. (a -> b) -> a -> b
$
                Context d -> [EventsNode]
forall val. Context val -> [EventsNode]
Derive.ctx_sub_tracks (PassedArgs d -> Context d
forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args)
        Just [[(ScoreTime, ScoreTime, NoteDeriver)]]
tracks -> [Track] -> Deriver [Track]
forall (m :: * -> *) a. Monad m => a -> m a
return
            [ Either Text TrackId -> [Event] -> Track
SubT.Track (Text -> Either Text TrackId
forall a b. a -> Either a b
Left (Text -> Either Text TrackId) -> Text -> Either Text TrackId
forall a b. (a -> b) -> a -> b
$ Text
"subevent:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Show a => a -> Text
showt Integer
i) ([Event] -> Track) -> [Event] -> Track
forall a b. (a -> b) -> a -> b
$
                ((ScoreTime, ScoreTime, NoteDeriver) -> Event)
-> [(ScoreTime, ScoreTime, NoteDeriver)] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map (\(ScoreTime
s, ScoreTime
d, NoteDeriver
n) -> ScoreTime -> ScoreTime -> NoteDeriver -> Event
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) <- [Integer]
-> [[(ScoreTime, ScoreTime, NoteDeriver)]]
-> [(Integer, [(ScoreTime, ScoreTime, NoteDeriver)])]
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) = Track -> Maybe Track
forall a. a -> Maybe a
Just (Track -> Maybe Track) -> Track -> Maybe Track
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 (Either Text TrackId
-> (TrackId -> Either Text TrackId)
-> Maybe TrackId
-> Either Text TrackId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text TrackId
forall a b. a -> Either a b
Left Text
"no-track-id") TrackId -> Either Text TrackId
forall a b. b -> Either a b
Right Maybe TrackId
track_id)
            ((Note -> Event) -> [Note] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map Note -> Event
mkevent [Note]
notes)
    (ScoreTime
start, ScoreTime
end) = PassedArgs d -> (ScoreTime, ScoreTime)
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, [EventsNode]
tree) = SubT.EventT
        { _start :: ScoreTime
_start = ScoreTime
shift
        , _duration :: ScoreTime
_duration = ScoreTime
stretch
        , _note :: NoteDeriver
_note = ScoreTime -> NoteDeriver -> NoteDeriver
forall a. ScoreTime -> Deriver a -> Deriver a
Derive.stretch
            (if ScoreTime
stretch ScoreTime -> ScoreTime -> Bool
forall a. Eq a => a -> a -> Bool
== ScoreTime
0 then ScoreTime
1 else ScoreTime -> ScoreTime
forall a. Fractional a => a -> a
recip ScoreTime
stretch)
            ([EventsNode] -> NoteDeriver
BlockUtil.derive_tracks [EventsNode]
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 =
    ([EventsNode] -> Either Text [EventsNode])
-> PassedArgs a -> Either Text (PassedArgs a)
forall a.
([EventsNode] -> Either Text [EventsNode])
-> PassedArgs a -> Either Text (PassedArgs a)
modify_sub_tracks (([EventsNode] -> Either Text [EventsNode])
 -> PassedArgs a -> Either Text (PassedArgs a))
-> ([EventsNode] -> Either Text [EventsNode])
-> PassedArgs a
-> Either Text (PassedArgs a)
forall a b. (a -> b) -> a -> b
$ (Events -> Either Text Events)
-> [EventsNode] -> Either Text [EventsNode]
modify_sub_notes (([EventT Text] -> Events)
-> Either Text [EventT Text] -> Either Text Events
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [EventT Text] -> Events
to (Either Text [EventT Text] -> Either Text Events)
-> (Events -> Either Text [EventT Text])
-> Events
-> Either Text Events
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EventT Text] -> Either Text [EventT Text]
modify ([EventT Text] -> Either Text [EventT Text])
-> (Events -> [EventT Text]) -> Events -> Either Text [EventT Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> [EventT Text]
from)
    where
    from :: Events -> [EventT Text]
from = (Event -> EventT Text) -> [Event] -> [EventT Text]
forall a b. (a -> b) -> [a] -> [b]
map Event -> EventT Text
make ([Event] -> [EventT Text])
-> (Events -> [Event]) -> Events -> [EventT Text]
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
        ([Event] -> Events)
-> ([EventT Text] -> [Event]) -> [EventT Text] -> Events
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EventT Text -> Event) -> [EventT Text] -> [Event]
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)
-> [EventsNode] -> Either Text [EventsNode]
modify_sub_notes Events -> Either Text Events
modify = (EventsNode -> Either Text EventsNode)
-> [EventsNode] -> Either Text [EventsNode]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((EventsNode -> Either Text EventsNode)
 -> [EventsNode] -> Either Text [EventsNode])
-> (EventsNode -> Either Text EventsNode)
-> [EventsNode]
-> Either Text [EventsNode]
forall a b. (a -> b) -> a -> b
$ (Track -> Either Text Track)
-> EventsNode -> Either Text EventsNode
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Track -> Either Text Track)
 -> EventsNode -> Either Text EventsNode)
-> (Track -> Either Text Track)
-> EventsNode
-> Either Text EventsNode
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)
            Track -> Either Text Track
forall a b. b -> Either a b
Right (Track -> Either Text Track) -> Track -> Either Text Track
forall a b. (a -> b) -> a -> b
$ Track
track { track_events :: Events
TrackTree.track_events = Events
events }
        else Track -> Either Text Track
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.
([EventsNode] -> Either Text [EventsNode])
-> PassedArgs a -> Either Text (PassedArgs a)
modify_sub_tracks [EventsNode] -> Either Text [EventsNode]
modify PassedArgs a
args = do
    [EventsNode]
tracks <- [EventsNode] -> Either Text [EventsNode]
modify ([EventsNode] -> Either Text [EventsNode])
-> [EventsNode] -> Either Text [EventsNode]
forall a b. (a -> b) -> a -> b
$ Context a -> [EventsNode]
forall val. Context val -> [EventsNode]
Derive.ctx_sub_tracks (PassedArgs a -> Context a
forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs a
args)
    PassedArgs a -> Either Text (PassedArgs a)
forall a b. b -> Either a b
Right (PassedArgs a -> Either Text (PassedArgs a))
-> PassedArgs a -> Either Text (PassedArgs a)
forall a b. (a -> b) -> a -> b
$ PassedArgs a
args
        { passed_ctx :: Context a
Derive.passed_ctx = (PassedArgs a -> Context a
forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs a
args)
            { ctx_sub_tracks :: [EventsNode]
Derive.ctx_sub_tracks = [EventsNode]
tracks }
        }

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

-- | Derive and merge Events.
derive :: [SubT.Event] -> Derive.NoteDeriver
derive :: [Event] -> NoteDeriver
derive = (Event -> NoteDeriver) -> [Event] -> NoteDeriver
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (\(SubT.EventT ScoreTime
s ScoreTime
d NoteDeriver
n) -> ScoreTime -> ScoreTime -> NoteDeriver -> NoteDeriver
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 ([Event] -> NoteDeriver)
-> ([[Event]] -> [Event]) -> [[Event]] -> NoteDeriver
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> ScoreTime) -> [[Event]] -> [Event]
forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Seq.merge_lists Event -> ScoreTime
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 <- Event -> NoteDeriver
forall a. EventT a -> a
SubT._note Event
event
    let note :: Maybe Note
note = Event -> Maybe Note
Score.initial_note (Event -> Maybe Note) -> Maybe Event -> Maybe Note
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head (Stream Event -> [Event]
forall a. Stream a -> [a]
Stream.events_of Stream Event
stream)
    EventT (Maybe Note) -> Deriver (EventT (Maybe Note))
forall (m :: * -> *) a. Monad m => a -> m a
return (EventT (Maybe Note) -> Deriver (EventT (Maybe Note)))
-> EventT (Maybe Note) -> Deriver (EventT (Maybe Note))
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 =
    ScoreTime -> ScoreTime -> NoteDeriver -> NoteDeriver
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
to_start ScoreTime
factor (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ [Event] -> NoteDeriver
derive
        [Event
e { _start :: ScoreTime
SubT._start = Event -> ScoreTime
forall a. EventT a -> ScoreTime
SubT._start Event
e ScoreTime -> ScoreTime -> ScoreTime
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 ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
to_start) ScoreTime -> ScoreTime -> ScoreTime
forall a. Fractional a => a -> a -> a
/ (ScoreTime
from_end ScoreTime -> ScoreTime -> ScoreTime
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 =
    ([Event] -> [RestEvent]) -> [[Event]] -> [[RestEvent]]
forall a b. (a -> b) -> [a] -> [b]
map ((ScoreTime -> ScoreTime -> [Event] -> [RestEvent])
-> (ScoreTime, ScoreTime) -> [Event] -> [RestEvent]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Bool -> ScoreTime -> ScoreTime -> [Event] -> [RestEvent]
forall a.
Bool -> ScoreTime -> ScoreTime -> [EventT a] -> [EventT (Maybe a)]
find_gaps Bool
want_final_rest) (PassedArgs d -> (ScoreTime, ScoreTime)
forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs d
args)) ([[Event]] -> [[RestEvent]])
-> Deriver [[Event]] -> Deriver [[RestEvent]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool -> PassedArgs d -> Deriver [[Event]]
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 ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
> ScoreTime
0 = ScoreTime -> ScoreTime -> Maybe a -> EventT (Maybe a)
forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
start ScoreTime
gap Maybe a
forall a. Maybe a
Nothing EventT (Maybe a) -> [EventT (Maybe a)] -> [EventT (Maybe a)]
forall a. a -> [a] -> [a]
: [EventT (Maybe a)]
rest
    | Bool
otherwise = [EventT (Maybe a)]
rest
    where
    gap :: ScoreTime
gap = EventT a -> ScoreTime
forall a. EventT a -> ScoreTime
SubT._start EventT a
event ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
start
    rest :: [EventT (Maybe a)]
rest = (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> EventT a -> EventT (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventT a
event)
        EventT (Maybe a) -> [EventT (Maybe a)] -> [EventT (Maybe a)]
forall a. a -> [a] -> [a]
: Bool -> ScoreTime -> ScoreTime -> [EventT a] -> [EventT (Maybe a)]
forall a.
Bool -> ScoreTime -> ScoreTime -> [EventT a] -> [EventT (Maybe a)]
find_gaps Bool
want_final_rest (EventT a -> ScoreTime
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 ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
< ScoreTime
end = [ScoreTime -> ScoreTime -> Maybe a -> EventT (Maybe a)
forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
start (ScoreTime
endScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
-ScoreTime
start) Maybe a
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 =
    ScoreTime -> ScoreTime -> NoteDeriver -> NoteDeriver
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
to_start ScoreTime
factor (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
        [Event] -> NoteDeriver
derive [Event
e { _start :: ScoreTime
SubT._start = Event -> ScoreTime
forall a. EventT a -> ScoreTime
SubT._start Event
e ScoreTime -> ScoreTime -> ScoreTime
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 ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
to_start) ScoreTime -> ScoreTime -> ScoreTime
forall a. Fractional a => a -> a -> a
/ (ScoreTime
from_end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
from_start)

strip_rests :: [RestEvent] -> [SubT.Event]
strip_rests :: [RestEvent] -> [Event]
strip_rests [RestEvent]
events = [ScoreTime -> ScoreTime -> NoteDeriver -> Event
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 = Context Event -> Expr -> NoteDeriver
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 =
            [[(ScoreTime, ScoreTime, NoteDeriver)]]
-> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
forall a. a -> Maybe a
Just ([[(ScoreTime, ScoreTime, NoteDeriver)]]
 -> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]])
-> [[(ScoreTime, ScoreTime, NoteDeriver)]]
-> Maybe [[(ScoreTime, ScoreTime, NoteDeriver)]]
forall a b. (a -> b) -> a -> b
$ ([Event] -> [(ScoreTime, ScoreTime, NoteDeriver)])
-> [[Event]] -> [[(ScoreTime, ScoreTime, NoteDeriver)]]
forall a b. (a -> b) -> [a] -> [b]
map ((Event -> (ScoreTime, ScoreTime, NoteDeriver))
-> [Event] -> [(ScoreTime, ScoreTime, NoteDeriver)]
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 (Expr -> [[Event]] -> NoteDeriver)
-> Expr -> [[Event]] -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Call Val -> Expr
forall val. Call val -> Expr val
Expr.generator (Call Val -> Expr) -> Call Val -> Expr
forall a b. (a -> b) -> a -> b
$ Symbol -> [Term] -> Call Val
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.
-}