Extracted Kan tests.

kenzo-test.asd

@@ -9,23 +9,24 @@
   :pathname #P"test/"
   :components ((:file "package")
 	       (:file "common")
-	       (:file "combinations-test")
+	       ;; === test files ===
-	       (:file "various-test")
+	       (:file "bar-test")
+	       (:file "bicones-test")
+	       (:file "cartesian-products-test")
+               (:file "ccn")
 	       (:file "chain-complexes-test")
 	       (:file "chcm-elementary-op-test")
-	       (:file "diabolo")
 	       (:file "circle")
-               (:file "ccn")
+	       (:file "combinations-test")
-	       (:file "effective-homology-test")
-	       (:file "bicones-test")
-	       (:file "homology-groups-test")
-	       (:file "searching-homology-test")
-	       (:file "delta-test")
-	       (:file "bar-test")
-	       (:file "cartesian-products-test")
 	       (:file "cones-test")
 	       ;;(:file "cl-space-efhm-test")
-	       (:file "tensor-products-test")
+	       (:file "delta-test")
+	       (:file "diabolo")
+	       (:file "effective-homology-test")
+	       (:file "homology-groups-test")
 	       (:file "k-pi-n-test")
+	       (:file "kan-test")
+	       (:file "searching-homology-test")
 	       (:file "simplicial-sets-test")
-	       ))
+	       (:file "tensor-products-test")
+	       (:file "various-test")))

package.lisp

@@ -233,6 +233,16 @@
 	   Z2-BAR-ABSM
 	   Z-COCYCLE-GBAR
 
+	   ;; kan.lisp
+
+	   CHECK-HAT
+	   SMST-KAN
+
+	   ;; loop-spaces.lisp
+
+	   GDELTAB
+	   LOOP3
+
 	   ;; macros.lisp
 
 	   -1-EXPT-N
@@ -261,11 +271,13 @@
 	   GNRT
 	   GRIN
 	   I-SBTR
+	   KFLL
 	   MASK
 	   RBCC
 	   TERM
 	   TERM-CMBN
 	   TCC
+	   WITH-ABSM
 
 	   ;; searching-homology.lisp
 

src/kan.lisp

@@ -9,121 +9,37 @@
 (DEFUN KAN (idnm)
   (declare (fixnum idnm))
   (the (or null simplicial-group)
-     (find idnm *kan-list* :key #'idnm)))
+       (find idnm *kan-list* :key #'idnm)))
+
 
 #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((kan kan) stream)
   (the kan
-     (progn
+       (progn
-       (format stream "[K~D Kan-Simplicial-Set]" (idnm kan))
+	 (format stream "[K~D Kan-Simplicial-Set]" (idnm kan))
-       kan)))
+	 kan)))
 #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (ext:package-lock :clos) t))
 
+
 (DEFUN SMST-KAN (smst kfll)
   (declare
-     (type simplicial-set smst)
+   (type simplicial-set smst)
-     (type kfll kfll))
+   (type kfll kfll))
   (the kan
-     (progn
+       (progn
-       (change-class smst 'kan)
+	 (change-class smst 'kan)
-       (setf (slot-value smst 'kfll) kfll)
+	 (setf (slot-value smst 'kfll) kfll)
-       (pushnew smst *kan-list*)
+	 (pushnew smst *kan-list*)
-       smst)))
+	 smst)))
 
-#|
-  (setf d (delta-infinity))
-  (defun vertex-i (absm i)
-     (with-absm (dgop gmsm) absm
-       (let ((dgop (nreverse (dgop-int-ext dgop)))
-             (gmsm (dlop-int-ext gmsm)))
-         (do ((dgop-mark dgop)
-              (gmsm-mark gmsm)
-              (ii 0 (1+ ii)))
-             ((= i ii) (car gmsm-mark))
-            (if (and dgop-mark
-                     (= ii (car dgop-mark)))
-               (pop dgop-mark)
-               (pop gmsm-mark))))))
-  (vertex-i (absm 0 1) 0)
-  (vertex-i (absm 1 1) 0)
-  (vertex-i (absm 1 1) 1)
-  (vertex-i (absm 0 3) 0)
-  (vertex-i (absm 0 3) 1)
-  (vertex-i (absm 3 1) 0)
-  (vertex-i (absm 3 1) 1)
-  (vertex-i (absm 3 1) 2)
-  (vertex-i (absm 1 3) 0)
-  (vertex-i (absm 1 3) 1)
-  (vertex-i (absm 1 3) 2)
-  (vertex-i (absm 2 3) 0)
-  (vertex-i (absm 2 3) 1)
-  (vertex-i (absm 2 3) 2)
-  (vertex-i (absm 0 7) 0)
-  (vertex-i (absm 0 7) 1)
-  (vertex-i (absm 0 7) 2)
-  (defun absm-int-ext (absm)
-     (with-absm (dgop gmsm) absm
-        (do ((dgop (nreverse (dgop-int-ext dgop)))
-             (gmsm (rest (dlop-int-ext gmsm)))
-             (i 0 (1+ i))
-             (rslt (list (first (dlop-int-ext gmsm)))))
-            ((and (endp dgop) (endp gmsm)) (nreverse rslt))
-           (if dgop
-              (if (= i (car dgop))
-                 (progn
-                   (pop dgop)
-                   (push (first rslt) rslt))
-                 (push (pop gmsm) rslt))
-              (return (nreconc rslt gmsm))))))
-  (defun absm-ext-int (vlist)
-     (do ((dgop nil)
-          (gmsm (list (first vlist)))
-          (mark (rest vlist) (cdr mark))
-          (idgop 0 (1+ idgop)))
-         ((endp mark) (absm (dgop-ext-int dgop)
-                            (dgop-ext-int gmsm)))
-        (if (= (first gmsm) (car mark))
-           (push idgop dgop)
-           (push (car mark) gmsm))))
-  (absm-ext-int '(0 0 0 1 2 3 3 3))
-  (absm-ext-int '(0 1 1 1 2))
-  (absm-int-ext (absm-ext-int '(0 0 0 1 2 3 3 3)))
-  (absm-int-ext (absm-ext-int '(0 1 1 1 2)))
-  (defun dkfll (indx dmns hat)
-     (cond ((= 1 dmns)
-            (absm 1 (gmsm (first hat))))
-           ((= 0 indx)
-            (let ((del-1 (absm-int-ext (first hat)))
-                  (del-2 (absm-int-ext (second hat))))
-              (absm-ext-int
-                 (cons (first del-1)
-                       (cons (second del-2) (rest del-1))))))
-           ((= 1 indx)
-            (let ((del-0 (absm-int-ext (first hat)))
-                  (del-2 (absm-int-ext (second hat))))
-              (absm-ext-int
-                 (cons (first del-2) del-0))))
-           (t
-            (let ((del-0 (absm-int-ext (first hat)))
-                  (del-1 (absm-int-ext (second hat))))
-              (absm-ext-int
-                 (cons (first del-1) del-0))))))
-  (smst-kan d #'dkfll)
-  (kfll d 0 1 (list (absm 0 1)))
-  (kfll d 0 2 (list (absm 0 5) (absm 0 3)))
-  (kfll d 1 2 (list (absm 0 6) (absm 0 3)))
-  (kfll d 2 2 (list (absm 0 6) (absm 0 5)))
-  (kfll d 0 2 (list (absm 0 3) (absm 0 3)))
-  (kfll d 1 2 (list (absm 1 2) (absm 0 3)))
-|#
 
 (DEFUN CHECK-HAT (kan indx dmns hat)
   (declare
-     (type kan kan)
+   (type kan kan)
-     (fixnum indx dmns)  ;;; dmns like in (funcall kfll ...)
+   (fixnum indx dmns)  ;;; dmns like in (funcall kfll ...)
-     (list hat))
+   (list hat))
   (assert (= dmns (length hat)))
   (setf hat
 	(append (subseq hat 0 indx)
@@ -132,63 +48,54 @@
   (do ((cmpr (cmpr kan))
        (j 0 (1+ j)))
       ((> j dmns) t)
-      (declare
+    (declare
-         (type cmprf cmpr)
+     (type cmprf cmpr)
-	 (fixnum j))
+     (fixnum j))
-     (unless (= j indx)
+    (unless (= j indx)
-       (let ((del-j (nth j hat)))
+      (let ((del-j (nth j hat)))
-	 (declare (type absm del-j))
+	(declare (type absm del-j))
-	 (do ((i j (1+ i)))
+	(do ((i j (1+ i)))
-	     ((= i dmns))
+	    ((= i dmns))
-	     (declare (fixnum i))
+	  (declare (fixnum i))
-	    (unless (= i (1- indx))
+	  (unless (= i (1- indx))
-	      (let ((del-i-del-j (face kan i (1- dmns) del-j))
+	    (let ((del-i-del-j (face kan i (1- dmns) del-j))
-		    (del-j-del-i+1 (face kan j (1- dmns)
+		  (del-j-del-i+1 (face kan j (1- dmns)
-					 (nth (1+ i) hat))))
+				       (nth (1+ i) hat))))
-		(declare (type absm del-i-del-j del-j-del-i+1))
+	      (declare (type absm del-i-del-j del-j-del-i+1))
-		(assert (eq :equal
+	      (assert (eq :equal
-			    (a-cmpr3 cmpr del-i-del-j del-j-del-i+1))))))))))
+			  (a-cmpr3 cmpr del-i-del-j del-j-del-i+1))))))))))
-
-#|
-  (setf od (gdeltab))
-  (setf s (loop3 0 31 2))
-  (setf faces (mapcar #'(lambda (indx) (face od indx 3 s))
-                      '(0 1 2 3)))
-  (delete (nth 1 faces) faces)
-  (check-hat od 1 3 faces)
-  (setf (nth 2 faces) (nth 1 faces))
-  (check-hat od 1 3 faces)
-|#
 
 
 (DEFUN CHECK-KAN (kan indx dmns hat)
   (declare
-     (type kan kan)
+   (type kan kan)
-     (fixnum indx dmns)
+   (fixnum indx dmns)
-     (list hat))
+   (list hat))
   (the (values)
-     (let ((rslt (kfll kan indx dmns hat))
+       (let ((rslt (kfll kan indx dmns hat))
-	   (cmpr (cmpr kan))
+	     (cmpr (cmpr kan))
-	   (face (face kan)))
+	     (face (face kan)))
-       (declare
+	 (declare
 	  (type absm rslt)
 	  (type cmprf cmpr)
 	  (type face face))
-       (check-hat kan indx dmns hat)
+	 (check-hat kan indx dmns hat)
-       (do ((i 0 (1+ i)))
+	 (do ((i 0 (1+ i)))
-	   ((> i dmns))
+	     ((> i dmns))
-	  (declare (fixnum i))
+	   (declare (fixnum i))
-	  (unless (= i indx)
+	   (unless (= i indx)
-	    (let ((x-i (pop hat))
+	     (let ((x-i (pop hat))
-		  (del-i-rslt (a-face4 face i dmns rslt)))
+		   (del-i-rslt (a-face4 face i dmns rslt)))
-	      (declare (type absm x-i del-i-rslt))
+	       (declare (type absm x-i del-i-rslt))
-	      (with-absm (dgop1 gmsm1) x-i
+	       (with-absm (dgop1 gmsm1) x-i
-	      (with-absm (dgop2 gmsm2) del-i-rslt
+			  (with-absm
-		 (unless (and (= dgop1 dgop2)
+			      (dgop2 gmsm2) del-i-rslt
-			      (eq (funcall cmpr gmsm1 gmsm2) :equal))
+			      (unless (and (= dgop1 dgop2)
-		    (error "Wrong result:~@
+					   (eq (funcall cmpr gmsm1 gmsm2)
+					       :equal))
+				(error "Wrong result:~@
                             Fill = ~A~@
                             Del-~D(Fill) = ~A~@
                             Hat-~D = ~A"
-		       rslt i del-i-rslt i x-i)))))))
+				       rslt i del-i-rslt i x-i)))))))
-       (done))))
+	 (done))))

test/kan-test.lisp

@@ -0,0 +1,117 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(defun vertex-i (absm i)
+  (cat:with-absm
+      (dgop gmsm) absm
+      (let ((dgop (nreverse (cat:dgop-int-ext dgop)))
+	    (gmsm (cat:dlop-int-ext gmsm)))
+	(do ((dgop-mark dgop)
+	     (gmsm-mark gmsm)
+	     (ii 0 (1+ ii)))
+	    ((= i ii) (car gmsm-mark))
+	  (if (and dgop-mark
+		   (= ii (car dgop-mark)))
+	      (pop dgop-mark)
+	      (pop gmsm-mark))))))
+
+
+(test vertex-i
+      (let ((d (cat:delta-infinity)))
+	(vertex-i (cat:absm 0 1) 0)
+	(vertex-i (cat:absm 1 1) 0)
+	(vertex-i (cat:absm 1 1) 1)
+	(vertex-i (cat:absm 0 3) 0)
+	(vertex-i (cat:absm 0 3) 1)
+	(vertex-i (cat:absm 3 1) 0)
+	(vertex-i (cat:absm 3 1) 1)
+	(vertex-i (cat:absm 3 1) 2)
+	(vertex-i (cat:absm 1 3) 0)
+	(vertex-i (cat:absm 1 3) 1)
+	(vertex-i (cat:absm 1 3) 2)
+	(vertex-i (cat:absm 2 3) 0)
+	(vertex-i (cat:absm 2 3) 1)
+	(vertex-i (cat:absm 2 3) 2)
+	(vertex-i (cat:absm 0 7) 0)
+	(vertex-i (cat:absm 0 7) 1)
+	(vertex-i (cat:absm 0 7) 2)))
+
+
+(defun absm-int-ext (absm)
+  (cat:with-absm
+      (dgop gmsm) absm
+      (do ((dgop (nreverse (cat:dgop-int-ext dgop)))
+	   (gmsm (rest (cat:dlop-int-ext gmsm)))
+	   (i 0 (1+ i))
+	   (rslt (list (first (cat:dlop-int-ext gmsm)))))
+	  ((and (endp dgop) (endp gmsm)) (nreverse rslt))
+	(if dgop
+	    (if (= i (car dgop))
+		(progn
+		  (pop dgop)
+		  (push (first rslt) rslt))
+		(push (pop gmsm) rslt))
+	    (return (nreconc rslt gmsm))))))
+
+
+(defun absm-ext-int (vlist)
+  (do ((dgop nil)
+       (gmsm (list (first vlist)))
+       (mark (rest vlist) (cdr mark))
+       (idgop 0 (1+ idgop)))
+      ((endp mark) (cat:absm (cat:dgop-ext-int dgop)
+			     (cat:dgop-ext-int gmsm)))
+    (if (= (first gmsm) (car mark))
+	(push idgop dgop)
+	(push (car mark) gmsm))))
+
+
+(test absm-int-ext
+      (absm-ext-int '(0 0 0 1 2 3 3 3))
+      (absm-ext-int '(0 1 1 1 2))
+      (absm-int-ext (absm-ext-int '(0 0 0 1 2 3 3 3)))
+      (absm-int-ext (absm-ext-int '(0 1 1 1 2))))
+
+
+(defun dkfll (indx dmns hat)
+  (cond ((= 1 dmns)
+	 (cat:absm 1 (cat:gmsm (first hat))))
+	((= 0 indx)
+	 (let ((del-1 (absm-int-ext (first hat)))
+	       (del-2 (absm-int-ext (second hat))))
+	   (absm-ext-int
+	    (cons (first del-1)
+		  (cons (second del-2) (rest del-1))))))
+	((= 1 indx)
+	 (let ((del-0 (absm-int-ext (first hat)))
+	       (del-2 (absm-int-ext (second hat))))
+	   (absm-ext-int
+	    (cons (first del-2) del-0))))
+	(t
+	 (let ((del-0 (absm-int-ext (first hat)))
+	       (del-1 (absm-int-ext (second hat))))
+	   (absm-ext-int
+	    (cons (first del-1) del-0))))))
+
+
+(let ((d (cat:delta-infinity)))
+  (cat:smst-kan d #'dkfll)
+  (cat:kfll d 0 1 (list (cat:absm 0 1)))
+  (cat:kfll d 0 2 (list (cat:absm 0 5) (cat:absm 0 3)))
+  (cat:kfll d 1 2 (list (cat:absm 0 6) (cat:absm 0 3)))
+  (cat:kfll d 2 2 (list (cat:absm 0 6) (cat:absm 0 5)))
+  (cat:kfll d 0 2 (list (cat:absm 0 3) (cat:absm 0 3)))
+  (cat:kfll d 1 2 (list (cat:absm 1 2) (cat:absm 0 3))))
+
+
+(test check-hat
+      (let* ((od (cat:gdeltab))
+	     (s (cat:loop3 0 31 2))
+	     (faces (mapcar #'(lambda (indx) (cat:face od indx 3 s))
+			    '(0 1 2 3))))
+	(delete (nth 1 faces) faces)
+	(cat:check-hat od 1 3 faces)
+	(setf (nth 2 faces) (nth 1 faces))
+	(signals simple-error (cat:check-hat od 1 3 faces))))