From 89975ca8fa1cbf670d062ecb24e62f20de26422b Mon Sep 17 00:00:00 2001
From: Gerd Heber <gheber@hdfgroup.org>
Date: Fri, 10 Jul 2015 06:58:06 -0500
Subject: [PATCH] First cl-space-efhm test extracted. This part seems to be
 affected by the ICMBN-P issues.

---
 kenzo-test.asd               |    3 +-
 package.lisp                 |    6 +
 src/cl-space-efhm.lisp       | 1380 +++++++++++++++++-----------------
 test/bar-test.lisp           |   22 +-
 test/cl-space-efhm-test.lisp |   56 ++
 test/common.lisp             |   16 +
 6 files changed, 756 insertions(+), 727 deletions(-)
 create mode 100644 test/cl-space-efhm-test.lisp

diff --git a/kenzo-test.asd b/kenzo-test.asd
index 65fa90e..1ff5fdd 100644
--- a/kenzo-test.asd
+++ b/kenzo-test.asd
@@ -23,4 +23,5 @@
 	       (:file "delta-test")
 	       (:file "bar-test")
 	       (:file "cartesian-products-test")
-	       (:file "cones-test")))
+	       (:file "cones-test")
+	       (:file "cl-space-efhm-test")))
diff --git a/package.lisp b/package.lisp
index fb815e9..3f6b784 100644
--- a/package.lisp
+++ b/package.lisp
@@ -86,6 +86,10 @@
 	   Z-CHCM
 	   ZERO-MRPH
 
+	   ;; cl-space-efhm.lisp
+
+	   CS-HAT-U-T
+
 	   ;; classes.lisp
 
 	   ABSM
@@ -101,6 +105,7 @@
 	   F
 	   FACE
 	   G
+	   GBAR
 	   GMSM
 	   H
 	   HOMOTOPY-EQUIVALENCE
@@ -114,6 +119,7 @@
 	   REDUCTION
 	   RRDCT
 	   TCC
+	   TNPR
 
 	   ;; combinations.lisp
 
diff --git a/src/cl-space-efhm.lisp b/src/cl-space-efhm.lisp
index f223f8b..f942c25 100644
--- a/src/cl-space-efhm.lisp
+++ b/src/cl-space-efhm.lisp
@@ -7,62 +7,83 @@
 (provide "cl-space-efhm")
 
 (DEFUN CS-HAT-U-U (smgr
-		     &aux (bar (bar smgr))
-		          (cl-space (classifying-space smgr))
-			  (clsp-tnsr-smgr (tnsr-prdc cl-space smgr)))
+		   &aux (bar (bar smgr))
+		     (cl-space (classifying-space smgr))
+		     (clsp-tnsr-smgr (tnsr-prdc cl-space smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type chain-complex bar clsp-tnsr-smgr)
-    (type simplicial-set cl-space))
+   (type simplicial-group smgr)
+   (type chain-complex bar clsp-tnsr-smgr)
+   (type simplicial-set cl-space))
   (the chain-complex
-     (tnsr-prdc clsp-tnsr-smgr bar)))
+       (tnsr-prdc clsp-tnsr-smgr bar)))
 
 (DEFUN CS-HAT-RIGHT-PERTURBATION-INTR (smgr)
   (declare (type simplicial-group smgr))
   (let ((aprd (aprd smgr)))
     (flet ((rslt (degr tnpr)
 	     (declare
-	       (fixnum degr)
-	       (type tnpr tnpr))
+	      (fixnum degr)
+	      (type tnpr tnpr))
 	     (with-tnpr (degr1 tnpr1 degr2 abar2) tnpr
-	       (when (zerop degr2)
-		 (return-from rslt (zero-cmbn (1- degr))))
-	       (with-tnpr (degr11 gbar11 degr12 gmsm12) tnpr1
-		 (let ((sign (-1-expt-n degr1))
-		       (brgn21 (first (abar-list abar2)))
-		       (bar22 (make-abar :list (rest (abar-list abar2)))))
-		   (declare
-		     (fixnum sign)
-		     (type brgn brgn21)
-		     (type abar bar22))
-		   (with-brgn (degr21 gmsm21) brgn21
-		   (let ((degr22 (- degr2 degr21)))
-		     (declare (fixnum degr22))
-		     (decf degr21) ;; = dmns(gmsm21)
-		     (let ((aprd (gnrt-? aprd (+ degr12 degr21)
-					 (tnpr degr12 gmsm12 degr21 gmsm21))))
-		       (declare (type cmbn aprd))
-		       (with-cmbn (degr12+21 list) aprd
-			 (make-cmbn :degr (1- degr)
-			   :list
-			   (mapcar
-			     #'(lambda (term)
-				 (declare (type term term))
-				 (with-term (cffc gmsm) term
-				   (term (* sign cffc)
-					 (tnpr (+ degr1 degr21)
-					       (tnpr degr11 gbar11 degr12+21 gmsm)
-					       degr22 bar22))))
-			     list)))))))))))
-	  (the intr-mrph #'rslt))))
+			(when (zerop degr2)
+			  (return-from rslt (zero-cmbn (1- degr))))
+			(with-tnpr (degr11 gbar11 degr12 gmsm12) tnpr1
+				   (let ((sign (-1-expt-n degr1))
+					 (brgn21 (first (abar-list abar2)))
+					 (bar22 (make-abar
+						 :list (rest (abar-list
+							      abar2)))))
+				     (declare
+				      (fixnum sign)
+				      (type brgn brgn21)
+				      (type abar bar22))
+				     (with-brgn (degr21 gmsm21) brgn21
+						(let ((degr22 (- degr2 degr21)))
+						  (declare (fixnum degr22))
+						  (decf degr21) ;; = dmns(gmsm21)
+						  (let ((aprd
+							 (gnrt-? aprd
+								 (+ degr12
+								    degr21)
+								 (tnpr degr12
+								       gmsm12
+								       degr21
+								       gmsm21))))
+						    (declare (type cmbn aprd))
+						    (with-cmbn (degr12+21 list)
+						      aprd
+						      (make-cmbn
+						       :degr (1- degr)
+						       :list
+						       (mapcar
+							#'(lambda (term)
+							    (declare
+							     (type term term))
+							    (with-term
+								(cffc gmsm) term
+								(term (* sign
+									 cffc)
+								      (tnpr
+								       (+ degr1
+									  degr21)
+								       (tnpr
+									degr11
+									gbar11
+									degr12+21
+									gmsm)
+								       degr22
+								       bar22))))
+							list)))))))))))
+      (the intr-mrph #'rslt))))
+
 
 (DEFUN CS-HAT-RIGHT-PERTURBATION (smgr
-				    &aux (hat-u-u (cs-hat-u-u smgr)))
+				  &aux (hat-u-u (cs-hat-u-u smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type chain-complex hat-u-u))
+   (type simplicial-group smgr)
+   (type chain-complex hat-u-u))
   (the morphism
-     (build-mrph
+       (build-mrph
         :sorc hat-u-u
 	:trgt hat-u-u
 	:degr -1
@@ -70,787 +91,732 @@
 	:strt :gnrt
 	:orgn `(cs-hat-right-perturbation ,smgr))))
 
-(DEFUN CS-HAT-U-T (smgr
-		     &aux (hat-u-u (cs-hat-u-u smgr))
-		          (hat-right-perturbation
-			    (cs-hat-right-perturbation smgr)))
-  (declare
-    (type simplicial-group smgr)
-    (type chain-complex hat-u-u)
-    (type morphism hat-right-perturbation))
-  (the chain-complex
-    (progn
-      (setf (slot-value hat-right-perturbation 'sorc) hat-u-u
-	    (slot-value hat-right-perturbation 'trgt) hat-u-u)
-      ;; cf lp-space-efhm.lisp
-      (add hat-u-u hat-right-perturbation))))
 
-#|
-  (cat-init)
-  (setf c (cs-hat-u-t (k-z-1)))
-  (defun random-abar (tot-degr~ max-degr)
-    (do ((rslt nil)
-         (cum-degr 0 (+ cum-degr degr 1))
-         (degr))
-        ((>= cum-degr tot-degr~) (make-abar :list rslt))
-       (setf degr (1+ (random max-degr)))
-       (push (brgn (1+ degr)
-                   (let ((list (make-list degr)))
-                     (mapl
-                       #'(lambda (sublist)
-                           (setf (car sublist) (- (random 21) 10)))
-                       list)
-                     list))
-             rslt)))
-  (dotimes (i 5) (print (random-abar 8 4)))
-  (setf abar (random-abar 8 4))
-  (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-  (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
-                   abar-degr abar))
-  (? c (+ 5 abar-degr) gnrt)
-  (? c *)
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 10)
-         (print (? c (+ 5 abar-degr) gnrt))
-         (print (? c (? c (+ 5 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
-                       abar-degr abar))
-      (unless (>= abar-degr 9)
-         (print (? c (+ 6 abar-degr) gnrt))
-         (print (? c (? c (+ 6 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
-	   	     abar-degr abar))
-      (unless (>= abar-degr 10)
-        (print (? c (+ 5 abar-degr) gnrt))
-        (print (? c (? c (+ 5 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 11)
-         (print (? c (+ 4 abar-degr) gnrt))
-         (print (? c (? c (+ 4 abar-degr) gnrt))))))
-|#
+(DEFUN CS-HAT-U-T (smgr
+		   &aux (hat-u-u (cs-hat-u-u smgr))
+		     (hat-right-perturbation
+		      (cs-hat-right-perturbation smgr)))
+  (declare
+   (type simplicial-group smgr)
+   (type chain-complex hat-u-u)
+   (type morphism hat-right-perturbation))
+  (the chain-complex
+       (progn
+	 (setf (slot-value hat-right-perturbation 'sorc) hat-u-u
+	       (slot-value hat-right-perturbation 'trgt) hat-u-u)
+	 ;; cf lp-space-efhm.lisp
+	 (add hat-u-u hat-right-perturbation))))
+
 
 (DEFUN CS-HAT-LEFT-PERTURBATION (smgr
-			       &aux (fibration (smgr-fibration smgr))
-			            (bar (bar smgr))
-			            (hat-u-t (cs-hat-u-t smgr)))
+				 &aux (fibration (smgr-fibration smgr))
+				   (bar (bar smgr))
+				   (hat-u-t (cs-hat-u-t smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type fibration fibration)
-    (type chain-complex bar hat-u-t))
+   (type simplicial-group smgr)
+   (type fibration fibration)
+   (type chain-complex bar hat-u-t))
   (the morphism
-    (multiple-value-bind (brown bottom-perturbation)
-			 (brown-reduction fibration)
-      (declare
-        (ignore brown)
-	(type morphism bottom-perturbation))
-      (let ((rslt (tnsr-prdc bottom-perturbation (idnt-mrph bar))))
-	(declare (type morphism rslt))
-	(setf (slot-value rslt 'sorc) hat-u-t
-	      (slot-value rslt 'trgt) hat-u-t)
-	rslt))))
+       (multiple-value-bind (brown bottom-perturbation)
+	   (brown-reduction fibration)
+	 (declare
+	  (ignore brown)
+	  (type morphism bottom-perturbation))
+	 (let ((rslt (tnsr-prdc bottom-perturbation (idnt-mrph bar))))
+	   (declare (type morphism rslt))
+	   (setf (slot-value rslt 'sorc) hat-u-t
+		 (slot-value rslt 'trgt) hat-u-t)
+	   rslt))))
+
 
 (DEFUN CS-HAT-T-U (smgr
-		    &aux (bar (bar smgr))
-		         (fibration (smgr-fibration smgr))
-		         (brown (brown-reduction fibration))
-		         (twisted-tnsr-prdc (bcc brown))
-		         (hat-u-u (cs-hat-u-u smgr)))
+		   &aux (bar (bar smgr))
+		     (fibration (smgr-fibration smgr))
+		     (brown (brown-reduction fibration))
+		     (twisted-tnsr-prdc (bcc brown))
+		     (hat-u-u (cs-hat-u-u smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type chain-complex bar twisted-tnsr-prdc hat-u-u)
-    (type fibration fibration)
-    (type reduction brown))
+   (type simplicial-group smgr)
+   (type chain-complex bar twisted-tnsr-prdc hat-u-u)
+   (type fibration fibration)
+   (type reduction brown))
   (the chain-complex
-    (let ((rslt (tnsr-prdc twisted-tnsr-prdc bar)))
-      (declare (type chain-complex rslt))
-      (setf (slot-value rslt 'grmd) hat-u-u)
-      rslt)))
+       (let ((rslt (tnsr-prdc twisted-tnsr-prdc bar)))
+	 (declare (type chain-complex rslt))
+	 (setf (slot-value rslt 'grmd) hat-u-u)
+	 rslt)))
 
 #|
-  (cat-init)
-  (setf c (cs-hat-t-u (k-z-1)))
-  (defun random-abar (tot-degr~ max-degr)
-    (do ((rslt nil)
-         (cum-degr 0 (+ cum-degr degr 1))
-         (degr))
-        ((>= cum-degr tot-degr~) (make-abar :list rslt))
-       (setf degr (1+ (random max-degr)))
-       (push (brgn (1+ degr)
-                   (let ((list (make-list degr)))
-                     (mapl
-                       #'(lambda (sublist)
-                           (setf (car sublist) (- (random 21) 10)))
-                       list)
-                     list))
-             rslt)))
-  (dotimes (i 5) (print (random-abar 8 4)))
-  (setf abar (random-abar 8 4))
-  (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-  (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
-                   abar-degr abar))
-  (? c (+ 5 abar-degr) gnrt)
-  (? c *)
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 10)
-         (print (? c (+ 5 abar-degr) gnrt))
-         (print (? c (? c (+ 5 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
-                       abar-degr abar))
-      (unless (>= abar-degr 9)
-         (print (? c (+ 6 abar-degr) gnrt))
-         (print (? c (? c (+ 6 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
+(cat-init)
+(setf c (cs-hat-t-u (k-z-1)))
+(defun random-abar (tot-degr~ max-degr)
+  (do ((rslt nil)
+       (cum-degr 0 (+ cum-degr degr 1))
+       (degr))
+      ((>= cum-degr tot-degr~) (make-abar :list rslt))
+    (setf degr (1+ (random max-degr)))
+    (push (brgn (1+ degr)
+		(let ((list (make-list degr)))
+		  (mapl
+		   #'(lambda (sublist)
+		       (setf (car sublist) (- (random 21) 10)))
+		   list)
+		  list))
+	  rslt)))
+(dotimes (i 5) (print (random-abar 8 4)))
+(setf abar (random-abar 8 4))
+(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
+		 abar-degr abar))
+(? c (+ 5 abar-degr) gnrt)
+(? c *)
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (unless (>= abar-degr 10)
+      (print (? c (+ 5 abar-degr) gnrt))
+      (print (? c (? c (+ 5 abar-degr) gnrt))))))
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
+		     abar-degr abar))
+    (unless (>= abar-degr 9)
+      (print (? c (+ 6 abar-degr) gnrt))
+      (print (? c (? c (+ 6 abar-degr) gnrt))))))
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
 	   	     abar-degr abar))
-      (unless (>= abar-degr 10)
-        (print (? c (+ 5 abar-degr) gnrt))
-        (print (? c (? c (+ 5 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 11)
-         (print (? c (+ 4 abar-degr) gnrt))
-         (print (? c (? c (+ 4 abar-degr) gnrt))))))
+    (unless (>= abar-degr 10)
+      (print (? c (+ 5 abar-degr) gnrt))
+      (print (? c (? c (+ 5 abar-degr) gnrt))))))
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (unless (>= abar-degr 11)
+      (print (? c (+ 4 abar-degr) gnrt))
+      (print (? c (? c (+ 4 abar-degr) gnrt))))))
 |#
 
 (DEFUN CS-LEFT-HMEQ-HAT (smgr
-			   &aux (hat-t-u (cs-hat-t-u smgr))
-			        (hat-right-perturbation
-				  (cs-hat-right-perturbation smgr)))
+			 &aux (hat-t-u (cs-hat-t-u smgr))
+			   (hat-right-perturbation
+			    (cs-hat-right-perturbation smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type chain-complex hat-t-u)
-    (type morphism hat-right-perturbation))
+   (type simplicial-group smgr)
+   (type chain-complex hat-t-u)
+   (type morphism hat-right-perturbation))
   (the chain-complex
-    (add hat-t-u hat-right-perturbation)))
+       (add hat-t-u hat-right-perturbation)))
 
 #|
-  (cat-init)
-  (setf c (cs-left-hmeq-hat (k-z-1)))
-  (defun random-abar (tot-degr~ max-degr)
-    (do ((rslt nil)
-         (cum-degr 0 (+ cum-degr degr 1))
-         (degr))
-        ((>= cum-degr tot-degr~) (make-abar :list rslt))
-       (setf degr (1+ (random max-degr)))
-       (push (brgn (1+ degr)
-                   (let ((list (make-list degr)))
-                     (mapl
-                       #'(lambda (sublist)
-                           (setf (car sublist) (- (random 21) 10)))
-                       list)
-                     list))
-             rslt)))
-   (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 10)
-         (print (? c (+ 5 abar-degr) gnrt))
-         (print (? c (? c (+ 5 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
-                       abar-degr abar))
-      (unless (>= abar-degr 9)
-         (print (? c (+ 6 abar-degr) gnrt))
-         (print (? c (? c (+ 6 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
+(cat-init)
+(setf c (cs-left-hmeq-hat (k-z-1)))
+(defun random-abar (tot-degr~ max-degr)
+  (do ((rslt nil)
+       (cum-degr 0 (+ cum-degr degr 1))
+       (degr))
+      ((>= cum-degr tot-degr~) (make-abar :list rslt))
+    (setf degr (1+ (random max-degr)))
+    (push (brgn (1+ degr)
+		(let ((list (make-list degr)))
+		  (mapl
+		   #'(lambda (sublist)
+		       (setf (car sublist) (- (random 21) 10)))
+		   list)
+		  list))
+	  rslt)))
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (unless (>= abar-degr 10)
+      (print (? c (+ 5 abar-degr) gnrt))
+      (print (? c (? c (+ 5 abar-degr) gnrt))))))
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
+		     abar-degr abar))
+    (unless (>= abar-degr 9)
+      (print (? c (+ 6 abar-degr) gnrt))
+      (print (? c (? c (+ 6 abar-degr) gnrt))))))
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
 	   	     abar-degr abar))
-      (unless (>= abar-degr 10)
-        (print (? c (+ 5 abar-degr) gnrt))
-        (print (? c (? c (+ 5 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 11)
-         (print (? c (+ 4 abar-degr) gnrt))
-         (print (? c (? c (+ 4 abar-degr) gnrt))))))
+    (unless (>= abar-degr 10)
+      (print (? c (+ 5 abar-degr) gnrt))
+      (print (? c (? c (+ 5 abar-degr) gnrt))))))
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (unless (>= abar-degr 11)
+      (print (? c (+ 4 abar-degr) gnrt))
+      (print (? c (? c (+ 4 abar-degr) gnrt))))))
 |#
 
 (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F (cmbn)
   (declare (type cmbn cmbn))
   (the cmbn
-    (with-cmbn (degr list) cmbn
-      (make-cmbn
-        :degr degr
-	:list (mapcar
-	        #'(lambda (term)
-		    (declare (type term term))
-		    (with-term (cffc tnpr) term
-		      (term cffc (gnrt1 (gnrt1 tnpr)))))		    
-	        (member-if	       
-		  #'(lambda (term)
-		      (declare (type term term))
-		      (with-term (cffc tnpr) term
-			(declare (ignore cffc))
-		      (with-tnpr (degr1 tnpr1 degr2 abar2) tnpr
-			(declare (ignore degr1 abar2))
-			(and (zerop degr2) (zerop (degr2 tnpr1))))))
-		  list))))))
+       (with-cmbn (degr list) cmbn
+		  (make-cmbn
+		   :degr degr
+		   :list (mapcar
+			  #'(lambda (term)
+			      (declare (type term term))
+			      (with-term (cffc tnpr) term
+					 (term cffc (gnrt1 (gnrt1 tnpr)))))		    
+			  (member-if	       
+			   #'(lambda (term)
+			       (declare (type term term))
+			       (with-term (cffc tnpr) term
+					  (declare (ignore cffc))
+					  (with-tnpr (degr1 tnpr1 degr2 abar2) tnpr
+						     (declare (ignore degr1 abar2))
+						     (and (zerop degr2) (zerop (degr2 tnpr1))))))
+			   list))))))
 
 #|
-  (cs-pre-left-hmeq-left-reduction-intr-f
-    (cmbn 6 100 (tnpr 4 (tnpr 2 'a 2 'b) 2 'c)
-            10  (tnpr 6 (tnpr 2 'a 4 'b) 0 'c)
-            50  (tnpr 6 (tnpr 6 'a 0 'b) 0 'c)
-            1   (tnpr 6 (tnpr 6 'aa 0 'b) 0 'c)))
+(cs-pre-left-hmeq-left-reduction-intr-f
+ (cmbn 6 100 (tnpr 4 (tnpr 2 'a 2 'b) 2 'c)
+       10  (tnpr 6 (tnpr 2 'a 4 'b) 0 'c)
+       50  (tnpr 6 (tnpr 6 'a 0 'b) 0 'c)
+       1   (tnpr 6 (tnpr 6 'aa 0 'b) 0 'c)))
 |#
 
 (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (smgr
-					   &aux (hat-u-t (cs-hat-u-t smgr))
-					        (classifying-space (classifying-space smgr)))
+					  &aux (hat-u-t (cs-hat-u-t smgr))
+					    (classifying-space (classifying-space smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type chain-complex hat-u-t)
-    (type simplicial-set classifying-space))
+   (type simplicial-group smgr)
+   (type chain-complex hat-u-t)
+   (type simplicial-set classifying-space))
   (the morphism
-    (build-mrph
-      :sorc hat-u-t
-      :trgt classifying-space
-      :degr 0
-      :intr #'cs-pre-left-hmeq-left-reduction-intr-f
-      :strt :cmbn
-      :orgn `(cs-pre-left-hmeq-left-reduction-f ,smgr))))
+       (build-mrph
+	:sorc hat-u-t
+	:trgt classifying-space
+	:degr 0
+	:intr #'cs-pre-left-hmeq-left-reduction-intr-f
+	:strt :cmbn
+	:orgn `(cs-pre-left-hmeq-left-reduction-f ,smgr))))
 
 (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-G (idnt)
   (declare (type gmsm idnt))
   (flet ((rslt (cmbn)
 	   (declare (type cmbn cmbn))
 	   (the cmbn
-	     (with-cmbn (degr list) cmbn
-	       (make-cmbn
-		 :degr degr
-		 :list (mapcar
-			 #'(lambda (term)
-			     (declare (type term term))
-			     (with-term (cffc gbar) term
-			       (term cffc
-				     (tnpr degr
-					   (tnpr degr gbar 0 idnt)
-					   0 +null-abar+))))
-			 list))))))
-     (the intr-mrph #'rslt)))
+		(with-cmbn (degr list) cmbn
+			   (make-cmbn
+			    :degr degr
+			    :list (mapcar
+				   #'(lambda (term)
+				       (declare (type term term))
+				       (with-term (cffc gbar) term
+						  (term cffc
+							(tnpr degr
+							      (tnpr degr gbar 0 idnt)
+							      0 +null-abar+))))
+				   list))))))
+    (the intr-mrph #'rslt)))
 
 #|
-  (setf g (cs-pre-left-hmeq-left-reduction-intr-g '()))
-  (funcall g (cmbn 3 14 (gbar 3 0 'a 1 'b 0 '())))
+(setf g (cs-pre-left-hmeq-left-reduction-intr-g '()))
+(funcall g (cmbn 3 14 (gbar 3 0 'a 1 'b 0 '())))
 |#
 
 (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-G (smgr
-					   &aux (hat-u-t (cs-hat-u-t smgr))
-					        (classifying-space (classifying-space smgr)))
+					  &aux (hat-u-t (cs-hat-u-t smgr))
+					    (classifying-space (classifying-space smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type chain-complex hat-u-t)
-    (type simplicial-set classifying-space))
+   (type simplicial-group smgr)
+   (type chain-complex hat-u-t)
+   (type simplicial-set classifying-space))
   (the morphism
-    (build-mrph
-      :sorc classifying-space
-      :trgt hat-u-t
-      :degr 0
-      :intr (cs-pre-left-hmeq-left-reduction-intr-g (bspn smgr))
-      :strt :cmbn
-      :orgn `(cs-pre-left-hmeq-left-reduction-g ,smgr))))
+       (build-mrph
+	:sorc classifying-space
+	:trgt hat-u-t
+	:degr 0
+	:intr (cs-pre-left-hmeq-left-reduction-intr-g (bspn smgr))
+	:strt :cmbn
+	:orgn `(cs-pre-left-hmeq-left-reduction-g ,smgr))))
 
 (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-H (cmpr idnt)
   (declare (type gmsm idnt))
   (flet ((rslt (cmbn)
 	   (declare (type cmbn cmbn))
 	   (the cmbn
-	     (with-cmbn (degr list) cmbn
-	       (do ((rslt (zero-cmbn (1+ degr)))
-		    (mark list (cdr mark)))
-		   ((endp mark) rslt)
-		   (declare
-		     (type cmbn rslt)
-		     (list mark))
-		  (let ((term (car mark)))
-		    (declare (type term term))
-		    (with-term (cffc tnpr) term
-		    (with-tnpr (degr1 tnpr1 degr2 abar2) tnpr
-		      (declare (ignore degr1))
-		    (with-tnpr (degr11 gbar11 degr12 gmsm12) tnpr1
-		      (unless (zerop degr12)
-			(dstr-add-term-to-cmbn
-			  cmpr
-			  (if (evenp degr11) cffc (- cffc))
-			  (tnpr degr11
-				(tnpr degr11 gbar11 0 idnt)
-				(+ 1 degr12 degr2)
-				(make-abar
-				 :list
-				 (cons (brgn (1+ degr12)
-					     gmsm12)
-				       (abar-list abar2))))
-			  rslt)))))))))))
-     (the intr-mrph #'rslt)))
+		(with-cmbn (degr list) cmbn
+			   (do ((rslt (zero-cmbn (1+ degr)))
+				(mark list (cdr mark)))
+			       ((endp mark) rslt)
+			     (declare
+			      (type cmbn rslt)
+			      (list mark))
+			     (let ((term (car mark)))
+			       (declare (type term term))
+			       (with-term (cffc tnpr) term
+					  (with-tnpr (degr1 tnpr1 degr2 abar2) tnpr
+						     (declare (ignore degr1))
+						     (with-tnpr (degr11 gbar11 degr12 gmsm12) tnpr1
+								(unless (zerop degr12)
+								  (dstr-add-term-to-cmbn
+								   cmpr
+								   (if (evenp degr11) cffc (- cffc))
+								   (tnpr degr11
+									 (tnpr degr11 gbar11 0 idnt)
+									 (+ 1 degr12 degr2)
+									 (make-abar
+									  :list
+									  (cons (brgn (1+ degr12)
+										      gmsm12)
+										(abar-list abar2))))
+								   rslt)))))))))))
+    (the intr-mrph #'rslt)))
 
 (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (smgr
-					   &aux (hat-u-t (cs-hat-u-t smgr)))
+					  &aux (hat-u-t (cs-hat-u-t smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type chain-complex hat-u-t))
+   (type simplicial-group smgr)
+   (type chain-complex hat-u-t))
   (the morphism
-    (build-mrph
-      :sorc hat-u-t
-      :trgt hat-u-t
-      :degr +1
-      :intr (cs-pre-left-hmeq-left-reduction-intr-h (cmpr hat-u-t) (bspn smgr))
-      :strt :cmbn
-      :orgn `(cs-pre-left-hmeq-left-reduction-h ,smgr))))
+       (build-mrph
+	:sorc hat-u-t
+	:trgt hat-u-t
+	:degr +1
+	:intr (cs-pre-left-hmeq-left-reduction-intr-h (cmpr hat-u-t) (bspn smgr))
+	:strt :cmbn
+	:orgn `(cs-pre-left-hmeq-left-reduction-h ,smgr))))
 
 
 
 (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION (smgr)
   (declare (type simplicial-group smgr))
   (the reduction
-    (build-rdct
-      :f (cs-pre-left-hmeq-left-reduction-f smgr)
-      :g (cs-pre-left-hmeq-left-reduction-g smgr)
-      :h (cs-pre-left-hmeq-left-reduction-h smgr)
-      :orgn `(cs-pre-left-hmeq-left-reduction ,smgr))))
+       (build-rdct
+	:f (cs-pre-left-hmeq-left-reduction-f smgr)
+	:g (cs-pre-left-hmeq-left-reduction-g smgr)
+	:h (cs-pre-left-hmeq-left-reduction-h smgr)
+	:orgn `(cs-pre-left-hmeq-left-reduction ,smgr))))
 
 #|
-  (cat-init)
-  (defun random-abar (tot-degr~ max-degr)
-    (do ((rslt nil)
-         (cum-degr 0 (+ cum-degr degr 1))
-         (degr))
-        ((>= cum-degr tot-degr~) (make-abar :list rslt))
-       (setf degr (1+ (random max-degr)))
-       (push (brgn (1+ degr)
-                   (let ((list (make-list degr)))
-                     (mapl
-                       #'(lambda (sublist)
-                           (setf (car sublist) (- (random 21) 10)))
-                       list)
-                     list))
-             rslt)))
-  (setf rdct (cs-pre-left-hmeq-left-reduction (k-z-1)))
-  (pre-check-rdct rdct)
-  (setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
-        *bc* (cmbn 0 1 +null-gbar+))
-  (check-rdct)
-  (setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
-  (check-rdct)
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (setf gbar (gbar 2 0 '(1) 0 '()))
-      (unless (>= abar-degr 9)
-        (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
-              *bc* (cmbn 2 1 gbar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 6 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
-                       abar-degr abar))
-      (setf gbar (gbar 3 0 '(1 2) 1 '() 0 '()))
-      (unless (>= abar-degr 8)
-        (setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
-              *bc* (cmbn 3 1 gbar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 6 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
+(cat-init)
+(defun random-abar (tot-degr~ max-degr)
+  (do ((rslt nil)
+       (cum-degr 0 (+ cum-degr degr 1))
+       (degr))
+      ((>= cum-degr tot-degr~) (make-abar :list rslt))
+    (setf degr (1+ (random max-degr)))
+    (push (brgn (1+ degr)
+		(let ((list (make-list degr)))
+		  (mapl
+		   #'(lambda (sublist)
+		       (setf (car sublist) (- (random 21) 10)))
+		   list)
+		  list))
+	  rslt)))
+(setf rdct (cs-pre-left-hmeq-left-reduction (k-z-1)))
+(pre-check-rdct rdct)
+(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
+      *bc* (cmbn 0 1 +null-gbar+))
+(check-rdct)
+(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
+(check-rdct)
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (setf gbar (gbar 2 0 '(1) 0 '()))
+    (unless (>= abar-degr 9)
+      (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
+	    *bc* (cmbn 2 1 gbar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 6 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
+		     abar-degr abar))
+    (setf gbar (gbar 3 0 '(1 2) 1 '() 0 '()))
+    (unless (>= abar-degr 8)
+      (setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
+	    *bc* (cmbn 3 1 gbar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 6 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
 	   	     abar-degr abar))
-      (setf gbar (gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
-      (unless (>= abar-degr 9)
-        (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
-        (setf *bc* (cmbn 4 1 gbar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 6 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (setf gbar (gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9) 0 '()))
-      (unless (>= abar-degr 10)
-         (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
-         (setf *bc* (cmbn 5 1 gbar))
-         (check-rdct))))
+    (setf gbar (gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
+    (unless (>= abar-degr 9)
+      (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
+      (setf *bc* (cmbn 4 1 gbar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 6 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (setf gbar (gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9) 0 '()))
+    (unless (>= abar-degr 10)
+      (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
+      (setf *bc* (cmbn 5 1 gbar))
+      (check-rdct))))
 |#
 
 (DEFUN CS-LEFT-HMEQ-LEFT-REDUCTION (smgr
-				     &aux (pre-left-hmeq-left-reduction
-					     (cs-pre-left-hmeq-left-reduction smgr))
-				          (hat-left-perturbation
-					     (cs-hat-left-perturbation smgr)))
+				    &aux (pre-left-hmeq-left-reduction
+					  (cs-pre-left-hmeq-left-reduction smgr))
+				      (hat-left-perturbation
+				       (cs-hat-left-perturbation smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type reduction pre-left-hmeq-left-reduction)
-    (type morphism hat-left-perturbation))
+   (type simplicial-group smgr)
+   (type reduction pre-left-hmeq-left-reduction)
+   (type morphism hat-left-perturbation))
   (the reduction
-    (progn
-      (dstr-change-sorc-trgt hat-left-perturbation
-	:new-sorc (tcc pre-left-hmeq-left-reduction)
-	:new-trgt (tcc pre-left-hmeq-left-reduction))
-      (let ((rslt (special-bpl-2 pre-left-hmeq-left-reduction
-				 hat-left-perturbation)))
-	(declare (type reduction rslt))
-	(with-slots (tcc f g h) rslt
-	  (setf tcc (cs-left-hmeq-hat smgr)
-		(slot-value f 'sorc) tcc
-		(slot-value g 'trgt) tcc
-		(slot-value h 'sorc) tcc
-		(slot-value h 'trgt) tcc))
-	rslt))))
-	
+       (progn
+	 (dstr-change-sorc-trgt hat-left-perturbation
+				:new-sorc (tcc pre-left-hmeq-left-reduction)
+				:new-trgt (tcc pre-left-hmeq-left-reduction))
+	 (let ((rslt (special-bpl-2 pre-left-hmeq-left-reduction
+				    hat-left-perturbation)))
+	   (declare (type reduction rslt))
+	   (with-slots (tcc f g h) rslt
+	     (setf tcc (cs-left-hmeq-hat smgr)
+		   (slot-value f 'sorc) tcc
+		   (slot-value g 'trgt) tcc
+		   (slot-value h 'sorc) tcc
+		   (slot-value h 'trgt) tcc))
+	   rslt))))
+
 
 #|
-  (cat-init)
-  (defun random-abar (tot-degr~ max-degr)
-    (do ((rslt nil)
-         (cum-degr 0 (+ cum-degr degr 1))
-         (degr))
-        ((>= cum-degr tot-degr~) (make-abar :list rslt))
-       (setf degr (1+ (random max-degr)))
-       (push (brgn (1+ degr)
-                   (let ((list (make-list degr)))
-                     (mapl
-                       #'(lambda (sublist)
-                           (setf (car sublist) (- (random 21) 10)))
-                       list)
-                     list))
-             rslt)))
-  (setf rdct (cs-left-hmeq-left-reduction (k-z-1)))
-  (pre-check-rdct rdct)
-  (setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
-        *bc* (cmbn 0 1 +null-gbar+))
-  (check-rdct)
-  (setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
-  (check-rdct)
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (setf gbar (gbar 2 0 '(1) 0 '()))
-      (unless (>= abar-degr 9)
-        (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
-              *bc* (cmbn 2 1 gbar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 6 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
-                       abar-degr abar))
-      (setf gbar (gbar 3 0 '(1 2) 1 '() 0 '()))
-      (unless (>= abar-degr 8)
-        (setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
-              *bc* (cmbn 3 1 gbar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 6 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
+(cat-init)
+(defun random-abar (tot-degr~ max-degr)
+  (do ((rslt nil)
+       (cum-degr 0 (+ cum-degr degr 1))
+       (degr))
+      ((>= cum-degr tot-degr~) (make-abar :list rslt))
+    (setf degr (1+ (random max-degr)))
+    (push (brgn (1+ degr)
+		(let ((list (make-list degr)))
+		  (mapl
+		   #'(lambda (sublist)
+		       (setf (car sublist) (- (random 21) 10)))
+		   list)
+		  list))
+	  rslt)))
+(setf rdct (cs-left-hmeq-left-reduction (k-z-1)))
+(pre-check-rdct rdct)
+(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
+      *bc* (cmbn 0 1 +null-gbar+))
+(check-rdct)
+(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
+(check-rdct)
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (setf gbar (gbar 2 0 '(1) 0 '()))
+    (unless (>= abar-degr 9)
+      (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
+	    *bc* (cmbn 2 1 gbar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 6 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
+		     abar-degr abar))
+    (setf gbar (gbar 3 0 '(1 2) 1 '() 0 '()))
+    (unless (>= abar-degr 8)
+      (setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
+	    *bc* (cmbn 3 1 gbar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 6 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
 	   	     abar-degr abar))
-      (setf gbar (gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
-      (unless (>= abar-degr 9)
-        (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
-        (setf *bc* (cmbn 4 1 gbar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 6 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (setf gbar (gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9) 0 '()))
-      (unless (>= abar-degr 10)
-         (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
-         (setf *bc* (cmbn 5 1 gbar))
-         (check-rdct))))
+    (setf gbar (gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
+    (unless (>= abar-degr 9)
+      (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
+      (setf *bc* (cmbn 4 1 gbar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 6 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (setf gbar (gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9) 0 '()))
+    (unless (>= abar-degr 10)
+      (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
+      (setf *bc* (cmbn 5 1 gbar))
+      (check-rdct))))
 |#
 
 (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn)
   (declare (type cmbn cmbn))
   (the cmbn
-     (with-cmbn (degr list) cmbn
-     (let ((rslt +empty-list+))
-       (declare (list rslt))
-       (do ((mark list (cdr mark)))
-	   ((endp mark))
-	   (declare (list mark))
-	  (with--term (cffc tnpr) mark
-	  (with-tnpr (degr1 nil nil abar2) tnpr
-	    (if (zerop degr1)
-	       (push (term cffc abar2) rslt)
-	       (return)))))
-       (make-cmbn :degr degr
-		  :list (nreverse rslt))))))
+       (with-cmbn (degr list) cmbn
+		  (let ((rslt +empty-list+))
+		    (declare (list rslt))
+		    (do ((mark list (cdr mark)))
+			((endp mark))
+		      (declare (list mark))
+		      (with--term (cffc tnpr) mark
+				  (with-tnpr (degr1 nil nil abar2) tnpr
+					     (if (zerop degr1)
+						 (push (term cffc abar2) rslt)
+						 (return)))))
+		    (make-cmbn :degr degr
+			       :list (nreverse rslt))))))
 
 #|
-  (cs-pre-left-hmeq-right-reduction-intr-f
-    (cmbn 4 2 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i)
-                    4 (abar 2 'a 2 'b))
-            3 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i)
-                    4 (abar 2 'a 2 'c))
-            5 (tnpr 1 (tnpr 0 +null-gbar+ 1 'a)
-                    3 (abar 1 'a 2 'b))))
+(cs-pre-left-hmeq-right-reduction-intr-f
+ (cmbn 4 2 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i)
+		 4 (abar 2 'a 2 'b))
+       3 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i)
+	       4 (abar 2 'a 2 'c))
+       5 (tnpr 1 (tnpr 0 +null-gbar+ 1 'a)
+	       3 (abar 1 'a 2 'b))))
 |#
 
 (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (smgr
-					     &aux (hat-t-u (cs-hat-t-u smgr))
-					          (bar (bar smgr)))
+					   &aux (hat-t-u (cs-hat-t-u smgr))
+					     (bar (bar smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type chain-complex hat-t-u bar))
+   (type simplicial-group smgr)
+   (type chain-complex hat-t-u bar))
   (the morphism
-    (build-mrph
-      :sorc hat-t-u :trgt bar :degr 0
-      :intr #'cs-pre-left-hmeq-right-reduction-intr-f
-      :strt :cmbn
-      :orgn `(cs-pre-left-hmeq-right-reduction-f ,smgr))))
+       (build-mrph
+	:sorc hat-t-u :trgt bar :degr 0
+	:intr #'cs-pre-left-hmeq-right-reduction-intr-f
+	:strt :cmbn
+	:orgn `(cs-pre-left-hmeq-right-reduction-f ,smgr))))
 
 (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (idnt)
   (declare (type gmsm idnt))
   (flet ((rslt (cmbn)
 	   (declare (type cmbn cmbn))
 	   (the cmbn
-	     (with-cmbn (degr list) cmbn
-	     (let ((bsgn (tnpr 0 +null-gbar+ 0 idnt)))
-	       (declare (type tnpr bsgn))
-	       (make-cmbn :degr degr
-		 :list (mapcar
-			 #'(lambda (term)
-			     (declare (type term term))
-			     (with-term (cffc abar) term
-			       (term cffc
-				     (tnpr 0 bsgn
-					   degr abar))))
-			 list)))))))
+		(with-cmbn (degr list) cmbn
+			   (let ((bsgn (tnpr 0 +null-gbar+ 0 idnt)))
+			     (declare (type tnpr bsgn))
+			     (make-cmbn :degr degr
+					:list (mapcar
+					       #'(lambda (term)
+						   (declare (type term term))
+						   (with-term (cffc abar) term
+							      (term cffc
+								    (tnpr 0 bsgn
+									  degr abar))))
+					       list)))))))
     (the intr-mrph #'rslt)))
 
 #|
-  (setf g (cs-pre-left-hmeq-right-reduction-intr-g 'i))
-  (funcall g (cmbn 3 2 (abar 1 'a 2 'b)))
+(setf g (cs-pre-left-hmeq-right-reduction-intr-g 'i))
+(funcall g (cmbn 3 2 (abar 1 'a 2 'b)))
 |#
 
 (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (smgr
-					    &aux (hat-t-u (cs-hat-t-u smgr))
-					         (bar (bar smgr))
-						 (idnt (bspn smgr)))
+					   &aux (hat-t-u (cs-hat-t-u smgr))
+					     (bar (bar smgr))
+					     (idnt (bspn smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type chain-complex hat-t-u bar)
-    (type gmsm idnt))
+   (type simplicial-group smgr)
+   (type chain-complex hat-t-u bar)
+   (type gmsm idnt))
   (the morphism
-    (build-mrph
-      :sorc bar :trgt hat-t-u :degr 0
-      :intr (cs-pre-left-hmeq-right-reduction-intr-g idnt)
-      :strt :cmbn
-      :orgn `(cs-pre-left-hmeq-right-reduction-g ,smgr))))
+       (build-mrph
+	:sorc bar :trgt hat-t-u :degr 0
+	:intr (cs-pre-left-hmeq-right-reduction-intr-g idnt)
+	:strt :cmbn
+	:orgn `(cs-pre-left-hmeq-right-reduction-g ,smgr))))
 
 (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (smgr
-					    &aux (bar (bar smgr))
-					         (tnpr-contraction
-						   (smgr-tnpr-contraction smgr)))
+					   &aux (bar (bar smgr))
+					     (tnpr-contraction
+					      (smgr-tnpr-contraction smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type chain-complex bar)
-    (type morphism tnpr-contraction))
+   (type simplicial-group smgr)
+   (type chain-complex bar)
+   (type morphism tnpr-contraction))
   (the morphism
-    (tnsr-prdc tnpr-contraction (idnt-mrph bar))))
+       (tnsr-prdc tnpr-contraction (idnt-mrph bar))))
 
 (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION (smgr)
   (declare (type simplicial-group smgr))
   (the reduction
-    (build-rdct
-      :f (cs-pre-left-hmeq-right-reduction-f smgr)
-      :g (cs-pre-left-hmeq-right-reduction-g smgr)
-      :h (cs-pre-left-hmeq-right-reduction-h smgr)
-      :orgn `(cs-pre-left-hmeq-right-reduction ,smgr))))
+       (build-rdct
+	:f (cs-pre-left-hmeq-right-reduction-f smgr)
+	:g (cs-pre-left-hmeq-right-reduction-g smgr)
+	:h (cs-pre-left-hmeq-right-reduction-h smgr)
+	:orgn `(cs-pre-left-hmeq-right-reduction ,smgr))))
 
 #|
-  (cat-init)
-  (defun random-abar (tot-degr~ max-degr)
-    (do ((rslt nil)
-         (cum-degr 0 (+ cum-degr degr 1))
-         (degr))
-        ((>= cum-degr tot-degr~) (make-abar :list rslt))
-       (setf degr (1+ (random max-degr)))
-       (push (brgn (1+ degr)
-                   (let ((list (make-list degr)))
-                     (mapl
-                       #'(lambda (sublist)
-                           (setf (car sublist) (- (random 21) 10)))
-                       list)
-                     list))
-             rslt)))
-  (setf rdct (cs-pre-left-hmeq-right-reduction (k-z-1)))
-  (pre-check-rdct rdct)
-  (setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
-        *bc* (cmbn 0 1 +null-abar+))
-  (check-rdct)
-  (setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
-  (check-rdct)
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 9)
-        (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
-              *bc* (cmbn abar-degr 1 abar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 6 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
-                       abar-degr abar))
-      (unless (>= abar-degr 8)
-        (setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
-              *bc* (cmbn abar-degr 1 abar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 6 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
+(cat-init)
+(defun random-abar (tot-degr~ max-degr)
+  (do ((rslt nil)
+       (cum-degr 0 (+ cum-degr degr 1))
+       (degr))
+      ((>= cum-degr tot-degr~) (make-abar :list rslt))
+    (setf degr (1+ (random max-degr)))
+    (push (brgn (1+ degr)
+		(let ((list (make-list degr)))
+		  (mapl
+		   #'(lambda (sublist)
+		       (setf (car sublist) (- (random 21) 10)))
+		   list)
+		  list))
+	  rslt)))
+(setf rdct (cs-pre-left-hmeq-right-reduction (k-z-1)))
+(pre-check-rdct rdct)
+(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
+      *bc* (cmbn 0 1 +null-abar+))
+(check-rdct)
+(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
+(check-rdct)
+(dotimes (i 10)
+  (let ((abar (random-abar 8 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (unless (>= abar-degr 9)
+      (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
+	    *bc* (cmbn abar-degr 1 abar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 6 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
+		     abar-degr abar))
+    (unless (>= abar-degr 8)
+      (setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
+	    *bc* (cmbn abar-degr 1 abar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 6 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
 	   	     abar-degr abar))
-      (unless (>= abar-degr 9)
-        (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
-        (setf *bc* (cmbn abar-degr 1 abar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 6 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 10)
-         (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
-         (setf *bc* (cmbn abar-degr 1 abar))
-         (check-rdct))))
+    (unless (>= abar-degr 9)
+      (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
+      (setf *bc* (cmbn abar-degr 1 abar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 6 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (unless (>= abar-degr 10)
+      (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
+      (setf *bc* (cmbn abar-degr 1 abar))
+      (check-rdct))))
 |#
 
 (DEFUN CS-LEFT-HMEQ-RIGHT-REDUCTION (smgr
-				      &aux (pre-reduction
-					     (cs-pre-left-hmeq-right-reduction smgr))
-				           (perturbation
-					     (cs-hat-right-perturbation smgr)))
+				     &aux (pre-reduction
+					   (cs-pre-left-hmeq-right-reduction smgr))
+				       (perturbation
+					(cs-hat-right-perturbation smgr)))
   (declare
-    (type simplicial-group smgr)
-    (type reduction pre-reduction)
-    (type morphism perturbation))
+   (type simplicial-group smgr)
+   (type reduction pre-reduction)
+   (type morphism perturbation))
   (the reduction
-    (progn
-      (setf (slot-value perturbation 'sorc) (tcc pre-reduction)
-	    (slot-value perturbation 'trgt) (tcc pre-reduction))
-      (special-bpl-2 pre-reduction perturbation))))
+       (progn
+	 (setf (slot-value perturbation 'sorc) (tcc pre-reduction)
+	       (slot-value perturbation 'trgt) (tcc pre-reduction))
+	 (special-bpl-2 pre-reduction perturbation))))
 
 #|
-  (cat-init)
-  (defun random-abar (tot-degr~ max-degr)
-    (do ((rslt nil)
-         (cum-degr 0 (+ cum-degr degr 1))
-         (degr))
-        ((>= cum-degr tot-degr~) (make-abar :list rslt))
-       (setf degr (1+ (random max-degr)))
-       (push (brgn (1+ degr)
-                   (let ((list (make-list degr)))
-                     (mapl
-                       #'(lambda (sublist)
-                           (setf (car sublist) (- (random 21) 10)))
-                       list)
-                     list))
-             rslt)))
-  (setf rdct (cs-left-hmeq-right-reduction (k-z-1)))
-  (pre-check-rdct rdct)
-  (setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
-        *bc* (cmbn 0 1 +null-abar+))
-  (check-rdct)
-  (setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
-  (check-rdct)
-  (dotimes (i 10)
-    (let ((abar (random-abar 4 2)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 3 (tnpr 2 (gbar 2 0 '(3) 0 '()) 1 '(4))
-                       abar-degr abar))
-      (unless (>= abar-degr 9)
-        (setf *tc* (cmbn (+ 3 abar-degr) 1 gnrt)
-              *bc* (cmbn abar-degr 1 abar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 3 1)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(5 6))
-                       abar-degr abar))
-      (unless (>= abar-degr 8)
-        (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt)
-              *bc* (cmbn abar-degr 1 abar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 3 1)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 1 '() 0 '()) 2 '(5 6))
+(cat-init)
+(defun random-abar (tot-degr~ max-degr)
+  (do ((rslt nil)
+       (cum-degr 0 (+ cum-degr degr 1))
+       (degr))
+      ((>= cum-degr tot-degr~) (make-abar :list rslt))
+    (setf degr (1+ (random max-degr)))
+    (push (brgn (1+ degr)
+		(let ((list (make-list degr)))
+		  (mapl
+		   #'(lambda (sublist)
+		       (setf (car sublist) (- (random 21) 10)))
+		   list)
+		  list))
+	  rslt)))
+(setf rdct (cs-left-hmeq-right-reduction (k-z-1)))
+(pre-check-rdct rdct)
+(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
+      *bc* (cmbn 0 1 +null-abar+))
+(check-rdct)
+(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
+(check-rdct)
+(dotimes (i 10)
+  (let ((abar (random-abar 4 2)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 3 (tnpr 2 (gbar 2 0 '(3) 0 '()) 1 '(4))
+		     abar-degr abar))
+    (unless (>= abar-degr 9)
+      (setf *tc* (cmbn (+ 3 abar-degr) 1 gnrt)
+	    *bc* (cmbn abar-degr 1 abar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 3 1)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(5 6))
+		     abar-degr abar))
+    (unless (>= abar-degr 8)
+      (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt)
+	    *bc* (cmbn abar-degr 1 abar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 3 1)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 1 '() 0 '()) 2 '(5 6))
 	   	     abar-degr abar))
-      (unless (>= abar-degr 9)
-        (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
-        (setf *bc* (cmbn abar-degr 1 abar))
-        (check-rdct))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 6 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 10)
-         (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
-         (setf *bc* (cmbn abar-degr 1 abar))
-         (check-rdct))))
+    (unless (>= abar-degr 9)
+      (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
+      (setf *bc* (cmbn abar-degr 1 abar))
+      (check-rdct))))
+(dotimes (i 10)
+  (let ((abar (random-abar 6 4)))
+    (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
+    (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
+		     abar-degr abar))
+    (unless (>= abar-degr 10)
+      (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
+      (setf *bc* (cmbn abar-degr 1 abar))
+      (check-rdct))))
 |#
 
 (DEFUN CS-LEFT-HMEQ (smgr)
   (declare (type simplicial-group smgr))
   (the homotopy-equivalence
-    (build-hmeq
-      :lrdct (cs-left-hmeq-left-reduction smgr)
-      :rrdct (cs-left-hmeq-right-reduction smgr)
-      :orgn `(cs-left-hmeq ,smgr))))
+       (build-hmeq
+	:lrdct (cs-left-hmeq-left-reduction smgr)
+	:rrdct (cs-left-hmeq-right-reduction smgr)
+	:orgn `(cs-left-hmeq ,smgr))))
 
 #|
-  (cat-init)
-  (setf h (cs-left-hmeq (k-z-1)))
-  (setf abar (abar 2 '(2) 3 '(3 4)))
-  (rg h 5 abar)
-  (lf h *)
-  (lg h *)
-  (rf h *)
+(cat-init)
+(setf h (cs-left-hmeq (k-z-1)))
+(setf abar (abar 2 '(2) 3 '(3 4)))
+(rg h 5 abar)
+(lf h *)
+(lg h *)
+(rf h *)
 |#
 
 (DEFUN CLASSIFYING-SPACE-EFHM (smgr)
@@ -865,11 +831,11 @@
   (classifying-space-efhm (second (orgn classifying-space))))
 
 #|
-  (cat-init)
-  (setf k (k-z-1))
-  (homology k 0 10)
-  (setf bk (classifying-space k))
-  (homology bk 0 10)
-  (setf obk (loop-space bk))
-  (homology obk 0 6)
+(cat-init)
+(setf k (k-z-1))
+(homology k 0 10)
+(setf bk (classifying-space k))
+(homology bk 0 10)
+(setf obk (loop-space bk))
+(homology obk 0 6)
 |#
diff --git a/test/bar-test.lisp b/test/bar-test.lisp
index 98bbf1d..ed14550 100644
--- a/test/bar-test.lisp
+++ b/test/bar-test.lisp
@@ -56,7 +56,7 @@
 	(funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7)))))
 
 
-(defun random-abar (length)
+(defun random-abar1 (length)
   (let ((rslt nil))
     (dotimes (i length)
       (let* ((gmsm (random (cat:mask 7)))
@@ -71,9 +71,9 @@
 	(cat:cat-init)
 	(let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
 	  (dotimes (i 10)
-	    (print (random-abar 5)))
+	    (print (random-abar1 5)))
 	  (dotimes (i 10)
-	    (let ((abar (random-abar 3)))
+	    (let ((abar (random-abar1 3)))
 	      (print abar)
 	      (print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
 			    abar))
@@ -82,22 +82,6 @@
 				     abar))))))))
 
 
-(defun random-abar1 (tot-degr~ max-degr)
-  (do ((rslt nil)
-       (cum-degr 0 (+ cum-degr degr 1))
-       (degr))
-      ((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
-    (setf degr (1+ (random max-degr)))
-    (push (cat:brgn (1+ degr)
-		(let ((list (make-list degr)))
-		  (mapl
-		   #'(lambda (sublist)
-		       (setf (car sublist) (- (random 21) 10)))
-		   list)
-		  list))
-	  rslt)))
-
-
 #|
 (test bar-intr-hrzn-dffr
       (let* ((k (cat:k-z-1))
diff --git a/test/cl-space-efhm-test.lisp b/test/cl-space-efhm-test.lisp
new file mode 100644
index 0000000..0c0c2b9
--- /dev/null
+++ b/test/cl-space-efhm-test.lisp
@@ -0,0 +1,56 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+
+(test cs-hat-u-t
+      (progn
+	(cat:cat-init)
+	(let* ((c (cat:cs-hat-u-t (cat:k-z-1)))
+	       (abar (random-abar 8 4))
+	       (abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
+	       (gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
+					   2 '(4 5))
+			       abar-degr abar)))
+	  (dotimes (i 5) (print (random-abar 8 4)))
+	  #|
+	  (cat:? c (+ 5 abar-degr) gnrt)
+	  (cat:? c (cat:? c (+ 5 abar-degr) gnrt))
+	  (dotimes (i 10)
+	    (let ((abar (random-abar 8 4)))
+	      (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
+	      (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
+							   0 '()) 2 '(4 5))
+				   abar-degr abar))
+	      (unless (>= abar-degr 10)
+		(print (cat:? c (+ 5 abar-degr) gnrt))
+		(print (cat:? c (cat:? c (+ 5 abar-degr) gnrt))))))
+	  (dotimes (i 10)
+	    (let ((abar (random-abar 8 4)))
+	      (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
+	      (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
+							   0 '()) 3 '(4 5 6))
+				   abar-degr abar))
+	      (unless (>= abar-degr 9)
+		(print (cat:? c (+ 6 abar-degr) gnrt))
+		(print (cat:? c (cat:? c (+ 6 abar-degr) gnrt))))))
+	  (dotimes (i 10)
+	    (let ((abar (random-abar 8 4)))
+	      (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
+	      (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
+					       3 '(4 5 6)) abar-degr abar))
+	      (unless (>= abar-degr 10)
+		(print (cat:? c (+ 5 abar-degr) gnrt))
+		(print (cat:? c (cat:? c (+ 5 abar-degr) gnrt))))))
+	  (dotimes (i 10)
+	    (let ((abar (random-abar 8 4)))
+	      (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
+	      (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
+					       2 '(4 5))
+				   abar-degr abar))
+	      (unless (>= abar-degr 11)
+		(print (cat:? c (+ 4 abar-degr) gnrt))
+		(print (cat:? c (cat:? c (+ 4 abar-degr) gnrt))))))
+	  |#
+	  )))
diff --git a/test/common.lisp b/test/common.lisp
index f525170..2ed8ad6 100644
--- a/test/common.lisp
+++ b/test/common.lisp
@@ -168,3 +168,19 @@
 				       cat:*dg-gd* cat:*hg*))
 			 cat:*bc*
 			 cat:*tc*))))))
+
+
+(defun random-abar (tot-degr~ max-degr)
+  (do ((rslt nil)
+       (cum-degr 0 (+ cum-degr degr 1))
+       (degr))
+      ((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
+    (setf degr (1+ (random max-degr)))
+    (push (cat:brgn (1+ degr)
+		(let ((list (make-list degr)))
+		  (mapl
+		   #'(lambda (sublist)
+		       (setf (car sublist) (- (random 21) 10)))
+		   list)
+		  list))
+	  rslt)))