Added RESULT type corrections.

kenzo-test.asd

@@ -12,4 +12,5 @@
 	       (:file "chcm-elementary-op-test")
 	       (:file "diabolo")
 	       (:file "circle")
-               (:file "ccn")))
+               (:file "ccn")
+	       (:file "effective-homology-test")))

package.lisp

@@ -58,6 +58,10 @@
 	   ZERO-CMBN
 	   ZERO-INTR-DFFR
 
+	   ;; effective-homology.lisp
+
+	   BUILD-RDCT
+
 	   ;; fibrations.lisp
 
 	   FIBRATION-TOTAL
@@ -68,6 +72,7 @@
 
 	   ;; macros.lisp
 
+	   -1-EXPT-N
 	   ?
 	   BASIS
 	   BINOMIAL-P-Q

run-kenzo-test.lisp

@@ -1,5 +1,6 @@
 #+sbcl(require 'asdf)
 
+(asdf:operate 'asdf:load-op 'kenzo)
 (asdf:operate 'asdf:load-op 'kenzo-test)
 (in-package :kenzo-test)
 (run!)

src/chain-complexes.lisp

@@ -294,62 +294,63 @@
 
 
 
-(DEFUN MRPH-GNRT (cmpr2 intr degr gnrt memory &optional (left -1) (right (fill-pointer memory)))
+(DEFUN MRPH-GNRT (cmpr2 intr degr gnrt memory
+		  &optional (left -1) (right (fill-pointer memory)))
   (declare
-     (type intr-mrph intr)
+   (type intr-mrph intr)
-     ;; (function (fixnum gnrt) cmbn)
+   ;; (function (fixnum gnrt) cmbn)
-     (type cmprf cmpr2)
+   (type cmprf cmpr2)
-     (fixnum degr left right)
+   (fixnum degr left right)
-     (type gnrt gnrt)
+   (type gnrt gnrt)
    (vector memory)
    (special *results-n*)
    (fixnum *results-n*))
-   ;; (vector result)
+  ;; (vector result)
-   (the (values cmbn fixnum)
+  (the (values cmbn fixnum)
-      ;;; cmbn = image of the generator
+       ;; cmbn = image of the generator
-      ;;; fixnum = index "exact" or just "lower" of the maybe stored result
+       ;; fixnum = index "exact" or just "lower" of the maybe stored result
-      (loop
+       (loop
-        (when (= right (1+ left))            ;; the result for gnrt is not available
+	  (when (= right (1+ left)) ; the result for gnrt is not available
-          (push (get-internal-run-time) *start-stack*)
+	    (push (get-internal-run-time) *start-stack*)
-          (let ((value (funcall intr degr gnrt))
+	    (let ((value (funcall intr degr gnrt))
-                (runtime (- (get-internal-run-time) (pop *start-stack*))))
+		  (runtime (- (get-internal-run-time) (pop *start-stack*))))
-            (declare
+	      (declare
-             (type cmbn value)
+	       (type cmbn value)
-             (integer runtime))
+	       (integer runtime))
-            (if (> runtime +too-much-time+)
+	      (if (> runtime +too-much-time+)
-                ;;; the condition deciding whether
+		  ;; the condition deciding whether
-                ;;;   storing must happen
+		  ;; storing must happen
-                (let ((old-length (vector-push-extend nil memory)))
+		  (let ((old-length (vector-push-extend nil memory)))
-                  (declare (fixnum old-length))
+		    (declare (fixnum old-length))
-                  (replace memory memory
+		    (replace memory memory
-                           :start1 (1+ right) :end1 (1+ old-length)
+			     :start1 (1+ right) :end1 (1+ old-length)
-                           :start2 right :end2 old-length)
+			     :start2 right :end2 old-length)
-                  (setf (aref memory right)
+		    (setf (aref memory right)
-                    (make-result
+			  (make-result
-                     :gnrt gnrt :value value
+			   :gnrt gnrt :value value :clnm 1
-                     :clnm 1
+			   :rntm (let ((rntm
-                     :rntm (let ((rntm
+					(float
-                                  (float
+					 (/ runtime
-                                   (/ runtime internal-time-units-per-second))))
+					    internal-time-units-per-second))))
-                             (declare (single-float rntm))
+				   (declare (single-float rntm))
-                             (incf *results-cmlt-tm* rntm)
+				   (incf *results-cmlt-tm* rntm)
-                             rntm)))
+				   rntm)))
-                  (mapl #'(lambda (mark)
+		    (mapl #'(lambda (mark)
-                            (declare (cons mark))
+			      (declare (cons mark))
-                            (incf (car mark) runtime))
+			      (incf (car mark) runtime))
-                    *start-stack*)
+			  *start-stack*)
-                  (when (> (incf *results-n*) *results-max*)
+		    (when (> (incf *results-n*) *results-max*)
-                    (clean-results))
+		      (clean-results))
-                  (return (values value right)))
+		    (return (values value right)))
-              (return (values value left)))))
+		  (return (values value left)))))
-        (let ((middle (truncate (+ right left) 2)))
+	  (let ((middle (truncate (+ right left) 2)))
             (declare (fixnum middle))
             (ecase (funcall cmpr2 gnrt (result-gnrt (aref memory middle)))
-               (:equal (let ((rslt (aref memory middle)))
+	      (:equal (let ((rslt (aref memory middle)))
-			  (declare (type cons rslt))
+			(declare (type result rslt))
-			  (incf (result-clnm rslt))
+			(incf (result-clnm rslt))
-			  (return (values (result-value rslt) middle))))
+			(return (values (result-value rslt) middle))))
-               (:less (setf right middle))
+	      (:less (setf right middle))
               (:greater (setf left middle)))))))
 
 

src/classes.lisp

@@ -150,10 +150,10 @@
      (orgn :type list :initarg :orgn :reader orgn)))
 
 (DEFSTRUCT (RESULT (:print-function result-print))
-  (gnrt #+allegro :type #+allegro gnrt)
+  (gnrt nil :type gnrt)
-  (value #+allegro :type #+allegro cmbn)
+  (value nil :type cmbn)
-  (clnm #+allegro :type #+allegro fixnum)
+  (clnm 0 :type fixnum)
-  (rntm #+allegro :type #+allegro single-float))
+  (rntm 0.0 :type single-float))
 
 ;;;
 ;;;  EFFECTIVE HOMOLOGY

test/chain-complexes-test.lisp

@@ -3,16 +3,6 @@
 
 (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))
@@ -24,7 +14,6 @@
   (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))
@@ -66,9 +55,9 @@
 
 (defparameter *n* 10)
 (defun ff (degr i)
-  (do ((*2n* (ash *n* 1))
+  (do ((2*n* (ash *n* 1))
        (rslt cat:+empty-list+
-             (cons (cons (let ((cffc (- (random *2n*) *n*)))
+             (cons (cons (let ((cffc (- (random 2*n*) *n*)))
                            (if (minusp cffc) cffc (1+ cffc)))
                          (decf gnrt (1+ (random *n*))))
                    rslt))
@@ -76,7 +65,7 @@
        (k 0 (1+ k)))
       ((= k *n*)
        (cat:make-cmbn
-        :degr 0
+        :degr degr
         :list rslt))))
 
 (test cmbn-?

test/chcm-elementary-op-test.lisp

@@ -46,9 +46,9 @@
 
 (defparameter *n* 5)
 (defun ff (degr i)
-  (do ((*2n* (ash *n* 1))
+  (do ((2*n* (ash *n* 1))
        (rslt cat:+empty-list+
-	     (cons (cons (let ((cffc (- (random *2n*) *n*)))
+	     (cons (cons (let ((cffc (- (random 2*n*) *n*)))
 			   (if (minusp cffc) cffc (1+ cffc)))
 			 (decf gnrt (1+ (random *n*))))
 		   rslt))
@@ -56,7 +56,7 @@
        (k 0 (1+ k)))
       ((= k *n*)
        (cat:make-cmbn
-	:degr 0
+	:degr degr
 	:list rslt))))
 
 (test cmps