| Lynn Winebarger 2004-07-16, 3:59 pm |
|
Jamie wrote:
> Well, fair enough.
>
> How about this question, out of curiosity:
>
> What is Scheme used for, in general? It seems not to be a production
> language, used to write actual software, like C or C++ or Java. Does its
> simplicity make it good for theory-of-computation experiments or test
> cases, as the very long and mathematical thread started by Bill Richter
> above seems to imply?
>
> Thanks,
>
> Jamie
I don't know about anybody else, but I tend to use Scheme as a higher-order
assembly language. But you have to get so used to CPS that it's second
nature.
For example, I recently implemented AVL trees (first time for me).
I found Knuth's presentation completely ugly. The reason CPS is useful
for this problem is that it allows you to do multiway decision making,
and keep a locality of lexical reference.
Take deletion from the tree. Knuth's style would have you build a stack
of nodes that might need readjusting as you descend. Then after that, you
revisit the nodes in the stack. At this point, the nodes are sort of
anonymous - the code that considers them coming down the stack has to use
"adjustment factors" that encode information noticed descending the tree.
This CPS version builds the stack implicitly with continuations, but the
information held by the adjustment factors in Knuth's version is now
explicitly represented by the much more informative continuation names.
I'm not saying this is the most efficient implementation, but I find it
much more comprehensible (for first learning the structure of the AVL tree
node deletion problem) than Knuth's more optimized version.
Also in my first version, there was no "make-<x>-height-decreased-k",
instead I just wrote them out directly as closures, and then noticed the same code
appeared all over.
If you write out the insertion algorithm this way, you'll see the
"make-<x>-height-increased-k" is almost the same as "make-<y>-height-decreased-k"
except that the new child node is on the opposite side [where (x,y) = (right,left) or
(left,right)]. It's tempting to reduce them all to one make-make-height-changed-k
macro, but it's not clear that makes the code any more readable.
Lynn
(define delete-key
(lambda (root key)
(if (null-node? root)
root
(lookup/delete root key
(lambda (new-root) new-root)
(lambda (new-root) new-root)
(lambda () root)))))
(define lookup/delete
(lambda (node key height-unchanged-k height-decreased-k escape-k)
(if (null-node? node)
(escape-k)
(let ([node-key (node->key node)])
(cond
[(key-eq? key node-key)
(inner-delete-node node height-unchanged-k height-decreased-k escape-k)]
[(key-< key node-key)
;; go left
(lookup/delete (node->left node) key
(make-left-height-unchanged-k node height-unchanged-k)
(make-left-height-decreased-k node height-unchanged-k height-decreased-k)
escape-k)]
[else ;; assume total ordering - i.e. (key-< node-key key)
;; go right
(lookup/delete (node->right node) key
(make-right-height-unchanged-k node height-unchanged-k)
(make-right-height-decreased-k node height-unchanged-k height-decreased-k)
escape-k)])))))
(define inner-delete-node
(lambda (node height-unchanged-k height-decreased-k escape-k)
(let ([l (node->left node)]
[r (node->right node)]
[b (node->balance node)])
(cond
[(null-node? r)
(height-decreased-k l)]
[(null-node? l)
(height-decreased-k r)]
[else
;; new-node is a communication channel that allows us to use the height-x-k
;; makers even though we don't know what the key and value are at this moment.
;; [ We're simply moving the key/value of the least successor of the key
;; we're deleting to this position, and then _actually_ deleting that
;; key (which has no left child) ]
(let ([new-node (make-node 'foo1 'foo2 (node->balance node) l 'foo5)])
;; go down left spine of the right child until we find a node with no left child
(let descend ([t r]
[height-unchanged-k (make-right-height-unchanged-k new-node height-unchanged-k)]
[height-decreased-k (make-right-height-decreased-k new-node height-unchanged-k height-decreased-k)])
(if (null-node? (node->left t))
(begin
(set-key! new-node (node->key t))
(set-value! new-node (node->value t))
(height-decreased-k (node->right t)))
(descend (node->left t)
(make-left-height-unchanged-k t height-unchanged-k)
(make-left-height-decreased-k t height-unchanged-k height-decreased-k)))))]))))
(define make-left-height-decreased-k
(lambda (node height-unchanged-k height-decreased-k)
(lambda (new-left-node)
;; I know the height of my left subtree is 1 less than before
(let ([new-node-balance (+ (node->balance node) 1)])
;; am I too skewed to the right?
(if (> new-node-balance 1)
(let ([r (node->right node)])
(if (>= (node->balance r) 0)
;; single rotation, height may decrease or stay the same
(rotate-left (make-node (node->key node) (node->value node)
new-node-balance new-left-node r)
cannot-increase height-unchanged-k height-decreased-k)
;; else (< (node->balance r) 0)
;; do double rotation
(rotate-right r cannot-increase
(lambda (rotated-r)
(rotate-left (make-node (node->key node) (node->value node) new-node-balance
new-left-node rotated-r)
cannot-increase must-change height-decreased-k))
cannot-decrease)))
((if (<= new-node-balance 0) height-decreased-k height-unchanged-k)
(make-node (node->key node) (node->value node) new-node-balance
new-left-node (node->right node))))))))
(define make-right-height-decreased-k
(lambda (node height-unchanged-k height-decreased-k)
(lambda (new-right-node)
;; I know the height of my right subtree is 1 less than before
(let ([new-node-balance (- (node->balance node) 1)]
[l (node->left node)])
;; am I too skewed to the left?
(if (< new-node-balance -1)
(if (<= (node->balance l) 0)
;; single rotation, height remains the same (as before insertion)
(rotate-right (make-node (node->key node) (node->value node)
new-node-balance l new-right-node)
cannot-increase height-unchanged-k height-decreased-k)
;; else (> (node->balance l) 0)
;; do double rotation
(rotate-left l cannot-increase
(lambda (rotated-l)
(rotate-right (make-node (node->key node) (node->value node) new-node-balance
rotated-l new-right-node)
cannot-increase must-change height-decreased-k))
cannot-decrease))
((if (>= new-node-balance 0) height-decreased-k height-unchanged-k)
(make-node (node->key node) (node->value node) new-node-balance
l new-right-node)))))))
(define make-left-height-unchanged-k
(lambda (node height-unchanged-k)
(lambda (new-left-node)
(height-unchanged-k
(make-node (node->key node) (node->value node) (node->balance node)
new-left-node (node->right node))))))
(define make-right-height-unchanged-k
(lambda (node height-unchanged-k)
(lambda (new-right-node)
(height-unchanged-k
(make-node (node->key node) (node->value node) (node->balance node)
(node->left node) new-right-node)))))
(define null-node #())
(define null-node? (lambda (node) (eq? node #())))
(define make-node (lambda (key value balance left right) `#(,key ,value ,balance ,left ,right)))
(define node->key (lambda (node) (vector-ref node 0)))
(define node->value (lambda (node) (vector-ref node 1)))
(define node->balance
(lambda (node)
(if (null-node? node)
0
(vector-ref node 2))))
(define node->left (lambda (node) (vector-ref node 3)))
(define node->right (lambda (node) (vector-ref node 4)))
(define set-key! (lambda (node key) (vector-set! node 0 key) node))
(define set-value! (lambda (node value) (vector-set! node 1 value) node))
(define set-balance! (lambda (node balance) (vector-set! node 2 balance) node))
(define set-left! (lambda (node left) (vector-set! node 3 left) node))
(define set-right! (lambda (node right) (vector-set! node 4 right) node))
;;; the following are not fully tested. I adapted them from fully commented versions
;;; that show the constructions are correct for any height and balance.
(define rotate-left
(lambda (root height-increased-k height-unchanged-k height-decreased-k)
(let ([r (node->right root)]
[b (node->balance root)])
(let ([new-left (make-node (node->key root) (node->value root) 'foo (node->left root) (node->left r))]
[rb (node->balance r)])
(let ([new-root (make-node (node->key r) (node->value r) 'foo new-left (node->right r))])
(cond
[(<= b 0)
(cond
[(<= rb 0)
(set-balance! new-left (- b 1))
(set-balance! new-root (+ b rb -2))
(height-increased-k new-root)]
[else ;;(> rb 0)
(set-balance! new-left (- b rb 1))
(set-balance! new-root (- b 2))
(height-increased-k new-root)])]
[(> b 0)
(cond
[(<= rb 0)
(set-balance! new-left (- b 1))
(set-balance! new-root (- rb 1))
(height-unchanged-k new-root)]
[else ;;(> rb 0)
(set-balance! new-left (- b rb 1))
(set-balance! new-root (- (min (- b 1) rb) 1))
(if (= b 1)
(height-unchanged-k new-root)
(height-decreased-k new-root))])]))))))
(define rotate-right
(lambda (root height-increased-k height-unchanged-k height-decreased-k)
(let ([l (node->left root)]
[b (node->balance root)])
(let ([new-right (make-node (node->key root) (node->value root) 'foo (node->right l) (node->right root))]
[lb (node->balance l)])
(let ([new-root (make-node (node->key l) (node->value l) 'foo (node->left l) new-right)])
(cond
[(< b 0)
(cond
[(< lb 0)
(set-balance! new-right (- (1+ b) lb))
(set-balance! new-root (+ (max lb (1+ b)) 1))
(if (= b -1)
(height-unchanged-k new-root)
(height-decreased-k new-root))]
[else ;;(>= lb 0)
(set-balance! new-right (+ b 1))
(set-balance! new-root (+ lb 1))
(height-unchanged-k new-root)])]
[else ;;(>= b 0)
(cond
[(< lb 0)
(set-balance! new-right (- (1+ b) lb))
(set-balance! new-root (+ b 2))
(height-increased-k new-root)]
[else ;;(>= lb 0)
(set-balance! new-right (+ b 1))
(set-balance! new-root (+ b lb 2))
(height-increased-k new-root)])]))))))
|