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