-- 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_val
    -- ** 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
    , event_controls
    , control_at, event_control, initial_dynamic, modify_dynamic, set_dynamic
    , modify_control_vals, modify_control, modify_signal
    , 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.List as List
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.Lists as Lists
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 -> Key
event_text :: !Text
    -- | If the event is integrated back to a Ui.Event, use this text.  This is
    -- so calls can explicitly set how they would like their events to be
    -- integrated.  Otherwise, Integrate.Convert will try to infer something.
    , Event -> Key
event_integrate :: !Text
    , Event -> PSignal
event_pitch :: !PSignal.PSignal
    -- | 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 Key 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
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 -> Key
short_event Event
e = [Key] -> Key
Text.unwords forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [forall a. Pretty a => a -> Key
pretty (Event -> RealTime
event_start Event
e, Event -> RealTime
event_duration Event
e)]
    , [Key
"\"" forall a. Semigroup a => a -> a -> a
<> Event -> Key
event_text Event
e forall a. Semigroup a => a -> a -> a
<> Key
"\"" | Event -> Key
event_text Event
e forall a. Eq a => a -> a -> Bool
/= Key
""]
    , [Key
"'" forall a. Semigroup a => a -> a -> a
<> Event -> Key
event_integrate Event
e forall a. Semigroup a => a -> a -> a
<> Key
"'" | Event -> Key
event_integrate Event
e forall a. Eq a => a -> a -> Bool
/= Key
""]
    , [forall a. Pretty a => a -> Key
pretty (Event -> Instrument
event_instrument Event
e)]
    , [forall a. Pretty a => a -> Key
pretty Note
n | Just Note
n <- [Event -> Maybe Note
initial_note Event
e]]
    , [forall a. Pretty a => a -> Key
pretty Attributes
attrs |  Attributes
attrs forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty]
    , [Key
stack | Just Key
stack <- [Stack -> Maybe Key
Stack.pretty_ui_inner (Event -> Stack
event_stack Event
e)]]
    ]
    where attrs :: Attributes
attrs = Event -> Attributes
event_attributes Event
e

short_events :: [Event] -> Text
short_events :: [Event] -> Key
short_events [Event]
events = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
    Key
"[" forall a. a -> [a] -> [a]
: forall a. a -> [a] -> [a]
List.intersperse Key
", " (forall a b. (a -> b) -> [a] -> [b]
map Event -> Key
short_event [Event]
events) forall a. [a] -> [a] -> [a]
++ [Key
"]"]

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 :: Key
event_text = forall a. Monoid a => a
mempty
    , event_integrate :: Key
event_integrate = forall a. Monoid a => a
mempty
    , event_pitch :: PSignal
event_pitch = 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 = forall a. Monoid a => a
mempty
    , event_flags :: Flags
event_flags = forall a. Monoid a => a
mempty
    , event_delayed_args :: Map Key Dynamic
event_delayed_args = 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 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 = 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 = 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 forall a b. (a -> b) -> a -> b
$ Event -> RealTime
event_end Event
e1 forall a. Ord a => a -> a -> Bool
<= Event -> RealTime
event_end Event
e2 Bool -> Bool -> Bool
|| Event -> RealTime
event_start Event
e1 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 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 = 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 forall a b. (a -> b) -> a -> b
$ Event -> PSignal
event_pitch Event
event }
    where
    apply :: PSignal -> PSignal
apply = ControlMap -> PSignal -> PSignal
PSignal.apply_controls ControlMap
controls
        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) 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 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 forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Flags
flags }

-- ** logs

add_log :: CallStack.Stack => Text -> Event -> Event
add_log :: Stack => Key -> Event -> Event
add_log Key
msg = Msg -> Event -> Event
add_log_msg (Stack => Priority -> Maybe Stack -> Key -> Msg
Log.msg Priority
Log.Debug forall a. Maybe a
Nothing Key
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 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_val :: EnvKey.Key -> (Maybe DeriveT.Val -> DeriveT.Val) -> Event -> Event
modify_val :: Key -> (Maybe Val -> Val) -> Event -> Event
modify_val Key
key Maybe Val -> Val
modify = (Environ -> Environ) -> Event -> Event
modify_environ forall a b. (a -> b) -> a -> b
$ \(DeriveT.Environ Map Key Val
env) ->
    Map Key Val -> Environ
DeriveT.Environ forall a b. (a -> b) -> a -> b
$ forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Val -> Val
modify) Key
key Map Key Val
env

put_val :: EnvKey.Key -> DeriveT.Val -> Event -> Event
put_val :: Key -> Val -> Event -> Event
put_val Key
key = Key -> (Maybe Val -> Val) -> Event -> Event
modify_val Key
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

lookup_val :: EnvKey.Key -> Event -> Maybe DeriveT.Val
lookup_val :: Key -> Event -> Maybe Val
lookup_val Key
key = Key -> Environ -> Maybe Val
DeriveT.lookup Key
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
event_environ

-- ** attributes

event_attributes :: Event -> Attrs.Attributes
event_attributes :: Event -> Attributes
event_attributes = Environ -> Attributes
DeriveT.environ_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) 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) forall a. Eq a => a -> a -> Bool
/= 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 forall a b. (a -> b) -> a -> b
$ \Environ
env ->
    Key -> Val -> Environ -> Environ
DeriveT.insert Key
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 forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = forall a. a -> a
id
    | Bool
otherwise = (Attributes -> Attributes) -> Event -> Event
modify_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 forall a. Eq a => a -> a -> Bool
== 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 Key
_text Key
_integrate PSignal
pitch Stack
_ Highlight
_ Instrument
_ Environ
_ Flags
flags
            Map Key Dynamic
_delayed_args [Msg]
logs) =
        -- I can't force Dynamic, so leave off _delayed_args.
        forall a. NFData a => a -> ()
rnf (RealTime
start, RealTime
dur, PSignal
pitch, Flags
flags, [Msg]
logs)

instance Pretty Event where
    format :: Event -> Doc
format e :: Event
e@(Event RealTime
start RealTime
dur Key
text Key
integrate PSignal
pitch Stack
stack Highlight
highlight Instrument
inst Environ
env
            Flags
flags Map Key Dynamic
delayed_args [Msg]
logs) =
        Doc -> [(Key, Doc)] -> Doc
Pretty.record (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
(Pretty.<+>) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [Doc
"Event", forall a. Pretty a => a -> Doc
Pretty.format (RealTime
start, RealTime
dur)]
            , [Key -> Doc
Pretty.text forall a b. (a -> b) -> a -> b
$ Key
"\"" forall a. Semigroup a => a -> a -> a
<> Key
text forall a. Semigroup a => a -> a -> a
<> Key
"\"" | Key
text forall a. Eq a => a -> a -> Bool
/= Key
""]
            , [Key -> Doc
Pretty.text forall a b. (a -> b) -> a -> b
$ Key
"'" forall a. Semigroup a => a -> a -> a
<> Key
integrate forall a. Semigroup a => a -> a -> a
<> Key
"'" | Key
integrate forall a. Eq a => a -> a -> Bool
/= Key
""]
            , [forall a. Pretty a => a -> Doc
Pretty.format Note
n | Just Note
n <- [Event -> Maybe Note
initial_note Event
e]]
            , [ forall a. Pretty a => a -> Doc
Pretty.format Attributes
attrs
              | let attrs :: Attributes
attrs = Environ -> Attributes
DeriveT.environ_attributes Environ
env, Attributes
attrs forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty
              ]
            ]) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [(Key
"instrument", forall a. Pretty a => a -> Doc
Pretty.format Instrument
inst)]
            , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)]
g Key
"pitch" PSignal
pitch PSignal -> Bool
PSignal.null
            , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)]
g Key
"stack" Stack
stack (forall a. Eq a => a -> a -> Bool
== Stack
Stack.empty)
            , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)]
g Key
"highlight" Highlight
highlight (forall a. Eq a => a -> a -> Bool
== Highlight
Color.NoHighlight)
            , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)]
g Key
"environ" Environ
env Environ -> Bool
DeriveT.null
            , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)]
g Key
"flags" Flags
flags forall a. Set a -> Bool
Set.null
            , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)]
g Key
"delayed_args" Map Key Dynamic
delayed_args forall k a. Map k a -> Bool
Map.null
            , forall {a} {a}. Pretty a => a -> a -> (a -> Bool) -> [(a, Doc)]
g Key
"logs" [Msg]
logs forall (t :: * -> *) a. Foldable t => t a -> Bool
null
            ]
        where
        g :: a -> a -> (a -> Bool) -> [(a, Doc)]
g a
name a
val a -> Bool
empty = [(a
name, forall a. Pretty a => a -> Doc
Pretty.format a
val) | Bool -> Bool
not (a -> Bool
empty a
val)]

-- ** delayed args

put_arg :: Typeable.Typeable a => Text -> a -> Event -> Event
put_arg :: forall a. Typeable a => Key -> a -> Event -> Event
put_arg Key
key a
arg Event
event = Event
event
    { event_delayed_args :: Map Key Dynamic
event_delayed_args = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Key
key (forall a. Typeable a => a -> Dynamic
Dynamic.toDyn a
arg)
        (Event -> Map Key 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 => Key -> Event -> Either Key (Event, Maybe a)
take_arg Key
key Event
event = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key (Event -> Map Key Dynamic
event_delayed_args Event
event) of
    Maybe Dynamic
Nothing -> forall a b. b -> Either a b
Right (Event
event, forall a. Maybe a
Nothing)
    Just Dynamic
arg -> case forall a. Typeable a => Dynamic -> Maybe a
Dynamic.fromDynamic Dynamic
arg of
        Maybe a
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Key
"incorrect delayed arg type for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Key
showt Key
key
            forall a. Semigroup a => a -> a -> a
<> Key
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty Dynamic
arg
        Just a
a -> forall a b. b -> Either a b
Right (Key -> Event -> Event
delete_arg Key
key Event
event, forall a. a -> Maybe a
Just a
a)

delete_arg :: Text -> Event -> Event
delete_arg :: Key -> Event -> Event
delete_arg Key
key Event
event =
    Event
event { event_delayed_args :: Map Key Dynamic
event_delayed_args = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Key
key (Event -> Map Key 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 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_environ :: Environ
event_environ = ([(Key, Val)] -> [(Key, Val)]) -> Environ -> Environ
modify_env (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Val -> Val
shift))
            (Event -> Environ
event_environ Event
event)
        , event_pitch :: PSignal
event_pitch = RealTime -> PSignal -> PSignal
PSignal.shift RealTime
delta forall a b. (a -> b) -> a -> b
$ Event -> PSignal
event_pitch Event
event
        }
    where
    shift :: Val -> Val
shift = \case
        DeriveT.VSignal Typed Control
sig -> Typed Control -> Val
DeriveT.VSignal forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.shift RealTime
delta forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Control
sig
        DeriveT.VPSignal PSignal
sig -> PSignal -> Val
DeriveT.VPSignal forall a b. (a -> b) -> a -> b
$ RealTime -> PSignal -> PSignal
PSignal.shift RealTime
delta PSignal
sig
        Val
val -> Val
val
    pos :: RealTime
pos = RealTime -> RealTime
modify (Event -> RealTime
event_start Event
event)
    delta :: RealTime
delta = RealTime
pos forall a. Num a => a -> a -> a
- Event -> RealTime
event_start Event
event

modify_env :: ([(EnvKey.Key, DeriveT.Val)] -> [(EnvKey.Key, DeriveT.Val)])
    -> DeriveT.Environ -> DeriveT.Environ
modify_env :: ([(Key, Val)] -> [(Key, Val)]) -> Environ -> Environ
modify_env [(Key, Val)] -> [(Key, Val)]
modify (DeriveT.Environ Map Key Val
env) = Map Key Val -> Environ
DeriveT.Environ forall a b. (a -> b) -> a -> b
$
    forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList forall a b. (a -> b) -> a -> b
$ [(Key, Val)] -> [(Key, Val)]
modify forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList Map Key Val
env

place :: RealTime -> RealTime -> Event -> Event
place :: RealTime -> RealTime -> Event -> Event
place RealTime
start RealTime
dur Event
event = ((RealTime -> RealTime) -> Event -> Event
move (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 forall a. Eq a => a -> a -> Bool
== RealTime
0 = forall a. a -> a
id
    | Bool
otherwise = (RealTime -> RealTime) -> Event -> Event
duration (forall a. Ord a => a -> a -> a
max RealTime
min_duration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract RealTime
offset) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime -> RealTime) -> Event -> Event
move (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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Semigroup a => a -> a -> a
<> Event -> Environ
event_environ Event
event
    }

-- *** control

event_controls :: Event -> ScoreT.ControlMap
event_controls :: Event -> ControlMap
event_controls = Environ -> ControlMap
get forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
event_environ
    where
    get :: Environ -> ControlMap
get (DeriveT.Environ Map Key Val
env) = forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Key -> Control
ScoreT.Control) forall a b. (a -> b) -> a -> b
$
        forall b b2 a. (b -> Maybe b2) -> [(a, b)] -> [(a, b2)]
Lists.mapMaybeSnd Val -> Maybe (Typed Control)
is_signal forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList Map Key Val
env
    is_signal :: Val -> Maybe (Typed Control)
is_signal (DeriveT.VSignal Typed Control
sig) = forall a. a -> Maybe a
Just Typed Control
sig
    is_signal Val
_ = forall a. Maybe a
Nothing

-- | 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} (kind :: k). Signal kind -> RealTime -> Y
`Signal.at` RealTime
pos)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Event -> Maybe (Typed Control)
event_control Control
control

event_control :: ScoreT.Control -> Event -> Maybe (ScoreT.Typed Signal.Control)
event_control :: Control -> Event -> Maybe (Typed Control)
event_control (ScoreT.Control Key
control) = Val -> Maybe (Typed Control)
as_signal forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Key -> Event -> Maybe Val
lookup_val Key
control

initial_dynamic :: Event -> Signal.Y
initial_dynamic :: Event -> Y
initial_dynamic Event
event = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Y
0 forall a. Typed a -> a
ScoreT.val_of 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 =
    Control -> (Y -> Y) -> Event -> Event
modify_control_vals (Key -> Control
ScoreT.Control Key
EnvKey.dynamic_val) Y -> Y
modify
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> (Y -> Y) -> Event -> Event
modify_control_vals Control
Controls.dynamic Y -> Y
modify

-- | 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 = Key -> Val -> Event -> Event
put_val Key
EnvKey.dynamic_val Val
sig
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Val -> Event -> Event
put_val (Control -> Key
ScoreT.control_name Control
Controls.dynamic) Val
sig
    where sig :: Val
sig = Y -> Val
DeriveT.num 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 = case Control -> Event -> Maybe (Typed Control)
event_control Control
control Event
event of
    Maybe (Typed Control)
Nothing -> Event
event
    Just Typed Control
sig -> Key -> Val -> Event -> Event
put_val (Control -> Key
ScoreT.control_name Control
control)
        (Typed Control -> Val
DeriveT.VSignal (forall {k} (kind :: k). (Y -> Y) -> Signal kind -> Signal kind
Signal.map_y_linear Y -> Y
modify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Control
sig)) Event
event

-- | Like 'modify_control', but default to an empty control and retain any
-- type the original had.
modify_signal :: ScoreT.Control -> (Signal.Control -> Signal.Control)
    -> Event -> Event
modify_signal :: Control -> (Control -> Control) -> Event -> Event
modify_signal Control
control Control -> Control
modify =
    Control
-> (Maybe (Typed Control) -> Typed Control) -> Event -> Event
modify_control Control
control (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Control -> Control
modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe (forall a. a -> Typed a
ScoreT.untyped forall a. Monoid a => a
mempty))

modify_control :: ScoreT.Control
    -> (Maybe ScoreT.TypedSignal -> ScoreT.TypedSignal) -> Event -> Event
modify_control :: Control
-> (Maybe (Typed Control) -> Typed Control) -> Event -> Event
modify_control (ScoreT.Control Key
control) Maybe (Typed Control) -> Typed Control
modify =
    Key -> (Maybe Val -> Val) -> Event -> Event
modify_val Key
control (Typed Control -> Val
DeriveT.VSignal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Typed Control) -> Typed Control
modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Val -> Maybe (Typed Control)
as_signal =<<))

as_signal :: DeriveT.Val -> Maybe ScoreT.TypedSignal
as_signal :: Val -> Maybe (Typed Control)
as_signal = \case
    DeriveT.VSignal Typed Control
sig -> forall a. a -> Maybe a
Just Typed Control
sig
    Val
_ -> forall a. Maybe a
Nothing

set_control :: ScoreT.Control -> ScoreT.Typed Signal.Control -> Event -> Event
set_control :: Control -> Typed Control -> Event -> Event
set_control (ScoreT.Control Key
control) =
    Key -> (Maybe Val -> Val) -> Event -> Event
modify_val Key
control forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed Control -> Val
DeriveT.VSignal

event_controls_at :: RealTime -> Event -> ScoreT.ControlValMap
event_controls_at :: RealTime -> Event -> ControlValMap
event_controls_at RealTime
t Event
event =
    forall a. Typed a -> a
ScoreT.val_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} (kind :: k). Signal kind -> RealTime -> Y
`Signal.at` RealTime
t) 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 PSignal
sig Event
event = Event
event { event_pitch :: PSignal
event_pitch = PSignal
sig }

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 forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch = Event
event { event_pitch :: PSignal
event_pitch = PSignal
signal }
    | Bool
otherwise = Key -> (Maybe Val -> Val) -> Event -> Event
modify_val (PControl -> Key
ScoreT.pcontrol_name PControl
pcontrol)
        (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ PSignal -> Val
DeriveT.VPSignal PSignal
signal) Event
event

event_named_pitch :: ScoreT.PControl -> Event -> Maybe PSignal.PSignal
event_named_pitch :: PControl -> Event -> Maybe PSignal
event_named_pitch PControl
pcontrol Event
event
    | PControl
pcontrol forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch = forall a. a -> Maybe a
Just (Event -> PSignal
event_pitch Event
event)
    | Bool
otherwise = case Key -> Event -> Maybe Val
lookup_val (PControl -> Key
ScoreT.pcontrol_name PControl
pcontrol) Event
event of
        Just (DeriveT.VPSignal PSignal
sig) -> forall a. a -> Maybe a
Just PSignal
sig
        Maybe Val
_ -> forall a. Maybe a
Nothing

-- | 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 = forall a b. PitchConfig -> RawPitch a -> RawPitch b
PSignal.apply_config PitchConfig
config forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Event -> Maybe Pitch
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 Pitch
pitch_at RealTime
pos Event
event = PSignal -> RealTime -> Maybe Pitch
PSignal.at (Event -> PSignal
event_pitch Event
event) RealTime
pos

apply_controls :: Event -> RealTime -> PSignal.Pitch -> PSignal.Transposed
apply_controls :: Event -> RealTime -> Pitch -> Transposed
apply_controls Event
event RealTime
pos = ControlValMap -> Pitch -> 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Either PitchError NoteNumber
PSignal.pitch_nn
    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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Either PitchError Note
PSignal.pitch_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, Text)])
nn_signal :: Event -> (NoteNumber, [(RealTime, Key)])
nn_signal Event
event =
    PSignal -> (NoteNumber, [(RealTime, Key)])
PSignal.to_nn forall a b. (a -> b) -> a -> b
$ ControlMap -> PSignal -> PSignal
PSignal.apply_controls (Event -> ControlMap
event_controls Event
event) forall a b. (a -> b) -> a -> b
$
        Environ -> PSignal -> PSignal
PSignal.apply_environ (Event -> Environ
event_environ Event
event) forall a b. (a -> b) -> a -> b
$
        Event -> PSignal
event_pitch Event
event