hly (empty) → 0.1
raw patch · 9 files changed
+2524/−0 lines, 9 filesdep +basedep +hmtsetup-changed
Dependencies added: base, hmt
Files
- Music/LilyPond/Light.hs +638/−0
- Music/LilyPond/Light/Analysis.hs +623/−0
- Music/LilyPond/Light/Constant.hs +204/−0
- Music/LilyPond/Light/Constant/NoteName.hs +396/−0
- Music/LilyPond/Light/Model.hs +205/−0
- Music/LilyPond/Light/Output/LilyPond.hs +413/−0
- README +11/−0
- Setup.hs +3/−0
- hly.cabal +31/−0
+ Music/LilyPond/Light.hs view
@@ -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
+ Music/LilyPond/Light/Analysis.hs view
@@ -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+ _ -> []+
+ Music/LilyPond/Light/Constant.hs view
@@ -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 = ""}
+ Music/LilyPond/Light/Constant/NoteName.hs view
@@ -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
+ Music/LilyPond/Light/Model.hs view
@@ -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)
+ Music/LilyPond/Light/Output/LilyPond.hs view
@@ -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
+ README view
@@ -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/
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ hly.cabal view
@@ -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