-- 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 = forall a.
(Event -> ResolvedInstrument -> [LEvent a])
-> (Instrument -> Maybe ResolvedInstrument)
-> [Event]
-> [LEvent a]
ConvertUtil.convert forall {p}. Event -> p -> [LEvent Event]
event1 forall {b}. b -> Maybe ResolvedInstrument
lookup_inst 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 = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Cmd.ResolvedInstrument
        { inst_instrument :: Inst
inst_instrument = forall code. Backend -> Common code -> Inst code
Inst.Inst
            (Patch -> Backend
Inst.Midi forall a b. (a -> b) -> a -> b
$ PbRange -> Text -> Patch
Midi.Patch.patch (-Int
1, Int
1) Text
"ly-fake-inst")
            (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
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Config -> [(Instrument, StaffConfig)]
Types.config_staves Config
config) = forall a. a -> a
id
        | Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Instrument
insts) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument)
    insts :: Set Instrument
insts = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ Instrument
Constants.ly_global 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 = forall {a}. ExceptT Msg Identity a -> [LEvent a]
run 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 <- 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.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Pitch
maybe_pitch forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
has_code_flag) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, MonadError Msg m) => Text -> m a
throw Text
"a note without pitch must have code"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
dur forall a. Eq a => a -> a -> Bool
== Time
0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
has_code_flag) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, MonadError Msg m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"zero duration event must have " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Flags
Flags.ly_code
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Msg -> LEvent a
LEvent.Log forall a. a -> LEvent a
LEvent.Event forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
Identity.runIdentity
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just Transposed
pitch -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. (Stack, MonadError Msg m) => Text -> m a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"convert_pitch: "<>)) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) 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 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"scale id not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ScaleId
scale_id
        Just (Left PitchError
err) ->
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"scale " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ScaleId
scale_id forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty PitchError
err
        Just (Right Scale
scale) -> do
            Note
note <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ Transposed -> Either PitchError Note
PSignal.pitch_note Transposed
pitch
            Pitch
pitch <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty 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 = 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 = forall a b. (a -> b) -> [a] -> [b]
map 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 =
    forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral Time
t forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Time
time :: Double) forall a. Num a => a -> a -> a
* Time
time

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