622 lines
22 KiB
Common Lisp
622 lines
22 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
|
|
|
|
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
|
|
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
|
|
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
|
|
|
|
(IN-PACKAGE #:cat)
|
|
|
|
(PROVIDE "chain-complexes")
|
|
|
|
|
|
(DEFUN CAT-INIT ()
|
|
(declare (special *idnm-counter* *results-n* *results-cmlt-tm*))
|
|
"--------------------------------------------------------------[function-doc]
|
|
CAT-INIT
|
|
Args: ()
|
|
Initialize Kenzo internal data structures and clear, among other things,
|
|
the list of user created chain complexes *CHCM-LIST* and reset the global
|
|
counter to 0.
|
|
------------------------------------------------------------------------------"
|
|
(setf *idnm-counter* 0 *results-n* 0 *results-cmlt-tm* 0.0)
|
|
(map nil #'(lambda (listname)
|
|
(declare (symbol listname))
|
|
(setf (symbol-value listname) +empty-list+))
|
|
*list-list*)
|
|
(done))
|
|
|
|
|
|
(DEFUN HOW-MANY-OBJECTS ()
|
|
"--------------------------------------------------------------[function-doc]
|
|
HOW-MANY-OBJECTS
|
|
Args: ()
|
|
Return the number of user created objects by object type.
|
|
------------------------------------------------------------------------------"
|
|
(mapc #'(lambda (symbol)
|
|
(declare (type (or string symbol) symbol))
|
|
(let ((length (length (eval symbol))))
|
|
(declare (fixnum length))
|
|
(setf symbol (symbol-name symbol))
|
|
(setf symbol (subseq symbol 1 (- (length symbol) 6)))
|
|
(format t "~%~6D ~As" length symbol)))
|
|
*list-list*)
|
|
(done))
|
|
|
|
|
|
(DEFUN ALL-OBJECTS ()
|
|
"--------------------------------------------------------------[function-doc]
|
|
ALL-OBJECTS
|
|
Args: ()
|
|
Return a string representation of a user created objects.
|
|
------------------------------------------------------------------------------"
|
|
(let ((object-list
|
|
(sort (delete-duplicates
|
|
(mapcan #'(lambda (symbol)
|
|
(copy-list (eval symbol)))
|
|
*list-list*)
|
|
:test #'eq)
|
|
#'< :key #'idnm)))
|
|
(declare (list object-list))
|
|
(dolist (item object-list)
|
|
(format t "~%~A = ~A" item (orgn item))))
|
|
(done))
|
|
|
|
|
|
(DEFUN KD (idnm)
|
|
(declare (fixnum idnm))
|
|
"--------------------------------------------------------------[function-doc]
|
|
KD
|
|
Args: (idnm)
|
|
Return the type of Kenzo object number IDNM and print the comment list
|
|
(SLOT :ORGN) of the object.
|
|
------------------------------------------------------------------------------"
|
|
(dolist (list *list-list*)
|
|
(let ((found (find idnm (eval list) :key #'idnm)))
|
|
(when found
|
|
(format t "~%Object: ~A
|
|
~3TOrigin: ~A~2%" found (orgn found))
|
|
(return-from kd (values))))))
|
|
|
|
|
|
(DEFUN K (idnm)
|
|
(declare (fixnum idnm))
|
|
"--------------------------------------------------------------[function-doc]
|
|
K
|
|
Args: (idnm)
|
|
Returns the IDNM-th Kenzo object.
|
|
------------------------------------------------------------------------------"
|
|
(dolist (list *list-list*)
|
|
(let ((found (find idnm (eval list) :key #'idnm)))
|
|
(when found
|
|
(return-from k found)))))
|
|
|
|
|
|
(DEFUN KD2 (idnm)
|
|
(declare (fixnum idnm))
|
|
"--------------------------------------------------------------[function-doc]
|
|
KD2
|
|
Args: (idnm)
|
|
Return the type of Kenzo object number IDNM, print the comment list
|
|
(SLOT :ORGN) of the object and, recursively, return the same information
|
|
for all Kenzo objects of the same type in relation with this object. Return
|
|
the list of object numbers.
|
|
------------------------------------------------------------------------------"
|
|
(let ((k-list (k idnm)))
|
|
(unless k-list
|
|
(return-from kd2 nil))
|
|
(setf k-list (list k-list))
|
|
(do ((idnm (1- idnm) (1- idnm)))
|
|
((zerop idnm))
|
|
(declare (fixnum idnm))
|
|
(let ((found (find-if
|
|
#'(lambda (item)
|
|
(declare (type (or chain-complex morphism) item))
|
|
(member (k idnm) (orgn item)))
|
|
k-list)))
|
|
(declare (type (or null chain-complex morphism) found))
|
|
(when found
|
|
(push (k idnm) k-list))))
|
|
(mapc #'kd (nreverse (mapcar #'idnm k-list)))))
|
|
|
|
|
|
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf (ext:package-lock :clos) nil))
|
|
(DEFMETHOD PRINT-OBJECT ((chcm chain-complex) stream)
|
|
(the chain-complex
|
|
(progn
|
|
(format stream "[K~D Chain-Complex]" (idnm chcm))
|
|
chcm)))
|
|
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf (ext:package-lock :clos) t))
|
|
|
|
|
|
(DEFUN CHCM (idnm)
|
|
(declare (fixnum idnm))
|
|
"--------------------------------------------------------------[function-doc]
|
|
CHCM
|
|
Args: (idnm)
|
|
Return from the list *CHCM-LIST* the chain complex instance with Kenzo
|
|
identifier IDNUM or NIL, if it doesn't exist.
|
|
------------------------------------------------------------------------------"
|
|
(the (or chain-complex null)
|
|
(find idnm *chcm-list* :key #'idnm)))
|
|
|
|
|
|
(DEFUN RESULT-PRINT (result stream depth)
|
|
(declare
|
|
(type result result) (stream stream)
|
|
(ignore depth))
|
|
(format stream "~%<Rslt>
|
|
~4TGNRT-> ~A
|
|
~3TVALUE-> ~A
|
|
~4TCLNM-> ~6D
|
|
~4TRNTM-> ~11,3F"
|
|
(result-gnrt result) (result-value result)
|
|
(result-clnm result) (result-rntm result))
|
|
result)
|
|
|
|
|
|
(DEFGENERIC ?2 (chcm-or-mrph cmbn))
|
|
|
|
|
|
(DEFMETHOD ?2 ((mrph morphism) cmbn)
|
|
(declare (type cmbn cmbn))
|
|
(the cmbn
|
|
(cmbn-? mrph cmbn)))
|
|
|
|
|
|
(DEFMETHOD ?2 ((chcm chain-complex) cmbn)
|
|
(declare
|
|
(type cmbn cmbn))
|
|
(the cmbn
|
|
(cmbn-? (dffr1 chcm) cmbn)))
|
|
|
|
|
|
(DEFGENERIC ?3 (chcm-or-mrph degr gnrt))
|
|
|
|
|
|
(DEFMETHOD ?3 ((mrph morphism) degr gnrt)
|
|
(declare
|
|
(fixnum degr)
|
|
(type gnrt gnrt))
|
|
(the cmbn
|
|
(gnrt-? mrph degr gnrt)))
|
|
|
|
|
|
(DEFMETHOD ?3 ((chcm chain-complex) degr gnrt)
|
|
(declare
|
|
(fixnum degr)
|
|
(type gnrt gnrt))
|
|
(gnrt-? (dffr1 chcm) degr gnrt))
|
|
|
|
|
|
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf (ext:package-lock :clos) nil))
|
|
(DEFMETHOD PRINT-OBJECT ((mrph morphism) stream)
|
|
(the morphism
|
|
(progn
|
|
(if (eq (first (orgn (trgt mrph))) 'z-chcm)
|
|
(format stream "[K~D Cohomology-Class on K~D of degree ~D]"
|
|
(idnm mrph) (idnm (sorc mrph)) (- (degr mrph)))
|
|
(format stream "[K~D Morphism (degree ~D): K~D -> K~D]"
|
|
(idnm mrph) (degr mrph)
|
|
(idnm (sorc mrph)) (idnm (trgt mrph))))
|
|
mrph)))
|
|
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf (ext:package-lock :clos) t))
|
|
|
|
(DEFUN MRPH (n)
|
|
(declare (fixnum n))
|
|
"Return from the list *MRPH-LIST* the morphism instance with Kenzo identifier
|
|
IDNUM or NIL, if it doesn't exist."
|
|
(the (or morphism null)
|
|
(find n *mrph-list* :key #'idnm)))
|
|
|
|
|
|
(DEFUN BUILD-CHCM (&key cmpr basis bsgn intr-dffr strt orgn)
|
|
(declare
|
|
(type cmprf cmpr)
|
|
(type (or basis null) basis)
|
|
(type gnrt bsgn)
|
|
(type (or intr-mrph null) intr-dffr)
|
|
(type strt strt)
|
|
(type list orgn))
|
|
"--------------------------------------------------------------[function-doc]
|
|
BUILD-CHCM
|
|
Args: (&key cmpr basis bsgn intr-dffr strt orgn)
|
|
Returns an instance of the class CHAIN-COMPLEX. The keyword arguments are as
|
|
follows:
|
|
|
|
:CMPR CMPR, the comparison function for generators
|
|
|
|
:BASIS BASIS, the function defining the basis of the freee Z-modules C_p or the
|
|
the keyword :LOCALLY-EFFECTIVE
|
|
|
|
:BSGN BSGN, a generator, the base point of the underlying set
|
|
|
|
:INTR-DFFR INTR-DFFR, a Lisp function defining the differential homomorphism
|
|
for each p (d_p: C_p -> C_{p-1}
|
|
|
|
:STRT STRT, one of the keywords :GNRT or :CMBN, defining the mapping strategy
|
|
of the differential homomorphism, either by generator or by
|
|
combination. The default is :GNRT
|
|
|
|
:ORGN ORGN, a list which is the copy of a Lisp statement, in principle the
|
|
statement which was at the origin of the creation of this Kenzo
|
|
object. A caching process, using this slot, prevents the creation
|
|
of multiple copies of the same mathematical object, which is
|
|
important for efficiency. It is used also for debugging and
|
|
analyzing the program.
|
|
|
|
Use this function instead of creating instances via the standard constructor
|
|
MAKE-INSTANCE.
|
|
------------------------------------------------------------------------------"
|
|
(the chain-complex
|
|
(progn
|
|
(let ((already (find orgn *chcm-list* :test #'equal :key #'orgn)))
|
|
(declare (type (or chain-complex null) already))
|
|
(when already
|
|
(return-from build-chcm already)))
|
|
(unless basis
|
|
(setf basis :locally-effective))
|
|
(let ((chcm (make-instance 'chain-complex
|
|
:cmpr cmpr
|
|
:basis basis
|
|
:bsgn bsgn
|
|
:orgn orgn)))
|
|
(declare (type chain-complex chcm))
|
|
(setf (slot-value chcm 'dffr)
|
|
(build-mrph
|
|
:sorc chcm :trgt chcm :degr -1
|
|
:intr intr-dffr :strt strt
|
|
:orgn `(dffr ,chcm)))
|
|
(setf (slot-value chcm 'grmd) chcm)
|
|
(push chcm *chcm-list*)
|
|
chcm))))
|
|
|
|
|
|
(DEFUN BASIS2 (object n) ;;;
|
|
(declare
|
|
(type t object)
|
|
(fixnum n))
|
|
(the list
|
|
(with-slots (basis) object
|
|
(declare (type basis basis))
|
|
(when (eq :locally-effective basis)
|
|
(error "The object ~A is locally-effective." object))
|
|
(funcall basis n))))
|
|
|
|
|
|
(DEFUN BUILD-MRPH (&key sorc trgt degr intr strt orgn)
|
|
(declare
|
|
(type chain-complex sorc trgt)
|
|
(fixnum degr)
|
|
(type (or intr-mrph null) intr)
|
|
(type strt strt)
|
|
(list orgn))
|
|
"--------------------------------------------------------------[function-doc]
|
|
BUILD-MRPH
|
|
Args: (&key sorc trgt degr intr strt orgn)
|
|
Returns an instance of the class MORPHISM. The keyword arguments are as
|
|
follows:
|
|
|
|
:SORC SORC, the source object, a CHAIN-COMPLEX type object
|
|
|
|
:TRGT TRGT, the target object, a CHAIN-COMPLEX type object
|
|
|
|
:DEGR DEGR, the degree of the morphism, an integer
|
|
|
|
:INTR INTR, the Lisp function defining the effective mapping
|
|
|
|
:STRT STRT, one of the keywords :GNRT or :CMBN, defining the mapping strategy
|
|
of the differential homomorphism, either by generator or by
|
|
combination. The default is :GNRT
|
|
|
|
:ORGN ORGN, a list which is the copy of a Lisp statement, in principle the
|
|
statement which was at the origin of the creation of this Kenzo
|
|
object. A caching process, using this slot, prevents the creation
|
|
of multiple copies of the same mathematical object, which is
|
|
important for efficiency. It is used also for debugging and
|
|
analyzing the program.
|
|
|
|
Use this function instead of creating instances via the standard constructor
|
|
MAKE-INSTANCE.
|
|
------------------------------------------------------------------------------"
|
|
(the morphism
|
|
(progn
|
|
(let ((already (find orgn *mrph-list* :test #'equal :key #'orgn)))
|
|
(declare (type (or morphism null) already))
|
|
(when already
|
|
(return-from build-mrph already)))
|
|
(let ((mrph (make-instance 'morphism
|
|
:sorc sorc :trgt trgt :degr degr
|
|
:intr intr :strt strt
|
|
:orgn orgn)))
|
|
(declare (type morphism mrph))
|
|
(setf (slot-value mrph 'rslts)
|
|
(ecase strt
|
|
(:gnrt (map 'simple-vector
|
|
;; (vector (vector result))
|
|
#'(lambda (dummy)
|
|
(declare (ignore dummy))
|
|
(make-array 0
|
|
:adjustable t
|
|
:fill-pointer 0))
|
|
(make-list +maximal-dimension+)))
|
|
(:cmbn (make-array 0))))
|
|
(push mrph *mrph-list*)
|
|
mrph))))
|
|
|
|
;;; FUNCTIONS
|
|
|
|
(DEFUN NRESULTS ()
|
|
(the fixnum
|
|
(let ((nrslts 0))
|
|
(declare (fixnum nrslts))
|
|
(dolist (item *mrph-list*)
|
|
(declare (type morphism item))
|
|
(when (eq :gnrt (strt item))
|
|
(map nil
|
|
#'(lambda (drslt)
|
|
(declare (vector drslt))
|
|
(incf nrslts (length drslt)))
|
|
(rslts item))))
|
|
nrslts)))
|
|
|
|
|
|
(DEFUN TIME-LIST ()
|
|
(the list
|
|
(let ((time-list +empty-list+))
|
|
(declare (list time-list))
|
|
(dolist (item *mrph-list*)
|
|
(declare (type morphism item))
|
|
(when (eq :gnrt (strt item))
|
|
(map nil #'(lambda (drslt)
|
|
(declare (vector drslt))
|
|
(map nil #'(lambda (rslt)
|
|
(declare (type result rslt))
|
|
(let ((rntm (result-rntm rslt)))
|
|
(declare (single-float rntm))
|
|
(when (plusp rntm)
|
|
(push rntm time-list))))
|
|
drslt))
|
|
(rslts item))))
|
|
(sort time-list #'>))))
|
|
|
|
|
|
(DEFUN CLEAN-RESULTS (&optional (results-coef *results-coef*))
|
|
(declare
|
|
(single-float results-coef)
|
|
(special *results-coef* *results-cmlt-tm* *results-n* *results-verbose*))
|
|
(the (values )
|
|
(let ((cut (* results-coef (/ *results-cmlt-tm* *results-n*))))
|
|
(declare (single-float cut))
|
|
(setf *results-n* 0 *results-cmlt-tm* 0.0)
|
|
(dolist (item *mrph-list*)
|
|
(declare (type morphism item))
|
|
(when (eq :gnrt (strt item))
|
|
(let ((rslts (rslts item)))
|
|
(declare (vector rslts))
|
|
(dotimes (i +maximal-dimension+)
|
|
(declare (fixnum i))
|
|
(let ((rslts-i (aref rslts i))
|
|
(output (make-array 0 :adjustable t :fill-pointer 0)))
|
|
(declare (vector rslts-i output))
|
|
(map nil
|
|
#'(lambda (rslt)
|
|
(declare (type result rslt))
|
|
(let ((rntm (result-rntm rslt)))
|
|
(declare (single-float rntm))
|
|
(when (> rntm cut)
|
|
(incf *results-n*)
|
|
(incf *results-cmlt-tm* rntm)
|
|
(vector-push-extend rslt output))))
|
|
rslts-i)
|
|
(setf (aref rslts i) output))))))
|
|
(when *results-verbose*
|
|
(format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*)))))
|
|
|
|
|
|
(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)
|
|
(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)))
|
|
(declare (fixnum middle))
|
|
(ecase (funcall cmpr2 gnrt (result-gnrt (aref memory 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)))))))
|
|
|
|
|
|
(DEFUN MRPH-CMBN (scmpr2 tcmpr2 intr cmbn memory)
|
|
(declare
|
|
(type intr-mrph intr)
|
|
;; (function (fixnum gnrt) cmbn)
|
|
(type cmprf scmpr2 tcmpr2)
|
|
(type cmbn cmbn) ;;; cmbn is a non-zero one
|
|
(vector memory))
|
|
;; (vector result)
|
|
(the cmbn
|
|
(with-cmbn (degr list) cmbn
|
|
(let ((n-cmbn-list +empty-list+))
|
|
(declare (list n-cmbn-list))
|
|
(do ((mark list (cdr mark))
|
|
(left -1))
|
|
((endp mark))
|
|
(declare (list mark))
|
|
(multiple-value-bind (rslt new-left)
|
|
(mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left)
|
|
(setf left new-left)
|
|
(push (cons (-cffc mark) rslt) n-cmbn-list)))
|
|
(cmbn-cmbn tcmpr2 n-cmbn-list)))))
|
|
|
|
(DEFUN DO-CONTROL (cmpr cmbn)
|
|
(declare
|
|
(type cmprf cmpr)
|
|
(type cmbn cmbn))
|
|
(when *cmbn-control*
|
|
(let ((list (cmbn-list cmbn)))
|
|
(declare (list list))
|
|
(do ((mark1 (rest list) (cdr mark1))
|
|
(mark2 list mark1))
|
|
((endp mark1))
|
|
(declare (list mark1 mark2))
|
|
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
|
|
(setf *wrong-cmbn* cmbn)
|
|
(error "In the combination located by *WRONG-CMBN*, the generators:~@
|
|
~A and ~A are in a wrong order." (cdar mark2)
|
|
(cdar mark1))))))
|
|
cmbn)
|
|
|
|
#|
|
|
(DEFVAR *PROFILER-STACK*)
|
|
(SETF *PROFILER-STACK* +empty-list+)
|
|
|
|
(DEFUN PROFILER-INIT ()
|
|
(mapc #'(lambda (mrph)
|
|
(declare (type morphism mrph))
|
|
(setf (wrtm mrph) 0))
|
|
*mrph-list*))
|
|
|
|
(DEFUN PROFILER-ON ()
|
|
(push (get-internal-run-time) *profiler-stack*))
|
|
|
|
(DEFUN PROFILER-OFF (mrph)
|
|
(declare (type morphism mrph))
|
|
(let ((time-spent
|
|
(- (get-internal-run-time) (pop *profiler-stack*))))
|
|
(declare (integer time-spent))
|
|
(mapl #'(lambda (mark)
|
|
(declare (cons mark))
|
|
(incf (car mark) time-spent))
|
|
*profiler-stack*)
|
|
(incf (wrtm mrph) time-spent)))
|
|
|#
|
|
|
|
|
|
(DEFUN GNRT-? (mrph degr gnrt)
|
|
(declare
|
|
(type morphism mrph)
|
|
(fixnum degr)
|
|
(type gnrt gnrt))
|
|
(the cmbn
|
|
(progn
|
|
;; (profiler-on)
|
|
(when (and *future-display*
|
|
(> (get-internal-run-time) *future-display*))
|
|
(format t "~%GNRT-?
|
|
~3T~A ORGN = ~A
|
|
~3TDEGR = ~D
|
|
~3TGNRT = ~A"
|
|
mrph (orgn mrph) degr gnrt)
|
|
(setf *future-display* (+ (get-internal-run-time) *time-interval*)))
|
|
(with-slots (sorc (mdegr degr) intr strt ?-clnm) mrph
|
|
(declare
|
|
(type chain-complex sorc)
|
|
(fixnum mdegr ?-clnm)
|
|
(type intr-mrph intr)
|
|
(type strt strt))
|
|
(with-slots ((scmpr cmpr)) sorc
|
|
(declare (type cmprf scmpr))
|
|
(control (slot-value (slot-value mrph 'trgt) 'cmpr)
|
|
(progn
|
|
(incf ?-clnm)
|
|
(prog1
|
|
(ecase strt
|
|
(:gnrt
|
|
(mrph-gnrt scmpr intr
|
|
degr gnrt (svref (rslts mrph) degr)))
|
|
(:cmbn
|
|
(funcall intr (term-cmbn degr 1 gnrt))))
|
|
;; (profiler-off mrph)
|
|
))))))))
|
|
|
|
|
|
(DEFUN CMBN-? (mrph cmbn)
|
|
(declare
|
|
(type morphism mrph)
|
|
(type cmbn cmbn))
|
|
(the cmbn
|
|
(progn
|
|
;; (profiler-on)
|
|
(when (and *future-display*
|
|
(> (get-internal-run-time) *future-display*))
|
|
(format t "~%CMBN-?
|
|
~3T~A ORGN = ~A
|
|
~3TCMBN = ~A"
|
|
mrph (orgn mrph) cmbn)
|
|
(setf *future-display* (+ (get-internal-run-time) *time-interval*)))
|
|
(with-slots (sorc trgt degr intr strt ???-clnm) mrph
|
|
(declare
|
|
(type chain-complex sorc trgt)
|
|
(fixnum degr ???-clnm)
|
|
(type intr-mrph intr)
|
|
(type strt strt))
|
|
(with-slots ((scmpr cmpr)) sorc
|
|
(declare (type cmprf scmpr))
|
|
(with-slots ((tcmpr cmpr)) trgt
|
|
(declare (type cmprf tcmpr))
|
|
(control tcmpr
|
|
(progn
|
|
(controln scmpr cmbn)
|
|
(incf ???-clnm)
|
|
(when (eq strt :cmbn)
|
|
(return-from cmbn-? (funcall intr cmbn)))
|
|
(prog1
|
|
(if (cmbn-zero-p cmbn)
|
|
(zero-cmbn (+ (cmbn-degr cmbn) degr))
|
|
(mrph-cmbn scmpr tcmpr intr
|
|
cmbn (svref (rslts mrph)
|
|
(cmbn-degr cmbn))))
|
|
;; (profiler-off mrph)
|
|
)))))))))
|