-- 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 TypeSynonymInstances #-}
-- | Extract things from the PassedArgs data structure.
module Derive.Args where
import qualified Data.Map as Map

import qualified Util.Log as Log
import qualified Util.Seq as Seq
import qualified Derive.Derive as Derive
import           Derive.Derive (Context, PassedArgs)
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.PSignal as PSignal
import qualified Derive.Parse as Parse
import qualified Derive.Pitches as Pitches
import qualified Derive.Score as Score
import qualified Derive.Stream as Stream

import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal

import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Track as Track
import qualified Ui.Types as Types

import           Global
import           Types


context :: PassedArgs a -> Context a
context :: forall a. PassedArgs a -> Context a
context = PassedArgs a -> Context a
forall a. PassedArgs a -> Context a
Derive.passed_ctx

event :: PassedArgs a -> Event.Event
event :: forall a. PassedArgs a -> Event
event = Context a -> Event
forall val. Context val -> Event
Derive.ctx_event (Context a -> Event)
-> (PassedArgs a -> Context a) -> PassedArgs a -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Context a
forall a. PassedArgs a -> Context a
context

orientation :: PassedArgs a -> Types.Orientation
orientation :: forall a. PassedArgs a -> Orientation
orientation = Event -> Orientation
Event.orientation (Event -> Orientation)
-> (PassedArgs a -> Event) -> PassedArgs a -> Orientation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Event
forall a. PassedArgs a -> Event
event

negative :: PassedArgs a -> Bool
negative :: forall a. PassedArgs a -> Bool
negative = (Orientation -> Orientation -> Bool
forall a. Eq a => a -> a -> Bool
==Orientation
Types.Negative) (Orientation -> Bool)
-> (PassedArgs a -> Orientation) -> PassedArgs a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Orientation
forall a. PassedArgs a -> Orientation
orientation

-- * prev and next

{- NOTE [previous-pitch]
    There are many ways to get the previous pitch:

    'prev_pitch' - The simplest, it uses 'Derive.ctx_prev_val', so it only
    works when you are in a pitch track, and only gets the immediately previous
    pitch.  A special hack should make it work even if the pitch track is
    inverted and the previous pitch is in a different slice.

    'prev_event_pitch' - This is like 'prev_pitch', except that it works at
    the note track level.  It gets the entire previous event and picks out the
    last pitch it played.

    'lookup_prev_pitch' - This uses 'Derive.state_note_track', which means that
    it should work even in an inversion under a note track.

    'lookup_prev_logical_pitch' - This is actually an entirely different
    mechanism than the others.  Documented in 'Derive.NotePitchQuery'.

    Clearly this is too many.  Probably I can come up with a way to combine the
    first three.
-}

-- ** from 'Derive.ctx_prev_val'

prev_control :: Derive.ControlArgs -> Maybe (RealTime, Signal.Y)
prev_control :: ControlArgs -> Maybe (RealTime, Y)
prev_control = Signal ControlSig -> Maybe (RealTime, Y)
forall {k} (kind :: k). Signal kind -> Maybe (RealTime, Y)
Signal.last (Signal ControlSig -> Maybe (RealTime, Y))
-> (ControlArgs -> Maybe (Signal ControlSig))
-> ControlArgs
-> Maybe (RealTime, Y)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ControlArgs -> Maybe (Signal ControlSig)
forall a. PassedArgs a -> Maybe a
prev_val

prev_pitch :: Derive.PitchArgs -> Maybe (RealTime, PSignal.Pitch)
prev_pitch :: PitchArgs -> Maybe (RealTime, Pitch)
prev_pitch = PSignal -> Maybe (RealTime, Pitch)
PSignal.last (PSignal -> Maybe (RealTime, Pitch))
-> (PitchArgs -> Maybe PSignal)
-> PitchArgs
-> Maybe (RealTime, Pitch)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< PitchArgs -> Maybe PSignal
forall a. PassedArgs a -> Maybe a
prev_val

prev_event :: Derive.NoteArgs -> Maybe Score.Event
prev_event :: NoteArgs -> Maybe Event
prev_event = NoteArgs -> Maybe Event
forall a. PassedArgs a -> Maybe a
prev_val

prev_event_pitch :: PassedArgs Score.Event -> Maybe PSignal.Pitch
prev_event_pitch :: NoteArgs -> Maybe Pitch
prev_event_pitch NoteArgs
args =
    ((RealTime, Pitch) -> Pitch)
-> Maybe (RealTime, Pitch) -> Maybe Pitch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime, Pitch) -> Pitch
forall a b. (a, b) -> b
snd (Maybe (RealTime, Pitch) -> Maybe Pitch)
-> (Event -> Maybe (RealTime, Pitch)) -> Event -> Maybe Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Maybe (RealTime, Pitch)
PSignal.last (PSignal -> Maybe (RealTime, Pitch))
-> (Event -> PSignal) -> Event -> Maybe (RealTime, Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> PSignal
Score.event_pitch (Event -> Maybe Pitch) -> Maybe Event -> Maybe Pitch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NoteArgs -> Maybe Event
forall a. PassedArgs a -> Maybe a
prev_val NoteArgs
args

-- | Polymorphic version of 'prev_control' or 'prev_pitch'.
prev_val_end :: Derive.Taggable a => PassedArgs a -> Maybe RealTime
prev_val_end :: forall a. Taggable a => PassedArgs a -> Maybe RealTime
prev_val_end = a -> Maybe RealTime
forall {a}. Taggable a => a -> Maybe RealTime
extract (a -> Maybe RealTime)
-> (PassedArgs a -> Maybe a) -> PassedArgs a -> Maybe RealTime
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< PassedArgs a -> Maybe a
forall a. PassedArgs a -> Maybe a
prev_val
    where
    extract :: a -> Maybe RealTime
extract a
val = case a -> Tagged
forall a. Taggable a => a -> Tagged
Derive.to_tagged a
val of
        Derive.TagEvent Event
event -> RealTime -> Maybe RealTime
forall a. a -> Maybe a
Just (RealTime -> Maybe RealTime) -> RealTime -> Maybe RealTime
forall a b. (a -> b) -> a -> b
$ Event -> RealTime
Score.event_end Event
event
        Derive.TagControl Signal ControlSig
sig -> (RealTime, Y) -> RealTime
forall a b. (a, b) -> a
fst ((RealTime, Y) -> RealTime)
-> Maybe (RealTime, Y) -> Maybe RealTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal ControlSig -> Maybe (RealTime, Y)
forall {k} (kind :: k). Signal kind -> Maybe (RealTime, Y)
Signal.last Signal ControlSig
sig
        Derive.TagPitch PSignal
sig -> (RealTime, Pitch) -> RealTime
forall a b. (a, b) -> a
fst ((RealTime, Pitch) -> RealTime)
-> Maybe (RealTime, Pitch) -> Maybe RealTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PSignal -> Maybe (RealTime, Pitch)
PSignal.last PSignal
sig

-- | Get the previous val.  See NOTE [prev-val].
prev_val :: PassedArgs a -> Maybe a
prev_val :: forall a. PassedArgs a -> Maybe a
prev_val = Context a -> Maybe a
forall val. Context val -> Maybe val
Derive.ctx_prev_val (Context a -> Maybe a)
-> (PassedArgs a -> Context a) -> PassedArgs a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Context a
forall a. PassedArgs a -> Context a
context

-- ** from 'Derive.state_prev_val'

-- TODO do I really need so many ways to get the previous pitch?
-- prev_note_pitch :: Derive.Deriver (Maybe (RealTime, PSignal.Pitch))
-- prev_note_pitch = do
--     prev <- prev_note
--     return $ PSignal.last . Score.event_pitch =<< prev

prev_note_pitch :: RealTime -> Derive.Deriver (Maybe PSignal.Pitch)
prev_note_pitch :: RealTime -> Deriver (Maybe Pitch)
prev_note_pitch RealTime
start = Deriver State Error (Maybe Event)
-> (Event -> Deriver (Maybe Pitch)) -> Deriver (Maybe Pitch)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm Deriver State Error (Maybe Event)
prev_note ((Event -> Deriver (Maybe Pitch)) -> Deriver (Maybe Pitch))
-> (Event -> Deriver (Maybe Pitch)) -> Deriver (Maybe Pitch)
forall a b. (a -> b) -> a -> b
$
    Maybe Pitch -> Deriver (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pitch -> Deriver (Maybe Pitch))
-> (Event -> Maybe Pitch) -> Event -> Deriver (Maybe Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> PSignal -> Maybe Pitch
PSignal.at_negative RealTime
start (PSignal -> Maybe Pitch)
-> (Event -> PSignal) -> Event -> Maybe Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> PSignal
Score.event_pitch

-- | Get the previous note.  Unlike 'prev_val', this always gets the previous
-- Score.Event, even if you're evaluating a control track under the note track.
--
-- TODO it doesn't really belong here since it doesn't use PassedArgs, but
-- this is where I would look for a function for the previous value.
prev_note :: Derive.Deriver (Maybe Score.Event)
prev_note :: Deriver State Error (Maybe Event)
prev_note = do
    -- TODO this happens if you're not inverting, but that should be ok, right?
    (BlockId, TrackId)
addr <- Text -> Maybe (BlockId, TrackId) -> Deriver (BlockId, TrackId)
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"lookup_prev_note: no state_note_track"
        (Maybe (BlockId, TrackId) -> Deriver (BlockId, TrackId))
-> Deriver State Error (Maybe (BlockId, TrackId))
-> Deriver (BlockId, TrackId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (State -> Maybe (BlockId, TrackId))
-> Deriver State Error (Maybe (BlockId, TrackId))
forall st a err. (st -> a) -> Deriver st err a
Derive.gets (Dynamic -> Maybe (BlockId, TrackId)
Derive.state_note_track (Dynamic -> Maybe (BlockId, TrackId))
-> (State -> Dynamic) -> State -> Maybe (BlockId, TrackId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
Derive.state_dynamic)
    (State -> Maybe Event) -> Deriver State Error (Maybe Event)
forall st a err. (st -> a) -> Deriver st err a
Derive.gets ((State -> Maybe Event) -> Deriver State Error (Maybe Event))
-> (State -> Maybe Event) -> Deriver State Error (Maybe Event)
forall a b. (a -> b) -> a -> b
$ Tagged -> Maybe Event
forall a. Taggable a => Tagged -> Maybe a
Derive.from_tagged (Tagged -> Maybe Event)
-> (State -> Maybe Tagged) -> State -> Maybe Event
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (BlockId, TrackId) -> Map (BlockId, TrackId) Tagged -> Maybe Tagged
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (BlockId, TrackId)
addr (Map (BlockId, TrackId) Tagged -> Maybe Tagged)
-> (State -> Map (BlockId, TrackId) Tagged)
-> State
-> Maybe Tagged
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Threaded -> Map (BlockId, TrackId) Tagged
Derive.state_prev_val
        (Threaded -> Map (BlockId, TrackId) Tagged)
-> (State -> Threaded) -> State -> Map (BlockId, TrackId) Tagged
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Threaded
Derive.state_threaded

-- ** 'Derive.state_pitch_map'

-- | Pitch at the time of the next event in this track.
lookup_next_pitch :: PassedArgs a -> Derive.Deriver (Maybe PSignal.Pitch)
lookup_next_pitch :: forall a. PassedArgs a -> Deriver (Maybe Pitch)
lookup_next_pitch = Deriver (Maybe Pitch)
-> (TrackTime -> Deriver (Maybe Pitch))
-> Maybe TrackTime
-> Deriver (Maybe Pitch)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Pitch -> Deriver (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pitch
forall a. Maybe a
Nothing) TrackTime -> Deriver (Maybe Pitch)
lookup_pitch_at (Maybe TrackTime -> Deriver (Maybe Pitch))
-> (PassedArgs a -> Maybe TrackTime)
-> PassedArgs a
-> Deriver (Maybe Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Maybe TrackTime
forall a. PassedArgs a -> Maybe TrackTime
next_start

lookup_prev_pitch :: PassedArgs a -> Derive.Deriver (Maybe PSignal.Pitch)
lookup_prev_pitch :: forall a. PassedArgs a -> Deriver (Maybe Pitch)
lookup_prev_pitch = Deriver (Maybe Pitch)
-> (TrackTime -> Deriver (Maybe Pitch))
-> Maybe TrackTime
-> Deriver (Maybe Pitch)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Pitch -> Deriver (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pitch
forall a. Maybe a
Nothing) TrackTime -> Deriver (Maybe Pitch)
lookup_pitch_at (Maybe TrackTime -> Deriver (Maybe Pitch))
-> (PassedArgs a -> Maybe TrackTime)
-> PassedArgs a
-> Deriver (Maybe Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Maybe TrackTime
forall a. PassedArgs a -> Maybe TrackTime
prev_start

-- | Pitch at the time of the next note event of this track's
-- 'Derive.state_note_track'.
lookup_next_note_pitch :: ScoreTime -> Derive.Deriver (Maybe PSignal.Pitch)
lookup_next_note_pitch :: TrackTime -> Deriver (Maybe Pitch)
lookup_next_note_pitch TrackTime
start =
    Deriver State Error (Maybe Event)
-> (Event -> Deriver (Maybe Pitch)) -> Deriver (Maybe Pitch)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (TrackTime -> Events -> Maybe Event
note_after TrackTime
start (Events -> Maybe Event)
-> Deriver State Error Events -> Deriver State Error (Maybe Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error Events
get_note_events) ((Event -> Deriver (Maybe Pitch)) -> Deriver (Maybe Pitch))
-> (Event -> Deriver (Maybe Pitch)) -> Deriver (Maybe Pitch)
forall a b. (a -> b) -> a -> b
$
    TrackTime -> Deriver (Maybe Pitch)
lookup_pitch_at (TrackTime -> Deriver (Maybe Pitch))
-> (Event -> TrackTime) -> Event -> Deriver (Maybe Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> TrackTime
Event.start

lookup_prev_note_pitch :: ScoreTime -> Derive.Deriver (Maybe PSignal.Pitch)
lookup_prev_note_pitch :: TrackTime -> Deriver (Maybe Pitch)
lookup_prev_note_pitch TrackTime
start =
    Deriver State Error (Maybe Event)
-> (Event -> Deriver (Maybe Pitch)) -> Deriver (Maybe Pitch)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (TrackTime -> Events -> Maybe Event
note_before TrackTime
start (Events -> Maybe Event)
-> Deriver State Error Events -> Deriver State Error (Maybe Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error Events
get_note_events) ((Event -> Deriver (Maybe Pitch)) -> Deriver (Maybe Pitch))
-> (Event -> Deriver (Maybe Pitch)) -> Deriver (Maybe Pitch)
forall a b. (a -> b) -> a -> b
$
    TrackTime -> Deriver (Maybe Pitch)
lookup_pitch_at (TrackTime -> Deriver (Maybe Pitch))
-> (Event -> TrackTime) -> Event -> Deriver (Maybe Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> TrackTime
Event.start

note_before :: TrackTime -> Events.Events -> Maybe Event.Event
note_before :: TrackTime -> Events -> Maybe Event
note_before TrackTime
p = Events -> Maybe Event
Events.last (Events -> Maybe Event)
-> (Events -> Events) -> Events -> Maybe Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Events, Events) -> Events
forall a b. (a, b) -> a
fst ((Events, Events) -> Events)
-> (Events -> (Events, Events)) -> Events -> Events
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Events -> (Events, Events)
Events.split_exclude TrackTime
p

note_after :: TrackTime -> Events.Events -> Maybe Event.Event
note_after :: TrackTime -> Events -> Maybe Event
note_after TrackTime
p = Events -> Maybe Event
Events.head (Events -> Maybe Event)
-> (Events -> Events) -> Events -> Maybe Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Events, Events) -> Events
forall a b. (a, b) -> b
snd ((Events, Events) -> Events)
-> (Events -> (Events, Events)) -> Events -> Events
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Events -> (Events, Events)
Events.split_exclude TrackTime
p

get_note_events :: Derive.Deriver Events.Events
get_note_events :: Deriver State Error Events
get_note_events = do
    -- TODO this happens if you're not inverting, is that ok?
    (BlockId
_, TrackId
track_id) <- Text -> Maybe (BlockId, TrackId) -> Deriver (BlockId, TrackId)
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"no state_note_track"
        (Maybe (BlockId, TrackId) -> Deriver (BlockId, TrackId))
-> Deriver State Error (Maybe (BlockId, TrackId))
-> Deriver (BlockId, TrackId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (State -> Maybe (BlockId, TrackId))
-> Deriver State Error (Maybe (BlockId, TrackId))
forall st a err. (st -> a) -> Deriver st err a
Derive.gets (Dynamic -> Maybe (BlockId, TrackId)
Derive.state_note_track (Dynamic -> Maybe (BlockId, TrackId))
-> (State -> Dynamic) -> State -> Maybe (BlockId, TrackId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
Derive.state_dynamic)
    Track -> Events
Track.track_events (Track -> Events)
-> Deriver State Error Track -> Deriver State Error Events
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackId -> Deriver State Error Track
Derive.get_track TrackId
track_id

-- | Get a logical pitch at the given time, via 'Derive.state_pitch_map'.
-- As documented by 'Derive.state_pitch_map', the pitch map is unset while
-- evaluating the pitch map, so pitch calls that use this shouldn't be
-- surprised if it's Nothing.
lookup_pitch_at :: TrackTime -> Derive.Deriver (Maybe PSignal.Pitch)
lookup_pitch_at :: TrackTime -> Deriver (Maybe Pitch)
lookup_pitch_at TrackTime
pos = Deriver State Error (Maybe (Maybe PSignal, [Msg]))
-> ((Maybe PSignal, [Msg]) -> Deriver (Maybe Pitch))
-> Deriver (Maybe Pitch)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm ((Dynamic -> Maybe (Maybe PSignal, [Msg]))
-> Deriver State Error (Maybe (Maybe PSignal, [Msg]))
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Maybe (Maybe PSignal, [Msg])
Derive.state_pitch_map) (((Maybe PSignal, [Msg]) -> Deriver (Maybe Pitch))
 -> Deriver (Maybe Pitch))
-> ((Maybe PSignal, [Msg]) -> Deriver (Maybe Pitch))
-> Deriver (Maybe Pitch)
forall a b. (a -> b) -> a -> b
$
    \(Maybe PSignal
maybe_sig, [Msg]
logs) -> do
        (Msg -> Deriver State Error ()) -> [Msg] -> Deriver State Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Msg -> Deriver State Error ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write (Msg -> Deriver State Error ())
-> (Msg -> Msg) -> Msg -> Deriver State Error ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Msg -> Msg
Log.add_prefix (Text
"lookup_pitch_at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackTime -> Text
forall a. Pretty a => a -> Text
pretty TrackTime
pos)) ([Msg] -> Deriver State Error ())
-> [Msg] -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$
            (Msg -> Bool) -> [Msg] -> [Msg]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>=Priority
Log.Warn) (Priority -> Bool) -> (Msg -> Priority) -> Msg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Priority
Log.msg_priority) [Msg]
logs
        -- PSignal is actually in TrackTime, see 'Derive.state_pitch_map'.
        Maybe Pitch -> Deriver (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pitch -> Deriver (Maybe Pitch))
-> Maybe Pitch -> Deriver (Maybe Pitch)
forall a b. (a -> b) -> a -> b
$ RealTime -> PSignal -> Maybe Pitch
PSignal.at (TrackTime -> RealTime
RealTime.from_score TrackTime
pos) (PSignal -> Maybe Pitch) -> Maybe PSignal -> Maybe Pitch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe PSignal
maybe_sig

-- | Like 'lookup_pitch_at', except for parsed pitches.  Normally you'd pass
-- 'Derive.Call.get_pitch_functions' to make a 'Pitch.Pitch'.
lookup_parsed_pitch_at :: (Pitch.Note -> Maybe a) -> TrackTime
    -> Derive.Deriver (Maybe a)
lookup_parsed_pitch_at :: forall a. (Note -> Maybe a) -> TrackTime -> Deriver (Maybe a)
lookup_parsed_pitch_at Note -> Maybe a
parse_pitch TrackTime
pos =
    Deriver (Maybe Pitch)
-> (Pitch -> Deriver State Error (Maybe a))
-> Deriver State Error (Maybe a)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (TrackTime -> Deriver (Maybe Pitch)
lookup_pitch_at TrackTime
pos) ((Pitch -> Deriver State Error (Maybe a))
 -> Deriver State Error (Maybe a))
-> (Pitch -> Deriver State Error (Maybe a))
-> Deriver State Error (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Pitch
pitch -> do
        RealTime
rpos <- TrackTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real TrackTime
pos
        -- TODO transposes may be out of sync because state_pitch_map is in
        -- TrackTime.
        Note
note <- Transposed -> Deriver Note
Pitches.pitch_note (Transposed -> Deriver Note)
-> Deriver State Error Transposed -> Deriver Note
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Pitch -> Deriver State Error Transposed
Derive.resolve_pitch RealTime
rpos Pitch
pitch
        a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a)
-> Deriver State Error a -> Deriver State Error (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe a -> Deriver State Error a
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"unparseable pitch" (Note -> Maybe a
parse_pitch Note
note)

-- ** eval

-- | Unused, but might be used again if I need to evaluate the next event.
eval :: Derive.CallableExpr d => Context x -> Event.Event -> [Event.Event]
    -> Derive.Deriver (Stream.Stream d)
eval :: forall d x.
CallableExpr d =>
Context x -> Event -> [Event] -> Deriver (Stream d)
eval Context x
ctx Event
event [Event]
prev = case Text -> Either Text Expr
Parse.parse_expr (Event -> Text
Event.text Event
event) of
    Left Text
err -> Text -> Deriver (Stream d)
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver (Stream d)) -> Text -> Deriver (Stream d)
forall a b. (a -> b) -> a -> b
$ Text
"parse error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
    Right Expr
expr -> Bool -> Context d -> Expr -> Deriver (Stream d)
forall d.
CallableExpr d =>
Bool -> Context d -> Expr -> Deriver (Stream d)
Eval.eval_expr Bool
False Context d
forall {val}. Context val
prev_ctx Expr
expr
        where
        prev_ctx :: Context val
prev_ctx = Context x
ctx
            { ctx_prev_val :: Maybe val
Derive.ctx_prev_val = Maybe val
forall a. Maybe a
Nothing
            , ctx_event :: Event
Derive.ctx_event = Event
event
            , ctx_prev_events :: [Event]
Derive.ctx_prev_events = [Event]
prev
            , ctx_next_events :: [Event]
Derive.ctx_next_events =
                Context x -> Event
forall val. Context val -> Event
Derive.ctx_event Context x
ctx Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: Context x -> [Event]
forall val. Context val -> [Event]
Derive.ctx_next_events Context x
ctx
            , ctx_event_end :: TrackTime
Derive.ctx_event_end = Event -> TrackTime
Event.start (Event -> TrackTime) -> Event -> TrackTime
forall a b. (a -> b) -> a -> b
$ Context x -> Event
forall val. Context val -> Event
Derive.ctx_event Context x
ctx
            }

-- | Get the pitch at the time of the next event, when evaluating a pitch
-- track.  Since the pitch hasn't been evaluated yet, it has to be evaluated
-- here.  So if it depends on the previous pitch, you won't get a pitch back.
--
-- Actually, the pitch likely *has* been evaluated, I just can't get at it
-- here.  If it's uninverted then I have the whole pitch track, and if it's
-- inverted then the event at or after the end of the event will be included.
-- But 'Derive.Control.trim_signal' will clip that sample off to avoid
-- a spurious pitch change at the end of the note.
eval_next_pitch :: Derive.PitchArgs -> Derive.Deriver (Maybe PSignal.Pitch)
eval_next_pitch :: PitchArgs -> Deriver (Maybe Pitch)
eval_next_pitch = Deriver (Maybe Pitch)
-> (Event -> Deriver (Maybe Pitch))
-> Maybe Event
-> Deriver (Maybe Pitch)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Pitch -> Deriver (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pitch
forall a. Maybe a
Nothing) Event -> Deriver (Maybe Pitch)
eval_pitch (Maybe Event -> Deriver (Maybe Pitch))
-> (PitchArgs -> Maybe Event) -> PitchArgs -> Deriver (Maybe Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head ([Event] -> Maybe Event)
-> (PitchArgs -> [Event]) -> PitchArgs -> Maybe Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchArgs -> [Event]
forall a. PassedArgs a -> [Event]
next_events

eval_pitch :: Event.Event -> Derive.Deriver (Maybe PSignal.Pitch)
eval_pitch :: Event -> Deriver (Maybe Pitch)
eval_pitch Event
event = Deriver State Error (Maybe (Stream PSignal))
-> (Stream PSignal -> Deriver (Maybe Pitch))
-> Deriver (Maybe Pitch)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (Either Text (Stream PSignal) -> Maybe (Stream PSignal)
forall {a} {a}. Either a a -> Maybe a
to_maybe (Either Text (Stream PSignal) -> Maybe (Stream PSignal))
-> Deriver State Error (Either Text (Stream PSignal))
-> Deriver State Error (Maybe (Stream PSignal))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Deriver State Error (Either Text (Stream PSignal))
forall d.
CallableExpr d =>
Event -> Deriver (Either Text (Stream d))
Eval.eval_event Event
event) ((Stream PSignal -> Deriver (Maybe Pitch))
 -> Deriver (Maybe Pitch))
-> (Stream PSignal -> Deriver (Maybe Pitch))
-> Deriver (Maybe Pitch)
forall a b. (a -> b) -> a -> b
$ \Stream PSignal
stream -> do
    RealTime
start <- TrackTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (Event -> TrackTime
Event.start Event
event)
    Maybe Pitch -> Deriver (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pitch -> Deriver (Maybe Pitch))
-> Maybe Pitch -> Deriver (Maybe Pitch)
forall a b. (a -> b) -> a -> b
$ RealTime -> PSignal -> Maybe Pitch
PSignal.at RealTime
start (PSignal -> Maybe Pitch) -> PSignal -> Maybe Pitch
forall a b. (a -> b) -> a -> b
$ [PSignal] -> PSignal
forall a. Monoid a => [a] -> a
mconcat ([PSignal] -> PSignal) -> [PSignal] -> PSignal
forall a b. (a -> b) -> a -> b
$ Stream PSignal -> [PSignal]
forall a. Stream a -> [a]
Stream.events_of Stream PSignal
stream
    where to_maybe :: Either a a -> Maybe a
to_maybe = (a -> Maybe a) -> (a -> Maybe a) -> Either a a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> a -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just

-- * event timing

start :: PassedArgs a -> TrackTime
start :: forall a. PassedArgs a -> TrackTime
start = Event -> TrackTime
Event.start (Event -> TrackTime)
-> (PassedArgs a -> Event) -> PassedArgs a -> TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Event
forall a. PassedArgs a -> Event
event

duration :: PassedArgs a -> TrackTime
duration :: forall a. PassedArgs a -> TrackTime
duration = Event -> TrackTime
Event.duration (Event -> TrackTime)
-> (PassedArgs a -> Event) -> PassedArgs a -> TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Event
forall a. PassedArgs a -> Event
event

real_duration :: PassedArgs a -> Derive.Deriver RealTime
real_duration :: forall a. PassedArgs a -> Deriver RealTime
real_duration PassedArgs a
args = (-) (RealTime -> RealTime -> RealTime)
-> Deriver RealTime -> Deriver State Error (RealTime -> RealTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassedArgs a -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
real_end PassedArgs a
args Deriver State Error (RealTime -> RealTime)
-> Deriver RealTime -> Deriver RealTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PassedArgs a -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
real_start PassedArgs a
args

real_start :: PassedArgs a -> Derive.Deriver RealTime
real_start :: forall a. PassedArgs a -> Deriver RealTime
real_start = TrackTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (TrackTime -> Deriver RealTime)
-> (PassedArgs a -> TrackTime) -> PassedArgs a -> Deriver RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> TrackTime
forall a. PassedArgs a -> TrackTime
start

end :: PassedArgs a -> TrackTime
end :: forall a. PassedArgs a -> TrackTime
end = Event -> TrackTime
Event.end (Event -> TrackTime)
-> (PassedArgs a -> Event) -> PassedArgs a -> TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Event
forall a. PassedArgs a -> Event
event

real_end :: PassedArgs a -> Derive.Deriver RealTime
real_end :: forall a. PassedArgs a -> Deriver RealTime
real_end = TrackTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (TrackTime -> Deriver RealTime)
-> (PassedArgs a -> TrackTime) -> PassedArgs a -> Deriver RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> TrackTime
forall a. PassedArgs a -> TrackTime
end

-- | The start of the next event, or the end of the block if there is no next
-- event.
--
-- Used by calls to determine their extent, especially control calls, which
-- have no explicit duration.
next :: PassedArgs a -> TrackTime
next :: forall a. PassedArgs a -> TrackTime
next = Context a -> TrackTime
forall val. Context val -> TrackTime
Derive.ctx_event_end (Context a -> TrackTime)
-> (PassedArgs a -> Context a) -> PassedArgs a -> TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Context a
forall a. PassedArgs a -> Context a
context

-- | End of the next event, or the end of the block if there is no next event.
next_end :: PassedArgs a -> TrackTime
next_end :: forall a. PassedArgs a -> TrackTime
next_end PassedArgs a
args = TrackTime -> (Event -> TrackTime) -> Maybe Event -> TrackTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PassedArgs a -> TrackTime
forall a. PassedArgs a -> TrackTime
next PassedArgs a
args) Event -> TrackTime
Event.end ([Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head (PassedArgs a -> [Event]
forall a. PassedArgs a -> [Event]
next_events PassedArgs a
args))

-- | Get the start of the next event, if there is one.
--
-- This is similar to 'next', except that it will be Nothing at the end of
-- the block.
next_start :: PassedArgs a -> Maybe TrackTime
next_start :: forall a. PassedArgs a -> Maybe TrackTime
next_start = (Event -> TrackTime) -> Maybe Event -> Maybe TrackTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> TrackTime
Event.start (Maybe Event -> Maybe TrackTime)
-> (PassedArgs a -> Maybe Event) -> PassedArgs a -> Maybe TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head ([Event] -> Maybe Event)
-> (PassedArgs a -> [Event]) -> PassedArgs a -> Maybe Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> [Event]
forall a. PassedArgs a -> [Event]
next_events

-- | Start time of the previous event.
prev_start :: PassedArgs a -> Maybe TrackTime
prev_start :: forall a. PassedArgs a -> Maybe TrackTime
prev_start = (Event -> TrackTime) -> Maybe Event -> Maybe TrackTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> TrackTime
Event.start (Maybe Event -> Maybe TrackTime)
-> (PassedArgs a -> Maybe Event) -> PassedArgs a -> Maybe TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head ([Event] -> Maybe Event)
-> (PassedArgs a -> [Event]) -> PassedArgs a -> Maybe Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> [Event]
forall a. PassedArgs a -> [Event]
prev_events

-- | End time of the previous event.
prev_end :: PassedArgs a -> Maybe TrackTime
prev_end :: forall a. PassedArgs a -> Maybe TrackTime
prev_end = (Event -> TrackTime) -> Maybe Event -> Maybe TrackTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> TrackTime
Event.end (Maybe Event -> Maybe TrackTime)
-> (PassedArgs a -> Maybe Event) -> PassedArgs a -> Maybe TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head ([Event] -> Maybe Event)
-> (PassedArgs a -> [Event]) -> PassedArgs a -> Maybe Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> [Event]
forall a. PassedArgs a -> [Event]
prev_events

prev_events, next_events :: PassedArgs a -> [Event.Event]
next_events :: forall a. PassedArgs a -> [Event]
next_events = Context a -> [Event]
forall val. Context val -> [Event]
Derive.ctx_next_events (Context a -> [Event])
-> (PassedArgs a -> Context a) -> PassedArgs a -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Context a
forall a. PassedArgs a -> Context a
context
prev_events :: forall a. PassedArgs a -> [Event]
prev_events = Context a -> [Event]
forall val. Context val -> [Event]
Derive.ctx_prev_events (Context a -> [Event])
-> (PassedArgs a -> Context a) -> PassedArgs a -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Context a
forall a. PassedArgs a -> Context a
context

-- ** modify

-- | Modify the duration of the ctx_event.  This is a hack, because calls run
-- in TrackTime, instead of using Derive.place.
set_duration :: TrackTime -> PassedArgs a -> PassedArgs a
set_duration :: forall a. TrackTime -> PassedArgs a -> PassedArgs a
set_duration TrackTime
dur PassedArgs a
args = PassedArgs a
args
    { passed_ctx :: Context a
Derive.passed_ctx = Context a
ctx
        { ctx_event :: Event
Derive.ctx_event = Lens Event TrackTime
Event.duration_ Lens Event TrackTime -> TrackTime -> Event -> Event
forall f a. Lens f a -> a -> f -> f
#= TrackTime
dur (Event -> Event) -> Event -> Event
forall a b. (a -> b) -> a -> b
$ Context a -> Event
forall val. Context val -> Event
Derive.ctx_event Context a
ctx }
    }
    where ctx :: Context a
ctx = PassedArgs a -> Context a
forall a. PassedArgs a -> Context a
Derive.passed_ctx PassedArgs a
args

-- ** range

-- | Range of the called event, i.e. (min, max).  Note that range is the
-- minimum to maximum, which is not the same as the start and end if the event
-- has negative duration.
range :: PassedArgs a -> (TrackTime, TrackTime)
range :: forall a. PassedArgs a -> (TrackTime, TrackTime)
range = Event -> (TrackTime, TrackTime)
Event.range (Event -> (TrackTime, TrackTime))
-> (PassedArgs a -> Event)
-> PassedArgs a
-> (TrackTime, TrackTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Event
forall a. PassedArgs a -> Event
event

real_range :: PassedArgs a -> Derive.Deriver (RealTime, RealTime)
real_range :: forall a. PassedArgs a -> Deriver (RealTime, RealTime)
real_range PassedArgs a
args = (,) (RealTime -> RealTime -> (RealTime, RealTime))
-> Deriver RealTime
-> Deriver State Error (RealTime -> (RealTime, RealTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real TrackTime
start Deriver State Error (RealTime -> (RealTime, RealTime))
-> Deriver RealTime -> Deriver (RealTime, RealTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TrackTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real TrackTime
end
    where (TrackTime
start, TrackTime
end) = PassedArgs a -> (TrackTime, TrackTime)
forall a. PassedArgs a -> (TrackTime, TrackTime)
range PassedArgs a
args

-- | Like 'range', but if the duration is 0, then the end is 'next' event.
range_or_next :: PassedArgs a -> (TrackTime, TrackTime)
range_or_next :: forall a. PassedArgs a -> (TrackTime, TrackTime)
range_or_next PassedArgs a
args
    | TrackTime
start TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
end = (TrackTime
start, PassedArgs a -> TrackTime
forall a. PassedArgs a -> TrackTime
next PassedArgs a
args)
    | Bool
otherwise = (TrackTime
start, TrackTime
end)
    where (TrackTime
start, TrackTime
end) = PassedArgs a -> (TrackTime, TrackTime)
forall a. PassedArgs a -> (TrackTime, TrackTime)
range PassedArgs a
args

real_range_or_next :: PassedArgs a -> Derive.Deriver (RealTime, RealTime)
real_range_or_next :: forall a. PassedArgs a -> Deriver (RealTime, RealTime)
real_range_or_next PassedArgs a
args = (,) (RealTime -> RealTime -> (RealTime, RealTime))
-> Deriver RealTime
-> Deriver State Error (RealTime -> (RealTime, RealTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real TrackTime
start Deriver State Error (RealTime -> (RealTime, RealTime))
-> Deriver RealTime -> Deriver (RealTime, RealTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TrackTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real TrackTime
end
    where (TrackTime
start, TrackTime
end) = PassedArgs a -> (TrackTime, TrackTime)
forall a. PassedArgs a -> (TrackTime, TrackTime)
range_or_next PassedArgs a
args

-- | The current event's start and end times.
--
-- If the event has a duration, then use that.  Otherwise, if there is
-- a 'EnvKey.note_end', return that.  Otherwise, return 'next'.  However, if
-- there's an 'EnvKey.note_start' and it's past the event start, then this
-- event isn't contained within the range of its parent note, which means that
-- its expected note end has also passed.  In that case, it returns
-- (note_start, note_start), which should cause the call to just emit its final
-- sample at the note-start, which will both get the correct value for the
-- event and not destroy the earlier track signal fragment.
range_or_note_end :: PassedArgs a -> Derive.Deriver (TrackTime, TrackTime)
range_or_note_end :: forall a. PassedArgs a -> Deriver (TrackTime, TrackTime)
range_or_note_end PassedArgs a
args
    | TrackTime
start TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
end = do
        Maybe TrackTime
note_start <- Text -> Deriver (Maybe TrackTime)
forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.note_start
        Maybe TrackTime
note_end <- Text -> Deriver (Maybe TrackTime)
forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.note_end
        case (Maybe TrackTime
note_start, Maybe TrackTime
note_end) of
            (Just TrackTime
note_start, Just TrackTime
note_end)
                | TrackTime
start TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
< TrackTime
note_start -> (TrackTime, TrackTime) -> Deriver (TrackTime, TrackTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime
note_start, TrackTime
note_start)
                | Bool
otherwise ->
                    (TrackTime, TrackTime) -> Deriver (TrackTime, TrackTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime
start, TrackTime -> TrackTime -> TrackTime
forall a. Ord a => a -> a -> a
min (PassedArgs a -> TrackTime
forall a. PassedArgs a -> TrackTime
next PassedArgs a
args) (TrackTime -> TrackTime -> TrackTime
forall a. Ord a => a -> a -> a
max TrackTime
end TrackTime
note_end))
            (Maybe TrackTime, Maybe TrackTime)
_ -> (TrackTime, TrackTime) -> Deriver (TrackTime, TrackTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime
start, PassedArgs a -> TrackTime
forall a. PassedArgs a -> TrackTime
next PassedArgs a
args)
    | Bool
otherwise = (TrackTime, TrackTime) -> Deriver (TrackTime, TrackTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime
start, TrackTime
end)
    where (TrackTime
start, TrackTime
end) = PassedArgs a -> (TrackTime, TrackTime)
forall a. PassedArgs a -> (TrackTime, TrackTime)
range PassedArgs a
args

-- | Start and duration of the event.  This is probably the right thing for
-- calls that generate a note since it will give a negative duration when
-- appropriate.
extent :: PassedArgs a -> (TrackTime, TrackTime)
extent :: forall a. PassedArgs a -> (TrackTime, TrackTime)
extent = (\Event
e -> (Event -> TrackTime
Event.start Event
e, Event -> TrackTime
Event.duration Event
e)) (Event -> (TrackTime, TrackTime))
-> (PassedArgs a -> Event)
-> PassedArgs a
-> (TrackTime, TrackTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedArgs a -> Event
forall a. PassedArgs a -> Event
event

real_extent :: PassedArgs a -> Derive.Deriver (RealTime, RealTime)
real_extent :: forall a. PassedArgs a -> Deriver (RealTime, RealTime)
real_extent PassedArgs a
args = do
    let e :: Event
e = PassedArgs a -> Event
forall a. PassedArgs a -> Event
event PassedArgs a
args
    RealTime
start <- TrackTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (Event -> TrackTime
Event.start Event
e)
    RealTime
end <- TrackTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (Event -> TrackTime
Event.end Event
e)
    (RealTime, RealTime) -> Deriver (RealTime, RealTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime
start, RealTime
end RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
start)

-- | Event range as it appears on the track, regardless of slicing.
range_on_track :: PassedArgs a -> (TrackTime, TrackTime)
range_on_track :: forall a. PassedArgs a -> (TrackTime, TrackTime)
range_on_track PassedArgs a
args = (TrackTime
shifted TrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
+ TrackTime
start, TrackTime
shifted TrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
+ TrackTime
end)
    where
    (TrackTime
start, TrackTime
end) = PassedArgs a -> (TrackTime, TrackTime)
forall a. PassedArgs a -> (TrackTime, TrackTime)
range PassedArgs a
args
    shifted :: TrackTime
shifted = Context a -> TrackTime
forall val. Context val -> TrackTime
Derive.ctx_track_shifted (PassedArgs a -> Context a
forall a. PassedArgs a -> Context a
context PassedArgs a
args)

-- | This normalizes a deriver to start at 0 and have a duration of 1, provided
-- that the deriver is placed at the start and dur of the given args.  This is
-- the case if the deriver is a transformer arg, so this is useful for
-- a transformer to manipulate its argument.
normalized :: PassedArgs a -> Derive.Deriver b -> Derive.Deriver b
normalized :: forall a b. PassedArgs a -> Deriver b -> Deriver b
normalized PassedArgs a
args = TrackTime -> TrackTime -> Deriver b -> Deriver b
forall a. TrackTime -> TrackTime -> Deriver a -> Deriver a
Derive.place (- (TrackTime
start TrackTime -> TrackTime -> TrackTime
forall a. Fractional a => a -> a -> a
/ TrackTime
dur)) (TrackTime
1 TrackTime -> TrackTime -> TrackTime
forall a. Fractional a => a -> a -> a
/ TrackTime
dur)
    where
    (TrackTime
start, TrackTime
dur_) = PassedArgs a -> (TrackTime, TrackTime)
forall a. PassedArgs a -> (TrackTime, TrackTime)
extent PassedArgs a
args
    dur :: TrackTime
dur = if TrackTime
dur_ TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
0 then TrackTime
1 else TrackTime
dur_

-- | Like 'normalized', but only shifts start to 0.
normalized_start :: PassedArgs a -> Derive.Deriver b -> Derive.Deriver b
normalized_start :: forall a b. PassedArgs a -> Deriver b -> Deriver b
normalized_start PassedArgs a
args = TrackTime -> Deriver b -> Deriver b
forall a. TrackTime -> Deriver a -> Deriver a
Derive.at (- PassedArgs a -> TrackTime
forall a. PassedArgs a -> TrackTime
start PassedArgs a
args)

{- NOTE [prev-val]

    Many control calls rely on the last value emitted by the previous call.
    I can't think of a way around that, because it's really fundamental to how
    the notation works, and it would be a real pain (and redundant) to have to
    write where interpolation comes from all the time.

    So conceptually each call takes the last val of the previous one as an
    argument.  This is problematic because it means you never know how far back
    in the track a given call's dependence extends.  Since track slicing
    divides control tracks into lots of little chunks it's not so simple to
    get the previous value.

    Initially I relied entirely on 'Derive.ctx_prev_val' and a hack where
    certain calls were marked as requiring the previous value, which 'slice'
    would then use.  The problem with that is that slice is working purely
    syntactically, and it doesn't know what's really in scope, nor does it
    understand val calls.  This is #2 below.

    After that, I tried #3, but ran into trouble wanting to get the previous
    Score.Event.  Actually, I could have supported Score.Event with the
    evaluating technique, but I forgot that I had already done all these work
    before, implemented most of #2 before stumbling on #1 again, when its
    earlier problems seemed less severe than before.

    So the current solution is #1.

    1. Extend the 'Derive.ctx_prev_val' mechanism to work even across sliced
    tracks.  Since they are no longer evaluated in sequence, I have to save
    them in a `Map (BlockId, TrackId) (RealTime, Either Signal.Y
    PSignal.Pitch))`.  However, this is problematic in its own way because
    it's actually threaded state, which is new.  This isn't actually so bad,
    because I would add it in a new Threaded state, and it's only making
    explicit the already threaded nature of track derivation, due to prev_val.
    An additional problem is that, once again due to slicing, control events
    are evaluated twice, which means that the second evaluation gets the first
    evaluation's value as it's \"previous\" value.  An extra hack in
    "Derive.EvalTrack" avoids recording a previous value when the event is past
    the end of a slice.

    2. Make 'slice' figure out which calls will need the previous val.  This is
    like the old syntactic mechanism only more robust.  Calls already include
    a `prev` tag that indicates they rely on the previous value.  This is
    complicated because what is in scope can change dynamically, so the slicing
    has to be done under the track's transform at least.  That means slicing
    is split into two halves, where the first part just marks slice boundaries,
    and the actual slice is done in the track deriver.

    3. If a call doesn't have a prev val already, it can go evaluate the prev
    event itself, which must be able to continue recursively until there really
    isn't a prev event.  This can do more work, but is appealing because it
    removes the serialization requirement of 'Derive.ctx_prev_val'.
        - This means if multiple calls want the prev val, it'll be evaluated
        multiple times, unless I cache it somehow.
        - I should clear out the next events so it doesn't get in a loop if it
        wants the next event.  Actually it's fine if it wants to look at it, it
        just can't want to evaluate it.
-}