]> git.donarmstrong.com Git - lilypond.git/blob - scm/lily-library.scm
* scm/define-grobs.scm (all-grob-descriptions): use callback to
[lilypond.git] / scm / lily-library.scm
1 ;;;;
2 ;;;; lily-library.scm -- utilities
3 ;;;;
4 ;;;;  source file of the GNU LilyPond music typesetter
5 ;;;; 
6 ;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
7 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
8
9
10 (define-public X 0)
11 (define-public Y 1)
12 (define-safe-public START -1)
13 (define-safe-public STOP 1)
14 (define-public LEFT -1)
15 (define-public RIGHT 1)
16 (define-public UP 1)
17 (define-public DOWN -1)
18 (define-public CENTER 0)
19
20 (define-safe-public DOUBLE-FLAT -4)
21 (define-safe-public THREE-Q-FLAT -3)
22 (define-safe-public FLAT -2)
23 (define-safe-public SEMI-FLAT -1)
24 (define-safe-public NATURAL 0)
25 (define-safe-public SEMI-SHARP 1)
26 (define-safe-public SHARP 2)
27 (define-safe-public THREE-Q-SHARP 3)
28 (define-safe-public DOUBLE-SHARP 4)
29 (define-safe-public SEMI-TONE 2)
30
31 (define-public ZERO-MOMENT (ly:make-moment 0 1)) 
32
33 (define-public (moment-min a b)
34   (if (ly:moment<? a b) a b))
35
36 (define-public (average x . lst)
37   (/ (+ x (apply + lst)) (1+ (length lst))))
38
39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40 ;; lily specific variables.
41
42 (define-public default-script-alist '())
43
44
45 ;; parser stuff.
46 (define-public (print-music-as-book parser music)
47   (let* ((head (ly:parser-lookup parser '$defaultheader))
48          (book (ly:make-book (ly:parser-lookup parser '$defaultpaper)
49                              head (scorify-music music parser))))
50     (print-book-with-defaults parser book)))
51
52 (define-public (print-score-as-book parser score)
53   (let* ((head (ly:parser-lookup parser '$defaultheader))
54          (book (ly:make-book (ly:parser-lookup parser '$defaultpaper)
55                              head score)))
56     (print-book-with-defaults parser book)))
57
58 (define-public (print-score parser score)
59   (let* ((head (ly:parser-lookup parser '$defaultheader))
60          (book (ly:make-book (ly:parser-lookup parser '$defaultpaper)
61                              head score)))
62     (ly:parser-print-score parser book)))
63                 
64 (define-public (collect-scores-for-book parser score)
65   (ly:parser-define!
66    parser 'toplevel-scores
67    (cons score (ly:parser-lookup parser 'toplevel-scores))))
68
69
70 (define-public (scorify-music music parser)
71   
72   (for-each (lambda (func)
73               (set! music (func music parser)))
74             toplevel-music-functions)
75
76   (ly:make-score music))
77
78 (define-public (collect-music-for-book parser music)
79   ;; discard music if its 'void property is true.
80   (let ((void-music (ly:music-property music 'void)))
81     (if (or (null? void-music) (not void-music))
82         (collect-scores-for-book parser (scorify-music music parser)))))
83
84
85 (define-public (print-book-with-defaults parser book)
86   (let*
87       ((paper (ly:parser-lookup parser '$defaultpaper))
88        (layout (ly:parser-lookup parser '$defaultlayout))
89        (count (ly:parser-lookup parser 'output-count))
90        (base (ly:parser-output-name parser)))
91
92     (if (not (integer? count))
93         (set! count 0))
94
95     (if (> count 0)
96         (set! base (format #f "~a-~a" base count)))
97
98     (ly:parser-define! parser 'output-count (1+ count))
99     (ly:book-process book paper layout base)
100     ))
101
102 (define-public (print-score-with-defaults parser score)
103   (let*
104       ((paper (ly:parser-lookup parser '$defaultpaper))
105        (layout (ly:parser-lookup parser '$defaultlayout))
106        (header (ly:parser-lookup parser '$defaultheader))
107        (count (ly:parser-lookup parser 'output-count))
108        (base (ly:parser-output-name parser)))
109
110     (if (not (integer? count))
111         (set! count 0))
112
113     (if (> count 0)
114         (set! base (format #f "~a-~a" base count)))
115
116     (ly:parser-define! parser 'output-count (1+ count))
117     (ly:score-process score header paper layout base)
118     ))
119
120
121 ;;;;;;;;;;;;;;;;
122 ;; alist
123 (define-public assoc-get ly:assoc-get)
124
125 (define-public (uniqued-alist alist acc)
126   (if (null? alist) acc
127       (if (assoc (caar alist) acc)
128           (uniqued-alist (cdr alist) acc)
129           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
130
131 (define-public (alist<? x y)
132   (string<? (symbol->string (car x))
133             (symbol->string (car y))))
134
135 (define-public (chain-assoc x alist-list)
136   (if (null? alist-list)
137       #f
138       (let* ((handle (assoc x (car alist-list))))
139         (if (pair? handle)
140             handle
141             (chain-assoc x (cdr alist-list))))))
142
143 (define-public (chain-assoc-get x alist-list . default)
144   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
145 found."
146
147   (define (helper x alist-list default)
148     (if (null? alist-list)
149         default
150         (let* ((handle (assoc x (car alist-list))))
151           (if (pair? handle)
152               (cdr handle)
153               (helper x (cdr alist-list) default)))))
154
155   (helper x alist-list
156           (if (pair? default) (car default) #f)))
157
158 (define (map-alist-vals func list)
159   "map FUNC over the vals of  LIST, leaving the keys."
160   (if (null?  list)
161       '()
162       (cons (cons  (caar list) (func (cdar list)))
163             (map-alist-vals func (cdr list)))))
164
165 (define (map-alist-keys func list)
166   "map FUNC over the keys of an alist LIST, leaving the vals. "
167   (if (null?  list)
168       '()
169       (cons (cons (func (caar list)) (cdar list))
170             (map-alist-keys func (cdr list)))))
171
172 (define-public (first-member members lst)
173   "Return first successful MEMBER of member from MEMBERS in LST."
174   (if (null? members)
175       #f
176       (let ((m (member (car members) lst)))
177         (if m m (first-member (cdr members) lst)))))
178
179 (define-public (first-assoc keys lst)
180   "Return first successful ASSOC of key from KEYS in LST."
181   (if (null? keys)
182       #f
183       (let ((k (assoc (car keys) lst)))
184         (if k k (first-assoc (cdr keys) lst)))))
185
186 (define-public (flatten-alist alist)
187   (if (null? alist)
188       '()
189       (cons (caar alist)
190             (cons (cdar alist)
191                   (flatten-alist (cdr alist))))))
192
193 ;;;;;;;;;;;;;;;;
194 ;; vector
195 (define-public (vector-for-each proc vec)
196   (do
197       ((i 0 (1+ i)))
198       ((>= i (vector-length vec)) vec)
199     (vector-set! vec i (proc (vector-ref vec i)))))
200
201 ;;;;;;;;;;;;;;;;
202 ;; hash
203
204 (if (not (defined? 'hash-table?)) ;; guile 1.6 compat
205     (begin
206       (define hash-table? vector?)
207       (define-public (hash-for-each proc tab)
208         (hash-fold (lambda (k v prior)
209                      (proc k v)
210                      #f)
211                    #f
212                    tab))
213       (define-public (hash-table->alist t)
214         "Convert table t to list"
215         (apply append (vector->list t))))
216
217     ;; native hashtabs.
218     (begin
219       (define-public (hash-table->alist t)
220         (hash-fold (lambda (k v acc) (acons  k v  acc))
221                    '() t))))
222
223 ;; todo: code dup with C++. 
224 (define-safe-public (alist->hash-table lst)
225   "Convert alist to table"
226   (let ((m (make-hash-table (length lst))))
227     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
228     m))
229
230 ;;;;;;;;;;;;;;;;
231 ; list
232
233 (define (flatten-list lst)
234   "Unnest LST" 
235   (if (null? lst)
236       '()
237       (if (pair? (car lst))
238           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
239           (cons (car lst) (flatten-list (cdr lst))))))
240
241 (define (list-minus a b)
242   "Return list of elements in A that are not in B."
243   (lset-difference eq? a b))
244
245 ;; TODO: use the srfi-1 partition function.
246 (define-public (uniq-list lst)
247   
248   "Uniq LST, assuming that it is sorted"
249   (define (helper acc lst) 
250     (if (null? lst)
251         acc
252         (if (null? (cdr lst))
253             (cons (car lst) acc)
254             (if (equal? (car lst) (cadr lst))
255                 (helper acc (cdr lst))
256                 (helper (cons (car lst) acc)  (cdr lst))))))
257   (reverse! (helper '() lst) '()))
258
259 (define (split-at-predicate predicate lst)
260  "Split LST = (a_1 a_2 ... a_k b_1 ... b_k)
261   into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k) 
262   Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
263   L1 is copied, L2 not.
264
265   (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
266  ;; " Emacs is broken
267
268  (define (inner-split predicate lst acc)
269    (cond
270     ((null? lst) acc)
271     ((null? (cdr lst))
272      (set-car! acc (cons (car lst) (car acc)))
273      acc)
274     ((predicate (car lst) (cadr lst))
275      (set-car! acc (cons (car lst) (car acc)))
276      (inner-split predicate (cdr lst) acc))
277     (else
278      (set-car! acc (cons (car lst) (car acc)))
279      (set-cdr! acc (cdr lst))
280      acc)))
281  
282  (let* ((c (cons '() '())))
283    (inner-split predicate lst  c)
284    (set-car! c (reverse! (car c)))
285    c))
286
287 (define-public (split-list lst sep?)
288    "(display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))))
289    =>
290    ((a b c) (d e f) (g))
291   "
292    ;; " Emacs is broken
293    (define (split-one sep?  lst acc)
294      "Split off the first parts before separator and return both parts."
295      (if (null? lst)
296          (cons acc '())
297          (if (sep? (car lst))
298              (cons acc (cdr lst))
299              (split-one sep? (cdr lst) (cons (car lst) acc)))))
300    
301    (if (null? lst)
302        '()
303        (let* ((c (split-one sep? lst '())))
304          (cons (reverse! (car c) '()) (split-list (cdr c) sep?)))))
305
306 (define-public (offset-add a b)
307   (cons (+ (car a) (car b))
308         (+ (cdr a) (cdr b)))) 
309
310 (define-public (offset-flip-y o)
311   (cons (car o) (- (cdr o))))
312
313 (define-public (offset-scale o scale)
314   (cons (* (car o) scale)
315         (* (cdr o) scale)))
316
317 (define-public (ly:list->offsets accum coords)
318   (if (null? coords)
319       accum
320       (cons (cons (car coords) (cadr coords))
321             (ly:list->offsets accum (cddr coords)))))
322
323 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
324 ;; numbers
325
326 (if (not (defined? 'nan?)) ;; guile 1.6 compat
327     (define-public (nan? x) (not (or (< 0.0 x)
328                                      (> 0.0 x)
329                                      (= 0.0 x)))))
330
331 (if (not (defined? 'inf?))
332     (define-public (inf? x) (= (/ 1.0 x) 0.0)))
333
334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
335 ;; intervals
336
337 (define-public (interval-length x)
338   "Length of the number-pair X, when an interval"
339   (max 0 (- (cdr x) (car x))))
340
341 (define-public interval-start car)
342 (define-public (ordered-cons a b)
343   (cons (min a b)
344         (max a b)))
345
346 (define-public interval-end cdr)
347
348 (define-public (interval-index interval dir)
349   "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)"
350   
351   (* (+  (interval-start interval) (interval-end interval)
352          (* dir (- (interval-end interval) (interval-start interval))))
353      0.5))
354
355 (define-public (interval-center x)
356   "Center the number-pair X, when an interval"
357   (if (interval-empty? x)
358       0.0
359       (/ (+ (car x) (cdr x)) 2)))
360
361 (define-public interval-start car)
362 (define-public interval-end cdr)
363 (define-public (interval-translate iv amount)
364   (cons (+ amount (car iv))
365         (+ amount (cdr iv))))
366
367 (define (other-axis a)
368   (remainder (+ a 1) 2))
369
370 (define-public (interval-widen iv amount)
371    (cons (- (car iv) amount)
372          (+ (cdr iv) amount)))
373
374
375 (define-public (interval-empty? iv)
376    (> (car iv) (cdr iv)))
377
378 (define-public (interval-union i1 i2)
379    (cons (min (car i1) (car i2))
380          (max (cdr i1) (cdr i2))))
381
382 (define-public (interval-sane? i)
383   (not (or  (nan? (car i))
384             (inf? (car i))
385             (nan? (cdr i))
386             (inf? (cdr i))
387             (> (car i) (cdr i)))))
388
389
390 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
391 ;;
392
393
394
395 (define-public (ly:numbers->string lst)
396   (string-join (map ly:number->string lst) " "))
397
398 (define (number->octal-string x)
399   (let* ((n (inexact->exact x))
400          (n64 (quotient n 64))
401          (n8 (quotient (- n (* n64 64)) 8)))
402     (string-append
403      (number->string n64)
404      (number->string n8)
405      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
406
407 (define-public (ly:inexact->string x radix)
408   (let ((n (inexact->exact x)))
409     (number->string n radix)))
410
411 (define-public (ly:number-pair->string c)
412   (string-append (ly:number->string (car c)) " "
413                  (ly:number->string (cdr c))))
414
415
416 (define-public (write-me message x)
417   "Return X.  Display MESSAGE and write X.  Handy for debugging,
418 possibly turned off."
419   (display message) (write x) (newline) x)
420 ;;  x)
421
422 (define-public (stderr string . rest)
423   (apply format (cons (current-error-port) (cons string rest)))
424   (force-output (current-error-port)))
425
426 (define-public (debugf string . rest)
427   (if #f
428       (apply stderr (cons string rest))))
429
430 (define (index-cell cell dir)
431   (if (equal? dir 1)
432       (cdr cell)
433       (car cell)))
434
435 (define (cons-map f x)
436   "map F to contents of X"
437   (cons (f (car x)) (f (cdr x))))
438
439 (define-public (list-insert-separator lst between)
440   "Create new list, inserting BETWEEN between elements of LIST"
441   (define (conc x y )
442     (if (eq? y #f)
443         (list x)
444         (cons x  (cons between y))))
445   (fold-right conc #f lst))
446
447 (define-public (string-regexp-substitute a b str)
448   (regexp-substitute/global #f a str 'pre b 'post)) 
449
450 (define (regexp-split str regex)
451   (define matches '())
452   (define end-of-prev-match 0)
453   (define (notice match)
454
455     (set! matches (cons (substring (match:string match)
456                                    end-of-prev-match
457                                    (match:start match))
458                         matches))
459     (set! end-of-prev-match (match:end match)))
460
461   (regexp-substitute/global #f regex str notice 'post)
462
463   (if (< end-of-prev-match (string-length str))
464       (set!
465        matches
466        (cons (substring str end-of-prev-match (string-length str)) matches)))
467
468    (reverse matches))
469
470 ;;;;;;;;;;;;;;;;
471 ; other
472 (define (sign x)
473   (if (= x 0)
474       0
475       (if (< x 0) -1 1)))
476
477 (define-public (car< a b) (< (car a) (car b)))
478
479
480 (define-public (symbol<? lst r)
481   (string<? (symbol->string lst) (symbol->string r)))
482
483 (define-public (symbol-key<? lst r)
484   (string<? (symbol->string (car lst)) (symbol->string (car r))))
485
486 ;;
487 ;; don't confuse users with #<procedure .. > syntax. 
488 ;; 
489 (define-public (scm->string val)
490   (if (and (procedure? val) (symbol? (procedure-name val)))
491       (symbol->string (procedure-name val))
492       (string-append
493        (if (self-evaluating? val) "" "'")
494        (call-with-output-string (lambda (port) (display val port))))))
495
496 (define-public (!= lst r)
497   (not (= lst r)))
498
499 (define-public lily-unit->bigpoint-factor
500   (cond
501    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
502    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
503    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
504
505 (define-public lily-unit->mm-factor
506   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
507
508 ;;; FONT may be font smob, or pango font string...
509 (define-public (font-name-style font)
510       ;; FIXME: ughr, (ly:font-name) sometimes also has Style appended.
511       (let* ((font-name (ly:font-name font))
512              (full-name (if font-name font-name (ly:font-file-name font)))
513              (name-style (string-split full-name #\-)))
514         ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
515         (if (string-prefix? "feta-alphabet" full-name)
516             (list "emmentaler"
517                   (substring  full-name (string-length "feta-alphabet")))
518             (if (not (null? (cdr name-style)))
519             name-style
520             (append name-style '("Regular"))))))
521
522 (define-public (modified-font-metric-font-scaling font)
523   (let* ((designsize (ly:font-design-size font))
524          (magnification (* (ly:font-magnification font)))
525          (scaling (* magnification designsize)))
526     (debugf "scaling:~S\n" scaling)
527     (debugf "magnification:~S\n" magnification)
528     (debugf "design:~S\n" designsize)
529     scaling))
530
531 (define-public (version-not-seen-message input-file-name)
532   (ly:message
533    (string-append
534     input-file-name ": 0: " (_ "warning: ")
535    (format #f
536            (_ "no \\version statement found, please add~afor future compatibility")
537            (format #f "\n\n\\version ~s\n\n" (lilypond-version))))))
538
539 (define-public (old-relative-not-used-message input-file-name)
540   (ly:message
541    (string-append
542     input-file-name ": 0: " (_ "warning: ")
543     (_ "old relative compatibility not used"))))