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