diff --git a/set.scm b/set.scm index f43a19f..c870af9 100644 --- a/set.scm +++ b/set.scm @@ -113,7 +113,7 @@ (lighter-dir (%set:invdir heavier-dir))) (let ((heavy-heavy (%set:get heavier heavier-dir)) (heavy-light (%set:get heavier lighter-dir))) - (if (<= (abs (%avl:diff heavy-light lighter) 1)) + (if (<= (abs (%set:height-diff heavy-light lighter)) 1) (let ((node (%set:node val heavier-dir heavy-light lighter-dir lighter))) @@ -134,17 +134,13 @@ node (%set:rotate node heavier-dir))))))))) -;;; JOIN takes two trees and the data for a node, such that all nodes -;;; in LEFT are less than or equal to VAL, and all nodes in RIGHT are -;;; greater than or equal to VAL, and outputs a balanced binary search -;;; tree. (define set:join - (lambda (left val right) - (let ((diff (%set:diff left right))) + (lambda (val dir1 node1 dir2 node2) + (let ((diff (%set:height-diff node1 node2))) (cond - ((> diff 1) (%set:join left val right '<)) - ((< diff -1) (%set:join right val left '>)) - (else (set:node val '< left '> right)))))) + ((> diff 1) (%set:join node1 val node2 dir1)) + ((< diff -1) (%set:join node2 val node1 dir2)) + (else (%set:node val dir1 node1 dir2 node2)))))) (define set:join2 (letrec @@ -153,20 +149,19 @@ (if (null? left) right (let ((split-last-tree (split-last left))) - (set:join (bst:get split-last-tree '<) - (bst:get split-last-tree '=) - right))))) + (set:join (%set:get split-last-tree '=) + '< (%set:get split-last-tree '<) + '> right))))) (split-last (lambda (tree) - (let ((right (set:get tree '>))) + (let ((right (%set:get tree '>))) (if (null? right) tree (let ((last (split-last right))) - (bst:node (set:get last '=) - (join (set:get tree '<) - (set:get tree '=) - (set:get last '<)) - '()))))))) + (%set:node (%set:get last '=) + (set:join (%set:get tree '=) + '< (%set:get tree '<) + '> (%set:get last '>))))))))) join2)) ;;; ;;;;;;;;;;;;;;;;; @@ -187,7 +182,7 @@ (let ((dir (<=> (%set:get tree '=) data))) (if (eq? dir '=) tree - (loop (set:get tree dir)))))))) + (loop (%set:get tree dir)))))))) (loop tree))))) ;;; (SET:INSERT <=>) generates an insert function for comparison function @@ -205,17 +200,16 @@ (if (null? tree) node (let ((dir (<=> (%set:get tree '=) - (%set:get node '=))) - (left (%set:get tree '<)) - (right (%set:get tree '>))) + (%set:get node '=)))) (if (eq? dir '=) (begin (set! found tree) - (set:node (set:get node '=) - '< left '> right)) - (join (set:node (%set:get tree '=) - dir (loop left) - (set:invdir dir) right)))))))) + (%set:node (%set:get node '=) + '< left '> right)) + (let ((invdir (%set:invdir dir))) + (set:join (%set:get tree '=) + dir (loop (%set:get tree dir)) + invdir (%set:get tree invdir))))))))) (let ((newtree (loop tree))) (cons newtree found))))))) @@ -235,16 +229,16 @@ (if (null? tree) node (let ((dir (<=> (%set:get tree '=) - (%set:get node '=))) - (left (%set:get tree '<)) - (right (%set:get tree '>))) + (%set:get node '=)))) (if (eq? dir '=) (begin (set! found tree) - (set:join2 left right)) - (join (set:node (%set:get tree '=) - dir (loop left) - (set:invdir dir) right)))))))) + (set:join2 (%set:get tree '<) + (%set:get tree '>))) + (let ((invdir (%set:invdir dir))) + (set:join (%set:get tree '=) + dir (loop (%set:get tree dir)) + invdir (%set:get tree invdir))))))))) (let ((newtree (loop tree))) (cons newtree found))))))) @@ -260,11 +254,23 @@ ((string>? x y) '>) (else '=))))) +(cond-expand + ((and (not miniscm-unslisp) (not r7rs)) + (define (list-set! lst n val) + (if (= n 0) + (set-car! lst val) + (list-set! (cdr lst) (- n 1) val))))) + (define map:string<=> (lambda (x y) (string<=> (car x) (car y)))) (define %smap:insert (set:insert map:string<=>)) + +;;; (SMAP:INSERT TREE KEY VAL) inserts (CONS KEY VAL) into TREE, and +;;; returns (CONS NEWROOT FOUND), where NEWROOT is the new root of +;;; the tree, and FOUND is #F if no element matching KEY was found, +;;; or the matching element if found. (define smap:insert (lambda (tree key val) (%smap:insert tree (%set:node (cons key val) @@ -272,6 +278,8 @@ '> '())))) (define %smap:search (set:in map:string<=>)) + +;;; (SMAP:SEARCH TREE KEY) (define smap:search (lambda (tree key) (%smap:search tree (cons key '())))) @@ -287,6 +295,46 @@ (define smap:val (lambda (node) (cdr (%set:get node '=)))) +;;; ;;;;; +;;; Tests +;;; ;;;;; + +;;; LST is a list of elements of the form +;;; (KEY VAL ALREADY-IN) +;;; where ALREADY-IN is #F for an element not in the set, or the value +;;; that should be in the set. + +(define %set:operate-all + (lambda (f tree lst) + (if (null? lst) + tree + (let ((key (list-ref (car lst) 0)) + (val (list-ref (car lst) 1)) + (already-in (list-ref (car lst) 2))) + (let ((insert-return (f tree key val))) + (cond + ((and already-in (not (cdr insert-return))) + "should have been found") + ((and already-in (not (equal? already-in + (smap:val (cdr insert-return))))) + "found is not correct") + (else (%set:operate-all f (car insert-return) (cdr lst))))))))) + +(define %set:insert-all + (lambda (tree lst) + (%set:operate-all smap:insert tree lst))) + +(define %set:search-all + (lambda (tree lst) + (%set:operate-all (lambda (tree key _) + (let ((search-res (smap:search tree key))) + (cons tree search-res))) tree lst))) + +(define %set:delete-all + (lambda (tree lst) + (%set:operate-all (lambda (tree key _) + (smap:delete tree key)) tree lst))) + (define %set:tests (list (cons "rotate right" @@ -354,4 +402,30 @@ ((not (cdr delete-return)) "string not found") ((not (eqv? (car delete-return) '())) "returned tree not null") - (else #t)))))))))))))) + (else #t)))))))))))) + (cons "insert a few unique then delete" + (lambda () + (let ((to-insert (list + (list (string #\a #\b #\c) 1 #f) + (list (string #\a #\b #\d) 2 #f) + (list (string #\d #\e #\f) 3 #f) + (list (string #\1 #\2 #\3 #\a #\C) 4 #f)))) + (display "insert all") (newline) + (let ((tree (%set:insert-all '() to-insert))) + (if (string? tree) + tree + (begin + (for-each (lambda (x) + (list-set! x 2 (list-ref x 1))) + to-insert) + (display "search all") (newline) + (let ((res (%set:search-all tree to-insert))) + (if (string? res) + res + (begin + (display "delete all") (newline) + (let ((tree (%set:delete-all tree to-insert))) + (cond + ((string? tree) tree) + ((not (null? tree)) "did not delete everything") + (else #t))))))))))))))