-- Copyright 2017 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

-- | Utilities for the default note call.  They're separated here so internal
-- utilities can make events without importing "Derive.C.Prelude.Note".
module Derive.Call.NoteUtil (make_event, make_event_control_vals) where
import qualified Data.Map as Map

import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Flags as Flags
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT

import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal
import qualified Ui.Color as Color
import qualified Ui.Event as Event
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


-- | This is the canonical way to make a Score.Event.  It handles all the
-- control trimming and control function value stashing that the perform layer
-- relies on.
make_event :: Derive.PassedArgs a -> Derive.Dynamic -> RealTime -> RealTime
    -> Text -> Flags.Flags -> Derive.Deriver Score.Event
make_event :: forall a.
PassedArgs a
-> Dynamic
-> RealTime
-> RealTime
-> Text
-> Flags
-> Deriver Event
make_event PassedArgs a
args Dynamic
dyn RealTime
start RealTime
dur Text
integrate Flags
flags = do
    ControlValMap
cvmap <- RealTime -> Deriver ControlValMap
Derive.controls_at RealTime
start
    forall a.
ControlValMap
-> PassedArgs a
-> Dynamic
-> RealTime
-> RealTime
-> Text
-> Flags
-> Deriver Event
make_event_control_vals ControlValMap
cvmap PassedArgs a
args Dynamic
dyn RealTime
start RealTime
dur Text
integrate Flags
flags

-- | Specialized version of 'make_event' just so I can avoid calling
-- Derive.controls_at twice.
make_event_control_vals :: ScoreT.ControlValMap -> Derive.PassedArgs a
    -> Derive.Dynamic -> RealTime -> RealTime -> Text -> Flags.Flags
    -> Derive.Deriver Score.Event
make_event_control_vals :: forall a.
ControlValMap
-> PassedArgs a
-> Dynamic
-> RealTime
-> RealTime
-> Text
-> Flags
-> Deriver Event
make_event_control_vals ControlValMap
cvmap PassedArgs a
args Dynamic
dyn RealTime
start RealTime
dur Text
integrate Flags
flags = do
    RealTime
offset <- RealTime -> Deriver RealTime
get_start_offset RealTime
start
    Deriver ()
Internal.increment_event_serial
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Score.Event
        { event_start :: RealTime
event_start = RealTime
start
        , event_duration :: RealTime
event_duration = RealTime
dur
        , event_text :: Text
event_text = Event -> Text
Event.text (forall a. PassedArgs a -> Event
Args.event PassedArgs a
args)
        , event_integrate :: Text
event_integrate = Text
integrate
        , event_pitch :: PSignal
event_pitch = RealTime -> PSignal -> PSignal
trim_pitch RealTime
start (Dynamic -> PSignal
Derive.state_pitch Dynamic
dyn)
        , event_stack :: Stack
event_stack = Dynamic -> Stack
Derive.state_stack Dynamic
dyn
        , event_highlight :: Highlight
event_highlight = Highlight
Color.NoHighlight
        , event_instrument :: Instrument
event_instrument = forall a. a -> Maybe a -> a
fromMaybe Instrument
ScoreT.empty_instrument forall a b. (a -> b) -> a -> b
$
            forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.instrument Environ
environ
        -- Put trimmed controls back into the environ.
        , event_environ :: Environ
event_environ = (Val -> Val) -> Environ -> Environ
Env.map (RealTime -> Val -> Val
trim_control_vals RealTime
start) forall a b. (a -> b) -> a -> b
$
            ControlValMap -> RealTime -> Environ -> Environ
stash_convert_values ControlValMap
cvmap RealTime
offset Environ
environ
        , event_flags :: Flags
event_flags = Flags
flags
        , event_delayed_args :: Map Text Dynamic
event_delayed_args = forall a. Monoid a => a
mempty
        , event_logs :: [Msg]
event_logs = []
        }
    where environ :: Environ
environ = Dynamic -> Environ
Derive.state_environ Dynamic
dyn

-- | Trim control signals.
--
-- Previously I would also trim to the end of the note, but now I leave it
-- as-is and rely on the performer to trim the end according to the
-- instrument's decay time.  This is so that a note whose decay persists
-- outside of its block can still see control changes after its block ends.
trim_control_vals :: RealTime -> DeriveT.Val -> DeriveT.Val
trim_control_vals :: RealTime -> Val -> Val
trim_control_vals RealTime
start = \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.drop_before RealTime
start 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.drop_before RealTime
start PSignal
sig
    Val
val -> Val
val

-- | Stash the dynamic value from the ControlValMap in
-- 'Controls.dynamic_function'.  Gory details in NOTE [EnvKey.dynamic_val].
stash_convert_values :: ScoreT.ControlValMap -> RealTime -> Env.Environ
    -> Env.Environ
stash_convert_values :: ControlValMap -> RealTime -> Environ -> Environ
stash_convert_values ControlValMap
vals RealTime
offset =
    Environ -> Environ
stash_start_offset
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Text -> Environ -> Environ
insert_if Control
Controls.dynamic Text
EnvKey.dynamic_val
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Text -> Environ -> Environ
insert_if Control
Controls.attack_velocity Text
EnvKey.attack_val
    -- Perhaps this should be sampled at the event end, but I don't want to
    -- get a whole new ControlValMap just for that.
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Text -> Environ -> Environ
insert_if Control
Controls.release_velocity Text
EnvKey.release_val
    where
    stash_start_offset :: Environ -> Environ
stash_start_offset = forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
EnvKey.start_offset_val RealTime
offset
    insert_if :: Control -> Text -> Environ -> Environ
insert_if Control
control Text
key = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
key) forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control ControlValMap
vals

get_start_offset :: RealTime -> Derive.Deriver RealTime
get_start_offset :: RealTime -> Deriver RealTime
get_start_offset RealTime
start = do
    RealTime
start_s <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
0 Y -> RealTime
RealTime.seconds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Control -> RealTime -> Deriver (Maybe Y)
Derive.untyped_control_at Control
Controls.start_s RealTime
start
    ScoreTime
start_t <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScoreTime
0 Y -> ScoreTime
ScoreTime.from_double forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Control -> RealTime -> Deriver (Maybe Y)
Derive.untyped_control_at Control
Controls.start_t RealTime
start
    RealTime
start_t <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration RealTime
start ScoreTime
start_t
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime
start_s forall a. Num a => a -> a -> a
+ RealTime
start_t

-- | For inverted tracks, this trimming should already be done by
-- 'Derive.Control.trim_signal'.
trim_pitch :: RealTime -> PSignal.PSignal -> PSignal.PSignal
trim_pitch :: RealTime -> PSignal -> PSignal
trim_pitch = RealTime -> PSignal -> PSignal
PSignal.drop_before