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

Updated formatting. Moved examples to the test file.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-04 16:50:59 -05:00
parent 71db68240c
commit b6c2f46f4f
1 changed files with 286 additions and 356 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

638
src/effective-homology.lisp
View File

@ -14,66 +14,69 @@
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil)) (setf (ext:package-lock :clos) nil))
(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))
(DEFUN RDCT (n) (DEFUN RDCT (n)
(declare (fixnum n)) (declare (fixnum n))
(the (or null reduction) "Retrieve the N-th user created reduction from the list *RDCT-LIST*.
(find n *rdct-list* :key #'idnm))) Return NIL if it doesn't exist."
(the (or null reduction)
(find n *rdct-list* :key #'idnm)))
(DEFUN BUILD-RDCT (&key f g h orgn) (DEFUN BUILD-RDCT (&key f g h orgn)
(declare (declare
(type morphism f g h) (type morphism f g h)
(list orgn)) (list orgn))
(the reduction "Create a reduction. Use this function instead of the generic MAKE-INSTANCE."
(progn (the reduction
(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)
(declare (type chain-complex chcm)) (declare (type chain-complex chcm))
(build-rdct (build-rdct
:f (idnt-mrph chcm) :f (idnt-mrph chcm)
:g (idnt-mrph chcm) :g (idnt-mrph chcm)
:h (zero-mrph chcm chcm +1) :h (zero-mrph chcm chcm +1)
:orgn `(trivial-rdct ,chcm))) :orgn `(trivial-rdct ,chcm)))
;;; ;;;
;;; HOMOTOPY-EQUIVALENCES ;;; HOMOTOPY-EQUIVALENCES
@ -84,33 +87,33 @@
(:documentation "needed by ECL")) (:documentation "needed by ECL"))
(DEFMETHOD BUILD-HMEQ ((keyword1 (eql :lrdct)) lrdct &key rrdct orgn) (DEFMETHOD BUILD-HMEQ ((keyword1 (eql :lrdct)) lrdct &key rrdct orgn)
(declare (declare
(type reduction lrdct rrdct) (type reduction lrdct rrdct)
(list orgn)) (list orgn))
(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))))))
@ -119,77 +122,73 @@
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil)) (setf (ext:package-lock :clos) nil))
(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))
(DEFMETHOD HMEQ ((n integer)) (DEFMETHOD HMEQ ((n integer))
(declare (fixnum n)) (declare (fixnum n))
(the (or homotopy-equivalence null) (the (or homotopy-equivalence null)
(find n *hmeq-list* :key #'idnm))) (find n *hmeq-list* :key #'idnm)))
(DEFMETHOD BUILD-HMEQ ((keyword1 (eql :lf)) lf &key lg lh rf rg rh orgn) (DEFMETHOD BUILD-HMEQ ((keyword1 (eql :lf)) lf &key lg lh rf rg rh orgn)
(declare (declare
(type morphism lf lg lh rf rg rh) (type morphism lf lg lh rf rg rh)
(list orgn)) (list orgn))
(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 :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh lrdct)) :lrdct (build-rdct :f lf :g lg :h lh
: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 lrdct))
:rrdct (build-rdct :f rf :g rg :h rh
:orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct))
:orgn orgn)))) :orgn orgn))))
(DEFUN TRIVIAL-HMEQ (chcm) (DEFUN TRIVIAL-HMEQ (chcm)
(declare (type chain-complex chcm)) (declare (type chain-complex chcm))
(build-hmeq (build-hmeq
:lrdct (trivial-rdct chcm) :lrdct (trivial-rdct chcm)
:rrdct (trivial-rdct chcm) :rrdct (trivial-rdct chcm)
:orgn `(trivial-hmeq ,chcm))) :orgn `(trivial-hmeq ,chcm)))
#|
(cat-init)
(setf cc (cdelta 5))
(setf hmeq (trivial-hmeq cc))
|#
;; Functions. ;; Functions.
(DEFUN PRE-CHECK-RDCT (rdct) (DEFUN PRE-CHECK-RDCT (rdct)
(declare (type reduction rdct)) (declare (type reduction rdct))
(with-slots (bcc tcc f g h) rdct (with-slots (bcc tcc f g h) rdct
(declare (declare
(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))
(DEFUN CHECK-RDCT () (DEFUN CHECK-RDCT ()
@ -197,299 +196,230 @@
(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))
#|
(setf rdct (make-rdct 6 3)) ;;; defined in a previous test
(pre-check-rdct rdct)
(setf *tc* (cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) 1000 '(2 3 4)))
(setf *bc* (cmbn 3 4 '(0 1 2 3)))
(check-rdct))
|#
(DEFMETHOD CMPS ((brdct reduction) (trdct reduction) &optional dummy) (DEFMETHOD CMPS ((brdct reduction) (trdct reduction) &optional dummy)
(declare (ignore dummy)) (declare (ignore dummy))
(when (eq (first (orgn brdct)) 'trivial-rdct) (when (eq (first (orgn brdct)) 'trivial-rdct)
(return-from cmps trdct)) (return-from cmps trdct))
(when (eq (first (orgn trdct)) 'trivial-rdct) (when (eq (first (orgn trdct)) 'trivial-rdct)
(return-from cmps brdct)) (return-from cmps brdct))
(with-slots ((tf f) (tg g) (th h)) trdct (with-slots ((tf f) (tg g) (th h)) trdct
(declare (type morphism tf tg th)) (declare (type morphism tf tg th))
(with-slots ((bf f) (bg g) (bh h)) brdct (with-slots ((bf f) (bg g) (bh h)) brdct
(declare (type morphism bf bg bh)) (declare (type morphism bf bg bh))
(build-rdct (build-rdct
:f (cmps bf tf) :f (cmps bf tf)
:g (cmps tg bg) :g (cmps tg bg)
:h (add th (i-cmps tg bh tf)) :h (add th (i-cmps tg bh tf))
:orgn `(cmps ,brdct ,trdct))))) :orgn `(cmps ,brdct ,trdct)))))
#| ;;
(setf trdct (make-rdct 6 4)) ;; BASIC PERTURBATION LEMMA.
(setf brdct (make-rdct 4 3)) ;;
(setf rdct (cmps brdct trdct))
(pre-check-rdct rdct)
(setf *tcc* (cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4)
100 '(1 3 5) 10 '(1 4 5) 1 '(3 4 5))
*bcc* (cmbn 2 1 '(0 1 3)))
(check-rdct))
|#
;
; BASIC PERTURBATION LEMMA.
;
(DEFMETHOD ADD ((rdct reduction) (perturbation morphism) &optional dummy) (DEFMETHOD ADD ((rdct reduction) (perturbation morphism) &optional dummy)
(declare (type null dummy)) (declare (type null dummy))
(when dummy (when dummy
(error "Why a third argument in (ADD REDUCTION MORPHISM)?")) (error "Why a third argument in (ADD REDUCTION MORPHISM)?"))
(when (eq (grmd (tcc rdct)) (grmd (sorc perturbation))) (when (eq (grmd (tcc rdct)) (grmd (sorc perturbation)))
(return-from add (return-from add
(basic-perturbation-lemma rdct perturbation))) (basic-perturbation-lemma rdct perturbation)))
(when (eq (grmd (bcc rdct)) (grmd (sorc perturbation))) (when (eq (grmd (bcc rdct)) (grmd (sorc perturbation)))
(return-from add (return-from add
(easy-perturbation-lemma rdct perturbation))) (easy-perturbation-lemma rdct perturbation)))
(error "In (METHOD ADD REDUCTION MORPHISM),~@ (error "In (METHOD ADD REDUCTION MORPHISM),~@
the data do not sound like coherent.")) the data do not sound like coherent."))
(DEFUN BASIC-PERTURBATION-LEMMA (reduction top-perturbation) (DEFUN BASIC-PERTURBATION-LEMMA (reduction top-perturbation)
(declare (declare
(type reduction reduction) (type reduction reduction)
(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 :new-trgt new-bcc) (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc
new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc :new-trgt new-tcc) :new-trgt new-bcc)
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc :new-trgt new-tcc)) new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc
(values :new-trgt new-tcc)
(build-rdct :f new-f :g new-g :h new-h new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
:orgn `(basic-perturbation-lemma ,reduction ,top-perturbation)) :new-trgt new-tcc))
bottom-perturbation))))) (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) (DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation)
(declare (declare
(type reduction reduction) (type reduction reduction)
(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 :new-trgt new-bcc) :f (dstr-change-sorc-trgt old-f :new-sorc new-tcc
:g (dstr-change-sorc-trgt old-g :new-sorc new-bcc :new-trgt new-tcc) :new-trgt new-bcc)
:h (dstr-change-sorc-trgt old-h :new-sorc new-tcc :new-trgt new-tcc) :g (dstr-change-sorc-trgt old-g :new-sorc new-bcc
:orgn `(easy-perturbation-lemma ,reduction ,bottom-perturbation)) :new-trgt new-tcc)
top-perturbation)))))) :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) (DEFUN SPECIAL-BPL (reduction top-perturbation)
(declare (declare
(type reduction reduction) (type reduction reduction)
(type morphism top-perturbation)) (type morphism top-perturbation))
(when (eq (first (orgn top-perturbation)) 'zero-mrph) (when (eq (first (orgn top-perturbation)) 'zero-mrph)
(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-trgt new-tcc)) new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
(build-rdct :f new-f :g old-g :h new-h :new-trgt new-tcc))
:orgn `(special-bpl ,reduction ,top-perturbation)))))) (build-rdct :f new-f :g old-g :h new-h
:orgn `(special-bpl ,reduction ,top-perturbation))))))
(DEFUN SPECIAL-BPL-2 (reduction top-perturbation) (DEFUN SPECIAL-BPL-2 (reduction top-perturbation)
(declare (declare
(type reduction reduction) (type reduction reduction)
(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-trgt new-tcc)) new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
(values :new-trgt new-tcc))
(build-rdct :f old-f :g new-g :h new-h (values
:orgn `(special-bpl-2 ,reduction ,top-perturbation))))))) (build-rdct :f old-f :g new-g :h new-h
: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) (cmbn-opps (cmbn-? h-delta iterated)))) (iterated (term-cmbn degr 1 gnrt)
(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)
(cat-init) &optional dummy)
(setf rdct (make-rdct 6 3)) (declare (ignore dummy))
(setf perturb (zero-mrph (cdelta 6) (cdelta 6) -1)) (the homotopy-equivalence
(setf new-rdct (add rdct perturb)) (with-slots (lrdct rrdct) hmeq
(pre-check-rdct new-rdct)
(setf *tc* (cmbn 2 3 '(0 1 2))
*bc* (cmbn 3 4 '(0 1 2 3)))
(check-rdct))
|#
#|
(cat-init)
(setf rdct (make-rdct 6 3))
(setf perturb (opps (dffr (tcc rdct))))
(setf new-rdct (add rdct perturb))
(pre-check-rdct new-rdct)
(setf *tc* (cmbn 2 3 '(0 1 2))
*bc* (cmbn 3 4 '(0 1 2 3)))
(check-rdct))
|#
#| ;; an absurd reduction ; just to test bpl-*-sigma
(cat-init)
(setf tcc (build-chcm
:cmpr #'l-cmpr
:basis :locally-effective
:bsgn '(0)
:intr-dffr #'(lambda (degr gnrt)
(cmbn (1- degr) 1 gnrt))
:strt :gnrt
:orgn '(test1)))
(setf rdct (trivial-rdct tcc))
(setf (slot-value rdct 'h)
(build-mrph
:sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(cmbn (1+ degr) 1 gnrt))
:strt :gnrt
:orgn '(test2)))
(setf perturb
(build-mrph
:sorc tcc :trgt tcc :degr -1
:intr #'(lambda (degr gnrt)
(if (zerop (first gnrt))
(zero-cmbn (1- degr))
(cmbn (1- degr) 1 (list (1- (first gnrt)) (1+ (second gnrt))))))
:strt :gnrt
:orgn '(test3)))
(setf new-rdct (add rdct perturb))
(gnrt-? (dffr (tcc new-rdct)) 3 '(3 5))
(gnrt-? (dffr (bcc new-rdct)) 3 '(3 5))
|#
(DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism) &optional dummy)
(declare (ignore dummy))
(the homotopy-equivalence
(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))))))
#|
(cat-init)
(setf hmeq (trivial-hmeq (cdelta 4)))
(add (lrdct hmeq) (opps (dffr (cdelta 4))))
(setf hmeq (add hmeq (opps (dffr (cdelta 4)))))
(gnrt-? (dffr (rbcc hmeq)) 3 '(0 1 2 3)))
|#