module Music.Score.Export.Lilypond (
HasLilypondInstrument(..),
Lilypond,
LyContext(..),
HasLilypond,
toLilypond,
toLilypondString,
showLilypond,
openLilypond,
writeLilypond,
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.Default
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 qualified Music.Lilypond as Lilypond
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.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.Time.Internal.Quantize
class HasLilypondInstrument a where
getLilypondClef :: a -> Int
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)
data LyScore a = LyScore { getLyScore :: (ScoreInfo, [LyStaff a]) }
deriving (Functor, Eq, Show)
data LyStaff a = LyStaff { getLyStaff :: (StaffInfo, [LyBar a]) }
deriving (Functor, Eq, Show)
data LyBar a = LyBar { getLyBar :: (BarInfo, Rhythm a) }
deriving (Functor, Eq, Show)
data LyContext a = LyContext Duration (Maybe a)
deriving (Functor, Foldable, Traversable, Eq, Show)
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
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))
= (setTimeSignature `ifJust` timeSignature)
. renderBarMusic $ x
where
ifJust = maybe id
setTimeSignature (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) = bimap fromIntegral fromIntegral $ unRatio $ realToFrac m
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 $ removeCloseDynMarks)
. map (second $ over dynamics notateDynamic)
. map (second $ preserveMeta addDynCon)
. map (second $ preserveMeta simultaneous)
. extractParts'
$ normScore
where
(timeSignatureMarks, barDurations) = extractTimeSignatures normScore
normScore = normalizeScore score
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
-> Int
-> 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
handleErrors (Left e) = error $ "Quantization failed: " ++ e
handleErrors (Right x) = x
instance HasBackendNote Lilypond a => HasBackendNote Lilypond [a] where
exportNote = exportChord
instance HasBackendNote Lilypond Integer where
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
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 . 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
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
rcomposed = composed . reverse
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
rcomposed = composed . reverse
instance HasBackendNote Lilypond a => HasBackendNote Lilypond (ColorT a) where
exportNote b = uncurry notate . getCouple . getColorT . fmap (exportNote b) . sequenceA
where
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
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 . getCouple . getTextT . fmap (exportNote b) . sequenceA
where
notate texts = composed (fmap Lilypond.addText texts)
instance HasBackendNote Lilypond a => HasBackendNote Lilypond (HarmonicT a) where
exportNote b = uncurry notate . getCouple . getHarmonicT . fmap (exportNote b) . 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
notateArtificial n = id
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
notateGliss ((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 notateTie . getTieT . fmap (exportNote b) . sequenceA
exportChord b = uncurry notateTie . getTieT . fmap (exportChord b) . sequenceA . fmap sequenceA
notateTie (Any ta, Any tb)
| ta && tb = Lilypond.beginTie
| tb = Lilypond.beginTie
| ta = id
| otherwise = id
type HasLilypond a = (HasBackendNote Lilypond (BackendScoreEvent Lilypond a), HasBackendScore Lilypond a)
toLilypondString :: HasLilypond a => a -> String
toLilypondString = show . Pretty.pretty . toLilypond
toLilypond :: HasLilypond a => a -> Lilypond.Music
toLilypond = export (undefined::Lilypond)
showLilypond :: HasLilypond a => a -> IO ()
showLilypond = putStrLn . toLilypondString
writeLilypond :: HasLilypond a => FilePath -> a -> IO ()
writeLilypond = writeLilypond' def
data LilypondOptions
= LyInlineFormat
| LyScoreFormat
instance Default LilypondOptions where
def = LyInlineFormat
writeLilypond' :: HasLilypond a => LilypondOptions -> FilePath -> a -> IO ()
writeLilypond' options path sc = writeFile path $ (lyFilePrefix ++) $ toLilypondString sc
where
title = ""
composer = ""
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"
openLilypond :: HasLilypond a => a -> IO ()
openLilypond = openLilypond' def
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"
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))
removeCloseDynMarks :: (HasPhrases' s a, HasDynamics' a, Dynamic a ~ DynamicNotation, a ~ SetDynamic (Dynamic a) a) => s -> s
removeCloseDynMarks = mapPhrasesWithPrevAndCurrentOnset f
where
f Nothing t = id
f (Just t1) t2 = if (t2 .-. t1) > 1.5 then id else over (_head.mapped) removeDynMark
removeDynMark :: (HasDynamics' a, Dynamic a ~ DynamicNotation, a ~ SetDynamic (Dynamic a) a) => a -> a
removeDynMark x = set (dynamics' . _Wrapped' . _2) Nothing x
type TVoice a = Track (Phrase a)
mapPhrasesWithPrevAndCurrentOnset :: HasPhrases s t a b => (Maybe Time -> Time -> Phrase a -> Phrase b) -> s -> t
mapPhrasesWithPrevAndCurrentOnset f = over (mvoices . mVoiceTVoice) (withPrevAndCurrentOnset f)
withPrevAndCurrentOnset :: (Maybe Time -> Time -> a -> b) -> Track a -> Track b
withPrevAndCurrentOnset f = over delayeds (fmap (\(x,y,z) -> fmap (f (fmap _onset x) (_onset y)) y) . withPrevNext)
mVoiceTVoice :: Lens (MVoice a) (MVoice b) (TVoice a) (TVoice b)
mVoiceTVoice = mvoicePVoice . pVoiceTVoice
pVoiceTVoice :: Lens (PVoice a) (PVoice b) (TVoice a) (TVoice b)
pVoiceTVoice = lens pVoiceToTVoice (flip tVoiceToPVoice)
where
pVoiceToTVoice :: PVoice a -> TVoice a
pVoiceToTVoice x = mkTrack $ rights $ map (sequenceA) $ mapZip (offsetPoints (0::Time)) (withDurationR x)
tVoiceToPVoice :: TVoice a -> PVoice b -> PVoice a
tVoiceToPVoice tv pv = set _rights newPhrases pv
where
newPhrases = toListOf traverse tv
_rights :: Lens [Either a b] [Either a c] [b] [c]
_rights = lens _rightsGet (flip _rightsSet)
_rightsGet :: [Either a b] -> [b]
_rightsGet = rights
_rightsSet :: [c] -> [Either a b] -> [Either a c]
_rightsSet cs = sndMapAccumL f cs
where
f cs (Left a) = (cs, Left a)
f (c:cs) (Right b) = (cs, Right c)
f [] (Right _) = error "No more cs"
sndMapAccumL f z = snd . Data.List.mapAccumL f z
mapZip :: ([a] -> [b]) -> [(a,c)] -> [(b,c)]
mapZip f = uncurry zip . first f . unzipR
mkTrack :: [(Time, a)] -> Track a
mkTrack = view track . map (view delayed)
withDurationR :: (Functor f, HasDuration a) => f a -> f (Duration, a)
withDurationR = fmap $ \x -> (_duration x, x)
mapWithDuration :: HasDuration a => (Duration -> a -> b) -> a -> b
mapWithDuration = over dual withDurationL . uncurry
where
withDurationL :: (Contravariant f, HasDuration a) => f (Duration, a) -> f a
withDurationL = contramap $ \x -> (_duration x, x)
dual :: Iso (a -> b) (c -> d) (Op b a) (Op d c)
dual = iso Op getOp
dursToVoice :: [Duration] -> Voice ()
dursToVoice = mconcat . map (\d -> stretch d $ return ())
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)