Added chcm-elementary-op tests.

kenzo-test.asd

@@ -9,5 +9,6 @@
 	       (:file "combinations-test")
 	       (:file "various-test")
 	       (:file "chain-complexes-test")
+	       (:file "chcm-elementary-op-test")
 	       (:file "diabolo")
 	       (:file "circle")))

package.lisp

@@ -17,6 +17,15 @@
 
 	   ;; chcm-elementary-op.lisp
 
+	   ADD
+	   CMPS
+	   IDNT-MRPH
+	   N-MRPH
+	   OPPS
+	   SBTR
+	   Z-CHCM
+	   ZERO-MRPH
+
 	   ;; classes.lisp
 
 	   CHAIN-COMPLEX
@@ -44,6 +53,14 @@
 	   ZERO-CMBN
 	   ZERO-INTR-DFFR
 
+	   ;; fibrations.lisp
+
+	   FIBRATION-TOTAL
+
+	   ;; k-pi-n.lisp
+
+	   K-Z
+
 	   ;; macros.lisp
 
 	   BASIS
@@ -57,6 +74,18 @@
 	   TERM
 	   TERM-CMBN
 
+	   ;; searching-homology.lisp
+
+	   HOMOLOGY
+
+	   ;; smith.lisp
+
+	   CHML-CLSS
+
+	   ;; special-smsts.lisp
+
+	   SPHERE
+
 	   ;; various.lisp
 
 	   +EMPTY-LIST+
@@ -70,5 +99,9 @@
 	   SRANDOM
 	   V<A-B>
 
+	   ;; whitehead.lisp
+
+	   Z-WHITEHEAD
+
 	   ))
 

src/chcm-elementary-op.lisp

@@ -35,19 +35,6 @@
          :strt :cmbn
          :orgn `(zero-mrph ,chcm1 ,chcm2 ,degr))))
 
-#|
-  (cat-init)
-  (setf z (zero-mrph (Z-chcm) (Z-chcm) 2))
-  (gnrt-? z 0 :z-gnrt)
-  (cmbn-? z (cmbn 3))
-  (setf z2 (zero-mrph (Z-chcm) (Z-chcm) 2))
-  (eq z z2)
-  (setf z3 (zero-mrph (Z-chcm) (Z-chcm) 3))
-  (gnrt-? z3 0 :z-gnrt)
-  (eq z z3))
-|#    
-
-
 
 (DEFUN IDNT-MRPH (chcm)
    (declare (type chain-complex chcm))
@@ -58,12 +45,6 @@
          :strt :cmbn
          :orgn `(idnt-mrph ,chcm))))
 
-#|
-  (setf zi (idnt-mrph (Z-chcm)))
-  (gnrt-? zi 0 :z-gnrt)
-  (setf zi2 (idnt-mrph (Z-chcm)))
-  (eq zi zi2))
-|#
 
 (DEFUN OPPS (mrph)
    (declare (type morphism mrph))
@@ -77,13 +58,6 @@
             :strt :cmbn
             :orgn `(opps ,mrph)))))
 
-#|
-  (cat-init)
-  (setf -zi (opps (idnt-mrph (Z-chcm))))
-  (gnrt-? -zi 0 :z-gnrt)
-  (setf -zi2 (opps (idnt-mrph (Z-chcm))))
-  (eq -zi -zi2))
-|#
 
 (DEFMETHOD CMPS ((chcm1 chain-complex) (chcm2 chain-complex) &optional strt)
    (declare (type (or strt null) strt))
@@ -147,44 +121,6 @@
                                     (cmbn-? mrph1 (gnrt-? mrph2 degr gnrt))))
                       :strt :gnrt :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt))))))))
 
-#|
-  (cat-init)
-  (setf cc (build-chcm :cmpr #'f-cmpr
-                       :basis :locally-effective
-                       :bsgn 0
-                       :intr-dffr #'(lambda (cmbn)
-                                       (cmbn (1- (cmbn-degr cmbn))))
-                       :strt :cmbn
-                       :orgn '(Z of Z)))
-  (setf *n* 5)
-  (defun ff (degr i)
-     (do ((*2n* (ash *n* 1))
-          (rslt +empty-list+
-                (cons (cons (let ((cffc (- (random *2n*) *n*)))
-                               (if (minusp cffc) cffc (1+ cffc)))
-                            (decf gnrt (1+ (random *n*))))
-                      rslt))
-          (gnrt i)
-          (k 0 (1+ k)))
-         ((= k *n*)
-          (make-cmbn
-             :degr 0
-             :list rslt))))
-  (setf mrph (build-mrph :sorc cc :trgt cc :degr 0
-			 :intr #'ff :strt :gnrt :orgn '(test)))
-  (setf mrph2 (2mrph-cmps mrph mrph :gnrt))
-  (gnrt-? mrph2 0 0) 
-  (dotimes (i 5)
-     (print (gnrt-? mrph2 0 i)))
-  (setf mrph (build-mrph :sorc cc :trgt cc :degr 0
-			 :intr #'ff :strt :gnrt :orgn '(test)))
-  (setf mrph3 (cmps mrph mrph :cmbn))
-  (gnrt-? mrph3 0 0) 
-  (dotimes (i 5)
-     (print (gnrt-? mrph3 0 i)))
-  (setf mrph33 (cmps mrph mrph :cmbn))
-  (eq mrph3 mrph33))
-|# 
 
 (DEFUN N-MRPH-INTR (n mrph)
   (declare
@@ -209,20 +145,6 @@
 	:intr (n-mrph-intr n mrph) :strt :cmbn
 	:orgn `(n-mrph ,n ,mrph)))))
 
-#|
-  (setf s3 (sphere 3))
-  (setf ch3 (chml-clss s3 3))
-  (setf 2ch3 (n-mrph 2 ch3))
-  (setf f3 (z-whitehead s3 2ch3))
-  (setf x (fibration-total f3))
-  (homology x 0 10)
-  (setf k (k-z 3))
-  (setf ch3 (chml-clss k 3))
-  (setf 2ch3 (n-mrph 2 ch3))
-  (setf f3 (z-whitehead k 2ch3))
-  (setf x (fibration-total f3))
-  (homology x 0 10)
-|#  
 
 (DEFMETHOD ADD ((mrph1 morphism) (mrph2 morphism) &optional strt)
    (declare (type (or null strt) strt))
@@ -276,43 +198,6 @@
                          :strt :cmbn
                          :orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))))))))
 
-#|
-  (cat-init)
-  (setf cc (build-chcm :cmpr #'f-cmpr
-                       :basis :locally-effective
-                       :bsgn 0
-                       :intr-dffr #'(lambda (cmbn)
-                                       (cmbn (1- (cmbn-degr cmbn))))
-                       :strt :cmbn
-                       :orgn '(Z of Z)))
-  (setf *n* 10)
-  (defun ff (degr i)
-     (do ((*2n* (ash *n* 1))
-          (rslt +empty-list+
-                (cons (cons (let ((cffc (- (random *2n*) *n*)))
-                               (if (minusp cffc) cffc (1+ cffc)))
-                            (decf gnrt (1+ (random *n*))))
-                      rslt))
-          (gnrt i)
-          (k 0 (1+ k)))
-         ((= k *n*)
-          (make-cmbn
-             :degr 0
-             :list rslt))))
-  (setf mrph1 (build-mrph :sorc cc :trgt cc :degr 0
-                          :intr #'ff :strt :gnrt :orgn '(test)))
-  (setf mrph2 (build-mrph :sorc cc :trgt cc :degr 0
-                          :intr #'ff :strt :gnrt :orgn '(test2)))
-  (setf mrph3 (add mrph1 mrph2 :gnrt))
-  (setf +too-much-time+ -1)
-  (gnrt-? mrph1 0 0)
-  (gnrt-? mrph2 0 0)
-  (gnrt-? mrph3 0 0)
-  (setf mrph4 (add mrph1 mrph2 :cmbn))
-  (gnrt-? mrph4 0 0)
-  (setf mrph44 (add mrph1 mrph2 :cmbn))
-  (eq mrph4 mrph44))
-|#
 
 (DEFMETHOD SBTR ((mrph1 morphism) (mrph2 morphism) &optional strt)
    (declare (type (or null strt) strt))
@@ -366,44 +251,6 @@
                          :strt :cmbn
                          :orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))))))))
 
-#|
-()
-(cat-init)
-(setf cc (build-chcm :cmpr #'f-cmpr
-                     :basis :locally-effective
-                     :bsgn 0
-                     :intr-dffr #'(lambda (cmbn)
-                                    (cmbn (1- (cmbn-degr cmbn))))
-                     :strt :cmbn
-                     :orgn '(Z of Z)))
-(setf *n* 10)
-(defun ff (degr i)
-  (do ((*2n* (ash *n* 1))
-       (rslt +empty-list+
-             (cons (cons (let ((cffc (- (random *2n*) *n*)))
-                           (if (minusp cffc) cffc (1+ cffc)))
-                         (decf gnrt (1+ (random *n*))))
-                   rslt))
-       (gnrt i)
-       (k 0 (1+ k)))
-      ((= k *n*)
-       (make-cmbn
-        :degr 0
-        :list rslt))))
-(setf mrph1 (build-mrph :sorc cc :trgt cc :degr 0
-                        :intr #'ff :strt :gnrt :orgn '(test)))
-(setf mrph2 (build-mrph :sorc cc :trgt cc :degr 0
-                        :intr #'ff :strt :gnrt :orgn '(test2)))
-(setf mrph3 (sbtr mrph1 mrph2 :gnrt))
-(setf +too-much-time+ -1)
-(gnrt-? mrph1 0 0)
-(gnrt-? mrph2 0 0)
-(gnrt-? mrph3 0 0)
-(setf mrph4 (sbtr mrph1 mrph2 :cmbn))
-(gnrt-? mrph4 0 0)
-(setf mrph44 (sbtr mrph1 mrph2 :cmbn))
-(eq mrph4 mrph44))
-|#
 
 (DEFUN CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt)
    (declare

test/chcm-elementary-op-test.lisp

@@ -0,0 +1,187 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(test zero-mrph
+      (progn
+	(cat:cat-init)
+	(let* ((z (cat:zero-mrph (cat:Z-chcm) (cat:Z-chcm) 2))
+	       (z2 (cat:zero-mrph (cat:Z-chcm) (cat:Z-chcm) 2))
+	       (z3 (cat:zero-mrph (cat:Z-chcm) (cat:Z-chcm) 3))
+	       (comb (cat:gnrt-? z 0 :z-gnrt))
+	       (comb1 (cat:cmbn-? z (cat:cmbn 3)))
+	       (comb2 (cat:gnrt-? z3 0 :z-gnrt)))
+	  (is (equal (cat:cmbn-degr comb) 2))
+	  (is (equal (cat:cmbn-list comb) nil))
+	  (is (equal (cat:cmbn-degr comb1) 5))
+	  (is (equal (cat:cmbn-list comb1) nil))
+	  (is (eq z z2))
+	  (is (equal (cat:cmbn-degr comb2) 3))
+	  (is (equal (cat:cmbn-list comb2) nil))
+	  (is (not (eq z z3))))))
+
+
+(test idnt-mrph
+      (progn
+	(cat:cat-init)
+	(let* ((zi (cat:idnt-mrph (cat:Z-chcm)))
+	       (comb (cat:gnrt-? zi 0 :z-gnrt))
+	       (zi2 (cat:idnt-mrph (cat:Z-chcm))))
+	  (is (equal (cat:cmbn-degr comb) 0))
+	  (is (equal (cat:cmbn-list comb) (cons (cons 1 :z-gnrt) nil)))
+	  (is (eq zi zi2)))))
+
+
+(test opps
+      (progn
+	(cat:cat-init)
+	(let* ((-zi (cat:opps (cat:idnt-mrph (cat:Z-chcm))))
+	       (comb (cat:gnrt-? -zi 0 :z-gnrt))
+	       (-zi2 (cat:opps (cat:idnt-mrph (cat:Z-chcm)))))
+	  (is (equal (cat:cmbn-degr comb) 0))
+	  (is (equal (cat:cmbn-list comb) (cons (cons -1 :z-gnrt) nil)))
+	  (is (eq -zi -zi2)))))
+
+
+(defparameter *n* 5)
+(defun ff (degr i)
+  (do ((*2n* (ash *n* 1))
+       (rslt cat:+empty-list+
+	     (cons (cons (let ((cffc (- (random *2n*) *n*)))
+			   (if (minusp cffc) cffc (1+ cffc)))
+			 (decf gnrt (1+ (random *n*))))
+		   rslt))
+       (gnrt i)
+       (k 0 (1+ k)))
+      ((= k *n*)
+       (cat:make-cmbn
+	:degr 0
+	:list rslt))))
+
+(test cmps
+      (progn
+	(cat:cat-init)
+	(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
+				   :basis :locally-effective
+				   :bsgn 0
+				   :intr-dffr #'(lambda (cmbn)
+						  (cat:cmbn
+						   (1- (cat:cmbn-degr cmbn))))
+				   :strt :cmbn
+				   :orgn '(Z of Z)))
+	       (mrph (cat:build-mrph :sorc cc :trgt cc :degr 0
+				     :intr #'ff :strt :gnrt :orgn '(test)))
+	       (mrph2 (cat:cmps mrph mrph :gnrt))
+	       (comb (cat:gnrt-? mrph2 0 0))
+	       (mrph3 (cat:cmps mrph mrph :cmbn))
+               (comb1 (cat:gnrt-? mrph3 0 0))
+	       (mrph33 (cat:cmps mrph mrph :cmbn)))
+	  (dotimes (i 5)
+	    (setq comb (cat:gnrt-? mrph2 0 i))
+	    (is (equal (cat:cmbn-degr comb) 0)))
+	  (dotimes (i 5)
+	    (setq comb1 (cat:gnrt-? mrph3 0 i))
+	    (is (equal (cat:cmbn-degr comb1) 0)))
+	  (is (eq mrph3 mrph33)))))
+
+#|
+  (setf s3 (sphere 3))
+  (setf ch3 (chml-clss s3 3))
+  (setf 2ch3 (n-mrph 2 ch3))
+  (setf f3 (z-whitehead s3 2ch3))
+  (setf x (fibration-total f3))
+  (homology x 0 10)
+  (setf k (k-z 3))
+  (setf ch3 (chml-clss k 3))
+  (setf 2ch3 (n-mrph 2 ch3))
+  (setf f3 (z-whitehead k 2ch3))
+  (setf x (fibration-total f3))
+  (homology x 0 10)
+|#
+
+(test n-mrph
+      (progn
+	(cat:cat-init)
+	(let* ((s3 (cat:sphere 3))
+	       (ch3 (cat:chml-clss s3 3))
+	       (2ch3 (cat:n-mrph 2 ch3))
+;;	       (f3 (cat:z-whitehead s3 2ch3))
+;;	       (x (cat:fibration-total f3))
+	       (k (cat:k-z 3)))
+;;	  (cat:homology x 0 10)
+;;	  (setf ch3 (cat:chml-clss k 3))
+;;	  (setf 2ch3 (cat:n-mrph 2 ch3))
+;;	  (setf f3 (cat:z-whitehead k 2ch3))
+;;	  (setf x (cat:fibration-total f3))
+;;	  (cat:homology x 0 10)
+	  )))
+
+
+(setf *n* 10)
+(setf cat:+too-much-time+ -1)
+(test add
+      (progn
+	(cat:cat-init)
+	(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
+				   :basis :locally-effective
+				   :bsgn 0
+				   :intr-dffr #'(lambda (cmbn)
+						  (cat:cmbn
+						   (1- (cat:cmbn-degr cmbn))))
+				   :strt :cmbn
+				   :orgn '(Z of Z)))
+	       (mrph1 (cat:build-mrph :sorc cc :trgt cc :degr 0
+				     :intr #'ff :strt :gnrt :orgn '(test)))
+	       (mrph2 (cat:build-mrph :sorc cc :trgt cc :degr 0
+				     :intr #'ff :strt :gnrt :orgn '(test2)))
+	       (mrph3 (cat:add mrph1 mrph2 :gnrt))
+
+	       (comb1 (cat:gnrt-? mrph1 0 0))
+	       (comb2 (cat:gnrt-? mrph2 0 0))
+	       (comb3 (cat:gnrt-? mrph3 0 0))
+	       (mrph4 (cat:add mrph1 mrph2 :cmbn))
+	       (comb4 (cat:gnrt-? mrph4 0 0))
+	       (mrph44 (cat:add mrph1 mrph2 :cmbn)))
+	  (is (equal (cat:cmbn-degr comb1) 0))
+	  (is (equal (length (cat:cmbn-list comb1)) 10))
+	  (is (equal (cat:cmbn-degr comb2) 0))
+	  (is (equal (length (cat:cmbn-list comb2)) 10))
+	  (is (equal (cat:cmbn-degr comb3) 0))
+	  (is (<= (length (cat:cmbn-list comb3)) 20))
+	  (is (equal (cat:cmbn-degr comb4) 0))
+	  (is (<= (length (cat:cmbn-list comb4)) 20))
+	  (is (eq mrph4 mrph44)))))
+
+
+(test sbtr
+      (progn
+	(cat:cat-init)
+	(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
+				   :basis :locally-effective
+				   :bsgn 0
+				   :intr-dffr #'(lambda (cmbn)
+						  (cat:cmbn
+						   (1- (cat:cmbn-degr cmbn))))
+				   :strt :cmbn
+				   :orgn '(Z of Z)))
+	       (mrph1 (cat:build-mrph :sorc cc :trgt cc :degr 0
+				     :intr #'ff :strt :gnrt :orgn '(test)))
+	       (mrph2 (cat:build-mrph :sorc cc :trgt cc :degr 0
+				     :intr #'ff :strt :gnrt :orgn '(test2)))
+	       (mrph3 (cat:sbtr mrph1 mrph2 :gnrt))
+	       (comb1 (cat:gnrt-? mrph1 0 0))
+	       (comb2 (cat:gnrt-? mrph2 0 0))
+	       (comb3 (cat:gnrt-? mrph3 0 0))
+	       (mrph4 (cat:sbtr mrph1 mrph2 :cmbn))
+	       (comb4 (cat:gnrt-? mrph4 0 0))
+	       (mrph44 (cat:sbtr mrph1 mrph2 :cmbn)))
+	  (is (equal (cat:cmbn-degr comb1) 0))
+	  (is (equal (length (cat:cmbn-list comb1)) 10))
+	  (is (equal (cat:cmbn-degr comb2) 0))
+	  (is (equal (length (cat:cmbn-list comb2)) 10))
+	  (is (equal (cat:cmbn-degr comb3) 0))
+	  (is (<= (length (cat:cmbn-list comb3)) 20))
+	  (is (equal (cat:cmbn-degr comb4) 0))
+	  (is (<= (length (cat:cmbn-list comb4)) 20))
+	  (is (eq mrph4 mrph44)))))