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

138
src/effective-homology.lisp
View File

@ -24,6 +24,8 @@
(DEFUN RDCT (n)
(declare (fixnum n))
"Retrieve the N-th user created reduction from the list *RDCT-LIST*.
Return NIL if it doesn't exist."
(the (or null reduction)
(find n *rdct-list* :key #'idnm)))
@ -31,6 +33,7 @@
(declare
(type morphism f g h)
(list orgn))
"Create a reduction. Use this function instead of the generic MAKE-INSTANCE."
(the reduction
(progn
(unless orgn
@ -147,8 +150,10 @@
(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))
:rrdct (build-rdct :f rf :g rg :h rh :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct))
:lrdct (build-rdct :f lf :g lg :h lh
: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))))
(DEFUN TRIVIAL-HMEQ (chcm)
@ -158,12 +163,6 @@
:rrdct (trivial-rdct chcm)
:orgn `(trivial-hmeq ,chcm)))
#|
(cat-init)
(setf cc (cdelta 5))
(setf hmeq (trivial-hmeq cc))
|#
;; Functions.
@ -207,14 +206,6 @@
(read-line))
(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)
(declare (ignore dummy))
(when (eq (first (orgn brdct)) 'trivial-rdct)
@ -231,20 +222,9 @@
:h (add th (i-cmps tg bh tf))
:orgn `(cmps ,brdct ,trdct)))))
#|
(setf trdct (make-rdct 6 4))
(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.
;
;;
;; BASIC PERTURBATION LEMMA.
;;
(DEFMETHOD ADD ((rdct reduction) (perturbation morphism) &optional dummy)
(declare (type null dummy))
@ -295,12 +275,16 @@
(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))
(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))
:orgn `(basic-perturbation-lemma ,reduction
,top-perturbation))
bottom-perturbation)))))
(DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation)
@ -326,10 +310,14 @@
(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))
: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)
@ -358,7 +346,8 @@
(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))
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))))))
@ -389,7 +378,8 @@
(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))
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)))))))
@ -408,7 +398,8 @@
(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))))
(iterated (term-cmbn degr 1 gnrt)
(cmbn-opps (cmbn-? h-delta iterated))))
((cmbn-zero-p iterated) rslt)
(declare (type cmbn rslt iterated)))))
(build-mrph
@ -417,61 +408,8 @@
:strt :gnrt
:orgn `(bpl-*-sigma ,homotopy ,perturbation))))))
#|
(cat-init)
(setf rdct (make-rdct 6 3))
(setf perturb (zero-mrph (cdelta 6) (cdelta 6) -1))
(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))
|#
#|
(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)
(DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism)
&optional dummy)
(declare (ignore dummy))
(the homotopy-equivalence
(with-slots (lrdct rrdct) hmeq
@ -485,11 +423,3 @@
:lrdct new-lrdct
:rrdct (add rrdct top-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)))
|#