define-equality-test

define-equality-test.lisp

(defmacro define-equality-test (name (&rest options) &body cases)
  (declare (ignore options))
  `(defun ,name (object1 object2)
     (cond ,@(mapcar #'make-cond-clause cases))))

(defun make-cond-clause (case)
  (destructuring-bind (type comparison) case
    `((and (typep object1 ',type)
           (typep object2 ',type))
      ,(make-comparison-body comparison 'object1 'object2 'identity))))

(defun make-comparison-body (comparison object1 object2 key)
  (cond ((atom comparison)
         `(,comparison (,key ,object1) (,key ,object2)))
        ((eq (car comparison) 'funcall)
         (destructuring-bind (name) (cdr comparison)
           `(funcall ,name (,key ,object1) (,key ,object2))))
        ((eq (car comparison) 'and)
         `(and ,@(loop for subcomparison in (cdr comparison)
                       collect (make-comparison-body subcomparison object1 object2 key))))
        ((eq (car comparison) 'call)
         (destructuring-bind (operator comparison) (cdr comparison)
           `(,operator (lambda (,object1 ,object2)
                         ,(make-comparison-body comparison object1 object2 'identity))
                       ,object1 ,object2)))
        ((eq (car comparison) 'nest)
         (destructuring-bind (operator &rest comparisons) (cdr comparison)
           (let ((object1-vars (loop for c in comparisons collect (gensym)))
                 (object2-vars (loop for c in comparisons collect (gensym))))
             `(,operator (lambda (,@object1-vars)
                           (,operator (lambda (,@object2-vars)
                                        (and ,@(mapcar (lambda (comparison object1-var object2-var)
                                                         (make-comparison-body comparison object1-var object2-var 'identity))
                                                       comparisons
                                                       object1-vars
                                                       object2-vars)))
                                      ,object2))
                         ,object1))))
        ((eq (car comparison) 'store)
         (destructuring-bind (name1 name2 store-key &rest comparisons) (cdr comparison)
           `(let ((,name1 (,store-key ,object1))
                  (,name2 (,store-key ,object2)))
              (declare (ignorable ,name1 ,name2))
              ,@(mapcar (lambda (comparison)
                          (make-comparison-body comparison object1 object2 key))
                        comparisons))))
        (t
         (destructuring-bind (key-comparison key) comparison
           (make-comparison-body key-comparison object1 object2 key)))))

(defun every-slot-value (function object1 object2)
  (every (lambda (slotd)
           (let ((reader (sb-pcl::slot-definition-internal-reader-function slotd)))
             (funcall function
                      (funcall reader object1)
                      (funcall reader object2))))
         (sb-mop:class-slots (class-of object1))))

(defun array-dimensions-hack (array)
  (if (= 1 (array-rank array))
      (list (length array))
      (array-dimensions array)))

;; equalp-like

(define-equality-test my-equalp ()
  (number =)
  (character char-equal)
  (cons (and (my-equalp car) (my-equalp cdr)))
  (array (and (equal array-dimensions-hack)
              (call every my-equalp)))
  (structure-object (and (eql class-of)
                         (call every-slot-value my-equalp)))
  (hash-table (and (= hash-table-count)
                   (eq hash-table-test)
                   (store test1 test2 hash-table-test
                          (nest maphash (funcall test1) my-equalp))))
  (t equal))

;; CL-USER> (rt:do-tests)
;; Doing 44 pending tests of 44 tests total.
;;  EQUALP.1 EQUALP.2 EQUALP.3 EQUALP.4 EQUALP.5 EQUALP.6 EQUALP.7 EQUALP.8
;;  EQUALP.9 EQUALP.10 EQUALP.11 EQUALP.12 EQUALP.13 EQUALP.14 EQUALP.15
;;  EQUALP.16 EQUALP.17 EQUALP.18 EQUALP.19 EQUALP.20 EQUALP.21 EQUALP.22
;;  EQUALP.23 EQUALP.24 EQUALP.25 EQUALP.26 EQUALP.27 EQUALP.27A EQUALP.28
;;  EQUALP.29 EQUALP.29A EQUALP.30 EQUALP.31 EQUALP.31A EQUALP.32 EQUALP.33
;;  EQUALP.33A EQUALP.34 EQUALP.35 EQUALP.36 EQUALP.ORDER.1
;; Test EQUALP.ERROR.1 failed
;; Form: (SIGNALS-ERROR (EQUALP) PROGRAM-ERROR)
;; Expected value: T
;; Actual value: #<SB-INT:SIMPLE-PROGRAM-ERROR "invalid number of arguments: ~S" {10156517D3}>.
;; Test EQUALP.ERROR.2 failed
;; Form: (SIGNALS-ERROR (EQUALP NIL) PROGRAM-ERROR)
;; Expected value: T
;; Actual value: #<SB-INT:SIMPLE-PROGRAM-ERROR "invalid number of arguments: ~S" {10156530C3}>.
;; Test EQUALP.ERROR.3 failed
;; Form: (SIGNALS-ERROR (EQUALP NIL NIL NIL) PROGRAM-ERROR)
;; Expected value: T
;; Actual value: #<SB-INT:SIMPLE-PROGRAM-ERROR "invalid number of arguments: ~S" {1015654A33}>.
;; 3 out of 44 total tests failed: EQUALP.ERROR.1, EQUALP.ERROR.2, 
;;    EQUALP.ERROR.3.