module Music.LilyPond.Light (module Music.LilyPond.Light
,module Music.LilyPond.Light.Constant
,module Music.LilyPond.Light.Constant.NoteName
,module Music.LilyPond.Light.Model
,module Music.LilyPond.Light.Output.LilyPond
,module Music.Theory.Duration
,module Music.Theory.Duration.Name
,module Music.Theory.Key
,module Music.Theory.Pitch) where
import Data.List
import Data.Monoid
import Data.Ratio
import Music.LilyPond.Light.Constant
import Music.LilyPond.Light.Constant.NoteName
import Music.LilyPond.Light.Model
import Music.LilyPond.Light.Output.LilyPond
import Music.Theory.Duration
import Music.Theory.Duration.Name
import Music.Theory.Pitch
import Music.Theory.Key
is_note :: Music -> Bool
is_note (Note _ _ _) = True
is_note _ = False
is_chord :: Music -> Bool
is_chord (Chord _ _ _) = True
is_chord _ = False
is_rest :: Music -> Bool
is_rest (Rest _ _) = True
is_rest _ = False
is_mm_rest :: Music -> Bool
is_mm_rest (MMRest _ _ _) = True
is_mm_rest _ = False
is_grace :: Music -> Bool
is_grace (Grace _) = True
is_grace _ = False
is_after_grace :: Music -> Bool
is_after_grace (AfterGrace _ _) = True
is_after_grace _ = False
is_grace_skip :: Music -> Bool
is_grace_skip (Grace (Skip _)) = True
is_grace_skip _ = False
is_clef :: Music -> Bool
is_clef (Clef _ _) = True
is_clef _ = False
is_time :: Music -> Bool
is_time (Time _) = True
is_time _ = False
is_tempo :: Music -> Bool
is_tempo (Tempo _ _) = True
is_tempo _ = False
is_barlinecheck :: Music -> Bool
is_barlinecheck (Command BarlineCheck) = True
is_barlinecheck _ = False
is_tied :: Music -> Bool
is_tied m =
case m of
Note _ _ xs -> Begin_Tie `elem` xs
Chord _ _ xs -> Begin_Tie `elem` xs
_ -> False
is_tuplet :: Music -> Bool
is_tuplet (Tuplet _ _ _) = True
is_tuplet _ = False
r_acc :: Music -> Music
r_acc x = x &rAcc
c_acc :: Music -> Music
c_acc x = x &cAcc
clr_acc :: Music -> Music
clr_acc m =
let rl = [rAcc,cAcc]
in case m of
Note x d a -> Note x d (a \\ rl)
Chord xs d a -> Chord (map clr_acc xs) d a
_ -> error ("clr_acc at non-note/chord: " ++ ly_music_elem m)
octpc_to_note :: (Octave, PitchClass) -> Music
octpc_to_note x = Note (octpc_to_pitch x) Nothing []
r :: Duration -> Music
r x = Rest x []
r' :: TimeSignature -> Music
r' x = MMRest 1 x []
empty_measure :: Integer -> Integer -> Music
empty_measure n d = mconcat [MMRest 1 (n,d) [], l]
null_measure :: Integer -> Integer -> Music
null_measure n d =
let x = Duration d 0 1
in mconcat (map Skip (genericReplicate n x) ++ [l])
measure_rest :: Integer -> Integer -> Music
measure_rest n d = mconcat [time_signature (n,d), empty_measure n d]
measure_null :: Integer -> Integer -> Music
measure_null n d = mconcat [time_signature (n,d), null_measure n d]
type M_Annotation = Music
data Measure = Measure [M_Annotation] [Music]
m_annotate :: M_Annotation -> Measure -> Measure
m_annotate a (Measure as xs) = Measure (as++[a]) xs
m_annotate' :: [M_Annotation] -> Measure -> Measure
m_annotate' as' (Measure as xs) = Measure (as++as') xs
m_annotate_first' :: [M_Annotation] -> [Measure] -> [Measure]
m_annotate_first' as xs =
case xs of
(x:xs') -> m_annotate' as x : xs'
[] -> error "m_annotate_first'"
m_annotate_last' :: [M_Annotation] -> [Measure] -> [Measure]
m_annotate_last' as xs =
case xs of
[] -> []
[x] -> [m_annotate' as x]
(x:xs') -> x : m_annotate_last' as xs'
m_elements :: Measure -> [Music]
m_elements (Measure as xs) = as ++ xs
mm_elements :: [Measure] -> [Music]
mm_elements = concat . map m_elements
edit_dur :: (Duration -> Duration) -> Music -> Music
edit_dur fn x =
case x of
Note _ Nothing _ -> x
Note n (Just d) a -> Note n (Just (fn d)) a
Chord n d a -> Chord n (fn d) a
Rest d a -> Rest (fn d) a
Skip d -> Skip (fn d)
_ -> x
tuplet :: Tuplet_T -> [Music] -> Music
tuplet (d,n) =
let fn x = x { multiplier = n%d }
in Tuplet Normal_Tuplet (n,d) . mconcat . map (edit_dur fn)
tuplet_above,tuplet_below :: Tuplet_T -> [Music] -> Music
tuplet_above n xs = mconcat [tuplet_up, tuplet n xs, tuplet_neutral]
tuplet_below n xs = mconcat [tuplet_down, tuplet n xs, tuplet_neutral]
scale_durations :: Tuplet_T -> [Music] -> Music
scale_durations (n,d) =
let fn x = x { multiplier = d%n }
in Tuplet Scale_Durations (n,d) . mconcat . map (edit_dur fn)
time_signature :: TimeSignature -> Music
time_signature = Time
with_time_signature :: TimeSignature -> [Music] -> Music
with_time_signature ts xs = mconcat (time_signature ts : xs)
ts_whole_note :: TimeSignature -> [Duration]
ts_whole_note t =
case t of
(1,2) -> [half_note]
(2,16) -> [eighth_note]
(2,8) -> [quarter_note]
(2,4) -> [half_note]
(2,2) -> [whole_note]
(3,16) -> [dotted_eighth_note]
(3,8) -> [dotted_quarter_note]
(3,4) -> [dotted_half_note]
(3,2) -> [dotted_whole_note]
(4,16) -> [quarter_note]
(4,8) -> [half_note]
(4,4) -> [whole_note]
(4,2) -> [breve]
(5,16) -> [quarter_note,sixteenth_note]
(5,8) -> [half_note,eighth_note]
(5,4) -> [whole_note,quarter_note]
(6,2) -> [dotted_breve]
_ -> error ("ts_whole_note: " ++ show t)
ts_use_fractions :: Music
ts_use_fractions =
let x = "\\override Staff.TimeSignature #'style = #'()"
in Command (User x)
ts_set_fraction :: Integer -> Integer -> Music
ts_set_fraction n d =
let x = "#'(" ++ show n ++ " . " ++ show d ++ ")"
y = "\\set Staff.timeSignatureFraction = " ++ x
in Command (User y)
numeric_time_signature :: Music
numeric_time_signature = Command (User "\\numericTimeSignature")
ts_parentheses :: Music
ts_parentheses =
let x = "\\override Staff.TimeSignature #'stencil = #(lambda (grob) (bracketify-stencil (ly:time-signature::print grob) Y 0.1 0.2 0.1))"
in Command (User x)
key :: Music -> Mode_T -> Music
key (Note (Pitch n a _) _ _) md = Key n (Just a) md
key _ _ = error "key"
std_repeat :: Integer -> [Music] -> Music
std_repeat n = Repeat n . mconcat
allows_annotations :: Music -> Bool
allows_annotations m =
is_note m ||
is_chord m ||
is_rest m ||
is_mm_rest m
add_annotation :: Annotation -> Music -> Maybe Music
add_annotation a m =
case m of
Note n d as -> Just (Note n d (as ++ [a]))
Chord n d as -> Just (Chord n d (as ++ [a]))
Rest d as -> Just (Rest d (as ++ [a]))
MMRest i j as -> Just (MMRest i j (as ++ [a]))
_ -> Nothing
add_annotation_err :: Annotation -> Music -> Music
add_annotation_err a m =
case add_annotation a m of
Just m' -> m'
Nothing -> error ("add_annotation failed: " ++ show (a,ly_music_elem m))
(&) :: Music -> Annotation -> Music
m & a = add_annotation_err a m
(&#) :: Pitch -> Annotation -> Music
x &# y = Note x Nothing [y]
perhaps_annotate :: Annotation -> Music -> Music
perhaps_annotate a m = maybe m id (add_annotation a m)
bracket_annotation_fn :: (Annotation -> Music -> Music) ->
(Annotation,Annotation) -> [Music] -> [Music]
bracket_annotation_fn fn (begin, end) xs =
let x0 = head xs
xn = last xs
xs' = drop 1 (reverse (drop 1 (reverse xs)))
xs_e = show (map ly_music_elem xs)
in if length xs >= 2
then [fn begin x0] ++ xs' ++ [fn end xn]
else error ("bracket_annotation failed: " ++ xs_e)
bracket_annotation :: (Annotation,Annotation) -> [Music] -> [Music]
bracket_annotation = bracket_annotation_fn add_annotation_err
bracket_annotation' :: (Annotation,Annotation) -> [Music] -> [Music]
bracket_annotation' a x =
case x of
(_:_:_) -> bracket_annotation_fn perhaps_annotate a x
_ -> x
beam' :: [Music] -> [Music]
beam' = bracket_annotation (begin_beam, end_beam)
beam :: [Music] -> Music
beam = mconcat . beam'
slur' :: [Music] -> [Music]
slur' = bracket_annotation (begin_slur, end_slur)
slur :: [Music] -> Music
slur = mconcat . slur'
phrasing_slur' :: [Music] -> [Music]
phrasing_slur' =
let a = (begin_phrasing_slur, end_phrasing_slur)
in bracket_annotation a
phrasing_slur :: [Music] -> Music
phrasing_slur = mconcat . phrasing_slur'
text_above,text_below :: String -> Annotation
text_above x = CompositeAnnotation [Above, Text x]
text_below x = CompositeAnnotation [Below, Text x]
arco,pizz :: Annotation
arco = text_above "arco"
pizz = text_above "pizz."
stem_tremolo :: Integer -> Annotation
stem_tremolo = Articulation . StemTremolo
place_above,place_below :: Annotation -> Annotation
place_above x = CompositeAnnotation [Above, x]
place_below x = CompositeAnnotation [Below, x]
note_annotate :: Annotation -> Music -> Music
note_annotate a m =
case m of
Note n d xs -> Note n d (xs++[a])
_ -> m
initial_note_chord_annotate :: Annotation -> [Music] -> [Music]
initial_note_chord_annotate a m =
case m of
[] -> []
(x:xs) -> if is_note x || is_chord x
then x & a : xs
else x : initial_note_chord_annotate a xs
allows_indirect_annotation :: Music -> Bool
allows_indirect_annotation m =
case m of
Grace x -> allows_indirect_annotation x
AfterGrace x _ -> allows_indirect_annotation x
Tuplet _ _ x -> allows_indirect_annotation x
Join (x:_) -> allows_indirect_annotation x
_ -> allows_annotations m
indirect_annotation :: Annotation -> Music -> Music
indirect_annotation a m =
case m of
Grace x -> Grace (indirect_annotation a x)
AfterGrace x1 x2 -> AfterGrace (indirect_annotation a x1) x2
Tuplet tm tt x -> Tuplet tm tt (indirect_annotation a x)
Join (x:xs) -> Join (indirect_annotation a x : xs)
_ -> m & a
attach_indirect_annotation :: Annotation -> [Music] -> [Music]
attach_indirect_annotation _ [] = error "attach_indirect_annotation"
attach_indirect_annotation a (x:xs) =
if allows_indirect_annotation x
then indirect_annotation a x : xs
else x : attach_indirect_annotation a xs
note_edit_octave :: (Integer -> Integer) -> Music -> Music
note_edit_octave fn m =
case m of
Note (Pitch n a o) d xs -> Note (Pitch n a (fn o)) d xs
_ -> m
note_shift_octave :: Integer -> Music -> Music
note_shift_octave i = note_edit_octave (+ i)
p_or, p_and :: (t -> Bool) -> (t -> Bool) -> t -> Bool
p_or p1 p2 = \x -> p1 x || p2 x
p_and p1 p2 = \x -> p1 x && p2 x
span_r :: (a -> Bool) -> [a] -> ([a], [a], [a])
span_r fn xs =
let (o1,o2) = span fn xs
(o3,o4) = span fn (reverse o2)
in (o1,reverse o4, reverse o3)
perhaps_beam :: [Music] -> [Music]
perhaps_beam xs =
case xs of
[] -> []
[x] -> [x]
_ -> beam' xs
beam_notes :: [Music] -> Music
beam_notes xs =
let (x1,x2,x3) = span_r (not . p_or is_note is_chord) xs
in mconcat (x1 ++ perhaps_beam x2 ++ x3)
set_subdivide_beams :: Integer -> Music
set_subdivide_beams i =
let x0 = "\\set subdivideBeams = ##t"
x1 = "\\set baseMoment = #(ly:make-moment 1 " ++ show i ++ ")"
in mconcat [Command (User x0), Command (User x1)]
(##) :: Pitch -> Duration -> Music
x ## d = Note x (Just d) []
(#) :: Music -> Duration -> Music
x # d =
case x of
Note n _ a -> Note n (Just d) a
Chord n _ a -> Chord n d a
_ -> error ("##: " ++ show x)
chd_p :: [Pitch] -> Duration -> Music
chd_p [] _ = error "chd_p: null elements"
chd_p xs d = Chord (map (\x -> Note x Nothing []) xs) d []
chd :: [Music] -> Duration -> Music
chd [] _ = error "chd: null elements"
chd xs d =
let fn x =
let err msg = error (msg ++ ": " ++ show x)
in case x of
Note _ (Just _) _ -> err "chd: note has duration"
Note _ Nothing _ -> x
_ -> err "chd: non note element"
in Chord (map fn xs) d []
bar_number_check :: Integer -> Music
bar_number_check = Command . BarNumberCheck
change :: String -> Music
change x = Command (Change x)
partial :: Duration -> Music
partial = Command . Partial
hairpin_circled_tip :: Bool -> Music
hairpin_circled_tip x =
let c = if x
then "\\override Hairpin #'circled-tip = ##t"
else "\\revert Hairpin #'circled-tip"
in Command (User c)
hairpin_to_barline :: Bool -> Music
hairpin_to_barline x =
let c = if x
then "\\revert Hairpin #'to-barline"
else "\\override Hairpin #'to-barline = ##f"
in Command (User c)
name_to_id :: Staff_Name -> Staff_ID
name_to_id (x,_) =
case x of
"" -> "no_id"
_ -> "id_" ++ x
staff :: Staff_Name -> [Music] -> Staff
staff nm =
let st = Staff_Settings Normal_Staff (name_to_id nm) 0
in Staff st nm . Part Nothing
rhythmic_staff :: Staff_Name -> [Music] -> Staff
rhythmic_staff nm =
let st = Staff_Settings Rhythmic_Staff (name_to_id nm) 0
in Staff st nm . Part Nothing
text_staff :: Staff_Name -> String -> [Music] -> Staff
text_staff nm txt =
let st = Staff_Settings Normal_Staff (name_to_id nm) 0
in Staff st nm . Part (Just txt)
piano_staff :: Staff_Name -> [[Music]] -> Staff
piano_staff nm [rh,lh] =
let st x = Staff_Settings Normal_Staff x 0
in Staff_Set
PianoStaff
nm
[Staff (st "rh") ("","") (Part Nothing rh)
,Staff (st "lh") ("","") (Part Nothing lh)]
piano_staff nm xs =
Staff_Set PianoStaff nm (map (staff ("","")) xs)
grand_staff :: Staff_Name -> [[Music]] -> Staff
grand_staff nm = Staff_Set GrandStaff nm . map (staff ("",""))
staff_group :: Staff_Name -> [[Music]] -> Staff
staff_group nm = Staff_Set StaffGroup nm . map (staff ("",""))
rhythmic_grand_staff :: Staff_Name -> [[Music]] -> Staff
rhythmic_grand_staff nm = Staff_Set GrandStaff nm . map (rhythmic_staff ("",""))
grand_staff' :: Staff_Name -> [Staff_Name] -> [[Music]] -> Staff
grand_staff' nm xs ys = Staff_Set GrandStaff nm (zipWith staff xs ys)
staff_group' :: Staff_Name -> [Staff_Name] -> [[Music]] -> Staff
staff_group' nm xs ys = Staff_Set StaffGroup nm (zipWith staff xs ys)
two_part_staff :: Staff_Name -> ([Music], [Music]) -> Staff
two_part_staff nm (p0, p1) =
let st = Staff_Settings Normal_Staff (name_to_id nm) 0
in Staff st nm (MultipleParts [voice_one:p0
,voice_two:p1])
instr_name :: Staff_Name -> Staff -> Staff
instr_name nm pt =
case pt of
Staff st _ x -> Staff st nm x
Staff_Set ty _ xs -> Staff_Set ty nm xs
resize_staff :: Int -> Staff -> Staff
resize_staff n st =
case st of
Staff (Staff_Settings ty i sc) nm pt ->
Staff (Staff_Settings ty i (sc + n)) nm pt
Staff_Set ty nm xs ->
Staff_Set ty nm (map (resize_staff n) xs)
score :: [Staff] -> Score
score = Score default_score_settings
tempo :: Duration -> Integer -> Music
tempo = Tempo
after_grace :: Music -> Music -> Music
after_grace = AfterGrace
grace :: Music -> Music
grace = Grace
tremolo :: (Music, Music) -> Integer -> Music
tremolo = Tremolo
polyphony :: Music -> Music -> Music
polyphony = Polyphony
polyphony' :: [Music] -> [Music] -> Music
polyphony' x y = polyphony (mconcat x) (mconcat y)
cross_noteheads :: Music
cross_noteheads =
Command (User "\\override NoteHead #'style = #'cross")
revert_noteheads :: Music
revert_noteheads =
Command (User "\\revert NoteHead #'style")
join_rests :: [Music] -> [Music]
join_rests =
let fn recur xs =
case xs of
[] -> []
Rest d a : Rest d' a' : ys ->
case sum_dur d d' of
Nothing -> let zs = Rest d a : join_rests (Rest d' a' : ys)
in if recur then fn False zs else zs
Just d'' -> join_rests (Rest d'' (a ++ a') : ys)
y:ys -> y : join_rests ys
in fn True