From b6c2f46f4f13649518974bc962ae8661c1d2a9a8 Mon Sep 17 00:00:00 2001
From: Gerd Heber <gheber@hdfgroup.org>
Date: Sat, 4 Jul 2015 16:50:59 -0500
Subject: [PATCH] Updated formatting. Moved examples to the test file.

---
 src/effective-homology.lisp | 642 ++++++++++++++++--------------------
 1 file changed, 286 insertions(+), 356 deletions(-)

diff --git a/src/effective-homology.lisp b/src/effective-homology.lisp
index fde20b9..a99fba2 100644
--- a/src/effective-homology.lisp
+++ b/src/effective-homology.lisp
@@ -14,66 +14,69 @@
 #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((rdct reduction) stream)
- (the reduction
-   (progn
-      (format stream "[K~D Reduction K~D => K~D]"
-	      (idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct)))
-     rdct)))
+  (the reduction
+       (progn
+	 (format stream "[K~D Reduction K~D => K~D]"
+		 (idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct)))
+	 rdct)))
 #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (ext:package-lock :clos) t))
 
 (DEFUN RDCT (n)
-   (declare (fixnum n))
-   (the (or null reduction)
-      (find n *rdct-list* :key #'idnm)))
+  (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)))
 
 (DEFUN BUILD-RDCT (&key f g h orgn)
-   (declare
-      (type morphism f g h)
-      (list orgn))
-   (the reduction
-      (progn
+  (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
-            (setf orgn `(build-rdct ,f ,g ,h)))
+	   (setf orgn `(build-rdct ,f ,g ,h)))
          (let ((already (find orgn *rdct-list* :test #'equal :key #'orgn)))
-            (declare (type (or reduction null) already))
-            (when already
-               (return-from build-rdct already)))
+	   (declare (type (or reduction null) already))
+	   (when already
+	     (return-from build-rdct already)))
          (with-slots ((fsorc sorc) (ftrgt trgt) (fdegr degr)) f
-            (declare
-               (type chain-complex fsorc ftrgt)
-               (fixnum fdegr))
-         (with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g
-            (declare
-               (type chain-complex gsorc gtrgt)
-               (fixnum gdegr))
-         (with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h
-            (declare
-               (type chain-complex hsorc htrgt)
-               (fixnum hdegr))
-            (unless (and (eq gsorc ftrgt)
-                         (eq fsorc gtrgt)
-                         (eq hsorc fsorc)
-                         (eq htrgt fsorc)
-                         (zerop fdegr)
-                         (zerop gdegr)
-                         (= +1 hdegr))
-               (error "In BUILD-RDCT, the data are non coherent."))
-            (let ((rdct (make-instance 'reduction
-                           :tcc fsorc :bcc ftrgt
-                           :f f :g g :h h
-                           :orgn orgn)))
-               (declare (type reduction rdct))
-               (push rdct *rdct-list*)
-               rdct)))))))
+	   (declare
+	    (type chain-complex fsorc ftrgt)
+	    (fixnum fdegr))
+	   (with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g
+	     (declare
+	      (type chain-complex gsorc gtrgt)
+	      (fixnum gdegr))
+	     (with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h
+	       (declare
+		(type chain-complex hsorc htrgt)
+		(fixnum hdegr))
+	       (unless (and (eq gsorc ftrgt)
+			    (eq fsorc gtrgt)
+			    (eq hsorc fsorc)
+			    (eq htrgt fsorc)
+			    (zerop fdegr)
+			    (zerop gdegr)
+			    (= +1 hdegr))
+		 (error "In BUILD-RDCT, the data are non coherent."))
+	       (let ((rdct (make-instance 'reduction
+					  :tcc fsorc :bcc ftrgt
+					  :f f :g g :h h
+					  :orgn orgn)))
+		 (declare (type reduction rdct))
+		 (push rdct *rdct-list*)
+		 rdct)))))))
 
 (DEFUN TRIVIAL-RDCT (chcm)
   (declare (type chain-complex chcm))
-   (build-rdct
-    :f (idnt-mrph chcm)
-    :g (idnt-mrph chcm)
-    :h (zero-mrph chcm chcm +1) 
-    :orgn `(trivial-rdct ,chcm)))
+  (build-rdct
+   :f (idnt-mrph chcm)
+   :g (idnt-mrph chcm)
+   :h (zero-mrph chcm chcm +1) 
+   :orgn `(trivial-rdct ,chcm)))
 
 ;;;
 ;;;  HOMOTOPY-EQUIVALENCES
@@ -84,33 +87,33 @@
   (:documentation "needed by ECL"))
 
 (DEFMETHOD BUILD-HMEQ ((keyword1 (eql :lrdct)) lrdct &key rrdct orgn)
-   (declare
-      (type reduction lrdct rrdct)
-      (list orgn))
-   (the homotopy-equivalence
-      (progn
+  (declare
+   (type reduction lrdct rrdct)
+   (list orgn))
+  (the homotopy-equivalence
+       (progn
          (with-slots ((lf f) (lg g) (lh h) (ltcc tcc) (lbcc bcc)) lrdct
-            (declare
-               (type morphism lf lg lh)
-               (type chain-complex ltcc lbcc))
-         (with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct
-            (declare
-               (type morphism rf rg rh)
-               (type chain-complex rtcc rbcc))         
-            (unless (eq ltcc rtcc)
+	   (declare
+	    (type morphism lf lg lh)
+	    (type chain-complex ltcc lbcc))
+	   (with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct
+	     (declare
+	      (type morphism rf rg rh)
+	      (type chain-complex rtcc rbcc))
+	     (unless (eq ltcc rtcc)
                (error "In BUILD-HMEQ (version from rdct), the tcc's are not the same."))
-            (unless orgn
+	     (unless orgn
                (setf orgn `(build-hmeq ,lrdct ,rrdct)))
-            (let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
+	     (let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
                (declare (type (or homotopy-equivalence null) already))
                (when already
-                  (return-from build-hmeq already)))
-            (let ((hmeq (make-instance 'homotopy-equivalence
-                           :lbcc lbcc :tcc ltcc :rbcc rbcc
-                           :lf lf :lg lg :lh lh
-                           :rf rf :rg rg :rh rh
-                           :lrdct lrdct :rrdct rrdct
-                           :orgn orgn)))
+		 (return-from build-hmeq already)))
+	     (let ((hmeq (make-instance 'homotopy-equivalence
+					:lbcc lbcc :tcc ltcc :rbcc rbcc
+					:lf lf :lg lg :lh lh
+					:rf rf :rg rg :rh rh
+					:lrdct lrdct :rrdct rrdct
+					:orgn orgn)))
                (declare (type homotopy-equivalence hmeq))
                (push hmeq *hmeq-list*)
                hmeq))))))
@@ -119,77 +122,73 @@
 #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((hmeq homotopy-equivalence) stream)
- (the homotopy-equivalence
-   (progn
-      (format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]"
-	      (idnm hmeq)
-	      (idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq)))
-     hmeq)))
+  (the homotopy-equivalence
+       (progn
+	 (format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]"
+		 (idnm hmeq)
+		 (idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq)))
+	 hmeq)))
 #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (ext:package-lock :clos) t))
 
 
 (DEFMETHOD HMEQ ((n integer))
-   (declare (fixnum n))
-   (the (or homotopy-equivalence null)
-      (find n *hmeq-list* :key #'idnm)))
+  (declare (fixnum n))
+  (the (or homotopy-equivalence null)
+       (find n *hmeq-list* :key #'idnm)))
 
 (DEFMETHOD BUILD-HMEQ ((keyword1 (eql :lf)) lf &key lg lh rf rg rh orgn)
-   (declare
-      (type morphism lf lg lh rf rg rh)
-      (list orgn))
-   (the homotopy-equivalence
-      (progn
+  (declare
+   (type morphism lf lg lh rf rg rh)
+   (list orgn))
+  (the homotopy-equivalence
+       (progn
          (unless orgn
-            (setf orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh)))
+	   (setf orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh)))
          (let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
-            (declare (type (or null homotopy-equivalence) already))
-            (when already
-               (return-from build-hmeq already)))
+	   (declare (type (or null homotopy-equivalence) already))
+	   (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))
-          :rrdct (build-rdct :f rf :g rg :h rh :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct))
+          :lrdct (build-rdct :f lf :g lg :h lh
+			     :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)
-   (declare (type chain-complex chcm))
-   (build-hmeq
-      :lrdct (trivial-rdct chcm)
-      :rrdct (trivial-rdct chcm)
-      :orgn `(trivial-hmeq ,chcm)))
-
-#|
-  (cat-init)
-  (setf cc (cdelta 5))
-  (setf hmeq (trivial-hmeq cc))
-|# 
+  (declare (type chain-complex chcm))
+  (build-hmeq
+   :lrdct (trivial-rdct chcm)
+   :rrdct (trivial-rdct chcm)
+   :orgn `(trivial-hmeq ,chcm)))
 
 ;; Functions.
 
 
 (DEFUN PRE-CHECK-RDCT (rdct)
-   (declare (type reduction rdct))
-   (with-slots (bcc tcc f g h) rdct
-      (declare
-         (type chain-complex bcc tcc)
-         (type morphism f g h))
-      (setf *tdd* (cmps tcc tcc)
-            *bdd* (cmps bcc bcc)
-            *df-fd* (sbtr
-                       (cmps bcc f)
-                       (cmps f tcc))
-            *dg-gd* (sbtr
-                       (cmps tcc g)
-                       (cmps g bcc))
-            *id-fg* (sbtr (idnt-mrph bcc) (cmps f g))
-            *id-gf-dh-hd* (i-sbtr (idnt-mrph tcc)
-                             (cmps g f)
-                             (cmps tcc h)
-                             (cmps h tcc))
-            *hh* (cmps h h)
-            *fh* (cmps f h)
-            *hg* (cmps h g)))
-   (done))
+  (declare (type reduction rdct))
+  (with-slots (bcc tcc f g h) rdct
+    (declare
+     (type chain-complex bcc tcc)
+     (type morphism f g h))
+    (setf *tdd* (cmps tcc tcc)
+	  *bdd* (cmps bcc bcc)
+	  *df-fd* (sbtr
+		   (cmps bcc f)
+		   (cmps f tcc))
+	  *dg-gd* (sbtr
+		   (cmps tcc g)
+		   (cmps g bcc))
+	  *id-fg* (sbtr (idnt-mrph bcc) (cmps f g))
+	  *id-gf-dh-hd* (i-sbtr (idnt-mrph tcc)
+				(cmps g f)
+				(cmps tcc h)
+				(cmps h tcc))
+	  *hh* (cmps h h)
+	  *fh* (cmps f h)
+	  *hg* (cmps h g)))
+  (done))
 
 
 (DEFUN CHECK-RDCT ()
@@ -197,299 +196,230 @@
     (declare (type symbol cmbn))
     (format t "~%~A => ~A" cmbn (eval cmbn)))
   (dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd*
-		       *hh* *fh* *hg*))
+		 *hh* *fh* *hg*))
     (declare (type symbol phi))
     (format t "~%Checking ~A = 0" phi)
     (format t "~%Result: ")
     (princ (cmbn-? (eval phi)
-              (if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
-                 *bc* *tc*)))
+		   (if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
+		       *bc* *tc*)))
     (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)
-     (return-from cmps trdct))
+    (return-from cmps trdct))
   (when (eq (first (orgn trdct)) 'trivial-rdct)
-     (return-from cmps brdct))
+    (return-from cmps brdct))
   (with-slots ((tf f) (tg g) (th h)) trdct
     (declare (type morphism tf tg th))
-  (with-slots ((bf f) (bg g) (bh h)) brdct
-    (declare (type morphism bf bg bh))
-    (build-rdct
+    (with-slots ((bf f) (bg g) (bh h)) brdct
+      (declare (type morphism bf bg bh))
+      (build-rdct
        :f (cmps bf tf)
        :g (cmps tg bg)
        :h (add th (i-cmps tg bh tf))
        :orgn `(cmps ,brdct ,trdct)))))
 
-#|
-  (setf trdct (make-rdct 6 4))
-  (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.
-;
+;;
+;; BASIC PERTURBATION LEMMA.
+;;
 
 (DEFMETHOD ADD ((rdct reduction) (perturbation morphism) &optional dummy)
-   (declare (type null dummy))
-   (when dummy
-      (error "Why a third argument in (ADD REDUCTION MORPHISM)?"))
-   (when (eq (grmd (tcc rdct)) (grmd (sorc perturbation)))
-      (return-from add
-         (basic-perturbation-lemma rdct perturbation)))
-   (when (eq (grmd (bcc rdct)) (grmd (sorc perturbation)))
-      (return-from add
-         (easy-perturbation-lemma rdct perturbation)))
-   (error "In (METHOD ADD REDUCTION MORPHISM),~@
+  (declare (type null dummy))
+  (when dummy
+    (error "Why a third argument in (ADD REDUCTION MORPHISM)?"))
+  (when (eq (grmd (tcc rdct)) (grmd (sorc perturbation)))
+    (return-from add
+      (basic-perturbation-lemma rdct perturbation)))
+  (when (eq (grmd (bcc rdct)) (grmd (sorc perturbation)))
+    (return-from add
+      (easy-perturbation-lemma rdct perturbation)))
+  (error "In (METHOD ADD REDUCTION MORPHISM),~@
            the data do not sound like coherent."))
 
 (DEFUN BASIC-PERTURBATION-LEMMA (reduction top-perturbation)
-   (declare
-      (type reduction reduction)
-      (type morphism top-perturbation))
-   (the (values reduction morphism)
-      (with-slots ((old-tcc tcc) (old-bcc bcc)
-                   (old-f f) (old-g g) (old-h h)) reduction
+  (declare
+   (type reduction reduction)
+   (type morphism top-perturbation))
+  (the (values reduction morphism)
+       (with-slots ((old-tcc tcc) (old-bcc bcc)
+		    (old-f f) (old-g g) (old-h h)) reduction
          (declare
-            (type chain-complex old-tcc old-bcc)
-            (type morphism old-f old-g old-h))
+	  (type chain-complex old-tcc old-bcc)
+	  (type morphism old-f old-g old-h))
          (when (eq (first (orgn top-perturbation)) 'zero-mrph)
-            (return-from basic-perturbation-lemma
-               (values reduction (zero-mrph old-bcc))))
+	   (return-from basic-perturbation-lemma
+	     (values reduction (zero-mrph old-bcc))))
          (when (eq (first (orgn (h reduction))) 'zero-mrph)
-            (return-from basic-perturbation-lemma
-               (values
-                  (trivial-rdct (add old-tcc top-perturbation))
-                  (i-cmps old-f top-perturbation old-g))))      
+	   (return-from basic-perturbation-lemma
+	     (values
+	      (trivial-rdct (add old-tcc top-perturbation))
+	      (i-cmps old-f top-perturbation old-g))))
          (let* ((sigma (bpl-*-sigma old-h top-perturbation))
-                (new-f (cmps old-f 
-                          (sbtr (idnt-mrph old-tcc)
-                             (i-cmps
-                                top-perturbation
-                                sigma
-                                old-h))))
+                (new-f (cmps old-f
+			     (sbtr (idnt-mrph old-tcc)
+				   (i-cmps
+				    top-perturbation
+				    sigma
+				    old-h))))
                 (new-g (cmps sigma old-g))
                 (new-h (cmps sigma old-h))
                 (bottom-perturbation (i-cmps
-                                        old-f
-                                        top-perturbation
-                                        new-g))
+				      old-f
+				      top-perturbation
+				      new-g))
                 (new-tcc (add old-tcc top-perturbation))
                 (new-bcc (add old-bcc bottom-perturbation)))
-            (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)
-                  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))
-               bottom-perturbation)))))
+	   (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)
+		 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))
+	    bottom-perturbation)))))
 
 (DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation)
-   (declare
-      (type reduction reduction)
-      (type morphism bottom-perturbation))
-   (the (values reduction morphism)
-      (with-slots ((old-tcc tcc) (old-bcc bcc)
-                   (old-f f) (old-g g) (old-h h)) reduction
+  (declare
+   (type reduction reduction)
+   (type morphism bottom-perturbation))
+  (the (values reduction morphism)
+       (with-slots ((old-tcc tcc) (old-bcc bcc)
+		    (old-f f) (old-g g) (old-h h)) reduction
          (declare
-            (type chain-complex old-tcc old-bcc)
-            (type morphism old-f old-g old-h))
+	  (type chain-complex old-tcc old-bcc)
+	  (type morphism old-f old-g old-h))
          (when (eq 'zero-mrph (first (orgn bottom-perturbation)))
-            (return-from easy-perturbation-lemma
-               (values reduction (zero-mrph old-tcc))))
+	   (return-from easy-perturbation-lemma
+	     (values reduction (zero-mrph old-tcc))))
 	 (when (eq 'trivial-rdct (first (orgn reduction)))
-	    (return-from easy-perturbation-lemma
-	       (trivial-rdct (add (bcc reduction) bottom-perturbation))))
+	   (return-from easy-perturbation-lemma
+	     (trivial-rdct (add (bcc reduction) bottom-perturbation))))
          (let ((top-perturbation (i-cmps old-g bottom-perturbation old-f)))
-            (declare (type morphism top-perturbation))
-            (let ((new-bcc (add old-bcc bottom-perturbation))
-                  (new-tcc (add old-tcc top-perturbation)))
-               (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)
-                     :g (dstr-change-sorc-trgt old-g :new-sorc new-bcc :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))))))
+	   (declare (type morphism top-perturbation))
+	   (let ((new-bcc (add old-bcc bottom-perturbation))
+		 (new-tcc (add old-tcc top-perturbation)))
+	     (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)
+	       :g (dstr-change-sorc-trgt old-g :new-sorc new-bcc
+					 :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)
-   (declare
-      (type reduction reduction)
-      (type morphism top-perturbation))
-   (when (eq (first (orgn top-perturbation)) 'zero-mrph)
-      (return-from special-bpl reduction))
-   (the reduction
-      (with-slots ((old-tcc tcc) (old-bcc bcc)
-                   (old-f f) (old-g g) (old-h h)) reduction
+  (declare
+   (type reduction reduction)
+   (type morphism top-perturbation))
+  (when (eq (first (orgn top-perturbation)) 'zero-mrph)
+    (return-from special-bpl reduction))
+  (the reduction
+       (with-slots ((old-tcc tcc) (old-bcc bcc)
+		    (old-f f) (old-g g) (old-h h)) reduction
          (declare
-            (type chain-complex old-tcc old-bcc)
-            (type morphism old-f old-g old-h))
+	  (type chain-complex old-tcc old-bcc)
+	  (type morphism old-f old-g old-h))
          (let* ((sigma (bpl-*-sigma old-h top-perturbation))
-                (new-f (cmps old-f 
-                          (sbtr (idnt-mrph old-tcc)
-                             (i-cmps
-                                top-perturbation
-                                sigma
-                                old-h))))
+                (new-f (cmps old-f
+			     (sbtr (idnt-mrph old-tcc)
+				   (i-cmps
+				    top-perturbation
+				    sigma
+				    old-h))))
                 (new-h (cmps sigma old-h))
                 (new-tcc (add old-tcc top-perturbation)))
-            (declare
-               (type chain-complex new-tcc)
-               (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))
-            (build-rdct :f new-f :g old-g :h new-h
-               :orgn `(special-bpl ,reduction ,top-perturbation))))))
+	   (declare
+	    (type chain-complex new-tcc)
+	    (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))
+	   (build-rdct :f new-f :g old-g :h new-h
+		       :orgn `(special-bpl ,reduction ,top-perturbation))))))
 
 (DEFUN SPECIAL-BPL-2 (reduction top-perturbation)
-   (declare
-      (type reduction reduction)
-      (type morphism top-perturbation))
-   (the reduction
-      (with-slots ((old-tcc tcc) (old-bcc bcc)
-                   (old-f f) (old-g g) (old-h h)) reduction
+  (declare
+   (type reduction reduction)
+   (type morphism top-perturbation))
+  (the reduction
+       (with-slots ((old-tcc tcc) (old-bcc bcc)
+		    (old-f f) (old-g g) (old-h h)) reduction
          (declare
-            (type chain-complex old-tcc old-bcc)
-            (type morphism old-f old-g old-h))
+	  (type chain-complex old-tcc old-bcc)
+	  (type morphism old-f old-g old-h))
          (when (eq (first (orgn top-perturbation)) 'zero-mrph)
-            (return-from special-bpl-2
-               (values reduction (zero-mrph old-bcc))))
+	   (return-from special-bpl-2
+	     (values reduction (zero-mrph old-bcc))))
          (when (eq (first (orgn (h reduction))) 'zero-mrph)
-            (return-from special-bpl-2
-               (values
-                  (trivial-rdct (add old-tcc top-perturbation))
-                  (i-cmps old-f top-perturbation old-g))))      
+	   (return-from special-bpl-2
+	     (values
+	      (trivial-rdct (add old-tcc top-perturbation))
+	      (i-cmps old-f top-perturbation old-g))))
          (let* ((sigma (bpl-*-sigma old-h top-perturbation))
                 (new-g (cmps sigma old-g))
                 (new-h (cmps sigma old-h))
                 (new-tcc (add old-tcc top-perturbation)))
-            (declare
-               (type chain-complex new-tcc)
-               (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))
-            (values
-               (build-rdct :f old-f :g new-g :h new-h
-                  :orgn `(special-bpl-2 ,reduction ,top-perturbation)))))))
+	   (declare
+	    (type chain-complex new-tcc)
+	    (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))
+	   (values
+	    (build-rdct :f old-f :g new-g :h new-h
+			:orgn `(special-bpl-2 ,reduction ,top-perturbation)))))))
 
 (DEFUN BPL-*-sigma (homotopy perturbation)
-   (declare (type morphism homotopy perturbation))
-   (the morphism
-      (let ((cmpr (cmpr (sorc perturbation)))
-            (h-delta (cmps homotopy perturbation)))
+  (declare (type morphism homotopy perturbation))
+  (the morphism
+       (let ((cmpr (cmpr (sorc perturbation)))
+	     (h-delta (cmps homotopy perturbation)))
          (declare
-            (type cmprf cmpr)
-            (type morphism h-delta))
+	  (type cmprf cmpr)
+	  (type morphism h-delta))
          (flet
-            ((sigma-* (degr gnrt)
+	     ((sigma-* (degr gnrt)
                 (declare
-                   (fixnum degr)
-                   (type gnrt gnrt))
+		 (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
-               :sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0
-               :intr #'sigma-*
-               :strt :gnrt
-               :orgn `(bpl-*-sigma ,homotopy ,perturbation))))))
-     
-#|
-  (cat-init)
-  (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))
-|#
+		  (declare (type cmbn rslt iterated)))))
+	   (build-mrph
+	    :sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0
+	    :intr #'sigma-*
+	    :strt :gnrt
+	    :orgn `(bpl-*-sigma ,homotopy ,perturbation))))))
 
-#|
-  (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
+(DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism)
+		&optional dummy)
+  (declare (ignore dummy))
+  (the homotopy-equivalence
+       (with-slots (lrdct rrdct) hmeq
          (declare (type reduction lrdct rrdct))
          (multiple-value-bind (new-lrdct top-perturbation)
-                              (add lrdct lb-perturbation)
-            (declare
-               (type reduction new-lrdct)
-               (type morphism lb-perturbation))
-            (build-hmeq
-               :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)))
-|#
+	     (add lrdct lb-perturbation)
+	   (declare
+	    (type reduction new-lrdct)
+	    (type morphism lb-perturbation))
+	   (build-hmeq
+	    :lrdct new-lrdct
+	    :rrdct (add rrdct top-perturbation)
+	    :orgn `(add ,hmeq ,lb-perturbation))))))