set: add insert multiple test
This commit is contained in:
parent
f160ecaae1
commit
931cd50159
142
set.scm
142
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 '=)
|
||||
(%set:node (%set:get node '=)
|
||||
'< left '> right))
|
||||
(join (set:node (%set:get tree '=)
|
||||
dir (loop left)
|
||||
(set:invdir dir) 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))))))))))))
|
||||
(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))))))))))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue