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