;;;; song.scm --- Festival singing mode output
;;;;
;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
;;;; Copyright (C) 2006--2020 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)))
    (cond-expand
     (guile-2 (set-port-encoding! port "UTF-8"))
     (else))
    (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))
