1 ;;;; lily-library.scm -- utilities
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
11 (define-public START -1)
12 (define-public STOP 1)
13 (define-public LEFT -1)
14 (define-public RIGHT 1)
16 (define-public DOWN -1)
17 (define-public CENTER 0)
19 (define-public DOUBLE-FLAT -4)
20 (define-public THREE-Q-FLAT -3)
21 (define-public FLAT -2)
22 (define-public SEMI-FLAT -1)
23 (define-public NATURAL 0)
24 (define-public SEMI-SHARP 1)
25 (define-public SHARP 2)
26 (define-public THREE-Q-SHARP 3)
27 (define-public DOUBLE-SHARP 4)
28 (define-public SEMI-TONE 2)
30 (define-public ZERO-MOMENT (ly:make-moment 0 1))
32 (define-public (moment-min a b)
33 (if (ly:moment<? a b) a b))
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36 ;; lily specific variables.
38 (define-public default-script-alist '())
42 (define-public (print-music-as-book parser music)
43 (let* ((head (ly:parser-lookup parser '$globalheader))
44 (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
46 (ly:parser-print-book parser book)))
48 (define-public (print-score-as-book parser score)
50 ((head (ly:parser-lookup parser '$globalheader))
51 (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
53 (ly:parser-print-book parser book)))
55 (define-public (print-score parser score)
56 (let* ((head (ly:parser-lookup parser '$globalheader))
57 (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
59 (ly:parser-print-score parser book)))
61 (define-public (collect-scores-for-book parser score)
63 ((oldval (ly:parser-lookup parser 'toplevel-scores)))
64 (ly:parser-define parser 'toplevel-scores (cons score oldval))
67 (define-public (collect-music-for-book parser music)
68 (collect-scores-for-book parser (ly:music-scorify music parser)))
74 (define-public assoc-get ly:assoc-get)
76 (define-public (uniqued-alist alist acc)
78 (if (assoc (caar alist) acc)
79 (uniqued-alist (cdr alist) acc)
80 (uniqued-alist (cdr alist) (cons (car alist) acc)))))
82 (define-public (alist<? x y)
83 (string<? (symbol->string (car x))
84 (symbol->string (car y))))
86 (define-public (chain-assoc x alist-list)
87 (if (null? alist-list)
89 (let* ((handle (assoc x (car alist-list))))
92 (chain-assoc x (cdr alist-list))))))
94 (define-public (chain-assoc-get x alist-list . default)
95 "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
98 (define (helper x alist-list default)
99 (if (null? alist-list)
101 (let* ((handle (assoc x (car alist-list))))
104 (helper x (cdr alist-list) default)))))
107 (if (pair? default) (car default) #f)))
109 (define (map-alist-vals func list)
110 "map FUNC over the vals of LIST, leaving the keys."
113 (cons (cons (caar list) (func (cdar list)))
114 (map-alist-vals func (cdr list)))
117 (define (map-alist-keys func list)
118 "map FUNC over the keys of an alist LIST, leaving the vals. "
121 (cons (cons (func (caar list)) (cdar list))
122 (map-alist-keys func (cdr list)))
127 (define-public (vector-for-each proc vec)
130 ((>= i (vector-length vec)) vec)
133 (proc (vector-ref vec i)))))
138 (if (not (defined? 'hash-table?)) ; guile 1.6 compat
140 (define hash-table? vector?)
142 (define-public (hash-table->alist t)
143 "Convert table t to list"
150 (define-public (hash-table->alist t)
152 (hash-fold (lambda (k v acc) (acons k v acc))
157 ;; todo: code dup with C++.
158 (define-public (alist->hash-table l)
159 "Convert alist to table"
161 ((m (make-hash-table (length l))))
164 (hashq-set! m (car k-v) (cdr k-v)))
175 (define (flatten-list lst)
179 (if (pair? (car lst))
180 (append (flatten-list (car lst)) (flatten-list (cdr lst)))
181 (cons (car lst) (flatten-list (cdr lst))))
184 (define (list-minus a b)
185 "Return list of elements in A that are not in B."
186 (lset-difference eq? a b))
189 ;; TODO: use the srfi-1 partition function.
190 (define-public (uniq-list l)
192 "Uniq LIST, assuming that it is sorted"
193 (define (helper acc l)
198 (if (equal? (car l) (cadr l))
200 (helper (cons (car l) acc) (cdr l)))
202 (reverse! (helper '() l) '()))
205 (define (split-at-predicate predicate l)
206 "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
207 into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
208 Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
209 L1 is copied, L2 not.
211 (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
216 (define (inner-split predicate l acc)
220 (set-car! acc (cons (car l) (car acc)))
222 ((predicate (car l) (cadr l))
223 (set-car! acc (cons (car l) (car acc)))
224 (inner-split predicate (cdr l) acc))
226 (set-car! acc (cons (car l) (car acc)))
227 (set-cdr! acc (cdr l))
234 (inner-split predicate l c)
235 (set-car! c (reverse! (car c)))
240 (define-public (split-list l sep?)
242 (display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
244 ((a b c) (d e f) (g))
249 (define (split-one sep? l acc)
250 "Split off the first parts before separator and return both parts."
255 (split-one sep? (cdr l) (cons (car l) acc))
261 (let* ((c (split-one sep? l '())))
262 (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
266 (define-public (offset-add a b)
267 (cons (+ (car a) (car b))
268 (+ (cdr a) (cdr b))))
270 (define-public (interval-length x)
271 "Length of the number-pair X, when an interval"
272 (max 0 (- (cdr x) (car x)))
274 (define-public interval-start car)
275 (define-public interval-end cdr)
277 (define (other-axis a)
278 (remainder (+ a 1) 2))
281 (define-public (interval-widen iv amount)
282 (cons (- (car iv) amount)
283 (+ (cdr iv) amount)))
285 (define-public (interval-union i1 i2)
286 (cons (min (car i1) (car i2))
287 (max (cdr i1) (cdr i2))))
290 (define-public (write-me message x)
291 "Return X. Display MESSAGE and write X. Handy for debugging,
292 possibly turned off."
293 (display message) (write x) (newline) x)
296 (define (index-cell cell dir)
301 (define (cons-map f x)
302 "map F to contents of X"
303 (cons (f (car x)) (f (cdr x))))
306 (define-public (list-insert-separator lst between)
307 "Create new list, inserting BETWEEN between elements of LIST"
311 (cons x (cons between y))
313 (fold-right conc #f lst))
322 (define-public (symbol<? l r)
323 (string<? (symbol->string l) (symbol->string r)))
325 (define-public (!= l r)
329 (define-public scale-to-unit
331 ((equal? (ly:unit) "mm") (/ 72.0 25.4))
332 ((equal? (ly:unit) "pt") (/ 72.0 72.27))
333 (else (error "unknown unit" (ly:unit)))))
336 (define-public (font-family font)
337 (let ((name (ly:font-name font)))
339 (regexp-substitute/global #f "^GNU-(.*)-[.0-9]*$" name 'pre 1 'post)
341 ;;(stderr "font-name: ~S\n" (ly:font-name font))
342 ;;(stderr "font-file-name: ~S\n" (ly:font-file-name font))
343 (ly:font-file-name font)))))
345 (define-public (char->unicode-index font char)
346 (+ (case (ly:font-encoding font)
347 ((fetaMusic) (- #xe000 #x20))
348 ((fetaBraces) (- #xe000 #x40))
350 (char->integer char)))