--- /dev/null
+;;; lilypond-song.el --- Emacs support for LilyPond singing
+
+;; Copyright (C) 2006 Brailcom, o.p.s.
+
+;; Author: Milan Zamazal <pdm@brailcom.org>
+
+;; 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)
+ (".*\\<fi\\(\\>\\|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
--- /dev/null
+% festival.ly --- Festival singing mode output
+%
+% Copyright (C) 2006, 2007 Brailcom, o.p.s.
+%
+% Author: Milan Zamazal <pdm@brailcom.org>
+%
+% 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)
--- /dev/null
+;;; festival.scm --- Festival singing mode output
+
+;; Copyright (C) 2006, 2007 Brailcom, o.p.s.
+
+;; Author: Milan Zamazal <pdm@brailcom.org>
+
+;; 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)))
--- /dev/null
+;;; festival.scm --- Festival singing mode output
+
+;; Copyright (C) 2006, 2007 Brailcom, o.p.s.
+
+;; Author: Milan Zamazal <pdm@brailcom.org>
+
+;; 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 "<?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))
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
--- /dev/null
+#!@TARGET_PYTHON@
+
+# Copyright (C) 2006, 2007 Brailcom, o.p.s.
+#
+# Author: Milan Zamazal <pdm@brailcom.org>
+#
+# 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 ()
--- /dev/null
+#!@TARGET_PYTHON@
+
+# Copyright (C) 2006, 2007 Brailcom, o.p.s.
+#
+# Author: Milan Zamazal <pdm@brailcom.org>
+#
+# 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 ()
projects / lilypond.git / commitdiff