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 ,@(append-map
85 (list (symbol->keyword slot)
86 (list (make-symbol reader-format slot) 'record)))
89 `(set! ,(make-symbol reader-format (car s))
90 (record-accessor ,record (quote ,(car s)))))
93 `(set! ,(make-symbol writer-format (car s))
94 (record-modifier ,record (quote ,(car s)))))
98 (define-public (compose . functions)
99 (let ((functions* (drop-right functions 1))
100 (last-function (last functions)))
101 (letrec ((reduce (lambda (x functions)
102 (if (null? functions)
104 (reduce ((car functions) x) (cdr functions))))))
105 (lambda args (reduce (apply (last functions) args) (reverse functions*))))))
107 (define-macro (push! object list-var)
108 ;; The same as in Common Lisp
109 `(set! ,list-var (cons ,object ,list-var)))
112 (define-macro (add! object list-var)
113 `(set! ,list-var (append ,list-var (list ,object))))
116 (define-public (safe-car list)
121 (define-public (safe-last list)
127 ;;; LilyPond utility functions
130 (define-public (music-property-value? music property value)
131 "Return @code{#t} iff @var{music}'s @var{property} is equal to
133 (equal? (ly:music-property music property) value))
135 (define-public (music-name? music name)
136 "Return @code{#t} iff @var{music}'s name is @var{name}."
138 (member (ly:music-property music 'name) name)
139 (music-property-value? music 'name name)))
141 (define-public (music-property? music property)
142 "Return @code{#t} iff @var{music} is a property setter and sets
143 or unsets @var{property}."
144 (and (music-name? music '(PropertySet PropertyUnset))
145 (music-property-value? music 'symbol property)))
147 (define-public (music-has-property? music property)
148 "Return @code{#t} iff @var{music} contains @var{property}."
149 (not (eq? (ly:music-property music property) '())))
151 (define-public (property-value music)
152 "Return value of a property setter @var{music}.
153 If it unsets the property, return @code{#f}."
154 (if (music-name? music 'PropertyUnset)
156 (ly:music-property music 'value)))
158 (define-public (music-elements music)
159 "Return list of all @var{music}'s top-level children."
160 (let ((elt (ly:music-property music 'element))
161 (elts (ly:music-property music 'elements))
162 (arts (ly:music-property music 'articulations)))
164 (set! elts (append elts arts)))
169 (define-public (find-child music predicate)
170 "Find the first node in @var{music} that satisfies @var{predicate}."
171 (define (find-child queue)
174 (let ((elt (car queue)))
177 (find-child (append (music-elements elt) (cdr queue)))))))
178 (find-child (list music)))
180 (define-public (find-child-named music name)
181 "Return the first child in @var{music} that is named @var{name}."
182 (find-child music (lambda (elt) (music-name? elt name))))
184 (define-public (process-music music function)
185 "Process all nodes of @var{music} (including @var{music}) in the DFS order.
186 Apply @var{function} on each of the nodes. If @var{function} applied on a
187 node returns @code{#t}, don't process the node's subtree.
189 If a non-boolean is returned, it is considered the material to recurse."
190 (define (process-music queue)
191 (if (not (null? queue))
192 (let* ((elt (car queue))
193 (stop (function elt)))
194 (process-music (if (boolean? stop)
197 (append (music-elements elt) (cdr queue)))
198 ((if (cheap-list? stop) append cons)
199 stop (cdr queue)))))))
200 (process-music (list music)))