music-score-1.7: src/Music/Score/Export/Lilypond.hs
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# 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 TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-------------------------------------------------------------------------------------
-- |
-- 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 Music.Dynamics.Literal
import Music.Pitch.Literal
import qualified Codec.Midi as Midi
import Control.Arrow ((***))
import Control.Comonad (Comonad (..), extract)
import Control.Applicative
import Data.Colour.Names as Color
import Data.Default
import Data.Foldable (Foldable)
import qualified Data.Foldable
import Data.Functor.Couple
import Data.Maybe
import Data.Ratio
import Data.Traversable (Traversable, sequenceA)
import qualified Music.Lilypond as Lilypond
import qualified Music.MusicXml.Simple as MusicXml
import Music.Score.Internal.Export hiding (MVoice)
import Music.Time.Internal.Transform (whilstLD)
import System.Process
import Music.Time.Internal.Quantize
import qualified Text.Pretty as Pretty
import qualified Data.List
import Music.Score.Convert (reactiveToVoice', voiceToScore) -- TODO
import Music.Score.Internal.Util (composed, unRatio, swap, retainUpdates)
import Music.Score.Export.DynamicNotation
import Music.Score.Export.ArticulationNotation
import Data.Semigroup.Instances
import Music.Score.Export.Backend
import Data.Functor.Identity
import Data.Semigroup
import Control.Monad
import Data.VectorSpace hiding (Sum(..))
import Data.AffineSpace
import Control.Lens hiding (rewrite)
-- import Control.Lens.Operators hiding ((|>))
import Music.Time
import Music.Score.Meta
import Music.Score.Dynamics
import Music.Score.Articulation
import Music.Score.Part
import Music.Score.Tremolo
import Music.Score.Text
import Music.Score.Harmonics
import Music.Score.Slide
import Music.Score.Color
import Music.Score.Ties
import Music.Score.Export.Backend
import Music.Score.Meta.Time
import Music.Score.Phrases
-- |
-- 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 Lilypond.Music where
mempty = pcatLy []
mappend x y = pcatLy [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 -> Lilypond.Music
finalizeScore (LyScore (info, x))
= pcatLy
. map finalizeStaff $ x
where
extra = id
-- TODO finalizeStaffGroup
finalizeStaff :: LyStaff LyMusic -> LyMusic
finalizeStaff (LyStaff (info, x))
= addStaff
. addPartName (staffName info)
. addClef (staffClef info)
. scatLy
. map finalizeBar $ x
where
addStaff = Lilypond.New "Staff" Nothing
addClef c x = scatLy [Lilypond.Clef c, x]
addPartName partName xs = scatLy [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))
= maybe id setBarTimeSignature timeSignature
. renderBarMusic $ x
where
-- TODO key signatures
-- TODO rehearsal marks
-- TODO bar number change
-- TODO compound time signatures
setBarTimeSignature (getTimeSignature -> (ms, n)) x = scatLy [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) = scatLy $ map renderBarMusic rs
go (Tuplet m r) = Lilypond.Times (realToFrac m) (renderBarMusic r)
where
(a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m
-- TODO move
second f (x, y) = (x, f y)
type HasArticulation3 c d e = (
HasArticulation' c,
HasArticulation c d,
HasArticulation d e,
HasArticulation c e
)
type HasArticulationNotation a b c = (
HasArticulation3 a b c,
Articulation b ~ Ctxt (Articulation a),
Articulation c ~ ArticulationNotation,
-- TODO generalize
Articulation a ~ (Sum Double, Sum Double)
)
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)
)
=> HasBackendScore Lilypond (Score a) where
type BackendScoreEvent Lilypond (Score a) = SetArticulation ArticulationNotation (SetDynamic DynamicNotation a)
exportScore b score = LyScore
. (ScoreInfo,)
. map (uncurry $ exportPart timeSignatureMarks barDurations)
. map (second (over articulations notateArticulation))
. map (second (preserveMeta addArtCon))
. map (second (over dynamics notateDynamic))
. map (second (preserveMeta addDynCon))
. map (second (preserveMeta simultaneous))
. extractParts'
$ score
where
(timeSignatureMarks, barDurations) = extractTimeSignatures 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 = splitTiesVoiceAt
exportBar timeSignature
= LyBar
. addBarInfo
. quantizeBar
where
addBarInfo = (,) $ BarInfo timeSignature
quantizeBar = mapWithDur LyContext . rewrite . handleErrors . quantize . view eventsV
where
-- FIXME propagate quantization errors
handleErrors (Left e) = error $ "Quantization failed: " ++ e
handleErrors (Right x) = x
-- TODO move
addArtCon :: (
HasPhrases s t a b, HasArticulation a a, HasArticulation a b,
Articulation a ~ d, Articulation b ~ Ctxt d
) => s -> t
addArtCon = over (phrases.varticulation) withContext
varticulation = lens (fmap $ view articulation) (flip $ zipVoiceWithNoScale (set articulation))
{-
-- TODO customize and remove extraction-related constraints
instance (
HasDynamicNotation a b c,
HasOrdPart a, Transformable a, Semigroup a,
HasOrdPart c, Show (Part c), HasLilypondInstrument (Part c), Tiable c
)
=> HasBackendScore Lilypond (Voice a) where
type BackendScoreEvent Lilypond (Voice a) = SetDynamic DynamicNotation a
exportScore b = exportScore b . voiceToScore
-}
--------------------------------------------------------------------------------
{-
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 $ spellLy x
exportChord _ (LyContext d Nothing) = (^*realToFrac (4*d)) Lilypond.rest
exportChord _ (LyContext d (Just xs)) = (^*realToFrac (4*d)) $ Lilypond.chord $ fmap spellLy 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)
instance HasBackendNote Lilypond a => HasBackendNote Lilypond (DynamicT DynamicNotation a) where
exportNote b = uncurry notate . fmap (exportNote b) . getDynamicT . 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
instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ArticulationT ArticulationNotation a) where
exportNote b = uncurry notate . fmap (exportNote b) . getArticulationT . 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
instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ColorT a) where
exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getColorT . 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 (notate x d) $ exportNote b $ LyContext (snd $ notate x d) (fmap extract x)
where
notate Nothing d = (id, d)
notate (Just (TremoloT (Couple (Max 0, _)))) d = (id, d)
notate (Just (TremoloT (Couple (Max n, _)))) d = let
scale = 2^n
newDur = (d `min` (1/4)) / scale
repeats = d / newDur
in (Lilypond.Tremolo (round repeats), newDur)
instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TextT a) where
exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getTextT . sequenceA
where
notate texts = composed (fmap Lilypond.addText texts)
instance HasBackendNote Lilypond a => HasBackendNote Lilypond (HarmonicT a) where
exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getHarmonicT . sequenceA
where
notate (Any isNat, Sum n) = case (isNat, n) of
(_, 0) -> id
(True, n) -> notateNatural n
(False, n) -> notateArtificial n
notateNatural n = Lilypond.addFlageolet -- addOpen?
notateArtificial n = id -- TODO
instance HasBackendNote Lilypond a => HasBackendNote Lilypond (SlideT a) where
exportNote b = uncurry notate . fmap (exportNote b) . getCouple . getSlideT . sequenceA
where
notate ((Any eg, Any es),(Any bg, Any bs))
| bg = Lilypond.beginGlissando
| bs = Lilypond.beginGlissando
| otherwise = id
instance HasBackendNote Lilypond a => HasBackendNote Lilypond (TieT a) where
exportNote b = uncurry notate . fmap (exportNote b) . getTieT . sequenceA
where
notate (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 string.
--
toLilypondString :: HasLilypond a => a -> String
toLilypondString = show . Pretty.pretty . toLilypond
-- |
-- Convert a score to a Lilypond representation.
--
toLilypond :: HasLilypond a => a -> Lilypond.Music
toLilypond = export (undefined::Lilypond)
-- |
-- 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' def
data LilypondOptions
= LyInlineFormat
| LyScoreFormat
instance Default LilypondOptions where
def = LyInlineFormat
-- |
-- 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' def
-- |
-- 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
cleanLilypond = void $ runCommand
"rm -f test-*.tex test-*.texi test-*.count test-*.eps test-*.pdf test.eps"
runOpen = void $ runCommand
$ openCommand ++ " test.pdf"
-- Internal stuff
-- TODO This function is a workaround
-- Whenever it is used, we should make the original function preserve meta instead
preserveMeta :: (HasMeta a, HasMeta b) => (a -> b) -> a -> b
preserveMeta f x = let m = view meta x in set meta m (f x)
pcatLy :: [Lilypond.Music] -> Lilypond.Music
pcatLy = pcatLy' False
pcatLy' :: Bool -> [Lilypond.Music] -> Lilypond.Music
pcatLy' p = foldr Lilypond.simultaneous (Lilypond.Simultaneous p [])
scatLy :: [Lilypond.Music] -> Lilypond.Music
scatLy = foldr Lilypond.sequential (Lilypond.Sequential [])
spellLy :: Integer -> Lilypond.Note
spellLy a = Lilypond.NotePitch (spellLy' a) Nothing
spellLy' :: Integer -> Lilypond.Pitch
spellLy' p = Lilypond.Pitch (
toEnum $ fromIntegral pc,
fromIntegral alt,
fromIntegral oct
)
where (pc,alt,oct) = spellPitch (p + 72)
-- End internal