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