diff --git a/src/lib/hash-tree.rls b/src/lib/hash-tree.rls deleted file mode 100644 index a7329d4..0000000 --- a/src/lib/hash-tree.rls +++ /dev/null @@ -1,121 +0,0 @@ -;; Requires: make-structure equal? - -(define s:hash-tree-node (make-structure '() 5)) -(define (make-hash-tree-node hash key val [left #f] [right #f]) - (let ([node (make-struct s:hash-tree-node)]) - (struct-set! node 0 hash) - (struct-set! node 1 key) - (struct-set! node 2 val) - (struct-set! node 3 left) - (struct-set! node 4 right) - node)) - -(define (hash-tree-node-hash node) (struct-ref node 0)) -(define (hash-tree-node-key node) (struct-ref node 1)) -(define (hash-tree-node-value node) (struct-ref node 2)) -(define (hash-tree-node-left-child node) (struct-ref node 3)) -(define (hash-tree-node-right-child node) (struct-ref node 4)) - -(define (hash-tree-node-hash-set! node v) (struct-set! node 0 v)) -(define (hash-tree-node-key-set! node v) (struct-set! node 1 v)) -(define (hash-tree-node-value-set! node v) (struct-set! node 2 v)) -(define (hash-tree-node-left-child-set! node v) (struct-set! node 3 v)) -(define (hash-tree-node-right-child-set! node v) (struct-set! node 4 v)) - -(define s:hash-tree (make-structure '() 3)) -(define (make-hash-tree [hash-fn (lambda (x) (hash-value x))] - [eq-fn (lambda (x y) (equal? x y))]) - (let ([ht (make-struct s:hash-tree)]) - (struct-set! ht 0 hash-fn) - (struct-set! ht 1 eq-fn) - (struct-set! ht 2 #f) - ht)) - -(define (hash-tree-hash-function ht) (struct-ref ht 0)) -(define (hash-tree-eq-function ht) (struct-ref ht 1)) -(define (hash-tree-root-node ht) (struct-ref ht 2)) - -(define (hash-tree-hash-function-set! ht v) (struct-set! ht 0 v)) -(define (hash-tree-eq-function-set! ht v) (struct-set! ht 1 v)) -(define (hash-tree-root-node-set! ht v) (struct-set! ht 2 v)) - -(define (hash-tree-lookup ht key [not-found (lambda () #f)]) - (let ([hash ((hash-tree-hash-function ht) key)] - [eq-fn (hash-tree-eq-function ht)]) - (let search ([node (hash-tree-root-node ht)]) - (if node - (let ([node-hash (hash-tree-node-hash node)]) - (cond - [(and (fix= hash node-hash) - (eq-fn (hash-tree-node-key node) key)) - (hash-tree-node-value node)] - [(fix<= hash node-hash) - (search (hash-tree-node-left-child node))] - [else - (search (hash-tree-node-right-child node))])) - (not-found))))) - -; TODO: Implement balancing -(define (hash-tree-insert ht key val [collision (lambda (oldv) val)]) - (let ([hash ((hash-tree-hash-function ht) key)] - [eq-fn (hash-tree-eq-function ht)]) - (if (not (hash-tree-root-node ht)) - (hash-tree-root-node-set! ht - (make-hash-tree-node hash key val)) - (let search ([node (hash-tree-root-node ht)]) - (let ([node-hash (hash-tree-node-hash node)]) - (cond - [(and (fix= hash node-hash) - (eq-fn (hash-tree-node-key node) key)) - (hash-tree-node-value-set! node - (collision (hash-tree-node-value node)))] - [(fix<= hash node-hash) - (let ([child (hash-tree-node-left-child node)]) - (if child - (search child) - (hash-tree-node-left-child-set! node - (make-hash-tree-node hash key val))))] - [else - (let ([child (hash-tree-node-right-child node)]) - (if child - (search child) - (hash-tree-node-right-child-set! node - (make-hash-tree-node hash key val))))])))))) - -(define (hash-tree-remove ht key [not-found (lambda () #f)]) - (let ([hash ((hash-tree-hash-function ht) key)] - [eq-fn (hash-tree-eq-function ht)]) - (let search ([node (hash-tree-root-node ht)] - [replace-node! (lambda (n) (hash-tree-root-node-set! ht n))]) - (if node - (let ([node-hash (hash-tree-node-hash node)]) - (cond - [(and (fix= hash node-hash) - (eq-fn (hash-tree-node-key node) key)) - (let ([oldval (hash-tree-node-value node)] - [left (hash-tree-node-left-child node)] - [right (hash-tree-node-right-child node)]) - (cond - [(not left) (replace-node! right)] - [(not right) (replace-node! left)] - [else - (let find-leftmost ([parent node] [lnode right]) - (let ([lc (hash-tree-node-left-child lnode)]) - (if lc - (find-leftmost lnode lc) - (let ([rc (hash-tree-node-right-child lnode)]) - (hash-tree-node-left-child-set! parent rc) - (hash-tree-node-left-child-set! lnode left) - (unless (eq? lnode right) - (hash-tree-node-right-child-set! lnode right)) - (replace-node! lnode)))))]) - oldval)] - [(fix<= hash node-hash) - (search (hash-tree-node-left-child node) - (lambda (n) (hash-tree-node-left-child-set! node n)))] - [else - (search (hash-tree-node-right-child node) - (lambda (n) (hash-tree-node-right-child-set! node n)))])) - (not-found))))) - -; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/test-hash-table.rls b/src/test-hash-table.rls index 0ef26fd..4978277 100644 --- a/src/test-hash-table.rls +++ b/src/test-hash-table.rls @@ -2,6 +2,9 @@ (load "lib/primitive/foldl.rls") (load "lib/primitive/map.rls") (load "lib/util.rls") +(load "lib/parameters.rls") +(load "lib/abort.rls") +(load "lib/errors.rls") (load "lib/hash-table.rls") (define ht (make-hash-table)) diff --git a/src/test-port.rls b/src/test-port.rls index bbcb4c8..e8321b4 100644 --- a/src/test-port.rls +++ b/src/test-port.rls @@ -6,11 +6,11 @@ ;;(load "lib/primitive/append.rls") (load "lib/syntax.rls") ;(load "lib/util.rls") -;(load "lib/hash-table.rls") -;(load "lib/symbols.rls") ;(load "lib/parameters.rls") ;(load "lib/abort.rls") ;(load "lib/errors.rls") +;(load "lib/hash-table.rls") +;(load "lib/symbols.rls") ;(load "lib/port.rls") ;(load "lib/display.rls") ;(load "lib/reader.rls") diff --git a/src/test-writer.rls b/src/test-writer.rls index 830c266..e0e09b7 100644 --- a/src/test-writer.rls +++ b/src/test-writer.rls @@ -5,12 +5,12 @@ (load "lib/primitive/map.rls") (load "lib/primitive/append.rls") (load "lib/util.rls") -(load "lib/hash-table.rls") -(load "lib/symbols.rls") -(load "lib/keywords.rls") (load "lib/parameters.rls") (load "lib/abort.rls") (load "lib/errors.rls") +(load "lib/hash-table.rls") +(load "lib/symbols.rls") +(load "lib/keywords.rls") (load "lib/port.rls") (load "lib/display.rls") (load "lib/writer.rls")