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