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