Extracted tests from serre.lisp.
This commit is contained in:
Gerd Heber
parent
cb8a3d582c
commit
5dceced785
@ -35,6 +35,7 @@
|
||||
(:file "loop-spaces-test")
|
||||
(:file "ls-twisted-products-test")
|
||||
(:file "searching-homology-test")
|
||||
(:file "serre-test")
|
||||
(:file "simplicial-groups-test")
|
||||
(:file "simplicial-mrphs-test")
|
||||
(:file "simplicial-sets-test")
|
||||
|
||||
@ -415,6 +415,9 @@
|
||||
;; serre.lisp
|
||||
|
||||
BROWN-REDUCTION
|
||||
FIBRATION-DTAU-D
|
||||
FIBRATION-DTAU-D-INTR
|
||||
RIGHT-SERRE-EFHM
|
||||
|
||||
;; simplicial-mrphs.lisp
|
||||
|
||||
|
||||
339
src/serre.lisp
339
src/serre.lisp
@ -7,116 +7,85 @@
|
||||
(PROVIDE "serre")
|
||||
|
||||
(DEFUN FIBRATION-DTAU-D-INTR
|
||||
(fibration &aux (base (sorc fibration))
|
||||
(bface (face base))
|
||||
(fibre (trgt fibration))
|
||||
(fface (face fibre))
|
||||
(sintr-grml (sintr (grml fibre)))
|
||||
(fbspn (bspn fibre))
|
||||
(sintr-twist (sintr fibration))
|
||||
(total (fibration-total fibration))
|
||||
(total-cmpr (cmpr total)))
|
||||
(fibration &aux (base (sorc fibration))
|
||||
(bface (face base))
|
||||
(fibre (trgt fibration))
|
||||
(fface (face fibre))
|
||||
(sintr-grml (sintr (grml fibre)))
|
||||
(fbspn (bspn fibre))
|
||||
(sintr-twist (sintr fibration))
|
||||
(total (fibration-total fibration))
|
||||
(total-cmpr (cmpr total)))
|
||||
(declare
|
||||
(type fibration fibration)
|
||||
(type simplicial-set base total)
|
||||
(type face bface fface)
|
||||
(type simplicial-group fibre)
|
||||
(type gmsm fbspn)
|
||||
(type sintr sintr-grml sintr-twist)
|
||||
(type cmprf total-cmpr))
|
||||
(type fibration fibration)
|
||||
(type simplicial-set base total)
|
||||
(type face bface fface)
|
||||
(type simplicial-group fibre)
|
||||
(type gmsm fbspn)
|
||||
(type sintr sintr-grml sintr-twist)
|
||||
(type cmprf total-cmpr))
|
||||
(flet ((rslt (dmns crpr
|
||||
&aux (dmns-1 (1- dmns)))
|
||||
(declare
|
||||
(fixnum dmns dmns-1)
|
||||
(type crpr crpr))
|
||||
(unless (plusp dmns)
|
||||
(return-from rslt
|
||||
(zero-cmbn dmns-1)))
|
||||
(with-crpr (b-absm f-absm) crpr
|
||||
(let ((tau-b
|
||||
(tw-a-sintr3 sintr-twist dmns
|
||||
b-absm fbspn)))
|
||||
(declare (type absm tau-b))
|
||||
(when (= (dgop tau-b) (mask dmns-1))
|
||||
(return-from rslt
|
||||
(zero-cmbn dmns-1)))
|
||||
(let ((deln-b
|
||||
(a-face4 bface dmns dmns
|
||||
b-absm))
|
||||
(deln-f
|
||||
(a-face4 fface dmns dmns
|
||||
f-absm)))
|
||||
(declare
|
||||
(type absm deln-b deln-f tau-b))
|
||||
(let ((acrpr1 (2absm-acrpr deln-b deln-f))
|
||||
(acrpr2
|
||||
(2absm-acrpr
|
||||
deln-b
|
||||
(a-grml4 sintr-grml (1- dmns)
|
||||
tau-b deln-f))))
|
||||
(declare (type absm acrpr1 acrpr2))
|
||||
(with-absm (dgop1 crpr1) acrpr1
|
||||
(with-absm (dgop2 crpr2) acrpr2
|
||||
(if (zerop dgop1)
|
||||
(if (zerop dgop2)
|
||||
(dstr-add-term-to-cmbn
|
||||
total-cmpr
|
||||
(-1-expt-n+1 dmns) crpr1
|
||||
(term-cmbn dmns-1
|
||||
(-1-expt-n dmns)
|
||||
crpr2))
|
||||
(term-cmbn dmns-1
|
||||
(-1-expt-n+1 dmns)
|
||||
crpr1))
|
||||
(if (zerop dgop2)
|
||||
(term-cmbn dmns-1
|
||||
(-1-expt-n dmns)
|
||||
crpr2)
|
||||
(zero-cmbn dmns-1)))))))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
(declare
|
||||
(fixnum dmns dmns-1)
|
||||
(type crpr crpr))
|
||||
(unless (plusp dmns)
|
||||
(return-from rslt
|
||||
(zero-cmbn dmns-1)))
|
||||
(with-crpr
|
||||
(b-absm f-absm) crpr
|
||||
(let ((tau-b
|
||||
(tw-a-sintr3 sintr-twist dmns
|
||||
b-absm fbspn)))
|
||||
(declare (type absm tau-b))
|
||||
(when (= (dgop tau-b) (mask dmns-1))
|
||||
(return-from rslt
|
||||
(zero-cmbn dmns-1)))
|
||||
(let ((deln-b
|
||||
(a-face4 bface dmns dmns
|
||||
b-absm))
|
||||
(deln-f
|
||||
(a-face4 fface dmns dmns
|
||||
f-absm)))
|
||||
(declare
|
||||
(type absm deln-b deln-f tau-b))
|
||||
(let ((acrpr1 (2absm-acrpr deln-b deln-f))
|
||||
(acrpr2
|
||||
(2absm-acrpr
|
||||
deln-b
|
||||
(a-grml4 sintr-grml (1- dmns)
|
||||
tau-b deln-f))))
|
||||
(declare (type absm acrpr1 acrpr2))
|
||||
(with-absm
|
||||
(dgop1 crpr1) acrpr1
|
||||
(with-absm
|
||||
(dgop2 crpr2) acrpr2
|
||||
(if (zerop dgop1)
|
||||
(if (zerop dgop2)
|
||||
(dstr-add-term-to-cmbn
|
||||
total-cmpr
|
||||
(-1-expt-n+1 dmns) crpr1
|
||||
(term-cmbn dmns-1
|
||||
(-1-expt-n dmns)
|
||||
crpr2))
|
||||
(term-cmbn dmns-1
|
||||
(-1-expt-n+1 dmns)
|
||||
crpr1))
|
||||
(if (zerop dgop2)
|
||||
(term-cmbn dmns-1
|
||||
(-1-expt-n dmns)
|
||||
crpr2)
|
||||
(zero-cmbn dmns-1)))))))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s2 (sphere 2))
|
||||
(setf k (k-z2-1))
|
||||
(setf tw (build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(absm 0 1))
|
||||
:orgn '(s2-tw-kz2)))
|
||||
(setf dt-d (fibration-dtau-d-intr tw))
|
||||
(funcall dt-d 0 (crpr 0 '* 0 0))
|
||||
(funcall dt-d 3 (crpr 4 's2 0 3))
|
||||
(funcall dt-d 3 (crpr 2 's2 0 3))
|
||||
(funcall dt-d 3 (crpr 2 's2 5 1))
|
||||
(funcall dt-d 2 (crpr 0 's2 0 2))
|
||||
(cat-init)
|
||||
(setf s2 (sphere 2))
|
||||
(setf k (k-z-1))
|
||||
(setf tw (build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(absm 0 (list 1)))
|
||||
:orgn '(s2-tw-kz)))
|
||||
(setf dt-d (fibration-dtau-d-intr tw))
|
||||
(funcall dt-d 0 (crpr 0 '* 0 nil))
|
||||
(funcall dt-d 3 (crpr 4 's2 0 '(2 3 4)))
|
||||
(funcall dt-d 3 (crpr 2 's2 0 '(2 3 4)))
|
||||
(funcall dt-d 3 (crpr 2 's2 5 '(5)))
|
||||
(funcall dt-d 2 (crpr 0 's2 0 '(3 -2)))
|
||||
|#
|
||||
|
||||
(DEFUN FIBRATION-DTAU-D (fibration
|
||||
&aux (base (sorc fibration))
|
||||
(fibre (trgt fibration))
|
||||
(utotal (crts-prdc base fibre)))
|
||||
&aux (base (sorc fibration))
|
||||
(fibre (trgt fibration))
|
||||
(utotal (crts-prdc base fibre)))
|
||||
(declare (type fibration fibration))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
(build-mrph
|
||||
:sorc utotal
|
||||
:trgt utotal
|
||||
:degr -1
|
||||
@ -124,135 +93,73 @@
|
||||
:strt :gnrt
|
||||
:orgn `(fibration-dtau-d ,fibration))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s2 (sphere 2))
|
||||
(setf k (k-z-1))
|
||||
(setf tw (build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(absm 0 (list 1)))
|
||||
:orgn '(s2-tw-kz)))
|
||||
(setf dt-d (fibration-dtau-d tw))
|
||||
(? dt-d 0 (crpr 0 '* 0 nil))
|
||||
(? dt-d 3 (crpr 4 's2 0 '(2 3 4)))
|
||||
(? dt-d 3 (crpr 2 's2 0 '(2 3 4)))
|
||||
(? dt-d 3 (crpr 2 's2 5 '(5)))
|
||||
(? dt-d 2 (crpr 0 's2 0 '(3 -2)))
|
||||
|#
|
||||
|
||||
(DEFUN BROWN-REDUCTION (fibration
|
||||
&aux (base (sorc fibration))
|
||||
(fibre (trgt fibration))
|
||||
(total (fibration-total fibration))
|
||||
(ez (eilenberg-zilber base fibre))
|
||||
(t-perturbation (fibration-dtau-d fibration)))
|
||||
(fibre (trgt fibration))
|
||||
(total (fibration-total fibration))
|
||||
(ez (eilenberg-zilber base fibre))
|
||||
(t-perturbation (fibration-dtau-d fibration)))
|
||||
(declare
|
||||
(type fibration fibration)
|
||||
(type simplicial-set base fibre total)
|
||||
(type reduction ez)
|
||||
(type morphism t-perturbation))
|
||||
(type fibration fibration)
|
||||
(type simplicial-set base fibre total)
|
||||
(type reduction ez)
|
||||
(type morphism t-perturbation))
|
||||
(the (values reduction morphism)
|
||||
(multiple-value-bind (rslt b-perturbation) (add ez t-perturbation)
|
||||
(declare
|
||||
(type reduction rslt)
|
||||
(type morphism b-perturbation))
|
||||
(with-slots (f g h tcc) rslt
|
||||
(multiple-value-bind (rslt b-perturbation) (add ez t-perturbation)
|
||||
(declare
|
||||
(type reduction rslt)
|
||||
(type morphism b-perturbation))
|
||||
(with-slots (f g h tcc) rslt
|
||||
(setf tcc total)
|
||||
(dstr-change-sorc-trgt f :new-sorc total)
|
||||
(dstr-change-sorc-trgt g :new-trgt total)
|
||||
(dstr-change-sorc-trgt h :new-sorc total :new-trgt total)
|
||||
(values rslt b-perturbation)))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s2 (sphere 2))
|
||||
(setf k (k-z2-1))
|
||||
(setf tw (build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(absm 0 1))
|
||||
:orgn '(s2-tw-kz2)))
|
||||
(setf brown (brown-reduction tw))
|
||||
(setf tcc (tcc brown) bcc (bcc brown))
|
||||
(homology bcc 3)
|
||||
(homology tcc 1 8)
|
||||
(homology bcc 1 8)
|
||||
(cat-init)
|
||||
(setf s2 (sphere 2))
|
||||
(setf k (k-z-1))
|
||||
(setf tw (build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(absm 0 (list 1)))
|
||||
:orgn '(s2-tw-kz1)))
|
||||
(setf brown (brown-reduction tw))
|
||||
(homology (tcc brown) 1 5)
|
||||
(homology (bcc brown) 1 5)
|
||||
|#
|
||||
|
||||
(DEFUN LEFT-SERRE-EFHM (fibration)
|
||||
(declare (type fibration fibration))
|
||||
(the homotopy-equivalence
|
||||
(build-hmeq
|
||||
(build-hmeq
|
||||
:lrdct (trivial-rdct (fibration-total fibration))
|
||||
:rrdct (brown-reduction fibration))))
|
||||
|
||||
|
||||
(DEFUN RIGHT-SERRE-EFHM (fibration
|
||||
&aux (base (sorc fibration))
|
||||
(fibre (trgt fibration))
|
||||
(base-efhm (efhm base))
|
||||
(fibre-efhm (efhm fibre))
|
||||
(uprdc-efhm (tnsr-prdc base-efhm fibre-efhm)))
|
||||
&aux (base (sorc fibration))
|
||||
(fibre (trgt fibration))
|
||||
(base-efhm (efhm base))
|
||||
(fibre-efhm (efhm fibre))
|
||||
(uprdc-efhm (tnsr-prdc base-efhm fibre-efhm)))
|
||||
(declare
|
||||
(type fibration fibration)
|
||||
(type simplicial-set base fibre)
|
||||
(type homotopy-equivalence base-efhm fibre-efhm uprdc-efhm))
|
||||
(type fibration fibration)
|
||||
(type simplicial-set base fibre)
|
||||
(type homotopy-equivalence base-efhm fibre-efhm uprdc-efhm))
|
||||
(the homotopy-equivalence
|
||||
(multiple-value-bind (brown b-perturbation) (brown-reduction fibration)
|
||||
(declare
|
||||
(type reduction brown)
|
||||
(type morphism b-perturbation))
|
||||
(let ((rslt (add uprdc-efhm b-perturbation)))
|
||||
(declare (type homotopy-equivalence rslt))
|
||||
(with-slots (lbcc lf lg lrdct) rslt
|
||||
(multiple-value-bind (brown b-perturbation) (brown-reduction fibration)
|
||||
(declare
|
||||
(type reduction brown)
|
||||
(type morphism b-perturbation))
|
||||
(let ((rslt (add uprdc-efhm b-perturbation)))
|
||||
(declare (type homotopy-equivalence rslt))
|
||||
(with-slots (lbcc lf lg lrdct) rslt
|
||||
(declare
|
||||
(type chain-complex lbcc)
|
||||
(type morphism lf lg)
|
||||
(type reduction lrdct))
|
||||
(type chain-complex lbcc)
|
||||
(type morphism lf lg)
|
||||
(type reduction lrdct))
|
||||
(setf lbcc (bcc brown))
|
||||
(dstr-change-sorc-trgt lf :new-trgt lbcc)
|
||||
(dstr-change-sorc-trgt lg :new-sorc lbcc)
|
||||
(with-slots (bcc f g) lrdct
|
||||
(declare
|
||||
(type chain-complex bcc)
|
||||
(type morphism f g))
|
||||
(setf bcc lbcc)
|
||||
(dstr-change-sorc-trgt f :new-trgt lbcc)
|
||||
(dstr-change-sorc-trgt g :new-sorc lbcc)))
|
||||
rslt))))
|
||||
(declare
|
||||
(type chain-complex bcc)
|
||||
(type morphism f g))
|
||||
(setf bcc lbcc)
|
||||
(dstr-change-sorc-trgt f :new-trgt lbcc)
|
||||
(dstr-change-sorc-trgt g :new-sorc lbcc)))
|
||||
rslt))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s2 (sphere 2))
|
||||
(setf k (k-z-1))
|
||||
(setf tw (build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(absm 0 (list 1)))
|
||||
:orgn '(s2-tw-kz1)))
|
||||
(setf rh (right-serre-efhm tw))
|
||||
(setf rbcc (rbcc rh))
|
||||
(homology rbcc 0 5)
|
||||
|#
|
||||
|
||||
(DEFUN FIBRATION-TOTAL-EFHM (fibration)
|
||||
(declare (type fibration fibration))
|
||||
@ -260,27 +167,9 @@
|
||||
(cmps (left-serre-efhm fibration)
|
||||
(right-serre-efhm fibration))))
|
||||
|
||||
|
||||
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'fibration-total)))
|
||||
(declare
|
||||
(type simplicial-set smst))
|
||||
(type simplicial-set smst))
|
||||
(the homotopy-equivalence
|
||||
(fibration-total-efhm (second (orgn smst)))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s2 (sphere 2))
|
||||
(setf k (k-z-1))
|
||||
(setf tw (build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(absm 0 (list 2)))
|
||||
:orgn '(s2-tw-kz1)))
|
||||
(setf p3r (fibration-total tw))
|
||||
(homology p3r 1 )
|
||||
|#
|
||||
|
||||
|
||||
|
||||
|
||||
(fibration-total-efhm (second (orgn smst)))))
|
||||
|
||||
130
test/serre-test.lisp
Normal file
130
test/serre-test.lisp
Normal file
@ -0,0 +1,130 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
|
||||
(test fibration-dtau-d-intr
|
||||
(cat:cat-init)
|
||||
(let* ((s2 (cat:sphere 2))
|
||||
(k (cat:k-z2-1))
|
||||
(tw (cat:build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(cat:absm 0 1))
|
||||
:orgn '(s2-tw-kz2)))
|
||||
(dt-d (cat:fibration-dtau-d-intr tw)))
|
||||
(funcall dt-d 0 (cat:crpr 0 '* 0 0))
|
||||
(funcall dt-d 3 (cat:crpr 4 's2 0 3))
|
||||
(funcall dt-d 3 (cat:crpr 2 's2 0 3))
|
||||
(funcall dt-d 3 (cat:crpr 2 's2 5 1))
|
||||
(funcall dt-d 2 (cat:crpr 0 's2 0 2))))
|
||||
|
||||
(test fibration-dtau-d-intr1
|
||||
(cat:cat-init)
|
||||
(let* ((s2 (cat:sphere 2))
|
||||
(k (cat:k-z-1))
|
||||
(tw (cat:build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(cat:absm 0 (list 1)))
|
||||
:orgn '(s2-tw-kz)))
|
||||
(dt-d (cat:fibration-dtau-d-intr tw)))
|
||||
(funcall dt-d 0 (cat:crpr 0 '* 0 nil))
|
||||
(funcall dt-d 3 (cat:crpr 4 's2 0 '(2 3 4)))
|
||||
(funcall dt-d 3 (cat:crpr 2 's2 0 '(2 3 4)))
|
||||
(funcall dt-d 3 (cat:crpr 2 's2 5 '(5)))
|
||||
(funcall dt-d 2 (cat:crpr 0 's2 0 '(3 -2)))))
|
||||
|
||||
|
||||
(test fibration-dtau-d
|
||||
(cat:cat-init)
|
||||
(let* ((s2 (cat:sphere 2))
|
||||
(k (cat:k-z-1))
|
||||
(tw (cat:build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(cat:absm 0 (list 1)))
|
||||
:orgn '(s2-tw-kz)))
|
||||
(dt-d (cat:fibration-dtau-d tw)))
|
||||
(cat:? dt-d 0 (cat:crpr 0 '* 0 nil))
|
||||
(cat:? dt-d 3 (cat:crpr 4 's2 0 '(2 3 4)))
|
||||
(cat:? dt-d 3 (cat:crpr 2 's2 0 '(2 3 4)))
|
||||
(cat:? dt-d 3 (cat:crpr 2 's2 5 '(5)))
|
||||
(cat:? dt-d 2 (cat:crpr 0 's2 0 '(3 -2)))))
|
||||
|
||||
|
||||
(test brown-reduction
|
||||
(cat:cat-init)
|
||||
(let* ((s2 (cat:sphere 2))
|
||||
(k (cat:k-z2-1))
|
||||
(tw (cat:build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(cat:absm 0 1))
|
||||
:orgn '(s2-tw-kz2)))
|
||||
(brown (cat:brown-reduction tw))
|
||||
(tcc (cat:tcc brown))
|
||||
(bcc (cat:bcc brown)))
|
||||
(cat:homology bcc 3)
|
||||
(cat:homology tcc 1 8)
|
||||
(cat:homology bcc 1 8)))
|
||||
|
||||
#|
|
||||
(test brown-reduction1
|
||||
(cat:cat-init)
|
||||
(let* ((s2 (cat:sphere 2))
|
||||
(k (cat:k-z-1))
|
||||
(tw (cat:build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(cat:absm 0 (list 1)))
|
||||
:orgn '(s2-tw-kz)))
|
||||
(brown (cat:brown-reduction tw)))
|
||||
(cat:homology (cat:tcc brown) 1 5)
|
||||
(cat:homology (cat:bcc brown) 1 5)))
|
||||
|#
|
||||
|
||||
(test right-serre-efhm
|
||||
(cat:cat-init)
|
||||
(let* ((s2 (cat:sphere 2))
|
||||
(k (cat:k-z-1))
|
||||
(tw (cat:build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(cat:absm 0 (list 1)))
|
||||
:orgn '(s2-tw-kz1)))
|
||||
(rh (cat:right-serre-efhm tw))
|
||||
(rbcc (cat:rbcc rh)))
|
||||
(cat:homology rbcc 0 5)))
|
||||
|
||||
|
||||
(test fibration-total
|
||||
(cat:cat-init)
|
||||
(let* ((s2 (cat:sphere 2))
|
||||
(k (cat:k-z-1))
|
||||
(tw (cat:build-smmr
|
||||
:sorc s2
|
||||
:trgt k
|
||||
:degr -1
|
||||
:sintr #'(lambda (dmns gmsm)
|
||||
(cat:absm 0 (list 1)))
|
||||
:orgn '(s2-tw-kz1)))
|
||||
(p3r (cat:fibration-total tw)))
|
||||
(cat:homology p3r 1)))
|
||||
|
||||
|
||||
(test dummy
|
||||
(is (not (null t))))
|
||||
Loading…
Reference in New Issue
Block a user