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

set: add update

This commit is contained in:
Peter McGoron 2024-09-04 00:54:11 -04:00
parent 931cd50159
commit ad49a18de5
1 changed files with 150 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

225
set.scm
View File

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