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