Updated formatting. Moved examples to the test file.

src/effective-homology.lisp

@@ -24,6 +24,8 @@
 
 (DEFUN RDCT (n)
   (declare (fixnum n))
+  "Retrieve the N-th user created reduction from the list *RDCT-LIST*.
+Return NIL if it doesn't exist."
   (the (or null reduction)
        (find n *rdct-list* :key #'idnm)))
 
@@ -31,6 +33,7 @@
   (declare
    (type morphism f g h)
    (list orgn))
+  "Create a reduction. Use this function instead of the generic MAKE-INSTANCE."
   (the reduction
        (progn
          (unless orgn
@@ -147,8 +150,10 @@
 	   (when already
 	     (return-from build-hmeq already)))
          (build-hmeq
-          :lrdct (build-rdct :f lf :g lg :h lh :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh lrdct))
+          :lrdct (build-rdct :f lf :g lg :h lh
-          :rrdct (build-rdct :f rf :g rg :h rh :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct))
+			     :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh lrdct))
+          :rrdct (build-rdct :f rf :g rg :h rh
+			     :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct))
           :orgn orgn))))
 
 (DEFUN TRIVIAL-HMEQ (chcm)
@@ -158,12 +163,6 @@
    :rrdct (trivial-rdct chcm)
    :orgn `(trivial-hmeq ,chcm)))
 
-#|
-  (cat-init)
-  (setf cc (cdelta 5))
-  (setf hmeq (trivial-hmeq cc))
-|# 
-
 ;; Functions.
 
 
@@ -207,14 +206,6 @@
     (read-line))
   (done))
 
-#|
-  (setf rdct (make-rdct 6 3))        ;;; defined in a previous test
-  (pre-check-rdct rdct)
-  (setf *tc* (cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) 1000 '(2 3 4)))
-  (setf *bc* (cmbn 3 4 '(0 1 2 3)))  
-  (check-rdct))
-|#
-
 (DEFMETHOD CMPS ((brdct reduction) (trdct reduction) &optional dummy)
   (declare (ignore dummy))
   (when (eq (first (orgn brdct)) 'trivial-rdct)
@@ -231,20 +222,9 @@
        :h (add th (i-cmps tg bh tf))
        :orgn `(cmps ,brdct ,trdct)))))
 
-#|
+;;
-  (setf trdct (make-rdct 6 4))
+;; BASIC PERTURBATION LEMMA.
-  (setf brdct (make-rdct 4 3))
+;;
-  (setf rdct (cmps brdct trdct))
-  (pre-check-rdct rdct)
-  (setf *tcc* (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))
-        *bcc* (cmbn 2 1 '(0 1 3)))
-  (check-rdct))
-|#
-
-;
-; BASIC PERTURBATION LEMMA.
-;
 
 (DEFMETHOD ADD ((rdct reduction) (perturbation morphism) &optional dummy)
   (declare (type null dummy))
@@ -295,12 +275,16 @@
 	   (declare
 	    (type chain-complex new-tcc new-bcc)
 	    (type morphism sigma new-f new-g new-h bottom-perturbation))
-            (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc :new-trgt new-bcc)
+	   (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc
-                  new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc :new-trgt new-tcc)
+					      :new-trgt new-bcc)
-                  new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc :new-trgt new-tcc))
+		 new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc
+					      :new-trgt new-tcc)
+		 new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
+					      :new-trgt new-tcc))
 	   (values
 	    (build-rdct :f new-f :g new-g :h new-h
-                  :orgn `(basic-perturbation-lemma ,reduction ,top-perturbation))
+			:orgn `(basic-perturbation-lemma ,reduction
+							 ,top-perturbation))
 	    bottom-perturbation)))))
 
 (DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation)
@@ -326,10 +310,14 @@
 	     (declare (type chain-complex new-bcc new-tcc))
 	     (values
 	      (build-rdct
-                     :f (dstr-change-sorc-trgt old-f :new-sorc new-tcc :new-trgt new-bcc)
+	       :f (dstr-change-sorc-trgt old-f :new-sorc new-tcc
-                     :g (dstr-change-sorc-trgt old-g :new-sorc new-bcc :new-trgt new-tcc)
+					 :new-trgt new-bcc)
-                     :h (dstr-change-sorc-trgt old-h :new-sorc new-tcc :new-trgt new-tcc)
+	       :g (dstr-change-sorc-trgt old-g :new-sorc new-bcc
-                     :orgn `(easy-perturbation-lemma ,reduction ,bottom-perturbation))
+					 :new-trgt new-tcc)
+	       :h (dstr-change-sorc-trgt old-h :new-sorc new-tcc
+					 :new-trgt new-tcc)
+	       :orgn `(easy-perturbation-lemma ,reduction
+					       ,bottom-perturbation))
 	      top-perturbation))))))
 
 (DEFUN SPECIAL-BPL (reduction top-perturbation)
@@ -358,7 +346,8 @@
 	    (type morphism sigma new-f new-h))
 	   (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc)
 		 old-g (dstr-change-sorc-trgt old-g :new-trgt new-tcc)
-                  new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc :new-trgt new-tcc))
+		 new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
+					      :new-trgt new-tcc))
 	   (build-rdct :f new-f :g old-g :h new-h
 		       :orgn `(special-bpl ,reduction ,top-perturbation))))))
 
@@ -389,7 +378,8 @@
 	    (type morphism sigma new-g new-h))
 	   (setf old-f (dstr-change-sorc-trgt old-f :new-sorc new-tcc)
 		 new-g (dstr-change-sorc-trgt new-g :new-trgt new-tcc)
-                  new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc :new-trgt new-tcc))
+		 new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
+					      :new-trgt new-tcc))
 	   (values
 	    (build-rdct :f old-f :g new-g :h new-h
 			:orgn `(special-bpl-2 ,reduction ,top-perturbation)))))))
@@ -408,7 +398,8 @@
 		 (fixnum degr)
 		 (type gnrt gnrt))
                 (do ((rslt (zero-cmbn degr) (2cmbn-add cmpr rslt iterated))
-                     (iterated (term-cmbn degr 1 gnrt) (cmbn-opps (cmbn-? h-delta iterated))))
+                     (iterated (term-cmbn degr 1 gnrt)
+			       (cmbn-opps (cmbn-? h-delta iterated))))
                     ((cmbn-zero-p iterated) rslt)
 		  (declare (type cmbn rslt iterated)))))
 	   (build-mrph
@@ -417,61 +408,8 @@
 	    :strt :gnrt
 	    :orgn `(bpl-*-sigma ,homotopy ,perturbation))))))
 
-#|
+(DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism)
-  (cat-init)
+		&optional dummy)
-  (setf rdct (make-rdct 6 3))
-  (setf perturb (zero-mrph (cdelta 6) (cdelta 6) -1))
-  (setf new-rdct (add rdct perturb))
-  (pre-check-rdct new-rdct)
-  (setf *tc* (cmbn 2 3 '(0 1 2))
-        *bc* (cmbn 3 4 '(0 1 2 3)))
-  (check-rdct))
-|#
-
-#|
-  (cat-init)
-  (setf rdct (make-rdct 6 3))
-  (setf perturb (opps (dffr (tcc rdct))))
-  (setf new-rdct (add rdct perturb))
-  (pre-check-rdct new-rdct)
-  (setf *tc* (cmbn 2 3 '(0 1 2))
-        *bc* (cmbn 3 4 '(0 1 2 3)))
-  (check-rdct))
-|#
-
-#|  ;; an absurd reduction ; just to test bpl-*-sigma
-  (cat-init)
-  (setf tcc (build-chcm
-               :cmpr #'l-cmpr
-               :basis :locally-effective
-               :bsgn '(0)
-               :intr-dffr #'(lambda (degr gnrt)
-                               (cmbn (1- degr) 1 gnrt))
-               :strt :gnrt
-               :orgn '(test1)))
-  (setf rdct (trivial-rdct tcc))
-  (setf (slot-value rdct 'h)
-        (build-mrph
-           :sorc tcc :trgt tcc :degr +1
-           :intr #'(lambda (degr gnrt)
-                      (cmbn (1+ degr) 1 gnrt))
-           :strt :gnrt
-           :orgn '(test2)))
-  (setf perturb
-        (build-mrph
-           :sorc tcc :trgt tcc :degr -1
-           :intr #'(lambda (degr gnrt)
-                      (if (zerop (first gnrt))
-                         (zero-cmbn (1- degr))   
-                         (cmbn (1- degr) 1 (list (1- (first gnrt)) (1+ (second gnrt))))))
-           :strt :gnrt
-           :orgn '(test3)))
-  (setf new-rdct (add rdct perturb))
-  (gnrt-? (dffr (tcc new-rdct)) 3 '(3 5))
-  (gnrt-? (dffr (bcc new-rdct)) 3 '(3 5))
-|#
-
-(DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism) &optional dummy)
   (declare (ignore dummy))
   (the homotopy-equivalence
        (with-slots (lrdct rrdct) hmeq
@@ -485,11 +423,3 @@
 	    :lrdct new-lrdct
 	    :rrdct (add rrdct top-perturbation)
 	    :orgn `(add ,hmeq ,lb-perturbation))))))
-
-#|
-  (cat-init)
-  (setf hmeq (trivial-hmeq (cdelta 4)))
-  (add (lrdct hmeq) (opps (dffr (cdelta 4))))
-  (setf hmeq (add hmeq (opps (dffr (cdelta 4)))))
-  (gnrt-? (dffr (rbcc hmeq)) 3 '(0 1 2 3)))
-|#