scm/lily-library.scm

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