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