-- 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 MultiParamTypeClasses #-}
-- | Convert Derive.Score output into Lilypond.Events.
module Perform.Lilypond.Convert (convert, pitch_to_lily, quantize) where
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Identity as Identity
import qualified Data.Set as Set

import qualified Util.CallStack as CallStack
import qualified Util.Log as Log
import qualified Cmd.Cmd as Cmd
import qualified Derive.Derive as Derive
import qualified Derive.Env as Env
import qualified Derive.Flags as Flags
import qualified Derive.LEvent as LEvent
import qualified Derive.PSignal as PSignal
import qualified Derive.Scale.All as Scale.All
import qualified Derive.Score as Score

import qualified Perform.ConvertUtil as ConvertUtil
import qualified Perform.Lilypond.Constants as Constants
import qualified Perform.Lilypond.Types as Types
import qualified Perform.Midi.Patch as Midi.Patch

import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Instrument.InstT as InstT

import Global
import Types


-- * convert

-- | Convert Score events to Perform events, emitting warnings that may have
-- happened along the way.
--
-- Unlike the other backend converts, this one doesn't need a lookup inst
-- function.  It just fakes up an inst for whatever you ask it.  This means
-- 'Constants.ly_global' doesn't actually need an allocation.  The bad part is
-- that postproc is not applied, but I'll worry about that if I ever have
-- a postproc that affects lilypond.
convert :: Types.Config -> [Score.Event] -> [LEvent.LEvent Types.Event]
convert :: Config -> [Event] -> [LEvent Event]
convert Config
config = (Event -> ResolvedInstrument -> [LEvent Event])
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> [LEvent Event]
forall a.
(Event -> ResolvedInstrument -> [LEvent a])
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> [LEvent a]
ConvertUtil.convert Event -> ResolvedInstrument -> [LEvent Event]
forall {p}. Event -> p -> [LEvent Event]
event1 Instrument -> Maybe ResolvedInstrument
forall {b}. b -> Maybe ResolvedInstrument
lookup_inst ([Event] -> [LEvent Event])
-> ([Event] -> [Event]) -> [Event] -> [LEvent Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> [Event]
filter_instruments
    where
    -- Fake an instrument, which 'event1' will ignore.
    lookup_inst :: b -> Maybe ResolvedInstrument
lookup_inst = Maybe ResolvedInstrument -> b -> Maybe ResolvedInstrument
forall a b. a -> b -> a
const (Maybe ResolvedInstrument -> b -> Maybe ResolvedInstrument)
-> Maybe ResolvedInstrument -> b -> Maybe ResolvedInstrument
forall a b. (a -> b) -> a -> b
$ ResolvedInstrument -> Maybe ResolvedInstrument
forall a. a -> Maybe a
Just (ResolvedInstrument -> Maybe ResolvedInstrument)
-> ResolvedInstrument -> Maybe ResolvedInstrument
forall a b. (a -> b) -> a -> b
$ Cmd.ResolvedInstrument
        { inst_instrument :: Inst
inst_instrument = Backend -> Common InstrumentCode -> Inst
forall code. Backend -> Common code -> Inst code
Inst.Inst
            (Patch -> Backend
Inst.Midi (Patch -> Backend) -> Patch -> Backend
forall a b. (a -> b) -> a -> b
$ PbRange -> Text -> Patch
Midi.Patch.patch (-Int
1, Int
1) Text
"ly-fake-inst")
            (InstrumentCode -> Common InstrumentCode
forall code. code -> Common code
Common.common InstrumentCode
Cmd.empty_code)
        , inst_qualified :: Qualified
inst_qualified = Text -> Text -> Qualified
InstT.Qualified Text
"ly" Text
"ly-fake-inst"
        , inst_common_config :: Config
inst_common_config = Config
Common.empty_config
        , inst_backend :: Backend
inst_backend = Text -> Backend
Cmd.Dummy Text
"fake lilypond instrument"
        }
    event1 :: Event -> p -> [LEvent Event]
event1 Event
event p
_resolved =
        RealTime -> Event -> [LEvent Event]
convert_event (Config -> RealTime
Types.config_quarter_duration Config
config) Event
event
    filter_instruments :: [Event] -> [Event]
filter_instruments
        | [(Instrument, StaffConfig)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Config -> [(Instrument, StaffConfig)]
Types.config_staves Config
config) = [Event] -> [Event]
forall a. a -> a
id
        | Bool
otherwise = (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Instrument -> Set Instrument -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Instrument
insts) (Instrument -> Bool) -> (Event -> Instrument) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument)
    insts :: Set Instrument
insts = [Instrument] -> Set Instrument
forall a. Ord a => [a] -> Set a
Set.fromList ([Instrument] -> Set Instrument) -> [Instrument] -> Set Instrument
forall a b. (a -> b) -> a -> b
$ Instrument
Constants.ly_global Instrument -> [Instrument] -> [Instrument]
forall a. a -> [a] -> [a]
:
        [ Instrument
inst
        | (Instrument
inst, StaffConfig
staff) <- Config -> [(Instrument, StaffConfig)]
Types.config_staves Config
config
        , StaffConfig -> Bool
Types.staff_display StaffConfig
staff
        ]

{- | Normally events have a duration and a pitch, and the lilypond performer
    converts this into a normal lilypond note.  However, the deriver can emit
    lilypond code directly.  Since zero is not a valid duration in staff
    notation, it's used for lilypond directives.  It should have either
    'Constants.free_code_key', or one of the special directives from Constants.
    All those events should be marked with 'Flags.ly_code'.
-}
convert_event :: RealTime -> Score.Event -> [LEvent.LEvent Types.Event]
convert_event :: RealTime -> Event -> [LEvent Event]
convert_event RealTime
quarter Event
event = ExceptT Msg Identity Event -> [LEvent Event]
forall {a}. ExceptT Msg Identity a -> [LEvent a]
run (ExceptT Msg Identity Event -> [LEvent Event])
-> ExceptT Msg Identity Event -> [LEvent Event]
forall a b. (a -> b) -> a -> b
$ do
    let dur :: Time
dur = RealTime -> RealTime -> Time
Types.real_to_time RealTime
quarter (Event -> RealTime
Score.event_duration Event
event)
    Maybe Pitch
maybe_pitch <- Event -> ExceptT Msg Identity (Maybe Pitch)
forall (m :: * -> *). MonadError Msg m => Event -> m (Maybe Pitch)
convert_pitch Event
event
    -- Otherwise it will be misinterpreted as an explicit rest, which should be
    -- a purely internal concept.
    Bool -> ExceptT Msg Identity () -> ExceptT Msg Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Pitch
maybe_pitch Maybe Pitch -> Maybe Pitch -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Pitch
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
has_code_flag) (ExceptT Msg Identity () -> ExceptT Msg Identity ())
-> ExceptT Msg Identity () -> ExceptT Msg Identity ()
forall a b. (a -> b) -> a -> b
$
        Text -> ExceptT Msg Identity ()
forall (m :: * -> *) a. (Stack, MonadError Msg m) => Text -> m a
throw Text
"a note without pitch must have code"
    Bool -> ExceptT Msg Identity () -> ExceptT Msg Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
dur Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
has_code_flag) (ExceptT Msg Identity () -> ExceptT Msg Identity ())
-> ExceptT Msg Identity () -> ExceptT Msg Identity ()
forall a b. (a -> b) -> a -> b
$
        Text -> ExceptT Msg Identity ()
forall (m :: * -> *) a. (Stack, MonadError Msg m) => Text -> m a
throw (Text -> ExceptT Msg Identity ())
-> Text -> ExceptT Msg Identity ()
forall a b. (a -> b) -> a -> b
$ Text
"zero duration event must have " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Flags -> Text
forall a. Pretty a => a -> Text
pretty Flags
Flags.ly_code
    Event -> ExceptT Msg Identity Event
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> ExceptT Msg Identity Event)
-> Event -> ExceptT Msg Identity Event
forall a b. (a -> b) -> a -> b
$ Types.Event
        { event_start :: Time
event_start = RealTime -> RealTime -> Time
Types.real_to_time RealTime
quarter (Event -> RealTime
Score.event_start Event
event)
        , event_duration :: Time
event_duration =
            RealTime -> RealTime -> Time
Types.real_to_time RealTime
quarter (Event -> RealTime
Score.event_duration Event
event)
        , event_pitch :: Maybe Pitch
event_pitch = Maybe Pitch
maybe_pitch
        , event_instrument :: Instrument
event_instrument = Event -> Instrument
Score.event_instrument Event
event
        , event_environ :: Environ
event_environ = Event -> Environ
Score.event_environ Event
event
        , event_stack :: Stack
event_stack = Event -> Stack
Score.event_stack Event
event
        , event_clipped :: Bool
event_clipped = Bool
False
        }
    where
    has_code_flag :: Bool
has_code_flag = Flags -> Flags -> Bool
Flags.has (Event -> Flags
Score.event_flags Event
event) Flags
Flags.ly_code
    run :: ExceptT Msg Identity a -> [LEvent a]
run = (LEvent a -> [LEvent a] -> [LEvent a]
forall a. a -> [a] -> [a]
:[]) (LEvent a -> [LEvent a])
-> (ExceptT Msg Identity a -> LEvent a)
-> ExceptT Msg Identity a
-> [LEvent a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Msg -> LEvent a) -> (a -> LEvent a) -> Either Msg a -> LEvent a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Msg -> LEvent a
forall a. Msg -> LEvent a
LEvent.Log a -> LEvent a
forall a. a -> LEvent a
LEvent.Event (Either Msg a -> LEvent a)
-> (ExceptT Msg Identity a -> Either Msg a)
-> ExceptT Msg Identity a
-> LEvent a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Either Msg a) -> Either Msg a
forall a. Identity a -> a
Identity.runIdentity
        (Identity (Either Msg a) -> Either Msg a)
-> (ExceptT Msg Identity a -> Identity (Either Msg a))
-> ExceptT Msg Identity a
-> Either Msg a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Msg Identity a -> Identity (Either Msg a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT

throw :: (CallStack.Stack, Except.MonadError Log.Msg m) => Text -> m a
throw :: forall (m :: * -> *) a. (Stack, MonadError Msg m) => Text -> m a
throw = Msg -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError (Msg -> m a) -> (Text -> Msg) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn Maybe Stack
forall a. Maybe a
Nothing

convert_pitch :: Except.MonadError Log.Msg m =>
    Score.Event -> m (Maybe Types.Pitch)
convert_pitch :: forall (m :: * -> *). MonadError Msg m => Event -> m (Maybe Pitch)
convert_pitch Event
event = case Event -> Maybe Transposed
Score.initial_pitch Event
event of
    Maybe Transposed
Nothing -> Maybe Pitch -> m (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pitch
forall a. Maybe a
Nothing
    Just Transposed
pitch -> (Text -> m (Maybe Pitch))
-> (Pitch -> m (Maybe Pitch))
-> Either Text Pitch
-> m (Maybe Pitch)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> m (Maybe Pitch)
forall (m :: * -> *) a. (Stack, MonadError Msg m) => Text -> m a
throw (Text -> m (Maybe Pitch))
-> (Text -> Text) -> Text -> m (Maybe Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"convert_pitch: "<>)) (Maybe Pitch -> m (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pitch -> m (Maybe Pitch))
-> (Pitch -> Maybe Pitch) -> Pitch -> m (Maybe Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Maybe Pitch
forall a. a -> Maybe a
Just) (Either Text Pitch -> m (Maybe Pitch))
-> Either Text Pitch -> m (Maybe Pitch)
forall a b. (a -> b) -> a -> b
$
        Environ -> Transposed -> Either Text Pitch
pitch_to_lily (Event -> Environ
Score.event_environ Event
event) Transposed
pitch

-- * util

pitch_to_lily :: Env.Environ -> PSignal.Transposed -> Either Text Types.Pitch
pitch_to_lily :: Environ -> Transposed -> Either Text Pitch
pitch_to_lily Environ
env Transposed
pitch =
    case (\(Derive.LookupScale Environ -> ScaleId -> Maybe (Either PitchError Scale)
a) -> Environ -> ScaleId -> Maybe (Either PitchError Scale)
a) LookupScale
lookup_scale Environ
env ScaleId
scale_id of
        Maybe (Either PitchError Scale)
Nothing -> Text -> Either Text Pitch
forall a b. a -> Either a b
Left (Text -> Either Text Pitch) -> Text -> Either Text Pitch
forall a b. (a -> b) -> a -> b
$ Text
"scale id not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScaleId -> Text
forall a. Pretty a => a -> Text
pretty ScaleId
scale_id
        Just (Left PitchError
err) ->
            Text -> Either Text Pitch
forall a b. a -> Either a b
Left (Text -> Either Text Pitch) -> Text -> Either Text Pitch
forall a b. (a -> b) -> a -> b
$ Text
"scale " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScaleId -> Text
forall a. Pretty a => a -> Text
pretty ScaleId
scale_id Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PitchError -> Text
forall a. Pretty a => a -> Text
pretty PitchError
err
        Just (Right Scale
scale) -> do
            Note
note <- (PitchError -> Text) -> Either PitchError Note -> Either Text Note
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PitchError -> Text
forall a. Pretty a => a -> Text
pretty (Either PitchError Note -> Either Text Note)
-> Either PitchError Note -> Either Text Note
forall a b. (a -> b) -> a -> b
$ Transposed -> Either PitchError Note
PSignal.pitch_note Transposed
pitch
            Pitch
pitch <- (PitchError -> Text)
-> Either PitchError Pitch -> Either Text Pitch
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PitchError -> Text
forall a. Pretty a => a -> Text
pretty (Either PitchError Pitch -> Either Text Pitch)
-> Either PitchError Pitch -> Either Text Pitch
forall a b. (a -> b) -> a -> b
$ Scale -> Environ -> Note -> Either PitchError Pitch
Derive.scale_read Scale
scale Environ
env Note
note
            Pitch -> Either Text Pitch
Types.parse_pitch Pitch
pitch
    where scale_id :: ScaleId
scale_id = Transposed -> ScaleId
forall a. RawPitch a -> ScaleId
PSignal.pitch_scale_id Transposed
pitch

quantize :: Types.Duration -> [Types.Event] -> [Types.Event]
quantize :: Duration -> [Event] -> [Event]
quantize Duration
dur = (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map ((Event -> Event) -> [Event] -> [Event])
-> (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$ \Event
e -> Event
e
    { event_start :: Time
Types.event_start = Time -> Time
q (Event -> Time
Types.event_start Event
e)
    , event_duration :: Time
Types.event_duration = Time -> Time
q (Event -> Time
Types.event_duration Event
e)
    }
    where q :: Time -> Time
q = Time -> Time -> Time
quantize_time (Duration -> Time
Types.dur_to_time Duration
dur)

quantize_time :: Types.Time -> Types.Time -> Types.Time
quantize_time :: Time -> Time -> Time
quantize_time Time
time Time
t =
    Double -> Time
forall a b. (RealFrac a, Integral b) => a -> b
round (Time -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Time
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Time -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Time
time :: Double) Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
time

lookup_scale :: Derive.LookupScale
lookup_scale :: LookupScale
lookup_scale = LookupScale
Scale.All.lookup_scale