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-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 (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-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 (ly:list->offsets accum coords)
 236   (if (null? coords)
 237       accum
 238       (cons (cons (car coords) (cadr coords))
 239             (ly:list->offsets accum (cddr coords)))))
 240
 241 (define-public (interval-length x)
 242   "Length of the number-pair X, when an interval"
 243   (max 0 (- (cdr x) (car x))))
 244
 245 (define-public interval-start car)
 246 (define-public interval-end cdr)
 247
 248 (define (other-axis a)
 249   (remainder (+ a 1) 2))
 250
 251 (define-public (interval-widen iv amount)
 252    (cons (- (car iv) amount)
 253          (+ (cdr iv) amount)))
 254
 255 (define-public (interval-union i1 i2)
 256    (cons (min (car i1) (car i2))
 257          (max (cdr i1) (cdr i2))))
 258
 259 (define-public (write-me message x)
 260   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 261 possibly turned off."
 262   (display message) (write x) (newline) x)
 263 ;;  x)
 264
 265 (define-public (stderr string . rest)
 266   (apply format (cons (current-error-port) (cons string rest)))
 267   (force-output (current-error-port)))
 268
 269 (define (index-cell cell dir)
 270   (if (equal? dir 1)
 271       (cdr cell)
 272       (car cell)))
 273
 274 (define (cons-map f x)
 275   "map F to contents of X"
 276   (cons (f (car x)) (f (cdr x))))
 277
 278 (define-public (list-insert-separator lst between)
 279   "Create new list, inserting BETWEEN between elements of LIST"
 280   (define (conc x y )
 281     (if (eq? y #f)
 282         (list x)
 283         (cons x  (cons between y))))
 284   (fold-right conc #f lst))
 285
 286 ;;;;;;;;;;;;;;;;
 287 ; other
 288 (define (sign x)
 289   (if (= x 0)
 290       0
 291       (if (< x 0) -1 1)))
 292
 293 (define-public (symbol<? lst r)
 294   (string<? (symbol->string lst) (symbol->string r)))
 295
 296 (define-public (!= lst r)
 297   (not (= lst r)))
 298
 299 (define-public scale-to-unit
 300   (cond
 301    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 302    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 303    (else (error "unknown unit" (ly:unit)))))
 304
 305 ;;; font
 306 (define-public (font-name-style font)
 307   ;; FIXME: ughr, (ly:font-name) sometimes also has Style appended.
 308   (let* ((font-name (ly:font-name font))
 309          (full-name (if font-name font-name (ly:font-file-name font)))
 310          (name-style (string-split full-name #\-)))
 311     ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
 312     (if (string-prefix? "feta-alphabet" full-name)
 313         (list "emmentaler"
 314               (substring  full-name (string-length "feta-alphabet")))
 315         (if (not (null? (cdr name-style)))
 316             name-style
 317             (append name-style '("Regular"))))))
 318
 319
 320 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 321
 322 (define-public (ps-embed-cff body font-set-name version)
 323   (let* ((binary-data
 324           (string-append
 325            (format "/~a ~s StartData " font-set-name (string-length body))
 326            body))
 327
 328          (header
 329           (format
 330            "%%BeginResource: font ~a
 331 %!PS-Adobe-3.0 Resource-FontSet
 332 %%DocumentNeededResources: ProcSet (FontSetInit)
 333 %%Title: (FontSet/~a)
 334 %%Version: ~s
 335 %%EndComments
 336 %%IncludeResource: ProcSet (FontSetInit)
 337 %%BeginResource: FontSet (~a)
 338 /FontSetInit /ProcSet findresource begin
 339 %%BeginData: ~s Binary Bytes
 340 "
 341            font-set-name font-set-name version font-set-name
 342            (string-length binary-data)))
 343          (footer "\n%%EndData
 344 %%EndResource
 345 %%EOF
 346 %%EndResource"))
 347
 348     (string-append
 349      header
 350      binary-data
 351      footer)))