scm/song.scm

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