]> git.donarmstrong.com Git - lilypond.git/blob - scm/song-util.scm
Merge branch 'master' into lilypond/translation
[lilypond.git] / scm / song-util.scm
1 ;;; festival.scm --- Festival singing mode output
2
3 ;; Copyright (C) 2006, 2007 Brailcom, o.p.s.
4
5 ;; Author: Milan Zamazal <pdm@brailcom.org>
6
7 ;; COPYRIGHT NOTICE
8
9 ;; This program is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2 of the License, or
12 ;; (at your option) any later version.
13
14 ;; This program is distributed in the hope that it will be useful, but
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
16 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 ;; for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with this program; if not, write to the Free Software
21 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA.
22
23
24 (define-module (scm song-util))
25
26 (use-modules (srfi srfi-1))
27 (use-modules (ice-9 optargs))
28 (use-modules (ice-9 pretty-print))
29
30 (use-modules (lily))
31
32
33 ;;; Debugging utilities
34
35
36 ;; Iff true, enable a lot of debugging output
37 (define-public *debug* #f)
38
39 (define-macro (assert condition . data)
40   (if *debug*
41       `(if (not ,condition)
42            (error "Assertion failed" (quote ,condition) ,@data))
43       #f))
44 (export assert)
45
46 (define-macro (debug message object)
47   (if *debug*
48       `(debug* ,message ,object)
49       object))
50 (export debug)
51
52 (define (debug* message object)
53   (display "[[") (display message) (display "]] ") (pretty-print object)
54   object)
55
56
57 ;;; General utilities
58
59
60 (define-macro (defstruct name . slots)
61   ;; Similar as in Common Lisp, but much simplier -- no structure and slot options, no docstring
62   (let* ((slots* (map (lambda (s) (if (pair? s) s (list s))) slots))
63          (make-symbol (lambda (format% . extra-args)
64                         (string->symbol (apply format #f format% name extra-args))))
65          ($record? (make-symbol "~a?"))
66          ($make-record (make-symbol "make-~a"))
67          ($copy-record (make-symbol "copy-~a"))
68          (reader-format "~a-~a")
69          (writer-format "set-~a-~a!")
70          (record (gensym)))
71     `(begin
72        (define ,$record? #f)
73        (define ,$make-record #f)
74        (define ,$copy-record #f)
75        ,@(map (lambda (s) `(define ,(make-symbol reader-format (car s)) #f)) slots*)
76        ,@(map (lambda (s) `(define ,(make-symbol writer-format (car s)) #f)) slots*)
77        (let ((,record ,(make-record-type name (map car slots*))))
78          (set! ,$record?
79                (lambda (record) ((record-predicate ,record) record)))
80          (set! ,$make-record
81                (lambda* (#:key ,@slots)
82                  ((record-constructor ,record) ,@(map car slots*))))
83          (set! ,$copy-record
84                (lambda (record)
85                  (,$make-record ,@(apply
86                                    append
87                                    (map (lambda (slot)
88                                           (list (symbol->keyword slot)
89                                                 (list (make-symbol reader-format slot) 'record)))
90                                         (map car slots*))))))
91          ,@(map (lambda (s)
92                   `(set! ,(make-symbol reader-format (car s))
93                          (record-accessor ,record (quote ,(car s)))))
94                 slots*)
95          ,@(map (lambda (s)
96                   `(set! ,(make-symbol writer-format (car s))
97                          (record-modifier ,record (quote ,(car s)))))
98                 slots*)))))
99 (export defstruct)
100
101 (define-public (compose . functions)
102   (let ((functions* (drop-right functions 1))
103         (last-function (last functions)))
104     (letrec ((reduce (lambda (x functions)
105                        (if (null? functions)
106                            x
107                            (reduce ((car functions) x) (cdr functions))))))
108       (lambda args (reduce (apply (last functions) args) (reverse functions*))))))
109
110 (define-macro (push! object list-var)
111   ;; The same as in Common Lisp
112   `(set! ,list-var (cons ,object ,list-var)))
113 (export push!)
114
115 (define-macro (add! object list-var)
116   `(set! ,list-var (append ,list-var (list ,object))))
117 (export add!)
118
119 (define-public (safe-car list)
120   (if (null? list)
121       #f
122       (car list)))
123
124 (define-public (safe-last list)
125   (if (null? list)
126       #f
127       (last list)))
128
129
130 ;;; LilyPond utility functions
131
132
133 (define-public (music-property-value? music property value)
134   "Return true iff MUSIC's PROPERTY is equal to VALUE."
135   (equal? (ly:music-property music property) value))
136
137 (define-public (music-name? music name)
138   "Return true iff MUSIC's name is NAME."
139   (if (list? name)
140       (member (ly:music-property music 'name) name)
141       (music-property-value? music 'name name)))
142
143 (define-public (music-property? music property)
144   "Return true iff MUSIC is a property setter and sets or unsets PROPERTY."
145   (and (music-name? music '(PropertySet PropertyUnset))
146        (music-property-value? music 'symbol property)))
147
148 (define-public (music-has-property? music property)
149   "Return true iff MUSIC contains PROPERTY."
150   (not (eq? (ly:music-property music property) '())))
151
152 (define-public (property-value music)
153   "Return value of a property setter MUSIC.
154 If it unsets the property, return #f."
155   (if (music-name? music 'PropertyUnset)
156       #f
157       (ly:music-property music 'value)))
158
159 (define-public (music-elements music)
160   "Return list of all MUSIC's top-level children."
161   (let ((elt (ly:music-property music 'element))
162         (elts (ly:music-property music 'elements)))
163     (if (not (null? elt))
164         (cons elt elts)
165         elts)))
166
167 (define-public (find-child music predicate)
168   "Find the first node in MUSIC that satisfies PREDICATE."
169   (define (find-child queue)
170     (if (null? queue)
171         #f
172         (let ((elt (car queue)))
173           (if (predicate elt)
174               elt
175               (find-child (append (music-elements elt) (cdr queue)))))))
176   (find-child (list music)))
177
178 (define-public (find-child-named music name)
179   "Return the first child in MUSIC that is named NAME."
180   (find-child music (lambda (elt) (music-name? elt name))))
181
182 (define-public (process-music music function)
183   "Process all nodes of MUSIC (including MUSIC) in the DFS order.
184 Apply FUNCTION on each of the nodes.
185 If FUNCTION applied on a node returns true, don't process the node's subtree."
186   (define (process-music queue)
187     (if (not (null? queue))
188         (let* ((elt (car queue))
189                (stop (function elt)))
190           (process-music (if stop
191                              (cdr queue)
192                              (append (music-elements elt) (cdr queue)))))))
193   (process-music (list music)))