scm/lily-library.scm

   1 ;;;; lily-library.scm -- utilities
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 1998--2005 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8
   9 (define-public X 0)
  10 (define-public Y 1)
  11 (define-safe-public START -1)
  12 (define-safe-public STOP 1)
  13 (define-public LEFT -1)
  14 (define-public RIGHT 1)
  15 (define-public UP 1)
  16 (define-public DOWN -1)
  17 (define-public CENTER 0)
  18
  19 (define-safe-public DOUBLE-FLAT -4)
  20 (define-safe-public THREE-Q-FLAT -3)
  21 (define-safe-public FLAT -2)
  22 (define-safe-public SEMI-FLAT -1)
  23 (define-safe-public NATURAL 0)
  24 (define-safe-public SEMI-SHARP 1)
  25 (define-safe-public SHARP 2)
  26 (define-safe-public THREE-Q-SHARP 3)
  27 (define-safe-public DOUBLE-SHARP 4)
  28 (define-safe-public SEMI-TONE 2)
  29
  30 (define-public ZERO-MOMENT (ly:make-moment 0 1))
  31
  32 (define-public (moment-min a b)
  33   (if (ly:moment<? a b) a b))
  34
  35 (define-public (average x . lst)
  36   (/ (+ x (apply + lst)) (1+ (length lst))))
  37
  38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39 ;; lily specific variables.
  40
  41 (define-public default-script-alist '())
  42
  43
  44 ;; parser stuff.
  45 (define-public (print-music-as-book parser music)
  46   (let* ((head (ly:parser-lookup parser '$defaultheader))
  47          (book (ly:make-book (ly:parser-lookup parser '$defaultpaper)
  48                              head (scorify-music music parser))))
  49     (print-book-with-defaults parser book)))
  50
  51 (define-public (print-score-as-book parser score)
  52   (let* ((head (ly:parser-lookup parser '$defaultheader))
  53          (book (ly:make-book (ly:parser-lookup parser '$defaultpaper)
  54                              head score)))
  55     (print-book-with-defaults parser book)))
  56
  57 (define-public (print-score parser score)
  58   (let* ((head (ly:parser-lookup parser '$defaultheader))
  59          (book (ly:make-book (ly:parser-lookup parser '$defaultpaper)
  60                              head score)))
  61     (ly:parser-print-score parser book)))
  62
  63 (define-public (collect-scores-for-book parser score)
  64   (ly:parser-define!
  65    parser 'toplevel-scores
  66    (cons score (ly:parser-lookup parser 'toplevel-scores))))
  67
  68
  69 (define-public (scorify-music music parser)
  70
  71   (for-each (lambda (func)
  72               (set! music (func music parser)))
  73             toplevel-music-functions)
  74
  75   (ly:make-score music))
  76
  77 (define-public (collect-music-for-book parser music)
  78   (collect-scores-for-book parser (scorify-music music parser)))
  79
  80
  81 (define-public (print-book-with-defaults parser book)
  82   (let*
  83       ((paper (ly:parser-lookup parser '$defaultpaper))
  84        (layout (ly:parser-lookup parser '$defaultlayout))
  85        (count (ly:parser-lookup parser 'output-count))
  86        (base (ly:parser-output-name parser)))
  87
  88     (if (not (integer? count))
  89         (set! count 0))
  90
  91     (if (> count 0)
  92         (set! base (format #f "~a-~a" base count)))
  93
  94     (ly:parser-define! parser 'output-count (1+ count))
  95     (ly:book-process book paper layout base)
  96     ))
  97
  98 (define-public (print-score-with-defaults parser score)
  99   (let*
 100       ((paper (ly:parser-lookup parser '$defaultpaper))
 101        (layout (ly:parser-lookup parser '$defaultlayout))
 102        (header (ly:parser-lookup parser '$defaultheader))
 103        (count (ly:parser-lookup parser 'output-count))
 104        (base (ly:parser-output-name parser)))
 105
 106     (if (not (integer? count))
 107         (set! count 0))
 108
 109     (if (> count 0)
 110         (set! base (format #f "~a-~a" base count)))
 111
 112     (ly:parser-define! parser 'output-count (1+ count))
 113
 114
 115     (ly:score-process score header paper layout base)
 116     ))
 117
 118
 119 (define-public (paper-system-title? system)
 120   (equal? #t (ly:paper-system-property system 'is-title)
 121           ))
 122
 123 (define-public (paper-system-stencil system)
 124   (ly:paper-system-property system 'stencil))
 125
 126 (define-public (paper-system-extent system axis)
 127   (ly:stencil-extent (paper-system-stencil system) axis))
 128
 129 ;;;;;;;;;;;;;;;;
 130 ;; alist
 131 (define-public assoc-get ly:assoc-get)
 132
 133 (define-public (uniqued-alist alist acc)
 134   (if (null? alist) acc
 135       (if (assoc (caar alist) acc)
 136           (uniqued-alist (cdr alist) acc)
 137           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 138
 139 (define-public (alist<? x y)
 140   (string<? (symbol->string (car x))
 141             (symbol->string (car y))))
 142
 143 (define-public (chain-assoc x alist-list)
 144   (if (null? alist-list)
 145       #f
 146       (let* ((handle (assoc x (car alist-list))))
 147         (if (pair? handle)
 148             handle
 149             (chain-assoc x (cdr alist-list))))))
 150
 151 (define-public (chain-assoc-get x alist-list . default)
 152   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
 153 found."
 154
 155   (define (helper x alist-list default)
 156     (if (null? alist-list)
 157         default
 158         (let* ((handle (assoc x (car alist-list))))
 159           (if (pair? handle)
 160               (cdr handle)
 161               (helper x (cdr alist-list) default)))))
 162
 163   (helper x alist-list
 164           (if (pair? default) (car default) #f)))
 165
 166 (define (map-alist-vals func list)
 167   "map FUNC over the vals of  LIST, leaving the keys."
 168   (if (null?  list)
 169       '()
 170       (cons (cons  (caar list) (func (cdar list)))
 171             (map-alist-vals func (cdr list)))))
 172
 173 (define (map-alist-keys func list)
 174   "map FUNC over the keys of an alist LIST, leaving the vals. "
 175   (if (null?  list)
 176       '()
 177       (cons (cons (func (caar list)) (cdar list))
 178             (map-alist-keys func (cdr list)))))
 179
 180 (define-public (first-member members lst)
 181   "Return first successful MEMBER of member from MEMBERS in LST."
 182   (if (null? members)
 183       #f
 184       (let ((m (member (car members) lst)))
 185         (if m m (first-member (cdr members) lst)))))
 186
 187 (define-public (first-assoc keys lst)
 188   "Return first successful ASSOC of key from KEYS in LST."
 189   (if (null? keys)
 190       #f
 191       (let ((k (assoc (car keys) lst)))
 192         (if k k (first-assoc (cdr keys) lst)))))
 193
 194 (define-public (flatten-alist alist)
 195   (if (null? alist)
 196       '()
 197       (cons (caar alist)
 198             (cons (cdar alist)
 199                   (flatten-alist (cdr alist))))))
 200
 201 ;;;;;;;;;;;;;;;;
 202 ;; vector
 203 (define-public (vector-for-each proc vec)
 204   (do
 205       ((i 0 (1+ i)))
 206       ((>= i (vector-length vec)) vec)
 207     (vector-set! vec i (proc (vector-ref vec i)))))
 208
 209 ;;;;;;;;;;;;;;;;
 210 ;; hash
 211
 212 (if (not (defined? 'hash-table?)) ;; guile 1.6 compat
 213     (begin
 214       (define hash-table? vector?)
 215
 216       (define-public (hash-table->alist t)
 217         "Convert table t to list"
 218         (apply append (vector->list t))))
 219
 220     ;; native hashtabs.
 221     (begin
 222       (define-public (hash-table->alist t)
 223         (hash-fold (lambda (k v acc) (acons  k v  acc))
 224                    '() t))))
 225
 226 ;; todo: code dup with C++.
 227 (define-safe-public (alist->hash-table lst)
 228   "Convert alist to table"
 229   (let ((m (make-hash-table (length lst))))
 230     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 231     m))
 232
 233 ;;;;;;;;;;;;;;;;
 234 ; list
 235
 236 (define (flatten-list lst)
 237   "Unnest LST"
 238   (if (null? lst)
 239       '()
 240       (if (pair? (car lst))
 241           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
 242           (cons (car lst) (flatten-list (cdr lst))))))
 243
 244 (define (list-minus a b)
 245   "Return list of elements in A that are not in B."
 246   (lset-difference eq? a b))
 247
 248 ;; TODO: use the srfi-1 partition function.
 249 (define-public (uniq-list lst)
 250
 251   "Uniq LST, assuming that it is sorted"
 252   (define (helper acc lst)
 253     (if (null? lst)
 254         acc
 255         (if (null? (cdr lst))
 256             (cons (car lst) acc)
 257             (if (equal? (car lst) (cadr lst))
 258                 (helper acc (cdr lst))
 259                 (helper (cons (car lst) acc)  (cdr lst))))))
 260   (reverse! (helper '() lst) '()))
 261
 262 (define (split-at-predicate predicate lst)
 263  "Split LST = (a_1 a_2 ... a_k b_1 ... b_k)
 264   into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
 265   Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
 266   L1 is copied, L2 not.
 267
 268   (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
 269  ;; " Emacs is broken
 270
 271  (define (inner-split predicate lst acc)
 272    (cond
 273     ((null? lst) acc)
 274     ((null? (cdr lst))
 275      (set-car! acc (cons (car lst) (car acc)))
 276      acc)
 277     ((predicate (car lst) (cadr lst))
 278      (set-car! acc (cons (car lst) (car acc)))
 279      (inner-split predicate (cdr lst) acc))
 280     (else
 281      (set-car! acc (cons (car lst) (car acc)))
 282      (set-cdr! acc (cdr lst))
 283      acc)))
 284
 285  (let* ((c (cons '() '())))
 286    (inner-split predicate lst  c)
 287    (set-car! c (reverse! (car c)))
 288    c))
 289
 290 (define-public (split-list lst sep?)
 291    "(display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))))
 292    =>
 293    ((a b c) (d e f) (g))
 294   "
 295    ;; " Emacs is broken
 296    (define (split-one sep?  lst acc)
 297      "Split off the first parts before separator and return both parts."
 298      (if (null? lst)
 299          (cons acc '())
 300          (if (sep? (car lst))
 301              (cons acc (cdr lst))
 302              (split-one sep? (cdr lst) (cons (car lst) acc)))))
 303
 304    (if (null? lst)
 305        '()
 306        (let* ((c (split-one sep? lst '())))
 307          (cons (reverse! (car c) '()) (split-list (cdr c) sep?)))))
 308
 309 (define-public (offset-add a b)
 310   (cons (+ (car a) (car b))
 311         (+ (cdr a) (cdr b))))
 312
 313 (define-public (offset-flip-y o)
 314   (cons (car o) (- (cdr o))))
 315
 316 (define-public (ly:list->offsets accum coords)
 317   (if (null? coords)
 318       accum
 319       (cons (cons (car coords) (cadr coords))
 320             (ly:list->offsets accum (cddr coords)))))
 321
 322 (define-public (interval-length x)
 323   "Length of the number-pair X, when an interval"
 324   (max 0 (- (cdr x) (car x))))
 325
 326 (define-public interval-start car)
 327 (define-public interval-end cdr)
 328
 329 (define-public (interval-center x)
 330   "Center the number-pair X, when an interval"
 331   (/ (+ (car x) (cdr x)) 2))
 332
 333 (define-public interval-start car)
 334 (define-public interval-end cdr)
 335 (define-public (interval-translate iv amount)
 336   (cons (+ amount (car iv))
 337         (+ amount (cdr iv))))
 338
 339 (define (other-axis a)
 340   (remainder (+ a 1) 2))
 341
 342 (define-public (interval-widen iv amount)
 343    (cons (- (car iv) amount)
 344          (+ (cdr iv) amount)))
 345
 346
 347 (define-public (interval-empty? iv)
 348    (> (car iv) (cdr iv)))
 349
 350 (define-public (interval-union i1 i2)
 351    (cons (min (car i1) (car i2))
 352          (max (cdr i1) (cdr i2))))
 353
 354 (define-public (write-me message x)
 355   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 356 possibly turned off."
 357   (display message) (write x) (newline) x)
 358 ;;  x)
 359
 360 (define-public (stderr string . rest)
 361   (apply format (cons (current-error-port) (cons string rest)))
 362   (force-output (current-error-port)))
 363
 364 (define-public (debugf string . rest)
 365   (if #f
 366       (apply stderr (cons string rest))))
 367
 368 (define (index-cell cell dir)
 369   (if (equal? dir 1)
 370       (cdr cell)
 371       (car cell)))
 372
 373 (define (cons-map f x)
 374   "map F to contents of X"
 375   (cons (f (car x)) (f (cdr x))))
 376
 377 (define-public (list-insert-separator lst between)
 378   "Create new list, inserting BETWEEN between elements of LIST"
 379   (define (conc x y )
 380     (if (eq? y #f)
 381         (list x)
 382         (cons x  (cons between y))))
 383   (fold-right conc #f lst))
 384
 385 (define-public (string-regexp-substitute a b str)
 386   (regexp-substitute/global #f a str 'pre b 'post))
 387
 388 (define (regexp-split str regex)
 389   (define matches '())
 390   (define end-of-prev-match 0)
 391   (define (notice match)
 392     (set! matches (cons (substring (match:string match)
 393                                    end-of-prev-match
 394                                    (match:start match))
 395                         matches))
 396     (set! end-of-prev-match (match:end match)))
 397
 398   (regexp-substitute/global #f regex str notice 'post)
 399
 400   (if (< end-of-prev-match (string-length str))
 401       (set!
 402        matches
 403        (cons (substring str end-of-prev-match (string-length str)) matches)))
 404
 405    (reverse matches))
 406
 407 ;;;;;;;;;;;;;;;;
 408 ; other
 409 (define (sign x)
 410   (if (= x 0)
 411       0
 412       (if (< x 0) -1 1)))
 413
 414 (define-public (symbol<? lst r)
 415   (string<? (symbol->string lst) (symbol->string r)))
 416
 417 (define-public (symbol-key<? lst r)
 418   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 419
 420 ;;
 421 ;; don't confuse users with #<procedure .. > syntax.
 422 ;;
 423 (define-public (scm->string val)
 424   (if (and (procedure? val) (symbol? (procedure-name val)))
 425       (symbol->string (procedure-name val))
 426       (string-append
 427        (if (self-evaluating? val) "" "'")
 428        (call-with-output-string (lambda (port) (display val port))))))
 429
 430 (define-public (!= lst r)
 431   (not (= lst r)))
 432
 433 (define-public lily-unit->bigpoint-factor
 434   (cond
 435    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 436    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 437    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 438
 439 (define-public lily-unit->mm-factor
 440   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 441
 442 ;;; FONT may be font smob, or pango font string...
 443 (define-public (font-name-style font)
 444       ;; FIXME: ughr, (ly:font-name) sometimes also has Style appended.
 445       (let* ((font-name (ly:font-name font))
 446              (full-name (if font-name font-name (ly:font-file-name font)))
 447              (name-style (string-split full-name #\-)))
 448         ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
 449         (if (string-prefix? "feta-alphabet" full-name)
 450             (list "emmentaler"
 451                   (substring  full-name (string-length "feta-alphabet")))
 452             (if (not (null? (cdr name-style)))
 453             name-style
 454             (append name-style '("Regular"))))))
 455
 456 (define-public (modified-font-metric-font-scaling font)
 457   (let* ((designsize (ly:font-design-size font))
 458          (magnification (* (ly:font-magnification font)))
 459          (scaling (* magnification designsize)))
 460     (debugf "scaling:~S\n" scaling)
 461     (debugf "magnification:~S\n" magnification)
 462     (debugf "design:~S\n" designsize)
 463     scaling))
 464
 465 (define-public (version-not-seen-message input-file-name)
 466   (ly:message
 467    (string-append
 468     input-file-name ": 0: " (_ "warning: ")
 469    (format #f
 470            (_ "no \\version statement found,  add~afor future compatibility")
 471            (format #f "\n\n\\version ~s\n\n" (lilypond-version))))))
 472
 473 (define-public (old-relative-not-used-message input-file-name)
 474   (ly:message
 475    (string-append
 476     input-file-name ": 0: " (_ "warning: ")
 477     (_ "old relative compatibility not used"))))