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

-- | Convert 'Score.Event's to the low-level event format, 'Note.Note'.
module Perform.Im.Convert (write, convert) where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Cmd.Cmd as Cmd
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.LEvent as LEvent
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 Instrument.Common as Common
import qualified Instrument.InstT as InstT
import qualified Perform.ConvertUtil as ConvertUtil
import qualified Perform.Im.Patch as Patch
import qualified Perform.Signal

import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Note as Note
import qualified Synth.Shared.Signal as Signal

import           Global
import           Types


-- | Serialize the events to the given path.  This is done atomically because
-- this is run from the derive thread, which can be killed at any time.
write :: RealTime -> RealTime -> BlockId
    -> (ScoreT.Instrument -> Maybe Cmd.ResolvedInstrument) -> FilePath
    -> Vector.Vector Score.Event -> IO ()
write :: RealTime
-> RealTime
-> BlockId
-> (Instrument -> Maybe ResolvedInstrument)
-> FilePath
-> Vector Event
-> IO ()
write RealTime
adjust0 RealTime
play_multiplier BlockId
block_id Instrument -> Maybe ResolvedInstrument
lookup_inst FilePath
filename Vector Event
events = do
    [Note]
notes <- forall (m :: * -> *) d. LogMonad m => [LEvent d] -> m [d]
LEvent.write_logs forall a b. (a -> b) -> a -> b
$ BlockId
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> [LEvent Note]
convert BlockId
block_id Instrument -> Maybe ResolvedInstrument
lookup_inst forall a b. (a -> b) -> a -> b
$
        -- TODO fix sorted Derive.Stream: so I can remove this.
        forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn Event -> RealTime
Score.event_start forall a b. (a -> b) -> a -> b
$
        forall a. Vector a -> [a]
Vector.toList Vector Event
events
    -- The play multiplier is a speed multiplier, so it's a note time divider.
    FilePath -> [Note] -> IO Bool
Note.serialize FilePath
filename forall a b. (a -> b) -> a -> b
$ RealTime -> RealTime -> [Note] -> [Note]
multiply_time RealTime
adjust0 (RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
play_multiplier) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Note -> [Note] -> Note
trim_controls) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [(a, [a])]
Lists.zipNexts [Note]
notes
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

multiply_time :: RealTime -> RealTime -> [Note.Note] -> [Note.Note]
multiply_time :: RealTime -> RealTime -> [Note] -> [Note]
multiply_time RealTime
adjust0 RealTime
n
    | RealTime
n forall a. Eq a => a -> a -> Bool
== RealTime
1 Bool -> Bool -> Bool
&& RealTime
adjust0 forall a. Eq a => a -> a -> Bool
== RealTime
0 = forall a. a -> a
id
    | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \Note
note -> Note
note
        { start :: RealTime
Note.start = RealTime
n forall a. Num a => a -> a -> a
* (Note -> RealTime
Note.start Note
note forall a. Num a => a -> a -> a
+ RealTime
adjust0)
        , duration :: RealTime
Note.duration = RealTime
n forall a. Num a => a -> a -> a
* Note -> RealTime
Note.duration Note
note
        , controls :: Map Control Signal
Note.controls = forall {k} (kind :: k).
(RealTime -> RealTime) -> Signal kind -> Signal kind
Signal.map_x (forall a. Num a => a -> a -> a
*RealTime
n) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Note -> Map Control Signal
Note.controls Note
note
        }

-- | Trim signals down to the note ranges.  It's more efficient to serialize
-- fewer samples, and leads to less rerendering since note hashes are based
-- on all their controls, whether or not they're in range.
--
-- Also normalize constant signals to a single sample, fewer bogus breakpoints
-- can make the synthesizer more efficient.
trim_controls :: Note.Note -> [Note.Note] -> Note.Note
trim_controls :: Note -> [Note] -> Note
trim_controls Note
note [Note]
nexts =
    Note
note { controls :: Map Control Signal
Note.controls = Note -> [Note] -> Signal -> Signal
trim_control Note
note [Note]
nexts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Note -> Map Control Signal
Note.controls Note
note }

trim_control :: Note.Note -> [Note.Note] -> Signal.Signal -> Signal.Signal
trim_control :: Note -> [Note] -> Signal -> Signal
trim_control Note
note [Note]
nexts Signal
sig =
    case forall {k} (kind :: k). RealTime -> Signal kind -> Maybe Y
Signal.constant_val_from (Note -> RealTime
Note.start Note
note) Signal
sig of
        Maybe Y
Nothing -> case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
== Note -> (Instrument, Element)
key Note
note) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> (Instrument, Element)
key) [Note]
nexts of
            Maybe Note
Nothing -> forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.drop_before (Note -> RealTime
Note.start Note
note) Signal
sig
            Just Note
next -> forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.drop_after (Note -> RealTime
Note.start Note
next) forall a b. (a -> b) -> a -> b
$
                forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.drop_before (Note -> RealTime
Note.start Note
note) Signal
sig
        Just Y
y -> forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
y
    where
    key :: Note -> (Instrument, Element)
key Note
n = (Note -> Instrument
Note.instrument Note
n, Note -> Element
Note.element Note
n)

convert :: BlockId -> (ScoreT.Instrument -> Maybe Cmd.ResolvedInstrument)
    -> [Score.Event] -> [LEvent.LEvent Note.Note]
convert :: BlockId
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> [LEvent Note]
convert BlockId
block_id = forall a.
(Event -> ResolvedInstrument -> [LEvent a])
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> [LEvent a]
ConvertUtil.convert forall a b. (a -> b) -> a -> b
$ \Event
event ResolvedInstrument
resolved ->
    case ResolvedInstrument -> Backend
Cmd.inst_backend ResolvedInstrument
resolved of
        Cmd.Im Patch
patch -> BlockId -> Event -> Patch -> Element -> [LEvent Note]
convert_event BlockId
block_id Event
event Patch
patch Element
patch_name
            where InstT.Qualified Element
_ Element
patch_name = ResolvedInstrument -> Qualified
Cmd.inst_qualified ResolvedInstrument
resolved
        Backend
_ -> []

convert_event :: BlockId -> Score.Event -> Patch.Patch -> InstT.Name
    -> [LEvent.LEvent Note.Note]
convert_event :: BlockId -> Event -> Patch -> Element -> [LEvent Note]
convert_event BlockId
block_id Event
event Patch
patch Element
patch_name = forall a. LogId a -> [LEvent a]
run forall a b. (a -> b) -> a -> b
$ do
    let supported :: Map Control Element
supported = Patch -> Map Control Element
Patch.patch_controls Patch
patch
    let controls :: ControlMap
controls = Event -> ControlMap
Score.event_controls Event
event
    Maybe Signal
pitch <- if forall k a. Ord k => k -> Map k a -> Bool
Map.member Control
Control.pitch Map Control Element
supported
        then forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k). Signal a -> Signal
convert_signal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
LogMonad m =>
Event -> m (Signal NoteNumberSig)
convert_pitch Event
event
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Note.Note
        { patch :: Element
patch = Element
patch_name
        , instrument :: Instrument
instrument = Event -> Instrument
Score.event_instrument Event
event
        , trackId :: Maybe TrackId
trackId = BlockId -> Event -> Maybe TrackId
event_track_id BlockId
block_id Event
event
        -- To make it easier to set element by hand, I support some types which
        -- are likely to be used for element names.
        , element :: Element
element =
            case Element -> Environ -> Maybe Val
Env.lookup Element
EnvKey.element (Event -> Environ
Score.event_environ Event
event) of
                Just (DeriveT.VStr (Expr.Str Element
a)) -> Element
a
                Just Val
val | Just Typed Y
num <- Val -> Maybe (Typed Y)
DeriveT.constant_val Val
val ->
                    forall a. ShowVal a => a -> Element
ShowVal.show_val Typed Y
num
                Maybe Val
_ -> Element
""
        , start :: RealTime
start = Event -> RealTime
Score.event_start Event
event
        , duration :: RealTime
duration = Event -> RealTime
Score.event_duration Event
event
        , controls :: Map Control Signal
controls = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Control
Control.pitch) Maybe Signal
pitch forall a b. (a -> b) -> a -> b
$
            forall a. Map Control a -> ControlMap -> Map Control Signal
convert_controls Map Control Element
supported ControlMap
controls
        -- Restrict attributes to the ones it says it accepts, to protect
        -- against false advertising.
        , attributes :: Attributes
attributes = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
            forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
Common.lookup_attributes (Event -> Attributes
Score.event_attributes Event
event)
                (Patch -> AttributeMap
Patch.patch_attribute_map Patch
patch)
        , stack :: Stack
stack = Event -> Stack
Score.event_stack Event
event
        }

-- | The event TrackId is later used to display render progress.  Progress is
-- only displayed on the root block, so find its tracks.  The innermost track
-- is most likely to be the one with the notes on it.
event_track_id :: BlockId -> Score.Event -> Maybe TrackId
event_track_id :: BlockId -> Event -> Maybe TrackId
event_track_id BlockId
block_id = forall a. [a] -> Maybe a
Lists.last forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup BlockId
block_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [(BlockId, [TrackId])]
Stack.block_tracks_of
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Stack
Score.event_stack

run :: Log.LogId a -> [LEvent.LEvent a]
run :: forall a. LogId a -> [LEvent a]
run LogId a
action = forall a. a -> LEvent a
LEvent.Event a
note forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Msg -> LEvent a
LEvent.Log [Msg]
logs
    where (a
note, [Msg]
logs) = forall a. LogId a -> (a, [Msg])
Log.run_id LogId a
action

convert_signal :: Perform.Signal.Signal a -> Signal.Signal
convert_signal :: forall {k} (a :: k). Signal a -> Signal
convert_signal = forall {k1} {k2} (kind1 :: k1) (kind2 :: k2).
Signal kind1 -> Signal kind2
Perform.Signal.coerce

-- TODO trim controls?
convert_controls :: Map Control.Control a -> ScoreT.ControlMap
    -> Map Control.Control Signal.Signal
convert_controls :: forall a. Map Control a -> ControlMap -> Map Control Signal
convert_controls Map Control a
supported ControlMap
controls = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Control -> Control
to_control Control
c, forall {k} (a :: k). Signal a -> Signal
convert_signal Signal
sig)
    | (Control
c, ScoreT.Typed Type
_ Signal
sig) <- forall k a. Map k a -> [(k, a)]
Map.toList ControlMap
controls
    , forall k a. Ord k => k -> Map k a -> Bool
Map.member (Control -> Control
to_control Control
c) Map Control a
supported
    ]

to_control :: ScoreT.Control -> Control.Control
to_control :: Control -> Control
to_control = Element -> Control
Control.Control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Element
ScoreT.control_name

convert_pitch :: Log.LogMonad m => Score.Event -> m Perform.Signal.NoteNumber
convert_pitch :: forall (m :: * -> *).
LogMonad m =>
Event -> m (Signal NoteNumberSig)
convert_pitch Event
event = do
    let (Signal NoteNumberSig
sig, [(RealTime, Element)]
warns) = Event -> (Signal NoteNumberSig, [(RealTime, Element)])
Score.nn_signal Event
event
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RealTime, Element)]
warns) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Stack, LogMonad m) => Element -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$
        Element
"convert pitch: " forall a. Semigroup a => a -> a -> a
<> Element -> [Element] -> Element
Text.intercalate Element
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Element
pretty [(RealTime, Element)]
warns)
    forall (m :: * -> *) a. Monad m => a -> m a
return Signal NoteNumberSig
sig