define-namespace/examples/test-aatree.scm

;;;; 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")