1 ;;;; song.scm --- Festival singing mode output
3 ;;;; This file is part of LilyPond, the GNU music typesetter.
5 ;;;; Copyright (C) 2006, 2007 Brailcom, o.p.s.
6 ;;;; Author: Milan Zamazal <pdm@brailcom.org>
8 ;;;; LilyPond is free software: you can redistribute it and/or modify
9 ;;;; it under the terms of the GNU General Public License as published by
10 ;;;; the Free Software Foundation, either version 3 of the License, or
11 ;;;; (at your option) any later version.
13 ;;;; LilyPond is distributed in the hope that it will be useful,
14 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;;; GNU General Public License for more details.
18 ;;;; You should have received a copy of the GNU General Public License
19 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
22 (define-module (scm song)
23 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-39)
25 #:use-module (ice-9 optargs)
26 #:use-module (ice-9 receive)
28 #:use-module (scm song-util))
34 ;; The word to be sung in places where notes are played without lyrics.
35 ;; If it is #f, the places without lyrics are omitted on the output.
36 (define-public *skip-word* (make-parameter "-skip-"))
38 ;; If true, use syllables in the Festival XML file.
39 ;; If false, use whole words instead; this is necessary in languages like
40 ;; English, were the phonetic form cannot be deduced from syllables well enough.
41 (define-public *syllabify* (make-parameter #f))
43 ;; Base Festival octave to which LilyPond notes are mapped.
44 (define-public *base-octave* (make-parameter 5))
45 ;; The resulting base octave is sum of *base-octave* and
46 ;; *base-octave-shift*. This is done to work around a Festival bug
47 ;; causing Festival to segfault or produce invalid pitch on higher pitches.
48 ;(define *base-octave-shift* -2)
49 (define *base-octave-shift* (make-parameter 0))
51 ;; The coeficient by which the notes just before \breath are shortened.
52 (define-public *breathe-shortage* (make-parameter 0.8))
55 ;;; LilyPond interface
58 (define-public (output-file music tempo filename)
60 (debug-enable 'backtrace))
61 (ly:message "Writing Festival XML file ~a..." filename)
62 (let ((port (open-output-file filename)))
63 (write-header port tempo)
64 (write-lyrics port music)
73 (define pp-pitch-names '((0 . "c") (1 . "des") (2 . "d") (3 . "es") (4 . "e") (5 . "f")
74 (6 . "ges") (7 . "g") (8 . "as") (9 . "a") (10 . "bes") (11 . "b")))
78 (format #f "[~{~a ~}]" (map pp object)))
80 (format #f "skip(~a)" (skip-duration object)))
82 (format #f "~a(~a)~a" (lyrics-text object) (lyrics-duration object)
83 (if (lyrics-unfinished object) "-" "")))
85 (let ((pitch (ly:pitch-semitones (note-pitch object))))
87 (assoc-get (modulo pitch 12) pp-pitch-names)
88 (let ((octave (+ (inexact->exact (floor (/ pitch 12))) 1)))
93 (make-uniform-array #\' octave))
95 (make-uniform-array #\, (- 0 octave)))))
96 (pp-duration (note-duration object))
97 (if (> (note-joined object) 0) "-" ""))))
99 (format #f "r~a" (pp-duration (rest-duration object))))
103 (define (pp-duration duration)
104 (set! duration (/ 4 duration))
105 (if (< (abs (- duration (inexact->exact duration))) 0.0001)
106 (inexact->exact duration)
107 (/ (round (* duration 100)) 100)))
109 (define-public (warning object-with-origin message . args)
111 ((not object-with-origin)
113 ((note? object-with-origin)
114 (note-origin object-with-origin))
115 ((rest? object-with-origin)
116 (rest-origin object-with-origin))
117 ((ly:input-location? object-with-origin)
119 ((ly:music? object-with-origin)
120 (ly:music-property object-with-origin 'origin))
122 (format #t "Minor programming error: ~a~%" object-with-origin)
125 (ly:input-message origin "***Song Warning***")
126 (format #t "~%***Song Warning***"))
127 (apply ly:message message (map pp args))))
130 ;;; Analysis functions
133 (define *default-tempo* #f)
134 (define *tempo-compression* #f)
136 (define (duration->number duration)
137 (let* ((log (ly:duration-log duration))
138 (dots (ly:duration-dot-count duration))
139 (factor (ly:duration-factor duration)))
140 (exact->inexact (* (expt 2 (- log)) (+ 1 (/ dots 2)) (/ (car factor) (cdr factor))))))
142 (define (tempo->beats music)
143 (let* ((tempo-spec (find-child-named music 'SequentialMusic))
146 (let ((tempo-event (find-child-named tempo-spec
149 (let ((count (ly:music-property tempo-event
152 (round (/ (+ (car count) (cdr count)) 2))
155 (ly:music-property tempo-event 'tempo-unit)))))))
157 (format #t "Programming error (tempo->beats): ~a~%"
159 (debug-enable 'backtrace)
161 (set! *default-tempo* (property-value
162 (find-child tempo-spec (lambda (elt)
163 (music-property? elt 'tempoWholesPerMinute)))))
164 (round (* tempo (expt 2 (+ 2 (*base-octave-shift*))))))))
166 (defstruct music-context
170 (define (collect-lyrics-music music)
171 ;; Returns list of music-context instances.
172 (let ((music-context-list '()))
177 ((music-name? music* 'LyricCombineMusic)
178 (push! (make-music-context #:music music*
179 #:context (ly:music-property music* 'associated-context))
182 ((and (music-name? music* 'ContextSpeccedMusic)
183 (music-property-value? music* 'context-type 'Lyrics)
184 (not (find-child-named music* 'LyricCombineMusic)))
185 (let ((name-node (find-child music* (lambda (node) (music-property? node 'associatedVoice)))))
187 (push! (make-music-context #:music music* #:context (property-value name-node))
188 music-context-list)))
192 (debug "Lyrics contexts" (reverse music-context-list))))
205 (define (get-lyrics music context)
206 ;; Returns list of lyrics and skip instances.
207 (let ((lyrics-list '())
208 (next-ignore-melismata #f)
209 (ignore-melismata #f)
210 (next-current-voice context)
211 (current-voice context))
217 ((music-name? music 'EventChord)
218 (let ((lyric-event (find-child-named music 'LyricEvent)))
220 #:text (ly:music-property lyric-event 'text)
221 #:duration (* (duration->number (ly:music-property lyric-event 'duration)) 4)
222 #:unfinished (and (not (*syllabify*)) (find-child-named music 'HyphenEvent))
223 #:ignore-melismata ignore-melismata
224 #:context current-voice)
226 ;; LilyPond delays applying settings
227 (set! ignore-melismata next-ignore-melismata)
228 (set! current-voice next-current-voice)
231 ((music-name? music 'SkipMusic)
233 #:duration (* (duration->number (ly:music-property music 'duration)) 4)
234 #:context current-voice)
238 ((music-property? music 'ignoreMelismata)
239 (set! next-ignore-melismata (property-value music))
241 ((music-property? music 'associatedVoice)
242 (set! next-current-voice (property-value music))
247 (debug "Raw lyrics" (reverse lyrics-list))))
249 (defstruct score-voice
251 elements ; list of score-* instances
254 (defstruct score-choice
255 lists ; of lists of score-* instances
256 (n-assigned 0) ; number of lists having a verse-block
259 (defstruct score-repetice
260 count ; number of repetitions
261 elements ; list of score-* instances
264 (defstruct score-notes
265 note/rest-list ; list of note and rest instances
266 (verse-block-list '()) ; lyrics attached to notes -- multiple elements are
267 ; possible for multiple stanzas
273 joined ; to the next note
282 (define (get-notes music)
283 ;; Returns list of score-* instances.
284 (get-notes* music #t))
286 (define (get-notes* music autobeaming*)
287 ;; Returns list of score-* instances.
288 (let* ((result-list '())
290 (autobeaming autobeaming*)
297 ((music-has-property? music 'context-id)
298 (let ((context (ly:music-property music 'context-id))
299 (children (music-elements music)))
300 (add! (make-score-voice #:context (debug "Changing context" context)
301 #:elements (append-map (lambda (elt)
302 (get-notes* elt autobeaming))
307 ((music-property? music 'timeSignatureFraction)
308 (let ((value (property-value music)))
309 (debug "Timing change" value)))
310 ;; simultaneous notes
311 ((music-name? music 'SimultaneousMusic)
312 (let ((simultaneous-lists (map (lambda (child)
313 (get-notes* child autobeaming))
314 (ly:music-property music 'elements))))
315 (debug "Simultaneous lists" simultaneous-lists)
316 (add! (make-score-choice #:lists simultaneous-lists) result-list))
319 ((music-name? music 'VoltaRepeatedMusic)
320 (let ((repeat-count (ly:music-property music 'repeat-count))
321 (children (music-elements music)))
322 (add! (make-score-repetice #:count repeat-count
323 #:elements (append-map
324 (lambda (elt) (get-notes* elt autobeaming))
329 ((or (music-name? music 'EventChord)
330 (music-name? music 'MultiMeasureRestMusic)) ; 2.10
331 (debug "Simple music event" music)
332 (if *tempo-compression*
333 (set! music (ly:music-compress (ly:music-deep-copy music) *tempo-compression*)))
334 (let ((note (find-child-named music 'NoteEvent))
335 (rest (if (music-name? music 'MultiMeasureRestMusic) ; 2.10
337 (or (find-child-named music 'RestEvent)
338 (find-child-named music 'MultiMeasureRestEvent) ; 2.8
343 (let* ((pitch (ly:music-property note 'pitch))
344 (duration (* (duration->number (ly:music-property note 'duration)) 4))
345 (events (filter identity (list
346 (find-child-named music 'SlurEvent)
347 (find-child-named music 'ManualMelismaEvent)
348 (and (not autobeaming)
349 (find-child-named music 'BeamEvent)))))
350 (slur-start (length (filter (lambda (e) (music-property-value? e 'span-direction -1))
352 (slur-end (length (filter (lambda (e) (music-property-value? e 'span-direction 1))
354 (set! in-slur (+ in-slur slur-start (- slur-end)))
355 (let ((note-spec (make-note #:pitch pitch #:duration duration #:joined in-slur
356 #:origin (ly:music-property note 'origin)))
357 (last-result (and (not (null? result-list)) (last result-list))))
358 (set! last-note-spec note-spec)
360 (score-notes? last-result))
361 (set-score-notes-note/rest-list!
363 (append (score-notes-note/rest-list last-result) (list note-spec)))
364 (add! (make-score-notes #:note/rest-list (list note-spec)) result-list)))))
367 (let* ((duration (* (duration->number (ly:music-property rest 'duration)) 4))
368 (rest-spec (make-rest #:duration duration
369 #:origin (ly:music-property rest 'origin)))
370 (last-result (and (not (null? result-list)) (last result-list))))
372 (score-notes? last-result))
373 (set-score-notes-note/rest-list! last-result
374 (append (score-notes-note/rest-list last-result)
376 (add! (make-score-notes #:note/rest-list (list rest-spec)) result-list))))))
378 ;; autobeaming change
379 ((music-property? music 'autoBeaming)
380 (set! autobeaming (property-value music))
383 ((music-property? music 'melismaBusy) ; 2.10
384 (let ((change (if (property-value music) 1 -1)))
385 (set! in-slur (+ in-slur change))
387 (set-note-joined! last-note-spec (+ (note-joined last-note-spec) change)))))
389 ((music-property? music 'tempoWholesPerMinute)
390 (set! *tempo-compression* (ly:moment-div *default-tempo* (property-value music))))
392 ((music-name? music 'BreathingEvent)
394 (let* ((note-duration (note-duration last-note-spec))
395 (rest-spec (make-rest #:duration (* note-duration (- 1 (*breathe-shortage*)))
396 #:origin (ly:music-property music 'origin))))
397 (set-note-duration! last-note-spec (* note-duration (*breathe-shortage*)))
398 (add! (make-score-notes #:note/rest-list (list rest-spec)) result-list))
399 (warning music "\\\\breathe without previous note known")))
403 (debug "Raw notes" result-list)))
405 (defstruct verse-block ; lyrics for a given piece of music
407 (fresh #t) ; if #t, this block hasn't been yet included in the final output
410 (defstruct parallel-blocks ; several parallel blocks (e.g. stanzas)
411 block-list ; list of verse-blocks
414 (defstruct sequential-blocks
415 block-list ; list of verse-blocks
418 (defstruct repeated-blocks
419 block-list ; list of verse-blocks
420 count ; number of repetitions
424 text ; separate text element (syllable or word)
425 notelist/rests ; list of note lists (slurs) and rests
426 (unfinished #f) ; whether to be merged with the following verse
429 (define (find-lyrics-score score-list context accept-default)
430 ;; Returns score-* element of context or #f (if there's no such any).
431 (and (not (null? score-list))
432 (or (find-lyrics-score* (car score-list) context accept-default)
433 (find-lyrics-score (cdr score-list) context accept-default))))
435 (define (find-lyrics-score* score context accept-default)
437 ((and (score-voice? score)
438 (equal? (score-voice-context score) context))
440 ((score-voice? score)
441 (find-lyrics-score (score-voice-elements score) context #f))
442 ((score-choice? score)
443 (letrec ((lookup (lambda (lists)
446 (or (find-lyrics-score (car lists) context accept-default)
447 (lookup (cdr lists)))))))
448 (lookup (score-choice-lists score))))
449 ((score-repetice? score)
452 (find-lyrics-score (score-repetice-elements score) context accept-default)))
453 ((score-notes? score)
458 (error "Unknown score element" score))))
460 (define (insert-lyrics! lyrics/skip-list score-list context)
461 ;; Add verse-block-lists to score-list.
462 ;; Each processed score-notes instance must receive at most one block in each
463 ;; insert-lyrics! call. (It can get other blocks if more pieces of
464 ;; lyrics are attached to the same score part.)
465 (let ((lyrics-score-list (find-lyrics-score score-list context #f)))
466 (debug "Lyrics+skip list" lyrics/skip-list)
467 (debug "Corresponding score-* list" score-list)
468 (if lyrics-score-list
469 (insert-lyrics*! lyrics/skip-list (list lyrics-score-list) context)
470 (warning #f "Lyrics context not found: ~a" context))))
472 (define (insert-lyrics*! lyrics/skip-list score-list context)
473 (debug "Processing lyrics" lyrics/skip-list)
474 (debug "Processing score" score-list)
476 ((and (null? lyrics/skip-list)
479 ((null? lyrics/skip-list)
480 (warning #f "Extra notes: ~a ~a" context score-list))
482 (warning #f "Extra lyrics: ~a ~a" context lyrics/skip-list))
484 (let* ((lyrics/skip (car lyrics/skip-list))
485 (lyrics-context ((if (lyrics? lyrics/skip) lyrics-context skip-context) lyrics/skip))
486 (score (car score-list)))
488 ((score-voice? score)
489 (let ((new-context (score-voice-context score)))
490 (if (equal? new-context lyrics-context)
491 (insert-lyrics*! lyrics/skip-list
492 (append (score-voice-elements score)
493 (if (null? (cdr score-list))
495 (list (make-score-voice #:context context
496 #:elements (cdr score-list)))))
498 (insert-lyrics*! lyrics/skip-list (cdr score-list) context))))
499 ((score-choice? score)
500 (let* ((lists* (score-choice-lists score))
502 (n-assigned (score-choice-n-assigned score))
506 (while (and (not score*)
508 (set! score* (find-lyrics-score (car lists) lyrics-context allow-default))
509 (set! lists (cdr lists))
512 (if (and (null? lists)
514 (equal? lyrics-context context))
516 (set! allow-default #t)
518 (set! lists (score-choice-lists score)))))
519 (debug "Selected score" score*)
524 (receive (assigned-elts unassigned-elts) (split-at lists* n-assigned)
525 (set-score-choice-lists! score (append assigned-elts
526 (list (list-ref lists* n))
527 (take unassigned-elts (- n n-assigned))
529 (set-score-choice-n-assigned! score (+ n-assigned 1))))
530 (insert-lyrics*! lyrics/skip-list (append (if score* (list score*) '()) (cdr score-list)) context)))
531 ((score-repetice? score)
532 (insert-lyrics*! lyrics/skip-list
533 (append (score-repetice-elements score) (cdr score-list)) context))
534 ((score-notes? score)
535 ;; This is the only part which actually attaches the processed lyrics.
536 ;; The subsequent calls return verses which we collect into a verse block.
537 ;; We add the block to the score element.
538 (if (equal? lyrics-context context)
539 (set! lyrics/skip-list (really-insert-lyrics! lyrics/skip-list score context)))
540 (insert-lyrics*! lyrics/skip-list (cdr score-list) context))
542 (error "Unknown score element in lyrics processing" score)))))))
544 (define (really-insert-lyrics! lyrics/skip-list score context)
545 ;; Return new lyrics/skip-list.
546 ;; Score is modified by side effect.
547 (debug "Assigning notes" score)
548 (let ((note-list (score-notes-note/rest-list score))
549 (unfinished-verse #f)
551 (while (not (null? note-list))
552 (if (null? lyrics/skip-list)
553 (let ((final-rests '()))
554 (while (and (not (null? note-list))
555 (rest? (car note-list)))
556 (push! (car note-list) final-rests)
557 (set! note-list (cdr note-list)))
558 (if (not (null? final-rests))
559 (set! verse-list (append verse-list
560 (list (make-verse #:text ""
561 #:notelist/rests (reverse! final-rests))))))
562 (if (not (null? note-list))
564 (warning (car note-list) "Missing lyrics: ~a ~a" context note-list)
565 (set! note-list '()))))
566 (let ((lyrics/skip (car lyrics/skip-list)))
567 (receive (notelist/rest note-list*) (if (lyrics? lyrics/skip)
568 (consume-lyrics-notes lyrics/skip note-list context)
569 (consume-skip-notes lyrics/skip note-list context))
570 (debug "Consumed notes" (list lyrics/skip notelist/rest))
571 (set! note-list note-list*)
573 ((null? notelist/rest)
576 ((and (lyrics? lyrics/skip)
580 (string-append (verse-text unfinished-verse) (lyrics-text lyrics/skip)))
581 (set-verse-notelist/rests!
583 (append (verse-notelist/rests unfinished-verse) (list notelist/rest)))
584 (if (not (lyrics-unfinished lyrics/skip))
585 (set! unfinished-verse #f)))
586 ((lyrics? lyrics/skip)
587 (let ((verse (make-verse #:text (if (rest? notelist/rest)
589 (lyrics-text lyrics/skip))
590 #:notelist/rests (list notelist/rest))))
591 (add! verse verse-list)
592 (set! unfinished-verse (if (lyrics-unfinished lyrics/skip) verse #f))))
596 ((rest? notelist/rest)
597 (if (null? verse-list)
598 (set! verse-list (list (make-verse #:text ""
599 #:notelist/rests (list notelist/rest))))
600 (let ((last-verse (last verse-list)))
601 (set-verse-notelist/rests!
603 (append (verse-notelist/rests last-verse) (list notelist/rest))))))
604 ((pair? notelist/rest)
605 (add! (make-verse #:text (*skip-word*) #:notelist/rests (list notelist/rest))
608 (error "Unreachable branch reached")))
609 (set! unfinished-verse #f)))
610 (if (not (rest? notelist/rest))
611 (set! lyrics/skip-list (cdr lyrics/skip-list)))))))
613 (set-verse-unfinished! unfinished-verse #t))
614 (set-score-notes-verse-block-list!
616 (append (score-notes-verse-block-list score)
617 (list (make-verse-block #:verse-list verse-list)))))
620 (define (consume-lyrics-notes lyrics note-list context)
621 ;; Returns list of note instances + new note-list.
622 (assert (lyrics? lyrics))
623 (if (and (not (null? note-list))
624 (rest? (car note-list)))
625 (values (car note-list) (cdr note-list))
626 (let ((ignore-melismata (lyrics-ignore-melismata lyrics))
630 (not (null? note-list)))
631 (let ((note (car note-list)))
632 (push! note consumed)
633 (let ((note-slur (note-joined note)))
635 (warning note "Slur underrun"))
636 (set! join (and (not ignore-melismata) (> note-slur 0)))))
637 (set! note-list (cdr note-list)))
639 (warning (safe-car (if (null? note-list) consumed note-list))
640 "Unfinished slur: ~a ~a" context consumed))
641 (values (reverse consumed) note-list))))
643 (define (consume-skip-notes skip note-list context)
644 ;; Returns either note list (skip word defined) or rest instance (no skip word) + new note-list.
645 (assert (skip? skip))
646 (let ((duration (skip-duration skip))
649 (while (and (> duration epsilon)
650 (not (null? note-list)))
651 (let ((note (car note-list)))
652 (assert (note? note))
653 (push! note consumed)
654 (set! duration (- duration (note-duration note))))
655 (set! note-list (cdr note-list)))
656 (set! consumed (reverse! consumed))
658 ((> duration epsilon)
659 (warning (if (null? note-list) (safe-last consumed) (safe-car note-list))
660 "Excessive skip: ~a ~a ~a ~a" context skip duration consumed))
661 ((< duration (- epsilon))
662 (warning (if (null? note-list) (safe-last consumed) (safe-car note-list))
663 "Skip misalignment: ~a ~a ~a ~a" context skip duration consumed)))
664 (values (if (*skip-word*)
669 (define (extract-verse-blocks score)
670 ;; Returns list of blocks and parallel blocks.
671 (debug "Extracting verse blocks" score)
673 ((score-voice? score)
674 (append-map extract-verse-blocks (score-voice-elements score)))
675 ((score-choice? score)
676 (list (make-parallel-blocks
677 #:block-list (map (lambda (block-list)
678 (make-sequential-blocks
679 #:block-list (append-map extract-verse-blocks block-list)))
680 (score-choice-lists score)))))
681 ((score-repetice? score)
682 (list (make-repeated-blocks #:count (score-repetice-count score)
683 #:block-list (append-map extract-verse-blocks
684 (score-repetice-elements score)))))
685 ((score-notes? score)
686 (list (make-parallel-blocks #:block-list (score-notes-verse-block-list score))))
688 (error "Invalid score element" score))))
690 (define (extract-verses score-list)
691 ;; Returns (final) list of verses.
692 ;; The primary purpose of this routine is to build complete stanzas from
693 ;; lists of verse blocks.
694 ;; Extract verse-blocks and process them until no unprocessed stanzas remain.
695 (debug "Final score list" score-list)
696 (let ((verse-block-list (debug "Verse blocks" (append-map extract-verse-blocks score-list))))
697 (letrec ((combine (lambda (lst-1 lst-2)
698 (debug "Combining lists" (list lst-1 lst-2))
701 (let ((diff (- (length lst-1) (length lst-2))))
703 (let ((last-elt (last lst-1)))
705 (add! last-elt lst-1)
706 (set! diff (+ diff 1))))
707 (let ((last-elt (last lst-2)))
709 (add! last-elt lst-2)
710 (set! diff (- diff 1)))))
711 (debug "Combined" (map append lst-1 lst-2))))))
712 (expand* (lambda (block)
714 ((parallel-blocks? block)
715 (append-map (lambda (block) (expand (list block)))
716 (parallel-blocks-block-list block)))
717 ((sequential-blocks? block)
718 (expand (sequential-blocks-block-list block)))
719 ((repeated-blocks? block)
720 ;; Only simple repetice without nested parallel sections is supported.
721 (let ((count (repeated-blocks-count block))
722 (expanded (expand (repeated-blocks-block-list block)))
724 (while (not (null? expanded))
727 (while (and (> count* 0) (not (null? expanded)))
728 (set! item (append item (car expanded)))
729 (set! expanded (cdr expanded))
730 (set! count* (- count* 1)))
731 (push! item expanded*)))
732 (reverse expanded*)))
734 (list (list block))))))
735 (expand (lambda (block-list)
736 (debug "Expanding list" block-list)
737 (if (null? block-list)
739 (debug "Expanded" (combine (expand* (car block-list))
740 (expand (cdr block-list)))))))
741 (merge (lambda (verse-list)
745 ((verse-unfinished (car verse-list))
746 (let ((verse-1 (first verse-list))
747 (verse-2 (second verse-list)))
748 (merge (cons (make-verse #:text (string-append (verse-text verse-1)
749 (verse-text verse-2))
750 #:notelist/rests (append (verse-notelist/rests verse-1)
751 (verse-notelist/rests verse-2))
752 #:unfinished (verse-unfinished verse-2))
753 (cddr verse-list)))))
755 (cons (car verse-list) (merge (cdr verse-list))))))))
756 (debug "Final verses" (merge (append-map (lambda (lst) (append-map verse-block-verse-list lst))
757 (expand verse-block-list)))))))
759 (define (handle-music music)
760 ;; Returns list of verses.
761 ;; The main analysis function.
763 (display-scheme-music music))
764 (let ((score-list (debug "Final raw notes" (get-notes music)))
765 (music-context-list (collect-lyrics-music music)))
766 (for-each (lambda (music-context)
767 (let ((context (music-context-context music-context)))
768 (set! *tempo-compression* #f)
769 (insert-lyrics! (get-lyrics (music-context-music music-context) context)
771 (debug "Final score list" score-list)))
773 (extract-verses score-list)))
779 (define festival-note-mapping '((0 "C") (1 "C#") (2 "D") (3 "D#") (4 "E") (5 "F") (6 "F#")
780 (7 "G") (8 "G#") (9 "A") (10 "A#") (11 "B")))
781 (define (festival-pitch pitch)
782 (let* ((semitones (ly:pitch-semitones pitch))
783 (octave (inexact->exact (floor (/ semitones 12))))
784 (tone (modulo semitones 12)))
785 (format #f "~a~a" (car (assoc-get tone festival-note-mapping))
786 (+ octave (*base-octave*) (*base-octave-shift*)))))
788 (define (write-header port tempo)
789 (let ((beats (or (tempo->beats tempo) 100)))
790 (format port "<?xml version=\"1.0\"?>
791 <!DOCTYPE SINGING PUBLIC \"-//SINGING//DTD SINGING mark up//EN\" \"Singing.v0_1.dtd\" []>
795 (define (write-footer port)
796 (format port "</SINGING>~%"))
798 (define (write-lyrics port music)
800 (for-each (lambda (verse)
801 (let ((text (verse-text verse))
802 (note/rest-list (verse-notelist/rests verse)))
803 (receive (rest-list note-listlist) (partition rest? note/rest-list)
804 (debug "Rest list" rest-list)
805 (debug "Note list" note-listlist)
806 (if (not (null? rest-list))
807 (set! rest-dur (+ rest-dur (apply + (map rest-duration rest-list)))))
808 (if (not (null? note-listlist))
812 (write-rest-element port rest-dur)
814 (write-lyrics-element port text note-listlist))))))
815 (handle-music music))
817 (write-rest-element port rest-dur))))
819 (define (write-lyrics-element port text slur-list)
820 (let ((fmt "~{~{~a~^+~}~^,~}")
821 (transform (lambda (function)
823 (let ((rests (filter rest? slur)))
824 (if (not (null? rests))
826 (warning (car rests) "Rests in a slur: ~a" slur)
827 (set! slur (remove rest? slur)))))
830 (format port "<DURATION BEATS=\"~@?\"><PITCH NOTE=\"~@?\">~a</PITCH></DURATION>~%"
831 fmt (transform note-duration)
832 fmt (transform (compose festival-pitch note-pitch))
835 (define (write-rest-element port duration)
836 (format port "<REST BEATS=\"~a\"></REST>~%" duration))