utilities.scm

   1 ;;; utilities
   2
   3 (define (list-set! l i x)
   4   (cond ((null? l) (error "list-set!: out of bounds"))
   5           ((= i 0)   (set-car! l x))
   6           (else      (list-set! (cdr l) (- i 1) x))))
   7
   8 (define (interval n m) ; returns the list (n n+1 n+2 ... m)
   9   (if (<= n m) (cons n (interval (+ n 1) m)) '()))
  10
  11 (define (iota n) (interval 0 (- n 1)))
  12
  13 (define (keep f lst) ;; TODO call filter ?
  14   (cond ((null? lst)   '())
  15         ((f (car lst)) (cons (car lst) (keep f (cdr lst))))
  16         (else          (keep f (cdr lst)))))
  17
  18 (define (identity x) x)
  19
  20
  21 ;; sets using hash tables
  22 (define (new-empty-set) (make-table hash: eq?-hash test: eq?))
  23 (define (new-set x)
  24   (let ((s (new-empty-set)))
  25     (table-set! s x #t)
  26     s))
  27 (define (set-member? s x) (table-ref s x #f))
  28 (define (set-length s) (table-length s))
  29 (define (set-equal? s1 s2) (equal? s1 s2))
  30 (define (set-diff s1 s2)
  31   (let ((s (table-copy s1)))
  32     (table-for-each (lambda (key val) (table-set! s key))
  33                     s2)
  34     s))
  35 (define (set-intersection s1 s2)
  36   (define (inters s1 s2)
  37     (let ((t (table-copy s1)))
  38       (table-for-each (lambda (k v) (if (not (table-ref s2 k #f))
  39                                         (table-set! t k)))
  40                       s1)
  41       t))
  42   (if (< (table-length s1) (table-length s2))
  43       (inters s1 s2)
  44       (inters s2 s1)))
  45 (define (set-union s1 s2)
  46   (if (> (table-length s1) (table-length s2))
  47       (table-merge s1 s2)
  48       (table-merge s2 s1)))
  49 (define (set-union! s1 s2) (table-merge! s1 s2)) ; side-effects s1
  50 (define (set-union-multi sets) (foldl set-union (new-empty-set) sets))
  51 (define (set-add s1 x)
  52   (let ((s2 (table-copy s1)))
  53     (table-set! s2 x #t)
  54     s2))
  55 (define (set-add! s x) (table-set! s x #t)) ; faster, but side-effecting
  56 (define (set-remove! s x) (table-set! s x))
  57 (define (set-empty? s) (= (table-length s) 0))
  58 (define (list->set l) (list->table (map (lambda (x) (cons x #t)) l)))
  59 (define (set->list s) (map car (table->list s)))
  60 (define (set-filter p s1)
  61   (let ((s2 (new-empty-set)))
  62     (table-for-each (lambda (key value)
  63                       (if value
  64                           (table-set! s2 key #t)))
  65                     s1)
  66     s2))
  67 (define (set-for-each f s) (table-for-each (lambda (x dummy) (f x)) s))
  68
  69 (define (foldl f base lst)
  70   (if (null? lst)
  71       base
  72       (foldl f (f base (car lst)) (cdr lst))))
  73
  74 (define (pos-in-list x lst)
  75   (let loop ((lst lst) (i 0))
  76     (cond ((not (pair? lst)) #f)
  77           ((eq? (car lst) x) i)
  78           (else              (loop (cdr lst) (+ i 1))))))
  79
  80 (define (remove x lst)
  81   (cond ((null? lst)       '())
  82         ((eq? x (car lst)) (cdr lst))
  83         (else              (cons (car lst)
  84                                  (remove x (cdr lst))))))
  85
  86 (define (replace x y lst)
  87   (cond ((null? lst)       '())
  88         ((eq? x (car lst)) (cons y (cdr lst)))
  89         (else              (cons (car lst)
  90                                  (replace x y (cdr lst))))))
  91
  92 (define (last lst)
  93   (cond ((null? lst)       #f)
  94         ((null? (cdr lst)) (car lst))
  95         (else              (last (cdr lst)))))
  96
  97 (define (all-but-last lst)
  98   (let loop ((lst lst)
  99              (new '()))
 100     (cond ((null? lst)       #f)
 101           ((null? (cdr lst)) (reverse new))
 102           (else              (loop (cdr lst)
 103                                    (cons (car lst) new))))))
 104
 105 (define (memp p l)
 106   (cond ((null? l)   #f)
 107         ((p (car l)) l)
 108         (else        (memp p (cdr l)))))
 109
 110 (define (intersperse x l)
 111   (cond ((or (null? l) (null? (cdr l))) l)
 112         (else (cons (car l) (cons x (intersperse x (cdr l)))))))
 113 (define (unique l)
 114   (if (null? l)
 115       l
 116       (let ((head (car l))
 117             (rest (unique (cdr l))))
 118         (if (member head rest)
 119             rest
 120             (cons head rest)))))
 121 (define (string-append-with-separator sep . strings)
 122   (apply string-append (intersperse sep (unique strings))))
 123
 124 (define (split-string s delimiter) ; delimiter is a char
 125   (let loop ((s   (string->list s))
 126              (acc '())
 127              (res '()))
 128     (cond ((null? s)
 129            (reverse (map (lambda (x) (list->string (reverse x)))
 130                          (if (null? acc) res (cons acc res)))))
 131           ((eq? (car s) delimiter)
 132            (loop (cdr s)
 133                  '()
 134                  (cons acc res)))
 135           (else
 136            (loop (cdr s)
 137                  (cons (car s) acc)
 138                  res)))))