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