X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fsong.scm;fp=scm%2Fsong.scm;h=171ef6e191d3c4d685124d0e9e2a3ed087e0adf8;hb=32a34dcef0c0041c6d62677487a380b5c8b85712;hp=9dbca9fd6286d7c1c8204075840737c8e4d287fc;hpb=f41973ff763d5972a85995b6d40c864281ec6714;p=lilypond.git diff --git a/scm/song.scm b/scm/song.scm index 9dbca9fd62..171ef6e191 100644 --- a/scm/song.scm +++ b/scm/song.scm @@ -19,14 +19,13 @@ ;;;; along with LilyPond. If not, see . -(define-module (scm song)) - -(use-modules (srfi srfi-1)) -(use-modules (ice-9 optargs)) -(use-modules (ice-9 receive)) - -(use-modules (lily)) -(use-modules (scm song-util)) +(define-module (scm song) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-39) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (lily) + #:use-module (scm song-util)) ;;; Configuration @@ -34,23 +33,23 @@ ;; The word to be sung in places where notes are played without lyrics. ;; If it is #f, the places without lyrics are omitted on the output. -(define-public *skip-word* "-skip-") +(define-public *skip-word* (make-parameter "-skip-")) ;; If true, use syllables in the Festival XML file. ;; If false, use whole words instead; this is necessary in languages like ;; English, were the phonetic form cannot be deduced from syllables well enough. -(define-public *syllabify* #f) +(define-public *syllabify* (make-parameter #f)) ;; Base Festival octave to which LilyPond notes are mapped. -(define-public *base-octave* 5) +(define-public *base-octave* (make-parameter 5)) ;; The resulting base octave is sum of *base-octave* and ;; *base-octave-shift*. This is done to work around a Festival bug ;; causing Festival to segfault or produce invalid pitch on higher pitches. ;(define *base-octave-shift* -2) -(define *base-octave-shift* 0) +(define *base-octave-shift* (make-parameter 0)) ;; The coeficient by which the notes just before \breath are shortened. -(define-public *breathe-shortage* 0.8) +(define-public *breathe-shortage* (make-parameter 0.8)) ;;; LilyPond interface @@ -91,9 +90,9 @@ ((= octave 0) "") ((> octave 0) - (make-uniform-array #\' octave)) + (make-string octave #\')) ((< octave 0) - (make-uniform-array #\, (- 0 octave))))) + (make-string (- octave) #\,)))) (pp-duration (note-duration object)) (if (> (note-joined object) 0) "-" "")))) ((rest? object) @@ -135,10 +134,7 @@ (define *tempo-compression* #f) (define (duration->number duration) - (let* ((log (ly:duration-log duration)) - (dots (ly:duration-dot-count duration)) - (factor (ly:duration-factor duration))) - (exact->inexact (* (expt 2 (- log)) (+ 1 (/ dots 2)) (/ (car factor) (cdr factor)))))) + (exact->inexact (ly:moment-main (ly:duration-length duration)))) (define (tempo->beats music) (let* ((tempo-spec (find-child-named music 'SequentialMusic)) @@ -162,7 +158,7 @@ (set! *default-tempo* (property-value (find-child tempo-spec (lambda (elt) (music-property? elt 'tempoWholesPerMinute))))) - (round (* tempo (expt 2 (+ 2 *base-octave-shift*))))))) + (round (* tempo (expt 2 (+ 2 (*base-octave-shift*)))))))) (defstruct music-context music @@ -215,12 +211,12 @@ (lambda (music) (cond ;; true lyrics - ((music-name? music 'EventChord) + ((music-name? music '(EventChord LyricEvent)) (let ((lyric-event (find-child-named music 'LyricEvent))) (push! (make-lyrics #:text (ly:music-property lyric-event 'text) #:duration (* (duration->number (ly:music-property lyric-event 'duration)) 4) - #:unfinished (and (not *syllabify*) (find-child-named music 'HyphenEvent)) + #:unfinished (and (not (*syllabify*)) (find-child-named music 'HyphenEvent)) #:ignore-melismata ignore-melismata #:context current-voice) lyrics-list)) @@ -375,7 +371,21 @@ (append (score-notes-note/rest-list last-result) (list rest-spec))) (add! (make-score-notes #:note/rest-list (list rest-spec)) result-list)))))) - #f) + (filter + (lambda (m) + (not (music-name? m '(RestEvent + NoteEvent + LyricEvent + MultiMeasureRestEvent)))) + (ly:music-property music 'elements))) + ((music-name? music '(RestEvent + NoteEvent + LyricEvent + MultiMeasureRestEvent)) + (make-music 'EventChord + 'elements + (cons music + (ly:music-property music 'articulations)))) ;; autobeaming change ((music-property? music 'autoBeaming) (set! autobeaming (property-value music)) @@ -385,19 +395,22 @@ (let ((change (if (property-value music) 1 -1))) (set! in-slur (+ in-slur change)) (if last-note-spec - (set-note-joined! last-note-spec (+ (note-joined last-note-spec) change))))) + (set-note-joined! last-note-spec (+ (note-joined last-note-spec) change)))) + #t) ;; tempo change ((music-property? music 'tempoWholesPerMinute) - (set! *tempo-compression* (ly:moment-div *default-tempo* (property-value music)))) + (set! *tempo-compression* (ly:moment-div *default-tempo* (property-value music))) + #t) ;; breathe ((music-name? music 'BreathingEvent) (if last-note-spec (let* ((note-duration (note-duration last-note-spec)) - (rest-spec (make-rest #:duration (* note-duration (- 1 *breathe-shortage*)) + (rest-spec (make-rest #:duration (* note-duration (- 1 (*breathe-shortage*))) #:origin (ly:music-property music 'origin)))) - (set-note-duration! last-note-spec (* note-duration *breathe-shortage*)) + (set-note-duration! last-note-spec (* note-duration (*breathe-shortage*))) (add! (make-score-notes #:note/rest-list (list rest-spec)) result-list)) - (warning music "\\\\breathe without previous note known"))) + (warning music "\\\\breathe without previous note known")) + #t) ;; anything else (else #f)))) @@ -603,7 +616,7 @@ last-verse (append (verse-notelist/rests last-verse) (list notelist/rest)))))) ((pair? notelist/rest) - (add! (make-verse #:text *skip-word* #:notelist/rests (list notelist/rest)) + (add! (make-verse #:text (*skip-word*) #:notelist/rests (list notelist/rest)) verse-list)) (else (error "Unreachable branch reached"))) @@ -662,7 +675,7 @@ ((< duration (- epsilon)) (warning (if (null? note-list) (safe-last consumed) (safe-car note-list)) "Skip misalignment: ~a ~a ~a ~a" context skip duration consumed))) - (values (if *skip-word* + (values (if (*skip-word*) consumed '()) note-list))) @@ -784,7 +797,7 @@ (octave (inexact->exact (floor (/ semitones 12)))) (tone (modulo semitones 12))) (format #f "~a~a" (car (assoc-get tone festival-note-mapping)) - (+ octave *base-octave* *base-octave-shift*)))) + (+ octave (*base-octave*) (*base-octave-shift*))))) (define (write-header port tempo) (let ((beats (or (tempo->beats tempo) 100)))