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

Addressed issue #73.

Browse Source
This commit is contained in:
Gerd Heber 2015-11-11 19:12:25 -06:00
parent 1e09c2e8cc
commit bcb4a8539d
3 changed files with 461 additions and 450 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

488
src/chain-complexes.lisp
View File

@ -31,13 +31,13 @@ Args: ()
Return the number of user created objects by object type. Return the number of user created objects by object type.
------------------------------------------------------------------------------" ------------------------------------------------------------------------------"
(mapc #'(lambda (symbol) (mapc #'(lambda (symbol)
(declare (type (or string symbol) symbol)) (declare (type (or string symbol) symbol))
(let ((length (length (eval symbol)))) (let ((length (length (eval symbol))))
(declare (fixnum length)) (declare (fixnum length))
(setf symbol (symbol-name symbol)) (setf symbol (symbol-name symbol))
(setf symbol (subseq symbol 1 (- (length symbol) 6))) (setf symbol (subseq symbol 1 (- (length symbol) 6)))
(format t "~%~6D ~As" length symbol))) (format t "~%~6D ~As" length symbol)))
*list-list*) *list-list*)
(done)) (done))
@ -48,12 +48,12 @@ Args: ()
Return a string representation of a user created objects. Return a string representation of a user created objects.
------------------------------------------------------------------------------" ------------------------------------------------------------------------------"
(let ((object-list (let ((object-list
(sort (delete-duplicates (sort (delete-duplicates
(mapcan #'(lambda (symbol) (mapcan #'(lambda (symbol)
(copy-list (eval symbol))) (copy-list (eval symbol)))
*list-list*) *list-list*)
:test #'eq) :test #'eq)
#'< :key #'idnm))) #'< :key #'idnm)))
(declare (list object-list)) (declare (list object-list))
(dolist (item object-list) (dolist (item object-list)
(format t "~%~A = ~A" item (orgn item)))) (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*) (dolist (list *list-list*)
(let ((found (find idnm (eval list) :key #'idnm))) (let ((found (find idnm (eval list) :key #'idnm)))
(when found (when found
(format t "~%Object: ~A (format t "~%Object: ~A
~3TOrigin: ~A~2%" found (orgn found)) ~3TOrigin: ~A~2%" found (orgn found))
(return-from kd (values)))))) (return-from kd (values))))))
(DEFUN K (idnm) (DEFUN K (idnm)
@ -86,7 +86,7 @@ Returns the IDNM-th Kenzo object.
(dolist (list *list-list*) (dolist (list *list-list*)
(let ((found (find idnm (eval list) :key #'idnm))) (let ((found (find idnm (eval list) :key #'idnm)))
(when found (when found
(return-from k found))))) (return-from k found)))))
(DEFUN KD2 (idnm) (DEFUN KD2 (idnm)
@ -104,16 +104,16 @@ the list of object numbers.
(return-from kd2 nil)) (return-from kd2 nil))
(setf k-list (list k-list)) (setf k-list (list k-list))
(do ((idnm (1- idnm) (1- idnm))) (do ((idnm (1- idnm) (1- idnm)))
((zerop idnm)) ((zerop idnm))
(declare (fixnum idnm)) (declare (fixnum idnm))
(let ((found (find-if (let ((found (find-if
#'(lambda (item) #'(lambda (item)
(declare (type (or chain-complex morphism) item)) (declare (type (or chain-complex morphism) item))
(member (k idnm) (orgn item))) (member (k idnm) (orgn item)))
k-list))) k-list)))
(declare (type (or null chain-complex morphism) found)) (declare (type (or null chain-complex morphism) found))
(when found (when found
(push (k idnm) k-list)))) (push (k idnm) k-list))))
(mapc #'kd (nreverse (mapcar #'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) (DEFMETHOD PRINT-OBJECT ((chcm chain-complex) stream)
(the chain-complex (the chain-complex
(progn (progn
(format stream "[K~D Chain-Complex]" (idnm chcm)) (format stream "[K~D Chain-Complex]" (idnm chcm))
chcm))) chcm)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -149,8 +149,8 @@ identifier IDNUM or NIL, if it doesn't exist.
~3TVALUE-> ~A ~3TVALUE-> ~A
~4TCLNM-> ~6D ~4TCLNM-> ~6D
~4TRNTM-> ~11,3F" ~4TRNTM-> ~11,3F"
(result-gnrt result) (result-value result) (result-gnrt result) (result-value result)
(result-clnm result) (result-rntm result)) (result-clnm result) (result-rntm result))
result) result)
@ -193,12 +193,12 @@ identifier IDNUM or NIL, if it doesn't exist.
(DEFMETHOD PRINT-OBJECT ((mrph morphism) stream) (DEFMETHOD PRINT-OBJECT ((mrph morphism) stream)
(the morphism (the morphism
(progn (progn
(if (eq (first (orgn (trgt mrph))) 'z-chcm) (if (eq (first (orgn (trgt mrph))) 'z-chcm)
(format stream "[K~D Cohomology-Class on K~D of degree ~D]" (format stream "[K~D Cohomology-Class on K~D of degree ~D]"
(idnm mrph) (idnm (sorc mrph)) (- (degr mrph))) (idnm mrph) (idnm (sorc mrph)) (- (degr mrph)))
(format stream "[K~D Morphism (degree ~D): K~D -> K~D]" (format stream "[K~D Morphism (degree ~D): K~D -> K~D]"
(idnm mrph) (degr mrph) (idnm mrph) (degr mrph)
(idnm (sorc mrph)) (idnm (trgt mrph)))) (idnm (sorc mrph)) (idnm (trgt mrph))))
mrph))) mrph)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -239,10 +239,12 @@ follows:
of the differential homomorphism, either by generator or by of the differential homomorphism, either by generator or by
combination. The default is :GNRT combination. The default is :GNRT
:ORGN ORGN, a list containing a relevant and carefully chosen comment about :ORGN ORGN, a list which is the copy of a Lisp statement, in principle the
the origin of the chain complex. This comment should be unique statement which was at the origin of the creation of this Kenzo
for a Kenzo session (between calls of CAT-INIT), as it is used object. A caching process, using this slot, prevents the creation
for caching purposes. 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 Use this function instead of creating instances via the standard constructor
MAKE-INSTANCE. MAKE-INSTANCE.
@ -250,25 +252,25 @@ MAKE-INSTANCE.
(the chain-complex (the chain-complex
(progn (progn
(let ((already (find orgn *chcm-list* :test #'equal :key #'orgn))) (let ((already (find orgn *chcm-list* :test #'equal :key #'orgn)))
(declare (type (or chain-complex null) already)) (declare (type (or chain-complex null) already))
(when already (when already
(return-from build-chcm already))) (return-from build-chcm already)))
(unless basis (unless basis
(setf basis :locally-effective)) (setf basis :locally-effective))
(let ((chcm (make-instance 'chain-complex (let ((chcm (make-instance 'chain-complex
:cmpr cmpr :cmpr cmpr
:basis basis :basis basis
:bsgn bsgn :bsgn bsgn
:orgn orgn))) :orgn orgn)))
(declare (type chain-complex chcm)) (declare (type chain-complex chcm))
(setf (slot-value chcm 'dffr) (setf (slot-value chcm 'dffr)
(build-mrph (build-mrph
:sorc chcm :trgt chcm :degr -1 :sorc chcm :trgt chcm :degr -1
:intr intr-dffr :strt strt :intr intr-dffr :strt strt
:orgn `(dffr ,chcm))) :orgn `(dffr ,chcm)))
(setf (slot-value chcm 'grmd) chcm) (setf (slot-value chcm 'grmd) chcm)
(push chcm *chcm-list*) (push chcm *chcm-list*)
chcm)))) chcm))))
(DEFUN BASIS2 (object n) ;;; (DEFUN BASIS2 (object n) ;;;
@ -279,7 +281,7 @@ MAKE-INSTANCE.
(with-slots (basis) object (with-slots (basis) object
(declare (type basis basis)) (declare (type basis basis))
(when (eq :locally-effective 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)))) (funcall basis n))))
@ -308,10 +310,12 @@ follows:
of the differential homomorphism, either by generator or by of the differential homomorphism, either by generator or by
combination. The default is :GNRT combination. The default is :GNRT
:ORGN ORGN, a list containing a relevant and carefully chosen comment about :ORGN ORGN, a list which is the copy of a Lisp statement, in principle the
the origin of the chain complex. This comment should be unique statement which was at the origin of the creation of this Kenzo
for a Kenzo session (between calls of CAT-INIT), as it is used object. A caching process, using this slot, prevents the creation
for caching purposes. 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 Use this function instead of creating instances via the standard constructor
MAKE-INSTANCE. MAKE-INSTANCE.
@ -319,63 +323,63 @@ MAKE-INSTANCE.
(the morphism (the morphism
(progn (progn
(let ((already (find orgn *mrph-list* :test #'equal :key #'orgn))) (let ((already (find orgn *mrph-list* :test #'equal :key #'orgn)))
(declare (type (or morphism null) already)) (declare (type (or morphism null) already))
(when already (when already
(return-from build-mrph already))) (return-from build-mrph already)))
(let ((mrph (make-instance 'morphism (let ((mrph (make-instance 'morphism
:sorc sorc :trgt trgt :degr degr :sorc sorc :trgt trgt :degr degr
:intr intr :strt strt :intr intr :strt strt
:orgn orgn))) :orgn orgn)))
(declare (type morphism mrph)) (declare (type morphism mrph))
(setf (slot-value mrph 'rslts) (setf (slot-value mrph 'rslts)
(ecase strt (ecase strt
(:gnrt (map 'simple-vector (:gnrt (map 'simple-vector
;; (vector (vector result)) ;; (vector (vector result))
#'(lambda (dummy) #'(lambda (dummy)
(declare (ignore dummy)) (declare (ignore dummy))
(make-array 0 (make-array 0
:adjustable t :adjustable t
:fill-pointer 0)) :fill-pointer 0))
(make-list +maximal-dimension+))) (make-list +maximal-dimension+)))
(:cmbn (make-array 0)))) (:cmbn (make-array 0))))
(push mrph *mrph-list*) (push mrph *mrph-list*)
mrph)))) mrph))))
;;; FUNCTIONS ;;; FUNCTIONS
(DEFUN NRESULTS () (DEFUN NRESULTS ()
(the fixnum (the fixnum
(let ((nrslts 0)) (let ((nrslts 0))
(declare (fixnum nrslts)) (declare (fixnum nrslts))
(dolist (item *mrph-list*) (dolist (item *mrph-list*)
(declare (type morphism item)) (declare (type morphism item))
(when (eq :gnrt (strt item)) (when (eq :gnrt (strt item))
(map nil (map nil
#'(lambda (drslt) #'(lambda (drslt)
(declare (vector drslt)) (declare (vector drslt))
(incf nrslts (length drslt))) (incf nrslts (length drslt)))
(rslts item)))) (rslts item))))
nrslts))) nrslts)))
(DEFUN TIME-LIST () (DEFUN TIME-LIST ()
(the list (the list
(let ((time-list +empty-list+)) (let ((time-list +empty-list+))
(declare (list time-list)) (declare (list time-list))
(dolist (item *mrph-list*) (dolist (item *mrph-list*)
(declare (type morphism item)) (declare (type morphism item))
(when (eq :gnrt (strt item)) (when (eq :gnrt (strt item))
(map nil #'(lambda (drslt) (map nil #'(lambda (drslt)
(declare (vector drslt)) (declare (vector drslt))
(map nil #'(lambda (rslt) (map nil #'(lambda (rslt)
(declare (type result rslt)) (declare (type result rslt))
(let ((rntm (result-rntm rslt))) (let ((rntm (result-rntm rslt)))
(declare (single-float rntm)) (declare (single-float rntm))
(when (plusp rntm) (when (plusp rntm)
(push rntm time-list)))) (push rntm time-list))))
drslt)) drslt))
(rslts item)))) (rslts item))))
(sort time-list #'>)))) (sort time-list #'>))))
(DEFUN CLEAN-RESULTS (&optional (results-coef *results-coef*)) (DEFUN CLEAN-RESULTS (&optional (results-coef *results-coef*))
@ -384,35 +388,35 @@ MAKE-INSTANCE.
(special *results-coef* *results-cmlt-tm* *results-n* *results-verbose*)) (special *results-coef* *results-cmlt-tm* *results-n* *results-verbose*))
(the (values ) (the (values )
(let ((cut (* results-coef (/ *results-cmlt-tm* *results-n*)))) (let ((cut (* results-coef (/ *results-cmlt-tm* *results-n*))))
(declare (single-float cut)) (declare (single-float cut))
(setf *results-n* 0 *results-cmlt-tm* 0.0) (setf *results-n* 0 *results-cmlt-tm* 0.0)
(dolist (item *mrph-list*) (dolist (item *mrph-list*)
(declare (type morphism item)) (declare (type morphism item))
(when (eq :gnrt (strt item)) (when (eq :gnrt (strt item))
(let ((rslts (rslts item))) (let ((rslts (rslts item)))
(declare (vector rslts)) (declare (vector rslts))
(dotimes (i +maximal-dimension+) (dotimes (i +maximal-dimension+)
(declare (fixnum i)) (declare (fixnum i))
(let ((rslts-i (aref rslts i)) (let ((rslts-i (aref rslts i))
(output (make-array 0 :adjustable t :fill-pointer 0))) (output (make-array 0 :adjustable t :fill-pointer 0)))
(declare (vector rslts-i output)) (declare (vector rslts-i output))
(map nil (map nil
#'(lambda (rslt) #'(lambda (rslt)
(declare (type result rslt)) (declare (type result rslt))
(let ((rntm (result-rntm rslt))) (let ((rntm (result-rntm rslt)))
(declare (single-float rntm)) (declare (single-float rntm))
(when (> rntm cut) (when (> rntm cut)
(incf *results-n*) (incf *results-n*)
(incf *results-cmlt-tm* rntm) (incf *results-cmlt-tm* rntm)
(vector-push-extend rslt output)))) (vector-push-extend rslt output))))
rslts-i) rslts-i)
(setf (aref rslts i) output)))))) (setf (aref rslts i) output))))))
(when *results-verbose* (when *results-verbose*
(format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*))))) (format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*)))))
(DEFUN MRPH-GNRT (cmpr2 intr degr gnrt memory (DEFUN MRPH-GNRT (cmpr2 intr degr gnrt memory
&optional (left -1) (right (fill-pointer memory))) &optional (left -1) (right (fill-pointer memory)))
(declare (declare
(type intr-mrph intr) (type intr-mrph intr)
;; (function (fixnum gnrt) cmbn) ;; (function (fixnum gnrt) cmbn)
@ -427,47 +431,47 @@ MAKE-INSTANCE.
;; 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 :clnm 1 :gnrt gnrt :value value :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)) (declare (fixnum middle))
(ecase (funcall cmpr2 gnrt (result-gnrt (aref memory middle))) (ecase (funcall cmpr2 gnrt (result-gnrt (aref memory middle)))
(:equal (let ((rslt (aref memory middle))) (:equal (let ((rslt (aref memory middle)))
(declare (type result 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))))))) (:greater (setf left middle)))))))
@ -481,17 +485,17 @@ MAKE-INSTANCE.
;; (vector result) ;; (vector result)
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((n-cmbn-list +empty-list+)) (let ((n-cmbn-list +empty-list+))
(declare (list n-cmbn-list)) (declare (list n-cmbn-list))
(do ((mark list (cdr mark)) (do ((mark list (cdr mark))
(left -1)) (left -1))
((endp mark)) ((endp mark))
(declare (list mark)) (declare (list mark))
(multiple-value-bind (rslt new-left) (multiple-value-bind (rslt new-left)
(mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left) (mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left)
(setf left new-left) (setf left new-left)
(push (cons (-cffc mark) rslt) n-cmbn-list))) (push (cons (-cffc mark) rslt) n-cmbn-list)))
(cmbn-cmbn tcmpr2 n-cmbn-list))))) (cmbn-cmbn tcmpr2 n-cmbn-list)))))
(DEFUN DO-CONTROL (cmpr cmbn) (DEFUN DO-CONTROL (cmpr cmbn)
(declare (declare
@ -501,14 +505,14 @@ MAKE-INSTANCE.
(let ((list (cmbn-list cmbn))) (let ((list (cmbn-list cmbn)))
(declare (list list)) (declare (list list))
(do ((mark1 (rest list) (cdr mark1)) (do ((mark1 (rest list) (cdr mark1))
(mark2 list mark1)) (mark2 list mark1))
((endp mark1)) ((endp mark1))
(declare (list mark1 mark2)) (declare (list mark1 mark2))
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1))) (unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
(setf *wrong-cmbn* cmbn) (setf *wrong-cmbn* cmbn)
(error "In the combination located by *WRONG-CMBN*, the generators:~@ (error "In the combination located by *WRONG-CMBN*, the generators:~@
~A and ~A are in a wrong order." (cdar mark2) ~A and ~A are in a wrong order." (cdar mark2)
(cdar mark1)))))) (cdar mark1))))))
cmbn) cmbn)
#| #|
@ -517,9 +521,9 @@ MAKE-INSTANCE.
(DEFUN PROFILER-INIT () (DEFUN PROFILER-INIT ()
(mapc #'(lambda (mrph) (mapc #'(lambda (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(setf (wrtm mrph) 0)) (setf (wrtm mrph) 0))
*mrph-list*)) *mrph-list*))
(DEFUN PROFILER-ON () (DEFUN PROFILER-ON ()
(push (get-internal-run-time) *profiler-stack*)) (push (get-internal-run-time) *profiler-stack*))
@ -527,12 +531,12 @@ MAKE-INSTANCE.
(DEFUN PROFILER-OFF (mrph) (DEFUN PROFILER-OFF (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(let ((time-spent (let ((time-spent
(- (get-internal-run-time) (pop *profiler-stack*)))) (- (get-internal-run-time) (pop *profiler-stack*))))
(declare (integer time-spent)) (declare (integer time-spent))
(mapl #'(lambda (mark) (mapl #'(lambda (mark)
(declare (cons mark)) (declare (cons mark))
(incf (car mark) time-spent)) (incf (car mark) time-spent))
*profiler-stack*) *profiler-stack*)
(incf (wrtm mrph) time-spent))) (incf (wrtm mrph) time-spent)))
|# |#
@ -544,35 +548,35 @@ MAKE-INSTANCE.
(type gnrt gnrt)) (type gnrt gnrt))
(the cmbn (the cmbn
(progn (progn
;; (profiler-on) ;; (profiler-on)
(when (and *future-display* (when (and *future-display*
(> (get-internal-run-time) *future-display*)) (> (get-internal-run-time) *future-display*))
(format t "~%GNRT-? (format t "~%GNRT-?
~3T~A ORGN = ~A ~3T~A ORGN = ~A
~3TDEGR = ~D ~3TDEGR = ~D
~3TGNRT = ~A" ~3TGNRT = ~A"
mrph (orgn mrph) degr gnrt) mrph (orgn mrph) degr gnrt)
(setf *future-display* (+ (get-internal-run-time) *time-interval*))) (setf *future-display* (+ (get-internal-run-time) *time-interval*)))
(with-slots (sorc (mdegr degr) intr strt ?-clnm) mrph (with-slots (sorc (mdegr degr) intr strt ?-clnm) mrph
(declare (declare
(type chain-complex sorc) (type chain-complex sorc)
(fixnum mdegr ?-clnm) (fixnum mdegr ?-clnm)
(type intr-mrph intr) (type intr-mrph intr)
(type strt strt)) (type strt strt))
(with-slots ((scmpr cmpr)) sorc (with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr)) (declare (type cmprf scmpr))
(control (slot-value (slot-value mrph 'trgt) 'cmpr) (control (slot-value (slot-value mrph 'trgt) 'cmpr)
(progn (progn
(incf ?-clnm) (incf ?-clnm)
(prog1 (prog1
(ecase strt (ecase strt
(:gnrt (:gnrt
(mrph-gnrt scmpr intr (mrph-gnrt scmpr intr
degr gnrt (svref (rslts mrph) degr))) degr gnrt (svref (rslts mrph) degr)))
(:cmbn (:cmbn
(funcall intr (term-cmbn degr 1 gnrt)))) (funcall intr (term-cmbn degr 1 gnrt))))
;; (profiler-off mrph) ;; (profiler-off mrph)
)))))))) ))))))))
(DEFUN CMBN-? (mrph cmbn) (DEFUN CMBN-? (mrph cmbn)
@ -581,35 +585,35 @@ MAKE-INSTANCE.
(type cmbn cmbn)) (type cmbn cmbn))
(the cmbn (the cmbn
(progn (progn
;; (profiler-on) ;; (profiler-on)
(when (and *future-display* (when (and *future-display*
(> (get-internal-run-time) *future-display*)) (> (get-internal-run-time) *future-display*))
(format t "~%CMBN-? (format t "~%CMBN-?
~3T~A ORGN = ~A ~3T~A ORGN = ~A
~3TCMBN = ~A" ~3TCMBN = ~A"
mrph (orgn mrph) cmbn) mrph (orgn mrph) cmbn)
(setf *future-display* (+ (get-internal-run-time) *time-interval*))) (setf *future-display* (+ (get-internal-run-time) *time-interval*)))
(with-slots (sorc trgt degr intr strt ???-clnm) mrph (with-slots (sorc trgt degr intr strt ???-clnm) mrph
(declare (declare
(type chain-complex sorc trgt) (type chain-complex sorc trgt)
(fixnum degr ???-clnm) (fixnum degr ???-clnm)
(type intr-mrph intr) (type intr-mrph intr)
(type strt strt)) (type strt strt))
(with-slots ((scmpr cmpr)) sorc (with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr)) (declare (type cmprf scmpr))
(with-slots ((tcmpr cmpr)) trgt (with-slots ((tcmpr cmpr)) trgt
(declare (type cmprf tcmpr)) (declare (type cmprf tcmpr))
(control tcmpr (control tcmpr
(progn (progn
(controln scmpr cmbn) (controln scmpr cmbn)
(incf ???-clnm) (incf ???-clnm)
(when (eq strt :cmbn) (when (eq strt :cmbn)
(return-from cmbn-? (funcall intr cmbn))) (return-from cmbn-? (funcall intr cmbn)))
(prog1 (prog1
(if (cmbn-zero-p cmbn) (if (cmbn-zero-p cmbn)
(zero-cmbn (+ (cmbn-degr cmbn) degr)) (zero-cmbn (+ (cmbn-degr cmbn) degr))
(mrph-cmbn scmpr tcmpr intr (mrph-cmbn scmpr tcmpr intr
cmbn (svref (rslts mrph) cmbn (svref (rslts mrph)
(cmbn-degr cmbn)))) (cmbn-degr cmbn))))
;; (profiler-off mrph) ;; (profiler-off mrph)
))))))))) )))))))))

27
src/classes.lisp
View File

@ -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 7. IDNM, an integer, a system generated identifier for this object. Its reader
function is IDNM. function is IDNM.
8. ORGN, a list containg a comment indicating the origin of the object. The 8. ORGN, a list which is the copy of a Lisp statement, in principle the
should be unique (per session), since it is used in the implementation for statement which was at the origin of the creation of this Kenzo object.
caching purposes. Its reader function is ORGN. 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 9. IDNM, an integer, a system-generated identifier for this object. Its reader
function is IDNM. function is IDNM.
10. ORGN, a list containg a comment indicating the origin of the object. The 10. ORGN, a list which is the copy of a Lisp statement, in principle the
should be unique (per session), since it is used in the implementation for statement which was at the origin of the creation of this Kenzo object.
caching purposes. Its reader function is ORGN. 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. 5. H, an object of type MORPHISM representing the morphism of graded modules h.
Its reader function is H1. 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. function is IDNM.
10. ORGN, a list containg a comment indicating the origin of the object. 7. ORGN, a list which is the copy of a Lisp statement, in principle the
This comment should be unique for a Kenzo session (between calls of statement which was at the origin of the creation of this Kenzo object.
CAT-INIT), as it is used for caching purposes. Its reader function A caching process, using this slot, prevents the creation of multiple
is ORGN. copies of the same mathematical object, which is important for efficiency.
It is used also for debugging and analyzing the program.
-----------------------------------------------------------------------------")) -----------------------------------------------------------------------------"))

396
src/effective-homology.lisp
View File

@ -16,9 +16,9 @@
(DEFMETHOD PRINT-OBJECT ((rdct reduction) stream) (DEFMETHOD PRINT-OBJECT ((rdct reduction) stream)
(the reduction (the reduction
(progn (progn
(format stream "[K~D Reduction K~D => K~D]" (format stream "[K~D Reduction K~D => K~D]"
(idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct))) (idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct)))
rdct))) rdct)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (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 :H H, an object of type MORPHISM representing the morphism of graded modules h
of a reduction of a reduction
:ORGN ORGN, a list containing a relevant and carefully chosen comment about :ORGN ORGN, a list which is the copy of a Lisp statement, in principle the
the origin of the chain complex. This comment should be unique statement which was at the origin of the creation of this Kenzo
for a Kenzo session (between calls of CAT-INIT), as it is used object. A caching process, using this slot, prevents the creation
for caching purposes. 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 Use this function instead of creating instances via the standard constructor
MAKE-INSTANCE. MAKE-INSTANCE.
@ -65,38 +67,38 @@ MAKE-INSTANCE.
(the reduction (the reduction
(progn (progn
(unless orgn (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))) (let ((already (find orgn *rdct-list* :test #'equal :key #'orgn)))
(declare (type (or reduction null) already)) (declare (type (or reduction null) already))
(when already (when already
(return-from build-rdct already))) (return-from build-rdct already)))
(with-slots ((fsorc sorc) (ftrgt trgt) (fdegr degr)) f (with-slots ((fsorc sorc) (ftrgt trgt) (fdegr degr)) f
(declare (declare
(type chain-complex fsorc ftrgt) (type chain-complex fsorc ftrgt)
(fixnum fdegr)) (fixnum fdegr))
(with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g (with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g
(declare (declare
(type chain-complex gsorc gtrgt) (type chain-complex gsorc gtrgt)
(fixnum gdegr)) (fixnum gdegr))
(with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h (with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h
(declare (declare
(type chain-complex hsorc htrgt) (type chain-complex hsorc htrgt)
(fixnum hdegr)) (fixnum hdegr))
(unless (and (eq gsorc ftrgt) (unless (and (eq gsorc ftrgt)
(eq fsorc gtrgt) (eq fsorc gtrgt)
(eq hsorc fsorc) (eq hsorc fsorc)
(eq htrgt fsorc) (eq htrgt fsorc)
(zerop fdegr) (zerop fdegr)
(zerop gdegr) (zerop gdegr)
(= +1 hdegr)) (= +1 hdegr))
(error "In BUILD-RDCT, the data are non coherent.")) (error "In BUILD-RDCT, the data are non coherent."))
(let ((rdct (make-instance 'reduction (let ((rdct (make-instance 'reduction
:tcc fsorc :bcc ftrgt :tcc fsorc :bcc ftrgt
:f f :g g :h h :f f :g g :h h
:orgn orgn))) :orgn orgn)))
(declare (type reduction rdct)) (declare (type reduction rdct))
(push rdct *rdct-list*) (push rdct *rdct-list*)
rdct))))))) rdct)))))))
(DEFUN TRIVIAL-RDCT (chcm) (DEFUN TRIVIAL-RDCT (chcm)
@ -142,27 +144,27 @@ See also: ZERO-MRPH, IDNT-MRPH.
(the homotopy-equivalence (the homotopy-equivalence
(progn (progn
(with-slots ((lf f) (lg g) (lh h) (ltcc tcc) (lbcc bcc)) lrdct (with-slots ((lf f) (lg g) (lh h) (ltcc tcc) (lbcc bcc)) lrdct
(declare (declare
(type morphism lf lg lh) (type morphism lf lg lh)
(type chain-complex ltcc lbcc)) (type chain-complex ltcc lbcc))
(with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct (with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct
(declare (declare
(type morphism rf rg rh) (type morphism rf rg rh)
(type chain-complex rtcc rbcc)) (type chain-complex rtcc rbcc))
(unless (eq ltcc rtcc) (unless (eq ltcc rtcc)
(error "In BUILD-HMEQ (version from rdct), the tcc's are not the same.")) (error "In BUILD-HMEQ (version from rdct), the tcc's are not the same."))
(unless orgn (unless orgn
(setf orgn `(build-hmeq ,lrdct ,rrdct))) (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)) (declare (type (or homotopy-equivalence null) already))
(when already (when already
(return-from build-hmeq already))) (return-from build-hmeq already)))
(let ((hmeq (make-instance 'homotopy-equivalence (let ((hmeq (make-instance 'homotopy-equivalence
:lbcc lbcc :tcc ltcc :rbcc rbcc :lbcc lbcc :tcc ltcc :rbcc rbcc
:lf lf :lg lg :lh lh :lf lf :lg lg :lh lh
:rf rf :rg rg :rh rh :rf rf :rg rg :rh rh
:lrdct lrdct :rrdct rrdct :lrdct lrdct :rrdct rrdct
:orgn orgn))) :orgn orgn)))
(declare (type homotopy-equivalence hmeq)) (declare (type homotopy-equivalence hmeq))
(push hmeq *hmeq-list*) (push hmeq *hmeq-list*)
hmeq)))))) hmeq))))))
@ -173,10 +175,10 @@ See also: ZERO-MRPH, IDNT-MRPH.
(DEFMETHOD PRINT-OBJECT ((hmeq homotopy-equivalence) stream) (DEFMETHOD PRINT-OBJECT ((hmeq homotopy-equivalence) stream)
(the homotopy-equivalence (the homotopy-equivalence
(progn (progn
(format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]" (format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]"
(idnm hmeq) (idnm hmeq)
(idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq))) (idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq)))
hmeq))) hmeq)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -194,16 +196,16 @@ See also: ZERO-MRPH, IDNT-MRPH.
(the homotopy-equivalence (the homotopy-equivalence
(progn (progn
(unless orgn (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))) (let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
(declare (type (or null homotopy-equivalence) already)) (declare (type (or null homotopy-equivalence) already))
(when already (when already
(return-from build-hmeq already))) (return-from build-hmeq already)))
(build-hmeq (build-hmeq
:lrdct (build-rdct :f lf :g lg :h lh :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 :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)))) :orgn orgn))))
(DEFUN TRIVIAL-HMEQ (chcm) (DEFUN TRIVIAL-HMEQ (chcm)
@ -256,21 +258,21 @@ according to these formulas:
(type chain-complex bcc tcc) (type chain-complex bcc tcc)
(type morphism f g h)) (type morphism f g h))
(setf *tdd* (cmps tcc tcc) (setf *tdd* (cmps tcc tcc)
*bdd* (cmps bcc bcc) *bdd* (cmps bcc bcc)
*df-fd* (sbtr *df-fd* (sbtr
(cmps bcc f) (cmps bcc f)
(cmps f tcc)) (cmps f tcc))
*dg-gd* (sbtr *dg-gd* (sbtr
(cmps tcc g) (cmps tcc g)
(cmps g bcc)) (cmps g bcc))
*id-fg* (sbtr (idnt-mrph bcc) (cmps f g)) *id-fg* (sbtr (idnt-mrph bcc) (cmps f g))
*id-gf-dh-hd* (i-sbtr (idnt-mrph tcc) *id-gf-dh-hd* (i-sbtr (idnt-mrph tcc)
(cmps g f) (cmps g f)
(cmps tcc h) (cmps tcc h)
(cmps h tcc)) (cmps h tcc))
*hh* (cmps h h) *hh* (cmps h h)
*fh* (cmps f h) *fh* (cmps f h)
*hg* (cmps h g))) *hg* (cmps h g)))
(done)) (done))
@ -292,13 +294,13 @@ the <Enter> key.
(declare (type symbol cmbn)) (declare (type symbol cmbn))
(format t "~%~A => ~A" cmbn (eval cmbn))) (format t "~%~A => ~A" cmbn (eval cmbn)))
(dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd* (dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd*
*hh* *fh* *hg*)) *hh* *fh* *hg*))
(declare (type symbol phi)) (declare (type symbol phi))
(format t "~%Checking ~A = 0" phi) (format t "~%Checking ~A = 0" phi)
(format t "~%Result: ") (format t "~%Result: ")
(princ (cmbn-? (eval phi) (princ (cmbn-? (eval phi)
(if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*)) (if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
*bc* *tc*))) *bc* *tc*)))
(read-line)) (read-line))
(done)) (done))
@ -317,13 +319,13 @@ coherent, the result of each mapping is a null combination.
(declare (type symbol cmbn)) (declare (type symbol cmbn))
(format t "~%~A => ~A" cmbn (eval cmbn))) (format t "~%~A => ~A" cmbn (eval cmbn)))
(dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd* (dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd*
*hh* *fh* *hg*)) *hh* *fh* *hg*))
(declare (type symbol phi)) (declare (type symbol phi))
(format t "~%Checking ~A = 0" phi) (format t "~%Checking ~A = 0" phi)
(format t "~%Result: ") (format t "~%Result: ")
(princ (cmbn-? (eval phi) (princ (cmbn-? (eval phi)
(if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*)) (if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
*bc* *tc*)))) *bc* *tc*))))
(done)) (done))
@ -366,47 +368,47 @@ coherent, the result of each mapping is a null combination.
(type morphism top-perturbation)) (type morphism top-perturbation))
(the (values reduction morphism) (the (values reduction morphism)
(with-slots ((old-tcc tcc) (old-bcc bcc) (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 (declare
(type chain-complex old-tcc old-bcc) (type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h)) (type morphism old-f old-g old-h))
(when (eq (first (orgn top-perturbation)) 'zero-mrph) (when (eq (first (orgn top-perturbation)) 'zero-mrph)
(return-from basic-perturbation-lemma (return-from basic-perturbation-lemma
(values reduction (zero-mrph old-bcc)))) (values reduction (zero-mrph old-bcc))))
(when (eq (first (orgn (h reduction))) 'zero-mrph) (when (eq (first (orgn (h reduction))) 'zero-mrph)
(return-from basic-perturbation-lemma (return-from basic-perturbation-lemma
(values (values
(trivial-rdct (add old-tcc top-perturbation)) (trivial-rdct (add old-tcc top-perturbation))
(i-cmps old-f top-perturbation old-g)))) (i-cmps old-f top-perturbation old-g))))
(let* ((sigma (bpl-*-sigma old-h top-perturbation)) (let* ((sigma (bpl-*-sigma old-h top-perturbation))
(new-f (cmps old-f (new-f (cmps old-f
(sbtr (idnt-mrph old-tcc) (sbtr (idnt-mrph old-tcc)
(i-cmps (i-cmps
top-perturbation top-perturbation
sigma sigma
old-h)))) old-h))))
(new-g (cmps sigma old-g)) (new-g (cmps sigma old-g))
(new-h (cmps sigma old-h)) (new-h (cmps sigma old-h))
(bottom-perturbation (i-cmps (bottom-perturbation (i-cmps
old-f old-f
top-perturbation top-perturbation
new-g)) new-g))
(new-tcc (add old-tcc top-perturbation)) (new-tcc (add old-tcc top-perturbation))
(new-bcc (add old-bcc bottom-perturbation))) (new-bcc (add old-bcc bottom-perturbation)))
(declare (declare
(type chain-complex new-tcc new-bcc) (type chain-complex new-tcc new-bcc)
(type morphism sigma new-f new-g new-h bottom-perturbation)) (type morphism sigma new-f new-g new-h bottom-perturbation))
(setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc
:new-trgt new-bcc) :new-trgt new-bcc)
new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc
:new-trgt new-tcc) :new-trgt new-tcc)
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
:new-trgt new-tcc)) :new-trgt new-tcc))
(values (values
(build-rdct :f new-f :g new-g :h new-h (build-rdct :f new-f :g new-g :h new-h
:orgn `(basic-perturbation-lemma ,reduction :orgn `(basic-perturbation-lemma ,reduction
,top-perturbation)) ,top-perturbation))
bottom-perturbation))))) bottom-perturbation)))))
(DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation) (DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation)
(declare (declare
@ -414,32 +416,32 @@ coherent, the result of each mapping is a null combination.
(type morphism bottom-perturbation)) (type morphism bottom-perturbation))
(the (values reduction morphism) (the (values reduction morphism)
(with-slots ((old-tcc tcc) (old-bcc bcc) (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 (declare
(type chain-complex old-tcc old-bcc) (type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h)) (type morphism old-f old-g old-h))
(when (eq 'zero-mrph (first (orgn bottom-perturbation))) (when (eq 'zero-mrph (first (orgn bottom-perturbation)))
(return-from easy-perturbation-lemma (return-from easy-perturbation-lemma
(values reduction (zero-mrph old-tcc)))) (values reduction (zero-mrph old-tcc))))
(when (eq 'trivial-rdct (first (orgn reduction))) (when (eq 'trivial-rdct (first (orgn reduction)))
(return-from easy-perturbation-lemma (return-from easy-perturbation-lemma
(trivial-rdct (add (bcc reduction) bottom-perturbation)))) (trivial-rdct (add (bcc reduction) bottom-perturbation))))
(let ((top-perturbation (i-cmps old-g bottom-perturbation old-f))) (let ((top-perturbation (i-cmps old-g bottom-perturbation old-f)))
(declare (type morphism top-perturbation)) (declare (type morphism top-perturbation))
(let ((new-bcc (add old-bcc bottom-perturbation)) (let ((new-bcc (add old-bcc bottom-perturbation))
(new-tcc (add old-tcc top-perturbation))) (new-tcc (add old-tcc top-perturbation)))
(declare (type chain-complex new-bcc new-tcc)) (declare (type chain-complex new-bcc new-tcc))
(values (values
(build-rdct (build-rdct
:f (dstr-change-sorc-trgt old-f :new-sorc new-tcc :f (dstr-change-sorc-trgt old-f :new-sorc new-tcc
:new-trgt new-bcc) :new-trgt new-bcc)
:g (dstr-change-sorc-trgt old-g :new-sorc new-bcc :g (dstr-change-sorc-trgt old-g :new-sorc new-bcc
:new-trgt new-tcc) :new-trgt new-tcc)
:h (dstr-change-sorc-trgt old-h :new-sorc new-tcc :h (dstr-change-sorc-trgt old-h :new-sorc new-tcc
:new-trgt new-tcc) :new-trgt new-tcc)
:orgn `(easy-perturbation-lemma ,reduction :orgn `(easy-perturbation-lemma ,reduction
,bottom-perturbation)) ,bottom-perturbation))
top-perturbation)))))) top-perturbation))))))
(DEFUN SPECIAL-BPL (reduction top-perturbation) (DEFUN SPECIAL-BPL (reduction top-perturbation)
(declare (declare
@ -449,28 +451,28 @@ coherent, the result of each mapping is a null combination.
(return-from special-bpl reduction)) (return-from special-bpl reduction))
(the reduction (the reduction
(with-slots ((old-tcc tcc) (old-bcc bcc) (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 (declare
(type chain-complex old-tcc old-bcc) (type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h)) (type morphism old-f old-g old-h))
(let* ((sigma (bpl-*-sigma old-h top-perturbation)) (let* ((sigma (bpl-*-sigma old-h top-perturbation))
(new-f (cmps old-f (new-f (cmps old-f
(sbtr (idnt-mrph old-tcc) (sbtr (idnt-mrph old-tcc)
(i-cmps (i-cmps
top-perturbation top-perturbation
sigma sigma
old-h)))) old-h))))
(new-h (cmps sigma old-h)) (new-h (cmps sigma old-h))
(new-tcc (add old-tcc top-perturbation))) (new-tcc (add old-tcc top-perturbation)))
(declare (declare
(type chain-complex new-tcc) (type chain-complex new-tcc)
(type morphism sigma new-f new-h)) (type morphism sigma new-f new-h))
(setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc) (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) 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-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
:new-trgt new-tcc)) :new-trgt new-tcc))
(build-rdct :f new-f :g old-g :h new-h (build-rdct :f new-f :g old-g :h new-h
:orgn `(special-bpl ,reduction ,top-perturbation)))))) :orgn `(special-bpl ,reduction ,top-perturbation))))))
(DEFUN SPECIAL-BPL-2 (reduction top-perturbation) (DEFUN SPECIAL-BPL-2 (reduction top-perturbation)
(declare (declare
@ -478,69 +480,69 @@ coherent, the result of each mapping is a null combination.
(type morphism top-perturbation)) (type morphism top-perturbation))
(the reduction (the reduction
(with-slots ((old-tcc tcc) (old-bcc bcc) (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 (declare
(type chain-complex old-tcc old-bcc) (type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h)) (type morphism old-f old-g old-h))
(when (eq (first (orgn top-perturbation)) 'zero-mrph) (when (eq (first (orgn top-perturbation)) 'zero-mrph)
(return-from special-bpl-2 (return-from special-bpl-2
(values reduction (zero-mrph old-bcc)))) (values reduction (zero-mrph old-bcc))))
(when (eq (first (orgn (h reduction))) 'zero-mrph) (when (eq (first (orgn (h reduction))) 'zero-mrph)
(return-from special-bpl-2 (return-from special-bpl-2
(values (values
(trivial-rdct (add old-tcc top-perturbation)) (trivial-rdct (add old-tcc top-perturbation))
(i-cmps old-f top-perturbation old-g)))) (i-cmps old-f top-perturbation old-g))))
(let* ((sigma (bpl-*-sigma old-h top-perturbation)) (let* ((sigma (bpl-*-sigma old-h top-perturbation))
(new-g (cmps sigma old-g)) (new-g (cmps sigma old-g))
(new-h (cmps sigma old-h)) (new-h (cmps sigma old-h))
(new-tcc (add old-tcc top-perturbation))) (new-tcc (add old-tcc top-perturbation)))
(declare (declare
(type chain-complex new-tcc) (type chain-complex new-tcc)
(type morphism sigma new-g new-h)) (type morphism sigma new-g new-h))
(setf old-f (dstr-change-sorc-trgt old-f :new-sorc new-tcc) (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-g (dstr-change-sorc-trgt new-g :new-trgt new-tcc)
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
:new-trgt new-tcc)) :new-trgt new-tcc))
(values (values
(build-rdct :f old-f :g new-g :h new-h (build-rdct :f old-f :g new-g :h new-h
:orgn `(special-bpl-2 ,reduction ,top-perturbation))))))) :orgn `(special-bpl-2 ,reduction ,top-perturbation)))))))
(DEFUN BPL-*-sigma (homotopy perturbation) (DEFUN BPL-*-sigma (homotopy perturbation)
(declare (type morphism homotopy perturbation)) (declare (type morphism homotopy perturbation))
(the morphism (the morphism
(let ((cmpr (cmpr (sorc perturbation))) (let ((cmpr (cmpr (sorc perturbation)))
(h-delta (cmps homotopy perturbation))) (h-delta (cmps homotopy perturbation)))
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type morphism h-delta)) (type morphism h-delta))
(flet (flet
((sigma-* (degr gnrt) ((sigma-* (degr gnrt)
(declare (declare
(fixnum degr) (fixnum degr)
(type gnrt gnrt)) (type gnrt gnrt))
(do ((rslt (zero-cmbn degr) (2cmbn-add cmpr rslt iterated)) (do ((rslt (zero-cmbn degr) (2cmbn-add cmpr rslt iterated))
(iterated (term-cmbn degr 1 gnrt) (iterated (term-cmbn degr 1 gnrt)
(cmbn-opps (cmbn-? h-delta iterated)))) (cmbn-opps (cmbn-? h-delta iterated))))
((cmbn-zero-p iterated) rslt) ((cmbn-zero-p iterated) rslt)
(declare (type cmbn rslt iterated))))) (declare (type cmbn rslt iterated)))))
(build-mrph (build-mrph
:sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0 :sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0
:intr #'sigma-* :intr #'sigma-*
:strt :gnrt :strt :gnrt
:orgn `(bpl-*-sigma ,homotopy ,perturbation)))))) :orgn `(bpl-*-sigma ,homotopy ,perturbation))))))
(DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism) (DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism)
&optional dummy) &optional dummy)
(declare (ignore dummy)) (declare (ignore dummy))
(the homotopy-equivalence (the homotopy-equivalence
(with-slots (lrdct rrdct) hmeq (with-slots (lrdct rrdct) hmeq
(declare (type reduction lrdct rrdct)) (declare (type reduction lrdct rrdct))
(multiple-value-bind (new-lrdct top-perturbation) (multiple-value-bind (new-lrdct top-perturbation)
(add lrdct lb-perturbation) (add lrdct lb-perturbation)
(declare (declare
(type reduction new-lrdct) (type reduction new-lrdct)
(type morphism lb-perturbation)) (type morphism lb-perturbation))
(build-hmeq (build-hmeq
:lrdct new-lrdct :lrdct new-lrdct
:rrdct (add rrdct top-perturbation) :rrdct (add rrdct top-perturbation)
:orgn `(add ,hmeq ,lb-perturbation)))))) :orgn `(add ,hmeq ,lb-perturbation))))))