Added bicone tests and refactored common functions.

kenzo-test.asd

@@ -8,6 +8,7 @@
   :depends-on (:kenzo :fiveam)
   :pathname #P"test/"
   :components ((:file "package")
+	       (:file "common")
 	       (:file "combinations-test")
 	       (:file "various-test")
 	       (:file "chain-complexes-test")
@@ -15,4 +16,5 @@
 	       (:file "diabolo")
 	       (:file "circle")
                (:file "ccn")
-	       (:file "effective-homology-test")))
+	       (:file "effective-homology-test")
+	       (:file "bicones-test")))

package.lisp

@@ -20,6 +20,17 @@
 	   *TC*
 	   *TDD*
 
+	   ;; bicones.lisp
+
+	   BICN-CMBN-CMBNB
+	   BICN-CMBN-CMBNC
+	   BICN-CMBN-CMBND
+	   BICONE
+	   BICONE-BASIS
+	   BICONE-CMPR
+	   DISPATCH-BICN-CMBN
+	   MAKE-BICN-CMBN
+
 	   ;; chain-complexes.lisp
 
 	   ?2
@@ -70,6 +81,7 @@
 	   MORPHISM
 	   ORGN
 	   REDUCTION
+	   RRDCT
 	   TCC
 
 	   ;; combinations.lisp
@@ -92,6 +104,10 @@
 	   ZERO-CMBN
 	   ZERO-INTR-DFFR
 
+	   ;; delta.lisp
+
+	   DELTA-N-BASIS
+
 	   ;; effective-homology.lisp
 
 	   BUILD-RDCT
@@ -115,6 +131,9 @@
 	   ?
 	   BASIS
 	   BCC
+	   BCNB
+	   BCNC
+	   BCND
 	   BINOMIAL-P-Q
 	   CFFC
 	   CMBN-NON-ZERO-P
@@ -132,6 +151,10 @@
 
 	   HOMOLOGY
 
+	   ;; simplicial-sets.lisp
+
+	   DLOP-INT-EXT
+
 	   ;; smith.lisp
 
 	   CHML-CLSS

src/bicones.lisp

@@ -7,6 +7,8 @@
 (PROVIDE "bicones")
 
 (DEFUN DISPATCH-BICN-CMBN (cmbn)
+  "(DISPATCH-BICN-CMBN CMBN) splits the bicone combination CMBN into three
+combinations and returns 3 values."
   (declare (type cmbn cmbn))
   (the (values cmbn cmbn cmbn)
        (with-cmbn (degr list) cmbn
@@ -19,25 +21,27 @@
 		      (with-term (cffc bicn) term
 				 (with-bicn (bcnx ibicn) bicn
 					    (ecase bcnx
-                        (:bcnb (push (term cffc ibicn) listb))
+					      (:bcnb (push (term cffc ibicn)
-                        (:bcnc (push (term cffc ibicn) listc))
+							   listb))
-                        (:bcnd (push (term cffc ibicn) listd))))))
+					      (:bcnc (push (term cffc ibicn)
+							   listc))
+					      (:bcnd (push (term cffc ibicn)
+							   listd))))))
 		    (values
 		     (make-cmbn :degr degr :list (nreverse listb))
 		     (make-cmbn :degr (1+ degr) :list (nreverse listc))
 		     (make-cmbn :degr degr :list (nreverse listd)))))))
 
-#|
-()
-(dispatch-bicn-cmbn (cmbn 3 3 (bcnb 'b1) 4 (bcnb 'b2) 33 (bcnc 'c) 333 (bcnd 'd)))
-|#
-
 
 (DEFUN BICN-CMBN-CMBNB (cmbn)
   (declare (type cmbn cmbn))
+  "(BICN-CMBN-CMBNB CMBN) extracts from the bicone combination CMBN of degree
+n the B-component as a legal combination of degree n in B. If the B-component
+is empty, the null combination of degree n in B is returned."
   (the cmbn
        (with-cmbn (degr list) cmbn
-      (make-cmbn :degr degr
+		  (make-cmbn
+		   :degr degr
 		   :list (do ((rslt +empty-list+)
 			      (mark list (cdr mark)))
 			     ((endp mark) (nreverse rslt))
@@ -45,14 +49,20 @@
 			   (with--term (cffc bicn) mark
 				       (with-bicn (bcnx gnrtB) bicn
 						  (if (eq bcnx :bcnB)
-                                        (push (term cffc gnrtB) rslt)
+						      (push (term cffc gnrtB)
-                                      (return (nreverse rslt))))))))))
+							    rslt)
+						      (return
+							(nreverse rslt))))))))))
 
 (DEFUN BICN-CMBN-CMBNC (cmbn)
   (declare (type cmbn cmbn))
+  "(BICN-CMBN-CMBNC CMBN) extracts from the bicone combination CMBN of degree
+n the C-component as a legal combination of degree n+1 in C. If the C-component
+is empty, the null combination of degree n+1 in C is returned."
   (the cmbn
        (with-cmbn (degr list) cmbn
-         (make-cmbn :degr (1+ degr)
+		  (make-cmbn
+		   :degr (1+ degr)
 		   :list (do ((rslt +empty-list+)
 			      (mark (member :bcnc list
 					    ;; Correction 1-1-2
@@ -65,44 +75,50 @@
 			   (with--term (cffc bicn) mark
 				       (with-bicn (bcnx gnrtC) bicn
 						  (if (eq bcnx :bcnC)
-                           (push (term cffc gnrtC) rslt)
+						      (push (term cffc gnrtC)
-                           (return (nreverse rslt))))))))))
+							    rslt)
+						      (return
+							(nreverse rslt))))))))))
 
 
 (DEFUN BICN-CMBN-CMBND (cmbn)
   (declare (type cmbn cmbn))
+  "(BICN-CMBN-CMBND CMBN) extracts from the bicone combination CMBN of degree
+n the D-component as a legal combination of degree n in D. If the D-component
+is empty, the null combination of degree n in D is returned."
   (the cmbn
        (with-cmbn (degr list) cmbn
-      (make-cmbn :degr degr
+		  (make-cmbn
+		   :degr degr
 		   :list (mapcar
 			  #'(lambda (term)
 			      (declare (type term term))
 			      (with-term (cffc bicn) term
 					 (term cffc (ibicn bicn))))
-                         (member :bcnd list
+			  (member
+			   :bcnd list
 			   :key #'(lambda (term)
 				    (declare (type term term))
 				    (the keyword (bcnx (gnrt term))))))))))
 
-#|
-()
-(bicn-cmbn-cmbnb (cmbn 3 1 (bcnb 'a) 2 (bcnc 'b)))
-(bicn-cmbn-cmbnb (cmbn 3 2 (bcnc 'b)))
-(bicn-cmbn-cmbnc (cmbn 3 1 (bcnb 'a) 2 (bcnc 'b) 3 (bcnd 'c)))
-(bicn-cmbn-cmbnc (cmbn 3 1 (bcnb 'a) 3 (bcnd 'c)))
-(bicn-cmbn-cmbnd (cmbn 3 1 (bcnb 'a) 2 (bcnc 'b) 3 (bcnd 'c)))
-(bicn-cmbn-cmbnd (cmbn 3 2 (bcnb 'b)))
-|#
 
 (DEFUN MAKE-BICN-CMBN (cmbnb cmbnc cmbnd)
   (declare (type cmbn cmbnb cmbnc cmbnd))
+  "(MAKE-BICN-CMBN CMBNB CMBNC CMBND) constructs a bicone combination from
+CMBNB, CMBNC and CMBND, which belong to chain complexes B, C, D, respectively.
+Combinations CMBNB and CMBND must be of the same degree n and combination
+CMBNC must be of degree n+1, yiedling a bicone combination of degree n."
   (the cmbn
-      (with-cmbn (degrb listb) cmbnb
+       (with-cmbn
-      (with-cmbn (degrc listc) cmbnc
+	   (degrb listb) cmbnb
-      (with-cmbn (degrd listd) cmbnd
+	   (with-cmbn
+	       (degrc listc) cmbnc
+	       (with-cmbn
+		   (degrd listd) cmbnd
 		   (unless (= degrb (1- degrc) degrd)
 		     (error "In MAKE-BICN-CMBN, the degrees are not coherent."))
-         (make-cmbn :degr degrb
+		   (make-cmbn
+		    :degr degrb
 		    :list (nconc
 			   (mapcar #'(lambda (termb)
 				       (declare (type term termb))
@@ -120,11 +136,6 @@
 						  (term cffc (bcnd gnrtd))))
 				   listd))))))))
 
-#|
-()
-(multiple-value-call #'make-bicn-cmbn 
-  (dispatch-bicn-cmbn (cmbn 3 3 (bcnb 'b1) 4 (bcnb 'b2) 33 (bcnc 'c) 333 (bcnd 'd))))
-|#
 
 (DEFUN BICN-PRINT (bicn stream depth)
   (declare
@@ -139,15 +150,12 @@
 			  ibicn)
 		  bicn)))
 
-#|
-()
-(bcnb 'a)
-(bcnc 'b)
-(bcnd 'c)
-|#
 
 (DEFUN BICONE-CMPR (cmprb cmprc cmprd)
   (declare (type cmprf cmprb cmprc cmprd))
+  "(BICONE-CMPR CMPRB CMPRC CMPRD) returns a comparison function for bicone
+generators, which is contructed from the comparison functions CMPRB, CMPRC
+and CMPRD."
   (flet ((rslt (bicn1 bicn2)
 	   (declare (type bicn bicn1 bicn2))
 	   (let ((bcnx1 (bcnx bicn1)))
@@ -160,15 +168,12 @@
 		(:bcnd (funcall cmprd (ibicn bicn1) (ibicn bicn2))))))))
     (the cmprf #'rslt)))
 
-#|
-()
-(setf r (bicone-cmpr #'f-cmpr #'f-cmpr #'f-cmpr))
-(funcall r (bcnb 1) (bcnc 0))
-(funcall r (bcnb 1) (bcnb 2))
-|#
 
 (DEFUN BICONE-BASIS (basisb basisc basisd)
   (declare (type basis basisb basisc basisd))
+  "(BICONE-BASIS BASISB BASISC BASISD) returns a bicone basis function built
+from the basis functions BASISB, BASISC and BASISD. If at least one is
+locally effective, the function returns the symbol :locally-effective."
   (the basis
        (if (or (eq :locally-effective basisb)
 	       (eq :locally-effective basisc)
@@ -191,22 +196,17 @@
 			     (funcall basisd degr)))))
 	     (the basis #'rslt)))))
 
-#|
-()
-(bicone-basis :locally-effective :locally-effective :locally-effective)
-(setf b #'(lambda (degr) (mapcar #'(lambda (item) (cons degr item)) (<a-b> 0 degr))))
-(setf r (bicone-basis b b b))
-(funcall r 3)
-|#
 
 (DEFUN BICONE-INTR-DFFR (cmprc dffrb dffrc dffrd f1 f2)
   (declare
    (type cmprf cmprc)
    (type morphism dffrb dffrc dffrd f1 f2))
+  "(BICONE-INTR-DFFR CMPRC DFFRB DFFRC DFFRD F1 F2) "
   (flet ((rslt (cmbn)
 	   (declare (type cmbn cmbn))
 	   (the cmbn
-                (multiple-value-bind (cmbnb cmbnc cmbnd) (dispatch-bicn-cmbn cmbn)
+                (multiple-value-bind (cmbnb cmbnc cmbnd)
+		    (dispatch-bicn-cmbn cmbn)
 		  (declare (type cmbn cmbnb cmbnc cmbnd))
 		  (let ((dffrb (cmbn-? dffrb cmbnb))
 			(dffrc (cmbn-? dffrc cmbnc))
@@ -214,13 +214,21 @@
 			(f1 (cmbn-? f1 cmbnb))
 			(f2 (cmbn-? f2 cmbnd)))
 		    (declare (type cmbn dffrb dffrc dffrd f1 f2))
-                      (let ((cmbnc (2cmbn-sbtr cmprc (2cmbn-add cmprc f1 f2) dffrc)))
+		    (let ((cmbnc (2cmbn-sbtr cmprc
+					     (2cmbn-add cmprc f1 f2)
+					     dffrc)))
 		      (declare (type cmbn cmbnc))
 		      (make-bicn-cmbn dffrb cmbnc dffrd)))))))
     (the intr-mrph #'rslt)))
 
+
+
 (DEFUN BICONE (rdct1 rdct2)
   (declare (type reduction rdct1 rdct2))
+  "(BICONE RDCT1 RDCT2) returns the bicone chain complex from the reductions
+RDCT1 and RDCT2. B is the top chain complex of RDCT1 and D is the top chain
+complex of RDCT2. The bottom chain complexes of RDCT1 and RDCT2 must be the
+same, and C is that chain complex."
   (the chain-complex
        (with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f)) rdct1
          (declare
@@ -234,10 +242,12 @@
 	     (error "In BICONE, both reductions have different BCC's."))
 	   (let ((rslt (build-chcm
                         :cmpr (bicone-cmpr (cmpr tcc1) (cmpr bcc1) (cmpr tcc2))
-                        :basis (bicone-basis (basis tcc1) (basis bcc1) (basis tcc2))
+                        :basis (bicone-basis (basis tcc1) (basis bcc1)
+					     (basis tcc2))
                         :bsgn :undefined
                         :intr-dffr (bicone-intr-dffr (cmpr bcc1)
-                                      (dffr tcc1) (dffr bcc1) (dffr tcc2)
+						     (dffr tcc1) (dffr bcc1)
+						     (dffr tcc2)
 						     f1 f2)
                         :strt :cmbn
                         :orgn `(bicone ,rdct1 ,rdct2))))
@@ -245,73 +255,12 @@
 					; (slot-makunbound rslt 'bsgn)
 	     rslt)))))
 
-#|
-()
-(cat-init)
-(progn
-  (defun cdelta (dmns)
-    (build-chcm
-     :cmpr #'l-cmpr
-     :basis #'(lambda (n)
-                (mapcar #'dlop-int-ext (funcall (delta-n-basis dmns) n)))
-     :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 b (bicone (make-rdct 3 2) (make-rdct 4 2)))
-(basis b 1)
-(? b (cmbn 1 3 (bcnb '(0 3)) 4 (bcnc '(0 1 2)) 5 (bcnd '(0 4))))
-|#
 
-(DEFMETHOD CMPS ((hmeq1 homotopy-equivalence) (hmeq2 homotopy-equivalence) &optional dummy)
+(DEFMETHOD CMPS ((hmeq1 homotopy-equivalence) (hmeq2 homotopy-equivalence)
+		 &optional dummy)
   (declare (ignore dummy))
+  "(CMPS HMEQ1 HMEQ2 &OPTIONAL DUMMY) constructs a homotopy equivalence
+by composition of the homotopy equivalences HMEQ1 and HMEQ2."
   (the homotopy-equivalence
        (progn
          (when (eq 'trivial-hmeq (orgn hmeq2))
@@ -344,8 +293,12 @@
 			  :intr #'(lambda (cmbn)
 				    (declare (type cmbn cmbn))
 				    (let* ((cmbnB (cmbn-? g1 cmbn))
-                                              (cmbnC (zero-cmbn (1+ (cmbn-degr cmbn))))
+					   (cmbnC (zero-cmbn
-                                              (cmbnD (cmbn-? g3 (cmbn-? f2 (cmbn-opps cmbnB)))))
+						   (1+ (cmbn-degr cmbn))))
+					   (cmbnD (cmbn-? g3
+							  (cmbn-? f2
+								  (cmbn-opps
+								   cmbnB)))))
 				      (declare (type cmbn cmbnB cmbnC cmbnD))
 				      (make-bicn-cmbn cmbnB cmbnC cmbnD)))
 			  :strt :cmbn
@@ -358,16 +311,20 @@
 					(dispatch-bicn-cmbn cmbn)
 				      (declare (type cmbn cmbnB cmbnC cmbnD))
 				      (setf cmbnB (cmbn-? h1 cmbnB))
-                                          (let ((cmbnC (zero-cmbn (1+ (cmbn-degr cmbnC))))
+				      (let ((cmbnC (zero-cmbn
-                                                (cmbnD1 (cmbn-? g3 (cmbn-? f2 cmbnB)))
+						    (1+ (cmbn-degr cmbnC))))
+					    (cmbnD1 (cmbn-? g3
+							    (cmbn-? f2 cmbnB)))
 					    (cmbnD2 (cmbn-? g3 cmbnC))  ;; let, not let*
 					    (cmbnD3 (cmbn-? h3 cmbnD)))
-                                             (declare (type cmbn cmbnC cmbnD1 cmbnD2 cmbnD3))
+					(declare (type cmbn cmbnC cmbnD1 cmbnD2
+						       cmbnD3))
 					(make-bicn-cmbn
 					 cmbnB
 					 cmbnC
 					 (2cmbn-sbtr cmpr-D
-                                                   (2cmbn-add cmpr-D cmbnD2 cmbnD3)
+						     (2cmbn-add cmpr-D cmbnD2
+								cmbnD3)
 						     cmbnD1)))))
 			  :strt :cmbn
 			  :orgn `(cmps ,hmeq1 ,hmeq2 lh)))
@@ -383,8 +340,11 @@
 			  :intr #'(lambda (cmbn)
 				    (declare (type cmbn cmbn))
 				    (let* ((cmbnD (cmbn-? g4 cmbn))
-                                              (cmbnC (zero-cmbn (1+ (cmbn-degr cmbn))))
+					   (cmbnC (zero-cmbn
-                                              (cmbnB (cmbn-? g2 (cmbn-? f3 (cmbn-opps cmbnD)))))
+						   (1+ (cmbn-degr cmbn))))
+					   (cmbnB
+					    (cmbn-?
+					     g2 (cmbn-? f3 (cmbn-opps cmbnD)))))
 				      (declare (type cmbn cmbnD cmbnC cmbnB))
 				      (make-bicn-cmbn cmbnB cmbnC cmbnD)))
 			  :strt :cmbn
@@ -397,14 +357,18 @@
 					(dispatch-bicn-cmbn cmbn)
 				      (declare (type cmbn cmbnB cmbnC cmbnD))
 				      (setf cmbnD (cmbn-? h4 cmbnD))
-                                          (let ((cmbnC (zero-cmbn (1+ (cmbn-degr cmbnC))))
+				      (let ((cmbnC (zero-cmbn
-                                                (cmbnB1 (cmbn-? g2 (cmbn-? f3 cmbnD)))
+						    (1+ (cmbn-degr cmbnC))))
+					    (cmbnB1 (cmbn-? g2
+							    (cmbn-? f3 cmbnD)))
 					    (cmbnB2 (cmbn-? g2 cmbnC))  ;; let, not let*
 					    (cmbnB3 (cmbn-? h2 cmbnB)))
-                                             (declare (type cmbn cmbnC cmbnB1 cmbnB2 cmbnB3))
+					(declare (type cmbn cmbnC cmbnB1 cmbnB2
+						       cmbnB3))
 					(make-bicn-cmbn
 					 (2cmbn-sbtr cmpr-B
-                                                   (2cmbn-add cmpr-B cmbnB2 cmbnB3)
+						     (2cmbn-add cmpr-B cmbnB2
+								cmbnB3)
 						     cmbnB1)
 					 cmbnC
 					 cmbnD))))
@@ -414,31 +378,3 @@
 		  (type morphism lf lg lh rf rg rh))
 		 (build-hmeq :lf lf :lg lg :lh lh :rf rf :rg rg :rh rh
 			     :orgn `(cmps ,hmeq1 ,hmeq2)))))))))
-   
-#|
-()
-(cat-init)
-(setf c (build-chcm
-         :cmpr #'s-cmpr
-         :basis #'(lambda (dmns) '(a))
-         :bsgn 'a
-         :intr-dffr #'zero-intr-dffr
-         :strt :cmbn
-         :orgn '(c)))
-(setf h1 (trivial-hmeq c))
-(setf h2 (cmps h1 h1))
-(pre-check-rdct (lrdct h2))
-(setf *tc* (cmbn 3 1 (bcnB 'a) 10 (bcnC 'a) 100 (bcnD 'a)))
-(setf *bc* (cmbn 3 1 'a))
-(check-rdct)
-(pre-check-rdct (rrdct h2))
-(check-rdct)
-(setf h3 (cmps h2 h2))
-(setf *tc* (cmbn 3 1 (bcnB (bcnB 'a)) 10 (bcnB (bcnC 'a)) 100 (bcnB (bcnD 'a))
-                 1000 (bcnC 'a)
-                 10000 (bcnD (bcnB 'a)) 5234 (bcnD (bcnC 'a)) 223 (bcnD (bcnD 'a))))
-(pre-check-rdct (lrdct h3))
-(check-rdct)
-(pre-check-rdct (rrdct h3))
-(check-rdct)
-|#

src/cones.lisp

@@ -224,7 +224,7 @@
 (funcall rslt 4 (con0 '31))
 (funcall rslt 5 (con1 '31))
 (funcall rslt 4 (con1 '15))
-; (funcall rslt (cmbn 4 1 (con0 '31) 1 (con1 '15)))
+; (funcall rslt (cmbn 4 1 (con0 '31) 1 (con1 '15))) ;
 |#
 
 (DEFUN CONE (mrph)
@@ -365,4 +365,3 @@
   (declare (type chain-complex chcm))
   (the homotopy-equivalence
        (cone-efhm chcm)))
-

src/macros.lisp

@@ -352,12 +352,18 @@
          ,@body))))
 
 (DEFMACRO BCNB (gnrt)
+  "(BCNB GNRT) returns the representation of the generator GNRT belonging to the
+chain complex B."
   `(make-bicn :bcnx :bcnb :ibicn ,gnrt))
 
 (DEFMACRO BCNC (gnrt)
+  "(BCNC GNRT) returns the representation of the generator GNRT belonging to the
+chain complex C."
   `(make-bicn :bcnx :bcnc :ibicn ,gnrt))
 
 (DEFMACRO BCND (gnrt)
+  "(BCND GNRT) returns the representation of the generator GNRT belonging to the
+chain complex D."
   `(make-bicn :bcnx :bcnd :ibicn ,gnrt))
 
 (DEFMACRO WITH-BICN ((bcnx ibicn) bicn . body)

test/bicones-test.lisp

@@ -0,0 +1,118 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(test bicn-cmbn
+      (let* ((comb-bic (cat:cmbn 3 2 (cat:bcnb 'b1) 4 (cat:bcnb 'b2)
+				 6 (cat:bcnb 'b3) 3 (cat:bcnc 'c1)
+				 5 (cat:bcnc 'c2) 7 (cat:bcnd 'd1))))
+	(cat:cmbn-list comb-bic)
+	(cat:dispatch-bicn-cmbn (cat:cmbn 3 3 (cat:bcnb 'b1)
+					  4 (cat:bcnb 'b2)
+					  33 (cat:bcnc 'c)
+					  333 (cat:bcnd 'd)))))
+
+(test bicn-cmbn-cmbn*
+      (is (cat:cmbn-non-zero-p
+	   (cat:bicn-cmbn-cmbnb (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)))))
+      (is (cat:cmbn-zero-p
+	   (cat:bicn-cmbn-cmbnb (cat:cmbn 3 2 (cat:bcnc 'b)))))
+      (is (cat:cmbn-non-zero-p
+	   (cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)
+					  3 (cat:bcnd 'c)))))
+      (is (cat:cmbn-zero-p
+	   (cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 3 (cat:bcnd 'c)))))
+      (is (cat:cmbn-non-zero-p
+	   (cat:bicn-cmbn-cmbnd (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)
+					  3 (cat:bcnd 'c)))))
+      (is (cat:cmbn-zero-p
+	   (cat:bicn-cmbn-cmbnd (cat:cmbn 3 2 (cat:bcnb 'b))))))
+
+(test make-bicn-cmbn
+      (multiple-value-call #'cat:make-bicn-cmbn
+	(cat:dispatch-bicn-cmbn
+	 (cat:cmbn 3 3 (cat:bcnb 'b1) 4 (cat:bcnb 'b2) 33 (cat:bcnc 'c)
+		   333 (cat:bcnd 'd)))))
+
+(test bicn-print
+      (let ((a (format nil "~A" (cat:bcnb 'a)))
+	    (b (format nil "~A" (cat:bcnc 'b)))
+	    (c (format nil "~A" (cat:bcnd 'c))))
+	(is (string= a "<BcnB A>"))
+	(is (string= b "<BcnC B>"))
+	(is (string= c "<BcnD C>"))))
+
+(test bicone-cmpr
+      (let ((r (cat:bicone-cmpr #'cat:f-cmpr #'cat:f-cmpr #'cat:f-cmpr)))
+	(is (equal :less (funcall r (cat:bcnb 1) (cat:bcnc 0))))
+	(is (equal :less (funcall r (cat:bcnb 1) (cat:bcnb 2))))))
+
+(test bicone-basis
+      (is (equal :locally-effective
+		 (cat:bicone-basis :locally-effective
+				   :locally-effective
+				   :locally-effective)))
+      (let* ((b #'(lambda (degr)
+		    (mapcar #'(lambda (item)
+				(cons degr item)) (cat:<a-b> 0 degr))))
+	     (r (cat:bicone-basis b b b)))
+	(is (not (null (funcall r 3))))))
+
+
+(test bicone
+      (progn
+	(cat:cat-init)
+	(let ((delta3 (cdelta1 3))
+	      (bic (cat:bicone (make-rdct1 3 2) (make-rdct1 4 2))))
+	  #|
+	  (princ (cat:basis delta3 0))
+	  (princ (cat:basis delta3 1))
+	  (princ (cat:basis delta3 2))
+	  (princ (cat:basis delta3 3))
+	  (princ (cat:basis delta3 4))
+	  |#
+	  (princ (cat:basis bic 0))
+	  (princ (cat:basis bic 1))
+	  (princ (cat:basis bic 4))
+	  (princ (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3))
+				      4 (cat:bcnc '(0 1 2 3))
+				      5 (cat:bcnd '(0 1 4)))))
+	  (is (cat:cmbn-zero-p
+	       (cat:? bic
+		      (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3))
+					   4 (cat:bcnc '(0 1 2 3))
+					   5 (cat:bcnd '(0 1 4))))))))))
+
+
+(test cmps
+      (progn
+	(cat:cat-init)
+	(let* ((c (cat:build-chcm
+		  :cmpr #'cat:s-cmpr
+		  :basis #'(lambda (dmns) '(a))
+		  :bsgn 'a
+		  :intr-dffr #'cat:zero-intr-dffr
+		  :strt :cmbn
+		  :orgn '(c)))
+	       (h1 (cat:trivial-hmeq c))
+	       (h2 (cat:cmps h1 h1))
+	       (h3 (cat:cmps h2 h2)))
+	  (cat:pre-check-rdct (cat:lrdct h2))
+	  (setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB 'a) 10 (cat:bcnC 'a)
+			       100 (cat:bcnD 'a)))
+	  (setf cat:*bc* (cat:cmbn 3 1 'a))
+	  (check-rdct)
+	  (cat:pre-check-rdct (cat:rrdct h2))
+	  (check-rdct)
+	  (setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB (cat:bcnB 'a))
+				   10 (cat:bcnB (cat:bcnC 'a))
+				   100 (cat:bcnB (cat:bcnD 'a))
+				   1000 (cat:bcnC 'a)
+				   10000 (cat:bcnD (cat:bcnB 'a))
+				   5234 (cat:bcnD (cat:bcnC 'a))
+				   223 (cat:bcnD (cat:bcnD 'a))))
+	  (cat:pre-check-rdct (cat:lrdct h3))
+	  (check-rdct)
+	  (cat:pre-check-rdct (cat:rrdct h3))
+	  (check-rdct))))

test/chain-complexes-test.lisp

@@ -45,20 +45,7 @@
 	  (is (equal (cat:cmbn-list comb) (cons (cons 1 n) nil))))))))
 
 
-(defparameter *n* 10)
+(setf *n* 10)
-(defun ff (degr i)
-  (do ((2*n* (ash *n* 1))
-       (rslt cat:+empty-list+
-             (cons (cons (let ((cffc (- (random 2*n*) *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 degr
-        :list rslt))))
 
 (test cmbn-?
   (progn

test/chcm-elementary-op-test.lisp

@@ -44,20 +44,7 @@
 	  (is (eq -zi -zi2)))))
 
 
-(defparameter *n* 5)
+(setf *n* 5)
-(defun ff (degr i)
-  (do ((2*n* (ash *n* 1))
-       (rslt cat:+empty-list+
-	     (cons (cons (let ((cffc (- (random 2*n*) *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 degr
-	:list rslt))))
 
 (test cmps
       (progn

test/common.lisp

@@ -0,0 +1,170 @@
+
+(in-package :kenzo-test)
+
+(def-suite :kenzo)
+
+(defparameter *n* -1)
+
+(defun ff (degr i)
+  (declare (special *n*))
+  (do ((2*n* (ash *n* 1))
+       (rslt cat:+empty-list+
+             (cons (cons (let ((cffc (- (random 2*n*) *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 degr :list rslt))))
+
+
+(defun cdelta (dmns)
+  (the cat:chain-complex
+       (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))
+
+(defun cdelta1 (dmns)
+  (cat:build-chcm
+   :cmpr #'cat:l-cmpr
+   :basis #'(lambda (n)
+	      (mapcar #'cat:dlop-int-ext (funcall (cat:delta-n-basis dmns) n)))
+   :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-f1 (tdmns bdmns)
+  (cat:build-mrph
+   :sorc (cdelta1 tdmns) :trgt (cdelta1 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-g1 (tdmns bdmns)
+  (cat:build-mrph
+   :sorc (cdelta1 bdmns) :trgt (cdelta1 tdmns) :degr 0
+   :intr #'identity
+   :strt :cmbn
+   :orgn `(injection delta ,bdmns => delta ,tdmns)))
+
+
+(defun make-h1 (tdmns bdmns)
+  (cat:build-mrph
+   :sorc (cdelta1 tdmns) :trgt (cdelta1 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-rdct1 (tdmns bdmns)
+  (let ((rdct (cat:build-rdct
+	      :f (make-f1 tdmns bdmns)
+	      :g (make-g1 tdmns bdmns)
+	      :h (make-h1 tdmns bdmns)
+	      :orgn `(reduction delta ,tdmns ,bdmns))))
+    rdct))
+
+
+(defun check-rdct ()
+  (dolist (phi '(cat:*tdd* cat:*bdd* cat:*df-fd* cat:*dg-gd* cat:*id-fg*
+		 cat:*id-gf-dh-hd* cat:*hh* cat:*fh* cat:*hg*))
+    (declare (type symbol phi))
+    (is (cat:cmbn-zero-p
+	 (cat:cmbn-? (eval phi)
+		     (if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg*
+				       cat:*dg-gd* cat:*hg*))
+			 cat:*bc*
+			 cat:*tc*))))))

test/effective-homology-test.lisp

@@ -3,27 +3,6 @@
 
 (in-suite :kenzo)
 
-(defun cdelta (dmns)
-  (the cat:chain-complex
-       (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))))
-
 (test cdelta
       (progn
 	(cat:cat-init)
@@ -38,63 +17,6 @@
 	  (signals simple-error (equal (cat:basis cc 5) cat:+empty-list+)))))
 
 
-(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))
-
-
-(defun check-rdct ()
-  (dolist (phi '(cat:*tdd* cat:*bdd* cat:*df-fd* cat:*dg-gd* cat:*id-fg*
-		 cat:*id-gf-dh-hd* cat:*hh* cat:*fh* cat:*hg*))
-    (declare (type symbol phi))
-    (is (cat:cmbn-zero-p
-	 (cat:cmbn-? (eval phi)
-		     (if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg*
-				       cat:*dg-gd* cat:*hg*))
-			 cat:*bc*
-			 cat:*tc*))))))
-
 (test make-rdct
       (progn
 	(cat:cat-init)
@@ -106,6 +28,7 @@
 	  (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
 	  (check-rdct))))
 
+
 (test cmps
       (progn
 	(cat:cat-init)
@@ -118,6 +41,7 @@
 	  (setf cat:*bc* (cat:cmbn 2 1 '(0 1 3)))
 	  (check-rdct))))
 
+
 (test zero-mrph
       (progn
 	(cat:cat-init)
@@ -129,6 +53,7 @@
 	  (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
 	  (check-rdct))))
 
+
 (test opps
       (progn
 	(cat:cat-init)
@@ -140,6 +65,7 @@
 	  (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
 	  (check-rdct))))
 
+
 ;; an absurd reduction ; just to test bpl-*-sigma
 (test bpl-*-sigma
       (progn
@@ -175,6 +101,7 @@
 	  (cat:gnrt-? (cat:dffr (cat:tcc new-rdct)) 3 '(3 5))
 	  (cat:gnrt-? (cat:dffr (cat:bcc new-rdct)) 3 '(3 5)))))
 
+
 (test trivial-hmeq
       (progn
 	(cat:cat-init)