Added effective homology examples.

test/effective-homology-test.lisp

@@ -4,23 +4,39 @@
 (in-suite :kenzo)
 
 (defun cdelta (dmns)
-  (cat:build-chcm
+  (the cat:chain-complex
-   :cmpr #'cat:l-cmpr
+       (cat:build-chcm
-   :basis :locally-effective
+	:cmpr #'cat:l-cmpr
-   :bsgn '(0)
+	:basis :locally-effective
-   :intr-dffr #'(lambda (degr gmsm)
+	:bsgn '(0)
-		  (cat:make-cmbn
+	:intr-dffr #'(lambda (degr gmsm)
-		   :degr (1- degr)
+		       (cat:make-cmbn
-		   :list (do ((rslt cat:+empty-list+
+			:degr (1- degr)
-				    (cons (cons sign (append
+			:list (do ((rslt cat:+empty-list+
+					 (cons (cons sign
+						     (append
 						      (subseq gmsm 0 nark)
 						      (subseq gmsm (1+ nark))))
-					  rslt))
+					       rslt))
-			      (sign 1 (- sign))
+				   (sign 1 (- sign))
-			      (nark 0 (1+ nark)))
+				   (nark 0 (1+ nark)))
-			     ((> nark degr) rslt))))
+				  ((> nark degr) rslt))))
-   :strt :gnrt
+	:strt :gnrt
-   :orgn `(locally effective version of C_* delta ,dmns)))
+	:orgn `(locally effective version of C_* delta ,dmns))))
+
+(test cdelta
+      (progn
+	(cat:cat-init)
+	(let* ((cc (cdelta 5))
+	       (hmeq (cat:trivial-hmeq cc)))
+	  (declare (ignore hmeq))
+	  (signals simple-error (equal (cat:basis cc 0) cat:+empty-list+))
+	  (signals simple-error (equal (cat:basis cc 1) cat:+empty-list+))
+	  (signals simple-error (equal (cat:basis cc 2) cat:+empty-list+))
+	  (signals simple-error (equal (cat:basis cc 3) cat:+empty-list+))
+	  (signals simple-error (equal (cat:basis cc 4) cat:+empty-list+))
+	  (signals simple-error (equal (cat:basis cc 5) cat:+empty-list+)))))
+
 
 (defun make-f (tdmns bdmns)
   (cat:build-mrph
@@ -67,23 +83,102 @@
 	      :orgn `(reduction delta ,tdmns ,bdmns))))
     rdct))
 
-(test cdelta
+
+(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)
+	(let ((rdct (make-rdct 6 3)))
+	  (is (equal (cat:orgn rdct) '(REDUCTION DELTA 6 3)))
+	  (cat:pre-check-rdct rdct)
+	  (setf cat:*tc* (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4)
+				   1000 '(2 3 4)))
+	  (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
+	  (check-rdct))))
+
+(test cmps
+      (progn
+	(cat:cat-init)
+	(let* ((trdct (make-rdct 6 4))
+	       (brdct (make-rdct 4 3))
+	       (rdct (cat:cmps brdct trdct)))
+	  (cat:pre-check-rdct rdct)
+	  (setf cat:*tc* (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4)
+				    100 '(1 3 5) 10 '(1 4 5) 1 '(3 4 5)))
+	  (setf cat:*bc* (cat:cmbn 2 1 '(0 1 3)))
+	  (check-rdct))))
+
+(test zero-mrph
       (progn
 	(cat:cat-init)
 	(let* ((rdct (make-rdct 6 3))
-	       (f (cat:f rdct))
+	       (perturb (cat:zero-mrph (cdelta 6) (cdelta 6) -1))
-	       (g (cat:g rdct))
+	       (new-rdct (cat:add rdct perturb)))
-	       (h (cat:h rdct))
+	  (cat:pre-check-rdct new-rdct)
-	       (tcc (cat:tcc rdct))
+	  (setf cat:*tc* (cat:cmbn 2 3 '(0 1 2)))
-	       (bcc (cat:bcc rdct))
+	  (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
-	       (dh (cat:cmps (cat:dffr tcc) h))
+	  (check-rdct))))
-	       (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)))
 
-	  )
+(test opps
+      (progn
+	(cat:cat-init)
+	(let* ((rdct (make-rdct 6 3))
+	       (perturb (cat:opps (cat:dffr (cat:tcc rdct))))
+	       (new-rdct (cat:add rdct perturb)))
+	  (cat:pre-check-rdct new-rdct)
+	  (setf cat:*tc* (cat:cmbn 2 3 '(0 1 2)))
+	  (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
+	(cat:cat-init)
+	(let* ((tcc (cat:build-chcm
+		     :cmpr #'cat:l-cmpr
+		     :basis :locally-effective
+		     :bsgn '(0)
+		     :intr-dffr #'(lambda (degr gnrt)
+				    (cat:cmbn (1- degr) 1 gnrt))
+		     :strt :gnrt
+		     :orgn '(test1)))
+	       (rdct (cat:trivial-rdct tcc))
+	       (perturb (cat:build-mrph
+			 :sorc tcc :trgt tcc :degr -1
+			 :intr #'(lambda (degr gnrt)
+				   (if (zerop (first gnrt))
+				       (cat:zero-cmbn (1- degr))
+				       (cat:cmbn (1- degr) 1
+						 (list (1- (first gnrt))
+						       (1+ (second gnrt))))))
+			 :strt :gnrt
+			 :orgn '(test3)))
+	       (new-rdct))
+	  (setf (slot-value rdct 'cat:h)
+		(cat:build-mrph
+		 :sorc tcc :trgt tcc :degr +1
+		 :intr #'(lambda (degr gnrt)
+			   (cat:cmbn (1+ degr) 1 gnrt))
+		 :strt :gnrt
+		 :orgn '(test2)))
+	  (setf new-rdct (cat:add rdct perturb))
+	  (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)
+	(let ((hmeq (cat:trivial-hmeq (cdelta 4))))
+	  (cat:add (cat:lrdct hmeq) (cat:opps (cat:dffr (cdelta 4))))
+	  (setf hmeq (cat:add hmeq (cat:opps (cat:dffr (cdelta 4)))))
+	  (cat:gnrt-? (cat:dffr (cat:rbcc hmeq)) 3 '(0 1 2 3)))))