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 "combinations-test")
(:file "cones-test")
(:file "cs-twisted-products-test")
(:file "delta-test")
(:file "diabolo")
(:file "effective-homology-test")

9
package.lisp
View File

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

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

@ -23,21 +23,6 @@
:sintr #'smgr-fibration-sintr
: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)
(declare
@ -48,7 +33,8 @@
(fixnum degr degr+1)
(type crpr crpr))
(the cmbn
(with-crpr (absm1 absm2) crpr
(with-crpr
(absm1 absm2) crpr
(if (= (dgop absm2) (mask degr))
(zero-cmbn degr+1)
(term-cmbn degr+1
@ -56,10 +42,13 @@
(crpr 0 (make-gbar
:dmns degr+1
:list (cons absm2
(rest (unnormalize-gbar absm1 idnt))))
(rest
(unnormalize-gbar
absm1 idnt))))
(mask degr+1) idnt)))))))
(the intr-mrph #'rslt)))
(DEFUN SMGR-CRTS-CONTRACTION (smgr)
(declare (type simplicial-group smgr))
(the morphism
@ -71,25 +60,6 @@
:strt :gnrt
: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
&aux (fibration (smgr-fibration smgr))
@ -104,43 +74,3 @@
(type morphism f g chi))
(the morphism
(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)))
|#