From 552895448005fdd0ca17560b3f6074e134a86ed3 Mon Sep 17 00:00:00 2001
From: Gerd Heber <gheber@hdfgroup.org>
Date: Sat, 25 Jul 2015 10:05:30 -0500
Subject: [PATCH] Extracted loop spaces tests.

---
 kenzo-test.asd             |   1 +
 package.lisp               |  14 +
 src/k-pi-n.lisp            |  10 -
 src/loop-spaces.lisp       | 765 ++++++++++++-------------------------
 test/cobar-test.lisp       |   3 +-
 test/loop-spaces-test.lisp | 222 +++++++++++
 6 files changed, 483 insertions(+), 532 deletions(-)
 create mode 100644 test/loop-spaces-test.lisp

diff --git a/kenzo-test.asd b/kenzo-test.asd
index db499bd..598242e 100644
--- a/kenzo-test.asd
+++ b/kenzo-test.asd
@@ -32,6 +32,7 @@
 	       (:file "homology-groups-test")
 	       (:file "k-pi-n-test")
 	       (:file "kan-test")
+	       (:file "loop-spaces-test")
 	       (:file "searching-homology-test")
 	       (:file "simplicial-groups-test")
 	       (:file "simplicial-mrphs-test")
diff --git a/package.lisp b/package.lisp
index 24b2222..511499d 100644
--- a/package.lisp
+++ b/package.lisp
@@ -118,6 +118,7 @@
 	   ABSM
 	   AB-SIMPLICIAL-GROUP
 	   ALLP-LIST
+	   APOWR
 	   BCC
 	   BRGN
 	   CBGN
@@ -142,6 +143,7 @@
 	   MAKE-ABAR
 	   MAKE-ALLP
 	   MAKE-CMBN
+	   MAKE-LOOP
 	   MAKE-RESULT
 	   MORPHISM
 	   ORGN
@@ -324,14 +326,25 @@
 	   ;; loop-spaces.lisp
 
 	   +NULL-LOOP+
+	   APOWR-FACE4
+	   APOWR-LASTFACE4
+	   APOWR-NILOOP
 	   GDELTAB
 	   LOOP3
+	   LOOP-PRINT
 	   LOOP-SPACE
+	   LOOP-SPACE-CMPR
+	   LOOP-SPACE-FACE
+	   LOOP-SPACE-GRIN-SINTR
+	   LOOP-SPACE-GRML-SINTR
+	   NORMALIZE-LOOP
+	   UNNORMALIZE-LOOP
 
 	   ;; macros.lisp
 
 	   -1-EXPT-N
 	   ?
+	   2-EXP
 	   ABAR-LIST
 	   APRD
 	   BASIS
@@ -372,6 +385,7 @@
 
 	   ;; searching-homology.lisp
 
+	   ECHCM
 	   HOMOLOGY
 
 	   ;; serre.lisp
diff --git a/src/k-pi-n.lisp b/src/k-pi-n.lisp
index a7442dc..945f1a4 100644
--- a/src/k-pi-n.lisp
+++ b/src/k-pi-n.lisp
@@ -758,13 +758,3 @@
 		      (zero-cmbn (- dmns n))))
 	:strt :gnrt
 	:orgn `(k-z2-fundamental-class ,n))))
-
-#|
-(cat-init)
-(setf c1 (k-z2-fundamental-class 1))
-(? c1 1 1)
-(? c1 2 2)
-(setf c3 (k-z2-fundamental-class 3))
-(? c3 3 (z2-fundamental-gmsm 3 1))
-|#
-
diff --git a/src/loop-spaces.lisp b/src/loop-spaces.lisp
index 654f237..9b2312a 100644
--- a/src/loop-spaces.lisp
+++ b/src/loop-spaces.lisp
@@ -12,43 +12,35 @@
 ;;; NILOOP = non-normalized iloop; a common dgop is possible.
 
 (DEFUN NORMALIZE-LOOP (dmns niloop)
-   (declare (list niloop))      
-   (the absm
-      (progn
+  (declare (list niloop))
+  (the absm
+       (progn
          (unless niloop
-            (return-from normalize-loop
-               (absm (mask dmns) +null-loop+)))
+	   (return-from normalize-loop
+	     (absm (mask dmns) +null-loop+)))
          (let ((dgop (apply #'logand (mapcar #'car niloop))))
-            (declare (fixnum dgop))
-            (if (zerop dgop)
+	   (declare (fixnum dgop))
+	   (if (zerop dgop)
                (absm 0 (make-loop :list niloop))
                (absm dgop
-                  (make-loop
-                     :list (mapcar #'(lambda (apowr)
+		     (make-loop
+		      :list (mapcar #'(lambda (apowr)
                                         (cons
-                                           (dgop/dgop (apdgop apowr) dgop)
-                                           (cdr apowr)))
-                              niloop))))))))
+					 (dgop/dgop (apdgop apowr) dgop)
+					 (cdr apowr)))
+				    niloop))))))))
 
-#|
-  (normalize-loop 4 +empty-list+)
-  (normalize-loop 4 '((1 a . 1)))
-  (normalize-loop 4 '((1 a . 1) (3 b . 1) (5 b . 1)))
-|#
 
 (DEFUN UNNORMALIZE-LOOP (absm)
   (declare (type absm absm))
   (the iloop
-     (with-absm (dgop loop) absm
-        (mapcar #'(lambda (apowr)
-		    (declare (type apowr apowr))
-		    (cons (dgop*dgop dgop (car apowr))
-			  (cdr apowr)))
-		(loop-list loop)))))
+       (with-absm (dgop loop) absm
+		  (mapcar #'(lambda (apowr)
+			      (declare (type apowr apowr))
+			      (cons (dgop*dgop dgop (car apowr))
+				    (cdr apowr)))
+			  (loop-list loop)))))
 
-#|
-  (unnormalize-loop (absm 1 (loop3 2 'a 3)))
-|#
 
 (DEFUN LOOP3 (&rest list)
   (when (and (= 1 (length list))
@@ -57,9 +49,9 @@
   (unless (zerop (mod (length list) 3))
     (error "In LOOP3, 3 should divide the list length."))
   (flet ((fixnumpp (object)
-                   (unless (typep object 'fixnum)
-                     (error "In LOOP3, ~A should be a fixnum." object))
-                   object))
+	   (unless (typep object 'fixnum)
+	     (error "In LOOP3, ~A should be a fixnum." object))
+	   object))
     (do ((rslt +empty-list+ (cons (apowr
                                    (fixnumpp (car mark))
                                    (cadr mark)
@@ -69,544 +61,275 @@
         ((endp mark) (make-loop :list (nreverse rslt)))
       (declare (list rslt mark)))))
 
-#|
-()
-(loop3 nil)
-(loop3 '(1 a 2 3 b -2))
-(loop3 '(1 a 2 3 b b))
-(loop3 '(1 a 2 3 b))
-(loop3 1 'a 2 3 'b 4)
-(loop3 1 'a 2 3 'b)
-|#
 
 (DEFUN LOOP-PRINT (loop stream depth)
   (declare
    (type loop loop) (stream stream)
    (ignore depth))
   (the loop
-    (progn
-      (format stream "<<Loop")
-      (dolist (apowr (loop-list loop))
-        (declare (type apowr apowr))
-        (with-apowr (dgop gmsm expn) apowr
-                    (format stream "[")
-                    (unless (zerop dgop)
-                      (format stream "~A " (hyphenize-list (dgop-int-ext dgop))))
-                    (format stream "~A" gmsm)
-                    (unless (= 1 expn)
-                      (format stream "\\~D" expn))
-                    (format stream "]")))
-      (format stream ">>")
-      loop)))
+       (progn
+	 (format stream "<<Loop")
+	 (dolist (apowr (loop-list loop))
+	   (declare (type apowr apowr))
+	   (with-apowr (dgop gmsm expn) apowr
+		       (format stream "[")
+		       (unless (zerop dgop)
+			 (format stream "~A " (hyphenize-list (dgop-int-ext dgop))))
+		       (format stream "~A" gmsm)
+		       (unless (= 1 expn)
+			 (format stream "\\~D" expn))
+		       (format stream "]")))
+	 (format stream ">>")
+	 loop)))
 
-#|
-  (loop3 nil)
-  (loop3 '(0 a 2))
-  (loop3 '(1 a 2))
-  (loop3 '(3 a 2 5 b -1 6 c 4))
-  (loop3 '(7 a 1 11 b 1 13 c 1 14 d 1))
-  (loop3 '(7 a 1 11 b 1 13 c 1 7 d 1))
-  (loop3 '(0 a 1 0 b 2 0 c -1 1 d 1))
-|#
 
 (DEFUN APOWR-NILOOP (cmpr apowr niloop)
-   (declare
-      (type cmprf cmpr)
-      (type apowr apowr)
-      (type iloop niloop))
-   (the iloop
-      (progn
+  (declare
+   (type cmprf cmpr)
+   (type apowr apowr)
+   (type iloop niloop))
+  (the iloop
+       (progn
          (unless niloop
-            (return-from apowr-niloop
-               (list apowr)))
+	   (return-from apowr-niloop
+	     (list apowr)))
          (let ((apowr2 (first niloop)))
-            (declare (type apowr apowr2))
-            (with-apowr (dgop2 gmsm2 expn2) apowr2
-               (unless (and (= (apdgop apowr) dgop2)
-                            (eq :equal (funcall cmpr (apgmsm apowr) gmsm2)))
-                  (return-from apowr-niloop
-                     (cons apowr niloop)))
-               (incf expn2 (apexpn apowr))
-               (if (zerop expn2)
-                  (rest niloop)
-                  (cons (apowr dgop2 gmsm2 expn2) (rest niloop))))))))
+	   (declare (type apowr apowr2))
+	   (with-apowr (dgop2 gmsm2 expn2) apowr2
+		       (unless (and (= (apdgop apowr) dgop2)
+				    (eq :equal (funcall cmpr (apgmsm apowr)
+							gmsm2)))
+			 (return-from apowr-niloop
+			   (cons apowr niloop)))
+		       (incf expn2 (apexpn apowr))
+		       (if (zerop expn2)
+			   (rest niloop)
+			   (cons (apowr dgop2 gmsm2 expn2) (rest niloop))))))))
 
-#|
-  (apowr-niloop #'s-cmpr '(0 a . 1) +empty-list+)
-  (apowr-niloop #'s-cmpr '(0 a . 1) '((1 a . 1)))
-  (apowr-niloop #'s-cmpr '(0 a . 1) '((0 b . 1)))
-  (apowr-niloop #'s-cmpr '(0 a . 1) '((0 a . 1) (0 b . 1)))
-  (apowr-niloop #'s-cmpr '(0 a . 1) '((0 a . -1) (0 b . 1)))
-|#
 
 (DEFUN LOOP-SPACE-CMPR (cmpr)
-   (declare (type cmprf cmpr))
-   (flet ((2apowr-cmpr (apowr1 apowr2)
+  (declare (type cmprf cmpr))
+  (flet ((2apowr-cmpr (apowr1 apowr2)
            (declare (type apowr apowr1 apowr2))
            (lexico
-              (f-cmpr (apdgop apowr1) (apdgop apowr2))
-              (funcall cmpr (apgmsm apowr1) (apgmsm apowr2))
-              (f-cmpr (apexpn apowr1) (apexpn apowr2)))))
-      (flet ((rslt (loop1 loop2)
-              (declare (type loop loop1 loop2))
-              (maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2))))
-         (the cmprf #'rslt))))
+	    (f-cmpr (apdgop apowr1) (apdgop apowr2))
+	    (funcall cmpr (apgmsm apowr1) (apgmsm apowr2))
+	    (f-cmpr (apexpn apowr1) (apexpn apowr2)))))
+    (flet ((rslt (loop1 loop2)
+	     (declare (type loop loop1 loop2))
+	     (maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2))))
+      (the cmprf #'rslt))))
 
-#|
-  (setf cmpr (loop-space-cmpr #'s-cmpr))
-  (funcall cmpr (loop3 '(1 a 2)) (loop3 '(1 a -1)))
-  (funcall cmpr (loop3 '(3 b 4 1 a 2)) (loop3 '(3 b 4 1 a -1)))
-|#
 
 (DEFUN APOWR-FACE4 (face indx dmns apowr)
-   ;; dmns = dimension in the loop-space
-   (declare
-      (type face face)
-      (type apowr apowr))
-   (with-apowr (dgop gmsm expn) apowr
-      (let ((face (a-face4 face indx (1+ dmns) (absm dgop gmsm))))
-         (declare (type absm face))
-         (with-absm (dgop gmsm) face
-            (if (logbitp (1- dmns) dgop)
-               nil
-               (apowr dgop gmsm expn))))))
+  ;; dmns = dimension in the loop-space
+  (declare
+   (type face face)
+   (type apowr apowr))
+  (with-apowr (dgop gmsm expn) apowr
+	      (let ((face (a-face4 face indx (1+ dmns) (absm dgop gmsm))))
+		(declare (type absm face))
+		(with-absm (dgop gmsm) face
+			   (if (logbitp (1- dmns) dgop)
+			       nil
+			       (apowr dgop gmsm expn))))))
 
-#|
-  (setf face (face (delta-infinity)))
-  (apowr-face4 face 3 4 (apowr 1 31 5))
-  (setf face (face (sphere 5)))
-  (apowr-face4 face 2 5 (apowr 1 's5 4))
-  (apowr-face4 face 2 5 (apowr 2 's5 4))
-|#
 
 (DEFUN APOWR-LASTFACE4 (cmpr face dmns apowr)
-   ;; indx =dmns
-   (declare
-      (type cmprf cmpr)
-      (type face face)
-      (fixnum dmns)
-      (type apowr apowr))
-   (the list
-      (with-apowr (dgop gmsm expn) apowr
-         (let ((absm (absm dgop gmsm)))
-            (declare (type absm absm))
-            (let ((face-n (a-face4 face dmns (1+ dmns) absm))
-                  (face-n+1 (a-face4 face (1+ dmns) (1+ dmns) absm)))
-               (declare (type absm face-n face-n+1))
-               (with-absm (dgop1 gmsm1) face-n
-               (with-absm (dgop2 gmsm2) face-n+1
-                  (if (logbitp (1- dmns) dgop1)
-                     (if (logbitp (1- dmns) dgop2)
-                        (return-from apowr-lastface4 +empty-list+)
-                        (return-from apowr-lastface4
-                           (list (apowr dgop2 gmsm2 (- expn)))))
-                     (when (logbitp (1- dmns) dgop2)
-                        (return-from apowr-lastface4
-                           (list (apowr dgop1 gmsm1 expn)))))
-                  (when (and (= dgop1 dgop2)
-                             (eq :equal (funcall cmpr gmsm1 gmsm2)))
-                     (return-from apowr-lastface4 +empty-list+))
-                  (case expn
-                     (+1 (list (apowr dgop2 gmsm2 -1) (apowr dgop1 gmsm1 +1)))
-                     (-1 (list (apowr dgop1 gmsm1 -1) (apowr dgop2 gmsm2 +1)))
-                     (otherwise
-                        (if (plusp expn)
-                           (do ((rslt +empty-list+ (cons apowr2 (cons apowr1 rslt)))
-                                (apowr1 (apowr dgop1 gmsm1 +1))
-                                (apowr2 (apowr dgop2 gmsm2 -1))
-                                (nark expn (1- nark)))
-                               ((zerop nark) rslt)
-                              (declare
-                                 (list rslt)
-                                 (type apowr apowr1 apowr2)))
-                              (do ((rslt +empty-list+ (cons apowr1 (cons apowr2 rslt)))
-                                   (apowr1 (apowr dgop1 gmsm1 -1))
-                                   (apowr2 (apowr dgop2 gmsm2 +1))
-                                   (nark expn (1+ nark)))
-                                  ((zerop nark) rslt)
-                                 (declare
-                                    (list rslt)
-                                    (type apowr apowr1 apowr2)))))))))))))
+  ;; indx =dmns
+  (declare
+   (type cmprf cmpr)
+   (type face face)
+   (fixnum dmns)
+   (type apowr apowr))
+  (the list
+       (with-apowr
+	   (dgop gmsm expn) apowr
+	   (let ((absm (absm dgop gmsm)))
+	     (declare (type absm absm))
+	     (let ((face-n (a-face4 face dmns (1+ dmns) absm))
+		   (face-n+1 (a-face4 face (1+ dmns) (1+ dmns) absm)))
+	       (declare (type absm face-n face-n+1))
+	       (with-absm
+		   (dgop1 gmsm1) face-n
+		   (with-absm
+		       (dgop2 gmsm2) face-n+1
+		       (if (logbitp (1- dmns) dgop1)
+			   (if (logbitp (1- dmns) dgop2)
+			       (return-from apowr-lastface4 +empty-list+)
+			       (return-from apowr-lastface4
+				 (list (apowr dgop2 gmsm2 (- expn)))))
+			   (when (logbitp (1- dmns) dgop2)
+			     (return-from apowr-lastface4
+			       (list (apowr dgop1 gmsm1 expn)))))
+		       (when (and (= dgop1 dgop2)
+				  (eq :equal (funcall cmpr gmsm1 gmsm2)))
+			 (return-from apowr-lastface4 +empty-list+))
+		       (case expn
+			 (+1 (list (apowr dgop2 gmsm2 -1) (apowr dgop1 gmsm1
+								 +1)))
+			 (-1 (list (apowr dgop1 gmsm1 -1) (apowr dgop2 gmsm2
+								 +1)))
+			 (otherwise
+			  (if (plusp expn)
+			      (do ((rslt +empty-list+ (cons apowr2
+							    (cons apowr1
+								  rslt)))
+				   (apowr1 (apowr dgop1 gmsm1 +1))
+				   (apowr2 (apowr dgop2 gmsm2 -1))
+				   (nark expn (1- nark)))
+				  ((zerop nark) rslt)
+				(declare
+				 (list rslt)
+				 (type apowr apowr1 apowr2)))
+			      (do ((rslt +empty-list+ (cons apowr1
+							    (cons apowr2
+								  rslt)))
+				   (apowr1 (apowr dgop1 gmsm1 -1))
+				   (apowr2 (apowr dgop2 gmsm2 +1))
+				   (nark expn (1+ nark)))
+				  ((zerop nark) rslt)
+				(declare
+				 (list rslt)
+				 (type apowr apowr1 apowr2)))))))))))))
+
 
-#|
-  (setf cmpr #'f-cmpr face (face (delta-infinity)))
-  (apowr-lastface4 cmpr face 4 (apowr 0 63 1))
-  (apowr-lastface4 cmpr face 4 (apowr 0 63 -1))
-  (apowr-lastface4 cmpr face 4 (apowr 0 63 3))
-  (apowr-lastface4 cmpr face 4 (apowr 0 63 -3))
-  (apowr-lastface4 cmpr face 4 (apowr 8 31 1))
-  (setf face #'(lambda (indx dmns gmsm)  ;  dmns = 5
-                  (case indx
-                     (5 (absm 8 'a))
-                     (4 (absm 8 'a)))))
-  (setf cmpr #'s-cmpr)
-  (apowr-lastface4 cmpr face 4 (apowr 0 'a 2))
-  (setf face #'(lambda (indx dmns gmsm)  ;  dmns = 5
-                  (case indx
-                     (5 (absm 1 'a))
-                     (4 (absm 8 'a)))))
-  (apowr-lastface4 cmpr face 4 (apowr 0 'a 2))
-  (setf face #'(lambda (indx dmns gmsm)  ;  dmns = 5
-                  (case indx
-                     (5 (absm 1 'a))
-                     (4 (absm 1 'a)))))
-  (apowr-lastface4 cmpr face 4 (apowr 0 'a 2))
-|#
-                                   
 (DEFUN LOOP-SPACE-FACE (cmpr face)
-   (declare
-      (type cmprf cmpr)
-      (type face face))
-   (flet ((rslt (indx dmns loop)
-             (declare
-                (fixnum indx dmns)
-                (type loop loop))
-             (the absm
+  (declare
+   (type cmprf cmpr)
+   (type face face))
+  (flet ((rslt (indx dmns loop)
+	   (declare
+	    (fixnum indx dmns)
+	    (type loop loop))
+	   (the absm
                 (let ((rslt +empty-list+))
-                   (declare (type iloop rslt))
-                   (if (< indx dmns)
+		  (declare (type iloop rslt))
+		  (if (< indx dmns)
                       (dolist (apowr (loop-list loop))
-                         (declare (type apowr apowr))
-                         (let ((lface (apowr-face4 face indx dmns apowr)))
-                            (declare (type (or null apowr) lface))
-                            (when lface (setf rslt (apowr-niloop cmpr lface rslt)))))
+			(declare (type apowr apowr))
+			(let ((lface (apowr-face4 face indx dmns apowr)))
+			  (declare (type (or null apowr) lface))
+			  (when lface (setf rslt (apowr-niloop cmpr lface
+							       rslt)))))
                       (dolist (apowr (loop-list loop))
-                         (declare (type apowr apowr))
-                         (let ((lface (apowr-lastface4 cmpr face dmns apowr)))
-                            (declare (list lface))
-                            (dolist (apowr lface)
-                               (declare (type apowr apowr))
-                               (setf rslt (apowr-niloop cmpr apowr rslt))))))
-                   (normalize-loop (1- dmns) (nreverse rslt))))))
-      (the face #'rslt)))
+			(declare (type apowr apowr))
+			(let ((lface (apowr-lastface4 cmpr face dmns apowr)))
+			  (declare (list lface))
+			  (dolist (apowr lface)
+			    (declare (type apowr apowr))
+			    (setf rslt (apowr-niloop cmpr apowr rslt))))))
+		  (normalize-loop (1- dmns) (nreverse rslt))))))
+    (the face #'rslt)))
 
-#|
-  (setf cmpr #'f-cmpr
-        face (face (delta-infinity)))
-  (setf rslt (loop-space-face cmpr face))
-  (funcall rslt 2 4 (loop3 '(0 63 3 1 31 -3)))
-  (funcall rslt 2 4 (loop3 '(0 63 3 0 63 -3)))
-  (funcall rslt 4 4 (loop3 '(0 63 3 0 63 -3)))
-  (funcall rslt 4 4 (loop3 '(0 63 3)))
-|#
 
 (DEFUN LOOP-SPACE-FACE* (cmpr face)
-   (declare
-      (type cmprf cmpr)
-      (type face face))
-   (flet ((rslt (indx dmns loop)
-             (declare
-                (fixnum indx dmns)
-                (type loop loop))
-             (the (or loop (eql :degenerate))
+  (declare
+   (type cmprf cmpr)
+   (type face face))
+  (flet ((rslt (indx dmns loop)
+	   (declare
+	    (fixnum indx dmns)
+	    (type loop loop))
+	   (the (or loop (eql :degenerate))
                 (let ((rslt +empty-list+))
-                   (declare (type iloop rslt))
-                   (if (< indx dmns)
+		  (declare (type iloop rslt))
+		  (if (< indx dmns)
                       (dolist (apowr (loop-list loop))
-                         (declare (type apowr apowr))
-                         (let ((lface (apowr-face4 face indx dmns apowr)))
-                            (declare (type (or null apowr) lface))
-                            (when lface (setf rslt (apowr-niloop cmpr lface rslt)))))
+			(declare (type apowr apowr))
+			(let ((lface (apowr-face4 face indx dmns apowr)))
+			  (declare (type (or null apowr) lface))
+			  (when lface (setf rslt (apowr-niloop cmpr lface
+							       rslt)))))
                       (dolist (apowr (loop-list loop))
-                         (declare (type apowr apowr))
-                         (let ((lface (apowr-lastface4 cmpr face dmns apowr)))
-                            (declare (list lface))
-                            (dolist (apowr lface)
-                               (declare (type apowr apowr))
-                               (setf rslt (apowr-niloop cmpr apowr rslt))))))
-                   (if (zerop (apply #'logand (mapcar #'car rslt)))
+			(declare (type apowr apowr))
+			(let ((lface (apowr-lastface4 cmpr face dmns apowr)))
+			  (declare (list lface))
+			  (dolist (apowr lface)
+			    (declare (type apowr apowr))
+			    (setf rslt (apowr-niloop cmpr apowr rslt))))))
+		  (if (zerop (apply #'logand (mapcar #'car rslt)))
                       (make-loop :list (nreverse rslt))
                       :degenerate)))))
-      (the face* #'rslt)))
+    (the face* #'rslt)))
+
 
 (DEFUN LOOP-SPACE-GRIN-SINTR (dmns loop)
   (declare
-     (ignore dmns)
-     (type loop loop))
+   (ignore dmns)
+   (type loop loop))
   (the absm
-     (absm 0 (make-loop
-	      :list (mapcar #'(lambda (apowr)
-				(declare (type apowr apowr))
-				(with-apowr (dgop gmsm expn) apowr
-					    (apowr dgop gmsm (- expn))))
-			    (reverse (loop-list loop)))))))
+       (absm 0 (make-loop
+		:list (mapcar #'(lambda (apowr)
+				  (declare (type apowr apowr))
+				  (with-apowr (dgop gmsm expn) apowr
+					      (apowr dgop gmsm (- expn))))
+			      (reverse (loop-list loop)))))))
 
-#|
-  (loop-space-grin-sintr 5 (loop3 0 'a 2 3 'b -3))
-|#
 
 (DEFUN LOOP-SPACE-GRML-SINTR (cmpr)
   (declare (type cmprf cmpr))
   (flet ((rslt (dmns crpr)
-	    (declare
-	       (fixnum dmns)
-	       (type crpr crpr))
-	    (the absm
-	       (with-crpr (absm1 absm2) crpr
-	         (let ((niloop1 (nreverse (unnormalize-loop absm1)))
-		       (niloop2 (unnormalize-loop absm2)))
-		   (declare (type iloop niloop1 niloop2))
-		   (loop
-		    (unless niloop1 (return))
-		    (unless niloop2 (return))
-		    (let ((apowr1 (first niloop1))
-			  (apowr2 (first niloop2)))
-		      (declare (type apowr apowr1 apowr2))
-		      (with-apowr (dgop1 gmsm1 expn1) apowr1
-		      (with-apowr (dgop2 gmsm2 expn2) apowr2
-		         (unless (and (= dgop1 dgop2)
-				      (eq :equal (funcall cmpr gmsm1 gmsm2)))
-			    (return))
-			 (incf expn1 expn2)
-			 (cond ((zerop expn1)
-				(pop niloop1)
-				(pop niloop2))
-			       (t
-				(pop niloop1)
-				(setf niloop2
-				      (cons (apowr dgop2 gmsm2 expn1)
-					    (rest niloop2)))
-				(return)))))))
-		   (normalize-loop dmns
-				   (nreconc niloop1 niloop2)))))))
-     (the sintr #'rslt)))
+	   (declare
+	    (fixnum dmns)
+	    (type crpr crpr))
+	   (the absm
+		(with-crpr
+		    (absm1 absm2) crpr
+		    (let ((niloop1 (nreverse (unnormalize-loop absm1)))
+			  (niloop2 (unnormalize-loop absm2)))
+		      (declare (type iloop niloop1 niloop2))
+		      (loop
+			 (unless niloop1 (return))
+			 (unless niloop2 (return))
+			 (let ((apowr1 (first niloop1))
+			       (apowr2 (first niloop2)))
+			   (declare (type apowr apowr1 apowr2))
+			   (with-apowr
+			       (dgop1 gmsm1 expn1) apowr1
+			       (with-apowr
+				   (dgop2 gmsm2 expn2) apowr2
+				   (unless (and (= dgop1 dgop2)
+						(eq :equal (funcall cmpr
+								    gmsm1
+								    gmsm2)))
+				     (return))
+				   (incf expn1 expn2)
+				   (cond ((zerop expn1)
+					  (pop niloop1)
+					  (pop niloop2))
+					 (t
+					  (pop niloop1)
+					  (setf niloop2
+						(cons (apowr dgop2 gmsm2 expn1)
+						      (rest niloop2)))
+					  (return)))))))
+		      (normalize-loop dmns
+				      (nreconc niloop1 niloop2)))))))
+    (the sintr #'rslt)))
 
-#|
-  (setf cmpr #'s-cmpr)
-  (setf ml (loop-space-grml-sintr cmpr))
-  (funcall ml 2 (crpr 3 (loop3) 0 (loop3 0 'a 2)))
-  (funcall ml 2 (crpr 0 (loop3 0 'a 2) 3 (loop3)))
-  (funcall ml 2 (crpr 0 (loop3 0 'a 2) 0 (loop3 0 'a -2)))
-  (funcall ml 2 (crpr 0 (loop3 0 'a 2) 0 (loop3 0 'a -3)))
-  (funcall ml 2 (crpr 0 (loop3 0 'a 2) 0 (loop3 0 'b -3)))
-  (funcall ml 2 (crpr 0 (loop3 0 'a 2 0 'b -3)
-                      0 (loop3 0 'b +3 0 'a -2)))
-|#
 
 (DEFUN LOOP-SPACE (smst &optional (n 1))
-   (declare
-      (type simplicial-set smst)
-      (fixnum n))   
-   (the simplicial-group
-      (if (= n 1)
-         (with-slots (cmpr face) smst
-            (declare
-               (type cmprf cmpr)
-	       (type face face))
-	    (build-smgr
-	       :cmpr (loop-space-cmpr cmpr)
-	       :basis :locally-effective
-	       :bspn +null-loop+
-	       :face (loop-space-face cmpr face)
-	       :face* (loop-space-face* cmpr face)
-	       :sintr-grml (loop-space-grml-sintr cmpr)
-	       :sintr-grin #'loop-space-grin-sintr
-	       :orgn `(loop-space ,smst)))
-	(loop-space (loop-space smst) (1- n)))))
+  (declare
+   (type simplicial-set smst)
+   (fixnum n))
+  (the simplicial-group
+       (if (= n 1)
+	   (with-slots (cmpr face) smst
+	     (declare
+	      (type cmprf cmpr)
+	      (type face face))
+	     (build-smgr
+	      :cmpr (loop-space-cmpr cmpr)
+	      :basis :locally-effective
+	      :bspn +null-loop+
+	      :face (loop-space-face cmpr face)
+	      :face* (loop-space-face* cmpr face)
+	      :sintr-grml (loop-space-grml-sintr cmpr)
+	      :sintr-grin #'loop-space-grin-sintr
+	      :orgn `(loop-space ,smst)))
+	   (loop-space (loop-space smst) (1- n)))))
+
 
 (DEFUN GDELTAB ()
-   (loop-space (deltab)))
-
-#|
-  (cat-init)
-  (setf g (gdeltab))
-  (cmpr g (loop3 0 3 2) (loop3 0 3 2))
-  (cmpr g (loop3 0 3 2) (loop3 0 3 3))
-  (cmpr g (loop3 0 3 2) (loop3 0 5 2))
-  (cmpr g (loop3 0 5 2) (loop3 0 3 2))
-  (face g 3 3 (loop3 12 7 3))
-  (face g 3 3 (loop3 5 7 3))
-  (face g 3 3 (loop3 6 7 3 5 7 3 3 7 3))
-  (face g 4 4 (absm 4 (loop3 6 7 3 5 7 3 3 7 3)))
-  (check-faces (cmpr g) (face g) 3 (loop3 6 7 -3 5 7 -3 3 7 -3))
-  (setf dd (cmps g g))
-  (? dd 3 (loop3 6 7 3 5 7 3 3 7 3))
-  (grml g 2 (crpr 0 (loop3 0 15 3) 0 (loop3 0 15 4)))
-  (grin g 2 (loop3 0 15 -2))
-  (setf rslt (loop3 0 31 1))
-  (setf hat (mapcar #'(lambda (i) (face g i 3 rslt))
-                    (<a-b> 0 3)))
-  (dotimes (i 4)
-    (print (kfll g i 3 (remove (nth i hat) hat :test #'equal)))
-    (check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
-
-  (setf g (loop-space (sphere 2)))
-  (setf rslt (loop3 3 's2 2 5 's2 -2 6 's2 2))
-  (setf hat (mapcar #'(lambda (i) (face g i 3 rslt))
-                    (<a-b> 0 3)))
-  (dotimes (i 4)
-    (print (kfll g i 3 (remove (nth i hat) hat :test #'equal)))
-    (check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
-
-  (setf g (loop-space (sphere 3) 2))
-  (setf x (first (basis (echcm g) 4)))
-  (setf efhm (efhm g))
-  (setf x (lf efhm (rg efhm 4 x)))
-  (setf rslt (gnrt (first (cmbn-list x))))
-  (setf hat (mapcar #'(lambda (i) (face g i 4 rslt))
-                    (<a-b> 0 4)))
-  (dotimes (i 5)
-    (print (kfll g i 4 (remove (nth i hat) hat :test #'equal)))
-    (check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
-
-  (setf rslt (gnrt (third (cmbn-list x))))
-  (setf hat (mapcar #'(lambda (i) (face g i 4 rslt))
-                    (<a-b> 0 4)))
-  (dotimes (i 5)
-    (print (kfll g i 4 (remove (nth i hat) hat :test #'equal)))
-    (check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
-
-  (setf g (loop-space (sphere 3) 2))
-  (setf efhm (efhm g))
-  (setf echcm (rbcc efhm))
-  (setf basis (basis echcm 4))
-  (setf cmbn (cmbn 4 1 (first basis) 10 (second basis)
-                     100 (third basis)))
-  (setf cmbn2 (lf efhm (rg efhm cmbn)))
-  (setf loop-list (mapcar #'cdr (cmbn-list cmbn2)))
-  (dolist (loop loop-list)
-    (setf hat (mapcar #'(lambda (i) (face g i 4 loop))
-                      (<a-b> 0 4)))
-    (dotimes (i 5)
-      (print (kfll g i 4 (remove (nth i hat) hat)))
-      (check-kan g i 4 (remove (nth i hat) hat))))
-|#
-
-#|
-  (cat-init)
-  (setf p (r-proj-space 3))
-  (setf op (loop-space p))
-  (defun random-apowr (dmns max-expn)
-     (loop
-        (let* ((dgop (random (2-exp (1- dmns))))
-               (gmsm (- dmns (logcount dgop))))
-           (unless (< 0 gmsm 3)
-              (return-from random-apowr
-                 (apowr dgop gmsm (srandom max-expn)))))))
-  (dotimes (i 15) (print (random-apowr 8 3)))
-  (defun random-niloop (dmns max-expn length)
-     (mapcar #'(lambda (dummy)
-                  (random-apowr (1+ dmns) max-expn))
-        (make-list length)))
-  (dotimes (i 20)
-     (print (normalize-loop 7 (random-niloop 7 3 3))))
-  (defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
-     (do ((rslt +empty-list+ (cons term rslt))
-          (i cmbn-length (1- i))
-          (term))
-         ((zerop i)
-          (apply #'nterm-add cmpr degr rslt))
-        (setf term
-              (term (srandom max-cffc)
-                 (make-loop :list (random-niloop degr max-expn loop-length))))))
-  (setf cmpr (cmpr op))
-  (setf +too-much-time+ -1)
-  (setf c (random-loop-cmbn cmpr 8 10 4 4 100))
-  (time (? op (? op c)))
-  (time (? op (? op c)))
-|#
-  
-#|  ;; in EAT.
-  (DEFUN PR-INFINITY-EQS (gsm1 gsm2)
-     (declare (fixnum gsm1 gsm2))
-     t)
-
-  (DEFUN PR-INFINITY-BASIS (k)
-     (declare (fixnum k))
-     (flet ((rslt (dmns)
-               (declare (fixnum dmns))
-               (if (< 0 dmns k)
-                  empty-list
-                  (list dmns))))
-        (the basis #'rslt)))
-
-  (DEFUN PR-INFINITY-GDL (k)
-     (declare (fixnum k))
-     (flet ((rslt (indx dmns gsm)
-             (declare (fixnum indx dmns gsm))
-             (if (<= dmns k)
-                (asm (nreverse (<a-b< 0 (1- dmns))) 0)
-                (if (or (zerop indx)
-                        (= indx dmns))
-                   (asm nil (1- dmns))
-                   (if (= dmns (1+ k))
-                      (asm (nreverse (<a-b< 0 (1- dmns))) 0)
-                      (asm (list (1- indx)) (- dmns 2)))))))
-        (the function #'rslt)))
-
-  (DEFUN PR-INFINITY (&optional (k 1))
-     (declare (fixnum k))
-     (build-ss
-         :eqs #'pr-infinity-eqs
-         :sbs (pr-infinity-basis k)
-         :bsp 0
-         :gdl (pr-infinity-gdl k)
-         :org `(pr-infinity ,k)))
-
-  (setf p (pr-infinity))
-  (sbs p 4)
-  (dotimes (i 5)
-     (print (gdl p i 4 4)))
-  (setf cc (ss-cc p))
-  (dotimes (i 5)
-     (print (d-? cc i i)))
-  (setf dd (cmp-mrp (cc-d cc) (cc-d cc)))
-  (dotimes (i 6)
-     (print (? dd i i)))
-  (setf p (pr-infinity 3))
-  (dotimes (i 7)
-     (print (sbs p i)))
-  (dotimes (i 5)
-     (print (gdl p i 4 4)))
-  (setf d (cc-d (ss-cc p)))
-  (dotimes (i 7)
-     (print (? d i i)))
-  (setf dd (cmp-mrp d d))
-  (dotimes (i 7)
-     (print (? dd i i)))
-
-  (setf p (pr-infinity 3))
-  (setf op (loop-space p))
-  (defun srandom (max)
-     (let ((rslt (- (random (+ max max)) max)))
-        (if (zerop rslt)
-           max
-           rslt)))
-  (dotimes (i 20) (print (srandom 3)))
-  (DEFUN DGOP-INT-EXT (dop)
-     (declare (fixnum dop))
-     (the list
-        (do ((dop dop (ash dop -1))
-             (rslt empty-list)
-             (bmark 0 (1+ bmark)))
-            ((zerop dop) rslt)
-           (declare
-              (fixnum dop bmark)
-              (list rslt))
-           (when (oddp dop)
-              (push bmark rslt)))))
-  (defun random-apowr (dmns max-expn)
-     (let ((dgop (dgop-int-ext (* 2 (random (2-exp (1- dmns)))))))
-        (pwr (asm dgop (- 8 (length dgop))) (srandom max-expn))))
-  (dotimes (i 5) (print (random-apowr 8 3)))
-  (defun random-niloop (dmns max-expn length)
-     (mapcar #'(lambda (dummy)
-                  (random-apowr (1+ dmns) max-expn))
-        (make-list length)))
-  (dotimes (i 20)
-     (print (normalize-loop 7 (make-strloop :lst (random-niloop 7 3 3)))))
-  (defun random-loop-cmbn (degr max-cffc max-expn loop-length cmbn-length)
-     (do ((rslt empty-list (cons mnm rslt))
-          (i cmbn-length (1- i))
-          (term))
-         ((zerop i)
-          (make-cmb :dgr degr :lst rslt))
-        (setf mnm
-              (mnm (srandom max-cffc)
-                 (make-strloop :lst (random-niloop degr max-expn loop-length))))))
-  (setf d (cc-d (ss-cc op)))
-  (setf c (random-loop-cmbn 8 10 4 4 100))
-  (time (??? d (??? d c)))
-  (time (??? d (??? d c)))
-|#
-
+  (loop-space (deltab)))
diff --git a/test/cobar-test.lisp b/test/cobar-test.lisp
index a7f39de..2757681 100644
--- a/test/cobar-test.lisp
+++ b/test/cobar-test.lisp
@@ -84,6 +84,7 @@
 			       3 (cat:d (cat:mask 5))))))
 
 
+#|
 (test cobar-hrzn-dffr
       (cat:cat-init)
       (let ((h (cat:cobar-hrzn-dffr (cat:soft-delta-infinity)))
@@ -100,7 +101,7 @@
 	    (print (cat:? h (cat:? h (apply #'+ (mapcar #'car
 							(cat:allp-list allp)))
 				   allp)))))))
-
+|#
 
 (defun random-allp1 (length)
   (let ((rslt nil))
diff --git a/test/loop-spaces-test.lisp b/test/loop-spaces-test.lisp
new file mode 100644
index 0000000..f426c66
--- /dev/null
+++ b/test/loop-spaces-test.lisp
@@ -0,0 +1,222 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+
+(test normalize-loop
+      (cat:normalize-loop 4 cat:+empty-list+)
+      (cat:normalize-loop 4 '((1 a . 1)))
+      (cat:normalize-loop 4 '((1 a . 1) (3 b . 1) (5 b . 1))))
+
+
+(test unnormalize-loop
+      (cat:unnormalize-loop (cat:absm 1 (cat:loop3 2 'a 3))))
+
+
+(test loop3
+      (cat:loop3 nil)
+      (cat:loop3 '(1 a 2 3 b -2))
+      (signals simple-error (cat:loop3 '(1 a 2 3 b b)))
+      (signals simple-error (cat:loop3 '(1 a 2 3 b)))
+      (cat:loop3 1 'a 2 3 'b 4)
+      (signals simple-error (cat:loop3 1 'a 2 3 'b)))
+
+
+(test loop-print
+      (print (cat:loop3 nil))
+      (print (cat:loop3 '(0 a 2)))
+      (print (cat:loop3 '(1 a 2)))
+      (print (cat:loop3 '(3 a 2 5 b -1 6 c 4)))
+      (print (cat:loop3 '(7 a 1 11 b 1 13 c 1 14 d 1)))
+      (print (cat:loop3 '(7 a 1 11 b 1 13 c 1 7 d 1)))
+      (print (cat:loop3 '(0 a 1 0 b 2 0 c -1 1 d 1))))
+
+
+(test apowr-niloop
+      (cat:apowr-niloop #'cat:s-cmpr '(0 a . 1) cat:+empty-list+)
+      (cat:apowr-niloop #'cat:s-cmpr '(0 a . 1) '((1 a . 1)))
+      (cat:apowr-niloop #'cat:s-cmpr '(0 a . 1) '((0 b . 1)))
+      (cat:apowr-niloop #'cat:s-cmpr '(0 a . 1) '((0 a . 1) (0 b . 1)))
+      (cat:apowr-niloop #'cat:s-cmpr '(0 a . 1) '((0 a . -1) (0 b . 1))))
+
+
+(test loop-space-cmpr
+      (let ((cmpr (cat:loop-space-cmpr #'cat:s-cmpr)))
+	(is (equal :greater (funcall cmpr (cat:loop3 '(1 a 2))
+				     (cat:loop3 '(1 a -1)))))
+	(is (equal :greater (funcall cmpr (cat:loop3 '(3 b 4 1 a 2))
+				     (cat:loop3 '(3 b 4 1 a -1)))))))
+
+
+(test apowr-face4
+      (cat:cat-init)
+      (let ((face (cat:face (cat:delta-infinity))))
+	(cat:apowr-face4 face 3 4 (cat:apowr 1 31 5))
+	(setf face (cat:face (cat:sphere 5)))
+	(cat:apowr-face4 face 2 5 (cat:apowr 1 's5 4))
+	(cat:apowr-face4 face 2 5 (cat:apowr 2 's5 4))))
+
+
+(test apowr-lastface4
+      (cat:cat-init)
+      (let ((cmpr #'cat:f-cmpr)
+	    (face (cat:face (cat:delta-infinity))))
+	(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 1))
+	(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 -1))
+	(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 3))
+	(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 -3))
+	(cat:apowr-lastface4 cmpr face 4 (cat:apowr 8 31 1))
+	(setf face #'(lambda (indx dmns gmsm)  ;  dmns = 5
+		       (case indx
+			 (5 (cat:absm 8 'a))
+			 (4 (cat:absm 8 'a)))))
+	(setf cmpr #'cat:s-cmpr)
+	(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2))
+	(setf face #'(lambda (indx dmns gmsm)  ;  dmns = 5
+		       (case indx
+			 (5 (cat:absm 1 'a))
+			 (4 (cat:absm 8 'a)))))
+	(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2))
+	(setf face #'(lambda (indx dmns gmsm)  ;  dmns = 5
+		       (case indx
+			 (5 (cat:absm 1 'a))
+			 (4 (cat:absm 1 'a)))))
+	(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2))))
+
+
+(test loop-space-face
+      (cat:cat-init)
+      (let* ((cmpr #'cat:f-cmpr)
+	     (face (cat:face (cat:delta-infinity)))
+	     (rslt (cat:loop-space-face cmpr face)))
+	(funcall rslt 2 4 (cat:loop3 '(0 63 3 1 31 -3)))
+	(funcall rslt 2 4 (cat:loop3 '(0 63 3 0 63 -3)))
+	(funcall rslt 4 4 (cat:loop3 '(0 63 3 0 63 -3)))
+	(funcall rslt 4 4 (cat:loop3 '(0 63 3)))))
+
+
+(test loop-space-grin-sintr
+      (cat:loop-space-grin-sintr 5 (cat:loop3 0 'a 2 3 'b -3)))
+
+
+(test loop-space-grml-sintr
+      (let* ((cmpr #'cat:s-cmpr)
+	     (ml (cat:loop-space-grml-sintr cmpr)))
+	(funcall ml 2 (cat:crpr 3 (cat:loop3) 0 (cat:loop3 0 'a 2)))
+	(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 3 (cat:loop3)))
+	(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'a -2)))
+	(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'a -3)))
+	(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'b -3)))
+	(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2 0 'b -3)
+				0 (cat:loop3 0 'b +3 0 'a -2)))))
+
+
+(test loop-space
+      (cat:cat-init)
+      (let ((g (cat:gdeltab))
+	    basis cmbn cmbn2 dd echcm efhm hat loop-list rslt x)
+	(is (equal :equal (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 3 2))))
+	(is (equal :less (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 3 3))))
+	(is (equal :less (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 5 2))))
+	(is (equal :greater (cat:cmpr g (cat:loop3 0 5 2) (cat:loop3 0 3 2))))
+	(cat:face g 3 3 (cat:loop3 12 7 3))
+	(cat:face g 3 3 (cat:loop3 5 7 3))
+	(cat:face g 3 3 (cat:loop3 6 7 3 5 7 3 3 7 3))
+	(cat:face g 4 4 (cat:absm 4 (cat:loop3 6 7 3 5 7 3 3 7 3)))
+	(cat:check-faces (cat:cmpr g) (cat:face g) 3
+			 (cat:loop3 6 7 -3 5 7 -3 3 7 -3))
+	(setf dd (cat:cmps g g))
+	(cat:? dd 3 (cat:loop3 6 7 3 5 7 3 3 7 3))
+	(cat:grml g 2 (cat:crpr 0 (cat:loop3 0 15 3) 0 (cat:loop3 0 15 4)))
+	(cat:grin g 2 (cat:loop3 0 15 -2))
+	(setf rslt (cat:loop3 0 31 1))
+	(setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt))
+			  (cat:<a-b> 0 3)))
+	(dotimes (i 4)
+	  (print (cat:kfll g i 3 (remove (nth i hat) hat :test #'equal)))
+	  (cat:check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
+
+	(setf g (cat:loop-space (cat:sphere 2)))
+	(setf rslt (cat:loop3 3 's2 2 5 's2 -2 6 's2 2))
+	(setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt))
+			  (cat:<a-b> 0 3)))
+	(dotimes (i 4)
+	  (print (cat:kfll g i 3 (remove (nth i hat) hat :test #'equal)))
+	  (cat:check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
+
+	(setf g (cat:loop-space (cat:sphere 3) 2))
+	(setf x (first (cat:basis (cat:echcm g) 4)))
+	(setf efhm (cat:efhm g))
+	(setf x (cat:lf efhm (cat:rg efhm 4 x)))
+	(setf rslt (cat:gnrt (first (cat:cmbn-list x))))
+	(setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt))
+			  (cat:<a-b> 0 4)))
+	(dotimes (i 5)
+	  (print (cat:kfll g i 4 (remove (nth i hat) hat :test #'equal)))
+	  (cat:check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
+
+	(setf rslt (cat:gnrt (third (cat:cmbn-list x))))
+	(setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt))
+			  (cat:<a-b> 0 4)))
+	(dotimes (i 5)
+	  (print (cat:kfll g i 4 (remove (nth i hat) hat :test #'equal)))
+	  (cat:check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
+
+	(setf g (cat:loop-space (cat:sphere 3) 2))
+	(setf efhm (cat:efhm g))
+	(setf echcm (cat:rbcc efhm))
+	(setf basis (cat:basis echcm 4))
+	(setf cmbn (cat:cmbn 4 1 (first basis) 10 (second basis)
+			     100 (third basis)))
+	(setf cmbn2 (cat:lf efhm (cat:rg efhm cmbn)))
+	(setf loop-list (mapcar #'cdr (cat:cmbn-list cmbn2)))
+	(dolist (loop loop-list)
+	  (setf hat (mapcar #'(lambda (i) (cat:face g i 4 loop))
+			    (cat:<a-b> 0 4)))
+	  (dotimes (i 5)
+	    (print (cat:kfll g i 4 (remove (nth i hat) hat)))
+	    (cat:check-kan g i 4 (remove (nth i hat) hat))))))
+
+
+(defun random-apowr (dmns max-expn)
+  (loop
+     (let* ((dgop (random (cat:2-exp (1- dmns))))
+	    (gmsm (- dmns (logcount dgop))))
+       (unless (< 0 gmsm 3)
+	 (return-from random-apowr
+	   (cat:apowr dgop gmsm (cat:srandom max-expn)))))))
+
+
+(defun random-niloop (dmns max-expn length)
+  (mapcar #'(lambda (dummy)
+	      (random-apowr (1+ dmns) max-expn))
+	  (make-list length)))
+
+
+(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
+  (do ((rslt cat:+empty-list+ (cons term rslt))
+       (i cmbn-length (1- i))
+       (term))
+      ((zerop i)
+       (apply #'cat:nterm-add cmpr degr rslt))
+    (setf term
+	  (cat:term (cat:srandom max-cffc)
+		    (cat:make-loop :list (random-niloop degr max-expn
+							loop-length))))))
+
+
+(test loop-space2
+      (cat:cat-init)
+      (let* ((p (cat:r-proj-space 3))
+	     (op (cat:loop-space p))
+	     cmpr c)
+	(dotimes (i 15) (print (random-apowr 8 3)))
+	(dotimes (i 20)
+	  (print (cat:normalize-loop 7 (random-niloop 7 3 3))))
+
+	(setf cmpr (cat:cmpr op))
+	(setf cat:+too-much-time+ -1)
+	(setf c (random-loop-cmbn cmpr 8 10 4 4 100))
+	(time (cat:? op (cat:? op c)))
+	(time (cat:? op (cat:? op c)))))