{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | -- Copyright : (c) Hans Hoglund 2012-2014 -- -- License : BSD-style -- -- Maintainer : hans@hanshoglund.se -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- ------------------------------------------------------------------------------------- module Music.Score.Export.Lilypond ( -- * Lilypond backend HasLilypondInstrument(..), Lilypond, LyContext(..), HasLilypond, -- ** Converting to Lilypond toLilypond, toLilypondString, -- ** Lilypond I/O showLilypond, openLilypond, writeLilypond, -- ** Customize Lilypond backend LilypondOptions(..), openLilypond', writeLilypond', ) where import Control.Applicative import Control.Comonad (Comonad (..), extract) import Control.Lens hiding (rewrite) import Control.Monad import Data.AffineSpace import Data.Bifunctor import Data.Colour.Names as Color import Data.Either import Data.Foldable (Foldable) import Data.Functor.Adjunction (unzipR) import Data.Functor.Context -- import Data.Functor.Contravariant import Data.Functor.Couple import qualified Data.List import Data.Maybe import Data.Ratio import Data.Semigroup import Data.Traversable (Traversable, sequenceA) import Data.VectorSpace hiding (Sum (..)) import System.Process import qualified Text.Pretty as Pretty import Music.Dynamics.Literal import Music.Pitch.Literal import Music.Score.Articulation import Music.Score.Color import Music.Score.Dynamics import Music.Score.Export.ArticulationNotation import Music.Score.Export.Backend import Music.Score.Export.Backend import Music.Score.Export.DynamicNotation import Music.Score.Harmonics import Music.Score.Internal.Export hiding (MVoice) import Music.Score.Internal.Util (composed, retainUpdates, swap, unRatio, withPrevNext) import Music.Score.Meta import Music.Score.Meta.Time import Music.Score.Meta.Title import Music.Score.Meta.Attribution import Music.Score.Part import Music.Score.Phrases import Music.Score.Slide import Music.Score.Text import Music.Score.Ties import Music.Score.Tremolo import Music.Time import Music.Score.Internal.Quantize import qualified Music.Lilypond as Lilypond #define COMPLEX_POLY_STUFF 1 -- | -- Extract instrument info as per "Music.Part" -- This is really crude, needs rethinking! -- class HasLilypondInstrument a where getLilypondClef :: a -> Int {- TODO rewrite so that: - Each bar may include voices/layers (a la Sibelius) - Each part may generate more than one staff (for piano etc) -} -- | A token to represent the Lilypond backend. data Lilypond data ScoreInfo = ScoreInfo deriving (Eq, Show) data StaffInfo = StaffInfo { staffName :: String, staffClef :: Lilypond.Clef } deriving (Eq, Show) data BarInfo = BarInfo { barTimeSignature :: Maybe TimeSignature } deriving (Eq, Show) -- | Hierachical representation of a Lilypond score. -- A score is a parallel composition of staves. data LyScore a = LyScore { getLyScore :: (ScoreInfo, [LyStaff a]) } deriving (Functor, Eq, Show) -- | A staff is a sequential composition of bars. data LyStaff a = LyStaff { getLyStaff :: (StaffInfo, [LyBar a]) } deriving (Functor, Eq, Show) -- | A bar is a sequential composition of chords/notes/rests. data LyBar a = LyBar { getLyBar :: (BarInfo, Rhythm a) } deriving (Functor, Eq, Show) -- | Context passed to the note export. -- Includes duration and note/rest distinction. data LyContext a = LyContext Duration (Maybe a) deriving (Functor, Foldable, Traversable, Eq, Show) {- TODO move instance Monoid LyMusic where mempty = pcatL [] mappend x y = pcatL [x,y] -} type LyMusic = Lilypond.Music instance HasBackend Lilypond where type BackendScore Lilypond = LyScore type BackendContext Lilypond = LyContext type BackendNote Lilypond = LyMusic type BackendMusic Lilypond = LyMusic finalizeExport _ = finalizeScore where finalizeScore :: LyScore LyMusic -> LyMusic finalizeScore (LyScore (info, x)) = pcatL . map finalizeStaff $ x -- TODO finalizeStaffGroup finalizeStaff :: LyStaff LyMusic -> LyMusic finalizeStaff (LyStaff (info, x)) = addStaff . addPartName (staffName info) . addClef (staffClef info) . scatL . map finalizeBar $ x where addStaff = Lilypond.New "Staff" Nothing addClef c x = scatL [Lilypond.Clef c, x] addPartName partName xs = scatL [longName, shortName, xs] where longName = Lilypond.Set "Staff.instrumentName" (Lilypond.toValue partName) shortName = Lilypond.Set "Staff.shortInstrumentName" (Lilypond.toValue partName) finalizeBar :: LyBar LyMusic -> LyMusic finalizeBar (LyBar (BarInfo timeSignature, x)) = (setTimeSignature `ifJust` timeSignature) . renderBarMusic $ x where ifJust = maybe id -- TODO key signatures -- TODO rehearsal marks -- TODO bar number change -- TODO compound time signatures setTimeSignature (getTimeSignature -> (ms, n)) x = scatL [Lilypond.Time (sum ms) n, x] renderBarMusic :: Rhythm LyMusic -> LyMusic renderBarMusic = go where go (Beat d x) = Lilypond.removeSingleChords x go (Dotted n (Beat d x)) = Lilypond.removeSingleChords x go (Group rs) = scatL $ map renderBarMusic rs go (Tuplet m r) = Lilypond.Times (realToFrac m) (renderBarMusic r) where (a,b) = bimap fromIntegral fromIntegral $ unRatio $ realToFrac m #ifdef COMPLEX_POLY_STUFF instance ( HasDynamicNotation a b c, HasArticulationNotation c d e, Part e ~ Part c, HasOrdPart a, Transformable a, Semigroup a, Tiable e, HasOrdPart c, Show (Part c), HasLilypondInstrument (Part c), Satisfied ) => HasBackendScore Lilypond (Score a) where #else instance ( Tiable a, HasOrdPart a, Show (Part a), HasLilypondInstrument (Part a), Satisfied ) => HasBackendScore Lilypond (Score a) where #endif #ifdef COMPLEX_POLY_STUFF type BackendScoreEvent Lilypond (Score a) = SetArticulation ArticulationNotation (SetDynamic DynamicNotation a) #else type BackendScoreEvent Lilypond (Score a) = a #endif exportScore b score = LyScore . (ScoreInfo,) -- Store time signatures etc for later use by finalizeScore . map (uncurry $ exportPart timeSignatureMarks barDurations) #ifdef COMPLEX_POLY_STUFF -- Notate articulation . map (second $ over articulations notateArticulation) . map (second $ preserveMeta addArtCon) -- Notate dynamics . map (second $ removeCloseDynMarks) . map (second $ over dynamics notateDynamic) . map (second $ preserveMeta addDynCon) -- Merge simultaneous chords . map (second $ preserveMeta simultaneous) #endif . extractPartsWithInfo $ normScore where (timeSignatureMarks, barDurations) = extractTimeSignatures normScore normScore = normalizeScore score -- | Export a score as a single part. Overlapping notes will cause an error. exportPart :: ( Show (Part a), HasLilypondInstrument (Part a), Tiable a ) => [Maybe TimeSignature] -> [Duration] -> Part a -> Score a -> LyStaff (LyContext a) exportStaff :: Tiable a => [Maybe TimeSignature] -> [Duration] -> String -- ^ name -> Int -- ^ clef, as per Music.Parts -> MVoice a -> LyStaff (LyContext a) exportBar :: Tiable a => Maybe TimeSignature -> MVoice a -> LyBar (LyContext a) quantizeBar :: Tiable a => MVoice a -> Rhythm (LyContext a) exportPart timeSignatureMarks barDurations part = exportStaff timeSignatureMarks barDurations (show part) (getLilypondClef part) . view singleMVoice exportStaff timeSignatures barDurations name clefId = LyStaff . addStaffInfo . zipWith exportBar timeSignatures . splitIntoBars barDurations where clef = case clefId of 0 -> Lilypond.Treble 1 -> Lilypond.Alto 2 -> Lilypond.Bass addStaffInfo = (,) $ StaffInfo { staffName = name, staffClef = clef } splitIntoBars = splitTiesAt exportBar timeSignature = LyBar . addBarInfo . quantizeBar where addBarInfo = (,) $ BarInfo timeSignature quantizeBar = mapWithDur LyContext . rewrite . handleErrors . quantize . view pairs where -- FIXME propagate quantization errors handleErrors (Left e) = error $ "Quantization failed: " ++ e handleErrors (Right x) = x -------------------------------------------------------------------------------- {- Note: We want all note transformers to be applicative morphisms, i.e. notate (pure x) = pure (notate x) Specifically notate (mempty,x) = id . notate x Note: We use these idioms: exportNote b = exportNote b . fmap extract exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA The latter looks a lot like cotraverse. Generalization? -} instance HasBackendNote Lilypond a => HasBackendNote Lilypond [a] where exportNote = exportChord instance HasBackendNote Lilypond Integer where -- TODO can we get rid of exportChord alltogether and just use LyContext? exportNote _ (LyContext d Nothing) = (^*realToFrac (4*d)) Lilypond.rest exportNote _ (LyContext d (Just x)) = (^*realToFrac (4*d)) $ Lilypond.note $ spellL x exportChord _ (LyContext d Nothing) = (^*realToFrac (4*d)) Lilypond.rest exportChord _ (LyContext d (Just xs)) = (^*realToFrac (4*d)) $ Lilypond.chord $ fmap spellL xs instance HasBackendNote Lilypond Int where exportNote b = exportNote b . fmap toInteger exportChord b = exportChord b . fmap (fmap toInteger) instance HasBackendNote Lilypond Float where exportNote b = exportNote b . fmap (toInteger . round) exportChord b = exportChord b . fmap (fmap (toInteger . round)) instance HasBackendNote Lilypond Double where exportNote b = exportNote b . fmap (toInteger . round) exportChord b = exportChord b . fmap (fmap (toInteger . round)) instance Integral a => HasBackendNote Lilypond (Ratio a) where exportNote b = exportNote b . fmap (toInteger . round) instance HasBackendNote Lilypond a => HasBackendNote Lilypond (Behavior a) where exportNote b = exportNote b . fmap (! 0) exportChord b = exportChord b . fmap (fmap (! 0)) instance HasBackendNote Lilypond a => HasBackendNote Lilypond (Sum a) where exportNote b = exportNote b . fmap getSum instance HasBackendNote Lilypond a => HasBackendNote Lilypond (Product a) where exportNote b = exportNote b . fmap getProduct instance HasBackendNote Lilypond a => HasBackendNote Lilypond (PartT n a) where -- Part structure is handled by HasMidiBackendScore instances, so this is just an identity exportNote b = exportNote b . fmap extract exportChord b = exportChord b . fmap (fmap extract) #ifdef COMPLEX_POLY_STUFF instance HasBackendNote Lilypond a => HasBackendNote Lilypond (DynamicT DynamicNotation a) where exportNote b = uncurry notate . getDynamicT . fmap (exportNote b) . sequenceA where notate :: DynamicNotation -> LyMusic -> LyMusic notate (DynamicNotation (crescDims, level)) = rcomposed (fmap notateCrescDim crescDims) . notateLevel level notateCrescDim crescDims = case crescDims of NoCrescDim -> id BeginCresc -> Lilypond.beginCresc EndCresc -> Lilypond.endCresc BeginDim -> Lilypond.beginDim EndDim -> Lilypond.endDim -- TODO these literals are not so nice... notateLevel showLevel = case showLevel of Nothing -> id Just lvl -> Lilypond.addDynamics (fromDynamics (DynamicsL (Just (fixLevel . realToFrac $ lvl), Nothing))) fixLevel :: Double -> Double fixLevel x = fromIntegral (round (x - 0.5)) + 0.5 -- Use rcomposed as notateDynamic returns "mark" order, not application order rcomposed = composed . reverse #else instance HasBackendNote Lilypond a => HasBackendNote Lilypond (DynamicT b a) where exportNote b = exportNote b . fmap extract #endif #ifdef COMPLEX_POLY_STUFF instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ArticulationT ArticulationNotation a) where exportNote b = uncurry notate . getArticulationT . fmap (exportNote b) . sequenceA where notate :: ArticulationNotation -> LyMusic -> LyMusic notate (ArticulationNotation (slurs, marks)) = rcomposed (fmap notateMark marks) . rcomposed (fmap notateSlur slurs) notateMark mark = case mark of NoMark -> id Staccato -> Lilypond.addStaccato MoltoStaccato -> Lilypond.addStaccatissimo Marcato -> Lilypond.addMarcato Accent -> Lilypond.addAccent Tenuto -> Lilypond.addTenuto notateSlur slurs = case slurs of NoSlur -> id BeginSlur -> Lilypond.beginSlur EndSlur -> Lilypond.endSlur -- Use rcomposed as notateDynamic returns "mark" order, not application order rcomposed = composed . reverse #else instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ArticulationT {-ArticulationNotation-}b a) where exportNote b = exportNote b . fmap extract #endif instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ColorT a) where exportNote b = uncurry notate . getCouple . getColorT . fmap (exportNote b) . sequenceA where -- TODO This syntax will change in future Lilypond versions -- TODO handle any color notate (Option Nothing) = id notate (Option (Just (Last color))) = \x -> Lilypond.Sequential [ Lilypond.Override "NoteHead#' color" (Lilypond.toLiteralValue $ "#" ++ colorName color), x, Lilypond.Revert "NoteHead#' color" ] colorName c | c == Color.black = "black" | c == Color.red = "red" | c == Color.blue = "blue" | otherwise = error "Lilypond backend: Unkown color" instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TremoloT a) where -- TODO can this instance use the new shorter idiom? exportNote b (LyContext d x) = fst (notateTremolo x d) $ exportNote b $ LyContext (snd $ notateTremolo x d) (fmap extract x) instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TextT a) where exportNote b = uncurry notateText . getCouple . getTextT . fmap (exportNote b) . sequenceA where instance HasBackendNote Lilypond a => HasBackendNote Lilypond (HarmonicT a) where exportNote b = uncurry notateHarmonic . getCouple . getHarmonicT . fmap (exportNote b) . sequenceA instance HasBackendNote Lilypond a => HasBackendNote Lilypond (SlideT a) where exportNote b = uncurry notateGliss . getCouple . getSlideT . fmap (exportNote b) . sequenceA exportChord b = uncurry notateGliss . getCouple . getSlideT . fmap (exportChord b) . sequenceA . fmap sequenceA {- exportNote :: b -> BC a -> BN exportChord :: b -> BC [a] -> BN uncurry notateTie :: ((Any, Any), LyMusic) -> LyMusic BC (TieT a) sequenceA TieT (BC a) fmap (exportNote b) TieT BN notate . getTieT BN BC [TieT a] fmap sequenceA BC (TieT [a]) sequenceA TieT (BC [a]) fmap (exportChord b) TieT BN notate . getTieT BN -} instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TieT a) where exportNote b = uncurry notateTie . getTieT . fmap (exportNote b) . sequenceA exportChord b = uncurry notateTie . getTieT . fmap (exportChord b) . sequenceA . fmap sequenceA notateTremolo :: RealFrac b => Maybe (TremoloT a) -> b -> (LyMusic -> LyMusic, b) notateTremolo Nothing d = (id, d) notateTremolo (Just (runTremoloT -> (0, _))) d = (id, d) notateTremolo (Just (runTremoloT -> (n, _))) d = let scale = 2^n newDur = (d `min` (1/4)) / scale repeats = d / newDur in (Lilypond.Tremolo (round repeats), newDur) notateText :: [String] -> LyMusic -> LyMusic notateText texts = composed (fmap Lilypond.addText texts) notateHarmonic :: (Eq t, Num t) => (Any, Sum t) -> LyMusic -> LyMusic notateHarmonic (Any isNat, Sum n) = case (isNat, n) of (_, 0) -> id (True, n) -> notateNatural n (False, n) -> notateArtificial n where notateNatural n = Lilypond.addFlageolet -- addOpen? notateArtificial n = id -- TODO notateGliss :: ((Any, Any), (Any, Any)) -> LyMusic -> LyMusic notateGliss ((Any eg, Any es),(Any bg, Any bs)) | bg = Lilypond.beginGlissando | bs = Lilypond.beginGlissando | otherwise = id notateTie :: (Any, Any) -> LyMusic -> LyMusic notateTie (Any ta, Any tb) | ta && tb = Lilypond.beginTie | tb = Lilypond.beginTie | ta = id | otherwise = id -- | -- Constraint for types that has a Lilypond representation. -- type HasLilypond a = (HasBackendNote Lilypond (BackendScoreEvent Lilypond a), HasBackendScore Lilypond a) -- | -- Convert a score to a Lilypond representation. -- toLilypond :: HasLilypond a => a -> LyMusic toLilypond = export (undefined::Lilypond) -- | -- Convert a score to a Lilypond string. -- toLilypondString :: HasLilypond a => a -> String toLilypondString = show . Pretty.pretty . toLilypond -- | -- Convert a score to a Lilypond representaiton and print it on the standard output. -- showLilypond :: HasLilypond a => a -> IO () showLilypond = putStrLn . toLilypondString -- | -- Convert a score to a Lilypond representation and write to a file. -- writeLilypond :: HasLilypond a => FilePath -> a -> IO () writeLilypond = writeLilypond' mempty data LilypondOptions = LyInlineFormat | LyScoreFormat instance Monoid LilypondOptions where mempty = LyInlineFormat mappend = const -- | -- Convert a score to a Lilypond representation and write to a file. -- writeLilypond' :: HasLilypond a => LilypondOptions -> FilePath -> a -> IO () writeLilypond' options path sc = writeFile path $ (lyFilePrefix ++) $ toLilypondString sc where -- title = fromMaybe "" $ flip getTitleAt 0 $ metaAtStart sc -- composer = fromMaybe "" $ flip getAttribution "composer" $ metaAtStart sc title = "" composer = "" -- TODO generalize metaAtStart! lyFilePrefix = case options of LyInlineFormat -> lyInlinePrefix LyScoreFormat -> lyScorePrefix lyInlinePrefix = mempty ++ "%%% Generated by music-score %%%\n" ++ "\\include \"lilypond-book-preamble.ly\"\n" ++ "\\paper {\n" ++ " #(define dump-extents #t)\n" ++ "\n" ++ " indent = 0\\mm\n" ++ " line-width = 210\\mm - 2.0 * 0.4\\in\n" ++ " ragged-right = ##t\n" ++ " force-assignment = #\"\"\n" ++ " line-width = #(- line-width (* mm 3.000000))\n" ++ "}\n" ++ "\\header {\n" ++ " title = \"" ++ title ++ "\"\n" ++ " composer = \"" ++ composer ++ "\"\n" ++ "}\n" ++ "\\layout {\n" ++ "}" ++ "\n\n" lyScorePrefix = mempty ++ "\\paper {" ++ " indent = 0\\mm" ++ " line-width = 210\\mm - 2.0 * 0.4\\in" ++ "}" ++ "\\header {\n" ++ " title = \"" ++ title ++ "\"\n" ++ " composer = \"" ++ composer ++ "\"\n" ++ "}\n" ++ "\\layout {" ++ "}" ++ "\n\n" -- | -- Typeset a score using Lilypond and open it. (This is simple wrapper around -- 'writeLilypond' that may not work well on all platforms.) -- openLilypond :: HasLilypond a => a -> IO () openLilypond = openLilypond' mempty -- | -- Typeset a score using Lilypond and open it. (This is simple wrapper around -- 'writeLilypond' that may not work well on all platforms.) -- openLilypond' :: HasLilypond a => LilypondOptions -> a -> IO () openLilypond' options sc = do writeLilypond' options "test.ly" sc runLilypond >> cleanLilypond >> runOpen where runLilypond = void $ runCommand -- "lilypond -f pdf test.ly" >>= waitForProcess "lilypond -f pdf test.ly 2>/dev/null" >>= waitForProcess cleanLilypond = void $ runCommand "rm -f test-*.tex test-*.texi test-*.count test-*.eps test-*.pdf test.eps" runOpen = void $ runCommand $ openCommand ++ " test.pdf" pcatL :: [LyMusic] -> LyMusic pcatL = pcatL' False pcatL' :: Bool -> [LyMusic] -> LyMusic pcatL' p = foldr Lilypond.simultaneous (Lilypond.Simultaneous p []) scatL :: [LyMusic] -> LyMusic scatL = foldr Lilypond.sequential (Lilypond.Sequential []) spellL :: Integer -> Lilypond.Note spellL a = Lilypond.NotePitch (spellL' a) Nothing spellL' :: Integer -> Lilypond.Pitch spellL' p = Lilypond.Pitch ( toEnum $ fromIntegral pc, fromIntegral alt, fromIntegral oct ) where (pc,alt,oct) = spellPitch (p + 72) -- | A constraint that is always satisfied. type Satisfied = (() ~ ()) -- | A constraint that is never satisfied. type Unsatisfied = (() ~ Bool)