From: Milan Zamazal Date: Mon, 12 Feb 2007 11:20:16 +0000 (+0100) Subject: Singing support X-Git-Tag: release/2.11.18-1~3 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=d0c106f0391e64451d41db3ed11d1aa27afebbbb;p=lilypond.git Singing support --- diff --git a/elisp/lilypond-song.el b/elisp/lilypond-song.el new file mode 100644 index 0000000000..9886dac685 --- /dev/null +++ b/elisp/lilypond-song.el @@ -0,0 +1,558 @@ +;;; lilypond-song.el --- Emacs support for LilyPond singing + +;; Copyright (C) 2006 Brailcom, o.p.s. + +;; Author: Milan Zamazal + +;; COPYRIGHT NOTICE + +;; This program 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 2 of the License, or +;; (at your option) any later version. + +;; This program 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 this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + +;;; Commentary: + +;; This file adds Emacs support for singing lyrics of LilyPond files. +;; It extends lilypond-mode with the following commands (see their +;; documentation for more information): +;; +;; - M-x LilyPond-command-sing (C-c C-a) +;; - M-x LilyPond-command-sing-and-play (C-c C-q) +;; - M-x LilyPond-command-sing-last (C-c C-z) +;; +;; Note these commands are not available from the standard LilyPond mode +;; command menus. + +;;; Code: + + +(require 'cl) +(require 'lilypond-mode) + +(ignore-errors (require 'ecasound)) + + +;;; User options + + +(defcustom LilyPond-synthesize-command "lilysong" + "Command used to sing LilyPond files." + :group 'LilyPond + :type 'string) + +(defcustom LilyPond-play-command (or (executable-find "ecaplay") "play") + "Command used to play WAV files." + :group 'LilyPond + :type 'string) + +;; In case you would like to use fluidsynth (not recommended as fluidsynth +;; can perform wave file synthesis only in real time), you can use the +;; following setting: +;; (setq LilyPond-midi->wav-command "fluidsynth -nil -a file soundfont.sf2 '%s' && sox -t raw -s -r 44100 -w -c 2 fluidsynth.raw '%t'") +(defcustom LilyPond-midi->wav-command "timidity -Ow %m -s %r -o '%t' '%s'" + "Command used to make a WAV file from a MIDI file. +%s in the string is replaced with the source MIDI file name, +%t is replaced with the target WAV file name. +%r is replaced with rate. +%m is replaced with lilymidi call." + :group 'LilyPond + :type 'string) + +(defcustom LilyPond-voice-rates + '((".*czech.*" . 44100) + (".*\\\\|nnish\\).*" . 22050) + (".*" . 16000)) + "Alist of regexps matching voices and the corresponding voice rates. +It may be necessary to define proper voice rates here in order to +avoid ecasound resampling problems." + :group 'LilyPond + :type '(alist :key-type regexp :value-type integer)) + +(defcustom LilyPond-use-ecasound (and (featurep 'ecasound) + (executable-find "ecasound") + t) + "If non-nil, use ecasound for mixing and playing songs." + :group 'LilyPond + :type 'boolean) + +(defcustom LilyPond-voice-track-regexp "voice" + "Perl regexp matching names of MIDI tracks to be ignored on sing&play." + :group 'LilyPond + :type 'string) + +(defcustom LilyPond-lilymidi-command "\"`lilymidi --prefix-tracks -Q --filter-tracks '%s' '%f'`\"" + "Command to insert into LilyPond-midi->wav-command calls. +%f is replaced with the corresponding MIDI file name. +%s is replaced with `LilyPond-voice-track-regexp'." + :group 'LilyPond + :type 'string) + + +;;; Lyrics language handling + + +(defvar lilysong-language nil) +(make-variable-buffer-local 'lilysong-language) + +(defvar lilysong-last-language nil) +(make-variable-buffer-local 'lilysong-last-language) + +(defvar lilysong-languages '("cs" "en")) + +(defvar lilysong-voices nil) + +(defun lilysong-voices () + (or lilysong-voices + (with-temp-buffer + (call-process "lilysong" nil t nil "--list-voices") + (call-process "lilysong" nil t nil "--list-languages") + (goto-char (point-min)) + (while (not (eobp)) + (push (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + lilysong-voices) + (forward-line)) + lilysong-voices))) + +(defun lilysong-change-language () + "Change synthesis language or voice of the current document." + (interactive) + (setq lilysong-language + (completing-read "Lyrics language or voice: " + (mapcar 'list (lilysong-voices))))) + +(defun lilysong-update-language () + (unless lilysong-language + (lilysong-change-language))) + + +;;; Looking for \festival* and \midi commands + + +(defun lilysong-document-files () + (let ((resulting-files ()) + (stack (list (LilyPond-get-master-file)))) + (while (not (null stack)) + (let ((file (expand-file-name (pop stack)))) + (when (and (file-exists-p file) + (not (member file resulting-files))) + (push file resulting-files) + (save-excursion + (save-restriction + (set-buffer (find-file-noselect file nil)) + (widen) + (goto-char (point-min)) + (while (re-search-forward "^[^%\n]*\\\\include +\"\\([^\"]+\\)\"" nil t) + (push (match-string 1) stack))))))) + (nreverse resulting-files))) + +(defvar lilysong-festival-command-regexp + "^[^%\n]*\\\\festival\\(syl\\)? +#\"\\([^\"]+\\)\"") + +(defun lilysong-find-song (direction) + "Find XML file name of the nearest Festival command in the given DIRECTION. +DIRECTION is one of the symbols `forward' or `backward'. +If no Festival command is found in the current buffer, return nil. +The point is left at the position where the command occurrence was found." + (save-match-data + (when (funcall (if (eq direction 'backward) + 're-search-backward + 're-search-forward) + lilysong-festival-command-regexp nil t) + (match-string-no-properties 2)))) + +(defun lilysong-current-song () + "Return the XML file name corresponding to the song around current point. +If there is none, return nil." + (save-excursion + (or (progn (end-of-line) (lilysong-find-song 'backward)) + (progn (beginning-of-line) (lilysong-find-song 'forward))))) + +(defun lilysong-all-songs (&optional limit-to-region) + "Return list of XML file names of the song commands in the current buffer. +If there are none, return an empty list. +If LIMIT-TO-REGION is non-nil, look for the commands in the current region +only." + (let ((result '()) + (current nil)) + (save-excursion + (save-restriction + (when limit-to-region + (narrow-to-region (or (mark) (point)) (point))) + (goto-char (point-min)) + (while (setq current (lilysong-find-song 'forward)) + (push current result)))) + (nreverse result))) + +(defun lilysong-walk-files (collector) + (save-excursion + (mapcar (lambda (f) + (set-buffer (find-file-noselect f)) + (funcall collector)) + (lilysong-document-files)))) + +(defun lilysong-all-songs* () + "Return list of XML file names of the song commands in the current document." + (remove-duplicates (apply #'append (lilysong-walk-files #'lilysong-all-songs)) + :test #'equal)) + +(defvar lilysong-song-history nil) +(make-variable-buffer-local 'lilysong-song-history) + +(defvar lilysong-last-song-list nil) +(make-variable-buffer-local 'lilysong-last-song-list) + +(defvar lilysong-last-command-args nil) +(make-variable-buffer-local 'lilysong-last-command-args) + +(defun lilysong-song-list (multi) + (cond + ((eq multi 'all) + (lilysong-all-songs*)) + (multi + (lilysong-select-songs)) + (t + (lilysong-select-single-song)))) + +(defun lilysong-select-single-song () + (let ((song (lilysong-current-song))) + (if song + (list song) + (error "No song found")))) + +(defun lilysong-select-songs () + (let* ((all-songs (lilysong-all-songs*)) + (available-songs all-songs) + (initial-songs (if (or (not lilysong-last-song-list) + (eq LilyPond-command-current + 'LilyPond-command-region)) + (lilysong-all-songs t) + lilysong-last-song-list)) + (last-input (completing-read + (format "Sing file%s: " + (if initial-songs + (format " (default `%s')" + (mapconcat 'identity initial-songs + ", ")) + "")) + (mapcar 'list all-songs) + nil t nil + 'lilysong-song-history))) + (if (equal last-input "") + initial-songs + (let ((song-list '()) + default-input) + (while (not (equal last-input "")) + (push last-input song-list) + (setq default-input (second (member last-input available-songs))) + (setq available-songs (remove last-input available-songs)) + (setq last-input (completing-read "Sing file: " + (mapcar #'list available-songs) + nil t default-input + 'lilysong-song-history))) + (setq lilysong-last-song-list (nreverse song-list)))))) + +(defun lilysong-count-midi-words () + (count-rexp (point-min) (point-max) "^[^%]*\\\\midi")) + +(defun lilysong-midi-list (multi) + (if multi + (let ((basename (file-name-sans-extension (buffer-file-name))) + (count (apply #'+ (save-match-data + (lilysong-walk-files #'lilysong-count-midi-words)))) + (midi-files '())) + (while (> count 0) + (setq count (1- count)) + (if (= count 0) + (push (concat basename ".midi") midi-files) + (push (format "%s-%d.midi" basename count) midi-files))) + midi-files) + (list (LilyPond-string-current-midi)))) + + +;;; Compilation + + +(defun lilysong-file->wav (filename &optional extension) + (format "%s.%s" (save-match-data + (if (string-match "\\.midi$" filename) + filename + (file-name-sans-extension filename))) + (or extension "wav"))) + +(defun lilysong-file->ewf (filename) + (lilysong-file->wav filename "ewf")) + +(defstruct lilysong-compilation-data + command + makefile + buffer + songs + midi + in-parallel) +(defvar lilysong-compilation-data nil) +(defun lilysong-sing (songs &optional midi-files in-parallel) + (setq lilysong-last-command-args (list songs midi-files in-parallel)) + (lilysong-update-language) + (add-to-list 'compilation-finish-functions 'lilysong-after-compilation) + (setq songs (mapcar #'expand-file-name songs)) + (let* ((makefile (lilysong-makefile (current-buffer) songs midi-files)) + (command (format "make -f %s" makefile))) + (setq lilysong-compilation-data + (make-lilysong-compilation-data + :command command + :makefile makefile + :buffer (current-buffer) + :songs songs + :midi midi-files + :in-parallel in-parallel)) + (save-some-buffers (not compilation-ask-about-save)) + (unless (equal lilysong-language lilysong-last-language) + (mapc #'(lambda (f) (when (file-exists-p f) (delete-file f))) + (append songs (mapcar 'lilysong-file->wav midi-files)))) + (if (lilysong-up-to-date-p makefile) + (lilysong-process-generated-files lilysong-compilation-data) + (compile command)))) + +(defun lilysong-up-to-date-p (makefile) + (equal (call-process "make" nil nil nil "-f" makefile "-q") 0)) + +(defun lilysong-makefile (buffer songs midi-files) + (let ((temp-file (make-temp-file "Makefile.lilysong-el")) + (language lilysong-language)) + (with-temp-file temp-file + (let ((source-files (save-excursion + (set-buffer buffer) + (lilysong-document-files))) + (master-file (save-excursion + (set-buffer buffer) + (LilyPond-get-master-file))) + (lilyfiles (append songs midi-files))) + (insert "all:") + (dolist (f (mapcar 'lilysong-file->wav (append songs midi-files))) + (insert " " f)) + (insert "\n") + (when lilyfiles + (dolist (f songs) + (insert f " ")) + (when midi-files + (dolist (f midi-files) + (insert f " "))) + (insert ": " master-file "\n") + (insert "\t" LilyPond-lilypond-command " " master-file "\n") + (dolist (f songs) + (insert (lilysong-file->wav f) ": " f "\n") + (insert "\t" LilyPond-synthesize-command " $< " (or language "") "\n")) + ;; We can't use midi files in ecasound directly, because setpos + ;; doesn't work on them. + (let ((lilymidi LilyPond-lilymidi-command) + (voice-rate (format "%d" (or (cdr (assoc-if (lambda (key) (string-match key language)) + LilyPond-voice-rates)) + 16000)))) + (when (string-match "%s" lilymidi) + (setq lilymidi (replace-match LilyPond-voice-track-regexp nil nil lilymidi))) + (dolist (f midi-files) + (insert (lilysong-file->wav f) ": " f "\n") + (let ((command LilyPond-midi->wav-command) + (lilymidi* lilymidi)) + (when (string-match "%s" command) + (setq command (replace-match f nil nil command))) + (when (string-match "%t" command) + (setq command (replace-match (lilysong-file->wav f) nil nil command))) + (when (string-match "%r" command) + (setq command (replace-match voice-rate nil nil command))) + (when (string-match "%f" lilymidi*) + (setq lilymidi (replace-match f nil nil lilymidi*))) + (when (string-match "%m" command) + (setq command (replace-match lilymidi nil nil command))) + (insert "\t" command "\n"))) + )))) + temp-file)) + +(defun lilysong-after-compilation (buffer message) + (let ((data lilysong-compilation-data)) + (when (and data + (equal compile-command + (lilysong-compilation-data-command data))) + (unwind-protect + (when (lilysong-up-to-date-p (lilysong-compilation-data-makefile data)) + (lilysong-process-generated-files data)) + (delete-file (lilysong-compilation-data-makefile data)))))) + +(defun lilysong-process-generated-files (data) + (with-current-buffer (lilysong-compilation-data-buffer data) + (setq lilysong-last-language lilysong-language)) + (lilysong-play-files (lilysong-compilation-data-in-parallel data) + (lilysong-compilation-data-songs data) + (lilysong-compilation-data-midi data))) + + +;;; Playing files + + +(defun lilysong-play-files (in-parallel songs midi-files) + (funcall (if LilyPond-use-ecasound + 'lilysong-play-with-ecasound + 'lilysong-play-with-play) + in-parallel songs midi-files)) + +(defun lilysong-call-play (files) + (apply 'start-process "lilysong-el" nil LilyPond-play-command files)) + +(defun lilysong-play-with-play (in-parallel songs midi-files) + (let ((files (mapcar 'lilysong-file->wav (append songs midi-files)))) + (if in-parallel + (dolist (f files) + (lilysong-call-play (list f))) + (lilysong-call-play files)))) + +(defun lilysong-make-ewf-files (files) + (let ((offset 0.0)) + (dolist (f files) + (let* ((wav-file (lilysong-file->wav f)) + (length (with-temp-buffer + (call-process "ecalength" nil t nil "-s" wav-file) + (goto-char (point-max)) + (forward-line -1) + (read (current-buffer))))) + (with-temp-file (lilysong-file->ewf f) + (insert "source = " wav-file "\n") + (insert (format "offset = %s\n" offset)) + (insert "start-position = 0.0\n") + (insert (format "length = %s\n" length)) + (insert "looping = false\n")) + (setq offset (+ offset length)))))) + +(when (and (featurep 'ecasound) + (not (fboundp 'eci-cs-set-param))) + (defeci cs-set-param ((parameter "sChainsetup option: " "%s")))) + +(defun lilysong-play-with-ecasound (in-parallel songs midi-files) + (ecasound) + (eci-cs-add "lilysong-el") + (eci-cs-select "lilysong-el") + (eci-cs-remove) + (eci-cs-add "lilysong-el") + (eci-cs-select "lilysong-el") + (eci-cs-set-param "-z:mixmode,sum") + (unless in-parallel + (lilysong-make-ewf-files songs) + ;; MIDI files should actually start with each of the songs + (mapc 'lilysong-make-ewf-files (mapcar 'list midi-files))) + (let* ((file->wav (if in-parallel 'lilysong-file->wav 'lilysong-file->ewf)) + (files (mapcar file->wav (append songs midi-files)))) + (dolist (f files) + (eci-c-add f) + (eci-c-select f) + (eci-ai-add f)) + (eci-c-select-all) + (eci-ao-add-default) + (let* ((n (length songs)) + (right (if (<= n 1) 50 0)) + (step (if (<= n 1) 0 (/ 100.0 (1- n))))) + (dolist (f songs) + (let ((chain (funcall file->wav f))) + (eci-c-select chain) + (eci-cop-add "-erc:1,2") + (eci-cop-add (format "-epp:%f" (min right 100))) + (incf right step)))) + (eci-start))) + + +;;; User commands + + +(defun lilysong-arg->multi (arg) + (cond + ((not arg) + nil) + ((or + (numberp arg) + (equal arg '(4))) + t) + (t + 'all))) + +(defun lilysong-command (arg play-midi?) + (let* ((multi (lilysong-arg->multi arg)) + (song-list (lilysong-song-list multi)) + (midi-list (if play-midi? (lilysong-midi-list multi)))) + (message "Singing %s" (mapconcat 'identity song-list ", ")) + (lilysong-sing song-list midi-list (if play-midi? t (listp arg))))) + +(defun LilyPond-command-sing (&optional arg) + "Sing lyrics of the current LilyPond buffer. +Without any prefix argument, sing current \\festival* command. +With the universal prefix argument, ask which parts to sing. +With a double universal prefix argument, sing all the parts. +With a numeric prefix argument, ask which parts to sing and sing them +sequentially rather than in parallel." + (interactive "P") + (lilysong-command arg nil)) + +(defun LilyPond-command-sing-and-play (&optional arg) + "Sing lyrics and play midi of the current LilyPond buffer. +Without any prefix argument, sing and play current \\festival* and \\midi +commands. +With the universal prefix argument, ask which parts to sing and play. +With a double universal prefix argument, sing and play all the parts." + (interactive "P") + (lilysong-command arg t)) + +(defun LilyPond-command-sing-last () + "Repeat last LilyPond singing command." + (interactive) + (if lilysong-last-command-args + (apply 'lilysong-sing lilysong-last-command-args) + (error "No previous singing command"))) + +(defun LilyPond-command-clean () + "Remove generated *.xml and *.wav files used for singing." + (interactive) + (flet ((delete-file* (file) + (when (file-exists-p file) + (delete-file file)))) + (dolist (xml-file (lilysong-song-list 'all)) + (delete-file* xml-file) + (delete-file* (lilysong-file->wav xml-file))) + (mapc 'delete-file* (mapcar 'lilysong-file->wav (lilysong-midi-list 'all))))) + +(define-key LilyPond-mode-map "\C-c\C-a" 'LilyPond-command-sing) +(define-key LilyPond-mode-map "\C-c\C-q" 'LilyPond-command-sing-and-play) +(define-key LilyPond-mode-map "\C-c\C-x" 'LilyPond-command-clean) +(define-key LilyPond-mode-map "\C-c\C-z" 'LilyPond-command-sing-last) + +(easy-menu-add-item LilyPond-command-menu nil + ["Sing Current" LilyPond-command-sing t]) +(easy-menu-add-item LilyPond-command-menu nil + ["Sing Selected" (LilyPond-command-sing '(4)) t]) +(easy-menu-add-item LilyPond-command-menu nil + ["Sing All" (LilyPond-command-sing '(16)) t]) +(easy-menu-add-item LilyPond-command-menu nil + ["Sing Selected Sequentially" (LilyPond-command-sing 1) t]) +(easy-menu-add-item LilyPond-command-menu nil + ["Sing and Play Current" LilyPond-command-sing-and-play t]) +(easy-menu-add-item LilyPond-command-menu nil + ["Sing and Play Selected" (LilyPond-command-sing-and-play '(4)) t]) +(easy-menu-add-item LilyPond-command-menu nil + ["Sing and Play All" (LilyPond-command-sing-and-play '(16)) t]) +(easy-menu-add-item LilyPond-command-menu nil + ["Sing Last" LilyPond-command-sing-last t]) + + +;;; Announce + +(provide 'lilypond-song) + + +;;; lilypond-song.el ends here diff --git a/ly/festival.ly b/ly/festival.ly new file mode 100644 index 0000000000..f77b48f8e5 --- /dev/null +++ b/ly/festival.ly @@ -0,0 +1,38 @@ +% festival.ly --- Festival singing mode output +% +% Copyright (C) 2006, 2007 Brailcom, o.p.s. +% +% Author: Milan Zamazal +% +% COPYRIGHT NOTICE +% +% This program 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 2 of the License, or +% (at your option) any later version. +% +% This program 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 this program; if not, write to the Free Software +% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + +\version "2.11.11" + +#(use-modules (scm song)) + +% \festival #"filename" { \tempo N = X } { music } +festival = +#(define-music-function (parser location filename tempo music) (string? ly:music? ly:music?) + (output-file music tempo filename) + music) + +% \festivalsyl #"filename" { \tempo N = X } { music } +festivalsyl = +#(define-music-function (parser location filename tempo music) (string? ly:music? ly:music?) + (set! *syllabify* #t) + (output-file music tempo filename) + music) diff --git a/scm/song-util.scm b/scm/song-util.scm new file mode 100644 index 0000000000..22e5d83bd9 --- /dev/null +++ b/scm/song-util.scm @@ -0,0 +1,202 @@ +;;; festival.scm --- Festival singing mode output + +;; Copyright (C) 2006, 2007 Brailcom, o.p.s. + +;; Author: Milan Zamazal + +;; COPYRIGHT NOTICE + +;; This program 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 2 of the License, or +;; (at your option) any later version. + +;; This program 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 this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + + +(define-module (scm song-util)) + +(use-modules (srfi srfi-1)) +(use-modules (ice-9 optargs)) +(use-modules (ice-9 pretty-print)) + +(use-modules (lily)) + + +;;; Debugging utilities + + +;; Iff true, enable a lot of debugging output +(define-public *debug* #f) + +(define-macro (assert condition . data) + (if *debug* + `(if (not ,condition) + (error "Assertion failed" (quote ,condition) ,@data)) + #f)) +(export assert) + +(define-macro (debug message object) + (if *debug* + `(debug* ,message ,object) + object)) +(export debug) + +(define (debug* message object) + (display "[[") (display message) (display "]] ") (pretty-print object) + object) + + +;;; General utilities + + +(define-macro (defstruct name . slots) + ;; Similar as in Common Lisp, but much simplier -- no structure and slot options, no docstring + (let* ((slots* (map (lambda (s) (if (pair? s) s (list s))) slots)) + (make-symbol (lambda (format% . extra-args) + (string->symbol (apply format #f format% name extra-args)))) + ($record? (make-symbol "~a?")) + ($make-record (make-symbol "make-~a")) + ($copy-record (make-symbol "copy-~a")) + (reader-format "~a-~a") + (writer-format "set-~a-~a!") + (record (gensym))) + `(begin + (define ,$record? #f) + (define ,$make-record #f) + (define ,$copy-record #f) + ,@(map (lambda (s) `(define ,(make-symbol reader-format (car s)) #f)) slots*) + ,@(map (lambda (s) `(define ,(make-symbol writer-format (car s)) #f)) slots*) + (let ((,record ,(make-record-type name (map car slots*)))) + (set! ,$record? + (lambda (record) ((record-predicate ,record) record))) + (set! ,$make-record + (lambda* (#:key ,@slots) + ((record-constructor ,record) ,@(map car slots*)))) + (set! ,$copy-record + (lambda (record) + (,$make-record ,@(apply + append + (map (lambda (slot) + (list (symbol->keyword slot) + (list (make-symbol reader-format slot) 'record))) + (map car slots*)))))) + ,@(map (lambda (s) + `(set! ,(make-symbol reader-format (car s)) + (record-accessor ,record (quote ,(car s))))) + slots*) + ,@(map (lambda (s) + `(set! ,(make-symbol writer-format (car s)) + (record-modifier ,record (quote ,(car s))))) + slots*))))) +(export defstruct) + +(define-public (compose . functions) + (let ((functions* (drop-right functions 1)) + (last-function (last functions))) + (letrec ((reduce (lambda (x functions) + (if (null? functions) + x + (reduce ((car functions) x) (cdr functions)))))) + (lambda args (reduce (apply (last functions) args) (reverse functions*)))))) + +(define-macro (push! object list-var) + ;; The same as in Common Lisp + `(set! ,list-var (cons ,object ,list-var))) +(export push!) + +(define-macro (add! object list-var) + `(set! ,list-var (append ,list-var (list ,object)))) +(export add!) + +(define-public (flatten lst) + (cond + ((null? lst) + lst) + ((pair? (car lst)) + (append (flatten (car lst)) (flatten (cdr lst)))) + (else + (cons (car lst) (flatten (cdr lst)))))) + +(define-public (safe-car list) + (if (null? list) + #f + (car list))) + +(define-public (safe-last list) + (if (null? list) + #f + (last list))) + + +;;; LilyPond utility functions + + +(define-public (music-property-value? music property value) + "Return true iff MUSIC's PROPERTY is equal to VALUE." + (equal? (ly:music-property music property) value)) + +(define-public (music-name? music name) + "Return true iff MUSIC's name is NAME." + (if (list? name) + (member (ly:music-property music 'name) name) + (music-property-value? music 'name name))) + +(define-public (music-property? music property) + "Return true iff MUSIC is a property setter and sets or unsets PROPERTY." + (and (music-name? music '(PropertySet PropertyUnset)) + (music-property-value? music 'symbol property))) + +(define-public (music-has-property? music property) + "Return true iff MUSIC contains PROPERTY." + (not (eq? (ly:music-property music property) '()))) + +(define-public (property-value music) + "Return value of a property setter MUSIC. +If it unsets the property, return #f." + (if (music-name? music 'PropertyUnset) + #f + (ly:music-property music 'value))) + +(define-public (music-elements music) + "Return list of all MUSIC's top-level children." + (let ((elt (ly:music-property music 'element)) + (elts (ly:music-property music 'elements))) + (if (not (null? elt)) + (cons elt elts) + elts))) + +(define-public (find-child music predicate) + "Find the first node in MUSIC that satisfies PREDICATE." + (define (find-child queue) + (if (null? queue) + #f + (let ((elt (car queue))) + (if (predicate elt) + elt + (find-child (append (music-elements elt) (cdr queue))))))) + (find-child (list music))) + +(define-public (find-child-named music name) + "Return the first child in MUSIC that is named NAME." + (find-child music (lambda (elt) (music-name? elt name)))) + +(define-public (process-music music function) + "Process all nodes of MUSIC (including MUSIC) in the DFS order. +Apply FUNCTION on each of the nodes. +If FUNCTION applied on a node returns true, don't process the node's subtree." + (define (process-music queue) + (if (not (null? queue)) + (let* ((elt (car queue)) + (stop (function elt))) + (process-music (if stop + (cdr queue) + (append (music-elements elt) (cdr queue))))))) + (process-music (list music))) diff --git a/scm/song.scm b/scm/song.scm new file mode 100644 index 0000000000..313480a85a --- /dev/null +++ b/scm/song.scm @@ -0,0 +1,839 @@ +;;; festival.scm --- Festival singing mode output + +;; Copyright (C) 2006, 2007 Brailcom, o.p.s. + +;; Author: Milan Zamazal + +;; COPYRIGHT NOTICE + +;; This program 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 2 of the License, or +;; (at your option) any later version. + +;; This program 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 this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + + +(define-module (scm song)) + +(use-modules (srfi srfi-1)) +(use-modules (ice-9 optargs)) +(use-modules (ice-9 receive)) + +(use-modules (lily)) +(use-modules (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* "-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* #f) + +;; Base Festival octave to which LilyPond notes are mapped. +(define-public *base-octave* 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* 0) + +;; The coeficient by which the notes just before \breath are shortened. +(define-public *breathe-shortage* 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)) + #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" + (cdr (assoc (modulo pitch 12) pp-pitch-names)) + (let ((octave (+ (inexact->exact (floor (/ pitch 12))) 1))) + (cond + ((= octave 0) + "") + ((> octave 0) + (make-uniform-array #\' octave)) + ((< octave 0) + (make-uniform-array #\, (- 0 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) + (let* ((log (ly:duration-log duration)) + (dots (ly:duration-dot-count duration)) + (factor (ly:duration-factor duration))) + (exact->inexact (* (expt 2 (- log)) (+ 1 (/ dots 2)) (/ (car factor) (cdr factor)))))) + +(define (tempo->beats music) + (let* ((tempo-spec (or (find-child-named music 'MetronomeChangeEvent) + (find-child-named music 'SequentialMusic))) + (tempo (cond + ((not tempo-spec) + #f) + ((music-name? tempo-spec 'MetronomeChangeEvent) + (* (ly:music-property tempo-spec 'metronome-count) + (duration->number (ly:music-property tempo-spec 'tempo-unit)))) + ((music-name? tempo-spec 'SequentialMusic) + (* (property-value + (find-child tempo-spec (lambda (elt) (music-property? elt 'tempoUnitCount)))) + (duration->number + (property-value + (find-child tempo-spec (lambda (elt) (music-property? elt 'tempoUnitDuration))))))) + (else + (format #t "Programming error (tempo->beats): ~a~%" tempo-spec))))) + (debug-enable 'backtrace) + (if (and tempo (music-name? tempo-spec 'SequentialMusic)) + (set! *default-tempo* (property-value + (find-child tempo-spec (lambda (elt) (music-property? elt 'tempoWholesPerMinute)))))) + (if tempo + (round (* tempo (expt 2 (+ 2 *base-octave-shift*)))) + #f))) + +(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) + (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)))))) + #f) + ;; 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))))) + ;; tempo change + ((music-property? music 'tempoWholesPerMinute) + (set! *tempo-compression* (ly:moment-div *default-tempo* (property-value music)))) + ;; 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"))) + ;; 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" (cadr (assoc tone festival-note-mapping)) + (+ octave *base-octave* *base-octave-shift*)))) + +(define (write-header port tempo) + (let ((beats (or (tempo->beats tempo) 100))) + (format port " + + +" beats))) + +(define (write-footer port) + (format port "~%")) + +(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 "~a~%" + fmt (transform note-duration) + fmt (transform (compose festival-pitch note-pitch)) + text))) + +(define (write-rest-element port duration) + (format port "~%" duration)) diff --git a/scripts/GNUmakefile b/scripts/GNUmakefile index af9bf1b9e3..bae147532a 100644 --- a/scripts/GNUmakefile +++ b/scripts/GNUmakefile @@ -1,6 +1,6 @@ depth = .. -SEXECUTABLES=convert-ly lilypond-book abc2ly etf2ly midi2ly lilypond-invoke-editor musicxml2ly +SEXECUTABLES=convert-ly lilypond-book abc2ly etf2ly midi2ly lilypond-invoke-editor musicxml2ly lilysong lilymidi STEPMAKE_TEMPLATES=script help2man po LOCALSTEPMAKE_TEMPLATES = lilypond diff --git a/scripts/lilymidi.py b/scripts/lilymidi.py new file mode 100755 index 0000000000..22eb8e61f4 --- /dev/null +++ b/scripts/lilymidi.py @@ -0,0 +1,89 @@ +#!@TARGET_PYTHON@ + +# Copyright (C) 2006, 2007 Brailcom, o.p.s. +# +# Author: Milan Zamazal +# +# COPYRIGHT NOTICE +# +# This program 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 2 of the License, or +# (at your option) any later version. +# +# This program 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 this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + + +import optparse +import os +import sys + +""" +@relocate-preamble@ +""" + +def process_options (args): + parser = optparse.OptionParser (version="@TOPLEVEL_VERSION@") + parser.add_option ('', '--filter-tracks', metavar='REGEXP', action='store', type='string', dest='regexp', + help="display only tracks numbers, of those track names matching REGEXP") + parser.add_option ('', '--prefix-tracks', metavar='PREFIX', action='store', type='string', dest='prefix', + help="prefix filtered track numbers with PREFIX") + parser.add_option ('', '--dump', action='store_true', dest='dump', + help="just dump parsed contents of the MIDI file") + parser.usage = parser.usage + " FILE" + options, args = parser.parse_args (args) + if len (args) != 1: + parser.print_help () + sys.exit (2) + return options, args + +def read_midi (file): + import midi + return midi.parse (open (file).read ()) + +def track_info (data): + tracks = data[1] + def track_name (track): + name = '' + for time, event in track: + if time > 0: + break + if event[0] == 255 and event[1] == 3: + name = event[2] + break + return name + track_info = [] + for i in range (len (tracks)): + track_info.append ((i, track_name (tracks[i]))) + return track_info + +def go (): + options, args = process_options (sys.argv[1:]) + midi_file = args[0] + midi_data = read_midi (midi_file) + info = track_info (midi_data) + if options.dump: + print midi_data + elif options.regexp: + import re + regexp = re.compile (options.regexp) + numbers = [str(n+1) for n, name in info if regexp.search (name)] + if numbers: + if options.prefix: + sys.stdout.write ('%s ' % (options.prefix,)) + import string + sys.stdout.write (string.join (numbers, ',')) + sys.stdout.write ('\n') + else: + for n, name in info: + sys.stdout.write ('%d %s\n' % (n+1, name,)) + +if __name__ == '__main__': + go () diff --git a/scripts/lilysong.py b/scripts/lilysong.py new file mode 100755 index 0000000000..18d047a137 --- /dev/null +++ b/scripts/lilysong.py @@ -0,0 +1,217 @@ +#!@TARGET_PYTHON@ + +# Copyright (C) 2006, 2007 Brailcom, o.p.s. +# +# Author: Milan Zamazal +# +# COPYRIGHT NOTICE +# +# This program 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 2 of the License, or +# (at your option) any later version. +# +# This program 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 this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + + +import codecs +import optparse +import os +import popen2 +import sys +import tempfile + +""" +@relocate-preamble@ +""" + + +FESTIVAL_COMMAND = 'festival --pipe' +VOICE_CODINGS = {'voice_czech_ph': 'iso-8859-2'} + +_USAGE = """lilysong [ -p PLAY-PROGRAM ] FILE.xml [ LANGUAGE-CODE-OR-VOICE [ SPEEDUP ] ] +./lilysong FILE.ly [ LANGUAGE-CODE-OR-VOICE ] +./lilysong --list-voices +./lilysong --list-languages +""" + +def usage (): + print 'usage:', _USAGE + sys.exit (2) + +def process_options (args): + parser = optparse.OptionParser (usage=_USAGE, version="@TOPLEVEL_VERSION@") + parser.add_option ('', '--list-voices', action='store_true', dest='list_voices', + help="list available Festival voices") + parser.add_option ('', '--list-languages', action='store_true', dest='list_languages', + help="list available Festival languages") + parser.add_option ('-p', '--play-program', metavar='PROGRAM', + action='store', type='string', dest='play_program', + help="use PROGRAM to play song immediately") + options, args = parser.parse_args (args) + return options, args + +def call_festival (scheme_code): + in_, out = popen2.popen2 (FESTIVAL_COMMAND) + out.write (scheme_code) + out.close () + answer = '' + while True: + process_output = in_.read () + if not process_output: + break + answer = answer + process_output + return answer + +def select_voice (language_or_voice): + if language_or_voice[:6] == 'voice_': + voice = language_or_voice + else: + voice = call_festival (''' +(let ((candidates '())) + (mapcar (lambda (v) + (if (eq (cadr (assoc 'language (cadr (voice.description v)))) '%s) + (set! candidates (cons v candidates)))) + (append (voice.list) (mapcar car Voice_descriptions))) + (if candidates + (format t "voice_%%s" (car candidates)) + (format t "nil"))) +''' % (language_or_voice,)) + if voice == 'nil': + voice = None + return voice + +def list_voices (): + print call_festival (''' +(let ((voices (voice.list)) + (print-voice (lambda (v) (format t "voice_%s\n" v)))) + (mapcar print-voice voices) + (mapcar (lambda (v) (if (not (member v voices)) (print-voice v))) + (mapcar car Voice_descriptions))) +''') + +def list_languages (): + print call_festival (''' +(let ((languages '())) + (let ((voices (voice.list)) + (print-language (lambda (v) + (let ((language (cadr (assoc 'language (cadr (voice.description v)))))) + (if (and language (not (member language languages))) + (begin + (set! languages (cons language languages)) + (print language))))))) + (mapcar print-language voices) + (mapcar (lambda (v) (if (not (member v voices)) (print-language v))) + (mapcar car Voice_descriptions)))) +''') + +def process_xml_file (file_name, voice, speedup, play_program): + if speedup == 1: + speedup = None + coding = (VOICE_CODINGS.get (voice) or 'iso-8859-1') + _, xml_temp_file = tempfile.mkstemp ('.xml') + try: + # recode the XML file + recodep = (coding != 'utf-8') + if recodep: + decode = codecs.getdecoder ('utf-8') + encode = codecs.getencoder (coding) + input = open (file_name) + output = open (xml_temp_file, 'w') + while True: + data = input.read () + if not data: + break + if recodep: + data = encode (decode (data)[0])[0] + output.write (data) + output.close () + # synthesize + wav_file = file_name[:-3] + 'wav' + if speedup: + _, wav_temp_file = tempfile.mkstemp ('.wav') + else: + wav_temp_file = wav_file + try: + print "text2wave -eval '(%s)' -mode singing '%s' -o '%s'" % (voice, xml_temp_file, wav_temp_file,) + result = os.system ("text2wave -eval '(%s)' -mode singing '%s' -o '%s'" % + (voice, xml_temp_file, wav_temp_file,)) + if result: + sys.stdout.write ("Festival processing failed.\n") + return + if speedup: + result = os.system ("sox '%s' '%s' speed '%f'" % (wav_temp_file, wav_file, speedup,)) + if result: + sys.stdout.write ("Festival processing failed.\n") + return + finally: + if speedup: + try: + os.delete (wav_temp_file) + except: + pass + sys.stdout.write ("%s created.\n" % (wav_file,)) + # play + if play_program: + os.system ("%s '%s' >/dev/null" % (play_program, wav_file,)) + finally: + try: + os.delete (xml_temp_file) + except: + pass + +def process_ly_file (file_name, voice): + result = os.system ("lilypond '%s'" % (file_name,)) + if result: + return + xml_file = None + for f in os.listdir (os.path.dirname (file_name) or '.'): + if (f[-4:] == '.xml' and + (not xml_file or os.stat.st_mtime (f) > os.stat.st_mtime (xml_file))): + xml_file = f + if xml_file: + process_xml_file (xml_file, voice, None, None) + else: + sys.stderr.write ("No XML file found\n") + +def go (): + options, args = process_options (sys.argv[1:]) + if options.list_voices: + list_voices () + elif options.list_languages: + list_languages () + else: + arglen = len (args) + if arglen < 1: + usage () + file_name = args[0] + if arglen > 1: + language_or_voice = args[1] + voice = select_voice (language_or_voice) + else: + voice = None + if file_name[-3:] == '.ly': + if arglen > 2: + usage () + process_ly_file (file_name, voice) + else: + if arglen > 3: + usage () + elif arglen == 3: + try: + speedup = float (args[2]) + except ValueError: + usage () + else: + speedup = None + process_xml_file (file_name, voice, speedup, options.play_program) + +if __name__ == '__main__': + go ()