utilities.scm

   1 ;;; utilities
   2
   3 (define (interval n m) ; returns the list (n n+1 n+2 ... m)
   4   (if (<= n m) (cons n (interval (+ n 1) m)) '()))
   5
   6 (define (keep f lst)
   7   (cond ((null? lst)   '())
   8         ((f (car lst)) (cons (car lst) (keep f (cdr lst))))
   9         (else          (keep f (cdr lst)))))
  10
  11 ;; sets using bit vectors ;; TODO put both kinds of sets on the dumping grounds
  12 ;; TODO now with bignums
  13 (define (new-empty-bit-vector) 0)
  14 (define (new-bit-vector x) (arithmetic-shift 1 x))
  15 (define (bit-vector-member? s x)
  16   (not (= (bit-vector-intersection s (new-bit-vector x)) 0)))
  17 (define (bit-vector-length s) TODO) ;; TODO will that be needed ? doubt so, is for register allocation proper, but ordinary sets are likely ok for that (but we'd have to convert between the two if we don't switch register allocation to bit vectors)
  18 (define bit-vector-equal? =)
  19 (define (bit-vector-diff s1 s2) (bitwise-and a1 (bitwise-not s2)))
  20 (define (bit-vector-intersection s1 s2) (bitwise-and s1 s2))
  21 (define (bit-vector-union s1 s2) (bitwise-ior s1 s2))
  22 (define (bit-vector-union-multi bit-vectors)
  23   (foldl bit-vector-union (new-empty-bit-vector) bit-vectors))
  24 (define (bit-vector-empty? s) (= 0 s))
  25 (define (list->bit-vector l) TODO)
  26 (define (bit-vector->list s) TODO)
  27 (define (bit-vector-filter p s1) TODO)
  28 (define (bit-vector-for-each f s) TODO)
  29
  30 ;; sets using hash tables
  31 (define (new-empty-set) (make-table hash: eq?-hash test: eq?))
  32 (define (new-set x)
  33   (let ((s (new-empty-set)))
  34     (table-set! s x #t)
  35     s))
  36 (define (set-member? s x) (table-ref s x #f))
  37 (define (set-length s) (table-length s))
  38 (define (set-equal? s1 s2) (equal? s1 s2))
  39 (define (set-diff s1 s2)
  40   (let ((s (table-copy s1)))
  41     (table-for-each (lambda (key val) (table-set! s key))
  42                     s2)
  43     s))
  44 (define (set-intersection s1 s2)
  45   (define (inters s1 s2)
  46     (let ((t (table-copy s1)))
  47       (table-for-each (lambda (k v) (if (not (table-ref s2 k #f))
  48                                         (table-set! t k)))
  49                       s1)
  50       t))
  51   (if (< (table-length s1) (table-length s2))
  52       (inters s1 s2)
  53       (inters s2 s1)))
  54 (define (set-union s1 s2)
  55   (if (> (table-length s1) (table-length s2))
  56       (table-merge s1 s2)
  57       (table-merge s2 s1)))
  58 (define (set-union! s1 s2) (table-merge! s1 s2)) ; side-effects s1
  59 (define (set-union-multi sets) (foldl set-union (new-empty-set) sets))
  60 (define (set-add s1 x)
  61   (let ((s2 (table-copy s1)))
  62     (table-set! s2 x #t)
  63     s2))
  64 (define (set-add! s x) (table-set! s x #t)) ; faster, but side-effecting
  65 (define (set-remove! s x) (table-set! s x))
  66 (define (set-empty? s) (= (table-length s) 0))
  67 (define (list->set l) (list->table (map (lambda (x) (cons x #t)) l)))
  68 (define (set->list s) (map car (table->list s)))
  69 (define (set-filter p s1)
  70   (let ((s2 (new-empty-set)))
  71     (table-for-each (lambda (key value)
  72                       (if value
  73                           (table-set! s2 key #t)))
  74                     s1)
  75     s2))
  76 (define (set-for-each f s) (table-for-each (lambda (x dummy) (f x)) s))
  77
  78 (define (foldl f base lst)
  79   (if (null? lst)
  80       base
  81       (foldl f (f base (car lst)) (cdr lst))))
  82
  83 (define (pos-in-list x lst)
  84   (let loop ((lst lst) (i 0))
  85     (cond ((not (pair? lst)) #f)
  86           ((eq? (car lst) x) i)
  87           (else              (loop (cdr lst) (+ i 1))))))
  88
  89 (define (remove x lst)
  90   (cond ((null? lst)       '())
  91         ((eq? x (car lst)) (cdr lst))
  92         (else              (cons (car lst)
  93                                  (remove x (cdr lst))))))
  94
  95 (define (replace x y lst)
  96   (cond ((null? lst)       '())
  97         ((eq? x (car lst)) (cons y (cdr lst)))
  98         (else              (cons (car lst)
  99                                  (replace x y (cdr lst))))))
 100
 101 (define (last lst)
 102   (cond ((null? lst)       #f)
 103         ((null? (cdr lst)) (car lst))
 104         (else              (last (cdr lst)))))
 105
 106 (define (all-but-last lst)
 107   (let loop ((lst lst)
 108              (new '()))
 109     (cond ((null? lst)       #f)
 110           ((null? (cdr lst)) (reverse new))
 111           (else              (loop (cdr lst)
 112                                    (cons (car lst) new))))))
 113
 114 (define (memp p l)
 115   (cond ((null? l)   #f)
 116         ((p (car l)) l)
 117         (else        (memp p (cdr l)))))