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