;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Oct  4 09:24:24 2003
;;;; Contains: Aux. functions for testing hash tables



(eval-when (:load-toplevel :compile-toplevel :execute)
  (compile-and-load* "random-aux.lsp"))

(defparameter *hash-table-test-iters* 1000)

(defun test-hash-table-1 (&rest args)
  (let ((table (apply #'make-hash-table args))
        (test (or (getf args :test) 'eql)))
    (assert (member test '(eq eql equal equalp)))
    (assert (hash-table-p table))
    (assert (typep table 'hash-table))
    ;; Build a hash table using the arguments in ARGS.
    ;; Perform *hash-table-test-iters* iterations of
    ;; random hash table operations
    (let* ((universe-vec (coerce *universe* 'vector))
           ;; (universe-size (length universe-vec))
           (mapping nil)
           (count 0))

      (loop
       for i from 0 below *hash-table-test-iters*
       do (assert (eql (hash-table-count table) count))
       do (assert (let ((size (hash-table-size table)))
                    (and (integerp size) (>= size 0))))
       do
       (flet ((%remove-pair
               (rpair)
               (decf count)
               (let ((key (car rpair))
                     (expected-value (cdr rpair)))
                 (multiple-value-bind (value present-p)
                     (gethash key table)
                   (assert present-p)
                   (assert (eql expected-value value))
                   (setf mapping
                         (remove rpair mapping :count 1 :test 'eq)))
                 (assert (remhash key table))
                 (multiple-value-bind (value present-p)
                     (gethash key table)
                   (assert (not present-p))
                   (assert (null value))
                   ))))

         (rcase
          (1 ;; Insert
           (let* ((new-elem (random-from-seq universe-vec))
                  (pair (assoc new-elem mapping :test test)))
             (cond
              (pair
               (multiple-value-bind
                   (value present-p)
                   (gethash new-elem table)
                 (assert present-p)
                 (assert (eql (cdr pair) value))
                 (setf (cdr pair) i
                       (gethash new-elem table) i)))
              (t
               (assert
                (equal (multiple-value-list (gethash new-elem table))
                       '(nil nil)))
               (incf count)
               (push (cons new-elem i) mapping)
               (setf (gethash new-elem table) i)))))
          (1 ;; Delete element in the set
           (when mapping
             (%remove-pair (random-from-seq mapping))))
          (1 ;; Delete random element from universe
           (let* ((key (random-from-seq universe-vec))
                  (pair (assoc key mapping :test test)))
             (cond
              (pair (%remove-pair pair))
              (t
               ;; Not present -- check that this is true
               (assert (equal (multiple-value-list (gethash key table))
                              '(nil nil)))
               (assert (not (remhash key table)))
               (assert (equal (multiple-value-list (gethash key table))
                              '(nil nil)))))
             ))
          ))))))