Extracted Eilenberg-Zilber tests.

kenzo-test.asd

@@ -10,6 +10,7 @@
   :components ((:file "package")
 	       (:file "common")
 	       ;; === test files ===
+	       #|
 	       (:file "bar-test")
 	       (:file "bicones-test")
 	       (:file "cartesian-products-test")
@@ -26,6 +27,9 @@
 	       (:file "delta-test")
 	       (:file "diabolo")
 	       (:file "disk-pasting-test")
+	       |#
+	       (:file "eilenberg-zilber-test")
+	       #|
 	       (:file "effective-homology-test")
 	       (:file "homology-groups-test")
 	       (:file "k-pi-n-test")
@@ -36,4 +40,5 @@
 	       (:file "simplicial-sets-test")
 	       (:file "tensor-products-test")
 	       (:file "various-test")
+	       |#
 	       ))

package.lisp

@@ -264,7 +264,13 @@
 	   ;; eilenberg-zilber.lisp
 
 	   AW
+	   EML
 	   EZ
+	   INTR-AW
+	   INTR-EML
+	   INTR-PHI
+	   PHI
+	   SHUFFLE-SIGN
 
 	   ;; fibrations.lisp
 

src/eilenberg-zilber.lisp

@@ -18,17 +18,14 @@
 	     (setf factor (- factor))
 	     (setf rslt (* rslt factor))))))
 
-#|
-  (dotimes (i 30)
-     (format t "~%~A => ~@D" (hyphenize-list (dlop-int-ext i)) (shuffle-sign i)))
-|#       
 
 (DEFUN INTR-EML (cmbn)
   (declare (type cmbn cmbn))
   (when (cmbn-zero-p cmbn)
     (return-from intr-eml cmbn))
   (the cmbn
-      (with-cmbn (degr list) cmbn
+       (with-cmbn
+	   (degr list) cmbn
 	   (let* ((limits (make-array (+ degr 2)))
 		  (rslt (list nil))
 		  (rslt-mark rslt)
@@ -58,7 +55,8 @@
 		      (stop (svref limits (1+ i))))
 		     ((eq mark stop))
 		   (declare (list mark stop))
-                     (with--term (cffc tnpr) mark
+		   (with--term
+		       (cffc tnpr) mark
 		       (setf rslt-mark
 			     (setf (cdr rslt-mark)
 				   (list (term
@@ -70,12 +68,6 @@
 	      :degr degr
 	      :list (rest rslt))))))
 
-#|
-  (intr-eml (cmbn 3 1 (tnpr 0 'a 3 'b) 2 (tnpr 2 'a 1 'b) 3 (tnpr 2 'aa 1 'bb) 4 (tnpr 3 'a 0 'b)))
-  (intr-eml (cmbn 3 1 (tnpr 1 'c 2 'd) 10 (tnpr 2 'a 1 'b)))
-  (intr-eml (cmbn 3 10 (tnpr 1 'c 2 'd) 1 (tnpr 2 'a 1 'b) 100 (tnpr 2 'aa 1 'bb)))
-  (intr-eml (cmbn 3 10 (tnpr 1 'c 2 'd) 100 (tnpr 1 'cc 2 'dd) 1 (tnpr 2 'a 1 'b)))
-|#
 
 (DEFUN EML (smst1 smst2)
   (build-mrph
@@ -86,12 +78,6 @@
    :strt :cmbn
    :orgn `(eml ,smst1 ,smst2)))
 
-#|
-  (cat-init)
-  (setf d (delta-infinity))
-  (setf eml (eml d d))
-  (? eml (cmbn 3 1 (tnpr 0 1 3 30) 10 (tnpr 1 3 2 28) 100 (tnpr 2 7 1 24) 1000 (tnpr 3 15 0 16)))
-|#
 
 (DEFUN INTR-PHI (smst1 smst2
 		 &aux (crts-prdc (crts-prdc smst1 smst2))
@@ -123,12 +109,14 @@
 		      (setf (aref array-pq p q) (zero-cmbn i))))
 		  (dolist (term (cmbn-list cmbn))
 		    (declare (type term term))
-                      (with-term (cffc crpr) term
+		    (with-term
+			(cffc crpr) term
 			(let ((absm1 (absm1 crpr))
 			      (absm2 (absm2 crpr)))
 			  (declare (type absm absm1 absm2))
 			  (do ((n-alpha n (1- n-alpha))
-                                 (left-d absm1 (a-face4 face1 n-alpha n-alpha left-d)))
+			       (left-d absm1 (a-face4 face1 n-alpha n-alpha
+						      left-d)))
 			      ((zerop n-alpha))
 			    (declare
 			     (fixnum n-alpha)
@@ -137,7 +125,8 @@
 				 (i n-alpha (1- i))  ;; pseudo-degree
 				 (sign (-1-expt-n n-alpha) (- sign))
 				 (right-d absm2
-                                       (a-face4 face2 (1- i) dim-right-d right-d))
+					  (a-face4 face2 (1- i) dim-right-d
+						   right-d))
 				 (dim-right-d n (1- dim-right-d)))
 				((= beta n-alpha))
 			      (declare
@@ -145,8 +134,10 @@
 			       (type absm right-d))
 			      (let ((absm1 (1dgnr (1- i) left-d)))
 				(declare (type absm absm1))
-                                     (with-absm (dgop1 gmsm1) absm1
+				(with-absm
-                                     (with-absm (dgop2 gmsm2) right-d
+				    (dgop1 gmsm1) absm1
+				    (with-absm
+					(dgop2 gmsm2) right-d
 					(or (> (integer-length dgop1) i)
 					    (> (integer-length dgop2) i)
 					    (plusp (logand dgop1 dgop2))
@@ -154,26 +145,20 @@
 					     cmpr
 					     (* sign cffc)
 					     (crpr dgop1 gmsm1 dgop2 gmsm2)
-                                             (aref array-pq (1+ n-alpha) (- n beta))))))))))))
+					     (aref array-pq (1+ n-alpha)
+						   (- n beta))))))))))))
                   ;;                 array-pq)))  ;; in case of debugging
                   (intr-phi-2 array-pq cmpr)
 		  ))))
     (the intr-mrph #'rslt)))
 
-#|
-()
-(setf d (delta-infinity))
-(setf rslt (intr-phi d d))
-(funcall rslt (cmbn 3 1 (crpr 0 15 0 15)))
-|#
-
 #|
 
 (DEFUN INTR-PHI-22 (array-pq cmpr)
   (declare
    (type (simple-array cmbn (* *)) array-pq)
    (type cmprf cmpr))
-;   (format t "  -22-  ")
+;   (format t "  -22-  ")		;
   (the cmbn
        (let* ((n+1 (1- (array-dimension array-pq 0)))
 	      (n (1- n+1)))
@@ -226,7 +211,7 @@
   (declare
    (type (simple-array cmbn (* *)) array-pq)
    (type cmprf cmpr))
-;   (format t "  -2-  ")
+					;   (format t "  -2-  ")
   (the cmbn
        (let* ((n+1 (1- (array-dimension array-pq 0)))
 	      (n (1- n+1))
@@ -261,27 +246,22 @@
 		     (declare (fixnum q sign dgop1-ashed dgop2-ashed))
 		     (dolist (term (cmbn-list (aref array-pq p q)))
 		       (declare (type term term))
-                              (with-term (cffc crpr) term
+		       (with-term
-                                 (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
+			   (cffc crpr) term
+			   (with-crpr
+			       (dgop1 gmsm1 dgop2 gmsm2) crpr
 			       (setf cmbn-i-tail
 				     (setf (cdr cmbn-i-tail)
 					   (list (term (* sign cffc)
 						       (crpr
-                                                            (+ dgop1 dgop1-ashed) gmsm1
+							(+ dgop1 dgop1-ashed)
+							gmsm1
 							(+ dgop2 dgop2-ashed)
 							gmsm2))))))))))))))
          (if cmbn-list
 	     (apply #'ncmbn-add cmpr cmbn-list)
 	     (zero-cmbn n+1)))))
 
-#|
-  (setf d (delta-infinity))
-  (setf rslt (intr-phi d d))
-  (funcall rslt (cmbn 3 1 (crpr 0 15 0 15)))
-  (funcall rslt (cmbn 2 1 (crpr 0 7 0 7)))
-  (funcall rslt (cmbn 1 1 (crpr 0 3 0 3)))
-  (funcall rslt (cmbn 0 1 (crpr 0 1 0 1)))
-|#
 
 (DEFUN PHI (smst1 smst2)
   (declare (type simplicial-set smst1 smst2))
@@ -294,36 +274,6 @@
 	:strt :cmbn
 	:orgn `(phi ,smst1 ,smst2))))
 
-#|
-  (setf phi (phi (delta-infinity) (delta-infinity)))
-  (? phi 3 (crpr 0 15 0 15))
-|#
-
-#|  ;; Comparison with EAT.
-    ;; In Kenzo.
-  (cat-init)
-  (setf s (sphere 5))
-  (setf p (crts-prdc s s))
-  (setf b (basis p 8))
-  (setf c (make-cmbn :degr 8
-             :list (mapcar #'(lambda (item)
-                                (term (1+ (random 5)) item))
-                      b)))
-  (setf phi (phi s s))
-  (time (? phi c)))
-|#
-
-#|  ;; in EAT
-  (setf s (sphere 5))
-  (setf p (cpr-2ss s s))
-  (setf b (sbs p 8))
-  (setf c (make-cmb :dgr 8
-             :lst (mapcar #'(lambda (item)
-                               (mnm (1+ (random 5)) item))
-                     b)))
-  (setf phi (phi s s))
-  (time (??? phi c))
-|#
 
 (DEFUN INTR-AW (face1 face2)
   (declare (type face face1 face2))
@@ -371,14 +321,6 @@
 		   :list rslt)))))
     (the intr-mrph #'rslt)))
 
-#|
-  (setf r (intr-aw #'delta-face #'delta-face))
-  (funcall r 3 (crpr 0 15 0 15))
-  (setf s (sphere 3))
-  (setf f (face s))
-  (setf r (intr-aw f f))
-  (funcall r 3 (crpr 0 's3 0 's3))
-|#
 
 (DEFUN AW (smst1 smst2
 	   &aux (crts-prdc (crts-prdc smst1 smst2))
@@ -397,10 +339,6 @@
 	:strt :gnrt
 	:orgn `(aw ,smst1 ,smst2))))
 
-#|
-  (setf aw (aw (delta-infinity) (delta-infinity)))
-  (? aw (cmbn 3 1 (crpr 0 15 0 30) -1 (crpr 0 23 0 29)))
-|#
 
 (DEFUN EZ (smst1 smst2)
   (declare (type simplicial-set smst1 smst2))
@@ -411,51 +349,6 @@
 	:h (phi smst1 smst2)
 	:orgn `(eilenberg-zilber ,smst1 ,smst2))))
 
-#|
-(setf ez (ez (delta-infinity) (delta-infinity)))
-(setf *bc* (cmbn 3 1 (tnpr 0 1 3 30)
-             10 (tnpr 1 96 2 896)
-             100 (tnpr 2 7168 1 3)
-             1000 (tnpr 3 15 0 4096)))
-(setf *tc* (cmbn 3 1 (crpr 0 15 0 480)
-             100 (crpr 0 15 5 96)
-             10 (crpr 6 3 0 480)
-             1000 (crpr 6 3 1 224)))
-(pre-check-rdct ez)
-(check-rdct)
-|#
-
-
-#|
-  ;; Comparison EAT.
-  ;; In Kenzo.
-  (cat-init)
-  (setf s (sphere 5))
-  (setf ez (ez s s))
-  (setf b (basis (tcc ez) 8))
-  (setf c (make-cmbn :degr 8
-             :list (mapcar #'(lambda (item)
-                                (term (1+ (random 5)) item))
-                      b)))
-  (pre-check-rdct ez)
-  (setf +too-much-time+ -1)
-  (time (? *id-gf-dh-hd* c))
-  (time (? *id-gf-dh-hd* c))
-|#
-
-#|
-  ;; in EAT
-  (setf s (sphere 5))
-  (setf ez (ez s s))
-  (setf b (cbs (rdc-tcc ez) 8))
-  (setf c (make-cmb :dgr 8
-           :lst (mapcar #'(lambda (item)
-                             (mnm (1+ (random 5)) item))
-                   b)))
-  (verif-rdc ez)
-  (time (??? *id-gf-dh-hd* c))
-  (time (??? *id-gf-dh-hd* c))
-|#
 
 (DEFUN LEFT-CRTS-PRDC-EFHM (smst1 smst2)
   (declare (type simplicial-set smst1 smst2))
@@ -464,6 +357,7 @@
 	:lrdct (trivial-rdct (crts-prdc smst1 smst2))
 	:rrdct (ez smst1 smst2))))
 
+
 (DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'crts-prdc)))
   (declare (type simplicial-set smst))
   (the homotopy-equivalence
@@ -471,10 +365,3 @@
 	(left-crts-prdc-efhm (second (orgn smst)) (third (orgn smst)))
 	(tnsr-prdc (efhm (second (orgn smst)))
 		   (efhm (third (orgn smst)))))))
-
-#|
-  (cat-init)
-  (setf k (k-z 2))
-  (setf k2 (crts-prdc k k))
-  (homology k2 0 10)
-|#

test/eilenberg-zilber-test.lisp

@@ -0,0 +1,120 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+
+(test shuffle-sign
+      (dotimes (i 30)
+	(format t "~%~A => ~@D" (cat:hyphenize-list (cat:dlop-int-ext i))
+		(cat:shuffle-sign i))))
+
+
+(test intr-eml
+      (cat:intr-eml (cat:cmbn 3 1 (cat:tnpr 0 'a 3 'b)
+			      2 (cat:tnpr 2 'a 1 'b)
+			      3 (cat:tnpr 2 'aa 1 'bb)
+			      4 (cat:tnpr 3 'a 0 'b)))
+      (cat:intr-eml (cat:cmbn 3 1 (cat:tnpr 1 'c 2 'd)
+			      10 (cat:tnpr 2 'a 1 'b)))
+      (cat:intr-eml (cat:cmbn 3 10 (cat:tnpr 1 'c 2 'd)
+			      1 (cat:tnpr 2 'a 1 'b)
+			      100 (cat:tnpr 2 'aa 1 'bb)))
+      (cat:intr-eml (cat:cmbn 3 10 (cat:tnpr 1 'c 2 'd)
+			      100 (cat:tnpr 1 'cc 2 'dd)
+			      1 (cat:tnpr 2 'a 1 'b))))
+
+
+(test eml
+      (cat:cat-init)
+      (let* ((d (cat:delta-infinity))
+	     (eml (cat:eml d d)))
+	(cat:? eml (cat:cmbn 3 1 (cat:tnpr 0 1 3 30)
+			     10 (cat:tnpr 1 3 2 28)
+			     100 (cat:tnpr 2 7 1 24)
+			     1000 (cat:tnpr 3 15 0 16)))))
+
+
+(test intr-phi
+      (cat:cat-init)
+      (let* ((d (cat:delta-infinity))
+	     (rslt (cat:intr-phi d d)))
+	(funcall rslt (cat:cmbn 3 1 (cat:crpr 0 15 0 15)))
+	(funcall rslt (cat:cmbn 2 1 (cat:crpr 0 7 0 7)))
+	(funcall rslt (cat:cmbn 1 1 (cat:crpr 0 3 0 3)))
+	(funcall rslt (cat:cmbn 0 1 (cat:crpr 0 1 0 1)))))
+
+
+(test phi
+      (cat:cat-init)
+      (let ((phi (cat:phi (cat:delta-infinity) (cat:delta-infinity))))
+	(cat:? phi 3 (cat:crpr 0 15 0 15))))
+
+
+(test eat
+      (cat:cat-init)
+      (let* ((s (cat:sphere 5))
+	     (p (cat:crts-prdc s s))
+	     (b (cat:basis p 8))
+	     (c (cat:make-cmbn :degr 8
+			       :list (mapcar #'(lambda (item)
+						 (cat:term (1+ (random 5))
+							   item))
+					     b)))
+	     (phi (cat:phi s s)))
+	(time (cat:? phi c))))
+
+
+(test intr-aw
+      (cat:cat-init)
+      (let* ((r (cat:intr-aw #'cat:delta-face #'cat:delta-face))
+	     (s (cat:sphere 3))
+	     (f (cat:face s)))
+	(funcall r 3 (cat:crpr 0 15 0 15))
+	(setf r (cat:intr-aw f f))
+	(funcall r 3 (cat:crpr 0 's3 0 's3))))
+
+
+(test aw
+      (cat:cat-init)
+      (let ((aw (cat:aw (cat:delta-infinity) (cat:delta-infinity))))
+	(cat:? aw (cat:cmbn 3 1 (cat:crpr 0 15 0 30)
+			    -1 (cat:crpr 0 23 0 29)))))
+
+
+(test ez
+      (cat:cat-init)
+      (let ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity))))
+	(setf cat:*bc* (cat:cmbn 3 1 (cat:tnpr 0 1 3 30)
+				 10 (cat:tnpr 1 96 2 896)
+				 100 (cat:tnpr 2 7168 1 3)
+				 1000 (cat:tnpr 3 15 0 4096)))
+	(setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 15 0 480)
+				 100 (cat:crpr 0 15 5 96)
+				 10 (cat:crpr 6 3 0 480)
+				 1000 (cat:crpr 6 3 1 224)))
+	(cat:pre-check-rdct ez)
+	(check-rdct)))
+
+
+(test eat1
+      (cat:cat-init)
+      (let* ((s (cat:sphere 5))
+	     (ez (cat:ez s s))
+	     (b (cat:basis (cat:tcc ez) 8))
+	     (c (cat:make-cmbn :degr 8
+			       :list (mapcar #'(lambda (item)
+						 (cat:term (1+ (random 5))
+							   item))
+					     b))))
+	(cat:pre-check-rdct ez)
+	(setf cat:+too-much-time+ -1)
+	(time (cat:? cat:*id-gf-dh-hd* c))
+	(time (cat:? cat:*id-gf-dh-hd* c))))
+
+
+(test crts-prdc
+      (cat:cat-init)
+      (let* ((k (cat:k-z 2))
+	     (k2 (cat:crts-prdc k k)))
+	(cat:homology k2 0 10)))