From 5915c0caab9f0c188c389017b12e47ef1443a7a8 Mon Sep 17 00:00:00 2001 From: mariari Date: Thu, 12 Oct 2023 05:52:12 +0800 Subject: [PATCH 1/2] Fix obj-equalp Fixes obj-equalp method by checking the classes of provided terms. --- src/mixins/mixins.lisp | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/mixins/mixins.lisp b/src/mixins/mixins.lisp index 708aced75..150c217c5 100644 --- a/src/mixins/mixins.lisp +++ b/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) From a4678c0d4fc5f2ba4d103a6391db88f5eb1df44d Mon Sep 17 00:00:00 2001 From: Artem Gureev Date: Mon, 17 Jul 2023 18:06:11 +0600 Subject: [PATCH 2/2] Add Tests Adds testing of obj-equalp predicate on Geb objects and morphisms --- geb.asd | 1 + test/mixins.lisp | 58 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 59 insertions(+) create mode 100644 test/mixins.lisp diff --git a/geb.asd b/geb.asd index 396aff953..1093f4b2a 100644 --- a/geb.asd +++ b/geb.asd @@ -154,6 +154,7 @@ (:file bitc) (:file pipeline) (:file list) + (:file mixins) (:module gui :serial t :components ((:file test) diff --git a/test/mixins.lisp b/test/mixins.lisp new file mode 100644 index 000000000..52b89d228 --- /dev/null +++ b/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))))