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