module Music.LilyPond.Light.Notation where
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Ratio
import Music.LilyPond.Light.Constant
import Music.LilyPond.Light.Measure
import Music.LilyPond.Light.Model
import Music.LilyPond.Light.Output.LilyPond
import Music.Theory.Duration
import Music.Theory.Duration.Annotation
import Music.Theory.Key
import Music.Theory.Pitch
import Music.Theory.Pitch.Spelling
import Music.Theory.Time_Signature
import Text.Printf
is_music_c :: Music_C -> Music -> Bool
is_music_c c = (==) c . music_c
is_note :: Music -> Bool
is_note = is_music_c Note_C
is_chord :: Music -> Bool
is_chord = is_music_c Chord_C
is_rest :: Music -> Bool
is_rest = is_music_c Rest_C
is_skip :: Music -> Bool
is_skip = is_music_c Skip_C
is_mm_rest :: Music -> Bool
is_mm_rest = is_music_c MMRest_C
is_grace :: Music -> Bool
is_grace = is_music_c Grace_C
is_after_grace :: Music -> Bool
is_after_grace = is_music_c AfterGrace_C
is_grace_skip :: Music -> Bool
is_grace_skip m =
case m of
Grace (Skip _ _) -> True
_ -> False
is_clef :: Music -> Bool
is_clef = is_music_c Clef_C
is_time :: Music -> Bool
is_time = is_music_c Time_C
is_tempo :: Music -> Bool
is_tempo = is_music_c Tempo_C
is_command :: Music -> Bool
is_command = is_music_c Command_C
is_barlinecheck :: Music -> Bool
is_barlinecheck m =
case m of
Command BarlineCheck _ -> True
_ -> 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 = is_music_c Tuplet_C
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 pc_spell_ks x) Nothing []
rest :: Duration -> Music
rest x = Rest x []
mm_rest :: Time_Signature -> Music
mm_rest x = MMRest 1 x []
skip :: Duration -> Music
skip x = Skip x []
empty_measure :: Integer -> Integer -> Music
empty_measure n d = mconcat [MMRest 1 (n,d) [], bar_line_check]
null_measure :: Integer -> Integer -> Music
null_measure n d =
let x = Duration d 0 1
l = [bar_line_check]
in mconcat (map (\i -> Skip i []) (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]
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 a -> Skip (fn d) a
_ -> 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 :: Time_Signature -> Music
time_signature = Time
with_time_signature :: Time_Signature -> [Music] -> Music
with_time_signature ts xs = mconcat (time_signature ts : xs)
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) []
ts_stencil :: Bool -> Music
ts_stencil x =
let c = "\\override Staff.TimeSignature #'stencil = " ++ ly_bool x
in Command (User c) []
ts_transparent :: Bool -> Music
ts_transparent x =
let c = "\\override Staff.TimeSignature #'transparent = " ++ ly_bool x
in Command (User c) []
ts_all_invisible :: Music
ts_all_invisible =
let c = "\\override Staff.TimeSignature #'break-visibility = #all-invisible"
in Command (User c) []
key :: Music -> Mode_T -> Music
key m md =
case m of
(Note (Pitch n a _) _ _) -> Key n (Just a) md
_ -> error "key"
std_repeat :: Integer -> [Music] -> Music
std_repeat n = Repeat n . mconcat
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)
tie_r_ann :: [D_Annotation] -> [Annotation]
tie_r_ann a = if any (== Tie_Right) a then [Begin_Tie] else []
da_rest :: Duration_A -> Music
da_rest (d,_) = Rest d []
(##@) :: Pitch -> Duration_A -> Music
x ##@ (d,a) = Note x (Just d) (tie_r_ann a)
(##) :: Pitch -> Duration -> Music
x ## d = x ##@ (d,[])
(#@) :: Music -> Duration_A -> Music
x #@ (d,a) =
case x of
Note n _ a' -> Note n (Just d) (tie_r_ann a ++ a')
Chord n _ a' -> Chord n d (tie_r_ann a ++ a')
_ -> error ("###: " ++ show x)
(#) :: Music -> Duration -> Music
x # d = x #@ (d,[])
chd_p :: [Pitch] -> Duration -> Music
chd_p xs d =
case xs of
[] -> error "chd_p: null elements"
_ -> Chord (map (\x -> Note x Nothing []) xs) d []
chd :: [Music] -> Duration -> Music
chd xs d =
case xs of
[] -> error "chd: null elements"
_ -> 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 n = Command (BarNumberCheck n) []
bar_numbering :: Bool -> Music
bar_numbering x =
let r = if x then "#(#t #t #t)" else "#(#f #f #f)"
s = "\\override Score.BarNumber #'break-visibility = #'" ++ r
in Command (User s) []
change :: String -> Music
change x = Command (Change x) []
partial :: Duration -> Music
partial d = Command (Partial d) []
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) []
hairpin_minimum_length :: Maybe Int -> Music
hairpin_minimum_length x =
let c = case x of
Nothing -> "\\revert Hairpin #'minimum-length"
Just n -> "\\override Hairpin #'minimum-length = #" ++ show n
in Command (User c) []
set_8va_notation :: Music
set_8va_notation = Command (User "\\set Staff.ottavation = #\"8\"") []
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 xs =
case xs of
[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)]
_ -> 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
polyphony :: Music -> Music -> Music
polyphony = Polyphony
polyphony' :: [Music] -> [Music] -> Music
polyphony' x y = polyphony (mconcat x) (mconcat y)
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
type DA_F x = (Duration_A,x) -> Music
da_to_music :: DA_F t -> [(Duration_A,t)] -> [Music]
da_to_music fn x =
let g = da_group_tuplets_nn (map fst x)
g' = nn_reshape (,) g (map snd x)
tr el = case el of
Left i -> fn i
Right y -> let (y0,_):_ = y
(n,d,_) = fromJust (da_begin_tuplet y0)
in Tuplet Normal_Tuplet (d,n) (Join (map fn y))
in map tr g'
da_to_measures :: DA_F x -> Maybe [Time_Signature] -> [[(Duration_A,x)]] -> [Measure]
da_to_measures fn m_t x =
let m = map (da_to_music fn) x
jn i = Measure [i]
in case m_t of
Just t -> zipWith jn (map Time t) m
Nothing -> map (Measure []) m
mk_fragment :: (Double, Double) -> [Music] -> Fragment
mk_fragment (w,h) m =
let pr = mk_fragment_paper w h
in Fragment default_version pr (Join m)
mk_fragment_mm :: (Double, Double) -> [Measure] -> Fragment
mk_fragment_mm d = mk_fragment d . mm_elements
stem_transparent :: Bool -> Music
stem_transparent x =
let c = "\\override Stem #'transparent = " ++ ly_bool x
in Command (User c) []
text_length_on :: Music
text_length_on = Command (User "\\textLengthOn") []
text_outside_staff_priority :: Maybe Double -> Music
text_outside_staff_priority x =
let pr = case x of
Nothing -> ly_bool False
Just n -> '#' : show n
s = "\\override TextScript #'outside-staff-priority = " ++ pr
in Command (User s) []
text_extra_spacing_width :: (Double,Double) -> Music
text_extra_spacing_width (i,j) =
let t = "\\override TextScript #'extra-spacing-width = #'(%f . %f)"
s = printf t i j
in Command (User s) []
mm_delete_redundant_ts :: [Measure] -> [Measure]
mm_delete_redundant_ts =
let f st m = let Measure a n = m
ts = find is_time a
in case (st,ts) of
(Just p,Just q) -> if p == q
then (st,Measure (delete q a) n)
else (ts,m)
(_,Just _) -> (ts,m)
_ -> (st,m)
in snd . mapAccumL f Nothing