module Music.LilyPond.Light.Output.LilyPond
(ly_work
,ly_fragment
,ly_music_elem
,ly_process,ly_process_cwd
,Lilypond(..)) where
import Data.Char
import Data.Maybe
import System.Directory
import System.Exit
import System.FilePath
import System.Process
import Text.Printf
import qualified Music.Theory.Clef as C
import Music.Theory.Pitch
import Music.Theory.Pitch.Note
import Music.Theory.Duration
import Music.Theory.Dynamic_Mark
import Music.Theory.Key
import Music.LilyPond.Light.Model
with_brackets :: (String,String) -> [String] -> [String]
with_brackets (begin,end) xs = [begin] ++ xs ++ [end]
with_braces :: [String] -> [String]
with_braces = with_brackets ("{","}")
ly_sym :: String -> String
ly_sym x = "\\" ++ x
ly_str :: String -> String
ly_str x = "\"" ++ x ++ "\""
ly_markup :: String -> String
ly_markup x = "\\markup {" ++ x ++ "}"
ly_version :: Version -> [String]
ly_version (Version v) = ["\\version", ly_str v]
ly_assign' :: (String -> String) -> (String,String) -> Maybe [String]
ly_assign' fn (key,value) =
if null value
then Nothing
else Just [key,"=",fn value]
ly_assign :: (String -> String) -> (String,String) -> [String]
ly_assign fn (key,value) = [key,"=",fn value]
ly_units :: Units -> String
ly_units x =
case x of
MM -> "\\mm"
CM -> "\\cm"
ly_length :: Length -> String
ly_length (Length n x) = show n ++ ly_units x
ly_delete_nil_values :: [(String,String)] -> [(String,String)]
ly_delete_nil_values = filter (not . null . snd)
ly_paper :: Paper -> [String]
ly_paper p =
let tw = two_sided p
opt = maybe "" show
mg = if tw
then [("binding-offset", ly_length (binding_offset p))
,("inner-margin", ly_length (inner_margin p))
,("outer-margin", ly_length (outer_margin p))]
else [("left-margin", ly_length (left_margin p))
,("right-margin", ly_length (right_margin p))]
xs = [("bottom-margin", ly_length (bottom_margin p))
,("indent", ly_length (indent p))
,("paper-width", ly_length (paper_width p))
,("paper-height", ly_length (paper_height p))
,("ragged-right", ly_bool (ragged_right p))
,("ragged-last", ly_bool (ragged_last p))
,("ragged-bottom", ly_bool (ragged_bottom p))
,("ragged-last-bottom", ly_bool (ragged_last_bottom p))
,("top-margin", ly_length (top_margin p))
,("two-sided", ly_bool tw)
,("print-page-number", ly_bool (print_page_number p))
,("min-systems-per-page", opt (min_systems_per_page p))
,("max-systems-per-page", opt (max_systems_per_page p))
,("systems-per-page", opt (systems_per_page p))
,("systems-count", opt (systems_count p))
,("page-count", opt (page_count p))
,("system-separator-markup", fromMaybe "" (system_separator_markup p))
,("system-system-spacing.basic-distance", opt (system_spacing_basic_distance p))
,("system-system-spacing.minimum-distance", opt (system_spacing_minimum_distance p))
]
ys = ly_delete_nil_values (xs ++ mg)
in "\\paper" : with_braces (concat (map (ly_assign id) ys))
ly_header :: Header -> [String]
ly_header hdr =
let xs = [("dedication", dedication hdr)
,("title", title hdr)
,("subtitle", subtitle hdr)
,("subsubtitle", subsubtitle hdr)
,("instrument", instrument hdr)
,("composer", composer hdr)
,("opus", opus hdr)
,("poet", poet hdr)]
ys = [("tagline", tagline hdr)]
in "\\header" :
with_braces (concat (mapMaybe (ly_assign' ly_markup) xs) ++
concat (map (ly_assign ly_markup) ys))
ly_clef_t :: C.Clef_T -> String
ly_clef_t c =
case c of
C.Treble -> "treble"
C.Alto -> "alto"
C.Tenor -> "tenor"
C.Bass -> "bass"
C.Percussion -> "percussion"
ly_clef :: C.Clef Int -> String
ly_clef (C.Clef c o) =
let o' = case o of
(2) -> "_15"
(1) -> "_8"
1 -> "^8"
2 -> "^15"
_ -> error ("ly_clef: " ++ show (c,o))
in if o == 0
then ly_clef_t c
else concat ["\"", ly_clef_t c, o', "\""]
ly_note :: Note_T -> String
ly_note = map toLower . show
ly_alteration' :: Maybe Alteration_T -> String
ly_alteration' = maybe "" alteration_tonh
ly_alteration_rule :: [Annotation] -> String
ly_alteration_rule xs
| ReminderAccidental `elem` xs = "!"
| CautionaryAccidental `elem` xs = "?"
| otherwise = ""
ly_octave :: Octave -> String
ly_octave o =
case o of
(1) -> ",,,,"
0 -> ",,,"
1 -> ",,"
2 -> ","
3 -> ""
4 -> "'"
5 -> "''"
6 -> "'''"
7 -> "''''"
8 -> "'''''"
_ -> error ("ly_octave: " ++ show o)
ly_pitch :: [Annotation] -> Pitch -> String
ly_pitch xs (Pitch n a o) =
ly_note n ++
alteration_tonh a ++
ly_octave o ++
ly_alteration_rule xs
ly_articulation :: Articulation_T -> String
ly_articulation a =
case a of
Accent -> "\\accent"
Arpeggio -> "\\arpeggio"
ArpeggioDown -> "\\arpeggioDown"
ArpeggioNeutral -> "\\arpeggioNeutral"
ArpeggioUp -> "\\arpeggioUp"
DownBow -> "\\downbow"
Fermata -> "\\fermata"
Flageolet -> "\\flageolet "
Glissando -> "\\glissando "
Harmonic -> "\\harmonic"
LaissezVibrer -> "\\laissezVibrer"
Marcato -> "\\marcato"
Open -> "\\open"
Portato -> "\\portato"
Staccato -> "\\staccato"
Staccatissimo -> "\\staccatissimo"
StemTremolo x -> ':' : show x
Stopped -> "\\stopped"
Tenuto -> "\\tenuto"
Trill -> "\\trill"
UpBow -> "\\upbow"
ly_hairpin_t :: Hairpin_T -> String
ly_hairpin_t h =
case h of
Crescendo -> "\\<"
Diminuendo -> "\\>"
End_Hairpin -> "\\!"
ly_dynamic :: Dynamic_T -> String
ly_dynamic d =
case d of
Dynamic_Mark m -> '\\' : map toLower (show m)
Hairpin h -> ly_hairpin_t h
Espressivo -> "\\espressivo"
ly_fraction :: (Integer,Integer) -> String
ly_fraction (n,d) = show n ++ "/" ++ show d
ly_duple :: (Show x) => (x,x) -> String
ly_duple (x,y) = "#'(" ++ show x ++ " . " ++ show y ++ ")"
ly_duration :: Duration -> String
ly_duration = duration_to_lilypond_type
ly_phrasing :: Phrasing_T -> String
ly_phrasing p =
case p of
Begin_Slur -> "("
End_Slur -> ")"
Begin_PhrasingSlur -> "\\("
End_PhrasingSlur -> "\\)"
Begin_Beam -> "["
End_Beam -> "]"
SustainOn -> "\\sustainOn"
SustainOff -> "\\sustainOff"
ly_text :: Text_T -> String -> String
ly_text ty x =
case ty of
Text_Symbol -> ly_sym x
Text_Plain -> ly_str x
Text_Markup -> ly_markup x
ly_annotation :: Annotation -> String
ly_annotation a =
case a of
Articulation x -> ly_articulation x
Dynamic x -> ly_dynamic x
Phrasing x -> ly_phrasing x
Begin_Tie -> "~"
Place_Above -> "^"
Place_Default -> "-"
Place_Below -> "_"
Text_Mark ty x -> "\\mark " ++ ly_text ty x
Text ty x -> ly_text ty x
CompositeAnnotation xs -> unwords (map ly_annotation xs)
ReminderAccidental -> ""
CautionaryAccidental -> ""
Parentheses -> ""
Tweak _ -> ""
ly_tweak :: Annotation -> Maybe String
ly_tweak a =
case a of
Tweak str -> Just ("\\tweak " ++ str)
_ -> Nothing
ly_tweaks :: [Annotation] -> String
ly_tweaks = unwords . mapMaybe ly_tweak
ly_bar :: Bar_T -> String
ly_bar b =
case b of
NormalBarline -> "|"
DoubleBarline -> "||"
LeftRepeatBarline -> ".|:"
RightRepeatBarline -> ":|."
FinalBarline -> "|."
DottedBarline -> ":"
DashedBarline -> "!"
TickBarline -> "'"
InvisibleBarline -> ""
UserBarline s -> s
ly_command :: Command_T -> String
ly_command c =
case c of
AutoBeamOff -> "\\autoBeamOff"
Bar x -> "\\bar " ++ ly_str (ly_bar x)
BarlineCheck -> "|\n"
BarNumberCheck x -> "\\barNumberCheck #" ++ show x
Break -> "\\break"
Change x -> "\\change Staff = " ++ ly_str x
DynamicDown -> "\\dynamicDown"
DynamicNeutral -> "\\dynamicNeutral"
DynamicUp -> "\\dynamicUp"
NoBreak -> "\\noBreak"
NoPageBreak -> "\\noPageBreak"
Octavation x -> "\\ottava #" ++ show x
PageBreak -> "\\pageBreak"
Partial x -> "\\partial " ++ ly_duration x
Rehearsal_Mark Nothing -> "\\mark \\default"
Rehearsal_Mark (Just n) -> "\\mark #" ++ show n
StemDown -> "\\stemDown"
StemNeutral -> "\\stemNeutral"
StemUp -> "\\stemUp"
TupletDown -> "\\tupletDown"
TupletNeutral -> "\\tupletNeutral"
TupletUp -> "\\tupletUp"
User x -> x
VoiceOne -> "\\voiceOne"
VoiceTwo -> "\\voiceTwo"
VoiceThree -> "\\voiceThree"
VoiceFour -> "\\voiceFour"
ly_key_mode :: Mode_T -> String
ly_key_mode md =
case md of
Major_Mode -> "\\major"
Minor_Mode -> "\\minor"
ly_music_l :: [Music] -> [String]
ly_music_l = concatMap ly_music
ly_rest_type :: Rest_T -> String
ly_rest_type ty =
case ty of
Normal_Rest -> "r"
Spacer_Rest -> "s"
ly_paren :: [Annotation] -> [String] -> [String]
ly_paren a = if Parentheses `elem` a then ("\\parenthesize" :) else id
ly_music :: Music -> [String]
ly_music m =
case m of
Note p d aa -> ly_paren aa ([ly_tweaks aa,ly_pitch aa p, maybe "" ly_duration d] ++ map ly_annotation aa)
Chord xs d aa -> ly_paren aa (ly_tweaks aa :
with_brackets ("<",">") (ly_music_l xs) ++
[ly_duration d] ++ map ly_annotation aa)
Tremolo (Left x) n -> ["\\repeat", "\"tremolo\"", show n] ++ ly_music x
Tremolo (Right (x0,x1)) n -> ["\\repeat", "\"tremolo\"", show n] ++
with_braces (ly_music x0 ++ ly_music x1)
Rest ty d aa -> [ly_rest_type ty, ly_duration d] ++
map ly_annotation aa
MMRest i (j,k) aa -> let d = printf "R %d*%d " k (i*j)
in d : map ly_annotation aa
Skip d aa -> ["\\skip", ly_duration d] ++ map ly_annotation aa
Repeat n x -> ["\\repeat", "volta", show n] ++ with_braces (ly_music x)
Tuplet o n x ->
let (o',n') =
case o of
Normal_Tuplet -> ("\\times", ly_fraction n)
Scale_Durations -> ("\\scaleDurations", ly_duple n)
in [o', n'] ++ with_braces (ly_music x)
Grace x -> "\\grace" : with_braces (ly_music x)
AfterGrace x0 x1 -> "\\afterGrace" : concatMap ly_music [x0, x1]
Clef c -> ["\\clef", ly_clef c]
Time n -> ["\\time", ly_fraction n]
Key n a md -> ["\\key"
,ly_note n ++ ly_alteration' a
,ly_key_mode md]
Tempo m_str d r ->
let r' = floor r :: Integer
in case m_str of
Nothing -> ["\\tempo", ly_duration d, "=", show r']
Just str -> ["\\tempo", ly_markup str, ly_duration d, "=", show r']
Command x aa -> ly_command x : map ly_annotation aa
Join xs -> concatMap ly_music xs
Polyphony x1 x2 -> ["\\simultaneous", "{"] ++
with_braces (ly_music x1) ++
["\\\\"] ++
with_braces (ly_music x2) ++
["}"]
Empty -> []
ly_staff_name :: String -> Staff_Name -> [String]
ly_staff_name p (n1,n2) =
["\\set", p++".instrumentName", "=", ly_str (n1++" ")
,"\\set", p++".shortInstrumentName", "=", ly_str (n2++" ")]
ly_staff_t :: Staff_T -> String
ly_staff_t ty =
case ty of
Normal_Staff -> "Staff"
Rhythmic_Staff -> "RhythmicStaff"
ly_part :: [String] -> String -> Part -> [String]
ly_part nm i p =
let brk = with_brackets ("<<",">>")
mk_v xs = ["\\new"
,"Voice"
,"="
,ly_str i] ++ with_braces (ly_music (Join xs))
mk_txt txt = ["\\new"
,"Lyrics"
,"\\lyricsto"
,ly_str i] ++ with_braces [" " ++ txt ++ " "]
mk_chd txt = ["\\new","ChordNames","\\chordmode"] ++
with_braces [" " ++ txt ++ " "]
in case p of
(Part Nothing Nothing xs) -> with_braces (nm ++ ly_music (Join xs))
(Part chd txt xs) -> brk (nm ++ mk_v xs ++ maybe [] mk_chd chd ++ maybe [] mk_txt txt)
(MultipleParts xs) -> brk (concatMap mk_v xs)
ly_staff_set_t :: Staff_Set_T -> String
ly_staff_set_t x =
case x of
ChoirStaff -> "ChoirStaff"
GrandStaff -> "GrandStaff"
PianoStaff -> "PianoStaff"
StaffGroup -> "StaffGroup"
StaffGroup_SquareBracket -> "StaffGroup"
ly_staff :: Staff -> [String]
ly_staff s =
case s of
Staff (Staff_Settings ty i sc) nm pt ->
let i' = if null i then "no_id" else i
nm' = ly_staff_name "Staff" nm
sc' = if sc == 0
then ""
else printf " \\with { fontSize = #%d \\override StaffSymbol #'staff-space = #(magstep %d) } " sc sc
in ["\\new"
,ly_staff_t ty
,"="
,ly_str i'] ++ [sc'] ++ ly_part nm' i' pt
Staff_Set ty nm xs ->
let ty' = ly_staff_set_t ty
dlm = if ty == StaffGroup_SquareBracket
then "\\set StaffGroup.systemStartDelimiter = #'SystemStartSquare"
else ""
in (["\\new"
,ty'
,"\\simultaneous"
] ++
with_braces ([dlm] ++
ly_staff_name ty' nm ++
concatMap ly_staff xs))
ly_independent_time_signatures :: [String]
ly_independent_time_signatures =
["\\context { \\Score"
," \\remove \"Timing_translator\""
," \\remove \"Default_bar_line_engraver\""
," }"
," \\context {"
," \\Staff"
," \\consists \"Timing_translator\""
," \\consists \"Default_bar_line_engraver\""
," }"]
ly_remove_empty_staves :: Bool -> [String]
ly_remove_empty_staves g =
let f stf = ["\\context {"
," \\" ++ stf ++ "\\RemoveEmptyStaves"
,if g
then " \\override VerticalAxisGroup #'remove-first = ##t"
else ""
,"}"]
in concatMap f ["Staff","RhythmicStaff"]
ly_hide_time_signatures :: [String]
ly_hide_time_signatures =
["\\context {"
," \\Staff"
," \\remove \"Time_signature_engraver\""
,"}"]
ly_layout :: Score_Settings -> [String]
ly_layout x =
let mk_i = printf "\\context { \\%s \\consists \"Instrument_name_engraver\"}"
is = unlines (map mk_i ["StaffGroup","ChoirStaff","GrandStaff"])
in ["\\layout", "{"
,if independent_time_signatures x
then unlines ly_independent_time_signatures
else ""
,if hide_time_signatures x
then unlines ly_hide_time_signatures
else ""
,if remove_empty_staves x
then unlines (ly_remove_empty_staves (remove_empty_staves_first_system x))
else ""
,is
,"}"]
ly_score :: Score -> [String]
ly_score (Score pr xs) =
let xs' = with_braces (concatMap ly_staff xs)
xs'' = with_braces ("\\simultaneous" : xs' ++ ly_layout pr)
in "\\score" : xs''
ly_work :: Work -> String
ly_work (Work v p hdr sc) =
let xs = ly_version v ++
ly_paper p ++
ly_header hdr ++
ly_score sc
in unwords xs
ly_music_elem :: Music -> String
ly_music_elem = unwords . ly_music
ly_fragment :: Fragment -> String
ly_fragment (Fragment v p st) =
unlines (ly_version v ++
ly_paper p ++
ly_header default_header ++
with_braces (ly_staff st))
class Lilypond a where ly_notate :: a -> String
instance Lilypond Score where ly_notate = unlines . ly_score
instance Lilypond Work where ly_notate = ly_work
instance Lilypond Fragment where ly_notate = ly_fragment
ly_process :: Lilypond a => FilePath -> Format -> String -> a -> IO ExitCode
ly_process dir fmt nm ly = do
let fmt' = map toLower (show fmt)
o_fn = dir </> nm
ly_fn = o_fn <.> "ly"
cmd = printf "lilypond --%s -o %s %s" fmt' o_fn ly_fn
writeFile ly_fn (ly_notate ly)
system cmd
ly_process_cwd :: Lilypond a => Format -> String -> a -> IO ExitCode
ly_process_cwd fmt nm ly = do
d <- getCurrentDirectory
ly_process d fmt nm ly