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