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

xanadu - xml b-tree - 2

This commit is contained in:
erana 2012-01-21 00:39:06 +09:00
parent 48057882f2
commit 0e25720779
1 changed files with 14 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -26,6 +26,13 @@
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define (vector-median v)
(let ((retv (make-vector (inexact->exact (/ (vector-length v) 2)))))
(do ((i 0 (+ i 1)))
((= i (/ (vector-length v) 2)) retv)
(vector-set! retv i (vector-ref v i))
)))
(define (make-b-tree) (define (make-b-tree)
(let ((*tree (make-vector 0))) (let ((*tree (make-vector 0)))
@ -33,10 +40,14 @@
(cond ((= (vector-length tree) i) (display "null node") (vector-set! tree i str)) (cond ((= (vector-length tree) i) (display "null node") (vector-set! tree i str))
(else #f))) (else #f)))
(define (add-rec str tree) (define (grow-up upper-node)
(cond ((eq? node *tree)
(set! *tree (vector-median *tree
(define (add-rec str tree upper-node)
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((eq? i (vector-length tree)) ((eq? i (vector-length tree))
(grow-up) (grow-up upper-node)
(let ((vi (vector-ref tree i))) (let ((vi (vector-ref tree i)))
(cond ((string<=? str vi) (cond ((string<=? str vi)
0) 0)
@ -48,7 +59,7 @@
)) ))
(define (add str) (define (add str)
(add-rec *tree)) (add-rec *tree *tree))
(define (dispatch msg) (define (dispatch msg)
(cond ((eq? msg 'add) add) (cond ((eq? msg 'add) add)