diff --git a/Music/LilyPond/Light.hs b/Music/LilyPond/Light.hs new file mode 100644 --- /dev/null +++ b/Music/LilyPond/Light.hs @@ -0,0 +1,638 @@ +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 + +-- * Music category predicates + +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 + +-- | These are required to avoid issues in lilypond (see manual) +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 + +-- * Pitch + +-- | Add reminder accidental to note. +r_acc :: Music -> Music +r_acc x = x &rAcc + +-- | Add cautionary accidental to note. +c_acc :: Music -> Music +c_acc x = x &cAcc + +-- | Remove any reminder or cautionary accidentals at note or chord. +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 [] + +-- * Rests + +-- | Construct rests. +r :: Duration -> Music +r x = Rest x [] + +r' :: TimeSignature -> Music +r' x = MMRest 1 x [] + +-- | Create an empty measure for the specified time signature. +empty_measure :: Integer -> Integer -> Music +empty_measure n d = mconcat [MMRest 1 (n,d) [], l] + +-- | Like empty_measure, but with an invisible rest. +null_measure :: Integer -> Integer -> Music +null_measure n d = + let x = Duration d 0 1 + in mconcat (map Skip (genericReplicate n x) ++ [l]) + +-- | Like empty_measure but write time signature. +measure_rest :: Integer -> Integer -> Music +measure_rest n d = mconcat [time_signature (n,d), empty_measure n d] + +-- | Like measure_rest but write time signature. +measure_null :: Integer -> Integer -> Music +measure_null n d = mconcat [time_signature (n,d), null_measure n d] + +-- * Measures + +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 + +-- * Tuplets + +-- | Apply fn to the duration of x, if it has a duration. +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 + +-- | Temporal scaling of music (tuplets). +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 variants that set location, and then restore to neutral. +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] + +-- | Like tuplet but does not annotate music, see also +-- 'ts_set_fraction'. +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 signatures + +-- | Construct time signature. +time_signature :: TimeSignature -> Music +time_signature = Time + +-- | Allow proper auto-indenting of multiple measures with the same +-- time signature. +with_time_signature :: TimeSignature -> [Music] -> Music +with_time_signature ts xs = mconcat (time_signature ts : xs) + +{- +-- | Make a duration to fill a whole measure. +ts_dur :: TimeSignature -> Duration +ts_dur (n,d) = Duration d 0 (fromIntegral n) +-} + +-- | Tied, non-multiplied durations to fill a whole measure. +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) + +-- | Command to request that 4/4 and 2/2 etc. are typeset as fractions. +ts_use_fractions :: Music +ts_use_fractions = + let x = "\\override Staff.TimeSignature #'style = #'()" + in Command (User x) + +-- | Set the printed time-signature fraction. +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 signatures + +-- | Construct key signature. +key :: Music -> Mode_T -> Music +key (Note (Pitch n a _) _ _) md = Key n (Just a) md +key _ _ = error "key" + +-- * Repetition + +-- | Construct standard (two times) repeat. +std_repeat :: Integer -> [Music] -> Music +std_repeat n = Repeat n . mconcat + +-- * Annotations + +-- | Can a music element be annotated? +allows_annotations :: Music -> Bool +allows_annotations m = + is_note m || + is_chord m || + is_rest m || + is_mm_rest m + +-- | Add an annotation to music element. +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 an annotation to music element or error. +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)) + +-- | Add an annotation to music element, or error. +(&) :: Music -> Annotation -> Music +m & a = add_annotation_err a m + +-- | Add an annotation to a pitch. +(&#) :: Pitch -> Annotation -> Music +x &# y = Note x Nothing [y] + +-- | Add an annotation to music element. +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) + +-- | Manual beaming. +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] + +-- | Add an annotation to a note element, else identity. +note_annotate :: Annotation -> Music -> Music +note_annotate a m = + case m of + Note n d xs -> Note n d (xs++[a]) + _ -> m + +-- | Annotate the first note/chord element. +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 + +-- * Indirect annotations + +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 + +-- * Octave + +-- | Shift the octave of a note element, else identity. +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 + +-- | Shift the octave of a note element, else identity. +note_shift_octave :: Integer -> Music -> Music +note_shift_octave i = note_edit_octave (+ i) + +-- * Beaming + +-- | Predicate combinators. +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 (< 0) [-1,-2,1,2,3,-3,-4] => ([-1,-2],[1,2,3],[-3,-4]) +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) + +-- | Beam if at least two elements. +perhaps_beam :: [Music] -> [Music] +perhaps_beam xs = + case xs of + [] -> [] + [x] -> [x] + _ -> beam' xs + +-- | Beam interior notes/chords (ie. skip exterior +-- non-note/non-chords). +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) + +-- 2.13.29 (Issue #1083) +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)] + +-- * Duration + +-- | Add duration to pitch to make a note. +(##) :: Pitch -> Duration -> Music +x ## d = Note x (Just d) [] + +-- | Add duration to pitch to make a note. +(#) :: 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) + +-- * Chords + +-- | Construct chord. +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 [] + +-- * Commands + +-- | Construct bar number check. +bar_number_check :: Integer -> Music +bar_number_check = Command . BarNumberCheck + +-- | Change staff. +change :: String -> Music +change x = Command (Change x) + +-- | Indicate initial partial measure. +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) + +-- * Staff and Parts + +name_to_id :: Staff_Name -> Staff_ID +name_to_id (x,_) = + case x of + "" -> "no_id" + _ -> "id_" ++ x + +-- | Construct staff. +staff :: Staff_Name -> [Music] -> Staff +staff nm = + let st = Staff_Settings Normal_Staff (name_to_id nm) 0 + in Staff st nm . Part Nothing + +-- | Construct rhythmic staff. +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 + +-- | Construct staff with text underlay. +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) + +-- | Construct piano staff. For two staff piano music the staffs have +-- identifiers rh and lh. +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 ("","")) + +-- | Variant with names for each 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 + +-- * Aliases + +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 + +-- | Interior polyphony. For two part music on one staff see +-- two_part_staff. +polyphony :: Music -> Music -> Music +polyphony = Polyphony + +polyphony' :: [Music] -> [Music] -> Music +polyphony' x y = polyphony (mconcat x) (mconcat y) + +-- * Noteheads + +-- | Request cross note-heads. +cross_noteheads :: Music +cross_noteheads = + Command (User "\\override NoteHead #'style = #'cross") + +-- | Revert to standard note-heads. +revert_noteheads :: Music +revert_noteheads = + Command (User "\\revert NoteHead #'style") + +-- * Rests + +-- | Joins directly adjacent rest elements. +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 diff --git a/Music/LilyPond/Light/Analysis.hs b/Music/LilyPond/Light/Analysis.hs new file mode 100644 --- /dev/null +++ b/Music/LilyPond/Light/Analysis.hs @@ -0,0 +1,623 @@ +module Music.LilyPond.Light.Analysis where + +import Data.Function +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Ratio +import qualified Music.LilyPond.Light as L +import Music.LilyPond.Light.Model +import Music.Theory.Duration +import Music.Theory.Pitch +import qualified Music.Theory.Spelling as T + +type R = Double + +-- * Basic traversal + +-- | Apply a function to all elements and collect results in a list. +traverse :: (Music -> a) -> Music -> [a] +traverse fn = + let fn' xs m = (fn m : xs, m) + in reverse . fst . transform_st fn' [] + +-- | Collect all elements of a given type. +collect_entries :: (Music -> Bool) -> Music -> [Music] +collect_entries fn = filter fn . traverse id + +-- * Basic statistical analysis + +count_entries :: (Music -> Bool) -> Music -> Integer +count_entries fn = genericLength . filter id . traverse fn + +count_notes :: Music -> Integer +count_notes = count_entries L.is_note + +count_chords :: Music -> Integer +count_chords = count_entries L.is_chord + +count_ts :: Music -> Integer +count_ts = count_entries L.is_time + +-- * Basic pitch analysis + +-- | Does music element contain one or more pitches? +has_pitch :: Music -> Bool +has_pitch x = L.is_note x || + L.is_chord x || + L.is_grace x || + L.is_after_grace x + +-- | Collect pitches from a note or chord or join of such. +collect_pitches_no_grace :: Music -> [Pitch] +collect_pitches_no_grace m = + case m of + (Note x _ _) -> [x] + (Chord xs _ _) -> concatMap collect_pitches xs + (Skip _) -> [] + (Join xs) -> concatMap collect_pitches xs + _ -> error ("collect_pitches_no_grace: " ++ L.ly_music_elem m) + +-- | Collect pitches from a note, chord, or grace note. +collect_pitches :: Music -> [Pitch] +collect_pitches m = + case m of + (Grace x) -> collect_pitches x + (AfterGrace x0 x1) -> collect_pitches x0 ++ collect_pitches x1 + _ -> collect_pitches_no_grace m + +-- | Collect note sequence, filters tied notes. +note_seq :: Music -> [Music] +note_seq = filter (not . L.is_tied) . collect_entries L.is_note + +-- * Frequency analysis utilites + +freq_anal_by :: (Ord a) => (a -> a -> Ordering) -> [a] -> [(Int,a)] +freq_anal_by c = + let fn xs = (length xs, head xs) + in reverse . sort . map fn . group . sortBy c + +freq_anal :: (Ord a) => [a] -> [(Int,a)] +freq_anal = freq_anal_by compare + +-- * Durations + +type TempoMarking = (Duration,Integer) + +-- | Apply `d' dots to the rational pulse count `n'. +apply_dots :: Rational -> Integer -> Rational +apply_dots n d = + let m = map (\x -> n * (1 / fromInteger (2 ^ x))) [1..d] + in n + sum m + +-- | Convert a duration to a pulse count in relation to the indicated +-- time signature. +dur_pulses :: TimeSignature -> Duration -> Rational +dur_pulses (_, b) (Duration dv dt ml) = + let n = b % dv + in apply_dots n dt * ml + +-- | The duration, in seconds, of a pulse at the indicated time +-- signaure and tempo marking. +pulse_duration :: TimeSignature -> TempoMarking -> R +pulse_duration t (x,i) = + let j = recip (dur_pulses t x) + s = 60 / fromIntegral i + in fromRational j * s + +-- | The duration, in seconds, of a measure at the indicated time +-- signaure and tempo marking. +measure_duration :: TimeSignature -> TempoMarking -> R +measure_duration (n,d) t = pulse_duration (n,d) t * fromIntegral n + +-- * Temporal map + +type TimeSignature_Map = [(Measure,TimeSignature)] +type TempoMarking_Map = [(Measure,TempoMarking)] +type Temporal_Map = (TimeSignature_Map,TempoMarking_Map) + +temporal_map :: [Music] -> Temporal_Map +temporal_map xs = + let ts_m = ts_map xs + tm_m = tempo_map xs + in (ts_m,tm_m) + +-- | Return duration (in seconds) and pulse counts for n measures. +mm_durations :: Temporal_Map -> Integer -> [(R,Integer)] +mm_durations (ts_m,tm_m) n = + let get = map_lookup + fn xs i = if i == n + then xs + else let t = get ts_m i + j = measure_duration t (get tm_m i) + in fn ((j,fst t):xs) (i+1) + in reverse (fn [] 0) + +integrate :: (Num a) => [a] -> [a] +integrate [] = [] +integrate (x:xs) = + let f p c = (p + c, p + c) + in x : snd (mapAccumL f x xs) + +-- | Return start time and duration (in seconds) and pulse counts for +-- i measures. +mm_start_times :: Temporal_Map -> Integer -> [(R,R,Integer)] +mm_start_times tm i = + let (x,y) = unzip (mm_durations tm i) + in zip3 (0 : integrate x) x y + +location_to_rt :: [(R,R,Integer)] -> Location -> R +location_to_rt mm l = + let (x,y,z) = mm `genericIndex` measure l + in x + ((fromRational (pulse l) / fromIntegral z) * y) + +locate_rt :: [Music] -> [(R,Music)] +locate_rt xs = + let l = locate' xs + m = temporal_map xs + t = mm_start_times m (lv_last_measure l + 1) + fn (i,x) = (location_to_rt t i,x) + in map fn l + +-- * Temporal annotations + +data Locate_Mode = LM_Normal + | LM_In_Tuplet + deriving (Show, Eq, Ord) + +type Measure = Integer +type Pulse = Rational +type Part_ID = Integer + +-- | Data type representing the location of a musical element. +data Location = Location { measure :: Measure + , pulse :: Pulse + , part :: Part_ID + , mode :: Locate_Mode } + deriving (Show, Eq, Ord) + +-- | Convert a location to normal form under given time signature. +location_nf :: TimeSignature -> Location -> Location +location_nf ts l = + let (Location b p v m) = l + (n, _) = ts + p' = numerator p `div` denominator p + in if p' >= n + then location_nf ts (Location (b + 1) (p - fromIntegral n) v m) + else l + +-- | Type to thread state through location calculations. +type Locate_ST = (TimeSignature, Location) + +-- | Update state part number. +st_set_part :: Locate_ST -> Part_ID -> Locate_ST +st_set_part st v = + let (ts, (Location b p _ m)) = st + in (ts, Location b p v m) + +-- | Update state part number. +st_set_mode :: Locate_ST -> Locate_Mode -> Locate_ST +st_set_mode st m = + let (ts, Location b p v _) = st + in (ts, Location b p v m) + +-- | Step location state by duration. +location_step :: Locate_ST -> Duration -> Locate_ST +location_step st d = + let (ts, l) = st + (Location b p v m) = l + p' = p + dur_pulses ts d + l' = location_nf ts (Location b p' v m) + in (ts, l') + +-- | Located music +type LM = (Location, Music) + +-- | Located value +type LV a = (Location, a) + +-- | State threading form of location calculations. +-- Currently, nested polyphonic parts generate duplicate IDs (?) +locate_st :: Locate_ST -> Music -> (Locate_ST, [LM]) +locate_st st m = + let (ts, l) = st + this = (l,m) + in case m of + Note _ (Just d) _ -> (location_step st d, [this]) + Note _ _ _ -> error "locate_st: note without duration" + Chord _ d _ -> (location_step st d, [this]) + Tremolo _ _ -> error "locate_st: Tremolo" + Rest d _ -> (location_step st d, [this]) + MMRest i (j,k) _ -> let d = Duration k 0 ((i * j) % 1) + in (location_step st d, [this]) + Skip d -> (location_step st d, [this]) + Repeat _ x -> locate_st st x + Tuplet _ _ x -> + let st' = (ts, l { mode = LM_In_Tuplet }) + ((ts', l''), r) = locate_st st' x + in ((ts', l'' { mode = LM_Normal } ), this:r) + Grace _ -> (st, [this]) + AfterGrace x _ -> + let (st', _) = locate_st st x + in (st', [this]) + Join xs -> + let (st', r) = mapAccumL locate_st st xs + in (st', concat r) + Clef _ _ -> (st, [this]) + Time ts' -> ((ts', l), [this]) + Key _ _ _ -> (st, [this]) + Tempo _ _ -> (st, [this]) + Command _ -> (st, [this]) + Polyphony x0 x1 -> + let (Location _ _ v _) = l + st' = map (st_set_part st) [v ..] + r = zipWith locate_st st' [x0,x1] + ((st'',_):_) = r + in (st'', this : concat (map snd r)) + Empty -> (st, [this]) -- error "locate_st: empty" + +-- | Run location calculations. +locate :: Music -> [LM] +locate = snd . locate_st ((4,4), Location 0 0 0 LM_Normal) + +locate' :: [Music] -> [LM] +locate' = locate . mconcat + +-- | Extract list of part identifiers. +lv_located_parts :: [LV a] -> [Part_ID] +lv_located_parts = nub . sort . map (part . fst) + +lv_group_parts :: [LV a] -> [[LV a]] +lv_group_parts = kv_group_by part + +-- | Drop `n' measures. +lv_from_measure :: Integer -> [LV a] -> [LV a] +lv_from_measure n = dropWhile ((< n) . measure . fst) + +lv_group_measures :: [LV a] -> [[LV a]] +lv_group_measures = kv_group_by measure + +lv_extract_part :: Part_ID -> [LV a] -> [LV a] +lv_extract_part n = filter ((== n) . part . fst) + +lv_extract_measure :: Measure -> [LV a] -> [LV a] +lv_extract_measure n = filter ((== n) . measure . fst) + +lm_pitches :: [LM] -> [Pitch] +lm_pitches l = + let m = map snd l + p = concat (map collect_pitches (filter has_pitch m)) + in (nub . sort) p + +lm_pcset :: [LM] -> [PitchClass] +lm_pcset = nub . sort . map pitch_to_pc . lm_pitches + +lm_pitches_per_measure :: [LM] -> [[Pitch]] +lm_pitches_per_measure = map lm_pitches . lv_group_measures + +lm_pcset_per_measure :: [LM] -> [[PitchClass]] +lm_pcset_per_measure = map lm_pcset . lv_group_measures + +unlocate_p :: Music -> Bool +unlocate_p m = + case m of + Note _ Nothing _ -> False + Repeat _ _ -> False + Join _ -> False + Polyphony _ _ -> error "unlocate_p: Polyphony" + _ -> True + +normal_mode_p :: Location -> Bool +normal_mode_p l = mode l == LM_Normal + +lm_unlocate :: [LM] -> [Music] +lm_unlocate = filter unlocate_p . map snd . filter (normal_mode_p . fst) + +location_time :: Location -> (Measure,Pulse) +location_time (Location i j _ _) = (i,j) + +lv_sort :: [LV a] -> [LV a] +lv_sort = sortBy (compare `on` (location_time . fst)) + +located_pitches :: [[Music]] -> [(Location, [Pitch])] +located_pitches xs = + let xs' = map (lm_discard_tied_notes . locate') xs + set_vc i (j,x) = (j {part = i },x) + xs'' = concat (zipWith (\i x -> map (set_vc i) x) [1..] xs') + xs''' = lv_sort (filter (has_pitch . snd) xs'') + in kv_map id collect_pitches xs''' + +-- * Time-signature structure analysis. + +-- | Rewrite time signature to indicated denominator. +ts_rewrite :: Integer -> TimeSignature -> TimeSignature +ts_rewrite d' = + let dv i j = let (x,y) = i `divMod` j + in if y == 0 then x else error "ts_rewrite" + go (n,d) = case compare d d' of + EQ -> (n,d) + GT -> go (n `dv` 2, d `dv` 2) + LT -> go (n * 2, d * 2) + in go + +-- | Sum time signatures (ie. 3/16 and 1/2 sum to 11/16). +ts_sum :: [TimeSignature] -> TimeSignature +ts_sum xs = + let i = maximum (map snd xs) + xs' = map (ts_rewrite i) xs + j = sum (map fst xs') + in (j,i) + +measure_diff :: Location -> Location -> Integer +measure_diff l1 l2 = measure l2 - measure l1 + +lv_last_measure :: [LV a] -> Measure +lv_last_measure = + let fn = compare `on` measure + in measure . head . reverse . sortBy fn . map fst + +time_unpack :: Music -> TimeSignature +time_unpack (Time t) = t +time_unpack _ = error "time_unpack" + +-- | Time signature structure of music. +ts_structure :: Music -> [[(TimeSignature, Integer)]] +ts_structure m = + let m' = locate m + ts = filter (L.is_time . snd) m' + ts' = kv_map id time_unpack ts + ps = lv_group_parts ts' + e xs = let (l,t) = last xs + in (t, lv_last_measure m' - measure l) + f ((l1, t1), (l2, _)) = (t1, measure_diff l1 l2) + in map (\ys -> map f (zip ys (tail ys)) ++ [e ys]) ps + +ts_structure' :: [Music] -> [[(TimeSignature, Integer)]] +ts_structure' = ts_structure . mconcat + +structure_unfold' :: (Integral i) => [(a,i)] -> [a] +structure_unfold' = + let repl = genericReplicate + in concatMap (\(x,n) -> repl n x) + +structure_unfold :: (Integral i) => [(a,i)] -> [Maybe a] +structure_unfold = + let repl = genericReplicate + in concatMap (\(x,n) -> Just x : repl (n - 1) Nothing) + +lm_ts_map :: [LM] -> TimeSignature_Map +lm_ts_map xs = + let xs' = filter (L.is_time . snd) xs + in map (\(t,x) -> (measure t, time_unpack x)) xs' + +ts_map :: [Music] -> TimeSignature_Map +ts_map = lm_ts_map . locate' + +-- | Keys are in ascending order, the value retrieved is the that with +-- the greatest key less than or equal to the key requested. +map_lookup :: Ord i => [(i,a)] -> i -> a +map_lookup mp i = + let fn pr xs = + case xs of + ((j,x):xs') -> if j > i then pr else fn x xs' + [] -> pr + in case mp of + [(j,x)] -> if i >= j then x else error "map_lookup" + _ -> fn (error "map_lookup") mp + +ts_lookup :: [(Measure,TimeSignature)] -> Measure -> TimeSignature +ts_lookup = map_lookup + +-- * Tempo + +lm_tempo_map :: [LM] -> [(Measure,(Duration,Integer))] +lm_tempo_map xs = + let xs' = filter (L.is_tempo . snd) xs + in map (\(t,Tempo d x) -> (measure t, (d,x))) xs' + +tempo_map :: [Music] -> [(Measure,(Duration,Integer))] +tempo_map = lm_tempo_map . locate' + +tempo_lookup :: [(Measure,(Duration,Integer))] -> Measure -> (Duration,Integer) +tempo_lookup = map_lookup + +-- * Key/value utilties + +-- Group keys equal under 'fn'. +kv_group_by :: (Ord c) => (a -> c) -> [(a, b)] -> [[(a, b)]] +kv_group_by fn = + let mk_f op = (op `on` (fn . fst)) + in groupBy (mk_f (==)) . sortBy (mk_f compare) + +kv_collate :: (Ord k) => (a -> k) -> (a -> v) -> [a] -> [(k,[v])] +kv_collate k v = + map (\xs -> (k (head xs), map v xs)) . + groupBy ((==) `on` k) . + sortBy (compare `on` k) + +kv_collate' :: (Ord k) => [(k,v)] -> [(k,[v])] +kv_collate' = kv_collate fst snd + +-- | Filter with predicates at key and value. +kv_filter :: (k -> Bool) -> (v -> Bool) -> [(k,v)] -> [(k,v)] +kv_filter k v = filter (\x -> k (fst x) && v (snd x)) + +-- | Apply functions to keys and values. +kv_map :: (k -> k') -> (v -> v') -> [(k,v)] -> [(k',v')] +kv_map f g = map (\(k,v) -> (f k, g v)) + +-- * Measure collation + +measure_collate :: (Music -> Bool) -> Music -> [[(Integer, [Music])]] +measure_collate p m = + let m' = filter (p . snd) (locate m) + in map (kv_collate' . kv_map measure id) (lv_group_parts m') + +collation_unfold :: [(Integer, a)] -> [Maybe a] +collation_unfold = + let repl = genericReplicate + go _ [] = [] + go n ((m,x):r) = + let s = m - n + in repl s Nothing ++ [Just x] ++ go (n + s + 1) r + in go 0 + +-- * Transformation + +type ST_r st = (st, Music) +type ST_f st = (st -> Music -> ST_r st) + +transform_st :: ST_f st -> st -> Music -> ST_r st +transform_st fn st m = + let rc = transform_st fn + in case m of + Chord xs d a -> + let (st',xs') = mapAccumL rc st xs + in fn st' (Chord xs' d a) + Tremolo (x0,x1) n -> + let (st',x0') = rc st x0 + (st'',x1') = rc st' x1 + in fn st'' (Tremolo (x0', x1') n) + Repeat n x -> + let (st',x') = rc st x + in fn st' (Repeat n x') + Tuplet o t x -> + let (st',x') = rc st x + in fn st' (Tuplet o t x') + Grace x -> + let (st',x') = rc st x + in fn st' (Grace x') + AfterGrace x0 x1 -> + let (st',x0') = rc st x0 + (st'',x1') = rc st' x1 + in fn st'' (AfterGrace x0' x1') + Join xs -> + let (st',xs') = mapAccumL rc st xs + in fn st' (Join xs') + Polyphony x0 x1 -> + let (st',x0') = rc st x0 + (st'',x1') = rc st' x1 + in fn st'' (Polyphony x0' x1') + _ -> fn st m + +transform :: (Music -> Music) -> Music -> Music +transform fn = + let fn' _ m = ((), fn m) + in snd . transform_st fn' () + +-- * Repeats + +write_out_repeats :: Music -> Music +write_out_repeats = + let fn m = case m of + Repeat n x -> Join (genericReplicate n x) + _ -> m + in transform fn + +-- * Replace + +-- | Replace the pitch of note element n1 with that of n0. +note_replace_pitch :: Pitch -> Music -> Music +note_replace_pitch x n = n { note_pitch = x } + +note_replace_pitch_m :: Music -> Music -> Music +note_replace_pitch_m n0 n1 = n1 { note_pitch = note_pitch n0 } + +replace_notes_fn :: (a -> Pitch) -> [a] -> Music -> ([a], Music) +replace_notes_fn fn xs m = + case xs of + [] -> ([], m) + (n:ns) -> if L.is_note m + then let m' = note_replace_pitch (fn n) m + in if L.is_tied m + then (xs, m') + else (ns, m') + else (xs, m) + +-- | Replaces notes with indicated pitches, rhythms and annotations +-- are not replaced. Tied notes do not use multiple pitches from +-- the input sequence. +replace_notes_p :: [Pitch] -> Music -> Music +replace_notes_p ns = snd . transform_st (replace_notes_fn id) ns + +replace_notes :: [Music] -> Music -> Music +replace_notes ns = snd . transform_st (replace_notes_fn note_pitch) ns + +-- * Insert + +insert_after_notes_fn :: [Maybe Music] -> Music -> ([Maybe Music], Music) +insert_after_notes_fn xs m = + case xs of + [] -> ([], m) + (y:ys) -> if L.is_note m && not (L.is_tied m) + then (ys, case y of + Nothing -> m + Just y' -> Join [m,y']) + else (xs, m) + +-- | Inserts a value after each note as indicated. +insert_after_notes :: [Maybe Music] -> Music -> Music +insert_after_notes xs = snd . transform_st insert_after_notes_fn xs + +-- * Tied notes + +discard_tied_notes_pr :: (a -> Bool) -> (a -> Bool) -> [a] -> [a] +discard_tied_notes_pr i_pr f_pr = + let fn keep ns = + case ns of + (x:xs) -> let i = if keep then [x] else [] + in if i_pr x || (not keep && f_pr x) + then i ++ fn False xs + else i ++ fn True xs + _ -> ns + in fn True + +discard_tied_notes :: [Music] -> [Music] +discard_tied_notes = + let i_pr = L.is_tied + f_pr = not . has_pitch + in discard_tied_notes_pr i_pr f_pr + +lm_discard_tied_notes :: [LM] -> [LM] +lm_discard_tied_notes = + let i_pr = L.is_tied . snd + f_pr = not . has_pitch . snd + in discard_tied_notes_pr i_pr f_pr + +-- * Spelling + +spell_ks :: (Octave, PitchClass) -> Music +spell_ks (o,pc) = + let (n,a) = T.pc_spell_ks pc + in Note (Pitch n a o) Nothing [] + +spell_sharp :: (Octave, PitchClass) -> Music +spell_sharp (o,pc) = + let (n,a) = T.pc_spell_sharp pc + in Note (Pitch n a o) Nothing [] + +spell_flat :: (Octave, PitchClass) -> Music +spell_flat (o,pc) = + let (n,a) = T.pc_spell_flat pc + in Note (Pitch n a o) Nothing [] + +-- * Validation + +v_assert :: String -> (Music -> Bool) -> (Music -> Maybe String) +v_assert str fn m = + if fn m then Nothing else Just str + +-- | Notes in chords must not have duration. +v_chord_note_valid :: Music -> Maybe String +v_chord_note_valid = + let fn (Note _ Nothing _) = True + fn _ = False + in v_assert "v_chord_note_valid" fn + +validate :: Music -> [String] +validate m = + case m of + Chord [] _ _ -> ["empty chord"] + Chord xs _ _ -> mapMaybe v_chord_note_valid xs + _ -> [] + diff --git a/Music/LilyPond/Light/Constant.hs b/Music/LilyPond/Light/Constant.hs new file mode 100644 --- /dev/null +++ b/Music/LilyPond/Light/Constant.hs @@ -0,0 +1,204 @@ +module Music.LilyPond.Light.Constant where + +import Music.LilyPond.Light.Model + +-- * Annotations + +pppp,ppp,pp,p,mp,mf,f,ff,fff,ffff,fp,sfz :: Annotation +pppp = Dynamic PPPP +ppp = Dynamic PPP +pp = Dynamic Pianissimo +p = Dynamic Piano +mp = Dynamic MezzoPiano +mf = Dynamic MezzoForte +f = Dynamic Forte +ff = Dynamic Fortissimo +fff = Dynamic FFF +ffff = Dynamic FFFF +fp = Dynamic FP +sfz = Dynamic SFZ + +cresc,decr,end_cresc,end_decr,espressivo ::Annotation +cresc = Dynamic Begin_Crescendo +decr = Dynamic Begin_Decrescendo +end_cresc = Dynamic End_Dynamic +end_decr = Dynamic End_Dynamic +espressivo = Dynamic Espressivo + +arpeggio,fermata,flageolet,harmonic,laissezVibrer,glissando :: Annotation +arpeggio = Articulation Arpeggio +fermata = Articulation Fermata +flageolet = Articulation Flageolet +harmonic = Articulation Harmonic +laissezVibrer = Articulation LaissezVibrer +glissando = Articulation Glissando + +marcato,staccato,tenuto,accent :: Annotation +marcato = Articulation Marcato +staccato = Articulation Staccato +tenuto = Articulation Tenuto +accent = Articulation Accent + +-- * Clefs + +bass_clef,tenor_clef,alto_clef,treble_clef,percussion_clef :: Music +bass_clef = Clef Bass 0 +tenor_clef = Clef Tenor 0 +alto_clef = Clef Alto 0 +treble_clef = Clef Treble 0 +percussion_clef = Clef Percussion 0 + +bass_8vb_clef,treble_8va_clef,treble_8vb_clef,treble_15ma_clef :: Music +bass_8vb_clef = Clef Bass (-1) +treble_8va_clef = Clef Treble 1 +treble_8vb_clef = Clef Treble (-1) +treble_15ma_clef = Clef Treble 2 + +-- * Commands + +l :: Music +l = Command BarlineCheck + +double_barline,final_barline :: Music +double_barline = Command (Bar DoubleBarline) +final_barline = Command (Bar FinalBarline) + +system_break,no_system_break :: Music +system_break = Command Break +no_system_break = Command NoBreak + +page_break,no_page_break :: Music +page_break = Command PageBreak +no_page_break = Command NoPageBreak + +auto_beam_off :: Music +auto_beam_off = Command AutoBeamOff + +tuplet_down,tuplet_neutral,tuplet_up :: Music +tuplet_down = Command TupletDown +tuplet_neutral = Command TupletNeutral +tuplet_up = Command TupletUp + +voice_one,voice_two :: Music +voice_one = Command VoiceOne +voice_two = Command VoiceTwo + +stem_down,stem_neutral,stem_up :: Music +stem_down = Command StemDown +stem_neutral = Command StemNeutral +stem_up = Command StemUp + +dynamic_down,dynamic_neutral,dynamic_up :: Music +dynamic_down = Command DynamicDown +dynamic_neutral = Command DynamicNeutral +dynamic_up = Command DynamicUp + +begin_8va,end_8va :: Music +begin_8va = Command (Octavation 1) +end_8va = Command (Octavation 0) + +-- * Annotations + +ped,no_ped :: Annotation +ped = Phrasing SustainOn +no_ped = Phrasing SustainOff + +tie :: Annotation +tie = Begin_Tie + +-- | Beaming annotations. +begin_beam,end_beam :: Annotation +begin_beam = Phrasing Begin_Beam +end_beam = Phrasing End_Beam + +-- | Slur annotations. +begin_slur,end_slur :: Annotation +begin_slur = Phrasing Begin_Slur +end_slur = Phrasing End_Slur + +slur_down,slur_neutral,slur_up :: Music +slur_down = Command (User "\\slurDown") +slur_neutral = Command (User "\\slurNeutral") +slur_up = Command (User "\\slurUp") + +-- | Phrasing slur annotations. +begin_phrasing_slur,end_phrasing_slur :: Annotation +begin_phrasing_slur = Phrasing Begin_PhrasingSlur +end_phrasing_slur = Phrasing End_PhrasingSlur + +-- * Accidentals + +rAcc,cAcc :: Annotation +rAcc = ReminderAccidental +cAcc = CautionaryAccidental + +set_accidental_style_dodecaphonic :: Music +set_accidental_style_dodecaphonic = + let x = "#(set-accidental-style 'dodecaphonic)" + in Command (User x) + +set_accidental_style_neo_modern :: Music +set_accidental_style_neo_modern = + let x = "#(set-accidental-style 'neo-modern)" + in Command (User x) + +set_accidental_style_modern :: Music +set_accidental_style_modern = + let x = "#(set-accidental-style 'modern)" + in Command (User x) + +-- * Paper + +a4_paper :: Paper +a4_paper = + Paper {binding_offset = Length 0 MM + ,bottom_margin = Length 6 MM + ,indent = Length 15 MM + ,inner_margin = Length 10 MM + ,left_margin = Length 10 MM + ,outer_margin = Length 20 MM + ,paper_width = Length 210 MM + ,paper_height = Length 297 MM + ,ragged_last = False + ,ragged_last_bottom = True + ,right_margin = Length 10 MM + ,systems_per_page = Nothing + ,top_margin = Length 5 MM + ,two_sided = False} + +length_scale :: Double -> Length -> Length +length_scale n (Length x u) = Length (n * x) u + +paper_incr_size :: Paper -> Paper +paper_incr_size x = + let wd = paper_width x + ht = paper_height x + in x { paper_width = ht, paper_height = (length_scale 2 wd) } + +a3_paper :: Paper +a3_paper = paper_incr_size a4_paper + +a2_paper :: Paper +a2_paper = paper_incr_size a3_paper + +landscape :: Paper -> Paper +landscape x = + let wd = paper_width x + ht = paper_height x + in x { paper_width = ht, paper_height = wd } + +-- * Settings + +default_score_settings :: Score_Settings +default_score_settings = + Score_Settings { independent_time_signatures = False } + +-- * Header + +default_header :: Header +default_header = + Header {dedication = "" + ,title = "" + ,subtitle = "" + ,composer = "" + ,tagline = ""} diff --git a/Music/LilyPond/Light/Constant/NoteName.hs b/Music/LilyPond/Light/Constant/NoteName.hs new file mode 100644 --- /dev/null +++ b/Music/LilyPond/Light/Constant/NoteName.hs @@ -0,0 +1,396 @@ +module Music.LilyPond.Light.Constant.NoteName where + +import Music.LilyPond.Light.Model +import Music.Theory.Pitch + +-- * Notes + +mk_note :: Note_T -> Alteration_T -> Octave -> Music +mk_note n a o = Note (Pitch n a o) Nothing [] + +c1,d1,e1,f1,g1,a1,b1 :: Music +c1 = mk_note C Natural 1 +d1 = mk_note D Natural 1 +e1 = mk_note E Natural 1 +f1 = mk_note F Natural 1 +g1 = mk_note G Natural 1 +a1 = mk_note A Natural 1 +b1 = mk_note B Natural 1 + +ces1,des1,ees1,fes1,ges1,aes1,bes1 :: Music +ces1 = mk_note C Flat 1 +des1 = mk_note D Flat 1 +ees1 = mk_note E Flat 1 +fes1 = mk_note F Flat 1 +ges1 = mk_note G Flat 1 +aes1 = mk_note A Flat 1 +bes1 = mk_note B Flat 1 + +cis1,dis1,eis1,fis1,gis1,ais1,bis1 :: Music +cis1 = mk_note C Sharp 1 +dis1 = mk_note D Sharp 1 +eis1 = mk_note E Sharp 1 +fis1 = mk_note F Sharp 1 +gis1 = mk_note G Sharp 1 +ais1 = mk_note A Sharp 1 +bis1 = mk_note B Sharp 1 + +c2,d2,e2,f2,g2,a2,b2 :: Music +c2 = mk_note C Natural 2 +d2 = mk_note D Natural 2 +e2 = mk_note E Natural 2 +f2 = mk_note F Natural 2 +g2 = mk_note G Natural 2 +a2 = mk_note A Natural 2 +b2 = mk_note B Natural 2 + +ces2,des2,ees2,fes2,ges2,aes2,bes2 :: Music +ces2 = mk_note C Flat 2 +des2 = mk_note D Flat 2 +ees2 = mk_note E Flat 2 +fes2 = mk_note F Flat 2 +ges2 = mk_note G Flat 2 +aes2 = mk_note A Flat 2 +bes2 = mk_note B Flat 2 + +cis2,dis2,eis2,fis2,gis2,ais2,bis2 :: Music +cis2 = mk_note C Sharp 2 +dis2 = mk_note D Sharp 2 +eis2 = mk_note E Sharp 2 +fis2 = mk_note F Sharp 2 +gis2 = mk_note G Sharp 2 +ais2 = mk_note A Sharp 2 +bis2 = mk_note B Sharp 2 + +cisis2,disis2,eisis2,fisis2,gisis2,aisis2,bisis2 :: Music +cisis2 = mk_note C DoubleSharp 2 +disis2 = mk_note D DoubleSharp 2 +eisis2 = mk_note E DoubleSharp 2 +fisis2 = mk_note F DoubleSharp 2 +gisis2 = mk_note G DoubleSharp 2 +aisis2 = mk_note A DoubleSharp 2 +bisis2 = mk_note B DoubleSharp 2 + +c3,d3,e3,f3,g3,a3,b3 :: Music +c3 = mk_note C Natural 3 +d3 = mk_note D Natural 3 +e3 = mk_note E Natural 3 +f3 = mk_note F Natural 3 +g3 = mk_note G Natural 3 +a3 = mk_note A Natural 3 +b3 = mk_note B Natural 3 + +ces3,des3,ees3,fes3,ges3,aes3,bes3 :: Music +ces3 = mk_note C Flat 3 +des3 = mk_note D Flat 3 +ees3 = mk_note E Flat 3 +fes3 = mk_note F Flat 3 +ges3 = mk_note G Flat 3 +aes3 = mk_note A Flat 3 +bes3 = mk_note B Flat 3 + +cis3,dis3,eis3,fis3,gis3,ais3,bis3 :: Music +cis3 = mk_note C Sharp 3 +dis3 = mk_note D Sharp 3 +eis3 = mk_note E Sharp 3 +fis3 = mk_note F Sharp 3 +gis3 = mk_note G Sharp 3 +ais3 = mk_note A Sharp 3 +bis3 = mk_note B Sharp 3 + +cisis3,disis3,eisis3,fisis3,gisis3,aisis3,bisis3 :: Music +cisis3 = mk_note C DoubleSharp 3 +disis3 = mk_note D DoubleSharp 3 +eisis3 = mk_note E DoubleSharp 3 +fisis3 = mk_note F DoubleSharp 3 +gisis3 = mk_note G DoubleSharp 3 +aisis3 = mk_note A DoubleSharp 3 +bisis3 = mk_note B DoubleSharp 3 + +ceseh3,deseh3,eeseh3,feseh3,geseh3,aeseh3,beseh3 :: Music +ceseh3 = mk_note C ThreeQuarterToneFlat 3 +deseh3 = mk_note D ThreeQuarterToneFlat 3 +eeseh3 = mk_note E ThreeQuarterToneFlat 3 +feseh3 = mk_note F ThreeQuarterToneFlat 3 +geseh3 = mk_note G ThreeQuarterToneFlat 3 +aeseh3 = mk_note A ThreeQuarterToneFlat 3 +beseh3 = mk_note B ThreeQuarterToneFlat 3 + +ceh3,deh3,eeh3,feh3,geh3,aeh3,beh3 :: Music +ceh3 = mk_note C QuarterToneFlat 3 +deh3 = mk_note D QuarterToneFlat 3 +eeh3 = mk_note E QuarterToneFlat 3 +feh3 = mk_note F QuarterToneFlat 3 +geh3 = mk_note G QuarterToneFlat 3 +aeh3 = mk_note A QuarterToneFlat 3 +beh3 = mk_note B QuarterToneFlat 3 + +cih3,dih3,eih3,fih3,gih3,aih3,bih3 :: Music +cih3 = mk_note C QuarterToneSharp 3 +dih3 = mk_note D QuarterToneSharp 3 +eih3 = mk_note E QuarterToneSharp 3 +fih3 = mk_note F QuarterToneSharp 3 +gih3 = mk_note G QuarterToneSharp 3 +aih3 = mk_note A QuarterToneSharp 3 +bih3 = mk_note B QuarterToneSharp 3 + +cisih3,disih3,eisih3,fisih3,gisih3,aisih3,bisih3 :: Music +cisih3 = mk_note C ThreeQuarterToneSharp 3 +disih3 = mk_note D ThreeQuarterToneSharp 3 +eisih3 = mk_note E ThreeQuarterToneSharp 3 +fisih3 = mk_note F ThreeQuarterToneSharp 3 +gisih3 = mk_note G ThreeQuarterToneSharp 3 +aisih3 = mk_note A ThreeQuarterToneSharp 3 +bisih3 = mk_note B ThreeQuarterToneSharp 3 + +c4,d4,e4,f4,g4,a4,b4 :: Music +c4 = mk_note C Natural 4 +d4 = mk_note D Natural 4 +e4 = mk_note E Natural 4 +f4 = mk_note F Natural 4 +g4 = mk_note G Natural 4 +a4 = mk_note A Natural 4 +b4 = mk_note B Natural 4 + +ces4,des4,ees4,fes4,ges4,aes4,bes4 :: Music +ces4 = mk_note C Flat 4 +des4 = mk_note D Flat 4 +ees4 = mk_note E Flat 4 +fes4 = mk_note F Flat 4 +ges4 = mk_note G Flat 4 +aes4 = mk_note A Flat 4 +bes4 = mk_note B Flat 4 + +cis4,dis4,eis4,fis4,gis4,ais4,bis4 :: Music +cis4 = mk_note C Sharp 4 +dis4 = mk_note D Sharp 4 +eis4 = mk_note E Sharp 4 +fis4 = mk_note F Sharp 4 +gis4 = mk_note G Sharp 4 +ais4 = mk_note A Sharp 4 +bis4 = mk_note B Sharp 4 + +ceses4,deses4,eeses4,feses4,geses4,aeses4,beses4 :: Music +ceses4 = mk_note C DoubleFlat 4 +deses4 = mk_note D DoubleFlat 4 +eeses4 = mk_note E DoubleFlat 4 +feses4 = mk_note F DoubleFlat 4 +geses4 = mk_note G DoubleFlat 4 +aeses4 = mk_note A DoubleFlat 4 +beses4 = mk_note B DoubleFlat 4 + +cisis4,disis4,eisis4,fisis4,gisis4,aisis4,bisis4 :: Music +cisis4 = mk_note C DoubleSharp 4 +disis4 = mk_note D DoubleSharp 4 +eisis4 = mk_note E DoubleSharp 4 +fisis4 = mk_note F DoubleSharp 4 +gisis4 = mk_note G DoubleSharp 4 +aisis4 = mk_note A DoubleSharp 4 +bisis4 = mk_note B DoubleSharp 4 + +ceseh4,deseh4,eeseh4,feseh4,geseh4,aeseh4,beseh4 :: Music +ceseh4 = mk_note C ThreeQuarterToneFlat 4 +deseh4 = mk_note D ThreeQuarterToneFlat 4 +eeseh4 = mk_note E ThreeQuarterToneFlat 4 +feseh4 = mk_note F ThreeQuarterToneFlat 4 +geseh4 = mk_note G ThreeQuarterToneFlat 4 +aeseh4 = mk_note A ThreeQuarterToneFlat 4 +beseh4 = mk_note B ThreeQuarterToneFlat 4 + +ceh4,deh4,eeh4,feh4,geh4,aeh4,beh4 :: Music +ceh4 = mk_note C QuarterToneFlat 4 +deh4 = mk_note D QuarterToneFlat 4 +eeh4 = mk_note E QuarterToneFlat 4 +feh4 = mk_note F QuarterToneFlat 4 +geh4 = mk_note G QuarterToneFlat 4 +aeh4 = mk_note A QuarterToneFlat 4 +beh4 = mk_note B QuarterToneFlat 4 + +cih4,dih4,eih4,fih4,gih4,aih4,bih4 :: Music +cih4 = mk_note C QuarterToneSharp 4 +dih4 = mk_note D QuarterToneSharp 4 +eih4 = mk_note E QuarterToneSharp 4 +fih4 = mk_note F QuarterToneSharp 4 +gih4 = mk_note G QuarterToneSharp 4 +aih4 = mk_note A QuarterToneSharp 4 +bih4 = mk_note B QuarterToneSharp 4 + +cisih4,disih4,eisih4,fisih4,gisih4,aisih4,bisih4 :: Music +cisih4 = mk_note C ThreeQuarterToneSharp 4 +disih4 = mk_note D ThreeQuarterToneSharp 4 +eisih4 = mk_note E ThreeQuarterToneSharp 4 +fisih4 = mk_note F ThreeQuarterToneSharp 4 +gisih4 = mk_note G ThreeQuarterToneSharp 4 +aisih4 = mk_note A ThreeQuarterToneSharp 4 +bisih4 = mk_note B ThreeQuarterToneSharp 4 + +c5,d5,e5,f5,g5,a5,b5 :: Music +c5 = mk_note C Natural 5 +d5 = mk_note D Natural 5 +e5 = mk_note E Natural 5 +f5 = mk_note F Natural 5 +g5 = mk_note G Natural 5 +a5 = mk_note A Natural 5 +b5 = mk_note B Natural 5 + +ces5,des5,ees5,fes5,ges5,aes5,bes5 :: Music +ces5 = mk_note C Flat 5 +des5 = mk_note D Flat 5 +ees5 = mk_note E Flat 5 +fes5 = mk_note F Flat 5 +ges5 = mk_note G Flat 5 +aes5 = mk_note A Flat 5 +bes5 = mk_note B Flat 5 + +cis5,dis5,eis5,fis5,gis5,ais5,bis5 :: Music +cis5 = mk_note C Sharp 5 +dis5 = mk_note D Sharp 5 +eis5 = mk_note E Sharp 5 +fis5 = mk_note F Sharp 5 +gis5 = mk_note G Sharp 5 +ais5 = mk_note A Sharp 5 +bis5 = mk_note B Sharp 5 + +ceses5,deses5,eeses5,feses5,geses5,aeses5,beses5 :: Music +ceses5 = mk_note C DoubleFlat 5 +deses5 = mk_note D DoubleFlat 5 +eeses5 = mk_note E DoubleFlat 5 +feses5 = mk_note F DoubleFlat 5 +geses5 = mk_note G DoubleFlat 5 +aeses5 = mk_note A DoubleFlat 5 +beses5 = mk_note B DoubleFlat 5 + +cisis5,disis5,eisis5,fisis5,gisis5,aisis5,bisis5 :: Music +cisis5 = mk_note C DoubleSharp 5 +disis5 = mk_note D DoubleSharp 5 +eisis5 = mk_note E DoubleSharp 5 +fisis5 = mk_note F DoubleSharp 5 +gisis5 = mk_note G DoubleSharp 5 +aisis5 = mk_note A DoubleSharp 5 +bisis5 = mk_note B DoubleSharp 5 + +ceseh5,deseh5,eeseh5,feseh5,geseh5,aeseh5,beseh5 :: Music +ceseh5 = mk_note C ThreeQuarterToneFlat 5 +deseh5 = mk_note D ThreeQuarterToneFlat 5 +eeseh5 = mk_note E ThreeQuarterToneFlat 5 +feseh5 = mk_note F ThreeQuarterToneFlat 5 +geseh5 = mk_note G ThreeQuarterToneFlat 5 +aeseh5 = mk_note A ThreeQuarterToneFlat 5 +beseh5 = mk_note B ThreeQuarterToneFlat 5 + +ceh5,deh5,eeh5,feh5,geh5,aeh5,beh5 :: Music +ceh5 = mk_note C QuarterToneFlat 5 +deh5 = mk_note D QuarterToneFlat 5 +eeh5 = mk_note E QuarterToneFlat 5 +feh5 = mk_note F QuarterToneFlat 5 +geh5 = mk_note G QuarterToneFlat 5 +aeh5 = mk_note A QuarterToneFlat 5 +beh5 = mk_note B QuarterToneFlat 5 + +cih5,dih5,eih5,fih5,gih5,aih5,bih5 :: Music +cih5 = mk_note C QuarterToneSharp 5 +dih5 = mk_note D QuarterToneSharp 5 +eih5 = mk_note E QuarterToneSharp 5 +fih5 = mk_note F QuarterToneSharp 5 +gih5 = mk_note G QuarterToneSharp 5 +aih5 = mk_note A QuarterToneSharp 5 +bih5 = mk_note B QuarterToneSharp 5 + +cisih5,disih5,eisih5,fisih5,gisih5,aisih5,bisih5 :: Music +cisih5 = mk_note C ThreeQuarterToneSharp 5 +disih5 = mk_note D ThreeQuarterToneSharp 5 +eisih5 = mk_note E ThreeQuarterToneSharp 5 +fisih5 = mk_note F ThreeQuarterToneSharp 5 +gisih5 = mk_note G ThreeQuarterToneSharp 5 +aisih5 = mk_note A ThreeQuarterToneSharp 5 +bisih5 = mk_note B ThreeQuarterToneSharp 5 + +c6,d6,e6,f6,g6,a6,b6 :: Music +c6 = mk_note C Natural 6 +d6 = mk_note D Natural 6 +e6 = mk_note E Natural 6 +f6 = mk_note F Natural 6 +g6 = mk_note G Natural 6 +a6 = mk_note A Natural 6 +b6 = mk_note B Natural 6 + +ces6,des6,ees6,fes6,ges6,aes6,bes6 :: Music +ces6 = mk_note C Flat 6 +des6 = mk_note D Flat 6 +ees6 = mk_note E Flat 6 +fes6 = mk_note F Flat 6 +ges6 = mk_note G Flat 6 +aes6 = mk_note A Flat 6 +bes6 = mk_note B Flat 6 + +cis6,dis6,eis6,fis6,gis6,ais6,bis6 :: Music +cis6 = mk_note C Sharp 6 +dis6 = mk_note D Sharp 6 +eis6 = mk_note E Sharp 6 +fis6 = mk_note F Sharp 6 +gis6 = mk_note G Sharp 6 +ais6 = mk_note A Sharp 6 +bis6 = mk_note B Sharp 6 + +ceseh6,deseh6,eeseh6,feseh6,geseh6,aeseh6,beseh6 :: Music +ceseh6 = mk_note C ThreeQuarterToneFlat 6 +deseh6 = mk_note D ThreeQuarterToneFlat 6 +eeseh6 = mk_note E ThreeQuarterToneFlat 6 +feseh6 = mk_note F ThreeQuarterToneFlat 6 +geseh6 = mk_note G ThreeQuarterToneFlat 6 +aeseh6 = mk_note A ThreeQuarterToneFlat 6 +beseh6 = mk_note B ThreeQuarterToneFlat 6 + +ceh6,deh6,eeh6,feh6,geh6,aeh6,beh6 :: Music +ceh6 = mk_note C QuarterToneFlat 6 +deh6 = mk_note D QuarterToneFlat 6 +eeh6 = mk_note E QuarterToneFlat 6 +feh6 = mk_note F QuarterToneFlat 6 +geh6 = mk_note G QuarterToneFlat 6 +aeh6 = mk_note A QuarterToneFlat 6 +beh6 = mk_note B QuarterToneFlat 6 + +cih6,dih6,eih6,fih6,gih6,aih6,bih6 :: Music +cih6 = mk_note C QuarterToneSharp 6 +dih6 = mk_note D QuarterToneSharp 6 +eih6 = mk_note E QuarterToneSharp 6 +fih6 = mk_note F QuarterToneSharp 6 +gih6 = mk_note G QuarterToneSharp 6 +aih6 = mk_note A QuarterToneSharp 6 +bih6 = mk_note B QuarterToneSharp 6 + +cisih6,disih6,eisih6,fisih6,gisih6,aisih6,bisih6 :: Music +cisih6 = mk_note C ThreeQuarterToneSharp 6 +disih6 = mk_note D ThreeQuarterToneSharp 6 +eisih6 = mk_note E ThreeQuarterToneSharp 6 +fisih6 = mk_note F ThreeQuarterToneSharp 6 +gisih6 = mk_note G ThreeQuarterToneSharp 6 +aisih6 = mk_note A ThreeQuarterToneSharp 6 +bisih6 = mk_note B ThreeQuarterToneSharp 6 + +c7,d7,e7,f7,g7,a7,b7 :: Music +c7 = mk_note C Natural 7 +d7 = mk_note D Natural 7 +e7 = mk_note E Natural 7 +f7 = mk_note F Natural 7 +g7 = mk_note G Natural 7 +a7 = mk_note A Natural 7 +b7 = mk_note B Natural 7 + +ces7,des7,ees7,fes7,ges7,aes7,bes7 :: Music +ces7 = mk_note C Flat 7 +des7 = mk_note D Flat 7 +ees7 = mk_note E Flat 7 +fes7 = mk_note F Flat 7 +ges7 = mk_note G Flat 7 +aes7 = mk_note A Flat 7 +bes7 = mk_note B Flat 7 + +cis7,dis7,eis7,fis7,gis7,ais7,bis7 :: Music +cis7 = mk_note C Sharp 7 +dis7 = mk_note D Sharp 7 +eis7 = mk_note E Sharp 7 +fis7 = mk_note F Sharp 7 +gis7 = mk_note G Sharp 7 +ais7 = mk_note A Sharp 7 +bis7 = mk_note B Sharp 7 diff --git a/Music/LilyPond/Light/Model.hs b/Music/LilyPond/Light/Model.hs new file mode 100644 --- /dev/null +++ b/Music/LilyPond/Light/Model.hs @@ -0,0 +1,205 @@ +module Music.LilyPond.Light.Model where + +import Data.Monoid +import Music.Theory.Pitch +import Music.Theory.Duration +import Music.Theory.Key + +data Version = Version String + deriving (Eq, Show) + +data Units = MM | CM + deriving (Eq, Show) + +data Length = Length Double Units + deriving (Eq, Show) + +data Paper = Paper { binding_offset :: Length + , bottom_margin :: Length + , indent :: Length + , inner_margin :: Length + , left_margin :: Length + , outer_margin :: Length + , paper_width :: Length + , paper_height :: Length + , ragged_last :: Bool + , ragged_last_bottom :: Bool + , right_margin :: Length + , systems_per_page :: Maybe Integer + , top_margin :: Length + , two_sided :: Bool } + deriving (Eq, Show) + +data Header = Header { dedication :: String + , title :: String + , subtitle :: String + , composer :: String + , tagline :: String } + deriving (Eq, Show) + +data Clef_T = Bass | Tenor | Alto | Treble | Percussion + deriving (Eq, Ord, Show) + +data Articulation_T = Accent + | Arpeggio + | ArpeggioDown + | ArpeggioNeutral + | ArpeggioUp + | DownBow + | Fermata + | Flageolet + | Glissando + | Harmonic + | LaissezVibrer + | Marcato + | Open + | Portato + | Staccato + | StemTremolo Integer + | Stopped + | Tenuto + | Trill + | UpBow + deriving (Eq, Show) + +data Dynamic_T = PPPP | PPP | Pianissimo | Piano | MezzoPiano + | MezzoForte | Forte | Fortissimo | FFF | FFFF + | FP | SFZ + | Espressivo + | Begin_Crescendo + | Begin_Decrescendo + | End_Dynamic + deriving (Eq, Show) + +data Phrasing_T = Begin_Slur + | End_Slur + | Begin_PhrasingSlur + | End_PhrasingSlur + | Begin_Beam + | End_Beam + | SustainOn + | SustainOff + deriving (Eq, Show) + +data Annotation = Articulation Articulation_T + | Dynamic Dynamic_T + | Phrasing Phrasing_T + | Begin_Tie + | Above | Below + | Text String + | ReminderAccidental | CautionaryAccidental + | CompositeAnnotation [Annotation] + deriving (Eq, Show) + +data Bar_T = NormalBarline + | DoubleBarline + | LeftRepeatBarline + | RightRepeatBarline + | FinalBarline + deriving (Eq, Show) + +data Command_T = AutoBeamOff + | Bar Bar_T + | BarlineCheck + | BarNumberCheck Integer + | Break + | Change String + | DynamicDown + | DynamicNeutral + | DynamicUp + | NoBreak + | NoPageBreak + | Octavation Integer + | PageBreak + | Partial Duration + | StemDown + | StemNeutral + | StemUp + | TupletDown + | TupletNeutral + | TupletUp + | User String + | VoiceOne + | VoiceTwo + | VoiceThree + | VoiceFour + deriving (Eq, Show) + +type TimeSignature = (Integer, Integer) + +type Tuplet_T = (Integer, Integer) + +data Tuplet_Mode = Normal_Tuplet + | Scale_Durations + deriving (Eq, Show) + +data Music = Note { note_pitch :: Pitch + , note_duration :: (Maybe Duration) + , note_annotations :: [Annotation] } + | Chord { chord_notes :: [Music] + , chord_duration :: Duration + , chord_annotations :: [Annotation] } + | Tremolo (Music,Music) Integer + | Rest Duration [Annotation] + | MMRest Integer TimeSignature [Annotation] + | Skip Duration + | Repeat Integer Music + | Tuplet Tuplet_Mode Tuplet_T Music + | Grace Music + | AfterGrace Music Music + | Join [Music] + | Clef Clef_T Int + | Time TimeSignature + | Key Note_T (Maybe Alteration_T) Mode_T + | Tempo Duration Integer + | Command Command_T + | Polyphony Music Music + | Empty + deriving (Eq, Show) + +instance Monoid Music where + mempty = Empty + mappend x y = Join [x,y] + mconcat xs = Join xs + +type Staff_Name = (String,String) + +type Staff_ID = String + +data Staff_T = Normal_Staff + | Rhythmic_Staff + deriving (Eq, Show) + +data Part = Part (Maybe String) [Music] + | MultipleParts [[Music]] + deriving (Eq, Show) + +data Staff_Set_T = ChoirStaff + | GrandStaff + | PianoStaff + | StaffGroup + | StaffGroup_SquareBracket + deriving (Eq, Show) + +type Staff_Scalar = Int + +data Staff_Settings = Staff_Settings Staff_T Staff_ID Staff_Scalar + deriving (Eq, Show) + +data Staff = Staff Staff_Settings Staff_Name Part + | Staff_Set Staff_Set_T Staff_Name [Staff] + deriving (Eq, Show) + +data Score_Settings = + Score_Settings { independent_time_signatures :: Bool + } + deriving (Eq, Show) + +data Score = Score Score_Settings [Staff] + deriving (Eq, Show) + +data Work = Work { work_version :: Version + , work_paper :: Paper + , work_header :: Header + , work_score :: Score } + deriving (Eq, Show) diff --git a/Music/LilyPond/Light/Output/LilyPond.hs b/Music/LilyPond/Light/Output/LilyPond.hs new file mode 100644 --- /dev/null +++ b/Music/LilyPond/Light/Output/LilyPond.hs @@ -0,0 +1,413 @@ +module Music.LilyPond.Light.Output.LilyPond (ly_work + ,ly_music_elem) where + +import Data.List +import Music.LilyPond.Light.Model +import Music.Theory.Pitch +import Music.Theory.Duration +import Music.Theory.Key +import Text.Printf + +with_brackets :: (String,String) -> [String] -> [String] +with_brackets (begin,end) xs = [begin] ++ xs ++ [end] + +with_braces :: [String] -> [String] +with_braces = with_brackets ("{","}") + +ly_str :: String -> String +ly_str x = "\"" ++ x ++ "\"" + +ly_version :: Version -> [String] +ly_version (Version v) = ["\\version", ly_str v] + +ly_assign :: (String -> String) -> (String,String) -> [String] +ly_assign fn (key,value) = [key,"=",fn value] + +ly_bool :: Bool -> String +ly_bool True = "##t" +ly_bool False = "##f" + +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 + 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-last", ly_bool (ragged_last p)) + ,("ragged-last-bottom", ly_bool (ragged_last_bottom p)) + ,("systems-per-page", maybe "" show (systems_per_page p)) + ,("top-margin", ly_length (top_margin p)) + ,("two-sided", ly_bool tw)] + ys = ly_delete_nil_values (xs ++ mg) + in "\\paper" : with_braces (concatMap (ly_assign id) ys) + +ly_header :: Header -> [String] +ly_header hdr = + let xs = [("dedication", dedication hdr) + ,("title", title hdr) + ,("subtitle", subtitle hdr) + ,("composer", composer hdr) + ,("tagline", tagline hdr)] + in "\\header" : with_braces (concatMap (ly_assign ly_str) xs) + +ly_clef_t :: Clef_T -> String +ly_clef_t c = + case c of + Treble -> "treble" + Alto -> "alto" + Tenor -> "tenor" + Bass -> "bass" + Percussion -> "percussion" + +ly_clef :: Clef_T -> Int -> String +ly_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 n = + case n of + C -> "c" + D -> "d" + E -> "e" + F -> "f" + G -> "g" + A -> "a" + B -> "b" + +ly_alteration :: Alteration_T -> String +ly_alteration a = + case a of + DoubleFlat -> "eses" + ThreeQuarterToneFlat -> "eseh" + Flat -> "es" + QuarterToneFlat -> "eh" + Natural -> "" + QuarterToneSharp -> "ih" + Sharp -> "is" + ThreeQuarterToneSharp -> "isih" + DoubleSharp -> "isis" + +ly_alteration' :: Maybe Alteration_T -> String +ly_alteration' = maybe "" ly_alteration + +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 ++ + ly_alteration 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" + StemTremolo x -> ":" ++ show x + Stopped -> "\\stopped" + Tenuto -> "\\tenuto" + Trill -> "\\trill" + UpBow -> "\\upbow" + +ly_dynamic :: Dynamic_T -> String +ly_dynamic d = + case d of + PPPP -> "\\pppp" + PPP -> "\\ppp" + Pianissimo -> "\\pp" + Piano -> "\\p" + MezzoPiano -> "\\mp" + MezzoForte -> "\\mf" + Forte -> "\\f" + Fortissimo -> "\\ff" + FFF -> "\\fff" + FFFF -> "\\ffff" + FP -> "\\fp" + SFZ -> "\\sfz" + Begin_Crescendo -> "\\<" + Begin_Decrescendo -> "\\>" + End_Dynamic -> "\\!" + 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 ++ ")" + +-- note: the duration multiplier is *not* written +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_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 -> "~" + Above -> "^" + Below -> "_" + Text x -> ly_str x + CompositeAnnotation xs -> intercalate " " (map ly_annotation xs) + ReminderAccidental -> "" -- see ly_pitch + CautionaryAccidental -> "" -- see ly_pitch + +ly_bar :: Bar_T -> String +ly_bar b = + case b of + NormalBarline -> "|" + DoubleBarline -> "||" + LeftRepeatBarline -> "|:" + RightRepeatBarline -> ":|" + FinalBarline -> "|." + +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 + 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_music :: Music -> [String] +ly_music m = + case m of + Note p d aa -> [ly_pitch aa p, maybe "" ly_duration d] ++ + map ly_annotation aa + Chord xs d aa -> with_brackets ("<",">") (ly_music_l xs) ++ + [ly_duration d] ++ + map ly_annotation aa + Tremolo (x0,x1) n -> ["\\repeat", "\"tremolo\"", show n] ++ + with_braces (ly_music x0 ++ ly_music x1) + Rest d aa -> ["r", 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 -> ["\\skip", ly_duration d] + 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 o -> ["\\clef", ly_clef c o] + Time n -> ["\\time", ly_fraction n] + Key n a md -> ["\\key" + ,ly_note n ++ ly_alteration' a + ,ly_key_mode md] + Tempo d r -> ["\\tempo", ly_duration d, "=", show r] + Command x -> [ly_command x] + 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 ++ " "] + in case p of + (Part Nothing xs) -> with_braces (nm ++ ly_music (Join xs)) + (Part (Just txt) xs) -> brk (nm ++ mk_v xs ++ 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_layout :: Score_Settings -> [String] +ly_layout x = + let mk_i nm = printf "\\context { \\%s \\consists \"Instrument_name_engraver\"}" nm + is = unlines (map mk_i ["StaffGroup","ChoirStaff","GrandStaff"]) + in ["\\layout", "{" + ,if independent_time_signatures x + then unlines ly_independent_time_signatures + 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 concat (intersperse " " xs) + +ly_music_elem :: Music -> String +ly_music_elem = concat . intersperse " " . ly_music diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,11 @@ +hly - minimalist haskell lilypond + +A very lightweight embedding of the lilypond +typesetting model in haskell + + http://slavepianos.org/rd/?t=hly + http://haskell.org/ + http://lilypond.org/ + +(c) rohan drape, 2010-2011 + gpl, http://gnu.org/copyleft/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/hly.cabal b/hly.cabal new file mode 100644 --- /dev/null +++ b/hly.cabal @@ -0,0 +1,31 @@ +Name: hly +Version: 0.1 +Synopsis: Haskell LilyPond +Description: A very lightweight embedding of the lilypond + typesetting model in haskell +License: GPL +Category: Music +Copyright: (c) Rohan Drape, 2010-2011 +Author: Rohan Drape +Maintainer: rd@slavepianos.org +Stability: Experimental +Homepage: http://slavepianos.org/rd/?t=hly +Tested-With: GHC == 6.12.1 +Build-Type: Simple +Cabal-Version: >= 1.6 +Data-Files: README + +Library + Build-Depends: base == 4.*, + hmt + GHC-Options: -Wall -fwarn-tabs + Exposed-modules: Music.LilyPond.Light + Music.LilyPond.Light.Analysis + Music.LilyPond.Light.Constant + Music.LilyPond.Light.Constant.NoteName + Music.LilyPond.Light.Model + Music.LilyPond.Light.Output.LilyPond + +Source-Repository head + Type: darcs + Location: http://slavepianos.org/rd/sw/hly