diff --git a/kenzo-test.asd b/kenzo-test.asd
index 8bfe181..930072a 100644
--- a/kenzo-test.asd
+++ b/kenzo-test.asd
@@ -25,6 +25,7 @@
 	       (:file "cs-twisted-products-test")
 	       (:file "delta-test")
 	       (:file "diabolo")
+	       (:file "disk-pasting-test")
 	       (:file "effective-homology-test")
 	       (:file "homology-groups-test")
 	       (:file "k-pi-n-test")
diff --git a/package.lisp b/package.lisp
index 74bfa5c..7f3b754 100644
--- a/package.lisp
+++ b/package.lisp
@@ -241,10 +241,19 @@
 
 	   ;; disk-pasting.lisp
 
+	   CHCM-DISK-PASTING
 	   DISK-PASTING
+	   DISK-PASTING-BASIS
+	   DISK-PASTING-CMPR
+	   DISK-PASTING-FACE
+	   DISK-PASTING-INTR-DFFR
+	   HMEQ-DISK-PASTING
+	   MRPH-DISK-PASTING
+	   MRPH-DISK-PASTING-INTR
 
 	   ;; effective-homology.lisp
 
+	   BUILD-HMEQ
 	   BUILD-RDCT
 	   CHECK-RDCT
 	   CMPS
diff --git a/src/disk-pasting.lisp b/src/disk-pasting.lisp
index 659c34a..aa936ec 100644
--- a/src/disk-pasting.lisp
+++ b/src/disk-pasting.lisp
@@ -8,55 +8,39 @@
 
 (DEFUN DISK-PASTING-CMPR (cmpr new)
   (declare
-    (type cmprf cmpr)
-    (symbol new))
+   (type cmprf cmpr)
+   (symbol new))
   (flet ((rslt (gnrt1 gnrt2)
 	   (declare (type gnrt gnrt1 gnrt2))
 	   (if (eq gnrt1 new)
 	       (if (eq gnrt2 new)
 		   :equal
-		 :less)
-	     (if (eq gnrt2 new)
-		 :greater
-	       (funcall cmpr gnrt1 gnrt2)))))
+		   :less)
+	       (if (eq gnrt2 new)
+		   :greater
+		   (funcall cmpr gnrt1 gnrt2)))))
     (the cmprf #'rslt)))
 
-#|
-  (setf c (delta 3))
-  (setf cmpr (disk-pasting-cmpr (cmpr c) 'new))
-  (funcall cmpr 'new 'new)
-  (funcall cmpr 'new 5)
-  (funcall cmpr 5 'new)
-  (funcall cmpr 5 5)
-  (funcall cmpr 5 6)
-  (funcall cmpr 6 5)
-|#
 
 (DEFUN DISK-PASTING-BASIS (basis dmns new)
   (declare
-    (type basis basis)
-    (fixnum dmns)
-    (symbol new))
+   (type basis basis)
+   (fixnum dmns)
+   (symbol new))
   (flet ((rslt (degr)
 	   (declare (fixnum degr))
 	   (if (= degr dmns)
 	       (cons new (funcall basis dmns))
-	     (funcall basis degr))))
+	       (funcall basis degr))))
     (the basis #'rslt)))
 
-#|
-  (setf c (delta 3))
-  (setf basis (disk-pasting-basis (basis c) 3 'new))
-  (funcall basis 3)
-  (funcall basis 2)
-|#
 
 (DEFUN DISK-PASTING-INTR-DFFR (old-dffr degr new bndr)
   (declare
-    (type morphism old-dffr)
-    (fixnum degr)
-    (symbol new)
-    (type cmbn bndr))
+   (type morphism old-dffr)
+   (fixnum degr)
+   (symbol new)
+   (type cmbn bndr))
   (when (cmbn-non-zero-p (cmbn-? old-dffr bndr))
     (error "In CHCM-DISK-PASTING, the given boundary has a non-null boundary."))
   (let ((cmpr (cmpr (trgt old-dffr))))
@@ -64,72 +48,54 @@
     (flet ((rslt (cmbn)
 	     (declare (type cmbn cmbn))
 	     (with-cmbn (degr2 list) cmbn
-	       (unless (= degr degr2)
-		 (return-from rslt
-		   (cmbn-? old-dffr cmbn)))
-	       (unless list
-		 (return-from rslt
-		   (zero-cmbn (1- degr))))
-	       (unless (eq (-gnrt list) new)
-		 (return-from rslt
-		   (cmbn-? old-dffr cmbn)))
-	       (2cmbn-add cmpr
-		 (n-cmbn (-cffc list) bndr)
-		 (cmbn-? old-dffr
-			 (make-cmbn :degr degr
-				    :list (rest list)))))))
+			(unless (= degr degr2)
+			  (return-from rslt
+			    (cmbn-? old-dffr cmbn)))
+			(unless list
+			  (return-from rslt
+			    (zero-cmbn (1- degr))))
+			(unless (eq (-gnrt list) new)
+			  (return-from rslt
+			    (cmbn-? old-dffr cmbn)))
+			(2cmbn-add cmpr
+				   (n-cmbn (-cffc list) bndr)
+				   (cmbn-? old-dffr
+					   (make-cmbn :degr degr
+						      :list (rest list)))))))
       (the intr-mrph #'rslt))))
 
-#|
-  (cat-init)
-  (setf c (delta 3))
-  (setf intr (disk-pasting-intr-dffr (dffr c) 3 'new (cmbn 2 1 7)))
-  (setf intr (disk-pasting-intr-dffr (dffr c) 3 'new (? c 3 15)))
-  (funcall intr (cmbn 2 1 7))
-  (funcall intr (cmbn 3))
-  (funcall intr (cmbn 3 1 15))
-  (funcall intr (cmbn 3 1 'new 1 15))
-  (funcall intr (cmbn 3 1 'new -1 15))
-  (funcall intr (cmbn 3 -1 'new 1 15))
-  (funcall intr (cmbn 3 -1 'new -1 15))
-|#
- 
+
 (DEFUN CHCM-DISK-PASTING (chcm dmns new bndr)
   (declare
-    (type chain-complex chcm)
-    (fixnum dmns)
-    (symbol new)
-    (type cmbn bndr))
+   (type chain-complex chcm)
+   (fixnum dmns)
+   (symbol new)
+   (type cmbn bndr))
   (the chain-complex
-    (with-slots (cmpr basis dffr) chcm
-      (declare
-       (type cmprf cmpr)
-       (type basis basis)
-       (type morphism dffr))
-      (let ((rslt (build-chcm
-		   :cmpr (disk-pasting-cmpr cmpr new)
-		   :basis (disk-pasting-basis basis dmns new)
-		   :intr-dffr (disk-pasting-intr-dffr dffr dmns new bndr)
-		   :strt :cmbn
-		   :orgn `(chcm-disk-pasting ,chcm ,dmns ,new ,bndr))))
-	(declare (type chain-complex rslt))
-	(when (slot-boundp chcm 'bsgn)
-	  (setf (slot-value rslt 'bsgn) (slot-value chcm 'bsgn)))
-	rslt))))
+       (with-slots (cmpr basis dffr) chcm
+	 (declare
+	  (type cmprf cmpr)
+	  (type basis basis)
+	  (type morphism dffr))
+	 (let ((rslt (build-chcm
+		      :cmpr (disk-pasting-cmpr cmpr new)
+		      :basis (disk-pasting-basis basis dmns new)
+		      :intr-dffr (disk-pasting-intr-dffr dffr dmns new bndr)
+		      :strt :cmbn
+		      :orgn `(chcm-disk-pasting ,chcm ,dmns ,new ,bndr))))
+	   (declare (type chain-complex rslt))
+	   (when (slot-boundp chcm 'bsgn)
+	     (setf (slot-value rslt 'bsgn) (slot-value chcm 'bsgn)))
+	   rslt))))
 
-#|
-  (setf c (delta 3))
-  (setf s3 (chcm-disk-pasting c 3 'new (? c 3 15)))
-  (homology s3 0 5))
-|#
 
 (DEFUN DISK-PASTING-FACE (cmpr face dmns new faces)
   (declare
-    (type cmprf cmpr)
-    (type face face)
-    (fixnum dmns)
-    (symbol new)
-    (list faces))
+   (type cmprf cmpr)
+   (type face face)
+   (fixnum dmns)
+   (symbol new)
+   (list faces))
   (unless (= (1+ dmns) (length faces))
     (error "In DISK-PASTING, non-coherent arguments."))
   (mapl #'(lambda (mark)
@@ -139,147 +105,113 @@
 	faces)
   (flet ((rslt (indx dmns2 gmsm)
 	   (declare
-	     (fixnum indx dmns2)
-	     (type gmsm gmsm))
+	    (fixnum indx dmns2)
+	    (type gmsm gmsm))
 	   (unless (= dmns dmns2)
 	     (return-from rslt
 	       (funcall face indx dmns2 gmsm)))
 	   (if (eq gmsm new)
 	       (nth indx faces)
-	     (funcall face indx dmns gmsm))))
+	       (funcall face indx dmns gmsm))))
     (unless (check-faces cmpr #'rslt dmns new)
       (error "The new simplicial-set is not constructed."))
     (the face #'rslt)))
 
-#|
-  (cat-init)
-  (setf c (delta 3))
-  (setf face (disk-pasting-face (cmpr c) (face c)
-                3 'new (list 14 (absm 0 13) 11 7)))
-  (funcall face 0 2 7)
-  (funcall face 0 3 15)
-  (dotimes (i 4) (print (funcall face i 3 'new)))
-|#
 
 (DEFUN DISK-PASTING (smst dmns new faces)
   (declare
-    (type simplicial-set smst)
-    (fixnum dmns)
-    (symbol new)
-    (list faces))
+   (type simplicial-set smst)
+   (fixnum dmns)
+   (symbol new)
+   (list faces))
   (the simplicial-set
-    (with-slots (cmpr basis bsgn face dffr) smst
-      (declare
-       (type cmprf cmpr)
-       (type basis basis)
-       (type gmsm bsgn)
-       (type face face)
-       (type morphism dffr))
-      (let ((new-face (disk-pasting-face (cmpr smst) face
-					 dmns new faces))
-	    (new-bndr (zero-cmbn (1- dmns))))
-	(declare
-	  (type face new-face)
-	  (type cmbn new-bndr))
-	(do ((mark faces (cdr mark))
-	     (sign 1 (- sign)))
-	    ((endp mark))
-	    (declare
+       (with-slots (cmpr basis bsgn face dffr) smst
+	 (declare
+	  (type cmprf cmpr)
+	  (type basis basis)
+	  (type gmsm bsgn)
+	  (type face face)
+	  (type morphism dffr))
+	 (let ((new-face (disk-pasting-face (cmpr smst) face
+					    dmns new faces))
+	       (new-bndr (zero-cmbn (1- dmns))))
+	   (declare
+	    (type face new-face)
+	    (type cmbn new-bndr))
+	   (do ((mark faces (cdr mark))
+		(sign 1 (- sign)))
+	       ((endp mark))
+	     (declare
 	      (list mark)
 	      (fixnum sign))
-	  (let ((absm (car mark)))
-	    (declare (type absm absm))
-	    (with-absm (dgop gmsm) absm
-	      (unless (plusp dgop)
-		(dstr-add-term-to-cmbn cmpr sign gmsm new-bndr)))))
-	(build-smst
-	 :cmpr (disk-pasting-cmpr cmpr new)
-	 :basis (disk-pasting-basis basis dmns new)
-	 :bspn bsgn
-	 :face new-face
-	 :intr-bndr (disk-pasting-intr-dffr dffr dmns new new-bndr)
-	 :bndr-strt :cmbn
-	 :orgn `(disk-pasting ,smst ,dmns ,new ,faces))))))
+	     (let ((absm (car mark)))
+	       (declare (type absm absm))
+	       (with-absm (dgop gmsm) absm
+			  (unless (plusp dgop)
+			    (dstr-add-term-to-cmbn cmpr sign gmsm new-bndr)))))
+	   (build-smst
+	    :cmpr (disk-pasting-cmpr cmpr new)
+	    :basis (disk-pasting-basis basis dmns new)
+	    :bspn bsgn
+	    :face new-face
+	    :intr-bndr (disk-pasting-intr-dffr dffr dmns new new-bndr)
+	    :bndr-strt :cmbn
+	    :orgn `(disk-pasting ,smst ,dmns ,new ,faces))))))
 
-#|
-  (setf d2 (delta 2))
-  (setf s2 (disk-pasting d2 2 'new '(6 5 3)))
-  (homology s2 0 4)
-  (setf s2xs2 (crts-prdc s2 s2))
-  (homology s2xs2 0 6)
-|#
 
 (DEFUN MRPH-DISK-PASTING-INTR (mrph trgt-cmpr dmns new new-im)
   (declare
-    (type morphism mrph)
-    (type cmprf trgt-cmpr)
-    (fixnum dmns)
-    (symbol new)
-    (type cmbn new-im))
+   (type morphism mrph)
+   (type cmprf trgt-cmpr)
+   (fixnum dmns)
+   (symbol new)
+   (type cmbn new-im))
   (let ((mrph-degr (degr mrph)))
     (declare (fixnum mrph-degr))
     (flet ((rslt (cmbn)
 	     (declare (type cmbn cmbn))
 	     (with-cmbn (degr list) cmbn
-	       (unless (= degr dmns)
-		 (return-from rslt
-		   (cmbn-? mrph cmbn)))
-	       (unless list
-		 (return-from rslt
-		   (zero-cmbn (+ degr mrph-degr))))
-	       (unless (eq new (-gnrt list))
-		 (return-from rslt
-		   (cmbn-? mrph cmbn)))
-	       (2cmbn-add trgt-cmpr
-		 (n-cmbn (-cffc list) new-im)
-		 (cmbn-? mrph
-			 (make-cmbn :degr degr
-				    :list (rest list)))))))
+			(unless (= degr dmns)
+			  (return-from rslt
+			    (cmbn-? mrph cmbn)))
+			(unless list
+			  (return-from rslt
+			    (zero-cmbn (+ degr mrph-degr))))
+			(unless (eq new (-gnrt list))
+			  (return-from rslt
+			    (cmbn-? mrph cmbn)))
+			(2cmbn-add trgt-cmpr
+				   (n-cmbn (-cffc list) new-im)
+				   (cmbn-? mrph
+					   (make-cmbn :degr degr
+						      :list (rest list)))))))
       (the intr-mrph #'rslt))))
 
-#|
-  (setf m (idnt-mrph (delta 3)))
-  (setf intr
-        (mrph-disk-pasting-intr m (cmpr (delta 3))
-                                3 'new (cmbn 3 -1 15)))
-  (funcall intr (cmbn 2 3 7))
-  (funcall intr (cmbn 3))
-  (funcall intr (cmbn 3 4 15))
-  (funcall intr (cmbn 3 1 'new 1 15))
-  (funcall intr (cmbn 3 -1 'new 1 15))
-|#
 
 (DEFUN MRPH-DISK-PASTING (mrph new-sorc new-trgt dmns new new-im)
   (declare
-    (type morphism mrph)
-    (type chain-complex new-sorc new-trgt)
-    (fixnum dmns)
-    (symbol new)
-    (type cmbn new-im))
+   (type morphism mrph)
+   (type chain-complex new-sorc new-trgt)
+   (fixnum dmns)
+   (symbol new)
+   (type cmbn new-im))
   (the morphism
-    (build-mrph
-      :sorc new-sorc :trgt new-trgt :degr (degr mrph)
-      :intr (mrph-disk-pasting-intr mrph (cmpr new-trgt)
-				    dmns new new-im)
-      :strt :cmbn
-      :orgn `(mrph-disk-pasting ,mrph ,new-sorc ,new-trgt
-				,dmns ,new ,new-im))))
+       (build-mrph
+	:sorc new-sorc :trgt new-trgt :degr (degr mrph)
+	:intr (mrph-disk-pasting-intr mrph (cmpr new-trgt)
+				      dmns new new-im)
+	:strt :cmbn
+	:orgn `(mrph-disk-pasting ,mrph ,new-sorc ,new-trgt
+				  ,dmns ,new ,new-im))))
 
-#|
-  (setf d (delta 3))
-  (setf m (idnt-mrph d))
-  (setf sorc (chcm-disk-pasting d 3 'new (? d 3 15)))
-  (setf nm (mrph-disk-pasting m sorc sorc 3 'new (cmbn 3 1 'new)))
-  (? nm (cmbn 3 2 'new 3 15))
-|#
 
 (DEFUN HMEQ-DISK-PASTING (hmeq dmns new bndr &key new-lbcc)
   (declare
-    (type homotopy-equivalence hmeq)
-    (fixnum dmns)
-    (symbol new)
-    (type cmbn bndr)
-    (type (or null chain-complex) new-lbcc))
+   (type homotopy-equivalence hmeq)
+   (fixnum dmns)
+   (symbol new)
+   (type cmbn bndr)
+   (type (or null chain-complex) new-lbcc))
   (let* ((lg (lg hmeq))
 	 (rf (rf hmeq))
 	 (rh (rh hmeq))
@@ -289,108 +221,48 @@
 		       (chcm-disk-pasting (lbcc hmeq)
 					  dmns new bndr)))
 	 (new-tcc (chcm-disk-pasting (tcc hmeq)
-				      dmns new t-bndr))
+				     dmns new t-bndr))
 	 (new-rbcc (chcm-disk-pasting (rbcc hmeq)
 				      dmns new rb-bndr))
 	 (1+dmns (1+ dmns)))
     (declare
-      (type morphism lg rf rh)
-      (type cmbn t-bndr rb-bndr)
-      (type chain-complex new-lbcc new-tcc new-rbcc)
-      (fixnum 1+dmns))
+     (type morphism lg rf rh)
+     (type cmbn t-bndr rb-bndr)
+     (type chain-complex new-lbcc new-tcc new-rbcc)
+     (fixnum 1+dmns))
     (build-hmeq
-      :lrdct (build-rdct
-	       :f (mrph-disk-pasting (lf hmeq) new-tcc new-lbcc
-				     dmns new (cmbn dmns 1 new))
-	       :g (mrph-disk-pasting lg new-lbcc new-tcc
-				     dmns new (cmbn dmns 1 new))
-	       :h (mrph-disk-pasting (lh hmeq) new-tcc new-tcc
-				     dmns new (zero-cmbn 1+dmns)))
-      :rrdct (build-rdct
-	       :f (mrph-disk-pasting rf new-tcc new-rbcc
-				     dmns new (cmbn dmns 1 new))
-	       :g (mrph-disk-pasting (rg hmeq) new-rbcc new-tcc
-				     dmns new
-				     (make-cmbn
-				      :degr dmns
-				      :list (cons (term 1 new)
-						  (cmbn-list
-						   (cmbn-opps
-						    (cmbn-? rh t-bndr))))))
-	       :h (mrph-disk-pasting rh new-tcc new-tcc
-				     dmns new (zero-cmbn 1+dmns)))
-      :orgn `(hmeq-disk-pasting ,hmeq ,dmns ,new ,bndr))))
-				     
-#|
-(cat-init)
-(setf tcc
-      (build-chcm
-       :cmpr #'s-cmpr
-       :basis #'(lambda (degr)
-		  (case degr
-			(0 (list 'a))
-			(1 (list 'b))
-			(otherwise nil)))
-       :intr-dffr #'(lambda (degr gnrt)
-		      (if (= 1 degr)
-			  (cmbn 0 1 'a)
-			(zero-cmbn (1- degr))))
-       :strt :gnrt
-       :orgn '(z-z)))
-(setf bcc
-      (build-chcm
-       :cmpr #'s-cmpr
-       :basis #'(lambda (degr) nil)
-       :intr-dffr #'(lambda (degr gnrt) (error "Impossible."))
-       :strt :gnrt
-       :orgn '(zero)))
-(setf rh (build-mrph
-	  :sorc tcc :trgt tcc :degr +1
-	  :intr #'(lambda (degr gnrt)
-		    (if (zerop degr)
-			(cmbn 1 1 'b)
-		      (zero-cmbn 2)))
-	  :strt :gnrt
-	  :orgn '(rh)))
-(setf hmeq (build-hmeq
-	    :lrdct (trivial-rdct tcc)
-	    :rrdct (build-rdct
-		    :f (zero-mrph tcc bcc 0)
-		    :g (zero-mrph bcc tcc 0)
-		    :h rh
-		    :orgn '(rrdct))))
-(setf nhmeq (hmeq-disk-pasting hmeq 1 'new (cmbn 0 1 'a)))
-(pre-check-rdct (lrdct nhmeq))
-(setf *tc* (cmbn 0 1 'a))
-(setf *bc* *tc*)
-(check-rdct)
-(setf *tc* (cmbn 1 1 'new 10 'b))
-(setf *bc* *tc*)
-(check-rdct)
-(pre-check-rdct (rrdct nhmeq))
-(setf *bc* (zero-cmbn 0))
-(check-rdct)
-(setf *tc* (cmbn 0 1 'a))
-(check-rdct)
-|#
+     :lrdct (build-rdct
+	     :f (mrph-disk-pasting (lf hmeq) new-tcc new-lbcc
+				   dmns new (cmbn dmns 1 new))
+	     :g (mrph-disk-pasting lg new-lbcc new-tcc
+				   dmns new (cmbn dmns 1 new))
+	     :h (mrph-disk-pasting (lh hmeq) new-tcc new-tcc
+				   dmns new (zero-cmbn 1+dmns)))
+     :rrdct (build-rdct
+	     :f (mrph-disk-pasting rf new-tcc new-rbcc
+				   dmns new (cmbn dmns 1 new))
+	     :g (mrph-disk-pasting (rg hmeq) new-rbcc new-tcc
+				   dmns new
+				   (make-cmbn
+				    :degr dmns
+				    :list (cons (term 1 new)
+						(cmbn-list
+						 (cmbn-opps
+						  (cmbn-? rh t-bndr))))))
+	     :h (mrph-disk-pasting rh new-tcc new-tcc
+				   dmns new (zero-cmbn 1+dmns)))
+     :orgn `(hmeq-disk-pasting ,hmeq ,dmns ,new ,bndr))))
+
 
 (DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'disk-pasting)))
   (declare (type simplicial-set smst))
   (the homotopy-equivalence
-    (destructuring-bind (old-smst dmns new faces) (rest (orgn smst))
-			(declare
-			  (type simplicial-set old-smst)
-			  (fixnum dmns)
-			  (symbol new)
-			  (ignore faces))
-      (hmeq-disk-pasting (efhm old-smst)
-			 dmns new (? smst dmns new)
-			 :new-lbcc smst))))
-
-#|
-(cat-init)
-(setf d (delta 2))
-(setf s2 (disk-pasting d 2 'new '(6 5
-  3)))
-(homology s2 0 4)
-|#
+       (destructuring-bind (old-smst dmns new faces) (rest (orgn smst))
+	 (declare
+	  (type simplicial-set old-smst)
+	  (fixnum dmns)
+	  (symbol new)
+	  (ignore faces))
+	 (hmeq-disk-pasting (efhm old-smst)
+			    dmns new (? smst dmns new)
+			    :new-lbcc smst))))
diff --git a/test/disk-pasting-test.lisp b/test/disk-pasting-test.lisp
new file mode 100644
index 0000000..9eabdcb
--- /dev/null
+++ b/test/disk-pasting-test.lisp
@@ -0,0 +1,148 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(test disk-pasting-cmpr
+      (let* ((c (cat:delta 3))
+	     (cmpr (cat:disk-pasting-cmpr (cat:cmpr c) 'new)))
+	(is (equal :equal (funcall cmpr 'new 'new)))
+	(is (equal :less (funcall cmpr 'new 5)))
+	(is (equal :greater (funcall cmpr 5 'new)))
+	(is (equal :equal (funcall cmpr 5 5)))
+	(is (equal :less (funcall cmpr 5 6)))
+	(is (equal :greater (funcall cmpr 6 5)))))
+
+
+(test disk-pasting-basis
+      (cat:cat-init)
+      (let* ((c (cat:delta 3))
+	     (basis (cat:disk-pasting-basis (cat:basis c) 3 'new)))
+	(funcall basis 3)
+	(funcall basis 2)))
+
+
+(test disk-pasting-intr-dffr
+      (cat:cat-init)
+      (let* ((c (cat:delta 3))
+	     intr)
+	(signals simple-error
+		 (setf intr (cat:disk-pasting-intr-dffr
+			     (cat:dffr c) 3 'new (cat:cmbn 2 1 7))))
+	(setf intr (cat:disk-pasting-intr-dffr (cat:dffr c)
+					       3 'new (cat:? c 3 15)))
+	(funcall intr (cat:cmbn 2 1 7))
+	(funcall intr (cat:cmbn 3))
+	(funcall intr (cat:cmbn 3 1 15))
+	(funcall intr (cat:cmbn 3 1 'new 1 15))
+	(funcall intr (cat:cmbn 3 1 'new -1 15))
+	(funcall intr (cat:cmbn 3 -1 'new 1 15))
+	(funcall intr (cat:cmbn 3 -1 'new -1 15))))
+
+
+(test chcm-disk-pasting
+      (cat:cat-init)
+      (let* ((c (cat:delta 3))
+	     (s3 (cat:chcm-disk-pasting c 3 'new (cat:? c 3 15))))
+	(cat:homology s3 0 5)))
+
+
+(test disk-pasting-face
+      (cat:cat-init)
+      (let* ((c (cat:delta 3))
+	     (face (cat:disk-pasting-face (cat:cmpr c) (cat:face c)
+					  3 'new
+					  (list 14 (cat:absm 0 13) 11 7))))
+	(funcall face 0 2 7)
+	(funcall face 0 3 15)
+	(dotimes (i 4) (print (funcall face i 3 'new)))))
+
+
+(test disk-pasting
+      (cat:cat-init)
+      (let* ((d2 (cat:delta 2))
+	     (s2 (cat:disk-pasting d2 2 'new '(6 5 3)))
+	     s2xs2)
+	(cat:homology s2 0 4)
+	(setf s2xs2 (cat:crts-prdc s2 s2))
+	(cat:homology s2xs2 0 6)))
+
+
+(test mrph-disk-pasting-intr
+      (cat:cat-init)
+      (let* ((m (cat:idnt-mrph (cat:delta 3)))
+	     (intr (cat:mrph-disk-pasting-intr m (cat:cmpr (cat:delta 3))
+					       3 'new (cat:cmbn 3 -1 15))))
+	(funcall intr (cat:cmbn 2 3 7))
+	(funcall intr (cat:cmbn 3))
+	(funcall intr (cat:cmbn 3 4 15))
+	(funcall intr (cat:cmbn 3 1 'new 1 15))
+	(funcall intr (cat:cmbn 3 -1 'new 1 15))))
+
+
+(test mrph-disk-pasting
+      (cat:cat-init)
+      (let* ((d (cat:delta 3))
+	     (m (cat:idnt-mrph d))
+	     (sorc (cat:chcm-disk-pasting d 3 'new (cat:? d 3 15)))
+	     (nm (cat:mrph-disk-pasting m sorc sorc 3 'new
+					(cat:cmbn 3 1 'new))))
+	(cat:? nm (cat:cmbn 3 2 'new 3 15))))
+
+
+(test disk-pasting1
+      (cat:cat-init)
+      (let* ((d (cat:delta 2))
+	     (s2 (cat:disk-pasting d 2 'new '(6 5 3))))
+	(cat:homology s2 0 4)))
+
+
+(test hmeq-disk-pasting
+      (cat:cat-init)
+      (let* ((tcc (cat:build-chcm
+		   :cmpr #'cat:s-cmpr
+		   :basis #'(lambda (degr)
+			      (case degr
+				(0 (list 'a))
+				(1 (list 'b))
+				(otherwise nil)))
+		   :intr-dffr #'(lambda (degr gnrt)
+				  (if (= 1 degr)
+				      (cat:cmbn 0 1 'a)
+				      (cat:zero-cmbn (1- degr))))
+		   :strt :gnrt
+		   :orgn '(z-z)))
+	     (bcc (cat:build-chcm
+		   :cmpr #'cat:s-cmpr
+		   :basis #'(lambda (degr) nil)
+		   :intr-dffr #'(lambda (degr gnrt) (error "Impossible."))
+		   :strt :gnrt
+		   :orgn '(zero)))
+	     (rh (cat:build-mrph
+		  :sorc tcc :trgt tcc :degr +1
+		  :intr #'(lambda (degr gnrt)
+			    (if (zerop degr)
+				(cat:cmbn 1 1 'b)
+				(cat:zero-cmbn 2)))
+		  :strt :gnrt
+		  :orgn '(rh)))
+	     (hmeq (cat:build-hmeq
+		    :lrdct (cat:trivial-rdct tcc)
+		    :rrdct (cat:build-rdct
+			    :f (cat:zero-mrph tcc bcc 0)
+			    :g (cat:zero-mrph bcc tcc 0)
+			    :h rh
+			    :orgn '(rrdct))))
+	     (nhmeq (cat:hmeq-disk-pasting hmeq 1 'new (cat:cmbn 0 1 'a))))
+	(cat:pre-check-rdct (cat:lrdct nhmeq))
+	(setf cat:*tc* (cat:cmbn 0 1 'a))
+	(setf cat:*bc* cat:*tc*)
+	(check-rdct)
+	(setf cat:*tc* (cat:cmbn 1 1 'new 10 'b))
+	(setf cat:*bc* cat:*tc*)
+	(check-rdct)
+	(cat:pre-check-rdct (cat:rrdct nhmeq))
+	(setf cat:*bc* (cat:zero-cmbn 0))
+	(check-rdct)
+	(setf cat:*tc* (cat:cmbn 0 1 'a))
+	(check-rdct)))