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-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
  61 (define-public (collect-scores-for-book parser score)
  62   (ly:parser-define!
  63    parser 'toplevel-scores
  64    (cons score (ly:parser-lookup parser 'toplevel-scores))))
  65
  66 (define (collect-music-aux score-handler parser music)
  67   (define (music-property symbol)
  68     (let ((value (ly:music-property music symbol)))
  69       (if (not (null? value))
  70           value
  71           #f)))
  72   (cond ((music-property 'page-marker)
  73          ;; a page marker: set page break/turn permissions
  74          (for-each (lambda (symbol)
  75                      (let ((permission (music-property symbol)))
  76                        (if (symbol? permission)
  77                            (score-handler
  78                             (ly:make-page-marker symbol
  79                                                  (if (eqv? 'forbid permission)
  80                                                      '()
  81                                                      permission))))))
  82                    (list 'line-break-permission 'page-break-permission
  83                          'page-turn-permission)))
  84         ((not (music-property 'void))
  85          ;; a regular music expression: make a score with this music
  86          ;; void music is discarded
  87          (score-handler (scorify-music music parser)))))
  88
  89 (define-public (collect-music-for-book parser music)
  90   "Top-level music handler"
  91   (collect-music-aux (lambda (score)
  92                        (collect-scores-for-book parser score))
  93                      parser
  94                      music))
  95
  96 (define-public (collect-book-music-for-book parser book music)
  97   "Book music handler"
  98   (collect-music-aux (lambda (score)
  99                        (ly:book-add-score! book score))
 100                      parser
 101                      music))
 102
 103 (define-public (scorify-music music parser)
 104   "Preprocess MUSIC."
 105
 106   (for-each (lambda (func)
 107               (set! music (func music parser)))
 108             toplevel-music-functions)
 109
 110   (ly:make-score music))
 111
 112 (define (print-book-with parser book process-procedure)
 113   (let*
 114       ((paper (ly:parser-lookup parser '$defaultpaper))
 115        (layout (ly:parser-lookup parser '$defaultlayout))
 116
 117        (count (ly:parser-lookup parser 'output-count))
 118        (base (ly:parser-output-name parser)))
 119
 120     ;; must be careful: output-count is under user control.
 121     (if (not (integer? count))
 122         (set! count 0))
 123
 124     (if (> count 0)
 125         (set! base (format #f "~a-~a" base count)))
 126
 127     (ly:parser-define! parser 'output-count (1+ count))
 128     (process-procedure book paper layout base)
 129     ))
 130
 131 (define-public (print-book-with-defaults parser book)
 132   (print-book-with parser book ly:book-process))
 133
 134 (define-public (print-book-with-defaults-as-systems parser book)
 135   (print-book-with parser book ly:book-process-to-systems))
 136
 137 ;;;;;;;;;;;;;;;;
 138 ;; alist
 139
 140 (define-public assoc-get ly:assoc-get)
 141
 142 (define-public (uniqued-alist alist acc)
 143   (if (null? alist) acc
 144       (if (assoc (caar alist) acc)
 145           (uniqued-alist (cdr alist) acc)
 146           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 147
 148 (define-public (alist<? x y)
 149   (string<? (symbol->string (car x))
 150             (symbol->string (car y))))
 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 (define-public (hash-table->alist t)
 215   (hash-fold (lambda (k v acc) (acons  k v  acc))
 216              '() t))
 217
 218 ;; todo: code dup with C++.
 219 (define-safe-public (alist->hash-table lst)
 220   "Convert alist to table"
 221   (let ((m (make-hash-table (length lst))))
 222     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 223     m))
 224
 225 ;;;;;;;;;;;;;;;;
 226 ;; list
 227
 228 (define (functional-or . rest)
 229   (if (pair? rest)
 230       (or (car rest)
 231            (apply functional-and (cdr rest)))
 232       #f))
 233
 234 (define (functional-and . rest)
 235   (if (pair? rest)
 236       (and (car rest)
 237            (apply functional-and (cdr rest)))
 238       #t))
 239
 240 (define (split-list lst n)
 241   "Split LST in N equal sized parts"
 242
 243   (define (helper todo acc-vector k)
 244     (if (null? todo)
 245         acc-vector
 246         (begin
 247           (if (< k 0)
 248               (set! k (+ n k)))
 249
 250           (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
 251           (helper (cdr todo) acc-vector (1- k)))))
 252
 253   (helper lst (make-vector n '()) (1- n)))
 254
 255 (define (list-element-index lst x)
 256   (define (helper todo k)
 257     (cond
 258      ((null? todo) #f)
 259      ((equal? (car todo) x) k)
 260      (else
 261       (helper (cdr todo) (1+ k)))))
 262
 263   (helper lst 0))
 264
 265 (define-public (count-list lst)
 266   "Given lst (E1 E2 .. ) return ((E1 . 1) (E2 . 2) ... )  "
 267
 268   (define (helper l acc count)
 269     (if (pair? l)
 270         (helper (cdr l) (cons (cons (car l) count) acc) (1+ count))
 271         acc))
 272
 273
 274   (reverse (helper lst '() 1)))
 275
 276 (define-public (list-join lst intermediate)
 277   "put INTERMEDIATE  between all elts of LST."
 278
 279   (fold-right
 280    (lambda (elem prev)
 281             (if (pair? prev)
 282                 (cons  elem (cons intermediate prev))
 283                 (list elem)))
 284           '() lst))
 285
 286 (define-public (filtered-map proc lst)
 287   (filter
 288    (lambda (x) x)
 289    (map proc lst)))
 290
 291
 292 (define (flatten-list lst)
 293   "Unnest LST"
 294   (if (null? lst)
 295       '()
 296       (if (pair? (car lst))
 297           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
 298           (cons (car lst) (flatten-list (cdr lst))))))
 299
 300 (define (list-minus a b)
 301   "Return list of elements in A that are not in B."
 302   (lset-difference eq? a b))
 303
 304 (define-public (uniq-list lst)
 305   "Uniq LST, assuming that it is sorted"
 306
 307   (reverse!
 308    (fold (lambda (x acc)
 309            (if (null? acc)
 310                (list x)
 311                (if (eq? x (car acc))
 312                    acc
 313                    (cons x acc))))
 314          '() lst) '()))
 315
 316 (define (split-at-predicate predicate lst)
 317  "Split LST = (a_1 a_2 ... a_k b_1 ... b_k)
 318   into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
 319   Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
 320   L1 is copied, L2 not.
 321
 322   (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
 323
 324  ;; " Emacs is broken
 325
 326  (define (inner-split predicate lst acc)
 327    (cond
 328     ((null? lst) acc)
 329     ((null? (cdr lst))
 330      (set-car! acc (cons (car lst) (car acc)))
 331      acc)
 332     ((predicate (car lst) (cadr lst))
 333      (set-car! acc (cons (car lst) (car acc)))
 334      (inner-split predicate (cdr lst) acc))
 335     (else
 336      (set-car! acc (cons (car lst) (car acc)))
 337      (set-cdr! acc (cdr lst))
 338      acc)))
 339
 340  (let* ((c (cons '() '())))
 341    (inner-split predicate lst  c)
 342    (set-car! c (reverse! (car c)))
 343    c))
 344
 345 (define-public (split-list-by-separator lst sep?)
 346    "(display (split-list-by-separator '(a b c / d e f / g) (lambda (x) (equal? x '/))))
 347    =>
 348    ((a b c) (d e f) (g))
 349   "
 350    ;; " Emacs is broken
 351    (define (split-one sep?  lst acc)
 352      "Split off the first parts before separator and return both parts."
 353      (if (null? lst)
 354          (cons acc '())
 355          (if (sep? (car lst))
 356              (cons acc (cdr lst))
 357              (split-one sep? (cdr lst) (cons (car lst) acc)))))
 358
 359    (if (null? lst)
 360        '()
 361        (let* ((c (split-one sep? lst '())))
 362          (cons (reverse! (car c) '()) (split-list-by-separator (cdr c) sep?)))))
 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
 488 (define-public (write-me message x)
 489   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 490 possibly turned off."
 491   (display message) (write x) (newline) x)
 492 ;;  x)
 493
 494 (define-public (stderr string . rest)
 495   (apply format (cons (current-error-port) (cons string rest)))
 496   (force-output (current-error-port)))
 497
 498 (define-public (debugf string . rest)
 499   (if #f
 500       (apply stderr (cons string rest))))
 501
 502 (define (index-cell cell dir)
 503   (if (equal? dir 1)
 504       (cdr cell)
 505       (car cell)))
 506
 507 (define (cons-map f x)
 508   "map F to contents of X"
 509   (cons (f (car x)) (f (cdr x))))
 510
 511 (define-public (list-insert-separator lst between)
 512   "Create new list, inserting BETWEEN between elements of LIST"
 513   (define (conc x y )
 514     (if (eq? y #f)
 515         (list x)
 516         (cons x  (cons between y))))
 517   (fold-right conc #f lst))
 518
 519 (define-public (string-regexp-substitute a b str)
 520   (regexp-substitute/global #f a str 'pre b 'post))
 521
 522 (define (regexp-split str regex)
 523   (define matches '())
 524   (define end-of-prev-match 0)
 525   (define (notice match)
 526
 527     (set! matches (cons (substring (match:string match)
 528                                    end-of-prev-match
 529                                    (match:start match))
 530                         matches))
 531     (set! end-of-prev-match (match:end match)))
 532
 533   (regexp-substitute/global #f regex str notice 'post)
 534
 535   (if (< end-of-prev-match (string-length str))
 536       (set!
 537        matches
 538        (cons (substring str end-of-prev-match (string-length str)) matches)))
 539
 540    (reverse matches))
 541
 542 ;;;;;;;;;;;;;;;;
 543 ; other
 544 (define (sign x)
 545   (if (= x 0)
 546       0
 547       (if (< x 0) -1 1)))
 548
 549
 550 (define-public (car< a b)
 551   (< (car a) (car b)))
 552
 553 (define-public (symbol<? lst r)
 554   (string<? (symbol->string lst) (symbol->string r)))
 555
 556 (define-public (symbol-key<? lst r)
 557   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 558
 559 ;;
 560 ;; don't confuse users with #<procedure .. > syntax.
 561 ;;
 562 (define-public (scm->string val)
 563   (if (and (procedure? val) (symbol? (procedure-name val)))
 564       (symbol->string (procedure-name val))
 565       (string-append
 566        (if (self-evaluating? val) "" "'")
 567        (call-with-output-string (lambda (port) (display val port))))))
 568
 569 (define-public (!= lst r)
 570   (not (= lst r)))
 571
 572 (define-public lily-unit->bigpoint-factor
 573   (cond
 574    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 575    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 576    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 577
 578 (define-public lily-unit->mm-factor
 579   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 580
 581 ;;; FONT may be font smob, or pango font string...
 582 (define-public (font-name-style font)
 583       ;; FIXME: ughr, (ly:font-name) sometimes also has Style appended.
 584       (let* ((font-name (ly:font-name font))
 585              (full-name (if font-name font-name (ly:font-file-name font)))
 586              (name-style (string-split full-name #\-)))
 587         ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
 588         (if (string-prefix? "feta-alphabet" full-name)
 589             (list "emmentaler"
 590                   (substring  full-name (string-length "feta-alphabet")))
 591             (if (not (null? (cdr name-style)))
 592             name-style
 593             (append name-style '("Regular"))))))
 594
 595 (define-public (modified-font-metric-font-scaling font)
 596   (let* ((designsize (ly:font-design-size font))
 597          (magnification (* (ly:font-magnification font)))
 598          (scaling (* magnification designsize)))
 599     (debugf "scaling:~S\n" scaling)
 600     (debugf "magnification:~S\n" magnification)
 601     (debugf "design:~S\n" designsize)
 602     scaling))
 603
 604 (define-public (version-not-seen-message input-file-name)
 605   (ly:message
 606    "~a:0: ~a: ~a"
 607     input-file-name
 608     (_ "warning: ")
 609     (format #f
 610             (_ "no \\version statement found, please add~afor future compatibility")
 611             (format #f "\n\n\\version ~s\n\n" (lilypond-version)))))
 612
 613 (define-public (old-relative-not-used-message input-file-name)
 614   (ly:message
 615    "~a:0: ~a: ~a"
 616     input-file-name
 617     (_ "warning: ")
 618     (_ "old relative compatibility not used")))