From ad86b8c50059949d0b320e692ca29b79bb673fed Mon Sep 17 00:00:00 2001 From: gheber Date: Thu, 1 Jan 2015 18:30:57 -0600 Subject: [PATCH] Added RESULT type corrections. --- kenzo-test.asd | 3 +- package.lisp | 5 ++ run-kenzo-test.lisp | 1 + src/chain-complexes.lisp | 101 +++++++++++++++--------------- src/classes.lisp | 8 +-- test/chain-complexes-test.lisp | 17 +---- test/chcm-elementary-op-test.lisp | 6 +- 7 files changed, 69 insertions(+), 72 deletions(-) diff --git a/kenzo-test.asd b/kenzo-test.asd index c53521b..4e9ef78 100644 --- a/kenzo-test.asd +++ b/kenzo-test.asd @@ -12,4 +12,5 @@ (:file "chcm-elementary-op-test") (:file "diabolo") (:file "circle") - (:file "ccn"))) + (:file "ccn") + (:file "effective-homology-test"))) diff --git a/package.lisp b/package.lisp index 28f3bcd..ba58bb8 100644 --- a/package.lisp +++ b/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 diff --git a/run-kenzo-test.lisp b/run-kenzo-test.lisp index 4c78e48..3cc3bed 100644 --- a/run-kenzo-test.lisp +++ b/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!) diff --git a/src/chain-complexes.lisp b/src/chain-complexes.lisp index 0a15615..c1ad585 100644 --- a/src/chain-complexes.lisp +++ b/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) - ;; (function (fixnum gnrt) cmbn) - (type cmprf cmpr2) - (fixnum degr left right) - (type gnrt gnrt) + (type intr-mrph intr) + ;; (function (fixnum gnrt) cmbn) + (type cmprf cmpr2) + (fixnum degr left right) + (type gnrt gnrt) (vector memory) (special *results-n*) (fixnum *results-n*)) - ;; (vector result) - (the (values cmbn fixnum) - ;;; cmbn = image of the generator - ;;; fixnum = index "exact" or just "lower" of the maybe stored result - (loop - (when (= right (1+ left)) ;; the result for gnrt is not available - (push (get-internal-run-time) *start-stack*) - (let ((value (funcall intr degr gnrt)) - (runtime (- (get-internal-run-time) (pop *start-stack*)))) - (declare - (type cmbn value) - (integer runtime)) - (if (> runtime +too-much-time+) - ;;; the condition deciding whether - ;;; storing must happen - (let ((old-length (vector-push-extend nil memory))) - (declare (fixnum old-length)) - (replace memory memory - :start1 (1+ right) :end1 (1+ old-length) - :start2 right :end2 old-length) - (setf (aref memory right) - (make-result - :gnrt gnrt :value value - :clnm 1 - :rntm (let ((rntm - (float - (/ runtime internal-time-units-per-second)))) - (declare (single-float rntm)) - (incf *results-cmlt-tm* rntm) - rntm))) - (mapl #'(lambda (mark) - (declare (cons mark)) - (incf (car mark) runtime)) - *start-stack*) - (when (> (incf *results-n*) *results-max*) - (clean-results)) - (return (values value right))) - (return (values value left))))) - (let ((middle (truncate (+ right left) 2))) + ;; (vector result) + (the (values cmbn fixnum) + ;; cmbn = image of the generator + ;; fixnum = index "exact" or just "lower" of the maybe stored result + (loop + (when (= right (1+ left)) ; the result for gnrt is not available + (push (get-internal-run-time) *start-stack*) + (let ((value (funcall intr degr gnrt)) + (runtime (- (get-internal-run-time) (pop *start-stack*)))) + (declare + (type cmbn value) + (integer runtime)) + (if (> runtime +too-much-time+) + ;; the condition deciding whether + ;; storing must happen + (let ((old-length (vector-push-extend nil memory))) + (declare (fixnum old-length)) + (replace memory memory + :start1 (1+ right) :end1 (1+ old-length) + :start2 right :end2 old-length) + (setf (aref memory right) + (make-result + :gnrt gnrt :value value :clnm 1 + :rntm (let ((rntm + (float + (/ runtime + internal-time-units-per-second)))) + (declare (single-float rntm)) + (incf *results-cmlt-tm* rntm) + rntm))) + (mapl #'(lambda (mark) + (declare (cons mark)) + (incf (car mark) runtime)) + *start-stack*) + (when (> (incf *results-n*) *results-max*) + (clean-results)) + (return (values value right))) + (return (values value left))))) + (let ((middle (truncate (+ right left) 2))) (declare (fixnum middle)) (ecase (funcall cmpr2 gnrt (result-gnrt (aref memory middle))) - (:equal (let ((rslt (aref memory middle))) - (declare (type cons rslt)) - (incf (result-clnm rslt)) - (return (values (result-value rslt) middle)))) - (:less (setf right middle)) + (:equal (let ((rslt (aref memory middle))) + (declare (type result rslt)) + (incf (result-clnm rslt)) + (return (values (result-value rslt) middle)))) + (:less (setf right middle)) (:greater (setf left middle))))))) diff --git a/src/classes.lisp b/src/classes.lisp index 403b1f6..fb96ce3 100644 --- a/src/classes.lisp +++ b/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) - (value #+allegro :type #+allegro cmbn) - (clnm #+allegro :type #+allegro fixnum) - (rntm #+allegro :type #+allegro single-float)) + (gnrt nil :type gnrt) + (value nil :type cmbn) + (clnm 0 :type fixnum) + (rntm 0.0 :type single-float)) ;;; ;;; EFFECTIVE HOMOLOGY diff --git a/test/chain-complexes-test.lisp b/test/chain-complexes-test.lisp index bb9c864..6754151 100644 --- a/test/chain-complexes-test.lisp +++ b/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 "" #\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-? diff --git a/test/chcm-elementary-op-test.lisp b/test/chcm-elementary-op-test.lisp index 04bdda0..a3fef10 100644 --- a/test/chcm-elementary-op-test.lisp +++ b/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