Merge branch 'artem/obj-equalp-fix' into artem/beta-reduction

geb.asd

@@ -165,6 +165,7 @@
    (:file seqn)
    (:file pipeline)
    (:file list)
+   (:file mixins)
    (:module gui
     :serial t
     :components ((:file test)

src/mixins/mixins.lisp

@@ -53,8 +53,9 @@
   (c2mop:class-direct-slots (class-of object)))
 
 (defmethod obj-equalp ((obj1 pointwise-mixin) (obj2 pointwise-mixin))
-  (obj-equalp (to-pointwise-list obj1)
-              (to-pointwise-list obj2)))
+  (and (c2mop:subclassp (type-of obj1) (type-of obj2))
+       (obj-equalp (to-pointwise-list obj1)
+                   (to-pointwise-list obj2))))
 
 (defmethod obj-equalp ((obj1 list) (obj2 list))
   (or (eq obj1 obj2)

test/mixins.lisp

@@ -0,0 +1,58 @@
+(in-package :geb-test)
+
+(define-test geb-mixins :parent geb-test-suite)
+
+(defclass subclass-test (so1 distribute) ())
+
+(define-test equalp-substobj :parent geb-mixins
+  (obj-equalp so1 so1)
+  (not (obj-equalp so1 so0))
+  (obj-equalp so0 so0)
+  (obj-equalp (coprod so1 so1) (coprod so1 so1))
+  (not (obj-equalp (coprod so1 so0) (coprod so1 so1)))
+  (obj-equalp (prod so1 so1) (prod so1 so1))
+  (not (obj-equalp (prod so1 so0) (prod so1 so1)))
+  (not (obj-equalp (prod so1 so1) (coprod so1 so1)))
+  (obj-equalp (prod (prod so1 so1) so0) (prod (prod so1 so1) so0))
+  (not (obj-equalp (prod (prod so1 so1) so0) (prod (coprod so1 so1) so0)))
+  (and (c2mop:subclassp (type-of (make-instance 'subclass-test)) (type-of so1))
+       (not (obj-equalp (make-instance 'subclass-test) so1))))
+
+;; Note that here we are testing object equality without
+;; considering intensional aspects. E.g. initial morphism
+;; !: so0 -> so0 is different from id : 0 -> 0
+(define-test equalp-substmorph :parent geb-mixins
+  (obj-equalp (init so1) (init so1))
+  (not (obj-equalp (init so1) (init so0)))
+  (obj-equalp (terminal so1) (terminal so1))
+  (not (obj-equalp (terminal so1) (terminal so0)))
+  (obj-equalp (mcase (terminal so1) (terminal so1))
+              (mcase (terminal so1) (terminal so1)))
+  (not (obj-equalp (mcase (terminal so1) so1)
+                   (mcase (terminal so1) (terminal so1))))
+  (obj-equalp (distribute so1 so1 so1)
+              (distribute so1 so1 so1))
+  (not (obj-equalp (distribute so1 so1 so1)
+                   (distribute so1 so0 so0)))
+  (obj-equalp (pair (init so1) (init so1))
+              (pair (init so1) (init so1)))
+  (not (obj-equalp (pair (init so1) so0)
+                   (pair (init so1) (init so0))))
+  (obj-equalp (->left so1 so1)
+              (->left so1 so1))
+  (not (obj-equalp (->left so1 so1)
+                   (->left so1 so0)))
+  (obj-equalp (->right so1 so1)
+              (->right so1 so1))
+  (not (obj-equalp (->right so1 so1)
+                   (->right so1 so0)))
+  (obj-equalp (<-left so1 so1)
+              (<-left so1 so1))
+  (not (obj-equalp (<-left so1 so1)
+                   (<-left so1 so0)))
+  (obj-equalp (<-right so1 so1)
+              (<-right so1 so1))
+  (not (obj-equalp (<-right so1 so1)
+                   (<-right so1 so0)))
+  (not (obj-equalp (<-right so1 so1)
+                   (<-left so1 so1))))