189 lines
6.4 KiB
Scheme
189 lines
6.4 KiB
Scheme
;;;; 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")
|