Bump version.
[lilypond.git] / scm / lily-library.scm
blobf772d0527e931efa53cdf0917fcf359012e911bb
1 ;;;;
2 ;;;; lily-library.scm -- utilities
3 ;;;;
4 ;;;;  source file of the GNU LilyPond music typesetter
5 ;;;; 
6 ;;;; (c) 1998--2007 Jan Nieuwenhuizen <janneke@gnu.org>
7 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10 ;; constants.
12 (define-public X 0)
13 (define-public Y 1)
14 (define-safe-public START -1)
15 (define-safe-public STOP 1)
16 (define-public LEFT -1)
17 (define-public RIGHT 1)
18 (define-public UP 1)
19 (define-public DOWN -1)
20 (define-public CENTER 0)
22 (define-safe-public DOUBLE-FLAT-QTS -4)
23 (define-safe-public THREE-Q-FLAT-QTS -3)
24 (define-safe-public FLAT-QTS -2)
25 (define-safe-public SEMI-FLAT-QTS -1)
26 (define-safe-public NATURAL-QTS 0)
27 (define-safe-public SEMI-SHARP-QTS 1)
28 (define-safe-public SHARP-QTS 2)
29 (define-safe-public THREE-Q-SHARP-QTS 3)
30 (define-safe-public DOUBLE-SHARP-QTS 4)
31 (define-safe-public SEMI-TONE-QTS 2)
33 (define-safe-public DOUBLE-FLAT  -1)
34 (define-safe-public THREE-Q-FLAT -3/4)
35 (define-safe-public FLAT -1/2)
36 (define-safe-public SEMI-FLAT -1/4)
37 (define-safe-public NATURAL 0)
38 (define-safe-public SEMI-SHARP 1/4)
39 (define-safe-public SHARP 1/2)
40 (define-safe-public THREE-Q-SHARP 3/4)
41 (define-safe-public DOUBLE-SHARP 1)
42 (define-safe-public SEMI-TONE 1/2)
44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
45 ;; moments
47 (define-public ZERO-MOMENT (ly:make-moment 0 1)) 
49 (define-public (moment-min a b)
50   (if (ly:moment<? a b) a b))
52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
53 ;; arithmetic
54 (define-public (average x . lst)
55   (/ (+ x (apply + lst)) (1+ (length lst))))
57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
58 ;; parser <-> output hooks.
60                 
61 (define-public (collect-scores-for-book parser score)
62   (ly:parser-define!
63    parser 'toplevel-scores
64    (cons score (ly:parser-lookup parser 'toplevel-scores))))
66 (define (collect-music-aux score-handler parser music)
67   (define (music-property symbol)
68     (let ((value (ly:music-property music symbol)))
69       (if (not (null? value))
70           value
71           #f)))
72   (cond ((music-property 'page-marker)
73          ;; a page marker: set page break/turn permissions or label
74          (begin
75            (let ((label (music-property 'page-label)))
76              (if (symbol? label)
77                  (score-handler (ly:make-page-label-marker label))))
78            (for-each (lambda (symbol)
79                        (let ((permission (music-property symbol)))
80                          (if (symbol? permission)
81                              (score-handler
82                               (ly:make-page-permission-marker symbol
83                                                               (if (eqv? 'forbid permission)
84                                                                   '()
85                                                                   permission))))))
86                      (list 'line-break-permission 'page-break-permission
87                            'page-turn-permission))))
88         ((not (music-property 'void))
89          ;; a regular music expression: make a score with this music
90          ;; void music is discarded
91          (score-handler (scorify-music music parser)))))
93 (define-public (collect-music-for-book parser music)
94   "Top-level music handler"
95   (collect-music-aux (lambda (score)
96                        (collect-scores-for-book parser score))
97                      parser
98                      music))
100 (define-public (collect-book-music-for-book parser book music)
101   "Book music handler"
102   (collect-music-aux (lambda (score)
103                        (ly:book-add-score! book score))
104                      parser
105                      music))
107 (define-public (scorify-music music parser)
108   "Preprocess MUSIC."
109   
110   (for-each (lambda (func)
111               (set! music (func music parser)))
112             toplevel-music-functions)
114   (ly:make-score music))
116 (define (print-book-with parser book process-procedure)
117   (let*
118       ((paper (ly:parser-lookup parser '$defaultpaper))
119        (layout (ly:parser-lookup parser '$defaultlayout))
120        (count (ly:parser-lookup parser 'output-count))
121        (base (ly:parser-output-name parser))
122        (output-suffix (ly:parser-lookup parser 'output-suffix)) )
124     (if (string? output-suffix)
125         (set! base (format "~a-~a" base (string-regexp-substitute
126                                            "[^a-zA-Z0-9-]" "_" output-suffix))))
128     ;; must be careful: output-count is under user control.
129     (if (not (integer? count))
130         (set! count 0))
132     (if (> count 0)
133         (set! base (format #f "~a-~a" base count)))
134     (ly:parser-define! parser 'output-count (1+ count))
135     (process-procedure book paper layout base)
136     ))
138 (define-public (print-book-with-defaults parser book)
139   (print-book-with parser book ly:book-process))
141 (define-public (print-book-with-defaults-as-systems parser book)
142   (print-book-with parser book ly:book-process-to-systems))
144 ;;;;;;;;;;;;;;;;
145 ;; alist
147 (define-public assoc-get ly:assoc-get)
149 (define-public (uniqued-alist alist acc)
150   (if (null? alist) acc
151       (if (assoc (caar alist) acc)
152           (uniqued-alist (cdr alist) acc)
153           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
155 (define-public (alist<? x y)
156   (string<? (symbol->string (car x))
157             (symbol->string (car y))))
159 (define-public (chain-assoc-get x alist-list . default)
160   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
161 found."
163   (define (helper x alist-list default)
164     (if (null? alist-list)
165         default
166         (let* ((handle (assoc x (car alist-list))))
167           (if (pair? handle)
168               (cdr handle)
169               (helper x (cdr alist-list) default)))))
171   (helper x alist-list
172           (if (pair? default) (car default) #f)))
174 (define (map-alist-vals func list)
175   "map FUNC over the vals of  LIST, leaving the keys."
176   (if (null?  list)
177       '()
178       (cons (cons  (caar list) (func (cdar list)))
179             (map-alist-vals func (cdr list)))))
181 (define (map-alist-keys func list)
182   "map FUNC over the keys of an alist LIST, leaving the vals. "
183   (if (null?  list)
184       '()
185       (cons (cons (func (caar list)) (cdar list))
186             (map-alist-keys func (cdr list)))))
188 (define-public (first-member members lst)
189   "Return first successful MEMBER of member from MEMBERS in LST."
190   (if (null? members)
191       #f
192       (let ((m (member (car members) lst)))
193         (if m m (first-member (cdr members) lst)))))
195 (define-public (first-assoc keys lst)
196   "Return first successful ASSOC of key from KEYS in LST."
197   (if (null? keys)
198       #f
199       (let ((k (assoc (car keys) lst)))
200         (if k k (first-assoc (cdr keys) lst)))))
202 (define-public (flatten-alist alist)
203   (if (null? alist)
204       '()
205       (cons (caar alist)
206             (cons (cdar alist)
207                   (flatten-alist (cdr alist))))))
209 ;;;;;;;;;;;;;;;;
210 ;; vector
212 (define-public (vector-for-each proc vec)
213   (do
214       ((i 0 (1+ i)))
215       ((>= i (vector-length vec)) vec)
216     (vector-set! vec i (proc (vector-ref vec i)))))
218 ;;;;;;;;;;;;;;;;
219 ;; hash
221 (define-public (hash-table->alist t)
222   (hash-fold (lambda (k v acc) (acons  k v  acc))
223              '() t))
225 ;; todo: code dup with C++. 
226 (define-safe-public (alist->hash-table lst)
227   "Convert alist to table"
228   (let ((m (make-hash-table (length lst))))
229     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
230     m))
232 ;;;;;;;;;;;;;;;;
233 ;; list
235 (define (functional-or . rest)
236   (if (pair? rest)
237       (or (car rest)
238            (apply functional-and (cdr rest)))
239       #f))
241 (define (functional-and . rest)
242   (if (pair? rest)
243       (and (car rest)
244            (apply functional-and (cdr rest)))
245       #t))
247 (define (split-list lst n)
248   "Split LST in N equal sized parts"
249   
250   (define (helper todo acc-vector k)
251     (if (null? todo)
252         acc-vector
253         (begin
254           (if (< k 0)
255               (set! k (+ n k)))
256             
257           (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
258           (helper (cdr todo) acc-vector (1- k)))))
260   (helper lst (make-vector n '()) (1- n)))
262 (define (list-element-index lst x)
263   (define (helper todo k)
264     (cond
265      ((null? todo) #f)
266      ((equal? (car todo) x) k)
267      (else
268       (helper (cdr todo) (1+ k)))))
270   (helper lst 0))
272 (define-public (count-list lst)
273   "Given lst (E1 E2 .. ) return ((E1 . 1) (E2 . 2) ... )  "
275   (define (helper l acc count)
276     (if (pair? l)
277         (helper (cdr l) (cons (cons (car l) count) acc) (1+ count))
278         acc))
281   (reverse (helper lst '() 1)))
282   
283 (define-public (list-join lst intermediate)
284   "put INTERMEDIATE  between all elts of LST."
286   (fold-right
287    (lambda (elem prev)
288             (if (pair? prev)
289                 (cons  elem (cons intermediate prev))
290                 (list elem)))
291           '() lst))
293 (define-public (filtered-map proc lst)
294   (filter
295    (lambda (x) x)
296    (map proc lst)))
299 (define (flatten-list lst)
300   "Unnest LST" 
301   (if (null? lst)
302       '()
303       (if (pair? (car lst))
304           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
305           (cons (car lst) (flatten-list (cdr lst))))))
307 (define (list-minus a b)
308   "Return list of elements in A that are not in B."
309   (lset-difference eq? a b))
311 (define-public (uniq-list lst)
312   "Uniq LST, assuming that it is sorted. Uses equal? for comparisons."
314   (reverse! 
315    (fold (lambda (x acc)
316            (if (null? acc)
317                (list x)
318                (if (equal? x (car acc))
319                    acc
320                    (cons x acc))))
321          '() lst) '()))
323 (define (split-at-predicate predicate lst)
324  "Split LST = (a_1 a_2 ... a_k b_1 ... b_k)
325   into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k) 
326   Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
327   L1 is copied, L2 not.
329   (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
331  ;; " Emacs is broken
333  (define (inner-split predicate lst acc)
334    (cond
335     ((null? lst) acc)
336     ((null? (cdr lst))
337      (set-car! acc (cons (car lst) (car acc)))
338      acc)
339     ((predicate (car lst) (cadr lst))
340      (set-car! acc (cons (car lst) (car acc)))
341      (inner-split predicate (cdr lst) acc))
342     (else
343      (set-car! acc (cons (car lst) (car acc)))
344      (set-cdr! acc (cdr lst))
345      acc)))
347  (let* ((c (cons '() '())))
348    (inner-split predicate lst  c)
349    (set-car! c (reverse! (car c)))
350    c))
352 (define-public (split-list-by-separator lst sep?)
353    "(display (split-list-by-separator '(a b c / d e f / g) (lambda (x) (equal? x '/))))
354    =>
355    ((a b c) (d e f) (g))
356   "
357    ;; " Emacs is broken
358    (define (split-one sep?  lst acc)
359      "Split off the first parts before separator and return both parts."
360      (if (null? lst)
361          (cons acc '())
362          (if (sep? (car lst))
363              (cons acc (cdr lst))
364              (split-one sep? (cdr lst) (cons (car lst) acc)))))
365    
366    (if (null? lst)
367        '()
368        (let* ((c (split-one sep? lst '())))
369          (cons (reverse! (car c) '()) (split-list-by-separator (cdr c) sep?)))))
371 (define-public (offset-add a b)
372   (cons (+ (car a) (car b))
373         (+ (cdr a) (cdr b)))) 
375 (define-public (offset-flip-y o)
376   (cons (car o) (- (cdr o))))
378 (define-public (offset-scale o scale)
379   (cons (* (car o) scale)
380         (* (cdr o) scale)))
382 (define-public (ly:list->offsets accum coords)
383   (if (null? coords)
384       accum
385       (cons (cons (car coords) (cadr coords))
386             (ly:list->offsets accum (cddr coords)))))
388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
389 ;; numbers
391 (if (not (defined? 'nan?)) ;; guile 1.6 compat
392     (define-public (nan? x) (not (or (< 0.0 x)
393                                      (> 0.0 x)
394                                      (= 0.0 x)))))
396 (if (not (defined? 'inf?))
397     (define-public (inf? x) (= (/ 1.0 x) 0.0)))
399 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
400 ;; intervals
402 (define-public (interval-length x)
403   "Length of the number-pair X, when an interval"
404   (max 0 (- (cdr x) (car x))))
406 (define-public interval-start car)
407 (define-public (ordered-cons a b)
408   (cons (min a b)
409         (max a b)))
411 (define-public interval-end cdr)
413 (define-public (interval-bound interval dir)
414   ((if (= dir RIGHT) cdr car) interval))
416 (define-public (interval-index interval dir)
417   "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)"
418   
419   (* (+  (interval-start interval) (interval-end interval)
420          (* dir (- (interval-end interval) (interval-start interval))))
421      0.5))
423 (define-public (interval-center x)
424   "Center the number-pair X, when an interval"
425   (if (interval-empty? x)
426       0.0
427       (/ (+ (car x) (cdr x)) 2)))
429 (define-public interval-start car)
430 (define-public interval-end cdr)
431 (define-public (interval-translate iv amount)
432   (cons (+ amount (car iv))
433         (+ amount (cdr iv))))
435 (define (other-axis a)
436   (remainder (+ a 1) 2))
438 (define-public (interval-widen iv amount)
439    (cons (- (car iv) amount)
440          (+ (cdr iv) amount)))
443 (define-public (interval-empty? iv)
444    (> (car iv) (cdr iv)))
446 (define-public (interval-union i1 i2)
447    (cons (min (car i1) (car i2))
448          (max (cdr i1) (cdr i2))))
450 (define-public (interval-sane? i)
451   (not (or  (nan? (car i))
452             (inf? (car i))
453             (nan? (cdr i))
454             (inf? (cdr i))
455             (> (car i) (cdr i)))))
458 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
459 ;; string
461 (define-public (string-endswith s suffix)
462   (equal? suffix (substring s
463                             (max 0 (- (string-length s) (string-length suffix)))
464                             (string-length s))))
465              
466 (define-public (string-startswith s prefix)
467   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
468              
469 (define-public (string-encode-integer i)
470   (cond
471    ((= i  0) "o")
472    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
473    (else (string-append
474           (make-string 1 (integer->char (+ 65 (modulo i 26))))
475           (string-encode-integer (quotient i 26))))))
477 (define (number->octal-string x)
478   (let* ((n (inexact->exact x))
479          (n64 (quotient n 64))
480          (n8 (quotient (- n (* n64 64)) 8)))
481     (string-append
482      (number->string n64)
483      (number->string n8)
484      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
486 (define-public (ly:inexact->string x radix)
487   (let ((n (inexact->exact x)))
488     (number->string n radix)))
490 (define-public (ly:number-pair->string c)
491   (string-append (ly:number->string (car c)) " "
492                  (ly:number->string (cdr c))))
494 (define-public (dir-basename file . rest)
495   "Strip suffixes in REST, but leave directory component for FILE."
496   (define (inverse-basename x y) (basename y x))
497   (simple-format #f "~a/~a" (dirname file)
498                  (fold inverse-basename file rest)))
500 (define-public (write-me message x)
501   "Return X.  Display MESSAGE and write X.  Handy for debugging,
502 possibly turned off."
503   (display message) (write x) (newline) x)
504 ;;  x)
506 (define-public (stderr string . rest)
507   (apply format (cons (current-error-port) (cons string rest)))
508   (force-output (current-error-port)))
510 (define-public (debugf string . rest)
511   (if #f
512       (apply stderr (cons string rest))))
514 (define (index-cell cell dir)
515   (if (equal? dir 1)
516       (cdr cell)
517       (car cell)))
519 (define (cons-map f x)
520   "map F to contents of X"
521   (cons (f (car x)) (f (cdr x))))
523 (define-public (list-insert-separator lst between)
524   "Create new list, inserting BETWEEN between elements of LIST"
525   (define (conc x y )
526     (if (eq? y #f)
527         (list x)
528         (cons x  (cons between y))))
529   (fold-right conc #f lst))
531 (define-public (string-regexp-substitute a b str)
532   (regexp-substitute/global #f a str 'pre b 'post)) 
534 (define (regexp-split str regex)
535   (define matches '())
536   (define end-of-prev-match 0)
537   (define (notice match)
539     (set! matches (cons (substring (match:string match)
540                                    end-of-prev-match
541                                    (match:start match))
542                         matches))
543     (set! end-of-prev-match (match:end match)))
545   (regexp-substitute/global #f regex str notice 'post)
547   (if (< end-of-prev-match (string-length str))
548       (set!
549        matches
550        (cons (substring str end-of-prev-match (string-length str)) matches)))
552    (reverse matches))
554 ;;;;;;;;;;;;;;;;
555 ; other
556 (define (sign x)
557   (if (= x 0)
558       0
559       (if (< x 0) -1 1)))
562 (define-public (car< a b)
563   (< (car a) (car b)))
565 (define-public (symbol<? lst r)
566   (string<? (symbol->string lst) (symbol->string r)))
568 (define-public (symbol-key<? lst r)
569   (string<? (symbol->string (car lst)) (symbol->string (car r))))
572 ;; don't confuse users with #<procedure .. > syntax. 
573 ;; 
574 (define-public (scm->string val)
575   (if (and (procedure? val) (symbol? (procedure-name val)))
576       (symbol->string (procedure-name val))
577       (string-append
578        (if (self-evaluating? val) "" "'")
579        (call-with-output-string (lambda (port) (display val port))))))
581 (define-public (!= lst r)
582   (not (= lst r)))
584 (define-public lily-unit->bigpoint-factor
585   (cond
586    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
587    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
588    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
590 (define-public lily-unit->mm-factor
591   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
593 ;;; FONT may be font smob, or pango font string...
594 (define-public (font-name-style font)
595       ;; FIXME: ughr, (ly:font-name) sometimes also has Style appended.
596       (let* ((font-name (ly:font-name font))
597              (full-name (if font-name font-name (ly:font-file-name font)))
598              (name-style (string-split full-name #\-)))
599         ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
600         (if (string-prefix? "feta-alphabet" full-name)
601             (list "emmentaler"
602                   (substring  full-name (string-length "feta-alphabet")))
603             (if (not (null? (cdr name-style)))
604             name-style
605             (append name-style '("Regular"))))))
607 (define-public (modified-font-metric-font-scaling font)
608   (let* ((designsize (ly:font-design-size font))
609          (magnification (* (ly:font-magnification font)))
610          (scaling (* magnification designsize)))
611     (debugf "scaling:~S\n" scaling)
612     (debugf "magnification:~S\n" magnification)
613     (debugf "design:~S\n" designsize)
614     scaling))
616 (define-public (version-not-seen-message input-file-name)
617   (ly:message
618    "~a:0: ~a: ~a" 
619     input-file-name
620     (_ "warning: ")
621     (format #f
622             (_ "no \\version statement found, please add~afor future compatibility")
623             (format #f "\n\n\\version ~s\n\n" (lilypond-version)))))
625 (define-public (old-relative-not-used-message input-file-name)
626   (ly:message
627    "~a:0: ~a: ~a" 
628     input-file-name
629     (_ "warning: ")
630     (_ "old relative compatibility not used")))