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