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