scm/lily-library.scm

   1 ;;;; lily-library.scm -- utilities
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c)  1998--2004 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-public START -1)
  12 (define-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-public DOUBLE-FLAT -4)
  20 (define-public THREE-Q-FLAT -3)
  21 (define-public FLAT -2)
  22 (define-public SEMI-FLAT -1)
  23 (define-public NATURAL 0)
  24 (define-public SEMI-SHARP 1)
  25 (define-public SHARP 2)
  26 (define-public THREE-Q-SHARP 3)
  27 (define-public DOUBLE-SHARP 4)
  28 (define-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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36 ;; lily specific variables.
  37
  38 (define-public default-script-alist '())
  39
  40
  41 ;; parser stuff.
  42 (define-public (print-music-as-book parser music)
  43   (let* ((head  (ly:parser-lookup parser '$globalheader))
  44          (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
  45                              head score)))
  46     (ly:parser-print-book parser book)))
  47
  48 (define-public (print-score-as-book parser score)
  49   (let* ((head (ly:parser-lookup parser '$globalheader))
  50          (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
  51                              head score)))
  52     (ly:parser-print-book parser book)))
  53
  54 (define-public (print-score parser score)
  55   (let* ((head  (ly:parser-lookup parser '$globalheader))
  56          (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
  57                              head score)))
  58     (ly:parser-print-score parser book)))
  59
  60 (define-public (collect-scores-for-book  parser score)
  61   (let* ((oldval (ly:parser-lookup parser 'toplevel-scores)))
  62     (ly:parser-define parser 'toplevel-scores (cons score oldval))))
  63
  64 (define-public (collect-music-for-book parser music)
  65   (collect-scores-for-book parser (ly:music-scorify music parser)))
  66
  67
  68
  69 ;;;;;;;;;;;;;;;;
  70 ; alist
  71 (define-public assoc-get ly:assoc-get)
  72
  73 (define-public (uniqued-alist alist acc)
  74   (if (null? alist) acc
  75       (if (assoc (caar alist) acc)
  76           (uniqued-alist (cdr alist) acc)
  77           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
  78
  79 (define-public (alist<? x y)
  80   (string<? (symbol->string (car x))
  81             (symbol->string (car y))))
  82
  83 (define-public (chain-assoc x alist-list)
  84   (if (null? alist-list)
  85       #f
  86       (let* ((handle (assoc x (car alist-list))))
  87         (if (pair? handle)
  88             handle
  89             (chain-assoc x (cdr alist-list))))))
  90
  91 (define-public (chain-assoc-get x alist-list . default)
  92   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
  93 found."
  94
  95   (define (helper x alist-list default)
  96     (if (null? alist-list)
  97         default
  98         (let* ((handle (assoc x (car alist-list))))
  99           (if (pair? handle)
 100               (cdr handle)
 101               (helper x (cdr alist-list) default)))))
 102
 103   (helper x alist-list
 104           (if (pair? default) (car default) #f)))
 105
 106 (define (map-alist-vals func list)
 107   "map FUNC over the vals of  LIST, leaving the keys."
 108   (if (null?  list)
 109       '()
 110       (cons (cons  (caar list) (func (cdar list)))
 111             (map-alist-vals func (cdr list)))))
 112
 113 (define (map-alist-keys func list)
 114   "map FUNC over the keys of an alist LIST, leaving the vals. "
 115   (if (null?  list)
 116       '()
 117       (cons (cons (func (caar list)) (cdar list))
 118             (map-alist-keys func (cdr list)))))
 119
 120 ;;;;;;;;;;;;;;;;
 121 ;; vector
 122 (define-public (vector-for-each proc vec)
 123   (do
 124       ((i 0 (1+ i)))
 125       ((>= i (vector-length vec)) vec)
 126     (vector-set! vec i (proc (vector-ref vec i)))))
 127
 128 ;;;;;;;;;;;;;;;;
 129 ;; hash
 130
 131 (if (not (defined? 'hash-table?)) ;; guile 1.6 compat
 132     (begin
 133       (define hash-table? vector?)
 134
 135       (define-public (hash-table->alist t)
 136         "Convert table t to list"
 137         (apply append (vector->list t))))
 138
 139     ;; native hashtabs.
 140     (begin
 141       (define-public (hash-table->alist t)
 142         (hash-fold (lambda (k v acc) (acons  k v  acc))
 143                    '() t))))
 144
 145 ;; todo: code dup with C++.
 146 (define-public (alist->hash-table lst)
 147   "Convert alist to table"
 148   (let ((m (make-hash-table (length lst))))
 149     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 150     m))
 151
 152 ;;;;;;;;;;;;;;;;
 153 ; list
 154
 155 (define (flatten-list lst)
 156   "Unnest LST"
 157   (if (null? lst)
 158       '()
 159       (if (pair? (car lst))
 160           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
 161           (cons (car lst) (flatten-list (cdr lst))))))
 162
 163 (define (list-minus a b)
 164   "Return list of elements in A that are not in B."
 165   (lset-difference eq? a b))
 166
 167 ;; TODO: use the srfi-1 partition function.
 168 (define-public (uniq-list lst)
 169
 170   "Uniq LST, assuming that it is sorted"
 171   (define (helper acc lst)
 172     (if (null? lst)
 173         acc
 174         (if (null? (cdr lst))
 175             (cons (car lst) acc)
 176             (if (equal? (car lst) (cadr lst))
 177                 (helper acc (cdr lst))
 178                 (helper (cons (car lst) acc)  (cdr lst))))))
 179   (reverse! (helper '() lst) '()))
 180
 181 (define (split-at-predicate predicate lst)
 182  "Split LST = (a_1 a_2 ... a_k b_1 ... b_k)
 183   into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
 184   Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
 185   L1 is copied, L2 not.
 186
 187   (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
 188  ;; " Emacs is broken
 189
 190  (define (inner-split predicate lst acc)
 191    (cond
 192     ((null? lst) acc)
 193     ((null? (cdr lst))
 194      (set-car! acc (cons (car lst) (car acc)))
 195      acc)
 196     ((predicate (car lst) (cadr lst))
 197      (set-car! acc (cons (car lst) (car acc)))
 198      (inner-split predicate (cdr lst) acc))
 199     (else
 200      (set-car! acc (cons (car lst) (car acc)))
 201      (set-cdr! acc (cdr lst))
 202      acc))
 203    (let* ((c (cons '() '())))
 204      (inner-split predicate lst  c)
 205      (set-car! c (reverse! (car c)))
 206      c)))
 207
 208 (define-public (split-list lst sep?)
 209   "(display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
 210    =>
 211    ((a b c) (d e f) (g))
 212   "
 213   ;; " Emacs is broken
 214   (define (split-one sep?  lst acc)
 215     "Split off the first parts before separator and return both parts."
 216     (if (null? lst)
 217         (cons acc '())
 218         (if (sep? (car lst))
 219             (cons acc (cdr lst))
 220             (split-one sep? (cdr lst) (cons (car lst) acc)))))
 221
 222   (if (null? lst)
 223       '()
 224       (let* ((c (split-one sep? lst '())))
 225         (cons (reverse! (car c) '()) (split-list (cdr c) sep?)))))
 226
 227 (define-public (offset-add a b)
 228   (cons (+ (car a) (car b))
 229         (+ (cdr a) (cdr b))))
 230
 231 (define-public (ly:list->offsets accum coords)
 232   (if (null? coords)
 233       accum
 234       (cons (cons (car coords) (cadr coords))
 235             (ly:list->offsets accum (cddr coords)))))
 236
 237 (define-public (interval-length x)
 238   "Length of the number-pair X, when an interval"
 239   (max 0 (- (cdr x) (car x))))
 240
 241 (define-public interval-start car)
 242 (define-public interval-end cdr)
 243
 244 (define (other-axis a)
 245   (remainder (+ a 1) 2))
 246
 247 (define-public (interval-widen iv amount)
 248    (cons (- (car iv) amount)
 249          (+ (cdr iv) amount)))
 250
 251 (define-public (interval-union i1 i2)
 252    (cons (min (car i1) (car i2))
 253          (max (cdr i1) (cdr i2))))
 254
 255 (define-public (write-me message x)
 256   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 257 possibly turned off."
 258   (display message) (write x) (newline) x)
 259 ;;  x)
 260
 261 (define-public (stderr string . rest)
 262   (apply format (cons (current-error-port) (cons string rest)))
 263   (force-output (current-error-port)))
 264
 265 (define (index-cell cell dir)
 266   (if (equal? dir 1)
 267       (cdr cell)
 268       (car cell)))
 269
 270 (define (cons-map f x)
 271   "map F to contents of X"
 272   (cons (f (car x)) (f (cdr x))))
 273
 274 (define-public (list-insert-separator lst between)
 275   "Create new list, inserting BETWEEN between elements of LIST"
 276   (define (conc x y )
 277     (if (eq? y #f)
 278         (list x)
 279         (cons x  (cons between y))))
 280   (fold-right conc #f lst))
 281
 282 ;;;;;;;;;;;;;;;;
 283 ; other
 284 (define (sign x)
 285   (if (= x 0)
 286       0
 287       (if (< x 0) -1 1)))
 288
 289 (define-public (symbol<? lst r)
 290   (string<? (symbol->string lst) (symbol->string r)))
 291
 292 (define-public (!= lst r)
 293   (not (= lst r)))
 294
 295 (define-public scale-to-unit
 296   (cond
 297    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 298    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 299    (else (error "unknown unit" (ly:unit)))))
 300
 301 ;;; font
 302 (define-public (font-family font)
 303   (let ((name (ly:font-name font)))
 304     (if name
 305         (regexp-substitute/global #f "^GNU-(.*)-[.0-9]*$" name 'pre 1 'post)
 306         (begin
 307           ;;(stderr "font-name: ~S\n" (ly:font-name font))
 308           ;;(stderr "font-file-name: ~S\n" (ly:font-file-name font))
 309           (ly:font-file-name font)))))