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

Extracted Whitehead tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-26 10:09:14 -05:00
parent 2b78905586
commit dc4d330e5d
4 changed files with 223 additions and 307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -41,4 +41,5 @@
(:file "suspensions-test")
(:file "tensor-products-test")
(:file "various-test")
(:file "whitehead-test")
))

3
package.lisp
View File

@ -410,6 +410,7 @@
;; simplicial-mrphs.lisp
BUILD-SMMR
TW-A-SINTR3
;; simplicial-sets.lisp
@ -483,7 +484,9 @@
;; whitehead.lisp
Z-WHITEHEAD
Z-WHITEHEAD-SINTR
Z2-WHITEHEAD
Z2-WHITEHEAD-SINTR
))

200
src/whitehead.lisp
View File

@ -35,51 +35,6 @@
(gmsm-cocycle face n dmns gmsm chml-clss)))))
(the sintr #'rslt)))
#|
(cat-init)
(setf k (k-z 2))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 2
:intr #'(lambda (degr gnrt)
(if (= degr 2)
(term-cmbn 0 1 :z-gnrt)
(zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2)))
(setf tw (z-wwhitehead-sintr k 2 chml-clss))
(a-sintr3 tw 1 (absm 1 +null-gbar+)) ;;; cf old-macro cancelled
(a-sintr3 tw 2 (absm 3 +null-gbar+)) ;;; in macros.cl
(funcall tw 2 (gbar 2 0 '(55) 0 '()))
(funcall tw 3 (gbar 3 0 '(12 23)
0 '(34)
0 '()))
(funcall tw 4 (gbar 4 0 '(12 23 34)
2 '(45)
0 '(56)
0 '()))
(setf k (k-z 3))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 3
:intr #'(lambda (degr gnrt)
(if (= degr 3)
(term-cmbn 0 -1 :z-gnrt)
(zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (z-wwhitehead-sintr k 3 chml-clss))
(a-sintr3 tw 1 (absm 1 +null-gbar+))
(a-sintr3 tw 2 (absm 3 +null-gbar+))
(a-sintr3 tw 3 (absm 7 +null-gbar+))
(funcall tw 3 (z-fundamental-gmsm 3 55))
(equal (funcall tw 3 (z-fundamental-gmsm 3 55))
(absm 0 (z-fundamental-gmsm 3 55)))
(funcall tw 4 (gbar 4 0 (gbar 3 0 '(12 23) 0 '(34) 0 '())
0 (gbar 2 0 '(45) 0 '())
1 (gbar 0)
0 (gbar 0)))
|#
(DEFUN Z-WHITEHEAD-SINTR (smst n chml-clss
&aux (face (face smst))
@ -106,51 +61,6 @@
(gmsm-cocycle face n dmns gmsm chml-clss)))))
(the sintr #'rslt)))
#|
(cat-init)
(setf k (k-z 2))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 2
:intr #'(lambda (degr gnrt)
(if (= degr 2)
(term-cmbn 0 1 :z-gnrt)
(zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2)))
(setf tw (z-whitehead-sintr k 2 chml-clss))
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) '())
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) '())
(funcall tw 2 (gbar 2 0 '(55) 0 '()))
(funcall tw 3 (gbar 3 0 '(12 23)
0 '(34)
0 '()))
(funcall tw 4 (gbar 4 0 '(12 23 34)
2 '(45)
0 '(56)
0 '()))
(setf k (k-z 3))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 3
:intr #'(lambda (degr gnrt)
(if (= degr 3)
(term-cmbn 0 -1 :z-gnrt)
(zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (z-whitehead-sintr k 3 chml-clss))
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) +null-gbar+)
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) +null-gbar+)
(tw-a-sintr3 tw 3 (absm 7 +null-gbar+) +null-gbar+)
(funcall tw 3 (z-fundamental-gmsm 3 55))
(equal (funcall tw 3 (z-fundamental-gmsm 3 55))
(absm 0 (z-fundamental-gmsm 2 55)))
(funcall tw 4 (gbar 4 0 (gbar 3 0 '(12 23) 0 '(34) 0 '())
0 (gbar 2 0 '(45) 0 '())
1 (gbar 0)
0 (gbar 0)))
|#
(DEFUN Z-WHITEHEAD (smst chml-clss &aux (n (- (degr chml-clss))))
(declare
@ -192,51 +102,6 @@
(gmsm-cocycle face n dmns gmsm chml-clss)))))
(the sintr #'rslt)))
#|
(cat-init)
(setf k (k-z2 2))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 2
:intr #'(lambda (degr gnrt)
(if (= degr 2)
(term-cmbn 0 1 :z-gnrt)
(zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2)))
(setf tw (Z2-wwhitehead-sintr k 2 chml-clss))
(a-sintr3 tw 1 (absm 1 +null-gbar+))
(a-sintr3 tw 2 (absm 3 +null-gbar+))
(funcall tw 2 (gbar 2 0 1 0 0))
(funcall tw 3 (gbar 3 0 2
0 1
0 0))
(funcall tw 4 (gbar 4 0 3
2 1
0 1
0 0))
(setf k (k-z2 3))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 3
:intr #'(lambda (degr gnrt)
(if (= degr 3)
(term-cmbn 0 -1 :z-gnrt)
(zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (Z2-wwhitehead-sintr k 3 chml-clss))
(a-sintr3 tw 1 (absm 1 +null-gbar+))
(a-sintr3 tw 2 (absm 3 +null-gbar+))
(a-sintr3 tw 3 (absm 7 +null-gbar+))
(funcall tw 3 (Z2-fundamental-gmsm 3 1))
(equal (funcall tw 3 (Z2-fundamental-gmsm 3 1))
(absm 0 (Z2-fundamental-gmsm 3 1)))
(funcall tw 4 (gbar 4 0 (gbar 3 0 2 0 1 0 0)
0 (gbar 2 0 1 0 0)
1 (gbar 0)
0 (gbar 0)))
|#
(DEFUN Z2-WHITEHEAD-SINTR (smst n chml-clss
&aux (face (face smst))
@ -260,54 +125,10 @@
(if (< dmns n)
(absm (mask (1- dmns)) idnt)
(z2-cocycle-gbar-head n dmns
(gmsm-cocycle face n dmns gmsm chml-clss)))))
(gmsm-cocycle face n dmns gmsm
chml-clss)))))
(the sintr #'rslt)))
#|
(cat-init)
(setf k (k-z2 2))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 2
:intr #'(lambda (degr gnrt)
(if (= degr 2)
(term-cmbn 0 1 :z-gnrt)
(zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2)))
(setf tw (Z2-whitehead-sintr k 2 chml-clss))
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) 0)
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) 0)
(funcall tw 2 (gbar 2 0 1 0 '()))
(funcall tw 3 (gbar 3 0 2
0 1
0 0))
(funcall tw 4 (gbar 4 0 3
2 1
0 1
0 0))
(setf k (k-z2 3))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 3
:intr #'(lambda (degr gnrt)
(if (= degr 3)
(term-cmbn 0 -1 :z-gnrt)
(zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (Z2-whitehead-sintr k 3 chml-clss))
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) 0)
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) 0)
(tw-a-sintr3 tw 3 (absm 7 +null-gbar+) 0)
(funcall tw 3 (Z2-fundamental-gmsm 3 1))
(equal (funcall tw 3 (Z2-fundamental-gmsm 3 1))
(absm 0 (Z2-fundamental-gmsm 2 1)))
(funcall tw 4 (gbar 4 0 (gbar 3 0 2 0 1 0 0)
0 (gbar 2 0 1 0 0)
1 (gbar 0)
0 (gbar 0)))
|#
(DEFUN Z2-WHITEHEAD (smst chml-clss &aux (n (- (degr chml-clss))))
(declare
@ -319,20 +140,3 @@
:sorc smst :trgt (k-z2 (1- n)) :degr -1
:sintr (Z2-whitehead-sintr smst n chml-clss)
:orgn `(Z2-whitehead ,smst))))
#|
(setf m (moore 2 4))
(setf chml-clss
(build-mrph
:sorc m :trgt (z-chcm) :degr -4
:intr #'(lambda (dmns gmsm)
(if (= 4 dmns)
(cmbn 0 1 :z-gnrt)
(zero-cmbn (- dmns 4))))
:strt :gnrt
:orgn '(chml-clss moore 2 4)))
(setf mf (z2-whitehead m 4 chml-clss))
(setf mt (fibration-total mf))
(homology mt 0 10)
|#

108
test/whitehead-test.lisp Normal file
View File

@ -0,0 +1,108 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(test z-whitehead-sintr
(cat:cat-init)
(let* ((k (cat:k-z 2))
(ecc (cat:echcm k))
(chml-clss
(cat:build-mrph
:sorc ecc :trgt (cat:z-chcm) :degr 2
:intr #'(lambda (degr gnrt)
(if (= degr 2)
(cat:term-cmbn 0 1 :z-gnrt)
(cat:zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2)))
(tw (cat:z-whitehead-sintr k 2 chml-clss)))
(cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) '())
(cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) '())
(funcall tw 2 (cat:gbar 2 0 '(55) 0 '()))
(funcall tw 3 (cat:gbar 3 0 '(12 23) 0 '(34) 0 '()))
(funcall tw 4 (cat:gbar 4 0 '(12 23 34) 2 '(45) 0 '(56) 0 '()))
(setf k (cat:k-z 3))
(setf ecc (cat:echcm k))
(setf chml-clss
(cat:build-mrph
:sorc ecc :trgt (cat:z-chcm) :degr 3
:intr #'(lambda (degr gnrt)
(if (= degr 3)
(cat:term-cmbn 0 -1 :z-gnrt)
(cat:zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (cat:z-whitehead-sintr k 3 chml-clss))
(cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) cat:+null-gbar+)
(cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) cat:+null-gbar+)
(cat:tw-a-sintr3 tw 3 (cat:absm 7 cat:+null-gbar+) cat:+null-gbar+)
(funcall tw 3 (cat:z-fundamental-gmsm 3 55))
(is (equalp (funcall tw 3 (cat:z-fundamental-gmsm 3 55))
(cat:absm 0 (cat:z-fundamental-gmsm 2 55))))
(funcall tw 4 (cat:gbar 4 0 (cat:gbar 3 0 '(12 23) 0 '(34) 0 '())
0 (cat:gbar 2 0 '(45) 0 '())
1 (cat:gbar 0)
0 (cat:gbar 0)))))
(test Z2-whitehead-sintr
(cat:cat-init)
(let* ((k (cat:k-z2 2))
(ecc (cat:echcm k))
(chml-clss
(cat:build-mrph
:sorc ecc :trgt (cat:z-chcm) :degr 2
:intr #'(lambda (degr gnrt)
(if (= degr 2)
(cat:term-cmbn 0 1 :z-gnrt)
(cat:zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2)))
(tw (cat:Z2-whitehead-sintr k 2 chml-clss)))
(cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) 0)
(cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) 0)
(funcall tw 2 (cat:gbar 2 0 1 0 '()))
(funcall tw 3 (cat:gbar 3 0 2
0 1
0 0))
(funcall tw 4 (cat:gbar 4 0 3
2 1
0 1
0 0))
(setf k (cat:k-z2 3))
(setf ecc (cat:echcm k))
(setf chml-clss
(cat:build-mrph
:sorc ecc :trgt (cat:z-chcm) :degr 3
:intr #'(lambda (degr gnrt)
(if (= degr 3)
(cat:term-cmbn 0 -1 :z-gnrt)
(cat:zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (cat:Z2-whitehead-sintr k 3 chml-clss))
(cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) 0)
(cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) 0)
(cat:tw-a-sintr3 tw 3 (cat:absm 7 cat:+null-gbar+) 0)
(funcall tw 3 (cat:Z2-fundamental-gmsm 3 1))
(is (equalp (funcall tw 3 (cat:Z2-fundamental-gmsm 3 1))
(cat:absm 0 (cat:Z2-fundamental-gmsm 2 1))))
(funcall tw 4 (cat:gbar 4 0 (cat:gbar 3 0 2 0 1 0 0)
0 (cat:gbar 2 0 1 0 0)
1 (cat:gbar 0)
0 (cat:gbar 0)))))
(test Z2-whitehead
(cat:cat-init)
(let* ((m (cat:moore 2 4))
(chml-clss
(cat:build-mrph
:sorc m :trgt (cat:z-chcm) :degr -4
:intr #'(lambda (dmns gmsm)
(if (= 4 dmns)
(cat:cmbn 0 1 :z-gnrt)
(cat:zero-cmbn (- dmns 4))))
:strt :gnrt
:orgn '(chml-clss moore 2 4)))
(mf (cat:z2-whitehead m chml-clss))
(mt (cat:fibration-total mf)))
(cat:homology mt 0 10)))