LSR: Update.
[lilypond.git] / scm / song.scm
blob8edacdf13c24d8b03d4888d5058ff0c9a3dfcc38
1 ;;; festival.scm --- Festival singing mode output
3 ;; Copyright (C) 2006, 2007 Brailcom, o.p.s.
5 ;; Author: Milan Zamazal <pdm@brailcom.org>
7 ;; COPYRIGHT NOTICE
9 ;; This program is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2 of the License, or
12 ;; (at your option) any later version.
14 ;; This program is distributed in the hope that it will be useful, but
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
16 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 ;; for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with this program; if not, write to the Free Software
21 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA.
24 (define-module (scm song))
26 (use-modules (srfi srfi-1))
27 (use-modules (ice-9 optargs))
28 (use-modules (ice-9 receive))
30 (use-modules (lily))
31 (use-modules (scm song-util))
34 ;;; Configuration
37 ;; The word to be sung in places where notes are played without lyrics.
38 ;; If it is #f, the places without lyrics are omitted on the output.
39 (define-public *skip-word* "-skip-")
41 ;; If true, use syllables in the Festival XML file.
42 ;; If false, use whole words instead; this is necessary in languages like
43 ;; English, were the phonetic form cannot be deduced from syllables well enough.
44 (define-public *syllabify* #f)
46 ;; Base Festival octave to which LilyPond notes are mapped.
47 (define-public *base-octave* 5)
48 ;; The resulting base octave is sum of *base-octave* and
49 ;; *base-octave-shift*.  This is done to work around a Festival bug
50 ;; causing Festival to segfault or produce invalid pitch on higher pitches.
51 ;(define *base-octave-shift* -2)
52 (define *base-octave-shift* 0)
54 ;; The coeficient by which the notes just before \breath are shortened.
55 (define-public *breathe-shortage* 0.8)
58 ;;; LilyPond interface
61 (define-public (output-file music tempo filename)
62   (if *debug*
63       (debug-enable 'backtrace))
64   (ly:message "Writing Festival XML file ~a..." filename)
65   (let ((port (open-output-file filename)))
66     (write-header port tempo)
67     (write-lyrics port music)
68     (write-footer port)
69     (close-port port))
70   #f)
73 ;;; Utility functions
76 (define pp-pitch-names '((0 . "c") (1 . "des") (2 . "d") (3 . "es") (4 . "e") (5 . "f")
77                          (6 . "ges") (7 . "g") (8 . "as") (9 . "a") (10 . "bes") (11 . "b")))
78 (define (pp object)
79   (cond
80    ((list? object)
81     (format #f "[~{~a ~}]" (map pp object)))
82    ((skip? object)
83     (format #f "skip(~a)" (skip-duration object)))
84    ((lyrics? object)
85     (format #f "~a(~a)~a" (lyrics-text object) (lyrics-duration object)
86             (if (lyrics-unfinished object) "-" "")))
87    ((note? object)
88     (let ((pitch (ly:pitch-semitones (note-pitch object))))
89       (format #f "~a~a~a~a"
90               (cdr (assoc (modulo pitch 12) pp-pitch-names))
91               (let ((octave (+ (inexact->exact (floor (/ pitch 12))) 1)))
92                 (cond
93                  ((= octave 0)
94                   "")
95                  ((> octave 0)
96                   (make-uniform-array #\' octave))
97                  ((< octave 0)
98                   (make-uniform-array #\, (- 0 octave)))))
99               (pp-duration (note-duration object))
100               (if (> (note-joined object) 0) "-" ""))))
101    ((rest? object)
102     (format #f "r~a" (pp-duration (rest-duration object))))
103    (else
104     object)))
106 (define (pp-duration duration)
107   (set! duration (/ 4 duration))
108   (if (< (abs (- duration (inexact->exact duration))) 0.0001)
109       (inexact->exact duration)
110       (/ (round (* duration 100)) 100)))
112 (define-public (warning object-with-origin message . args)
113   (let ((origin (cond
114                  ((not object-with-origin)
115                   #f)
116                  ((note? object-with-origin)
117                   (note-origin object-with-origin))
118                  ((rest? object-with-origin)
119                   (rest-origin object-with-origin))
120                  ((ly:input-location? object-with-origin)
121                   object-with-origin)
122                  ((ly:music? object-with-origin)
123                   (ly:music-property object-with-origin 'origin))
124                  (else
125                   (format #t "Minor programming error: ~a~%" object-with-origin)
126                   #f))))
127     (if origin
128         (ly:input-message origin "***Song Warning***")
129         (format #t "~%***Song Warning***"))
130     (apply ly:message message (map pp args))))
133 ;;; Analysis functions
136 (define *default-tempo* #f)
137 (define *tempo-compression* #f)
139 (define (duration->number duration)
140   (let* ((log (ly:duration-log duration))
141          (dots (ly:duration-dot-count duration))
142          (factor (ly:duration-factor duration)))
143     (exact->inexact (* (expt 2 (- log)) (+ 1 (/ dots 2)) (/ (car factor) (cdr factor))))))
145 (define (tempo->beats music)
146   (let* ((tempo-spec (or (find-child-named music 'MetronomeChangeEvent)
147                          (find-child-named music 'SequentialMusic)))
148          (tempo (cond
149                  ((not tempo-spec)
150                   #f)
151                  ((music-name? tempo-spec 'MetronomeChangeEvent)
152                   (* (ly:music-property tempo-spec 'metronome-count)
153                      (duration->number (ly:music-property tempo-spec 'tempo-unit))))
154                  ((music-name? tempo-spec 'SequentialMusic)
155                   (* (property-value
156                       (find-child tempo-spec (lambda (elt) (music-property? elt 'tempoUnitCount))))
157                      (duration->number
158                       (property-value
159                        (find-child tempo-spec (lambda (elt) (music-property? elt 'tempoUnitDuration)))))))
160                  (else
161                   (format #t "Programming error (tempo->beats): ~a~%" tempo-spec)))))
162     (debug-enable 'backtrace)
163     (if (and tempo (music-name? tempo-spec 'SequentialMusic))
164         (set! *default-tempo* (property-value
165                                (find-child tempo-spec (lambda (elt) (music-property? elt 'tempoWholesPerMinute))))))
166     (if tempo
167         (round (* tempo (expt 2 (+ 2 *base-octave-shift*))))
168         #f)))
170 (defstruct music-context
171   music
172   context)
174 (define (collect-lyrics-music music)
175   ;; Returns list of music-context instances.
176   (let ((music-context-list '()))
177     (process-music
178      music
179      (lambda (music*)
180        (cond
181         ((music-name? music* 'LyricCombineMusic)
182          (push! (make-music-context #:music music*
183                                               #:context (ly:music-property music* 'associated-context))
184                      music-context-list)
185          #t)
186         ((and (music-name? music* 'ContextSpeccedMusic)
187               (music-property-value? music* 'context-type 'Lyrics)
188               (not (find-child-named music* 'LyricCombineMusic)))
189          (let ((name-node (find-child music* (lambda (node) (music-property? node 'associatedVoice)))))
190            (if name-node
191                (push! (make-music-context #:music music* #:context (property-value name-node))
192                            music-context-list)))
193          #t)
194         (else
195          #f))))
196     (debug "Lyrics contexts" (reverse music-context-list))))
198 (defstruct lyrics
199   text
200   duration
201   unfinished
202   ignore-melismata
203   context)
205 (defstruct skip
206   duration
207   context)
209 (define (get-lyrics music context)
210   ;; Returns list of lyrics and skip instances.
211   (let ((lyrics-list '())
212         (next-ignore-melismata #f)
213         (ignore-melismata #f)
214         (next-current-voice context)
215         (current-voice context))
216     (process-music
217      music
218      (lambda (music)
219        (cond
220         ;; true lyrics
221         ((music-name? music 'EventChord)
222          (let ((lyric-event (find-child-named music 'LyricEvent)))
223            (push! (make-lyrics
224                         #:text (ly:music-property lyric-event 'text)
225                         #:duration (* (duration->number (ly:music-property lyric-event 'duration)) 4)
226                         #:unfinished (and (not *syllabify*) (find-child-named music 'HyphenEvent))
227                         #:ignore-melismata ignore-melismata
228                         #:context current-voice)
229                        lyrics-list))
230          ;; LilyPond delays applying settings
231          (set! ignore-melismata next-ignore-melismata)
232          (set! current-voice next-current-voice)
233          #t)
234         ;; skipping
235         ((music-name? music 'SkipMusic)
236          (push! (make-skip
237                       #:duration (* (duration->number (ly:music-property music 'duration)) 4)
238                       #:context current-voice)
239                      lyrics-list)
240          #t)
241         ;; parameter change
242         ((music-property? music 'ignoreMelismata)
243          (set! next-ignore-melismata (property-value music))
244          #t)
245         ((music-property? music 'associatedVoice)
246          (set! next-current-voice (property-value music))
247          #t)
248         ;; anything else
249         (else
250          #f))))
251     (debug "Raw lyrics" (reverse lyrics-list))))
253 (defstruct score-voice
254   context
255   elements ; list of score-* instances
256   )
258 (defstruct score-choice
259   lists ; of lists of score-* instances
260   (n-assigned 0) ; number of lists having a verse-block
261   )
263 (defstruct score-repetice
264   count ; number of repetitions
265   elements ; list of score-* instances
266   )
268 (defstruct score-notes
269   note/rest-list ; list of note and rest instances
270   (verse-block-list '()) ; lyrics attached to notes -- multiple elements are
271                          ; possible for multiple stanzas
272   )
274 (defstruct note
275   pitch
276   duration
277   joined ; to the next note
278   origin
279   )
280   
281 (defstruct rest
282   duration
283   origin
284   )
286 (define (get-notes music)
287   ;; Returns list of score-* instances.
288   (get-notes* music #t))
290 (define (get-notes* music autobeaming*)
291   ;; Returns list of score-* instances.
292   (let* ((result-list '())
293          (in-slur 0)
294          (autobeaming autobeaming*)
295          (last-note-spec #f))
296     (process-music
297      music
298      (lambda (music)
299        (cond
300         ;; context change
301         ((music-has-property? music 'context-id)
302          (let ((context (ly:music-property music 'context-id))
303                (children (music-elements music)))
304            (add! (make-score-voice #:context (debug "Changing context" context)
305                                              #:elements (append-map (lambda (elt)
306                                                                       (get-notes* elt autobeaming))
307                                                                     children))
308                       result-list))
309          #t)
310         ;; timing change
311         ((music-property? music 'timeSignatureFraction)
312          (let ((value (property-value music)))
313            (debug "Timing change" value)))
314         ;; simultaneous notes
315         ((music-name? music 'SimultaneousMusic)
316          (let ((simultaneous-lists (map (lambda (child)
317                                           (get-notes* child autobeaming))
318                                         (ly:music-property music 'elements))))
319            (debug "Simultaneous lists" simultaneous-lists)
320            (add! (make-score-choice #:lists simultaneous-lists) result-list))
321          #t)
322         ;; repetice
323         ((music-name? music 'VoltaRepeatedMusic)
324          (let ((repeat-count (ly:music-property music 'repeat-count))
325                (children (music-elements music)))
326            (add! (make-score-repetice #:count repeat-count
327                                                 #:elements (append-map
328                                                             (lambda (elt) (get-notes* elt autobeaming))
329                                                             children))
330                       result-list))
331          #t)
332         ;; a note or rest
333         ((or (music-name? music 'EventChord)
334              (music-name? music 'MultiMeasureRestMusic)) ; 2.10
335          (debug "Simple music event" music)
336          (if *tempo-compression*
337              (set! music (ly:music-compress (ly:music-deep-copy music) *tempo-compression*)))
338          (let ((note (find-child-named music 'NoteEvent))
339                (rest (if (music-name? music 'MultiMeasureRestMusic) ; 2.10
340                          music
341                          (or (find-child-named music 'RestEvent)
342                              (find-child-named music 'MultiMeasureRestEvent) ; 2.8
343                              ))))
344            (cond
345             (note
346              (debug "Note" note)
347              (let* ((pitch (ly:music-property note 'pitch))
348                     (duration (* (duration->number (ly:music-property note 'duration)) 4))
349                     (events (filter identity (list
350                                               (find-child-named music 'SlurEvent)
351                                               (find-child-named music 'ManualMelismaEvent)
352                                               (and (not autobeaming)
353                                                    (find-child-named music 'BeamEvent)))))
354                     (slur-start (length (filter (lambda (e) (music-property-value? e 'span-direction -1))
355                                                 events)))
356                     (slur-end (length (filter (lambda (e) (music-property-value? e 'span-direction 1))
357                                               events))))
358                (set! in-slur (+ in-slur slur-start (- slur-end)))
359                (let ((note-spec (make-note #:pitch pitch #:duration duration #:joined in-slur
360                                                 #:origin (ly:music-property note 'origin)))
361                      (last-result (and (not (null? result-list)) (last result-list))))
362                  (set! last-note-spec note-spec)
363                  (if (and last-result
364                           (score-notes? last-result))
365                      (set-score-notes-note/rest-list!
366                       last-result
367                       (append (score-notes-note/rest-list last-result) (list note-spec)))
368                      (add! (make-score-notes #:note/rest-list (list note-spec)) result-list)))))
369             (rest
370              (debug "Rest" rest)
371              (let* ((duration (* (duration->number (ly:music-property rest 'duration)) 4))
372                     (rest-spec (make-rest #:duration duration
373                                                #:origin (ly:music-property rest 'origin)))
374                     (last-result (and (not (null? result-list)) (last result-list))))
375                (if (and last-result
376                         (score-notes? last-result))
377                    (set-score-notes-note/rest-list! last-result
378                                                          (append (score-notes-note/rest-list last-result)
379                                                                  (list rest-spec)))
380                    (add! (make-score-notes #:note/rest-list (list rest-spec)) result-list))))))
381          #f)
382         ;; autobeaming change
383         ((music-property? music 'autoBeaming)
384          (set! autobeaming (property-value music))
385          #t)
386         ;; melisma change
387         ((music-property? music 'melismaBusy) ; 2.10
388          (let ((change (if (property-value music) 1 -1)))
389            (set! in-slur (+ in-slur change))
390            (if last-note-spec
391                (set-note-joined! last-note-spec (+ (note-joined last-note-spec) change)))))
392         ;; tempo change
393         ((music-property? music 'tempoWholesPerMinute)
394          (set! *tempo-compression* (ly:moment-div *default-tempo* (property-value music))))
395         ;; breathe
396         ((music-name? music 'BreathingEvent)
397          (if last-note-spec
398              (let* ((note-duration (note-duration last-note-spec))
399                     (rest-spec (make-rest #:duration (* note-duration (- 1 *breathe-shortage*))
400                                                #:origin (ly:music-property music 'origin))))
401                (set-note-duration! last-note-spec (* note-duration *breathe-shortage*))
402                (add! (make-score-notes #:note/rest-list (list rest-spec)) result-list))
403              (warning music "\\\\breathe without previous note known")))
404         ;; anything else
405         (else
406          #f))))
407     (debug "Raw notes" result-list)))
409 (defstruct verse-block ; lyrics for a given piece of music
410   verse-list
411   (fresh #t) ; if #t, this block hasn't been yet included in the final output
412   )
414 (defstruct parallel-blocks ; several parallel blocks (e.g. stanzas)
415   block-list ; list of verse-blocks
416   )
418 (defstruct sequential-blocks
419   block-list ; list of verse-blocks
420   )
422 (defstruct repeated-blocks
423   block-list ; list of verse-blocks
424   count ; number of repetitions
425   )
427 (defstruct verse ; 
428   text ; separate text element (syllable or word)
429   notelist/rests ; list of note lists (slurs) and rests
430   (unfinished #f) ; whether to be merged with the following verse
431   )
433 (define (find-lyrics-score score-list context accept-default)
434   ;; Returns score-* element of context or #f (if there's no such any).
435   (and (not (null? score-list))
436        (or (find-lyrics-score* (car score-list) context accept-default)
437            (find-lyrics-score (cdr score-list) context accept-default))))
439 (define (find-lyrics-score* score context accept-default)
440   (cond
441    ((and (score-voice? score)
442          (equal? (score-voice-context score) context))
443     score)
444    ((score-voice? score)
445     (find-lyrics-score (score-voice-elements score) context #f))
446    ((score-choice? score)
447     (letrec ((lookup (lambda (lists)
448                        (if (null? lists)
449                            #f
450                            (or (find-lyrics-score (car lists) context accept-default)
451                                (lookup (cdr lists)))))))
452       (lookup (score-choice-lists score))))
453    ((score-repetice? score)
454     (if accept-default
455         score
456         (find-lyrics-score (score-repetice-elements score) context accept-default)))
457    ((score-notes? score)
458     (if accept-default
459         score
460         #f))
461    (else
462     (error "Unknown score element" score))))
464 (define (insert-lyrics! lyrics/skip-list score-list context)
465   ;; Add verse-block-lists to score-list.
466   ;; Each processed score-notes instance must receive at most one block in each
467   ;; insert-lyrics! call.  (It can get other blocks if more pieces of
468   ;; lyrics are attached to the same score part.)
469   (let ((lyrics-score-list (find-lyrics-score score-list context #f)))
470     (debug "Lyrics+skip list" lyrics/skip-list)
471     (debug "Corresponding score-* list" score-list)
472     (if lyrics-score-list
473         (insert-lyrics*! lyrics/skip-list (list lyrics-score-list) context)
474         (warning #f "Lyrics context not found: ~a" context))))
476 (define (insert-lyrics*! lyrics/skip-list score-list context)
477   (debug "Processing lyrics" lyrics/skip-list)
478   (debug "Processing score" score-list)
479   (cond
480    ((and (null? lyrics/skip-list)
481          (null? score-list))
482     #f)
483    ((null? lyrics/skip-list)
484     (warning #f "Extra notes: ~a ~a" context score-list))
485    ((null? score-list)
486     (warning #f "Extra lyrics: ~a ~a" context lyrics/skip-list))
487    (else
488     (let* ((lyrics/skip (car lyrics/skip-list))
489            (lyrics-context ((if (lyrics? lyrics/skip) lyrics-context skip-context) lyrics/skip))
490            (score (car score-list)))
491       (cond
492        ((score-voice? score)
493         (let ((new-context (score-voice-context score)))
494           (if (equal? new-context lyrics-context)
495               (insert-lyrics*! lyrics/skip-list
496                                     (append (score-voice-elements score)
497                                             (if (null? (cdr score-list))
498                                                 '()
499                                                 (list (make-score-voice #:context context
500                                                                              #:elements (cdr score-list)))))
501                                     new-context)
502               (insert-lyrics*! lyrics/skip-list (cdr score-list) context))))
503        ((score-choice? score)
504         (let* ((lists* (score-choice-lists score))
505                (lists lists*)
506                (n-assigned (score-choice-n-assigned score))
507                (n 0)
508                (allow-default #f)
509                (score* #f))
510           (while (and (not score*)
511                       (not (null? lists)))
512             (set! score* (find-lyrics-score (car lists) lyrics-context allow-default))
513             (set! lists (cdr lists))
514             (if (not score*)
515                 (set! n (+ n 1)))
516             (if (and (null? lists)
517                      (not allow-default)
518                      (equal? lyrics-context context))
519                 (begin
520                   (set! allow-default #t)
521                   (set! n 0)
522                   (set! lists (score-choice-lists score)))))
523           (debug "Selected score" score*)
524           (if (and score*
525                    (>= n n-assigned))
526               (begin
527                 (if (> n n-assigned)
528                     (receive (assigned-elts unassigned-elts) (split-at lists* n-assigned)
529                       (set-score-choice-lists! score (append assigned-elts
530                                                                   (list (list-ref lists* n))
531                                                                   (take unassigned-elts (- n n-assigned))
532                                                                   lists))))
533                 (set-score-choice-n-assigned! score (+ n-assigned 1))))
534           (insert-lyrics*! lyrics/skip-list (append (if score* (list score*) '()) (cdr score-list)) context)))
535        ((score-repetice? score)
536         (insert-lyrics*! lyrics/skip-list
537                               (append (score-repetice-elements score) (cdr score-list)) context))
538        ((score-notes? score)
539         ;; This is the only part which actually attaches the processed lyrics.
540         ;; The subsequent calls return verses which we collect into a verse block.
541         ;; We add the block to the score element.
542         (if (equal? lyrics-context context)
543             (set! lyrics/skip-list (really-insert-lyrics! lyrics/skip-list score context)))
544         (insert-lyrics*! lyrics/skip-list (cdr score-list) context))
545        (else
546         (error "Unknown score element in lyrics processing" score)))))))
548 (define (really-insert-lyrics! lyrics/skip-list score context)
549   ;; Return new lyrics/skip-list.
550   ;; Score is modified by side effect.
551   (debug "Assigning notes" score)
552   (let ((note-list (score-notes-note/rest-list score))
553         (unfinished-verse #f)
554         (verse-list '()))
555     (while (not (null? note-list))
556       (if (null? lyrics/skip-list)
557           (let ((final-rests '()))
558             (while (and (not (null? note-list))
559                         (rest? (car note-list)))
560               (push! (car note-list) final-rests)
561               (set! note-list (cdr note-list)))
562             (if (not (null? final-rests))
563                 (set! verse-list (append verse-list
564                                          (list (make-verse #:text ""
565                                                                 #:notelist/rests (reverse! final-rests))))))
566             (if (not (null? note-list))
567                 (begin
568                   (warning (car note-list) "Missing lyrics: ~a ~a" context note-list)
569                   (set! note-list '()))))
570           (let ((lyrics/skip (car lyrics/skip-list)))
571             (receive (notelist/rest note-list*) (if (lyrics? lyrics/skip)
572                                                     (consume-lyrics-notes lyrics/skip note-list context)
573                                                     (consume-skip-notes lyrics/skip note-list context))
574               (debug "Consumed notes" (list lyrics/skip notelist/rest))
575               (set! note-list note-list*)
576               (cond
577                ((null? notelist/rest)
578                 #f)
579                ;; Lyrics
580                ((and (lyrics? lyrics/skip)
581                      unfinished-verse)
582                 (set-verse-text!
583                  unfinished-verse
584                  (string-append (verse-text unfinished-verse) (lyrics-text lyrics/skip)))
585                 (set-verse-notelist/rests!
586                  unfinished-verse
587                  (append (verse-notelist/rests unfinished-verse) (list notelist/rest)))
588                 (if (not (lyrics-unfinished lyrics/skip))
589                     (set! unfinished-verse #f)))
590                ((lyrics? lyrics/skip)
591                 (let ((verse (make-verse #:text (if (rest? notelist/rest)
592                                                          ""
593                                                          (lyrics-text lyrics/skip))
594                                               #:notelist/rests (list notelist/rest))))
595                   (add! verse verse-list)
596                   (set! unfinished-verse (if (lyrics-unfinished lyrics/skip) verse #f))))
597                ;; Skip
598                ((skip? lyrics/skip)
599                 (cond
600                  ((rest? notelist/rest)
601                   (if (null? verse-list)
602                       (set! verse-list (list (make-verse #:text ""
603                                                               #:notelist/rests (list notelist/rest))))
604                       (let ((last-verse (last verse-list)))
605                         (set-verse-notelist/rests!
606                          last-verse
607                          (append (verse-notelist/rests last-verse) (list notelist/rest))))))
608                  ((pair? notelist/rest)
609                   (add! (make-verse #:text *skip-word* #:notelist/rests (list notelist/rest))
610                              verse-list))
611                  (else
612                   (error "Unreachable branch reached")))
613                 (set! unfinished-verse #f)))
614               (if (not (rest? notelist/rest))
615                   (set! lyrics/skip-list (cdr lyrics/skip-list)))))))
616     (if unfinished-verse
617         (set-verse-unfinished! unfinished-verse #t))
618     (set-score-notes-verse-block-list!
619      score
620      (append (score-notes-verse-block-list score)
621              (list (make-verse-block #:verse-list verse-list)))))
622   lyrics/skip-list)
624 (define (consume-lyrics-notes lyrics note-list context)
625   ;; Returns list of note instances + new note-list.
626   (assert (lyrics? lyrics))
627   (if (and (not (null? note-list))
628            (rest? (car note-list)))
629       (values (car note-list) (cdr note-list))
630       (let ((ignore-melismata (lyrics-ignore-melismata lyrics))
631             (join #t)
632             (consumed '()))
633         (while (and join
634                     (not (null? note-list)))
635           (let ((note (car note-list)))
636             (push! note consumed)
637             (let ((note-slur (note-joined note)))
638               (if (< note-slur 0)
639                   (warning note "Slur underrun"))
640               (set! join (and (not ignore-melismata) (> note-slur 0)))))
641           (set! note-list (cdr note-list)))
642         (if join
643             (warning (safe-car (if (null? note-list) consumed note-list))
644                      "Unfinished slur: ~a ~a" context consumed))
645         (values (reverse consumed) note-list))))
646   
647 (define (consume-skip-notes skip note-list context)
648   ;; Returns either note list (skip word defined) or rest instance (no skip word) + new note-list.
649   (assert (skip? skip))
650   (let ((duration (skip-duration skip))
651         (epsilon 0.001)
652         (consumed '()))
653     (while (and (> duration epsilon)
654                 (not (null? note-list)))
655       (let ((note (car note-list)))
656         (assert (note? note))
657         (push! note consumed)
658         (set! duration (- duration (note-duration note))))
659       (set! note-list (cdr note-list)))
660     (set! consumed (reverse! consumed))
661     (cond
662      ((> duration epsilon)
663       (warning (if (null? note-list) (safe-last consumed) (safe-car note-list))
664                     "Excessive skip: ~a ~a ~a ~a" context skip duration consumed))
665      ((< duration (- epsilon))
666       (warning (if (null? note-list) (safe-last consumed) (safe-car note-list))
667                     "Skip misalignment: ~a ~a ~a ~a" context skip duration consumed)))
668     (values (if *skip-word*
669                 consumed
670                 '())
671             note-list)))
673 (define (extract-verse-blocks score)
674   ;; Returns list of blocks and parallel blocks.
675   (debug "Extracting verse blocks" score)
676   (cond
677    ((score-voice? score)
678     (append-map extract-verse-blocks (score-voice-elements score)))
679    ((score-choice? score)
680     (list (make-parallel-blocks
681            #:block-list (map (lambda (block-list)
682                                (make-sequential-blocks
683                                 #:block-list (append-map extract-verse-blocks block-list)))
684                              (score-choice-lists score)))))
685    ((score-repetice? score)
686     (list (make-repeated-blocks #:count (score-repetice-count score)
687                                      #:block-list (append-map extract-verse-blocks
688                                                               (score-repetice-elements score)))))
689    ((score-notes? score)
690     (list (make-parallel-blocks #:block-list (score-notes-verse-block-list score))))
691    (else
692     (error "Invalid score element" score))))
694 (define (extract-verses score-list)
695   ;; Returns (final) list of verses.
696   ;; The primary purpose of this routine is to build complete stanzas from
697   ;; lists of verse blocks.
698   ;; Extract verse-blocks and process them until no unprocessed stanzas remain.
699   (debug "Final score list" score-list)
700   (let ((verse-block-list (debug "Verse blocks" (append-map extract-verse-blocks score-list))))
701     (letrec ((combine (lambda (lst-1 lst-2)
702                          (debug "Combining lists" (list lst-1 lst-2))
703                          (if (null? lst-2)
704                              lst-1
705                              (let ((diff (- (length lst-1) (length lst-2))))
706                                (if (< diff 0)
707                                    (let ((last-elt (last lst-1)))
708                                      (while (< diff 0)
709                                        (add! last-elt lst-1)
710                                        (set! diff (+ diff 1))))
711                                    (let ((last-elt (last lst-2)))
712                                      (while (> diff 0)
713                                        (add! last-elt lst-2)
714                                        (set! diff (- diff 1)))))
715                                (debug "Combined" (map append lst-1 lst-2))))))
716              (expand* (lambda (block)
717                         (cond
718                          ((parallel-blocks? block)
719                           (append-map (lambda (block) (expand (list block)))
720                                       (parallel-blocks-block-list block)))
721                          ((sequential-blocks? block)
722                           (expand (sequential-blocks-block-list block)))
723                          ((repeated-blocks? block)
724                           ;; Only simple repetice without nested parallel sections is supported.
725                           (let ((count (repeated-blocks-count block))
726                                 (expanded (expand (repeated-blocks-block-list block)))
727                                 (expanded* '()))
728                             (while (not (null? expanded))
729                               (let ((count* count)
730                                     (item '()))
731                                 (while (and (> count* 0) (not (null? expanded)))
732                                   (set! item (append item (car expanded)))
733                                   (set! expanded (cdr expanded))
734                                   (set! count* (- count* 1)))
735                                 (push! item expanded*)))
736                             (reverse expanded*)))
737                          (else
738                           (list (list block))))))
739              (expand (lambda (block-list)
740                        (debug "Expanding list" block-list)
741                        (if (null? block-list)
742                            '()
743                            (debug "Expanded" (combine (expand* (car block-list))
744                                                            (expand (cdr block-list)))))))
745              (merge (lambda (verse-list)
746                       (cond
747                        ((null? verse-list)
748                         '())
749                        ((verse-unfinished (car verse-list))
750                         (let ((verse-1 (first verse-list))
751                               (verse-2 (second verse-list)))
752                           (merge (cons (make-verse #:text (string-append (verse-text verse-1)
753                                                                               (verse-text verse-2))
754                                                         #:notelist/rests (append (verse-notelist/rests verse-1)
755                                                                                  (verse-notelist/rests verse-2))
756                                                         #:unfinished (verse-unfinished verse-2))
757                                        (cddr verse-list)))))
758                        (else
759                         (cons (car verse-list) (merge (cdr verse-list))))))))
760       (debug "Final verses" (merge (append-map (lambda (lst) (append-map verse-block-verse-list lst))
761                                                     (expand verse-block-list)))))))
763 (define (handle-music music)
764   ;; Returns list of verses.
765   ;; The main analysis function.
766   (if *debug*
767       (display-scheme-music music))
768   (let ((score-list (debug "Final raw notes" (get-notes music)))
769         (music-context-list (collect-lyrics-music music)))
770     (for-each (lambda (music-context)
771                 (let ((context (music-context-context music-context)))
772                   (set! *tempo-compression* #f)
773                   (insert-lyrics! (get-lyrics (music-context-music music-context) context)
774                                   score-list context)
775                   (debug "Final score list" score-list)))
776               music-context-list)    
777     (extract-verses score-list)))
780 ;;; Output
783 (define festival-note-mapping '((0 "C") (1 "C#") (2 "D") (3 "D#") (4 "E") (5 "F") (6 "F#")
784                                      (7 "G") (8 "G#") (9 "A") (10 "A#") (11 "B")))
785 (define (festival-pitch pitch)
786   (let* ((semitones (ly:pitch-semitones pitch))
787          (octave (inexact->exact (floor (/ semitones 12))))
788          (tone (modulo semitones 12)))
789     (format #f "~a~a" (cadr (assoc tone festival-note-mapping))
790             (+ octave *base-octave* *base-octave-shift*))))
792 (define (write-header port tempo)
793   (let ((beats (or (tempo->beats tempo) 100)))
794     (format port "<?xml version=\"1.0\"?>
795 <!DOCTYPE SINGING PUBLIC \"-//SINGING//DTD SINGING mark up//EN\" \"Singing.v0_1.dtd\" []>
796 <SINGING BPM=\"~d\">
797 " beats)))
799 (define (write-footer port)
800   (format port "</SINGING>~%"))
802 (define (write-lyrics port music)
803   (let ((rest-dur 0))
804     (for-each (lambda (verse)
805                 (let ((text (verse-text verse))
806                       (note/rest-list (verse-notelist/rests verse)))
807                   (receive (rest-list note-listlist) (partition rest? note/rest-list)
808                     (debug "Rest list" rest-list)
809                     (debug "Note list" note-listlist)
810                     (if (not (null? rest-list))
811                         (set! rest-dur (+ rest-dur (apply + (map rest-duration rest-list)))))
812                     (if (not (null? note-listlist))
813                         (begin
814                           (if (> rest-dur 0)
815                               (begin
816                                 (write-rest-element port rest-dur)
817                                 (set! rest-dur 0)))
818                           (write-lyrics-element port text note-listlist))))))
819               (handle-music music))
820     (if (> rest-dur 0)
821         (write-rest-element port rest-dur))))
823 (define (write-lyrics-element port text slur-list)
824   (let ((fmt "~{~{~a~^+~}~^,~}")
825         (transform (lambda (function)
826                      (map (lambda (slur)
827                             (let ((rests (filter rest? slur)))
828                               (if (not (null? rests))
829                                   (begin
830                                     (warning (car rests) "Rests in a slur: ~a" slur)
831                                     (set! slur (remove rest? slur)))))
832                             (map function slur))
833                           slur-list))))
834     (format port "<DURATION BEATS=\"~@?\"><PITCH NOTE=\"~@?\">~a</PITCH></DURATION>~%"
835             fmt (transform note-duration)
836             fmt (transform (compose festival-pitch note-pitch))
837             text)))
839 (define (write-rest-element port duration)
840   (format port "<REST BEATS=\"~a\"></REST>~%" duration))