This file is indexed.

/usr/share/lilypond/2.18.2/scm/song.scm is in lilypond-data 2.18.2-4.1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
;;;; song.scm --- Festival singing mode output
;;;;
;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
;;;; Copyright (C) 2006, 2007 Brailcom, o.p.s.
;;;; Author: Milan Zamazal <pdm@brailcom.org>
;;;;
;;;; LilyPond is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; LilyPond is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.


(define-module (scm song)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-39)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (lily)
  #:use-module (scm song-util))


;;; Configuration


;; The word to be sung in places where notes are played without lyrics.
;; If it is #f, the places without lyrics are omitted on the output.
(define-public *skip-word* (make-parameter "-skip-"))

;; If true, use syllables in the Festival XML file.
;; If false, use whole words instead; this is necessary in languages like
;; English, were the phonetic form cannot be deduced from syllables well enough.
(define-public *syllabify* (make-parameter #f))

;; Base Festival octave to which LilyPond notes are mapped.
(define-public *base-octave* (make-parameter 5))
;; The resulting base octave is sum of *base-octave* and
;; *base-octave-shift*.  This is done to work around a Festival bug
;; causing Festival to segfault or produce invalid pitch on higher pitches.
;; (define *base-octave-shift* -2)
(define *base-octave-shift* (make-parameter 0))

;; The coeficient by which the notes just before \breath are shortened.
(define-public *breathe-shortage* (make-parameter 0.8))


;;; LilyPond interface


(define-public (output-file music tempo filename)
  (if *debug*
      (debug-enable 'backtrace))
  (ly:message "Writing Festival XML file ~a..." filename)
  (let ((port (open-output-file filename)))
    (write-header port tempo)
    (write-lyrics port music)
    (write-footer port)
    (close-port port))
  #f)


;;; Utility functions


(define pp-pitch-names '((0 . "c") (1 . "des") (2 . "d") (3 . "es") (4 . "e") (5 . "f")
                         (6 . "ges") (7 . "g") (8 . "as") (9 . "a") (10 . "bes") (11 . "b")))
(define (pp object)
  (cond
   ((list? object)
    (format #f "[~{~a ~}]" (map pp object)))
   ((skip? object)
    (format #f "skip(~a)" (skip-duration object)))
   ((lyrics? object)
    (format #f "~a(~a)~a" (lyrics-text object) (lyrics-duration object)
            (if (lyrics-unfinished object) "-" "")))
   ((note? object)
    (let ((pitch (ly:pitch-semitones (note-pitch object))))
      (format #f "~a~a~a~a"
              (assoc-get (modulo pitch 12) pp-pitch-names)
              (let ((octave (+ (inexact->exact (floor (/ pitch 12))) 1)))
                (cond
                 ((= octave 0)
                  "")
                 ((> octave 0)
                  (make-string octave #\'))
                 ((< octave 0)
                  (make-string (- octave) #\,))))
              (pp-duration (note-duration object))
              (if (> (note-joined object) 0) "-" ""))))
   ((rest? object)
    (format #f "r~a" (pp-duration (rest-duration object))))
   (else
    object)))

(define (pp-duration duration)
  (set! duration (/ 4 duration))
  (if (< (abs (- duration (inexact->exact duration))) 0.0001)
      (inexact->exact duration)
      (/ (round (* duration 100)) 100)))

(define-public (warning object-with-origin message . args)
  (let ((origin (cond
                 ((not object-with-origin)
                  #f)
                 ((note? object-with-origin)
                  (note-origin object-with-origin))
                 ((rest? object-with-origin)
                  (rest-origin object-with-origin))
                 ((ly:input-location? object-with-origin)
                  object-with-origin)
                 ((ly:music? object-with-origin)
                  (ly:music-property object-with-origin 'origin))
                 (else
                  (format #t "Minor programming error: ~a~%" object-with-origin)
                  #f))))
    (if origin
        (ly:input-message origin "***Song Warning***")
        (format #t "~%***Song Warning***"))
    (apply ly:message message (map pp args))))


;;; Analysis functions


(define *default-tempo* #f)
(define *tempo-compression* #f)

(define (duration->number duration)
  (exact->inexact (ly:moment-main (ly:duration-length duration))))

(define (tempo->beats music)
  (let* ((tempo-spec (find-child-named music 'SequentialMusic))
         (tempo (cond
                 (tempo-spec
                  (let ((tempo-event (find-child-named tempo-spec
                                                       'TempoChangeEvent)))
                    (and tempo-event
                         (let ((count (ly:music-property tempo-event
                                                         'metronome-count)))
                           (* (if (pair? count)
                                  (round (/ (+ (car count) (cdr count)) 2))
                                  count)
                              (duration->number
                               (ly:music-property tempo-event 'tempo-unit)))))))
                 (else
                  (format #t "Programming error (tempo->beats): ~a~%"
                          tempo-spec)))))
    (debug-enable 'backtrace)
    (and tempo
         (set! *default-tempo* (property-value
                                (find-child tempo-spec (lambda (elt)
                                                         (music-property? elt 'tempoWholesPerMinute)))))
         (round (* tempo (expt 2 (+ 2 (*base-octave-shift*))))))))

(defstruct music-context
  music
  context)

(define (collect-lyrics-music music)
  ;; Returns list of music-context instances.
  (let ((music-context-list '()))
    (process-music
     music
     (lambda (music*)
       (cond
        ((music-name? music* 'LyricCombineMusic)
         (push! (make-music-context #:music music*
                                    #:context (ly:music-property music* 'associated-context))
                music-context-list)
         #t)
        ((and (music-name? music* 'ContextSpeccedMusic)
              (music-property-value? music* 'context-type 'Lyrics)
              (not (find-child-named music* 'LyricCombineMusic)))
         (let ((name-node (find-child music* (lambda (node) (music-property? node 'associatedVoice)))))
           (if name-node
               (push! (make-music-context #:music music* #:context (property-value name-node))
                      music-context-list)))
         #t)
        (else
         #f))))
    (debug "Lyrics contexts" (reverse music-context-list))))

(defstruct lyrics
  text
  duration
  unfinished
  ignore-melismata
  context)

(defstruct skip
  duration
  context)

(define (get-lyrics music context)
  ;; Returns list of lyrics and skip instances.
  (let ((lyrics-list '())
        (next-ignore-melismata #f)
        (ignore-melismata #f)
        (next-current-voice context)
        (current-voice context))
    (process-music
     music
     (lambda (music)
       (cond
        ;; true lyrics
        ((music-name? music '(EventChord LyricEvent))
         (let ((lyric-event (find-child-named music 'LyricEvent)))
           (push! (make-lyrics
                   #:text (ly:music-property lyric-event 'text)
                   #:duration (* (duration->number (ly:music-property lyric-event 'duration)) 4)
                   #:unfinished (and (not (*syllabify*)) (find-child-named music 'HyphenEvent))
                   #:ignore-melismata ignore-melismata
                   #:context current-voice)
                  lyrics-list))
         ;; LilyPond delays applying settings
         (set! ignore-melismata next-ignore-melismata)
         (set! current-voice next-current-voice)
         #t)
        ;; skipping
        ((music-name? music 'SkipMusic)
         (push! (make-skip
                 #:duration (* (duration->number (ly:music-property music 'duration)) 4)
                 #:context current-voice)
                lyrics-list)
         #t)
        ;; parameter change
        ((music-property? music 'ignoreMelismata)
         (set! next-ignore-melismata (property-value music))
         #t)
        ((music-property? music 'associatedVoice)
         (set! next-current-voice (property-value music))
         #t)
        ;; anything else
        (else
         #f))))
    (debug "Raw lyrics" (reverse lyrics-list))))

(defstruct score-voice
  context
  elements ; list of score-* instances
  )

(defstruct score-choice
  lists ; of lists of score-* instances
  (n-assigned 0) ; number of lists having a verse-block
  )

(defstruct score-repetice
  count ; number of repetitions
  elements ; list of score-* instances
  )

(defstruct score-notes
  note/rest-list                        ; list of note and rest instances
  (verse-block-list '())                ; lyrics attached to notes -- multiple
                                        ; elements are possible for
                                        ; multiple stanzas
  )

(defstruct note
  pitch
  duration
  joined ; to the next note
  origin
  )

(defstruct rest
  duration
  origin
  )

(define (get-notes music)
  ;; Returns list of score-* instances.
  (get-notes* music #t))

(define (get-notes* music autobeaming*)
  ;; Returns list of score-* instances.
  (let* ((result-list '())
         (in-slur 0)
         (autobeaming autobeaming*)
         (last-note-spec #f))
    (process-music
     music
     (lambda (music)
       (cond
        ;; context change
        ((music-has-property? music 'context-id)
         (let ((context (ly:music-property music 'context-id))
               (children (music-elements music)))
           (add! (make-score-voice #:context (debug "Changing context" context)
                                   #:elements (append-map (lambda (elt)
                                                            (get-notes* elt autobeaming))
                                                          children))
                 result-list))
         #t)
        ;; timing change
        ((music-property? music 'timeSignatureFraction)
         (let ((value (property-value music)))
           (debug "Timing change" value)))
        ;; simultaneous notes
        ((music-name? music 'SimultaneousMusic)
         (let ((simultaneous-lists (map (lambda (child)
                                          (get-notes* child autobeaming))
                                        (ly:music-property music 'elements))))
           (debug "Simultaneous lists" simultaneous-lists)
           (add! (make-score-choice #:lists simultaneous-lists) result-list))
         #t)
        ;; repetice
        ((music-name? music 'VoltaRepeatedMusic)
         (let ((repeat-count (ly:music-property music 'repeat-count))
               (children (music-elements music)))
           (add! (make-score-repetice #:count repeat-count
                                      #:elements (append-map
                                                  (lambda (elt) (get-notes* elt autobeaming))
                                                  children))
                 result-list))
         #t)
        ;; a note or rest
        ((or (music-name? music 'EventChord)
             (music-name? music 'MultiMeasureRestMusic)) ; 2.10
         (debug "Simple music event" music)
         (if *tempo-compression*
             (set! music (ly:music-compress (ly:music-deep-copy music) *tempo-compression*)))
         (let ((note (find-child-named music 'NoteEvent))
               (rest (if (music-name? music 'MultiMeasureRestMusic) ; 2.10
                         music
                         (or (find-child-named music 'RestEvent)
                             (find-child-named music 'MultiMeasureRestEvent) ; 2.8
                             ))))
           (cond
            (note
             (debug "Note" note)
             (let* ((pitch (ly:music-property note 'pitch))
                    (duration (* (duration->number (ly:music-property note 'duration)) 4))
                    (events (filter identity (list
                                              (find-child-named music 'SlurEvent)
                                              (find-child-named music 'ManualMelismaEvent)
                                              (and (not autobeaming)
                                                   (find-child-named music 'BeamEvent)))))
                    (slur-start (length (filter (lambda (e) (music-property-value? e 'span-direction -1))
                                                events)))
                    (slur-end (length (filter (lambda (e) (music-property-value? e 'span-direction 1))
                                              events))))
               (set! in-slur (+ in-slur slur-start (- slur-end)))
               (let ((note-spec (make-note #:pitch pitch #:duration duration #:joined in-slur
                                           #:origin (ly:music-property note 'origin)))
                     (last-result (and (not (null? result-list)) (last result-list))))
                 (set! last-note-spec note-spec)
                 (if (and last-result
                          (score-notes? last-result))
                     (set-score-notes-note/rest-list!
                      last-result
                      (append (score-notes-note/rest-list last-result) (list note-spec)))
                     (add! (make-score-notes #:note/rest-list (list note-spec)) result-list)))))
            (rest
             (debug "Rest" rest)
             (let* ((duration (* (duration->number (ly:music-property rest 'duration)) 4))
                    (rest-spec (make-rest #:duration duration
                                          #:origin (ly:music-property rest 'origin)))
                    (last-result (and (not (null? result-list)) (last result-list))))
               (if (and last-result
                        (score-notes? last-result))
                   (set-score-notes-note/rest-list! last-result
                                                    (append (score-notes-note/rest-list last-result)
                                                            (list rest-spec)))
                   (add! (make-score-notes #:note/rest-list (list rest-spec)) result-list))))))
         (filter
          (lambda (m)
            (not (music-name? m '(RestEvent
                                  NoteEvent
                                  LyricEvent
                                  MultiMeasureRestEvent))))
          (ly:music-property music 'elements)))
        ((music-name? music '(RestEvent
                              NoteEvent
                              LyricEvent
                              MultiMeasureRestEvent))
         (make-music 'EventChord
                     'elements
                     (cons music
                           (ly:music-property music 'articulations))))
        ;; autobeaming change
        ((music-property? music 'autoBeaming)
         (set! autobeaming (property-value music))
         #t)
        ;; melisma change
        ((music-property? music 'melismaBusy) ; 2.10
         (let ((change (if (property-value music) 1 -1)))
           (set! in-slur (+ in-slur change))
           (if last-note-spec
               (set-note-joined! last-note-spec (+ (note-joined last-note-spec) change))))
         #t)
        ;; tempo change
        ((music-property? music 'tempoWholesPerMinute)
         (set! *tempo-compression* (ly:moment-div *default-tempo* (property-value music)))
         #t)
        ;; breathe
        ((music-name? music 'BreathingEvent)
         (if last-note-spec
             (let* ((note-duration (note-duration last-note-spec))
                    (rest-spec (make-rest #:duration (* note-duration (- 1 (*breathe-shortage*)))
                                          #:origin (ly:music-property music 'origin))))
               (set-note-duration! last-note-spec (* note-duration (*breathe-shortage*)))
               (add! (make-score-notes #:note/rest-list (list rest-spec)) result-list))
             (warning music "\\\\breathe without previous note known"))
         #t)
        ;; anything else
        (else
         #f))))
    (debug "Raw notes" result-list)))

(defstruct verse-block ; lyrics for a given piece of music
  verse-list
  (fresh #t) ; if #t, this block hasn't been yet included in the final output
  )

(defstruct parallel-blocks ; several parallel blocks (e.g. stanzas)
  block-list ; list of verse-blocks
  )

(defstruct sequential-blocks
  block-list ; list of verse-blocks
  )

(defstruct repeated-blocks
  block-list ; list of verse-blocks
  count ; number of repetitions
  )

(defstruct verse ;
  text ; separate text element (syllable or word)
  notelist/rests ; list of note lists (slurs) and rests
  (unfinished #f) ; whether to be merged with the following verse
  )

(define (find-lyrics-score score-list context accept-default)
  ;; Returns score-* element of context or #f (if there's no such any).
  (and (not (null? score-list))
       (or (find-lyrics-score* (car score-list) context accept-default)
           (find-lyrics-score (cdr score-list) context accept-default))))

(define (find-lyrics-score* score context accept-default)
  (cond
   ((and (score-voice? score)
         (equal? (score-voice-context score) context))
    score)
   ((score-voice? score)
    (find-lyrics-score (score-voice-elements score) context #f))
   ((score-choice? score)
    (letrec ((lookup (lambda (lists)
                       (if (null? lists)
                           #f
                           (or (find-lyrics-score (car lists) context accept-default)
                               (lookup (cdr lists)))))))
      (lookup (score-choice-lists score))))
   ((score-repetice? score)
    (if accept-default
        score
        (find-lyrics-score (score-repetice-elements score) context accept-default)))
   ((score-notes? score)
    (if accept-default
        score
        #f))
   (else
    (error "Unknown score element" score))))

(define (insert-lyrics! lyrics/skip-list score-list context)
  ;; Add verse-block-lists to score-list.
  ;; Each processed score-notes instance must receive at most one block in each
  ;; insert-lyrics! call.  (It can get other blocks if more pieces of
  ;; lyrics are attached to the same score part.)
  (let ((lyrics-score-list (find-lyrics-score score-list context #f)))
    (debug "Lyrics+skip list" lyrics/skip-list)
    (debug "Corresponding score-* list" score-list)
    (if lyrics-score-list
        (insert-lyrics*! lyrics/skip-list (list lyrics-score-list) context)
        (warning #f "Lyrics context not found: ~a" context))))

(define (insert-lyrics*! lyrics/skip-list score-list context)
  (debug "Processing lyrics" lyrics/skip-list)
  (debug "Processing score" score-list)
  (cond
   ((and (null? lyrics/skip-list)
         (null? score-list))
    #f)
   ((null? lyrics/skip-list)
    (warning #f "Extra notes: ~a ~a" context score-list))
   ((null? score-list)
    (warning #f "Extra lyrics: ~a ~a" context lyrics/skip-list))
   (else
    (let* ((lyrics/skip (car lyrics/skip-list))
           (lyrics-context ((if (lyrics? lyrics/skip) lyrics-context skip-context) lyrics/skip))
           (score (car score-list)))
      (cond
       ((score-voice? score)
        (let ((new-context (score-voice-context score)))
          (if (equal? new-context lyrics-context)
              (insert-lyrics*! lyrics/skip-list
                               (append (score-voice-elements score)
                                       (if (null? (cdr score-list))
                                           '()
                                           (list (make-score-voice #:context context
                                                                   #:elements (cdr score-list)))))
                               new-context)
              (insert-lyrics*! lyrics/skip-list (cdr score-list) context))))
       ((score-choice? score)
        (let* ((lists* (score-choice-lists score))
               (lists lists*)
               (n-assigned (score-choice-n-assigned score))
               (n 0)
               (allow-default #f)
               (score* #f))
          (while (and (not score*)
                      (not (null? lists)))
                 (set! score* (find-lyrics-score (car lists) lyrics-context allow-default))
                 (set! lists (cdr lists))
                 (if (not score*)
                     (set! n (+ n 1)))
                 (if (and (null? lists)
                          (not allow-default)
                          (equal? lyrics-context context))
                     (begin
                       (set! allow-default #t)
                       (set! n 0)
                       (set! lists (score-choice-lists score)))))
          (debug "Selected score" score*)
          (if (and score*
                   (>= n n-assigned))
              (begin
                (if (> n n-assigned)
                    (receive (assigned-elts unassigned-elts) (split-at lists* n-assigned)
                             (set-score-choice-lists! score (append assigned-elts
                                                                    (list (list-ref lists* n))
                                                                    (take unassigned-elts (- n n-assigned))
                                                                    lists))))
                (set-score-choice-n-assigned! score (+ n-assigned 1))))
          (insert-lyrics*! lyrics/skip-list (append (if score* (list score*) '()) (cdr score-list)) context)))
       ((score-repetice? score)
        (insert-lyrics*! lyrics/skip-list
                         (append (score-repetice-elements score) (cdr score-list)) context))
       ((score-notes? score)
        ;; This is the only part which actually attaches the processed lyrics.
        ;; The subsequent calls return verses which we collect into a verse block.
        ;; We add the block to the score element.
        (if (equal? lyrics-context context)
            (set! lyrics/skip-list (really-insert-lyrics! lyrics/skip-list score context)))
        (insert-lyrics*! lyrics/skip-list (cdr score-list) context))
       (else
        (error "Unknown score element in lyrics processing" score)))))))

(define (really-insert-lyrics! lyrics/skip-list score context)
  ;; Return new lyrics/skip-list.
  ;; Score is modified by side effect.
  (debug "Assigning notes" score)
  (let ((note-list (score-notes-note/rest-list score))
        (unfinished-verse #f)
        (verse-list '()))
    (while (not (null? note-list))
           (if (null? lyrics/skip-list)
               (let ((final-rests '()))
                 (while (and (not (null? note-list))
                             (rest? (car note-list)))
                        (push! (car note-list) final-rests)
                        (set! note-list (cdr note-list)))
                 (if (not (null? final-rests))
                     (set! verse-list (append verse-list
                                              (list (make-verse #:text ""
                                                                #:notelist/rests (reverse! final-rests))))))
                 (if (not (null? note-list))
                     (begin
                       (warning (car note-list) "Missing lyrics: ~a ~a" context note-list)
                       (set! note-list '()))))
               (let ((lyrics/skip (car lyrics/skip-list)))
                 (receive (notelist/rest note-list*) (if (lyrics? lyrics/skip)
                                                         (consume-lyrics-notes lyrics/skip note-list context)
                                                         (consume-skip-notes lyrics/skip note-list context))
                          (debug "Consumed notes" (list lyrics/skip notelist/rest))
                          (set! note-list note-list*)
                          (cond
                           ((null? notelist/rest)
                            #f)
                           ;; Lyrics
                           ((and (lyrics? lyrics/skip)
                                 unfinished-verse)
                            (set-verse-text!
                             unfinished-verse
                             (string-append (verse-text unfinished-verse) (lyrics-text lyrics/skip)))
                            (set-verse-notelist/rests!
                             unfinished-verse
                             (append (verse-notelist/rests unfinished-verse) (list notelist/rest)))
                            (if (not (lyrics-unfinished lyrics/skip))
                                (set! unfinished-verse #f)))
                           ((lyrics? lyrics/skip)
                            (let ((verse (make-verse #:text (if (rest? notelist/rest)
                                                                ""
                                                                (lyrics-text lyrics/skip))
                                                     #:notelist/rests (list notelist/rest))))
                              (add! verse verse-list)
                              (set! unfinished-verse (if (lyrics-unfinished lyrics/skip) verse #f))))
                           ;; Skip
                           ((skip? lyrics/skip)
                            (cond
                             ((rest? notelist/rest)
                              (if (null? verse-list)
                                  (set! verse-list (list (make-verse #:text ""
                                                                     #:notelist/rests (list notelist/rest))))
                                  (let ((last-verse (last verse-list)))
                                    (set-verse-notelist/rests!
                                     last-verse
                                     (append (verse-notelist/rests last-verse) (list notelist/rest))))))
                             ((pair? notelist/rest)
                              (add! (make-verse #:text (*skip-word*) #:notelist/rests (list notelist/rest))
                                    verse-list))
                             (else
                              (error "Unreachable branch reached")))
                            (set! unfinished-verse #f)))
                          (if (not (rest? notelist/rest))
                              (set! lyrics/skip-list (cdr lyrics/skip-list)))))))
    (if unfinished-verse
        (set-verse-unfinished! unfinished-verse #t))
    (set-score-notes-verse-block-list!
     score
     (append (score-notes-verse-block-list score)
             (list (make-verse-block #:verse-list verse-list)))))
  lyrics/skip-list)

(define (consume-lyrics-notes lyrics note-list context)
  ;; Returns list of note instances + new note-list.
  (assert (lyrics? lyrics))
  (if (and (not (null? note-list))
           (rest? (car note-list)))
      (values (car note-list) (cdr note-list))
      (let ((ignore-melismata (lyrics-ignore-melismata lyrics))
            (join #t)
            (consumed '()))
        (while (and join
                    (not (null? note-list)))
               (let ((note (car note-list)))
                 (push! note consumed)
                 (let ((note-slur (note-joined note)))
                   (if (< note-slur 0)
                       (warning note "Slur underrun"))
                   (set! join (and (not ignore-melismata) (> note-slur 0)))))
               (set! note-list (cdr note-list)))
        (if join
            (warning (safe-car (if (null? note-list) consumed note-list))
                     "Unfinished slur: ~a ~a" context consumed))
        (values (reverse consumed) note-list))))

(define (consume-skip-notes skip note-list context)
  ;; Returns either note list (skip word defined) or rest instance (no skip word) + new note-list.
  (assert (skip? skip))
  (let ((duration (skip-duration skip))
        (epsilon 0.001)
        (consumed '()))
    (while (and (> duration epsilon)
                (not (null? note-list)))
           (let ((note (car note-list)))
             (assert (note? note))
             (push! note consumed)
             (set! duration (- duration (note-duration note))))
           (set! note-list (cdr note-list)))
    (set! consumed (reverse! consumed))
    (cond
     ((> duration epsilon)
      (warning (if (null? note-list) (safe-last consumed) (safe-car note-list))
               "Excessive skip: ~a ~a ~a ~a" context skip duration consumed))
     ((< duration (- epsilon))
      (warning (if (null? note-list) (safe-last consumed) (safe-car note-list))
               "Skip misalignment: ~a ~a ~a ~a" context skip duration consumed)))
    (values (if (*skip-word*)
                consumed
                '())
            note-list)))

(define (extract-verse-blocks score)
  ;; Returns list of blocks and parallel blocks.
  (debug "Extracting verse blocks" score)
  (cond
   ((score-voice? score)
    (append-map extract-verse-blocks (score-voice-elements score)))
   ((score-choice? score)
    (list (make-parallel-blocks
           #:block-list (map (lambda (block-list)
                               (make-sequential-blocks
                                #:block-list (append-map extract-verse-blocks block-list)))
                             (score-choice-lists score)))))
   ((score-repetice? score)
    (list (make-repeated-blocks #:count (score-repetice-count score)
                                #:block-list (append-map extract-verse-blocks
                                                         (score-repetice-elements score)))))
   ((score-notes? score)
    (list (make-parallel-blocks #:block-list (score-notes-verse-block-list score))))
   (else
    (error "Invalid score element" score))))

(define (extract-verses score-list)
  ;; Returns (final) list of verses.
  ;; The primary purpose of this routine is to build complete stanzas from
  ;; lists of verse blocks.
  ;; Extract verse-blocks and process them until no unprocessed stanzas remain.
  (debug "Final score list" score-list)
  (let ((verse-block-list (debug "Verse blocks" (append-map extract-verse-blocks score-list))))
    (letrec ((combine (lambda (lst-1 lst-2)
                        (debug "Combining lists" (list lst-1 lst-2))
                        (if (null? lst-2)
                            lst-1
                            (let ((diff (- (length lst-1) (length lst-2))))
                              (if (< diff 0)
                                  (let ((last-elt (last lst-1)))
                                    (while (< diff 0)
                                           (add! last-elt lst-1)
                                           (set! diff (+ diff 1))))
                                  (let ((last-elt (last lst-2)))
                                    (while (> diff 0)
                                           (add! last-elt lst-2)
                                           (set! diff (- diff 1)))))
                              (debug "Combined" (map append lst-1 lst-2))))))
             (expand* (lambda (block)
                        (cond
                         ((parallel-blocks? block)
                          (append-map (lambda (block) (expand (list block)))
                                      (parallel-blocks-block-list block)))
                         ((sequential-blocks? block)
                          (expand (sequential-blocks-block-list block)))
                         ((repeated-blocks? block)
                          ;; Only simple repetice without nested parallel sections is supported.
                          (let ((count (repeated-blocks-count block))
                                (expanded (expand (repeated-blocks-block-list block)))
                                (expanded* '()))
                            (while (not (null? expanded))
                                   (let ((count* count)
                                         (item '()))
                                     (while (and (> count* 0) (not (null? expanded)))
                                            (set! item (append item (car expanded)))
                                            (set! expanded (cdr expanded))
                                            (set! count* (- count* 1)))
                                     (push! item expanded*)))
                            (reverse expanded*)))
                         (else
                          (list (list block))))))
             (expand (lambda (block-list)
                       (debug "Expanding list" block-list)
                       (if (null? block-list)
                           '()
                           (debug "Expanded" (combine (expand* (car block-list))
                                                      (expand (cdr block-list)))))))
             (merge (lambda (verse-list)
                      (cond
                       ((null? verse-list)
                        '())
                       ((verse-unfinished (car verse-list))
                        (let ((verse-1 (first verse-list))
                              (verse-2 (second verse-list)))
                          (merge (cons (make-verse #:text (string-append (verse-text verse-1)
                                                                         (verse-text verse-2))
                                                   #:notelist/rests (append (verse-notelist/rests verse-1)
                                                                            (verse-notelist/rests verse-2))
                                                   #:unfinished (verse-unfinished verse-2))
                                       (cddr verse-list)))))
                       (else
                        (cons (car verse-list) (merge (cdr verse-list))))))))
      (debug "Final verses" (merge (append-map (lambda (lst) (append-map verse-block-verse-list lst))
                                               (expand verse-block-list)))))))

(define (handle-music music)
  ;; Returns list of verses.
  ;; The main analysis function.
  (if *debug*
      (display-scheme-music music))
  (let ((score-list (debug "Final raw notes" (get-notes music)))
        (music-context-list (collect-lyrics-music music)))
    (for-each (lambda (music-context)
                (let ((context (music-context-context music-context)))
                  (set! *tempo-compression* #f)
                  (insert-lyrics! (get-lyrics (music-context-music music-context) context)
                                  score-list context)
                  (debug "Final score list" score-list)))
              music-context-list)
    (extract-verses score-list)))


;;; Output


(define festival-note-mapping '((0 "C") (1 "C#") (2 "D") (3 "D#") (4 "E") (5 "F") (6 "F#")
                                (7 "G") (8 "G#") (9 "A") (10 "A#") (11 "B")))
(define (festival-pitch pitch)
  (let* ((semitones (ly:pitch-semitones pitch))
         (octave (inexact->exact (floor (/ semitones 12))))
         (tone (modulo semitones 12)))
    (format #f "~a~a" (car (assoc-get tone festival-note-mapping))
            (+ octave (*base-octave*) (*base-octave-shift*)))))

(define (write-header port tempo)
  (let ((beats (or (tempo->beats tempo) 100)))
    (format port "<?xml version=\"1.0\"?>
<!DOCTYPE SINGING PUBLIC \"-//SINGING//DTD SINGING mark up//EN\" \"Singing.v0_1.dtd\" []>
<SINGING BPM=\"~d\">
" beats)))

(define (write-footer port)
  (format port "</SINGING>~%"))

(define (write-lyrics port music)
  (let ((rest-dur 0))
    (for-each (lambda (verse)
                (let ((text (verse-text verse))
                      (note/rest-list (verse-notelist/rests verse)))
                  (receive (rest-list note-listlist) (partition rest? note/rest-list)
                           (debug "Rest list" rest-list)
                           (debug "Note list" note-listlist)
                           (if (not (null? rest-list))
                               (set! rest-dur (+ rest-dur (apply + (map rest-duration rest-list)))))
                           (if (not (null? note-listlist))
                               (begin
                                 (if (> rest-dur 0)
                                     (begin
                                       (write-rest-element port rest-dur)
                                       (set! rest-dur 0)))
                                 (write-lyrics-element port text note-listlist))))))
              (handle-music music))
    (if (> rest-dur 0)
        (write-rest-element port rest-dur))))

(define (write-lyrics-element port text slur-list)
  (let ((fmt "~{~{~a~^+~}~^,~}")
        (transform (lambda (function)
                     (map (lambda (slur)
                            (let ((rests (filter rest? slur)))
                              (if (not (null? rests))
                                  (begin
                                    (warning (car rests) "Rests in a slur: ~a" slur)
                                    (set! slur (remove rest? slur)))))
                            (map function slur))
                          slur-list))))
    (format port "<DURATION BEATS=\"~@?\"><PITCH NOTE=\"~@?\">~a</PITCH></DURATION>~%"
            fmt (transform note-duration)
            fmt (transform (compose festival-pitch note-pitch))
            text)))

(define (write-rest-element port duration)
  (format port "<REST BEATS=\"~a\"></REST>~%" duration))