UNSLISP/set.scm

632 lines
24 KiB
Scheme

;;; Copyright (C) Peter McGoron 2024
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, version 3 of the License.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Persistent AVL sets and maps using JOIN.
;;; ;;;;;;;;;;;;;;;;
;;; Nodes, direction
;;; ;;;;;;;;;;;;;;;;
;;; Returns the slot number for
;;; =: The node data
;;; h: the height
;;; <: the left child
;;; >: the right child
(define %set:accessor
(lambda (sym)
(cond
((eq? sym '=) 0)
((eq? sym 'h) 1)
((eq? sym '<) 2)
((eq? sym '>) 3)
(else (error "invalid direction")))))
;;; Gets data from node value given accessor symbol.
(define set:get
(lambda (t sym)
(let ((acc (%set:accessor sym)))
(if (null? t)
(cond
((eq? sym 'h) 0)
(else '()))
(vector-ref t (%set:accessor sym))))))
(define %set->sexpr
(lambda (node)
(if (null? node)
'()
(list (list 'data (set:get node '=))
(list '< (%set->sexpr (set:get node '<)))
(list '> (%set->sexpr (set:get node '>)))))))
(cond-expand
(chicken
(import (chicken process))
(define (set:display set)
(call-with-output-pipe
"dot -T png > /tmp/dot.png"
(lambda (out)
(letrec
((D
(lambda (o)
(display o out)
(display o)))
(dump-data
(lambda (tree)
(D "\"")
(D (set:get tree '=))
(D "\"")))
(connect
(lambda (parent child)
(if (null? child)
'()
(begin
(dump-data parent)
(D " -> ")
(dump-data child)
(D " ;\n")
(loop child)))))
(loop
(lambda (parent)
(if (null? parent)
'()
(begin
(connect parent (set:get parent '<))
(connect parent (set:get parent '>)))))))
(D "digraph t {\n")
(loop set)
(D "}\n"))))
(system "imv-wayland /tmp/dot.png")))
(else
(define set:display
(lambda (set)
(display (%set->sexpr set))
(newline)))))
;;; Get the height of a node, handling the empty node.
(define %set:height
(lambda (node)
(if (null? node)
0
(set:get node 'h))))
;;; Get the difference between the heights of two trees.
(define %set:height-diff
(lambda (t1 t2)
(- (%set:height t1) (%set:height t2))))
;;; Get the balance factor of a tree.
(define %set:bal
(lambda (t) (%set:height-diff (set:get t '<)
(set:get t '>))))
;;; Set data in node given accessor symbol.
(define %set:set!
(lambda (node dir x)
(vector-set! node (%set:accessor dir) x)))
;;; Construct a new tree with data VAL.
(define %set:node
(lambda (val dir1 node1 dir2 node2)
(let ((node (vector val (+ 1
(max (%set:height node1)
(%set:height node2)))
'() '())))
(%set:set! node dir1 node1)
(%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
((eq? dir '<) '>)
((eq? dir '>) '<)
(else (error "invalid direction")))))
;;; ;;;;;;;;;;;;;;
;;; Tree rotations
;;; ;;;;;;;;;;;;;;
;;; Rotate NODE to the left (dir = '>) or right (dir = '<).
(define %set:rotate
(lambda (node dir)
(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)
invdir to-swap)
invdir (set:get child invdir))))))))
;;; ;;;;;;;;;;;;;;;;;;;
;;; JOIN function for AVL trees.
;;; ;;;;;;;;;;;;;;;;;;;
;;; Handles rebalancing of the tree.
(define %set:join
(lambda (heavier val lighter heavier-dir)
(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)))
(if (<= (abs (%set:height-diff heavy-light lighter)) 1)
(let ((node (%set:node val
heavier-dir heavy-light
lighter-dir lighter)))
(if (<= (%set:height-diff node heavy-heavy) 1)
(%set:node heavy-val
heavier-dir heavy-heavy
lighter-dir node)
(%set:rotate (%set:node heavy-val
heavier-dir heavy-heavy
lighter-dir
(%set:rotate node lighter-dir))
heavier-dir)))
(let ((new-light (%set:join heavy-light val lighter heavier-dir)))
(let ((node (%set:node heavy-val
heavier-dir heavy-heavy
lighter-dir new-light)))
(if (<= (abs (%set:bal node)) 1)
node
(%set:rotate node heavier-dir)))))))))
(define set:join
(lambda (val dir1 node1 dir2 node2)
(let ((diff (%set:height-diff node1 node2)))
(cond
((> 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
((join2
(lambda (left right)
(if (null? left)
right
(let ((split-last-tree (split-last left)))
(set:join (set:get split-last-tree '=)
'< (set:get split-last-tree '<)
'> right)))))
(split-last
(lambda (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 '>))
'> '())))))))
join2))
(define set:split
(lambda (<=>)
(letrec
((split
(lambda (set data)
(if (null? set)
(%set:node #f '< '() '> '())
(let ((set-data (set:get set '=)))
(let ((dir (<=> data set-data)))
(if (eq? dir '=)
(set:node-new-val set #t)
(let ((new-tree (split (set:get set dir) data))
(invdir (%set:invdir dir)))
(%set:node (set:get new-tree '=)
dir (set:get new-tree dir)
invdir (set:join set-data
dir (set:get new-tree invdir)
invdir (set:get set invdir)))))))))))
split)))
;;; ;;;;;;;;;;;;;
;;; Set functions
;;; ;;;;;;;;;;;;;
;;; Generate union operation from split operation.
;;; Union prioritizes data in PRIORITY over keys in SECONDARY.
(define set:union
(lambda (split)
(letrec
((union
(lambda (priority secondary)
(cond
((null? priority) secondary)
((null? secondary) priority)
(else
(let ((key (set:get priority '=)))
(let ((split-tree (split secondary key)))
(set:join key
'< (union (set:get priority '<)
(set:get split-tree '<))
'> (union (set:get priority '>)
(set:get split-tree '>))))))))))
union)))
;;; ;;;;;;;;;;;;;;;;;
;;; Element functions
;;; ;;;;;;;;;;;;;;;;;
;;; (SET:IN <=>) generates a search function for comparison function <=>.
;;; (SEARCH TREE DATA) searches TREE for a node that matches DATA.
;;; It will return the node that contains the matched DATA, or '().
(define set:in
(lambda (<=>)
(lambda (tree data)
(letrec
((loop
(lambda (tree)
(if (null? tree)
'()
(let ((dir (<=> data (set:get tree '=))))
(if (eq? dir '=)
tree
(loop (set:get tree dir))))))))
(loop tree)))))
;;; (SET:UPDATE <=>) generates an update function for <=>.
;;; (UPDATE TREE DATA UPDATE) inserts a node with data (UPDATE DATA #F)
;;; into the tree if no node comparing equal to DATA is found, and a node
;;; with data (UPDATE DATA OLD) if OLD compares equal to NODE.
(define set:update
(lambda (<=>)
(lambda (tree data update)
(letrec
((loop
(lambda (tree)
(if (null? tree)
(%set:node (update data '()) '< '() '> '())
(let ((dir (<=> data (set:get tree '=))))
(if (eq? dir '=)
(%set:node (update data tree)
'< (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)))))))))
(loop tree)))))
;;; (SET:INSERT <=>) generates an insert function for comparison function
;;; <=>.
;;; (INSERT TREE DATA) inserts a node with DATA into TREE. It returns
;;; (CONS NEWTREE FOUND), where FOUND is the node that was replaced by
;;; the node, and '() otherwise, and NEWTREE is the new root of the tree.
(define set:insert
(lambda (update)
(lambda (tree node)
(let ((found '()))
(let ((newroot (update tree node
(lambda (data oldnode)
(set! found oldnode)
data))))
(cons newroot found))))))
;;; (SET:DELETE <=>) generates a delete function for comparison function
;;; <=>.
;;; (DELETE TREE DATA) deletes a node from TREE that compares equal to
;;; DATA. The function returns (CONS NEWTREE FOUND), where FOUND is the
;;; deleted node, or '() if not found, and NEWTREE is the root of the new
;;; tree.
(define set:delete
(lambda (<=>)
(lambda (tree data)
(let ((found '()))
(letrec
((loop
(lambda (tree)
(if (null? tree)
'()
(let ((dir (<=> data (set:get tree '=))))
(if (eq? dir '=)
(begin
(set! found 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)))))))))
(let ((newtree (loop tree)))
(cons newtree found)))))))
;;; ;;;;;;;;;;;;;;;;;;;;;;;
;;; Converting sets to maps
;;;
;;; The conversion stores (CONS KEY VAL) into each pair.
;;; ;;;;;;;;;;;;;;;;;;;;;;;
;;; Convert a <=> for sets to one for maps.
(define set:<=>-to-map
(lambda (<=>)
(lambda (x y)
(<=> (car x) (car y)))))
(define map:key
(lambda (node)
(car (set:get node '=))))
(define map:val
(lambda (node)
(cdr (set:get node '=))))
;;; (UPDATE TREE KEY UPDATE*) runs inserts a node with value
;;; (UPDATE KEY '()) if no node is found comparing equal to KEY, and
;;; (UPDATE KEY NODE) if NODE compared equal to KEY.
(define map:update
(lambda (%update-recursive)
(lambda (tree key update)
(%update-recursive tree (cons key '())
(lambda (_ oldnode)
(cons key
(update key oldnode)))))))
(define map:insert
(lambda (%update-recursive)
(let ((insert (set:insert %update-recursive)))
(lambda (tree key val)
(insert tree (cons key val))))))
(define map:search
(lambda (<=>)
(let ((search (set:in <=>)))
(lambda (tree key)
(search tree (cons key '()))))))
(define map:delete
(lambda (<=>)
(let ((delete (set:delete <=>)))
(lambda (tree key)
(delete tree (cons key '()))))))
(define map:split
(lambda (<=>) (set:split <=>)))
(define map:union
(lambda (split) (set:union split)))
;;; ;;;;;;;;;;;
;;; For strings
;;; ;;;;;;;;;;;
(cond-expand
((not miniscm-unslisp)
(define (string<=> x y)
(cond
((string<? x y) '<)
((string>? x y) '>)
(else '=))))
(else #f))
(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))))
(else #f))
(define map:string<=> (set:<=>-to-map string<=>))
(define %smap:update (set:update map:string<=>))
(define smap:update (map:update %smap:update))
(define smap:insert (map:insert %smap:update))
(define smap:search (map:search map:string<=>))
(define smap:delete (map:delete map:string<=>))
(define %smap:split (map:split map:string<=>))
(define smap:union (map:union %smap:split))
;;; ;;;;;
;;; 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 (null? (cdr insert-return)))
"should have been found")
((and already-in (not (equal? already-in
(map:val (cdr insert-return)))))
(display (list already-in
insert-return
(map:val (cdr insert-return))))
(newline)
"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"
(lambda ()
(let ((right (%set:rotate (%set:node 1
'< (%set:node 2
'< (%set:node 3
'< '()
'> '())
'> (%set:node 4
'< '()
'> '()))
'> (%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))
"bad right child of right child")
((not (eqv? (set:get (set:get (set:get right '>) '<) '=) 4))
"bad left child of right child")
(else #t)))))
(cons "rotate left"
(lambda ()
(let ((right (%set:rotate (%set:node 1
'> (%set:node 2
'< (%set:node 3
'< '()
'> '())
'> (%set:node 4
'< '()
'> '()))
'< (%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))
"bad right child of left child")
((not (eqv? (set:get (set:get (set:get right '<) '<) '=) 5))
"bad left child of left child")
(else #t)))))
(cons "insert then delete"
(lambda ()
(let ((insert-return (smap:insert '() (string #\a) 5)))
(cond
((not (pair? insert-return)) "invalid insert return")
((not (null? (cdr insert-return))) "string found in empty tree")
(else
(let ((tree (car insert-return)))
(let ((found (smap:search tree (string #\a))))
(cond
((null? found) "string not in tree")
((not (equal? (map:key tree) (string #\a)))
"returned key not equal to a")
((not (equal? (map:val tree) 5))
"returned value not equal to 5")
(else
(let ((delete-return (smap:delete tree (string #\a))))
(cond
((not (pair? delete-return))
"invalid delete return")
((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)
(list (string #\q #\w #\e) 5 #f)
(list (string #\1 #\2 #\3) 5 #f)
(list (string #\l #\i #\s #\p) 6 #f)
(list (string #\c) 7 #f)
(list (string #\s #\c #\m) 8 #f)
(list (string #\a #\l #\g #\o #\l) 9 #f)
(list (string #\a #\s #\m) 10 #f)
(list (string #\4) 11 #f)
(list (string #\a #\s #\m #\e) 12 #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))))))))))))
(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 (key oldnode)
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)))))))
(cons "union a few"
(lambda ()
(let ((tree1 (%set:insert-all '()
(list
(list (string #\a) 1 #f)
(list (string #\b) 2 #f)
(list (string #\c) 3 #f))))
(tree2 (%set:insert-all '()
(list
(list (string #\c) 4 #f)
(list (string #\d) 5 #f)
(list (string #\e) 6 #f)))))
(let ((tree (smap:union tree1 tree2))
(to-search (list
(list (string #\a) 1 1)
(list (string #\b) 2 2)
(list (string #\c) 3 3)
(list (string #\d) 5 5)
(list (string #\e) 6 6))))
(not (string? (%set:search-all tree to-search)))))))))