scm/lily-library.scm

   1
   2
   3 (define-public X 0)
   4 (define-public Y 1)
   5 (define-public START -1)
   6 (define-public STOP 1)
   7 (define-public LEFT -1)
   8 (define-public RIGHT 1)
   9 (define-public UP 1)
  10 (define-public DOWN -1)
  11 (define-public CENTER 0)
  12
  13 (define-public DOUBLE-FLAT -4)
  14 (define-public THREE-Q-FLAT -3)
  15 (define-public FLAT -2)
  16 (define-public SEMI-FLAT -1)
  17 (define-public NATURAL 0)
  18 (define-public SEMI-SHARP 1)
  19 (define-public SHARP 2)
  20 (define-public THREE-Q-SHARP 3)
  21 (define-public DOUBLE-SHARP 4)
  22 (define-public SEMI-TONE 2)
  23
  24 (define-public ZERO-MOMENT (ly:make-moment 0 1))
  25
  26 (define-public (moment-min a b)
  27   (if (ly:moment<? a b) a b))
  28
  29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30 ;; lily specific variables.
  31
  32 (define-public default-script-alist '())
  33
  34
  35 ;; parser stuff.
  36 (define-public (print-music-as-book parser music)
  37   (let* ((head  (ly:parser-lookup parser '$globalheader))
  38          (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
  39                              head score)))
  40     (ly:parser-print-book parser book)))
  41
  42 (define-public (print-score-as-book parser score)
  43   (let*
  44       ((head  (ly:parser-lookup parser '$globalheader))
  45        (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
  46                            head score)))
  47     (ly:parser-print-book parser book)))
  48
  49 (define-public (print-score parser score)
  50   (let* ((head  (ly:parser-lookup parser '$globalheader))
  51          (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
  52                              head score)))
  53     (ly:parser-print-score parser book)))
  54
  55 (define-public (collect-scores-for-book  parser score)
  56   (let*
  57       ((oldval (ly:parser-lookup parser 'toplevel-scores)))
  58     (ly:parser-define parser 'toplevel-scores (cons score oldval))
  59     ))
  60
  61 (define-public (collect-music-for-book parser music)
  62   (collect-scores-for-book parser (ly:music-scorify music parser)))
  63
  64
  65
  66 ;;;;;;;;;;;;;;;;
  67 ; alist
  68 (define-public assoc-get ly:assoc-get)
  69
  70 (define-public (uniqued-alist alist acc)
  71   (if (null? alist) acc
  72       (if (assoc (caar alist) acc)
  73           (uniqued-alist (cdr alist) acc)
  74           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
  75
  76 (define-public (alist<? x y)
  77   (string<? (symbol->string (car x))
  78             (symbol->string (car y))))
  79
  80 (define-public (chain-assoc x alist-list)
  81   (if (null? alist-list)
  82       #f
  83       (let* ((handle (assoc x (car alist-list))))
  84         (if (pair? handle)
  85             handle
  86             (chain-assoc x (cdr alist-list))))))
  87
  88 (define-public (chain-assoc-get x alist-list . default)
  89   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
  90 found."
  91
  92   (define (helper x alist-list default)
  93     (if (null? alist-list)
  94         default
  95         (let* ((handle (assoc x (car alist-list))))
  96           (if (pair? handle)
  97               (cdr handle)
  98               (helper x (cdr alist-list) default)))))
  99
 100   (helper x alist-list
 101           (if (pair? default) (car default) #f)))
 102
 103 (define (map-alist-vals func list)
 104   "map FUNC over the vals of  LIST, leaving the keys."
 105   (if (null?  list)
 106       '()
 107       (cons (cons  (caar list) (func (cdar list)))
 108             (map-alist-vals func (cdr list)))
 109       ))
 110
 111 (define (map-alist-keys func list)
 112   "map FUNC over the keys of an alist LIST, leaving the vals. "
 113   (if (null?  list)
 114       '()
 115       (cons (cons (func (caar list)) (cdar list))
 116             (map-alist-keys func (cdr list)))
 117       ))
 118
 119 ;;;;;;;;;;;;;;;;
 120 ;; hash
 121
 122
 123
 124 (if (not (defined? 'hash-table?))       ; guile 1.6 compat
 125     (begin
 126       (define hash-table? vector?)
 127
 128       (define-public (hash-table->alist t)
 129         "Convert table t to list"
 130         (apply append
 131                (vector->list t)
 132                )))
 133
 134     ;; native hashtabs.
 135     (begin
 136       (define-public (hash-table->alist t)
 137
 138         (hash-fold (lambda (k v acc) (acons  k v  acc))
 139                    '() t)
 140         )
 141       ))
 142
 143 ;; todo: code dup with C++.
 144 (define-public (alist->hash-table l)
 145   "Convert alist to table"
 146   (let
 147       ((m (make-hash-table (length l))))
 148
 149     (map (lambda (k-v)
 150            (hashq-set! m (car k-v) (cdr k-v)))
 151          l)
 152
 153     m))
 154
 155
 156
 157
 158 ;;;;;;;;;;;;;;;;
 159 ; list
 160
 161 (define (flatten-list lst)
 162   "Unnest LST"
 163   (if (null? lst)
 164       '()
 165       (if (pair? (car lst))
 166           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
 167           (cons (car lst) (flatten-list (cdr lst))))
 168   ))
 169
 170 (define (list-minus a b)
 171   "Return list of elements in A that are not in B."
 172   (lset-difference eq? a b))
 173
 174
 175 ;; TODO: use the srfi-1 partition function.
 176 (define-public (uniq-list l)
 177
 178   "Uniq LIST, assuming that it is sorted"
 179   (define (helper acc l)
 180     (if (null? l)
 181         acc
 182         (if (null? (cdr l))
 183             (cons (car l) acc)
 184             (if (equal? (car l) (cadr l))
 185                 (helper acc (cdr l))
 186                 (helper (cons (car l) acc)  (cdr l)))
 187             )))
 188   (reverse! (helper '() l) '()))
 189
 190
 191 (define (split-at-predicate predicate l)
 192  "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
 193 into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
 194 Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
 195 L1 is copied, L2 not.
 196
 197 (split-at-predicate (lambda (x y) (= (- y x) 2))  '(1 3 5 9 11) (cons '() '()))"
 198 ;; "
 199
 200 ;; KUT EMACS MODE.
 201
 202   (define (inner-split predicate l acc)
 203   (cond
 204    ((null? l) acc)
 205    ((null? (cdr l))
 206     (set-car! acc (cons (car l) (car acc)))
 207     acc)
 208    ((predicate (car l) (cadr l))
 209     (set-car! acc (cons (car l) (car acc)))
 210     (inner-split predicate (cdr l) acc))
 211    (else
 212     (set-car! acc (cons (car l) (car acc)))
 213     (set-cdr! acc (cdr l))
 214     acc)
 215
 216   ))
 217  (let*
 218     ((c (cons '() '()))
 219      )
 220   (inner-split predicate l  c)
 221   (set-car! c (reverse! (car c)))
 222   c)
 223 )
 224
 225
 226 (define-public (split-list l sep?)
 227 "
 228 (display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
 229 =>
 230 ((a b c) (d e f) (g))
 231
 232 "
 233 ;; " KUT EMACS.
 234
 235 (define (split-one sep?  l acc)
 236   "Split off the first parts before separator and return both parts."
 237   (if (null? l)
 238       (cons acc '())
 239       (if (sep? (car l))
 240           (cons acc (cdr l))
 241           (split-one sep? (cdr l) (cons (car l) acc))
 242           )
 243       ))
 244
 245 (if (null? l)
 246     '()
 247     (let* ((c (split-one sep? l '())))
 248       (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
 249       )))
 250
 251
 252 (define-public (offset-add a b)
 253   (cons (+ (car a) (car b))
 254         (+ (cdr a) (cdr b))))
 255
 256 (define-public (interval-length x)
 257   "Length of the number-pair X, when an interval"
 258   (max 0 (- (cdr x) (car x)))
 259   )
 260 (define-public interval-start car)
 261 (define-public interval-end cdr)
 262
 263 (define (other-axis a)
 264   (remainder (+ a 1) 2))
 265
 266
 267 (define-public (interval-widen iv amount)
 268    (cons (- (car iv) amount)
 269          (+ (cdr iv) amount)))
 270
 271 (define-public (interval-union i1 i2)
 272    (cons (min (car i1) (car i2))
 273          (max (cdr i1) (cdr i2))))
 274
 275
 276 (define-public (write-me message x)
 277   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 278 possibly turned off."
 279   (display message) (write x) (newline) x)
 280 ;;  x)
 281
 282 (define (index-cell cell dir)
 283   (if (equal? dir 1)
 284       (cdr cell)
 285       (car cell)))
 286
 287 (define (cons-map f x)
 288   "map F to contents of X"
 289   (cons (f (car x)) (f (cdr x))))
 290
 291
 292 (define-public (list-insert-separator lst between)
 293   "Create new list, inserting BETWEEN between elements of LIST"
 294   (define (conc x y )
 295     (if (eq? y #f)
 296         (list x)
 297         (cons x  (cons between y))
 298         ))
 299   (fold-right conc #f lst))
 300
 301 ;;;;;;;;;;;;;;;;
 302 ; other
 303 (define (sign x)
 304   (if (= x 0)
 305       0
 306       (if (< x 0) -1 1)))
 307
 308 (define-public (symbol<? l r)
 309   (string<? (symbol->string l) (symbol->string r)))
 310
 311 (define-public (!= l r)
 312   (not (= l r)))
 313
 314