nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Update test code for various library routine API changes.

This commit is contained in:
Jesse D. McDonald 2012-07-06 10:55:07 -05:00
parent b4be240d6f
commit b923693c61
4 changed files with 8 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

121
src/lib/hash-tree.rls
View File

@ -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:

3
src/test-hash-table.rls
View File

@ -2,6 +2,9 @@
(load "lib/primitive/foldl.rls") (load "lib/primitive/foldl.rls")
(load "lib/primitive/map.rls") (load "lib/primitive/map.rls")
(load "lib/util.rls") (load "lib/util.rls")
(load "lib/parameters.rls")
(load "lib/abort.rls")
(load "lib/errors.rls")
(load "lib/hash-table.rls") (load "lib/hash-table.rls")
(define ht (make-hash-table)) (define ht (make-hash-table))

4
src/test-port.rls
View File

@ -6,11 +6,11 @@
;;(load "lib/primitive/append.rls") ;;(load "lib/primitive/append.rls")
(load "lib/syntax.rls") (load "lib/syntax.rls")
;(load "lib/util.rls") ;(load "lib/util.rls")
;(load "lib/hash-table.rls")
;(load "lib/symbols.rls")
;(load "lib/parameters.rls") ;(load "lib/parameters.rls")
;(load "lib/abort.rls") ;(load "lib/abort.rls")
;(load "lib/errors.rls") ;(load "lib/errors.rls")
;(load "lib/hash-table.rls")
;(load "lib/symbols.rls")
;(load "lib/port.rls") ;(load "lib/port.rls")
;(load "lib/display.rls") ;(load "lib/display.rls")
;(load "lib/reader.rls") ;(load "lib/reader.rls")

6
src/test-writer.rls
View File

@ -5,12 +5,12 @@
(load "lib/primitive/map.rls") (load "lib/primitive/map.rls")
(load "lib/primitive/append.rls") (load "lib/primitive/append.rls")
(load "lib/util.rls") (load "lib/util.rls")
(load "lib/hash-table.rls")
(load "lib/symbols.rls")
(load "lib/keywords.rls")
(load "lib/parameters.rls") (load "lib/parameters.rls")
(load "lib/abort.rls") (load "lib/abort.rls")
(load "lib/errors.rls") (load "lib/errors.rls")
(load "lib/hash-table.rls")
(load "lib/symbols.rls")
(load "lib/keywords.rls")
(load "lib/port.rls") (load "lib/port.rls")
(load "lib/display.rls") (load "lib/display.rls")
(load "lib/writer.rls") (load "lib/writer.rls")