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