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*
  50       ((head  (ly:parser-lookup parser '$globalheader))
  51        (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
  52                            head score)))
  53     (ly:parser-print-book parser book)))
  54
  55 (define-public (print-score parser score)
  56   (let* ((head  (ly:parser-lookup parser '$globalheader))
  57          (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
  58                              head score)))
  59     (ly:parser-print-score parser book)))
  60
  61 (define-public (collect-scores-for-book  parser score)
  62   (let*
  63       ((oldval (ly:parser-lookup parser 'toplevel-scores)))
  64     (ly:parser-define parser 'toplevel-scores (cons score oldval))
  65     ))
  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
 117 (define (map-alist-keys func list)
 118   "map FUNC over the keys of an alist LIST, leaving the vals. "
 119   (if (null?  list)
 120       '()
 121       (cons (cons (func (caar list)) (cdar list))
 122             (map-alist-keys func (cdr list)))
 123       ))
 124
 125 ;;;;;;;;;;;;;;;;
 126 ;; hash
 127
 128
 129
 130 (if (not (defined? 'hash-table?))       ; guile 1.6 compat
 131     (begin
 132       (define hash-table? vector?)
 133
 134       (define-public (hash-table->alist t)
 135         "Convert table t to list"
 136         (apply append
 137                (vector->list t)
 138                )))
 139
 140     ;; native hashtabs.
 141     (begin
 142       (define-public (hash-table->alist t)
 143
 144         (hash-fold (lambda (k v acc) (acons  k v  acc))
 145                    '() t)
 146         )
 147       ))
 148
 149 ;; todo: code dup with C++.
 150 (define-public (alist->hash-table l)
 151   "Convert alist to table"
 152   (let
 153       ((m (make-hash-table (length l))))
 154
 155     (map (lambda (k-v)
 156            (hashq-set! m (car k-v) (cdr k-v)))
 157          l)
 158
 159     m))
 160
 161
 162
 163
 164 ;;;;;;;;;;;;;;;;
 165 ; list
 166
 167 (define (flatten-list lst)
 168   "Unnest LST"
 169   (if (null? lst)
 170       '()
 171       (if (pair? (car lst))
 172           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
 173           (cons (car lst) (flatten-list (cdr lst))))
 174   ))
 175
 176 (define (list-minus a b)
 177   "Return list of elements in A that are not in B."
 178   (lset-difference eq? a b))
 179
 180
 181 ;; TODO: use the srfi-1 partition function.
 182 (define-public (uniq-list l)
 183
 184   "Uniq LIST, assuming that it is sorted"
 185   (define (helper acc l)
 186     (if (null? l)
 187         acc
 188         (if (null? (cdr l))
 189             (cons (car l) acc)
 190             (if (equal? (car l) (cadr l))
 191                 (helper acc (cdr l))
 192                 (helper (cons (car l) acc)  (cdr l)))
 193             )))
 194   (reverse! (helper '() l) '()))
 195
 196
 197 (define (split-at-predicate predicate l)
 198  "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
 199 into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
 200 Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
 201 L1 is copied, L2 not.
 202
 203 (split-at-predicate (lambda (x y) (= (- y x) 2))  '(1 3 5 9 11) (cons '() '()))"
 204 ;; "
 205
 206 ;; KUT EMACS MODE.
 207
 208   (define (inner-split predicate l acc)
 209   (cond
 210    ((null? l) acc)
 211    ((null? (cdr l))
 212     (set-car! acc (cons (car l) (car acc)))
 213     acc)
 214    ((predicate (car l) (cadr l))
 215     (set-car! acc (cons (car l) (car acc)))
 216     (inner-split predicate (cdr l) acc))
 217    (else
 218     (set-car! acc (cons (car l) (car acc)))
 219     (set-cdr! acc (cdr l))
 220     acc)
 221
 222   ))
 223  (let*
 224     ((c (cons '() '()))
 225      )
 226   (inner-split predicate l  c)
 227   (set-car! c (reverse! (car c)))
 228   c)
 229 )
 230
 231
 232 (define-public (split-list l sep?)
 233 "
 234 (display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
 235 =>
 236 ((a b c) (d e f) (g))
 237
 238 "
 239 ;; " KUT EMACS.
 240
 241 (define (split-one sep?  l acc)
 242   "Split off the first parts before separator and return both parts."
 243   (if (null? l)
 244       (cons acc '())
 245       (if (sep? (car l))
 246           (cons acc (cdr l))
 247           (split-one sep? (cdr l) (cons (car l) acc))
 248           )
 249       ))
 250
 251 (if (null? l)
 252     '()
 253     (let* ((c (split-one sep? l '())))
 254       (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
 255       )))
 256
 257
 258 (define-public (offset-add a b)
 259   (cons (+ (car a) (car b))
 260         (+ (cdr a) (cdr b))))
 261
 262 (define-public (interval-length x)
 263   "Length of the number-pair X, when an interval"
 264   (max 0 (- (cdr x) (car x)))
 265   )
 266 (define-public interval-start car)
 267 (define-public interval-end cdr)
 268
 269 (define (other-axis a)
 270   (remainder (+ a 1) 2))
 271
 272
 273 (define-public (interval-widen iv amount)
 274    (cons (- (car iv) amount)
 275          (+ (cdr iv) amount)))
 276
 277 (define-public (interval-union i1 i2)
 278    (cons (min (car i1) (car i2))
 279          (max (cdr i1) (cdr i2))))
 280
 281
 282 (define-public (write-me message x)
 283   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 284 possibly turned off."
 285   (display message) (write x) (newline) x)
 286 ;;  x)
 287
 288 (define (index-cell cell dir)
 289   (if (equal? dir 1)
 290       (cdr cell)
 291       (car cell)))
 292
 293 (define (cons-map f x)
 294   "map F to contents of X"
 295   (cons (f (car x)) (f (cdr x))))
 296
 297
 298 (define-public (list-insert-separator lst between)
 299   "Create new list, inserting BETWEEN between elements of LIST"
 300   (define (conc x y )
 301     (if (eq? y #f)
 302         (list x)
 303         (cons x  (cons between y))
 304         ))
 305   (fold-right conc #f lst))
 306
 307 ;;;;;;;;;;;;;;;;
 308 ; other
 309 (define (sign x)
 310   (if (= x 0)
 311       0
 312       (if (< x 0) -1 1)))
 313
 314 (define-public (symbol<? l r)
 315   (string<? (symbol->string l) (symbol->string r)))
 316
 317 (define-public (!= l r)
 318   (not (= l r)))
 319
 320
 321 (define-public scale-to-unit
 322   (cond
 323    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 324    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 325    (else (error "unknown unit" (ly:unit)))))
 326
 327 ;;; font
 328 (define-public (font-family font)
 329   (let ((name (ly:font-name font)))
 330     (if name
 331         (regexp-substitute/global #f "^GNU-(.*)-[.0-9]*$" name 'pre 1 'post)
 332         (begin
 333           ;;(stderr "font-name: ~S\n" (ly:font-name font))
 334           ;;(stderr "font-file-name: ~S\n" (ly:font-file-name font))
 335           (ly:font-file-name font)))))
 336
 337 (define-public (char->unicode-index font char)
 338   (+ (case (ly:font-encoding font)
 339        ((fetaMusic) (- #xe000 #x20))
 340        ((fetaBraces) (- #xe000 #x40))
 341        (else 0))
 342      (char->integer char)))