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 (define (identity x) x)
  12
  13
  14 ;; sets using hash tables
  15 (define (new-empty-set) (make-table hash: eq?-hash test: eq?))
  16 (define (new-set x)
  17   (let ((s (new-empty-set)))
  18     (table-set! s x #t)
  19     s))
  20 (define (set-member? s x) (table-ref s x #f))
  21 (define (set-length s) (table-length s))
  22 (define (set-equal? s1 s2) (equal? s1 s2))
  23 (define (set-diff s1 s2)
  24   (let ((s (table-copy s1)))
  25     (table-for-each (lambda (key val) (table-set! s key))
  26                     s2)
  27     s))
  28 (define (set-intersection s1 s2)
  29   (define (inters s1 s2)
  30     (let ((t (table-copy s1)))
  31       (table-for-each (lambda (k v) (if (not (table-ref s2 k #f))
  32                                         (table-set! t k)))
  33                       s1)
  34       t))
  35   (if (< (table-length s1) (table-length s2))
  36       (inters s1 s2)
  37       (inters s2 s1)))
  38 (define (set-union s1 s2)
  39   (if (> (table-length s1) (table-length s2))
  40       (table-merge s1 s2)
  41       (table-merge s2 s1)))
  42 (define (set-union! s1 s2) (table-merge! s1 s2)) ; side-effects s1
  43 (define (set-union-multi sets) (foldl set-union (new-empty-set) sets))
  44 (define (set-add s1 x)
  45   (let ((s2 (table-copy s1)))
  46     (table-set! s2 x #t)
  47     s2))
  48 (define (set-add! s x) (table-set! s x #t)) ; faster, but side-effecting
  49 (define (set-remove! s x) (table-set! s x))
  50 (define (set-empty? s) (= (table-length s) 0))
  51 (define (list->set l) (list->table (map (lambda (x) (cons x #t)) l)))
  52 (define (set->list s) (map car (table->list s)))
  53 (define (set-filter p s1)
  54   (let ((s2 (new-empty-set)))
  55     (table-for-each (lambda (key value)
  56                       (if value
  57                           (table-set! s2 key #t)))
  58                     s1)
  59     s2))
  60 (define (set-for-each f s) (table-for-each (lambda (x dummy) (f x)) s))
  61
  62 (define (foldl f base lst)
  63   (if (null? lst)
  64       base
  65       (foldl f (f base (car lst)) (cdr lst))))
  66
  67 (define (pos-in-list x lst)
  68   (let loop ((lst lst) (i 0))
  69     (cond ((not (pair? lst)) #f)
  70           ((eq? (car lst) x) i)
  71           (else              (loop (cdr lst) (+ i 1))))))
  72
  73 (define (remove x lst)
  74   (cond ((null? lst)       '())
  75         ((eq? x (car lst)) (cdr lst))
  76         (else              (cons (car lst)
  77                                  (remove x (cdr lst))))))
  78
  79 (define (replace x y lst)
  80   (cond ((null? lst)       '())
  81         ((eq? x (car lst)) (cons y (cdr lst)))
  82         (else              (cons (car lst)
  83                                  (replace x y (cdr lst))))))
  84
  85 (define (last lst)
  86   (cond ((null? lst)       #f)
  87         ((null? (cdr lst)) (car lst))
  88         (else              (last (cdr lst)))))
  89
  90 (define (all-but-last lst)
  91   (let loop ((lst lst)
  92              (new '()))
  93     (cond ((null? lst)       #f)
  94           ((null? (cdr lst)) (reverse new))
  95           (else              (loop (cdr lst)
  96                                    (cons (car lst) new))))))
  97
  98 (define (memp p l)
  99   (cond ((null? l)   #f)
 100         ((p (car l)) l)
 101         (else        (memp p (cdr l)))))