-- 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.Lists as Lists
import qualified Util.Log as Log
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 = forall a. PassedArgs a -> Context a
Derive.passed_ctx

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

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

negative :: PassedArgs a -> Bool
negative :: forall a. PassedArgs a -> Bool
negative = (forall a. Eq a => a -> a -> Bool
==Orientation
Types.Negative) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall {k} (kind :: k). Signal kind -> Maybe (RealTime, Y)
Signal.last forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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 forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. PassedArgs a -> Maybe a
prev_val

prev_event :: Derive.NoteArgs -> Maybe Score.Event
prev_event :: NoteArgs -> Maybe Event
prev_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 =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Maybe (RealTime, Pitch)
PSignal.last forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> PSignal
Score.event_pitch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall {a}. Taggable a => a -> Maybe RealTime
extract forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. PassedArgs a -> Maybe a
prev_val
    where
    extract :: a -> Maybe RealTime
extract a
val = case forall a. Taggable a => a -> Tagged
Derive.to_tagged a
val of
        Derive.TagEvent Event
event -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Event -> RealTime
Score.event_end Event
event
        Derive.TagControl Control
sig -> forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (kind :: k). Signal kind -> Maybe (RealTime, Y)
Signal.last Control
sig
        Derive.TagPitch PSignal
sig -> forall a b. (a, b) -> a
fst 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 = forall val. Context val -> Maybe val
Derive.ctx_prev_val forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm Deriver (Maybe Event)
prev_note forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PSignal -> RealTime -> Maybe Pitch
`PSignal.at_negative` RealTime
start) 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 (Maybe Event)
prev_note = do
    -- TODO this happens if you're not inverting, but that should be ok, right?
    (BlockId, TrackId)
addr <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"lookup_prev_note: no state_note_track"
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall st a err. (st -> a) -> Deriver st err a
Derive.gets (Dynamic -> Maybe (BlockId, TrackId)
Derive.state_note_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
Derive.state_dynamic)
    forall st a err. (st -> a) -> Deriver st err a
Derive.gets forall a b. (a -> b) -> a -> b
$ forall a. Taggable a => Tagged -> Maybe a
Derive.from_tagged forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (BlockId, TrackId)
addr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Threaded -> Map (BlockId, TrackId) Tagged
Derive.state_prev_val
        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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) TrackTime -> Deriver (Maybe Pitch)
lookup_pitch_at forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) TrackTime -> Deriver (Maybe Pitch)
lookup_pitch_at forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver Events
get_note_events) forall a b. (a -> b) -> a -> b
$
    TrackTime -> Deriver (Maybe Pitch)
lookup_pitch_at 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 =
    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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver Events
get_note_events) forall a b. (a -> b) -> a -> b
$
    TrackTime -> Deriver (Maybe Pitch)
lookup_pitch_at 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd 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 Events
get_note_events = do
    -- TODO this happens if you're not inverting, is that ok?
    (BlockId
_, TrackId
track_id) <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"no state_note_track"
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall st a err. (st -> a) -> Deriver st err a
Derive.gets (Dynamic -> Maybe (BlockId, TrackId)
Derive.state_note_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
Derive.state_dynamic)
    Track -> Events
Track.track_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackId -> Deriver 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 = forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Maybe (Maybe PSignal, [Msg])
Derive.state_pitch_map) forall a b. (a -> b) -> a -> b
$
    \(Maybe PSignal
maybe_sig, [Msg]
logs) -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Msg -> Msg
Log.add_prefix (Text
"lookup_pitch_at " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackTime
pos)) forall a b. (a -> b) -> a -> b
$
            forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>=Priority
Log.Warn) 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'.
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip PSignal -> RealTime -> Maybe Pitch
PSignal.at (TrackTime -> RealTime
RealTime.from_score TrackTime
pos) 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 =
    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) forall a b. (a -> b) -> a -> b
$ \Pitch
pitch -> do
        RealTime
rpos <- 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 State Error Note
Pitches.pitch_note forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
rpos Pitch
pitch
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"parse error: " forall a. Semigroup a => a -> a -> a
<> Text
err
    Right Expr
expr -> forall d.
CallableExpr d =>
Bool -> Context d -> Expr -> Deriver (Stream d)
Eval.eval_expr Bool
False 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 = 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 =
                forall val. Context val -> Event
Derive.ctx_event Context x
ctx forall a. a -> [a] -> [a]
: forall val. Context val -> [Event]
Derive.ctx_next_events Context x
ctx
            , ctx_event_end :: TrackTime
Derive.ctx_event_end = Event -> TrackTime
Event.start forall a b. (a -> b) -> a -> b
$ 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) Event -> Deriver (Maybe Pitch)
eval_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall {a} {a}. Either a a -> Maybe a
to_maybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall d.
CallableExpr d =>
Event -> Deriver (Either Text (Stream d))
Eval.eval_event Event
event) forall a b. (a -> b) -> a -> b
$ \Stream PSignal
stream -> do
    RealTime
start <- forall a. Time a => a -> Deriver RealTime
Derive.real (Event -> TrackTime
Event.start Event
event)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PSignal -> RealTime -> Maybe Pitch
PSignal.at (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. Stream a -> [a]
Stream.events_of Stream PSignal
stream) RealTime
start
    where to_maybe :: Either a a -> Maybe a
to_maybe = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just

-- * event timing

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

duration :: PassedArgs a -> TrackTime
duration :: forall a. PassedArgs a -> TrackTime
duration = Event -> TrackTime
Event.duration forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (-) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PassedArgs a -> Deriver RealTime
real_end PassedArgs a
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = forall a. Time a => a -> Deriver RealTime
Derive.real forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PassedArgs a -> TrackTime
start

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

real_end :: PassedArgs a -> Derive.Deriver RealTime
real_end :: forall a. PassedArgs a -> Deriver RealTime
real_end = forall a. Time a => a -> Deriver RealTime
Derive.real forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall val. Context val -> TrackTime
Derive.ctx_event_end forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. PassedArgs a -> TrackTime
next PassedArgs a
args) Event -> TrackTime
Event.end (forall a. [a] -> Maybe a
Lists.head (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> TrackTime
Event.start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> TrackTime
Event.start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> TrackTime
Event.end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PassedArgs a -> [Event]
prev_events

prev_events, next_events :: PassedArgs a -> [Event.Event]
next_events :: forall a. PassedArgs a -> [Event]
next_events = forall val. Context val -> [Event]
Derive.ctx_next_events forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PassedArgs a -> Context a
context
prev_events :: forall a. PassedArgs a -> [Event]
prev_events = forall val. Context val -> [Event]
Derive.ctx_prev_events forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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_ forall f a. Lens f a -> a -> f -> f
#= TrackTime
dur forall a b. (a -> b) -> a -> b
$ forall val. Context val -> Event
Derive.ctx_event Context a
ctx }
    }
    where ctx :: Context a
ctx = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Time a => a -> Deriver RealTime
Derive.real TrackTime
start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Time a => a -> Deriver RealTime
Derive.real TrackTime
end
    where (TrackTime
start, TrackTime
end) = 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 forall a. Eq a => a -> a -> Bool
== TrackTime
end = (TrackTime
start, forall a. PassedArgs a -> TrackTime
next PassedArgs a
args)
    | Bool
otherwise = (TrackTime
start, TrackTime
end)
    where (TrackTime
start, TrackTime
end) = 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 = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Time a => a -> Deriver RealTime
Derive.real TrackTime
start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Time a => a -> Deriver RealTime
Derive.real TrackTime
end
    where (TrackTime
start, TrackTime
end) = 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 forall a. Eq a => a -> a -> Bool
== TrackTime
end = do
        Maybe TrackTime
note_start <- forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.note_start
        Maybe TrackTime
note_end <- 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 forall a. Ord a => a -> a -> Bool
< TrackTime
note_start -> forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime
note_start, TrackTime
note_start)
                | Bool
otherwise ->
                    forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime
start, forall a. Ord a => a -> a -> a
min (forall a. PassedArgs a -> TrackTime
next PassedArgs a
args) (forall a. Ord a => a -> a -> a
max TrackTime
end TrackTime
note_end))
            (Maybe TrackTime, Maybe TrackTime)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime
start, forall a. PassedArgs a -> TrackTime
next PassedArgs a
args)
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime
start, TrackTime
end)
    where (TrackTime
start, TrackTime
end) = 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)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. PassedArgs a -> Event
event PassedArgs a
args
    RealTime
start <- forall a. Time a => a -> Deriver RealTime
Derive.real (Event -> TrackTime
Event.start Event
e)
    RealTime
end <- forall a. Time a => a -> Deriver RealTime
Derive.real (Event -> TrackTime
Event.end Event
e)
    forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime
start, RealTime
end 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 forall a. Num a => a -> a -> a
+ TrackTime
start, TrackTime
shifted forall a. Num a => a -> a -> a
+ TrackTime
end)
    where
    (TrackTime
start, TrackTime
end) = forall a. PassedArgs a -> (TrackTime, TrackTime)
range PassedArgs a
args
    shifted :: TrackTime
shifted = forall val. Context val -> TrackTime
Derive.ctx_track_shifted (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 = forall a. TrackTime -> TrackTime -> Deriver a -> Deriver a
Derive.place (- (TrackTime
start forall a. Fractional a => a -> a -> a
/ TrackTime
dur)) (TrackTime
1 forall a. Fractional a => a -> a -> a
/ TrackTime
dur)
    where
    (TrackTime
start, TrackTime
dur_) = forall a. PassedArgs a -> (TrackTime, TrackTime)
extent PassedArgs a
args
    dur :: TrackTime
dur = if TrackTime
dur_ 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 = forall a. TrackTime -> Deriver a -> Deriver a
Derive.at (- 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.
-}