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