peter
/
UNSLISP
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

set: add insert multiple test

This commit is contained in:
Peter McGoron 2024-08-31 10:53:29 -04:00
parent f160ecaae1
commit 931cd50159
1 changed files with 110 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

142
set.scm
View File

@ -113,7 +113,7 @@
(lighter-dir (%set:invdir heavier-dir))) (lighter-dir (%set:invdir heavier-dir)))
(let ((heavy-heavy (%set:get heavier heavier-dir)) (let ((heavy-heavy (%set:get heavier heavier-dir))
(heavy-light (%set:get heavier lighter-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 (let ((node (%set:node val
heavier-dir heavy-light heavier-dir heavy-light
lighter-dir lighter))) lighter-dir lighter)))
@ -134,17 +134,13 @@
node node
(%set:rotate node heavier-dir))))))))) (%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 (define set:join
(lambda (left val right) (lambda (val dir1 node1 dir2 node2)
(let ((diff (%set:diff left right))) (let ((diff (%set:height-diff node1 node2)))
(cond (cond
((> diff 1) (%set:join left val right '<)) ((> diff 1) (%set:join node1 val node2 dir1))
((< diff -1) (%set:join right val left '>)) ((< diff -1) (%set:join node2 val node1 dir2))
(else (set:node val '< left '> right)))))) (else (%set:node val dir1 node1 dir2 node2))))))
(define set:join2 (define set:join2
(letrec (letrec
@ -153,20 +149,19 @@
(if (null? left) (if (null? left)
right right
(let ((split-last-tree (split-last left))) (let ((split-last-tree (split-last left)))
(set:join (bst:get split-last-tree '<) (set:join (%set:get split-last-tree '=)
(bst:get split-last-tree '=) '< (%set:get split-last-tree '<)
right))))) '> right)))))
(split-last (split-last
(lambda (tree) (lambda (tree)
(let ((right (set:get tree '>))) (let ((right (%set:get tree '>)))
(if (null? right) (if (null? right)
tree tree
(let ((last (split-last right))) (let ((last (split-last right)))
(bst:node (set:get last '=) (%set:node (%set:get last '=)
(join (set:get tree '<) (set:join (%set:get tree '=)
(set:get tree '=) '< (%set:get tree '<)
(set:get last '<)) '> (%set:get last '>)))))))))
'())))))))
join2)) join2))
;;; ;;;;;;;;;;;;;;;;; ;;; ;;;;;;;;;;;;;;;;;
@ -187,7 +182,7 @@
(let ((dir (<=> (%set:get tree '=) data))) (let ((dir (<=> (%set:get tree '=) data)))
(if (eq? dir '=) (if (eq? dir '=)
tree tree
(loop (set:get tree dir)))))))) (loop (%set:get tree dir))))))))
(loop tree))))) (loop tree)))))
;;; (SET:INSERT <=>) generates an insert function for comparison function ;;; (SET:INSERT <=>) generates an insert function for comparison function
@ -205,17 +200,16 @@
(if (null? tree) (if (null? tree)
node node
(let ((dir (<=> (%set:get tree '=) (let ((dir (<=> (%set:get tree '=)
(%set:get node '=))) (%set:get node '=))))
(left (%set:get tree '<))
(right (%set:get tree '>)))
(if (eq? dir '=) (if (eq? dir '=)
(begin (begin
(set! found tree) (set! found tree)
(set:node (set:get node '=) (%set:node (%set:get node '=)
'< left '> right)) '< left '> right))
(join (set:node (%set:get tree '=) (let ((invdir (%set:invdir dir)))
dir (loop left) (set:join (%set:get tree '=)
(set:invdir dir) right)))))))) dir (loop (%set:get tree dir))
invdir (%set:get tree invdir)))))))))
(let ((newtree (loop tree))) (let ((newtree (loop tree)))
(cons newtree found))))))) (cons newtree found)))))))
@ -235,16 +229,16 @@
(if (null? tree) (if (null? tree)
node node
(let ((dir (<=> (%set:get tree '=) (let ((dir (<=> (%set:get tree '=)
(%set:get node '=))) (%set:get node '=))))
(left (%set:get tree '<))
(right (%set:get tree '>)))
(if (eq? dir '=) (if (eq? dir '=)
(begin (begin
(set! found tree) (set! found tree)
(set:join2 left right)) (set:join2 (%set:get tree '<)
(join (set:node (%set:get tree '=) (%set:get tree '>)))
dir (loop left) (let ((invdir (%set:invdir dir)))
(set:invdir dir) right)))))))) (set:join (%set:get tree '=)
dir (loop (%set:get tree dir))
invdir (%set:get tree invdir)))))))))
(let ((newtree (loop tree))) (let ((newtree (loop tree)))
(cons newtree found))))))) (cons newtree found)))))))
@ -260,11 +254,23 @@
((string>? x y) '>) ((string>? x y) '>)
(else '=))))) (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<=> (define map:string<=>
(lambda (x y) (lambda (x y)
(string<=> (car x) (car y)))) (string<=> (car x) (car y))))
(define %smap:insert (set:insert map:string<=>)) (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 (define smap:insert
(lambda (tree key val) (lambda (tree key val)
(%smap:insert tree (%set:node (cons key val) (%smap:insert tree (%set:node (cons key val)
@ -272,6 +278,8 @@
'> '())))) '> '()))))
(define %smap:search (set:in map:string<=>)) (define %smap:search (set:in map:string<=>))
;;; (SMAP:SEARCH TREE KEY)
(define smap:search (define smap:search
(lambda (tree key) (lambda (tree key)
(%smap:search tree (cons key '())))) (%smap:search tree (cons key '()))))
@ -287,6 +295,46 @@
(define smap:val (define smap:val
(lambda (node) (cdr (%set:get node '=)))) (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 (define %set:tests
(list (list
(cons "rotate right" (cons "rotate right"
@ -354,4 +402,30 @@
((not (cdr delete-return)) "string not found") ((not (cdr delete-return)) "string not found")
((not (eqv? (car delete-return) '())) ((not (eqv? (car delete-return) '()))
"returned tree not null") "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)))))))))))))) (else #t))))))))))))))