Addressed issue #73.
This commit is contained in:
Gerd Heber
parent
1e09c2e8cc
commit
bcb4a8539d
@ -31,13 +31,13 @@ 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*)
|
||||
(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))
|
||||
|
||||
|
||||
@ -48,12 +48,12 @@ 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)))
|
||||
(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))))
|
||||
@ -71,9 +71,9 @@ Return the type of Kenzo object number IDNM and print the comment list
|
||||
(dolist (list *list-list*)
|
||||
(let ((found (find idnm (eval list) :key #'idnm)))
|
||||
(when found
|
||||
(format t "~%Object: ~A
|
||||
(format t "~%Object: ~A
|
||||
~3TOrigin: ~A~2%" found (orgn found))
|
||||
(return-from kd (values))))))
|
||||
(return-from kd (values))))))
|
||||
|
||||
|
||||
(DEFUN K (idnm)
|
||||
@ -86,7 +86,7 @@ Returns the IDNM-th Kenzo object.
|
||||
(dolist (list *list-list*)
|
||||
(let ((found (find idnm (eval list) :key #'idnm)))
|
||||
(when found
|
||||
(return-from k found)))))
|
||||
(return-from k found)))))
|
||||
|
||||
|
||||
(DEFUN KD2 (idnm)
|
||||
@ -104,16 +104,16 @@ the list of object numbers.
|
||||
(return-from kd2 nil))
|
||||
(setf k-list (list k-list))
|
||||
(do ((idnm (1- idnm) (1- idnm)))
|
||||
((zerop 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))))
|
||||
#'(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)))))
|
||||
|
||||
|
||||
@ -122,8 +122,8 @@ the list of object numbers.
|
||||
(DEFMETHOD PRINT-OBJECT ((chcm chain-complex) stream)
|
||||
(the chain-complex
|
||||
(progn
|
||||
(format stream "[K~D Chain-Complex]" (idnm chcm))
|
||||
chcm)))
|
||||
(format stream "[K~D Chain-Complex]" (idnm chcm))
|
||||
chcm)))
|
||||
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setf (ext:package-lock :clos) t))
|
||||
|
||||
@ -149,8 +149,8 @@ identifier IDNUM or NIL, if it doesn't exist.
|
||||
~3TVALUE-> ~A
|
||||
~4TCLNM-> ~6D
|
||||
~4TRNTM-> ~11,3F"
|
||||
(result-gnrt result) (result-value result)
|
||||
(result-clnm result) (result-rntm result))
|
||||
(result-gnrt result) (result-value result)
|
||||
(result-clnm result) (result-rntm result))
|
||||
result)
|
||||
|
||||
|
||||
@ -193,12 +193,12 @@ identifier IDNUM or NIL, if it doesn't exist.
|
||||
(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))))
|
||||
(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))
|
||||
@ -239,10 +239,12 @@ follows:
|
||||
of the differential homomorphism, either by generator or by
|
||||
combination. The default is :GNRT
|
||||
|
||||
:ORGN ORGN, a list containing a relevant and carefully chosen comment about
|
||||
the origin of the chain complex. This comment should be unique
|
||||
for a Kenzo session (between calls of CAT-INIT), as it is used
|
||||
for caching purposes.
|
||||
: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.
|
||||
@ -250,25 +252,25 @@ 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)))
|
||||
(declare (type (or chain-complex null) already))
|
||||
(when already
|
||||
(return-from build-chcm already)))
|
||||
(unless basis
|
||||
(setf basis :locally-effective))
|
||||
(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))))
|
||||
: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) ;;;
|
||||
@ -279,7 +281,7 @@ MAKE-INSTANCE.
|
||||
(with-slots (basis) object
|
||||
(declare (type basis basis))
|
||||
(when (eq :locally-effective basis)
|
||||
(error "The object ~A is locally-effective." object))
|
||||
(error "The object ~A is locally-effective." object))
|
||||
(funcall basis n))))
|
||||
|
||||
|
||||
@ -308,10 +310,12 @@ follows:
|
||||
of the differential homomorphism, either by generator or by
|
||||
combination. The default is :GNRT
|
||||
|
||||
:ORGN ORGN, a list containing a relevant and carefully chosen comment about
|
||||
the origin of the chain complex. This comment should be unique
|
||||
for a Kenzo session (between calls of CAT-INIT), as it is used
|
||||
for caching purposes.
|
||||
: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.
|
||||
@ -319,63 +323,63 @@ 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)))
|
||||
(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
|
||||
: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))
|
||||
(declare (ignore dummy))
|
||||
(make-array 0
|
||||
:adjustable t
|
||||
:fill-pointer 0))
|
||||
(make-list +maximal-dimension+)))
|
||||
(:cmbn (make-array 0))))
|
||||
(push mrph *mrph-list*)
|
||||
mrph))))
|
||||
(: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)))
|
||||
(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 #'>))))
|
||||
(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*))
|
||||
@ -384,35 +388,35 @@ MAKE-INSTANCE.
|
||||
(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*)))))
|
||||
(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)))
|
||||
&optional (left -1) (right (fill-pointer memory)))
|
||||
(declare
|
||||
(type intr-mrph intr)
|
||||
;; (function (fixnum gnrt) cmbn)
|
||||
@ -427,47 +431,47 @@ MAKE-INSTANCE.
|
||||
;; 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)))
|
||||
(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))
|
||||
(: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)))))))
|
||||
|
||||
|
||||
@ -481,17 +485,17 @@ MAKE-INSTANCE.
|
||||
;; (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)))))
|
||||
(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
|
||||
@ -501,14 +505,14 @@ MAKE-INSTANCE.
|
||||
(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:~@
|
||||
(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))))))
|
||||
(cdar mark1))))))
|
||||
cmbn)
|
||||
|
||||
#|
|
||||
@ -517,9 +521,9 @@ MAKE-INSTANCE.
|
||||
|
||||
(DEFUN PROFILER-INIT ()
|
||||
(mapc #'(lambda (mrph)
|
||||
(declare (type morphism mrph))
|
||||
(setf (wrtm mrph) 0))
|
||||
*mrph-list*))
|
||||
(declare (type morphism mrph))
|
||||
(setf (wrtm mrph) 0))
|
||||
*mrph-list*))
|
||||
|
||||
(DEFUN PROFILER-ON ()
|
||||
(push (get-internal-run-time) *profiler-stack*))
|
||||
@ -527,12 +531,12 @@ MAKE-INSTANCE.
|
||||
(DEFUN PROFILER-OFF (mrph)
|
||||
(declare (type morphism mrph))
|
||||
(let ((time-spent
|
||||
(- (get-internal-run-time) (pop *profiler-stack*))))
|
||||
(- (get-internal-run-time) (pop *profiler-stack*))))
|
||||
(declare (integer time-spent))
|
||||
(mapl #'(lambda (mark)
|
||||
(declare (cons mark))
|
||||
(incf (car mark) time-spent))
|
||||
*profiler-stack*)
|
||||
(declare (cons mark))
|
||||
(incf (car mark) time-spent))
|
||||
*profiler-stack*)
|
||||
(incf (wrtm mrph) time-spent)))
|
||||
|#
|
||||
|
||||
@ -544,35 +548,35 @@ MAKE-INSTANCE.
|
||||
(type gnrt gnrt))
|
||||
(the cmbn
|
||||
(progn
|
||||
;; (profiler-on)
|
||||
;; (profiler-on)
|
||||
(when (and *future-display*
|
||||
(> (get-internal-run-time) *future-display*))
|
||||
(format t "~%GNRT-?
|
||||
(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*)))
|
||||
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)
|
||||
))))))))
|
||||
(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)
|
||||
@ -581,35 +585,35 @@ MAKE-INSTANCE.
|
||||
(type cmbn cmbn))
|
||||
(the cmbn
|
||||
(progn
|
||||
;; (profiler-on)
|
||||
;; (profiler-on)
|
||||
(when (and *future-display*
|
||||
(> (get-internal-run-time) *future-display*))
|
||||
(format t "~%CMBN-?
|
||||
(format t "~%CMBN-?
|
||||
~3T~A ORGN = ~A
|
||||
~3TCMBN = ~A"
|
||||
mrph (orgn mrph) cmbn)
|
||||
(setf *future-display* (+ (get-internal-run-time) *time-interval*)))
|
||||
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)
|
||||
)))))))))
|
||||
(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)
|
||||
)))))))))
|
||||
|
||||
@ -192,9 +192,11 @@ Intances of this class represent chain complexes. The class has 8 slots:
|
||||
7. IDNM, an integer, a system generated identifier for this object. Its reader
|
||||
function is IDNM.
|
||||
|
||||
8. ORGN, a list containg a comment indicating the origin of the object. The
|
||||
should be unique (per session), since it is used in the implementation for
|
||||
caching purposes. Its reader function is ORGN.
|
||||
8. 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.
|
||||
-----------------------------------------------------------------------------"))
|
||||
|
||||
|
||||
@ -275,9 +277,11 @@ degree -1. The class has 10 slots:
|
||||
9. IDNM, an integer, a system-generated identifier for this object. Its reader
|
||||
function is IDNM.
|
||||
|
||||
10. ORGN, a list containg a comment indicating the origin of the object. The
|
||||
should be unique (per session), since it is used in the implementation for
|
||||
caching purposes. Its reader function is ORGN.
|
||||
10. 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.
|
||||
-----------------------------------------------------------------------------"))
|
||||
|
||||
|
||||
@ -335,13 +339,14 @@ The class has 7 slots:
|
||||
5. H, an object of type MORPHISM representing the morphism of graded modules h.
|
||||
Its reader function is H1.
|
||||
|
||||
9. IDNM, an integer, a system-generated identifier for this object. Its reader
|
||||
6. IDNM, an integer, a system-generated identifier for this object. Its reader
|
||||
function is IDNM.
|
||||
|
||||
10. ORGN, a list containg a comment indicating the origin of the object.
|
||||
This comment should be unique for a Kenzo session (between calls of
|
||||
CAT-INIT), as it is used for caching purposes. Its reader function
|
||||
is ORGN.
|
||||
7. 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.
|
||||
-----------------------------------------------------------------------------"))
|
||||
|
||||
|
||||
|
||||
@ -16,9 +16,9 @@
|
||||
(DEFMETHOD PRINT-OBJECT ((rdct reduction) stream)
|
||||
(the reduction
|
||||
(progn
|
||||
(format stream "[K~D Reduction K~D => K~D]"
|
||||
(idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct)))
|
||||
rdct)))
|
||||
(format stream "[K~D Reduction K~D => K~D]"
|
||||
(idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct)))
|
||||
rdct)))
|
||||
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setf (ext:package-lock :clos) t))
|
||||
|
||||
@ -54,10 +54,12 @@ follows:
|
||||
:H H, an object of type MORPHISM representing the morphism of graded modules h
|
||||
of a reduction
|
||||
|
||||
:ORGN ORGN, a list containing a relevant and carefully chosen comment about
|
||||
the origin of the chain complex. This comment should be unique
|
||||
for a Kenzo session (between calls of CAT-INIT), as it is used
|
||||
for caching purposes.
|
||||
: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.
|
||||
@ -65,38 +67,38 @@ MAKE-INSTANCE.
|
||||
(the reduction
|
||||
(progn
|
||||
(unless orgn
|
||||
(setf orgn `(build-rdct ,f ,g ,h)))
|
||||
(setf orgn `(build-rdct ,f ,g ,h)))
|
||||
(let ((already (find orgn *rdct-list* :test #'equal :key #'orgn)))
|
||||
(declare (type (or reduction null) already))
|
||||
(when already
|
||||
(return-from build-rdct already)))
|
||||
(declare (type (or reduction null) already))
|
||||
(when already
|
||||
(return-from build-rdct already)))
|
||||
(with-slots ((fsorc sorc) (ftrgt trgt) (fdegr degr)) f
|
||||
(declare
|
||||
(type chain-complex fsorc ftrgt)
|
||||
(fixnum fdegr))
|
||||
(with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g
|
||||
(declare
|
||||
(type chain-complex gsorc gtrgt)
|
||||
(fixnum gdegr))
|
||||
(with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h
|
||||
(declare
|
||||
(type chain-complex hsorc htrgt)
|
||||
(fixnum hdegr))
|
||||
(unless (and (eq gsorc ftrgt)
|
||||
(eq fsorc gtrgt)
|
||||
(eq hsorc fsorc)
|
||||
(eq htrgt fsorc)
|
||||
(zerop fdegr)
|
||||
(zerop gdegr)
|
||||
(= +1 hdegr))
|
||||
(error "In BUILD-RDCT, the data are non coherent."))
|
||||
(let ((rdct (make-instance 'reduction
|
||||
:tcc fsorc :bcc ftrgt
|
||||
:f f :g g :h h
|
||||
:orgn orgn)))
|
||||
(declare (type reduction rdct))
|
||||
(push rdct *rdct-list*)
|
||||
rdct)))))))
|
||||
(declare
|
||||
(type chain-complex fsorc ftrgt)
|
||||
(fixnum fdegr))
|
||||
(with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g
|
||||
(declare
|
||||
(type chain-complex gsorc gtrgt)
|
||||
(fixnum gdegr))
|
||||
(with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h
|
||||
(declare
|
||||
(type chain-complex hsorc htrgt)
|
||||
(fixnum hdegr))
|
||||
(unless (and (eq gsorc ftrgt)
|
||||
(eq fsorc gtrgt)
|
||||
(eq hsorc fsorc)
|
||||
(eq htrgt fsorc)
|
||||
(zerop fdegr)
|
||||
(zerop gdegr)
|
||||
(= +1 hdegr))
|
||||
(error "In BUILD-RDCT, the data are non coherent."))
|
||||
(let ((rdct (make-instance 'reduction
|
||||
:tcc fsorc :bcc ftrgt
|
||||
:f f :g g :h h
|
||||
:orgn orgn)))
|
||||
(declare (type reduction rdct))
|
||||
(push rdct *rdct-list*)
|
||||
rdct)))))))
|
||||
|
||||
|
||||
(DEFUN TRIVIAL-RDCT (chcm)
|
||||
@ -142,27 +144,27 @@ See also: ZERO-MRPH, IDNT-MRPH.
|
||||
(the homotopy-equivalence
|
||||
(progn
|
||||
(with-slots ((lf f) (lg g) (lh h) (ltcc tcc) (lbcc bcc)) lrdct
|
||||
(declare
|
||||
(type morphism lf lg lh)
|
||||
(type chain-complex ltcc lbcc))
|
||||
(with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct
|
||||
(declare
|
||||
(type morphism rf rg rh)
|
||||
(type chain-complex rtcc rbcc))
|
||||
(unless (eq ltcc rtcc)
|
||||
(declare
|
||||
(type morphism lf lg lh)
|
||||
(type chain-complex ltcc lbcc))
|
||||
(with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct
|
||||
(declare
|
||||
(type morphism rf rg rh)
|
||||
(type chain-complex rtcc rbcc))
|
||||
(unless (eq ltcc rtcc)
|
||||
(error "In BUILD-HMEQ (version from rdct), the tcc's are not the same."))
|
||||
(unless orgn
|
||||
(unless orgn
|
||||
(setf orgn `(build-hmeq ,lrdct ,rrdct)))
|
||||
(let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
|
||||
(let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
|
||||
(declare (type (or homotopy-equivalence null) already))
|
||||
(when already
|
||||
(return-from build-hmeq already)))
|
||||
(let ((hmeq (make-instance 'homotopy-equivalence
|
||||
:lbcc lbcc :tcc ltcc :rbcc rbcc
|
||||
:lf lf :lg lg :lh lh
|
||||
:rf rf :rg rg :rh rh
|
||||
:lrdct lrdct :rrdct rrdct
|
||||
:orgn orgn)))
|
||||
(return-from build-hmeq already)))
|
||||
(let ((hmeq (make-instance 'homotopy-equivalence
|
||||
:lbcc lbcc :tcc ltcc :rbcc rbcc
|
||||
:lf lf :lg lg :lh lh
|
||||
:rf rf :rg rg :rh rh
|
||||
:lrdct lrdct :rrdct rrdct
|
||||
:orgn orgn)))
|
||||
(declare (type homotopy-equivalence hmeq))
|
||||
(push hmeq *hmeq-list*)
|
||||
hmeq))))))
|
||||
@ -173,10 +175,10 @@ See also: ZERO-MRPH, IDNT-MRPH.
|
||||
(DEFMETHOD PRINT-OBJECT ((hmeq homotopy-equivalence) stream)
|
||||
(the homotopy-equivalence
|
||||
(progn
|
||||
(format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]"
|
||||
(idnm hmeq)
|
||||
(idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq)))
|
||||
hmeq)))
|
||||
(format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]"
|
||||
(idnm hmeq)
|
||||
(idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq)))
|
||||
hmeq)))
|
||||
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setf (ext:package-lock :clos) t))
|
||||
|
||||
@ -194,16 +196,16 @@ See also: ZERO-MRPH, IDNT-MRPH.
|
||||
(the homotopy-equivalence
|
||||
(progn
|
||||
(unless orgn
|
||||
(setf orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh)))
|
||||
(setf orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh)))
|
||||
(let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
|
||||
(declare (type (or null homotopy-equivalence) already))
|
||||
(when already
|
||||
(return-from build-hmeq already)))
|
||||
(declare (type (or null homotopy-equivalence) already))
|
||||
(when already
|
||||
(return-from build-hmeq already)))
|
||||
(build-hmeq
|
||||
:lrdct (build-rdct :f lf :g lg :h lh
|
||||
:orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh lrdct))
|
||||
:orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh lrdct))
|
||||
:rrdct (build-rdct :f rf :g rg :h rh
|
||||
:orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct))
|
||||
:orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct))
|
||||
:orgn orgn))))
|
||||
|
||||
(DEFUN TRIVIAL-HMEQ (chcm)
|
||||
@ -256,21 +258,21 @@ according to these formulas:
|
||||
(type chain-complex bcc tcc)
|
||||
(type morphism f g h))
|
||||
(setf *tdd* (cmps tcc tcc)
|
||||
*bdd* (cmps bcc bcc)
|
||||
*df-fd* (sbtr
|
||||
(cmps bcc f)
|
||||
(cmps f tcc))
|
||||
*dg-gd* (sbtr
|
||||
(cmps tcc g)
|
||||
(cmps g bcc))
|
||||
*id-fg* (sbtr (idnt-mrph bcc) (cmps f g))
|
||||
*id-gf-dh-hd* (i-sbtr (idnt-mrph tcc)
|
||||
(cmps g f)
|
||||
(cmps tcc h)
|
||||
(cmps h tcc))
|
||||
*hh* (cmps h h)
|
||||
*fh* (cmps f h)
|
||||
*hg* (cmps h g)))
|
||||
*bdd* (cmps bcc bcc)
|
||||
*df-fd* (sbtr
|
||||
(cmps bcc f)
|
||||
(cmps f tcc))
|
||||
*dg-gd* (sbtr
|
||||
(cmps tcc g)
|
||||
(cmps g bcc))
|
||||
*id-fg* (sbtr (idnt-mrph bcc) (cmps f g))
|
||||
*id-gf-dh-hd* (i-sbtr (idnt-mrph tcc)
|
||||
(cmps g f)
|
||||
(cmps tcc h)
|
||||
(cmps h tcc))
|
||||
*hh* (cmps h h)
|
||||
*fh* (cmps f h)
|
||||
*hg* (cmps h g)))
|
||||
(done))
|
||||
|
||||
|
||||
@ -292,13 +294,13 @@ the <Enter> key.
|
||||
(declare (type symbol cmbn))
|
||||
(format t "~%~A => ~A" cmbn (eval cmbn)))
|
||||
(dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd*
|
||||
*hh* *fh* *hg*))
|
||||
*hh* *fh* *hg*))
|
||||
(declare (type symbol phi))
|
||||
(format t "~%Checking ~A = 0" phi)
|
||||
(format t "~%Result: ")
|
||||
(princ (cmbn-? (eval phi)
|
||||
(if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
|
||||
*bc* *tc*)))
|
||||
(if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
|
||||
*bc* *tc*)))
|
||||
(read-line))
|
||||
(done))
|
||||
|
||||
@ -317,13 +319,13 @@ coherent, the result of each mapping is a null combination.
|
||||
(declare (type symbol cmbn))
|
||||
(format t "~%~A => ~A" cmbn (eval cmbn)))
|
||||
(dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd*
|
||||
*hh* *fh* *hg*))
|
||||
*hh* *fh* *hg*))
|
||||
(declare (type symbol phi))
|
||||
(format t "~%Checking ~A = 0" phi)
|
||||
(format t "~%Result: ")
|
||||
(princ (cmbn-? (eval phi)
|
||||
(if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
|
||||
*bc* *tc*))))
|
||||
(if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
|
||||
*bc* *tc*))))
|
||||
(done))
|
||||
|
||||
|
||||
@ -366,47 +368,47 @@ coherent, the result of each mapping is a null combination.
|
||||
(type morphism top-perturbation))
|
||||
(the (values reduction morphism)
|
||||
(with-slots ((old-tcc tcc) (old-bcc bcc)
|
||||
(old-f f) (old-g g) (old-h h)) reduction
|
||||
(old-f f) (old-g g) (old-h h)) reduction
|
||||
(declare
|
||||
(type chain-complex old-tcc old-bcc)
|
||||
(type morphism old-f old-g old-h))
|
||||
(type chain-complex old-tcc old-bcc)
|
||||
(type morphism old-f old-g old-h))
|
||||
(when (eq (first (orgn top-perturbation)) 'zero-mrph)
|
||||
(return-from basic-perturbation-lemma
|
||||
(values reduction (zero-mrph old-bcc))))
|
||||
(return-from basic-perturbation-lemma
|
||||
(values reduction (zero-mrph old-bcc))))
|
||||
(when (eq (first (orgn (h reduction))) 'zero-mrph)
|
||||
(return-from basic-perturbation-lemma
|
||||
(values
|
||||
(trivial-rdct (add old-tcc top-perturbation))
|
||||
(i-cmps old-f top-perturbation old-g))))
|
||||
(return-from basic-perturbation-lemma
|
||||
(values
|
||||
(trivial-rdct (add old-tcc top-perturbation))
|
||||
(i-cmps old-f top-perturbation old-g))))
|
||||
(let* ((sigma (bpl-*-sigma old-h top-perturbation))
|
||||
(new-f (cmps old-f
|
||||
(sbtr (idnt-mrph old-tcc)
|
||||
(i-cmps
|
||||
top-perturbation
|
||||
sigma
|
||||
old-h))))
|
||||
(sbtr (idnt-mrph old-tcc)
|
||||
(i-cmps
|
||||
top-perturbation
|
||||
sigma
|
||||
old-h))))
|
||||
(new-g (cmps sigma old-g))
|
||||
(new-h (cmps sigma old-h))
|
||||
(bottom-perturbation (i-cmps
|
||||
old-f
|
||||
top-perturbation
|
||||
new-g))
|
||||
old-f
|
||||
top-perturbation
|
||||
new-g))
|
||||
(new-tcc (add old-tcc top-perturbation))
|
||||
(new-bcc (add old-bcc bottom-perturbation)))
|
||||
(declare
|
||||
(type chain-complex new-tcc new-bcc)
|
||||
(type morphism sigma new-f new-g new-h bottom-perturbation))
|
||||
(setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc
|
||||
:new-trgt new-bcc)
|
||||
new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc
|
||||
:new-trgt new-tcc)
|
||||
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
|
||||
:new-trgt new-tcc))
|
||||
(values
|
||||
(build-rdct :f new-f :g new-g :h new-h
|
||||
:orgn `(basic-perturbation-lemma ,reduction
|
||||
,top-perturbation))
|
||||
bottom-perturbation)))))
|
||||
(declare
|
||||
(type chain-complex new-tcc new-bcc)
|
||||
(type morphism sigma new-f new-g new-h bottom-perturbation))
|
||||
(setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc
|
||||
:new-trgt new-bcc)
|
||||
new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc
|
||||
:new-trgt new-tcc)
|
||||
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
|
||||
:new-trgt new-tcc))
|
||||
(values
|
||||
(build-rdct :f new-f :g new-g :h new-h
|
||||
:orgn `(basic-perturbation-lemma ,reduction
|
||||
,top-perturbation))
|
||||
bottom-perturbation)))))
|
||||
|
||||
(DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation)
|
||||
(declare
|
||||
@ -414,32 +416,32 @@ coherent, the result of each mapping is a null combination.
|
||||
(type morphism bottom-perturbation))
|
||||
(the (values reduction morphism)
|
||||
(with-slots ((old-tcc tcc) (old-bcc bcc)
|
||||
(old-f f) (old-g g) (old-h h)) reduction
|
||||
(old-f f) (old-g g) (old-h h)) reduction
|
||||
(declare
|
||||
(type chain-complex old-tcc old-bcc)
|
||||
(type morphism old-f old-g old-h))
|
||||
(type chain-complex old-tcc old-bcc)
|
||||
(type morphism old-f old-g old-h))
|
||||
(when (eq 'zero-mrph (first (orgn bottom-perturbation)))
|
||||
(return-from easy-perturbation-lemma
|
||||
(values reduction (zero-mrph old-tcc))))
|
||||
(when (eq 'trivial-rdct (first (orgn reduction)))
|
||||
(return-from easy-perturbation-lemma
|
||||
(trivial-rdct (add (bcc reduction) bottom-perturbation))))
|
||||
(return-from easy-perturbation-lemma
|
||||
(values reduction (zero-mrph old-tcc))))
|
||||
(when (eq 'trivial-rdct (first (orgn reduction)))
|
||||
(return-from easy-perturbation-lemma
|
||||
(trivial-rdct (add (bcc reduction) bottom-perturbation))))
|
||||
(let ((top-perturbation (i-cmps old-g bottom-perturbation old-f)))
|
||||
(declare (type morphism top-perturbation))
|
||||
(let ((new-bcc (add old-bcc bottom-perturbation))
|
||||
(new-tcc (add old-tcc top-perturbation)))
|
||||
(declare (type chain-complex new-bcc new-tcc))
|
||||
(values
|
||||
(build-rdct
|
||||
:f (dstr-change-sorc-trgt old-f :new-sorc new-tcc
|
||||
:new-trgt new-bcc)
|
||||
:g (dstr-change-sorc-trgt old-g :new-sorc new-bcc
|
||||
:new-trgt new-tcc)
|
||||
:h (dstr-change-sorc-trgt old-h :new-sorc new-tcc
|
||||
:new-trgt new-tcc)
|
||||
:orgn `(easy-perturbation-lemma ,reduction
|
||||
,bottom-perturbation))
|
||||
top-perturbation))))))
|
||||
(declare (type morphism top-perturbation))
|
||||
(let ((new-bcc (add old-bcc bottom-perturbation))
|
||||
(new-tcc (add old-tcc top-perturbation)))
|
||||
(declare (type chain-complex new-bcc new-tcc))
|
||||
(values
|
||||
(build-rdct
|
||||
:f (dstr-change-sorc-trgt old-f :new-sorc new-tcc
|
||||
:new-trgt new-bcc)
|
||||
:g (dstr-change-sorc-trgt old-g :new-sorc new-bcc
|
||||
:new-trgt new-tcc)
|
||||
:h (dstr-change-sorc-trgt old-h :new-sorc new-tcc
|
||||
:new-trgt new-tcc)
|
||||
:orgn `(easy-perturbation-lemma ,reduction
|
||||
,bottom-perturbation))
|
||||
top-perturbation))))))
|
||||
|
||||
(DEFUN SPECIAL-BPL (reduction top-perturbation)
|
||||
(declare
|
||||
@ -449,28 +451,28 @@ coherent, the result of each mapping is a null combination.
|
||||
(return-from special-bpl reduction))
|
||||
(the reduction
|
||||
(with-slots ((old-tcc tcc) (old-bcc bcc)
|
||||
(old-f f) (old-g g) (old-h h)) reduction
|
||||
(old-f f) (old-g g) (old-h h)) reduction
|
||||
(declare
|
||||
(type chain-complex old-tcc old-bcc)
|
||||
(type morphism old-f old-g old-h))
|
||||
(type chain-complex old-tcc old-bcc)
|
||||
(type morphism old-f old-g old-h))
|
||||
(let* ((sigma (bpl-*-sigma old-h top-perturbation))
|
||||
(new-f (cmps old-f
|
||||
(sbtr (idnt-mrph old-tcc)
|
||||
(i-cmps
|
||||
top-perturbation
|
||||
sigma
|
||||
old-h))))
|
||||
(sbtr (idnt-mrph old-tcc)
|
||||
(i-cmps
|
||||
top-perturbation
|
||||
sigma
|
||||
old-h))))
|
||||
(new-h (cmps sigma old-h))
|
||||
(new-tcc (add old-tcc top-perturbation)))
|
||||
(declare
|
||||
(type chain-complex new-tcc)
|
||||
(type morphism sigma new-f new-h))
|
||||
(setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc)
|
||||
old-g (dstr-change-sorc-trgt old-g :new-trgt new-tcc)
|
||||
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
|
||||
:new-trgt new-tcc))
|
||||
(build-rdct :f new-f :g old-g :h new-h
|
||||
:orgn `(special-bpl ,reduction ,top-perturbation))))))
|
||||
(declare
|
||||
(type chain-complex new-tcc)
|
||||
(type morphism sigma new-f new-h))
|
||||
(setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc)
|
||||
old-g (dstr-change-sorc-trgt old-g :new-trgt new-tcc)
|
||||
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
|
||||
:new-trgt new-tcc))
|
||||
(build-rdct :f new-f :g old-g :h new-h
|
||||
:orgn `(special-bpl ,reduction ,top-perturbation))))))
|
||||
|
||||
(DEFUN SPECIAL-BPL-2 (reduction top-perturbation)
|
||||
(declare
|
||||
@ -478,69 +480,69 @@ coherent, the result of each mapping is a null combination.
|
||||
(type morphism top-perturbation))
|
||||
(the reduction
|
||||
(with-slots ((old-tcc tcc) (old-bcc bcc)
|
||||
(old-f f) (old-g g) (old-h h)) reduction
|
||||
(old-f f) (old-g g) (old-h h)) reduction
|
||||
(declare
|
||||
(type chain-complex old-tcc old-bcc)
|
||||
(type morphism old-f old-g old-h))
|
||||
(type chain-complex old-tcc old-bcc)
|
||||
(type morphism old-f old-g old-h))
|
||||
(when (eq (first (orgn top-perturbation)) 'zero-mrph)
|
||||
(return-from special-bpl-2
|
||||
(values reduction (zero-mrph old-bcc))))
|
||||
(return-from special-bpl-2
|
||||
(values reduction (zero-mrph old-bcc))))
|
||||
(when (eq (first (orgn (h reduction))) 'zero-mrph)
|
||||
(return-from special-bpl-2
|
||||
(values
|
||||
(trivial-rdct (add old-tcc top-perturbation))
|
||||
(i-cmps old-f top-perturbation old-g))))
|
||||
(return-from special-bpl-2
|
||||
(values
|
||||
(trivial-rdct (add old-tcc top-perturbation))
|
||||
(i-cmps old-f top-perturbation old-g))))
|
||||
(let* ((sigma (bpl-*-sigma old-h top-perturbation))
|
||||
(new-g (cmps sigma old-g))
|
||||
(new-h (cmps sigma old-h))
|
||||
(new-tcc (add old-tcc top-perturbation)))
|
||||
(declare
|
||||
(type chain-complex new-tcc)
|
||||
(type morphism sigma new-g new-h))
|
||||
(setf old-f (dstr-change-sorc-trgt old-f :new-sorc new-tcc)
|
||||
new-g (dstr-change-sorc-trgt new-g :new-trgt new-tcc)
|
||||
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
|
||||
:new-trgt new-tcc))
|
||||
(values
|
||||
(build-rdct :f old-f :g new-g :h new-h
|
||||
:orgn `(special-bpl-2 ,reduction ,top-perturbation)))))))
|
||||
(declare
|
||||
(type chain-complex new-tcc)
|
||||
(type morphism sigma new-g new-h))
|
||||
(setf old-f (dstr-change-sorc-trgt old-f :new-sorc new-tcc)
|
||||
new-g (dstr-change-sorc-trgt new-g :new-trgt new-tcc)
|
||||
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
|
||||
:new-trgt new-tcc))
|
||||
(values
|
||||
(build-rdct :f old-f :g new-g :h new-h
|
||||
:orgn `(special-bpl-2 ,reduction ,top-perturbation)))))))
|
||||
|
||||
(DEFUN BPL-*-sigma (homotopy perturbation)
|
||||
(declare (type morphism homotopy perturbation))
|
||||
(the morphism
|
||||
(let ((cmpr (cmpr (sorc perturbation)))
|
||||
(h-delta (cmps homotopy perturbation)))
|
||||
(h-delta (cmps homotopy perturbation)))
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type morphism h-delta))
|
||||
(type cmprf cmpr)
|
||||
(type morphism h-delta))
|
||||
(flet
|
||||
((sigma-* (degr gnrt)
|
||||
((sigma-* (degr gnrt)
|
||||
(declare
|
||||
(fixnum degr)
|
||||
(type gnrt gnrt))
|
||||
(fixnum degr)
|
||||
(type gnrt gnrt))
|
||||
(do ((rslt (zero-cmbn degr) (2cmbn-add cmpr rslt iterated))
|
||||
(iterated (term-cmbn degr 1 gnrt)
|
||||
(cmbn-opps (cmbn-? h-delta iterated))))
|
||||
(cmbn-opps (cmbn-? h-delta iterated))))
|
||||
((cmbn-zero-p iterated) rslt)
|
||||
(declare (type cmbn rslt iterated)))))
|
||||
(build-mrph
|
||||
:sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0
|
||||
:intr #'sigma-*
|
||||
:strt :gnrt
|
||||
:orgn `(bpl-*-sigma ,homotopy ,perturbation))))))
|
||||
(declare (type cmbn rslt iterated)))))
|
||||
(build-mrph
|
||||
:sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0
|
||||
:intr #'sigma-*
|
||||
:strt :gnrt
|
||||
:orgn `(bpl-*-sigma ,homotopy ,perturbation))))))
|
||||
|
||||
(DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism)
|
||||
&optional dummy)
|
||||
&optional dummy)
|
||||
(declare (ignore dummy))
|
||||
(the homotopy-equivalence
|
||||
(with-slots (lrdct rrdct) hmeq
|
||||
(declare (type reduction lrdct rrdct))
|
||||
(multiple-value-bind (new-lrdct top-perturbation)
|
||||
(add lrdct lb-perturbation)
|
||||
(declare
|
||||
(type reduction new-lrdct)
|
||||
(type morphism lb-perturbation))
|
||||
(build-hmeq
|
||||
:lrdct new-lrdct
|
||||
:rrdct (add rrdct top-perturbation)
|
||||
:orgn `(add ,hmeq ,lb-perturbation))))))
|
||||
(add lrdct lb-perturbation)
|
||||
(declare
|
||||
(type reduction new-lrdct)
|
||||
(type morphism lb-perturbation))
|
||||
(build-hmeq
|
||||
:lrdct new-lrdct
|
||||
:rrdct (add rrdct top-perturbation)
|
||||
:orgn `(add ,hmeq ,lb-perturbation))))))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user