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

@@ -11,6 +11,7 @@
   (the (or null simplicial-group)
        (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)
@@ -21,6 +22,7 @@
 #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (ext:package-lock :clos) t))
 
+
 (DEFUN SMST-KAN (smst kfll)
   (declare
    (type simplicial-set smst)
@@ -32,92 +34,6 @@
 	 (pushnew smst *kan-list*)
 	 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
@@ -149,17 +65,6 @@
 	      (assert (eq :equal
 			  (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
@@ -183,9 +88,11 @@
 		   (del-i-rslt (a-face4 face i dmns rslt)))
 	       (declare (type absm x-i del-i-rslt))
 	       (with-absm (dgop1 gmsm1) x-i
-	      (with-absm (dgop2 gmsm2) del-i-rslt
+			  (with-absm
+			      (dgop2 gmsm2) del-i-rslt
 			      (unless (and (= dgop1 dgop2)
-			      (eq (funcall cmpr gmsm1 gmsm2) :equal))
+					   (eq (funcall cmpr gmsm1 gmsm2)
+					       :equal))
 				(error "Wrong result:~@
                             Fill = ~A~@
                             Del-~D(Fill) = ~A~@

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))))