OLD | NEW |
1 ;;;; song.scm --- Festival singing mode output | 1 ;;;; song.scm --- Festival singing mode output |
2 ;;;; | 2 ;;;; |
3 ;;;; This file is part of LilyPond, the GNU music typesetter. | 3 ;;;; This file is part of LilyPond, the GNU music typesetter. |
4 ;;;; | 4 ;;;; |
5 ;;;; Copyright (C) 2006--2020 Brailcom, o.p.s. | 5 ;;;; Copyright (C) 2006--2020 Brailcom, o.p.s. |
6 ;;;; Author: Milan Zamazal <pdm@brailcom.org> | 6 ;;;; Author: Milan Zamazal <pdm@brailcom.org> |
7 ;;;; | 7 ;;;; |
8 ;;;; LilyPond is free software: you can redistribute it and/or modify | 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 | 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 | 10 ;;;; the Free Software Foundation, either version 3 of the License, or |
(...skipping 519 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
530 (begin | 530 (begin |
531 (set! allow-default #t) | 531 (set! allow-default #t) |
532 (set! n 0) | 532 (set! n 0) |
533 (set! lists (score-choice-lists score))))) | 533 (set! lists (score-choice-lists score))))) |
534 (debug "Selected score" score*) | 534 (debug "Selected score" score*) |
535 (if (and score* | 535 (if (and score* |
536 (>= n n-assigned)) | 536 (>= n n-assigned)) |
537 (begin | 537 (begin |
538 (if (> n n-assigned) | 538 (if (> n n-assigned) |
539 (receive (assigned-elts unassigned-elts) (split-at lists* n-
assigned) | 539 (receive (assigned-elts unassigned-elts) (split-at lists* n-
assigned) |
540 (set-score-choice-lists! score (append assigned-elt
s | 540 (set-score-choice-lists! score (append assigned-elts |
541 (list (list-
ref lists* n)) | 541 (list (list-ref lis
ts* n)) |
542 (take unassi
gned-elts (- n n-assigned)) | 542 (take unassigned-el
ts (- n n-assigned)) |
543 lists)))) | 543 lists)))) |
544 (set-score-choice-n-assigned! score (+ n-assigned 1)))) | 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))) | 545 (insert-lyrics*! lyrics/skip-list (append (if score* (list score*) '()
) (cdr score-list)) context))) |
546 ((score-repetice? score) | 546 ((score-repetice? score) |
547 (insert-lyrics*! lyrics/skip-list | 547 (insert-lyrics*! lyrics/skip-list |
548 (append (score-repetice-elements score) (cdr score-list
)) context)) | 548 (append (score-repetice-elements score) (cdr score-list
)) context)) |
549 ((score-notes? score) | 549 ((score-notes? score) |
550 ;; This is the only part which actually attaches the processed lyrics. | 550 ;; This is the only part which actually attaches the processed lyrics. |
551 ;; The subsequent calls return verses which we collect into a verse bloc
k. | 551 ;; The subsequent calls return verses which we collect into a verse bloc
k. |
552 ;; We add the block to the score element. | 552 ;; We add the block to the score element. |
553 (if (equal? lyrics-context context) | 553 (if (equal? lyrics-context context) |
(...skipping 21 matching lines...) Expand all Loading... |
575 (list (make-verse #:text "" | 575 (list (make-verse #:text "" |
576 #:notelist/rests
(reverse! final-rests)))))) | 576 #:notelist/rests
(reverse! final-rests)))))) |
577 (if (not (null? note-list)) | 577 (if (not (null? note-list)) |
578 (begin | 578 (begin |
579 (warning (car note-list) "Missing lyrics: ~a ~a" context
note-list) | 579 (warning (car note-list) "Missing lyrics: ~a ~a" context
note-list) |
580 (set! note-list '())))) | 580 (set! note-list '())))) |
581 (let ((lyrics/skip (car lyrics/skip-list))) | 581 (let ((lyrics/skip (car lyrics/skip-list))) |
582 (receive (notelist/rest note-list*) (if (lyrics? lyrics/skip) | 582 (receive (notelist/rest note-list*) (if (lyrics? lyrics/skip) |
583 (consume-lyrics-notes l
yrics/skip note-list context) | 583 (consume-lyrics-notes l
yrics/skip note-list context) |
584 (consume-skip-notes lyr
ics/skip note-list context)) | 584 (consume-skip-notes lyr
ics/skip note-list context)) |
585 (debug "Consumed notes" (list lyrics/skip notelist/res
t)) | 585 (debug "Consumed notes" (list lyrics/skip notelist/rest)) |
586 (set! note-list note-list*) | 586 (set! note-list note-list*) |
587 (cond | 587 (cond |
588 ((null? notelist/rest) | 588 ((null? notelist/rest) |
589 #f) | 589 #f) |
590 ;; Lyrics | 590 ;; Lyrics |
591 ((and (lyrics? lyrics/skip) | 591 ((and (lyrics? lyrics/skip) |
592 unfinished-verse) | 592 unfinished-verse) |
593 (set-verse-text! | 593 (set-verse-text! |
594 unfinished-verse | 594 unfinished-verse |
595 (string-append (verse-text unfinished-verse) (lyric
s-text lyrics/skip))) | 595 (string-append (verse-text unfinished-verse) (lyrics-text
lyrics/skip))) |
596 (set-verse-notelist/rests! | 596 (set-verse-notelist/rests! |
597 unfinished-verse | 597 unfinished-verse |
598 (append (verse-notelist/rests unfinished-verse) (li
st notelist/rest))) | 598 (append (verse-notelist/rests unfinished-verse) (list note
list/rest))) |
599 (if (not (lyrics-unfinished lyrics/skip)) | 599 (if (not (lyrics-unfinished lyrics/skip)) |
600 (set! unfinished-verse #f))) | 600 (set! unfinished-verse #f))) |
601 ((lyrics? lyrics/skip) | 601 ((lyrics? lyrics/skip) |
602 (let ((verse (make-verse #:text (if (rest? notelist/
rest) | 602 (let ((verse (make-verse #:text (if (rest? notelist/rest) |
603 "" | 603 "" |
604 (lyrics-text lyr
ics/skip)) | 604 (lyrics-text lyrics/ski
p)) |
605 #:notelist/rests (list note
list/rest)))) | 605 #:notelist/rests (list notelist/re
st)))) |
606 (add! verse verse-list) | 606 (add! verse verse-list) |
607 (set! unfinished-verse (if (lyrics-unfinished lyri
cs/skip) verse #f)))) | 607 (set! unfinished-verse (if (lyrics-unfinished lyrics/skip
) verse #f)))) |
608 ;; Skip | 608 ;; Skip |
609 ((skip? lyrics/skip) | 609 ((skip? lyrics/skip) |
610 (cond | 610 (cond |
611 ((rest? notelist/rest) | 611 ((rest? notelist/rest) |
612 (if (null? verse-list) | 612 (if (null? verse-list) |
613 (set! verse-list (list (make-verse #:text "" | 613 (set! verse-list (list (make-verse #:text "" |
614 #:notelist/
rests (list notelist/rest)))) | 614 #:notelist/rests (
list notelist/rest)))) |
615 (let ((last-verse (last verse-list))) | 615 (let ((last-verse (last verse-list))) |
616 (set-verse-notelist/rests! | 616 (set-verse-notelist/rests! |
617 last-verse | 617 last-verse |
618 (append (verse-notelist/rests last-verse) (
list notelist/rest)))))) | 618 (append (verse-notelist/rests last-verse) (list no
telist/rest)))))) |
619 ((pair? notelist/rest) | 619 ((pair? notelist/rest) |
620 (add! (make-verse #:text (*skip-word*) #:notelist/
rests (list notelist/rest)) | 620 (add! (make-verse #:text (*skip-word*) #:notelist/rests (
list notelist/rest)) |
621 verse-list)) | 621 verse-list)) |
622 (else | 622 (else |
623 (error "Unreachable branch reached"))) | 623 (error "Unreachable branch reached"))) |
624 (set! unfinished-verse #f))) | 624 (set! unfinished-verse #f))) |
625 (if (not (rest? notelist/rest)) | 625 (if (not (rest? notelist/rest)) |
626 (set! lyrics/skip-list (cdr lyrics/skip-list))))))
) | 626 (set! lyrics/skip-list (cdr lyrics/skip-list))))))) |
627 (if unfinished-verse | 627 (if unfinished-verse |
628 (set-verse-unfinished! unfinished-verse #t)) | 628 (set-verse-unfinished! unfinished-verse #t)) |
629 (set-score-notes-verse-block-list! | 629 (set-score-notes-verse-block-list! |
630 score | 630 score |
631 (append (score-notes-verse-block-list score) | 631 (append (score-notes-verse-block-list score) |
632 (list (make-verse-block #:verse-list verse-list))))) | 632 (list (make-verse-block #:verse-list verse-list))))) |
633 lyrics/skip-list) | 633 lyrics/skip-list) |
634 | 634 |
635 (define (consume-lyrics-notes lyrics note-list context) | 635 (define (consume-lyrics-notes lyrics note-list context) |
636 ;; Returns list of note instances + new note-list. | 636 ;; Returns list of note instances + new note-list. |
(...skipping 172 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
809 | 809 |
810 (define (write-footer port) | 810 (define (write-footer port) |
811 (format port "</SINGING>~%")) | 811 (format port "</SINGING>~%")) |
812 | 812 |
813 (define (write-lyrics port music) | 813 (define (write-lyrics port music) |
814 (let ((rest-dur 0)) | 814 (let ((rest-dur 0)) |
815 (for-each (lambda (verse) | 815 (for-each (lambda (verse) |
816 (let ((text (verse-text verse)) | 816 (let ((text (verse-text verse)) |
817 (note/rest-list (verse-notelist/rests verse))) | 817 (note/rest-list (verse-notelist/rests verse))) |
818 (receive (rest-list note-listlist) (partition rest? note/rest-
list) | 818 (receive (rest-list note-listlist) (partition rest? note/rest-
list) |
819 (debug "Rest list" rest-list) | 819 (debug "Rest list" rest-list) |
820 (debug "Note list" note-listlist) | 820 (debug "Note list" note-listlist) |
821 (if (not (null? rest-list)) | 821 (if (not (null? rest-list)) |
822 (set! rest-dur (+ rest-dur (apply + (map rest-dur
ation rest-list))))) | 822 (set! rest-dur (+ rest-dur (apply + (map rest-duration r
est-list))))) |
823 (if (not (null? note-listlist)) | 823 (if (not (null? note-listlist)) |
824 (begin | 824 (begin |
825 (if (> rest-dur 0) | 825 (if (> rest-dur 0) |
826 (begin | 826 (begin |
827 (write-rest-element port rest-dur) | 827 (write-rest-element port rest-dur) |
828 (set! rest-dur 0))) | 828 (set! rest-dur 0))) |
829 (write-lyrics-element port text note-listlist))
)))) | 829 (write-lyrics-element port text note-listlist)))))) |
830 (handle-music music)) | 830 (handle-music music)) |
831 (if (> rest-dur 0) | 831 (if (> rest-dur 0) |
832 (write-rest-element port rest-dur)))) | 832 (write-rest-element port rest-dur)))) |
833 | 833 |
834 (define (write-lyrics-element port text slur-list) | 834 (define (write-lyrics-element port text slur-list) |
835 (let ((fmt "~{~{~a~^+~}~^,~}") | 835 (let ((fmt "~{~{~a~^+~}~^,~}") |
836 (transform (lambda (function) | 836 (transform (lambda (function) |
837 (map (lambda (slur) | 837 (map (lambda (slur) |
838 (let ((rests (filter rest? slur))) | 838 (let ((rests (filter rest? slur))) |
839 (if (not (null? rests)) | 839 (if (not (null? rests)) |
840 (begin | 840 (begin |
841 (warning (car rests) "Rests in a slur: ~a" s
lur) | 841 (warning (car rests) "Rests in a slur: ~a" s
lur) |
842 (set! slur (remove rest? slur))))) | 842 (set! slur (remove rest? slur))))) |
843 (map function slur)) | 843 (map function slur)) |
844 slur-list)))) | 844 slur-list)))) |
845 (format port "<DURATION BEATS=\"~@?\"><PITCH NOTE=\"~@?\">~a</PITCH></DURATI
ON>~%" | 845 (format port "<DURATION BEATS=\"~@?\"><PITCH NOTE=\"~@?\">~a</PITCH></DURATI
ON>~%" |
846 fmt (transform note-duration) | 846 fmt (transform note-duration) |
847 fmt (transform (compose festival-pitch note-pitch)) | 847 fmt (transform (compose festival-pitch note-pitch)) |
848 text))) | 848 text))) |
849 | 849 |
850 (define (write-rest-element port duration) | 850 (define (write-rest-element port duration) |
851 (format port "<REST BEATS=\"~a\"></REST>~%" duration)) | 851 (format port "<REST BEATS=\"~a\"></REST>~%" duration)) |
OLD | NEW |