mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
tabs in srfi 146
This commit is contained in:
Alex Shinn
parent
d593a5cb0a
commit
648f615b77
11 changed files with 1259 additions and 1259 deletions
|
|
@ -38,61 +38,61 @@
|
|||
(define (sort-alist alist)
|
||||
(list-sort (lambda (a1 a2) (string<? (car a1) (car a2))) alist))
|
||||
(let ((contents (make-string-hash-table))
|
||||
(deleted-keys (make-string-set))
|
||||
(deletion-odds 5)
|
||||
(max-key-length 5)
|
||||
(operations 100))
|
||||
(deleted-keys (make-string-set))
|
||||
(deletion-odds 5)
|
||||
(max-key-length 5)
|
||||
(operations 100))
|
||||
(define (random-key)
|
||||
(let ((size (+ (random-integer max-key-length) 1)))
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i size))
|
||||
(write-char (integer->char (+ 97 (random-integer 26)))))))))
|
||||
(let ((size (+ (random-integer max-key-length) 1)))
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i size))
|
||||
(write-char (integer->char (+ 97 (random-integer 26)))))))))
|
||||
(define (fill-phm i phm)
|
||||
(let ((size (hash-table-size contents)))
|
||||
(cond ((zero? i) phm)
|
||||
((and (not (zero? size))
|
||||
(zero? (random-integer deletion-odds)))
|
||||
(let ((key (list-ref (hash-table-keys contents)
|
||||
(random-integer size))))
|
||||
(set-adjoin! deleted-keys key)
|
||||
(hash-table-delete! contents key)
|
||||
(fill-phm (- i 1)
|
||||
(remove phm key))))
|
||||
(else (let* ((key (random-key))
|
||||
(datum (random-integer 1000)))
|
||||
(set-delete! deleted-keys key)
|
||||
(hash-table-set! contents key datum)
|
||||
(fill-phm (- i 1)
|
||||
(put phm key datum)))))))
|
||||
(let ((size (hash-table-size contents)))
|
||||
(cond ((zero? i) phm)
|
||||
((and (not (zero? size))
|
||||
(zero? (random-integer deletion-odds)))
|
||||
(let ((key (list-ref (hash-table-keys contents)
|
||||
(random-integer size))))
|
||||
(set-adjoin! deleted-keys key)
|
||||
(hash-table-delete! contents key)
|
||||
(fill-phm (- i 1)
|
||||
(remove phm key))))
|
||||
(else (let* ((key (random-key))
|
||||
(datum (random-integer 1000)))
|
||||
(set-delete! deleted-keys key)
|
||||
(hash-table-set! contents key datum)
|
||||
(fill-phm (- i 1)
|
||||
(put phm key datum)))))))
|
||||
(let ((phm (fill-phm operations
|
||||
(transform (make-phm string-hash string=?)))))
|
||||
(test-assert (= (phm/count phm) (hash-table-size contents)))
|
||||
(hash-table-for-each (lambda (key datum)
|
||||
(test-assert (= datum (phm/get phm key -1)))
|
||||
(test-assert (phm/contains? phm key)))
|
||||
contents)
|
||||
(set-for-each (lambda (key)
|
||||
(test-assert (= -1 (phm/get phm key -1)))
|
||||
(test-assert (not (phm/contains? phm key))))
|
||||
deleted-keys)
|
||||
(let ((ht-alist (hash-table->alist contents))
|
||||
(phm-alist (phm->alist phm)))
|
||||
(test-assert (equal? (sort-alist ht-alist)
|
||||
(sort-alist phm-alist)))))))
|
||||
(transform (make-phm string-hash string=?)))))
|
||||
(test-assert (= (phm/count phm) (hash-table-size contents)))
|
||||
(hash-table-for-each (lambda (key datum)
|
||||
(test-assert (= datum (phm/get phm key -1)))
|
||||
(test-assert (phm/contains? phm key)))
|
||||
contents)
|
||||
(set-for-each (lambda (key)
|
||||
(test-assert (= -1 (phm/get phm key -1)))
|
||||
(test-assert (not (phm/contains? phm key))))
|
||||
deleted-keys)
|
||||
(let ((ht-alist (hash-table->alist contents))
|
||||
(phm-alist (phm->alist phm)))
|
||||
(test-assert (equal? (sort-alist ht-alist)
|
||||
(sort-alist phm-alist)))))))
|
||||
|
||||
(define (phm-remove-non-existent-test remove transform)
|
||||
(define (terrible-hash string) 0)
|
||||
(let ((phm (remove (transform (make-phm string-hash string=?))
|
||||
"not-present")))
|
||||
"not-present")))
|
||||
(test-assert (zero? (phm/count phm)))
|
||||
(test-assert (not (phm/contains? phm "not-present")))
|
||||
(test-assert (not (phm/get phm "not-present" #f))))
|
||||
(let ((phm (remove (transform (phm/put (make-phm terrible-hash string=?)
|
||||
"foo"
|
||||
1))
|
||||
"not-present")))
|
||||
"foo"
|
||||
1))
|
||||
"not-present")))
|
||||
(test-assert (= 1 (phm/count phm)))
|
||||
(test-assert (phm/contains? phm "foo"))
|
||||
(test-assert (not (phm/contains? phm "not-present")))))
|
||||
|
|
@ -102,72 +102,72 @@
|
|||
(list-sort (lambda (a1 a2) (string<? (car a1) (car a2))) alist))
|
||||
(define (terrible-hash string)
|
||||
(cond ((string=? string "foo") 0)
|
||||
((string=? string "bar") 1)
|
||||
(else 2)))
|
||||
((string=? string "bar") 1)
|
||||
(else 2)))
|
||||
(let* ((alist '(("foo" . 1) ("bar" . 2) ("baz" . 3) ("bat" . 4)
|
||||
("quux" . 5)))
|
||||
(phm-1 (fold (lambda (a phm) (put phm (car a) (cdr a)))
|
||||
(transform (make-phm terrible-hash string=?))
|
||||
alist))
|
||||
(phm (put phm-1 "baz" 3)))
|
||||
("quux" . 5)))
|
||||
(phm-1 (fold (lambda (a phm) (put phm (car a) (cdr a)))
|
||||
(transform (make-phm terrible-hash string=?))
|
||||
alist))
|
||||
(phm (put phm-1 "baz" 3)))
|
||||
(assert-phm= phm alist)
|
||||
(let ((phm-alist (phm->alist phm)))
|
||||
(test-assert (equal? (sort-alist alist)
|
||||
(sort-alist phm-alist))))
|
||||
(test-assert (equal? (sort-alist alist)
|
||||
(sort-alist phm-alist))))
|
||||
(let ((alist-minus-baz (alist-delete "baz" alist string=?))
|
||||
(phm-minus-baz (remove (transform phm) "baz")))
|
||||
(assert-phm= phm-minus-baz alist-minus-baz)
|
||||
(let ((phm-minus-nonexistent (remove phm-minus-baz "not-present")))
|
||||
(test-equal = (phm/count phm-minus-nonexistent) (- (length alist) 1))
|
||||
(let ((alist-minus-bat (alist-delete "bat" alist-minus-baz string=?))
|
||||
(phm-minus-bat (remove phm-minus-nonexistent "bat")))
|
||||
(assert-phm= phm-minus-bat alist-minus-bat))))))
|
||||
(phm-minus-baz (remove (transform phm) "baz")))
|
||||
(assert-phm= phm-minus-baz alist-minus-baz)
|
||||
(let ((phm-minus-nonexistent (remove phm-minus-baz "not-present")))
|
||||
(test-equal = (phm/count phm-minus-nonexistent) (- (length alist) 1))
|
||||
(let ((alist-minus-bat (alist-delete "bat" alist-minus-baz string=?))
|
||||
(phm-minus-bat (remove phm-minus-nonexistent "bat")))
|
||||
(assert-phm= phm-minus-bat alist-minus-bat))))))
|
||||
|
||||
(define (persistent-hash-map replace transform)
|
||||
(define (sort-alist alist)
|
||||
(list-sort (lambda (a1 a2) (string<? (car a1) (car a2))) alist))
|
||||
(let* ((alist-1 '(("a" . 1) ("b" . 2) ("c" . 3)))
|
||||
(alist-2 '(("a" . 1) ("b" . 4) ("c" . 3)))
|
||||
(alist-3 '(("a" . 1) ("b" . 4)))
|
||||
(phm (replace (transform (make-phm string-hash string=? alist-1))
|
||||
"b"
|
||||
(lambda (x) 4))))
|
||||
(alist-2 '(("a" . 1) ("b" . 4) ("c" . 3)))
|
||||
(alist-3 '(("a" . 1) ("b" . 4)))
|
||||
(phm (replace (transform (make-phm string-hash string=? alist-1))
|
||||
"b"
|
||||
(lambda (x) 4))))
|
||||
(test-assert (equal? alist-2 (sort-alist (phm->alist phm))))
|
||||
(test-assert (equal? alist-3
|
||||
(sort-alist
|
||||
(phm->alist
|
||||
(replace phm "c" (lambda (x) hamt-null))))))))
|
||||
(sort-alist
|
||||
(phm->alist
|
||||
(replace phm "c" (lambda (x) hamt-null))))))))
|
||||
|
||||
(define (hamt-max-depth hamt)
|
||||
"Return maximum depth of `hamt'. For testing."
|
||||
(let descend ((n (hamt/root hamt)))
|
||||
(cond ((collision? n) 1)
|
||||
((narrow? n)
|
||||
(let* ((array (narrow/array n))
|
||||
(stride (leaf-stride (hamt/payload? hamt)))
|
||||
(start (* stride (bit-count (narrow/leaves n))))
|
||||
(end (vector-length array)))
|
||||
(do ((i start (+ i 1))
|
||||
(high 0 (max high (descend (vector-ref array i)))))
|
||||
((= i end) (+ high 1)))))
|
||||
((wide? n)
|
||||
(let ((array (wide/array n))
|
||||
(c (wide/children n)))
|
||||
(let next-child ((high 0)
|
||||
(i 0))
|
||||
(cond ((next-set-bit c i hamt-bucket-size)
|
||||
=> (lambda (j)
|
||||
(next-child (max high
|
||||
(descend (vector-ref array j)))
|
||||
(+ j 1))))
|
||||
(else (+ high 1))))))
|
||||
(else (error "Invalid type of node." n)))))
|
||||
((narrow? n)
|
||||
(let* ((array (narrow/array n))
|
||||
(stride (leaf-stride (hamt/payload? hamt)))
|
||||
(start (* stride (bit-count (narrow/leaves n))))
|
||||
(end (vector-length array)))
|
||||
(do ((i start (+ i 1))
|
||||
(high 0 (max high (descend (vector-ref array i)))))
|
||||
((= i end) (+ high 1)))))
|
||||
((wide? n)
|
||||
(let ((array (wide/array n))
|
||||
(c (wide/children n)))
|
||||
(let next-child ((high 0)
|
||||
(i 0))
|
||||
(cond ((next-set-bit c i hamt-bucket-size)
|
||||
=> (lambda (j)
|
||||
(next-child (max high
|
||||
(descend (vector-ref array j)))
|
||||
(+ j 1))))
|
||||
(else (+ high 1))))))
|
||||
(else (error "Invalid type of node." n)))))
|
||||
|
||||
(test-begin "hamt-map")
|
||||
|
||||
(test-group "(persistent-hash-map make-phm alist)"
|
||||
(let* ((alist '(("a" . 1) ("b" . 2)))
|
||||
(phm (make-phm string-hash string=? alist)))
|
||||
(phm (make-phm string-hash string=? alist)))
|
||||
(test-assert (not (hamt/mutable? phm)))
|
||||
(assert-phm= phm alist)))
|
||||
|
||||
|
|
@ -189,20 +189,20 @@
|
|||
(define (flip mutate? phm)
|
||||
((if mutate? phm/mutable phm/immutable) phm))
|
||||
(phm-random-test (let ((mutate? #t))
|
||||
(lambda (phm key datum)
|
||||
(set! mutate? (not mutate?))
|
||||
((if mutate? phm/put! phm/put)
|
||||
(flip mutate? phm)
|
||||
key
|
||||
datum)))
|
||||
(let ((count 0))
|
||||
(lambda (phm key)
|
||||
(set! count (remainder (+ count 1) 3))
|
||||
(let ((mutate? (zero? count)))
|
||||
((if mutate? phm/remove! phm/remove)
|
||||
(flip mutate? phm)
|
||||
key))))
|
||||
(lambda (m) m)))
|
||||
(lambda (phm key datum)
|
||||
(set! mutate? (not mutate?))
|
||||
((if mutate? phm/put! phm/put)
|
||||
(flip mutate? phm)
|
||||
key
|
||||
datum)))
|
||||
(let ((count 0))
|
||||
(lambda (phm key)
|
||||
(set! count (remainder (+ count 1) 3))
|
||||
(let ((mutate? (zero? count)))
|
||||
((if mutate? phm/remove! phm/remove)
|
||||
(flip mutate? phm)
|
||||
key))))
|
||||
(lambda (m) m)))
|
||||
|
||||
(test-group "(persistent-hash-map remove-non-existent pure)"
|
||||
(phm-remove-non-existent-test phm/remove (lambda (m) m)))
|
||||
|
|
@ -212,12 +212,12 @@
|
|||
|
||||
(test-group "(persistent-hash-map phm/add-alist)"
|
||||
(let* ((alist '(("foo" . 1) ("bar" . 2) ("baz" . 3)))
|
||||
(phm (phm/add-alist (make-phm string-hash string=?) alist)))
|
||||
(phm (phm/add-alist (make-phm string-hash string=?) alist)))
|
||||
(assert-phm= phm alist)))
|
||||
|
||||
(test-group "(persistent-hash-map phm/add-alist!)"
|
||||
(let* ((alist '(("foo" . 1) ("bar" . 2) ("baz" . 3)))
|
||||
(phm (phm/mutable (make-phm string-hash string=?))))
|
||||
(phm (phm/mutable (make-phm string-hash string=?))))
|
||||
(phm/add-alist! phm alist)
|
||||
(assert-phm= phm alist)))
|
||||
|
||||
|
|
@ -231,26 +231,26 @@
|
|||
"Test that hashes that differ only above `hamt-hash-size' still work."
|
||||
(define big-hash
|
||||
(let* ((big-1 (expt 2 hamt-hash-size))
|
||||
(big-2 (* 2 big-1)))
|
||||
(lambda (string)
|
||||
(cond ((string=? string "foo") big-1)
|
||||
(else big-2)))))
|
||||
(big-2 (* 2 big-1)))
|
||||
(lambda (string)
|
||||
(cond ((string=? string "foo") big-1)
|
||||
(else big-2)))))
|
||||
(let* ((alist '(("foo" . 1) ("bar" . 2) ("baz" . 3) ("bat" . 4)
|
||||
("quux" . 5)))
|
||||
(phm (phm/add-alist (make-phm big-hash string=?) alist)))
|
||||
("quux" . 5)))
|
||||
(phm (phm/add-alist (make-phm big-hash string=?) alist)))
|
||||
(assert-phm= phm alist)))
|
||||
|
||||
(test-group "(persistent-hash-map same-first-fragment)"
|
||||
(define (same-first-fragment string)
|
||||
(* hamt-bucket-size (string-hash string)))
|
||||
(let* ((alist '(("foo" . 1) ("bar" . 2) ("baz" . 3) ("bat" . 4)
|
||||
("quux" . 5)))
|
||||
(phm (phm/add-alist (make-phm same-first-fragment string=?) alist)))
|
||||
("quux" . 5)))
|
||||
(phm (phm/add-alist (make-phm same-first-fragment string=?) alist)))
|
||||
(assert-phm= phm alist)
|
||||
(let ((phm-minus-baz (phm/remove phm "baz")))
|
||||
(assert-phm= phm-minus-baz (alist-delete "baz" alist string=?)))
|
||||
(assert-phm= phm-minus-baz (alist-delete "baz" alist string=?)))
|
||||
(let ((phm-minus-nonexistent (phm/remove phm "not-present")))
|
||||
(test-assert (= (phm/count phm-minus-nonexistent) (length alist))))))
|
||||
(test-assert (= (phm/count phm-minus-nonexistent) (length alist))))))
|
||||
|
||||
(test-group "(persistent-hash-map pure-mutate-interference)"
|
||||
"Test that mutating and pure operations interact with each other
|
||||
|
|
@ -258,20 +258,20 @@ correctly."
|
|||
(define (alist-replace alist key datum)
|
||||
(cons (cons key datum) (alist-delete key alist string=?)))
|
||||
(let* ((m0 (make-phm string-hash string=?))
|
||||
(a1 '(("foo" . 1) ("bar" . 2) ("baz" . 3)))
|
||||
(m1 (phm/add-alist m0 a1))
|
||||
(a4 (alist-replace a1 "foo" 4))
|
||||
(m2 (phm/put m1 "foo" 4))
|
||||
(a5 (alist-replace a1 "foo" 5))
|
||||
(m3 (phm/mutable m2))
|
||||
(m4 (phm/put! m3 "foo" 5))
|
||||
(a6 (alist-replace a1 "foo" 6))
|
||||
(m5 (phm/immutable m4))
|
||||
(m6 (phm/mutable m5))
|
||||
(m7 (phm/put! m6 "foo" 6))
|
||||
(a7 (alist-replace a1 "foo" 7))
|
||||
(a8 (alist-replace a1 "foo" 8))
|
||||
(m8 (phm/put! m6 "foo" 7)))
|
||||
(a1 '(("foo" . 1) ("bar" . 2) ("baz" . 3)))
|
||||
(m1 (phm/add-alist m0 a1))
|
||||
(a4 (alist-replace a1 "foo" 4))
|
||||
(m2 (phm/put m1 "foo" 4))
|
||||
(a5 (alist-replace a1 "foo" 5))
|
||||
(m3 (phm/mutable m2))
|
||||
(m4 (phm/put! m3 "foo" 5))
|
||||
(a6 (alist-replace a1 "foo" 6))
|
||||
(m5 (phm/immutable m4))
|
||||
(m6 (phm/mutable m5))
|
||||
(m7 (phm/put! m6 "foo" 6))
|
||||
(a7 (alist-replace a1 "foo" 7))
|
||||
(a8 (alist-replace a1 "foo" 8))
|
||||
(m8 (phm/put! m6 "foo" 7)))
|
||||
(phm/put! m4 "foo" 8)
|
||||
(assert-phm= m0 '())
|
||||
(assert-phm= m1 a1)
|
||||
|
|
@ -283,31 +283,31 @@ correctly."
|
|||
(assert-phm= m7 a7)
|
||||
(assert-phm= m8 a7)
|
||||
(let ((a (alist-delete "foo" a1 string=?))
|
||||
(m9 (phm/remove! m4 "foo")))
|
||||
(assert-phm= m4 a)
|
||||
(assert-phm= m9 a))))
|
||||
(m9 (phm/remove! m4 "foo")))
|
||||
(assert-phm= m4 a)
|
||||
(assert-phm= m9 a))))
|
||||
|
||||
(test-group "(persistent-hash-map phm/data)"
|
||||
(let* ((alist '(("a" . 1) ("b" . 2) ("c" . 3)))
|
||||
(data (phm/data (make-phm string-hash string=? alist))))
|
||||
(data (phm/data (make-phm string-hash string=? alist))))
|
||||
(test-assert (equal? (map cdr alist)
|
||||
(list-sort < data)))))
|
||||
(list-sort < data)))))
|
||||
|
||||
(test-group "(persistent-hash-map phm/keys)"
|
||||
(let* ((alist '(("a" . 1) ("b" . 2) ("c" . 3)))
|
||||
(keys (phm/keys (make-phm string-hash string=? alist))))
|
||||
(keys (phm/keys (make-phm string-hash string=? alist))))
|
||||
(test-assert (equal? (map car alist)
|
||||
(list-sort string<? keys)))))
|
||||
(list-sort string<? keys)))))
|
||||
|
||||
(test-group "(persistent-hash-map phm/for-each)"
|
||||
(define (sort-alist alist)
|
||||
(list-sort (lambda (a1 a2) (string<? (car a1) (car a2))) alist))
|
||||
(let* ((alist '(("a" . 1) ("b" . 2) ("c" . 3)))
|
||||
(phm (make-phm string-hash string=? alist))
|
||||
(accumulator '()))
|
||||
(phm (make-phm string-hash string=? alist))
|
||||
(accumulator '()))
|
||||
(phm/for-each (lambda (k d) (set! accumulator
|
||||
(cons (cons k d) accumulator)))
|
||||
phm)
|
||||
(cons (cons k d) accumulator)))
|
||||
phm)
|
||||
(test-assert (equal? alist (sort-alist accumulator)))))
|
||||
|
||||
(test-group "(persistent-hash-map phm/replace)"
|
||||
|
|
@ -320,12 +320,12 @@ correctly."
|
|||
(define (sort-alist alist)
|
||||
(list-sort (lambda (a1 a2) (string<? (car a1) (car a2))) alist))
|
||||
(let* ((alist-1 '(("a" . 1) ("b" . 2) ("c" . 3)))
|
||||
(alist-2 '(("a" . 1) ("b" . 5) ("c" . 3)))
|
||||
(phm-1 (phm/mutable (make-phm string-hash string=? alist-1))))
|
||||
(alist-2 '(("a" . 1) ("b" . 5) ("c" . 3)))
|
||||
(phm-1 (phm/mutable (make-phm string-hash string=? alist-1))))
|
||||
(phm/put! phm-1 "b" 4)
|
||||
(let ((phm-2 (phm/immutable phm-1
|
||||
(lambda (k d) (if (string=? k "b") (+ d 1) d)))))
|
||||
(test-assert (equal? alist-2 (sort-alist (phm->alist phm-2)))))))
|
||||
(lambda (k d) (if (string=? k "b") (+ d 1) d)))))
|
||||
(test-assert (equal? alist-2 (sort-alist (phm->alist phm-2)))))))
|
||||
|
||||
(test-group "(persistent-hash-map phm/mutable?)"
|
||||
(let ((phm (make-phm string-hash string=?)))
|
||||
|
|
@ -336,26 +336,26 @@ correctly."
|
|||
(test-group "(persistent-hash-map modify-collision add-different-hash)"
|
||||
(define (terrible-hash string)
|
||||
(cond ((string=? string "foo") 0)
|
||||
((string=? string "bar") 0)
|
||||
(else hamt-bucket-size))) ; same as 0 in bottom 5 bits
|
||||
((string=? string "bar") 0)
|
||||
(else hamt-bucket-size))) ; same as 0 in bottom 5 bits
|
||||
(let* ((alist '(("foo" . 1) ("bar" . 2)))
|
||||
(phm-1 (make-phm terrible-hash string=? alist))
|
||||
(phm-2 (phm/put phm-1 "baz" 3)))
|
||||
(phm-1 (make-phm terrible-hash string=? alist))
|
||||
(phm-2 (phm/put phm-1 "baz" 3)))
|
||||
(assert-phm= phm-2 '(("foo" . 1) ("bar" . 2) ("baz" . 3)))))
|
||||
|
||||
(test-group "(persistent-hash-map lower-collision)"
|
||||
(define same-bottom-three-fragments (expt hamt-bucket-size 3))
|
||||
(define (terrible-hash string)
|
||||
(if (or (string=? string "foo")
|
||||
(string=? string "bar"))
|
||||
same-bottom-three-fragments
|
||||
(* 2 same-bottom-three-fragments)))
|
||||
(string=? string "bar"))
|
||||
same-bottom-three-fragments
|
||||
(* 2 same-bottom-three-fragments)))
|
||||
(let* ((alist '(("foo" . 1) ("bar" . 2)))
|
||||
(phm-1 (make-phm terrible-hash string=? alist))
|
||||
(phm-2 (phm/put phm-1 "baz" 3))
|
||||
(phm-3 (phm/remove phm-2 "foo"))
|
||||
(phm-4 (phm/remove phm-3 "bar"))
|
||||
(phm-5 (phm/remove phm-4 "baz")))
|
||||
(phm-1 (make-phm terrible-hash string=? alist))
|
||||
(phm-2 (phm/put phm-1 "baz" 3))
|
||||
(phm-3 (phm/remove phm-2 "foo"))
|
||||
(phm-4 (phm/remove phm-3 "bar"))
|
||||
(phm-5 (phm/remove phm-4 "baz")))
|
||||
(assert-phm= phm-2 '(("foo" . 1) ("bar" . 2) ("baz" . 3)))
|
||||
(assert-phm= phm-3 '(("bar" . 2) ("baz" . 3)))
|
||||
(assert-phm= phm-4 '(("baz" . 3)))
|
||||
|
|
|
|||
|
|
@ -142,10 +142,10 @@
|
|||
(define (make-phm-inner hash = alist)
|
||||
(let ((phm (make-hamt = hash #t)))
|
||||
(if (null? alist)
|
||||
phm
|
||||
(let ((phm-1 (phm/mutable phm)))
|
||||
(phm/add-alist! phm-1 alist)
|
||||
(phm/immutable phm-1)))))
|
||||
phm
|
||||
(let ((phm-1 (phm/mutable phm)))
|
||||
(phm/add-alist! phm-1 alist)
|
||||
(phm/immutable phm-1)))))
|
||||
|
||||
(define make-phm
|
||||
(case-lambda
|
||||
|
|
@ -197,8 +197,8 @@
|
|||
(assert (phm? phm))
|
||||
(let ((result (hamt-fetch phm key)))
|
||||
(if (hamt-null? result)
|
||||
default
|
||||
result)))
|
||||
default
|
||||
result)))
|
||||
|
||||
(define phm/get
|
||||
(case-lambda
|
||||
|
|
|
|||
|
|
@ -27,13 +27,13 @@
|
|||
|
||||
(test-group "(do-list)"
|
||||
(let ((index-accumulator '())
|
||||
(value-accumulator '())
|
||||
(all-values '(1 2 3 4 5)))
|
||||
(value-accumulator '())
|
||||
(all-values '(1 2 3 4 5)))
|
||||
(do-list (value all-values)
|
||||
(set! value-accumulator (cons value value-accumulator)))
|
||||
(set! value-accumulator (cons value value-accumulator)))
|
||||
(test all-values (reverse value-accumulator))
|
||||
(do-list (value index all-values)
|
||||
(set! index-accumulator (cons index index-accumulator)))
|
||||
(set! index-accumulator (cons index index-accumulator)))
|
||||
(test '(4 3 2 1 0) index-accumulator)))
|
||||
|
||||
(test-end))
|
||||
|
|
@ -27,8 +27,8 @@
|
|||
((_ (operator argument ...))
|
||||
(unless (operator argument ...)
|
||||
(error "Assertion failed:"
|
||||
'(operator argument ...)
|
||||
(list 'operator argument ...))))
|
||||
'(operator argument ...)
|
||||
(list 'operator argument ...))))
|
||||
((_ expression)
|
||||
(unless expression
|
||||
(error "Assertion failed:" 'expression)))))
|
||||
|
|
@ -37,15 +37,15 @@
|
|||
(syntax-rules ()
|
||||
((_ (variable list) body ...)
|
||||
(do ((remaining list (cdr remaining)))
|
||||
((null? remaining))
|
||||
((null? remaining))
|
||||
(let ((variable (car remaining)))
|
||||
body ...)))
|
||||
body ...)))
|
||||
((_ (element-variable index-variable list) body ...)
|
||||
(do ((remaining list (cdr remaining))
|
||||
(index-variable 0 (+ index-variable 1)))
|
||||
((null? remaining))
|
||||
(index-variable 0 (+ index-variable 1)))
|
||||
((null? remaining))
|
||||
(let ((element-variable (car remaining)))
|
||||
body ...)))))
|
||||
body ...)))))
|
||||
|
||||
(define string-comparator
|
||||
(make-comparator string? string=? #f string-hash))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -26,35 +26,35 @@
|
|||
(define (tree-search comparator tree obj failure success)
|
||||
(let ((entry (phm/get tree obj)))
|
||||
(if entry
|
||||
(success (car entry) (cdr entry)
|
||||
(lambda (new-key new-datum ret)
|
||||
(let ((tree (phm/remove tree obj)))
|
||||
(values (phm/put tree new-key (cons new-key new-datum))
|
||||
ret)))
|
||||
(lambda (ret)
|
||||
(values (phm/remove tree obj) ret)))
|
||||
(failure (lambda (new-key new-datum ret)
|
||||
(values (phm/put tree new-key (cons new-key new-datum))
|
||||
ret))
|
||||
(lambda (ret)
|
||||
(values tree ret))))))
|
||||
(success (car entry) (cdr entry)
|
||||
(lambda (new-key new-datum ret)
|
||||
(let ((tree (phm/remove tree obj)))
|
||||
(values (phm/put tree new-key (cons new-key new-datum))
|
||||
ret)))
|
||||
(lambda (ret)
|
||||
(values (phm/remove tree obj) ret)))
|
||||
(failure (lambda (new-key new-datum ret)
|
||||
(values (phm/put tree new-key (cons new-key new-datum))
|
||||
ret))
|
||||
(lambda (ret)
|
||||
(values tree ret))))))
|
||||
|
||||
(define (tree-fold proc seed tree)
|
||||
(phm/for-each (lambda (key entry)
|
||||
(set! seed (proc (car entry) (cdr entry) seed)))
|
||||
tree)
|
||||
(set! seed (proc (car entry) (cdr entry) seed)))
|
||||
tree)
|
||||
seed)
|
||||
|
||||
(define (tree-for-each proc tree)
|
||||
(phm/for-each (lambda (key entry)
|
||||
(proc (car entry) (cdr entry)))
|
||||
tree))
|
||||
(proc (car entry) (cdr entry)))
|
||||
tree))
|
||||
|
||||
(define (tree-generator tree)
|
||||
(make-coroutine-generator
|
||||
(lambda (yield)
|
||||
(tree-for-each (lambda item (yield item))
|
||||
tree))))
|
||||
tree))))
|
||||
|
||||
;;; New types
|
||||
|
||||
|
|
@ -67,8 +67,8 @@
|
|||
(define (make-empty-hashmap comparator)
|
||||
(assume (comparator? comparator))
|
||||
(%make-hashmap comparator
|
||||
(make-phm (comparator-hash-function comparator)
|
||||
(comparator-equality-predicate comparator))))
|
||||
(make-phm (comparator-hash-function comparator)
|
||||
(comparator-equality-predicate comparator))))
|
||||
|
||||
;;; Exported procedures
|
||||
|
||||
|
|
@ -77,12 +77,12 @@
|
|||
(define (hashmap comparator . args)
|
||||
(assume (comparator? comparator))
|
||||
(hashmap-unfold null?
|
||||
(lambda (args)
|
||||
(values (car args)
|
||||
(cadr args)))
|
||||
cddr
|
||||
args
|
||||
comparator))
|
||||
(lambda (args)
|
||||
(values (car args)
|
||||
(cadr args)))
|
||||
cddr
|
||||
args
|
||||
comparator))
|
||||
|
||||
(define (hashmap-unfold stop? mapper successor seed comparator)
|
||||
(assume (procedure? stop?))
|
||||
|
|
@ -90,13 +90,13 @@
|
|||
(assume (procedure? successor))
|
||||
(assume (comparator? comparator))
|
||||
(let loop ((hashmap (make-empty-hashmap comparator))
|
||||
(seed seed))
|
||||
(seed seed))
|
||||
(if (stop? seed)
|
||||
hashmap
|
||||
(receive (key value)
|
||||
(mapper seed)
|
||||
(loop (hashmap-adjoin hashmap key value)
|
||||
(successor seed))))))
|
||||
hashmap
|
||||
(receive (key value)
|
||||
(mapper seed)
|
||||
(loop (hashmap-adjoin hashmap key value)
|
||||
(successor seed))))))
|
||||
|
||||
;; Predicates
|
||||
|
||||
|
|
@ -109,11 +109,11 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(hashmap-search hashmap
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(return #f))
|
||||
(lambda (key value update remove)
|
||||
(return #t))))))
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(return #f))
|
||||
(lambda (key value update remove)
|
||||
(return #t))))))
|
||||
|
||||
(define (hashmap-disjoint? hashmap1 hashmap2)
|
||||
(assume (hashmap? hashmap1))
|
||||
|
|
@ -121,9 +121,9 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(hashmap-for-each (lambda (key value)
|
||||
(when (hashmap-contains? hashmap2 key)
|
||||
(return #f)))
|
||||
hashmap1)
|
||||
(when (hashmap-contains? hashmap2 key)
|
||||
(return #f)))
|
||||
hashmap1)
|
||||
#t)))
|
||||
|
||||
;; Accessors
|
||||
|
|
@ -133,24 +133,24 @@
|
|||
((hashmap key)
|
||||
(assume (hashmap? hashmap))
|
||||
(hashmap-ref hashmap key (lambda ()
|
||||
(error "hashmap-ref: key not in hashmap" key))))
|
||||
(error "hashmap-ref: key not in hashmap" key))))
|
||||
((hashmap key failure)
|
||||
(assume (hashmap? hashmap))
|
||||
(assume (procedure? failure))
|
||||
(hashmap-ref hashmap key failure (lambda (value)
|
||||
value)))
|
||||
value)))
|
||||
((hashmap key failure success)
|
||||
(assume (hashmap? hashmap))
|
||||
(assume (procedure? failure))
|
||||
(assume (procedure? success))
|
||||
((call/cc
|
||||
(lambda (return-thunk)
|
||||
(hashmap-search hashmap
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(return-thunk failure))
|
||||
(lambda (key value update remove)
|
||||
(return-thunk (lambda () (success value)))))))))))
|
||||
(hashmap-search hashmap
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(return-thunk failure))
|
||||
(lambda (key value update remove)
|
||||
(return-thunk (lambda () (success value)))))))))))
|
||||
|
||||
(define (hashmap-ref/default hashmap key default)
|
||||
(assume (hashmap? hashmap))
|
||||
|
|
@ -161,25 +161,25 @@
|
|||
(define (hashmap-adjoin hashmap . args)
|
||||
(assume (hashmap? hashmap))
|
||||
(let loop ((args args)
|
||||
(hashmap hashmap))
|
||||
(hashmap hashmap))
|
||||
(if (null? args)
|
||||
hashmap
|
||||
(receive (hashmap value)
|
||||
(hashmap-intern hashmap (car args) (lambda () (cadr args)))
|
||||
(loop (cddr args) hashmap)))))
|
||||
hashmap
|
||||
(receive (hashmap value)
|
||||
(hashmap-intern hashmap (car args) (lambda () (cadr args)))
|
||||
(loop (cddr args) hashmap)))))
|
||||
|
||||
(define hashmap-adjoin! hashmap-adjoin)
|
||||
|
||||
(define (hashmap-set hashmap . args)
|
||||
(assume (hashmap? hashmap))
|
||||
(let loop ((args args)
|
||||
(hashmap hashmap))
|
||||
(hashmap hashmap))
|
||||
(if (null? args)
|
||||
hashmap
|
||||
(receive (hashmap)
|
||||
(hashmap-update hashmap (car args) (lambda (value) (cadr args)) (lambda () #f))
|
||||
(loop (cddr args)
|
||||
hashmap)))))
|
||||
hashmap
|
||||
(receive (hashmap)
|
||||
(hashmap-update hashmap (car args) (lambda (value) (cadr args)) (lambda () #f))
|
||||
(loop (cddr args)
|
||||
hashmap)))))
|
||||
|
||||
(define hashmap-set! hashmap-set)
|
||||
|
||||
|
|
@ -187,11 +187,11 @@
|
|||
(assume (hashmap? hashmap))
|
||||
(receive (hashmap obj)
|
||||
(hashmap-search hashmap
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(update key value #f)))
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(update key value #f)))
|
||||
hashmap))
|
||||
|
||||
(define hashmap-replace! hashmap-replace)
|
||||
|
|
@ -206,15 +206,15 @@
|
|||
(assume (hashmap? hashmap))
|
||||
(assume (list? keys))
|
||||
(fold (lambda (key hashmap)
|
||||
(receive (hashmap obj)
|
||||
(hashmap-search hashmap
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(remove #f)))
|
||||
hashmap))
|
||||
hashmap keys))
|
||||
(receive (hashmap obj)
|
||||
(hashmap-search hashmap
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(remove #f)))
|
||||
hashmap))
|
||||
hashmap keys))
|
||||
|
||||
(define hashmap-delete-all! hashmap-delete-all)
|
||||
|
||||
|
|
@ -224,13 +224,13 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(hashmap-search hashmap
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(receive (value)
|
||||
(failure)
|
||||
(insert value value)))
|
||||
(lambda (old-key old-value update remove)
|
||||
(return hashmap old-value))))))
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(receive (value)
|
||||
(failure)
|
||||
(insert value value)))
|
||||
(lambda (old-key old-value update remove)
|
||||
(return hashmap old-value))))))
|
||||
|
||||
(define hashmap-intern! hashmap-intern)
|
||||
|
||||
|
|
@ -238,22 +238,22 @@
|
|||
(case-lambda
|
||||
((hashmap key updater)
|
||||
(hashmap-update hashmap key updater (lambda ()
|
||||
(error "hashmap-update: key not found in hashmap" key))))
|
||||
(error "hashmap-update: key not found in hashmap" key))))
|
||||
((hashmap key updater failure)
|
||||
(hashmap-update hashmap key updater failure (lambda (value)
|
||||
value)))
|
||||
value)))
|
||||
((hashmap key updater failure success)
|
||||
(assume (hashmap? hashmap))
|
||||
(assume (procedure? updater))
|
||||
(assume (procedure? failure))
|
||||
(assume (procedure? success))
|
||||
(receive (hashmap obj)
|
||||
(hashmap-search hashmap
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(insert (updater (failure)) #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(update key (updater (success old-value)) #f)))
|
||||
(hashmap-search hashmap
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(insert (updater (failure)) #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(update key (updater (success old-value)) #f)))
|
||||
hashmap))))
|
||||
|
||||
(define hashmap-update! hashmap-update)
|
||||
|
|
@ -267,16 +267,16 @@
|
|||
(case-lambda
|
||||
((hashmap)
|
||||
(hashmap-pop hashmap (lambda ()
|
||||
(error "hashmap-pop: hashmap has no association"))))
|
||||
(error "hashmap-pop: hashmap has no association"))))
|
||||
((hashmap failure)
|
||||
(assume (hashmap? hashmap))
|
||||
(assume (procedure? failure))
|
||||
((call/cc
|
||||
(lambda (return-thunk)
|
||||
(receive (key value)
|
||||
(hashmap-find (lambda (key value) #t) hashmap (lambda () (return-thunk failure)))
|
||||
(lambda ()
|
||||
(values (hashmap-delete hashmap key) key value)))))))))
|
||||
(receive (key value)
|
||||
(hashmap-find (lambda (key value) #t) hashmap (lambda () (return-thunk failure)))
|
||||
(lambda ()
|
||||
(values (hashmap-delete hashmap key) key value)))))))))
|
||||
|
||||
(define hashmap-pop! hashmap-pop)
|
||||
|
||||
|
|
@ -287,20 +287,20 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(let*-values
|
||||
(((comparator)
|
||||
(hashmap-key-comparator hashmap))
|
||||
((tree obj)
|
||||
(tree-search comparator
|
||||
(hashmap-tree hashmap)
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(failure (lambda (value obj)
|
||||
(insert key value obj))
|
||||
(lambda (obj)
|
||||
(return hashmap obj))))
|
||||
success)))
|
||||
(((comparator)
|
||||
(hashmap-key-comparator hashmap))
|
||||
((tree obj)
|
||||
(tree-search comparator
|
||||
(hashmap-tree hashmap)
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(failure (lambda (value obj)
|
||||
(insert key value obj))
|
||||
(lambda (obj)
|
||||
(return hashmap obj))))
|
||||
success)))
|
||||
(values (%make-hashmap comparator tree)
|
||||
obj)))))
|
||||
obj)))))
|
||||
|
||||
(define hashmap-search! hashmap-search)
|
||||
|
||||
|
|
@ -309,8 +309,8 @@
|
|||
(define (hashmap-size hashmap)
|
||||
(assume (hashmap? hashmap))
|
||||
(hashmap-count (lambda (key value)
|
||||
#t)
|
||||
hashmap))
|
||||
#t)
|
||||
hashmap))
|
||||
|
||||
(define (hashmap-find predicate hashmap failure)
|
||||
(assume (procedure? predicate))
|
||||
|
|
@ -319,19 +319,19 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(hashmap-for-each (lambda (key value)
|
||||
(when (predicate key value)
|
||||
(return key value)))
|
||||
hashmap)
|
||||
(when (predicate key value)
|
||||
(return key value)))
|
||||
hashmap)
|
||||
(failure))))
|
||||
|
||||
(define (hashmap-count predicate hashmap)
|
||||
(assume (procedure? predicate))
|
||||
(assume (hashmap? hashmap))
|
||||
(hashmap-fold (lambda (key value count)
|
||||
(if (predicate key value)
|
||||
(+ 1 count)
|
||||
count))
|
||||
0 hashmap))
|
||||
(if (predicate key value)
|
||||
(+ 1 count)
|
||||
count))
|
||||
0 hashmap))
|
||||
|
||||
(define (hashmap-any? predicate hashmap)
|
||||
(assume (procedure? predicate))
|
||||
|
|
@ -339,34 +339,34 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(hashmap-for-each (lambda (key value)
|
||||
(when (predicate key value)
|
||||
(return #t)))
|
||||
hashmap)
|
||||
(when (predicate key value)
|
||||
(return #t)))
|
||||
hashmap)
|
||||
#f)))
|
||||
|
||||
(define (hashmap-every? predicate hashmap)
|
||||
(assume (procedure? predicate))
|
||||
(assume (hashmap? hashmap))
|
||||
(not (hashmap-any? (lambda (key value)
|
||||
(not (predicate key value)))
|
||||
hashmap)))
|
||||
(not (predicate key value)))
|
||||
hashmap)))
|
||||
|
||||
(define (hashmap-keys hashmap)
|
||||
(assume (hashmap? hashmap))
|
||||
(hashmap-fold (lambda (key value keys)
|
||||
(cons key keys))
|
||||
'() hashmap))
|
||||
(cons key keys))
|
||||
'() hashmap))
|
||||
|
||||
(define (hashmap-values hashmap)
|
||||
(assume (hashmap? hashmap))
|
||||
(hashmap-fold (lambda (key value values)
|
||||
(cons value values))
|
||||
'() hashmap))
|
||||
(cons value values))
|
||||
'() hashmap))
|
||||
|
||||
(define (hashmap-entries hashmap)
|
||||
(assume (hashmap? hashmap))
|
||||
(values (hashmap-keys hashmap)
|
||||
(hashmap-values hashmap)))
|
||||
(hashmap-values hashmap)))
|
||||
|
||||
;; Hashmap and folding
|
||||
|
||||
|
|
@ -375,11 +375,11 @@
|
|||
(assume (comparator? comparator))
|
||||
(assume (hashmap? hashmap))
|
||||
(hashmap-fold (lambda (key value hashmap)
|
||||
(receive (key value)
|
||||
(proc key value)
|
||||
(hashmap-set hashmap key value)))
|
||||
(make-empty-hashmap comparator)
|
||||
hashmap))
|
||||
(receive (key value)
|
||||
(proc key value)
|
||||
(hashmap-set hashmap key value)))
|
||||
(make-empty-hashmap comparator)
|
||||
hashmap))
|
||||
|
||||
(define (hashmap-for-each proc hashmap)
|
||||
(assume (procedure? proc))
|
||||
|
|
@ -395,19 +395,19 @@
|
|||
(assume (procedure? proc))
|
||||
(assume (hashmap? hashmap))
|
||||
(hashmap-fold (lambda (key value lst)
|
||||
(cons (proc key value) lst))
|
||||
'()
|
||||
hashmap))
|
||||
(cons (proc key value) lst))
|
||||
'()
|
||||
hashmap))
|
||||
|
||||
(define (hashmap-filter predicate hashmap)
|
||||
(assume (procedure? predicate))
|
||||
(assume (hashmap? hashmap))
|
||||
(hashmap-fold (lambda (key value hashmap)
|
||||
(if (predicate key value)
|
||||
(hashmap-set hashmap key value)
|
||||
hashmap))
|
||||
(make-empty-hashmap (hashmap-key-comparator hashmap))
|
||||
hashmap))
|
||||
(if (predicate key value)
|
||||
(hashmap-set hashmap key value)
|
||||
hashmap))
|
||||
(make-empty-hashmap (hashmap-key-comparator hashmap))
|
||||
hashmap))
|
||||
|
||||
(define hashmap-filter! hashmap-filter)
|
||||
|
||||
|
|
@ -415,8 +415,8 @@
|
|||
(assume (procedure? predicate))
|
||||
(assume (hashmap? hashmap))
|
||||
(hashmap-filter (lambda (key value)
|
||||
(not (predicate key value)))
|
||||
hashmap))
|
||||
(not (predicate key value)))
|
||||
hashmap))
|
||||
|
||||
(define hashmap-remove! hashmap-remove)
|
||||
|
||||
|
|
@ -424,7 +424,7 @@
|
|||
(assume (procedure? predicate))
|
||||
(assume (hashmap? hashmap))
|
||||
(values (hashmap-filter predicate hashmap)
|
||||
(hashmap-remove predicate hashmap)))
|
||||
(hashmap-remove predicate hashmap)))
|
||||
|
||||
(define hashmap-partition! hashmap-partition)
|
||||
|
||||
|
|
@ -437,30 +437,30 @@
|
|||
(define (hashmap->alist hashmap)
|
||||
(assume (hashmap? hashmap))
|
||||
(hashmap-fold (lambda (key value alist)
|
||||
(cons (cons key value) alist))
|
||||
'() hashmap))
|
||||
(cons (cons key value) alist))
|
||||
'() hashmap))
|
||||
|
||||
(define (alist->hashmap comparator alist)
|
||||
(assume (comparator? comparator))
|
||||
(assume (list? alist))
|
||||
(hashmap-unfold null?
|
||||
(lambda (alist)
|
||||
(let ((key (caar alist))
|
||||
(value (cdar alist)))
|
||||
(values key value)))
|
||||
cdr
|
||||
alist
|
||||
comparator))
|
||||
(lambda (alist)
|
||||
(let ((key (caar alist))
|
||||
(value (cdar alist)))
|
||||
(values key value)))
|
||||
cdr
|
||||
alist
|
||||
comparator))
|
||||
|
||||
(define (alist->hashmap! hashmap alist)
|
||||
(assume (hashmap? hashmap))
|
||||
(assume (list? alist))
|
||||
(fold (lambda (association hashmap)
|
||||
(let ((key (car association))
|
||||
(value (cdr association)))
|
||||
(hashmap-set hashmap key value)))
|
||||
hashmap
|
||||
alist))
|
||||
(let ((key (car association))
|
||||
(value (cdr association)))
|
||||
(hashmap-set hashmap key value)))
|
||||
hashmap
|
||||
alist))
|
||||
|
||||
;; Subhashmaps
|
||||
|
||||
|
|
@ -500,12 +500,12 @@
|
|||
(assume (hashmap? hashmap1))
|
||||
(assume (hashmap? hashmap2))
|
||||
(hashmap-every? (lambda (key value)
|
||||
(hashmap-ref hashmap2 key
|
||||
(lambda ()
|
||||
#f)
|
||||
(lambda (stored-value)
|
||||
(=? comparator value stored-value))))
|
||||
hashmap1))
|
||||
(hashmap-ref hashmap2 key
|
||||
(lambda ()
|
||||
#f)
|
||||
(lambda (stored-value)
|
||||
(=? comparator value stored-value))))
|
||||
hashmap1))
|
||||
|
||||
(define hashmap>?
|
||||
(case-lambda
|
||||
|
|
@ -580,44 +580,44 @@
|
|||
|
||||
(define (%hashmap-union hashmap1 hashmap2)
|
||||
(hashmap-fold (lambda (key2 value2 hashmap)
|
||||
(receive (hashmap obj)
|
||||
(hashmap-search hashmap
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(insert value2 #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(update key1 value1 #f)))
|
||||
hashmap))
|
||||
hashmap1 hashmap2))
|
||||
(receive (hashmap obj)
|
||||
(hashmap-search hashmap
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(insert value2 #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(update key1 value1 #f)))
|
||||
hashmap))
|
||||
hashmap1 hashmap2))
|
||||
|
||||
(define (%hashmap-intersection hashmap1 hashmap2)
|
||||
(hashmap-filter (lambda (key1 value1)
|
||||
(hashmap-contains? hashmap2 key1))
|
||||
hashmap1))
|
||||
(hashmap-contains? hashmap2 key1))
|
||||
hashmap1))
|
||||
|
||||
(define (%hashmap-difference hashmap1 hashmap2)
|
||||
(hashmap-fold (lambda (key2 value2 hashmap)
|
||||
(receive (hashmap obj)
|
||||
(hashmap-search hashmap
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(remove #f)))
|
||||
hashmap))
|
||||
hashmap1 hashmap2))
|
||||
(receive (hashmap obj)
|
||||
(hashmap-search hashmap
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(remove #f)))
|
||||
hashmap))
|
||||
hashmap1 hashmap2))
|
||||
|
||||
(define (%hashmap-xor hashmap1 hashmap2)
|
||||
(hashmap-fold (lambda (key2 value2 hashmap)
|
||||
(receive (hashmap obj)
|
||||
(hashmap-search hashmap
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(insert value2 #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(remove #f)))
|
||||
hashmap))
|
||||
hashmap1 hashmap2))
|
||||
(receive (hashmap obj)
|
||||
(hashmap-search hashmap
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(insert value2 #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(remove #f)))
|
||||
hashmap))
|
||||
hashmap1 hashmap2))
|
||||
|
||||
(define hashmap-union
|
||||
(case-lambda
|
||||
|
|
@ -695,9 +695,9 @@
|
|||
|
||||
(define (make-hashmap-comparator comparator)
|
||||
(make-comparator hashmap?
|
||||
(hashmap-equality comparator)
|
||||
#f
|
||||
(hashmap-hash-function comparator)))
|
||||
(hashmap-equality comparator)
|
||||
#f
|
||||
(hashmap-hash-function comparator)))
|
||||
|
||||
(define hashmap-comparator (make-hashmap-comparator (make-default-comparator)))
|
||||
|
||||
|
|
|
|||
|
|
@ -40,12 +40,12 @@
|
|||
(define (mapping comparator . args)
|
||||
(assume (comparator? comparator))
|
||||
(mapping-unfold null?
|
||||
(lambda (args)
|
||||
(values (car args)
|
||||
(cadr args)))
|
||||
cddr
|
||||
args
|
||||
comparator))
|
||||
(lambda (args)
|
||||
(values (car args)
|
||||
(cadr args)))
|
||||
cddr
|
||||
args
|
||||
comparator))
|
||||
|
||||
(define (mapping-unfold stop? mapper successor seed comparator)
|
||||
(assume (procedure? stop?))
|
||||
|
|
@ -53,13 +53,13 @@
|
|||
(assume (procedure? successor))
|
||||
(assume (comparator? comparator))
|
||||
(let loop ((mapping (make-empty-mapping comparator))
|
||||
(seed seed))
|
||||
(seed seed))
|
||||
(if (stop? seed)
|
||||
mapping
|
||||
(receive (key value)
|
||||
(mapper seed)
|
||||
(loop (mapping-adjoin mapping key value)
|
||||
(successor seed))))))
|
||||
mapping
|
||||
(receive (key value)
|
||||
(mapper seed)
|
||||
(loop (mapping-adjoin mapping key value)
|
||||
(successor seed))))))
|
||||
|
||||
(define mapping/ordered mapping)
|
||||
(define mapping-unfold/ordered mapping-unfold)
|
||||
|
|
@ -75,11 +75,11 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(mapping-search mapping
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(return #f))
|
||||
(lambda (key value update remove)
|
||||
(return #t))))))
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(return #f))
|
||||
(lambda (key value update remove)
|
||||
(return #t))))))
|
||||
|
||||
(define (mapping-disjoint? mapping1 mapping2)
|
||||
(assume (mapping? mapping1))
|
||||
|
|
@ -87,9 +87,9 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(mapping-for-each (lambda (key value)
|
||||
(when (mapping-contains? mapping2 key)
|
||||
(return #f)))
|
||||
mapping1)
|
||||
(when (mapping-contains? mapping2 key)
|
||||
(return #f)))
|
||||
mapping1)
|
||||
#t)))
|
||||
|
||||
;; Accessors
|
||||
|
|
@ -99,24 +99,24 @@
|
|||
((mapping key)
|
||||
(assume (mapping? mapping))
|
||||
(mapping-ref mapping key (lambda ()
|
||||
(error "mapping-ref: key not in mapping" key))))
|
||||
(error "mapping-ref: key not in mapping" key))))
|
||||
((mapping key failure)
|
||||
(assume (mapping? mapping))
|
||||
(assume (procedure? failure))
|
||||
(mapping-ref mapping key failure (lambda (value)
|
||||
value)))
|
||||
value)))
|
||||
((mapping key failure success)
|
||||
(assume (mapping? mapping))
|
||||
(assume (procedure? failure))
|
||||
(assume (procedure? success))
|
||||
((call/cc
|
||||
(lambda (return-thunk)
|
||||
(mapping-search mapping
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(return-thunk failure))
|
||||
(lambda (key value update remove)
|
||||
(return-thunk (lambda () (success value)))))))))))
|
||||
(mapping-search mapping
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(return-thunk failure))
|
||||
(lambda (key value update remove)
|
||||
(return-thunk (lambda () (success value)))))))))))
|
||||
|
||||
(define (mapping-ref/default mapping key default)
|
||||
(assume (mapping? mapping))
|
||||
|
|
@ -127,25 +127,25 @@
|
|||
(define (mapping-adjoin mapping . args)
|
||||
(assume (mapping? mapping))
|
||||
(let loop ((args args)
|
||||
(mapping mapping))
|
||||
(mapping mapping))
|
||||
(if (null? args)
|
||||
mapping
|
||||
(receive (mapping value)
|
||||
(mapping-intern mapping (car args) (lambda () (cadr args)))
|
||||
(loop (cddr args) mapping)))))
|
||||
mapping
|
||||
(receive (mapping value)
|
||||
(mapping-intern mapping (car args) (lambda () (cadr args)))
|
||||
(loop (cddr args) mapping)))))
|
||||
|
||||
(define mapping-adjoin! mapping-adjoin)
|
||||
|
||||
(define (mapping-set mapping . args)
|
||||
(assume (mapping? mapping))
|
||||
(let loop ((args args)
|
||||
(mapping mapping))
|
||||
(mapping mapping))
|
||||
(if (null? args)
|
||||
mapping
|
||||
(receive (mapping)
|
||||
(mapping-update mapping (car args) (lambda (value) (cadr args)) (lambda () #f))
|
||||
(loop (cddr args)
|
||||
mapping)))))
|
||||
mapping
|
||||
(receive (mapping)
|
||||
(mapping-update mapping (car args) (lambda (value) (cadr args)) (lambda () #f))
|
||||
(loop (cddr args)
|
||||
mapping)))))
|
||||
|
||||
(define mapping-set! mapping-set)
|
||||
|
||||
|
|
@ -153,11 +153,11 @@
|
|||
(assume (mapping? mapping))
|
||||
(receive (mapping obj)
|
||||
(mapping-search mapping
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(update key value #f)))
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(update key value #f)))
|
||||
mapping))
|
||||
|
||||
(define mapping-replace! mapping-replace)
|
||||
|
|
@ -172,15 +172,15 @@
|
|||
(assume (mapping? mapping))
|
||||
(assume (list? keys))
|
||||
(fold (lambda (key mapping)
|
||||
(receive (mapping obj)
|
||||
(mapping-search mapping
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(remove #f)))
|
||||
mapping))
|
||||
mapping keys))
|
||||
(receive (mapping obj)
|
||||
(mapping-search mapping
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(remove #f)))
|
||||
mapping))
|
||||
mapping keys))
|
||||
|
||||
(define mapping-delete-all! mapping-delete-all)
|
||||
|
||||
|
|
@ -190,13 +190,13 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(mapping-search mapping
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(receive (value)
|
||||
(failure)
|
||||
(insert value value)))
|
||||
(lambda (old-key old-value update remove)
|
||||
(return mapping old-value))))))
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(receive (value)
|
||||
(failure)
|
||||
(insert value value)))
|
||||
(lambda (old-key old-value update remove)
|
||||
(return mapping old-value))))))
|
||||
|
||||
(define mapping-intern! mapping-intern)
|
||||
|
||||
|
|
@ -204,22 +204,22 @@
|
|||
(case-lambda
|
||||
((mapping key updater)
|
||||
(mapping-update mapping key updater (lambda ()
|
||||
(error "mapping-update: key not found in mapping" key))))
|
||||
(error "mapping-update: key not found in mapping" key))))
|
||||
((mapping key updater failure)
|
||||
(mapping-update mapping key updater failure (lambda (value)
|
||||
value)))
|
||||
value)))
|
||||
((mapping key updater failure success)
|
||||
(assume (mapping? mapping))
|
||||
(assume (procedure? updater))
|
||||
(assume (procedure? failure))
|
||||
(assume (procedure? success))
|
||||
(receive (mapping obj)
|
||||
(mapping-search mapping
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(insert (updater (failure)) #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(update key (updater (success old-value)) #f)))
|
||||
(mapping-search mapping
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(insert (updater (failure)) #f))
|
||||
(lambda (old-key old-value update remove)
|
||||
(update key (updater (success old-value)) #f)))
|
||||
mapping))))
|
||||
|
||||
(define mapping-update! mapping-update)
|
||||
|
|
@ -233,16 +233,16 @@
|
|||
(case-lambda
|
||||
((mapping)
|
||||
(mapping-pop mapping (lambda ()
|
||||
(error "mapping-pop: mapping has no association"))))
|
||||
(error "mapping-pop: mapping has no association"))))
|
||||
((mapping failure)
|
||||
(assume (mapping? mapping))
|
||||
(assume (procedure? failure))
|
||||
((call/cc
|
||||
(lambda (return-thunk)
|
||||
(receive (key value)
|
||||
(mapping-find (lambda (key value) #t) mapping (lambda () (return-thunk failure)))
|
||||
(lambda ()
|
||||
(values (mapping-delete mapping key) key value)))))))))
|
||||
(receive (key value)
|
||||
(mapping-find (lambda (key value) #t) mapping (lambda () (return-thunk failure)))
|
||||
(lambda ()
|
||||
(values (mapping-delete mapping key) key value)))))))))
|
||||
|
||||
(define mapping-pop! mapping-pop)
|
||||
|
||||
|
|
@ -253,20 +253,20 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(let*-values
|
||||
(((comparator)
|
||||
(mapping-key-comparator mapping))
|
||||
((tree obj)
|
||||
(tree-search comparator
|
||||
(mapping-tree mapping)
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(failure (lambda (value obj)
|
||||
(insert key value obj))
|
||||
(lambda (obj)
|
||||
(return mapping obj))))
|
||||
success)))
|
||||
(((comparator)
|
||||
(mapping-key-comparator mapping))
|
||||
((tree obj)
|
||||
(tree-search comparator
|
||||
(mapping-tree mapping)
|
||||
key
|
||||
(lambda (insert ignore)
|
||||
(failure (lambda (value obj)
|
||||
(insert key value obj))
|
||||
(lambda (obj)
|
||||
(return mapping obj))))
|
||||
success)))
|
||||
(values (%make-mapping comparator tree)
|
||||
obj)))))
|
||||
obj)))))
|
||||
|
||||
(define mapping-search! mapping-search)
|
||||
|
||||
|
|
@ -275,8 +275,8 @@
|
|||
(define (mapping-size mapping)
|
||||
(assume (mapping? mapping))
|
||||
(mapping-count (lambda (key value)
|
||||
#t)
|
||||
mapping))
|
||||
#t)
|
||||
mapping))
|
||||
|
||||
(define (mapping-find predicate mapping failure)
|
||||
(assume (procedure? predicate))
|
||||
|
|
@ -285,19 +285,19 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(mapping-for-each (lambda (key value)
|
||||
(when (predicate key value)
|
||||
(return key value)))
|
||||
mapping)
|
||||
(when (predicate key value)
|
||||
(return key value)))
|
||||
mapping)
|
||||
(failure))))
|
||||
|
||||
(define (mapping-count predicate mapping)
|
||||
(assume (procedure? predicate))
|
||||
(assume (mapping? mapping))
|
||||
(mapping-fold (lambda (key value count)
|
||||
(if (predicate key value)
|
||||
(+ 1 count)
|
||||
count))
|
||||
0 mapping))
|
||||
(if (predicate key value)
|
||||
(+ 1 count)
|
||||
count))
|
||||
0 mapping))
|
||||
|
||||
(define (mapping-any? predicate mapping)
|
||||
(assume (procedure? predicate))
|
||||
|
|
@ -305,34 +305,34 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(mapping-for-each (lambda (key value)
|
||||
(when (predicate key value)
|
||||
(return #t)))
|
||||
mapping)
|
||||
(when (predicate key value)
|
||||
(return #t)))
|
||||
mapping)
|
||||
#f)))
|
||||
|
||||
(define (mapping-every? predicate mapping)
|
||||
(assume (procedure? predicate))
|
||||
(assume (mapping? mapping))
|
||||
(not (mapping-any? (lambda (key value)
|
||||
(not (predicate key value)))
|
||||
mapping)))
|
||||
(not (predicate key value)))
|
||||
mapping)))
|
||||
|
||||
(define (mapping-keys mapping)
|
||||
(assume (mapping? mapping))
|
||||
(mapping-fold/reverse (lambda (key value keys)
|
||||
(cons key keys))
|
||||
'() mapping))
|
||||
(cons key keys))
|
||||
'() mapping))
|
||||
|
||||
(define (mapping-values mapping)
|
||||
(assume (mapping? mapping))
|
||||
(mapping-fold/reverse (lambda (key value values)
|
||||
(cons value values))
|
||||
'() mapping))
|
||||
(cons value values))
|
||||
'() mapping))
|
||||
|
||||
(define (mapping-entries mapping)
|
||||
(assume (mapping? mapping))
|
||||
(values (mapping-keys mapping)
|
||||
(mapping-values mapping)))
|
||||
(mapping-values mapping)))
|
||||
|
||||
;; Mapping and folding
|
||||
|
||||
|
|
@ -341,11 +341,11 @@
|
|||
(assume (comparator? comparator))
|
||||
(assume (mapping? mapping))
|
||||
(mapping-fold (lambda (key value mapping)
|
||||
(receive (key value)
|
||||
(proc key value)
|
||||
(mapping-set mapping key value)))
|
||||
(make-empty-mapping comparator)
|
||||
mapping))
|
||||
(receive (key value)
|
||||
(proc key value)
|
||||
(mapping-set mapping key value)))
|
||||
(make-empty-mapping comparator)
|
||||
mapping))
|
||||
|
||||
(define (mapping-for-each proc mapping)
|
||||
(assume (procedure? proc))
|
||||
|
|
@ -361,19 +361,19 @@
|
|||
(assume (procedure? proc))
|
||||
(assume (mapping? mapping))
|
||||
(mapping-fold/reverse (lambda (key value lst)
|
||||
(cons (proc key value) lst))
|
||||
'()
|
||||
mapping))
|
||||
(cons (proc key value) lst))
|
||||
'()
|
||||
mapping))
|
||||
|
||||
(define (mapping-filter predicate mapping)
|
||||
(assume (procedure? predicate))
|
||||
(assume (mapping? mapping))
|
||||
(mapping-fold (lambda (key value mapping)
|
||||
(if (predicate key value)
|
||||
(mapping-set mapping key value)
|
||||
mapping))
|
||||
(make-empty-mapping (mapping-key-comparator mapping))
|
||||
mapping))
|
||||
(if (predicate key value)
|
||||
(mapping-set mapping key value)
|
||||
mapping))
|
||||
(make-empty-mapping (mapping-key-comparator mapping))
|
||||
mapping))
|
||||
|
||||
(define mapping-filter! mapping-filter)
|
||||
|
||||
|
|
@ -381,8 +381,8 @@
|
|||
(assume (procedure? predicate))
|
||||
(assume (mapping? mapping))
|
||||
(mapping-filter (lambda (key value)
|
||||
(not (predicate key value)))
|
||||
mapping))
|
||||
(not (predicate key value)))
|
||||
mapping))
|
||||
|
||||
(define mapping-remove! mapping-remove)
|
||||
|
||||
|
|
@ -390,7 +390,7 @@
|
|||
(assume (procedure? predicate))
|
||||
(assume (mapping? mapping))
|
||||
(values (mapping-filter predicate mapping)
|
||||
(mapping-remove predicate mapping)))
|
||||
(mapping-remove predicate mapping)))
|
||||
|
||||
(define mapping-partition! mapping-partition)
|
||||
|
||||
|
|
@ -404,30 +404,30 @@
|
|||
(assume (mapping? mapping))
|
||||
(reverse
|
||||
(mapping-fold (lambda (key value alist)
|
||||
(cons (cons key value) alist))
|
||||
'() mapping)))
|
||||
(cons (cons key value) alist))
|
||||
'() mapping)))
|
||||
|
||||
(define (alist->mapping comparator alist)
|
||||
(assume (comparator? comparator))
|
||||
(assume (list? alist))
|
||||
(mapping-unfold null?
|
||||
(lambda (alist)
|
||||
(let ((key (caar alist))
|
||||
(value (cdar alist)))
|
||||
(values key value)))
|
||||
cdr
|
||||
alist
|
||||
comparator))
|
||||
(lambda (alist)
|
||||
(let ((key (caar alist))
|
||||
(value (cdar alist)))
|
||||
(values key value)))
|
||||
cdr
|
||||
alist
|
||||
comparator))
|
||||
|
||||
(define (alist->mapping! mapping alist)
|
||||
(assume (mapping? mapping))
|
||||
(assume (list? alist))
|
||||
(fold (lambda (association mapping)
|
||||
(let ((key (car association))
|
||||
(value (cdr association)))
|
||||
(mapping-set mapping key value)))
|
||||
mapping
|
||||
alist))
|
||||
(let ((key (car association))
|
||||
(value (cdr association)))
|
||||
(mapping-set mapping key value)))
|
||||
mapping
|
||||
alist))
|
||||
|
||||
(define alist->mapping/ordered alist->mapping)
|
||||
(define alist->mapping/ordered! alist->mapping!)
|
||||
|
|
@ -470,28 +470,28 @@
|
|||
(assume (mapping? mapping1))
|
||||
(assume (mapping? mapping2))
|
||||
(let ((less? (comparator-ordering-predicate (mapping-key-comparator mapping1)))
|
||||
(equality-predicate (comparator-equality-predicate comparator))
|
||||
(gen1 (tree-generator (mapping-tree mapping1)))
|
||||
(gen2 (tree-generator (mapping-tree mapping2))))
|
||||
(equality-predicate (comparator-equality-predicate comparator))
|
||||
(gen1 (tree-generator (mapping-tree mapping1)))
|
||||
(gen2 (tree-generator (mapping-tree mapping2))))
|
||||
(let loop ((item1 (gen1))
|
||||
(item2 (gen2)))
|
||||
(item2 (gen2)))
|
||||
(cond
|
||||
((eof-object? item1)
|
||||
#t)
|
||||
#t)
|
||||
((eof-object? item2)
|
||||
#f)
|
||||
#f)
|
||||
(else
|
||||
(let ((key1 (car item1)) (value1 (cadr item1))
|
||||
(key2 (car item2)) (value2 (cadr item2)))
|
||||
(cond
|
||||
((less? key1 key2)
|
||||
#f)
|
||||
((less? key2 key1)
|
||||
(loop item1 (gen2)))
|
||||
((equality-predicate value1 value2)
|
||||
(loop (gen1) (gen2)))
|
||||
(else
|
||||
#f))))))))
|
||||
(let ((key1 (car item1)) (value1 (cadr item1))
|
||||
(key2 (car item2)) (value2 (cadr item2)))
|
||||
(cond
|
||||
((less? key1 key2)
|
||||
#f)
|
||||
((less? key2 key1)
|
||||
(loop item1 (gen2)))
|
||||
((equality-predicate value1 value2)
|
||||
(loop (gen1) (gen2)))
|
||||
(else
|
||||
#f))))))))
|
||||
|
||||
(define mapping>?
|
||||
(case-lambda
|
||||
|
|
@ -566,44 +566,44 @@
|
|||
|
||||
(define (%mapping-union mapping1 mapping2)
|
||||
(mapping-fold (lambda (key2 value2 mapping)
|
||||
(receive (mapping obj)
|
||||
(mapping-search mapping
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(insert value2 #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(update key1 value1 #f)))
|
||||
mapping))
|
||||
mapping1 mapping2))
|
||||
(receive (mapping obj)
|
||||
(mapping-search mapping
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(insert value2 #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(update key1 value1 #f)))
|
||||
mapping))
|
||||
mapping1 mapping2))
|
||||
|
||||
(define (%mapping-intersection mapping1 mapping2)
|
||||
(mapping-filter (lambda (key1 value1)
|
||||
(mapping-contains? mapping2 key1))
|
||||
mapping1))
|
||||
(mapping-contains? mapping2 key1))
|
||||
mapping1))
|
||||
|
||||
(define (%mapping-difference mapping1 mapping2)
|
||||
(mapping-fold (lambda (key2 value2 mapping)
|
||||
(receive (mapping obj)
|
||||
(mapping-search mapping
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(remove #f)))
|
||||
mapping))
|
||||
mapping1 mapping2))
|
||||
(receive (mapping obj)
|
||||
(mapping-search mapping
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(ignore #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(remove #f)))
|
||||
mapping))
|
||||
mapping1 mapping2))
|
||||
|
||||
(define (%mapping-xor mapping1 mapping2)
|
||||
(mapping-fold (lambda (key2 value2 mapping)
|
||||
(receive (mapping obj)
|
||||
(mapping-search mapping
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(insert value2 #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(remove #f)))
|
||||
mapping))
|
||||
mapping1 mapping2))
|
||||
(receive (mapping obj)
|
||||
(mapping-search mapping
|
||||
key2
|
||||
(lambda (insert ignore)
|
||||
(insert value2 #f))
|
||||
(lambda (key1 value1 update remove)
|
||||
(remove #f)))
|
||||
mapping))
|
||||
mapping1 mapping2))
|
||||
|
||||
(define mapping-union
|
||||
(case-lambda
|
||||
|
|
@ -672,8 +672,8 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(mapping-fold (lambda (key value acc)
|
||||
(return key))
|
||||
#f mapping)
|
||||
(return key))
|
||||
#f mapping)
|
||||
(error "mapping-min-key: empty map"))))
|
||||
|
||||
(define (mapping-max-key mapping)
|
||||
|
|
@ -681,8 +681,8 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(mapping-fold/reverse (lambda (key value acc)
|
||||
(return key))
|
||||
#f mapping)
|
||||
(return key))
|
||||
#f mapping)
|
||||
(error "mapping-max-key: empty map"))))
|
||||
|
||||
(define (mapping-min-value mapping)
|
||||
|
|
@ -690,8 +690,8 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(mapping-fold (lambda (key value acc)
|
||||
(return value))
|
||||
#f mapping)
|
||||
(return value))
|
||||
#f mapping)
|
||||
(error "mapping-min-value: empty map"))))
|
||||
|
||||
(define (mapping-max-value mapping)
|
||||
|
|
@ -699,8 +699,8 @@
|
|||
(call/cc
|
||||
(lambda (return)
|
||||
(mapping-fold/reverse (lambda (key value acc)
|
||||
(return value))
|
||||
#f mapping)
|
||||
(return value))
|
||||
#f mapping)
|
||||
(error "mapping-max-value: empty map"))))
|
||||
|
||||
(define (mapping-key-predecessor mapping obj failure)
|
||||
|
|
@ -717,28 +717,28 @@
|
|||
(assume (mapping? mapping))
|
||||
(let ((comparator (mapping-key-comparator mapping)))
|
||||
(receive (tree< tree<= tree= tree>= tree>)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(%make-mapping comparator tree=))))
|
||||
|
||||
(define (mapping-range< mapping obj)
|
||||
(assume (mapping? mapping))
|
||||
(let ((comparator (mapping-key-comparator mapping)))
|
||||
(receive (tree< tree<= tree= tree>= tree>)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(%make-mapping comparator tree<))))
|
||||
|
||||
(define (mapping-range<= mapping obj)
|
||||
(assume (mapping? mapping))
|
||||
(let ((comparator (mapping-key-comparator mapping)))
|
||||
(receive (tree< tree<= tree= tree>= tree>)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(%make-mapping comparator tree<=))))
|
||||
|
||||
(define (mapping-range> mapping obj)
|
||||
(assume (mapping? mapping))
|
||||
(let ((comparator (mapping-key-comparator mapping)))
|
||||
(receive (tree< tree<= tree= tree>= tree>)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(%make-mapping comparator tree>))))
|
||||
|
||||
(define (mapping-range>= mapping obj)
|
||||
|
|
@ -746,7 +746,7 @@
|
|||
(assume (mapping? mapping))
|
||||
(let ((comparator (mapping-key-comparator mapping)))
|
||||
(receive (tree< tree<= tree= tree>= tree>)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(%make-mapping comparator tree>=))))
|
||||
|
||||
(define mapping-range=! mapping-range=)
|
||||
|
|
@ -759,21 +759,21 @@
|
|||
(assume (mapping? mapping))
|
||||
(let ((comparator (mapping-key-comparator mapping)))
|
||||
(receive (tree< tree<= tree= tree>= tree>)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(tree-split comparator (mapping-tree mapping) obj)
|
||||
(values (%make-mapping comparator tree<)
|
||||
(%make-mapping comparator tree<=)
|
||||
(%make-mapping comparator tree=)
|
||||
(%make-mapping comparator tree>=)
|
||||
(%make-mapping comparator tree>)))))
|
||||
(%make-mapping comparator tree<=)
|
||||
(%make-mapping comparator tree=)
|
||||
(%make-mapping comparator tree>=)
|
||||
(%make-mapping comparator tree>)))))
|
||||
|
||||
(define (mapping-catenate comparator mapping1 pivot-key pivot-value mapping2)
|
||||
(assume (comparator? comparator))
|
||||
(assume (mapping? mapping1))
|
||||
(assume (mapping? mapping2))
|
||||
(%make-mapping comparator (tree-catenate (mapping-tree mapping1)
|
||||
pivot-key
|
||||
pivot-value
|
||||
(mapping-tree mapping2))))
|
||||
pivot-key
|
||||
pivot-value
|
||||
(mapping-tree mapping2))))
|
||||
|
||||
(define mapping-catenate! mapping-catenate)
|
||||
|
||||
|
|
@ -800,30 +800,30 @@
|
|||
(define (mapping-ordering comparator)
|
||||
(assume (comparator? comparator))
|
||||
(let ((value-equality (comparator-equality-predicate comparator))
|
||||
(value-ordering (comparator-ordering-predicate comparator)))
|
||||
(value-ordering (comparator-ordering-predicate comparator)))
|
||||
(lambda (mapping1 mapping2)
|
||||
(let* ((key-comparator (mapping-key-comparator mapping1))
|
||||
(equality (comparator-equality-predicate key-comparator))
|
||||
(ordering (comparator-ordering-predicate key-comparator))
|
||||
(gen1 (tree-generator (mapping-tree mapping1)))
|
||||
(gen2 (tree-generator (mapping-tree mapping2))))
|
||||
(let loop ()
|
||||
(let ((item1 (gen1)) (item2 (gen2)))
|
||||
(cond
|
||||
((eof-object? item1)
|
||||
(not (eof-object? item2)))
|
||||
((eof-object? item2)
|
||||
#f)
|
||||
(else
|
||||
(let ((key1 (car item1)) (value1 (cadr item1))
|
||||
(key2 (car item2)) (value2 (cadr item2)))
|
||||
(cond
|
||||
((equality key1 key2)
|
||||
(if (value-equality value1 value2)
|
||||
(loop)
|
||||
(value-ordering value1 value2)))
|
||||
(else
|
||||
(ordering key1 key2))))))))))))
|
||||
(equality (comparator-equality-predicate key-comparator))
|
||||
(ordering (comparator-ordering-predicate key-comparator))
|
||||
(gen1 (tree-generator (mapping-tree mapping1)))
|
||||
(gen2 (tree-generator (mapping-tree mapping2))))
|
||||
(let loop ()
|
||||
(let ((item1 (gen1)) (item2 (gen2)))
|
||||
(cond
|
||||
((eof-object? item1)
|
||||
(not (eof-object? item2)))
|
||||
((eof-object? item2)
|
||||
#f)
|
||||
(else
|
||||
(let ((key1 (car item1)) (value1 (cadr item1))
|
||||
(key2 (car item2)) (value2 (cadr item2)))
|
||||
(cond
|
||||
((equality key1 key2)
|
||||
(if (value-equality value1 value2)
|
||||
(loop)
|
||||
(value-ordering value1 value2)))
|
||||
(else
|
||||
(ordering key1 key2))))))))))))
|
||||
|
||||
(define (make-mapping-comparator comparator)
|
||||
(make-comparator mapping? (mapping-equality comparator) (mapping-ordering comparator) #f))
|
||||
|
|
|
|||
|
|
@ -57,16 +57,16 @@
|
|||
((compile-patterns (expression* ...) tree (clauses ...) ())
|
||||
(call-with-current-continuation
|
||||
(lambda (return)
|
||||
(or (and-let* clauses
|
||||
(call-with-values
|
||||
(lambda () . expression*)
|
||||
return))
|
||||
...
|
||||
(error "tree does not match any pattern" tree)))))
|
||||
(or (and-let* clauses
|
||||
(call-with-values
|
||||
(lambda () . expression*)
|
||||
return))
|
||||
...
|
||||
(error "tree does not match any pattern" tree)))))
|
||||
|
||||
((compile-patterns e tree clauses* (pattern . pattern*))
|
||||
(compile-pattern tree pattern
|
||||
(add-pattern e tree clauses* pattern*)))))
|
||||
(add-pattern e tree clauses* pattern*)))))
|
||||
|
||||
(define-syntax add-pattern
|
||||
(syntax-rules ()
|
||||
|
|
@ -93,23 +93,23 @@
|
|||
|
||||
((compile-pattern tree (and pt ...) k*)
|
||||
(compile-subpatterns () ((t pt) ...)
|
||||
(compile-and-pattern tree t k*)))
|
||||
(compile-and-pattern tree t k*)))
|
||||
|
||||
((compile-pattern tree (node pc pa px pb) k*)
|
||||
(compile-subpatterns () ((c pc) (a pa) (x px) (b pb))
|
||||
(compile-node-pattern tree c a x b k*)))
|
||||
(compile-node-pattern tree c a x b k*)))
|
||||
|
||||
((compile-pattern tree (red pa px pb) k*)
|
||||
(compile-subpatterns () ((a pa) (x px) (b pb))
|
||||
(compile-color-pattern red? tree a x b k*)))
|
||||
(compile-color-pattern red? tree a x b k*)))
|
||||
|
||||
((compile-pattern tree (black pa px pb) k*)
|
||||
(compile-subpatterns () ((a pa) (x px) (b pb))
|
||||
(compile-color-pattern black? tree a x b k*)))
|
||||
(compile-color-pattern black? tree a x b k*)))
|
||||
|
||||
((compile-pattern tree (white pa px pb) k*)
|
||||
(compile-subpatterns () ((a pa) (x px) (b pb))
|
||||
(compile-color-pattern white? tree a x b k*)))
|
||||
(compile-color-pattern white? tree a x b k*)))
|
||||
|
||||
((compile-pattern tree _ (k ...))
|
||||
(k ... ()))
|
||||
|
|
@ -126,19 +126,19 @@
|
|||
(syntax-rules ()
|
||||
((compile-node-pattern tree c a x b (k ...) clauses)
|
||||
(k ... (((item tree))
|
||||
(c (color tree))
|
||||
(a (left tree))
|
||||
(x (item tree))
|
||||
(b (right tree)) . clauses)))))
|
||||
(c (color tree))
|
||||
(a (left tree))
|
||||
(x (item tree))
|
||||
(b (right tree)) . clauses)))))
|
||||
|
||||
(define-syntax compile-color-pattern
|
||||
(syntax-rules ()
|
||||
((compile-color-pattern pred? tree a x b (k ...) clauses)
|
||||
(k ... (((item tree))
|
||||
((pred? tree))
|
||||
(a (left tree))
|
||||
(x (item tree))
|
||||
(b (right tree)) . clauses)))))
|
||||
((pred? tree))
|
||||
(a (left tree))
|
||||
(x (item tree))
|
||||
(b (right tree)) . clauses)))))
|
||||
|
||||
(define-syntax compile-subpatterns
|
||||
(syntax-rules ()
|
||||
|
|
@ -186,10 +186,10 @@
|
|||
acc)
|
||||
((node _ a x b)
|
||||
(let*
|
||||
((acc (loop acc a))
|
||||
(acc (proc (item-key x) (item-value x) acc))
|
||||
(acc (loop acc b)))
|
||||
acc)))))
|
||||
((acc (loop acc a))
|
||||
(acc (proc (item-key x) (item-value x) acc))
|
||||
(acc (loop acc b)))
|
||||
acc)))))
|
||||
|
||||
(define (tree-fold/reverse proc seed tree)
|
||||
(let loop ((acc seed) (tree tree))
|
||||
|
|
@ -198,15 +198,15 @@
|
|||
acc)
|
||||
((node _ a x b)
|
||||
(let*
|
||||
((acc (loop acc b))
|
||||
(acc (proc (item-key x) (item-value x) acc))
|
||||
(acc (loop acc a)))
|
||||
acc)))))
|
||||
((acc (loop acc b))
|
||||
(acc (proc (item-key x) (item-value x) acc))
|
||||
(acc (loop acc a)))
|
||||
acc)))))
|
||||
|
||||
(define (tree-for-each proc tree)
|
||||
(tree-fold (lambda (key value acc)
|
||||
(proc key value))
|
||||
#f tree))
|
||||
(proc key value))
|
||||
#f tree))
|
||||
|
||||
(define (tree-generator tree)
|
||||
(make-coroutine-generator
|
||||
|
|
@ -218,51 +218,51 @@
|
|||
(define (tree-search comparator tree obj failure success)
|
||||
(receive (tree ret op)
|
||||
(let search ((tree (redden tree)))
|
||||
(tree-match tree
|
||||
((black)
|
||||
(failure
|
||||
;; insert
|
||||
(lambda (new-key new-value ret)
|
||||
(values (red (black-leaf) (make-item new-key new-value) (black-leaf))
|
||||
ret
|
||||
balance))
|
||||
;; ignore
|
||||
(lambda (ret)
|
||||
(values (black-leaf) ret identity))))
|
||||
|
||||
((and t (node c a x b))
|
||||
(let ((key (item-key x)))
|
||||
(comparator-if<=> comparator obj key
|
||||
|
||||
(receive (a ret op) (search a)
|
||||
(values (op (node c a x b)) ret op))
|
||||
|
||||
(success
|
||||
key
|
||||
(item-value x)
|
||||
;; update
|
||||
(lambda (new-key new-value ret)
|
||||
(values (node c a (make-item new-key new-value) b)
|
||||
ret
|
||||
identity))
|
||||
;; remove
|
||||
(lambda (ret)
|
||||
(values
|
||||
(tree-match t
|
||||
((red (black) x (black))
|
||||
(black-leaf))
|
||||
((black (red a x b) _ (black))
|
||||
(black a x b))
|
||||
((black (black) _ (black))
|
||||
(white-leaf))
|
||||
(_
|
||||
(receive (x b) (min+delete b)
|
||||
(rotate (node c a x b)))))
|
||||
ret
|
||||
rotate)))
|
||||
|
||||
(receive (b ret op) (search b)
|
||||
(values (op (node c a x b)) ret op)))))))
|
||||
(tree-match tree
|
||||
((black)
|
||||
(failure
|
||||
;; insert
|
||||
(lambda (new-key new-value ret)
|
||||
(values (red (black-leaf) (make-item new-key new-value) (black-leaf))
|
||||
ret
|
||||
balance))
|
||||
;; ignore
|
||||
(lambda (ret)
|
||||
(values (black-leaf) ret identity))))
|
||||
|
||||
((and t (node c a x b))
|
||||
(let ((key (item-key x)))
|
||||
(comparator-if<=> comparator obj key
|
||||
|
||||
(receive (a ret op) (search a)
|
||||
(values (op (node c a x b)) ret op))
|
||||
|
||||
(success
|
||||
key
|
||||
(item-value x)
|
||||
;; update
|
||||
(lambda (new-key new-value ret)
|
||||
(values (node c a (make-item new-key new-value) b)
|
||||
ret
|
||||
identity))
|
||||
;; remove
|
||||
(lambda (ret)
|
||||
(values
|
||||
(tree-match t
|
||||
((red (black) x (black))
|
||||
(black-leaf))
|
||||
((black (red a x b) _ (black))
|
||||
(black a x b))
|
||||
((black (black) _ (black))
|
||||
(white-leaf))
|
||||
(_
|
||||
(receive (x b) (min+delete b)
|
||||
(rotate (node c a x b)))))
|
||||
ret
|
||||
rotate)))
|
||||
|
||||
(receive (b ret op) (search b)
|
||||
(values (op (node c a x b)) ret op)))))))
|
||||
|
||||
(values (blacken tree) ret)))
|
||||
|
||||
|
|
@ -273,10 +273,10 @@
|
|||
(return))
|
||||
((node _ a x b)
|
||||
(let ((key (item-key x)))
|
||||
(comparator-if<=> comparator key obj
|
||||
(loop return b)
|
||||
(loop return b)
|
||||
(loop (lambda () key) a)))))))
|
||||
(comparator-if<=> comparator key obj
|
||||
(loop return b)
|
||||
(loop return b)
|
||||
(loop (lambda () key) a)))))))
|
||||
|
||||
(define (tree-key-predecessor comparator tree obj failure)
|
||||
(let loop ((return failure) (tree tree))
|
||||
|
|
@ -285,10 +285,10 @@
|
|||
(return))
|
||||
((node _ a x b)
|
||||
(let ((key (item-key x)))
|
||||
(comparator-if<=> comparator key obj
|
||||
(loop (lambda () key) b)
|
||||
(loop return a)
|
||||
(loop return a)))))))
|
||||
(comparator-if<=> comparator key obj
|
||||
(loop (lambda () key) b)
|
||||
(loop return a)
|
||||
(loop return a)))))))
|
||||
|
||||
(define (tree-map proc tree)
|
||||
(let loop ((tree tree))
|
||||
|
|
@ -297,64 +297,64 @@
|
|||
(black-leaf))
|
||||
((node c a x b)
|
||||
(receive (key value)
|
||||
(proc (item-key x) (item-value x))
|
||||
(node c (loop a) (make-item key value) (loop b)))))))
|
||||
(proc (item-key x) (item-value x))
|
||||
(node c (loop a) (make-item key value) (loop b)))))))
|
||||
|
||||
|
||||
(define (tree-catenate tree1 pivot-key pivot-value tree2)
|
||||
(let ((pivot (make-item pivot-key pivot-value))
|
||||
(height1 (black-height tree1))
|
||||
(height2 (black-height tree2)))
|
||||
(height1 (black-height tree1))
|
||||
(height2 (black-height tree2)))
|
||||
(cond
|
||||
((= height1 height2)
|
||||
(black tree1 pivot tree2))
|
||||
((< height1 height2)
|
||||
(blacken
|
||||
(let loop ((tree tree2) (depth (- height2 height1)))
|
||||
(if (zero? depth)
|
||||
(balance (red tree1 pivot tree))
|
||||
(balance
|
||||
(node (color tree) (loop (left tree) (- depth 1)) (item tree) (right tree)))))))
|
||||
(if (zero? depth)
|
||||
(balance (red tree1 pivot tree))
|
||||
(balance
|
||||
(node (color tree) (loop (left tree) (- depth 1)) (item tree) (right tree)))))))
|
||||
(else
|
||||
(blacken
|
||||
(let loop ((tree tree1) (depth (- height1 height2)))
|
||||
(if (zero? depth)
|
||||
(balance (red tree pivot tree2))
|
||||
(balance
|
||||
(node (color tree) (left tree) (item tree) (loop (right tree) (- depth 1)))))))))))
|
||||
(if (zero? depth)
|
||||
(balance (red tree pivot tree2))
|
||||
(balance
|
||||
(node (color tree) (left tree) (item tree) (loop (right tree) (- depth 1)))))))))))
|
||||
|
||||
(define (tree-split comparator tree obj)
|
||||
(let loop ((tree1 (black-leaf))
|
||||
(tree2 (black-leaf))
|
||||
(pivot1 #f)
|
||||
(pivot2 #f)
|
||||
(tree tree))
|
||||
(tree2 (black-leaf))
|
||||
(pivot1 #f)
|
||||
(pivot2 #f)
|
||||
(tree tree))
|
||||
(tree-match tree
|
||||
((black)
|
||||
(let ((tree1 (catenate-left tree1 pivot1 (black-leaf)))
|
||||
(tree2 (catenate-right (black-leaf) pivot2 tree2)))
|
||||
(values tree1 tree1 (black-leaf) tree2 tree2)))
|
||||
(tree2 (catenate-right (black-leaf) pivot2 tree2)))
|
||||
(values tree1 tree1 (black-leaf) tree2 tree2)))
|
||||
((node _ a x b)
|
||||
(comparator-if<=> comparator obj (item-key x)
|
||||
(loop tree1
|
||||
(catenate-right (blacken b) pivot2 tree2)
|
||||
pivot1
|
||||
x
|
||||
(blacken a))
|
||||
(let* ((tree1 (catenate-left tree1 pivot1 (blacken a)))
|
||||
(tree1+ (catenate-left tree1 x (black-leaf)))
|
||||
(tree2 (catenate-right (blacken b) pivot2 tree2))
|
||||
(tree2+ (catenate-right (black-leaf) x tree2)))
|
||||
(values tree1
|
||||
tree1+
|
||||
(black (black-leaf) x (black-leaf))
|
||||
tree2+
|
||||
tree2))
|
||||
(loop (catenate-left tree1 pivot1 (blacken a))
|
||||
tree2
|
||||
x
|
||||
pivot2
|
||||
(blacken b)))))))
|
||||
(loop tree1
|
||||
(catenate-right (blacken b) pivot2 tree2)
|
||||
pivot1
|
||||
x
|
||||
(blacken a))
|
||||
(let* ((tree1 (catenate-left tree1 pivot1 (blacken a)))
|
||||
(tree1+ (catenate-left tree1 x (black-leaf)))
|
||||
(tree2 (catenate-right (blacken b) pivot2 tree2))
|
||||
(tree2+ (catenate-right (black-leaf) x tree2)))
|
||||
(values tree1
|
||||
tree1+
|
||||
(black (black-leaf) x (black-leaf))
|
||||
tree2+
|
||||
tree2))
|
||||
(loop (catenate-left tree1 pivot1 (blacken a))
|
||||
tree2
|
||||
x
|
||||
pivot2
|
||||
(blacken b)))))))
|
||||
|
||||
(define (catenate-left tree1 item tree2)
|
||||
(if item
|
||||
|
|
@ -379,14 +379,14 @@
|
|||
(define (left-tree tree depth)
|
||||
(let loop ((parent #f) (tree tree) (depth depth))
|
||||
(if (zero? depth)
|
||||
(values parent tree)
|
||||
(loop tree (left tree) (- depth 1)))))
|
||||
(values parent tree)
|
||||
(loop tree (left tree) (- depth 1)))))
|
||||
|
||||
(define (right-tree tree depth)
|
||||
(let loop ((parent #f) (tree tree) (depth depth))
|
||||
(if (zero? depth)
|
||||
(values parent tree)
|
||||
(loop tree (right tree) (- depth 1)))))
|
||||
(values parent tree)
|
||||
(loop tree (right tree) (- depth 1)))))
|
||||
|
||||
;;; Helper procedures for deleting and balancing
|
||||
|
||||
|
|
|
|||
|
|
@ -144,7 +144,7 @@
|
|||
(receive (mapping value)
|
||||
(mapping-intern mapping1 'd (lambda () 42))
|
||||
(list value (mapping-ref mapping 'd))))
|
||||
|
||||
|
||||
(test "mapping-update"
|
||||
4
|
||||
(mapping-ref mapping3 'b))
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@
|
|||
(test-group "(vector-without)"
|
||||
(define (check expected start end)
|
||||
(let ((v #(0 1 2 3 4)))
|
||||
(test expected (vector-without v start end))))
|
||||
(test expected (vector-without v start end))))
|
||||
(check #(0 1 2 3 4) 0 0)
|
||||
(check #() 0 5)
|
||||
(check #(1 2 3 4) 0 1)
|
||||
|
|
@ -46,24 +46,24 @@
|
|||
(test-group "(vector-edit adjacent-adds)"
|
||||
(let ((array (vector 0 1 2)))
|
||||
(test #(0 1 2 3 4)
|
||||
(vector-edit array
|
||||
(add 3 3)
|
||||
(add 3 4)))))
|
||||
(vector-edit array
|
||||
(add 3 3)
|
||||
(add 3 4)))))
|
||||
|
||||
(test-group "(vector-edit adjacent-drops)"
|
||||
(let ((array (vector 0 1 2 3 4 5)))
|
||||
(test #(0 1 2)
|
||||
(vector-edit array
|
||||
(drop 3 1)
|
||||
(drop 4 2)))))
|
||||
(vector-edit array
|
||||
(drop 3 1)
|
||||
(drop 4 2)))))
|
||||
|
||||
(test-group "(vector-edit alternating-add-drop)"
|
||||
(let ((array (vector 0 1 2 2 2 3 4 6 6 6 6 7 9)))
|
||||
(test #(0 1 2 3 4 5 6 7 8 9)
|
||||
(vector-edit array
|
||||
(drop 3 2)
|
||||
(add 7 5)
|
||||
(drop 8 3)
|
||||
(add 12 8)))))
|
||||
(vector-edit array
|
||||
(drop 3 2)
|
||||
(add 7 5)
|
||||
(drop 8 3)
|
||||
(add 12 8)))))
|
||||
|
||||
(test-end))
|
||||
|
|
@ -31,9 +31,9 @@
|
|||
(define (vector-without v start end)
|
||||
"Return a copy of vector `v' without the elements with indices [start, end)."
|
||||
(let* ((size (vector-length v))
|
||||
(gap-size (- end start))
|
||||
(new-size (- size gap-size))
|
||||
(result (make-vector new-size)))
|
||||
(gap-size (- end start))
|
||||
(new-size (- size gap-size))
|
||||
(result (make-vector new-size)))
|
||||
(vector-copy! result 0 v 0 start)
|
||||
(vector-copy! result start v end size)
|
||||
result))
|
||||
|
|
@ -63,14 +63,14 @@
|
|||
(vector-copy! r (+ o s) v o index)
|
||||
(vector-set! r (+ s index) e)
|
||||
(let ((skew (+ s 1)))
|
||||
(vector-edit-code v r index skew . rest))))
|
||||
(vector-edit-code v r index skew . rest))))
|
||||
((_ v r o s (drop i c) . rest)
|
||||
(let ((index i))
|
||||
(vector-copy! r (+ o s) v o index)
|
||||
(let* ((dropped c)
|
||||
(offset (+ index dropped))
|
||||
(skew (- s dropped)))
|
||||
(vector-edit-code v r offset skew . rest))))))
|
||||
(offset (+ index dropped))
|
||||
(skew (- s dropped)))
|
||||
(vector-edit-code v r offset skew . rest))))))
|
||||
|
||||
;; <> Optimize this by allowing one to supply more than one value in
|
||||
;; `add' sub-expressions so that adjacent values can be inserted
|
||||
|
|
@ -89,5 +89,5 @@
|
|||
(syntax-rules ()
|
||||
((_ v . rest)
|
||||
(let ((result (make-vector (+ (vector-length v)
|
||||
(vector-edit-total-skew 0 . rest)))))
|
||||
(vector-edit-total-skew 0 . rest)))))
|
||||
(vector-edit-code v result 0 0 . rest)))))
|
||||
Loading…
Add table
Reference in a new issue