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

39
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
(if (not (vector? tree))
0
(let ((len (vector-length tree))) (let ((len (vector-length tree)))
(do ((i 0 (+ i 1)))
((>= i len) 0)
(display 'foo)
(display (((vector-ref tree i)'get-data)))
(display 'foo)
(dump-rec (vector-ref tree i))
))))
(define (dump)
(dump-rec *tree))
(define (add-rec str tree) ;; root param in b-treenode ;; refactor call-with-values
(let ((lefttree ((tree 'get-left)))
(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))) (do ((i 0 (+ i 1)))
((cond ((>= i (- len 1));;last node ((cond ((>= i (- len 1));;last node
(do ((j 0 (+ j 1))) (do ((j 0 (+ j 1)))
((= j len) (display "node not added.") 0) ((= j len) (display "node not added.") 0)
(add-rec str (vector-ref j tree))) (add-rec str (vector-ref j tree)))
))) )
((and (string<? str (((vector-ref tree i) 'get-data))) ((and (string<? str (((vector-ref lefttree i) 'get-data)))
(string>? str (((vector-ref tree (+ i 1)) 'get-data)))) (string>? str (((vector-ref lefttree (+ i 1)) 'get-data))))
(let ((lr (vector-median tree))) (let ((lr (vector-median lefttree)))
(let ((new-node (make-b-tree-node (car lr) (cadr lr)))) (let ((new-node (make-b-tree-node (car lr) (cadr lr))))
((new-node 'set-data!) str) ((new-node 'set-data!) str)
(vector-set! tree i new-node) (vector-set! tree i new-node)
))) )))
((string=? str (((vector-ref tree i)'get-data))) ((string=? str (((vector-ref lefttree i)'get-data)))
(set! i (vector-length tree))) (set! i (vector-length tree)))
(else (display "never reached."))))) (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))