scm/lily-library.scm

   1 ;;;;
   2 ;;;; lily-library.scm -- utilities
   3 ;;;;
   4 ;;;;  source file of the GNU LilyPond music typesetter
   5 ;;;;
   6 ;;;; (c) 1998--2009 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
   8
   9 ; for take, drop, take-while, list-index, and find-tail:
  10 (use-modules (srfi srfi-1))
  11
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13 ;; constants.
  14
  15 (define-public X 0)
  16 (define-public Y 1)
  17 (define-safe-public START -1)
  18 (define-safe-public STOP 1)
  19 (define-public LEFT -1)
  20 (define-public RIGHT 1)
  21 (define-public UP 1)
  22 (define-public DOWN -1)
  23 (define-public CENTER 0)
  24
  25 (define-safe-public DOUBLE-FLAT-QTS -4)
  26 (define-safe-public THREE-Q-FLAT-QTS -3)
  27 (define-safe-public FLAT-QTS -2)
  28 (define-safe-public SEMI-FLAT-QTS -1)
  29 (define-safe-public NATURAL-QTS 0)
  30 (define-safe-public SEMI-SHARP-QTS 1)
  31 (define-safe-public SHARP-QTS 2)
  32 (define-safe-public THREE-Q-SHARP-QTS 3)
  33 (define-safe-public DOUBLE-SHARP-QTS 4)
  34 (define-safe-public SEMI-TONE-QTS 2)
  35
  36 (define-safe-public DOUBLE-FLAT  -1)
  37 (define-safe-public THREE-Q-FLAT -3/4)
  38 (define-safe-public FLAT -1/2)
  39 (define-safe-public SEMI-FLAT -1/4)
  40 (define-safe-public NATURAL 0)
  41 (define-safe-public SEMI-SHARP 1/4)
  42 (define-safe-public SHARP 1/2)
  43 (define-safe-public THREE-Q-SHARP 3/4)
  44 (define-safe-public DOUBLE-SHARP 1)
  45 (define-safe-public SEMI-TONE 1/2)
  46
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48 ;; moments
  49
  50 (define-public ZERO-MOMENT (ly:make-moment 0 1))
  51
  52 (define-public (moment-min a b)
  53   (if (ly:moment<? a b) a b))
  54
  55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  56 ;; arithmetic
  57 (define-public (average x . lst)
  58   (/ (+ x (apply + lst)) (1+ (length lst))))
  59
  60 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61 ;; parser <-> output hooks.
  62
  63 (define-public (collect-bookpart-for-book parser book-part)
  64   "Toplevel book-part handler"
  65   (define (add-bookpart book-part)
  66     (ly:parser-define!
  67        parser 'toplevel-bookparts
  68        (cons book-part (ly:parser-lookup parser 'toplevel-bookparts))))
  69   ;; If toplevel scores have been found before this \bookpart,
  70   ;; add them first to a dedicated bookpart
  71   (if (pair? (ly:parser-lookup parser 'toplevel-scores))
  72       (begin
  73         (add-bookpart (ly:make-book-part
  74                        (ly:parser-lookup parser 'toplevel-scores)))
  75         (ly:parser-define! parser 'toplevel-scores (list))))
  76   (add-bookpart book-part))
  77
  78 (define-public (collect-scores-for-book parser score)
  79   (ly:parser-define!
  80    parser 'toplevel-scores
  81    (cons score (ly:parser-lookup parser 'toplevel-scores))))
  82
  83 (define-public (collect-music-aux score-handler parser music)
  84   (define (music-property symbol)
  85     (let ((value (ly:music-property music symbol)))
  86       (if (not (null? value))
  87           value
  88           #f)))
  89   (cond ((music-property 'page-marker)
  90          ;; a page marker: set page break/turn permissions or label
  91          (begin
  92            (let ((label (music-property 'page-label)))
  93              (if (symbol? label)
  94                  (score-handler (ly:make-page-label-marker label))))
  95            (for-each (lambda (symbol)
  96                        (let ((permission (music-property symbol)))
  97                          (if (symbol? permission)
  98                              (score-handler
  99                               (ly:make-page-permission-marker symbol
 100                                                               (if (eqv? 'forbid permission)
 101                                                                   '()
 102                                                                   permission))))))
 103                      (list 'line-break-permission 'page-break-permission
 104                            'page-turn-permission))))
 105         ((not (music-property 'void))
 106          ;; a regular music expression: make a score with this music
 107          ;; void music is discarded
 108          (score-handler (scorify-music music parser)))))
 109
 110 (define-public (collect-music-for-book parser music)
 111   "Top-level music handler"
 112   (collect-music-aux (lambda (score)
 113                        (collect-scores-for-book parser score))
 114                      parser
 115                      music))
 116
 117 (define-public (collect-book-music-for-book parser book music)
 118   "Book music handler"
 119   (collect-music-aux (lambda (score)
 120                        (ly:book-add-score! book score))
 121                      parser
 122                      music))
 123
 124 (define-public (scorify-music music parser)
 125   "Preprocess MUSIC."
 126
 127   (for-each (lambda (func)
 128               (set! music (func music parser)))
 129             toplevel-music-functions)
 130
 131   (ly:make-score music))
 132
 133 (define (print-book-with parser book process-procedure)
 134   (let*
 135       ((paper (ly:parser-lookup parser '$defaultpaper))
 136        (layout (ly:parser-lookup parser '$defaultlayout))
 137        (count (ly:parser-lookup parser 'output-count))
 138        (base (ly:parser-output-name parser))
 139        (output-suffix (ly:parser-lookup parser 'output-suffix)) )
 140
 141     (if (string? output-suffix)
 142         (set! base (format "~a-~a" base (string-regexp-substitute
 143                                            "[^a-zA-Z0-9-]" "_" output-suffix))))
 144
 145     ;; must be careful: output-count is under user control.
 146     (if (not (integer? count))
 147         (set! count 0))
 148
 149     (if (> count 0)
 150         (set! base (format #f "~a-~a" base count)))
 151     (ly:parser-define! parser 'output-count (1+ count))
 152     (process-procedure book paper layout base)
 153     ))
 154
 155 (define-public (print-book-with-defaults parser book)
 156   (print-book-with parser book ly:book-process))
 157
 158 (define-public (print-book-with-defaults-as-systems parser book)
 159   (print-book-with parser book ly:book-process-to-systems))
 160
 161 ;;;;;;;;;;;;;;;;
 162 ;; alist
 163
 164 (define-public assoc-get ly:assoc-get)
 165
 166 (define-public (uniqued-alist alist acc)
 167   (if (null? alist) acc
 168       (if (assoc (caar alist) acc)
 169           (uniqued-alist (cdr alist) acc)
 170           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 171
 172 (define-public (alist<? x y)
 173   (string<? (symbol->string (car x))
 174             (symbol->string (car y))))
 175
 176 (define-public (chain-assoc-get x alist-list . default)
 177   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
 178 found."
 179
 180   (define (helper x alist-list default)
 181     (if (null? alist-list)
 182         default
 183         (let* ((handle (assoc x (car alist-list))))
 184           (if (pair? handle)
 185               (cdr handle)
 186               (helper x (cdr alist-list) default)))))
 187
 188   (helper x alist-list
 189           (if (pair? default) (car default) #f)))
 190
 191 (define (map-alist-vals func list)
 192   "map FUNC over the vals of  LIST, leaving the keys."
 193   (if (null?  list)
 194       '()
 195       (cons (cons  (caar list) (func (cdar list)))
 196             (map-alist-vals func (cdr list)))))
 197
 198 (define (map-alist-keys func list)
 199   "map FUNC over the keys of an alist LIST, leaving the vals. "
 200   (if (null?  list)
 201       '()
 202       (cons (cons (func (caar list)) (cdar list))
 203             (map-alist-keys func (cdr list)))))
 204
 205 (define-public (first-member members lst)
 206   "Return first successful MEMBER of member from MEMBERS in LST."
 207   (if (null? members)
 208       #f
 209       (let ((m (member (car members) lst)))
 210         (if m m (first-member (cdr members) lst)))))
 211
 212 (define-public (first-assoc keys lst)
 213   "Return first successful ASSOC of key from KEYS in LST."
 214   (if (null? keys)
 215       #f
 216       (let ((k (assoc (car keys) lst)))
 217         (if k k (first-assoc (cdr keys) lst)))))
 218
 219 (define-public (flatten-alist alist)
 220   (if (null? alist)
 221       '()
 222       (cons (caar alist)
 223             (cons (cdar alist)
 224                   (flatten-alist (cdr alist))))))
 225
 226 ;;;;;;;;;;;;;;;;
 227 ;; vector
 228
 229 (define-public (vector-for-each proc vec)
 230   (do
 231       ((i 0 (1+ i)))
 232       ((>= i (vector-length vec)) vec)
 233     (vector-set! vec i (proc (vector-ref vec i)))))
 234
 235 ;;;;;;;;;;;;;;;;
 236 ;; hash
 237
 238 (define-public (hash-table->alist t)
 239   (hash-fold (lambda (k v acc) (acons  k v  acc))
 240              '() t))
 241
 242 ;; todo: code dup with C++.
 243 (define-safe-public (alist->hash-table lst)
 244   "Convert alist to table"
 245   (let ((m (make-hash-table (length lst))))
 246     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 247     m))
 248
 249 ;;;;;;;;;;;;;;;;
 250 ;; list
 251
 252 (define (functional-or . rest)
 253   (if (pair? rest)
 254       (or (car rest)
 255            (apply functional-and (cdr rest)))
 256       #f))
 257
 258 (define (functional-and . rest)
 259   (if (pair? rest)
 260       (and (car rest)
 261            (apply functional-and (cdr rest)))
 262       #t))
 263
 264 (define (split-list lst n)
 265   "Split LST in N equal sized parts"
 266
 267   (define (helper todo acc-vector k)
 268     (if (null? todo)
 269         acc-vector
 270         (begin
 271           (if (< k 0)
 272               (set! k (+ n k)))
 273
 274           (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
 275           (helper (cdr todo) acc-vector (1- k)))))
 276
 277   (helper lst (make-vector n '()) (1- n)))
 278
 279 (define (list-element-index lst x)
 280   (define (helper todo k)
 281     (cond
 282      ((null? todo) #f)
 283      ((equal? (car todo) x) k)
 284      (else
 285       (helper (cdr todo) (1+ k)))))
 286
 287   (helper lst 0))
 288
 289 (define-public (count-list lst)
 290   "Given lst (E1 E2 .. ) return ((E1 . 1) (E2 . 2) ... )  "
 291
 292   (define (helper l acc count)
 293     (if (pair? l)
 294         (helper (cdr l) (cons (cons (car l) count) acc) (1+ count))
 295         acc))
 296
 297
 298   (reverse (helper lst '() 1)))
 299
 300 (define-public (list-join lst intermediate)
 301   "put INTERMEDIATE  between all elts of LST."
 302
 303   (fold-right
 304    (lambda (elem prev)
 305             (if (pair? prev)
 306                 (cons  elem (cons intermediate prev))
 307                 (list elem)))
 308           '() lst))
 309
 310 (define-public (filtered-map proc lst)
 311   (filter
 312    (lambda (x) x)
 313    (map proc lst)))
 314
 315
 316 (define (flatten-list lst)
 317   "Unnest LST"
 318   (if (null? lst)
 319       '()
 320       (if (pair? (car lst))
 321           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
 322           (cons (car lst) (flatten-list (cdr lst))))))
 323
 324 (define (list-minus a b)
 325   "Return list of elements in A that are not in B."
 326   (lset-difference eq? a b))
 327
 328 (define-public (uniq-list lst)
 329   "Uniq LST, assuming that it is sorted. Uses equal? for comparisons."
 330
 331   (reverse!
 332    (fold (lambda (x acc)
 333            (if (null? acc)
 334                (list x)
 335                (if (equal? x (car acc))
 336                    acc
 337                    (cons x acc))))
 338          '() lst) '()))
 339
 340 (define (split-at-predicate pred lst)
 341   "Split LST into two lists at the first element that returns #f for
 342   (PRED previous_element element). Return the two parts as a pair.
 343   Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
 344   (if (null? lst)
 345       (list lst)
 346       (let ((i (list-index pred (cdr lst) lst)))
 347         (if i
 348             (cons (take lst (1+ i)) (drop lst (1+ i)))
 349             (list lst)))))
 350
 351 (define-public (split-list-by-separator lst pred)
 352   "Split LST at each element that satisfies PRED, and return the parts
 353   (with the separators removed) as a list of lists. Example:
 354   (split-list-by-separator '(a 0 b c 1 d) number?) ==> ((a) (b c) (d))"
 355   (let loop ((result '()) (lst lst))
 356     (if (and lst (not (null? lst)))
 357         (loop
 358           (append result
 359                   (list (take-while (lambda (x) (not (pred x))) lst)))
 360           (let ((tail (find-tail pred lst)))
 361             (if tail (cdr tail) #f)))
 362        result)))
 363
 364 (define-public (offset-add a b)
 365   (cons (+ (car a) (car b))
 366         (+ (cdr a) (cdr b))))
 367
 368 (define-public (offset-flip-y o)
 369   (cons (car o) (- (cdr o))))
 370
 371 (define-public (offset-scale o scale)
 372   (cons (* (car o) scale)
 373         (* (cdr o) scale)))
 374
 375 (define-public (ly:list->offsets accum coords)
 376   (if (null? coords)
 377       accum
 378       (cons (cons (car coords) (cadr coords))
 379             (ly:list->offsets accum (cddr coords)))))
 380
 381 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 382 ;; numbers
 383
 384 (if (not (defined? 'nan?)) ;; guile 1.6 compat
 385     (define-public (nan? x) (not (or (< 0.0 x)
 386                                      (> 0.0 x)
 387                                      (= 0.0 x)))))
 388
 389 (if (not (defined? 'inf?))
 390     (define-public (inf? x) (= (/ 1.0 x) 0.0)))
 391
 392 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 393 ;; intervals
 394
 395 (define-public (interval-length x)
 396   "Length of the number-pair X, when an interval"
 397   (max 0 (- (cdr x) (car x))))
 398
 399 (define-public interval-start car)
 400 (define-public (ordered-cons a b)
 401   (cons (min a b)
 402         (max a b)))
 403
 404 (define-public interval-end cdr)
 405
 406 (define-public (interval-bound interval dir)
 407   ((if (= dir RIGHT) cdr car) interval))
 408
 409 (define-public (interval-index interval dir)
 410   "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)"
 411
 412   (* (+  (interval-start interval) (interval-end interval)
 413          (* dir (- (interval-end interval) (interval-start interval))))
 414      0.5))
 415
 416 (define-public (interval-center x)
 417   "Center the number-pair X, when an interval"
 418   (if (interval-empty? x)
 419       0.0
 420       (/ (+ (car x) (cdr x)) 2)))
 421
 422 (define-public interval-start car)
 423 (define-public interval-end cdr)
 424 (define-public (interval-translate iv amount)
 425   (cons (+ amount (car iv))
 426         (+ amount (cdr iv))))
 427
 428 (define (other-axis a)
 429   (remainder (+ a 1) 2))
 430
 431 (define-public (interval-widen iv amount)
 432    (cons (- (car iv) amount)
 433          (+ (cdr iv) amount)))
 434
 435
 436 (define-public (interval-empty? iv)
 437    (> (car iv) (cdr iv)))
 438
 439 (define-public (interval-union i1 i2)
 440    (cons (min (car i1) (car i2))
 441          (max (cdr i1) (cdr i2))))
 442
 443 (define-public (interval-sane? i)
 444   (not (or  (nan? (car i))
 445             (inf? (car i))
 446             (nan? (cdr i))
 447             (inf? (cdr i))
 448             (> (car i) (cdr i)))))
 449
 450
 451 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 452 ;; string
 453
 454 (define-public (string-endswith s suffix)
 455   (equal? suffix (substring s
 456                             (max 0 (- (string-length s) (string-length suffix)))
 457                             (string-length s))))
 458
 459 (define-public (string-startswith s prefix)
 460   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 461
 462 (define-public (string-encode-integer i)
 463   (cond
 464    ((= i  0) "o")
 465    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 466    (else (string-append
 467           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 468           (string-encode-integer (quotient i 26))))))
 469
 470 (define (number->octal-string x)
 471   (let* ((n (inexact->exact x))
 472          (n64 (quotient n 64))
 473          (n8 (quotient (- n (* n64 64)) 8)))
 474     (string-append
 475      (number->string n64)
 476      (number->string n8)
 477      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 478
 479 (define-public (ly:inexact->string x radix)
 480   (let ((n (inexact->exact x)))
 481     (number->string n radix)))
 482
 483 (define-public (ly:number-pair->string c)
 484   (string-append (ly:number->string (car c)) " "
 485                  (ly:number->string (cdr c))))
 486
 487 (define-public (dir-basename file . rest)
 488   "Strip suffixes in REST, but leave directory component for FILE."
 489   (define (inverse-basename x y) (basename y x))
 490   (simple-format #f "~a/~a" (dirname file)
 491                  (fold inverse-basename file rest)))
 492
 493 (define-public (write-me message x)
 494   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 495 possibly turned off."
 496   (display message) (write x) (newline) x)
 497 ;;  x)
 498
 499 (define-public (stderr string . rest)
 500   (apply format (cons (current-error-port) (cons string rest)))
 501   (force-output (current-error-port)))
 502
 503 (define-public (debugf string . rest)
 504   (if #f
 505       (apply stderr (cons string rest))))
 506
 507 (define (index-cell cell dir)
 508   (if (equal? dir 1)
 509       (cdr cell)
 510       (car cell)))
 511
 512 (define (cons-map f x)
 513   "map F to contents of X"
 514   (cons (f (car x)) (f (cdr x))))
 515
 516 (define-public (list-insert-separator lst between)
 517   "Create new list, inserting BETWEEN between elements of LIST"
 518   (define (conc x y )
 519     (if (eq? y #f)
 520         (list x)
 521         (cons x  (cons between y))))
 522   (fold-right conc #f lst))
 523
 524 (define-public (string-regexp-substitute a b str)
 525   (regexp-substitute/global #f a str 'pre b 'post))
 526
 527 (define (regexp-split str regex)
 528   (define matches '())
 529   (define end-of-prev-match 0)
 530   (define (notice match)
 531
 532     (set! matches (cons (substring (match:string match)
 533                                    end-of-prev-match
 534                                    (match:start match))
 535                         matches))
 536     (set! end-of-prev-match (match:end match)))
 537
 538   (regexp-substitute/global #f regex str notice 'post)
 539
 540   (if (< end-of-prev-match (string-length str))
 541       (set!
 542        matches
 543        (cons (substring str end-of-prev-match (string-length str)) matches)))
 544
 545    (reverse matches))
 546
 547 ;;;;;;;;;;;;;;;;
 548 ;; other
 549
 550 (define (sign x)
 551   (if (= x 0)
 552       0
 553       (if (< x 0) -1 1)))
 554
 555 (define-public (binary-search start end getter target-val)
 556   (_i "Find the index between @var{start} and @var{end} (an integer)
 557 which will produce the closest match to @var{target-val} when
 558 applied to function @var{getter}.")
 559   (if (<= end start)
 560       start
 561       (let* ((compare (quotient (+ start end) 2))
 562              (get-val (getter compare)))
 563         (cond
 564          ((< target-val get-val)
 565           (set! end (1- compare)))
 566          ((< get-val target-val)
 567           (set! start (1+ compare))))
 568         (binary-search start end getter target-val))))
 569
 570 (define-public (car< a b)
 571   (< (car a) (car b)))
 572
 573 (define-public (symbol<? lst r)
 574   (string<? (symbol->string lst) (symbol->string r)))
 575
 576 (define-public (symbol-key<? lst r)
 577   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 578
 579 ;;
 580 ;; don't confuse users with #<procedure .. > syntax.
 581 ;;
 582 (define-public (scm->string val)
 583   (if (and (procedure? val)
 584            (symbol? (procedure-name val)))
 585       (symbol->string (procedure-name val))
 586       (string-append
 587        (if (self-evaluating? val)
 588            (if (string? val)
 589                "\""
 590                "")
 591            "'")
 592        (call-with-output-string (lambda (port) (display val port)))
 593        (if (string? val)
 594            "\""
 595            ""))))
 596
 597 (define-public (!= lst r)
 598   (not (= lst r)))
 599
 600 (define-public lily-unit->bigpoint-factor
 601   (cond
 602    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 603    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 604    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 605
 606 (define-public lily-unit->mm-factor
 607   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 608
 609 ;;; FONT may be font smob, or pango font string...
 610 (define-public (font-name-style font)
 611   ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
 612   (if (and (string? font)
 613            (string-prefix? "feta-alphabet" font))
 614       (string-append "emmentaler"
 615                      "-"
 616                      (substring font
 617                                 (string-length "feta-alphabet")
 618                                 (string-length font)))
 619       (let* ((font-name (ly:font-name font))
 620              (full-name (if font-name font-name (ly:font-file-name font))))
 621         (if (string-prefix? "Aybabtu" full-name)
 622             "aybabtu"
 623             (string-downcase full-name)))))
 624
 625 (define-public (modified-font-metric-font-scaling font)
 626   (let* ((designsize (ly:font-design-size font))
 627          (magnification (* (ly:font-magnification font)))
 628          (scaling (* magnification designsize)))
 629     (debugf "scaling:~S\n" scaling)
 630     (debugf "magnification:~S\n" magnification)
 631     (debugf "design:~S\n" designsize)
 632     scaling))
 633
 634 (define-public (version-not-seen-message input-file-name)
 635   (ly:message
 636    "~a:0: ~a ~a"
 637     input-file-name
 638     (_ "warning:")
 639     (format #f
 640             (_ "no \\version statement found, please add~afor future compatibility")
 641             (format #f "\n\n\\version ~s\n\n" (lilypond-version)))))
 642
 643 (define-public (old-relative-not-used-message input-file-name)
 644   (ly:message
 645    "~a:0: ~a ~a"
 646     input-file-name
 647     (_ "warning:")
 648     (_ "old relative compatibility not used")))