First batch of classifying spaces tests.

package.lisp

@@ -149,6 +149,11 @@
 
 	   +NULL-GBAR+
 	   CLASSIFYING-SPACE
+	   CLASSIFYING-SPACE-BASIS
+	   CLASSIFYING-SPACE-CMPR
+	   GBAR
+	   NORMALIZE-GBAR
+	   UNNORMALIZE-GBAR
 
 	   ;; combinations.lisp
 
@@ -302,6 +307,7 @@
 	   LF
 	   LG
 	   MASK
+	   MAKE-GBAR
 	   RBCC
 	   RF
 	   RG

src/classifying-spaces.lisp

@@ -60,7 +60,8 @@
 		      :dmns (- dmns (logcount r-dgop))
 		      :list (nreconc r-absm-list mark)))))
 	   (let ((absm (car mark)))
-	    (with-absm (dgop gmsm) absm
+	     (with-absm
+		 (dgop gmsm) absm
 		 (declare (ignore gmsm))
 		 (if (and (= dgop mask)
 			  (logbitp indx and-dgops))
@@ -72,7 +73,8 @@
 			    (setf (car sublist)
 				  (let ((absm (car sublist)))
 				    (declare (type absm absm))
-				(with-absm (dgop gmsm) absm
+				    (with-absm
+					(dgop gmsm) absm
 					(absm (multiple-value-bind (q r)
 						  (floor dgop 2-indx)
 						(declare (fixnum q r))
@@ -81,23 +83,6 @@
 			r-absm-list))
 		     (push absm r-absm-list))))))))
 
-#|
-()
-(normalize-gbar (list 0))
-(normalize-gbar (list 1 (absm 0 'i)))
-(normalize-gbar (list 2 (absm 1 'i) (absm 0 'i)))
-(normalize-gbar (list 2 (absm 0 'a) (absm 0 'i)))
-(normalize-gbar (list 4 (absm 0 'a) (absm 0 'b) (absm 0 'c) (absm 0 'i)))
-(normalize-gbar (list 4 (absm 7 'i) (absm 3 'i) (absm 1 'i) (absm 0 'i)))
-(normalize-gbar (list 4 (absm 0 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
-(normalize-gbar (list 4 (absm 1 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
-(normalize-gbar (list 4 (absm 2 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
-(normalize-gbar (list 4 (absm 4 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
-(normalize-gbar (list 4 (absm 3 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
-(normalize-gbar (list 4 (absm 5 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
-(normalize-gbar (list 4 (absm 6 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
-(normalize-gbar (list 4 (absm 1 'a) (absm 3 'i) (absm 1 'i) (absm 0 'i)))
-|#
 
 (DEFUN UNNORMALIZE-GBAR (absm idnt)
   (declare
@@ -130,39 +115,6 @@
 				     (incf dgop3 2-indx))
 				   (push (ndgnr dgop3 (pop list)) rslt)))))))
 
-#|
-()
-(unnormalize-gbar (absm 1 +null-gbar+) 'i)
-(unnormalize-gbar (absm 15 +null-gbar+) 'i)
-(normalize-gbar (unnormalize-gbar (absm 15 +null-gbar+) 'i))
-(unnormalize-gbar
- (absm 0 (make-gbar :dmns 4
-                    :list (list (absm 0 'a) (absm 0 'b)
-                                (absm 0 'c) (absm 0 'i)))) 'i)
-(normalize-gbar
- (unnormalize-gbar
-  (absm 0 (make-gbar :dmns 4
-                     :list (list (absm 0 'a) (absm 0 'b)
-                                 (absm 0 'c) (absm 0 'i)))) 'i))
-(unnormalize-gbar
- (absm 5 (make-gbar :dmns 4
-                    :list (list (absm 0 'a) (absm 0 'b)
-                                (absm 0 'c) (absm 0 'i)))) 'i)
-(normalize-gbar
- (unnormalize-gbar
-  (absm 5 (make-gbar :dmns 4
-                     :list (list (absm 0 'a) (absm 0 'b)
-                                 (absm 0 'c) (absm 0 'i)))) 'i))
-(unnormalize-gbar
- (absm 9 (make-gbar :dmns 4
-                    :list (list (absm 0 'a) (absm 0 'b)
-                                (absm 0 'c) (absm 0 'i)))) 'i)
-(normalize-gbar
- (unnormalize-gbar
-  (absm 9 (make-gbar :dmns 4
-                     :list (list (absm 0 'a) (absm 0 'b)
-                                 (absm 0 'c) (absm 0 'i)))) 'i))
-|#
 
 (DEFUN GBAR (dmns &rest rest)
   (the gbar
@@ -177,12 +129,6 @@
 			      ((endp mark) (nreverse rslt))
 			    (declare (list mark rslt)))))))
 
-#|
-()
-(gbar 0)
-(gbar 1)
-(gbar 2 1 'a 2 'b)
-|#
 
 (DEFUN CLASSIFYING-SPACE-CMPR (cmpr)
   (declare (type cmprf cmpr))
@@ -195,12 +141,6 @@
 	    (gbar-list gbar1) (gbar-list gbar2))))
     (the cmprf #'rslt)))
 
-#|
-  (setf cmpr (classifying-space-cmpr 's-cmpr))
-  (funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 1 'a 0 'a))
-  (funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 0 'b 0 'a))
-  (funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 0 'a 0 'a))
-|#
 
 (DEFUN CLASSIFYING-SPACE-BASIS (basis)
   (declare (type basis basis))
@@ -240,15 +180,6 @@
       (setf crts-basis (crts-prdc-basis basis #'rslt))
       (the basis #'rslt))))
 
-#|
-()
-(cat-init)
-(setf k (k-z2-1))
-(setf b (classifying-space-basis (basis k)))
-(funcall b 0)
-(funcall b 1)
-(dotimes (i 5) (print (funcall b i)))
-|#
 
 (DEFUN CLASSIFYING-SPACE-FACE (face sintr-grml)
   (declare
@@ -280,13 +211,13 @@
     (the face #'rslt)))
 
 #|
-  (setf om (loop-space (moore 2 2)))
+(setf om (loop-space (moore 2 2)))
-  (setf face (classifying-space-face (face om) (sintr (grml om))))
+(setf face (classifying-space-face (face om) (sintr (grml om))))
-  (setf gbar (gbar 4 0 (loop3 3 'm2 1 4 'n3 1)
+(setf gbar (gbar 4 0 (loop3 3 'm2 1 4 'n3 1)
 		 0 (loop3 0 'n3 1)
 		 0 (loop3 0 'm2 1)
 		 0 +null-loop+))
-  (dotimes (i 5)
+(dotimes (i 5)
   (print (funcall face i 4 gbar)))
 |#
 
@@ -301,14 +232,14 @@
 		   :orgn `(classifying-space ,smgr))))
 
 #|
-  (cat-init)
+(cat-init)
-  (setf c (classifying-space (k-z2-1)))
+(setf c (classifying-space (k-z2-1)))
-  (orgn c)
+(orgn c)
-  (first (basis c 4))
+(first (basis c 4))
-  (? c 4 (first (basis c 4)))
+(? c 4 (first (basis c 4)))
-  (? c *)
+(? c *)
-  (cprd c 4 ***)
+(cprd c 4 ***)
-  (dotimes (i 5)
+(dotimes (i 5)
   (print (face c i 4 (first (basis c 4)))))
 |#
 
@@ -335,12 +266,12 @@
     (the sintr #'rslt)))
 
 #|
-  (setf grml (classifying-space-grml-sintr '() (sintr (grml (k-z-1)))))
+(setf grml (classifying-space-grml-sintr '() (sintr (grml (k-z-1)))))
-  (funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
+(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
 		      0 (gbar 3 0 '(-1 -2) 0 '(-3) 0 '())))
-  (funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
+(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
 		      4 (gbar 2 0 '(-3) 0 '())))
-  (funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
+(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
 		      1 (gbar 2 0 '(-3) 0 '())))
 |#
 
@@ -362,8 +293,8 @@
     (the sintr #'rslt)))
 
 #|
-  (setf grin (classifying-space-grin-sintr (sintr (grin (k-z-1)))))
+(setf grin (classifying-space-grin-sintr (sintr (grin (k-z-1)))))
-  (funcall grin 3 (gbar 3 0 '(1 2) 1 '() 0 '()))
+(funcall grin 3 (gbar 3 0 '(1 2) 1 '() 0 '()))
 |#
 
 
@@ -383,14 +314,14 @@
 	'ab-simplicial-group)))
 
 #|
-  (setf k-z-1 (k-z-1))
+(setf k-z-1 (k-z-1))
-  (setf k-z-2 (classifying-space k-z-1))
+(setf k-z-2 (classifying-space k-z-1))
-  (setf k-z-3 (classifying-space k-z-2))
+(setf k-z-3 (classifying-space k-z-2))
-  (homology k-z-3 0 10)
+(homology k-z-3 0 10)
-  (setf k-z2-1 (k-z2-1))
+(setf k-z2-1 (k-z2-1))
-  (setf k-z2-2 (classifying-space k-z2-1))
+(setf k-z2-2 (classifying-space k-z2-1))
-  (setf k-z2-3 (classifying-space k-z2-2))
+(setf k-z2-3 (classifying-space k-z2-2))
-  (setf k-z2-4 (classifying-space k-z2-3))
+(setf k-z2-4 (classifying-space k-z2-3))
-  (setf k-z2-5 (classifying-space k-z2-4))
+(setf k-z2-5 (classifying-space k-z2-4))
-  (homology k-z2-5 0 7)
+(homology k-z2-5 0 7)
 |#

test/classifying-spaces-test.lisp

@@ -0,0 +1,103 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+
+(test normalize-gbar
+      (cat:normalize-gbar (list 0))
+      (cat:normalize-gbar (list 1 (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 2 (cat:absm 1 'i) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 2 (cat:absm 0 'a) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 4 (cat:absm 0 'a) (cat:absm 0 'b)
+				(cat:absm 0 'c) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 4 (cat:absm 7 'i) (cat:absm 3 'i)
+				(cat:absm 1 'i) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 4 (cat:absm 0 'a) (cat:absm 3 'i)
+				(cat:absm 0 'c) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 4 (cat:absm 1 'a) (cat:absm 3 'i)
+				(cat:absm 0 'c) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 4 (cat:absm 2 'a) (cat:absm 3 'i)
+				(cat:absm 0 'c) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 4 (cat:absm 4 'a) (cat:absm 3 'i)
+				(cat:absm 0 'c) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 4 (cat:absm 3 'a) (cat:absm 3 'i)
+				(cat:absm 0 'c) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 4 (cat:absm 5 'a) (cat:absm 3 'i)
+				(cat:absm 0 'c) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 4 (cat:absm 6 'a) (cat:absm 3 'i)
+				(cat:absm 0 'c) (cat:absm 0 'i)))
+      (cat:normalize-gbar (list 4 (cat:absm 1 'a) (cat:absm 3 'i)
+				(cat:absm 1 'i) (cat:absm 0 'i))))
+
+
+(test unnormalize-gbar
+      (cat:unnormalize-gbar (cat:absm 1 cat:+null-gbar+) 'i)
+      (cat:unnormalize-gbar (cat:absm 15 cat:+null-gbar+) 'i)
+      (cat:normalize-gbar (cat:unnormalize-gbar
+			   (cat:absm 15 cat:+null-gbar+) 'i))
+      (cat:unnormalize-gbar
+       (cat:absm 0 (cat:make-gbar :dmns 4
+			  :list (list (cat:absm 0 'a) (cat:absm 0 'b)
+				      (cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
+      (cat:normalize-gbar
+       (cat:unnormalize-gbar
+	(cat:absm 0 (cat:make-gbar :dmns 4
+			   :list (list (cat:absm 0 'a) (cat:absm 0 'b)
+				       (cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
+      (cat:unnormalize-gbar
+       (cat:absm 5 (cat:make-gbar :dmns 4
+			  :list (list (cat:absm 0 'a) (cat:absm 0 'b)
+				      (cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
+      (cat:normalize-gbar
+       (cat:unnormalize-gbar
+	(cat:absm 5 (cat:make-gbar :dmns 4
+			   :list (list (cat:absm 0 'a) (cat:absm 0 'b)
+				       (cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
+      (cat:unnormalize-gbar
+       (cat:absm 9 (cat:make-gbar :dmns 4
+			  :list (list (cat:absm 0 'a) (cat:absm 0 'b)
+				      (cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
+      (cat:normalize-gbar
+       (cat:unnormalize-gbar
+	(cat:absm 9 (cat:make-gbar :dmns 4
+			   :list (list (cat:absm 0 'a) (cat:absm 0 'b)
+				       (cat:absm 0 'c) (cat:absm 0 'i)))) 'i)))
+
+
+(test gbar
+      (cat:gbar 0)
+      (signals #-ecl simple-error
+	       #+ecl simple-type-error (cat:gbar 1))
+      (cat:gbar 2 1 'a 2 'b))
+
+
+(test classifying-space-cmpr
+      (let ((cmpr (cat:classifying-space-cmpr 'cat:s-cmpr)))
+	(is (equal :less (funcall cmpr
+				  (cat:gbar 2 0 'a 0 'a)
+				  (cat:gbar 2 1 'a 0 'a))))
+	(is (equal :less (funcall cmpr
+				  (cat:gbar 2 0 'a 0 'a)
+				  (cat:gbar 2 0 'b 0 'a))))
+	(is (equal :equal (funcall cmpr
+				   (cat:gbar 2 0 'a 0 'a)
+				   (cat:gbar 2 0 'a 0 'a))))))
+
+
+(test classifying-space-basis
+      (cat:cat-init)
+      (let* ((k (cat:k-z2-1))
+	     (b (cat:classifying-space-basis (cat:basis k))))
+	(funcall b 0)
+	(funcall b 1)
+	(dotimes (i 5) (print (funcall b i)))))
+#|
+()
+(cat-init)
+(setf k (k-z2-1))
+(setf b (classifying-space-basis (basis k)))
+(funcall b 0)
+(funcall b 1)
+(dotimes (i 5) (print (funcall b i)))
+|#