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