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

;;;; Hash Tries: Persistent Trie-Structured Hash Tables
;;;; (Joke of a) Test Suite

;;; 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.

(define-test-suite hash-trie-tests
  "Hash tries: persistent trie-structured hash tables")

(define-test-case hash-trie-tests creation ()
  (test-eqv #t (hash-trie? (make-hash-trie hash-trie-type:string))))

(define-test-case hash-trie-tests emptiness ()
  (test-eqv #t (hash-trie/empty? (make-hash-trie hash-trie-type:string))))

(define-test-case hash-trie-tests unary-insertion ()
  (let ((key "Hello") (datum "world"))
    (test-equal datum
      (hash-trie/lookup
       (hash-trie/insert (make-hash-trie hash-trie-type:string) key datum)
       key
       #f))))

(define-test-case hash-trie-tests unary-deletion ()
  (test-eqv #t
    (hash-trie/empty?
     (let ((key "Hello") (datum "world"))
       (hash-trie/delete
        (hash-trie/insert (make-hash-trie hash-trie-type:string) key datum)
        key)))))

(define-test-case hash-trie-tests insertion/deletion ()
  (do ((i 0 (+ i 1))
       (hash-trie
        (make-hash-trie hash-trie-type:string)
        (hash-trie/insert hash-trie (number->string i #x10) i)))
      ((= i 1000)
       (do ((i 0 (+ i 1))
            (hash-trie
             hash-trie
             (hash-trie/update hash-trie (number->string i #x10)
               (lambda (datum replace delete)
                 replace                ;ignore
                 (test-eqv datum i)
                 (delete))
               (lambda (insert)
                 insert                 ;ignore
                 (test-failure "Failed at index:" i)))))
           ((= i 500)
            (do ((i 0 (+ i 1)))
                ((= i 1000))
              (test-eqv (if (< i 500) #f i)
                (hash-trie/lookup hash-trie (number->string i #x10) #f))))
         (test-eqv (- 1000 i) (hash-trie/count hash-trie))
         (test-eqv i
           (hash-trie/lookup hash-trie (number->string i #x10) #f))))
    (test-eqv i (hash-trie/count hash-trie))))

(define (alist-sort key<? alist)
  (list-sort (lambda (a b) (key<? (car a) (car b))) alist))

(define-test-case hash-trie-tests hash-trie<->alist ()
  (do ((i 0 (+ i 1))
       (hash-trie
        (make-hash-trie hash-trie-type:string)
        (hash-trie/insert hash-trie (number->string i #x10) i))
       (alist
        '()
        (cons (cons (number->string i #x10) i) alist)))
      ((= i 1000)
       (let ((sorted-alist
              ;; It is tempting just to reverse ALIST here, but the
              ;; lexicographic order on strings does not coincide with
              ;; the order in which we created the alist.
              (alist-sort string<? alist)))
         (test-compare equal?
                       sorted-alist
                       (alist-sort string<? (hash-trie->alist hash-trie)))
         (test-compare equal?
                       sorted-alist
                       (alist-sort
                        string<?
                        (hash-trie->alist
                         (alist->hash-trie sorted-alist
                                           hash-trie-type:string))))))))

(define-test-case hash-trie-tests random-stress ()
  (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.  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))))))))
    (let ((alist (cons 'SENTINEL '())))
      (let loop
          ((i 0) (hash-trie (make-hash-trie hash-trie-type:exact-integer)))
        (if (>= i 10000)
            (begin
              (test-compare equal?
                            (cdr alist)
                            (alist-sort < (hash-trie->alist hash-trie)))
              (test-compare equal?
                            (cdr alist)
                            (alist-sort
                             <
                             (hash-trie->alist
                              (alist->hash-trie
                               (cdr alist)
                               hash-trie-type:exact-integer)))))
            (let* ((i (+ i 1))
                   (n (random-integer i)))
              (case (random-integer 2)
                ((0)
                 (alist/insert! alist n n)
                 (loop i (hash-trie/insert hash-trie n n)))
                ((1)
                 (alist/delete! alist n)
                 (loop i (hash-trie/delete hash-trie n)))
                (else
                 (test-failure
                  "(RANDOM-INTEGER 2) gave neither 0 nor 1!")))))))))