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