;;; -*- Mode: Scheme -*-

;;;; Binary Trees of Bounded Balance
;;;; (Incomplete) Tests

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * 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.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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 is a rudimentary test suite for bounded-balance binary trees.
;;; It does not cover all the code in bb-tree.scm.  These tests take
;;; some time to run: on my machine, about a minute in MIT Scheme, and
;;; over twelve minutes in Scheme48.  Having BB-TREE-TEST-ITERATIONS
;;; set to 100 is probably overkill.
;;;
;;; This test suite uses SRFI 8 (RECEIVE), and SRFI 27 to generate
;;; random integers.  The testing library that this file uses is at
;;;
;;;   <http://mumble.net/~campbell/darcs/trc-testing/>.

(define-test-suite bb-tree-tests
  "BB-Trees: functional binary trees of bounded balance")

(define (random-bb-tree count)
  (let loop ((i 0) (bb-tree (make-bb-tree bb-tree-type:exact-integer)))
    (if (>= i count)
        (begin (bb-tree/check bb-tree test-failure) bb-tree)
        (let ((i (+ i 1)))
          (loop
           i
           (let ((n (random-integer i)))
             (case (random-integer 4)
               ((0 1 2) (bb-tree/insert bb-tree n n))
               ((3) (bb-tree/delete bb-tree n))
               (else
                (error "(RANDOM-INTEGER 4) gave me a bogus value!")))))))))

(define (randomly-split-bb-tree bb-tree)
  (let ((type (bb-tree/type bb-tree))
        (count (bb-tree/count bb-tree)))
    (let loop ((i 0) (a (make-bb-tree type)) (b (make-bb-tree type)))
      (if (= i count)
          (begin (bb-tree/check a test-failure)
                 (bb-tree/check b test-failure)
                 (values a b))
          (receive (key datum) (bb-tree/index-key&datum bb-tree i)
            (case (random-integer 2)
              ((0) (loop (+ i 1) (bb-tree/insert a key datum) b))
              ((1) (loop (+ i 1) a (bb-tree/insert b key datum)))
              (else (error "(RANDOM-INTEGER 2) gave me a bogus value!"))))))))

(define (iota-bb-tree count)            ;What a crummy name.
  (let loop ((i 0) (bb-tree (make-bb-tree bb-tree-type:exact-integer)))
    (if (>= i count)
        bb-tree
        (loop (+ i 1) (bb-tree/insert bb-tree i i)))))

(define bb-tree-test-count 10000)
(define bb-tree-test-iterations 100)

(define-test-case bb-tree-tests bb-tree<->alist ()
  (let ((bb-tree (iota-bb-tree bb-tree-test-count))
        (alist
         (let loop ((i bb-tree-test-count) (alist '()))
           (if (zero? i)
               alist
               (let ((i (- i 1)))
                 (loop i (cons (cons i i) alist)))))))
    (test-eqv bb-tree-test-count (bb-tree/count bb-tree))
    (test-equal alist (bb-tree->alist bb-tree))
    (test-equal
     alist
     (bb-tree->alist (alist->bb-tree alist bb-tree-type:exact-integer)))))

(define-test-case bb-tree-tests lists ()
  (do ((i 0 (+ i 1)))
      ((>= i bb-tree-test-iterations))
    (let ((bb-tree (random-bb-tree bb-tree-test-count)))
      (test-equal (bb-tree->alist bb-tree)
                  (map cons
                       (bb-tree/key-list bb-tree)
                       (bb-tree/datum-list bb-tree))))))

(define-test-case bb-tree-tests insertion/deletion ()
  (let ()
    (define (append-reverse list tail)
      (if (pair? list)
          (append-reverse (cdr list) (cons (car list) tail))
          tail))
    ;; Keep the alists sorted and update them destructively, to reduce
    ;; the number of times we encounter the worst case for linear-time
    ;; updates, and to avoid the need to sort the alist afterward.
    ;; Doing so significantly reduces the amount of time spent in this
    ;; test.
    (define (alist/insert! alist key datum)
      (let loop ((previous alist))
        (let ((alist (cdr previous)))
          (if (pair? alist)
              (cond ((< key (caar alist))
                     (set-cdr! previous (cons (cons key datum) alist)))
                    ((< (caar alist) key) (loop alist))
                    (else (set-cdr! (car alist) datum)))
              (set-cdr! previous (cons (cons key datum) '()))))))
    (define (alist/delete! alist key)
      (let loop ((previous alist))
        (let ((alist (cdr previous)))
          (if (pair? alist)
              (cond ((< (caar alist) key) (loop alist))
                    ((not (< key (caar alist)))
                     (set-cdr! previous (cdr alist))))))))
    ;; This is a very slow test to run, so just do it once, rather than
    ;; BB-TREE-TEST-ITERATIONS times.
    (let ((alist (cons 'SENTINEL '())))
      (let loop ((i 0) (bb-tree (make-bb-tree bb-tree-type:exact-integer)))
        (bb-tree/check bb-tree test-failure)
        (if (>= i bb-tree-test-count)
            (begin
              (for-each (lambda (association)
                          (test-eqv (cdr association)
                            (bb-tree/lookup bb-tree (car association) #f)))
                        (cdr alist))
              (test-equal (cdr alist) (bb-tree->alist bb-tree))
              (test-equal (cdr alist)
                          (bb-tree->alist
                           (alist->bb-tree (cdr alist)
                                           bb-tree-type:exact-integer))))
            (let ((i (+ i 1)))
              (loop
               i
               (let ((n (random-integer i)))
                 (case (random-integer 4)
                   ((0 1 2)
                    (alist/insert! alist n n)
                    (let ((bb-tree (bb-tree/insert bb-tree n n)))
                      (test-eqv n (bb-tree/lookup bb-tree n #f))
                      bb-tree))
                   ((3)
                    (alist/delete! alist n)
                    (let ((bb-tree (bb-tree/delete bb-tree n)))
                      (test-eqv #f (bb-tree/lookup bb-tree n #f))
                      bb-tree))
                   (else
                    (error
                     "(RANDOM-INTEGER 4) gave me a bogus value!")))))))))))

(define-test-suite (bb-tree-tests.indexing bb-tree-tests)
  "Indexing operations")

(define-test-case bb-tree-tests.indexing key<->index ()
  (do ((i 0 (+ i 1)))
      ((>= i bb-tree-test-iterations))
    (let* ((bb-tree (random-bb-tree bb-tree-test-count))
           (count (bb-tree/count bb-tree)))
      (do ((i 0 (+ i 1)))
          ((>= i count))
        (let ((key (bb-tree/index bb-tree i)))
          (test-eqv i (bb-tree/key->index bb-tree key))
          (test-eqv (bb-tree/lookup bb-tree key #f)
                    (bb-tree/index-datum bb-tree i)))))))

(define-test-case bb-tree-tests.indexing replace-index ()
  (let ((bb-tree (iota-bb-tree bb-tree-test-count)))
    (do ((i 0 (+ i 1)))
        ((>= i bb-tree-test-count))
      (let ((bb-tree (bb-tree/replace-index bb-tree i 'ZOOT)))
        (test-eqv 'ZOOT (bb-tree/index-datum bb-tree i))
        (test-eqv 'ZOOT (bb-tree/lookup bb-tree i #f))))))

(define-test-case bb-tree-tests.indexing modify-index ()
  (let ((bb-tree (iota-bb-tree bb-tree-test-count)))
    (do ((i 0 (+ i 1)))
        ((>= i bb-tree-test-count))
      (let ((bb-tree
             (bb-tree/modify-index bb-tree i
               (lambda (key datum) (test-eqv i key) (- 0 datum)))))
        (test-eqv (- 0 i) (bb-tree/index-datum bb-tree i))
        (test-eqv (- 0 i) (bb-tree/lookup bb-tree i #f))))))

;;; This test is not very interesting: it just compares the consistency
;;; of BB-TREE/UPDATE-INDEX with BB-TREE/REPLACE-INDEX and
;;; BB-TREE/DELETE-INDEX.

(define-test-case bb-tree-tests.indexing update-index ()
  (let ((bb-tree (random-bb-tree bb-tree-test-count))
        (check-probability^-1 (ceiling (/ bb-tree-test-iterations 2))))
    (do ((i 0 (+ i 1)))
        ((>= i bb-tree-test-iterations))
      (let loop ((a bb-tree) (b bb-tree) (count (bb-tree/count bb-tree)) (i 0))
        (if (zero? (random-integer check-probability^-1))
            (begin (bb-tree/check a test-failure)
                   (bb-tree/check b test-failure)))
        (test-eqv count (bb-tree/count a))
        (test-eqv count (bb-tree/count b))
        (if (or (zero? count) (>= i bb-tree-test-count))
            (test-equal (bb-tree->alist a) (bb-tree->alist b))
            (let ((n (random-integer count)))
              (bb-tree/update-index a n
                (lambda (key datum replace delete)
                  (test-eqv n (bb-tree/key->index b key))
                  (receive (key* datum*) (bb-tree/index-key&datum b n)
                    (test-eqv key key*)
                    (test-eqv datum datum*))
                  (if (zero? (random-integer 4))
                      (loop (replace (- 0 datum))
                            (bb-tree/replace-index b n (- 0 datum))
                            count
                            (+ i 1))
                      (loop (delete)
                            (receive (k b) (bb-tree/delete-index b n)
                              k         ;ignore
                              b)
                            (- count 1)
                            (+ i 1)))))))))))

;;; These two tests take a long time to run, but they were the only
;;; ones that turned up balance errors in deletion (both in this
;;; implementation and in the one that comes with GHC which practically
;;; everyone in the Haskell world uses for general finite maps!).  It
;;; would be better, probably, to separate the balance checks for
;;; sequences of extremum deletions from the indexing tests.

(define-test-case bb-tree-tests.indexing minimum-and-index ()
  (do ((i 0 (+ i 1)))
      ((>= i bb-tree-test-iterations))
    (let* ((bb-tree (random-bb-tree bb-tree-test-count))
           (count (bb-tree/count bb-tree))
           (check-probability^-1
            (* 100 (ceiling (/ bb-tree-test-count (max count 1))))))
      (let loop ((i 0) (bb-tree* bb-tree))
        (if (>= i count)
            (test-eqv #t (bb-tree/empty? bb-tree*))
            (receive (key bb-tree*) (bb-tree/delete-min bb-tree* #f)
              (test-eqv key (bb-tree/index bb-tree i))
              ;; Checking is very slow, so do it only occasionally.
              (if (zero? (random-integer check-probability^-1))
                  (bb-tree/check bb-tree* test-failure))
              (loop (+ i 1) bb-tree*)))))))

(define-test-case bb-tree-tests.indexing maximum-and-index ()
  (do ((i 0 (+ i 1)))
      ((>= i bb-tree-test-iterations))
    (let* ((bb-tree (random-bb-tree bb-tree-test-count))
           (count (bb-tree/count bb-tree))
           (check-probability^-1
            (* 100 (ceiling (/ bb-tree-test-count (max count 1))))))
      (let loop ((i count) (bb-tree* bb-tree))
        (if (zero? i)
            (test-predicate bb-tree/empty? bb-tree*)
            (let ((i (- i 1)))
              (receive (key bb-tree*) (bb-tree/delete-max bb-tree* #f)
                (test-eqv key (bb-tree/index bb-tree i))
                (if (zero? (random-integer check-probability^-1))
                    (bb-tree/check bb-tree* test-failure))
                (loop i bb-tree*))))))))

(define-test-suite (bb-tree-tests.ordered-set bb-tree-tests)
  "Ordered set operations")

(define-test-case bb-tree-tests.ordered-set split ()
  (do ((i 0 (+ i 1)))
      ((>= i bb-tree-test-iterations))
    (let ((bb-tree (random-bb-tree bb-tree-test-count))
          (pivot (random-integer bb-tree-test-count)))
      (receive (lesser greater) (bb-tree/split bb-tree pivot)
        (bb-tree/check lesser test-failure)
        (bb-tree/check greater test-failure)
        (let ((lesser-alist (bb-tree->alist lesser))
              (greater-alist (bb-tree->alist greater)))
          (for-each (lambda (association)
                      (test-compare > pivot (car association)))
                    lesser-alist)
          (for-each (lambda (association)
                      (test-compare < pivot (car association)))
                    greater-alist)
          (let ((lesser* (bb-tree/split< bb-tree pivot)))
            (bb-tree/check lesser* test-failure)
            (test-equal lesser-alist (bb-tree->alist lesser*)))
          (let ((greater* (bb-tree/split> bb-tree pivot)))
            (bb-tree/check greater* test-failure)
            (test-equal greater-alist (bb-tree->alist greater*)))
          (bb-tree/split* bb-tree pivot
            (lambda (datum lesser greater)
              (test-eqv datum (bb-tree/lookup bb-tree pivot #f))
              (bb-tree/check lesser test-failure)
              (bb-tree/check greater test-failure)
              (test-equal lesser-alist (bb-tree->alist lesser))
              (test-equal greater-alist (bb-tree->alist greater)))
            (lambda (lesser greater)
              (test-eqv #f (bb-tree/member? bb-tree pivot))
              (bb-tree/check lesser test-failure)
              (bb-tree/check greater test-failure)
              (test-equal lesser-alist (bb-tree->alist lesser))
              (test-equal greater-alist (bb-tree->alist greater))))
          (test-equal (append lesser-alist greater-alist)
                      (bb-tree->alist (bb-tree/delete bb-tree pivot))))))))

(define-test-case bb-tree-tests.ordered-set union ()
  (let ((bb-tree (random-bb-tree bb-tree-test-count)))
    (do ((i 0 (+ i 1)))
        ((>= i bb-tree-test-iterations))
      (receive (a b) (randomly-split-bb-tree bb-tree)
        (let ((alist (bb-tree->alist bb-tree)))
          (define (check union)
            (bb-tree/check union test-failure)
            (test-equal alist (bb-tree->alist union)))
          (check (bb-tree/union a b))
          (check (bb-tree/union-merge a b
                   (lambda (key datum-a datum-b)
                     (test-failure "Unexpected merge:" key datum-a datum-b))))
          (check (bb-tree/union bb-tree a))
          (check (bb-tree/union-merge bb-tree a
                   (lambda (key datum-bb-tree datum-a)
                     key                ;ignore
                     (test-eqv datum-bb-tree datum-a)
                     datum-bb-tree)))
          (check (bb-tree/union-merge bb-tree b
                   (lambda (key datum-bb-tree datum-b)
                     key                ;ignore
                     (test-eqv datum-bb-tree datum-b)
                     datum-bb-tree))))))))

(define-test-case bb-tree-tests.ordered-set intersection ()
  (let ((bb-tree (random-bb-tree bb-tree-test-count)))
    (do ((i 0 (+ i 1)))
        ((>= i bb-tree-test-iterations))
      (receive (a b) (randomly-split-bb-tree bb-tree)
        (let ((intersection/a*b (bb-tree/intersection a b)))
          (bb-tree/check intersection/a*b test-failure)
          (test-predicate bb-tree/empty? intersection/a*b))
        (let ((intersection/bb-tree*a (bb-tree/intersection bb-tree a)))
          (bb-tree/check intersection/bb-tree*a test-failure)
          (test-equal (bb-tree->alist a)
                      (bb-tree->alist intersection/bb-tree*a)))
        (let ((intersection/bb-tree*b (bb-tree/intersection bb-tree b)))
          (bb-tree/check intersection/bb-tree*b test-failure)
          (test-equal (bb-tree->alist b)
                      (bb-tree->alist (bb-tree/intersection bb-tree b))))
        (test-eqv #t (bb-tree/submap? a bb-tree eqv?))
        (test-eqv #t (bb-tree/submap? b bb-tree eqv?))))))

(define-test-case bb-tree-tests.ordered-set difference ()
  (let ((bb-tree (random-bb-tree bb-tree-test-count)))
    (do ((i 0 (+ i 1)))
        ((>= i bb-tree-test-iterations))
      (receive (a b) (randomly-split-bb-tree bb-tree)
        (let ((a-alist (bb-tree->alist a))
              (b-alist (bb-tree->alist b)))
          (define (check alist difference)
            (bb-tree/check difference test-failure)
            (test-equal alist (bb-tree->alist difference)))
          (check a-alist (bb-tree/difference a b))
          (check b-alist (bb-tree/difference b a))
          (check a-alist
            (bb-tree/difference-merge bb-tree b
              (lambda (key bb-tree-datum b-datum replace delete)
                key replace             ;ignore
                (test-eqv bb-tree-datum b-datum)
                (delete))))
          (check b-alist
            (bb-tree/difference-merge bb-tree a
              (lambda (key bb-tree-datum a-datum replace delete)
                key replace             ;ignore
                (test-eqv bb-tree-datum a-datum)
                (delete)))))))))

(define (random-bb-tree-subset bb-tree fraction-denominator)
  ((lambda (bb-tree)
     (bb-tree/check bb-tree test-failure)
     bb-tree)
   (bb-tree/filter bb-tree
     (lambda (key datum)
       key datum                        ;ignore
       ;; (< (random-real) (/ 1 fraction-denominator))
       (zero? (random-integer fraction-denominator))))))

(define-test-case bb-tree-tests.ordered-set demorgan ()
  (let ((bb-tree (random-bb-tree bb-tree-test-count)))
    (do ((i 0 (+ i 1)))
        ((>= i bb-tree-test-iterations))
      (let ((a (random-bb-tree-subset bb-tree 3))
            (b (random-bb-tree-subset bb-tree 3))
            (c (random-bb-tree-subset bb-tree 3)))
        (let ((complement-of-union
               (bb-tree/difference bb-tree
                                   (bb-tree/union (bb-tree/union a b) c)))
              (intersection-of-complements
               (bb-tree/intersection
                (bb-tree/intersection
                 (bb-tree/difference bb-tree a)
                 (bb-tree/difference bb-tree b))
                (bb-tree/difference bb-tree c))))
          (bb-tree/check complement-of-union test-failure)
          (bb-tree/check intersection-of-complements test-failure)
          (test-equal (bb-tree->alist complement-of-union)
                      (bb-tree->alist intersection-of-complements)))
        (let ((complement-of-intersection
               (bb-tree/difference
                bb-tree
                (bb-tree/intersection (bb-tree/intersection a b) c)))
              (union-of-complements
               (bb-tree/union
                (bb-tree/union (bb-tree/difference bb-tree a)
                               (bb-tree/difference bb-tree b))
                (bb-tree/difference bb-tree c))))
          (bb-tree/check complement-of-intersection test-failure)
          (bb-tree/check union-of-complements test-failure)
          (test-equal (bb-tree->alist complement-of-intersection)
                      (bb-tree->alist union-of-complements)))))))

(define-test-case bb-tree-tests.ordered-set set-relations ()
  (let ((bb-tree (random-bb-tree bb-tree-test-count)))
    (do ((i 0 (+ i 1)))
        ((>= i bb-tree-test-iterations))
      (let ((a (random-bb-tree-subset bb-tree 2))
            (b (random-bb-tree-subset bb-tree 2)))
        (let ((union (bb-tree/union a b)))
          (bb-tree/check union test-failure)
          (test-eqv #t (bb-tree/submap? a union eqv?))
          (test-eqv #t (bb-tree/submap? b union eqv?)))
        (let ((intersection (bb-tree/intersection a b)))
          (bb-tree/check intersection test-failure)
          (test-eqv #t (bb-tree/submap? intersection a eqv?))
          (test-eqv #t (bb-tree/submap? intersection b eqv?)))
        (let ((difference (bb-tree/difference a b)))
          (bb-tree/check difference test-failure)
          (test-eqv #t (bb-tree/submap? difference a eqv?)))))))