set: add insert multiple test

1 files changed, 110 insertions, 36 deletions

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))))))))))))))