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