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