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

Extracted tests from cs-twisted-products.lisp.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-23 06:53:16 -05:00
parent 9e2a323b85
commit 80a94c4c72
4 changed files with 149 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -22,6 +22,7 @@
(:file "cobar-test") (:file "cobar-test")
(:file "combinations-test") (:file "combinations-test")
(:file "cones-test") (:file "cones-test")
(:file "cs-twisted-products-test")
(:file "delta-test") (:file "delta-test")
(:file "diabolo") (:file "diabolo")
(:file "effective-homology-test") (:file "effective-homology-test")

9
package.lisp
View File

@ -214,6 +214,11 @@
TERM-CON1 TERM-CON1
TERM-UNCON TERM-UNCON
;; cs-twisted-products.lisp
SMGR-CRTS-CONTRACTION
SMGR-FIBRATION
SMGR-TNPR-CONTRACTION
;; delta.lisp ;; delta.lisp
@ -344,6 +349,10 @@
HOMOLOGY HOMOLOGY
;; serre.lisp
BROWN-REDUCTION
;; simplicial-mrphs.lisp ;; simplicial-mrphs.lisp
BUILD-SMMR BUILD-SMMR

154
src/cs-twisted-products.lisp
View File

@ -8,139 +8,69 @@
(DEFUN SMGR-FIBRATION-SINTR (dmns gbar) (DEFUN SMGR-FIBRATION-SINTR (dmns gbar)
(declare (declare
(ignore dmns) (ignore dmns)
(type gbar gbar)) (type gbar gbar))
(the absm (the absm
(first (gbar-list gbar)))) (first (gbar-list gbar))))
(DEFUN SMGR-FIBRATION (smgr) (DEFUN SMGR-FIBRATION (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the fibration (the fibration
(build-smmr (build-smmr
:sorc (classifying-space smgr) :sorc (classifying-space smgr)
:trgt smgr :trgt smgr
:degr -1 :degr -1
:sintr #'smgr-fibration-sintr :sintr #'smgr-fibration-sintr
:orgn `(simplicial-group-fibration ,smgr)))) :orgn `(simplicial-group-fibration ,smgr))))
#|
(setf k1 (k-z-1))
(setf tw (smgr-fibration k1))
(setf k2 (sorc tw))
(setf tt (fibration-total tw))
(setf gmsm (crpr 0 (gbar 4 0 '(10 11 12) 0 '(20 21) 0 '(30) 0 '())
0 '(2 4 6 8)))
(dotimes (i 5)
(print (face tt i 4 gmsm)))
(setf br (brown-reduction tw))
(setf tw-pr (bcc br))
(? tw-pr 4 (tnpr 4 (gbar 4 0 '(1 10 100) 0 '(1000 10000)
0 '(100000) 0 '())
0 '()))
|#
(DEFUN SMGR-CRTS-CONTRACTION-INTR (idnt) (DEFUN SMGR-CRTS-CONTRACTION-INTR (idnt)
(declare (declare
(type gmsm idnt)) (type gmsm idnt))
(flet ((rslt (degr crpr (flet ((rslt (degr crpr
&aux (degr+1 (1+ degr))) &aux (degr+1 (1+ degr)))
(declare (declare
(fixnum degr degr+1) (fixnum degr degr+1)
(type crpr crpr)) (type crpr crpr))
(the cmbn (the cmbn
(with-crpr (absm1 absm2) crpr (with-crpr
(if (= (dgop absm2) (mask degr)) (absm1 absm2) crpr
(zero-cmbn degr+1) (if (= (dgop absm2) (mask degr))
(term-cmbn degr+1 (zero-cmbn degr+1)
(-1-expt-n+1 degr) (term-cmbn degr+1
(crpr 0 (make-gbar (-1-expt-n+1 degr)
:dmns degr+1 (crpr 0 (make-gbar
:list (cons absm2 :dmns degr+1
(rest (unnormalize-gbar absm1 idnt)))) :list (cons absm2
(mask degr+1) idnt))))))) (rest
(the intr-mrph #'rslt))) (unnormalize-gbar
absm1 idnt))))
(mask degr+1) idnt)))))))
(the intr-mrph #'rslt)))
(DEFUN SMGR-CRTS-CONTRACTION (smgr) (DEFUN SMGR-CRTS-CONTRACTION (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc (fibration-total (smgr-fibration smgr)) :sorc (fibration-total (smgr-fibration smgr))
:trgt (fibration-total (smgr-fibration smgr)) :trgt (fibration-total (smgr-fibration smgr))
:degr +1 :degr +1
:intr (smgr-crts-contraction-intr (bspn smgr)) :intr (smgr-crts-contraction-intr (bspn smgr))
:strt :gnrt :strt :gnrt
:orgn `(smgr-crts-contraction ,smgr)))) :orgn `(smgr-crts-contraction ,smgr))))
#|
(cat-init)
(setf chi (smgr-crts-contraction (k-z-1)))
(setf rdct (build-rdct :f (zero-mrph (sorc chi) (z-chcm))
:g (zero-mrph (z-chcm) (sorc chi))
:h chi))
(pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (crpr 0 +null-gbar+ 0 '())))
(setf *bc* (cmbn 0 1 :z-gnrt))
(check-rdct)
(setf *tc* (cmbn 1 1 (crpr 1 +null-gbar+ 0 '(1))))
(check-rdct)
(setf *tc* (cmbn 4 1 (crpr 0 (gbar 4 0 '(10 11 12) 0 '(20 21) 0 '(30) 0 '())
0 '(2 4 6 8))))
(check-rdct)
(setf *tc* (cmbn 3 1 (crpr 0 (gbar 3 0 '(10 11) 0 '(20) 0 '())
0 '(2 4 6))))
(check-rdct)
|#
(DEFUN SMGR-TNPR-CONTRACTION (smgr (DEFUN SMGR-TNPR-CONTRACTION (smgr
&aux (fibration (smgr-fibration smgr)) &aux (fibration (smgr-fibration smgr))
(brown (brown-reduction fibration)) (brown (brown-reduction fibration))
(f (f brown)) (f (f brown))
(g (g brown)) (g (g brown))
(chi (smgr-crts-contraction smgr))) (chi (smgr-crts-contraction smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type fibration fibration) (type fibration fibration)
(type reduction brown) (type reduction brown)
(type morphism f g chi)) (type morphism f g chi))
(the morphism (the morphism
(i-cmps f chi g))) (i-cmps f chi g)))
#|
(cat-init)
(setf chi (smgr-tnpr-contraction (k-z-1)))
(setf rdct (build-rdct :f (zero-mrph (sorc chi) (z-chcm))
:g (zero-mrph (z-chcm) (sorc chi))
:h chi))
(pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (tnpr 0 +null-gbar+ 0 '())))
(setf *bc* (cmbn 0 1 :z-gnrt))
(check-rdct)
(setf *tc* (cmbn 1 1 (tnpr 0 +null-gbar+ 1 '(1))))
(check-rdct)
(setf *tc* (cmbn 3 1 (tnpr 0 +null-gbar+ 3 '(1 10 100))))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 3 1 (tnpr 2 (gbar 2 0 '(1) 0 '()) 1 '(10))))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 3 1 (tnpr 3 (gbar 3 0 '(1 10) 0 '(100) 0 '()) 0 '())))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 4 1 (tnpr 0 +null-gbar+ 4 '(1 10 100 1000))))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 4 1 (tnpr 2 (gbar 2 0 '(1) 0 '()) 2 '(10 100))))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 4 1 (tnpr 3 (gbar 3 0 '(1 10) 0 '(100) 0 '())
1 '(1000))))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 4 1 (tnpr 4 (gbar 4 0 '(1 10 100)
0 '(1000 10000)
0 '(100000)
0 '())
0 '())))
(? chi *tc*)
(check-rdct)
|#

97
test/cs-twisted-products-test.lisp Normal file
View File

@ -0,0 +1,97 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(test smgr-fibration
(cat:cat-init)
(let* ((k1 (cat:k-z-1))
(tw (cat:smgr-fibration k1))
(k2 (cat:sorc tw))
(tt (cat:fibration-total tw))
(gmsm (cat:crpr 0 (cat:gbar 4 0 '(10 11 12) 0 '(20 21)
0 '(30) 0 '())
0 '(2 4 6 8)))
(br (cat:brown-reduction tw))
(tw-pr (cat:bcc br)))
(dotimes (i 5)
(print (cat:face tt i 4 gmsm)))
(cat:? tw-pr 4 (cat:tnpr 4 (cat:gbar 4 0 '(1 10 100) 0 '(1000 10000)
0 '(100000) 0 '())
0 '()))))
#|
(test smgr-crts-contraction
(cat:cat-init)
(let* ((chi (cat:smgr-crts-contraction (cat:k-z-1)))
(rdct (cat:build-rdct :f (cat:zero-mrph (cat:sorc chi)
(cat:z-chcm))
:g (cat:zero-mrph (cat:z-chcm)
(cat:sorc chi))
:h chi)))
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:crpr 0 cat:+null-gbar+ 0 '())))
(setf cat:*bc* (cat:cmbn 0 1 :z-gnrt))
(check-rdct)
(setf cat:*tc* (cat:cmbn 1 1 (cat:crpr 1 cat:+null-gbar+ 0 '(1))))
(check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:crpr 0 (cat:gbar 4 0 '(10 11 12)
0 '(20 21)
0 '(30) 0 '())
0 '(2 4 6 8))))
(check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 (cat:gbar 3 0 '(10 11)
0 '(20) 0 '())
0 '(2 4 6))))
(check-rdct)))
|#
#|
(test smgr-tnpr-contraction
(cat:cat-init)
(let* ((chi (cat:smgr-tnpr-contraction (cat:k-z-1)))
(rdct (cat:build-rdct :f (cat:zero-mrph (cat:sorc chi)
(cat:z-chcm))
:g (cat:zero-mrph (cat:z-chcm)
(cat:sorc chi))
:h chi)))
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0 cat:+null-gbar+ 0 '())))
(setf cat:*bc* (cat:cmbn 0 1 :z-gnrt))
(check-rdct)
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 0 cat:+null-gbar+ 1 '(1))))
(check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 0 cat:+null-gbar+
3 '(1 10 100))))
(cat:? chi cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 2 (cat:gbar 2 0 '(1) 0 '())
1 '(10))))
(cat:? chi cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:gbar 3 0 '(1 10)
0 '(100) 0 '())
0 '())))
(cat:? chi cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 0 cat:+null-gbar+
4 '(1 10 100 1000))))
(cat:? chi cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:gbar 2 0 '(1) 0 '())
2 '(10 100))))
(cat:? chi cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 3 (cat:gbar 3 0 '(1 10)
0 '(100) 0 '())
1 '(1000))))
(cat:? chi cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 4 (cat:gbar 4 0 '(1 10 100)
0 '(1000 10000)
0 '(100000)
0 '())
0 '())))
(cat:? chi cat:*tc*)
(check-rdct)))
|#