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