]> git.donarmstrong.com Git - lilypond.git/blob - scm/song-util.scm
Formatting from Ralph.
[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 (flatten lst)
120   (cond
121    ((null? lst)
122     lst)
123    ((pair? (car lst))
124     (append (flatten (car lst)) (flatten (cdr lst))))
125    (else
126     (cons (car lst) (flatten (cdr lst))))))
127
128 (define-public (safe-car list)
129   (if (null? list)
130       #f
131       (car list)))
132
133 (define-public (safe-last list)
134   (if (null? list)
135       #f
136       (last list)))
137
138
139 ;;; LilyPond utility functions
140
141
142 (define-public (music-property-value? music property value)
143   "Return true iff MUSIC's PROPERTY is equal to VALUE."
144   (equal? (ly:music-property music property) value))
145
146 (define-public (music-name? music name)
147   "Return true iff MUSIC's name is NAME."
148   (if (list? name)
149       (member (ly:music-property music 'name) name)
150       (music-property-value? music 'name name)))
151
152 (define-public (music-property? music property)
153   "Return true iff MUSIC is a property setter and sets or unsets PROPERTY."
154   (and (music-name? music '(PropertySet PropertyUnset))
155        (music-property-value? music 'symbol property)))
156
157 (define-public (music-has-property? music property)
158   "Return true iff MUSIC contains PROPERTY."
159   (not (eq? (ly:music-property music property) '())))
160
161 (define-public (property-value music)
162   "Return value of a property setter MUSIC.
163 If it unsets the property, return #f."
164   (if (music-name? music 'PropertyUnset)
165       #f
166       (ly:music-property music 'value)))
167
168 (define-public (music-elements music)
169   "Return list of all MUSIC's top-level children."
170   (let ((elt (ly:music-property music 'element))
171         (elts (ly:music-property music 'elements)))
172     (if (not (null? elt))
173         (cons elt elts)
174         elts)))
175
176 (define-public (find-child music predicate)
177   "Find the first node in MUSIC that satisfies PREDICATE."
178   (define (find-child queue)
179     (if (null? queue)
180         #f
181         (let ((elt (car queue)))
182           (if (predicate elt)
183               elt
184               (find-child (append (music-elements elt) (cdr queue)))))))
185   (find-child (list music)))
186
187 (define-public (find-child-named music name)
188   "Return the first child in MUSIC that is named NAME."
189   (find-child music (lambda (elt) (music-name? elt name))))
190
191 (define-public (process-music music function)
192   "Process all nodes of MUSIC (including MUSIC) in the DFS order.
193 Apply FUNCTION on each of the nodes.
194 If FUNCTION applied on a node returns true, don't process the node's subtree."
195   (define (process-music queue)
196     (if (not (null? queue))
197         (let* ((elt (car queue))
198                (stop (function elt)))
199           (process-music (if stop
200                              (cdr queue)
201                              (append (music-elements elt) (cdr queue)))))))
202   (process-music (list music)))