scm/lily-library.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 1998--2010 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
   5 ;;;;
   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.
  10 ;;;;
  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.
  15 ;;;;
  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/>.
  18
  19 ; for take, drop, take-while, list-index, and find-tail:
  20 (use-modules (srfi srfi-1))
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;; constants.
  24
  25 (define-public X 0)
  26 (define-public Y 1)
  27 (define-safe-public START -1)
  28 (define-safe-public STOP 1)
  29 (define-public LEFT -1)
  30 (define-public RIGHT 1)
  31 (define-public UP 1)
  32 (define-public DOWN -1)
  33 (define-public CENTER 0)
  34
  35 (define-safe-public DOUBLE-FLAT-QTS -4)
  36 (define-safe-public THREE-Q-FLAT-QTS -3)
  37 (define-safe-public FLAT-QTS -2)
  38 (define-safe-public SEMI-FLAT-QTS -1)
  39 (define-safe-public NATURAL-QTS 0)
  40 (define-safe-public SEMI-SHARP-QTS 1)
  41 (define-safe-public SHARP-QTS 2)
  42 (define-safe-public THREE-Q-SHARP-QTS 3)
  43 (define-safe-public DOUBLE-SHARP-QTS 4)
  44 (define-safe-public SEMI-TONE-QTS 2)
  45
  46 (define-safe-public DOUBLE-FLAT  -1)
  47 (define-safe-public THREE-Q-FLAT -3/4)
  48 (define-safe-public FLAT -1/2)
  49 (define-safe-public SEMI-FLAT -1/4)
  50 (define-safe-public NATURAL 0)
  51 (define-safe-public SEMI-SHARP 1/4)
  52 (define-safe-public SHARP 1/2)
  53 (define-safe-public THREE-Q-SHARP 3/4)
  54 (define-safe-public DOUBLE-SHARP 1)
  55 (define-safe-public SEMI-TONE 1/2)
  56
  57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58 ;; moments
  59
  60 (define-public ZERO-MOMENT (ly:make-moment 0 1))
  61
  62 (define-public (moment-min a b)
  63   (if (ly:moment<? a b) a b))
  64
  65 (define-public (moment<=? a b)
  66   (or (equal? a b)
  67       (ly:moment<? a b)))
  68
  69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70 ;; arithmetic
  71 (define-public (average x . lst)
  72   (/ (+ x (apply + lst)) (1+ (length lst))))
  73
  74 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75 ;; parser <-> output hooks.
  76
  77 (define-public (collect-bookpart-for-book parser book-part)
  78   "Toplevel book-part handler"
  79   (define (add-bookpart book-part)
  80     (ly:parser-define!
  81        parser 'toplevel-bookparts
  82        (cons book-part (ly:parser-lookup parser 'toplevel-bookparts))))
  83   ;; If toplevel scores have been found before this \bookpart,
  84   ;; add them first to a dedicated bookpart
  85   (if (pair? (ly:parser-lookup parser 'toplevel-scores))
  86       (begin
  87         (add-bookpart (ly:make-book-part
  88                        (ly:parser-lookup parser 'toplevel-scores)))
  89         (ly:parser-define! parser 'toplevel-scores (list))))
  90   (add-bookpart book-part))
  91
  92 (define-public (collect-scores-for-book parser score)
  93   (ly:parser-define!
  94    parser 'toplevel-scores
  95    (cons score (ly:parser-lookup parser 'toplevel-scores))))
  96
  97 (define-public (collect-music-aux score-handler parser music)
  98   (define (music-property symbol)
  99     (let ((value (ly:music-property music symbol)))
 100       (if (not (null? value))
 101           value
 102           #f)))
 103   (cond ((music-property 'page-marker)
 104          ;; a page marker: set page break/turn permissions or label
 105          (begin
 106            (let ((label (music-property 'page-label)))
 107              (if (symbol? label)
 108                  (score-handler (ly:make-page-label-marker label))))
 109            (for-each (lambda (symbol)
 110                        (let ((permission (music-property symbol)))
 111                          (if (symbol? permission)
 112                              (score-handler
 113                               (ly:make-page-permission-marker symbol
 114                                                               (if (eqv? 'forbid permission)
 115                                                                   '()
 116                                                                   permission))))))
 117                      (list 'line-break-permission 'page-break-permission
 118                            'page-turn-permission))))
 119         ((not (music-property 'void))
 120          ;; a regular music expression: make a score with this music
 121          ;; void music is discarded
 122          (score-handler (scorify-music music parser)))))
 123
 124 (define-public (collect-music-for-book parser music)
 125   "Top-level music handler"
 126   (collect-music-aux (lambda (score)
 127                        (collect-scores-for-book parser score))
 128                      parser
 129                      music))
 130
 131 (define-public (collect-book-music-for-book parser book music)
 132   "Book music handler"
 133   (collect-music-aux (lambda (score)
 134                        (ly:book-add-score! book score))
 135                      parser
 136                      music))
 137
 138 (define-public (scorify-music music parser)
 139   "Preprocess MUSIC."
 140
 141   (for-each (lambda (func)
 142               (set! music (func music parser)))
 143             toplevel-music-functions)
 144
 145   (ly:make-score music))
 146
 147
 148 (define (get-current-filename parser)
 149   "return any suffix value for output filename allowing for settings by
 150 calls to bookOutputName function"
 151   (let ((book-filename (ly:parser-lookup parser 'book-filename)))
 152     (if (not book-filename)
 153         (ly:parser-output-name parser)
 154         book-filename)))
 155
 156 (define (get-current-suffix parser)
 157   "return any suffix value for output filename allowing for settings by calls to
 158 bookoutput function"
 159   (let ((book-output-suffix (ly:parser-lookup parser 'book-output-suffix)))
 160     (if (not (string? book-output-suffix))
 161         (ly:parser-lookup parser 'output-suffix)
 162         book-output-suffix)))
 163
 164 (define-public current-outfile-name #f)  ; for use by regression tests
 165
 166 (define (get-outfile-name parser)
 167   "return current filename for generating backend output files"
 168   ;; user can now override the base file name, so we have to use
 169   ;; the file-name concatenated with any potential output-suffix value
 170   ;; as the key to out internal a-list
 171   (let* ((base-name (get-current-filename parser))
 172          (output-suffix (get-current-suffix parser))
 173          (alist-key (format "~a~a" base-name output-suffix))
 174          (counter-alist (ly:parser-lookup parser 'counter-alist))
 175          (output-count (assoc-get alist-key counter-alist 0))
 176          (result base-name))
 177     ;; Allow all ASCII alphanumerics, including accents
 178     (if (string? output-suffix)
 179         (set! result
 180               (format "~a-~a"
 181                       result
 182                       (string-regexp-substitute
 183                        "[^-[:alnum:]]"
 184                        "_"
 185                        output-suffix))))
 186
 187     ;; assoc-get call will always have returned a number
 188     (if (> output-count 0)
 189         (set! result (format #f "~a-~a" result output-count)))
 190
 191     (ly:parser-define!
 192      parser 'counter-alist
 193      (assoc-set! counter-alist alist-key (1+ output-count)))
 194     (set! current-outfile-name result)
 195     result))
 196
 197 (define (print-book-with parser book process-procedure)
 198   (let* ((paper (ly:parser-lookup parser '$defaultpaper))
 199          (layout (ly:parser-lookup parser '$defaultlayout))
 200          (outfile-name (get-outfile-name parser)))
 201     (process-procedure book paper layout outfile-name)))
 202
 203 (define-public (print-book-with-defaults parser book)
 204   (print-book-with parser book ly:book-process))
 205
 206 (define-public (print-book-with-defaults-as-systems parser book)
 207   (print-book-with parser book ly:book-process-to-systems))
 208
 209 ;; Add a score to the current bookpart, book or toplevel
 210 (define-public (add-score parser score)
 211     (cond
 212       ((ly:parser-lookup parser '$current-bookpart)
 213           ((ly:parser-lookup parser 'bookpart-score-handler)
 214                 (ly:parser-lookup parser '$current-bookpart) score))
 215       ((ly:parser-lookup parser '$current-book)
 216           ((ly:parser-lookup parser 'book-score-handler)
 217                 (ly:parser-lookup parser '$current-book) score))
 218       (else
 219           ((ly:parser-lookup parser 'toplevel-score-handler) parser score))))
 220
 221 (define-public (add-text parser text)
 222   (add-score parser (list text)))
 223
 224 (define-public (add-music parser music)
 225   (collect-music-aux (lambda (score)
 226                        (add-score parser score))
 227                      parser
 228                      music))
 229
 230
 231 ;;;;;;;;;;;;;;;;
 232 ;; alist
 233
 234 (define-public assoc-get ly:assoc-get)
 235
 236 (define-public chain-assoc-get ly:chain-assoc-get)
 237
 238 (define-public (uniqued-alist alist acc)
 239   (if (null? alist) acc
 240       (if (assoc (caar alist) acc)
 241           (uniqued-alist (cdr alist) acc)
 242           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 243
 244 (define-public (alist<? x y)
 245   (string<? (symbol->string (car x))
 246             (symbol->string (car y))))
 247
 248 (define (map-alist-vals func list)
 249   "map FUNC over the vals of  LIST, leaving the keys."
 250   (if (null?  list)
 251       '()
 252       (cons (cons  (caar list) (func (cdar list)))
 253             (map-alist-vals func (cdr list)))))
 254
 255 (define (map-alist-keys func list)
 256   "map FUNC over the keys of an alist LIST, leaving the vals. "
 257   (if (null?  list)
 258       '()
 259       (cons (cons (func (caar list)) (cdar list))
 260             (map-alist-keys func (cdr list)))))
 261
 262 (define-public (first-member members lst)
 263   "Return first successful MEMBER of member from MEMBERS in LST."
 264   (if (null? members)
 265       #f
 266       (let ((m (member (car members) lst)))
 267         (if m m (first-member (cdr members) lst)))))
 268
 269 (define-public (first-assoc keys lst)
 270   "Return first successful ASSOC of key from KEYS in LST."
 271   (if (null? keys)
 272       #f
 273       (let ((k (assoc (car keys) lst)))
 274         (if k k (first-assoc (cdr keys) lst)))))
 275
 276 (define-public (flatten-alist alist)
 277   (if (null? alist)
 278       '()
 279       (cons (caar alist)
 280             (cons (cdar alist)
 281                   (flatten-alist (cdr alist))))))
 282
 283 ;;;;;;;;;;;;;;;;
 284 ;; vector
 285
 286 (define-public (vector-for-each proc vec)
 287   (do
 288       ((i 0 (1+ i)))
 289       ((>= i (vector-length vec)) vec)
 290     (vector-set! vec i (proc (vector-ref vec i)))))
 291
 292 ;;;;;;;;;;;;;;;;
 293 ;; hash
 294
 295 (define-public (hash-table->alist t)
 296   (hash-fold (lambda (k v acc) (acons  k v  acc))
 297              '() t))
 298
 299 ;; todo: code dup with C++.
 300 (define-safe-public (alist->hash-table lst)
 301   "Convert alist to table"
 302   (let ((m (make-hash-table (length lst))))
 303     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 304     m))
 305
 306 ;;;;;;;;;;;;;;;;
 307 ;; list
 308
 309 (define (functional-or . rest)
 310   (if (pair? rest)
 311       (or (car rest)
 312            (apply functional-or (cdr rest)))
 313       #f))
 314
 315 (define (functional-and . rest)
 316   (if (pair? rest)
 317       (and (car rest)
 318            (apply functional-and (cdr rest)))
 319       #t))
 320
 321 (define (split-list lst n)
 322   "Split LST in N equal sized parts"
 323
 324   (define (helper todo acc-vector k)
 325     (if (null? todo)
 326         acc-vector
 327         (begin
 328           (if (< k 0)
 329               (set! k (+ n k)))
 330
 331           (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
 332           (helper (cdr todo) acc-vector (1- k)))))
 333
 334   (helper lst (make-vector n '()) (1- n)))
 335
 336 (define (list-element-index lst x)
 337   (define (helper todo k)
 338     (cond
 339      ((null? todo) #f)
 340      ((equal? (car todo) x) k)
 341      (else
 342       (helper (cdr todo) (1+ k)))))
 343
 344   (helper lst 0))
 345
 346 (define-public (count-list lst)
 347   "Given lst (E1 E2 .. ) return ((E1 . 1) (E2 . 2) ... )  "
 348
 349   (define (helper l acc count)
 350     (if (pair? l)
 351         (helper (cdr l) (cons (cons (car l) count) acc) (1+ count))
 352         acc))
 353
 354
 355   (reverse (helper lst '() 1)))
 356
 357 (define-public (list-join lst intermediate)
 358   "put INTERMEDIATE  between all elts of LST."
 359
 360   (fold-right
 361    (lambda (elem prev)
 362             (if (pair? prev)
 363                 (cons  elem (cons intermediate prev))
 364                 (list elem)))
 365           '() lst))
 366
 367 (define-public (filtered-map proc lst)
 368   (filter
 369    (lambda (x) x)
 370    (map proc lst)))
 371
 372 (define (flatten-list x)
 373   "Unnest list."
 374   (cond ((null? x) '())
 375         ((not (pair? x)) (list x))
 376         (else (append (flatten-list (car x))
 377                       (flatten-list (cdr x))))))
 378
 379 (define (list-minus a b)
 380   "Return list of elements in A that are not in B."
 381   (lset-difference eq? a b))
 382
 383 (define-public (uniq-list lst)
 384   "Uniq LST, assuming that it is sorted. Uses equal? for comparisons."
 385
 386   (reverse!
 387    (fold (lambda (x acc)
 388            (if (null? acc)
 389                (list x)
 390                (if (equal? x (car acc))
 391                    acc
 392                    (cons x acc))))
 393          '() lst) '()))
 394
 395 (define (split-at-predicate pred lst)
 396   "Split LST into two lists at the first element that returns #f for
 397   (PRED previous_element element). Return the two parts as a pair.
 398   Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
 399   (if (null? lst)
 400       (list lst)
 401       (let ((i (list-index (lambda (x y) (not (pred x y)))
 402                            lst
 403                            (cdr lst))))
 404         (if i
 405             (cons (take lst (1+ i)) (drop lst (1+ i)))
 406             (list lst)))))
 407
 408 (define-public (split-list-by-separator lst pred)
 409   "Split LST at each element that satisfies PRED, and return the parts
 410   (with the separators removed) as a list of lists. Example:
 411   (split-list-by-separator '(a 0 b c 1 d) number?) ==> ((a) (b c) (d))"
 412   (let loop ((result '()) (lst lst))
 413     (if (and lst (not (null? lst)))
 414         (loop
 415           (append result
 416                   (list (take-while (lambda (x) (not (pred x))) lst)))
 417           (let ((tail (find-tail pred lst)))
 418             (if tail (cdr tail) #f)))
 419        result)))
 420
 421 (define-public (offset-add a b)
 422   (cons (+ (car a) (car b))
 423         (+ (cdr a) (cdr b))))
 424
 425 (define-public (offset-flip-y o)
 426   (cons (car o) (- (cdr o))))
 427
 428 (define-public (offset-scale o scale)
 429   (cons (* (car o) scale)
 430         (* (cdr o) scale)))
 431
 432 (define-public (ly:list->offsets accum coords)
 433   (if (null? coords)
 434       accum
 435       (cons (cons (car coords) (cadr coords))
 436             (ly:list->offsets accum (cddr coords)))))
 437
 438 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 439 ;; numbers
 440
 441 (if (not (defined? 'nan?)) ;; guile 1.6 compat
 442     (define-public (nan? x) (not (or (< 0.0 x)
 443                                      (> 0.0 x)
 444                                      (= 0.0 x)))))
 445
 446 (if (not (defined? 'inf?))
 447     (define-public (inf? x) (= (/ 1.0 x) 0.0)))
 448
 449 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 450 ;; intervals
 451
 452 (define-public empty-interval '(+inf.0 . -inf.0))
 453
 454 (define-public (symmetric-interval expr)
 455   (cons (- expr) expr))
 456
 457 (define-public (interval-length x)
 458   "Length of the number-pair X, when an interval"
 459   (max 0 (- (cdr x) (car x))))
 460
 461 (define-public (ordered-cons a b)
 462   (cons (min a b)
 463         (max a b)))
 464
 465 (define-public (interval-bound interval dir)
 466   ((if (= dir RIGHT) cdr car) interval))
 467
 468 (define-public (interval-index interval dir)
 469   "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)"
 470
 471   (* (+  (interval-start interval) (interval-end interval)
 472          (* dir (- (interval-end interval) (interval-start interval))))
 473      0.5))
 474
 475 (define-public (interval-center x)
 476   "Center the number-pair X, when an interval"
 477   (if (interval-empty? x)
 478       0.0
 479       (/ (+ (car x) (cdr x)) 2)))
 480
 481 (define-public interval-start car)
 482
 483 (define-public interval-end cdr)
 484
 485 (define-public (interval-translate iv amount)
 486   (cons (+ amount (car iv))
 487         (+ amount (cdr iv))))
 488
 489 (define (other-axis a)
 490   (remainder (+ a 1) 2))
 491
 492 (define-public (interval-widen iv amount)
 493    (cons (- (car iv) amount)
 494          (+ (cdr iv) amount)))
 495
 496 (define-public (interval-empty? iv)
 497    (> (car iv) (cdr iv)))
 498
 499 (define-public (interval-union i1 i2)
 500    (cons (min (car i1) (car i2))
 501          (max (cdr i1) (cdr i2))))
 502
 503 (define-public (interval-intersection i1 i2)
 504    (cons (max (car i1) (car i2))
 505          (min (cdr i1) (cdr i2))))
 506
 507 (define-public (interval-sane? i)
 508   (not (or  (nan? (car i))
 509             (inf? (car i))
 510             (nan? (cdr i))
 511             (inf? (cdr i))
 512             (> (car i) (cdr i)))))
 513
 514 (define-public (add-point interval p)
 515   (cons (min (interval-start interval) p)
 516         (max (interval-end interval) p)))
 517
 518 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 519 ;; string
 520
 521 (define-public (string-endswith s suffix)
 522   (equal? suffix (substring s
 523                             (max 0 (- (string-length s) (string-length suffix)))
 524                             (string-length s))))
 525
 526 (define-public (string-startswith s prefix)
 527   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 528
 529 (define-public (string-encode-integer i)
 530   (cond
 531    ((= i  0) "o")
 532    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 533    (else (string-append
 534           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 535           (string-encode-integer (quotient i 26))))))
 536
 537 (define (number->octal-string x)
 538   (let* ((n (inexact->exact x))
 539          (n64 (quotient n 64))
 540          (n8 (quotient (- n (* n64 64)) 8)))
 541     (string-append
 542      (number->string n64)
 543      (number->string n8)
 544      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 545
 546 (define-public (ly:inexact->string x radix)
 547   (let ((n (inexact->exact x)))
 548     (number->string n radix)))
 549
 550 (define-public (ly:number-pair->string c)
 551   (string-append (ly:number->string (car c)) " "
 552                  (ly:number->string (cdr c))))
 553
 554 (define-public (dir-basename file . rest)
 555   "Strip suffixes in REST, but leave directory component for FILE."
 556   (define (inverse-basename x y) (basename y x))
 557   (simple-format #f "~a/~a" (dirname file)
 558                  (fold inverse-basename file rest)))
 559
 560 (define-public (write-me message x)
 561   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 562 possibly turned off."
 563   (display message) (write x) (newline) x)
 564 ;;  x)
 565
 566 (define-public (stderr string . rest)
 567   (apply format (cons (current-error-port) (cons string rest)))
 568   (force-output (current-error-port)))
 569
 570 (define-public (debugf string . rest)
 571   (if #f
 572       (apply stderr (cons string rest))))
 573
 574 (define (index-cell cell dir)
 575   (if (equal? dir 1)
 576       (cdr cell)
 577       (car cell)))
 578
 579 (define (cons-map f x)
 580   "map F to contents of X"
 581   (cons (f (car x)) (f (cdr x))))
 582
 583 (define-public (list-insert-separator lst between)
 584   "Create new list, inserting BETWEEN between elements of LIST"
 585   (define (conc x y )
 586     (if (eq? y #f)
 587         (list x)
 588         (cons x  (cons between y))))
 589   (fold-right conc #f lst))
 590
 591 (define-public (string-regexp-substitute a b str)
 592   (regexp-substitute/global #f a str 'pre b 'post))
 593
 594 (define (regexp-split str regex)
 595   (define matches '())
 596   (define end-of-prev-match 0)
 597   (define (notice match)
 598
 599     (set! matches (cons (substring (match:string match)
 600                                    end-of-prev-match
 601                                    (match:start match))
 602                         matches))
 603     (set! end-of-prev-match (match:end match)))
 604
 605   (regexp-substitute/global #f regex str notice 'post)
 606
 607   (if (< end-of-prev-match (string-length str))
 608       (set!
 609        matches
 610        (cons (substring str end-of-prev-match (string-length str)) matches)))
 611
 612    (reverse matches))
 613
 614 ;;;;;;;;;;;;;;;;
 615 ;; other
 616
 617 (define (sign x)
 618   (if (= x 0)
 619       0
 620       (if (< x 0) -1 1)))
 621
 622 (define-public (binary-search start end getter target-val)
 623   (_i "Find the index between @var{start} and @var{end} (an integer)
 624 which will produce the closest match to @var{target-val} when
 625 applied to function @var{getter}.")
 626   (if (<= end start)
 627       start
 628       (let* ((compare (quotient (+ start end) 2))
 629              (get-val (getter compare)))
 630         (cond
 631          ((< target-val get-val)
 632           (set! end (1- compare)))
 633          ((< get-val target-val)
 634           (set! start (1+ compare))))
 635         (binary-search start end getter target-val))))
 636
 637 (define-public (car< a b)
 638   (< (car a) (car b)))
 639
 640 (define-public (symbol<? lst r)
 641   (string<? (symbol->string lst) (symbol->string r)))
 642
 643 (define-public (symbol-key<? lst r)
 644   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 645
 646 (define-public (eval-carefully symbol module . default)
 647   "Check if all symbols in expr SYMBOL are reachable
 648    in module MODULE. In that case evaluate, otherwise
 649    print a warning and set an optional DEFAULT."
 650   (let* ((unavailable? (lambda (sym)
 651                          (not (module-defined? module sym))))
 652          (sym-unavailable (if (pair? symbol)
 653                               (filter
 654                                 unavailable?
 655                                 (filter symbol? (flatten-list symbol)))
 656                               (if (unavailable? symbol)
 657                                    #t
 658                                    '()))))
 659     (if (null? sym-unavailable)
 660         (eval symbol module)
 661         (let* ((def (and (pair? default) (car default))))
 662           (ly:programming-error
 663             "cannot evaluate ~S in module ~S, setting to ~S"
 664             (object->string symbol)
 665             (object->string module)
 666             (object->string def))
 667           def))))
 668
 669 ;;
 670 ;; don't confuse users with #<procedure .. > syntax.
 671 ;;
 672 (define-public (scm->string val)
 673   (if (and (procedure? val)
 674            (symbol? (procedure-name val)))
 675       (symbol->string (procedure-name val))
 676       (string-append
 677        (if (self-evaluating? val)
 678            (if (string? val)
 679                "\""
 680                "")
 681            "'")
 682        (call-with-output-string (lambda (port) (display val port)))
 683        (if (string? val)
 684            "\""
 685            ""))))
 686
 687 (define-public (!= lst r)
 688   (not (= lst r)))
 689
 690 (define-public lily-unit->bigpoint-factor
 691   (cond
 692    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 693    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 694    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 695
 696 (define-public lily-unit->mm-factor
 697   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 698
 699 ;;; FONT may be font smob, or pango font string...
 700 (define-public (font-name-style font)
 701   ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
 702   (if (and (string? font)
 703            (string-prefix? "feta-alphabet" font))
 704       (string-append "emmentaler"
 705                      "-"
 706                      (substring font
 707                                 (string-length "feta-alphabet")
 708                                 (string-length font)))
 709       (let* ((font-name (ly:font-name font))
 710              (full-name (if font-name font-name (ly:font-file-name font))))
 711         (if (string-prefix? "Emmentaler-Brace" full-name)
 712             "emmentaler-brace"
 713             (string-downcase full-name)))))
 714
 715 (define-public (modified-font-metric-font-scaling font)
 716   (let* ((designsize (ly:font-design-size font))
 717          (magnification (* (ly:font-magnification font)))
 718          (scaling (* magnification designsize)))
 719     (debugf "scaling:~S\n" scaling)
 720     (debugf "magnification:~S\n" magnification)
 721     (debugf "design:~S\n" designsize)
 722     scaling))
 723
 724 (define-public (version-not-seen-message input-file-name)
 725   (ly:message
 726    "~a:0: ~a ~a"
 727     input-file-name
 728     (_ "warning:")
 729     (format #f
 730             (_ "no \\version statement found, please add~afor future compatibility")
 731             (format #f "\n\n\\version ~s\n\n" (lilypond-version)))))
 732
 733 (define-public (old-relative-not-used-message input-file-name)
 734   (ly:message
 735    "~a:0: ~a ~a"
 736     input-file-name
 737     (_ "warning:")
 738     (_ "old relative compatibility not used")))