Added effective homology test.

package.lisp

@@ -30,15 +30,20 @@
 
 	   ;; classes.lisp
 
+	   BCC
 	   CHAIN-COMPLEX
 	   CMBN-CMBN
 	   CMBN-DEGR
+	   CMBN-LIST
 	   DEGR
 	   DFFR1
-	   CMBN-LIST
+	   F
+	   G
+	   H
 	   MAKE-CMBN
 	   MAKE-RESULT
 	   MORPHISM
+	   TCC
 
 	   ;; combinations.lisp
 
@@ -82,6 +87,7 @@
 	   CMPR
 	   DFFR
 	   GNRT
+	   I-SBTR
 	   TERM
 	   TERM-CMBN
 

src/effective-homology.lisp

@@ -111,74 +111,7 @@
                (declare (type homotopy-equivalence hmeq))
                (push hmeq *hmeq-list*)
                hmeq))))))
-#|
+
-  (cat-init)
-  (progn ;;;; reused in another test
-   (defun cdelta (dmns)
-     (build-chcm
-        :cmpr #'l-cmpr
-        :basis :locally-effective
-        :bsgn '(0)
-        :intr-dffr #'(lambda (degr gmsm)
-                        (make-cmbn
-                           :degr (1- degr)
-                           :list (do ((rslt +empty-list+
-                                           (cons (cons sign (append
-                                                               (subseq gmsm 0 nark)
-                                                               (subseq gmsm (1+ nark))))
-                                                 rslt))
-                                     (sign 1 (- sign))
-                                     (nark 0 (1+ nark)))
-                                    ((> nark degr) rslt))))
-        :strt :gnrt
-        :orgn `(locally effective version of C_* delta ,dmns)))
-   (defun make-f (tdmns bdmns)
-     (build-mrph
-        :sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0
-        :intr #'(lambda (degr gmsm)
-                   (let ((pos (position-if #'(lambda (vertex) (>= vertex bdmns)) gmsm)))
-                      (if pos
-                         (if (< pos degr)
-                            (zero-cmbn degr)
-                            (cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
-                         (cmbn degr 1 gmsm))))
-        :strt :gnrt
-        :orgn `(projection delta ,tdmns => delta ,bdmns)))
-   (defun make-g (tdmns bdmns)
-     (build-mrph
-        :sorc (cdelta bdmns) :trgt (cdelta tdmns) :degr 0
-        :intr #'identity
-        :strt :cmbn
-        :orgn `(injection delta ,bdmns => delta ,tdmns)))
-   (defun make-h (tdmns bdmns)
-     (build-mrph
-        :sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1
-        :intr #'(lambda (degr gmsm)
-                   (let ((pos (position-if #'(lambda (vertex) (>= vertex bdmns)) gmsm)))
-                      (if pos
-                         (if (member bdmns gmsm)
-                            (zero-cmbn (1+ degr))
-                            (cmbn (1+ degr) (-1-expt-n pos)
-                               (append (subseq gmsm 0 pos) (list bdmns) (subseq gmsm pos))))
-                         (zero-cmbn (1+ degr)))))
-        :strt :gnrt
-        :orgn `(homotopy for delta ,tdmns => ,bdmns)))
-   (defun make-rdct (tdmns bdmns)
-       (setf rdct (build-rdct
-                    :f (make-f tdmns bdmns)
-                    :g (make-g tdmns bdmns)
-                    :h (make-h tdmns bdmns)
-                    :orgn `(reduction delta ,tdmns ,bdmns)))))
-  (setf rdct (make-rdct 6 3))
-  (setf f (f rdct) g (g rdct) h (h rdct)
-        tcc (tcc rdct) bcc (bcc rdct))
-  (setf dh (cmps (dffr tcc) h))
-  (setf hd (cmps h (dffr tcc)))
-  (setf gf (cmps g f))
-  (setf id-gf-dh-hd (i-sbtr (idnt-mrph tcc) gf dh hd))
-  (setf c (cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) 1000 '(2 3 4)))
-  (cmbn-? id-gf-dh-hd c)
-|#
 
 #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (ext:package-lock :clos) nil))

test/effective-homology-test.lisp

@@ -0,0 +1,89 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(defun cdelta (dmns)
+  (cat:build-chcm
+   :cmpr #'cat:l-cmpr
+   :basis :locally-effective
+   :bsgn '(0)
+   :intr-dffr #'(lambda (degr gmsm)
+		  (cat:make-cmbn
+		   :degr (1- degr)
+		   :list (do ((rslt cat:+empty-list+
+				    (cons (cons sign (append
+						      (subseq gmsm 0 nark)
+						      (subseq gmsm (1+ nark))))
+					  rslt))
+			      (sign 1 (- sign))
+			      (nark 0 (1+ nark)))
+			     ((> nark degr) rslt))))
+   :strt :gnrt
+   :orgn `(locally effective version of C_* delta ,dmns)))
+
+(defun make-f (tdmns bdmns)
+  (cat:build-mrph
+   :sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0
+   :intr #'(lambda (degr gmsm)
+	     (let ((pos (position-if #'(lambda (vertex)
+					 (>= vertex bdmns)) gmsm)))
+	       (if pos
+		   (if (< pos degr)
+		       (cat:zero-cmbn degr)
+		       (cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
+		   (cat:cmbn degr 1 gmsm))))
+   :strt :gnrt
+   :orgn `(projection delta ,tdmns => delta ,bdmns)))
+
+(defun make-g (tdmns bdmns)
+  (cat:build-mrph
+   :sorc (cdelta bdmns) :trgt (cdelta tdmns) :degr 0
+   :intr #'identity
+   :strt :cmbn
+   :orgn `(injection delta ,bdmns => delta ,tdmns)))
+
+(defun make-h (tdmns bdmns)
+  (cat:build-mrph
+   :sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1
+   :intr #'(lambda (degr gmsm)
+	     (let ((pos (position-if #'(lambda (vertex)
+					 (>= vertex bdmns)) gmsm)))
+	       (if pos
+		   (if (member bdmns gmsm)
+		       (cat:zero-cmbn (1+ degr))
+		       (cat:cmbn (1+ degr) (cat:-1-expt-n pos)
+				 (append (subseq gmsm 0 pos) (list bdmns)
+					 (subseq gmsm pos))))
+		   (cat:zero-cmbn (1+ degr)))))
+   :strt :gnrt
+   :orgn `(homotopy for delta ,tdmns => ,bdmns)))
+
+(defun make-rdct (tdmns bdmns)
+  (let ((rdct (cat:build-rdct
+	      :f (make-f tdmns bdmns)
+	      :g (make-g tdmns bdmns)
+	      :h (make-h tdmns bdmns)
+	      :orgn `(reduction delta ,tdmns ,bdmns))))
+    rdct))
+
+(test cdelta
+      (progn
+	(cat:cat-init)
+	(let* ((rdct (make-rdct 6 3))
+	       (f (cat:f rdct))
+	       (g (cat:g rdct))
+	       (h (cat:h rdct))
+	       (tcc (cat:tcc rdct))
+	       (bcc (cat:bcc rdct))
+	       (dh (cat:cmps (cat:dffr tcc) h))
+	       (hd (cat:cmps h (cat:dffr tcc)))
+	       (gf (cat:cmps g f))
+	       (id-gf-dh-hd (cat:i-sbtr (cat:idnt-mrph tcc) gf dh hd))
+	       (c (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4)
+			    1000 '(2 3 4)))
+	       (comb (cat:cmbn-? id-gf-dh-hd c)))
+
+	  )
+
+	))