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