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   (let* ((oldval (ly:parser-lookup parser 'toplevel-scores)))
  65     (ly:parser-define parser 'toplevel-scores (cons score oldval))))
  66
  67 (define-public (collect-music-for-book parser music)
  68   (collect-scores-for-book parser (ly:music-scorify music parser)))
  69
  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 (index-cell cell dir)
 273   (if (equal? dir 1)
 274       (cdr cell)
 275       (car cell)))
 276
 277 (define (cons-map f x)
 278   "map F to contents of X"
 279   (cons (f (car x)) (f (cdr x))))
 280
 281 (define-public (list-insert-separator lst between)
 282   "Create new list, inserting BETWEEN between elements of LIST"
 283   (define (conc x y )
 284     (if (eq? y #f)
 285         (list x)
 286         (cons x  (cons between y))))
 287   (fold-right conc #f lst))
 288
 289 ;;;;;;;;;;;;;;;;
 290 ; other
 291 (define (sign x)
 292   (if (= x 0)
 293       0
 294       (if (< x 0) -1 1)))
 295
 296 (define-public (symbol<? lst r)
 297   (string<? (symbol->string lst) (symbol->string r)))
 298
 299 (define-public (!= lst r)
 300   (not (= lst r)))
 301
 302 (define-public scale-to-unit
 303   (cond
 304    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 305    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 306    (else (error "unknown unit" (ly:unit)))))
 307
 308 ;;; font
 309 (define-public (font-name-style font)
 310   ;; FIXME: ughr, (ly:font-name) sometimes also has Style appended.
 311   (let* ((font-name (ly:font-name font))
 312          (full-name (if font-name font-name (ly:font-file-name font)))
 313          (name-style (string-split full-name #\-)))
 314     ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
 315     (if (string-prefix? "feta-alphabet" full-name)
 316         (list "emmentaler"
 317               (substring  full-name (string-length "feta-alphabet")))
 318         (if (not (null? (cdr name-style)))
 319             name-style
 320             (append name-style '("Regular"))))))
 321
 322
 323 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 324
 325 (define-public (ps-embed-cff body font-set-name version)
 326   (let* ((binary-data
 327           (string-append
 328            (format "/~a ~s StartData " font-set-name (string-length body))
 329            body))
 330
 331          (header
 332           (format
 333            "%%BeginResource: font ~a
 334 %!PS-Adobe-3.0 Resource-FontSet
 335 %%DocumentNeededResources: ProcSet (FontSetInit)
 336 %%Title: (FontSet/~a)
 337 %%Version: ~s
 338 %%EndComments
 339 %%IncludeResource: ProcSet (FontSetInit)
 340 %%BeginResource: FontSet (~a)
 341 /FontSetInit /ProcSet findresource begin
 342 %%BeginData: ~s Binary Bytes
 343 "
 344            font-set-name font-set-name version font-set-name
 345            (string-length binary-data)))
 346          (footer "\n%%EndData
 347 %%EndResource
 348 %%EOF
 349 %%EndResource\n"))
 350
 351     (string-append
 352      header
 353      binary-data
 354      footer)))
 355
 356 (define-public (version-not-seen-message)
 357   (ly:warn
 358    (format #f
 359            (_ "No \\version statement found.  Please add~afor future compatibility.")
 360            (format #f "\n\n\\version ~s\n\n" (lilypond-version))))
 361   (newline (current-error-port)))
 362
 363