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 15:17:53 +09:00
parent d510987da3
commit 06f87b279e
1 changed files with 30 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -41,6 +41,7 @@
(set! data value)) (set! data value))
(define (get-left) (define (get-left)
(display "get-left")
left) left)
(define (get-right) (define (get-right)
@ -72,10 +73,12 @@
((eq? msg 'get-right) ((eq? msg 'get-right)
get-right) get-right)
(else (display "b-tree-node : message not understood"))))) (else (display "b-tree-node : message not understood")))))
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-b-tree-node (make-vector n-ary) (make-vector n-ary)))) (let ((*tree (make-b-tree-node;; #f #f)))
(make-vector n-ary (make-b-tree-node #f #f))
(make-vector n-ary (make-b-tree-node #f #f)))))
(define (vector-median v) (define (vector-median v)
(let ((len (ceiling (/ (vector-length v) 2)))) (let ((len (ceiling (/ (vector-length v) 2))))
@ -122,32 +125,45 @@
(dump-rec *tree)) (dump-rec *tree))
(define (add-rec str tree) ;; root param in b-treenode ;; refactor call-with-values (define (add-rec str tree) ;; root param in b-treenode ;; refactor call-with-values
(let ((lefttree ((tree 'get-left))) (let ((lefttree (tree 'get-left));;FIXME
(righttree ((tree 'get-right)))) (righttree (tree 'get-right)))
;;len (vector-length ((tree 'get-left))))) ;;len (vector-length ((tree 'get-left)))))
(call-with-values (call-with-values
(lambda () (values lefttree righttree)) (lambda () (values lefttree righttree))
(lambda (lefttree righttree) (lambda (lefttree righttree)
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((cond ((>= i (- len 1));;last node ((cond ((or lefttree
(do ((j 0 (+ j 1))) (not (((vector-ref lefttree i) 'get-data)))
((= j len) (display "node not added.") 0) (string=? (((vector-ref lefttree i) 'get-data)) ""))
(add-rec str (vector-ref j tree))) (display 'FOO1)
) (let ((lr (vector-median lefttree)))
(let ((new-node (make-b-tree-node (car lr) (cadr lr))));;FIXME lenght mustbe n-ary
((new-node 'set-data!) str)
(vector-set! lefttree i new-node)
)))
((and (string<? str (((vector-ref lefttree i) 'get-data))) ((and (string<? str (((vector-ref lefttree i) 'get-data)))
(string>? str (((vector-ref lefttree (+ i 1)) 'get-data)))) (string>? str (((vector-ref lefttree (+ i 1)) 'get-data))))
(let ((lr (vector-median lefttree))) (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! lefttree i new-node)
))) )))
((string=? str (((vector-ref lefttree i)'get-data))) ;;((string=? str (((vector-ref lefttree i)'get-data)))
(set! i (vector-length tree))) ;; (set! i (vector-length tree)))
((>= i (- len 1));;last node
(do ((j 0 (+ j 1)))
((= j len) (display "node not added.") 0)
(add-rec str (vector-ref lefttree i)))
)
(else (display "never reached."))))) (else (display "never reached.")))))
)))) ))))
(define (add str) (define (add str)
(add-rec str *tree)) (display "FOO")
(add-rec str *tree)
(display "FOO")
)
(define (dispatch msg) (define (dispatch msg)
(cond ((eq? msg 'add) add) (cond ((eq? msg 'add) add)
@ -158,5 +174,5 @@
(define bt (make-b-tree 2)) (define bt (make-b-tree 2))
((bt 'add) "abc") ((bt 'add)"abc")
;;((bt 'dump)) ;;((bt 'dump))