scm/lily-library.scm

   1 ;;;;
   2 ;;;; lily-library.scm -- utilities
   3 ;;;;
   4 ;;;;  source file of the GNU LilyPond music typesetter
   5 ;;;;
   6 ;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
   8
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10 ;; constants.
  11
  12 (define-public X 0)
  13 (define-public Y 1)
  14 (define-safe-public START -1)
  15 (define-safe-public STOP 1)
  16 (define-public LEFT -1)
  17 (define-public RIGHT 1)
  18 (define-public UP 1)
  19 (define-public DOWN -1)
  20 (define-public CENTER 0)
  21
  22 (define-safe-public DOUBLE-FLAT-QTS -4)
  23 (define-safe-public THREE-Q-FLAT-QTS -3)
  24 (define-safe-public FLAT-QTS -2)
  25 (define-safe-public SEMI-FLAT-QTS -1)
  26 (define-safe-public NATURAL-QTS 0)
  27 (define-safe-public SEMI-SHARP-QTS 1)
  28 (define-safe-public SHARP-QTS 2)
  29 (define-safe-public THREE-Q-SHARP-QTS 3)
  30 (define-safe-public DOUBLE-SHARP-QTS 4)
  31 (define-safe-public SEMI-TONE-QTS 2)
  32
  33 (define-safe-public DOUBLE-FLAT  -1)
  34 (define-safe-public THREE-Q-FLAT -3/4)
  35 (define-safe-public FLAT -1/2)
  36 (define-safe-public SEMI-FLAT -1/4)
  37 (define-safe-public NATURAL 0)
  38 (define-safe-public SEMI-SHARP 1/4)
  39 (define-safe-public SHARP 1/2)
  40 (define-safe-public THREE-Q-SHARP 3/4)
  41 (define-safe-public DOUBLE-SHARP 1)
  42 (define-safe-public SEMI-TONE 1/2)
  43
  44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  45 ;; moments
  46
  47 (define-public ZERO-MOMENT (ly:make-moment 0 1))
  48
  49 (define-public (moment-min a b)
  50   (if (ly:moment<? a b) a b))
  51
  52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53 ;; arithmetic
  54 (define-public (average x . lst)
  55   (/ (+ x (apply + lst)) (1+ (length lst))))
  56
  57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58 ;; parser <-> output hooks.
  59
  60
  61 (define-public (collect-scores-for-book parser score)
  62   (ly:parser-define!
  63    parser 'toplevel-scores
  64    (cons score (ly:parser-lookup parser 'toplevel-scores))))
  65
  66 (define (collect-music-aux score-handler parser music)
  67   (define (music-property symbol)
  68     (let ((value (ly:music-property music symbol)))
  69       (if (not (null? value))
  70           value
  71           #f)))
  72   (cond ((music-property 'page-marker)
  73          ;; a page marker: set page break/turn permissions or label
  74          (begin
  75            (let ((label (music-property 'label)))
  76              (if (symbol? label)
  77                  (score-handler (ly:make-page-label-marker label))))
  78            (for-each (lambda (symbol)
  79                        (let ((permission (music-property symbol)))
  80                          (if (symbol? permission)
  81                              (score-handler
  82                               (ly:make-page-permission-marker symbol
  83                                                               (if (eqv? 'forbid permission)
  84                                                                   '()
  85                                                                   permission))))))
  86                      (list 'line-break-permission 'page-break-permission
  87                            'page-turn-permission))))
  88         ((not (music-property 'void))
  89          ;; a regular music expression: make a score with this music
  90          ;; void music is discarded
  91          (score-handler (scorify-music music parser)))))
  92
  93 (define-public (collect-music-for-book parser music)
  94   "Top-level music handler"
  95   (collect-music-aux (lambda (score)
  96                        (collect-scores-for-book parser score))
  97                      parser
  98                      music))
  99
 100 (define-public (collect-book-music-for-book parser book music)
 101   "Book music handler"
 102   (collect-music-aux (lambda (score)
 103                        (ly:book-add-score! book score))
 104                      parser
 105                      music))
 106
 107 (define-public (scorify-music music parser)
 108   "Preprocess MUSIC."
 109
 110   (for-each (lambda (func)
 111               (set! music (func music parser)))
 112             toplevel-music-functions)
 113
 114   (ly:make-score music))
 115
 116 (define (print-book-with parser book process-procedure)
 117   (let*
 118       ((paper (ly:parser-lookup parser '$defaultpaper))
 119        (layout (ly:parser-lookup parser '$defaultlayout))
 120
 121        (count (ly:parser-lookup parser 'output-count))
 122        (base (ly:parser-output-name parser)))
 123
 124     ;; must be careful: output-count is under user control.
 125     (if (not (integer? count))
 126         (set! count 0))
 127
 128     (if (> count 0)
 129         (set! base (format #f "~a-~a" base count)))
 130
 131     (ly:parser-define! parser 'output-count (1+ count))
 132     (process-procedure book paper layout base)
 133     ))
 134
 135 (define-public (print-book-with-defaults parser book)
 136   (print-book-with parser book ly:book-process))
 137
 138 (define-public (print-book-with-defaults-as-systems parser book)
 139   (print-book-with parser book ly:book-process-to-systems))
 140
 141 ;;;;;;;;;;;;;;;;
 142 ;; alist
 143
 144 (define-public assoc-get ly:assoc-get)
 145
 146 (define-public (uniqued-alist alist acc)
 147   (if (null? alist) acc
 148       (if (assoc (caar alist) acc)
 149           (uniqued-alist (cdr alist) acc)
 150           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 151
 152 (define-public (alist<? x y)
 153   (string<? (symbol->string (car x))
 154             (symbol->string (car y))))
 155
 156 (define-public (chain-assoc-get x alist-list . default)
 157   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
 158 found."
 159
 160   (define (helper x alist-list default)
 161     (if (null? alist-list)
 162         default
 163         (let* ((handle (assoc x (car alist-list))))
 164           (if (pair? handle)
 165               (cdr handle)
 166               (helper x (cdr alist-list) default)))))
 167
 168   (helper x alist-list
 169           (if (pair? default) (car default) #f)))
 170
 171 (define (map-alist-vals func list)
 172   "map FUNC over the vals of  LIST, leaving the keys."
 173   (if (null?  list)
 174       '()
 175       (cons (cons  (caar list) (func (cdar list)))
 176             (map-alist-vals func (cdr list)))))
 177
 178 (define (map-alist-keys func list)
 179   "map FUNC over the keys of an alist LIST, leaving the vals. "
 180   (if (null?  list)
 181       '()
 182       (cons (cons (func (caar list)) (cdar list))
 183             (map-alist-keys func (cdr list)))))
 184
 185 (define-public (first-member members lst)
 186   "Return first successful MEMBER of member from MEMBERS in LST."
 187   (if (null? members)
 188       #f
 189       (let ((m (member (car members) lst)))
 190         (if m m (first-member (cdr members) lst)))))
 191
 192 (define-public (first-assoc keys lst)
 193   "Return first successful ASSOC of key from KEYS in LST."
 194   (if (null? keys)
 195       #f
 196       (let ((k (assoc (car keys) lst)))
 197         (if k k (first-assoc (cdr keys) lst)))))
 198
 199 (define-public (flatten-alist alist)
 200   (if (null? alist)
 201       '()
 202       (cons (caar alist)
 203             (cons (cdar alist)
 204                   (flatten-alist (cdr alist))))))
 205
 206 ;;;;;;;;;;;;;;;;
 207 ;; vector
 208
 209 (define-public (vector-for-each proc vec)
 210   (do
 211       ((i 0 (1+ i)))
 212       ((>= i (vector-length vec)) vec)
 213     (vector-set! vec i (proc (vector-ref vec i)))))
 214
 215 ;;;;;;;;;;;;;;;;
 216 ;; hash
 217
 218 (define-public (hash-table->alist t)
 219   (hash-fold (lambda (k v acc) (acons  k v  acc))
 220              '() t))
 221
 222 ;; todo: code dup with C++.
 223 (define-safe-public (alist->hash-table lst)
 224   "Convert alist to table"
 225   (let ((m (make-hash-table (length lst))))
 226     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 227     m))
 228
 229 ;;;;;;;;;;;;;;;;
 230 ;; list
 231
 232 (define (functional-or . rest)
 233   (if (pair? rest)
 234       (or (car rest)
 235            (apply functional-and (cdr rest)))
 236       #f))
 237
 238 (define (functional-and . rest)
 239   (if (pair? rest)
 240       (and (car rest)
 241            (apply functional-and (cdr rest)))
 242       #t))
 243
 244 (define (split-list lst n)
 245   "Split LST in N equal sized parts"
 246
 247   (define (helper todo acc-vector k)
 248     (if (null? todo)
 249         acc-vector
 250         (begin
 251           (if (< k 0)
 252               (set! k (+ n k)))
 253
 254           (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
 255           (helper (cdr todo) acc-vector (1- k)))))
 256
 257   (helper lst (make-vector n '()) (1- n)))
 258
 259 (define (list-element-index lst x)
 260   (define (helper todo k)
 261     (cond
 262      ((null? todo) #f)
 263      ((equal? (car todo) x) k)
 264      (else
 265       (helper (cdr todo) (1+ k)))))
 266
 267   (helper lst 0))
 268
 269 (define-public (count-list lst)
 270   "Given lst (E1 E2 .. ) return ((E1 . 1) (E2 . 2) ... )  "
 271
 272   (define (helper l acc count)
 273     (if (pair? l)
 274         (helper (cdr l) (cons (cons (car l) count) acc) (1+ count))
 275         acc))
 276
 277
 278   (reverse (helper lst '() 1)))
 279
 280 (define-public (list-join lst intermediate)
 281   "put INTERMEDIATE  between all elts of LST."
 282
 283   (fold-right
 284    (lambda (elem prev)
 285             (if (pair? prev)
 286                 (cons  elem (cons intermediate prev))
 287                 (list elem)))
 288           '() lst))
 289
 290 (define-public (filtered-map proc lst)
 291   (filter
 292    (lambda (x) x)
 293    (map proc lst)))
 294
 295
 296 (define (flatten-list lst)
 297   "Unnest LST"
 298   (if (null? lst)
 299       '()
 300       (if (pair? (car lst))
 301           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
 302           (cons (car lst) (flatten-list (cdr lst))))))
 303
 304 (define (list-minus a b)
 305   "Return list of elements in A that are not in B."
 306   (lset-difference eq? a b))
 307
 308 (define-public (uniq-list lst)
 309   "Uniq LST, assuming that it is sorted"
 310
 311   (reverse!
 312    (fold (lambda (x acc)
 313            (if (null? acc)
 314                (list x)
 315                (if (eq? x (car acc))
 316                    acc
 317                    (cons x acc))))
 318          '() lst) '()))
 319
 320 (define (split-at-predicate predicate lst)
 321  "Split LST = (a_1 a_2 ... a_k b_1 ... b_k)
 322   into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
 323   Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
 324   L1 is copied, L2 not.
 325
 326   (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
 327
 328  ;; " Emacs is broken
 329
 330  (define (inner-split predicate lst acc)
 331    (cond
 332     ((null? lst) acc)
 333     ((null? (cdr lst))
 334      (set-car! acc (cons (car lst) (car acc)))
 335      acc)
 336     ((predicate (car lst) (cadr lst))
 337      (set-car! acc (cons (car lst) (car acc)))
 338      (inner-split predicate (cdr lst) acc))
 339     (else
 340      (set-car! acc (cons (car lst) (car acc)))
 341      (set-cdr! acc (cdr lst))
 342      acc)))
 343
 344  (let* ((c (cons '() '())))
 345    (inner-split predicate lst  c)
 346    (set-car! c (reverse! (car c)))
 347    c))
 348
 349 (define-public (split-list-by-separator lst sep?)
 350    "(display (split-list-by-separator '(a b c / d e f / g) (lambda (x) (equal? x '/))))
 351    =>
 352    ((a b c) (d e f) (g))
 353   "
 354    ;; " Emacs is broken
 355    (define (split-one sep?  lst acc)
 356      "Split off the first parts before separator and return both parts."
 357      (if (null? lst)
 358          (cons acc '())
 359          (if (sep? (car lst))
 360              (cons acc (cdr lst))
 361              (split-one sep? (cdr lst) (cons (car lst) acc)))))
 362
 363    (if (null? lst)
 364        '()
 365        (let* ((c (split-one sep? lst '())))
 366          (cons (reverse! (car c) '()) (split-list-by-separator (cdr c) sep?)))))
 367
 368 (define-public (offset-add a b)
 369   (cons (+ (car a) (car b))
 370         (+ (cdr a) (cdr b))))
 371
 372 (define-public (offset-flip-y o)
 373   (cons (car o) (- (cdr o))))
 374
 375 (define-public (offset-scale o scale)
 376   (cons (* (car o) scale)
 377         (* (cdr o) scale)))
 378
 379 (define-public (ly:list->offsets accum coords)
 380   (if (null? coords)
 381       accum
 382       (cons (cons (car coords) (cadr coords))
 383             (ly:list->offsets accum (cddr coords)))))
 384
 385 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 386 ;; numbers
 387
 388 (if (not (defined? 'nan?)) ;; guile 1.6 compat
 389     (define-public (nan? x) (not (or (< 0.0 x)
 390                                      (> 0.0 x)
 391                                      (= 0.0 x)))))
 392
 393 (if (not (defined? 'inf?))
 394     (define-public (inf? x) (= (/ 1.0 x) 0.0)))
 395
 396 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 397 ;; intervals
 398
 399 (define-public (interval-length x)
 400   "Length of the number-pair X, when an interval"
 401   (max 0 (- (cdr x) (car x))))
 402
 403 (define-public interval-start car)
 404 (define-public (ordered-cons a b)
 405   (cons (min a b)
 406         (max a b)))
 407
 408 (define-public interval-end cdr)
 409
 410 (define-public (interval-bound interval dir)
 411   ((if (= dir RIGHT) cdr car) interval))
 412
 413 (define-public (interval-index interval dir)
 414   "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)"
 415
 416   (* (+  (interval-start interval) (interval-end interval)
 417          (* dir (- (interval-end interval) (interval-start interval))))
 418      0.5))
 419
 420 (define-public (interval-center x)
 421   "Center the number-pair X, when an interval"
 422   (if (interval-empty? x)
 423       0.0
 424       (/ (+ (car x) (cdr x)) 2)))
 425
 426 (define-public interval-start car)
 427 (define-public interval-end cdr)
 428 (define-public (interval-translate iv amount)
 429   (cons (+ amount (car iv))
 430         (+ amount (cdr iv))))
 431
 432 (define (other-axis a)
 433   (remainder (+ a 1) 2))
 434
 435 (define-public (interval-widen iv amount)
 436    (cons (- (car iv) amount)
 437          (+ (cdr iv) amount)))
 438
 439
 440 (define-public (interval-empty? iv)
 441    (> (car iv) (cdr iv)))
 442
 443 (define-public (interval-union i1 i2)
 444    (cons (min (car i1) (car i2))
 445          (max (cdr i1) (cdr i2))))
 446
 447 (define-public (interval-sane? i)
 448   (not (or  (nan? (car i))
 449             (inf? (car i))
 450             (nan? (cdr i))
 451             (inf? (cdr i))
 452             (> (car i) (cdr i)))))
 453
 454
 455 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 456 ;; string
 457
 458 (define-public (string-endswith s suffix)
 459   (equal? suffix (substring s
 460                             (max 0 (- (string-length s) (string-length suffix)))
 461                             (string-length s))))
 462
 463 (define-public (string-startswith s prefix)
 464   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 465
 466 (define-public (string-encode-integer i)
 467   (cond
 468    ((= i  0) "o")
 469    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 470    (else (string-append
 471           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 472           (string-encode-integer (quotient i 26))))))
 473
 474 (define (number->octal-string x)
 475   (let* ((n (inexact->exact x))
 476          (n64 (quotient n 64))
 477          (n8 (quotient (- n (* n64 64)) 8)))
 478     (string-append
 479      (number->string n64)
 480      (number->string n8)
 481      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 482
 483 (define-public (ly:inexact->string x radix)
 484   (let ((n (inexact->exact x)))
 485     (number->string n radix)))
 486
 487 (define-public (ly:number-pair->string c)
 488   (string-append (ly:number->string (car c)) " "
 489                  (ly:number->string (cdr c))))
 490
 491
 492 (define-public (write-me message x)
 493   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 494 possibly turned off."
 495   (display message) (write x) (newline) x)
 496 ;;  x)
 497
 498 (define-public (stderr string . rest)
 499   (apply format (cons (current-error-port) (cons string rest)))
 500   (force-output (current-error-port)))
 501
 502 (define-public (debugf string . rest)
 503   (if #f
 504       (apply stderr (cons string rest))))
 505
 506 (define (index-cell cell dir)
 507   (if (equal? dir 1)
 508       (cdr cell)
 509       (car cell)))
 510
 511 (define (cons-map f x)
 512   "map F to contents of X"
 513   (cons (f (car x)) (f (cdr x))))
 514
 515 (define-public (list-insert-separator lst between)
 516   "Create new list, inserting BETWEEN between elements of LIST"
 517   (define (conc x y )
 518     (if (eq? y #f)
 519         (list x)
 520         (cons x  (cons between y))))
 521   (fold-right conc #f lst))
 522
 523 (define-public (string-regexp-substitute a b str)
 524   (regexp-substitute/global #f a str 'pre b 'post))
 525
 526 (define (regexp-split str regex)
 527   (define matches '())
 528   (define end-of-prev-match 0)
 529   (define (notice match)
 530
 531     (set! matches (cons (substring (match:string match)
 532                                    end-of-prev-match
 533                                    (match:start match))
 534                         matches))
 535     (set! end-of-prev-match (match:end match)))
 536
 537   (regexp-substitute/global #f regex str notice 'post)
 538
 539   (if (< end-of-prev-match (string-length str))
 540       (set!
 541        matches
 542        (cons (substring str end-of-prev-match (string-length str)) matches)))
 543
 544    (reverse matches))
 545
 546 ;;;;;;;;;;;;;;;;
 547 ; other
 548 (define (sign x)
 549   (if (= x 0)
 550       0
 551       (if (< x 0) -1 1)))
 552
 553
 554 (define-public (car< a b)
 555   (< (car a) (car b)))
 556
 557 (define-public (symbol<? lst r)
 558   (string<? (symbol->string lst) (symbol->string r)))
 559
 560 (define-public (symbol-key<? lst r)
 561   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 562
 563 ;;
 564 ;; don't confuse users with #<procedure .. > syntax.
 565 ;;
 566 (define-public (scm->string val)
 567   (if (and (procedure? val) (symbol? (procedure-name val)))
 568       (symbol->string (procedure-name val))
 569       (string-append
 570        (if (self-evaluating? val) "" "'")
 571        (call-with-output-string (lambda (port) (display val port))))))
 572
 573 (define-public (!= lst r)
 574   (not (= lst r)))
 575
 576 (define-public lily-unit->bigpoint-factor
 577   (cond
 578    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 579    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 580    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 581
 582 (define-public lily-unit->mm-factor
 583   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 584
 585 ;;; FONT may be font smob, or pango font string...
 586 (define-public (font-name-style font)
 587       ;; FIXME: ughr, (ly:font-name) sometimes also has Style appended.
 588       (let* ((font-name (ly:font-name font))
 589              (full-name (if font-name font-name (ly:font-file-name font)))
 590              (name-style (string-split full-name #\-)))
 591         ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
 592         (if (string-prefix? "feta-alphabet" full-name)
 593             (list "emmentaler"
 594                   (substring  full-name (string-length "feta-alphabet")))
 595             (if (not (null? (cdr name-style)))
 596             name-style
 597             (append name-style '("Regular"))))))
 598
 599 (define-public (modified-font-metric-font-scaling font)
 600   (let* ((designsize (ly:font-design-size font))
 601          (magnification (* (ly:font-magnification font)))
 602          (scaling (* magnification designsize)))
 603     (debugf "scaling:~S\n" scaling)
 604     (debugf "magnification:~S\n" magnification)
 605     (debugf "design:~S\n" designsize)
 606     scaling))
 607
 608 (define-public (version-not-seen-message input-file-name)
 609   (ly:message
 610    "~a:0: ~a: ~a"
 611     input-file-name
 612     (_ "warning: ")
 613     (format #f
 614             (_ "no \\version statement found, please add~afor future compatibility")
 615             (format #f "\n\n\\version ~s\n\n" (lilypond-version)))))
 616
 617 (define-public (old-relative-not-used-message input-file-name)
 618   (ly:message
 619    "~a:0: ~a: ~a"
 620     input-file-name
 621     (_ "warning: ")
 622     (_ "old relative compatibility not used")))