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