scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

xanadu - btree

This commit is contained in:
erana 2012-01-21 14:35:56 +09:00
parent dcb0d28ae1
commit d510987da3
1 changed files with 44 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
scsh/xanadu/b-tree.scm
View File

@ -75,7 +75,7 @@
dispatch)) dispatch))
(define (make-b-tree n-ary);;NOTE FIXME n-ary and vector-length (define (make-b-tree n-ary);;NOTE FIXME n-ary and vector-length
(let ((*tree (make-vector n-ary (make-b-tree-node (make-vector n-ary) (make-vector n-ary))))) (let ((*tree (make-b-tree-node (make-vector n-ary) (make-vector n-ary))))
(define (vector-median v) (define (vector-median v)
(let ((len (ceiling (/ (vector-length v) 2)))) (let ((len (ceiling (/ (vector-length v) 2))))
@ -106,24 +106,45 @@
(define (search str) (define (search str)
(search-rec str *tree)) (search-rec str *tree))
(define (add-rec str tree) ;; root param in b-treenode (define (dump-rec tree) ;; root param in b-treenode
(let ((len (vector-length tree))) (if (not (vector? tree))
(do ((i 0 (+ i 1))) 0
((cond ((>= i (- len 1));;last node (let ((len (vector-length tree)))
(do ((j 0 (+ j 1))) (do ((i 0 (+ i 1)))
((= j len) (display "node not added.") 0) ((>= i len) 0)
(add-rec str (vector-ref j tree))) (display 'foo)
))) (display (((vector-ref tree i)'get-data)))
((and (string<? str (((vector-ref tree i) 'get-data))) (display 'foo)
(string>? str (((vector-ref tree (+ i 1)) 'get-data)))) (dump-rec (vector-ref tree i))
(let ((lr (vector-median tree))) ))))
(let ((new-node (make-b-tree-node (car lr) (cadr lr))))
((new-node 'set-data!) str) (define (dump)
(vector-set! tree i new-node) (dump-rec *tree))
)))
((string=? str (((vector-ref tree i)'get-data))) (define (add-rec str tree) ;; root param in b-treenode ;; refactor call-with-values
(set! i (vector-length tree))) (let ((lefttree ((tree 'get-left)))
(else (display "never reached."))))) (righttree ((tree 'get-right))))
;;len (vector-length ((tree 'get-left)))))
(call-with-values
(lambda () (values lefttree righttree))
(lambda (lefttree righttree)
(do ((i 0 (+ i 1)))
((cond ((>= i (- len 1));;last node
(do ((j 0 (+ j 1)))
((= j len) (display "node not added.") 0)
(add-rec str (vector-ref j tree)))
)
((and (string<? str (((vector-ref lefttree i) 'get-data)))
(string>? str (((vector-ref lefttree (+ i 1)) 'get-data))))
(let ((lr (vector-median lefttree)))
(let ((new-node (make-b-tree-node (car lr) (cadr lr))))
((new-node 'set-data!) str)
(vector-set! tree i new-node)
)))
((string=? str (((vector-ref lefttree i)'get-data)))
(set! i (vector-length tree)))
(else (display "never reached.")))))
))))
(define (add str) (define (add str)
(add-rec str *tree)) (add-rec str *tree))
@ -131,9 +152,11 @@
(define (dispatch msg) (define (dispatch msg)
(cond ((eq? msg 'add) add) (cond ((eq? msg 'add) add)
((eq? msg 'search) search) ((eq? msg 'search) search)
((eq? msg 'dump) dump)
(else (display "b-tree : message not understood.")))) (else (display "b-tree : message not understood."))))
dispatch)) dispatch))
(define (bt) (make-b-tree 2)) (define bt (make-b-tree 2))
((bt 'add) "abc") ((bt 'add) "abc")
;;((bt 'dump))