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