108 lines
3.3 KiB
Scheme
108 lines
3.3 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
;Date: Thu, 4 Nov 93 14:34:04 EST
|
||
|
|
;Subject: binary search trees
|
||
|
|
;From: kelsey@research.nj.nec.com
|
||
|
|
;
|
||
|
|
;If you want to add the Hilbert tables I think you should change
|
||
|
|
;the name and add some documentation. Neither the name nor the
|
||
|
|
;only comment in the file are particulary informative. They are
|
||
|
|
;not infinite dimensional vectors, just arbitrarily large one
|
||
|
|
;dimensional ones.
|
||
|
|
;
|
||
|
|
;How about make-big-vector etc.?
|
||
|
|
|
||
|
|
|
||
|
|
; Hilbert vectors are like vectors that grow as large as they need to.
|
||
|
|
; That is, they can be indexed by arbitrarily large nonnegative integers.
|
||
|
|
|
||
|
|
; The implementation allows for arbitrarily large gaps by arranging
|
||
|
|
; the entries in a tree.
|
||
|
|
|
||
|
|
; So-called because they live in an infinite-dimensional vector
|
||
|
|
; space...
|
||
|
|
|
||
|
|
; ,open bitwise define-record-types
|
||
|
|
|
||
|
|
|
||
|
|
(define hilbert-log 8)
|
||
|
|
(define hilbert-node-size (arithmetic-shift 1 hilbert-log))
|
||
|
|
(define hilbert-mask (- hilbert-node-size 1))
|
||
|
|
(define minus-hilbert-log (- 0 hilbert-log))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
(define-record-type hilbert :hilbert
|
||
|
|
(really-make-hilbert height root)
|
||
|
|
(height hilbert-height set-hilbert-height!)
|
||
|
|
(root hilbert-root set-hilbert-root!))
|
||
|
|
|
||
|
|
(define (make-hilbert)
|
||
|
|
(really-make-hilbert 1 (make-vector hilbert-node-size #f)))
|
||
|
|
|
||
|
|
|
||
|
|
(define (hilbert-ref hilbert index)
|
||
|
|
(let recur ((height (hilbert-height hilbert))
|
||
|
|
(index index))
|
||
|
|
(if (= height 1)
|
||
|
|
(let ((root (hilbert-root hilbert)))
|
||
|
|
(if (< index (vector-length root))
|
||
|
|
(vector-ref root index)
|
||
|
|
#f))
|
||
|
|
(let ((node (recur (- height 1)
|
||
|
|
(arithmetic-shift index minus-hilbert-log))))
|
||
|
|
(if node
|
||
|
|
(vector-ref node (bitwise-and index hilbert-mask))
|
||
|
|
#f)))))
|
||
|
|
|
||
|
|
(define (hilbert-set! hilbert index value)
|
||
|
|
(vector-set!
|
||
|
|
(let recur ((height (hilbert-height hilbert))
|
||
|
|
(index index))
|
||
|
|
(if (= height 1)
|
||
|
|
(make-higher-if-necessary hilbert index)
|
||
|
|
(let ((index (arithmetic-shift index minus-hilbert-log)))
|
||
|
|
(make-node-if-necessary
|
||
|
|
(recur (- height 1) index)
|
||
|
|
(bitwise-and index hilbert-mask)))))
|
||
|
|
(bitwise-and index hilbert-mask)
|
||
|
|
value))
|
||
|
|
|
||
|
|
(define (make-higher-if-necessary hilbert index)
|
||
|
|
(if (< index hilbert-node-size)
|
||
|
|
(hilbert-root hilbert)
|
||
|
|
(let ((new-root (make-vector hilbert-node-size #f)))
|
||
|
|
(write `(higher ,index)) (newline)
|
||
|
|
(vector-set! new-root 0 (hilbert-root hilbert))
|
||
|
|
(set-hilbert-root! hilbert new-root)
|
||
|
|
(set-hilbert-height! hilbert (+ (hilbert-height hilbert) 1))
|
||
|
|
(let ((index (arithmetic-shift index minus-hilbert-log)))
|
||
|
|
(make-node-if-necessary (make-higher-if-necessary hilbert index)
|
||
|
|
(bitwise-and index hilbert-mask))))))
|
||
|
|
|
||
|
|
(define (make-node-if-necessary node index)
|
||
|
|
(or (vector-ref node index)
|
||
|
|
(let ((new (make-vector hilbert-node-size #f)))
|
||
|
|
;; (write `(wider ,index)) (newline)
|
||
|
|
(vector-set! node index new)
|
||
|
|
new)))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
; For debugging
|
||
|
|
;(define (hilbert->list h)
|
||
|
|
; (let recur ((node (hilbert-root h))
|
||
|
|
; (height (hilbert-height h))
|
||
|
|
; (more '()))
|
||
|
|
; (if (= height 0)
|
||
|
|
; (if (or node (pair? more))
|
||
|
|
; (cons node more)
|
||
|
|
; '())
|
||
|
|
; (do ((i (- hilbert-node-size 1) (- i 1))
|
||
|
|
; (more more (recur (if node
|
||
|
|
; (vector-ref node i)
|
||
|
|
; #f)
|
||
|
|
; (- height 1) more)))
|
||
|
|
; ((< i 0) more)))))
|