All files compile w/ SBCL

kenzo-test.asd

@@ -7,4 +7,7 @@
   :pathname #P"test/"
   :components ((:file "package")
 	       (:file "combinations-test")
-	       (:file "various-test")))
+	       (:file "various-test")
+	       (:file "chain-complexes-test")
+	       (:file "diabolo")
+	       (:file "circle")))

kenzo.asd

@@ -18,5 +18,36 @@
 				     (:file "classes")
 				     (:file "combinations")
 				     (:file "chain-complexes")
-				     (:file "chcm-elementary-op")))))
+				     (:file "chcm-elementary-op")
+				     (:file "effective-homology")
+				     (:file "homology-groups")
+				     (:file "searching-homology")
+				     (:file "cones")
+				     (:file "bicones")
+				     (:file "tensor-products")
+				     (:file "coalgebras")
+				     (:file "cobar")
+				     (:file "algebras")
+				     (:file "bar")
+				     (:file "simplicial-sets")
+				     (:file "simplicial-mrphs")
+				     (:file "delta")
+				     (:file "special-smsts")
+				     (:file "suspensions")
+				     (:file "disk-pasting")
+				     (:file "cartesian-products")
+				     (:file "eilenberg-zilber")
+				     (:file "kan")
+				     (:file "simplicial-groups")
+				     (:file "fibrations")
+				     (:file "loop-spaces")
+				     (:file "ls-twisted-products")
+				     (:file "lp-space-efhm")
+				     (:file "classifying-spaces")
+				     (:file "k-pi-n")
+				     (:file "serre")
+				     (:file "cs-twisted-products")
+				     (:file "cl-space-efhm")
+				     (:file "whitehead")
+				     (:file "smith")))))
 

package.lisp

@@ -7,13 +7,19 @@
 
 	   ;; chain-complexes.lisp
 
+	   BUILD-CHCM
+	   CAT-INIT
+	   DO-CONTROL
+
 	   ;; chcm-elementary-op.lisp
 
 	   ;; classes.lisp
 
+	   CHAIN-COMPLEX
 	   CMBN-CMBN
 	   CMBN-DEGR
 	   CMBN-LIST
+	   MAKE-RESULT
 
 	   ;; combinations.lisp
 
@@ -35,15 +41,20 @@
 
 	   ;; macros.lisp
 
+	   BASIS
+	   BINOMIAL-P-Q
 	   CFFC
-	   GNRT
 	   CMBN-NON-ZERO-P
 	   CMBN-ZERO-P
+	   CMPR
+	   DFFR
+	   GNRT
 	   TERM
 	   TERM-CMBN
 
 	   ;; various.lisp
 
+	   +EMPTY-LIST+
 	   <A-B<
 	   <A-B>
 	   >A-B<

src/algebras.lisp

@@ -2,7 +2,7 @@
 ;;;  ALGEBRAS  ALGEBRAS  ALGEBRAS  ALGEBRAS  ALGEBRAS  ALGEBRAS
 ;;;  ALGEBRAS  ALGEBRAS  ALGEBRAS  ALGEBRAS  ALGEBRAS  ALGEBRAS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "algebras")
 

src/bar.lisp

@@ -6,7 +6,7 @@
 ;;;  MAC-LANE signs (p. 306)
 ;;;
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "bar")
 
@@ -31,8 +31,8 @@
 (abar 2 'a 3))  ;; error
 |#
 
-(DEFCONSTANT +NULL-ABAR+ (make-abar :list +empty-list+))
+#-sbcl (DEFCONSTANT +NULL-ABAR+ (make-abar :list +empty-list+))
-
+#+sbcl (DEFPARAMETER +NULL-ABAR+ (make-abar :list +empty-list+))
 
 ;;; -[CLISP
 #|

src/bicones.lisp

@@ -2,7 +2,7 @@
 ;;;  BICONES  BICONES  BICONES  BICONES  BICONES  BICONES  BICONES  BICONES
 ;;;  BICONES  BICONES  BICONES  BICONES  BICONES  BICONES  BICONES  BICONES
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "bicones")
 

src/cartesian-products.lisp

@@ -2,7 +2,7 @@
 ;;;  CARTESIAN-PRODUCTS  CARTESIAN-PRODUCTS  CARTESIAN-PRODUCTS  CARTESIAN-PRODUCTS
 ;;;  CARTESIAN-PRODUCTS  CARTESIAN-PRODUCTS  CARTESIAN-PRODUCTS  CARTESIAN-PRODUCTS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "cartesian-products")
 

src/chain-complexes.lisp

@@ -111,11 +111,6 @@
   result)
   
 
-#|
-()
-(make-result :gnrt 'a :value '(a a) :clnm 23 :rntm 2.345)
-|#
-
 (DEFPARAMETER +MAXIMAL-DIMENSION+ 15)
 
 (DEFVAR *MRPH-LIST*)
@@ -419,15 +414,6 @@
                     ~A and ~A are in a wrong order." (cdar mark2) (cdar mark1)))))
    cmbn)
 
-#|
-  (do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'c))
-  (do-control #'s-cmpr (cmbn 0 1 'b 1 'b -1 'c))
-  (do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
-  (setf *cmbn-control* nil)
-  (control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
-  (setf *cmbn-control* t)
-  (control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
-|#
 
 #|
 (DEFVAR *PROFILER-STACK*)
@@ -495,38 +481,6 @@
 ;;                     (profiler-off mrph)
                      ))))))))
 
-#|
-()
-(cat-init)
-(setf cc (build-chcm :cmpr #'f-cmpr
-                     :basis :locally-effective
-                     :bsgn 0
-                     :intr-dffr #'(lambda (cmbn)
-                                    (cmbn (1- (cmbn-degr cmbn))))
-                     :strt :cmbn
-                     :orgn '(Z of Z)))
-(setf cc (build-chcm :cmpr #'f-cmpr
-                     :basis :locally-effective
-                     :bsgn 0
-                     :intr-dffr #'(lambda (cmbn)
-                                    (cmbn (1- (cmbn-degr cmbn))))
-                     :strt :cmbn
-                     :orgn '(Z of Z)))
-(setf ff (build-mrph :sorc cc :trgt cc :degr 0
-                     :intr #'(lambda (degr n) (cmbn degr 1 n))
-                     :strt :gnrt :orgn '(test)))
-(setf ff (build-mrph :sorc cc :trgt cc :degr 0
-                     :intr #'(lambda (degr n) (cmbn degr 1 n))
-                     :strt :gnrt :orgn '(test)))
-(dotimes (i 20)
-  (let ((n (- (random 50) 50)))
-    (format t "~%~D   ~D" n (gnrt-? ff 0 n))))
-(setf +too-much-time+ -1)
-(dotimes (i 20)
-  (let ((n (- (random 50) 50)))
-    (format t "~%~D   ~D" n (gnrt-? ff 0 n))))
-(setf +too-much-time+ 50)
-|#
 
 (DEFUN CMBN-? (mrph cmbn)
    (declare
@@ -565,41 +519,3 @@
                            cmbn (svref (rslts mrph) (cmbn-degr cmbn))))
 ;;                     (profiler-off mrph)
                      )))))))))
-
-#|
-()
-(cat-init)
-(setf cc (build-chcm :cmpr #'f-cmpr
-                     :basis :locally-effective
-                     :bsgn 0
-                     :intr-dffr #'(lambda (cmbn)
-                                    (cmbn (1- (cmbn-degr cmbn))))
-                     :strt :cmbn
-                     :orgn '(Z of Z)))
-(setf *n* 10)
-(defun ff (degr i)
-  (do ((*2n* (ash *n* 1))
-       (rslt +empty-list+
-             (cons (cons (let ((cffc (- (random *2n*) *n*)))
-                           (if (minusp cffc) cffc (1+ cffc)))
-                         (decf gnrt (1+ (random *n*))))
-                   rslt))
-       (gnrt i)
-       (k 0 (1+ k)))
-      ((= k *n*)
-       (make-cmbn
-        :degr 0
-        :list rslt))))
-(ff 0 20)
-(compile 'ff)
-(setf mrph (build-mrph :sorc cc :trgt cc :degr 0
-                       :intr #'ff :strt :gnrt :orgn '(test)))
-(cmbn-? mrph (cmbn 0 1 100))
-(cmbn-? mrph *)
-(cmbn-? mrph *)
-(cmbn-? mrph *)
-(cmbn-? mrph *)
-(cmbn-? mrph *)
-(time (cmbn-? mrph *))
-(inspect mrph)
-|#

src/cl-space-efhm.lisp

@@ -2,7 +2,7 @@
 ;;;  CL-SPACE-EFHM  CL-SPACE-EFHM  CL-SPACE-EFHM  CL-SPACE-EFHM
 ;;;  CL-SPACE-EFHM  CL-SPACE-EFHM  CL-SPACE-EFHM  CL-SPACE-EFHM
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (provide "cl-space-efhm")
 

src/classifying-spaces.lisp

@@ -2,11 +2,12 @@
 ;;;  CLASSIFYING-SPACES  CLASSIFYING-SPACES  CLASSIFYING-SPACES
 ;;;  CLASSIFYING-SPACES  CLASSIFYING-SPACES  CLASSIFYING-SPACES
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (provide "classifying-spaces")
 
-(DEFCONSTANT +NULL-GBAR+ (make-gbar :dmns 0 :list +empty-list+))
+#-sbcl (DEFCONSTANT +NULL-GBAR+ (make-gbar :dmns 0 :list +empty-list+))
+#+sbcl (DEFPARAMETER +NULL-GBAR+ (make-gbar :dmns 0 :list +empty-list+))
 
 (DEFUN GBAR-PRINT (gbar stream depth)
   (declare

src/coalgebras.lisp

@@ -2,7 +2,7 @@
 ;;;  COALGEBRAS  COALGEBRAS  COALGEBRAS  COALGEBRAS  COALGEBRAS  COALGEBRAS
 ;;;  COALGEBRAS  COALGEBRAS  COALGEBRAS  COALGEBRAS  COALGEBRAS  COALGEBRAS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "coalgebras")
 

src/cobar.lisp

@@ -2,7 +2,7 @@
 ;;;  COBAR  COBAR  COBAR  COBAR  COBAR  COBAR  COBAR  COBAR  COBAR
 ;;;  COBAR  COBAR  COBAR  COBAR  COBAR  COBAR  COBAR  COBAR  COBAR
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "cobar")
 
@@ -28,7 +28,9 @@
 (allp 2 'a 3))  ;; error
 |#
 
-(DEFCONSTANT +NULL-ALLP+ (make-allp :list +empty-list+))
+#-sbcl(DEFCONSTANT +NULL-ALLP+ (make-allp :list +empty-list+))
+#+sbcl (DEFPARAMETER +NULL-ALLP+ (make-allp :list +empty-list+))
+
 
 (DEFUN ALLP-PRINT (allp stream depth)
   (declare

src/cones.lisp

@@ -2,7 +2,7 @@
 ;;;  CONES  CONES  CONES  CONES  CONES  CONES  CONES  CONES  CONES  CONES
 ;;;  CONES  CONES  CONES  CONES  CONES  CONES  CONES  CONES  CONES  CONES
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "cones")
 

src/cs-twisted-products.lisp

@@ -2,7 +2,7 @@
 ;;;  CS-TWISTED-PRODUCTS  CS-TWISTED-PRODUCTS  CS-TWISTED-PRODUCTS
 ;;;  CS-TWISTED-PRODUCTS  CS-TWISTED-PRODUCTS  CS-TWISTED-PRODUCTS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "cs-twisted-products")
 

src/delta.lisp

@@ -2,7 +2,7 @@
 ;;;  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA
 ;;;  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "delta")
 

src/disk-pasting.lisp

@@ -2,7 +2,7 @@
 ;;;  DISK-PASTING  DISK-PASTING  DISK-PASTING  DISK-PASTING
 ;;;  DISK-PASTING  DISK-PASTING  DISK-PASTING  DISK-PASTING
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (provide "disk-pasting")
 

src/effective-homology.lisp

@@ -2,7 +2,7 @@
 ;;;  EFFECTIVE-HOMOLOGY  EFFECTIVE-HOMOLOGY  EFFECTIVE-HOMOLOGY
 ;;;  EFFECTIVE-HOMOLOGY  EFFECTIVE-HOMOLOGY  EFFECTIVE-HOMOLOGY
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "effective-homology")
 

src/eilenberg-zilber.lisp

@@ -2,7 +2,7 @@
 ;;;  EILENBERG-ZILBER  EILENBERG-ZILBER  EILENBERG-ZILBER
 ;;;  EILENBERG-ZILBER  EILENBERG-ZILBER  EILENBERG-ZILBER
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "eilenberg-zilber")
 

src/fibrations.lisp

@@ -2,7 +2,7 @@
 ;;;  FIBRATIONS  FIBRATIONS  FIBRATIONS  FIBRATIONS  FIBRATIONS
 ;;;  FIBRATIONS  FIBRATIONS  FIBRATIONS  FIBRATIONS  FIBRATIONS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "fibrations")
 

src/homology-groups.lisp

@@ -2,7 +2,7 @@
 ;;  HOMOLOGY-GROUPS  HOMOLOGY-GROUPS  HOMOLOGY-GROUPS  HOMOLOGY-GROUPS
 ;;  HOMOLOGY-GROUPS  HOMOLOGY-GROUPS  HOMOLOGY-GROUPS  HOMOLOGY-GROUPS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (provide "homology-groups")
 

src/k-pi-n.lisp

@@ -2,7 +2,7 @@
 ;;;  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1
 ;;;  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "k-pi-1")
 

src/kan.lisp

@@ -2,7 +2,7 @@
 ;;;  KAN  KAN  KAN  KAN  KAN  KAN  KAN  KAN  KAN  KAN  KAN  KAN
 ;;;  KAN  KAN  KAN  KAN  KAN  KAN  KAN  KAN  KAN  KAN  KAN  KAN
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (provide "kan")
 

src/loop-spaces.lisp

@@ -2,11 +2,12 @@
 ;;;  LOOP-SPACES  LOOP-SPACES  LOOP-SPACES  LOOP-SPACES  LOOP-SPACES  LOOP-SPACES
 ;;;  LOOP-SPACES  LOOP-SPACES  LOOP-SPACES  LOOP-SPACES  LOOP-SPACES  LOOP-SPACES
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "loop-spaces")
 
-(DEFCONSTANT +NULL-LOOP+ (make-loop :list +empty-list+))
+#-sbcl (DEFCONSTANT +NULL-LOOP+ (make-loop :list +empty-list+))
+#+sbcl (DEFPARAMETER +NULL-LOOP+ (make-loop :list +empty-list+))
 
 ;;; NILOOP = non-normalized iloop; a common dgop is possible.
 

src/lp-space-efhm.lisp

@@ -2,7 +2,7 @@
 ;;;  LP-SPACE-EFHM  LP-SPACE-EFHM  LP-SPACE-EFHM  LP-SPACE-EFHM
 ;;;  LP-SPACE-EFHM  LP-SPACE-EFHM  LP-SPACE-EFHM  LP-SPACE-EFHM
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "lp-space-efhm")
 

src/ls-twisted-products.lisp

@@ -2,7 +2,7 @@
 ;;;  LS-TWISTED-PRODUCTS  LS-TWISTED-PRODUCTS  LS-TWISTED-PRODUCTS
 ;;;  LS-TWISTED-PRODUCTS  LS-TWISTED-PRODUCTS  LS-TWISTED-PRODUCTS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "ls-twisted-products")
 

src/searching-homology.lisp

@@ -2,7 +2,7 @@
 ;;;  SEARCHING-HOMOLOGY  SEARCHING-HOMOLOGY  SEARCHING-HOMOLOGY
 ;;;  SEARCHING-HOMOLOGY  SEARCHING-HOMOLOGY  SEARCHING-HOMOLOGY
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "searching-homology")
 

src/serre.lisp

@@ -2,7 +2,7 @@
 ;;;  SERRE  SERRE  SERRE  SERRE  SERRE  SERRE  SERRE  SERRE  SERRE
 ;;;  SERRE  SERRE  SERRE  SERRE  SERRE  SERRE  SERRE  SERRE  SERRE
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "serre")
 

src/simplicial-groups.lisp

@@ -2,7 +2,7 @@
 ;;;  SIMPLICIAL-GROUPS  SIMPLICIAL-GROUPS  SIMPLICIAL-GROUPS
 ;;;  SIMPLICIAL-GROUPS  SIMPLICIAL-GROUPS  SIMPLICIAL-GROUPS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "simplicial-groups")
 

src/simplicial-mrphs.lisp

@@ -2,7 +2,7 @@
 ;;;  SIMPLICIAL-MRPHS  SIMPLICIAL-MRPHS  SIMPLICIAL-MRPHS
 ;;;  SIMPLICIAL-MRPHS  SIMPLICIAL-MRPHS  SIMPLICIAL-MRPHS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "simplicial-mrphs")
 

src/simplicial-sets.lisp

@@ -2,7 +2,7 @@
 ;;;  SIMPLICIAL-SETS  SIMPLICIAL-SETS  SIMPLICIAL-SETS
 ;;;  SIMPLICIAL-SETS  SIMPLICIAL-SETS  SIMPLICIAL-SETS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "simplicial-sets")
 

src/smith.lisp

@@ -2,7 +2,7 @@
 ;;;  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH
 ;;;  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "smith")
 

src/special-smsts.lisp

@@ -2,7 +2,7 @@
 ;;;  SPECIAL-SMSTS  SPECIAL-SMSTS  SPECIAL-SMSTS  SPECIAL-SMSTS  SPECIAL-SMSTS
 ;;;  SPECIAL-SMSTS  SPECIAL-SMSTS  SPECIAL-SMSTS  SPECIAL-SMSTS  SPECIAL-SMSTS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "special-smsts")
 

src/suspensions.lisp

@@ -2,7 +2,7 @@
 ;;;  SUSPENSIONS  SUSPENSIONS  SUSPENSIONS  SUSPENSIONS
 ;;;  SUSPENSIONS  SUSPENSIONS  SUSPENSIONS  SUSPENSIONS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "suspensions")
 

src/tensor-products.lisp

@@ -2,7 +2,7 @@
 ;;;  TENSOR-PRODUCTS  TENSOR-PRODUCTS  TENSOR-PRODUCTS  TENSOR-PRODUCTS  TENSOR-PRODUCTS
 ;;;  TENSOR-PRODUCTS  TENSOR-PRODUCTS  TENSOR-PRODUCTS  TENSOR-PRODUCTS  TENSOR-PRODUCTS
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (PROVIDE "tensor-products")
 

src/whitehead.lisp

@@ -2,7 +2,7 @@
 ;;;  WHITEHEAD  WHITEHEAD  WHITEHEAD  WHITEHEAD  WHITEHEAD  WHITEHEAD  WHITEHEAD
 ;;;  WHITEHEAD  WHITEHEAD  WHITEHEAD  WHITEHEAD  WHITEHEAD  WHITEHEAD  WHITEHEAD
 
-(IN-PACKAGE "COMMON-LISP-USER")
+(IN-PACKAGE #:cat)
 
 (provide "whitehead")
 

test/chain-complexes-test.lisp

@@ -0,0 +1,110 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(test result-print
+      (let ((rslt (format nil "~a"
+			  (cat:make-result :gnrt 'a :value '(a a)
+					   :clnm 23 :rntm 2.345))))
+	(is (equal rslt (format nil "~{~a~}"
+				     '(#\Newline "<Rslt>" #\Newline
+				       "    GNRT-> A" #\Newline
+				       "   VALUE-> (A A)" #\Newline
+				       "    CLNM->     23" #\Newline
+				       "    RNTM->       2.345"))))))
+
+#|
+  (do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'c))
+  (do-control #'s-cmpr (cmbn 0 1 'b 1 'b -1 'c))
+  (do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
+  (setf *cmbn-control* nil)
+  (control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
+  (setf *cmbn-control* t)
+  (control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
+|#
+
+(test do-control
+      (let ((comb (cat:do-control #'cat:s-cmpr (cat:cmbn 0 1 'a 1 'b -1 'c))))
+	(is (equal (cat:cmbn-degr comb) 0))
+	(is (equal (cat:cmbn-list comb) '((1 . a) (1 . b) (-1 . c)))))
+
+      (signals simple-error (cat:do-control #'cat:s-cmpr
+			      (cat:cmbn 0 1 'b 1 'b -1 'c)))
+
+      (signals simple-error (cat:do-control #'cat:s-cmpr
+			      (cat:cmbn 0 1 'a 1 'b -1 'b)))
+
+      (setf cat:*cmbn-control* nil))
+
+#|
+()
+(cat-init)
+(setf cc (build-chcm :cmpr #'f-cmpr
+                     :basis :locally-effective
+                     :bsgn 0
+                     :intr-dffr #'(lambda (cmbn)
+                                    (cmbn (1- (cmbn-degr cmbn))))
+                     :strt :cmbn
+                     :orgn '(Z of Z)))
+(setf cc (build-chcm :cmpr #'f-cmpr
+                     :basis :locally-effective
+                     :bsgn 0
+                     :intr-dffr #'(lambda (cmbn)
+                                    (cmbn (1- (cmbn-degr cmbn))))
+                     :strt :cmbn
+                     :orgn '(Z of Z)))
+(setf ff (build-mrph :sorc cc :trgt cc :degr 0
+                     :intr #'(lambda (degr n) (cmbn degr 1 n))
+                     :strt :gnrt :orgn '(test)))
+(setf ff (build-mrph :sorc cc :trgt cc :degr 0
+                     :intr #'(lambda (degr n) (cmbn degr 1 n))
+                     :strt :gnrt :orgn '(test)))
+(dotimes (i 20)
+  (let ((n (- (random 50) 50)))
+    (format t "~%~D   ~D" n (gnrt-? ff 0 n))))
+(setf +too-much-time+ -1)
+(dotimes (i 20)
+  (let ((n (- (random 50) 50)))
+    (format t "~%~D   ~D" n (gnrt-? ff 0 n))))
+(setf +too-much-time+ 50)
+|#
+
+
+#|
+()
+(cat-init)
+(setf cc (build-chcm :cmpr #'f-cmpr
+                     :basis :locally-effective
+                     :bsgn 0
+                     :intr-dffr #'(lambda (cmbn)
+                                    (cmbn (1- (cmbn-degr cmbn))))
+                     :strt :cmbn
+                     :orgn '(Z of Z)))
+(setf *n* 10)
+(defun ff (degr i)
+  (do ((*2n* (ash *n* 1))
+       (rslt +empty-list+
+             (cons (cons (let ((cffc (- (random *2n*) *n*)))
+                           (if (minusp cffc) cffc (1+ cffc)))
+                         (decf gnrt (1+ (random *n*))))
+                   rslt))
+       (gnrt i)
+       (k 0 (1+ k)))
+      ((= k *n*)
+       (make-cmbn
+        :degr 0
+        :list rslt))))
+(ff 0 20)
+(compile 'ff)
+(setf mrph (build-mrph :sorc cc :trgt cc :degr 0
+                       :intr #'ff :strt :gnrt :orgn '(test)))
+(cmbn-? mrph (cmbn 0 1 100))
+(cmbn-? mrph *)
+(cmbn-? mrph *)
+(cmbn-? mrph *)
+(cmbn-? mrph *)
+(cmbn-? mrph *)
+(time (cmbn-? mrph *))
+(inspect mrph)
+|#

test/circle.lisp

@@ -0,0 +1,26 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(defun circle ()
+  (the cat:chain-complex
+       (cat:build-chcm
+	:cmpr #'(lambda (gnrt1 gnrt2) (the cat:cmpr :equal))
+	:basis #'(lambda (dmns)
+		   (the list
+			(case dmns (0 '(*)) (1 '(s1))
+			      (otherwise cat:+empty-list+))))
+	:bsgn '*
+	:intr-dffr #'cat:zero-intr-dffr
+	:strt :cmbn
+	:orgn '(circle))))
+
+
+(test circle
+      (progn
+	(cat:cat-init)
+	(let ((circle (circle)))
+	  (is (equal (cat:basis circle 0) '(*)))
+	  (is (equal (cat:basis circle 1) '(s1)))
+	  (is (equal (cat:basis circle 2) cat:+empty-list+)))))

test/diabolo.lisp

@@ -0,0 +1,49 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(defun diabolo-basis (dmn)
+  (case dmn
+    (0 '(s0 s1 s2 s3 s4 s5))
+    (1 '(s01 s02 s12 s23 s34 s35 s45))
+    (2 '(s345))
+    (otherwise nil)))
+
+(defun diabolo-pure-dffr (dmn gnr)
+  (unless (<= 0 dmn 2)
+    (error "Incorrect dimension for diabolo-dp."))
+  (case dmn
+    (0 (cat:cmbn -1))
+    (1 (case gnr
+	 (s01 (cat:cmbn 0 -1 's0 1 's1))
+	 (s02 (cat:cmbn 0 -1 's0 1 's2))
+	 (s12 (cat:cmbn 0 -1 's1 1 's2))
+	 (s23 (cat:cmbn 0 -1 's2 1 's3))
+	 (s34 (cat:cmbn 0 -1 's3 1 's4))
+	 (s35 (cat:cmbn 0 -1 's3 1 's5))
+	 (s45 (cat:cmbn 0 -1 's4 1 's5))))
+    (2 (case gnr
+	 (s345 (cat:cmbn 1 1 's34 -1 's35 1 's45))))
+    (otherwise (error "Bad generator for complex diabolo."))))
+
+(test diabolo
+      (progn
+	(cat:cat-init)
+	(let ((diabolo (cat:build-chcm :cmpr #'cat:s-cmpr
+				       :basis #'diabolo-basis
+				       :bsgn 's0
+				       :intr-dffr #'diabolo-pure-dffr
+				       :strt :GNRT
+				       :orgn '(diabolo-for-example))))
+	  (is (equal (cat:basis diabolo 0) '(s0 s1 s2 s3 s4 s5)))
+	  (is (equal (cat:basis diabolo 1) '(s01 s02 s12 s23 s34 s35 s45)))
+	  (is (equal (cat:basis diabolo 2) '(s345)))
+	  (is (null (cat:basis diabolo 10)))
+
+	  (let* ((comb (cat:dffr diabolo 2 's345))
+		 (comb1 (cat:dffr diabolo comb)))
+	    (is (equal (cat:cmbn-degr comb) 1))
+	    (is (equal (cat:cmbn-list comb) '((1 . s34) (-1 . s35) (1 . s45))))
+	    (is (equal (cat:cmbn-degr comb1) 0))
+	    (is (equal (cat:cmbn-list comb1) nil))))))

test/various-test.lisp

@@ -7,11 +7,12 @@
       (let ((rslt '(1 5 10 10 5 1)))
 	(dotimes (i 6)
 	  (is (equal (cat:binomial-n-p 5 i)
-		     (nth i rslt)))))
+		     (nth i rslt))))))
 
-      (let ((rslt '(1 4 3 1 1 1)))
+(test binomial-p-q
+      (let ((rslt '(1 5 10 10 5 1)))
 	(dotimes (i 6)
-	  (is (equal (cat:binomial-n-p (- 5 i) i)
+	  (is (equal (cat:binomial-p-q (- 5 i) i)
 		     (nth i rslt))))))
 
 (test <a-b<