-- 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 CPP #-}
-- | The 'convert' function and support.
module Cmd.Integrate.Convert (
    Track(..), Tracks
    , convert
#ifdef TESTING
    , module Cmd.Integrate.Convert
#endif
) where
import qualified Data.Either as Either
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 Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Pretty as Pretty
import qualified Util.Texts as Texts

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Perf as Perf
import qualified Derive.Call as Call
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.PSignal as PSignal
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream

import qualified Instrument.Common as Common
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.Ui as Ui

import           Global
import           Types


-- | Include flags as a comment in generated events, for debugging.  It
-- clutters the output though.  TODO: need a better way
debug :: Bool
debug :: Bool
debug = Bool
False

type Error = Text
type Title = Text

-- | A simplified description of a UI track, as collected by
-- "Derive.Call.Integrate".
data Track = Track {
    Track -> Text
track_title :: !Title
    , Track -> [Event]
track_events :: ![Event.Event]
    } deriving (Track -> Track -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Track -> Track -> Bool
$c/= :: Track -> Track -> Bool
== :: Track -> Track -> Bool
$c== :: Track -> Track -> Bool
Eq, Voice -> Track -> ShowS
[Track] -> ShowS
Track -> String
forall a.
(Voice -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Track] -> ShowS
$cshowList :: [Track] -> ShowS
show :: Track -> String
$cshow :: Track -> String
showsPrec :: Voice -> Track -> ShowS
$cshowsPrec :: Voice -> Track -> ShowS
Show)

instance Pretty Track where
    format :: Track -> Doc
format (Track Text
title [Event]
events) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Track"
        [ (Text
"title", forall a. Pretty a => a -> Doc
Pretty.format Text
title)
        , (Text
"events", forall a. Pretty a => a -> Doc
Pretty.format [Event]
events)
        ]

-- | (note track, control tracks)
type Tracks = [(Track, [Track])]
type Config = (GetCallMap, Pitch.ScaleId)
type GetCallMap = ScoreT.Instrument -> Common.CallMap

-- | Convert 'Score.Event's to 'Tracks'.  This involves splitting overlapping
-- events into tracks, and trying to map low level notation back to high level.
convert :: Cmd.M m => BlockId -> Stream.Stream Score.Event -> m Tracks
convert :: forall (m :: * -> *). M m => BlockId -> Stream Event -> m Tracks
convert BlockId
source_block Stream Event
stream = do
    Instrument -> Maybe ResolvedInstrument
lookup_inst <- forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
Cmd.get_lookup_instrument
    let get_call_map :: Instrument -> CallMap
get_call_map = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall code. Common code -> CallMap
Common.common_call_map forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedInstrument -> Common InstrumentCode
Cmd.inst_common)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instrument -> Maybe ResolvedInstrument
lookup_inst
    ScaleId
default_scale_id <- forall (m :: * -> *). M m => m ScaleId
Perf.default_scale_id
    Map TrackId Voice
tracknums <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m [(TrackId, Voice)]
Ui.tracknums_of BlockId
source_block
    let ([Event]
events, [Msg]
logs) = forall a. Stream a -> ([a], [Msg])
Stream.partition Stream Event
stream
        ([Text]
errs, Tracks
tracks) = Config -> Map TrackId Voice -> [Event] -> ([Text], Tracks)
integrate (Instrument -> CallMap
get_call_map, ScaleId
default_scale_id)
            Map TrackId Voice
tracknums [Event]
events
    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
"integrate") [Msg]
logs
    -- If something failed to derive I shouldn't integrate that into the block.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((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) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw Text
"aborting integrate due to warnings"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
"integrating events: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"; " [Text]
errs
    forall (m :: * -> *) a. Monad m => a -> m a
return Tracks
tracks

-- | Convert derived score events back into UI events.
integrate :: Config -> Map TrackId TrackNum -> [Score.Event]
    -> ([Error], Tracks)
integrate :: Config -> Map TrackId Voice -> [Event] -> ([Text], Tracks)
integrate Config
config Map TrackId Voice
tracknums =
    forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Config -> (TrackKey, [Event]) -> Either Text (Track, [Track])
integrate_track Config
config)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TrackId Voice -> [Event] -> [(TrackKey, [Event])]
allocate_tracks Map TrackId Voice
tracknums

-- | Allocate the events to separate tracks.
allocate_tracks :: Map TrackId TrackNum -> [Score.Event]
    -> [(TrackKey, [Score.Event])]
allocate_tracks :: Map TrackId Voice -> [Event] -> [(TrackKey, [Event])]
allocate_tracks Map TrackId Voice
tracknums = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. (a, [Event]) -> [(a, [Event])]
overlap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort Event -> TrackKey
group_key
    where
    overlap :: (a, [Event]) -> [(a, [Event])]
overlap (a
key, [Event]
events) = forall a b. (a -> b) -> [a] -> [b]
map ((,) a
key) ([Event] -> [[Event]]
split_overlapping [Event]
events)
    -- Sort by tracknum so an integrated block's tracks come out in the same
    -- order as the original.
    group_key :: Score.Event -> TrackKey
    group_key :: Event -> TrackKey
group_key Event
event =
        ( TrackId -> Maybe Voice
tracknum_of forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Event -> Maybe TrackId
track_of Event
event
        , Event -> Instrument
Score.event_instrument Event
event
        , PSignal -> ScaleId
PSignal.sig_scale_id (Event -> PSignal
Score.event_pitch Event
event)
        , Event -> Maybe Voice
event_voice Event
event
        , Event -> Maybe Hand
event_hand Event
event
        )
    tracknum_of :: TrackId -> Maybe Voice
tracknum_of TrackId
tid = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
tid Map TrackId Voice
tracknums

-- | Split events into separate lists of non-overlapping events.
split_overlapping :: [Score.Event] -> [[Score.Event]]
split_overlapping :: [Event] -> [[Event]]
split_overlapping [] = []
split_overlapping [Event]
events = [Event]
track forall a. a -> [a] -> [a]
: [Event] -> [[Event]]
split_overlapping [Event]
rest
    where
    -- Go through the track and collect non-overlapping events, then do it
    -- recursively until there are none left.
    ([Event]
track, [Event]
rest) = forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers ([Event] -> [Either Event Event]
strip [Event]
events)
    strip :: [Event] -> [Either Event Event]
strip [] = []
    strip (Event
event:[Event]
events) = forall a b. a -> Either a b
Left Event
event forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right [Event]
overlapping forall a. [a] -> [a] -> [a]
++ [Event] -> [Either Event Event]
strip [Event]
rest
        where ([Event]
overlapping, [Event]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Event -> Event -> Bool
overlaps Event
event) [Event]
events

overlaps :: Score.Event -> Score.Event -> Bool
overlaps :: Event -> Event -> Bool
overlaps Event
e1 Event
e2 = Event -> RealTime
Score.event_start Event
e2 forall a. Ord a => a -> a -> Bool
< Event -> RealTime
Score.event_end Event
e1
    Bool -> Bool -> Bool
|| Event -> RealTime
Score.event_start Event
e1 forall a. Eq a => a -> a -> Bool
== Event -> RealTime
Score.event_start Event
e2

event_voice :: Score.Event -> Maybe Voice
event_voice :: Event -> Maybe Voice
event_voice = forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.voice forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
Score.event_environ

event_hand :: Score.Event -> Maybe Call.Hand
event_hand :: Event -> Maybe Hand
event_hand = forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.hand forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
Score.event_environ

track_of :: Score.Event -> Maybe TrackId
track_of :: Event -> Maybe TrackId
track_of = forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Frame -> Maybe TrackId
Stack.track_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
Stack.innermost
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Stack
Score.event_stack

-- | This determines how tracks are split when integration recreates track
-- structure.
type TrackKey =
    ( Maybe TrackNum, ScoreT.Instrument, Pitch.ScaleId
    , Maybe Voice, Maybe Call.Hand
    )
type Voice = Int

integrate_track :: Config -> (TrackKey, [Score.Event])
    -> Either Error (Track, [Track])
integrate_track :: Config -> (TrackKey, [Event]) -> Either Text (Track, [Track])
integrate_track (Instrument -> CallMap
get_call_map, ScaleId
default_scale_id)
        ((Maybe Voice
_, Instrument
inst, ScaleId
scale_id, Maybe Voice
voice, Maybe Hand
hand), [Event]
events) = do
    [Track]
pitch_track <- if [Event] -> Bool
no_pitch_signals [Event]
events Bool -> Bool -> Bool
|| Bool
no_scale
        then forall (m :: * -> *) a. Monad m => a -> m a
return []
        else case ScaleId -> [Event] -> (Track, [Text])
pitch_events ScaleId
sid forall a b. (a -> b) -> a -> b
$ [Event]
events of
            (Track
track, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return [Track
track]
            (Track
_, [Text]
errs) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"; " [Text]
errs
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( Instrument
-> (Maybe Voice, Maybe Hand) -> CallMap -> [Event] -> Track
note_events Instrument
inst (Maybe Voice
voice, Maybe Hand
hand) (Instrument -> CallMap
get_call_map Instrument
inst) [Event]
events
        , [Track]
pitch_track forall a. [a] -> [a] -> [a]
++ [Event] -> [Track]
control_events [Event]
events
        )
    where
    -- Instruments like mridangam '(natural)' call use this for ambient pitch.
    no_scale :: Bool
no_scale = ScaleId
scale_id forall a. Eq a => a -> a -> Bool
== Scale -> ScaleId
PSignal.pscale_scale_id Scale
PSignal.no_scale
    sid :: ScaleId
sid = if ScaleId
scale_id forall a. Eq a => a -> a -> Bool
== ScaleId
default_scale_id then ScaleId
Pitch.empty_scale else ScaleId
scale_id

-- ** note

note_events :: ScoreT.Instrument -> (Maybe Voice, Maybe Call.Hand)
    -> Common.CallMap -> [Score.Event] -> Track
note_events :: Instrument
-> (Maybe Voice, Maybe Hand) -> CallMap -> [Event] -> Track
note_events Instrument
inst (Maybe Voice
voice, Maybe Hand
hand) CallMap
call_map [Event]
events =
    Text -> [Event] -> Track
make_track Text
note_title (forall a b. (a -> b) -> [a] -> [b]
map (CallMap -> Event -> Event
note_event CallMap
call_map) [Event]
events)
    where
    note_title :: Text
note_title = Text -> [Text] -> Text
Text.intercalate Text
" | " forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Text
"")
        [ Instrument -> Text
ParseTitle.instrument_to_title Instrument
inst
        , forall {a}. ShowVal a => Text -> Maybe a -> Text
add_env Text
EnvKey.voice Maybe Voice
voice
        , forall {a}. ShowVal a => Text -> Maybe a -> Text
add_env Text
EnvKey.hand Maybe Hand
hand
        ]
    add_env :: Text -> Maybe a -> Text
add_env Text
key = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (((Text
key forall a. Semigroup a => a -> a -> a
<> Text
"=")<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowVal a => a -> Text
ShowVal.show_val)

note_event :: Common.CallMap -> Score.Event -> Event.Event
note_event :: CallMap -> Event -> Event
note_event CallMap
call_map Event
event =
    Stack -> TrackTime -> TrackTime -> Text -> Event
ui_event (Event -> Stack
Score.event_stack Event
event)
        (RealTime -> TrackTime
RealTime.to_score (Event -> RealTime
Score.event_start Event
event))
        (RealTime -> TrackTime
RealTime.to_score (Event -> RealTime
Score.event_duration Event
event))
        (CallMap -> Event -> Text
note_call CallMap
call_map Event
event)

note_call :: Common.CallMap -> Score.Event -> Text
note_call :: CallMap -> Event -> Text
note_call CallMap
call_map Event
event = forall a. Textlike a => a -> a -> a -> a
Texts.join2 Text
" -- " Text
text Text
comment
    where
    text :: Text
text
        | Event -> Text
Score.event_integrate Event
event forall a. Eq a => a -> a -> Bool
/= Text
"" = Event -> Text
Score.event_integrate Event
event
        | Just Symbol
sym <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Attributes
attrs CallMap
call_map = Symbol -> Text
Expr.unsym Symbol
sym
        | Attributes
attrs forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty = forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
attrs
        | Bool
otherwise = Text
""
        where attrs :: Attributes
attrs = Event -> Attributes
Score.event_attributes Event
event
    -- Append flags to help with debugging.  The presence of a flag
    -- probably means some postproc step wasn't applied.
    comment :: Text
comment
        | Bool
debug Bool -> Bool -> Bool
&& Flags
flags forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty = forall a. Pretty a => a -> Text
pretty Flags
flags
        | Bool
otherwise = Text
""
        where flags :: Flags
flags = Event -> Flags
Score.event_flags Event
event


-- ** pitch

-- | Unlike 'control_events', this only drops dups that occur within the same
-- event.  This is because it's more normal to think of each note as
-- establishing a new pitch, even if it's the same as the last one.
pitch_events :: Pitch.ScaleId -> [Score.Event] -> (Track, [Error])
pitch_events :: ScaleId -> [Event] -> (Track, [Text])
pitch_events ScaleId
scale_id [Event]
events =
    (Text -> [Event] -> Track
make_track Text
pitch_title ([[Event]] -> [Event]
tidy_pitches [[Event]]
ui_events), forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]]
errs)
    where
    pitch_title :: Text
pitch_title = ScaleId -> Text
ParseTitle.scale_to_title ScaleId
scale_id
    ([[Event]]
ui_events, [[Text]]
errs) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Event -> ([Event], [Text])
pitch_signal_events [Event]
events
    tidy_pitches :: [[Event]] -> [Event]
tidy_pitches = [Event] -> [Event]
clip_to_zero forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Event]] -> [Event]
clip_concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [Event] -> [Event]
drop_dups

no_pitch_signals :: [Score.Event] -> Bool
no_pitch_signals :: [Event] -> Bool
no_pitch_signals = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (PSignal -> Bool
PSignal.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> PSignal
Score.event_pitch)

-- | Convert an event's pitch signal to symbolic note names.  This uses
-- 'PSignal.pitch_note', which handles a constant transposition, but not
-- continuous pitch changes (it's not even clear how to spell those).  I could
-- try to convert back from NoteNumbers, but I still have the problem of how
-- to convert the curve back to high level pitches.
pitch_signal_events :: Score.Event -> ([Event.Event], [Error])
pitch_signal_events :: Event -> ([Event], [Text])
pitch_signal_events Event
event = ([Event]
ui_events, [Text]
pitch_errs)
    where
    start :: RealTime
start = Event -> RealTime
Score.event_start Event
event
    ([RealTime]
xs, [Pitch]
ys) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ PSignal -> [(RealTime, Pitch)]
PSignal.to_pairs forall a b. (a -> b) -> a -> b
$ RealTime -> PSignal -> PSignal
PSignal.clip_before RealTime
start forall a b. (a -> b) -> a -> b
$
        Event -> PSignal
Score.event_pitch Event
event
    pitches :: [(RealTime, Pitch, Either PitchError Note)]
pitches = forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [RealTime]
xs [Pitch]
ys
        (forall a b. (a -> b) -> [a] -> [b]
map (Transposed -> Either PitchError Note
PSignal.pitch_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime -> Pitch -> Transposed
Score.apply_controls Event
event RealTime
start) [Pitch]
ys)
    pitch_errs :: [Text]
pitch_errs =
        [ forall a. Pretty a => a -> Text
pretty RealTime
x forall a. Semigroup a => a -> a -> a
<> Text
": converting " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Pitch
p forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty PitchError
err
        | (RealTime
x, Pitch
p, Left PitchError
err) <- [(RealTime, Pitch, Either PitchError Note)]
pitches
        ]
    ui_events :: [Event]
ui_events =
        [ Stack -> TrackTime -> TrackTime -> Text -> Event
ui_event (Event -> Stack
Score.event_stack Event
event) (RealTime -> TrackTime
RealTime.to_score RealTime
x) TrackTime
0
            (Note -> Text
Pitch.note_text Note
note)
        | (RealTime
x, Pitch
_, Right Note
note) <- [(RealTime, Pitch, Either PitchError Note)]
pitches
        ]

-- ** control

control_events :: [Score.Event] -> [Track]
control_events :: [Event] -> [Track]
control_events [Event]
events =
    forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Bool
empty_track) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Event] -> Typed Control -> Track
control_track [Event]
events) [Typed Control]
controls
    where
    controls :: [Typed Control]
controls = forall a. Ord a => [a] -> [a]
List.sort forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
Lists.unique forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (a, Typed a) -> Typed a
typed_control forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. (Control, b) -> Bool
wanted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> ControlMap
Score.event_controls)
        [Event]
events
    -- The integrate calls always include these because they affect the
    -- pitches.  'pitch_signal_events' will have already applied them though,
    -- so we don't need to have them again.
    -- TODO: technically they should be from pscale_transposers, but that's
    -- so much work to collect, let's just assume the standards.
    wanted :: (Control, b) -> Bool
wanted = (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Control
Controls.integrate_keep) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
    typed_control :: (a, Typed a) -> Typed a
typed_control (a
control, Typed a
sig) = forall a. Type -> a -> Typed a
ScoreT.Typed (forall a. Typed a -> Type
ScoreT.type_of Typed a
sig) a
control

control_track :: [Score.Event] -> ScoreT.Typed ScoreT.Control -> Track
control_track :: [Event] -> Typed Control -> Track
control_track [Event]
events Typed Control
control =
    Text -> [Event] -> Track
make_track (Typed Control -> Text
ParseTitle.control_to_title Typed Control
control) [Event]
ui_events
    where
    ui_events :: [Event]
ui_events = [Event] -> [Event]
drop_dyn forall a b. (a -> b) -> a -> b
$ [[Event]] -> [Event]
tidy_controls forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Control -> Event -> [Event]
signal_events Control
c) [Event]
events
    -- Don't emit a dyn track if it's just the default.
    drop_dyn :: [Event] -> [Event]
drop_dyn [Event]
events = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
c Map Control Y
Derive.initial_control_vals of
        Just Y
val | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((forall a. Eq a => a -> a -> Bool
==Text
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Text
Event.text) [Event]
events -> []
            where t :: Text
t = Y -> Text
ShowVal.show_hex_val Y
val
        Maybe Y
_ -> [Event]
events
    tidy_controls :: [[Event]] -> [Event]
tidy_controls = [Event] -> [Event]
clip_to_zero forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> [Event]
drop_dups forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Event]] -> [Event]
clip_concat
    c :: Control
c = forall a. Typed a -> a
ScoreT.val_of Typed Control
control

signal_events :: ScoreT.Control -> Score.Event -> [Event.Event]
signal_events :: Control -> Event -> [Event]
signal_events Control
control Event
event = case Control -> Event -> Maybe (Typed Control)
Score.event_control Control
control Event
event of
    Maybe (Typed Control)
Nothing -> []
    Just Typed Control
sig -> forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RealTime -> Y -> Event
mk) forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Signal kind -> [(RealTime, Y)]
Signal.to_pairs forall a b. (a -> b) -> a -> b
$
        forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.clip_before RealTime
start (forall a. Typed a -> a
ScoreT.val_of Typed Control
sig)
    where
    -- Suppose ambient dyn is .75, but then post integrate it is set to .6.
    -- Since the dyn track multiplies by default, this would wind up doubly
    -- applying the .75, for .75*.6.  So the integrate call saves its ambient
    -- dyn so we can invert it here.
    invert :: Y
invert
        | Control
control forall a. Eq a => a -> a -> Bool
== Control
Controls.dynamic = forall a. a -> Maybe a -> a
fromMaybe Y
1 forall a b. (a -> b) -> a -> b
$
            forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val (Control -> Text
ScoreT.control_name Control
Controls.dynamic_integrate) forall a b. (a -> b) -> a -> b
$
            Event -> Environ
Score.event_environ Event
event
        | Bool
otherwise = Y
1
    start :: RealTime
start = Event -> RealTime
Score.event_start Event
event
    mk :: RealTime -> Y -> Event
mk RealTime
x Y
y = Stack -> TrackTime -> TrackTime -> Text -> Event
ui_event (Event -> Stack
Score.event_stack Event
event) (RealTime -> TrackTime
RealTime.to_score RealTime
x) TrackTime
0
        (Y -> Text
ShowVal.show_hex_val (Y
y forall a. Fractional a => a -> a -> a
/ Y
invert))

-- * util

ui_event :: Stack.Stack -> ScoreTime -> ScoreTime -> Text -> Event.Event
ui_event :: Stack -> TrackTime -> TrackTime -> Text -> Event
ui_event Stack
stack TrackTime
pos TrackTime
dur Text
text =
    Lens Event (Maybe Stack)
Event.stack_ forall f a. Lens f a -> a -> f -> f
#= forall a. a -> Maybe a
Just (Stack -> TrackTime -> Stack
Event.Stack Stack
stack TrackTime
pos) forall a b. (a -> b) -> a -> b
$ TrackTime -> TrackTime -> Text -> Event
Event.event TrackTime
pos TrackTime
dur Text
text

-- | Concatenate the events, dropping ones that are out of order.  The
-- durations are not modified, so they still might overlap in duration, but the
-- start times will be increasing.
clip_concat :: [[Event.Event]] -> [Event.Event]
clip_concat :: [[Event]] -> [Event]
clip_concat = forall a. (a -> a -> Bool) -> [a] -> [a]
Lists.dropWith Event -> Event -> Bool
out_of_order forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    where out_of_order :: Event -> Event -> Bool
out_of_order Event
e1 Event
e2 = Event -> TrackTime
Event.start Event
e2 forall a. Ord a => a -> a -> Bool
<= Event -> TrackTime
Event.start Event
e1

-- | Drop subsequent events with the same text, since those are redundant for
-- controls.
drop_dups :: [Event.Event] -> [Event.Event]
drop_dups :: [Event] -> [Event]
drop_dups = forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropDups Event -> Text
Event.text

-- | Drop events before 0, keeping at least one at 0.  Controls can wind up
-- with samples before 0 (e.g. after using 'Derive.Score.move'), but events
-- can't start before 0.
clip_to_zero :: [Event.Event] -> [Event.Event]
clip_to_zero :: [Event] -> [Event]
clip_to_zero (Event
e1 : rest :: [Event]
rest@(Event
e2 : [Event]
_))
    | Event -> TrackTime
Event.start Event
e1 forall a. Ord a => a -> a -> Bool
<= TrackTime
0 Bool -> Bool -> Bool
&& Event -> TrackTime
Event.start Event
e2 forall a. Ord a => a -> a -> Bool
<= TrackTime
0 = [Event] -> [Event]
clip_to_zero [Event]
rest
    | Bool
otherwise = (Lens Event TrackTime
Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f
%= forall a. Ord a => a -> a -> a
max TrackTime
0 forall a b. (a -> b) -> a -> b
$ Event
e1) forall a. a -> [a] -> [a]
: [Event]
rest
clip_to_zero [Event
e] = [Lens Event TrackTime
Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f
%= forall a. Ord a => a -> a -> a
max TrackTime
0 forall a b. (a -> b) -> a -> b
$ Event
e]
clip_to_zero [] = []

make_track :: Title -> [Event.Event] -> Track
make_track :: Text -> [Event] -> Track
make_track Text
title [Event]
events = Text -> [Event] -> Track
Track Text
title (forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn Event -> TrackTime
Event.start [Event]
events)

empty_track :: Track -> Bool
empty_track :: Track -> Bool
empty_track (Track Text
_ []) = Bool
True
empty_track Track
_ = Bool
False