set: add update
This commit is contained in:
parent
931cd50159
commit
ad49a18de5
225
set.scm
225
set.scm
|
|
@ -32,7 +32,7 @@
|
|||
(else (error "invalid direction")))))
|
||||
|
||||
;;; Gets data from node value given accessor symbol.
|
||||
(define %set:get
|
||||
(define set:get
|
||||
(lambda (t sym)
|
||||
(vector-ref t (%set:accessor sym))))
|
||||
|
||||
|
|
@ -40,16 +40,16 @@
|
|||
(lambda (node)
|
||||
(if (null? node)
|
||||
'()
|
||||
(list (list 'data (%set:get node '=))
|
||||
(list '< (%set->sexpr (%set:get node '<)))
|
||||
(list '> (%set->sexpr (%set:get node '>)))))))
|
||||
(list (list 'data (set:get node '=))
|
||||
(list '< (%set->sexpr (set:get node '<)))
|
||||
(list '> (%set->sexpr (set:get node '>)))))))
|
||||
|
||||
;;; Get the height of a node, handling the empty node.
|
||||
(define %set:height
|
||||
(lambda (node)
|
||||
(if (null? node)
|
||||
0
|
||||
(%set:get node 'h))))
|
||||
(set:get node 'h))))
|
||||
|
||||
;;; Get the difference between the heights of two trees.
|
||||
(define %set:height-diff
|
||||
|
|
@ -58,8 +58,8 @@
|
|||
|
||||
;;; Get the balance factor of a tree.
|
||||
(define %set:bal
|
||||
(lambda (t) (%set:height-diff (%set:get t '<)
|
||||
(%set:get t '>))))
|
||||
(lambda (t) (%set:height-diff (set:get t '<)
|
||||
(set:get t '>))))
|
||||
|
||||
;;; Set data in node given accessor symbol.
|
||||
(define %set:set!
|
||||
|
|
@ -77,6 +77,12 @@
|
|||
(%set:set! node dir2 node2)
|
||||
node)))
|
||||
|
||||
(define set:node-new-val
|
||||
(lambda (node newval)
|
||||
(%set:node newval
|
||||
'< (set:get node '<)
|
||||
'> (set:get node '>))))
|
||||
|
||||
(define %set:invdir
|
||||
(lambda (dir)
|
||||
(cond
|
||||
|
|
@ -94,13 +100,13 @@
|
|||
(if (null? node)
|
||||
#f
|
||||
(let ((invdir (%set:invdir dir)))
|
||||
(let ((child (%set:get node invdir)))
|
||||
(let ((to-swap (%set:get child dir)))
|
||||
(%set:node (%set:get child '=)
|
||||
dir (%set:node (%set:get node '=)
|
||||
dir (%set:get node dir)
|
||||
(let ((child (set:get node invdir)))
|
||||
(let ((to-swap (set:get child dir)))
|
||||
(%set:node (set:get child '=)
|
||||
dir (%set:node (set:get node '=)
|
||||
dir (set:get node dir)
|
||||
invdir to-swap)
|
||||
invdir (%set:get child invdir))))))))
|
||||
invdir (set:get child invdir))))))))
|
||||
|
||||
;;; ;;;;;;;;;;;;;;;;;;;
|
||||
;;; JOIN function for AVL trees.
|
||||
|
|
@ -109,10 +115,10 @@
|
|||
;;; Handles rebalancing of the tree.
|
||||
(define %set:join
|
||||
(lambda (heavier val lighter heavier-dir)
|
||||
(let ((heavy-val (%set:get heavier '=))
|
||||
(let ((heavy-val (set:get heavier '=))
|
||||
(lighter-dir (%set:invdir heavier-dir)))
|
||||
(let ((heavy-heavy (%set:get heavier heavier-dir))
|
||||
(heavy-light (%set:get heavier lighter-dir)))
|
||||
(let ((heavy-heavy (set:get heavier heavier-dir))
|
||||
(heavy-light (set:get heavier lighter-dir)))
|
||||
(if (<= (abs (%set:height-diff heavy-light lighter)) 1)
|
||||
(let ((node (%set:node val
|
||||
heavier-dir heavy-light
|
||||
|
|
@ -149,19 +155,19 @@
|
|||
(if (null? left)
|
||||
right
|
||||
(let ((split-last-tree (split-last left)))
|
||||
(set:join (%set:get split-last-tree '=)
|
||||
'< (%set:get split-last-tree '<)
|
||||
(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)))
|
||||
(%set:node (%set:get last '=)
|
||||
(set: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))
|
||||
|
||||
;;; ;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -179,10 +185,32 @@
|
|||
(lambda (tree)
|
||||
(if (null? tree)
|
||||
#f
|
||||
(let ((dir (<=> (%set:get tree '=) data)))
|
||||
(let ((dir (<=> (set:get tree '=) data)))
|
||||
(if (eq? dir '=)
|
||||
tree
|
||||
(loop (%set:get tree dir))))))))
|
||||
(loop (set:get tree dir))))))))
|
||||
(loop tree)))))
|
||||
|
||||
;;; (SET:UPDATE <=>) generates an update function for <=>.
|
||||
;;; (UPDATE TREE NODE UPDATE) inserts (UPDATE NODE #F) into the tree if
|
||||
;;; no node comparing equal to NODE is found, and (UPDATE NODE OLD) if
|
||||
;;; OLD compares equal to NODE.
|
||||
(define set:update
|
||||
(lambda (<=>)
|
||||
(lambda (tree node update)
|
||||
(letrec
|
||||
((loop
|
||||
(lambda (tree)
|
||||
(if (null? tree)
|
||||
(update node #f)
|
||||
(let ((dir (<=> (set:get tree '=)
|
||||
(set:get node '=))))
|
||||
(if (eq? dir '=)
|
||||
(update node tree)
|
||||
(let ((invdir (%set:invdir dir)))
|
||||
(set:join (set:get tree '=)
|
||||
dir (loop (set:get tree dir))
|
||||
invdir (set:get tree invdir)))))))))
|
||||
(loop tree)))))
|
||||
|
||||
;;; (SET:INSERT <=>) generates an insert function for comparison function
|
||||
|
|
@ -191,27 +219,18 @@
|
|||
;;; (CONS NEWTREE FOUND), where FOUND is the node that was replaced by
|
||||
;;; NODE, and #F otherwise, and NEWTREE is the new root of the tree.
|
||||
(define set:insert
|
||||
(lambda (<=>)
|
||||
(lambda (update)
|
||||
(lambda (tree node)
|
||||
(let ((found #f))
|
||||
(letrec
|
||||
((loop
|
||||
(lambda (tree)
|
||||
(if (null? tree)
|
||||
(let ((newroot (update tree node
|
||||
(lambda (node oldnode)
|
||||
(if (not oldnode)
|
||||
node
|
||||
(let ((dir (<=> (%set:get tree '=)
|
||||
(%set:get node '=))))
|
||||
(if (eq? dir '=)
|
||||
(begin
|
||||
(set! found tree)
|
||||
(%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)))))))
|
||||
(set! found oldnode)
|
||||
(set:node-new-val oldnode
|
||||
(set:get node '=))))))))
|
||||
(cons newroot found))))))
|
||||
|
||||
;;; (SET:DELETE <=>) generates a delete function for comparison function
|
||||
;;; <=>.
|
||||
|
|
@ -228,20 +247,48 @@
|
|||
(lambda (tree)
|
||||
(if (null? tree)
|
||||
node
|
||||
(let ((dir (<=> (%set:get tree '=)
|
||||
(%set:get node '=))))
|
||||
(let ((dir (<=> (set:get tree '=)
|
||||
(set:get node '=))))
|
||||
(if (eq? dir '=)
|
||||
(begin
|
||||
(set! found tree)
|
||||
(set:join2 (%set:get tree '<)
|
||||
(%set:get tree '>)))
|
||||
(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)))))))))
|
||||
(set:join (set:get tree '=)
|
||||
dir (loop (set:get tree dir))
|
||||
invdir (set:get tree invdir)))))))))
|
||||
(let ((newtree (loop tree)))
|
||||
(cons newtree found)))))))
|
||||
|
||||
;;; ;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Converting sets to maps
|
||||
;;; ;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; Convert a <=> for sets to one for maps.
|
||||
(define set:<=>-to-map
|
||||
(lambda (<=>)
|
||||
(lambda (x y)
|
||||
(<=> (car x) (car y)))))
|
||||
|
||||
(define map:node-new-val
|
||||
(lambda (node newkey newval)
|
||||
(set:node-new-val node
|
||||
(cons newkey newval))))
|
||||
|
||||
(define map:empty-node
|
||||
(lambda (key val)
|
||||
(%set:node (cons key val)
|
||||
'< '() '> '())))
|
||||
|
||||
(define map:key
|
||||
(lambda (node)
|
||||
(car (set:get node '=))))
|
||||
|
||||
(define map:val
|
||||
(lambda (node)
|
||||
(cdr (set:get node '=))))
|
||||
|
||||
;;; ;;;;;;;;;;;
|
||||
;;; For strings
|
||||
;;; ;;;;;;;;;;;
|
||||
|
|
@ -261,11 +308,18 @@
|
|||
(set-car! lst val)
|
||||
(list-set! (cdr lst) (- n 1) val)))))
|
||||
|
||||
(define map:string<=>
|
||||
(lambda (x y)
|
||||
(string<=> (car x) (car y))))
|
||||
(define map:string<=> (set:<=>-to-map string<=>))
|
||||
|
||||
(define %smap:insert (set:insert map:string<=>))
|
||||
(define %smap:update (set:update map:string<=>))
|
||||
(define %smap:insert (set:insert %smap:update))
|
||||
|
||||
;;; (SMAP:UPDATE TREE KEY UPDATE) updates NODE in TREE with
|
||||
;;; (UPDATE NODE-WITH-KEY NODE), where NODE-WITH-KEY is an empty node
|
||||
;;; with the key KEY, and (UPDATE NODE-WITH-KEY #F) if no NODE is
|
||||
;;; found.
|
||||
(define smap:update
|
||||
(lambda (tree key update)
|
||||
(%smap:update tree (map:empty-node key '()) update)))
|
||||
|
||||
;;; (SMAP:INSERT TREE KEY VAL) inserts (CONS KEY VAL) into TREE, and
|
||||
;;; returns (CONS NEWROOT FOUND), where NEWROOT is the new root of
|
||||
|
|
@ -273,9 +327,7 @@
|
|||
;;; or the matching element if found.
|
||||
(define smap:insert
|
||||
(lambda (tree key val)
|
||||
(%smap:insert tree (%set:node (cons key val)
|
||||
'< '()
|
||||
'> '()))))
|
||||
(%smap:insert tree (map:empty-node key val))))
|
||||
|
||||
(define %smap:search (set:in map:string<=>))
|
||||
|
||||
|
|
@ -287,13 +339,7 @@
|
|||
(define %smap:delete (set:delete map:string<=>))
|
||||
(define smap:delete
|
||||
(lambda (tree key)
|
||||
(%smap:delete tree (%set:node (cons key '())
|
||||
'< '() '> '()))))
|
||||
|
||||
(define smap:key
|
||||
(lambda (node) (car (%set:get node '=))))
|
||||
(define smap:val
|
||||
(lambda (node) (cdr (%set:get node '=))))
|
||||
(%smap:delete tree (map:empty-node key '()))))
|
||||
|
||||
;;; ;;;;;
|
||||
;;; Tests
|
||||
|
|
@ -316,7 +362,7 @@
|
|||
((and already-in (not (cdr insert-return)))
|
||||
"should have been found")
|
||||
((and already-in (not (equal? already-in
|
||||
(smap:val (cdr insert-return)))))
|
||||
(map:val (cdr insert-return)))))
|
||||
"found is not correct")
|
||||
(else (%set:operate-all f (car insert-return) (cdr lst)))))))))
|
||||
|
||||
|
|
@ -350,12 +396,12 @@
|
|||
'> (%set:node 5 '< '() '> '()))
|
||||
'>)))
|
||||
(cond
|
||||
((not (eqv? (%set:get right '=) 2)) "bad parent")
|
||||
((not (eqv? (%set:get (%set:get right '>) '=) 1)) "bad right child")
|
||||
((not (eqv? (%set:get (%set:get right '<) '=) 3)) "bad left child")
|
||||
((not (eqv? (%set:get (%set:get (%set:get right '>) '>) '=) 5))
|
||||
((not (eqv? (set:get right '=) 2)) "bad parent")
|
||||
((not (eqv? (set:get (set:get right '>) '=) 1)) "bad right child")
|
||||
((not (eqv? (set:get (set:get right '<) '=) 3)) "bad left child")
|
||||
((not (eqv? (set:get (set:get (set:get right '>) '>) '=) 5))
|
||||
"bad right child of right child")
|
||||
((not (eqv? (%set:get (%set:get (%set:get right '>) '<) '=) 4))
|
||||
((not (eqv? (set:get (set:get (set:get right '>) '<) '=) 4))
|
||||
"bad left child of right child")
|
||||
(else #t)))))
|
||||
(cons "rotate left"
|
||||
|
|
@ -371,12 +417,12 @@
|
|||
'< (%set:node 5 '< '() '> '()))
|
||||
'<)))
|
||||
(cond
|
||||
((not (eqv? (%set:get right '=) 2)) "bad parent")
|
||||
((not (eqv? (%set:get (%set:get right '>) '=) 4)) "bad right child")
|
||||
((not (eqv? (%set:get (%set:get right '<) '=) 1)) "bad left child")
|
||||
((not (eqv? (%set:get (%set:get (%set:get right '<) '>) '=) 3))
|
||||
((not (eqv? (set:get right '=) 2)) "bad parent")
|
||||
((not (eqv? (set:get (set:get right '>) '=) 4)) "bad right child")
|
||||
((not (eqv? (set:get (set:get right '<) '=) 1)) "bad left child")
|
||||
((not (eqv? (set:get (set:get (set:get right '<) '>) '=) 3))
|
||||
"bad right child of left child")
|
||||
((not (eqv? (%set:get (%set:get (%set:get right '<) '<) '=) 5))
|
||||
((not (eqv? (set:get (set:get (set:get right '<) '<) '=) 5))
|
||||
"bad left child of left child")
|
||||
(else #t)))))
|
||||
(cons "insert then delete"
|
||||
|
|
@ -390,9 +436,9 @@
|
|||
(let ((found (smap:search tree (string #\a))))
|
||||
(cond
|
||||
((not found) "string not in tree")
|
||||
((not (equal? (smap:key tree) (string #\a)))
|
||||
((not (equal? (map:key tree) (string #\a)))
|
||||
"returned key not equal to a")
|
||||
((not (equal? (smap:val tree) 5))
|
||||
((not (equal? (map:val tree) 5))
|
||||
"returned value not equal to 5")
|
||||
(else
|
||||
(let ((delete-return (smap:delete tree (string #\a))))
|
||||
|
|
@ -428,4 +474,29 @@
|
|||
(cond
|
||||
((string? tree) tree)
|
||||
((not (null? tree)) "did not delete everything")
|
||||
(else #t))))))))))))))
|
||||
(else #t))))))))))))
|
||||
(cons "insert a few, update"
|
||||
(lambda ()
|
||||
(let ((tree (%set:insert-all '()
|
||||
(list
|
||||
(list (string #\a #\b #\c #\d) 1 #f)
|
||||
(list (string #\e #\f #\g #\h) 2 #f)
|
||||
(list (string #\1 #\4 #\2 #\9 #\3) 3 #f)
|
||||
(list (string #\a #\b #\c #\d #\e) 4 #f)))))
|
||||
(if (string? tree)
|
||||
tree
|
||||
(let ((tree (smap:update tree
|
||||
(string #\a #\b #\c #\d #\e)
|
||||
(lambda (node oldnode)
|
||||
(map:node-new-val oldnode
|
||||
(string #\a #\b #\c #\d #\e)
|
||||
10)))))
|
||||
(let ((res (%set:search-all tree
|
||||
(list
|
||||
(list (string #\a #\b #\c #\d) 1 1)
|
||||
(list (string #\e #\f #\g #\h) 2 2)
|
||||
(list (string #\1 #\4 #\2 #\9 #\3) 3 3)
|
||||
(list (string #\a #\b #\c #\d #\e) 10 10)))))
|
||||
(if (string? res)
|
||||
res
|
||||
#t)))))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue