module Music.LilyPond.Light.Notation where
import Data.List
import qualified Data.List.Split as Split
import Data.Maybe
import Data.Ratio
import Text.Printf
import qualified Music.Theory.Duration as T
import qualified Music.Theory.Duration.Annotation as T
import qualified Music.Theory.Duration.RQ as T
import qualified Music.Theory.Duration.Sequence.Notate as T
import qualified Music.Theory.Key as T
import qualified Music.Theory.Pitch as T
import qualified Music.Theory.Pitch.Spelling.Table as T
import qualified Music.Theory.Time_Signature as T
import Music.LilyPond.Light.Constant
import Music.LilyPond.Light.Measure
import Music.LilyPond.Light.Model
import Music.LilyPond.Light.Output.LilyPond
import Music.LilyPond.Light.Paper
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
music_immediate_duration :: Music -> Maybe T.Duration
music_immediate_duration m =
case m of
Note _ d _ -> d
Chord _ d _ -> Just d
Rest _ d _ -> Just d
_ -> Nothing
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 :: (T.Octave, T.PitchClass) -> Music
octpc_to_note x = Note (T.octpc_to_pitch T.pc_spell_ks x) Nothing []
rest :: T.Duration -> Music
rest x = Rest Normal_Rest x []
spacer_rest :: T.Duration -> Music
spacer_rest x = Rest Spacer_Rest x []
mm_rest :: T.Time_Signature -> Music
mm_rest x = MMRest 1 x []
skip :: T.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 = T.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 :: (T.Duration -> T.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 ty d a -> Rest ty (fn d) a
Skip d a -> Skip (fn d) a
_ -> x
tuplet :: Tuplet_T -> [Music] -> Music
tuplet (d,n) =
let fn x = x { T.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 { T.multiplier = d%n }
in Tuplet Scale_Durations (n,d) . mconcat . map (edit_dur fn)
time_signature :: T.Time_Signature -> Music
time_signature = Time
with_time_signature :: T.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) []
mm_stencil :: Bool -> Music
mm_stencil x =
let c = "\\override Score.MetronomeMark #'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 :: T.Key -> Music
key (n,a,md) = Key n (Just a) md
std_repeat :: Integer -> [Music] -> Music
std_repeat n = Repeat n . mconcat
note_edit_octave :: (T.Octave -> T.Octave) -> Music -> Music
note_edit_octave fn m =
case m of
Note (T.Pitch n a o) d xs -> Note (T.Pitch n a (fn o)) d xs
_ -> m
note_shift_octave :: T.Octave -> Music -> Music
note_shift_octave i = note_edit_octave (+ i)
tie_r_ann :: [T.D_Annotation] -> [Annotation]
tie_r_ann a = if any (== T.Tie_Right) a then [Begin_Tie] else []
clear_l_ann :: [T.D_Annotation] -> [Annotation] -> [Annotation]
clear_l_ann d_a m_a = if any (== T.Tie_Left) d_a then [] else m_a
da_rest :: T.Duration_A -> Music
da_rest (d,_) = Rest Normal_Rest d []
(##@) :: T.Pitch -> T.Duration_A -> Music
x ##@ (d,a) = Note x (Just d) (tie_r_ann a)
(##) :: T.Pitch -> T.Duration -> Music
x ## d = x ##@ (d,[])
(#@) :: Music -> T.Duration_A -> Music
x #@ (d,a) =
case x of
Note n _ a' -> Note n (Just d) (tie_r_ann a ++ clear_l_ann a a')
Chord n _ a' -> Chord n d (tie_r_ann a ++ clear_l_ann a a')
Rest ty _ a' -> Rest ty d (clear_l_ann a a')
_ -> error ("#@: " ++ show x)
(#) :: Music -> T.Duration -> Music
x # d =
case x of
Rest ty _ a -> Rest ty d a
_ -> x #@ (d,[])
chd_p_ann :: [T.Pitch] -> [[Annotation]] -> T.Duration -> Music
chd_p_ann xs an d =
let f x a = Note x Nothing a
in case xs of
[] -> error "chd_p_ann: null elements"
_ -> Chord (zipWith f xs an) d []
chd_p :: [T.Pitch] -> T.Duration -> Music
chd_p xs = chd_p_ann xs (repeat [])
chd :: [Music] -> T.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 :: T.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_line_count :: Int -> Music
staff_line_count n =
let x = "\\override Staff.StaffSymbol.line-count = #" ++ show n
in Command (User x) []
staff' :: Staff_T -> Staff_Name -> [Music] -> Staff
staff' ty nm =
let st = Staff_Settings ty (name_to_id nm) 0
in Staff st nm . Part Nothing Nothing
staff :: Staff_Name -> [Music] -> Staff
staff = staff' Normal_Staff
rhythmic_staff :: Staff_Name -> [Music] -> Staff
rhythmic_staff = staff' Rhythmic_Staff
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 Nothing (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 Nothing rh)
,Staff (st "lh") ("","") (Part Nothing 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 ("",""))
staff_set :: (Staff_Set_T,Staff_T) -> Staff_Name -> [Staff_Name] -> [[Music]] -> Staff
staff_set (set_ty,stf_ty) nm xs ys = Staff_Set set_ty nm (zipWith (staff' stf_ty) xs ys)
grand_staff' :: Staff_Name -> [Staff_Name] -> [[Music]] -> Staff
grand_staff' = staff_set (GrandStaff,Normal_Staff)
staff_group' :: Staff_Name -> [Staff_Name] -> [[Music]] -> Staff
staff_group' = staff_set (StaffGroup,Normal_Staff)
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 ty d a : Rest ty' d' a' : ys ->
case T.sum_dur d d' of
Nothing -> let zs = Rest ty d a : join_rests (Rest ty' d' a' : ys)
in if recur then fn False zs else zs
Just d'' -> join_rests (Rest ty' d'' (a ++ a') : ys)
y:ys -> y : join_rests ys
in fn True
type DA_F x = (T.Duration_A,x) -> Music
da_to_music :: DA_F t -> [(T.Duration_A,t)] -> [Music]
da_to_music fn x =
let g = T.da_group_tuplets_nn (map fst x)
g' = T.nn_reshape (,) g (map snd x)
tr el = case el of
Left i -> fn i
Right y -> let (y0,_):_ = y
(n,d,_) = fromJust (T.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 [T.Time_Signature] -> [[(T.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
rq_to_measures :: (Show x) => Int -> DA_F x -> [T.Simplify_T] -> [T.Time_Signature] -> Maybe [[T.RQ]] -> [T.RQ] -> [x] -> [Measure]
rq_to_measures limit fn r ts rqp rq x =
let da = T.notate_mm_ascribe_err limit r ts rqp rq x
in da_to_measures fn (Just ts) da
mk_fragment :: (Double, Double) -> [[Music]] -> Fragment
mk_fragment (w,h) m =
let pr = mk_fragment_paper w h
in Fragment default_version pr (grand_staff ("","") m)
mk_fragment_mm :: (Double, Double) -> [[Measure]] -> Fragment
mk_fragment_mm d = mk_fragment d . map mm_elements
stem_transparent :: Bool -> Music
stem_transparent x =
let c = "\\override Stem #'transparent = " ++ ly_bool x
in Command (User c) []
text_length_on,text_length_off :: Music
text_length_on = Command (User "\\textLengthOn") []
text_length_off = Command (User "\\textLengthOff") []
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
mm_measures_per_system :: [Int] -> [Measure] -> [Measure]
mm_measures_per_system n mm =
let f (m0:l) = m_annotate_pre system_break m0 : l
f [] = error "mm_measures_per_system"
in case Split.splitPlaces n mm of
g0:l -> concat (g0 : map f l)
_ -> mm
mm_measures_per_system_eq :: Int -> [Measure] -> [Measure]
mm_measures_per_system_eq n =
let f k m = if k /= 0 && k `mod` n == 0
then m_annotate_pre system_break m
else m
in zipWith f [0..]
default_rehearsal_mark :: Music
default_rehearsal_mark = Command (Rehearsal_Mark Nothing) []