Extracted suspensions tests.

kenzo-test.asd

@@ -38,6 +38,7 @@
 	       (:file "simplicial-groups-test")
 	       (:file "simplicial-mrphs-test")
 	       (:file "simplicial-sets-test")
+	       (:file "suspensions-test")
 	       (:file "tensor-products-test")
 	       (:file "various-test")
 	       ))

package.lisp

@@ -121,6 +121,7 @@
 	   APOWR
 	   BCC
 	   BRGN
+	   BSGN
 	   BSPN
 	   CBGN
 	   CHAIN-COMPLEX
@@ -446,6 +447,16 @@
 	   SPHERE
 	   SPHERE-FACE
 
+	   ;; suspensions.lisp
+
+	   SUSPENSION
+	   SUSPENSION-BASIS
+	   SUSPENSION-CMPR
+	   SUSPENSION-FACE
+	   SUSPENSION-INTR
+	   SUSPENSION-INTR-CPRD
+	   SUSPENSION-INTR-DFFR
+
 	   ;; tensor-products.lisp
 
 	   2CMBN-TNPR

src/suspensions.lisp

@@ -15,12 +15,6 @@
 	       (funcall cmpr gnrt1 gnrt2))))
     (the cmprf #'rslt)))
 
-#|
-  (setf cc (deltab))
-  (setf cmpr (suspension-cmpr (cmpr cc)))
-  (funcall cmpr :s-bsgn :s-bsgn)
-  (funcall cmpr 6 5)
-|#
 
 (DEFUN SUSPENSION-BASIS (basis)
   (declare (type basis basis))
@@ -34,19 +28,13 @@
 	     (otherwise (funcall basis (1- degr))))))
     (the basis #'rslt)))
 
-#|
-  (setf cc (sphere 2))
-  (setf basis (suspension-basis (basis cc)))
-  (dotimes (i 6)
-    (print (funcall basis i)))
-  (suspension-basis :locally-effective)
-|#
 
 (DEFUN SUSPENSION-INTR-DFFR (dffr)
   (declare (type morphism dffr))
   (flet ((rslt (cmbn)
 	   (declare (type cmbn cmbn))
-	   (with-cmbn (degr list) cmbn
+	   (with-cmbn
+	       (degr list) cmbn
 	       (decf degr)
 	       (if (<= degr 0)
 		   (zero-cmbn degr)
@@ -57,12 +45,6 @@
 							:list list))))))))
     (the intr-mrph #'rslt)))
 
-#|
-  (setf cc (deltab))
-  (setf intr (suspension-intr-dffr (dffr cc)))
-  (funcall intr (cmbn 0 3 :s-bsgn))
-  (funcall intr (cmbn 3 66 7))
-|#
 
 (DEFUN SUSPENSION (obj &optional (n 1))
   (declare (type (or chain-complex morphism reduction
@@ -75,6 +57,7 @@
 
 (DEFGENERIC SUSPENSION-1 (x))
 
+
 (DEFMETHOD SUSPENSION-1 ((chcm chain-complex))
   (the chain-complex
        (with-slots (cmpr basis dffr) chcm
@@ -86,22 +69,12 @@
 	  :strt :cmbn
 	  :orgn `(suspension ,chcm)))))
 
-#|
-  (cat-init)
-  (setf cc (deltab))
-  (setf scc (suspension cc))
-  (cmpr scc 7 11)
-  (basis scc 3)  ;; error
-  (bsgn scc)
-  (? scc 3 11)
-  (setf scc (suspension cc 2))
-  (? scc 4 11)
-|#
 
 (DEFUN SUSPENSION-INTR-CPRD (cmbn)
   (declare (type cmbn cmbn))
   (the cmbn
-    (with-cmbn (degr list) cmbn
+       (with-cmbn
+	   (degr list) cmbn
 	   (if (zerop degr)
 	       (make-cmbn :degr 0
 			  :list (if list
@@ -116,7 +89,8 @@
 				  (mapc
 				   #'(lambda (term)
 				       (declare (type term term))
-				(with-term (cffc gnrt) term
+				       (with-term
+					   (cffc gnrt) term
 					   (push (term cffc
 						       (tnpr 0 :s-bsgn
 							     degr gnrt))
@@ -128,11 +102,6 @@
 				   list)
 				  (nreconc list1 (nreverse list2))))))))
 
-#|
- (suspension-intr-cprd (cmbn 0))
- (suspension-intr-cprd (cmbn 0 5 :s-bsgn))
- (suspension-intr-cprd (cmbn 3 4 7 5 11))
-|#
 
 (DEFMETHOD SUSPENSION-1 ((clgb coalgebra))
   (the coalgebra
@@ -147,14 +116,6 @@
 	       `(coproduct ,irslt))
 	 irslt)))
 
-#|
-  (cat-init)
-  (setf coal (deltab))
-  (setf scoal (suspension coal))
-  (setf scoal (suspension coal))
-  (? scoal 3 7)
-  (cprd scoal 3 7)
-|#
 
 (DEFUN SUSPENSION-FACE (face)
   (declare (type face face))
@@ -172,21 +133,6 @@
 		     irslt)))))
     (the face #'rslt)))
 
-#|
-  (setf ss (deltab))
-  (setf face (suspension-face (face ss)))
-  (funcall face 4 4 15)
-  (funcall face 0 4 15)
-  (check-faces #'f-cmpr face 4 15)
-  (check-faces #'f-cmpr face 3 7)
-  (check-faces #'f-cmpr face 2 3)
-  (setf m (moore 2 3))
-  (setf face (suspension-face (face m)))
-  (dotimes (i 5) (print (funcall face i 4 'm3)))
-  (dotimes (i 6) (print (funcall face i 5 'mm4)))
-  (check-faces #'s-cmpr face 4 'm3)
-  (check-faces #'s-cmpr face 5 'mm4)
-|#
 
 (DEFMETHOD SUSPENSION-1 ((smst simplicial-set))
   (the simplicial-set
@@ -201,22 +147,6 @@
 	       `(diagonal ,irslt))
 	 irslt)))
 
-#|
-  (cat-init)
-  (setf d (deltab))
-  (setf sd (suspension d))
-  (setf sd (suspension d))
-  (inspect sd)
-  (? sd 3 7)
-  (cprd sd 3 7)
-  (face sd 3 3 7)
-  (face sd 2 3 7)
-  (setf m (moore 2 1))
-  (setf sm (suspension m))
-  (homology sm 0 5)
-  (setf ssm (suspension sm))
-  (homology ssm 0 6)
-|#
 
 (DEFUN SUSPENSION-INTR (mrph)
   (declare (type morphism mrph))
@@ -224,7 +154,8 @@
     (declare (fixnum mdegr))
     (flet ((rslt (cmbn)
 	     (declare (type cmbn cmbn))
-	     (with-cmbn (cdegr list) cmbn
+	     (with-cmbn
+		 (cdegr list) cmbn
 		 (when (zerop cdegr)
 		   (return-from rslt
 		     (if (zerop mdegr)
@@ -236,17 +167,6 @@
 							   :list list)))))))
       (the intr-mrph #'rslt))))
 
-#|
-  (setf f (idnt-mrph (deltab)))
-  (setf sf (suspension-intr f))
-  (funcall sf (cmbn 0 3 :s-bsgn))
-  (funcall sf (cmbn 2 4 3))
-  (setf d (dffr (deltab)))
-  (setf sd (suspension-intr d))
-  (funcall sd (cmbn 0 3 :s-bsgn))
-  (funcall sd (cmbn 2 4 3))
-  (funcall sd (cmbn 3 4 7))
-|#
 
 (DEFMETHOD SUSPENSION-1 ((mrph morphism))
   (the morphism
@@ -268,17 +188,6 @@
 	  :strt :cmbn
 	  :orgn `(suspension ,mrph)))))
 
-#|
-  (setf f (idnt-mrph (deltab)))
-  (setf sf (suspension f))
-  (? sf (cmbn 0 3 :s-bsgn))
-  (? sf (cmbn 2 4 3))
-  (setf d (dffr (deltab)))
-  (setf sd (suspension d))
-  (? sd (cmbn 0 3 :s-bsgn))
-  (? sd (cmbn 2 4 3))
-  (? sd (cmbn 3 4 7))
-|#
 
 (DEFMETHOD SUSPENSION-1 ((rdct reduction))
   (the reduction (progn
@@ -291,34 +200,19 @@
 		    :h (suspension (h rdct))
 		    :orgn `(suspension ,rdct)))))
 
-#|
-  (setf rdct (ez (deltab) (deltab)))
-  (setf srdct (suspension rdct))
-  (pre-check-rdct srdct)
-  (setf *tc* (cmbn 4 1 (crpr 0 15 0 15)))
-  (setf *bc* (cmbn 4 1 (tnpr 0 1 3 15)
-                     5 (tnpr 1 3 2 7)
-                     10 (tnpr 2 7 1 3)
-                     100 (tnpr 3 15 0 1)))
-  (check-rdct)
-|#
 
 (DEFMETHOD SUSPENSION-1 ((hmeq homotopy-equivalence))
   (the homotopy-equivalence (progn
 			      (when (eq (first (orgn hmeq)) 'trivial-hmeq)
 				(return-from suspension-1
-	(trivial-hmeq (suspension (second (orgn hmeq))))))
+				  (trivial-hmeq (suspension
+						 (second (orgn hmeq))))))
 			      (build-hmeq
 			       :lrdct (suspension (lrdct hmeq))
 			       :rrdct (suspension (rrdct hmeq))
 			       :orgn `(suspension ,hmeq)))))
 
+
 (DEFMETHOD SEARCH-EFHM (suspension (orgn (eql 'suspension)))
   (declare (type chain-complex suspension))
   (suspension (efhm (second (orgn suspension)))))
-
-#|
-  (setf sk (suspension (k-z 2)))
-  (homology sk 0 10)
-|#
-  

test/common.lisp

@@ -224,6 +224,7 @@
 (defun random-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
   (apply #'cat:nterm-add cmpr degr
 	 (mapcar #'(lambda (dummy)
+		     (declare (ignore dummy))
                      (cat:term (cat:srandom max-cffc)
 			       (random-crpr degr max-expn loop-length)))
 		 (make-list cmbn-length))))
@@ -255,5 +256,6 @@
 
 (defun random-niloop (dmns max-expn length)
   (mapcar #'(lambda (dummy)
+	      (declare (ignore dummy))
 	      (random-apowr (1+ dmns) max-expn))
 	  (make-list length)))

test/suspensions-test.lisp

@@ -0,0 +1,133 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(test suspension-cmpr
+      (cat:cat-init)
+      (let* ((cc (cat:deltab))
+	     (cmpr (cat:suspension-cmpr (cat:cmpr cc))))
+	(is (equal :equal (funcall cmpr :s-bsgn :s-bsgn)))
+	(is (equal :greater (funcall cmpr 6 5)))))
+
+
+(test suspension-basis
+      (cat:cat-init)
+      (let* ((cc (cat:sphere 2))
+	     (basis (cat:suspension-basis (cat:basis cc))))
+	(dotimes (i 6)
+	  (print (funcall basis i)))
+	(cat:suspension-basis :locally-effective)))
+
+
+(test suspension-intr-dffr
+      (cat:cat-init)
+      (let* ((cc (cat:deltab))
+	     (intr (cat:suspension-intr-dffr (cat:dffr cc))))
+	(funcall intr (cat:cmbn 0 3 :s-bsgn))
+	(funcall intr (cat:cmbn 3 66 7))))
+
+
+(test suspension
+      (cat:cat-init)
+      (let* ((cc (cat:deltab))
+	     (scc (cat:suspension cc)))
+	(cat:cmpr scc 7 11)
+	(signals simple-error (cat:basis scc 3))
+	(cat:bsgn scc)
+	(cat:? scc 3 11)
+	(setf scc (cat:suspension cc 2))
+	(cat:? scc 4 11)))
+
+
+(test suspension-intr-cprd
+      (cat:suspension-intr-cprd (cat:cmbn 0))
+      (cat:suspension-intr-cprd (cat:cmbn 0 5 :s-bsgn))
+      (cat:suspension-intr-cprd (cat:cmbn 3 4 7 5 11)))
+
+
+(test coal
+      (cat:cat-init)
+      (let* ((coal (cat:deltab))
+	     (scoal (cat:suspension coal)))
+	(setf scoal (cat:suspension coal))
+	(cat:? scoal 3 7)
+	(cat:cprd scoal 3 7)))
+
+
+(test suspension-face
+      (cat:cat-init)
+      (let* ((ss (cat:deltab))
+	     (face (cat:suspension-face (cat:face ss)))
+	     (m (cat:moore 2 3)))
+	(funcall face 4 4 15)
+	(funcall face 0 4 15)
+	(cat:check-faces #'cat:f-cmpr face 4 15)
+	(cat:check-faces #'cat:f-cmpr face 3 7)
+	(cat:check-faces #'cat:f-cmpr face 2 3)
+	(setf face (cat:suspension-face (cat:face m)))
+	(dotimes (i 5) (print (funcall face i 4 'm3)))
+	(dotimes (i 6) (print (funcall face i 5 'mm4)))
+	(cat:check-faces #'cat:s-cmpr face 4 'm3)
+	(cat:check-faces #'cat:s-cmpr face 5 'mm4)))
+
+
+(test suspension1
+      (cat:cat-init)
+      (let* ((d (cat:deltab))
+	     (sd (cat:suspension d))
+	     (m (cat:moore 2 1))
+	     (sm (cat:suspension m)))
+	(setf sd (cat:suspension d))
+	(cat:? sd 3 7)
+	(cat:cprd sd 3 7)
+	(cat:face sd 3 3 7)
+	(cat:face sd 2 3 7)
+	(cat:homology sm 0 5)
+	(setf ssm (cat:suspension sm))
+	(cat:homology ssm 0 6)))
+
+
+(test suspension-intr
+      (cat:cat-init)
+      (let* ((f (cat:idnt-mrph (cat:deltab)))
+	     (sf (cat:suspension-intr f))
+	     (d (cat:dffr (cat:deltab)))
+	     (sd (cat:suspension-intr d)))
+	(funcall sf (cat:cmbn 0 3 :s-bsgn))
+	(funcall sf (cat:cmbn 2 4 3))
+	(funcall sd (cat:cmbn 0 3 :s-bsgn))
+	(funcall sd (cat:cmbn 2 4 3))
+	(funcall sd (cat:cmbn 3 4 7))))
+
+
+(test suspension2
+      (cat:cat-init)
+      (let* ((f (cat:idnt-mrph (cat:deltab)))
+	     (sf (cat:suspension f))
+	     (d (cat:dffr (cat:deltab)))
+	     (sd (cat:suspension d)))
+	(cat:? sf (cat:cmbn 0 3 :s-bsgn))
+	(cat:? sf (cat:cmbn 2 4 3))
+	(cat:? sd (cat:cmbn 0 3 :s-bsgn))
+	(cat:? sd (cat:cmbn 2 4 3))
+	(cat:? sd (cat:cmbn 3 4 7))))
+
+
+(test suspension3
+      (cat:cat-init)
+      (let* ((rdct (cat:ez (cat:deltab) (cat:deltab)))
+	     (srdct (cat:suspension rdct)))
+	(cat:pre-check-rdct srdct)
+	(setf cat:*tc* (cat:cmbn 4 1 (cat:crpr 0 15 0 15)))
+	(setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 0 1 3 15)
+				 5 (cat:tnpr 1 3 2 7)
+				 10 (cat:tnpr 2 7 1 3)
+				 100 (cat:tnpr 3 15 0 1)))
+	(check-rdct)))
+
+
+(test suspension4
+      (cat:cat-init)
+      (let ((sk (cat:suspension (cat:k-z 2))))
+	(cat:homology sk 0 10)))