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