1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 1998--2015 Jan Nieuwenhuizen <janneke@gnu.org>
4 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
6 ;;;; LilyPond is free software: you can redistribute it and/or modify
7 ;;;; it under the terms of the GNU General Public License as published by
8 ;;;; the Free Software Foundation, either version 3 of the License, or
9 ;;;; (at your option) any later version.
11 ;;;; LilyPond is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;;; GNU General Public License for more details.
16 ;;;; You should have received a copy of the GNU General Public License
17 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
19 ;; for take, drop, take-while, list-index, and find-tail:
20 (use-modules (srfi srfi-1))
22 ;; for define-safe-public when byte-compiling using Guile V2
23 (use-modules (scm safe-utility-defs))
25 (use-modules (ice-9 pretty-print))
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 (define-safe-public START -1)
33 (define-safe-public STOP 1)
34 (define-public LEFT -1)
35 (define-public RIGHT 1)
37 (define-public DOWN -1)
38 (define-public CENTER 0)
40 (define-safe-public DOUBLE-FLAT -1)
41 (define-safe-public THREE-Q-FLAT -3/4)
42 (define-safe-public FLAT -1/2)
43 (define-safe-public SEMI-FLAT -1/4)
44 (define-safe-public NATURAL 0)
45 (define-safe-public SEMI-SHARP 1/4)
46 (define-safe-public SHARP 1/2)
47 (define-safe-public THREE-Q-SHARP 3/4)
48 (define-safe-public DOUBLE-SHARP 1)
49 (define-safe-public SEMI-TONE 1/2)
51 (define-safe-public INFINITY-INT 1000000)
53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
56 (define-public ZERO-MOMENT (ly:make-moment 0 1))
58 (define-public (moment-min a b)
59 (if (ly:moment<? a b) a b))
61 (define-public (moment<=? a b)
65 (define-public (fraction->moment fraction)
68 (ly:make-moment (car fraction) (cdr fraction))))
70 (define-public (moment->fraction moment)
71 (cons (ly:moment-main-numerator moment)
72 (ly:moment-main-denominator moment)))
74 (define-public (seconds->moment s context)
75 "Return a moment equivalent to s seconds at the current tempo."
76 (ly:moment-mul (ly:context-property context 'tempoWholesPerMinute)
77 (ly:make-moment (/ s 60))))
79 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
82 (define-public (duration-log-factor lognum)
83 "Given a logarithmic duration number, return the length of the duration,
84 as a number of whole notes."
85 (or (and (exact? lognum) (integer? lognum))
86 (scm-error 'wrong-type-arg "duration-log-factor" "Not an integer: ~S" (list lognum) #f))
91 (define-public (duration-dot-factor dotcount)
92 "Given a count of the dots used to extend a musical duration, return
93 the numeric factor by which they increase the duration."
94 (or (and (exact? dotcount) (integer? dotcount) (>= dotcount 0))
95 (scm-error 'wrong-type-arg "duration-dot-factor" "Not a count: ~S" (list dotcount) #f))
96 (- 2 (/ (ash 1 dotcount))))
98 (define-public (duration-length dur)
99 "Return the overall length of a duration, as a number of whole
100 notes. (Not to be confused with ly:duration-length, which returns a
101 less-useful moment object.)"
102 (ly:moment-main (ly:duration-length dur)))
104 (define-public (duration-visual dur)
105 "Given a duration object, return the visual part of the duration (base
106 note length and dot count), in the form of a duration object with
107 non-visual scale factor 1."
108 (ly:make-duration (ly:duration-log dur) (ly:duration-dot-count dur) 1))
110 (define-public (duration-visual-length dur)
111 "Given a duration object, return the length of the visual part of the
112 duration (base note length and dot count), as a number of whole notes."
113 (duration-length (duration-visual dur)))
115 (define-public (unity-if-multimeasure context dur)
116 "Given a context and a duration, return @code{1} if the duration is
117 longer than the @code{measureLength} in that context, and @code{#f} otherwise.
118 This supports historic use of @code{Completion_heads_engraver} to split
119 @code{c1*3} into three whole notes."
120 (if (ly:moment<? (ly:context-property context 'measureLength)
121 (ly:duration-length dur))
125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
127 (define-public (average x . lst)
128 (/ (+ x (apply + lst)) (1+ (length lst))))
130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
131 ;; parser <-> output hooks.
133 (define-public (collect-bookpart-for-book book-part)
134 "Toplevel book-part handler."
135 (define (add-bookpart book-part)
136 (ly:parser-define! 'toplevel-bookparts
137 (cons book-part (ly:parser-lookup 'toplevel-bookparts))))
138 ;; If toplevel scores have been found before this \bookpart,
139 ;; add them first to a dedicated bookpart
140 (if (pair? (ly:parser-lookup 'toplevel-scores))
142 (add-bookpart (ly:make-book-part
143 (ly:parser-lookup 'toplevel-scores)))
144 (ly:parser-define! 'toplevel-scores (list))))
145 (add-bookpart book-part))
147 (define-public (collect-scores-for-book score)
148 (ly:parser-define! 'toplevel-scores
149 (cons score (ly:parser-lookup 'toplevel-scores))))
151 (define-public (collect-music-aux score-handler music)
152 (define (music-property symbol)
153 (ly:music-property music symbol #f))
154 (cond ((music-property 'page-marker)
155 ;; a page marker: set page break/turn permissions or label
156 (let ((label (music-property 'page-label)))
158 (score-handler (ly:make-page-label-marker label))))
159 (for-each (lambda (symbol)
160 (let ((permission (music-property symbol)))
161 (if (symbol? permission)
163 (ly:make-page-permission-marker symbol
164 (if (eq? 'forbid permission)
167 '(line-break-permission page-break-permission
168 page-turn-permission)))
169 ((not (music-property 'void))
170 ;; a regular music expression: make a score with this music
171 ;; void music is discarded
172 (score-handler (scorify-music music)))))
174 (define-public (collect-music-for-book music)
175 "Top-level music handler."
176 (collect-music-aux (lambda (score)
177 (collect-scores-for-book score))
180 (define-public (collect-book-music-for-book book music)
181 "Book music handler."
182 (collect-music-aux (lambda (score)
183 (ly:book-add-score! book score))
186 (define-public (scorify-music music)
187 "Preprocess @var{music}."
189 (fold (lambda (f m) (f m))
191 toplevel-music-functions)))
193 (define (get-current-filename book)
194 "return any suffix value for output filename allowing for settings by
195 calls to bookOutputName function"
196 (or (paper-variable book 'output-filename)
197 (ly:parser-output-name)))
199 (define (get-current-suffix book)
200 "return any suffix value for output filename allowing for settings by calls to
202 (let ((book-output-suffix (paper-variable book 'output-suffix)))
203 (if (not (string? book-output-suffix))
204 (ly:parser-lookup 'output-suffix)
205 book-output-suffix)))
207 (define-public current-outfile-name #f) ; for use by regression tests
209 (define (get-outfile-name book)
210 "return current filename for generating backend output files"
211 ;; user can now override the base file name, so we have to use
212 ;; the file-name concatenated with any potential output-suffix value
213 ;; as the key to out internal a-list
214 (let* ((base-name (get-current-filename book))
215 (output-suffix (get-current-suffix book))
216 (alist-key (format #f "~a~a" base-name output-suffix))
217 (counter-alist (ly:parser-lookup 'counter-alist))
218 (output-count (assoc-get alist-key counter-alist 0))
220 ;; Allow all ASCII alphanumerics, including accents
221 (if (string? output-suffix)
225 (string-regexp-substitute
230 ;; assoc-get call will always have returned a number
231 (if (> output-count 0)
232 (set! result (format #f "~a-~a" result output-count)))
234 (ly:parser-define! 'counter-alist
235 (assoc-set! counter-alist alist-key (1+ output-count)))
236 (set! current-outfile-name result)
239 (define (print-book-with book process-procedure)
240 (let* ((paper (ly:parser-lookup '$defaultpaper))
241 (layout (ly:parser-lookup '$defaultlayout))
242 (outfile-name (get-outfile-name book)))
243 (process-procedure book paper layout outfile-name)))
245 (define-public (print-book-with-defaults book)
246 (print-book-with book ly:book-process))
248 (define-public (print-book-with-defaults-as-systems book)
249 (print-book-with book ly:book-process-to-systems))
251 ;; Add a score to the current bookpart, book or toplevel
252 (define-public (add-score score)
254 ((ly:parser-lookup '$current-bookpart)
255 ((ly:parser-lookup 'bookpart-score-handler)
256 (ly:parser-lookup '$current-bookpart) score))
257 ((ly:parser-lookup '$current-book)
258 ((ly:parser-lookup 'book-score-handler)
259 (ly:parser-lookup '$current-book) score))
261 ((ly:parser-lookup 'toplevel-score-handler) score))))
263 (define-public paper-variable
267 (append (if (and book (ly:output-def? (ly:book-paper book)))
268 (list (ly:book-paper book))
270 (ly:parser-lookup '$papers)
271 (list (ly:parser-lookup '$defaultpaper))))))
272 (make-procedure-with-setter
273 (lambda (book symbol)
274 (any (lambda (p) (ly:output-def-lookup p symbol #f))
276 (lambda (book symbol value)
277 (ly:output-def-set-variable!
278 (car (get-papers book))
281 (define-public (add-text text)
282 (add-score (list text)))
284 (define-public (add-music music)
285 (collect-music-aux (lambda (score)
289 (define-public (context-mod-from-music music)
290 (let ((warn #t) (mods (ly:make-context-mod)))
291 (let loop ((m music))
292 (if (music-is-of-type? m 'layout-instruction-event)
293 (let ((symbol (ly:music-property m 'symbol)))
296 (case (ly:music-property m 'name)
300 (ly:music-property m 'value)))
302 (list 'unset symbol))
306 (ly:music-property m 'grob-value)
308 ((ly:music-property m 'grob-property #f) => list)
310 (ly:music-property m 'grob-property-path)))))
315 ((ly:music-property m 'grob-property #f) => list)
317 (ly:music-property m 'grob-property-path))))))))
318 (case (ly:music-property m 'name)
320 (ly:add-context-mod mods
322 (ly:music-property m 'procedure))))
323 ((ContextSpeccedMusic)
324 (loop (ly:music-property m 'element)))
326 (let ((callback (ly:music-property m 'elements-callback)))
327 (if (procedure? callback)
328 (for-each loop (callback m))
329 (if (and warn (ly:duration? (ly:music-property m 'duration)))
333 (_ "Music unsuitable for context-mod"))
334 (set! warn #f)))))))))
337 (define-public (context-defs-from-music output-def music)
339 (let loop ((m music) (mods #f))
340 ;; The parser turns all sets, overrides etc into something
341 ;; wrapped in ContextSpeccedMusic. If we ever get a set,
342 ;; override etc that is not wrapped in ContextSpeccedMusic, the
343 ;; user has created it in Scheme himself without providing the
344 ;; required wrapping. In that case, using #f in the place of a
345 ;; context modification results in a reasonably recognizable
347 (if (music-is-of-type? m 'layout-instruction-event)
350 (case (ly:music-property m 'name)
353 (ly:music-property m 'symbol)
354 (ly:music-property m 'value)))
357 (ly:music-property m 'symbol)))
360 (ly:music-property m 'symbol)
361 (ly:music-property m 'grob-value)
363 ((ly:music-property m 'grob-property #f) => list)
365 (ly:music-property m 'grob-property-path)))))
368 (ly:music-property m 'symbol)
370 ((ly:music-property m 'grob-property #f) => list)
372 (ly:music-property m 'grob-property-path)))))))
373 (case (ly:music-property m 'name)
375 (ly:add-context-mod mods
377 (ly:music-property m 'procedure))))
378 ((ContextSpeccedMusic)
379 ;; Use let* here to let defs catch up with modifications
380 ;; to the context defs made in the recursion
381 (let* ((mods (loop (ly:music-property m 'element)
382 (ly:make-context-mod)))
383 (defs (ly:output-find-context-def
384 output-def (ly:music-property m 'context-type))))
388 (ly:format (_ "Cannot find context-def \\~a")
389 (ly:music-property m 'context-type)))
392 (ly:output-def-set-variable!
393 output-def (car entry)
394 (ly:context-def-modify (cdr entry) mods)))
397 (let ((callback (ly:music-property m 'elements-callback)))
398 (if (procedure? callback)
399 (fold loop mods (callback m))
400 (if (and warn (ly:duration? (ly:music-property m 'duration)))
404 (_ "Music unsuitable for output-def"))
405 (set! warn #f))))))))
412 (define-public assoc-get ly:assoc-get)
414 (define-public chain-assoc-get ly:chain-assoc-get)
416 (define-public (uniqued-alist alist acc)
417 (if (null? alist) acc
418 (if (assoc (caar alist) acc)
419 (uniqued-alist (cdr alist) acc)
420 (uniqued-alist (cdr alist) (cons (car alist) acc)))))
422 (define-public (alist<? x y)
423 (string<? (symbol->string (car x))
424 (symbol->string (car y))))
426 (define (map-alist-vals func list)
427 "map FUNC over the vals of LIST, leaving the keys."
430 (cons (cons (caar list) (func (cdar list)))
431 (map-alist-vals func (cdr list)))))
433 (define (map-alist-keys func list)
434 "map FUNC over the keys of an alist LIST, leaving the vals."
437 (cons (cons (func (caar list)) (cdar list))
438 (map-alist-keys func (cdr list)))))
440 (define-public (first-member members lst)
441 "Return first successful member (of member) from @var{members} in
443 (any (lambda (m) (member m lst)) members))
445 (define-public (first-assoc keys lst)
446 "Return first successful assoc of key from @var{keys} in @var{lst}."
447 (any (lambda (k) (assoc k lst)) keys))
449 (define-public (flatten-alist alist)
454 (flatten-alist (cdr alist))))))
456 (define-public (map-selected-alist-keys function keys alist)
457 "Return @var{alist} with @var{function} applied to all of the values
462 @code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))}
463 @code{((a . -1) (b . 2) (c . 3) (d . 4)}
465 (define (map-selected-alist-keys-helper key alist)
468 (if (equal? key (car pair))
469 (cons key (function (cdr pair)))
472 (fold map-selected-alist-keys-helper alist keys))
477 (define-public (vector-for-each proc vec)
480 ((>= i (vector-length vec)) vec)
481 (vector-set! vec i (proc (vector-ref vec i)))))
486 (define-public (hash-table->alist t)
487 (hash-fold acons '() t))
489 ;; todo: code dup with C++.
490 (define-safe-public (alist->hash-table lst)
491 "Convert alist to table"
492 (let ((m (make-hash-table (length lst))))
493 (for-each (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
499 (define (functional-or . rest)
502 (define (functional-and . rest)
503 (every identity rest))
505 (define (split-list lst n)
506 "Split LST in N equal sized parts"
508 (define (helper todo acc-vector k)
515 (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
516 (helper (cdr todo) acc-vector (1- k)))))
518 (helper lst (make-vector n '()) (1- n)))
520 (define (list-element-index lst x)
521 (list-index (lambda (m) (equal? m x)) lst))
523 (define-public (count-list lst)
524 "Given @var{lst} as @code{(E1 E2 .. )}, return
525 @code{((E1 . 1) (E2 . 2) ... )}."
526 (map cons lst (iota (length lst) 1)))
528 (define-public (list-join lst intermediate)
529 "Put @var{intermediate} between all elts of @var{lst}."
534 (cons elem (cons intermediate prev))
538 (define-public filtered-map filter-map)
540 (define-public (flatten-list x)
542 (let loop ((x x) (tail '()))
543 (cond ((list? x) (fold-right loop tail x))
544 ((not (pair? x)) (cons x tail))
545 (else (loop (car x) (loop (cdr x) tail))))))
547 (define (list-minus a b)
548 "Return list of elements in A that are not in B."
549 (lset-difference eq? a b))
551 (define-public (uniq-list lst)
552 "Uniq @var{lst}, assuming that it is sorted. Uses @code{equal?}
556 (fold (lambda (x acc)
559 (if (equal? x (car acc))
564 (define (split-at-predicate pred lst)
565 "Split LST into two lists at the first element that returns #f for
566 (PRED previous_element element). Return the two parts as a pair.
567 Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
568 (let ((i (and (pair? lst)
569 (list-index (lambda (x y) (not (pred x y)))
574 (lambda () (split-at lst (1+ i)))
578 (define-public (split-list-by-separator lst pred)
579 "Split @var{lst} at each element that satisfies @var{pred}, and return
580 the parts (with the separators removed) as a list of lists. For example,
581 executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns
582 @samp{((a) (b c) (d))}."
583 (call-with-values (lambda () (break pred lst))
588 (split-list-by-separator (cdr tail) pred))))))
590 (define-public (offset-add a b)
591 (cons (+ (car a) (car b))
592 (+ (cdr a) (cdr b))))
594 (define-public (offset-flip-y o)
595 (cons (car o) (- (cdr o))))
597 (define-public (offset-scale o scale)
598 (cons (* (car o) scale)
601 (define-public (ly:list->offsets accum coords)
604 (cons (cons (car coords) (cadr coords))
605 (ly:list->offsets accum (cddr coords)))))
607 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
610 (define-public empty-interval '(+inf.0 . -inf.0))
612 (define-public (symmetric-interval expr)
613 (cons (- expr) expr))
615 (define-public (interval-length x)
616 "Length of the number-pair @var{x}, if an interval."
617 (max 0 (- (cdr x) (car x))))
619 (define-public (ordered-cons a b)
623 (define-public (interval-bound interval dir)
624 ((if (= dir RIGHT) cdr car) interval))
626 (define-public (interval-index interval dir)
627 "Interpolate @var{interval} between between left (@var{dir}=-1) and
628 right (@var{dir}=+1)."
630 (* (+ (interval-start interval) (interval-end interval)
631 (* dir (- (interval-end interval) (interval-start interval))))
634 (define-public (interval-center x)
635 "Center the number-pair @var{x}, if an interval."
636 (if (interval-empty? x)
638 (/ (+ (car x) (cdr x)) 2)))
640 (define-public interval-start car)
642 (define-public interval-end cdr)
644 (define (other-axis a)
645 (remainder (+ a 1) 2))
647 (define-public (interval-scale iv factor)
648 (cons (* (car iv) factor)
649 (* (cdr iv) factor)))
651 (define-public (interval-widen iv amount)
652 (cons (- (car iv) amount)
653 (+ (cdr iv) amount)))
655 (define-public (interval-empty? iv)
656 (> (car iv) (cdr iv)))
658 (define-public (interval-union i1 i2)
660 (min (car i1) (car i2))
661 (max (cdr i1) (cdr i2))))
663 (define-public (interval-intersection i1 i2)
665 (max (car i1) (car i2))
666 (min (cdr i1) (cdr i2))))
668 (define-public (interval-sane? i)
669 (not (or (nan? (car i))
673 (> (car i) (cdr i)))))
675 (define-public (add-point interval p)
676 (cons (min (interval-start interval) p)
677 (max (interval-end interval) p)))
679 (define-public (reverse-interval iv)
680 (cons (cdr iv) (car iv)))
682 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
688 (define (coord-operation operator operand coordinate)
690 (cons (operator (coord-x operand) (coord-x coordinate))
691 (operator (coord-y operand) (coord-y coordinate)))
692 (cons (operator operand (coord-x coordinate))
693 (operator operand (coord-y coordinate)))))
695 (define (coord-apply function coordinate)
698 ((coord-x function) (coord-x coordinate))
699 ((coord-y function) (coord-y coordinate)))
701 (function (coord-x coordinate))
702 (function (coord-y coordinate)))))
704 (define-public (coord-translate coordinate amount)
705 (coord-operation + amount coordinate))
707 (define-public (coord-scale coordinate amount)
708 (coord-operation * amount coordinate))
710 (define-public (coord-rotate coordinate angle-in-radians)
711 (coord-rotated coordinate (/ angle-in-radians PI-OVER-180)))
713 (define-public (coord-rotated coordinate direction)
714 ;; Same, in degrees or with a given direction
715 (let ((dir (ly:directed direction)))
716 (cons (- (* (car dir) (car coordinate))
717 (* (cdr dir) (cdr coordinate)))
718 (+ (* (car dir) (cdr coordinate))
719 (* (cdr dir) (car coordinate))))))
721 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
724 (define-public PI (* 4 (atan 1)))
726 (define-public TWO-PI (* 2 PI))
728 (define-public PI-OVER-TWO (/ PI 2))
730 (define-public THREE-PI-OVER-TWO (* 3 PI-OVER-TWO))
732 (define-public (cyclic-base-value value cycle)
733 "Take @var{value} and modulo-maps it between 0 and base @var{cycle}."
735 (cyclic-base-value (+ value cycle) cycle))
737 (cyclic-base-value (- value cycle) cycle))
740 (define-public (angle-0-2pi angle)
741 "Take @var{angle} (in radians) and maps it between 0 and 2pi."
742 (cyclic-base-value angle TWO-PI))
744 (define-public (angle-0-360 angle)
745 "Take @var{angle} (in degrees) and maps it between 0 and 360 degrees."
746 (cyclic-base-value angle 360.0))
748 (define-public PI-OVER-180 (/ PI 180))
750 (define-public (degrees->radians angle-degrees)
751 "Convert the given angle from degrees to radians."
752 (* angle-degrees PI-OVER-180))
754 (define-public (ellipse-radius x-radius y-radius angle)
756 (* x-radius y-radius)
758 (+ (* (expt y-radius 2)
759 (* (cos angle) (cos angle)))
761 (* (sin angle) (sin angle)))))))
763 (define-public (polar->rectangular radius angle-in-degrees)
764 "Return polar coordinates (@var{radius}, @var{angle-in-degrees})
765 as rectangular coordinates @code{(x-length . y-length)}."
766 (ly:directed angle-in-degrees radius))
768 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
771 (define-public (string-endswith s suffix)
772 (equal? suffix (substring s
773 (max 0 (- (string-length s) (string-length suffix)))
776 (define-public (string-startswith s prefix)
777 (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
779 (define-public (remove-whitespace strg)
780 "Remove characters satisfying @code{char-whitespace?} from string @var{strg}"
782 (string-delete char-whitespace? strg)
783 (string-delete strg char-whitespace?)))
785 (define-public (string-encode-integer i)
788 ((< i 0) (string-append "n" (string-encode-integer (- i))))
790 (make-string 1 (integer->char (+ 65 (modulo i 26))))
791 (string-encode-integer (quotient i 26))))))
793 (define (number->octal-string x)
794 (let* ((n (inexact->exact x))
795 (n64 (quotient n 64))
796 (n8 (quotient (- n (* n64 64)) 8)))
800 (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
802 (define-public (ly:inexact->string x radix)
803 (let ((n (inexact->exact x)))
804 (number->string n radix)))
806 (define-public (ly:number-pair->string c)
807 (string-append (ly:number->string (car c)) " "
808 (ly:number->string (cdr c))))
810 (define-public (dir-basename file . rest)
811 "Strip suffixes in @var{rest}, but leave directory component for
813 (define (inverse-basename x y) (basename y x))
814 (simple-format #f "~a/~a" (dirname file)
815 (fold inverse-basename file rest)))
817 (define-public (write-me message x)
818 "Return @var{x}. Display @var{message} and write @var{x}.
819 Handy for debugging, possibly turned off."
820 (display message) (write x) (newline) x)
823 (define-public (stderr string . rest)
824 (apply format (current-error-port) string rest)
825 (force-output (current-error-port)))
827 (define-public (debugf string . rest)
829 (apply stderr string rest)))
831 (define (index-cell cell dir)
836 (define (cons-map f x)
837 "map F to contents of X"
838 (cons (f (car x)) (f (cdr x))))
840 (define-public (list-insert-separator lst between)
841 "Create new list, inserting @var{between} between elements of @var{lst}."
845 (cons x (cons between y))))
846 (fold-right conc #f lst))
848 (define-public (string-regexp-substitute a b str)
849 (regexp-substitute/global #f a str 'pre b 'post))
851 (define (regexp-split str regex)
853 (define end-of-prev-match 0)
854 (define (notice match)
856 (set! matches (cons (substring (match:string match)
860 (set! end-of-prev-match (match:end match)))
862 (regexp-substitute/global #f regex str notice 'post)
864 (if (< end-of-prev-match (string-length str))
867 (cons (substring str end-of-prev-match (string-length str)) matches)))
871 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
874 (define-public (number-format number-type num . custom-format)
875 "Print NUM accordingly to the requested NUMBER-TYPE.
876 Choices include @code{roman-lower} (by default),
877 @code{roman-upper}, @code{arabic} and @code{custom}.
878 In the latter case, CUSTOM-FORMAT must be supplied
879 and will be applied to NUM."
881 ((equal? number-type 'roman-lower)
882 (fancy-format #f "~(~@r~)" num))
883 ((equal? number-type 'roman-upper)
884 (fancy-format #f "~@r" num))
885 ((equal? number-type 'arabic)
886 (fancy-format #f "~d" num))
887 ((equal? number-type 'custom)
888 (fancy-format #f (car custom-format) num))
889 (else (fancy-format #f "~(~@r~)" num))))
891 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
894 (define (lexicographic-list-compare? op a b)
895 "Lexicographically compare two lists @var{a} and @var{b} using
896 the operator @var{op}. The types of the list elements have to
897 be comparable with @var{op}. If the lists are of different length
898 the trailing elements of the longer list are ignored."
901 (let loop ((ca ca) (cb (car b)) (a (cdr a)) (b (cdr b)))
902 (let ((axb (op ca cb)))
903 (if (and (pair? a) (pair? b)
904 (eq? axb iseql (op cb ca)))
905 (loop (car a) (car b) (cdr a) (cdr b))
908 (define (ly:version? op ver)
909 "Using the operator @var{op} compare the currently executed LilyPond
910 version with a given version @var{ver} which is passed as a list of
912 (lexicographic-list-compare? op (ly:version) ver))
922 (define-public (binary-search start end getter target-val)
923 (_i "Find the index between @var{start} and @var{end} (an integer)
924 which produces the closest match to @var{target-val} if
925 applied to function @var{getter}.")
928 (let* ((compare (quotient (+ start end) 2))
929 (get-val (getter compare)))
931 ((< target-val get-val)
932 (set! end (1- compare)))
933 ((< get-val target-val)
934 (set! start (1+ compare))))
935 (binary-search start end getter target-val))))
937 (define-public (car< a b)
940 (define-public (car<= a b)
941 (<= (car a) (car b)))
943 (define-public (symbol<? lst r)
944 (string<? (symbol->string lst) (symbol->string r)))
946 (define-public (symbol-key<? lst r)
947 (string<? (symbol->string (car lst)) (symbol->string (car r))))
949 (define-public (eval-carefully symbol module . default)
950 "Check whether all symbols in expr @var{symbol} are reachable
951 in module @var{module}. In that case evaluate, otherwise
952 print a warning and set an optional @var{default}."
953 (let* ((unavailable? (lambda (sym)
954 (not (module-defined? module sym))))
958 (filter symbol? (flatten-list symbol)))))
959 (if (null? sym-unavailable)
961 (let* ((def (and (pair? default) (car default))))
962 (ly:programming-error
963 "cannot evaluate ~S in module ~S, setting to ~S"
964 (object->string symbol)
965 (object->string module)
966 (object->string def))
969 (define (self-evaluating? x)
970 (or (number? x) (string? x) (procedure? x) (boolean? x)))
973 (any (lambda (p) ((car p) x)) lilypond-exported-predicates))
975 (define-public (pretty-printable? val)
976 (and (not (self-evaluating? val))
978 (not (hash-table? val))
979 (not (ly-type? val))))
981 (define-public (scm->string val)
982 (let* ((quote-style (if (string? val)
984 (if (or (null? val) ; (ly-type? '()) => #t
985 (and (not (self-evaluating? val))
987 (not (hash-table? val))
988 (not (ly-type? val))))
991 ; don't confuse users with #<procedure ...> syntax
992 (str (if (and (procedure? val)
993 (symbol? (procedure-name val)))
994 (symbol->string (procedure-name val))
995 (call-with-output-string
996 (if (pretty-printable? val)
997 ; property values in PDF hit margin after 64 columns
999 (pretty-print val port #:width (case quote-style
1002 (lambda (port) (display val port)))))))
1004 ((single) (string-append
1006 (string-regexp-substitute "\n " "\n " str)))
1007 ((double) (string-append "\"" str "\""))
1010 (define-public (!= lst r)
1013 (define-public lily-unit->bigpoint-factor
1015 ((equal? (ly:unit) "mm") (/ 72.0 25.4))
1016 ((equal? (ly:unit) "pt") (/ 72.0 72.27))
1017 (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
1019 (define-public lily-unit->mm-factor
1020 (* 25.4 (/ lily-unit->bigpoint-factor 72)))
1022 ;;; FONT may be font smob, or pango font string...
1023 (define-public (font-name-style font)
1025 (string-downcase font)
1026 (let* ((font-name (ly:font-name font))
1027 (full-name (if font-name font-name (ly:font-file-name font))))
1028 (string-downcase full-name))))
1030 (define-public (modified-font-metric-font-scaling font)
1031 (let* ((designsize (ly:font-design-size font))
1032 (magnification (* (ly:font-magnification font)))
1033 (scaling (* magnification designsize)))
1034 (debugf "scaling:~S\n" scaling)
1035 (debugf "magnification:~S\n" magnification)
1036 (debugf "design:~S\n" designsize)
1039 (define-public (version-not-seen-message input-file-name)
1041 (ly:format "~a:1" input-file-name)
1042 (_ "no \\version statement found, please add~afor future compatibility")
1043 (format #f "\n\n\\version ~s\n\n" (lilypond-version))))
1045 (define-public (output-module? module)
1046 "Returns @code{#t} if @var{module} belongs to an output module
1047 usually carrying context definitions (@code{\\midi} or
1049 (or (module-ref module 'is-midi #f)
1050 (module-ref module 'is-layout #f)))