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

@@ -11,328 +11,132 @@
 ;;;
 
 (DEFUN Z-WWHITEHEAD-SINTR (smst n chml-clss
-				&aux (face (face smst))
+			   &aux (face (face smst))
-				     (k-z-n (k-z n))
+			     (k-z-n (k-z n))
-				     (idnt (bspn k-z-n))
+			     (idnt (bspn k-z-n))
-				     (efhm (efhm smst)))
+			     (efhm (efhm smst)))
-   (declare
+  (declare
-      (type simplicial-set smst)
+   (type simplicial-set smst)
-      (fixnum n)
+   (fixnum n)
-      (type morphism chml-clss)
+   (type morphism chml-clss)
-      (type face face)
+   (type face face)
-      (type ab-simplicial-group k-z-n)
+   (type ab-simplicial-group k-z-n)
-      (type gmsm idnt)
+   (type gmsm idnt)
-      (type homotopy-equivalence efhm))
+   (type homotopy-equivalence efhm))
-   (setf chml-clss
+  (setf chml-clss
-	 (i-cmps chml-clss (rf efhm) (lg efhm)))
+	(i-cmps chml-clss (rf efhm) (lg efhm)))
-   (flet ((rslt (dmns gmsm)
+  (flet ((rslt (dmns gmsm)
-	    (declare
+	   (declare
-	      (fixnum dmns)
+	    (fixnum dmns)
-	      (type gmsm gmsm))
+	    (type gmsm gmsm))
-	    (if (< dmns n)
+	   (if (< dmns n)
-	        (absm (mask dmns) idnt)
+	       (absm (mask dmns) idnt)
-	      (z-cocycle-gbar n dmns
+	       (z-cocycle-gbar n dmns
-		(gmsm-cocycle face n dmns gmsm chml-clss)))))
+			       (gmsm-cocycle face n dmns gmsm chml-clss)))))
-     (the sintr #'rslt)))
+    (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))
+			  &aux (face (face smst))
-				     (k-z-n-1 (k-z (1- n)))
+			    (k-z-n-1 (k-z (1- n)))
-				     (idnt (bspn k-z-n-1))
+			    (idnt (bspn k-z-n-1))
-				     (efhm (efhm smst)))
+			    (efhm (efhm smst)))
-   (declare
+  (declare
-      (type simplicial-set smst)
+   (type simplicial-set smst)
-      (fixnum n)
+   (fixnum n)
-      (type morphism chml-clss)
+   (type morphism chml-clss)
-      (type face face)
+   (type face face)
-      (type ab-simplicial-group k-z-n-1)
+   (type ab-simplicial-group k-z-n-1)
-      (type gmsm idnt)
+   (type gmsm idnt)
-      (type homotopy-equivalence efhm))
+   (type homotopy-equivalence efhm))
-   (setf chml-clss
+  (setf chml-clss
-	 (i-cmps chml-clss (rf efhm) (lg efhm)))
+	(i-cmps chml-clss (rf efhm) (lg efhm)))
-   (flet ((rslt (dmns gmsm)
+  (flet ((rslt (dmns gmsm)
-	    (declare
+	   (declare
-	      (fixnum dmns)
+	    (fixnum dmns)
-	      (type gmsm gmsm))
+	    (type gmsm gmsm))
-	    (if (< dmns n)
+	   (if (< dmns n)
-	        (absm (mask (1- dmns)) idnt)
+	       (absm (mask (1- dmns)) idnt)
-	      (z-cocycle-gbar-head n dmns
+	       (z-cocycle-gbar-head n dmns
-		(gmsm-cocycle face n dmns gmsm chml-clss)))))
+				    (gmsm-cocycle face n dmns gmsm chml-clss)))))
-     (the sintr #'rslt)))
+    (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
+  (declare
-      (type simplicial-set smst)
+   (type simplicial-set smst)
-      (fixnum n)
+   (fixnum n)
-      (type morphism chml-clss))
+   (type morphism chml-clss))
-   (the fibration
+  (the fibration
-      (build-smmr
+       (build-smmr
-         :sorc smst :trgt (k-z (1- n)) :degr -1
+	:sorc smst :trgt (k-z (1- n)) :degr -1
-         :sintr (z-whitehead-sintr smst n chml-clss)
+	:sintr (z-whitehead-sintr smst n chml-clss)
-         :orgn `(z-whitehead ,smst))))
+	:orgn `(z-whitehead ,smst))))
 
 ;;;
 ;;; Z/2Z
 ;;;
 
 (DEFUN Z2-WWHITEHEAD-SINTR (smst n chml-clss
-				&aux (face (face smst))
+			    &aux (face (face smst))
-				     (k-z2-n (k-z2 n))
+			      (k-z2-n (k-z2 n))
-				     (idnt (bspn k-z2-n))
+			      (idnt (bspn k-z2-n))
-				     (efhm (efhm smst)))
+			      (efhm (efhm smst)))
-   (declare
+  (declare
-      (type simplicial-set smst)
+   (type simplicial-set smst)
-      (fixnum n)
+   (fixnum n)
-      (type morphism chml-clss)
+   (type morphism chml-clss)
-      (type face face)
+   (type face face)
-      (type ab-simplicial-group k-z2-n)
+   (type ab-simplicial-group k-z2-n)
-      (type gmsm idnt)
+   (type gmsm idnt)
-      (type homotopy-equivalence efhm))
+   (type homotopy-equivalence efhm))
-   (setf chml-clss
+  (setf chml-clss
-	 (i-cmps chml-clss (rf efhm) (lg efhm)))
+	(i-cmps chml-clss (rf efhm) (lg efhm)))
-   (flet ((rslt (dmns gmsm)
+  (flet ((rslt (dmns gmsm)
-	    (declare
+	   (declare
-	      (fixnum dmns)
+	    (fixnum dmns)
-	      (type gmsm gmsm))
+	    (type gmsm gmsm))
-	    (if (< dmns n)
+	   (if (< dmns n)
-	        (absm (mask dmns) idnt)
+	       (absm (mask dmns) idnt)
-	      (z2-cocycle-gbar n dmns
+	       (z2-cocycle-gbar n dmns
-		(gmsm-cocycle face n dmns gmsm chml-clss)))))
+				(gmsm-cocycle face n dmns gmsm chml-clss)))))
-     (the sintr #'rslt)))
+    (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))
+			   &aux (face (face smst))
-				     (k-z2-n-1 (k-z2 (1- n)))
+			     (k-z2-n-1 (k-z2 (1- n)))
-				     (idnt (bspn k-z2-n-1))
+			     (idnt (bspn k-z2-n-1))
-				     (efhm (efhm smst)))
+			     (efhm (efhm smst)))
-   (declare
+  (declare
-      (type simplicial-set smst)
+   (type simplicial-set smst)
-      (fixnum n)
+   (fixnum n)
-      (type morphism chml-clss)
+   (type morphism chml-clss)
-      (type face face)
+   (type face face)
-      (type ab-simplicial-group k-z2-n-1)
+   (type ab-simplicial-group k-z2-n-1)
-      (type gmsm idnt)
+   (type gmsm idnt)
-      (type homotopy-equivalence efhm))
+   (type homotopy-equivalence efhm))
-   (setf chml-clss
+  (setf chml-clss
-	 (i-cmps chml-clss (rf efhm) (lg efhm)))
+	(i-cmps chml-clss (rf efhm) (lg efhm)))
-   (flet ((rslt (dmns gmsm)
+  (flet ((rslt (dmns gmsm)
-	    (declare
+	   (declare
-	      (fixnum dmns)
+	    (fixnum dmns)
-	      (type gmsm gmsm))
+	    (type gmsm gmsm))
-	    (if (< dmns n)
+	   (if (< dmns n)
-	        (absm (mask (1- dmns)) idnt)
+	       (absm (mask (1- dmns)) idnt)
-	      (z2-cocycle-gbar-head n dmns
+	       (z2-cocycle-gbar-head n dmns
-		(gmsm-cocycle face n dmns gmsm chml-clss)))))     
+				     (gmsm-cocycle face n dmns gmsm
-     (the sintr #'rslt)))
+						   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
+  (declare
-      (type simplicial-set smst)
+   (type simplicial-set smst)
-      (fixnum n)
+   (fixnum n)
-      (type morphism chml-clss))
+   (type morphism chml-clss))
-   (the fibration
+  (the fibration
-      (build-smmr
+       (build-smmr
-         :sorc smst :trgt (k-z2 (1- n)) :degr -1
+	:sorc smst :trgt (k-z2 (1- n)) :degr -1
-         :sintr (Z2-whitehead-sintr smst n chml-clss)
+	:sintr (Z2-whitehead-sintr smst n chml-clss)
-         :orgn `(Z2-whitehead ,smst))))
+	: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)))