From a1ca5821c3a0a0e07d6fbff75f543b503694f19d Mon Sep 17 00:00:00 2001
From: Gerd Heber <gheber@hdfgroup.org>
Date: Mon, 27 Jul 2015 18:27:45 -0500
Subject: [PATCH] Extracted tests from special-smsts.lisp.

---
 kenzo-test.asd               |   1 +
 package.lisp                 |   9 +
 src/special-smsts.lisp       | 976 +++++++++++++++--------------------
 test/special-smsts-test.lisp | 162 ++++++
 4 files changed, 594 insertions(+), 554 deletions(-)
 create mode 100644 test/special-smsts-test.lisp

diff --git a/kenzo-test.asd b/kenzo-test.asd
index e7a592f..50dbf59 100644
--- a/kenzo-test.asd
+++ b/kenzo-test.asd
@@ -39,6 +39,7 @@
 	       (:file "simplicial-mrphs-test")
 	       (:file "simplicial-sets-test")
 	       (:file "smith-test")
+	       (:file "special-smsts-test")
 	       (:file "suspensions-test")
 	       (:file "tensor-products-test")
 	       (:file "various-test")
diff --git a/package.lisp b/package.lisp
index 99c5e23..a48d5e8 100644
--- a/package.lisp
+++ b/package.lisp
@@ -14,6 +14,7 @@
 	   *FH*
 	   *HG*
 	   *HH*
+	   *HOMOLOGY-VERBOSE*
 	   *ID-FG*
 	   *ID-GF-DH-HD*
            *LIST-LIST*
@@ -140,6 +141,7 @@
 	   H
 	   HOMOTOPY-EQUIVALENCE
 	   IABSM
+	   IDNM
 	   KAN
 	   LOOP-LIST
 	   LRDCT
@@ -442,6 +444,7 @@
 	   NDGNR
 	   NFACE
 	   REMOVE-BIT
+	   SMST
 
 	   ;; smith.lisp
 
@@ -476,10 +479,16 @@
 	   ;; special-smsts.lisp
 
 	   BUILD-FINITE-SS
+	   FINITE-SS-PRE-TABLE
+	   FINITE-SS-PRE-TABLE-TABLE
+	   FINITE-SS-TABLE
+	   GMSMS-SUBSMST
 	   MOORE
 	   R-PROJ-SPACE
+	   R-PROJ-SPACE-BASIS
 	   SPHERE
 	   SPHERE-FACE
+	   SPHERE-WEDGE
 
 	   ;; suspensions.lisp
 
diff --git a/src/special-smsts.lisp b/src/special-smsts.lisp
index 974c330..d22d91d 100644
--- a/src/special-smsts.lisp
+++ b/src/special-smsts.lisp
@@ -10,528 +10,461 @@
 ;;;                         faces
 
 (DEFUN FINITE-SS-PRE-TABLE (list)
-   (declare (list list))
-   (the list
-      (let ((pre-rslt +empty-list+)
-            (dmns-mark nil)
-            (gmsm-mark nil))
+  (declare (list list))
+  (the list
+       (let ((pre-rslt +empty-list+)
+	     (dmns-mark nil)
+	     (gmsm-mark nil))
          (declare (list pre-rslt dmns-mark gmsm-mark))
          (dolist (item list)
-            (declare (type (or fixnum symbol list) item))
-            (cond ((typep item 'fixnum)
-                   (let ((found (assoc item pre-rslt)))
-                      (declare (list found))
-                      (setf dmns-mark 
-                            (or found
-                                (car (push (list item) pre-rslt)))
-                            gmsm-mark nil)))
-                  ((symbolp item)
-                   (when (assoc item (cdr dmns-mark))
-                      (error "In BUILD-FINITE-SS, the symbol ~A is present two times."
-                         item))
-                   (setf gmsm-mark (car (push (list item) (cdr dmns-mark)))))
-                  ((listp item)
-                   (unless gmsm-mark
-                      (error "In BUILD-FINITE-SS, the face list ~A~@
+	   (declare (type (or fixnum symbol list) item))
+	   (cond ((typep item 'fixnum)
+		  (let ((found (assoc item pre-rslt)))
+		    (declare (list found))
+		    (setf dmns-mark
+			  (or found
+			      (car (push (list item) pre-rslt)))
+			  gmsm-mark nil)))
+		 ((symbolp item)
+		  (when (assoc item (cdr dmns-mark))
+		    (error "In BUILD-FINITE-SS, the symbol ~A is present two times."
+			   item))
+		  (setf gmsm-mark (car (push (list item) (cdr dmns-mark)))))
+		 ((listp item)
+		  (unless gmsm-mark
+		    (error "In BUILD-FINITE-SS, the face list ~A~@
                               is not after a symbol." item))
-                   (nconc gmsm-mark item)
-                   (setf gmsm-mark nil))
-                  (t
-                     (error "In BUILD-FINITE-SS, the argument ~A does not make sense." item))))         
+		  (nconc gmsm-mark item)
+		  (setf gmsm-mark nil))
+		 (t
+		  (error "In BUILD-FINITE-SS, the argument ~A does not make sense." item))))
          (do ((mark1 pre-rslt (cdr mark1)))
              ((endp mark1))
-             (declare (list mark1))
-            (do ((mark2 (rest mark1) (cdr mark2)))
-                ((endp mark2))
-               (declare (list mark2))
-               (let ((inter (intersection (cdar mark1) (cdar mark2) :key #'first)))
-                  (declare (list inter))
-                  (when inter
-                     (error "In BUILD-FINITE-SS, the symbol ~A is present two times."
+	   (declare (list mark1))
+	   (do ((mark2 (rest mark1) (cdr mark2)))
+	       ((endp mark2))
+	     (declare (list mark2))
+	     (let ((inter (intersection (cdar mark1) (cdar mark2)
+					:key #'first)))
+	       (declare (list inter))
+	       (when inter
+		 (error "In BUILD-FINITE-SS, the symbol ~A is present two times."
                         (caar inter))))))
          pre-rslt)))
 
-#|
-  (setf p (finite-ss-pre-table '(0 v0 v1 v2)))
-  (finite-ss-pre-table '(0 v0 v0 v2))
-  (setf p (finite-ss-pre-table '(0 v0 v1 1 e0 e1 e2)))
-  (finite-ss-pre-table '(0 v0 v1 1 e0 e1 v1))
-  (setf p (finite-ss-pre-table '(0 v0 (v0 v0))))
-  (setf p (finite-ss-pre-table '(0 v0 v1 v2 0 v3)))
-  (finite-ss-pre-table '(0 v0 (v0 v0) (v1 v1)))
-  (finite-ss-pre-table '(0 (v0 v0) (v1 v1)))
-  (finite-ss-pre-table '(0 v0 (v0 v0) #(1 2))))
-|#
 
 (DEFUN FINITE-SS-PRE-TABLE-TABLE (pre-table)
-   (declare (list pre-table))
-   (let* ((maxdim (1+ (apply #'max (mapcar #'first pre-table))))
-          (table (make-array maxdim :initial-element +empty-list+)))
-      (declare
-         (fixnum maxdim)
-         (simple-vector table))
-      (dolist (item pre-table)
-         (declare (list item))
-         (setf (svref table (first item))
-               (sort (rest item) #'string< :key #'first)))
-      table))
+  (declare (list pre-table))
+  (let* ((maxdim (1+ (apply #'max (mapcar #'first pre-table))))
+	 (table (make-array maxdim :initial-element +empty-list+)))
+    (declare
+     (fixnum maxdim)
+     (simple-vector table))
+    (dolist (item pre-table)
+      (declare (list item))
+      (setf (svref table (first item))
+	    (sort (rest item) #'string< :key #'first)))
+    table))
 
-#|
-  (setf p (finite-ss-pre-table-table
-             (finite-ss-pre-table '(2 v0 (e1 e2) v1 1 e0 e1 e2)))))
-|#
 
 (DEFUN FINITE-SS-FIND-GMSM (table gmsm dmns &optional (max-dmns (1+ dmns)))
-   (declare
-      (type gmsm gmsm)
-      (fixnum dmns max-dmns))
-   (do ((dmns dmns (1+ dmns)))
-       ((>= dmns max-dmns) nil)
-      (declare (fixnum dmns))
-      (let ((found (find gmsm (svref table dmns) :test #'eq :key #'car)))
-         (declare (type (or cons null) found))
-         (when found
-            (return-from finite-ss-find-gmsm dmns)))))
- 
+  (declare
+   (type gmsm gmsm)
+   (fixnum dmns max-dmns))
+  (do ((dmns dmns (1+ dmns)))
+      ((>= dmns max-dmns) nil)
+    (declare (fixnum dmns))
+    (let ((found (find gmsm (svref table dmns) :test #'eq :key #'car)))
+      (declare (type (or cons null) found))
+      (when found
+	(return-from finite-ss-find-gmsm dmns)))))
+
+
 (DEFUN FINITE-SS-FINISH-TABLE (table bspn)
-   (declare (simple-vector table))
-   (dotimes (dmns (length table))
-      (declare (fixnum dmns))
-      (finite-ss-finish-line table dmns bspn))
-   table)
+  (declare (simple-vector table))
+  (dotimes (dmns (length table))
+    (declare (fixnum dmns))
+    (finite-ss-finish-line table dmns bspn))
+  table)
+
 
 (DEFUN FINITE-SS-FINISH-LINE (table dmns bspn)
-   (declare
-      (simple-vector table)
-      (fixnum dmns))
-   (setf (svref table dmns)
-         (mapcar
-            #'(lambda (entry)
-                 (finite-ss-finish-entry table entry dmns bspn))
-            (svref table dmns))))
+  (declare
+   (simple-vector table)
+   (fixnum dmns))
+  (setf (svref table dmns)
+	(mapcar
+	 #'(lambda (entry)
+	     (finite-ss-finish-entry table entry dmns bspn))
+	 (svref table dmns))))
+
 
 (DEFUN FINITE-SS-FINISH-ENTRY (table entry dmns bspn)
-   (declare
-      (simple-vector table)
-      (list entry)
-      (fixnum dmns)
-      (symbol bspn))
-   (let ((simplex (first entry))
-         (faces (rest entry)))
-      (declare
-         (symbol simplex)
-         (list faces))
-      (when (zerop dmns)
-         (return-from finite-ss-finish-entry
-            (make-gmsm-faces-info
-               :gmsm simplex :faces +s-empty-vector+
-               :bndr +zero-negative-cmbn+)))
-      (setf faces (nconc faces (make-list (1+ (- dmns (length faces)))
-                                  :initial-element bspn)))
-      (let ((rslt (make-gmsm-faces-info :gmsm simplex)))
-         (declare (cons rslt))
-         (flet ((process-face (face)
-                 (declare (type (or symbol list) face))
-                 (when (symbolp face)
-                    (setf face (list face)))
-                 (let* ((gmsm2 (car (last face)))
-                        (dgop-ext (nbutlast face))
-                        (dmns2 (finite-ss-find-gmsm table gmsm2 0 dmns)))
-                    (declare
-                       (symbol gmsm2)
-                       (list dgop-ext)
-                       (type (or fixnum null) dmns2))
-                    (unless dmns2
-                       (error "In BUILD-FINITE-SS, the face ~A is absent." gmsm2))
-                    (when (zerop (length dgop-ext))
-                       (setf dgop-ext (nreverse (<a-b< dmns2 (1- dmns)))))
-                    (unless (= (+ (length dgop-ext) dmns2 1) dmns)
-                       (error "In BUILD-FINITE-SS, the face ~A has a wrong dimension."
+  (declare
+   (simple-vector table)
+   (list entry)
+   (fixnum dmns)
+   (symbol bspn))
+  (let ((simplex (first entry))
+	(faces (rest entry)))
+    (declare
+     (symbol simplex)
+     (list faces))
+    (when (zerop dmns)
+      (return-from finite-ss-finish-entry
+	(make-gmsm-faces-info
+	 :gmsm simplex :faces +s-empty-vector+
+	 :bndr +zero-negative-cmbn+)))
+    (setf faces (nconc faces (make-list (1+ (- dmns (length faces)))
+					:initial-element bspn)))
+    (let ((rslt (make-gmsm-faces-info :gmsm simplex)))
+      (declare (cons rslt))
+      (flet ((process-face (face)
+	       (declare (type (or symbol list) face))
+	       (when (symbolp face)
+		 (setf face (list face)))
+	       (let* ((gmsm2 (car (last face)))
+		      (dgop-ext (nbutlast face))
+		      (dmns2 (finite-ss-find-gmsm table gmsm2 0 dmns)))
+		 (declare
+		  (symbol gmsm2)
+		  (list dgop-ext)
+		  (type (or fixnum null) dmns2))
+		 (unless dmns2
+		   (error "In BUILD-FINITE-SS, the face ~A is absent." gmsm2))
+		 (when (zerop (length dgop-ext))
+		   (setf dgop-ext (nreverse (<a-b< dmns2 (1- dmns)))))
+		 (unless (= (+ (length dgop-ext) dmns2 1) dmns)
+		   (error "In BUILD-FINITE-SS, the face ~A has a wrong dimension."
                           (append dgop-ext (list gmsm2))))
-                    (absm (dgop-ext-int dgop-ext) gmsm2))))
-            (setf (info-faces rslt)
-                  (map 'simple-vector #'process-face faces))
-            (setf (info-bndr rslt)
-                  (apply #'nterm-add #'s-cmpr (1- dmns)
+		 (absm (dgop-ext-int dgop-ext) gmsm2))))
+	(setf (info-faces rslt)
+	      (map 'simple-vector #'process-face faces))
+	(setf (info-bndr rslt)
+	      (apply #'nterm-add #'s-cmpr (1- dmns)
                      (do ((rslt +empty-list+)
                           (faces (info-faces rslt))
                           (indx dmns (1- indx)))
                          ((minusp indx) rslt)
-                        (declare
-                           (list rslt)
-                           (simple-vector faces)
-                           (fixnum indx))
-                        (let ((face (svref faces indx)))
-                           (declare (type absm face))
-                           (unless (degenerate-p face)
-                              (push (term (-1-expt-n indx) (gmsm face))
+		       (declare
+			(list rslt)
+			(simple-vector faces)
+			(fixnum indx))
+		       (let ((face (svref faces indx)))
+			 (declare (type absm face))
+			 (unless (degenerate-p face)
+			   (push (term (-1-expt-n indx) (gmsm face))
                                  rslt))))))
-            rslt))))
+	rslt))))
+
 
 (DEFUN FINITE-SS-TABLE (list)
-   (declare (list list))
-   (setf list (cons 0 list))
-   (let* ((bspn (second list))
-          (pre-table (finite-ss-pre-table list))
-          (table (finite-ss-pre-table-table pre-table)))
-      (declare
-         (symbol bspn)
-         (list pre-table)
-         (simple-vector table))
-      ;; (vector (vector gmsm-faces-info))
-      (finite-ss-finish-table table bspn)))
+  (declare (list list))
+  (setf list (cons 0 list))
+  (let* ((bspn (second list))
+	 (pre-table (finite-ss-pre-table list))
+	 (table (finite-ss-pre-table-table pre-table)))
+    (declare
+     (symbol bspn)
+     (list pre-table)
+     (simple-vector table))
+    ;; (vector (vector gmsm-faces-info))
+    (finite-ss-finish-table table bspn)))
 
-#|
-  (finite-ss-table '(*))
-  (finite-ss-table '(a b))
-  (finite-ss-table '(a b 1 c (b a)))
-  (finite-ss-table '(* 2 s2 3 s3))
-  (finite-ss-table '(s0 s1 s2 1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1) 2 s012 (s12 s02 s01)))
-  (finite-ss-table '(* 4 s4 ((2 1 0 *))))
-  (finite-ss-table '(* 4 s4 ((1 1 0 *))))
-  (finite-ss-table '(* 1 s (t)))
-  (finite-ss-table '(* 4 s4 ((1 0 *)))))
-|#
 
 (DEFUN FINITE-SS-BASIS (table)
-   (declare (simple-vector table))
-   (flet ((rslt (dmns)
-             (declare (fixnum dmns))
-             (the list
+  (declare (simple-vector table))
+  (flet ((rslt (dmns)
+	   (declare (fixnum dmns))
+	   (the list
                 (if (< -1 dmns (length table))
-                   (mapcar #'car (svref table dmns))
-                   +empty-list+))))
-      #'rslt))
+		    (mapcar #'car (svref table dmns))
+		    +empty-list+))))
+    #'rslt))
+
 
 (DEFUN FINITE-SS-FACE (ind-smst table)
-   (declare
-      (symbol ind-smst)
-      (simple-vector table))
-   (flet ((rslt (indx dmns gmsm)
+  (declare
+   (symbol ind-smst)
+   (simple-vector table))
+  (flet ((rslt (indx dmns gmsm)
            (declare
-              (fixnum indx dmns)
-              (symbol gmsm))
+	    (fixnum indx dmns)
+	    (symbol gmsm))
            (let ((found (find gmsm (svref table dmns) :key #'car)))
-              (unless found
-                 (error "In the finite simplicial set ~A,~@
-                         the simplex ~A is absent in dimension ~D." (eval ind-smst) gmsm dmns))
-              (svref (info-faces found) indx))))
-      #'rslt))
+	     (unless found
+	       (error "In the finite simplicial set ~A,~@
+                         the simplex ~A is absent in dimension ~D."
+		      (eval ind-smst) gmsm dmns))
+	     (svref (info-faces found) indx))))
+    #'rslt))
+
 
 (DEFUN FINITE-SS-INTR-BNDR (ind-smst table)
-   (declare
-      (symbol ind-smst)
-      (simple-vector table))
-   (flet ((rslt (dmns gmsm)
+  (declare
+   (symbol ind-smst)
+   (simple-vector table))
+  (flet ((rslt (dmns gmsm)
            (declare
-              (fixnum dmns)
-              (symbol gmsm))
+	    (fixnum dmns)
+	    (symbol gmsm))
            (let ((found (find gmsm (svref table dmns) :key #'car)))
-              (unless found
-                 (error "In the finite simplicial set ~A,~@
+	     (unless found
+	       (error "In the finite simplicial set ~A,~@
                          the simplex ~A is absent in dimension ~D." (eval ind-smst) gmsm dmns))
-              (info-bndr found))))
-      #'rslt))
+	     (info-bndr found))))
+    #'rslt))
+
 
 (DEFUN BUILD-FINITE-SS (list)
-   (declare (list list))
-   (let ((bspn (first list))
-         (table (finite-ss-table list))
-         (ind-smst (gensym)))
-      (declare
-         (symbol bspn ind-smst)
-         (simple-vector table))
-      ;;  (vector (vector gmsm-faces-info))
-      (let ((rslt (build-smst
-                     :cmpr #'s-cmpr
-                     :basis (finite-ss-basis table)
-                     :bspn bspn
-                     :face (finite-ss-face ind-smst table)
-                     :intr-bndr (finite-ss-intr-bndr ind-smst table)
-                     :bndr-strt :gnrt
-                     :orgn `(build-finite-ss ,list))))
-         (setf (symbol-value ind-smst) rslt)
-         (unless (check-smst rslt 0 (length table))
-            (pop *smst-list*)
-            (pop *chcm-list*)
-            (pop *mrph-list*)
-            (return-from build-finite-ss nil))
-         rslt)))
+  (declare (list list))
+  (let ((bspn (first list))
+	(table (finite-ss-table list))
+	(ind-smst (gensym)))
+    (declare
+     (symbol bspn ind-smst)
+     (simple-vector table))
+    ;;  (vector (vector gmsm-faces-info))
+    (let ((rslt (build-smst
+		 :cmpr #'s-cmpr
+		 :basis (finite-ss-basis table)
+		 :bspn bspn
+		 :face (finite-ss-face ind-smst table)
+		 :intr-bndr (finite-ss-intr-bndr ind-smst table)
+		 :bndr-strt :gnrt
+		 :orgn `(build-finite-ss ,list))))
+      (setf (symbol-value ind-smst) rslt)
+      (inspect rslt)
+      (unless (check-smst rslt 0 (length table))
+	(pop *smst-list*)
+	(pop *chcm-list*)
+	(pop *mrph-list*)
+	(return-from build-finite-ss nil))
+      rslt)))
 
-#|
-()
-(cat-init)
-(setf tr (build-finite-ss '(s0 s1 s2
-                               1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
-                               2 s012 (s12 s02 s01))))
-(cmpr tr 's01 's02)
-(basis tr 2)
-(bspn tr)
-(face tr 1 2 's012)
-(? tr 2 's012)
-(? tr *)
-(inspect tr)
-(mapcar #'(lambda (s) (length (eval s))) *list-list*)
-(setf tr (build-finite-ss '(s0 s1 s2
-                               1 s01 (s1 s1) s02 (s2 s0) s12 (s2 s1)
-                               2 s012 (s12 s02 s01))))
-(mapcar #'(lambda (s) (length (eval s))) *list-list*))
-|#
 
 (DEFUN SPHERE-CMPR (gmsm1 gmsm2)
-   (declare (ignore gmsm1 gmsm2))
-   (the cmpr :equal))
+  (declare (ignore gmsm1 gmsm2))
+  (the cmpr :equal))
+
 
 (DEFUN SPHERE-BASIS (dmns)
-   (declare (fixnum dmns))
-   (let ((fund-gmsm (intern (format nil "S~D" dmns))))
-      (declare (symbol fund-gmsm))
-      (flet ((rslt (dmns2)
-                (declare (fixnum dmns2))
-                (cond ((zerop dmns2)
-                       (list '*))
-                      ((= dmns2 dmns)
-                       (list fund-gmsm))
-                      (t
-                         +empty-list+))))
-         (the basis #'rslt))))
+  (declare (fixnum dmns))
+  (let ((fund-gmsm (intern (format nil "S~D" dmns))))
+    (declare (symbol fund-gmsm))
+    (flet ((rslt (dmns2)
+	     (declare (fixnum dmns2))
+	     (cond ((zerop dmns2)
+		    (list '*))
+		   ((= dmns2 dmns)
+		    (list fund-gmsm))
+		   (t
+		    +empty-list+))))
+      (the basis #'rslt))))
+
 
 (DEFUN SPHERE-FACE (dmns)
-   (declare (fixnum dmns))
-   (let ((face (absm (mask (1- dmns)) '*)))
-      (declare (type absm face))
-      (flet ((rslt (indx dmns2 gmsm)
-                (declare (ignore indx dmns2 gmsm))
-                (the absm face)))
-         #'rslt)))
+  (declare (fixnum dmns))
+  (let ((face (absm (mask (1- dmns)) '*)))
+    (declare (type absm face))
+    (flet ((rslt (indx dmns2 gmsm)
+	     (declare (ignore indx dmns2 gmsm))
+	     (the absm face)))
+      #'rslt)))
+
 
 (DEFUN SPHERE (dmns)
-   (declare (fixnum dmns))
-   (unless (plusp dmns)
-      (error "In SPHERE, the dimension ~D should be positive." dmns))
-   (unless (< dmns +maximal-dimension+)
-      (error "In SPHERE, the dimension ~D should be < ~D."
-         dmns +maximal-dimension+))
-   (the simplicial-set
-      (let ((rslt (build-smst
-                     :cmpr #'sphere-cmpr
-                     :basis (sphere-basis dmns)
-                     :bspn '*
-                     :face (sphere-face dmns)
-                     :intr-bndr #'zero-intr-dffr
-                     :bndr-strt :cmbn
-                     :orgn `(sphere ,dmns))))
+  (declare (fixnum dmns))
+  (unless (plusp dmns)
+    (error "In SPHERE, the dimension ~D should be positive." dmns))
+  (unless (< dmns +maximal-dimension+)
+    (error "In SPHERE, the dimension ~D should be < ~D."
+	   dmns +maximal-dimension+))
+  (the simplicial-set
+       (let ((rslt (build-smst
+		    :cmpr #'sphere-cmpr
+		    :basis (sphere-basis dmns)
+		    :bspn '*
+		    :face (sphere-face dmns)
+		    :intr-bndr #'zero-intr-dffr
+		    :bndr-strt :cmbn
+		    :orgn `(sphere ,dmns))))
          (declare (type simplicial-set rslt))
          (setf (slot-value (bndr rslt) 'orgn)
                `(zero-mrph ,rslt ,rslt -1))
          rslt)))
 
-#|
-  (cat-init)
-  (setf s3 (sphere 3))
-  (funcall (cmpr s3) 's3 's3)
-  (dotimes (i 5)
-     (print (funcall (basis s3) i)))
-  (mapcar #'(lambda (i) (funcall (face s3) i 3 's3)) (<a-b> 0 3))
-  (? s3 3 's3)
-  (smst (idnm s3))
-  (chcm (idnm s3))
-  (setf d (bndr s3))
-  (add d d))
-|#
 
 (DEFUN SPHERE-WEDGE-BASIS (dmns-list)
-   (declare (list dmns-list))
-   (flet ((rslt (dmns)
-             (declare (fixnum dmns))
-             (when (zerop dmns)
-                (return-from rslt '(*)))
-             (do ((i (count dmns dmns-list) (1- i))
-                  (basis +empty-list+
-                         (cons (intern (format nil "S~D-~D" dmns i))
-                               basis)))
-                 ((zerop i) basis)
-                (declare
-                   (fixnum i)
-                   (list basis)))))
-      (the basis #'rslt)))
+  (declare (list dmns-list))
+  (flet ((rslt (dmns)
+	   (declare (fixnum dmns))
+	   (when (zerop dmns)
+	     (return-from rslt '(*)))
+	   (do ((i (count dmns dmns-list) (1- i))
+		(basis +empty-list+
+		       (cons (intern (format nil "S~D-~D" dmns i))
+			     basis)))
+	       ((zerop i) basis)
+	     (declare
+	      (fixnum i)
+	      (list basis)))))
+    (the basis #'rslt)))
+
 
 (DEFUN SPHERE-WEDGE-FACE (indx dmns gmsm)
-   (declare
-      (ignore indx gmsm)
-      (fixnum dmns))
-   (the absm
-      (absm (mask (1- dmns)) '*)))
+  (declare
+   (ignore indx gmsm)
+   (fixnum dmns))
+  (the absm
+       (absm (mask (1- dmns)) '*)))
 
 (DEFUN SPHERE-WEDGE (&rest dmns-list)
-   (declare (list dmns-list))
-   (the simplicial-set
-      (let ((rslt (build-smst
-                     :cmpr #'s-cmpr
-                     :basis (sphere-wedge-basis dmns-list)
-                     :face #'sphere-wedge-face
-                     :intr-bndr #'zero-intr-dffr
-                     :bndr-strt :cmbn
-                     :orgn `(sphere-wedge ,@dmns-list))))
+  (declare (list dmns-list))
+  (the simplicial-set
+       (let ((rslt (build-smst
+		    :cmpr #'s-cmpr
+		    :basis (sphere-wedge-basis dmns-list)
+		    :face #'sphere-wedge-face
+		    :intr-bndr #'zero-intr-dffr
+		    :bndr-strt :cmbn
+		    :orgn `(sphere-wedge ,@dmns-list))))
          (declare (type simplicial-set rslt))
          (setf (slot-value (bndr rslt) 'orgn)
                `(zero-mrph ,rslt ,rslt -1))
          rslt)))
 
-#|
-  (cat-init)
-  (setf w (sphere-wedge 3 2 3))
-  (funcall (cmpr w) 's3-1 's3-2)
-  (dotimes (i 5) (print (funcall (basis w) i)))
-  (funcall (face w) 2 3 's3-1)
-  (gnrt-? (bndr w) 3 's3-2))
-|#
 
 (DEFUN MOORE-CMPR (gmsm1 gmsm2)
-   (declare (ignore gmsm1 gmsm2))
-   (the cmpr :equal))
+  (declare (ignore gmsm1 gmsm2))
+  (the cmpr :equal))
+
 
 (DEFUN MOORE-BASIS (dmns)
-   (declare (fixnum dmns))
-   (let ((lgmsm1 (list (intern (format nil "M~D" dmns))))
-         (lgmsm2 (list (intern (format nil "N~D" (1+ dmns))))))
-      (declare (list lgmsm1 lgmsm2))
-      (flet ((rslt (dmns2)
-                (declare (fixnum dmns2))
-                (cond ((zerop dmns2) '(*))
-                      ((= dmns dmns2) lgmsm1)
-                      ((= (1+ dmns) dmns2) lgmsm2)
-                      (t +empty-list+))))
-         (the basis #'rslt))))
+  (declare (fixnum dmns))
+  (let ((lgmsm1 (list (intern (format nil "M~D" dmns))))
+	(lgmsm2 (list (intern (format nil "N~D" (1+ dmns))))))
+    (declare (list lgmsm1 lgmsm2))
+    (flet ((rslt (dmns2)
+	     (declare (fixnum dmns2))
+	     (cond ((zerop dmns2) '(*))
+		   ((= dmns dmns2) lgmsm1)
+		   ((= (1+ dmns) dmns2) lgmsm2)
+		   (t +empty-list+))))
+      (the basis #'rslt))))
+
 
 (DEFUN MOORE-FACE (pii dmns)
-   (declare (fixnum pii dmns))
-   (let ((face (absm 0 (intern (format nil "M~D" dmns))))
-         (bspn1 (absm (mask (1- dmns)) '*))
-         (bspn2 (absm (mask dmns) '*))
-         (2pii (ash pii 1)))
-      (declare
-         (type absm face)
-         (type absm bspn1 bspn2)
-         (fixnum 2pii))
-      (flet ((rslt (indx dmns2 gmsm)
-                (declare
-                   (fixnum indx dmns2)
-                   (ignore gmsm))
-                (the absm
-                   (if (= dmns dmns2)
+  (declare (fixnum pii dmns))
+  (let ((face (absm 0 (intern (format nil "M~D" dmns))))
+	(bspn1 (absm (mask (1- dmns)) '*))
+	(bspn2 (absm (mask dmns) '*))
+	(2pii (ash pii 1)))
+    (declare
+     (type absm face)
+     (type absm bspn1 bspn2)
+     (fixnum 2pii))
+    (flet ((rslt (indx dmns2 gmsm)
+	     (declare
+	      (fixnum indx dmns2)
+	      (ignore gmsm))
+	     (the absm
+		  (if (= dmns dmns2)
                       bspn1
                       (if (oddp indx)
-                         bspn2
-                         (if (< indx 2pii)
-                            face
-                            bspn2))))))
-         (the face #'rslt))))
+			  bspn2
+			  (if (< indx 2pii)
+			      face
+			      bspn2))))))
+      (the face #'rslt))))
+
 
 (DEFUN MOORE-INTR-BNDR (pii dmns)
-   (declare (fixnum pii dmns))
-   (let ((1+dmns (1+ dmns))
-         (gmsm1 (intern (format nil "M~D" dmns))))
-      (declare
-         (fixnum 1+dmns)
-         (type symbol gmsm1))
-      (flet ((rslt (cmbn)
-                (declare
-                   (type cmbn cmbn))
-                (with-cmbn (degr list) cmbn
-                   (unless list
-                      (return-from rslt (zero-cmbn (1- (cmbn-degr cmbn)))))
-                   (if (= degr 1+dmns)
-                      (term-cmbn dmns (* (cffc (first list)) pii) gmsm1)
-                      (zero-cmbn (1- (cmbn-degr cmbn)))))))
-         (the intr-mrph #'rslt))))
+  (declare (fixnum pii dmns))
+  (let ((1+dmns (1+ dmns))
+	(gmsm1 (intern (format nil "M~D" dmns))))
+    (declare
+     (fixnum 1+dmns)
+     (type symbol gmsm1))
+    (flet ((rslt (cmbn)
+	     (declare
+	      (type cmbn cmbn))
+	     (with-cmbn (degr list) cmbn
+			(unless list
+			  (return-from rslt (zero-cmbn (1- (cmbn-degr cmbn)))))
+			(if (= degr 1+dmns)
+			    (term-cmbn dmns (* (cffc (first list)) pii) gmsm1)
+			    (zero-cmbn (1- (cmbn-degr cmbn)))))))
+      (the intr-mrph #'rslt))))
+
 
 (DEFUN MOORE (pii dmns)
-   (declare (fixnum pii dmns))
-   (the simplicial-set
-      (build-smst
-         :cmpr #'moore-cmpr
-         :basis (moore-basis dmns)
-         :face (moore-face pii dmns)
-         :intr-bndr (moore-intr-bndr pii dmns)
-         :bndr-strt :cmbn
-         :orgn `(moore ,pii ,dmns))))
+  (declare (fixnum pii dmns))
+  (the simplicial-set
+       (build-smst
+	:cmpr #'moore-cmpr
+	:basis (moore-basis dmns)
+	:face (moore-face pii dmns)
+	:intr-bndr (moore-intr-bndr pii dmns)
+	:bndr-strt :cmbn
+	:orgn `(moore ,pii ,dmns))))
 
-#|
-  (cat-init)
-  (setf m4 (moore 2 4))
-  (cmpr m4 'n5 'n5)
-  (dotimes (i 7)
-     (print (basis m4 i)))
-  (mapcar #'(lambda (i) (face m4 i 5 'n5)) (<a-b> 0 5))
-  (? m4 4 'm4)
-  (? m4 5 'n5))
-|#
 
 (DEFUN R-PROJ-SPACE-CMPR (gmsm1 gmsm2)
-   (declare (ignore gmsm1 gmsm2))
-   (the cmpr :equal))
+  (declare (ignore gmsm1 gmsm2))
+  (the cmpr :equal))
+
 
 (DEFUN R-PROJ-SPACE-BASIS (k l)
   (declare (fixnum k) (type (or (eql :infinity) fixnum) l))
   (the basis
-    (progn
-      (when (eq l :infinity)
-        (setf l most-positive-fixnum))
-      (flet
-          ((rslt (dmns)
-                 (declare (fixnum dmns))
-                 (the list
-                   (if (or (minusp dmns)
-                           (< 0 dmns k)
-                           (>= dmns l))
-                       +empty-list+
-                     (list dmns)))))
-        (the basis #'rslt)))))
+       (progn
+	 (when (eq l :infinity)
+	   (setf l most-positive-fixnum))
+	 (flet
+	     ((rslt (dmns)
+		(declare (fixnum dmns))
+		(the list
+		     (if (or (minusp dmns)
+			     (< 0 dmns k)
+			     (>= dmns l))
+			 +empty-list+
+			 (list dmns)))))
+	   (the basis #'rslt)))))
 
-#|
-()
-(setf b (r-proj-space-basis 1 :infinity))
-(dotimes (i 5) (print (funcall b i)))
-(setf b (r-proj-space-basis 1 5))
-(dotimes (i 8) (print (funcall b i)))
-(setf b (r-proj-space-basis 3 :infinity))
-(dotimes (i 5) (print (funcall b i)))
-(setf b (r-proj-space-basis 3 6))
-(dotimes (i 10) (print (funcall b i)))
-|#
 
 (DEFUN R-PROJ-SPACE-FACE (k)
-   (declare (fixnum k))
-   (flet ((rslt (indx dmns gmsm)
+  (declare (fixnum k))
+  (flet ((rslt (indx dmns gmsm)
            (declare
-	      (fixnum indx dmns)
-	      (ignore gmsm))
+	    (fixnum indx dmns)
+	    (ignore gmsm))
            (if (<= dmns k)
-              (absm (mask (1- dmns)) 0)
-              (if (or (zerop indx)
-                      (= indx dmns))
-                 (absm 0 (1- dmns))
-                 (if (= dmns (1+ k))
-                    (absm (mask (1- dmns)) 0)
-                    (absm (2-exp (1- indx)) (- dmns 2)))))))
-      (the face #'rslt)))
+	       (absm (mask (1- dmns)) 0)
+	       (if (or (zerop indx)
+		       (= indx dmns))
+		   (absm 0 (1- dmns))
+		   (if (= dmns (1+ k))
+		       (absm (mask (1- dmns)) 0)
+		       (absm (2-exp (1- indx)) (- dmns 2)))))))
+    (the face #'rslt)))
+
 
 (DEFUN R-PROJ-SPACE-INTR-BNDR (k)
-   (declare (fixnum k))
-   (flet ((rslt (cmbn)
+  (declare (fixnum k))
+  (flet ((rslt (cmbn)
            (declare (type cmbn cmbn))
            (with-cmbn (degr list) cmbn
-              (unless list
-                 (return-from rslt (zero-cmbn (1- degr))))
-              (if (<= degr k)
-                 (zero-cmbn (1- degr))
-                 (if (evenp degr)
-                    (make-cmbn
-                       :degr (1- degr)
-                       :list (list (term (* 2 (-cffc list)) (1- degr))))
-                    (zero-cmbn (1- degr)))))))
-      (the intr-mrph #'rslt)))
+		      (unless list
+			(return-from rslt (zero-cmbn (1- degr))))
+		      (if (<= degr k)
+			  (zero-cmbn (1- degr))
+			  (if (evenp degr)
+			      (make-cmbn
+			       :degr (1- degr)
+			       :list (list (term (* 2 (-cffc list)) (1- degr))))
+			      (zero-cmbn (1- degr)))))))
+    (the intr-mrph #'rslt)))
 
 (DEFUN R-PROJ-SPACE (&optional (l :infinity) (k 1))
   (declare (fixnum k) (type (or fixnum (eql :infinity))))
@@ -540,40 +473,17 @@
         (plusp k)
         (or (eq l :infinity)
             (and (typep l 'fixnum)
-                 (<= k l)))))    
+                 (<= k l)))))
   (the simplicial-set
-    (build-smst
-     :cmpr #'R-proj-space-cmpr
-     :basis (R-proj-space-basis k l)
-     :bspn 0
-     :face (R-proj-space-face k)
-     :intr-bndr (R-proj-space-intr-bndr k)
-     :bndr-strt :cmbn
-     :orgn `(R-proj-space ,k ,l))))
+       (build-smst
+	:cmpr #'R-proj-space-cmpr
+	:basis (R-proj-space-basis k l)
+	:bspn 0
+	:face (R-proj-space-face k)
+	:intr-bndr (R-proj-space-intr-bndr k)
+	:bndr-strt :cmbn
+	:orgn `(R-proj-space ,k ,l))))
 
-#|
-()
-(cat-init)
-(setf p (R-proj-space))
-(basis p 4)
-(dotimes (i 5)
-  (print (face p i 4 4)))
-(dotimes (i 5)
-  (print (? p i i)))
-(setf dd (cmps p p))
-(dotimes (i 6)
-  (print (? dd i i)))
-(setf p (R-proj-space 3))
-(dotimes (i 7)
-  (print (basis p i)))
-(dotimes (i 5)
-  (print (face p i 4 4)))
-(dotimes (i 7)
-  (print (? p i i)))
-(setf dd (cmps p p))
-(dotimes (i 7)
-  (print (? dd i i)))
-|#
 
 ;;; Constructing a small simplicial subset
 ;;; from a combination of simplices.
@@ -581,24 +491,21 @@
 (DEFUN CMBN-GMSMS (cmbn)
   (declare (type cmbn cmbn))
   (the list
-    ;; Returns a list made of:
-    ;;   the degree of the combination;
-    ;;   the list of simplex generators of the combinations.
-    (cons (cmbn-degr cmbn) (mapcar #'cdr (cmbn-list cmbn)))))
+       ;; Returns a list made of:
+       ;;   the degree of the combination;
+       ;;   the list of simplex generators of the combinations.
+       (cons (cmbn-degr cmbn) (mapcar #'cdr (cmbn-list cmbn)))))
 
-#|
-()
-|#
 
 (DEFUN GMSMS-SUBSMST (smst gmsms
-                           &aux
-                           (dmns (typecase gmsms
-                                   (cmbn (cmbn-degr gmsms))
-                                   (otherwise (first gmsms))))
-                           (cmpr= #'(lambda (gmsm1 gmsm2)
-                                      (declare (type gmsm gmsm1 gmsm2))
-                                      (the boolean
-                                        (eq (cmpr smst gmsm1 gmsm2) :equal)))))                           
+		      &aux
+			(dmns (typecase gmsms
+				(cmbn (cmbn-degr gmsms))
+				(otherwise (first gmsms))))
+			(cmpr= #'(lambda (gmsm1 gmsm2)
+				   (declare (type gmsm gmsm1 gmsm2))
+				   (the boolean
+                                        (eq (cmpr smst gmsm1 gmsm2) :equal)))))
   (declare
    (type simplicial-set smst)
    (type (or cmbn list) gmsms)
@@ -607,82 +514,43 @@
   (when (typep gmsms 'cmbn)
     (setf gmsms (cmbn-gmsms gmsms)))
   (the (values simplicial-set morphism)
-    (let ((prslt (make-array (1+ dmns) :initial-element +empty-list+)))
-      (declare (type simple-vector prslt))
-      (setf (svref prslt dmns) (rest gmsms))
-      (do ((d dmns (1- d)))
-          ((zerop d))
-        (declare (fixnum d))
-        (dolist (gmsm (svref prslt d))
-          (declare (type gmsm gmsm))
-          (dotimes (iface (1+ d))
-            (declare (fixnum iface))
-            (with-absm (dgop gmsm) (face smst iface d gmsm)
-                       (declare (fixnum dgop) (type gmsm gmsm))
-              (pushnew gmsm (svref prslt (- d 1 (logcount dgop)))
-                       :test cmpr=)))))
-      (let ((rslt-basis #'(lambda (k)
-                            (declare (fixnum dmns))
-                            (the list
-                              (if (<= 0 k dmns) 
-                                  (aref prslt k)
-                                +empty-list+)))))
-        (declare (type (function (fixnum) list) rslt-basis))
-        (let ((subsmst (build-smst
-                        :cmpr (cmpr smst)
-                        :basis rslt-basis
-                        :bspn (let ((bspn (bspn smst)))
-                                (declare (type gmsm bspn))
-                                (pushnew bspn (svref prslt 0) :test cmpr=)
-                                bspn)
-                        :face (face smst)
-                        :orgn `(gmsms-subsmst ,gmsms))))
-          (declare (type simplicial-set subsmst))
-          (values subsmst
-                  (build-mrph :sorc subsmst
-                              :trgt smst
-                              :degr 0
-                              :intr #'(lambda (cmbn)
-                                        (declare (type cmbn cmbn))
-                                        (the cmbn cmbn))
-                              :strt :cmbn
-                              :orgn `(gmsms-subsmst-incl ,gmsms))))))))
-                            
-                            
-                            
-#|
-()
-(cat-init)
-(setf k (k-z 2))
-(setf efhm (efhm k))
-(setf *homology-verbose* nil)
-(chcm-homology-gen (rbcc efhm) 4)
-(setf g (first *))
-(setf cmbn (lf efhm (rg efhm g)))
-(multiple-value-setq (kf incl) (gmsms-subsmst k cmbn))
-(setf cone (cone incl))
-(efhm cone)
-(homology kf 0 5)
-(homology (cone incl) 0 6)
-
-(chcm-homology-gen (rbcc efhm) 8)
-(setf g (first *))
-(setf cmbn (lf efhm (rg efhm g)))
-(multiple-value-setq (kf incl) (gmsms-subsmst k cmbn))
-(setf cone (cone incl))
-(efhm cone)
-(homology kf 0 9)
-(homology (cone incl) 0 10)
-(dotimes (i 9) (print (length (basis kf i))))
-
-()
-(setf s2 (sphere 2))
-(setf cl2 (chml-clss s2 2))
-(setf f2 (z-whitehead s2 cl2))
-(setf s3 (fibration-total f2))
-(setf efhm (efhm s3))
-(basis (rbcc efhm) 3)
-(setf cmbn (lf efhm (rg efhm 3 (first (basis (rbcc efhm) 3)))))
-(setf kf (gmsms-subsmst s3 cmbn))
-(homology kf 0 4)
-|#
+       (let ((prslt (make-array (1+ dmns) :initial-element +empty-list+)))
+	 (declare (type simple-vector prslt))
+	 (setf (svref prslt dmns) (rest gmsms))
+	 (do ((d dmns (1- d)))
+	     ((zerop d))
+	   (declare (fixnum d))
+	   (dolist (gmsm (svref prslt d))
+	     (declare (type gmsm gmsm))
+	     (dotimes (iface (1+ d))
+	       (declare (fixnum iface))
+	       (with-absm (dgop gmsm) (face smst iface d gmsm)
+			  (declare (fixnum dgop) (type gmsm gmsm))
+			  (pushnew gmsm (svref prslt (- d 1 (logcount dgop)))
+				   :test cmpr=)))))
+	 (let ((rslt-basis #'(lambda (k)
+			       (declare (fixnum dmns))
+			       (the list
+				    (if (<= 0 k dmns)
+					(aref prslt k)
+					+empty-list+)))))
+	   (declare (type (function (fixnum) list) rslt-basis))
+	   (let ((subsmst (build-smst
+			   :cmpr (cmpr smst)
+			   :basis rslt-basis
+			   :bspn (let ((bspn (bspn smst)))
+				   (declare (type gmsm bspn))
+				   (pushnew bspn (svref prslt 0) :test cmpr=)
+				   bspn)
+			   :face (face smst)
+			   :orgn `(gmsms-subsmst ,gmsms))))
+	     (declare (type simplicial-set subsmst))
+	     (values subsmst
+		     (build-mrph :sorc subsmst
+				 :trgt smst
+				 :degr 0
+				 :intr #'(lambda (cmbn)
+					   (declare (type cmbn cmbn))
+					   (the cmbn cmbn))
+				 :strt :cmbn
+				 :orgn `(gmsms-subsmst-incl ,gmsms))))))))
diff --git a/test/special-smsts-test.lisp b/test/special-smsts-test.lisp
new file mode 100644
index 0000000..ead3165
--- /dev/null
+++ b/test/special-smsts-test.lisp
@@ -0,0 +1,162 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(test finite-ss-pre-table
+      (let ((p (cat:finite-ss-pre-table '(0 v0 v1 v2))))
+	(signals simple-error (cat:finite-ss-pre-table '(0 v0 v0 v2)))
+	(setf p (cat:finite-ss-pre-table '(0 v0 v1 1 e0 e1 e2)))
+	(signals simple-error (cat:finite-ss-pre-table '(0 v0 v1 1 e0 e1 v1)))
+	(setf p (cat:finite-ss-pre-table '(0 v0 (v0 v0))))
+	(setf p (cat:finite-ss-pre-table '(0 v0 v1 v2 0 v3)))
+	(signals simple-error (cat:finite-ss-pre-table '(0 v0 (v0 v0)
+							 (v1 v1))))
+	(signals simple-error (cat:finite-ss-pre-table '(0 (v0 v0) (v1 v1))))
+	(signals simple-error (cat:finite-ss-pre-table '(0 v0 (v0 v0)
+							 #(1 2))))))
+
+
+(test finite-ss-pre-table-table
+      (let ((p (cat:finite-ss-pre-table-table
+		(cat:finite-ss-pre-table '(2 v0 (e1 e2) v1 1 e0 e1 e2)))))))
+
+
+(test finite-ss-table
+      (cat:finite-ss-table '(*))
+      (cat:finite-ss-table '(a b))
+      (cat:finite-ss-table '(a b 1 c (b a)))
+      (cat:finite-ss-table '(* 2 s2 3 s3))
+      (cat:finite-ss-table '(s0 s1 s2 1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
+			     2 s012 (s12 s02 s01)))
+      (cat:finite-ss-table '(* 4 s4 ((2 1 0 *))))
+      (signals simple-error (cat:finite-ss-table '(* 4 s4 ((1 1 0 *)))))
+      (signals simple-error (cat:finite-ss-table '(* 1 s (t))))
+      (signals simple-error (cat:finite-ss-table '(* 4 s4 ((1 0 *))))))
+
+
+#|
+TR is NIL. Why?
+
+(test build-finite-ss
+      (cat:cat-init)
+      (let (tr (cat:build-finite-ss '(s0 s1 s2
+				      1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
+				      2 s012 (s12 s02 s01))))
+	(cat:cmpr tr 's01 's02)
+        (cat:basis tr 2)
+	(cat:bspn tr)
+	(cat:face tr 1 2 's012)
+	(cat:? tr 2 's012)
+	(cat:? tr (cat:? tr 2 's012))
+	(mapcar #'(lambda (s) (length (eval s))) cat:*list-list*)
+	(setf tr (cat:build-finite-ss '(s0 s1 s2
+					1 s01 (s1 s1) s02 (s2 s0) s12 (s2 s1)
+					2 s012 (s12 s02 s01))))
+	(mapcar #'(lambda (s) (length (eval s))) cat:*list-list*)))
+|#
+
+(test sphere
+      (cat:cat-init)
+      (let ((s3 (cat:sphere 3))
+	    d)
+	(funcall (cat:cmpr s3) 's3 's3)
+	(dotimes (i 5)
+	  (print (funcall (cat:basis s3) i)))
+	(mapcar #'(lambda (i) (funcall (cat:face s3) i 3 's3)) (cat:<a-b> 0 3))
+	(cat:? s3 3 's3)
+	(cat:smst (cat:idnm s3))
+	(cat:chcm (cat:idnm s3))
+	(setf d (cat:bndr s3))
+	(cat:add d d)))
+
+
+(test sphere-wedge
+      (cat:cat-init)
+      (let ((w (cat:sphere-wedge 3 2 3)))
+	(funcall (cat:cmpr w) 's3-1 's3-2)
+	(dotimes (i 5) (print (funcall (cat:basis w) i)))
+	(funcall (cat:face w) 2 3 's3-1)
+	(cat:gnrt-? (cat:bndr w) 3 's3-2)))
+
+
+(test moore
+      (cat:cat-init)
+      (let ((m4 (cat:moore 2 4)))
+	(cat:cmpr m4 'n5 'n5)
+	(dotimes (i 7)
+	  (print (cat:basis m4 i)))
+	(mapcar #'(lambda (i) (cat:face m4 i 5 'n5)) (cat:<a-b> 0 5))
+	(cat:? m4 4 'm4)
+	(cat:? m4 5 'n5)))
+
+
+(test r-proj-space-basis
+      (let ((b (cat:r-proj-space-basis 1 :infinity)))
+	(dotimes (i 5) (print (funcall b i)))
+	(setf b (cat:r-proj-space-basis 1 5))
+	(dotimes (i 8) (print (funcall b i)))
+	(setf b (cat:r-proj-space-basis 3 :infinity))
+	(dotimes (i 5) (print (funcall b i)))
+	(setf b (cat:r-proj-space-basis 3 6))
+	(dotimes (i 10) (print (funcall b i)))))
+
+
+(test R-proj-space
+      (cat:cat-init)
+      (let ((p (cat:R-proj-space)))
+	(cat:basis p 4)
+	(dotimes (i 5)
+	  (print (cat:face p i 4 4)))
+	(dotimes (i 5)
+	  (print (cat:? p i i)))
+	(setf dd (cat:cmps p p))
+	(dotimes (i 6)
+	  (print (cat:? dd i i)))
+	(setf p (cat:R-proj-space 3))
+	(dotimes (i 7)
+	  (print (cat:basis p i)))
+	(dotimes (i 5)
+	  (print (cat:face p i 4 4)))
+	(dotimes (i 7)
+	  (print (cat:? p i i)))
+	(setf dd (cat:cmps p p))
+	(dotimes (i 7)
+	  (print (cat:? dd i i)))))
+
+
+(test gmsms-subsmst
+      (cat:cat-init)
+      (let* ((k (cat:k-z 2))
+	     (efhm (cat:efhm k))
+	     g cmbn kf incl cone s2 cl2 f2 s3
+
+	     )
+	(setf cat:*homology-verbose* nil)
+	(setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 4)))
+	(setf cmbn (cat:lf efhm (cat:rg efhm g)))
+	(multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn))
+	(setf cone (cat:cone incl))
+	(cat:efhm cone)
+	(cat:homology kf 0 5)
+	(cat:homology (cat:cone incl) 0 6)
+
+	(setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 8)))
+	(setf cmbn (cat:lf efhm (cat:rg efhm g)))
+	(multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn))
+	(setf cone (cat:cone incl))
+	(cat:efhm cone)
+	(cat:homology kf 0 9)
+	(cat:homology (cat:cone incl) 0 10)
+	(dotimes (i 9) (print (length (cat:basis kf i))))
+
+	(setf s2 (cat:sphere 2))
+	(setf cl2 (cat:chml-clss s2 2))
+	(setf f2 (cat:z-whitehead s2 cl2))
+	(setf s3 (cat:fibration-total f2))
+	(setf efhm (cat:efhm s3))
+	(cat:basis (cat:rbcc efhm) 3)
+	(setf cmbn (cat:lf efhm (cat:rg efhm 3 (first (cat:basis
+						       (cat:rbcc efhm) 3)))))
+	(setf kf (cat:gmsms-subsmst s3 cmbn))
+	(cat:homology kf 0 4)))