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