-- 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 DeriveDataTypeable #-}
{- | This has Score.Event, which is the main output of the deriver.

    The events here are generated from UI Events, and will eventually be
    transformed into Perform Events, which are specific to the performance
    backend.
-}
module Derive.Score (
    -- * Event
    Event(..)
    , short_event, short_events
    , empty_event, event_end, event_min, event_max
    , events_overlap
    , event_scale_id
    , copy, normalize
    -- ** flags
    , has_flags, add_flags, remove_flags
    -- ** logs
    , add_log, add_log_msg
    -- ** environ
    , modify_environ, modify_environ_key
    -- ** attributes
    , event_attributes, has_attribute, intersecting_attributes
    , modify_attributes, add_attributes, remove_attributes
    -- ** delayed args
    , put_arg, take_arg

    -- ** modify events
    , move, place, move_start, duration, set_duration, set_instrument
    -- *** control
    , control_at, event_control, initial_dynamic, modify_dynamic, set_dynamic
    , modify_control
    , set_control, event_controls_at
    -- *** pitch
    , set_pitch, set_named_pitch, event_named_pitch
    , transposed_at, pitch_at, apply_controls
    , initial_pitch, nn_at, initial_nn, note_at, initial_note
    , nn_signal
) where
import qualified Control.DeepSeq as DeepSeq
import           Control.DeepSeq (rnf)
import qualified Data.Dynamic as Dynamic
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Typeable as Typeable

import qualified Util.CallStack as CallStack
import qualified Util.Log as Log
import qualified Util.Pretty as Pretty

import qualified Derive.Attrs as Attrs
import qualified Derive.Controls as Controls
import qualified Derive.DeriveT as DeriveT
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Flags as Flags
import qualified Derive.PSignal as PSignal
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack

import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal
import qualified Ui.Color as Color

import           Global
import           Types


-- * Event

data Event = Event {
    Event -> RealTime
event_start :: !RealTime
    , Event -> RealTime
event_duration :: !RealTime
    -- | This is the text of the call that created the event.  It's basically
    -- just for debugging.
    , Event -> Text
event_text :: !Text
    , Event -> ControlMap
event_controls :: !DeriveT.ControlMap
    , Event -> PSignal
event_pitch :: !PSignal.PSignal
    -- | Named pitch signals.
    , Event -> PitchMap
event_pitches :: !DeriveT.PitchMap
    -- | Keep track of where this event originally came from.  That way, if an
    -- error or warning is emitted concerning this event, its position on the
    -- UI can be highlighted.
    , Event -> Stack
event_stack :: !Stack.Stack
    , Event -> Highlight
event_highlight :: !Color.Highlight
    , Event -> Instrument
event_instrument :: !ScoreT.Instrument
    , Event -> Environ
event_environ :: !DeriveT.Environ
    -- | Flags have their own field rather than being in 'event_environ', this
    -- emphasizes that they're meant to be used by calls and not from the
    -- score.
    , Event -> Flags
event_flags :: !Flags.Flags
    -- | This has arguments passed from a call that applies an attribute to one
    -- which is meant to later realize the attribute.  This happens when a call
    -- needs to be configured at the track level, but also needs some
    -- information only available later, such as the real start time or pitch
    -- of the next note.  They are indexed by attribute because there may be
    -- multiple delayed calls on a single note, and the realize postproc may
    -- want to ignore some, e.g. if they are overidden by another attribute.
    --
    -- I couldn't think of a type safe way to do this, but Dynamic should be
    -- safe enough if you use a shared type declaration in both writer and
    -- reader.
    , Event -> Map Text Dynamic
event_delayed_args :: !(Map Text Dynamic.Dynamic)
    -- | Keep track of interesting things that have happened to this event.
    -- Postproc transforms that alter it should prefix a note.
    , Event -> [Msg]
event_logs :: ![Log.Msg]
    } deriving (Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show, Typeable.Typeable)

-- | Format an event in a way suitable for including inline in log messages.
-- It's short, but hopefully enough information to identify the event in
-- question.
--
-- This is the derive equivalent to 'Cmd.Cmd.log_event'.
short_event :: Event -> Text
short_event :: Event -> Text
short_event Event
e = Doc -> Text
forall a. Pretty a => a -> Text
pretty (Doc -> Text) -> Doc -> Text
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc -> Doc) -> [Doc] -> Doc
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
(Pretty.<+>) ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Doc]] -> [Doc]) -> [[Doc]] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ([Doc] -> Bool) -> [[Doc]] -> [[Doc]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Doc] -> Bool) -> [Doc] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
    [ [(RealTime, RealTime) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Event -> RealTime
event_start Event
e, Event -> RealTime
event_duration Event
e)]
    , [Instrument -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Event -> Instrument
event_instrument Event
e)]
    , [Note -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Note
n | Just Note
n <- [Event -> Maybe Note
initial_note Event
e]]
    , [Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Event -> Text
event_text Event
e) | Bool -> Bool
not (Text -> Bool
Text.null (Event -> Text
event_text Event
e))]
    , [Text -> Doc
Pretty.text Text
stack
        | Just Text
stack <- [Stack -> Maybe Text
Stack.pretty_ui_inner (Event -> Stack
event_stack Event
e)]]
    ]

short_events :: [Event] -> Text
short_events :: [Event] -> Text
short_events =
    Doc -> Text
forall a. Pretty a => a -> Text
pretty (Doc -> Text) -> ([Event] -> Doc) -> [Event] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char -> [Doc] -> Doc
forall a. Pretty a => Char -> Char -> [a] -> Doc
Pretty.formattedList Char
'[' Char
']' ([Doc] -> Doc) -> ([Event] -> [Doc]) -> [Event] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> Doc) -> [Event] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Doc
Pretty.text (Text -> Doc) -> (Event -> Text) -> Event -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Text
short_event)

empty_event :: Event
empty_event :: Event
empty_event = Event
    { event_start :: RealTime
event_start = RealTime
0
    , event_duration :: RealTime
event_duration = RealTime
0
    , event_text :: Text
event_text = Text
forall a. Monoid a => a
mempty
    , event_controls :: ControlMap
event_controls = ControlMap
forall a. Monoid a => a
mempty
    , event_pitch :: PSignal
event_pitch = PSignal
forall a. Monoid a => a
mempty
    , event_pitches :: PitchMap
event_pitches = PitchMap
forall a. Monoid a => a
mempty
    , event_stack :: Stack
event_stack = Stack
Stack.empty
    , event_highlight :: Highlight
event_highlight = Highlight
Color.NoHighlight
    , event_instrument :: Instrument
event_instrument = Instrument
ScoreT.empty_instrument
    , event_environ :: Environ
event_environ = Environ
forall a. Monoid a => a
mempty
    , event_flags :: Flags
event_flags = Flags
forall a. Monoid a => a
mempty
    , event_delayed_args :: Map Text Dynamic
event_delayed_args = Map Text Dynamic
forall a. Monoid a => a
mempty
    , event_logs :: [Msg]
event_logs = []
    }

event_end :: Event -> RealTime
event_end :: Event -> RealTime
event_end Event
event = Event -> RealTime
event_start Event
event RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ Event -> RealTime
event_duration Event
event

-- | Get minimum and maximum edges of the event.  'event_start' isn't
-- necessarily the minimum because of negative durations.
event_min, event_max :: Event -> RealTime
event_min :: Event -> RealTime
event_min Event
event = RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
min (Event -> RealTime
event_start Event
event) (Event -> RealTime
event_end Event
event)
event_max :: Event -> RealTime
event_max Event
event = RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max (Event -> RealTime
event_start Event
event) (Event -> RealTime
event_end Event
event)

events_overlap :: Event -> Event -> Bool
events_overlap :: Event -> Event -> Bool
events_overlap Event
e1 Event
e2 =
    Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Event -> RealTime
event_end Event
e1 RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<= Event -> RealTime
event_end Event
e2 Bool -> Bool -> Bool
|| Event -> RealTime
event_start Event
e1 RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>= Event -> RealTime
event_end Event
e2

event_scale_id :: Event -> Pitch.ScaleId
event_scale_id :: Event -> ScaleId
event_scale_id = PSignal -> ScaleId
PSignal.sig_scale_id (PSignal -> ScaleId) -> (Event -> PSignal) -> Event -> ScaleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> PSignal
event_pitch

-- | If you use an event to create another event, call this to clear out
-- data that shouldn't go with the copy.
copy :: Event -> Event
copy :: Event -> Event
copy Event
event = Event
event { event_flags :: Flags
event_flags = Flags
forall a. Monoid a => a
mempty, event_logs :: [Msg]
event_logs = [] }

-- | Apply environ and controls to pitches.
--
-- Normally this is done by Convert, but if you want to see an event for
-- debugging it can be nicer to see the normalized version.
--
-- Unlike "Perform.Midi.Convert", this doesn't trim the controls, so it applies
-- out-of-range transpositions.
normalize :: Event -> Event
normalize :: Event -> Event
normalize Event
event = Event
event
    { event_pitch :: PSignal
event_pitch = PSignal -> PSignal
apply (PSignal -> PSignal) -> PSignal -> PSignal
forall a b. (a -> b) -> a -> b
$ Event -> PSignal
event_pitch Event
event
    , event_pitches :: PitchMap
event_pitches = PSignal -> PSignal
apply (PSignal -> PSignal) -> PitchMap -> PitchMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> PitchMap
event_pitches Event
event
    }
    where
    apply :: PSignal -> PSignal
apply = ControlMap -> PSignal -> PSignal
PSignal.apply_controls ControlMap
controls
        (PSignal -> PSignal) -> (PSignal -> PSignal) -> PSignal -> PSignal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> PSignal -> PSignal
PSignal.apply_environ (Event -> Environ
event_environ Event
event)
    controls :: ControlMap
controls = Event -> ControlMap
event_controls Event
event

-- ** flags

has_flags :: Flags.Flags -> Event -> Bool
has_flags :: Flags -> Event -> Bool
has_flags Flags
flags = (Flags -> Flags -> Bool
`Flags.has` Flags
flags) (Flags -> Bool) -> (Event -> Flags) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Flags
event_flags

add_flags :: Flags.Flags -> Event -> Event
add_flags :: Flags -> Event -> Event
add_flags Flags
flags Event
event = Event
event { event_flags :: Flags
event_flags = Flags
flags Flags -> Flags -> Flags
forall a. Semigroup a => a -> a -> a
<> Event -> Flags
event_flags Event
event }

remove_flags :: Flags.Flags -> Event -> Event
remove_flags :: Flags -> Event -> Event
remove_flags Flags
flags Event
event =
    Event
event { event_flags :: Flags
event_flags = Event -> Flags
event_flags Event
event Flags -> Flags -> Flags
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Flags
flags }

-- ** logs

add_log :: CallStack.Stack => Text -> Event -> Event
add_log :: Stack => Text -> Event -> Event
add_log Text
msg = Msg -> Event -> Event
add_log_msg (Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Debug Maybe Stack
forall a. Maybe a
Nothing Text
msg)

add_log_msg :: Log.Msg -> Event -> Event
add_log_msg :: Msg -> Event -> Event
add_log_msg Msg
msg Event
event = Event
event { event_logs :: [Msg]
event_logs = Msg
msg Msg -> [Msg] -> [Msg]
forall a. a -> [a] -> [a]
: Event -> [Msg]
event_logs Event
event }

-- ** environ

modify_environ :: (DeriveT.Environ -> DeriveT.Environ) -> Event -> Event
modify_environ :: (Environ -> Environ) -> Event -> Event
modify_environ Environ -> Environ
f Event
event = Event
event { event_environ :: Environ
event_environ = Environ -> Environ
f (Event -> Environ
event_environ Event
event) }

-- | Modify the value at the given key.
modify_environ_key :: EnvKey.Key
    -> (Maybe DeriveT.Val -> DeriveT.Val) -> Event -> Event
modify_environ_key :: Text -> (Maybe Val -> Val) -> Event -> Event
modify_environ_key Text
key Maybe Val -> Val
modify = (Environ -> Environ) -> Event -> Event
modify_environ ((Environ -> Environ) -> Event -> Event)
-> (Environ -> Environ) -> Event -> Event
forall a b. (a -> b) -> a -> b
$ \(DeriveT.Environ Map Text Val
env) ->
    Map Text Val -> Environ
DeriveT.Environ (Map Text Val -> Environ) -> Map Text Val -> Environ
forall a b. (a -> b) -> a -> b
$ (Maybe Val -> Maybe Val) -> Text -> Map Text Val -> Map Text Val
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Val -> Maybe Val
forall a. a -> Maybe a
Just (Val -> Maybe Val) -> (Maybe Val -> Val) -> Maybe Val -> Maybe Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Val -> Val
modify) Text
key Map Text Val
env

-- ** attributes

event_attributes :: Event -> Attrs.Attributes
event_attributes :: Event -> Attributes
event_attributes = Environ -> Attributes
DeriveT.environ_attributes (Environ -> Attributes)
-> (Event -> Environ) -> Event -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
event_environ

has_attribute :: Attrs.Attributes -> Event -> Bool
has_attribute :: Attributes -> Event -> Bool
has_attribute Attributes
attr = (Attributes -> Attributes -> Bool
`Attrs.contain` Attributes
attr) (Attributes -> Bool) -> (Event -> Attributes) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Attributes
event_attributes

intersecting_attributes :: Attrs.Attributes -> Event -> Bool
intersecting_attributes :: Attributes -> Event -> Bool
intersecting_attributes Attributes
attrs Event
event =
    Attributes -> Attributes -> Attributes
Attrs.intersection Attributes
attrs (Event -> Attributes
event_attributes Event
event) Attributes -> Attributes -> Bool
forall a. Eq a => a -> a -> Bool
/= Attributes
forall a. Monoid a => a
mempty

modify_attributes :: (Attrs.Attributes -> Attrs.Attributes) -> Event -> Event
modify_attributes :: (Attributes -> Attributes) -> Event -> Event
modify_attributes Attributes -> Attributes
modify = (Environ -> Environ) -> Event -> Event
modify_environ ((Environ -> Environ) -> Event -> Event)
-> (Environ -> Environ) -> Event -> Event
forall a b. (a -> b) -> a -> b
$ \Environ
env ->
    Text -> Val -> Environ -> Environ
DeriveT.insert Text
EnvKey.attributes
        (Attributes -> Val
DeriveT.VAttributes (Attributes -> Attributes
modify (Environ -> Attributes
DeriveT.environ_attributes Environ
env))) Environ
env

add_attributes :: Attrs.Attributes -> Event -> Event
add_attributes :: Attributes -> Event -> Event
add_attributes Attributes
attrs
    | Attributes
attrs Attributes -> Attributes -> Bool
forall a. Eq a => a -> a -> Bool
== Attributes
forall a. Monoid a => a
mempty = Event -> Event
forall a. a -> a
id
    | Bool
otherwise = (Attributes -> Attributes) -> Event -> Event
modify_attributes (Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<>Attributes
attrs)

remove_attributes :: Attrs.Attributes -> Event -> Event
remove_attributes :: Attributes -> Event -> Event
remove_attributes Attributes
attrs Event
event
    | Attributes
attrs Attributes -> Attributes -> Bool
forall a. Eq a => a -> a -> Bool
== Attributes
forall a. Monoid a => a
mempty Bool -> Bool -> Bool
|| Bool -> Bool
not (Attributes -> Event -> Bool
has_attribute Attributes
attrs Event
event) = Event
event
    | Bool
otherwise = (Attributes -> Attributes) -> Event -> Event
modify_attributes (Attributes -> Attributes -> Attributes
Attrs.remove Attributes
attrs) Event
event

instance DeepSeq.NFData Event where
    rnf :: Event -> ()
rnf (Event RealTime
start RealTime
dur Text
text ControlMap
controls PSignal
pitch PitchMap
pitches Stack
_ Highlight
_ Instrument
_ Environ
_
            Flags
flags Map Text Dynamic
_delayed_args [Msg]
logs) =
        -- I can't force Dynamic, so leave off _delayed_args.
        (RealTime, RealTime, Text, ControlMap, PSignal, PitchMap, Flags,
 [Msg])
-> ()
forall a. NFData a => a -> ()
rnf (RealTime
start, RealTime
dur, Text
text, ControlMap
controls, PSignal
pitch, PitchMap
pitches, Flags
flags, [Msg]
logs)

instance Pretty Event where
    format :: Event -> Doc
format (Event RealTime
start RealTime
dur Text
text ControlMap
controls PSignal
pitch PitchMap
pitches
            Stack
stack Highlight
highlight Instrument
inst Environ
env Flags
flags Map Text Dynamic
delayed_args [Msg]
logs) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record (Doc
"Event"
                Doc -> Doc -> Doc
Pretty.<+> (RealTime, RealTime) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (RealTime
start, RealTime
dur)
                Doc -> Doc -> Doc
Pretty.<+> Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Text
text)
            [ (Text
"instrument", Instrument -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Instrument
inst)
            , (Text
"pitch", PSignal -> Doc
forall a. Pretty a => a -> Doc
Pretty.format PSignal
pitch)
            , (Text
"pitches", PitchMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format PitchMap
pitches)
            , (Text
"controls", ControlMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ControlMap
controls)
            , (Text
"stack", Stack -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Stack
stack)
            , (Text
"highlight", Text -> Doc
Pretty.text (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ Highlight -> Text
forall a. Show a => a -> Text
showt Highlight
highlight)
            , (Text
"environ", Environ -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Environ
env)
            , (Text
"flags", Flags -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Flags
flags)
            , (Text
"delayed_args", Map Text Dynamic -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map Text Dynamic
delayed_args)
            , (Text
"logs", [Msg] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Msg]
logs)
            ]

-- ** delayed args

put_arg :: Typeable.Typeable a => Text -> a -> Event -> Event
put_arg :: forall a. Typeable a => Text -> a -> Event -> Event
put_arg Text
key a
arg Event
event = Event
event
    { event_delayed_args :: Map Text Dynamic
event_delayed_args = Text -> Dynamic -> Map Text Dynamic -> Map Text Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
key (a -> Dynamic
forall a. Typeable a => a -> Dynamic
Dynamic.toDyn a
arg)
        (Event -> Map Text Dynamic
event_delayed_args Event
event)
    }

-- | Find an arg in 'event_delayed_args', and remove it from the event if it
-- existed.  Throw an error if it existed but had an unexpected type.
take_arg :: Typeable.Typeable a => Text -> Event
    -> Either Text (Event, Maybe a)
take_arg :: forall a.
Typeable a =>
Text -> Event -> Either Text (Event, Maybe a)
take_arg Text
key Event
event = case Text -> Map Text Dynamic -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
key (Event -> Map Text Dynamic
event_delayed_args Event
event) of
    Maybe Dynamic
Nothing -> (Event, Maybe a) -> Either Text (Event, Maybe a)
forall a b. b -> Either a b
Right (Event
event, Maybe a
forall a. Maybe a
Nothing)
    Just Dynamic
arg -> case Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
Dynamic.fromDynamic Dynamic
arg of
        Maybe a
Nothing -> Text -> Either Text (Event, Maybe a)
forall a b. a -> Either a b
Left (Text -> Either Text (Event, Maybe a))
-> Text -> Either Text (Event, Maybe a)
forall a b. (a -> b) -> a -> b
$ Text
"incorrect delayed arg type for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showt Text
key
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Dynamic -> Text
forall a. Pretty a => a -> Text
pretty Dynamic
arg
        Just a
a -> (Event, Maybe a) -> Either Text (Event, Maybe a)
forall a b. b -> Either a b
Right (Text -> Event -> Event
delete_arg Text
key Event
event, a -> Maybe a
forall a. a -> Maybe a
Just a
a)

delete_arg :: Text -> Event -> Event
delete_arg :: Text -> Event -> Event
delete_arg Text
key Event
event =
    Event
event { event_delayed_args :: Map Text Dynamic
event_delayed_args = Text -> Map Text Dynamic -> Map Text Dynamic
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
key (Event -> Map Text Dynamic
event_delayed_args Event
event) }

-- ** modify events

-- These operate directly on events, so we are in RealTime at this point.

-- | Change the start time of an event and move its controls along with it.
move :: (RealTime -> RealTime) -> Event -> Event
move :: (RealTime -> RealTime) -> Event -> Event
move RealTime -> RealTime
modify Event
event
    | RealTime
pos RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== Event -> RealTime
event_start Event
event = Event
event
    | Bool
otherwise = Event
event
        { event_start :: RealTime
event_start = RealTime
pos
        , event_controls :: ControlMap
event_controls = (Control -> Control) -> Typed Control -> Typed Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> Control -> Control
forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.shift RealTime
delta) (Typed Control -> Typed Control) -> ControlMap -> ControlMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> ControlMap
event_controls Event
event
        , event_pitch :: PSignal
event_pitch = RealTime -> PSignal -> PSignal
PSignal.shift RealTime
delta (PSignal -> PSignal) -> PSignal -> PSignal
forall a b. (a -> b) -> a -> b
$ Event -> PSignal
event_pitch Event
event
        , event_pitches :: PitchMap
event_pitches = RealTime -> PSignal -> PSignal
PSignal.shift RealTime
delta (PSignal -> PSignal) -> PitchMap -> PitchMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> PitchMap
event_pitches Event
event
        }
    where
    pos :: RealTime
pos = RealTime -> RealTime
modify (Event -> RealTime
event_start Event
event)
    delta :: RealTime
delta = RealTime
pos RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- Event -> RealTime
event_start Event
event

place :: RealTime -> RealTime -> Event -> Event
place :: RealTime -> RealTime -> Event -> Event
place RealTime
start RealTime
dur Event
event = ((RealTime -> RealTime) -> Event -> Event
move (RealTime -> RealTime -> RealTime
forall a b. a -> b -> a
const RealTime
start) Event
event) { event_duration :: RealTime
event_duration = RealTime
dur }

move_start :: RealTime -> RealTime -> Event -> Event
move_start :: RealTime -> RealTime -> Event -> Event
move_start RealTime
min_duration RealTime
offset
    | RealTime
offset RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== RealTime
0 = Event -> Event
forall a. a -> a
id
    | Bool
otherwise = (RealTime -> RealTime) -> Event -> Event
duration (RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max RealTime
min_duration (RealTime -> RealTime)
-> (RealTime -> RealTime) -> RealTime -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
subtract RealTime
offset) (Event -> Event) -> (Event -> Event) -> Event -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime -> RealTime) -> Event -> Event
move (RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+RealTime
offset)

duration :: (RealTime -> RealTime) -> Event -> Event
duration :: (RealTime -> RealTime) -> Event -> Event
duration RealTime -> RealTime
modify Event
event
    | RealTime
dur RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== Event -> RealTime
event_duration Event
event = Event
event
    | Bool
otherwise = Event
event { event_duration :: RealTime
event_duration = RealTime
dur }
    where dur :: RealTime
dur = RealTime -> RealTime
modify (Event -> RealTime
event_duration Event
event)

set_duration :: RealTime -> Event -> Event
set_duration :: RealTime -> Event -> Event
set_duration = (RealTime -> RealTime) -> Event -> Event
duration ((RealTime -> RealTime) -> Event -> Event)
-> (RealTime -> RealTime -> RealTime) -> RealTime -> Event -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> RealTime -> RealTime
forall a b. a -> b -> a
const

-- | Set the instrument on an event, and also update its environ from the
-- instrument.  You should really rederive with the new instrument, but this
-- way can be more convenient, if somewhat sketchy.
set_instrument :: ScoreT.Instrument -> DeriveT.Environ -> Event -> Event
set_instrument :: Instrument -> Environ -> Event -> Event
set_instrument Instrument
score_inst Environ
inst_environ Event
event = Event
event
    { event_instrument :: Instrument
event_instrument = Instrument
score_inst
    , event_environ :: Environ
event_environ = Environ
inst_environ Environ -> Environ -> Environ
forall a. Semigroup a => a -> a -> a
<> Event -> Environ
event_environ Event
event
    }

-- *** control

-- | Get a control value from the event, or Nothing if that control isn't
-- present.
control_at :: RealTime -> ScoreT.Control -> Event
    -> Maybe (ScoreT.Typed Signal.Y)
control_at :: RealTime -> Control -> Event -> Maybe (Typed Y)
control_at RealTime
pos Control
control Event
event =
    (Control -> Y) -> Typed Control -> Typed Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> Control -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
pos) (Typed Control -> Typed Y)
-> Maybe (Typed Control) -> Maybe (Typed Y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Control -> ControlMap -> Maybe (Typed Control)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control (Event -> ControlMap
event_controls Event
event)

event_control :: ScoreT.Control -> Event -> Maybe (ScoreT.Typed Signal.Control)
event_control :: Control -> Event -> Maybe (Typed Control)
event_control Control
control = Control -> ControlMap -> Maybe (Typed Control)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control (ControlMap -> Maybe (Typed Control))
-> (Event -> ControlMap) -> Event -> Maybe (Typed Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> ControlMap
event_controls

initial_dynamic :: Event -> Signal.Y
initial_dynamic :: Event -> Y
initial_dynamic Event
event = Y -> (Typed Y -> Y) -> Maybe (Typed Y) -> Y
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Y
0 Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val (Maybe (Typed Y) -> Y) -> Maybe (Typed Y) -> Y
forall a b. (a -> b) -> a -> b
$
     -- Derive.initial_controls should mean this is never Nothing.
    RealTime -> Control -> Event -> Maybe (Typed Y)
control_at (Event -> RealTime
event_start Event
event) Control
Controls.dynamic Event
event

-- | Use this instead of 'modify_control_vals' because it also sets
-- 'EnvKey.dynamic_val'.  This is only valid for linear functions like (+) or
-- (*).
modify_dynamic :: (Signal.Y -> Signal.Y) -> Event -> Event
modify_dynamic :: (Y -> Y) -> Event -> Event
modify_dynamic Y -> Y
modify =
    Text -> (Maybe Val -> Val) -> Event -> Event
modify_environ_key Text
EnvKey.dynamic_val
            (Typed Y -> Val
DeriveT.VNum (Typed Y -> Val) -> (Maybe Val -> Typed Y) -> Maybe Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Typed Y
forall a. a -> Typed a
ScoreT.untyped (Y -> Typed Y) -> (Maybe Val -> Y) -> Maybe Val -> Typed Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Y
modify (Y -> Y) -> (Maybe Val -> Y) -> Maybe Val -> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Val -> Y
num_of)
        (Event -> Event) -> (Event -> Event) -> Event -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> (Y -> Y) -> Event -> Event
modify_control_vals Control
Controls.dynamic Y -> Y
modify
    where
    num_of :: Maybe Val -> Y
num_of (Just (DeriveT.VNum Typed Y
n)) = Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val Typed Y
n
    num_of Maybe Val
_ = Y
0

-- | Use this instead of 'set_control' because it also sets
-- 'EnvKey.dynamic_val'.
set_dynamic :: Signal.Y -> Event -> Event
set_dynamic :: Y -> Event -> Event
set_dynamic Y
dyn =
    Text -> (Maybe Val -> Val) -> Event -> Event
modify_environ_key Text
EnvKey.dynamic_val
            (Val -> Maybe Val -> Val
forall a b. a -> b -> a
const (Val -> Maybe Val -> Val) -> Val -> Maybe Val -> Val
forall a b. (a -> b) -> a -> b
$ Typed Y -> Val
DeriveT.VNum (Typed Y -> Val) -> Typed Y -> Val
forall a b. (a -> b) -> a -> b
$ Y -> Typed Y
forall a. a -> Typed a
ScoreT.untyped Y
dyn)
        (Event -> Event) -> (Event -> Event) -> Event -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Typed Control -> Event -> Event
set_control Control
Controls.dynamic (Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
dyn))

modify_control_vals :: ScoreT.Control -> (Signal.Y -> Signal.Y) -> Event
    -> Event
modify_control_vals :: Control -> (Y -> Y) -> Event -> Event
modify_control_vals Control
control Y -> Y
modify Event
event = Event
event
    { event_controls :: ControlMap
event_controls = (Typed Control -> Typed Control)
-> Control -> ControlMap -> ControlMap
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((Control -> Control) -> Typed Control -> Typed Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Y -> Y) -> Control -> Control
forall {k} (kind :: k). (Y -> Y) -> Signal kind -> Signal kind
Signal.map_y_linear Y -> Y
modify)) Control
control
        (Event -> ControlMap
event_controls Event
event)
    }

-- | Modify a control.  If there is no existing control, the modify function
-- gets an empty signal.
modify_control :: ScoreT.Control -> (Signal.Control -> Signal.Control) -> Event
    -> Event
modify_control :: Control -> (Control -> Control) -> Event -> Event
modify_control Control
control Control -> Control
modify Event
event = Event
event
    { event_controls :: ControlMap
event_controls =
        (Maybe (Typed Control) -> Maybe (Typed Control))
-> Control -> ControlMap -> ControlMap
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Typed Control -> Maybe (Typed Control)
forall a. a -> Maybe a
Just (Typed Control -> Maybe (Typed Control))
-> (Maybe (Typed Control) -> Typed Control)
-> Maybe (Typed Control)
-> Maybe (Typed Control)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Typed Control) -> Typed Control
forall {f :: * -> *}.
(Functor f, Monoid (f Control)) =>
Maybe (f Control) -> f Control
alter) Control
control (Event -> ControlMap
event_controls Event
event)
    }
    where alter :: Maybe (f Control) -> f Control
alter Maybe (f Control)
old = Control -> Control
modify (Control -> Control) -> f Control -> f Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Control -> Maybe (f Control) -> f Control
forall a. a -> Maybe a -> a
fromMaybe f Control
forall a. Monoid a => a
mempty Maybe (f Control)
old

set_control :: ScoreT.Control -> ScoreT.Typed Signal.Control -> Event -> Event
set_control :: Control -> Typed Control -> Event -> Event
set_control Control
control Typed Control
signal Event
event = Event
event
    { event_controls :: ControlMap
event_controls = Control -> Typed Control -> ControlMap -> ControlMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Control
control Typed Control
signal (Event -> ControlMap
event_controls Event
event) }

event_controls_at :: RealTime -> Event -> ScoreT.ControlValMap
event_controls_at :: RealTime -> Event -> ControlValMap
event_controls_at RealTime
t Event
event =
    Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val (Typed Y -> Y) -> (Typed Control -> Typed Y) -> Typed Control -> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Control -> Y) -> Typed Control -> Typed Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> Control -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
t) (Typed Control -> Y) -> ControlMap -> ControlValMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> ControlMap
event_controls Event
event

-- *** pitch

set_pitch :: PSignal.PSignal -> Event -> Event
set_pitch :: PSignal -> Event -> Event
set_pitch = PControl -> PSignal -> Event -> Event
set_named_pitch PControl
ScoreT.default_pitch

set_named_pitch :: ScoreT.PControl -> PSignal.PSignal -> Event -> Event
set_named_pitch :: PControl -> PSignal -> Event -> Event
set_named_pitch PControl
pcontrol PSignal
signal Event
event
    | PControl
pcontrol PControl -> PControl -> Bool
forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch = Event
event { event_pitch :: PSignal
event_pitch = PSignal
signal }
    | Bool
otherwise = Event
event
        { event_pitches :: PitchMap
event_pitches = PControl -> PSignal -> PitchMap -> PitchMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PControl
pcontrol PSignal
signal (Event -> PitchMap
event_pitches Event
event) }

event_named_pitch :: ScoreT.PControl -> Event -> Maybe PSignal.PSignal
event_named_pitch :: PControl -> Event -> Maybe PSignal
event_named_pitch PControl
pcontrol
    | PControl
pcontrol PControl -> PControl -> Bool
forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch = PSignal -> Maybe PSignal
forall a. a -> Maybe a
Just (PSignal -> Maybe PSignal)
-> (Event -> PSignal) -> Event -> Maybe PSignal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> PSignal
event_pitch
    | Bool
otherwise = PControl -> PitchMap -> Maybe PSignal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PControl
pcontrol (PitchMap -> Maybe PSignal)
-> (Event -> PitchMap) -> Event -> Maybe PSignal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> PitchMap
event_pitches

-- | Unlike 'Derive.Derive.pitch_at', the transposition has already been
-- applied.  This is because callers expect to get the actual pitch, not the
-- pitch plus some homework to do on the pitch.  If you use this pitch to emit
-- another pitch you proabbly need the raw pitch, but so far everyone doing
-- that is at the Derive level, not postproc, so they use Derive.pitch_at.
{-# SCC transposed_at #-}
transposed_at :: RealTime -> Event -> Maybe PSignal.Transposed
transposed_at :: RealTime -> Event -> Maybe Transposed
transposed_at RealTime
pos Event
event = PitchConfig -> RawPitch Untransposed_ -> Transposed
forall a b. PitchConfig -> RawPitch a -> RawPitch b
PSignal.apply_config PitchConfig
config (RawPitch Untransposed_ -> Transposed)
-> Maybe (RawPitch Untransposed_) -> Maybe Transposed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Event -> Maybe (RawPitch Untransposed_)
pitch_at RealTime
pos Event
event
    where
    config :: PitchConfig
config = Environ -> ControlValMap -> PitchConfig
PSignal.PitchConfig (Event -> Environ
event_environ Event
event)
        (RealTime -> Event -> ControlValMap
event_controls_at RealTime
pos Event
event)

pitch_at :: RealTime -> Event -> Maybe PSignal.Pitch
pitch_at :: RealTime -> Event -> Maybe (RawPitch Untransposed_)
pitch_at RealTime
pos Event
event = RealTime -> PSignal -> Maybe (RawPitch Untransposed_)
PSignal.at RealTime
pos (PSignal -> Maybe (RawPitch Untransposed_))
-> PSignal -> Maybe (RawPitch Untransposed_)
forall a b. (a -> b) -> a -> b
$ Event -> PSignal
event_pitch Event
event

apply_controls :: Event -> RealTime -> PSignal.Pitch -> PSignal.Transposed
apply_controls :: Event -> RealTime -> RawPitch Untransposed_ -> Transposed
apply_controls Event
event RealTime
pos = ControlValMap -> RawPitch Untransposed_ -> Transposed
PSignal.apply (RealTime -> Event -> ControlValMap
event_controls_at RealTime
pos Event
event)

initial_pitch :: Event -> Maybe PSignal.Transposed
initial_pitch :: Event -> Maybe Transposed
initial_pitch Event
event = RealTime -> Event -> Maybe Transposed
transposed_at (Event -> RealTime
event_start Event
event) Event
event

nn_at :: RealTime -> Event -> Maybe Pitch.NoteNumber
nn_at :: RealTime -> Event -> Maybe NoteNumber
nn_at RealTime
pos Event
event = (PitchError -> Maybe NoteNumber)
-> (NoteNumber -> Maybe NoteNumber)
-> Either PitchError NoteNumber
-> Maybe NoteNumber
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe NoteNumber -> PitchError -> Maybe NoteNumber
forall a b. a -> b -> a
const Maybe NoteNumber
forall a. Maybe a
Nothing) NoteNumber -> Maybe NoteNumber
forall a. a -> Maybe a
Just (Either PitchError NoteNumber -> Maybe NoteNumber)
-> (Transposed -> Either PitchError NoteNumber)
-> Transposed
-> Maybe NoteNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Either PitchError NoteNumber
PSignal.pitch_nn
    (Transposed -> Maybe NoteNumber)
-> Maybe Transposed -> Maybe NoteNumber
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Event -> Maybe Transposed
transposed_at RealTime
pos Event
event

{-# SCC initial_nn #-}
initial_nn :: Event -> Maybe Pitch.NoteNumber
initial_nn :: Event -> Maybe NoteNumber
initial_nn Event
event = RealTime -> Event -> Maybe NoteNumber
nn_at (Event -> RealTime
event_start Event
event) Event
event

note_at :: RealTime -> Event -> Maybe Pitch.Note
note_at :: RealTime -> Event -> Maybe Note
note_at RealTime
pos Event
event = (PitchError -> Maybe Note)
-> (Note -> Maybe Note) -> Either PitchError Note -> Maybe Note
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Note -> PitchError -> Maybe Note
forall a b. a -> b -> a
const Maybe Note
forall a. Maybe a
Nothing) Note -> Maybe Note
forall a. a -> Maybe a
Just (Either PitchError Note -> Maybe Note)
-> (Transposed -> Either PitchError Note)
-> Transposed
-> Maybe Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Either PitchError Note
PSignal.pitch_note
    (Transposed -> Maybe Note) -> Maybe Transposed -> Maybe Note
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Event -> Maybe Transposed
transposed_at RealTime
pos Event
event

initial_note :: Event -> Maybe Pitch.Note
initial_note :: Event -> Maybe Note
initial_note Event
event = RealTime -> Event -> Maybe Note
note_at (Event -> RealTime
event_start Event
event) Event
event

{-# SCC nn_signal #-}
nn_signal :: Event -> (Signal.NoteNumber, [(RealTime, PSignal.PitchError)])
nn_signal :: Event -> (NoteNumber, [(RealTime, PitchError)])
nn_signal Event
event =
    PSignal -> (NoteNumber, [(RealTime, PitchError)])
PSignal.to_nn (PSignal -> (NoteNumber, [(RealTime, PitchError)]))
-> PSignal -> (NoteNumber, [(RealTime, PitchError)])
forall a b. (a -> b) -> a -> b
$ ControlMap -> PSignal -> PSignal
PSignal.apply_controls (Event -> ControlMap
event_controls Event
event) (PSignal -> PSignal) -> PSignal -> PSignal
forall a b. (a -> b) -> a -> b
$
        Environ -> PSignal -> PSignal
PSignal.apply_environ (Event -> Environ
event_environ Event
event) (PSignal -> PSignal) -> PSignal -> PSignal
forall a b. (a -> b) -> a -> b
$
        Event -> PSignal
event_pitch Event
event