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 (filter f lst)
  14   (cond ((null? lst)   '())
  15         ((f (car lst)) (cons (car lst) (filter f (cdr lst))))
  16         (else          (filter 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)
  51   (if (null? sets)
  52       (new-empty-set)
  53       (let loop ((l (cdr sets))
  54                  (s (set-copy (car sets))))
  55         (if (null? l)
  56             s
  57             (let ((s2 (car l)))
  58               (if (> (set-length s) (set-length s2))
  59                   (begin (set-union! s s2)
  60                          (loop (cdr l) s))
  61                   (let ((s2 (set-copy s2)))
  62                     (set-union! s2 s)
  63                     (loop (cdr l) s2))))))))
  64 (define (set-add s1 x)
  65   (let ((s2 (table-copy s1)))
  66     (table-set! s2 x #t)
  67     s2))
  68 (define (set-add! s x) (table-set! s x #t)) ; faster, but side-effecting
  69 (define (set-remove! s x) (table-set! s x))
  70 (define (set-empty? s) (= (table-length s) 0))
  71 (define (list->set l) (list->table (map (lambda (x) (cons x #t)) l)))
  72 (define (set->list s) (map car (table->list s)))
  73 (define (set-filter p s1)
  74   (let ((s2 (new-empty-set)))
  75     (table-for-each (lambda (key value)
  76                       (if value
  77                           (table-set! s2 key #t)))
  78                     s1)
  79     s2))
  80 (define (set-for-each f s) (table-for-each (lambda (x dummy) (f x)) s))
  81 (define (set-subset? s1 s2) ; is s2 a subset of s1 ?
  82   (if (> (set-length s2) (set-length s1))
  83       #f
  84       (let loop ((l (set->list s2)))
  85         (cond ((null? l)
  86                #t)
  87               ((set-member? s1 (car l))
  88                (loop (cdr l)))
  89               (else
  90                #f)))))
  91 (define set-copy table-copy)
  92
  93 (define (foldl f base lst)
  94   (if (null? lst)
  95       base
  96       (foldl f (f base (car lst)) (cdr lst))))
  97
  98 (define (pos-in-list x lst)
  99   (let loop ((lst lst) (i 0))
 100     (cond ((not (pair? lst)) #f)
 101           ((eq? (car lst) x) i)
 102           (else              (loop (cdr lst) (+ i 1))))))
 103
 104 (define (remove x lst)
 105   (cond ((null? lst)       '())
 106         ((eq? x (car lst)) (cdr lst))
 107         (else              (cons (car lst)
 108                                  (remove x (cdr lst))))))
 109
 110 (define (replace x y lst)
 111   (cond ((null? lst)       '())
 112         ((eq? x (car lst)) (cons y (cdr lst)))
 113         (else              (cons (car lst)
 114                                  (replace x y (cdr lst))))))
 115
 116 (define (last lst)
 117   (cond ((null? lst)       #f)
 118         ((null? (cdr lst)) (car lst))
 119         (else              (last (cdr lst)))))
 120
 121 (define (all-but-last lst)
 122   (let loop ((lst lst)
 123              (new '()))
 124     (cond ((null? lst)       #f)
 125           ((null? (cdr lst)) (reverse new))
 126           (else              (loop (cdr lst)
 127                                    (cons (car lst) new))))))
 128
 129 (define (memp p l)
 130   (cond ((null? l)   #f)
 131         ((p (car l)) l)
 132         (else        (memp p (cdr l)))))
 133
 134 (define (intersperse x l)
 135   (cond ((or (null? l) (null? (cdr l))) l)
 136         (else (cons (car l) (cons x (intersperse x (cdr l)))))))
 137 (define (unique l)
 138   (if (null? l)
 139       l
 140       (let ((head (car l))
 141             (rest (unique (cdr l))))
 142         (if (member head rest)
 143             rest
 144             (cons head rest)))))
 145 (define (string-append-with-separator sep . strings)
 146   (apply string-append (intersperse sep (unique strings))))
 147
 148 (define (split-string s delimiter) ; delimiter is a char
 149   (let loop ((s   (string->list s))
 150              (acc '())
 151              (res '()))
 152     (cond ((null? s)
 153            (reverse (map (lambda (x) (list->string (reverse x)))
 154                          (if (null? acc) res (cons acc res)))))
 155           ((eq? (car s) delimiter)
 156            (loop (cdr s)
 157                  '()
 158                  (cons acc res)))
 159           (else
 160            (loop (cdr s)
 161                  (cons (car s) acc)
 162                  res)))))
 163
 164
 165 (declare
 166   (standard-bindings)
 167   (block)
 168   (fixnum)
 169 ;;   (not safe)
 170 )
 171
 172 (define (make-bitset n)
 173    (let ((len (fxarithmetic-shift-right (+ n 7) 3)))
 174      (make-u8vector len)))
 175
 176 (define (bitset-add! bs i)
 177    (let* ((j (fxarithmetic-shift-right i 3))
 178           (k (fxand i 7)))
 179      (u8vector-set! bs
 180                     j
 181                     (fxior (u8vector-ref bs j)
 182                            (fxarithmetic-shift-left 1 k)))))
 183 (define (bitset-remove! bs i)
 184   (let* ((j (fxarithmetic-shift-right i 3))
 185          (k (fxand i 7)))
 186     (u8vector-set! bs
 187                    j
 188                    (fxand (u8vector-ref bs j)
 189                           (fxnot (fxarithmetic-shift-left 1 k))))))
 190
 191 (define (bitset-member? bs i)
 192    (let* ((j (fxarithmetic-shift-right i 3))
 193           (k (fxand i 7)))
 194      (not (fx= 0 (fxand (u8vector-ref bs j)
 195                         (fxarithmetic-shift-left 1 k))))))
 196
 197 (define (bitset-intersection b1 b2)
 198   (let* ((l  (u8vector-length b1)) ; both should have the same length
 199          (b3 (make-u8vector l 0))) ;; TODO abstract with diff and union!
 200     (let loop ((l (- l 1)))
 201       (if (>= l 0)
 202           (begin (u8vector-set! b3 l (fxand (u8vector-ref b1 l)
 203                                             (u8vector-ref b2 l)))
 204                  (loop (- l 1)))
 205           b3))))
 206
 207 (define (bitset-diff b1 b2)
 208   (let* ((l  (u8vector-length b1)) ; both should have the same length
 209          (b3 (make-u8vector l 0)))
 210     (let loop ((l (- l 1)))
 211       (if (>= l 0)
 212           (begin (u8vector-set! b3 l (fxand (u8vector-ref b1 l)
 213                                             (fxnot (u8vector-ref b2 l))))
 214                  (loop (- l 1)))
 215           b3))))
 216
 217 (define (bitset-union! b1 b2)
 218   (let* ((l (u8vector-length b1))) ; both should have the same length
 219     (let loop ((l (- l 1)))
 220       (if (>= l 0)
 221           (begin (u8vector-set! b1 l (fxior (u8vector-ref b1 l)
 222                                             (u8vector-ref b2 l)))
 223                  (loop (- l 1)))
 224           b1))))
 225
 226 (define (bitset-empty? bs)
 227   (let loop ((l (- (u8vector-length bs) 1)))
 228     (cond ((< l 0)
 229            #t)
 230           ((= (u8vector-ref bs l) 0)
 231            (loop (- l 1)))
 232           (else #f))))
 233
 234 (define (bitset-length bs)
 235   (let loop ((l (- (u8vector-length bs) 1))
 236              (n 0))
 237     (if (< l 0)
 238         n
 239         (loop
 240          (- l 1)
 241          (+ n
 242             (let ((b (u8vector-ref bs l)))
 243               (let loop2 ((i 0) (n 0)) ;; TODO is there a better way ?
 244                 (if (> i 7)
 245                     n
 246                     (loop2 (+ i 1)
 247                            (+ n
 248                               (if (= (fxand (fxarithmetic-shift-left 1 i) b) 0)
 249                                   0
 250                                   1)))))))))))
 251
 252 (define (list->bitset n lst)
 253    (let ((bs (make-bitset n)))
 254      (let loop ((lst lst))
 255        (if (pair? lst)
 256            (let ((i (car lst)))
 257              (bitset-add! bs i)
 258              (loop (cdr lst)))
 259            bs))))
 260
 261 (define (bitset->list bs)
 262    (let ((n (fxarithmetic-shift-left (u8vector-length bs) 3)))
 263      (let loop ((i (- n 1)) (lst '()))
 264        (if (>= i 0)
 265            (loop (- i 1)
 266                  (if (bitset-member? bs i)
 267                      (cons i lst)
 268                      lst))
 269            lst))))
 270
 271 (define bitset-copy u8vector-copy)
 272
 273 (define (bitset-union-multi n bitsets) ; n is necessary is bitsets is null
 274   (let ((bs (make-bitset n)))
 275     (let loop ((l bitsets))
 276       (if (null? l)
 277           bs
 278           (begin (bitset-union! bs (car l))
 279                  (loop (cdr l)))))))
 280
 281 (define (bitset-subset? b1 b2) ; is b2 a subset of b1 ?
 282   (equal? (bitset-intersection b1 b2) b2))