Extracted tensor product tests.

kenzo-test.asd

@@ -9,6 +9,7 @@
   :pathname #P"test/"
   :components ((:file "package")
 	       (:file "common")
+	       #|
 	       (:file "combinations-test")
 	       (:file "various-test")
 	       (:file "chain-complexes-test")
@@ -24,4 +25,6 @@
 	       (:file "bar-test")
 	       (:file "cartesian-products-test")
 	       (:file "cones-test")
-	       (:file "cl-space-efhm-test")))
+	       (:file "cl-space-efhm-test")
+	       |#
+	       (:file "tensor-products-test")))

package.lisp

@@ -19,6 +19,7 @@
            *LIST-LIST*
 	   *TC*
 	   *TDD*
+	   *TNPR-WITH-DEGREES*
 
 	   ;; bar.lisp
 
@@ -88,6 +89,7 @@
 
 	   ;; cl-space-efhm.lisp
 
+	   CS-HAT-T-U
 	   CS-HAT-U-T
 
 	   ;; classes.lisp
@@ -118,6 +120,7 @@
 	   ORGN
 	   REDUCTION
 	   RRDCT
+	   SORC
 	   TCC
 	   TNPR
 
@@ -258,6 +261,16 @@
 	   SPHERE
 	   BUILD-FINITE-SS
 
+	   ;; tensor-products.lisp
+
+	   2CMBN-TNPR
+	   TNSR-PRDC
+	   TNSR-PRDC-BASIS
+	   TNSR-PRDC-CMPR
+	   TNSR-PRDC-INTR
+	   TNSR-PRDC-INTR-DFFR
+	   TNPR-PRINT
+
 	   ;; various.lisp
 
 	   +EMPTY-LIST+

run-kenzo-test.lisp

@@ -1,3 +1,6 @@
+
+(DECLAIM (OPTIMIZE (speed 0) (space 0) (debug 3)))
+
 (require 'asdf)
 
 (asdf:operate 'asdf:load-op 'kenzo-test)

src/kenzo.lisp

@@ -7,7 +7,6 @@
   (values))
 
 ;;(PROCLAIM '(OPTIMIZE (speed 3) (safety 1) (space 0) (debug 0)))
-(DECLAIM (OPTIMIZE (speed 0) (space 0) (debug 3)))
 
 ;; Don't mess with ANSI's definition of DEFCONSTANT!
 

src/tensor-products.lisp

@@ -21,40 +21,31 @@
 	 tnpr)))
 
 
-
-#|
-  (tnpr 2 'a 3 'b)
-  (setf *tnpr-with-degrees* t)    
-  (tnpr 2 'a 3 'b)
-  (setf *tnpr-with-degrees* nil)
-|#
-
 (DEFUN 2CMBN-TNPR (cmbn1 cmbn2)
   (declare (type cmbn cmbn1 cmbn2))
   (the cmbn
-      (with-cmbn (degr1 list1) cmbn1
+       (with-cmbn
-      (with-cmbn (degr2 list2) cmbn2
+	   (degr1 list1) cmbn1
+	   (with-cmbn
+	       (degr2 list2) cmbn2
 	       (make-cmbn
 		:degr (+ degr1 degr2)
 		:list (mapcan
 		       #'(lambda (term1)
 			   (declare (type term term1))
 			   (the list
-                             (with-term (cffc1 gnrt1) term1
+				(with-term
+				    (cffc1 gnrt1) term1
 				    (mapcar
 				     #'(lambda (term2)
 					 (declare (type term term2))
 					 (the term
 					      (term
 					       (* cffc1 (cffc term2))
-                                              (tnpr degr1 gnrt1 degr2 (gnrt term2)))))
+					       (tnpr degr1 gnrt1 degr2
+						     (gnrt term2)))))
 				     list2))))
 		       list1))))))
-#|
-  (setf *tnpr-with-degrees* t)
-  (2cmbn-tnpr (cmbn 2 3 'a 4 'b -5 'c) (cmbn 3 4 'x -3 'y 2 'z)))
-|#
-
 
 #|
 (DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2)
@@ -82,17 +73,6 @@
     (the cmprf #'rslt)))
 
 
-#|
-  (setf cmpr (tnsr-prdc-cmpr #'s-cmpr #'s-cmpr))
-  (funcall cmpr (tnpr 2 'a 3 'b) (tnpr 3 'a 2 'b))
-  (funcall cmpr (tnpr 3 'a 2 'b) (tnpr 2 'a 3 'b))
-  (funcall cmpr (tnpr 2 'a 3 'b) (tnpr 2 'b 3 'b))
-  (funcall cmpr (tnpr 2 'b 3 'b) (tnpr 2 'a 3 'b))
-  (funcall cmpr (tnpr 2 'a 3 'a) (tnpr 2 'a 3 'b))
-  (funcall cmpr (tnpr 2 'a 3 'c) (tnpr 2 'a 3 'b))
-  (funcall cmpr (tnpr 2 'a 3 'b) (tnpr 2 'a 3 'b)))
-|#
-
 (DEFUN TNSR-PRDC-BASIS (basis1 basis2)
   (declare (type basis basis1 basis2))
   (when (or (eq basis1 :locally-effective)
@@ -122,24 +102,13 @@
 					 #'(lambda (gnrt2)
 					     (declare (type gnrt gnrt2))
 					     (the tnpr
-                                                       (tnpr degr1 gnrt1 degr2 gnrt2)))
+						  (tnpr degr1 gnrt1 degr2
+							gnrt2)))
 					 basis2)))
 			       basis1))))
 		   (<a-b> 0 degr))))))
     (the basis #'rslt)))
 
-#|
-  (defun bas (degr)
-     (case degr
-        (0 '(a b c))
-        (1 '(d))
-        (2 nil)
-        (3 '(x y))))
-  (setf bas (tnsr-prdc-basis #'bas #'bas))
-  (dotimes (i 8)
-     (print (funcall bas i))))
-|#
-
 
 (DEFUN TNSR-PRDC-INTR-DFFR (dffr1 dffr2)
   (declare (type morphism dffr1 dffr2))
@@ -148,7 +117,8 @@
 	    (fixnum degr)
 	    (type tnpr tnpr))
 	   (the cmbn
-                (with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
+                (with-tnpr
+		    (degr1 gnrt1 degr2 gnrt2) tnpr
 		    (let ((degr1-1 (1- degr1))
 			  (degr2-1 (1- degr2))
 			  (sign (oddp degr1))
@@ -164,36 +134,22 @@
 			      (mapcar
 			       #'(lambda (term1)
 				   (declare (type term term1))
-                                          (with-term (cffc1 gnrt1) term1
+				   (with-term
-                                             (term cffc1
+				       (cffc1 gnrt1) term1
-                                                (tnpr degr1-1 gnrt1 degr2 gnrt2))))
+				       (term cffc1 (tnpr degr1-1 gnrt1
+							 degr2 gnrt2))))
 			       list1)
 			      (mapcar
 			       #'(lambda (term2)
 				   (declare (type term term2))
 				   (with-term (cffc2 gnrt2) term2
 					      (term (if sign (- cffc2) cffc2)
-                                                (tnpr degr1 gnrt1 degr2-1 gnrt2))))
+						    (tnpr degr1 gnrt1
+							  degr2-1 gnrt2))))
 			       list2))))))))
     (the intr-mrph #'rslt)))
 
 
-#|
-  (cat-init)
-  (setf chcm (build-chcm :cmpr #'s-cmpr :strt :gnrt :orgn '(test-1)))
-  (setf dffr (build-mrph :sorc chcm :trgt chcm :degr -1
-                         :intr #'(lambda (degr gnrt)
-                                    (ecase gnrt
-                                       (a (cmbn (1- degr) 2 'd1a -3 'd2a))
-                                       (b (cmbn (1- degr) 3 'd1b -4 'd2b))))
-                         :strt :gnrt :orgn '(test-2)))
-  (setf rslt (tnsr-prdc-intr-dffr dffr dffr))
-  (funcall rslt 4 (tnpr 2 'a 2 'b))
-  (funcall rslt 5 (tnpr 3 'a 2 'b))
-  (funcall rslt 5 (tnpr 2 'a 3 'b))
-  (funcall rslt 6 (tnpr 3 'a 3 'b)))
-|#
-
 (DEFGENERIC TNSR-PRDC (chcm-hmeq-mrph-rdct1 chcm-hmeq-mrph-rdct2))
 
 (DEFMETHOD TNSR-PRDC ((chcm1 chain-complex) (chcm2 chain-complex))
@@ -223,15 +179,6 @@
 		 (slot-makunbound rslt 'bsgn))
 	     rslt)))))
 
-#|
-  (setf dd (tnsr-prdc (delta 2) (delta 3)))
-  (cmpr dd (tnpr 2 7 2 11) (tnpr 2 7 2 14))
-  (basis dd 3)
-  (? dd 4 (tnpr 2 7 2 14))
-  (? dd 3 (tnpr 1 6 2 14))
-  (? dd (? dd 4 (tnpr 2 7 2 14)))
-  (? dd (? dd 3 (tnpr 1 6 2 14))))
-|#
 
 (DEFUN TNSR-PRDC-INTR (mrph1 mrph2)
   (declare
@@ -257,30 +204,6 @@
 			  rslt))))
       (the intr-mrph #'rslt))))
 
-#|
-  (cat-init)
-  (setf chcm (build-chcm :cmpr #'s-cmpr :strt :gnrt :orgn '(test-1)))
-  (setf mrph (build-mrph :sorc chcm :trgt chcm :degr 0
-                         :intr #'(lambda (degr gnrt)
-                                    (ecase gnrt
-                                       (a (cmbn degr 2 'd1a -3 'd2a))
-                                       (b (cmbn degr 3 'd1b -4 'd2b))))
-                         :strt :gnrt :orgn '(test-2)))
-  (setf rslt (tnsr-prdc-intr mrph mrph))
-  (funcall rslt 6 (tnpr 2 'a 4 'b))
-  (funcall rslt 5 (tnpr 3 'a 2 'b))
-  (setf mrph (build-mrph :sorc chcm :trgt chcm :degr 1
-                         :intr #'(lambda (degr gnrt)
-                                    (ecase gnrt
-                                       (a (cmbn (1+ degr) 2 'd1a -3 'd2a))
-                                       (b (cmbn (1+ degr) 3 'd1b -4 'd2b))))
-                         :strt :gnrt :orgn '(test-3)))
-  (setf rslt (tnsr-prdc-intr mrph mrph))
-  (funcall rslt 6 (tnpr 2 'a 4 'b))
-  (funcall rslt 5 (tnpr 3 'a 2 'b)))
-|#
-
-
 
 (DEFMETHOD TNSR-PRDC ((mrph1 morphism) (mrph2 morphism))
   (the morphism
@@ -306,19 +229,6 @@
 		   :strt :gnrt
 		   :orgn `(tnsr-prdc ,mrph1 ,mrph2))))))))
 
-#|
-  (cat-init)
-  (setf d (dffr (delta-infinity)))
-  (setf dd (tnsr-prdc d d))
-  (eq (sorc dd) (tnsr-prdc (delta-infinity) (delta-infinity)))
-  (? dd 5 (tnpr 2 7 3 15))
-  (? dd 5 (tnpr 3 15 2 7))
-  (? dd (? dd 5 (tnpr 2 7 3 15)))
-  (? dd (? dd 5 (tnpr 3 15 2 7)))
-  (setf ddd (cmps dd dd))
-  (? ddd 5 (tnpr 2 7 3 15))
-  (? ddd 5 (tnpr 3 15 2 7))
-|#
 
 (DEFMETHOD TNSR-PRDC ((rdct1 reduction) (rdct2 reduction))
   (the reduction
@@ -343,15 +253,6 @@
 		  (tnsr-prdc (idnt-mrph tcc1) h2))
 	      :orgn `(tnsr-prdc ,rdct1 ,rdct2)))))))
 
-#|
-  (cat-init)
-  (setf r (ez (delta-infinity) (delta-infinity)))
-  (setf r2 (tnsr-prdc r r))
-  (setf *bc* (cmbn 4 1 (tnpr 2 (tnpr 1 3 1 3) 2 (tnpr 1 3 1 3)))
-        *tc* (cmbn 2 1 (tnpr 1 (crpr 0 3 0 3) 1 (crpr 0 3 0 3))))
-  (pre-check-rdct r2)
-  (check-rdct)
-|#
 
 (DEFMETHOD TNSR-PRDC ((hmeq1 homotopy-equivalence)
 		      (hmeq2 homotopy-equivalence))
@@ -366,10 +267,3 @@
   (the homotopy-equivalence
        (tnsr-prdc (efhm (second (orgn chcm)))
 		  (efhm (third (orgn chcm))))))
-
-#|
-(cat-init)
-(setf k (k-z 2))
-(setf k2 (tnsr-prdc k k))
-(homology k2 0 10)
-|#

test/tensor-products-test.lisp

@@ -0,0 +1,150 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+
+(test tnpr
+      (cat:tnpr 2 'a 3 'b)
+      (setf cat:*tnpr-with-degrees* t)
+      (cat:tnpr 2 'a 3 'b)
+      (setf cat:*tnpr-with-degrees* nil))
+
+
+(test 2cmbn-tnpr
+      (setf cat:*tnpr-with-degrees* t)
+      (cat:2cmbn-tnpr (cat:cmbn 2 3 'a 4 'b -5 'c)
+		      (cat:cmbn 3 4 'x -3 'y 2 'z)))
+
+
+(test tnsr-prdc-cmpr
+      (let ((cmpr (cat:tnsr-prdc-cmpr #'cat:s-cmpr #'cat:s-cmpr)))
+	(is (equal :less (funcall cmpr
+				  (cat:tnpr 2 'a 3 'b)
+				  (cat:tnpr 3 'a 2 'b))))
+	(is (equal :greater (funcall cmpr
+				     (cat:tnpr 3 'a 2 'b)
+				     (cat:tnpr 2 'a 3 'b))))
+	(is (equal :less (funcall cmpr
+				   (cat:tnpr 2 'a 3 'b)
+				   (cat:tnpr 2 'b 3 'b))))
+	(is (equal :greater (funcall cmpr
+				     (cat:tnpr 2 'b 3 'b)
+				     (cat:tnpr 2 'a 3 'b))))
+	(is (equal :less (funcall cmpr
+				  (cat:tnpr 2 'a 3 'a)
+				  (cat:tnpr 2 'a 3 'b))))
+	(is (equal :greater (funcall cmpr
+				     (cat:tnpr 2 'a 3 'c)
+				     (cat:tnpr 2 'a 3 'b))))
+	(is (equal :equal (funcall cmpr
+				   (cat:tnpr 2 'a 3 'b)
+				   (cat:tnpr 2 'a 3 'b))))))
+
+
+(defun bas (degr)
+  (case degr
+    (0 '(a b c))
+    (1 '(d))
+    (2 nil)
+    (3 '(x y))))
+
+
+(test tnsr-prdc-basis
+      (let ((bas (cat:tnsr-prdc-basis #'bas #'bas)))
+	(dotimes (i 8)
+	  (print (funcall bas i)))))
+
+
+(test tnsr-prdc-intr-dffr
+      	(cat:cat-init)
+	(let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr
+				     :basis :locally-effective
+				     :intr-dffr #'cat:zero-mrph
+				     :strt :gnrt :orgn '(test-1)))
+	       (dffr (cat:build-mrph
+		       :sorc chcm :trgt chcm :degr -1
+		       :intr #'(lambda (degr gnrt)
+				 (ecase gnrt
+				   (a (cat:cmbn (1- degr) 2 'd1a -3 'd2a))
+				   (b (cat:cmbn (1- degr) 3 'd1b -4 'd2b))))
+		       :strt :gnrt :orgn '(test-2)))
+	       (rslt (cat:tnsr-prdc-intr-dffr dffr dffr)))
+	  (funcall rslt 4 (cat:tnpr 2 'a 2 'b))
+	  (funcall rslt 5 (cat:tnpr 3 'a 2 'b))
+	  (funcall rslt 5 (cat:tnpr 2 'a 3 'b))
+	  (funcall rslt 6 (cat:tnpr 3 'a 3 'b))))
+
+
+(test tnsr-prdc
+      (let ((dd (cat:tnsr-prdc (cat:delta 2) (cat:delta 3))))
+	(cat:cmpr dd (cat:tnpr 2 7 2 11) (cat:tnpr 2 7 2 14))
+	(cat:basis dd 3)
+	(cat:? dd 4 (cat:tnpr 2 7 2 14))
+	(cat:? dd 3 (cat:tnpr 1 6 2 14))
+	(cat:? dd (cat:? dd 4 (cat:tnpr 2 7 2 14)))
+	(cat:? dd (cat:? dd 3 (cat:tnpr 1 6 2 14)))))
+
+
+(test tnsr-prdc-intr
+      (cat:cat-init)
+      (let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr
+				   :basis :locally-effective
+				   :intr-dffr #'cat:zero-mrph
+				   :strt :gnrt
+				   :orgn '(test-1)))
+
+	     (mrph (cat:build-mrph
+		    :sorc chcm :trgt chcm :degr 0
+		    :intr #'(lambda (degr gnrt)
+			      (ecase gnrt
+				(a (cat:cmbn degr 2 'd1a -3 'd2a))
+				(b (cat:cmbn degr 3 'd1b -4 'd2b))))
+		    :strt :gnrt :orgn '(test-2)))
+	     (rslt (cat:tnsr-prdc-intr mrph mrph)))
+	(funcall rslt 6 (cat:tnpr 2 'a 4 'b))
+	(funcall rslt 5 (cat:tnpr 3 'a 2 'b))
+	(setf mrph (cat:build-mrph
+		    :sorc chcm :trgt chcm :degr 1
+		    :intr #'(lambda (degr gnrt)
+			      (ecase gnrt
+				(a (cat:cmbn (1+ degr) 2 'd1a -3 'd2a))
+				(b (cat:cmbn (1+ degr) 3 'd1b -4 'd2b))))
+		    :strt :gnrt :orgn '(test-3)))
+	(setf rslt (cat:tnsr-prdc-intr mrph mrph))
+	(funcall rslt 6 (cat:tnpr 2 'a 4 'b))
+	(funcall rslt 5 (cat:tnpr 3 'a 2 'b))))
+
+
+(test tnsr-prdc
+      (cat:cat-init)
+      (let* ((d (cat:dffr (cat:delta-infinity)))
+	     (dd (cat:tnsr-prdc d d))
+	     (ddd (cat:cmps dd dd)))
+	(is (eq (cat:sorc dd) (cat:tnsr-prdc (cat:delta-infinity)
+					     (cat:delta-infinity))))
+	(cat:? dd 5 (cat:tnpr 2 7 3 15))
+	(cat:? dd 5 (cat:tnpr 3 15 2 7))
+	(cat:? dd (cat:? dd 5 (cat:tnpr 2 7 3 15)))
+	(cat:? dd (cat:? dd 5 (cat:tnpr 3 15 2 7)))
+	(cat:? ddd 5 (cat:tnpr 2 7 3 15))
+	(cat:? ddd 5 (cat:tnpr 3 15 2 7))))
+
+#|
+(test tnsr-prdc1
+      (cat:cat-init)
+      (let* ((r (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
+	     (r2 (cat:tnsr-prdc r r)))
+	(setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:tnpr 1 3 1 3) 2
+					       (cat:tnpr 1 3 1 3)))
+	      cat:*tc* (cat:cmbn 2 1 (cat:tnpr 1 (cat:crpr 0 3 0 3) 1
+					       (cat:crpr 0 3 0 3))))
+	(cat:pre-check-rdct r2)
+	(check-rdct)))
+
+(test tnsr-prdc2
+      (cat:cat-init)
+      (let* ((k (cat:k-z 2))
+	     (k2 (cat:tnsr-prdc k k)))
+	(cat:homology k2 0 10)))
+|#