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