scm/song.scm

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