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