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