Extracted Whitehead tests.

kenzo-test.asd

@@ -41,4 +41,5 @@
 	       (:file "suspensions-test")
 	       (:file "tensor-products-test")
 	       (:file "various-test")
+	       (:file "whitehead-test")
 	       ))

package.lisp

@@ -410,6 +410,7 @@
 	   ;; simplicial-mrphs.lisp
 
 	   BUILD-SMMR
+	   TW-A-SINTR3
 
 	   ;; simplicial-sets.lisp
 
@@ -483,7 +484,9 @@
 	   ;; whitehead.lisp
 
 	   Z-WHITEHEAD
+	   Z-WHITEHEAD-SINTR
 	   Z2-WHITEHEAD
+	   Z2-WHITEHEAD-SINTR
 
 	   ))
 

src/whitehead.lisp

@@ -35,51 +35,6 @@
 			       (gmsm-cocycle face n dmns gmsm chml-clss)))))
     (the sintr #'rslt)))
 
-#|
-(cat-init)
-(setf k (k-z 2))
-(setf ecc (echcm k))
-(setf chml-clss
-      (build-mrph
-        :sorc ecc :trgt (z-chcm) :degr 2
-	:intr #'(lambda (degr gnrt)
-		  (if (= degr 2)
-		      (term-cmbn 0 1 :z-gnrt)
-		    (zero-cmbn (- degr 2))))
-	:strt :gnrt :orgn '(fundamental-class k-z-2)))
-(setf tw (z-wwhitehead-sintr k 2 chml-clss))
-(a-sintr3 tw 1 (absm 1 +null-gbar+))  ;;; cf old-macro cancelled
-(a-sintr3 tw 2 (absm 3 +null-gbar+))  ;;; in macros.cl
-(funcall tw 2 (gbar 2 0 '(55) 0 '()))
-(funcall tw 3 (gbar 3 0 '(12 23)
-                      0 '(34)
-                      0 '()))
-(funcall tw 4 (gbar 4 0 '(12 23 34)
-                      2 '(45)
-                      0 '(56)
-                      0 '()))
-(setf k (k-z 3))
-(setf ecc (echcm k))
-(setf chml-clss
-      (build-mrph
-        :sorc ecc :trgt (z-chcm) :degr 3
-	:intr #'(lambda (degr gnrt)
-		  (if (= degr 3)
-		      (term-cmbn 0 -1 :z-gnrt)
-		    (zero-cmbn (- degr 3))))
-	:strt :gnrt :orgn '(fundamental-class k-z-3)))
-(setf tw (z-wwhitehead-sintr k 3 chml-clss))
-(a-sintr3 tw 1 (absm 1 +null-gbar+))
-(a-sintr3 tw 2 (absm 3 +null-gbar+))
-(a-sintr3 tw 3 (absm 7 +null-gbar+))
-(funcall tw 3 (z-fundamental-gmsm 3 55))
-(equal (funcall tw 3 (z-fundamental-gmsm 3 55))
-       (absm 0 (z-fundamental-gmsm 3 55)))
-(funcall tw 4 (gbar 4 0 (gbar 3 0 '(12 23) 0 '(34) 0 '())
-                      0 (gbar 2 0 '(45) 0 '())
-                      1 (gbar 0)
-                      0 (gbar 0)))
-|#
 
 (DEFUN Z-WHITEHEAD-SINTR (smst n chml-clss
 			  &aux (face (face smst))
@@ -106,51 +61,6 @@
 				    (gmsm-cocycle face n dmns gmsm chml-clss)))))
     (the sintr #'rslt)))
 
-#|
-(cat-init)
-(setf k (k-z 2))
-(setf ecc (echcm k))
-(setf chml-clss
-      (build-mrph
-        :sorc ecc :trgt (z-chcm) :degr 2
-	:intr #'(lambda (degr gnrt)
-		  (if (= degr 2)
-		      (term-cmbn 0 1 :z-gnrt)
-		    (zero-cmbn (- degr 2))))
-	:strt :gnrt :orgn '(fundamental-class k-z-2)))
-(setf tw (z-whitehead-sintr k 2 chml-clss))
-(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) '())
-(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) '())
-(funcall tw 2 (gbar 2 0 '(55) 0 '()))
-(funcall tw 3 (gbar 3 0 '(12 23)
-                      0 '(34)
-                      0 '()))
-(funcall tw 4 (gbar 4 0 '(12 23 34)
-                      2 '(45)
-                      0 '(56)
-                      0 '()))
-(setf k (k-z 3))
-(setf ecc (echcm k))
-(setf chml-clss
-      (build-mrph
-        :sorc ecc :trgt (z-chcm) :degr 3
-	:intr #'(lambda (degr gnrt)
-		  (if (= degr 3)
-		      (term-cmbn 0 -1 :z-gnrt)
-		    (zero-cmbn (- degr 3))))
-	:strt :gnrt :orgn '(fundamental-class k-z-3)))
-(setf tw (z-whitehead-sintr k 3 chml-clss))
-(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) +null-gbar+)
-(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) +null-gbar+)
-(tw-a-sintr3 tw 3 (absm 7 +null-gbar+) +null-gbar+)
-(funcall tw 3 (z-fundamental-gmsm 3 55))
-(equal (funcall tw 3 (z-fundamental-gmsm 3 55))
-       (absm 0 (z-fundamental-gmsm 2 55)))
-(funcall tw 4 (gbar 4 0 (gbar 3 0 '(12 23) 0 '(34) 0 '())
-                      0 (gbar 2 0 '(45) 0 '())
-                      1 (gbar 0)
-                      0 (gbar 0)))
-|#
 
 (DEFUN Z-WHITEHEAD (smst chml-clss &aux (n (- (degr chml-clss))))
   (declare
@@ -192,51 +102,6 @@
 				(gmsm-cocycle face n dmns gmsm chml-clss)))))
     (the sintr #'rslt)))
 
-#|
-(cat-init)
-(setf k (k-z2 2))
-(setf ecc (echcm k))
-(setf chml-clss
-      (build-mrph
-        :sorc ecc :trgt (z-chcm) :degr 2
-	:intr #'(lambda (degr gnrt)
-		  (if (= degr 2)
-		      (term-cmbn 0 1 :z-gnrt)
-		    (zero-cmbn (- degr 2))))
-	:strt :gnrt :orgn '(fundamental-class k-z-2)))
-(setf tw (Z2-wwhitehead-sintr k 2 chml-clss))
-(a-sintr3 tw 1 (absm 1 +null-gbar+))
-(a-sintr3 tw 2 (absm 3 +null-gbar+))
-(funcall tw 2 (gbar 2 0 1 0 0))
-(funcall tw 3 (gbar 3 0 2
-                      0 1
-                      0 0))
-(funcall tw 4 (gbar 4 0 3
-                      2 1
-                      0 1
-                      0 0))
-(setf k (k-z2 3))
-(setf ecc (echcm k))
-(setf chml-clss
-      (build-mrph
-        :sorc ecc :trgt (z-chcm) :degr 3
-	:intr #'(lambda (degr gnrt)
-		  (if (= degr 3)
-		      (term-cmbn 0 -1 :z-gnrt)
-		    (zero-cmbn (- degr 3))))
-	:strt :gnrt :orgn '(fundamental-class k-z-3)))
-(setf tw (Z2-wwhitehead-sintr k 3 chml-clss))
-(a-sintr3 tw 1 (absm 1 +null-gbar+))
-(a-sintr3 tw 2 (absm 3 +null-gbar+))
-(a-sintr3 tw 3 (absm 7 +null-gbar+))
-(funcall tw 3 (Z2-fundamental-gmsm 3 1))
-(equal (funcall tw 3 (Z2-fundamental-gmsm 3 1))
-       (absm 0 (Z2-fundamental-gmsm 3 1)))
-(funcall tw 4 (gbar 4 0 (gbar 3 0 2 0 1 0 0)
-                      0 (gbar 2 0 1 0 0)
-                      1 (gbar 0)
-                      0 (gbar 0)))
-|#
 
 (DEFUN Z2-WHITEHEAD-SINTR (smst n chml-clss
 			   &aux (face (face smst))
@@ -260,54 +125,10 @@
 	   (if (< dmns n)
 	       (absm (mask (1- dmns)) idnt)
 	       (z2-cocycle-gbar-head n dmns
-		(gmsm-cocycle face n dmns gmsm chml-clss)))))     
+				     (gmsm-cocycle face n dmns gmsm
+						   chml-clss)))))
     (the sintr #'rslt)))
 
-#|
-(cat-init)
-(setf k (k-z2 2))
-(setf ecc (echcm k))
-(setf chml-clss
-      (build-mrph
-        :sorc ecc :trgt (z-chcm) :degr 2
-	:intr #'(lambda (degr gnrt)
-		  (if (= degr 2)
-		      (term-cmbn 0 1 :z-gnrt)
-		    (zero-cmbn (- degr 2))))
-	:strt :gnrt :orgn '(fundamental-class k-z-2)))
-(setf tw (Z2-whitehead-sintr k 2 chml-clss))
-(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) 0)
-(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) 0)
-(funcall tw 2 (gbar 2 0 1 0 '()))
-(funcall tw 3 (gbar 3 0 2
-                      0 1
-                      0 0))
-(funcall tw 4 (gbar 4 0 3
-                      2 1
-                      0 1
-                      0 0))
-(setf k (k-z2 3))
-(setf ecc (echcm k))
-(setf chml-clss
-      (build-mrph
-        :sorc ecc :trgt (z-chcm) :degr 3
-	:intr #'(lambda (degr gnrt)
-		  (if (= degr 3)
-		      (term-cmbn 0 -1 :z-gnrt)
-		    (zero-cmbn (- degr 3))))
-	:strt :gnrt :orgn '(fundamental-class k-z-3)))
-(setf tw (Z2-whitehead-sintr k 3 chml-clss))
-(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) 0)
-(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) 0)
-(tw-a-sintr3 tw 3 (absm 7 +null-gbar+) 0)
-(funcall tw 3 (Z2-fundamental-gmsm 3 1))
-(equal (funcall tw 3 (Z2-fundamental-gmsm 3 1))
-       (absm 0 (Z2-fundamental-gmsm 2 1)))
-(funcall tw 4 (gbar 4 0 (gbar 3 0 2 0 1 0 0)
-                      0 (gbar 2 0 1 0 0)
-                      1 (gbar 0)
-                      0 (gbar 0)))
-|#
 
 (DEFUN Z2-WHITEHEAD (smst chml-clss &aux (n (- (degr chml-clss))))
   (declare
@@ -319,20 +140,3 @@
 	:sorc smst :trgt (k-z2 (1- n)) :degr -1
 	:sintr (Z2-whitehead-sintr smst n chml-clss)
 	:orgn `(Z2-whitehead ,smst))))
-
-#|
-(setf m (moore 2 4))
-(setf chml-clss
-      (build-mrph
-         :sorc m :trgt (z-chcm) :degr -4
-         :intr #'(lambda (dmns gmsm)
-                    (if (= 4 dmns)
-                       (cmbn 0 1 :z-gnrt)
-                       (zero-cmbn (- dmns 4))))
-         :strt :gnrt
-         :orgn '(chml-clss moore 2 4)))
-(setf mf (z2-whitehead m 4 chml-clss))
-(setf mt (fibration-total mf))
-(homology mt 0 10)
-|#
-         

test/whitehead-test.lisp

@@ -0,0 +1,108 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+
+(test z-whitehead-sintr
+      (cat:cat-init)
+      (let* ((k (cat:k-z 2))
+	     (ecc (cat:echcm k))
+	     (chml-clss
+	      (cat:build-mrph
+	       :sorc ecc :trgt (cat:z-chcm) :degr 2
+	       :intr #'(lambda (degr gnrt)
+			 (if (= degr 2)
+			     (cat:term-cmbn 0 1 :z-gnrt)
+			     (cat:zero-cmbn (- degr 2))))
+	       :strt :gnrt :orgn '(fundamental-class k-z-2)))
+	     (tw (cat:z-whitehead-sintr k 2 chml-clss)))
+	(cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) '())
+	(cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) '())
+	(funcall tw 2 (cat:gbar 2 0 '(55) 0 '()))
+	(funcall tw 3 (cat:gbar 3 0 '(12 23) 0 '(34) 0 '()))
+	(funcall tw 4 (cat:gbar 4 0 '(12 23 34) 2 '(45) 0 '(56) 0 '()))
+	(setf k (cat:k-z 3))
+	(setf ecc (cat:echcm k))
+	(setf chml-clss
+	      (cat:build-mrph
+	       :sorc ecc :trgt (cat:z-chcm) :degr 3
+	       :intr #'(lambda (degr gnrt)
+			 (if (= degr 3)
+			     (cat:term-cmbn 0 -1 :z-gnrt)
+			     (cat:zero-cmbn (- degr 3))))
+	       :strt :gnrt :orgn '(fundamental-class k-z-3)))
+	(setf tw (cat:z-whitehead-sintr k 3 chml-clss))
+	(cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) cat:+null-gbar+)
+	(cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) cat:+null-gbar+)
+	(cat:tw-a-sintr3 tw 3 (cat:absm 7 cat:+null-gbar+) cat:+null-gbar+)
+	(funcall tw 3 (cat:z-fundamental-gmsm 3 55))
+	(is (equalp (funcall tw 3 (cat:z-fundamental-gmsm 3 55))
+		    (cat:absm 0 (cat:z-fundamental-gmsm 2 55))))
+	(funcall tw 4 (cat:gbar 4 0 (cat:gbar 3 0 '(12 23) 0 '(34) 0 '())
+			    0 (cat:gbar 2 0 '(45) 0 '())
+			    1 (cat:gbar 0)
+			    0 (cat:gbar 0)))))
+
+
+(test Z2-whitehead-sintr
+      (cat:cat-init)
+      (let* ((k (cat:k-z2 2))
+	     (ecc (cat:echcm k))
+	     (chml-clss
+	      (cat:build-mrph
+	       :sorc ecc :trgt (cat:z-chcm) :degr 2
+	       :intr #'(lambda (degr gnrt)
+			 (if (= degr 2)
+			     (cat:term-cmbn 0 1 :z-gnrt)
+			     (cat:zero-cmbn (- degr 2))))
+	       :strt :gnrt :orgn '(fundamental-class k-z-2)))
+	     (tw (cat:Z2-whitehead-sintr k 2 chml-clss)))
+	(cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) 0)
+	(cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) 0)
+	(funcall tw 2 (cat:gbar 2 0 1 0 '()))
+	(funcall tw 3 (cat:gbar 3 0 2
+				0 1
+				0 0))
+	(funcall tw 4 (cat:gbar 4 0 3
+				2 1
+				0 1
+				0 0))
+	(setf k (cat:k-z2 3))
+	(setf ecc (cat:echcm k))
+	(setf chml-clss
+	      (cat:build-mrph
+	       :sorc ecc :trgt (cat:z-chcm) :degr 3
+	       :intr #'(lambda (degr gnrt)
+			 (if (= degr 3)
+			     (cat:term-cmbn 0 -1 :z-gnrt)
+			     (cat:zero-cmbn (- degr 3))))
+	       :strt :gnrt :orgn '(fundamental-class k-z-3)))
+	(setf tw (cat:Z2-whitehead-sintr k 3 chml-clss))
+	(cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) 0)
+	(cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) 0)
+	(cat:tw-a-sintr3 tw 3 (cat:absm 7 cat:+null-gbar+) 0)
+	(funcall tw 3 (cat:Z2-fundamental-gmsm 3 1))
+	(is (equalp (funcall tw 3 (cat:Z2-fundamental-gmsm 3 1))
+	       (cat:absm 0 (cat:Z2-fundamental-gmsm 2 1))))
+	(funcall tw 4 (cat:gbar 4 0 (cat:gbar 3 0 2 0 1 0 0)
+			    0 (cat:gbar 2 0 1 0 0)
+			    1 (cat:gbar 0)
+			    0 (cat:gbar 0)))))
+
+
+(test Z2-whitehead
+      (cat:cat-init)
+      (let* ((m (cat:moore 2 4))
+	     (chml-clss
+	      (cat:build-mrph
+	       :sorc m :trgt (cat:z-chcm) :degr -4
+	       :intr #'(lambda (dmns gmsm)
+			 (if (= 4 dmns)
+			     (cat:cmbn 0 1 :z-gnrt)
+			     (cat:zero-cmbn (- dmns 4))))
+	       :strt :gnrt
+	       :orgn '(chml-clss moore 2 4)))
+	     (mf (cat:z2-whitehead m chml-clss))
+	     (mt (cat:fibration-total mf)))
+	(cat:homology mt 0 10)))