aatree and linked-list
This commit is contained in:
parent
5a5fbd861f
commit
c18bee846d
10
README.rst
10
README.rst
|
|
@ -49,3 +49,13 @@ Differences from R7RS
|
|||
* Namespace names are identifers, not lists.
|
||||
* Namespaces are Scheme objects.
|
||||
* To import outside of namespaces, use IMPORT-FROM-NAMSPACE, not IMPORT.
|
||||
|
||||
--------
|
||||
Examples
|
||||
--------
|
||||
|
||||
* ``srfi/srfi-1.scm`` is the reference implementation of SRFI-1 wrapped in
|
||||
a namespace.
|
||||
* ``examples/aatree.scm`` is an imperative binary tree implementation.
|
||||
``examples/test-aatree.scm`` uses SRFI-64 to run some tests on the
|
||||
implementation. Requires SRFI-9 and SRFI-11 (``let-values``).
|
||||
|
|
|
|||
|
|
@ -85,7 +85,3 @@
|
|||
(syntax-rules ()
|
||||
((import-from-namespace body ...)
|
||||
(%import-from-namespace '() body ...))))
|
||||
|
||||
(import-from-namespace (only srfi-1 fold))
|
||||
(fold (lambda (elem acc) (+ elem acc)) 0'(1 2 3 4 5))
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,232 @@
|
|||
;;;; Copyright (c) 2024, Peter McGoron
|
||||
;;;;
|
||||
;;;; Redistribution and use in source and binary forms, with or without
|
||||
;;;; modification, are permitted provided that the following conditions
|
||||
;;;; are met:
|
||||
;;;;
|
||||
;;;; 1) Redistributions of source code must retain the above copyright
|
||||
;;;; notice, this list of conditions and the following disclaimer.
|
||||
;;;; 2) Redistributions in binary form must reproduce the above copyright
|
||||
;;;; notice, this list of conditions and the following disclaimer
|
||||
;;;; in the documentation and/or other materials provided with the
|
||||
;;;; distribution.
|
||||
;;;;
|
||||
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
|
||||
;;;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
;;;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
|
||||
;;;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||||
;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
;;;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
;;;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
;;;; POSSIBILITY OF SUCH DAMAGE.
|
||||
;;;;
|
||||
;;;; This implements functional balanced binary search trees (AA Trees).
|
||||
;;;;
|
||||
;;;; (NEW <=>) makes a new AA Tree root.
|
||||
;;;; (<=> KEY1 KEY2) must return one of the symbols in '(< = >), which
|
||||
;;;; denote that KEY1 is less than, equivalent to, or greater than KEY2.
|
||||
;;;;
|
||||
;;;; (SEARCH TREE KEY) searches the tree for the first node equivalent
|
||||
;;;; to KEY. If successful, it returns (VALUES 'FOUND KEY VAL). Otherwise
|
||||
;;;; it returns (VALUES 'NOT-FOUND '() '()).
|
||||
;;;;
|
||||
;;;; (INSERT TREE KEY VAL) inserts KEY into TREE with value VAL. If
|
||||
;;;; a key equivalent to KEY is already in TREE, the old key is replaced with
|
||||
;;;; KEY and the old value is replaced with VAL, and the function returns
|
||||
;;;; (VALUES 'FOUND OLDKEY OLDVAL). If the value is not found, then
|
||||
;;;; the function returns (VALUES 'NOT-FOUND OLDKEY OLDVAL).
|
||||
;;;;
|
||||
;;;; (DELETE TREE KEY) deletes the node equivalent to KEY, if it exists.
|
||||
;;;; It returns
|
||||
|
||||
(define-namespace aatree
|
||||
(begin
|
||||
(define-record-type :aatree-node
|
||||
(new-node key value left right level)
|
||||
node?
|
||||
(key get-key key-set!)
|
||||
(value get-value value-set!)
|
||||
(left get-left left-set!)
|
||||
(right get-right right-set!)
|
||||
(level get-level-raw level-set!))
|
||||
(define-record-type :aatree
|
||||
(%aatree <=> root)
|
||||
aatree?
|
||||
(<=> get-<=>)
|
||||
(root get-root set-root!))
|
||||
(define leaf '())
|
||||
(define (new <=>) (%aatree <=> leaf))
|
||||
(define leaf? null?)
|
||||
(define (get-level r)
|
||||
(if (leaf? r)
|
||||
0
|
||||
(get-level-raw r)))
|
||||
; Option-like accessors
|
||||
(define (maybe-right t)
|
||||
(if (null? t)
|
||||
leaf
|
||||
(get-right t)))
|
||||
(define (maybe-left t)
|
||||
(if (null? t)
|
||||
leaf
|
||||
(get-left t)))
|
||||
; right rotation
|
||||
; a b
|
||||
; / \ / \
|
||||
; b c -> d a
|
||||
; / \ / \
|
||||
; d e e c
|
||||
(define (skew A)
|
||||
(let* ((B (maybe-left A))
|
||||
(E (maybe-right B)))
|
||||
(if (and (not (leaf? A))
|
||||
(eq? (get-level B)
|
||||
(get-level A)))
|
||||
(begin
|
||||
(right-set! B A)
|
||||
(left-set! A E)
|
||||
B)
|
||||
A)))
|
||||
; left rotation
|
||||
; a c
|
||||
; / \ / \
|
||||
; b c -> a e
|
||||
; / \ / \
|
||||
; d e b d
|
||||
;
|
||||
(define (split A)
|
||||
(let* ((C (maybe-right A))
|
||||
(E (maybe-right C))
|
||||
(D (maybe-left C)))
|
||||
(if (and (not (leaf? A))
|
||||
(not (leaf? C))
|
||||
(eq? (get-level E)
|
||||
(get-level A)))
|
||||
(begin
|
||||
(left-set! C A)
|
||||
(right-set! A D)
|
||||
(level-set! C (+ (get-level C) 1))
|
||||
C)
|
||||
A)))
|
||||
(define (search* <=> tree key)
|
||||
(if (leaf? tree)
|
||||
(values 'not-found '() '())
|
||||
(let ((nodekey (get-key tree)))
|
||||
(case (<=> key nodekey)
|
||||
((<) (search* <=> (get-left tree) key))
|
||||
((>) (search* <=> (get-right tree) key))
|
||||
((=) (values 'found nodekey (get-value tree)))))))
|
||||
(define (search tree key) (search* (get-<=> tree) (get-root tree) key))
|
||||
(define (insert* <=> node key val)
|
||||
(if (leaf? node)
|
||||
(values (new-node key val '() '() 1) 'not-found '() '())
|
||||
(case (<=> key (get-key node))
|
||||
((=) (let ((oldval (get-value node)))
|
||||
(value-set! node val)
|
||||
(values node 'found (get-key node) oldval)))
|
||||
((<) (let-values (((newnode . rest)
|
||||
(insert* <=> (get-left node) key val)))
|
||||
(left-set! node newnode)
|
||||
(apply values (cons (split (skew node)) rest))))
|
||||
((>) (let-values (((newnode . rest)
|
||||
(insert* <=> (get-right node) key val)))
|
||||
(right-set! node newnode)
|
||||
(apply values (cons (split (skew node)) rest))))
|
||||
(else (error "comparision must return <, =, or >")))))
|
||||
(define (insert tree key val)
|
||||
(let-values (((new-root . rest) (insert* (get-<=> tree) (get-root tree) key val)))
|
||||
(set-root! tree new-root)
|
||||
(apply values rest)))
|
||||
(define (delete* <=> tree key)
|
||||
(if (leaf? tree)
|
||||
(values tree 'not-found '() '())
|
||||
(let ((process (lambda (t)
|
||||
(if (leaf? t)
|
||||
t
|
||||
(let* ((level (get-level t))
|
||||
(level-l (get-level (get-left t)))
|
||||
(level-r (get-level (get-right t)))
|
||||
(new-level (- level 1)))
|
||||
(if (or (< level-l new-level)
|
||||
(< level-r new-level))
|
||||
(begin
|
||||
(if (> level-r new-level)
|
||||
(level-set! (get-right t)
|
||||
(min level-r new-level)))
|
||||
(level-set! t new-level)
|
||||
(set! t (skew t))
|
||||
(right-set! t (skew (get-right t)))
|
||||
(right-set! (get-right t)
|
||||
(skew (get-right (get-right t))))
|
||||
(set! t (split t))
|
||||
(right-set! t (split (get-right t)))))
|
||||
t)))))
|
||||
(case (<=> key (get-key tree))
|
||||
((<) (let-values (((newnode . rest)
|
||||
(delete* <=> (get-left tree) key)))
|
||||
(left-set! tree newnode)
|
||||
(apply values (cons (process tree) rest))))
|
||||
((>) (let-values (((newnode . rest)
|
||||
(delete* <=> (get-right tree) key)))
|
||||
(right-set! tree newnode)
|
||||
(apply values (cons (process tree) rest))))
|
||||
((=) (letrec
|
||||
((del-min (lambda (t)
|
||||
(if (leaf? (get-left t))
|
||||
(values (get-right t) 'found (get-key t)
|
||||
(get-value t))
|
||||
(let-values (((newnode . rest)
|
||||
(del-min (get-left t))))
|
||||
(if (leaf? (get-right t))
|
||||
(error "imbalanced tree"))
|
||||
(left-set! t newnode)
|
||||
(apply values
|
||||
(cons (process t) rest)))))))
|
||||
(if (leaf? (get-right tree))
|
||||
(if (not (leaf? (get-left tree)))
|
||||
(error "imbalanced tree")
|
||||
(values '() 'found (get-key tree) (get-value tree)))
|
||||
(let-values (((newnode status key value)
|
||||
(del-min (get-right tree)))
|
||||
((oldvalue) (get-value tree))
|
||||
((oldkey) (get-key tree)))
|
||||
(key-set! tree key)
|
||||
(value-set! tree value)
|
||||
(right-set! tree newnode)
|
||||
(values (process tree) status oldkey oldvalue)))))))))
|
||||
(define (delete tree key)
|
||||
(let-values (((new-root . rest) (delete* (get-<=> tree)
|
||||
(get-root tree)
|
||||
key)))
|
||||
(set-root! tree new-root)
|
||||
(apply values rest)))
|
||||
(define (aatree->alist* node alist)
|
||||
(if (leaf? node)
|
||||
alist
|
||||
(let ((alist-right (aatree->alist* (get-right node) alist)))
|
||||
(aatree->alist* (get-left node)
|
||||
(cons (cons (get-key node)
|
||||
(get-value node))
|
||||
alist-right)))))
|
||||
(define (aatree->alist tree) (aatree->alist* (get-root tree) '()))
|
||||
(define (alist->aatree* node <=> alist)
|
||||
(if (null? alist)
|
||||
node
|
||||
(let ((pair (car alist)))
|
||||
(let-values (((node . _)
|
||||
(insert node <=>
|
||||
(car pair)
|
||||
(cdr pair))))
|
||||
(alist->aatree* node (cdr alist) <=>)))))
|
||||
(define (alist->aatree tree)
|
||||
(alist->aatree* (get-root tree) (get-<=> tree) '())))
|
||||
(export
|
||||
aatree?
|
||||
new
|
||||
aatree->alist alist->aatree
|
||||
search insert delete))
|
||||
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
(define-namespace linked-list
|
||||
(define-record-type linked-list
|
||||
(linked-list head tail)
|
||||
linked-list?
|
||||
(head get-head set-head!)
|
||||
(tail get-tail set-tail!))
|
||||
(define (new) (linked-list '() '()))
|
||||
(define (empty? lst) (null? (get-head lst)))
|
||||
(define (linked-list->list lst) (get-head lst))
|
||||
(define (push-first lst val)
|
||||
(let ((container (list val)))
|
||||
(set-head! lst container)
|
||||
(set-tail! list container)))
|
||||
(define (push-head lst val)
|
||||
(if (empty? lst)
|
||||
(push-first lst val)
|
||||
(set-head! lst (cons val (get-head lst)))))
|
||||
(define (push-tail lst val)
|
||||
(if (empty? lst)
|
||||
(push-first lst val)
|
||||
(let ((container (list val)))
|
||||
(set-cdr! (get-tail lst) container)
|
||||
(set-tail! lst container))))
|
||||
(export new empty?
|
||||
push-head push-tail
|
||||
linked-list->list))
|
||||
|
||||
|
|
@ -0,0 +1,188 @@
|
|||
;;;; Copyright (c) 2024, Peter McGoron
|
||||
;;;;
|
||||
;;;; Redistribution and use in source and binary forms, with or without
|
||||
;;;; modification, are permitted provided that the following conditions
|
||||
;;;; are met:
|
||||
;;;;
|
||||
;;;; 1) Redistributions of source code must retain the above copyright
|
||||
;;;; notice, this list of conditions and the following disclaimer.
|
||||
;;;; 2) Redistributions in binary form must reproduce the above copyright
|
||||
;;;; notice, this list of conditions and the following disclaimer
|
||||
;;;; in the documentation and/or other materials provided with the
|
||||
;;;; distribution.
|
||||
;;;;
|
||||
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
|
||||
;;;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
;;;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
|
||||
;;;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||||
;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
;;;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
;;;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
;;;; POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(load "../srfi/srfi-64.scm")
|
||||
(load "../define-namespace-5.scm")
|
||||
(load "aatree.scm")
|
||||
|
||||
(define (string<=> x y)
|
||||
(if (string<? x y)
|
||||
'<
|
||||
(if (string=? x y)
|
||||
'=
|
||||
'>)))
|
||||
|
||||
(import-from-namespace
|
||||
(only aatree aatree? aatree->alist)
|
||||
(rename aatree
|
||||
(new aatree/new)
|
||||
(search aatree/search)
|
||||
(insert aatree/insert)
|
||||
(delete aatree/delete)))
|
||||
|
||||
(test-begin "AATree")
|
||||
|
||||
(test-begin "insert one")
|
||||
(define tree (aatree/new string<=>))
|
||||
(let-values (((status key value)
|
||||
(aatree/insert tree "a" 1)))
|
||||
(test-equal "insert status" 'not-found status)
|
||||
(let-values (((status key value)
|
||||
(aatree/search tree "a")))
|
||||
(test-equal "search status" 'found status)
|
||||
(test-equal "search key" "a" key)
|
||||
(test-equal "search value" 1 value)))
|
||||
(test-end "insert one")
|
||||
|
||||
|
||||
(test-begin "insert many in order")
|
||||
(define inspairs
|
||||
'(("a" . 1) ("b" . 2) ("c" . 3) ("d" . 4) ("e" . 5) ("f" . 6)
|
||||
("g" . 7) ("h" . 8) ("i" . 9) ("j" . 10) ("k" . 11) ("l" . 12)
|
||||
("m" . 13) ("n" . 14) ("o" . 15) ("p" . 16) ("q" . 17) ("r" . 18)
|
||||
("s" . 19) ("t" . 20) ("u" . 21) ("v" . 22) ("w" . 23) ("x" . 24)
|
||||
("y" . 25) ("z" . 26)))
|
||||
|
||||
(define (fold-collect f start processed to-process)
|
||||
(if (null? to-process)
|
||||
start
|
||||
(let ((new-elem (car to-process)))
|
||||
(fold-collect f (f start new-elem processed)
|
||||
(cons new-elem processed)
|
||||
(cdr to-process)))))
|
||||
|
||||
(define (iter f l)
|
||||
(if (pair? l)
|
||||
(begin
|
||||
(f (car l))
|
||||
(iter f (cdr l)))))
|
||||
|
||||
(define (test-insert node pair searchlist)
|
||||
(let-values (((status key value)
|
||||
(aatree/insert node (car pair) (cdr pair))))
|
||||
(test-equal "insert" 'not-found status)
|
||||
(iter (lambda (pair)
|
||||
(let ((key (car pair))
|
||||
(val (cdr pair)))
|
||||
(let-values (((status retkey retval)
|
||||
(aatree/search node key)))
|
||||
(test-equal "search status" 'found status)
|
||||
(test-equal "search key" key retkey)
|
||||
(test-equal "search value" val retval))))
|
||||
searchlist)
|
||||
node))
|
||||
|
||||
|
||||
(define inserted-in-order
|
||||
(fold-collect test-insert (aatree/new string<=>) '() inspairs))
|
||||
(test-end "insert many in order")
|
||||
|
||||
(display "a\n")
|
||||
;; Not possible to implement good randomin strictly portable R5RS scheme,
|
||||
;; Shuffled using "shuf"
|
||||
|
||||
(test-begin "insert shuffled")
|
||||
(define shuffled-list
|
||||
'(("k" . 11)
|
||||
("p" . 16)
|
||||
("r" . 18)
|
||||
("w" . 23)
|
||||
("x" . 24)
|
||||
("t" . 20)
|
||||
("f" . 6)
|
||||
("z" . 26)
|
||||
("h" . 8)
|
||||
("a" . 1)
|
||||
("s" . 19)
|
||||
("e" . 5)
|
||||
("d" . 4)
|
||||
("y" . 25)
|
||||
("c" . 3)
|
||||
("j" . 10)
|
||||
("v" . 22)
|
||||
("g" . 7)
|
||||
("o" . 15)
|
||||
("q" . 17)
|
||||
("m" . 13)
|
||||
("u" . 21)
|
||||
("l" . 12)
|
||||
("b" . 2)
|
||||
("n" . 14)
|
||||
("i" . 9)))
|
||||
(fold-collect test-insert (aatree/new string<=>) '() shuffled-list)
|
||||
(test-end "insert shuffled")
|
||||
|
||||
(test-begin "delete one")
|
||||
|
||||
(define tree (aatree/new string<=>))
|
||||
(let-values (((status key value)
|
||||
(aatree/insert tree "a" 1)))
|
||||
(test-equal "insert status" 'not-found status)
|
||||
(let-values (((status retkey retval)
|
||||
(aatree/search tree "a")))
|
||||
(test-equal "search 1 status" 'found status)
|
||||
(test-equal "search 1 key" "a" retkey)
|
||||
(test-equal "search 1 value" 1 retval)
|
||||
(let-values (((status retkey retval)
|
||||
(aatree/delete tree "a")))
|
||||
(test-equal "delete status" 'found status)
|
||||
(test-equal "delete key" "a" retkey)
|
||||
(test-equal "delete value" 1 retval)
|
||||
(let-values (((status . _)
|
||||
(aatree/search tree "a")))
|
||||
(test-equal "search 2 status" status 'not-found)))))
|
||||
(test-end "delete one")
|
||||
|
||||
(define (test-delete tree deleted to-delete)
|
||||
(if (pair? to-delete)
|
||||
(let ((pair (car to-delete)))
|
||||
(let-values (((status retkey retval)
|
||||
(aatree/delete tree (car pair))))
|
||||
(test-equal "delete status" 'found status)
|
||||
(test-equal "delete key" (car pair) retkey)
|
||||
(test-equal "delete value" (cdr pair) retval)
|
||||
(iter (lambda (pair)
|
||||
(let ((key (car pair)))
|
||||
(let-values (((status . _)
|
||||
(aatree/search tree key)))
|
||||
(test-equal "deleted search" 'not-found status))))
|
||||
(cons pair deleted))
|
||||
(iter (lambda (pair)
|
||||
(let ((key (car pair))
|
||||
(val (cdr pair)))
|
||||
(let-values (((status retkey retval)
|
||||
(aatree/search tree key)))
|
||||
(test-equal "to-delete search" 'found status)
|
||||
(test-equal "to-delete search value" val retval)
|
||||
(test-equal "to-delete search key" key retkey))))
|
||||
(cdr to-delete))
|
||||
(test-delete tree (cons pair deleted) (cdr to-delete))))))
|
||||
|
||||
(test-begin "insert and shuffled delete")
|
||||
(test-delete inserted-in-order '() shuffled-list)
|
||||
(test-end "insert and shuffled delete")
|
||||
|
||||
(test-end "AATree")
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
(define-syntax let-values
|
||||
(syntax-rules ()
|
||||
((let-values (?binding ...) ?body0 ?body1 ...)
|
||||
(let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))
|
||||
|
||||
((let-values "bind" () ?tmps ?body)
|
||||
(let ?tmps ?body))
|
||||
|
||||
((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
|
||||
(let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))
|
||||
|
||||
((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
|
||||
(call-with-values
|
||||
(lambda () ?e0)
|
||||
(lambda ?args
|
||||
(let-values "bind" ?bindings ?tmps ?body))))
|
||||
|
||||
((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
|
||||
(let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))
|
||||
|
||||
((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
|
||||
(call-with-values
|
||||
(lambda () ?e0)
|
||||
(lambda (?arg ... . x)
|
||||
(let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))
|
||||
|
||||
(define-syntax let*-values
|
||||
(syntax-rules ()
|
||||
((let*-values () ?body0 ?body1 ...)
|
||||
(begin ?body0 ?body1 ...))
|
||||
|
||||
((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...)
|
||||
(let-values (?binding0)
|
||||
(let*-values (?binding1 ...) ?body0 ?body1 ...)))))
|
||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue