scm/lily-library.scm

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