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