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