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