;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Thu Oct 17 22:14:42 2002
;;;; Contains: Tests for EQUALP


;;; Characters
(deftest equalp.1
  (loop for c across +base-chars+
        always (loop for d across +base-chars+
                     always (if (char-equal c d) (equalpt c d)
                              (not (equalpt c d)))))
  t)

;;; Fixnums
(deftest equalp.2
  (loop for i from 1 to 100
        always (loop for j from 1 to 100
                     always (if (eqlt i j) (equalpt i j)
                              (not (equalpt i j)))))
  t)

;;; Strings
(deftest equalp.3
  (equalpt "abc" "ABC")
  t)

(deftest equalp.4
  (equalpt "abc" "abd")
  nil)

;;; Arrays
(deftest equalp.5
  :notes (:allow-nil-arrays)
  (equalpt (make-array '(0) :element-type nil) #())
  t)

(deftest equalp.6
  :notes (:allow-nil-arrays)
  (equalpt (make-array '(0) :element-type nil) "")
  t)

(deftest equalp.7
  (loop for nbits from 1 to 100
        for type = `(unsigned-byte ,nbits)
        for bound = (ash 1 nbits)
        for val = (random bound)
        for a1 = (make-array nil :initial-element val :element-type type)
        for a2 = (make-array nil :initial-element val)
        unless (equalp a1 a2)
        collect (list nbits type val))
  nil)

(deftest equalp.8
  (loop for nbits from 1 to 100
        for type = `(unsigned-byte ,nbits)
        for bound = (ash 1 nbits)
        for n = (1+ (random 20))
        for vals = (loop repeat n collect (random bound))
        for a1 = (make-array n :initial-contents vals :element-type type)
        for a2 = (make-array n :initial-contents vals)
        unless (equalp a1 a2)
        collect (list nbits type vals))
  nil)

(deftest equalp.9
  (loop for nbits from 1 to 100
        for type = `(signed-byte ,nbits)
        for bound = (ash 1 nbits)
        for n = (1+ (random 20))
        for vals = (loop repeat n collect (- (random bound) (/ bound 2)))
        for a1 = (make-array n :initial-contents vals :element-type type)
        for a2 = (make-array n :initial-contents vals)
        unless (equalp a1 a2)
        collect (list nbits type vals))
  nil)

(deftest equalp.10
  (equalpt #*0010 #(0 0 1 0))
  t)

(deftest equalp.11
  (let ((v1 #(1 2 3))
        (v2 (make-array 8 :initial-contents '(1 2 3 4 5 6 7 8)
                        :fill-pointer 3)))
    (equalpt v1 v2))
  t)

(deftest equalp.12
  (equalpt '(#\a #\b) "ab")
  nil)

(deftest equalp.13
  (equalpt '(#\a #\b) '(#\A #\B))
  t)

(deftest equalp.14
  (let ((s1 (make-array '(4) :initial-contents '(#\a #\b #\c #\d)
                        :element-type 'base-char))
        (s2 (make-array '(4) :initial-contents '(#\a #\b #\c #\d)
                        :element-type 'character)))
    (equalpt s1 s2))
  t)

(deftest equalp.15
  (let ((bv (make-array '(4) :initial-contents '(0 0 1 0)
                        :element-type 'bit))
        (v #(0 0 1 0)))
    (equalpt bv v))
  t)

;;; Structures
(defstruct equalp-struct-16
  a b c)

(defstruct equalp-struct-16-alt
  a b c)

(deftest equalp.16
  (let ((s1 (make-equalp-struct-16 :a 1 :b 2 :c #\a))
        (s2 (make-equalp-struct-16 :a 1.0 :b 2.0 :c #\A))
        (s3 (make-equalp-struct-16-alt :a 1.0 :b 2.0 :c #\A)))
    (values (equalpt s1 s2)
            (equalpt s1 s3)
            (equalpt s2 s3)))
  t nil nil)

;;; Floats
(deftest equalp.17
  (loop for i below 8192
        for f = (float i 1.0s0)
        repeat 1000
        unless (equalp i f)
        collect (list i f))
  nil)

(deftest equalp.18
  (loop for i = (- (random 10000000) 5000000)
        for f = (float i 1.0f0)
        repeat 1000
        unless (equalp i f)
        collect (list i f))
  nil)

(deftest equalp.19
  (loop for i = (- (random 10000000) 5000000)
        for f = (float i 1.0d0)
        repeat 1000
        unless (equalp i f)
        collect (list i f))
  nil)

(deftest equalp.20
  (loop for i = (- (random 10000000) 5000000)
        for f = (float i 1.0l0)
        repeat 1000
        unless (equalp i f)
        collect (list i f))
  nil)

;;; Hash tables
(deftest equalp.21
  (let ((ht1 (make-hash-table :test #'eq))
        (ht2 (make-hash-table :test #'eql))
        (ht3 (make-hash-table :test #'equal))
        (ht4 (make-hash-table :test #'equalp)))
    (values (equalpt ht1 ht2)
            (equalpt ht1 ht3)
            (equalpt ht1 ht4)
            (equalpt ht2 ht3)
            (equalpt ht2 ht4)
            (equalpt ht3 ht4)))
  nil nil nil nil nil nil)

(deftest equalp.22
  (equalpt (make-hash-table :test 'eq)
           (make-hash-table :test #'eq))
  t)

(deftest equalp.23
  (equalpt (make-hash-table :test 'eql)
           (make-hash-table :test #'eql))
  t)

(deftest equalp.24
  (equalpt (make-hash-table :test 'equal)
           (make-hash-table :test #'equal))
  t)

(deftest equalp.25
  (equalpt (make-hash-table :test 'equalp)
           (make-hash-table :test #'equalp))
  t)

(deftest equalp.26
  (let ((ht1 (make-hash-table :test #'eq))
        (ht2 (make-hash-table :test #'eq)))
    (setf (gethash #\a ht1) t)
    (setf (gethash #\A ht2) t)
    (equalpt ht1 ht2))
  nil)

(deftest equalp.27
  (let ((ht1 (make-hash-table :test #'eq))
        (ht2 (make-hash-table :test #'eq)))
    (setf (gethash 'a ht1) #\a)
    (setf (gethash 'a ht2) #\A)
    (equalpt ht1 ht2))
  t)

(deftest equalp.27a
  (let ((ht1 (make-hash-table :test #'eq))
        (ht2 (make-hash-table :test #'eq)))
    (setf (gethash 'a ht1) #\a)
    (setf (gethash 'a ht2) #\b)
    (equalpt ht1 ht2))
  nil)

(deftest equalp.28
  (let ((ht1 (make-hash-table :test #'eql))
        (ht2 (make-hash-table :test #'eql)))
    (setf (gethash #\a ht1) t)
    (setf (gethash #\A ht2) t)
    (equalpt ht1 ht2))
  nil)

(deftest equalp.29
  (let ((ht1 (make-hash-table :test #'eql))
        (ht2 (make-hash-table :test #'eql)))
    (setf (gethash #\a ht1) "a")
    (setf (gethash #\a ht2) "A")
    (equalpt ht1 ht2))
  t)

(deftest equalp.29a
  (let ((ht1 (make-hash-table :test #'eql))
        (ht2 (make-hash-table :test #'eql)))
    (setf (gethash #\a ht1) "a")
    (setf (gethash #\a ht2) "b")
    (equalpt ht1 ht2))
  nil)

(deftest equalp.30
  (let ((ht1 (make-hash-table :test #'equal))
        (ht2 (make-hash-table :test #'equal)))
    (setf (gethash #\a ht1) t)
    (setf (gethash #\A ht2) t)
    (equalpt ht1 ht2))
  nil)

(deftest equalp.31
  (let ((ht1 (make-hash-table :test #'equal))
        (ht2 (make-hash-table :test #'equal)))
    (setf (gethash #\a ht1) "a")
    (setf (gethash #\a ht2) "A")
    (equalpt ht1 ht2))
  t)

(deftest equalp.31a
  (let ((ht1 (make-hash-table :test #'equal))
        (ht2 (make-hash-table :test #'equal)))
    (setf (gethash #\a ht1) "a")
    (setf (gethash #\a ht2) "b")
    (equalpt ht1 ht2))
  nil)

(deftest equalp.32
  (let ((ht1 (make-hash-table :test #'equalp))
        (ht2 (make-hash-table :test #'equalp)))
    (setf (gethash #\a ht1) t)
    (setf (gethash #\A ht2) t)
    (equalpt ht1 ht2))
  t)

(deftest equalp.33
  (let ((ht1 (make-hash-table :test #'equalp))
        (ht2 (make-hash-table :test #'equalp)))
    (setf (gethash #\a ht1) "a")
    (setf (gethash #\a ht2) "A")
    (equalpt ht1 ht2))
  t)

(deftest equalp.33a
  (let ((ht1 (make-hash-table :test #'equalp))
        (ht2 (make-hash-table :test #'equalp)))
    (setf (gethash #\a ht1) "a")
    (setf (gethash #\a ht2) "b")
    (equalpt ht1 ht2))
  nil)

(deftest equalp.34
  (let ((ht1 (make-hash-table :test #'equalp))
        (ht2 (make-hash-table :test #'equalp)))
    (setf (gethash '#:a ht1) t)
    (setf (gethash '#:a ht2) t)
    (equalpt ht1 ht2))
  nil)

(deftest equalp.35
  (loop for test in '(eq eql equal equalp)
        collect
        (flet ((%make-table
                ()
                (apply #'make-hash-table
                       :test test
                       `(,@(when (coin)
                             (list :size (random 100)))
                           ,@(when (coin)
                               (list :rehash-size (1+ (random 50))))
                           ,@(when (coin)
                               (list :rehash-threshold (random 1.0)) )))))
          (loop repeat 200
                count
                (let ((ht1 (%make-table))
                      (ht2 (%make-table))
                      (pairs (loop for i below (random 100) collect (cons (gensym) i))))
                  (loop for (k . v) in pairs do (setf (gethash k ht1) v))
                  (setf pairs (random-permute pairs))
                  (loop for (k . v) in pairs do (setf (gethash k ht2) v))
                  (not (equalp ht1 ht2))))))
  (0 0 0 0))

;;; Instances
(defclass equalp-class-36 () ((slot1 :initarg :slot1) (slot2 :initarg :slot2)))

;;; If structure is backed up by an instance, it may happen that
;;; instances are compared like structures for `equalp' - slot by
;;; slot. This was a problem in ECL 16.1.3.
(deftest equalp.36
    (equalp (make-instance 'equalp-class-36 :slot1 1 :slot2 2)
            (make-instance 'equalp-class-36 :slot1 1 :slot2 2))
  nil)

(deftest equalp.order.1
  (let ((i 0) x y)
    (values
     (equalp (setf x (incf i)) (setf y (incf i)))
     i x y))
  nil 2 1 2)

;;; Error tests

(deftest equalp.error.1
  (signals-error (equalp) program-error)
  t)

(deftest equalp.error.2
  (signals-error (equalp nil) program-error)
  t)

(deftest equalp.error.3
  (signals-error (equalp nil nil nil) program-error)
  t)