mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added RESULT type corrections.

Browse Source
This commit is contained in:
gheber 2015-01-01 18:30:57 -06:00
parent b3627d3b5d
commit ad86b8c500
7 changed files with 69 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
kenzo-test.asd
View File

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

5
package.lisp
View File

@ -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

1
run-kenzo-test.lisp
View File

@ -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!)

101
src/chain-complexes.lisp
View File

@ -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)))))))

8
src/classes.lisp
View File

@ -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

17
test/chain-complexes-test.lisp
View File

@ -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-?

6
test/chcm-elementary-op-test.lisp
View File

@ -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