scm/lily-library.scm

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