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

Extracted tests from serre.lisp.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-28 06:47:14 -05:00
parent cb8a3d582c
commit 5dceced785
4 changed files with 248 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -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")

3
package.lisp
View File

@ -415,6 +415,9 @@
;; serre.lisp
BROWN-REDUCTION
FIBRATION-DTAU-D
FIBRATION-DTAU-D-INTR
RIGHT-SERRE-EFHM
;; simplicial-mrphs.lisp

127
src/serre.lisp
View File

@ -32,7 +32,8 @@
(unless (plusp dmns)
(return-from rslt
(zero-cmbn dmns-1)))
(with-crpr (b-absm f-absm) crpr
(with-crpr
(b-absm f-absm) crpr
(let ((tau-b
(tw-a-sintr3 sintr-twist dmns
b-absm fbspn)))
@ -55,8 +56,10 @@
(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
(with-absm
(dgop1 crpr1) acrpr1
(with-absm
(dgop2 crpr2) acrpr2
(if (zerop dgop1)
(if (zerop dgop2)
(dstr-add-term-to-cmbn
@ -75,40 +78,6 @@
(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))
@ -124,24 +93,6 @@
: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))
@ -166,36 +117,6 @@
(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))
@ -204,6 +125,7 @@
:lrdct (trivial-rdct (fibration-total fibration))
:rrdct (brown-reduction fibration))))
(DEFUN RIGHT-SERRE-EFHM (fibration
&aux (base (sorc fibration))
(fibre (trgt fibration))
@ -238,21 +160,6 @@
(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))
(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 )
|#

130
test/serre-test.lisp Normal file
View 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))))