1 ;;;; song-util.scm --- Festival singing mode output
3 ;;;; This file is part of LilyPond, the GNU music typesetter.
5 ;;;; Copyright (C) 2006, 2007 Brailcom, o.p.s.
6 ;;;; Author: Milan Zamazal <pdm@brailcom.org>
8 ;;;; LilyPond is free software: you can redistribute it and/or modify
9 ;;;; it under the terms of the GNU General Public License as published by
10 ;;;; the Free Software Foundation, either version 3 of the License, or
11 ;;;; (at your option) any later version.
13 ;;;; LilyPond is distributed in the hope that it will be useful,
14 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;;; GNU General Public License for more details.
18 ;;;; You should have received a copy of the GNU General Public License
19 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
22 (define-module (scm song-util))
24 (use-modules (srfi srfi-1))
25 (use-modules (ice-9 optargs))
26 (use-modules (ice-9 pretty-print))
31 ;;; Debugging utilities
34 ;; Iff true, enable a lot of debugging output
35 (define-public *debug* #f)
37 (define-macro (assert condition . data)
40 (error "Assertion failed" (quote ,condition) ,@data))
44 (define-macro (debug message object)
46 `(debug* ,message ,object)
50 (define (debug* message object)
51 (display "[[") (display message) (display "]] ") (pretty-print object)
58 (define-macro (defstruct name . slots)
59 ;; Similar as in Common Lisp, but much simplier -- no structure and slot options, no docstring
60 (let* ((slots* (map (lambda (s) (if (pair? s) s (list s))) slots))
61 (make-symbol (lambda (format% . extra-args)
62 (string->symbol (apply format #f format% name extra-args))))
63 ($record? (make-symbol "~a?"))
64 ($make-record (make-symbol "make-~a"))
65 ($copy-record (make-symbol "copy-~a"))
66 (reader-format "~a-~a")
67 (writer-format "set-~a-~a!")
71 (define ,$make-record #f)
72 (define ,$copy-record #f)
73 ,@(map (lambda (s) `(define ,(make-symbol reader-format (car s)) #f)) slots*)
74 ,@(map (lambda (s) `(define ,(make-symbol writer-format (car s)) #f)) slots*)
75 (let ((,record ,(make-record-type name (map car slots*))))
77 (lambda (record) ((record-predicate ,record) record)))
79 (lambda* (#:key ,@slots)
80 ((record-constructor ,record) ,@(map car slots*))))
83 (,$make-record ,@(apply
86 (list (symbol->keyword slot)
87 (list (make-symbol reader-format slot) 'record)))
90 `(set! ,(make-symbol reader-format (car s))
91 (record-accessor ,record (quote ,(car s)))))
94 `(set! ,(make-symbol writer-format (car s))
95 (record-modifier ,record (quote ,(car s)))))
99 (define-public (compose . functions)
100 (let ((functions* (drop-right functions 1))
101 (last-function (last functions)))
102 (letrec ((reduce (lambda (x functions)
103 (if (null? functions)
105 (reduce ((car functions) x) (cdr functions))))))
106 (lambda args (reduce (apply (last functions) args) (reverse functions*))))))
108 (define-macro (push! object list-var)
109 ;; The same as in Common Lisp
110 `(set! ,list-var (cons ,object ,list-var)))
113 (define-macro (add! object list-var)
114 `(set! ,list-var (append ,list-var (list ,object))))
117 (define-public (safe-car list)
122 (define-public (safe-last list)
128 ;;; LilyPond utility functions
131 (define-public (music-property-value? music property value)
132 "Return @code{#t} iff @var{music}'s @var{property} is equal to
134 (equal? (ly:music-property music property) value))
136 (define-public (music-name? music name)
137 "Return @code{#t} iff @var{music}'s name is @var{name}."
139 (member (ly:music-property music 'name) name)
140 (music-property-value? music 'name name)))
142 (define-public (music-property? music property)
143 "Return @code{#t} iff @var{music} is a property setter and sets
144 or unsets @var{property}."
145 (and (music-name? music '(PropertySet PropertyUnset))
146 (music-property-value? music 'symbol property)))
148 (define-public (music-has-property? music property)
149 "Return @code{#t} iff @var{music} contains @var{property}."
150 (not (eq? (ly:music-property music property) '())))
152 (define-public (property-value music)
153 "Return value of a property setter @var{music}.
154 If it unsets the property, return @code{#f}."
155 (if (music-name? music 'PropertyUnset)
157 (ly:music-property music 'value)))
159 (define-public (music-elements music)
160 "Return list of all @var{music}'s top-level children."
161 (let ((elt (ly:music-property music 'element))
162 (elts (ly:music-property music 'elements))
163 (arts (ly:music-property music 'articulations)))
165 (set! elts (append elts arts)))
170 (define-public (find-child music predicate)
171 "Find the first node in @var{music} that satisfies @var{predicate}."
172 (define (find-child queue)
175 (let ((elt (car queue)))
178 (find-child (append (music-elements elt) (cdr queue)))))))
179 (find-child (list music)))
181 (define-public (find-child-named music name)
182 "Return the first child in @var{music} that is named @var{name}."
183 (find-child music (lambda (elt) (music-name? elt name))))
185 (define-public (process-music music function)
186 "Process all nodes of @var{music} (including @var{music}) in the DFS order.
187 Apply @var{function} on each of the nodes. If @var{function} applied on a
188 node returns @code{#t}, don't process the node's subtree.
190 If a non-boolean is returned, it is considered the material to recurse."
191 (define (process-music queue)
192 (if (not (null? queue))
193 (let* ((elt (car queue))
194 (stop (function elt)))
195 (process-music (if (boolean? stop)
198 (append (music-elements elt) (cdr queue)))
199 ((if (cheap-list? stop) append cons)
200 stop (cdr queue)))))))
201 (process-music (list music)))