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 ;; intervals
 440
 441 (define-public empty-interval '(+inf.0 . -inf.0))
 442
 443 (define-public (symmetric-interval expr)
 444   (cons (- expr) expr))
 445
 446 (define-public (interval-length x)
 447   "Length of the number-pair X, when an interval"
 448   (max 0 (- (cdr x) (car x))))
 449
 450 (define-public (ordered-cons a b)
 451   (cons (min a b)
 452         (max a b)))
 453
 454 (define-public (interval-bound interval dir)
 455   ((if (= dir RIGHT) cdr car) interval))
 456
 457 (define-public (interval-index interval dir)
 458   "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)"
 459
 460   (* (+  (interval-start interval) (interval-end interval)
 461          (* dir (- (interval-end interval) (interval-start interval))))
 462      0.5))
 463
 464 (define-public (interval-center x)
 465   "Center the number-pair X, when an interval"
 466   (if (interval-empty? x)
 467       0.0
 468       (/ (+ (car x) (cdr x)) 2)))
 469
 470 (define-public interval-start car)
 471
 472 (define-public interval-end cdr)
 473
 474 (define-public (interval-translate iv amount)
 475   (cons (+ amount (car iv))
 476         (+ amount (cdr iv))))
 477
 478 (define (other-axis a)
 479   (remainder (+ a 1) 2))
 480
 481 (define-public (interval-widen iv amount)
 482    (cons (- (car iv) amount)
 483          (+ (cdr iv) amount)))
 484
 485 (define-public (interval-empty? iv)
 486    (> (car iv) (cdr iv)))
 487
 488 (define-public (interval-union i1 i2)
 489    (cons (min (car i1) (car i2))
 490          (max (cdr i1) (cdr i2))))
 491
 492 (define-public (interval-intersection i1 i2)
 493    (cons (max (car i1) (car i2))
 494          (min (cdr i1) (cdr i2))))
 495
 496 (define-public (interval-sane? i)
 497   (not (or  (nan? (car i))
 498             (inf? (car i))
 499             (nan? (cdr i))
 500             (inf? (cdr i))
 501             (> (car i) (cdr i)))))
 502
 503 (define-public (add-point interval p)
 504   (cons (min (interval-start interval) p)
 505         (max (interval-end interval) p)))
 506
 507 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 508 ;; string
 509
 510 (define-public (string-endswith s suffix)
 511   (equal? suffix (substring s
 512                             (max 0 (- (string-length s) (string-length suffix)))
 513                             (string-length s))))
 514
 515 (define-public (string-startswith s prefix)
 516   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 517
 518 (define-public (string-encode-integer i)
 519   (cond
 520    ((= i  0) "o")
 521    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 522    (else (string-append
 523           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 524           (string-encode-integer (quotient i 26))))))
 525
 526 (define (number->octal-string x)
 527   (let* ((n (inexact->exact x))
 528          (n64 (quotient n 64))
 529          (n8 (quotient (- n (* n64 64)) 8)))
 530     (string-append
 531      (number->string n64)
 532      (number->string n8)
 533      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 534
 535 (define-public (ly:inexact->string x radix)
 536   (let ((n (inexact->exact x)))
 537     (number->string n radix)))
 538
 539 (define-public (ly:number-pair->string c)
 540   (string-append (ly:number->string (car c)) " "
 541                  (ly:number->string (cdr c))))
 542
 543 (define-public (dir-basename file . rest)
 544   "Strip suffixes in REST, but leave directory component for FILE."
 545   (define (inverse-basename x y) (basename y x))
 546   (simple-format #f "~a/~a" (dirname file)
 547                  (fold inverse-basename file rest)))
 548
 549 (define-public (write-me message x)
 550   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 551 possibly turned off."
 552   (display message) (write x) (newline) x)
 553 ;;  x)
 554
 555 (define-public (stderr string . rest)
 556   (apply format (cons (current-error-port) (cons string rest)))
 557   (force-output (current-error-port)))
 558
 559 (define-public (debugf string . rest)
 560   (if #f
 561       (apply stderr (cons string rest))))
 562
 563 (define (index-cell cell dir)
 564   (if (equal? dir 1)
 565       (cdr cell)
 566       (car cell)))
 567
 568 (define (cons-map f x)
 569   "map F to contents of X"
 570   (cons (f (car x)) (f (cdr x))))
 571
 572 (define-public (list-insert-separator lst between)
 573   "Create new list, inserting BETWEEN between elements of LIST"
 574   (define (conc x y )
 575     (if (eq? y #f)
 576         (list x)
 577         (cons x  (cons between y))))
 578   (fold-right conc #f lst))
 579
 580 (define-public (string-regexp-substitute a b str)
 581   (regexp-substitute/global #f a str 'pre b 'post))
 582
 583 (define (regexp-split str regex)
 584   (define matches '())
 585   (define end-of-prev-match 0)
 586   (define (notice match)
 587
 588     (set! matches (cons (substring (match:string match)
 589                                    end-of-prev-match
 590                                    (match:start match))
 591                         matches))
 592     (set! end-of-prev-match (match:end match)))
 593
 594   (regexp-substitute/global #f regex str notice 'post)
 595
 596   (if (< end-of-prev-match (string-length str))
 597       (set!
 598        matches
 599        (cons (substring str end-of-prev-match (string-length str)) matches)))
 600
 601    (reverse matches))
 602
 603 ;;;;;;;;;;;;;;;;
 604 ;; other
 605
 606 (define (sign x)
 607   (if (= x 0)
 608       0
 609       (if (< x 0) -1 1)))
 610
 611 (define-public (binary-search start end getter target-val)
 612   (_i "Find the index between @var{start} and @var{end} (an integer)
 613 which will produce the closest match to @var{target-val} when
 614 applied to function @var{getter}.")
 615   (if (<= end start)
 616       start
 617       (let* ((compare (quotient (+ start end) 2))
 618              (get-val (getter compare)))
 619         (cond
 620          ((< target-val get-val)
 621           (set! end (1- compare)))
 622          ((< get-val target-val)
 623           (set! start (1+ compare))))
 624         (binary-search start end getter target-val))))
 625
 626 (define-public (car< a b)
 627   (< (car a) (car b)))
 628
 629 (define-public (symbol<? lst r)
 630   (string<? (symbol->string lst) (symbol->string r)))
 631
 632 (define-public (symbol-key<? lst r)
 633   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 634
 635 (define-public (eval-carefully symbol module . default)
 636   "Check if all symbols in expr SYMBOL are reachable
 637    in module MODULE. In that case evaluate, otherwise
 638    print a warning and set an optional DEFAULT."
 639   (let* ((unavailable? (lambda (sym)
 640                          (not (module-defined? module sym))))
 641          (sym-unavailable (if (pair? symbol)
 642                               (filter
 643                                 unavailable?
 644                                 (filter symbol? (flatten-list symbol)))
 645                               (if (unavailable? symbol)
 646                                    #t
 647                                    '()))))
 648     (if (null? sym-unavailable)
 649         (eval symbol module)
 650         (let* ((def (and (pair? default) (car default))))
 651           (ly:programming-error
 652             "cannot evaluate ~S in module ~S, setting to ~S"
 653             (object->string symbol)
 654             (object->string module)
 655             (object->string def))
 656           def))))
 657
 658 ;;
 659 ;; don't confuse users with #<procedure .. > syntax.
 660 ;;
 661 (define-public (scm->string val)
 662   (if (and (procedure? val)
 663            (symbol? (procedure-name val)))
 664       (symbol->string (procedure-name val))
 665       (string-append
 666        (if (self-evaluating? val)
 667            (if (string? val)
 668                "\""
 669                "")
 670            "'")
 671        (call-with-output-string (lambda (port) (display val port)))
 672        (if (string? val)
 673            "\""
 674            ""))))
 675
 676 (define-public (!= lst r)
 677   (not (= lst r)))
 678
 679 (define-public lily-unit->bigpoint-factor
 680   (cond
 681    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 682    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 683    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 684
 685 (define-public lily-unit->mm-factor
 686   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 687
 688 ;;; FONT may be font smob, or pango font string...
 689 (define-public (font-name-style font)
 690   (if (string? font)
 691       (string-downcase font)
 692       (let* ((font-name (ly:font-name font))
 693              (full-name (if font-name font-name (ly:font-file-name font))))
 694           (string-downcase full-name))))
 695
 696 (define-public (modified-font-metric-font-scaling font)
 697   (let* ((designsize (ly:font-design-size font))
 698          (magnification (* (ly:font-magnification font)))
 699          (scaling (* magnification designsize)))
 700     (debugf "scaling:~S\n" scaling)
 701     (debugf "magnification:~S\n" magnification)
 702     (debugf "design:~S\n" designsize)
 703     scaling))
 704
 705 (define-public (version-not-seen-message input-file-name)
 706   (ly:message
 707    "~a:0: ~a ~a"
 708     input-file-name
 709     (_ "warning:")
 710     (format #f
 711             (_ "no \\version statement found, please add~afor future compatibility")
 712             (format #f "\n\n\\version ~s\n\n" (lilypond-version)))))
 713
 714 (define-public (old-relative-not-used-message input-file-name)
 715   (ly:message
 716    "~a:0: ~a ~a"
 717     input-file-name
 718     (_ "warning:")
 719     (_ "old relative compatibility not used")))