Add HAMT persistent hash map data structure
ober
27f1b46440ca15a65cecc8c9bd54f4093481ce8a
new file mode 100644 --- /dev/null +++ b/lib/std/misc/persistent.sls @@ -0,0 +1,432 @@ +#!chezscheme +;;; (std misc persistent) -- Hash Array Mapped Trie (HAMT) +;;; +;;; Persistent (immutable) hash map with structural sharing. +;;; Uses 32-way branching (5 bits per level) with bitmap-indexed nodes. +;;; All operations return new HAMTs; the original is never mutated. +;;; +;;; Usage: +;;; (import (std misc persistent)) +;;; (define h0 hamt-empty) +;;; (define h1 (hamt-set h0 "name" "Alice")) +;;; (define h2 (hamt-set h1 "age" 30)) +;;; (hamt-ref h2 "name" #f) ; => "Alice" +;;; (hamt-contains? h2 "age") ; => #t +;;; (hamt-size h2) ; => 2 +;;; (hamt->alist h2) ; => (("name" . "Alice") ("age" . 30)) +;;; (define h3 (hamt-delete h2 "age")) +;;; (hamt-size h3) ; => 1 + +(library (std misc persistent) + (export + hamt-empty + hamt? + hamt-ref + hamt-set + hamt-delete + hamt-contains? + hamt-size + hamt-fold + hamt-keys + hamt-values + hamt-map + hamt->alist + alist->hamt) + + (import (chezscheme)) + + ;; ========== Constants ========== + ;; 5 bits per level, 32-way branching + (define BITS 5) + (define WIDTH 32) ; (expt 2 BITS) + (define MASK 31) ; (- WIDTH 1) + + ;; ========== Node types ========== + ;; Three node types: + ;; - empty: #f + ;; - leaf: stores a single key-value pair + ;; - bitmap-indexed: sparse array of children indexed by bitmap + ;; - collision: multiple entries sharing the same hash + + (define-record-type leaf + (fields hash key value)) + + (define-record-type bitmap-node + (fields bitmap children)) ; bitmap: fixnum, children: vector + + (define-record-type collision-node + (fields hash entries)) ; entries: list of (key . value) pairs + + ;; ========== HAMT wrapper ========== + (define-record-type hamt-rec + (fields root count)) + + (define (hamt? x) (hamt-rec? x)) + + (define hamt-empty (make-hamt-rec #f 0)) + + ;; ========== Bit manipulation helpers ========== + + ;; Extract the 5-bit fragment at the given level (shift) + (define (hash-fragment shift hash) + (fxlogand MASK (fxsrl hash shift))) + + ;; Count the number of set bits below position in bitmap (popcount of masked bits) + ;; This gives us the index into the children vector. + (define (bitmap-index bitmap frag) + (bitwise-bit-count (fxlogand bitmap (- (fxsll 1 frag) 1)))) + + ;; Check if a bit is set in bitmap + (define (bitmap-has? bitmap frag) + (fxlogbit? frag bitmap)) + + ;; ========== Internal node operations ========== + + ;; Create a new bitmap-node with one child + (define (make-single-child-node frag child) + (make-bitmap-node (fxsll 1 frag) (vector child))) + + ;; Insert/replace a child in a bitmap-node + (define (bitmap-node-set bm-node frag child) + (let* ([bitmap (bitmap-node-bitmap bm-node)] + [children (bitmap-node-children bm-node)] + [idx (bitmap-index bitmap frag)]) + (if (bitmap-has? bitmap frag) + ;; Replace existing child at idx + (let ([new-children (vector-copy children)]) + (vector-set! new-children idx child) + (make-bitmap-node bitmap new-children)) + ;; Insert new child at idx + (let* ([len (vector-length children)] + [new-children (make-vector (+ len 1))]) + ;; Copy elements before idx + (do ([i 0 (+ i 1)]) + ((= i idx)) + (vector-set! new-children i (vector-ref children i))) + ;; Insert new child + (vector-set! new-children idx child) + ;; Copy elements after idx + (do ([i idx (+ i 1)]) + ((= i len)) + (vector-set! new-children (+ i 1) (vector-ref children i))) + (make-bitmap-node (fxlogior bitmap (fxsll 1 frag)) new-children))))) + + ;; Remove a child from a bitmap-node + (define (bitmap-node-remove bm-node frag) + (let* ([bitmap (bitmap-node-bitmap bm-node)] + [children (bitmap-node-children bm-node)] + [idx (bitmap-index bitmap frag)] + [len (vector-length children)] + [new-bitmap (fxlogand bitmap (fxlognot (fxsll 1 frag)))]) + (cond + [(= len 1) + ;; Removing the last child => empty + #f] + [(= len 2) + ;; Removing one of two children: if the remaining child is a leaf + ;; or collision, promote it up; otherwise keep as bitmap-node + (let ([remaining (vector-ref children (if (= idx 0) 1 0))]) + (if (or (leaf? remaining) (collision-node? remaining)) + remaining + ;; remaining is a bitmap-node; can't promote, keep structure + (let ([new-children (make-vector 1)]) + (vector-set! new-children 0 remaining) + (make-bitmap-node new-bitmap new-children))))] + [else + ;; Remove element at idx + (let ([new-children (make-vector (- len 1))]) + (do ([i 0 (+ i 1)]) + ((= i idx)) + (vector-set! new-children i (vector-ref children i))) + (do ([i (+ idx 1) (+ i 1)]) + ((= i len)) + (vector-set! new-children (- i 1) (vector-ref children i))) + (make-bitmap-node new-bitmap new-children))]))) + + ;; ========== Collision node helpers ========== + + ;; Find key in collision entries + (define (collision-find-entry entries key) + (cond + [(null? entries) #f] + [(equal? (caar entries) key) (car entries)] + [else (collision-find-entry (cdr entries) key)])) + + ;; Update/insert in collision entries + (define (collision-set-entry entries key value) + (cond + [(null? entries) + (list (cons key value))] + [(equal? (caar entries) key) + (cons (cons key value) (cdr entries))] + [else + (cons (car entries) (collision-set-entry (cdr entries) key value))])) + + ;; Remove from collision entries + (define (collision-remove-entry entries key) + (cond + [(null? entries) '()] + [(equal? (caar entries) key) (cdr entries)] + [else (cons (car entries) (collision-remove-entry (cdr entries) key))])) + + ;; ========== Core: node-set ========== + ;; Insert/update a key-value pair in the trie rooted at `node`. + ;; Returns (values new-node added?) where added? is #t if size increased. + (define (node-set node hash key value shift) + (cond + ;; Empty slot: create a leaf + [(not node) + (values (make-leaf hash key value) #t)] + + ;; Leaf node + [(leaf? node) + (let ([existing-hash (leaf-hash node)]) + (cond + ;; Same hash and same key: replace value + [(and (= hash existing-hash) (equal? key (leaf-key node))) + (if (equal? value (leaf-value node)) + (values node #f) ; no change + (values (make-leaf hash key value) #f))] + ;; Same hash, different key: create collision node + [(= hash existing-hash) + (values (make-collision-node hash + (list (cons key value) + (cons (leaf-key node) (leaf-value node)))) + #t)] + ;; Different hash: need to push both down + [else + (let* ([frag1 (hash-fragment shift existing-hash)] + [frag2 (hash-fragment shift hash)]) + (if (= frag1 frag2) + ;; Same fragment at this level: recurse deeper + (let-values ([(child _) (node-set node hash key value (+ shift BITS))]) + ;; Push the new subtree into a bitmap-node at this level + ;; Actually, we need to create a bitmap-node with one child + ;; that contains both entries. Let me restructure: + ;; Create a sub-node with just the existing leaf, then insert the new key. + (let-values ([(sub added?) (node-set (make-single-child-node frag1 node) + hash key value shift)]) + (values sub added?))) + ;; Different fragments: create bitmap-node with both children + (let* ([bm1 (fxsll 1 frag1)] + [bm2 (fxsll 1 frag2)] + [bitmap (fxlogior bm1 bm2)]) + (if (< frag1 frag2) + (values (make-bitmap-node bitmap (vector node (make-leaf hash key value))) #t) + (values (make-bitmap-node bitmap (vector (make-leaf hash key value) node)) #t)))))]))] + + ;; Bitmap-indexed node + [(bitmap-node? node) + (let* ([frag (hash-fragment shift hash)] + [bitmap (bitmap-node-bitmap node)] + [idx (bitmap-index bitmap frag)]) + (if (bitmap-has? bitmap frag) + ;; Child exists at this position: recurse into it + (let ([child (vector-ref (bitmap-node-children node) idx)]) + (let-values ([(new-child added?) (node-set child hash key value (+ shift BITS))]) + (if (eq? new-child child) + (values node #f) + (values (bitmap-node-set node frag new-child) added?)))) + ;; No child at this position: add a new leaf + (values (bitmap-node-set node frag (make-leaf hash key value)) #t)))] + + ;; Collision node + [(collision-node? node) + (let ([node-hash (collision-node-hash node)] + [entries (collision-node-entries node)]) + (if (= hash node-hash) + ;; Same hash bucket: add/update in collision list + (let ([existing (collision-find-entry entries key)]) + (if existing + (if (equal? (cdr existing) value) + (values node #f) + (values (make-collision-node hash (collision-set-entry entries key value)) #f)) + (values (make-collision-node hash (collision-set-entry entries key value)) #t))) + ;; Different hash: need to nest this collision under a bitmap-node + (let* ([frag1 (hash-fragment shift node-hash)] + [frag2 (hash-fragment shift hash)]) + (if (= frag1 frag2) + ;; Same fragment: recurse deeper + (let-values ([(sub added?) + (node-set (make-single-child-node frag1 node) + hash key value shift)]) + (values sub added?)) + ;; Different fragments: two children + (let* ([new-leaf (make-leaf hash key value)] + [bm1 (fxsll 1 frag1)] + [bm2 (fxsll 1 frag2)] + [bitmap (fxlogior bm1 bm2)]) + (if (< frag1 frag2) + (values (make-bitmap-node bitmap (vector node new-leaf)) #t) + (values (make-bitmap-node bitmap (vector new-leaf node)) #t)))))))] + + [else (error 'node-set "invalid node type" node)])) + + ;; ========== Core: node-ref ========== + (define (node-ref node hash key shift default) + (cond + [(not node) default] + + [(leaf? node) + (if (and (= hash (leaf-hash node)) (equal? key (leaf-key node))) + (leaf-value node) + default)] + + [(bitmap-node? node) + (let* ([frag (hash-fragment shift hash)] + [bitmap (bitmap-node-bitmap node)]) + (if (bitmap-has? bitmap frag) + (let ([idx (bitmap-index bitmap frag)]) + (node-ref (vector-ref (bitmap-node-children node) idx) + hash key (+ shift BITS) default)) + default))] + + [(collision-node? node) + (if (= hash (collision-node-hash node)) + (let ([entry (collision-find-entry (collision-node-entries node) key)]) + (if entry (cdr entry) default)) + default)] + + [else (error 'node-ref "invalid node type" node)])) + + ;; ========== Core: node-delete ========== + ;; Returns (values new-node removed?) where removed? is #t if size decreased. + (define (node-delete node hash key shift) + (cond + [(not node) + (values #f #f)] + + [(leaf? node) + (if (and (= hash (leaf-hash node)) (equal? key (leaf-key node))) + (values #f #t) + (values node #f))] + + [(bitmap-node? node) + (let* ([frag (hash-fragment shift hash)] + [bitmap (bitmap-node-bitmap node)]) + (if (bitmap-has? bitmap frag) + (let* ([idx (bitmap-index bitmap frag)] + [child (vector-ref (bitmap-node-children node) idx)]) + (let-values ([(new-child removed?) (node-delete child hash key (+ shift BITS))]) + (if (not removed?) + (values node #f) + (if (not new-child) + ;; Child was deleted entirely + (values (bitmap-node-remove node frag) #t) + ;; Child was modified + (values (bitmap-node-set node frag new-child) #t))))) + (values node #f)))] + + [(collision-node? node) + (if (= hash (collision-node-hash node)) + (let* ([entries (collision-node-entries node)] + [new-entries (collision-remove-entry entries key)]) + (if (= (length new-entries) (length entries)) + (values node #f) ; key not found + (if (= (length new-entries) 1) + ;; Only one entry left: convert to leaf + (let ([e (car new-entries)]) + (values (make-leaf hash (car e) (cdr e)) #t)) + (values (make-collision-node hash new-entries) #t)))) + (values node #f))] + + [else (error 'node-delete "invalid node type" node)])) + + ;; ========== Core: node-fold ========== + (define (node-fold proc seed node) + (cond + [(not node) seed] + + [(leaf? node) + (proc (leaf-key node) (leaf-value node) seed)] + + [(bitmap-node? node) + (let ([children (bitmap-node-children node)] + [len (vector-length (bitmap-node-children node))]) + (let loop ([i 0] [acc seed]) + (if (= i len) + acc + (loop (+ i 1) (node-fold proc acc (vector-ref children i))))))] + + [(collision-node? node) + (let loop ([entries (collision-node-entries node)] [acc seed]) + (if (null? entries) + acc + (loop (cdr entries) (proc (caar entries) (cdar entries) acc))))] + + [else (error 'node-fold "invalid node type" node)])) + + ;; ========== Core: node-map ========== + ;; Apply f to each value, returning a new node tree + (define (node-map f node) + (cond + [(not node) #f] + + [(leaf? node) + (make-leaf (leaf-hash node) (leaf-key node) (f (leaf-value node)))] + + [(bitmap-node? node) + (let* ([children (bitmap-node-children node)] + [len (vector-length children)] + [new-children (make-vector len)]) + (do ([i 0 (+ i 1)]) + ((= i len)) + (vector-set! new-children i (node-map f (vector-ref children i)))) + (make-bitmap-node (bitmap-node-bitmap node) new-children))] + + [(collision-node? node) + (make-collision-node + (collision-node-hash node) + (map (lambda (e) (cons (car e) (f (cdr e)))) + (collision-node-entries node)))] + + [else (error 'node-map "invalid node type" node)])) + + ;; ========== Public API ========== + + (define (hamt-set h key value) + (let ([hash (equal-hash key)]) + (let-values ([(new-root added?) (node-set (hamt-rec-root h) hash key value 0)]) + (make-hamt-rec new-root + (if added? (+ (hamt-rec-count h) 1) (hamt-rec-count h)))))) + + (define (hamt-ref h key default) + (node-ref (hamt-rec-root h) (equal-hash key) key 0 default)) + + (define (hamt-delete h key) + (let ([hash (equal-hash key)]) + (let-values ([(new-root removed?) (node-delete (hamt-rec-root h) hash key 0)]) + (if removed? + (make-hamt-rec new-root (- (hamt-rec-count h) 1)) + h)))) + + (define (hamt-contains? h key) + (let ([sentinel (list 'not-found)]) + (not (eq? (hamt-ref h key sentinel) sentinel)))) + + (define (hamt-size h) + (hamt-rec-count h)) + + (define (hamt-fold proc seed h) + (node-fold proc seed (hamt-rec-root h))) + + (define (hamt-keys h) + (hamt-fold (lambda (k v acc) (cons k acc)) '() h)) + + (define (hamt-values h) + (hamt-fold (lambda (k v acc) (cons v acc)) '() h)) + + (define (hamt-map f h) + (make-hamt-rec (node-map f (hamt-rec-root h)) (hamt-rec-count h))) + + (define (hamt->alist h) + (hamt-fold (lambda (k v acc) (cons (cons k v) acc)) '() h)) + + (define (alist->hamt alist) + (let loop ([pairs alist] [h hamt-empty]) + (if (null? pairs) + h + (loop (cdr pairs) + (hamt-set h (caar pairs) (cdar pairs)))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-persistent.ss @@ -0,0 +1,241 @@ +#!chezscheme +;;; tests/test-persistent.ss -- Tests for (std misc persistent) HAMT + +(import (chezscheme) (std misc persistent)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(printf "--- Persistent HAMT Tests ---~%~%") + +;; ---- 1. empty hamt ---- +(test "empty-hamt?" (hamt? hamt-empty) #t) +(test "empty-size" (hamt-size hamt-empty) 0) +(test "empty-ref" (hamt-ref hamt-empty 'x 'default) 'default) +(test "empty-contains?" (hamt-contains? hamt-empty 'x) #f) +(test "empty->alist" (hamt->alist hamt-empty) '()) +(test "empty-keys" (hamt-keys hamt-empty) '()) +(test "empty-values" (hamt-values hamt-empty) '()) +(test "empty-fold" (hamt-fold (lambda (k v acc) (+ acc 1)) 0 hamt-empty) 0) + +;; ---- 2. single insert and lookup ---- +(let ([h (hamt-set hamt-empty "hello" 42)]) + (test "single-hamt?" (hamt? h) #t) + (test "single-size" (hamt-size h) 1) + (test "single-ref" (hamt-ref h "hello" #f) 42) + (test "single-contains?" (hamt-contains? h "hello") #t) + (test "single-missing" (hamt-ref h "world" 'nope) 'nope) + (test "single-not-contains?" (hamt-contains? h "world") #f)) + +;; ---- 3. multiple inserts ---- +(let* ([h0 hamt-empty] + [h1 (hamt-set h0 'a 1)] + [h2 (hamt-set h1 'b 2)] + [h3 (hamt-set h2 'c 3)]) + (test "multi-size" (hamt-size h3) 3) + (test "multi-ref-a" (hamt-ref h3 'a #f) 1) + (test "multi-ref-b" (hamt-ref h3 'b #f) 2) + (test "multi-ref-c" (hamt-ref h3 'c #f) 3) + (test "multi-missing" (hamt-ref h3 'd #f) #f)) + +;; ---- 4. update existing key ---- +(let* ([h1 (hamt-set hamt-empty 'k 100)] + [h2 (hamt-set h1 'k 200)]) + (test "update-new-value" (hamt-ref h2 'k #f) 200) + (test "update-old-value" (hamt-ref h1 'k #f) 100) ; persistence! + (test "update-size" (hamt-size h2) 1)) + +;; ---- 5. update with same value ---- +(let* ([h1 (hamt-set hamt-empty 'k 42)] + [h2 (hamt-set h1 'k 42)]) + (test "same-value-size" (hamt-size h2) 1)) + +;; ---- 6. delete ---- +(let* ([h (alist->hamt '((a . 1) (b . 2) (c . 3)))] + [h2 (hamt-delete h 'b)]) + (test "delete-size" (hamt-size h2) 2) + (test "delete-removed" (hamt-contains? h2 'b) #f) + (test "delete-kept-a" (hamt-ref h2 'a #f) 1) + (test "delete-kept-c" (hamt-ref h2 'c #f) 3) + ;; original preserved + (test "delete-original" (hamt-size h) 3) + (test "delete-original-b" (hamt-ref h 'b #f) 2)) + +;; ---- 7. delete non-existent key ---- +(let* ([h (hamt-set hamt-empty 'a 1)] + [h2 (hamt-delete h 'nonexistent)]) + (test "delete-nonexist-size" (hamt-size h2) 1) + (test "delete-nonexist-eq" (eq? h h2) #t)) + +;; ---- 8. delete from empty ---- +(let ([h (hamt-delete hamt-empty 'x)]) + (test "delete-empty-size" (hamt-size h) 0)) + +;; ---- 9. delete all keys ---- +(let* ([h (alist->hamt '((a . 1) (b . 2) (c . 3)))] + [h2 (hamt-delete (hamt-delete (hamt-delete h 'a) 'b) 'c)]) + (test "delete-all-size" (hamt-size h2) 0) + (test "delete-all-alist" (hamt->alist h2) '())) + +;; ---- 10. hamt-fold ---- +(let ([h (alist->hamt '((a . 1) (b . 2) (c . 3)))]) + (test "fold-sum" (hamt-fold (lambda (k v acc) (+ v acc)) 0 h) 6) + (test "fold-count" (hamt-fold (lambda (k v acc) (+ acc 1)) 0 h) 3)) + +;; ---- 11. hamt-keys and hamt-values ---- +(let ([h (alist->hamt '((x . 10) (y . 20)))]) + (test "keys-length" (length (hamt-keys h)) 2) + (test "values-length" (length (hamt-values h)) 2) + ;; Order may vary but all keys/values must be present + (test "keys-contain-x" (not (not (member 'x (hamt-keys h)))) #t) + (test "keys-contain-y" (not (not (member 'y (hamt-keys h)))) #t) + (test "values-contain-10" (not (not (member 10 (hamt-values h)))) #t) + (test "values-contain-20" (not (not (member 20 (hamt-values h)))) #t)) + +;; ---- 12. hamt-map ---- +(let* ([h (alist->hamt '((a . 1) (b . 2) (c . 3)))] + [h2 (hamt-map (lambda (v) (* v 10)) h)]) + (test "map-a" (hamt-ref h2 'a #f) 10) + (test "map-b" (hamt-ref h2 'b #f) 20) + (test "map-c" (hamt-ref h2 'c #f) 30) + (test "map-size" (hamt-size h2) 3) + ;; original unchanged + (test "map-orig" (hamt-ref h 'a #f) 1)) + +;; ---- 13. hamt->alist and alist->hamt round-trip ---- +(let* ([original '((x . 10) (y . 20) (z . 30))] + [h (alist->hamt original)] + [al (hamt->alist h)]) + (test "roundtrip-size" (length al) 3) + ;; Check all entries present (order may differ) + (test "roundtrip-x" (cdr (assoc 'x al)) 10) + (test "roundtrip-y" (cdr (assoc 'y al)) 20) + (test "roundtrip-z" (cdr (assoc 'z al)) 30)) + +;; ---- 14. persistence / structural sharing ---- +(let* ([h0 hamt-empty] + [h1 (hamt-set h0 'a 1)] + [h2 (hamt-set h1 'b 2)] + [h3 (hamt-set h2 'c 3)] + [h4 (hamt-delete h3 'a)]) + ;; Each version is independent + (test "persist-h0" (hamt-size h0) 0) + (test "persist-h1" (hamt-size h1) 1) + (test "persist-h2" (hamt-size h2) 2) + (test "persist-h3" (hamt-size h3) 3) + (test "persist-h4" (hamt-size h4) 2) + ;; h1 doesn't see b or c + (test "persist-h1-no-b" (hamt-contains? h1 'b) #f) + (test "persist-h1-no-c" (hamt-contains? h1 'c) #f) + ;; h4 doesn't see a + (test "persist-h4-no-a" (hamt-contains? h4 'a) #f) + (test "persist-h4-has-b" (hamt-contains? h4 'b) #t) + (test "persist-h4-has-c" (hamt-contains? h4 'c) #t)) + +;; ---- 15. various key types ---- +(let* ([h hamt-empty] + [h (hamt-set h 42 "number")] + [h (hamt-set h "str" "string")] + [h (hamt-set h 'sym "symbol")] + [h (hamt-set h '(a b) "list")] + [h (hamt-set h #t "boolean")] + [h (hamt-set h #\x "char")]) + (test "key-number" (hamt-ref h 42 #f) "number") + (test "key-string" (hamt-ref h "str" #f) "string") + (test "key-symbol" (hamt-ref h 'sym #f) "symbol") + (test "key-list" (hamt-ref h '(a b) #f) "list") + (test "key-boolean" (hamt-ref h #t #f) "boolean") + (test "key-char" (hamt-ref h #\x #f) "char") + (test "mixed-size" (hamt-size h) 6)) + +;; ---- 16. stress test: 500 entries ---- +(let ([h (let loop ([h hamt-empty] [i 0]) + (if (= i 500) + h + (loop (hamt-set h i (* i i)) (+ i 1))))]) + (test "stress-size" (hamt-size h) 500) + (test "stress-ref-0" (hamt-ref h 0 #f) 0) + (test "stress-ref-250" (hamt-ref h 250 #f) 62500) + (test "stress-ref-499" (hamt-ref h 499 #f) 249001) + (test "stress-missing" (hamt-ref h 500 'no) 'no) + ;; Delete every other entry + (let ([h2 (let loop ([h h] [i 0]) + (if (= i 500) + h + (loop (if (even? i) (hamt-delete h i) h) (+ i 1))))]) + (test "stress-after-delete-size" (hamt-size h2) 250) + (test "stress-deleted-even" (hamt-contains? h2 0) #f) + (test "stress-kept-odd" (hamt-contains? h2 1) #t) + (test "stress-deleted-100" (hamt-contains? h2 100) #f) + (test "stress-kept-101" (hamt-contains? h2 101) #t))) + +;; ---- 17. alist->hamt with duplicate keys (last wins) ---- +(let ([h (alist->hamt '((a . 1) (b . 2) (a . 3)))]) + (test "alist-dup-value" (hamt-ref h 'a #f) 3) + (test "alist-dup-size" (hamt-size h) 2)) + +;; ---- 18. hamt-map preserves keys ---- +(let* ([h (alist->hamt '((a . 1) (b . 2)))] + [h2 (hamt-map (lambda (v) (string-append "val" (number->string v))) h)]) + (test "map-preserves-key-a" (hamt-ref h2 'a #f) "val1") + (test "map-preserves-key-b" (hamt-ref h2 'b #f) "val2")) + +;; ---- 19. hamt-fold accumulation order ---- +;; fold should visit all entries exactly once +(let* ([h (alist->hamt '((a . 1) (b . 2) (c . 3)))] + [collected (hamt-fold (lambda (k v acc) (cons (cons k v) acc)) '() h)]) + (test "fold-collected-length" (length collected) 3) + (test "fold-has-a" (not (not (assoc 'a collected))) #t) + (test "fold-has-b" (not (not (assoc 'b collected))) #t) + (test "fold-has-c" (not (not (assoc 'c collected))) #t)) + +;; ---- 20. type predicate ---- +(test "hamt?-true" (hamt? hamt-empty) #t) +(test "hamt?-set" (hamt? (hamt-set hamt-empty 'k 1)) #t) +(test "hamt?-false-list" (hamt? '()) #f) +(test "hamt?-false-num" (hamt? 42) #f) +(test "hamt?-false-str" (hamt? "hello") #f) + +;; ---- 21. string keys (common use case) ---- +(let* ([h hamt-empty] + [h (hamt-set h "name" "Alice")] + [h (hamt-set h "email" "alice@example.com")] + [h (hamt-set h "age" 30)]) + (test "string-keys-name" (hamt-ref h "name" #f) "Alice") + (test "string-keys-email" (hamt-ref h "email" #f) "alice@example.com") + (test "string-keys-age" (hamt-ref h "age" #f) 30) + (test "string-keys-size" (hamt-size h) 3)) + +;; ---- 22. large-scale correctness ---- +;; Insert 1000 keys, verify all, delete all, verify empty +(let ([h (let loop ([h hamt-empty] [i 0]) + (if (= i 1000) h + (loop (hamt-set h i (number->string i)) (+ i 1))))]) + (test "large-size" (hamt-size h) 1000) + ;; Verify every key + (let ([all-ok (let loop ([i 0]) + (if (= i 1000) #t + (if (equal? (hamt-ref h i #f) (number->string i)) + (loop (+ i 1)) + #f)))]) + (test "large-all-present" all-ok #t)) + ;; Delete all + (let ([h2 (let loop ([h h] [i 0]) + (if (= i 1000) h + (loop (hamt-delete h i) (+ i 1))))]) + (test "large-delete-all" (hamt-size h2) 0))) + +(printf "~%Results: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) (exit 1))