Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding (srfi 146 hash)

Browse source
This commit is contained in:
Alex Shinn 2020-05-26 17:05:07 +09:00
parent 61680088d2
commit 11e0328fef
22 changed files with 3194 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
AUTHORS
View file

@ -20,6 +20,7 @@ The following distributed SRFIs use the reference implementations:
(srfi 134) is Shiro Kawai's implementation
(srfi 135) is Will Clinger's implementation
(srfi 139), (srfi 146), (srfi 154), (srfi 165) are Marc Nieper-Wißkirchen's implementations
(srfi 146 hash) is Arthur Gleckler's Hash Array Mapped Trie implementation
The benchmarks are based on the Racket versions of the classic
Gabriel benchmarks from

38
lib/scheme/mapping.sld Normal file
View file

@ -0,0 +1,38 @@
(define-library (scheme mapping)
(import (srfi 146))
(export mapping mapping-unfold
mapping/ordered mapping-unfold/ordered
mapping? mapping-contains? mapping-empty? mapping-disjoint?
mapping-ref mapping-ref/default mapping-key-comparator
mapping-adjoin mapping-adjoin!
mapping-set mapping-set!
mapping-replace mapping-replace!
mapping-delete mapping-delete! mapping-delete-all mapping-delete-all!
mapping-intern mapping-intern!
mapping-update mapping-update! mapping-update/default mapping-update!/default
mapping-pop mapping-pop!
mapping-search mapping-search!
mapping-size mapping-find mapping-count mapping-any? mapping-every?
mapping-keys mapping-values mapping-entries
mapping-map mapping-map->list mapping-for-each mapping-fold
mapping-filter mapping-filter!
mapping-remove mapping-remove!
mapping-partition mapping-partition!
mapping-copy mapping->alist alist->mapping alist->mapping!
alist->mapping/ordered alist->mapping/ordered!
mapping=? mapping<? mapping>? mapping<=? mapping>=?
mapping-union mapping-intersection mapping-difference mapping-xor
mapping-union! mapping-intersection! mapping-difference! mapping-xor!
make-mapping-comparator
mapping-comparator
mapping-min-key mapping-max-key
mapping-min-value mapping-max-value
mapping-key-predecessor mapping-key-successor
mapping-range= mapping-range< mapping-range> mapping-range<= mapping-range>=
mapping-range=! mapping-range<! mapping-range>! mapping-range<=! mapping-range>=!
mapping-split
mapping-catenate mapping-catenate!
mapping-map/monotone mapping-map/monotone!
mapping-fold/reverse
comparator?))

28
lib/scheme/mapping/hash.sld Normal file
View file

@ -0,0 +1,28 @@
(define-library (scheme mapping hash)
(import (srfi 146 hash))
(export
hashmap hashmap-unfold
hashmap? hashmap-contains? hashmap-empty? hashmap-disjoint?
hashmap-ref hashmap-ref/default hashmap-key-comparator
hashmap-adjoin hashmap-adjoin!
hashmap-set hashmap-set!
hashmap-replace hashmap-replace!
hashmap-delete hashmap-delete! hashmap-delete-all hashmap-delete-all!
hashmap-intern hashmap-intern!
hashmap-update hashmap-update! hashmap-update/default hashmap-update!/default
hashmap-pop hashmap-pop!
hashmap-search hashmap-search!
hashmap-size hashmap-find hashmap-count hashmap-any? hashmap-every?
hashmap-keys hashmap-values hashmap-entries
hashmap-map hashmap-map->list hashmap-for-each hashmap-fold
hashmap-filter hashmap-filter!
hashmap-remove hashmap-remove!
hashmap-partition hashmap-partition!
hashmap-copy hashmap->alist alist->hashmap alist->hashmap!
hashmap=? hashmap<? hashmap>? hashmap<=? hashmap>=?
hashmap-union hashmap-intersection hashmap-difference hashmap-xor
hashmap-union! hashmap-intersection! hashmap-difference! hashmap-xor!
make-hashmap-comparator
hashmap-comparator
comparator?))

367
lib/srfi/146/hamt-map-test.scm Normal file
View file

@ -0,0 +1,367 @@
;;;; HAMT Map Tests
;;; Copyright MMXV-MMXVII Arthur A. Gleckler. All rights reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
(define (make-string-set)
(set (make-comparator string? string=? string<? string-hash)))
(define (run-hamt-map-tests)
(define (assert-phm= phm alist)
(test-equal = (length alist) (phm/count phm))
(do-list (a alist)
(test-assert (phm/contains? phm (car a)))
(test-assert (= (cdr a) (phm/get phm (car a) #f)))))
(define (phm-random-test put remove transform)
(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))
(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)))))))))
(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 ((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)))))))
(define (phm-remove-non-existent-test remove transform)
(define (terrible-hash string) 0)
(let ((phm (remove (transform (make-phm string-hash string=?))
"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")))
(test-assert (= 1 (phm/count phm)))
(test-assert (phm/contains? phm "foo"))
(test-assert (not (phm/contains? phm "not-present")))))
(define (phm-collision-test put remove transform)
(define (sort-alist alist)
(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)))
(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)))
(assert-phm= phm alist)
(let ((phm-alist (phm->alist phm)))
(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))))))
(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))))
(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))))))))
(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)))))
(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)))
(test-assert (not (hamt/mutable? phm)))
(assert-phm= phm alist)))
(test-group "(persistent-hash-map make-phm phm/count)"
(let ((phm (make-phm string-hash string=? '(("a". 1) ("b" . 2)))))
(test-assert (= 2 (phm/count phm)))))
(test-group "(persistent-hash-map phm/empty?)"
(test-assert (phm/empty? (make-phm string-hash string=?)))
(test-assert (not (phm/empty? (make-phm string-hash string=? '(("a")))))))
(test-group "(persistent-hash-map random pure)"
(phm-random-test phm/put phm/remove (lambda (m) m)))
(test-group "(persistent-hash-map random mutate)"
(phm-random-test phm/put! phm/remove! phm/mutable))
(test-group "(persistent-hash-map random mixed)"
(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)))
(test-group "(persistent-hash-map remove-non-existent pure)"
(phm-remove-non-existent-test phm/remove (lambda (m) m)))
(test-group "(persistent-hash-map remove-non-existent mutate)"
(phm-remove-non-existent-test phm/remove! phm/mutable))
(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)))
(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/add-alist! phm alist)
(assert-phm= phm alist)))
(test-group "(persistent-hash-map collisions pure)"
(phm-collision-test phm/put phm/remove (lambda (m) m)))
(test-group "(persistent-hash-map collisions mutate)"
(phm-collision-test phm/put! phm/remove! phm/mutable))
(test-group "(persistent-hash-map big-hash)"
"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)))))
(let* ((alist '(("foo" . 1) ("bar" . 2) ("baz" . 3) ("bat" . 4)
("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)))
(assert-phm= phm alist)
(let ((phm-minus-baz (phm/remove phm "baz")))
(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-group "(persistent-hash-map pure-mutate-interference)"
"Test that mutating and pure operations interact with each other
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)))
(phm/put! m4 "foo" 8)
(assert-phm= m0 '())
(assert-phm= m1 a1)
(assert-phm= m2 a4)
(assert-phm= m3 a8)
(assert-phm= m4 a8)
(assert-phm= m5 a5)
(assert-phm= m6 a7)
(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))))
(test-group "(persistent-hash-map phm/data)"
(let* ((alist '(("a" . 1) ("b" . 2) ("c" . 3)))
(data (phm/data (make-phm string-hash string=? alist))))
(test-assert (equal? (map cdr alist)
(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))))
(test-assert (equal? (map car alist)
(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/for-each (lambda (k d) (set! accumulator
(cons (cons k d) accumulator)))
phm)
(test-assert (equal? alist (sort-alist accumulator)))))
(test-group "(persistent-hash-map phm/replace)"
(persistent-hash-map phm/replace (lambda (m) m)))
(test-group "(persistent-hash-map phm/replace!)"
(persistent-hash-map phm/replace! phm/mutable))
(test-group "(persistent-hash-map immutable-replace)"
(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))))
(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)))))))
(test-group "(persistent-hash-map phm/mutable?)"
(let ((phm (make-phm string-hash string=?)))
(test-assert (not (phm/mutable? phm)))
(test-assert (phm/mutable? (phm/mutable phm)))
(test-assert (not (phm/mutable? (phm/immutable (phm/mutable phm)))))))
(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
(let* ((alist '(("foo" . 1) ("bar" . 2)))
(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)))
(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")))
(assert-phm= phm-2 '(("foo" . 1) ("bar" . 2) ("baz" . 3)))
(assert-phm= phm-3 '(("bar" . 2) ("baz" . 3)))
(assert-phm= phm-4 '(("baz" . 3)))
(assert-phm= phm-5 '())
(test-assert (= 5 (hamt-max-depth phm-2)))
(test-assert (= 4 (hamt-max-depth phm-3)))
(test-assert (= 1 (hamt-max-depth phm-4)))
(test-assert (= 1 (hamt-max-depth phm-5)))))
(test-end))

27
lib/srfi/146/hamt-map-test.sld Normal file
View file

@ -0,0 +1,27 @@
(define-library (srfi 146 hamt-map-test)
(import
(scheme base)
(chibi test)
(srfi 146 hamt)
(srfu 146 hamt-map)
(srfi 146 hamt-misc)
(only (srfi 1) alist-delete fold)
(only (srfi 27) random-integer)
(only (srfi 113)
set
set-adjoin!
set-delete!
set-for-each)
(only (srfi 125)
hash-table->alist
hash-table-keys
hash-table-delete!
hash-table-for-each
hash-table-set!
hash-table-size
string-hash)
(only (srfi 128) make-comparator)
(only (srfi 132) list-sort)
(only (srfi 151) bit-count))
(export run-hamt-map-tests)
(include "hamt-map-test.scm"))

245
lib/srfi/146/hamt-map.scm Normal file
View file

@ -0,0 +1,245 @@
;;;; Persistent Hash Map
;;; Copyright MMXV-MMXVII Arthur A. Gleckler. All rights reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
;;; Public protocol (API)
;; (phm? datum)
;; Return true iff `datum' is a persistent hash map.
;; (make-phm hash = [alist])
;; Return a new immutable persistent hash map that uses the `hash'
;; procedure to hash its keys and `=' to compare them. If `alist'
;; is supplied, include all its keys and data in the result. Later
;; occurrences of the same key override earlier ones.
;; (phm/count phm)
;; Return the number of elements in `phm'.
;; (phm/empty? phm)
;; Return true iff `phm' is empty.
;; (phm/immutable phm)
;; (phm/immutable phm replace)
;; Return a PHM equivalent to `phm', but that is immutable. Even if
;; `phm' is mutable, no change to it will affect the returned one.
;; If `replace' is supplied, replace the datum associated with each
;; key whose value has been modified since the PHM was made mutable
;; with the result of calling `replace' on that key and datum. This
;; is useful for converting PHSs (sets) stored as values in a PHM
;; back into immutable ones when the containing PHM is made
;; immutable.
;; (phm/mutable phm)
;; Return a PHM equivalent to `phm', but that is mutable. If `phm'
;; was immutable, no change to the returned PHM will affect `phm'.
;; (phm/mutable? phm)
;; Return true iff `phm' is mutable.
;; (phm/put phm key datum)
;; Return a PHM equivalent to `phm' except that `datum' is at `key'.
;; (phm/put! phm key datum)
;; Return a PHM equivalent to `phm' except that `datum' is at `key'.
;; Modify `phm', which must be mutable, in the process.
;; (phm/replace phm key replace)
;; Return a PHM equivalent to `phm' except that whatever value is at
;; `key' has been replaced by `(replace datum)', or `(replace
;; hamt-null)' if there was no value there already. If `replace'
;; returns `hamt-null', the value is removed.
;; (phm/replace! phm key replace)
;; Return a PHM equivalent to `phm' except that whatever value is at
;; `key' has been replaced by `(replace datum)', or `(replace
;; hamt-null)' if there was no value there already. If `replace'
;; returns `hamt-null', the value is removed. Modify `phm', which
;; must be mutable, in the process.
;; (phm/get phm key [default])
;; Return the datum stored at `key' in `phm'. If none is present,
;; return `default' if it was supplied, or #f if it was not.
;; (phm/contains? phm key)
;; Return true iff `phm' has a datum at `key'.
;; (phm/remove phm key)
;; Return a PHM equivalent to `phm' except that there is no datum at
;; `key'.
;; (phm/remove! phm key)
;; Return a PHM equivalent to `phm' except that there is no datum at
;; `key'. Modify `phm', which must be mutable, in the process.
;; (phm/add-alist phm alist)
;; Return a PHM equivalent to `phm' except that, for every pair in
;; `alist', the datum in its cdr is stored in the new PHM at the key
;; in its car. Later occurrences of the same key override earlier
;; ones.
;; (phm/add-alist! phm alist)
;; Return a PHM equivalent to `phm' except that, for every pair in
;; `alist', the datum in its cdr is stored in the new PHM at the key
;; in its car. Later occurrences of the same key override earlier
;; ones. Modify `phm', which must be mutable, in the process.
;; (phm->alist phm)
;; Return an alist mapping the keys in `phm' to their values.
;; (phm/keys phm)
;; Return a list of the keys in `phm'.
;; (phm/for-each procedure phm)
;; Run `procedure' on each key and datum in `phm'.
;;; Implementation of public protocol (API)
(define (phm? datum)
(and (hash-array-mapped-trie? datum)
(hamt/payload? datum)))
(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)))))
(define make-phm
(case-lambda
((hash =) (make-phm-inner hash = '()))
((hash = alist) (make-phm-inner hash = alist))))
(define (phm/count phm)
(assert (phm? phm))
(hamt/count phm))
(define (phm/empty? phm)
(assert (phm? phm))
(hamt/empty? phm))
(define phm/immutable
(case-lambda
((phm)
(assert (phm? phm))
(hamt/immutable phm))
((phm replace)
(assert (phm? phm))
(hamt/immutable phm replace))))
(define (phm/mutable phm)
(assert (phm? phm))
(hamt/mutable phm))
(define (phm/mutable? phm)
(assert (phm? phm))
(hamt/mutable? phm))
(define (phm/put phm key datum)
(assert (phm? phm))
(hamt/put phm key datum))
(define (phm/put! phm key datum)
(assert (phm? phm))
(hamt/put! phm key datum))
(define (phm/replace phm key replace)
(assert (phm? phm))
(hamt/replace phm key replace))
(define (phm/replace! phm key replace)
(assert (phm? phm))
(hamt/replace! phm key replace))
(define (phm/get-inner phm key default)
(assert (phm? phm))
(let ((result (hamt-fetch phm key)))
(if (hamt-null? result)
default
result)))
(define phm/get
(case-lambda
((phm key) (phm/get-inner phm key #f))
((phm key default) (phm/get-inner phm key default))))
(define (phm/contains? phm key)
(assert (phm? phm))
(not (hamt-null? (hamt-fetch phm key))))
(define (phm/remove phm key)
(assert (phm? phm))
(phm/put phm key hamt-null))
(define (phm/remove! phm key)
(assert (phm? phm))
(assert (hamt/mutable? phm))
(phm/put! phm key hamt-null))
(define (phm/add-alist phm alist)
(assert (phm? phm))
(fold (lambda (a phm) (phm/put phm (car a) (cdr a))) phm alist))
(define (phm/add-alist! phm alist)
(assert (phm? phm))
(do-list (a alist)
(phm/put! phm (car a) (cdr a)))
phm)
(define (phm->alist phm)
(assert (phm? phm))
(hamt->list phm cons))
(define (phm/data phm)
(assert (phm? phm))
(hamt->list phm (lambda (k d) d)))
(define (phm/keys phm)
(assert (phm? phm))
(hamt->list phm (lambda (k d) k)))
(define (phm/for-each procedure phm)
(assert (phm? phm))
(hamt/for-each procedure phm))

28
lib/srfi/146/hamt-map.sld Normal file
View file

@ -0,0 +1,28 @@
(define-library (srfi 146 hamt-map)
(import
(scheme base)
(scheme case-lambda)
(only (srfi 1) fold)
(srfi 16)
(srfi 146 hamt)
(srfi 146 hamt-misc))
(export
make-phm phm?
phm->alist
phm/add-alist phm/add-alist!
phm/contains?
phm/count
phm/empty?
phm/for-each
phm/get
phm/immutable
phm/keys
phm/mutable phm/mutable?
phm/put
phm/put!
phm/remove phm/remove!
phm/replace phm/replace!
;; This is only needed by tests:
phm/data)
(include "hamt-map.scm"))

39
lib/srfi/146/hamt-misc-test.scm Normal file
View file

@ -0,0 +1,39 @@
;;;; Tests of utilities used by HAMT
;;; Copyright MMIV-MMXVII Arthur A. Gleckler. All rights reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
(define (run-hamt-misc-tests)
(test-begin "hamt-misc")
(test-group "(do-list)"
(let ((index-accumulator '())
(value-accumulator '())
(all-values '(1 2 3 4 5)))
(do-list (value all-values)
(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)))
(test '(4 3 2 1 0) index-accumulator)))
(test-end))

4
lib/srfi/146/hamt-misc-test.sld Normal file
View file

@ -0,0 +1,4 @@
(define-library (srfi 146 hamt-misc-test)
(import (scheme base) (chibi test) (srfi 146 hamt-misc))
(export run-hamt-misc-tests)
(include "hamt-misc-test.scm"))

59
lib/srfi/146/hamt-misc.scm Normal file
View file

@ -0,0 +1,59 @@
;;;; Utilities used by HAMT
;;; Copyright MMIV-MMXVII Arthur A. Gleckler. All rights reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
(define-syntax assert
(syntax-rules ()
((_ (operator argument ...))
(unless (operator argument ...)
(error "Assertion failed:"
'(operator argument ...)
(list 'operator argument ...))))
((_ expression)
(unless expression
(error "Assertion failed:" 'expression)))))
(define-syntax do-list
(syntax-rules ()
((_ (variable list) body ...)
(do ((remaining list (cdr remaining)))
((null? remaining))
(let ((variable (car remaining)))
body ...)))
((_ (element-variable index-variable list) body ...)
(do ((remaining list (cdr remaining))
(index-variable 0 (+ index-variable 1)))
((null? remaining))
(let ((element-variable (car remaining)))
body ...)))))
(define string-comparator
(make-comparator string? string=? #f string-hash))
(define (make-string-hash-table)
(make-hash-table string-comparator))
(define (with-output-to-string thunk)
(parameterize ((current-output-port (open-output-string)))
(thunk)
(get-output-string (current-output-port))))

10
lib/srfi/146/hamt-misc.sld Normal file
View file

@ -0,0 +1,10 @@
(define-library (srfi 146 hamt-misc)
(import
(scheme base)
(scheme case-lambda)
(only (srfi 125) make-hash-table string-hash)
(only (srfi 128) make-comparator))
(export assert do-list
make-string-hash-table
with-output-to-string)
(include "hamt-misc.scm"))

36
lib/srfi/146/hamt-test.scm Normal file
View file

@ -0,0 +1,36 @@
;;;; HAMT Core Tests
;;; Copyright MMXV-MMXVII Arthur A. Gleckler. All rights reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
;;; HAMT Core Tests
(define (run-hamt-core-tests)
(test-begin "hamt-core")
(test-group "(hash-array-mapped-trie fragment->mask)"
(test-equal = 0 (fragment->mask 0))
(test-equal = 1 (fragment->mask 1))
(test-equal = 3 (fragment->mask 2))
(test-equal = 7 (fragment->mask 3)))
(test-end))

6
lib/srfi/146/hamt-test.sld Normal file
View file

@ -0,0 +1,6 @@
(define-library (srfi 146 hamt-test)
(import (scheme base)
(chibi test)
(only (srfi 146 hamt) fragment->mask))
(export run-hamt-core-tests)
(include "hamt-test.scm"))

913
lib/srfi/146/hamt.scm Normal file
View file

@ -0,0 +1,913 @@
;;;; Persistent Hash Map
;;; Copyright MMXV-MMXVII Arthur A. Gleckler. All rights reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
;;; Naming conventions:
;; =: procedure that compares keys
;; c: bit string representing the non-leaf children present
;; immediately below a sparse node
;; d: datum, or `hamt-null' to represent absence or deletion
;; dp: procedure that takes an existing datum and returns the datum
;; that should replace it. Either may be `hamt-null'. When
;; there is no payload, `hamt-null' is passed.
;; h: hash
;; hp: procedure that computes hash
;; k: key that maps to a particular datum
;; l: bit string representing the leaves present below a sparse node
;; n: node (of type `collision', `narrow', or `wide')
;;; Background
;; See these papers:
;; - Ideal Hash Trees, Phil Bagwell, 2000,
;; <https://infoscience.epfl.ch/record/64398/files/idealhashtrees.pdf>
;; - Optimizing Hash-Array Mapped Tries for Fast and Lean Immutable
;; JVM Collections, Steinforder & Vinju, 2015,
;; <http://michael.steindorfer.name/publications/oopsla15.pdf>
;; Also, see Clojure's persistent hash maps, which support both
;; mutable ("transient") and persistent modes.
;;; Design
;; According to Phil Bagwell's paper, "Occasionally an entire 32 bit
;; hash may be consumed and a new one must be computed to
;; differentiate the two keys." Later, he says "The hash function was
;; tailored to give a 32 bit hash. The algorithm requires that the
;; hash can be extended to an arbitrary number of bits. This was
;; accomplished by rehashing the key combined with an integer
;; representing the trie level, zero being the root. Hence if two
;; keys do give the same initial hash then the rehash has a
;; probability of 1 in 2^32 of a further collision." However, I
;; implement collision lists instead because they will be rarely used
;; when hash functions are good, but work well when they're not, as in
;; the case of MIT Scheme's `string-hash'.
(define hamt-hash-slice-size 5)
(define hamt-hash-size
(let ((word-size fx-width))
(- word-size
(remainder word-size hamt-hash-slice-size))))
(define hamt-hash-modulus (expt 2 hamt-hash-size))
(define hamt-bucket-size (expt 2 hamt-hash-slice-size))
(define hamt-null (cons 'hamt 'null))
(define-record-type hash-array-mapped-trie
(%make-hamt = count hash mutable? payload? root)
hash-array-mapped-trie?
(= hamt/=)
(count hamt/count set-hamt/count!)
(hash hamt/hash)
(mutable? hamt/mutable?)
(payload? hamt/payload?)
(root hamt/root set-hamt/root!))
(define (make-hamt = hash payload?)
(%make-hamt = 0 hash #f payload? (make-empty-narrow)))
(define-record-type collision
(make-collision entries hash)
collision?
(entries collision/entries)
(hash collision/hash))
(define-record-type narrow
(make-narrow array children leaves)
narrow?
(array narrow/array)
(children narrow/children)
(leaves narrow/leaves))
(define-record-type wide
(make-wide array children leaves)
wide?
(array wide/array)
(children wide/children set-wide/children!)
(leaves wide/leaves set-wide/leaves!))
(define (hamt/empty? hamt)
(zero? (hamt/count hamt)))
(define (hamt/immutable-inner hamt replace)
"Return a HAMT equivalent to `hamt', but that is immutable. Even if
`hamt' is mutable, no change to it will affect the returned HAMT. If
`hamt' has payloads, replace each datum in a wide node with what
`replace' returns when passed the key and corresponding datum. This
is useful for converting HAMT sets stored as values in a HAMT map back
to immutable ones when the containing map is made immutable. (Only
data in wide nodes will have been modified since the change to mutable
happened.)"
(if (hamt/mutable? hamt)
(let ((payload? (hamt/payload? hamt)))
(%make-hamt (hamt/= hamt)
(hamt/count hamt)
(hamt/hash hamt)
#f
payload?
(->immutable (hamt/root hamt) payload? replace)))
hamt))
(define hamt/immutable
(case-lambda
((hamt) (hamt/immutable-inner hamt (lambda (k d) d)))
((hamt replace) (hamt/immutable-inner hamt replace))))
(define (hamt/mutable hamt)
(if (hamt/mutable? hamt)
hamt
(%make-hamt (hamt/= hamt)
(hamt/count hamt)
(hamt/hash hamt)
#t
(hamt/payload? hamt)
(hamt/root hamt))))
(define (hamt/replace hamt key dp)
(assert (not (hamt/mutable? hamt)))
(let*-values (((payload?) (hamt/payload? hamt))
((root) (hamt/root hamt))
((==) (hamt/= hamt))
((hp) (hamt/hash hamt))
((hash) (hash-bits hp key))
((change node) (modify-pure hamt root 0 dp hash key)))
(if (eq? node root)
hamt
(let ((count (+ (hamt/count hamt) change)))
(%make-hamt == count hp #f payload? node)))))
(define (hamt/put hamt key datum)
(hamt/replace hamt key (lambda (x) datum)))
(define (hamt/replace! hamt key dp)
(assert (hamt/mutable? hamt))
(let*-values (((root) (hamt/root hamt))
((hp) (hamt/hash hamt))
((hash) (hash-bits hp key))
((change node) (mutate hamt root 0 dp hash key)))
(unless (zero? change)
(set-hamt/count! hamt (+ (hamt/count hamt) change)))
(unless (eq? node root)
(set-hamt/root! hamt node))
hamt))
(define (hamt/put! hamt key datum)
(hamt/replace! hamt key (lambda (x) datum)))
(define (make-empty-narrow)
(make-narrow (vector) 0 0))
(define (hamt-null? n)
(eq? n hamt-null))
(define (collision-single-leaf? n)
(let ((elements (collision/entries n)))
(and (not (null? elements))
(null? (cdr elements)))))
(define (narrow-single-leaf? n)
(and (zero? (narrow/children n))
(= 1 (bit-count (narrow/leaves n)))))
(define (wide-single-leaf? n)
(and (zero? (wide/children n))
(= 1 (bit-count (wide/leaves n)))))
(define (hash-bits hp key)
(remainder (hp key) hamt-hash-modulus))
(define (next-set-bit i start end)
(let ((index (first-set-bit (bit-field i start end))))
(and (not (= index -1))
(+ index start))))
(define (narrow->wide n payload?)
(let* ((c (narrow/children n))
(l (narrow/leaves n))
(stride (leaf-stride payload?))
(a-in (narrow/array n))
(a-out (make-vector (* stride hamt-bucket-size))))
(let next-leaf ((start 0) (count 0))
(let ((i (next-set-bit l start hamt-bucket-size)))
(when i
(let ((j (* stride i)))
(vector-set! a-out j (vector-ref a-in count))
(when payload?
(vector-set! a-out (+ j 1) (vector-ref a-in (+ count 1)))))
(next-leaf (+ i 1) (+ stride count)))))
(let next-child ((start 0) (offset (* stride (bit-count l))))
(let ((i (next-set-bit c start hamt-bucket-size)))
(when i
(vector-set! a-out (* stride i) (vector-ref a-in offset))
(next-child (+ i 1) (+ offset 1)))))
(make-wide a-out c l)))
(define (->immutable n payload? replace)
"Convert `n' and its descendants into `collision' or `narrow' nodes.
Stop at the first `collision' node or `narrow' node on each path. If
`payload?' is true, then expect data, not just keys, and replace each
datum in a wide node with what `replace' returns when passed the key
and corresponding datum."
(cond ((collision? n) n)
((narrow? n) n)
((wide? n)
(let* ((c (wide/children n))
(l (wide/leaves n))
(stride (leaf-stride payload?))
(l-count (bit-count l))
(a-in (wide/array n))
(a-out (make-vector
(+ (* stride l-count) (bit-count c)))))
(let next-leaf ((start 0) (count 0))
(let ((i (next-set-bit l
start
hamt-bucket-size)))
(when i
(let* ((j (* stride i))
(key (vector-ref a-in j)))
(vector-set! a-out count key)
(when payload?
(vector-set! a-out
(+ count 1)
(replace
key
(vector-ref a-in (+ j 1))))))
(next-leaf (+ i 1) (+ stride count)))))
(let next-child ((start 0) (offset (* stride l-count)))
(let ((i (next-set-bit c
start
hamt-bucket-size)))
(when i
(vector-set! a-out
offset
(->immutable (vector-ref a-in (* stride i))
payload?
replace))
(next-child (+ i 1) (+ offset 1)))))
(make-narrow a-out c l)))
(else (error "Unexpected type of node."))))
(define (hash-fragment shift hash)
(bit-field hash shift (+ shift hamt-hash-slice-size)))
(define (fragment->mask fragment)
(- (expt 2 fragment) 1))
(define (mutate hamt n shift dp h k)
(cond ((collision? n) (modify-collision hamt n shift dp h k))
((narrow? n)
(modify-wide hamt
(narrow->wide n (hamt/payload? hamt))
shift
dp
h
k))
((wide? n) (modify-wide hamt n shift dp h k))
(else (error "Unknown HAMT node type." n))))
(define (modify-wide hamt n shift dp h k)
(let ((fragment (hash-fragment shift h)))
(cond ((bit-set? fragment (wide/children n))
(modify-wide-child hamt n shift dp h k))
((bit-set? fragment (wide/leaves n))
(modify-wide-leaf hamt n shift dp h k))
(else
(let ((d (dp hamt-null)))
(if (hamt-null? d)
(values 0 n)
(modify-wide-new hamt n shift d h k)))))))
(define (modify-wide-child hamt n shift dp h k)
(let*-values (((fragment) (hash-fragment shift h))
((array) (wide/array n))
((payload?) (hamt/payload? hamt))
((stride) (leaf-stride payload?))
((i) (* stride fragment))
((child) (vector-ref array i))
((change new-child)
(mutate hamt
child
(+ shift hamt-hash-slice-size)
dp
h
k)))
(define (coalesce key datum)
(vector-set! array i key)
(when payload?
(vector-set! array (+ i 1) datum))
(set-wide/children! n (copy-bit fragment (wide/children n) #f))
(set-wide/leaves! n (copy-bit fragment (wide/leaves n) #t))
(values change n))
(define (replace)
(vector-set! array i new-child)
(values change n))
(cond ((eq? new-child child) (values change n))
((hamt-null? new-child)
(error "Child cannot become null." n))
((collision? new-child)
(if (collision-single-leaf? new-child)
(let ((a (car (collision/entries new-child))))
(if payload?
(coalesce (car a) (cdr a))
(coalesce a #f)))
(replace)))
((wide? new-child)
(if (wide-single-leaf? new-child)
(let ((a (wide/array new-child))
(j (* stride (next-set-bit (wide/leaves new-child)
0
hamt-bucket-size))))
(coalesce (vector-ref a j)
(and payload? (vector-ref a (+ j 1)))))
(replace)))
((narrow? new-child)
(replace))
(else (error "Unexpected type of child node.")))))
(define (modify-wide-leaf hamt n shift dp h k)
(let* ((fragment (hash-fragment shift h))
(array (wide/array n))
(payload? (hamt/payload? hamt))
(stride (leaf-stride payload?))
(i (* stride fragment))
(key (vector-ref array i)))
(if ((hamt/= hamt) k key)
(let* ((existing (if payload? (vector-ref array (+ i 1)) hamt-null))
(d (dp existing)))
(cond ((hamt-null? d)
(vector-set! array i #f)
(when payload? (vector-set! array (+ i 1) #f))
(set-wide/leaves! n (copy-bit fragment (wide/leaves n) #f))
(values -1 n))
(else
(when payload? (vector-set! array (+ i 1) d))
(values 0 n))))
(let ((d (dp hamt-null)))
(if (hamt-null? d)
(values 0 n)
(add-wide-leaf-key hamt n shift d h k))))))
(define (add-wide-leaf-key hamt n shift d h k)
(define payload? (hamt/payload? hamt))
(define make-entry
(if payload? cons (lambda (k d) k)))
(let* ((fragment (hash-fragment shift h))
(array (wide/array n))
(stride (leaf-stride payload?))
(i (* stride fragment))
(key (vector-ref array i))
(hash (hash-bits (hamt/hash hamt) key))
(datum (and payload? (vector-ref array (+ i 1)))))
(vector-set! array
i
(if (= h hash)
(make-collision (list (make-entry k d)
(make-entry key datum))
h)
(make-narrow-with-two-keys
payload?
(+ shift hamt-hash-slice-size)
h
k
d
hash
key
datum)))
(when payload?
(vector-set! array (+ i 1) #f))
(set-wide/children! n (copy-bit fragment (wide/children n) #t))
(set-wide/leaves! n (copy-bit fragment (wide/leaves n) #f))
(values 1 n)))
(define (modify-wide-new hamt n shift d h k)
(let* ((fragment (hash-fragment shift h))
(array (wide/array n))
(payload? (hamt/payload? hamt))
(stride (leaf-stride payload?))
(i (* stride fragment)))
(vector-set! array i k)
(when payload?
(vector-set! array (+ i 1) d))
(set-wide/leaves! n (copy-bit fragment (wide/leaves n) #t))
(values 1 n)))
(define (make-narrow-with-two-keys payload? shift h1 k1 d1 h2 k2 d2)
(define (two-leaves f1 k1 d1 f2 k2 d2)
(make-narrow
(if payload?
(vector k1 d1 k2 d2)
(vector k1 k2))
0
(copy-bit f2 (copy-bit f1 0 #t) #t)))
(assert (not (= h1 h2)))
(let ((f1 (hash-fragment shift h1))
(f2 (hash-fragment shift h2)))
(cond ((= f1 f2)
(make-narrow
(vector (make-narrow-with-two-keys payload?
(+ shift hamt-hash-slice-size)
h1
k1
d1
h2
k2
d2))
(copy-bit f1 0 #t)
0))
((< f1 f2)
(two-leaves f1 k1 d1 f2 k2 d2))
(else
(two-leaves f2 k2 d2 f1 k1 d1)))))
(define (modify-pure hamt n shift dp h k)
(cond ((collision? n) (modify-collision hamt n shift dp h k))
((narrow? n) (modify-narrow hamt n shift dp h k))
((wide? n) (error "Should have been converted to narrow before here."))
(else (error "Unknown HAMT node type." n))))
(define (lower-collision hamt n shift dp h k)
"If we try to add a key to a collision but it has a different hash
than the collision's elements, add it to a narrow above the collision
instead. Add as many levels of child-only narrows as needed to reach
the point where the hash fragments differ. This is guaranteed to
happen at some level because we're only called when the full hashes
differ."
(let ((collision-hash (collision/hash n))
(d (dp hamt-null)))
(if (hamt-null? d)
(values 0 n)
(values
1
(let descend ((shift shift))
(let ((collision-fragment (hash-fragment shift collision-hash))
(leaf-fragment (hash-fragment shift h)))
(if (= collision-fragment leaf-fragment)
(let ((child (descend (+ shift hamt-hash-slice-size))))
(make-narrow
(vector child)
(copy-bit collision-fragment 0 #t)
0))
(make-narrow
(if (hamt/payload? hamt)
(vector k d n)
(vector k n))
(copy-bit collision-fragment 0 #t)
(copy-bit leaf-fragment 0 #t)))))))))
(define (modify-collision hamt n shift dp h k)
(if (= h (collision/hash n))
(let ((payload? (hamt/payload? hamt)))
(let next ((entries (collision/entries n))
(checked '()))
(if (null? entries)
(let ((d (dp hamt-null)))
(if (hamt-null? d)
(values 0 n)
(values 1
(make-collision (if payload?
(cons (cons k d) checked)
(cons k checked))
h))))
(let* ((entry (car entries))
(key (if payload? (car entry) entry)))
(if ((hamt/= hamt) k key)
(let* ((existing (if payload? (cdr entry) hamt-null))
(d (dp existing))
(delete? (hamt-null? d))
(others (append checked (cdr entries))))
(values
(if delete? -1 0)
(make-collision (cond (delete? others)
(payload? (cons (cons k d) others))
(else (cons k others)))
h)))
(next (cdr entries)
(cons (car entries) checked)))))))
(lower-collision hamt n shift dp h k)))
;; If we're storing "payloads," i.e. a datum to go with each key, we
;; must reserve two spots for each key in each vector. Otherwise, we
;; need only one.
(define (leaf-stride payload?)
(if payload? 2 1))
(define (narrow-child-index l c mask payload?)
(+ (* (leaf-stride payload?) (bit-count l))
(bit-count (bitwise-and c mask))))
(define (narrow-leaf-index l mask payload?)
(* (leaf-stride payload?) (bit-count (bitwise-and l mask))))
(define (modify-narrow hamt n shift dp h k)
(let ((fragment (hash-fragment shift h)))
(cond ((bit-set? fragment (narrow/children n))
(modify-narrow-child hamt n shift dp h k))
((bit-set? fragment (narrow/leaves n))
(modify-narrow-leaf hamt n shift dp h k))
(else
(let ((d (dp hamt-null)))
(if (hamt-null? d)
(values 0 n)
(modify-narrow-new hamt n shift d h k)))))))
(define (modify-narrow-child hamt n shift dp h k)
(let*-values (((fragment) (hash-fragment shift h))
((mask) (fragment->mask fragment))
((c) (narrow/children n))
((l) (narrow/leaves n))
((array) (narrow/array n))
((payload?) (hamt/payload? hamt))
((child-index)
(narrow-child-index l c mask payload?))
((child) (vector-ref array child-index))
((change new-child)
(modify-pure hamt
child
(+ shift hamt-hash-slice-size)
dp
h
k)))
(define (coalesce key datum)
(let ((leaf-index (narrow-leaf-index l mask payload?)))
(values change
(make-narrow (if payload?
(vector-edit array
(add leaf-index key)
(add leaf-index datum)
(drop child-index 1))
(vector-edit array
(add leaf-index key)
(drop child-index 1)))
(copy-bit fragment c #f)
(copy-bit fragment l #t)))))
(define (replace)
(values change
(make-narrow (vector-replace-one array child-index new-child)
c
l)))
(cond ((eq? new-child child) (values 0 n))
((hamt-null? new-child)
(error "Child cannot become null." n))
((collision? new-child)
(if (collision-single-leaf? new-child)
(let ((a (car (collision/entries new-child))))
(if payload?
(coalesce (car a) (cdr a))
(coalesce a #f)))
(replace)))
((narrow? new-child)
(if (narrow-single-leaf? new-child)
(let ((a (narrow/array new-child)))
(coalesce (vector-ref a 0)
(and payload? (vector-ref a 1))))
(replace)))
((wide? new-child)
(error "New child should be collision or narrow."))
(else (error "Unexpected type of child node.")))))
(define (modify-narrow-leaf hamt n shift dp h k)
(let* ((fragment (hash-fragment shift h))
(mask (fragment->mask fragment))
(c (narrow/children n))
(l (narrow/leaves n))
(array (narrow/array n))
(payload? (hamt/payload? hamt))
(stride (leaf-stride payload?))
(leaf-index (narrow-leaf-index l mask payload?))
(key (vector-ref array leaf-index)))
(if ((hamt/= hamt) k key)
(let* ((existing (if payload?
(vector-ref array (+ leaf-index 1))
hamt-null))
(d (dp existing)))
(cond ((hamt-null? d)
(values -1
(make-narrow (vector-without array
leaf-index
(+ leaf-index stride))
c
(copy-bit fragment l #f))))
(payload?
(values
0
(make-narrow (vector-replace-one array (+ leaf-index 1) d)
c
l)))
(else (values 0 n))))
(let ((d (dp hamt-null)))
(if (hamt-null? d)
(values 0 n)
(add-narrow-leaf-key hamt n shift d h k))))))
(define (add-narrow-leaf-key hamt n shift d h k)
(define payload? (hamt/payload? hamt))
(define make-entry
(if payload? cons (lambda (k d) k)))
(let* ((fragment (hash-fragment shift h))
(mask (fragment->mask fragment))
(c (narrow/children n))
(l (narrow/leaves n))
(array (narrow/array n))
(payload? (hamt/payload? hamt))
(stride (leaf-stride payload?))
(leaf-index (narrow-leaf-index l mask payload?))
(key (vector-ref array leaf-index))
(child-index (narrow-child-index l c mask payload?))
(hash (hash-bits (hamt/hash hamt) key))
(datum (and payload? (vector-ref array (+ leaf-index 1)))))
(values 1
(make-narrow (if (= h hash)
(vector-edit
array
(drop leaf-index stride)
(add child-index
(make-collision (list (make-entry k d)
(make-entry key datum))
h)))
(vector-edit
array
(drop leaf-index stride)
(add child-index
(make-narrow-with-two-keys
payload?
(+ shift hamt-hash-slice-size)
h
k
d
hash
key
datum))))
(copy-bit fragment c #t)
(copy-bit fragment l #f)))))
(define (modify-narrow-new hamt n shift d h k)
(let* ((fragment (hash-fragment shift h))
(mask (fragment->mask fragment))
(c (narrow/children n))
(l (narrow/leaves n))
(array (narrow/array n))
(payload? (hamt/payload? hamt))
(leaf-index (narrow-leaf-index l mask payload?))
(delete? (hamt-null? d)))
(values 1
(make-narrow (if payload?
(vector-edit array
(add leaf-index k)
(add leaf-index d))
(vector-edit array
(add leaf-index k)))
c
(copy-bit fragment l #t)))))
(define (hamt-fetch hamt key)
"Fetch datum from `hamt' at `key'. Return `hamt-null' if the key is
not present. If `hamt' stores no payloads, return the symbol
`present' if the key is present."
(let ((h (hash-bits (hamt/hash hamt) key))
(payload? (hamt/payload? hamt)))
(let descend ((n (hamt/root hamt))
(shift 0))
(cond ((collision? n)
(let ((entries (collision/entries n))
(key= (hamt/= hamt)))
(if payload?
(cond ((assoc key entries key=) => cdr)
(else hamt-null))
(if (find-tail (lambda (e) (key= key e)) entries)
'present
hamt-null))))
((narrow? n)
(let ((array (narrow/array n))
(c (narrow/children n))
(l (narrow/leaves n))
(fragment (hash-fragment shift h)))
(cond ((bit-set? fragment c)
(let* ((mask (fragment->mask fragment))
(child-index (narrow-child-index
l
c
mask
(hamt/payload? hamt))))
(descend (vector-ref array child-index)
(+ shift hamt-hash-slice-size))))
((bit-set? fragment l)
(let* ((mask (fragment->mask fragment))
(leaf-index
(narrow-leaf-index l mask (hamt/payload? hamt)))
(k (vector-ref array leaf-index)))
(if ((hamt/= hamt) k key)
(if payload?
(vector-ref array (+ leaf-index 1))
'present)
hamt-null)))
(else hamt-null))))
((wide? n)
(let ((array (wide/array n))
(stride (leaf-stride (hamt/payload? hamt)))
(c (wide/children n))
(l (wide/leaves n))
(i (hash-fragment shift h)))
(cond ((bit-set? i c)
(descend (vector-ref array (* stride i))
(+ shift hamt-hash-slice-size)))
((bit-set? i l)
(let* ((j (* stride i))
(k (vector-ref array j)))
(if ((hamt/= hamt) k key)
(if payload?
(vector-ref array (+ j 1))
'present)
hamt-null)))
(else hamt-null))))
(else (error "Unexpected type of child node."))))))
(define (collision/for-each procedure node payload?)
(if payload?
(do-list (e (collision/entries node))
(procedure (car e) (cdr e)))
(do-list (e (collision/entries node))
(procedure e #f))))
(define (narrow/for-each procedure node payload?)
(let ((array (narrow/array node))
(stride (leaf-stride payload?))
(c (narrow/children node))
(l (narrow/leaves node)))
(let next-leaf ((count 0)
(start 0))
(let ((i (next-set-bit l start hamt-bucket-size)))
(if i
(let* ((j (* stride count))
(k (vector-ref array j))
(d (and payload? (vector-ref array (+ j 1)))))
(procedure k d)
(next-leaf (+ count 1) (+ i 1)))
(let next-child ((start 0)
(offset (* stride count)))
(let ((i (next-set-bit c start hamt-bucket-size)))
(when i
(let ((child (vector-ref array offset)))
(hamt-node/for-each child payload? procedure)
(next-child (+ i 1) (+ offset 1)))))))))))
(define (wide/for-each procedure node payload?)
(let ((array (wide/array node))
(stride (leaf-stride payload?))
(c (wide/children node))
(l (wide/leaves node)))
(do ((i 0 (+ i 1)))
((= i hamt-bucket-size))
(let ((j (* stride i)))
(cond ((bit-set? i l)
(let ((k (vector-ref array j))
(d (and payload? (vector-ref array (+ j 1)))))
(procedure k d)))
((bit-set? i c)
(let ((child (vector-ref array j)))
(hamt-node/for-each child payload? procedure))))))))
(define (hamt-node/for-each node payload? procedure)
(cond ((collision? node) (collision/for-each procedure node payload?))
((narrow? node) (narrow/for-each procedure node payload?))
((wide? node) (wide/for-each procedure node payload?))
(else (error "Invalid type of node." node))))
(define (hamt/for-each procedure hamt)
(hamt-node/for-each (hamt/root hamt)
(hamt/payload? hamt)
procedure))
(define (hamt->list hamt procedure)
(let ((accumulator '()))
(hamt/for-each (lambda (k v)
(set! accumulator
(cons (procedure k v)
accumulator)))
hamt)
accumulator))
;;; Debugging
(define (assert-collision-valid node hp payload?)
"Do sanity checks on a collision. Return the list of all keys
present."
(let ((entries (collision/entries node))
(hash (collision/hash node))
(extract (if payload? car (lambda (x) x))))
(do-list (a entries)
(assert (= hash (hash-bits hp (extract a)))))
(if payload?
(map car entries)
entries)))
(define (assert-narrow-valid node hp payload? shift)
"Do sanity checks on a narrow and all its children. Return the list
of all keys present."
(let ((array (narrow/array node))
(stride (leaf-stride payload?))
(c (narrow/children node))
(l (narrow/leaves node)))
(assert (zero? (bitwise-and c l)))
(let next-leaf ((count 0)
(i 0)
(keys '()))
(if (< i hamt-bucket-size)
(cond ((bit-set? i l)
(let ((k (vector-ref array (* stride count))))
(assert (= i (hash-fragment shift (hash-bits hp k))))
(next-leaf (+ count 1) (+ i 1) (cons k keys))))
(else (next-leaf count (+ i 1) keys)))
(let next-child ((i 0)
(key-groups (list keys))
(offset (* stride count)))
(if (= i hamt-bucket-size)
(apply append key-groups)
(cond ((bit-set? i c)
(let* ((child (vector-ref array offset))
(child-keys (assert-hamt-node-valid
child
hp
payload?
(+ shift hamt-hash-slice-size))))
(do-list (k child-keys)
(assert (= i
(hash-fragment shift (hash-bits hp k)))))
(next-child (+ i 1)
(cons child-keys key-groups)
(+ offset 1))))
(else (next-child (+ i 1) key-groups offset)))))))))
(define (assert-wide-valid node hp payload? shift)
"Do sanity checks on a wide and all its children. Return the list
of all keys present."
(let ((array (wide/array node))
(stride (leaf-stride payload?))
(c (wide/children node))
(l (wide/leaves node)))
(assert (zero? (bitwise-and c l)))
(let next-fragment ((i 0)
(key-groups '()))
(if (= i hamt-bucket-size)
(apply append key-groups)
(let ((j (* stride i)))
(cond ((bit-set? i l)
(let ((k (vector-ref array j)))
(assert (= i (hash-fragment shift (hash-bits hp k))))
(next-fragment (+ i 1) (cons (list k) key-groups))))
((bit-set? i c)
(let* ((child (vector-ref array j))
(child-keys (assert-hamt-node-valid
child
hp
payload?
(+ shift hamt-hash-slice-size))))
(do-list (k child-keys)
(assert (= i
(hash-fragment shift (hash-bits hp k)))))
(next-fragment (+ i 1)
(cons child-keys key-groups))))
(else
(assert (not (vector-ref array j)))
(when payload?
(assert (not (vector-ref array (+ j 1)))))
(next-fragment (+ i 1) key-groups))))))))
(define (assert-hamt-node-valid node hp payload? shift)
"Do sanity checks on a HAMT node and all its children. Return the
list of all keys present."
(cond ((collision? node) (assert-collision-valid node hp payload?))
((narrow? node) (assert-narrow-valid node hp payload? shift))
((wide? node) (assert-wide-valid node hp payload? shift))
(else (error "Invalid type of node." node))))
(define (assert-hamt-valid hamt)
"Do sanity checks on `hamt'."
(let ((hp (hamt/hash hamt)))
(assert (procedure? (hamt/= hamt)))
(assert (procedure? hp))
(assert (memq (hamt/mutable? hamt) '(#t #f)))
(let* ((payload? (hamt/payload? hamt))
(keys (assert-hamt-node-valid (hamt/root hamt) hp payload? 0)))
(assert (= (hamt/count hamt) (length keys))))))

42
lib/srfi/146/hamt.sld Normal file
View file

@ -0,0 +1,42 @@
(define-library (srfi 146 hamt)
(import (scheme base)
(scheme case-lambda)
(only (srfi 1) find-tail)
(srfi 16)
(only (srfi 143) fx-width)
(srfi 151)
(srfi 146 hamt-misc)
(srfi 146 vector-edit))
(export fragment->mask
hamt->list
hamt-fetch
hamt-null
hamt-null?
hamt/count
hamt/empty?
hamt/for-each
hamt/immutable
hamt/mutable
hamt/mutable?
hamt/payload?
hamt/put
hamt/put!
hamt/replace
hamt/replace!
hash-array-mapped-trie?
make-hamt
;; These are only needed by tests:
collision?
hamt-bucket-size
hamt-hash-size
hamt/root
leaf-stride
narrow/array
narrow/leaves
narrow?
next-set-bit
wide/array
wide/children
wide?)
(include "hamt.scm"))

441
lib/srfi/146/hash-test.sld Normal file
View file

@ -0,0 +1,441 @@
;; Copyright (C) Marc Nieper-Wißkirchen (2016, 2017). All Rights
;; Reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
(define-library (srfi 146 hash-test)
(export run-tests)
(import (scheme base)
(srfi 1)
(srfi 8)
(srfi 64)
(srfi 146 hash)
(srfi 128))
(begin
(define comparator (make-default-comparator))
(define (run-tests)
(test-begin "SRFI 146: Hashmaps")
(test-group "Predicates"
(define hashmap0 (hashmap comparator))
(define hashmap1 (hashmap comparator 'a 1 'b 2 'c 3))
(define hashmap2 (hashmap comparator 'c 1 'd 2 'e 3))
(define hashmap3 (hashmap comparator 'd 1 'e 2 'f 3))
(test-assert "hashmap?: a hashmap"
(hashmap? (hashmap comparator)))
(test-assert "hashmap?: not a hashmap"
(not (hashmap? (list 1 2 3))))
(test-assert "hashmap-empty?: empty hashmap"
(hashmap-empty? hashmap0))
(test-assert "hashmap-empty?: non-empty hashmap"
(not (hashmap-empty? hashmap1)))
(test-assert "hashmap-contains?: containing"
(hashmap-contains? hashmap1 'b))
(test-assert "hashmap-contains?: not containing"
(not (hashmap-contains? hashmap1 '2)))
(test-assert "hashmap-disjoint?: disjoint"
(hashmap-disjoint? hashmap1 hashmap3))
(test-assert "hashmap-disjoint?: not disjoint"
(not (hashmap-disjoint? hashmap1 hashmap2))))
(test-group "Accessors"
(define hashmap1 (hashmap comparator 'a 1 'b 2 'c 3))
(test-equal "hashmap-ref: key found"
2
(hashmap-ref hashmap1 'b))
(test-equal "hashmap-ref: key not found/with failure"
42
(hashmap-ref hashmap1 'd (lambda () 42)))
(test-error "hashmap-ref: key not found/without failure"
(hashmap-ref hashmap1 'd))
(test-equal "hashmap-ref: with success procedure"
(* 2 2)
(hashmap-ref hashmap1 'b (lambda () #f) (lambda (x) (* x x))))
(test-equal "hashmap-ref/default: key found"
3
(hashmap-ref/default hashmap1 'c 42))
(test-equal "hashmap-ref/default: key not found"
42
(hashmap-ref/default hashmap1 'd 42))
(test-equal "hashmap-key-comparator"
comparator
(hashmap-key-comparator hashmap1)))
(test-group "Updaters"
(define hashmap1 (hashmap comparator 'a 1 'b 2 'c 3))
(define hashmap2 (hashmap-set hashmap1 'c 4 'd 4 'd 5))
(define hashmap3 (hashmap-update hashmap1 'b (lambda (x) (* x x))))
(define hashmap4 (hashmap-update/default hashmap1 'd (lambda (x) (* x x)) 4))
(define hashmap5 (hashmap-adjoin hashmap1 'c 4 'd 4 'd 5))
(define hashmap0 (hashmap comparator))
(test-equal "hashmap-adjoin: key already in hashmap"
3
(hashmap-ref hashmap5 'c))
(test-equal "hashmap-adjoin: key set earlier"
4
(hashmap-ref hashmap5 'd))
(test-equal "hashmap-set: key already in hashmap"
4
(hashmap-ref hashmap2 'c))
(test-equal "hashmap-set: key set earlier"
5
(hashmap-ref hashmap2 'd))
(test-equal "hashmap-replace: key not in hashmap"
#f
(hashmap-ref/default (hashmap-replace hashmap1 'd 4) 'd #f))
(test-equal "hashmap-replace: key in hashmap"
6
(hashmap-ref (hashmap-replace hashmap1 'c 6) 'c))
(test-equal "hashmap-delete"
42
(hashmap-ref/default (hashmap-delete hashmap1 'b) 'b 42))
(test-equal "hashmap-delete-all"
42
(hashmap-ref/default (hashmap-delete-all hashmap1 '(a b)) 'b 42))
(test-equal "hashmap-intern: key in hashmap"
(list hashmap1 2)
(receive result
(hashmap-intern hashmap1 'b (lambda () (error "should not have been invoked")))
result))
(test-equal "hashmap-intern: key not in hashmap"
(list 42 42)
(receive (hashmap value)
(hashmap-intern hashmap1 'd (lambda () 42))
(list value (hashmap-ref hashmap 'd))))
(test-equal "hashmap-update"
4
(hashmap-ref hashmap3 'b))
(test-equal "hashmap-update/default"
16
(hashmap-ref hashmap4 'd))
(test-equal "hashmap-pop: empty hashmap"
'empty
(hashmap-pop hashmap0 (lambda () 'empty)))
(test-assert "hashmap-pop: non-empty hashmap"
(member
(receive (hashmap key value)
(hashmap-pop hashmap1)
(list (hashmap-size hashmap) key value))
'((2 a 1) (2 b 2) (2 c 3)))))
(test-group "The whole hashmap"
(define hashmap0 (hashmap comparator))
(define hashmap1 (hashmap comparator 'a 1 'b 2 'c 3))
(test-equal "hashmap-size: empty hashmap"
0
(hashmap-size hashmap0))
(test-equal "hashmap-size: non-empty hashmap"
3
(hashmap-size hashmap1))
(test-equal "hashmap-find: found in hashmap"
(list 'b 2)
(receive result
(hashmap-find (lambda (key value)
(and (eq? key 'b)
(= value 2)))
hashmap1
(lambda () (error "should not have been called")))
result))
(test-equal "hashmap-find: not found in hashmap"
(list 42)
(receive result
(hashmap-find (lambda (key value)
(eq? key 'd))
hashmap1
(lambda ()
42))
result))
(test-equal "hashmap-count"
2
(hashmap-count (lambda (key value)
(>= value 2))
hashmap1))
(test-assert "hashmap-any?: found"
(hashmap-any? (lambda (key value)
(= value 3))
hashmap1))
(test-assert "hashmap-any?: not found"
(not (hashmap-any? (lambda (key value)
(= value 4))
hashmap1)))
(test-assert "hashmap-every?: true"
(hashmap-every? (lambda (key value)
(<= value 3))
hashmap1))
(test-assert "hashmap-every?: false"
(not (hashmap-every? (lambda (key value)
(<= value 2))
hashmap1)))
(test-equal "hashmap-keys"
3
(length (hashmap-keys hashmap1)))
(test-equal "hashmap-values"
6
(fold + 0 (hashmap-values hashmap1)))
(test-equal "hashmap-entries"
(list 3 6)
(receive (keys values)
(hashmap-entries hashmap1)
(list (length keys) (fold + 0 values)))))
(test-group "Hashmap and folding"
(define hashmap1 (hashmap comparator 'a 1 'b 2 'c 3))
(define hashmap2 (hashmap-map (lambda (key value)
(values (symbol->string key)
(* 10 value)))
comparator
hashmap1))
(test-equal "hashmap-map"
20
(hashmap-ref hashmap2 "b"))
(test-equal "hashmap-for-each"
6
(let ((counter 0))
(hashmap-for-each (lambda (key value)
(set! counter (+ counter value)))
hashmap1)
counter))
(test-equal "hashmap-fold"
6
(hashmap-fold (lambda (key value acc)
(+ value acc))
0
hashmap1))
(test-equal "hashmap-map->list"
(+ (* 1 1) (* 2 2) (* 3 3))
(fold + 0 (hashmap-map->list (lambda (key value)
(* value value))
hashmap1)))
(test-equal "hashmap-filter"
2
(hashmap-size (hashmap-filter (lambda (key value)
(<= value 2))
hashmap1)))
(test-equal "hashmap-remove"
1
(hashmap-size (hashmap-remove (lambda (key value)
(<= value 2))
hashmap1)))
(test-equal "hashmap-partition"
(list 1 2)
(receive result
(hashmap-partition (lambda (key value)
(eq? 'b key))
hashmap1)
(map hashmap-size result)))
(test-group "Copying and conversion"
(define hashmap1 (hashmap comparator 'a 1 'b 2 'c 3))
(define hashmap2 (alist->hashmap comparator '((a . 1) (b . 2) (c . 3))))
(define hashmap3 (alist->hashmap! (hashmap-copy hashmap1) '((d . 4) '(c . 5))))
(test-equal "hashmap-copy: same size"
3
(hashmap-size (hashmap-copy hashmap1)))
(test-equal "hashmap-copy: same comparator"
comparator
(hashmap-key-comparator (hashmap-copy hashmap1)))
(test-equal "hashmap->alist"
(cons 'b 2)
(assq 'b (hashmap->alist hashmap1)))
(test-equal "alist->hashmap"
2
(hashmap-ref hashmap2 'b)
)
(test-equal "alist->hashmap!: new key"
4
(hashmap-ref hashmap3 'd))
(test-equal "alist->hashmap!: existing key"
3
(hashmap-ref hashmap3 'c)))
(test-group "Subhashmaps"
(define hashmap1 (hashmap comparator 'a 1 'b 2 'c 3))
(define hashmap2 (hashmap comparator 'a 1 'b 2 'c 3))
(define hashmap3 (hashmap comparator 'a 1 'c 3))
(define hashmap4 (hashmap comparator 'a 1 'c 3 'd 4))
(define hashmap5 (hashmap comparator 'a 1 'b 2 'c 6))
(define hashmap6 (hashmap (make-comparator (comparator-type-test-predicate comparator)
(comparator-equality-predicate comparator)
(comparator-ordering-predicate comparator)
(comparator-hash-function comparator))
'a 1 'b 2 'c 3))
(test-assert "hashmap=?: equal hashmaps"
(hashmap=? comparator hashmap1 hashmap2))
(test-assert "hashmap=?: unequal hashmaps"
(not (hashmap=? comparator hashmap1 hashmap4)))
(test-assert "hashmap=?: different comparators"
(not (hashmap=? comparator hashmap1 hashmap6)))
(test-assert "hashmap<?: proper subset"
(hashmap<? comparator hashmap3 hashmap1))
(test-assert "hashmap<?: improper subset"
(not (hashmap<? comparator hashmap3 hashmap1 hashmap2)))
(test-assert "hashmap>?: proper superset"
(hashmap>? comparator hashmap2 hashmap3))
(test-assert "hashmap>?: improper superset"
(not (hashmap>? comparator hashmap1 hashmap2 hashmap3)))
(test-assert "hashmap<=?: subset"
(hashmap<=? comparator hashmap3 hashmap2 hashmap1))
(test-assert "hashmap<=?: non-matching values"
(not (hashmap<=? comparator hashmap3 hashmap5)))
(test-assert "hashmap<=?: not a subset"
(not (hashmap<=? comparator hashmap2 hashmap4)))
(test-assert "hashmap>=?: superset"
(hashmap>=? comparator hashmap4 hashmap3))
(test-assert "hashmap>=?: not a superset"
(not (hashmap>=? comparator hashmap5 hashmap3))))
(test-group "Set theory operations"
(define hashmap1 (hashmap comparator 'a 1 'b 2 'c 3))
(define hashmap2 (hashmap comparator 'a 1 'b 2 'd 4))
(define hashmap3 (hashmap comparator 'a 1 'b 2))
(define hashmap4 (hashmap comparator 'a 1 'b 2 'c 4))
(define hashmap5 (hashmap comparator 'a 1 'c 3))
(define hashmap6 (hashmap comparator 'd 4 'e 5 'f 6))
(test-equal "hashmap-union: new association"
4
(hashmap-ref (hashmap-union hashmap1 hashmap2) 'd))
(test-equal "hashmap-union: existing association"
3
(hashmap-ref (hashmap-union hashmap1 hashmap4) 'c))
(test-equal "hashmap-union: three hashmaps"
6
(hashmap-size (hashmap-union hashmap1 hashmap2 hashmap6)))
(test-equal "hashmap-intersection: existing association"
3
(hashmap-ref (hashmap-intersection hashmap1 hashmap4) 'c))
(test-equal "hashmap-intersection: removed association"
42
(hashmap-ref/default (hashmap-intersection hashmap1 hashmap5) 'b 42))
(test-equal "hashmap-difference"
2
(hashmap-size (hashmap-difference hashmap2 hashmap6)))
(test-equal "hashmap-xor"
4
(hashmap-size (hashmap-xor hashmap2 hashmap6))))
(test-group "Comparators"
(define hashmap1 (hashmap comparator 'a 1 'b 2 'c 3))
(define hashmap2 (hashmap comparator 'a 1 'b 2 'c 3))
(define hashmap3 (hashmap comparator 'a 1 'b 2))
(define hashmap4 (hashmap comparator 'a 1 'b 2 'c 4))
(define hashmap5 (hashmap comparator 'a 1 'c 3))
(define hashmap0 (hashmap comparator
hashmap1 "a"
hashmap2 "b"
hashmap3 "c"
hashmap4 "d"
hashmap5 "e"))
(test-assert "hashmap-comparator"
(comparator? hashmap-comparator))
(test-equal "hashmap-keyed hashmap"
(list "a" "a" "c" "d" "e")
(list (hashmap-ref hashmap0 hashmap1)
(hashmap-ref hashmap0 hashmap2)
(hashmap-ref hashmap0 hashmap3)
(hashmap-ref hashmap0 hashmap4)
(hashmap-ref hashmap0 hashmap5)
))
(test-group "Ordering comparators"
(test-assert "=?: equal hashmaps"
(=? comparator hashmap1 hashmap2))
(test-assert "=?: unequal hashmaps"
(not (=? comparator hashmap1 hashmap4))))))
(test-end "SRFI 146: Hashmaps"))))

704
lib/srfi/146/hash.scm Normal file
View file

@ -0,0 +1,704 @@
;; Copyright (C) Marc Nieper-Wißkirchen (2018). All Rights
;; Reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;;; Implementation layer
(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))))))
(define (tree-fold proc seed tree)
(phm/for-each (lambda (key entry)
(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))
(define (tree-generator tree)
(make-coroutine-generator
(lambda (yield)
(tree-for-each (lambda item (yield item))
tree))))
;;; New types
(define-record-type <hashmap>
(%make-hashmap comparator tree)
hashmap?
(comparator hashmap-key-comparator)
(tree hashmap-tree))
(define (make-empty-hashmap comparator)
(assume (comparator? comparator))
(%make-hashmap comparator
(make-phm (comparator-hash-function comparator)
(comparator-equality-predicate comparator))))
;;; Exported procedures
;; Constructors
(define (hashmap comparator . args)
(assume (comparator? comparator))
(hashmap-unfold null?
(lambda (args)
(values (car args)
(cadr args)))
cddr
args
comparator))
(define (hashmap-unfold stop? mapper successor seed comparator)
(assume (procedure? stop?))
(assume (procedure? mapper))
(assume (procedure? successor))
(assume (comparator? comparator))
(let loop ((hashmap (make-empty-hashmap comparator))
(seed seed))
(if (stop? seed)
hashmap
(receive (key value)
(mapper seed)
(loop (hashmap-adjoin hashmap key value)
(successor seed))))))
;; Predicates
(define (hashmap-empty? hashmap)
(assume (hashmap? hashmap))
(not (hashmap-any? (lambda (key value) #t) hashmap)))
(define (hashmap-contains? hashmap key)
(assume (hashmap? hashmap))
(call/cc
(lambda (return)
(hashmap-search hashmap
key
(lambda (insert ignore)
(return #f))
(lambda (key value update remove)
(return #t))))))
(define (hashmap-disjoint? hashmap1 hashmap2)
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(call/cc
(lambda (return)
(hashmap-for-each (lambda (key value)
(when (hashmap-contains? hashmap2 key)
(return #f)))
hashmap1)
#t)))
;; Accessors
(define hashmap-ref
(case-lambda
((hashmap key)
(assume (hashmap? hashmap))
(hashmap-ref hashmap key (lambda ()
(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)))
((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)))))))))))
(define (hashmap-ref/default hashmap key default)
(assume (hashmap? hashmap))
(hashmap-ref hashmap key (lambda () default)))
;; Updaters
(define (hashmap-adjoin hashmap . args)
(assume (hashmap? hashmap))
(let loop ((args args)
(hashmap hashmap))
(if (null? args)
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))
(if (null? args)
hashmap
(receive (hashmap)
(hashmap-update hashmap (car args) (lambda (value) (cadr args)) (lambda () #f))
(loop (cddr args)
hashmap)))))
(define hashmap-set! hashmap-set)
(define (hashmap-replace hashmap key value)
(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)))
hashmap))
(define hashmap-replace! hashmap-replace)
(define (hashmap-delete hashmap . keys)
(assume (hashmap? hashmap))
(hashmap-delete-all hashmap keys))
(define hashmap-delete! hashmap-delete)
(define (hashmap-delete-all hashmap keys)
(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))
(define hashmap-delete-all! hashmap-delete-all)
(define (hashmap-intern hashmap key failure)
(assume (hashmap? hashmap))
(assume (procedure? failure))
(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))))))
(define hashmap-intern! hashmap-intern)
(define hashmap-update
(case-lambda
((hashmap key updater)
(hashmap-update hashmap key updater (lambda ()
(error "hashmap-update: key not found in hashmap" key))))
((hashmap key updater failure)
(hashmap-update hashmap key updater failure (lambda (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))))
(define hashmap-update! hashmap-update)
(define (hashmap-update/default hashmap key updater default)
(hashmap-update hashmap key updater (lambda () default)))
(define hashmap-update!/default hashmap-update/default)
(define hashmap-pop
(case-lambda
((hashmap)
(hashmap-pop hashmap (lambda ()
(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)))))))))
(define hashmap-pop! hashmap-pop)
(define (hashmap-search hashmap key failure success)
(assume (hashmap? hashmap))
(assume (procedure? failure))
(assume (procedure? success))
(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)))
(values (%make-hashmap comparator tree)
obj)))))
(define hashmap-search! hashmap-search)
;; The whole hashmap
(define (hashmap-size hashmap)
(assume (hashmap? hashmap))
(hashmap-count (lambda (key value)
#t)
hashmap))
(define (hashmap-find predicate hashmap failure)
(assume (procedure? predicate))
(assume (hashmap? hashmap))
(assume (procedure? failure))
(call/cc
(lambda (return)
(hashmap-for-each (lambda (key value)
(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))
(define (hashmap-any? predicate hashmap)
(assume (procedure? predicate))
(assume (hashmap? hashmap))
(call/cc
(lambda (return)
(hashmap-for-each (lambda (key value)
(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)))
(define (hashmap-keys hashmap)
(assume (hashmap? hashmap))
(hashmap-fold (lambda (key value keys)
(cons key keys))
'() hashmap))
(define (hashmap-values hashmap)
(assume (hashmap? hashmap))
(hashmap-fold (lambda (key value values)
(cons value values))
'() hashmap))
(define (hashmap-entries hashmap)
(assume (hashmap? hashmap))
(values (hashmap-keys hashmap)
(hashmap-values hashmap)))
;; Hashmap and folding
(define (hashmap-map proc comparator hashmap)
(assume (procedure? proc))
(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))
(define (hashmap-for-each proc hashmap)
(assume (procedure? proc))
(assume (hashmap? hashmap))
(tree-for-each proc (hashmap-tree hashmap)))
(define (hashmap-fold proc acc hashmap)
(assume (procedure? proc))
(assume (hashmap? hashmap))
(tree-fold proc acc (hashmap-tree hashmap)))
(define (hashmap-map->list proc hashmap)
(assume (procedure? proc))
(assume (hashmap? hashmap))
(hashmap-fold (lambda (key value lst)
(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))
(define hashmap-filter! hashmap-filter)
(define (hashmap-remove predicate hashmap)
(assume (procedure? predicate))
(assume (hashmap? hashmap))
(hashmap-filter (lambda (key value)
(not (predicate key value)))
hashmap))
(define hashmap-remove! hashmap-remove)
(define (hashmap-partition predicate hashmap)
(assume (procedure? predicate))
(assume (hashmap? hashmap))
(values (hashmap-filter predicate hashmap)
(hashmap-remove predicate hashmap)))
(define hashmap-partition! hashmap-partition)
;; Copying and conversion
(define (hashmap-copy hashmap)
(assume (hashmap? hashmap))
hashmap)
(define (hashmap->alist hashmap)
(assume (hashmap? hashmap))
(hashmap-fold (lambda (key value alist)
(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))
(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))
;; Subhashmaps
(define hashmap=?
(case-lambda
((comparator hashmap)
(assume (hashmap? hashmap))
#t)
((comparator hashmap1 hashmap2) (%hashmap=? comparator hashmap1 hashmap2))
((comparator hashmap1 hashmap2 . hashmaps)
(and (%hashmap=? comparator hashmap1 hashmap2)
(apply hashmap=? comparator hashmap2 hashmaps)))))
(define (%hashmap=? comparator hashmap1 hashmap2)
(and (eq? (hashmap-key-comparator hashmap1) (hashmap-key-comparator hashmap2))
(%hashmap<=? comparator hashmap1 hashmap2)
(%hashmap<=? comparator hashmap2 hashmap1)))
(define hashmap<=?
(case-lambda
((comparator hashmap)
(assume (hashmap? hashmap))
#t)
((comparator hashmap1 hashmap2)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(%hashmap<=? comparator hashmap1 hashmap2))
((comparator hashmap1 hashmap2 . hashmaps)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(and (%hashmap<=? comparator hashmap1 hashmap2)
(apply hashmap<=? comparator hashmap2 hashmaps)))))
(define (%hashmap<=? comparator hashmap1 hashmap2)
(assume (comparator? comparator))
(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))
(define hashmap>?
(case-lambda
((comparator hashmap)
(assume (hashmap? hashmap))
#t)
((comparator hashmap1 hashmap2)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(%hashmap>? comparator hashmap1 hashmap2))
((comparator hashmap1 hashmap2 . hashmaps)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(and (%hashmap>? comparator hashmap1 hashmap2)
(apply hashmap>? comparator hashmap2 hashmaps)))))
(define (%hashmap>? comparator hashmap1 hashmap2)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(not (%hashmap<=? comparator hashmap1 hashmap2)))
(define hashmap<?
(case-lambda
((comparator hashmap)
(assume (hashmap? hashmap))
#t)
((comparator hashmap1 hashmap2)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(%hashmap<? comparator hashmap1 hashmap2))
((comparator hashmap1 hashmap2 . hashmaps)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(and (%hashmap<? comparator hashmap1 hashmap2)
(apply hashmap<? comparator hashmap2 hashmaps)))))
(define (%hashmap<? comparator hashmap1 hashmap2)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(%hashmap>? comparator hashmap2 hashmap1))
(define hashmap>=?
(case-lambda
((comparator hashmap)
(assume (hashmap? hashmap))
#t)
((comparator hashmap1 hashmap2)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(%hashmap>=? comparator hashmap1 hashmap2))
((comparator hashmap1 hashmap2 . hashmaps)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(and (%hashmap>=? comparator hashmap1 hashmap2)
(apply hashmap>=? comparator hashmap2 hashmaps)))))
(define (%hashmap>=? comparator hashmap1 hashmap2)
(assume (comparator? comparator))
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(not (%hashmap<? comparator hashmap1 hashmap2)))
;; Set theory operations
(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))
(define (%hashmap-intersection hashmap1 hashmap2)
(hashmap-filter (lambda (key1 value1)
(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))
(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))
(define hashmap-union
(case-lambda
((hashmap)
(assume (hashmap? hashmap))
hashmap)
((hashmap1 hashmap2)
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(%hashmap-union hashmap1 hashmap2))
((hashmap1 hashmap2 . hashmaps)
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(apply hashmap-union (%hashmap-union hashmap1 hashmap2) hashmaps))))
(define hashmap-union! hashmap-union)
(define hashmap-intersection
(case-lambda
((hashmap)
(assume (hashmap? hashmap))
hashmap)
((hashmap1 hashmap2)
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(%hashmap-intersection hashmap1 hashmap2))
((hashmap1 hashmap2 . hashmaps)
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(apply hashmap-intersection (%hashmap-intersection hashmap1 hashmap2) hashmaps))))
(define hashmap-intersection! hashmap-intersection)
(define hashmap-difference
(case-lambda
((hashmap)
(assume (hashmap? hashmap))
hashmap)
((hashmap1 hashmap2)
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(%hashmap-difference hashmap1 hashmap2))
((hashmap1 hashmap2 . hashmaps)
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(apply hashmap-difference (%hashmap-difference hashmap1 hashmap2) hashmaps))))
(define hashmap-difference! hashmap-difference)
(define hashmap-xor
(case-lambda
((hashmap)
(assume (hashmap? hashmap))
hashmap)
((hashmap1 hashmap2)
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(%hashmap-xor hashmap1 hashmap2))
((hashmap1 hashmap2 . hashmaps)
(assume (hashmap? hashmap1))
(assume (hashmap? hashmap2))
(apply hashmap-xor (%hashmap-xor hashmap1 hashmap2) hashmaps))))
(define hashmap-xor! hashmap-xor)
;; Comparators
(define (hashmap-equality comparator)
(assume (comparator? comparator))
(lambda (hashmap1 hashmap2)
(hashmap=? comparator hashmap1 hashmap2)))
(define (hashmap-hash-function comparator)
(assume (comparator? comparator))
(lambda (hashmap)
0 ;; TODO
#;
(default-hash (hashmap->alist hashmap))))
(define (make-hashmap-comparator comparator)
(make-comparator hashmap?
(hashmap-equality comparator)
#f
(hashmap-hash-function comparator)))
(define hashmap-comparator (make-hashmap-comparator (make-default-comparator)))
(comparator-register-default! hashmap-comparator)

36
lib/srfi/146/hash.sld Normal file
View file

@ -0,0 +1,36 @@
(define-library (srfi 146 hash)
(export
hashmap hashmap-unfold
hashmap? hashmap-contains? hashmap-empty? hashmap-disjoint?
hashmap-ref hashmap-ref/default hashmap-key-comparator
hashmap-adjoin hashmap-adjoin!
hashmap-set hashmap-set!
hashmap-replace hashmap-replace!
hashmap-delete hashmap-delete! hashmap-delete-all hashmap-delete-all!
hashmap-intern hashmap-intern!
hashmap-update hashmap-update! hashmap-update/default hashmap-update!/default
hashmap-pop hashmap-pop!
hashmap-search hashmap-search!
hashmap-size hashmap-find hashmap-count hashmap-any? hashmap-every?
hashmap-keys hashmap-values hashmap-entries
hashmap-map hashmap-map->list hashmap-for-each hashmap-fold
hashmap-filter hashmap-filter!
hashmap-remove hashmap-remove!
hashmap-partition hashmap-partition!
hashmap-copy hashmap->alist alist->hashmap alist->hashmap!
hashmap=? hashmap<? hashmap>? hashmap<=? hashmap>=?
hashmap-union hashmap-intersection hashmap-difference hashmap-xor
hashmap-union! hashmap-intersection! hashmap-difference! hashmap-xor!
make-hashmap-comparator
hashmap-comparator
comparator?)
(import (scheme base)
(scheme case-lambda)
(srfi 1)
(srfi 8)
(srfi 121)
(srfi 128)
(srfi 145)
(srfi 146 hamt-map))
(include "hash.scm"))

69
lib/srfi/146/vector-edit-test.scm Normal file
View file

@ -0,0 +1,69 @@
;;;; `vector-edit' tests
;;; Copyright MMIV-MMXV Arthur A. Gleckler. All rights reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
(define (run-vector-edit-tests)
(test-begin "vector-edit")
(test-group "(vector-without)"
(define (check expected start end)
(let ((v #(0 1 2 3 4)))
(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)
(check #(2 3 4) 0 2)
(check #(0 2 3 4) 1 2)
(check #(0 3 4) 1 3)
(check #(0 1 4) 2 4)
(check #(0 1 2 3) 4 5)
(check #(0 1 2) 3 5))
(test-group "(vector-edit empty)"
(let ((array (vector 0 1 2)))
(test #(0 1 2) (vector-edit array))))
(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)))))
(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)))))
(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)))))
(test-end))

4
lib/srfi/146/vector-edit-test.sld Normal file
View file

@ -0,0 +1,4 @@
(define-library (srfi 146 vector-edit-test)
(import (scheme base) (chibi test) (srfi 146 vector-edit))
(export run-vector-edit-tests)
(include "vector-edit-test.scm"))

93
lib/srfi/146/vector-edit.scm Normal file
View file

@ -0,0 +1,93 @@
;;;; `vector-edit'
;;; Copyright MMIV-MMXV Arthur A. Gleckler. All rights reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
;;; `vector-edit' adds and/or removes elements from a vector
;;; non-destructively, i.e. by returning a new vector. It maps
;;; offsets in the original vector to offsets in the new vector so
;;; that the caller doesn't have to perform these error-prone
;;; calculations itself.
(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)))
(vector-copy! result 0 v 0 start)
(vector-copy! result start v end size)
result))
(define (vector-replace-one v i e)
"Return a copy of vector `v' with the `i'th element replaced by `e'."
(let ((result (vector-copy v)))
(vector-set! result i e)
result))
(define-syntax vector-edit-total-skew
(syntax-rules (add drop)
((_ s) s)
((_ s (add i e) . rest)
(vector-edit-total-skew (+ s 1) . rest))
((_ s (drop i c) . rest)
(vector-edit-total-skew (- s c) . rest))))
(define-syntax vector-edit-code
(syntax-rules (add drop)
((_ v r o s)
(let ((index (vector-length v)))
(vector-copy! r (+ o s) v o index)
r))
((_ v r o s (add i e) . rest)
(let ((index i))
(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))))
((_ 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))))))
;; <> Optimize this by allowing one to supply more than one value in
;; `add' sub-expressions so that adjacent values can be inserted
;; without extra computation.
;; Given a vector `v' and a set of `(add i e)' and `(drop i c)' forms,
;; return a new vector that is the result of applying insertions to
;; and deletions from `v'. Interpret each `i' as an index into `v',
;; each `e' as an element to be inserted into the resulting vector at
;; the index corresponding to `i', and each `c' as a count of elements
;; of `v' to be dropped starting at index `i'. The `i' values in the
;; `add' and `drop' forms must never decrease from left to right.
;; This is useful for doing insertions and deletions without
;; constructing an intermediate vector.
(define-syntax vector-edit
(syntax-rules ()
((_ v . rest)
(let ((result (make-vector (+ (vector-length v)
(vector-edit-total-skew 0 . rest)))))
(vector-edit-code v result 0 0 . rest)))))

4
lib/srfi/146/vector-edit.sld Normal file
View file

@ -0,0 +1,4 @@
(define-library (srfi 146 vector-edit)
(import (scheme base))
(export vector-edit vector-replace-one vector-without)
(include "vector-edit.scm"))