Extracted Eilenberg-Zilber tests.
This commit is contained in:
Gerd Heber
parent
c921cb9c2b
commit
84004e8556
@ -10,6 +10,7 @@
|
||||
:components ((:file "package")
|
||||
(:file "common")
|
||||
;; === test files ===
|
||||
#|
|
||||
(:file "bar-test")
|
||||
(:file "bicones-test")
|
||||
(:file "cartesian-products-test")
|
||||
@ -26,6 +27,9 @@
|
||||
(:file "delta-test")
|
||||
(:file "diabolo")
|
||||
(:file "disk-pasting-test")
|
||||
|#
|
||||
(:file "eilenberg-zilber-test")
|
||||
#|
|
||||
(:file "effective-homology-test")
|
||||
(:file "homology-groups-test")
|
||||
(:file "k-pi-n-test")
|
||||
@ -36,4 +40,5 @@
|
||||
(:file "simplicial-sets-test")
|
||||
(:file "tensor-products-test")
|
||||
(:file "various-test")
|
||||
|#
|
||||
))
|
||||
|
||||
@ -264,7 +264,13 @@
|
||||
;; eilenberg-zilber.lisp
|
||||
|
||||
AW
|
||||
EML
|
||||
EZ
|
||||
INTR-AW
|
||||
INTR-EML
|
||||
INTR-PHI
|
||||
PHI
|
||||
SHUFFLE-SIGN
|
||||
|
||||
;; fibrations.lisp
|
||||
|
||||
|
||||
@ -18,17 +18,14 @@
|
||||
(setf factor (- factor))
|
||||
(setf rslt (* rslt factor))))))
|
||||
|
||||
#|
|
||||
(dotimes (i 30)
|
||||
(format t "~%~A => ~@D" (hyphenize-list (dlop-int-ext i)) (shuffle-sign i)))
|
||||
|#
|
||||
|
||||
(DEFUN INTR-EML (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(when (cmbn-zero-p cmbn)
|
||||
(return-from intr-eml cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(with-cmbn
|
||||
(degr list) cmbn
|
||||
(let* ((limits (make-array (+ degr 2)))
|
||||
(rslt (list nil))
|
||||
(rslt-mark rslt)
|
||||
@ -58,7 +55,8 @@
|
||||
(stop (svref limits (1+ i))))
|
||||
((eq mark stop))
|
||||
(declare (list mark stop))
|
||||
(with--term (cffc tnpr) mark
|
||||
(with--term
|
||||
(cffc tnpr) mark
|
||||
(setf rslt-mark
|
||||
(setf (cdr rslt-mark)
|
||||
(list (term
|
||||
@ -70,12 +68,6 @@
|
||||
:degr degr
|
||||
:list (rest rslt))))))
|
||||
|
||||
#|
|
||||
(intr-eml (cmbn 3 1 (tnpr 0 'a 3 'b) 2 (tnpr 2 'a 1 'b) 3 (tnpr 2 'aa 1 'bb) 4 (tnpr 3 'a 0 'b)))
|
||||
(intr-eml (cmbn 3 1 (tnpr 1 'c 2 'd) 10 (tnpr 2 'a 1 'b)))
|
||||
(intr-eml (cmbn 3 10 (tnpr 1 'c 2 'd) 1 (tnpr 2 'a 1 'b) 100 (tnpr 2 'aa 1 'bb)))
|
||||
(intr-eml (cmbn 3 10 (tnpr 1 'c 2 'd) 100 (tnpr 1 'cc 2 'dd) 1 (tnpr 2 'a 1 'b)))
|
||||
|#
|
||||
|
||||
(DEFUN EML (smst1 smst2)
|
||||
(build-mrph
|
||||
@ -86,12 +78,6 @@
|
||||
:strt :cmbn
|
||||
:orgn `(eml ,smst1 ,smst2)))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf d (delta-infinity))
|
||||
(setf eml (eml d d))
|
||||
(? eml (cmbn 3 1 (tnpr 0 1 3 30) 10 (tnpr 1 3 2 28) 100 (tnpr 2 7 1 24) 1000 (tnpr 3 15 0 16)))
|
||||
|#
|
||||
|
||||
(DEFUN INTR-PHI (smst1 smst2
|
||||
&aux (crts-prdc (crts-prdc smst1 smst2))
|
||||
@ -123,12 +109,14 @@
|
||||
(setf (aref array-pq p q) (zero-cmbn i))))
|
||||
(dolist (term (cmbn-list cmbn))
|
||||
(declare (type term term))
|
||||
(with-term (cffc crpr) term
|
||||
(with-term
|
||||
(cffc crpr) term
|
||||
(let ((absm1 (absm1 crpr))
|
||||
(absm2 (absm2 crpr)))
|
||||
(declare (type absm absm1 absm2))
|
||||
(do ((n-alpha n (1- n-alpha))
|
||||
(left-d absm1 (a-face4 face1 n-alpha n-alpha left-d)))
|
||||
(left-d absm1 (a-face4 face1 n-alpha n-alpha
|
||||
left-d)))
|
||||
((zerop n-alpha))
|
||||
(declare
|
||||
(fixnum n-alpha)
|
||||
@ -137,7 +125,8 @@
|
||||
(i n-alpha (1- i)) ;; pseudo-degree
|
||||
(sign (-1-expt-n n-alpha) (- sign))
|
||||
(right-d absm2
|
||||
(a-face4 face2 (1- i) dim-right-d right-d))
|
||||
(a-face4 face2 (1- i) dim-right-d
|
||||
right-d))
|
||||
(dim-right-d n (1- dim-right-d)))
|
||||
((= beta n-alpha))
|
||||
(declare
|
||||
@ -145,8 +134,10 @@
|
||||
(type absm right-d))
|
||||
(let ((absm1 (1dgnr (1- i) left-d)))
|
||||
(declare (type absm absm1))
|
||||
(with-absm (dgop1 gmsm1) absm1
|
||||
(with-absm (dgop2 gmsm2) right-d
|
||||
(with-absm
|
||||
(dgop1 gmsm1) absm1
|
||||
(with-absm
|
||||
(dgop2 gmsm2) right-d
|
||||
(or (> (integer-length dgop1) i)
|
||||
(> (integer-length dgop2) i)
|
||||
(plusp (logand dgop1 dgop2))
|
||||
@ -154,26 +145,20 @@
|
||||
cmpr
|
||||
(* sign cffc)
|
||||
(crpr dgop1 gmsm1 dgop2 gmsm2)
|
||||
(aref array-pq (1+ n-alpha) (- n beta))))))))))))
|
||||
(aref array-pq (1+ n-alpha)
|
||||
(- n beta))))))))))))
|
||||
;; array-pq))) ;; in case of debugging
|
||||
(intr-phi-2 array-pq cmpr)
|
||||
))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf d (delta-infinity))
|
||||
(setf rslt (intr-phi d d))
|
||||
(funcall rslt (cmbn 3 1 (crpr 0 15 0 15)))
|
||||
|#
|
||||
|
||||
#|
|
||||
|
||||
(DEFUN INTR-PHI-22 (array-pq cmpr)
|
||||
(declare
|
||||
(type (simple-array cmbn (* *)) array-pq)
|
||||
(type cmprf cmpr))
|
||||
; (format t " -22- ")
|
||||
; (format t " -22- ") ;
|
||||
(the cmbn
|
||||
(let* ((n+1 (1- (array-dimension array-pq 0)))
|
||||
(n (1- n+1)))
|
||||
@ -226,7 +211,7 @@
|
||||
(declare
|
||||
(type (simple-array cmbn (* *)) array-pq)
|
||||
(type cmprf cmpr))
|
||||
; (format t " -2- ")
|
||||
; (format t " -2- ")
|
||||
(the cmbn
|
||||
(let* ((n+1 (1- (array-dimension array-pq 0)))
|
||||
(n (1- n+1))
|
||||
@ -261,27 +246,22 @@
|
||||
(declare (fixnum q sign dgop1-ashed dgop2-ashed))
|
||||
(dolist (term (cmbn-list (aref array-pq p q)))
|
||||
(declare (type term term))
|
||||
(with-term (cffc crpr) term
|
||||
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
|
||||
(with-term
|
||||
(cffc crpr) term
|
||||
(with-crpr
|
||||
(dgop1 gmsm1 dgop2 gmsm2) crpr
|
||||
(setf cmbn-i-tail
|
||||
(setf (cdr cmbn-i-tail)
|
||||
(list (term (* sign cffc)
|
||||
(crpr
|
||||
(+ dgop1 dgop1-ashed) gmsm1
|
||||
(+ dgop1 dgop1-ashed)
|
||||
gmsm1
|
||||
(+ dgop2 dgop2-ashed)
|
||||
gmsm2))))))))))))))
|
||||
(if cmbn-list
|
||||
(apply #'ncmbn-add cmpr cmbn-list)
|
||||
(zero-cmbn n+1)))))
|
||||
|
||||
#|
|
||||
(setf d (delta-infinity))
|
||||
(setf rslt (intr-phi d d))
|
||||
(funcall rslt (cmbn 3 1 (crpr 0 15 0 15)))
|
||||
(funcall rslt (cmbn 2 1 (crpr 0 7 0 7)))
|
||||
(funcall rslt (cmbn 1 1 (crpr 0 3 0 3)))
|
||||
(funcall rslt (cmbn 0 1 (crpr 0 1 0 1)))
|
||||
|#
|
||||
|
||||
(DEFUN PHI (smst1 smst2)
|
||||
(declare (type simplicial-set smst1 smst2))
|
||||
@ -294,36 +274,6 @@
|
||||
:strt :cmbn
|
||||
:orgn `(phi ,smst1 ,smst2))))
|
||||
|
||||
#|
|
||||
(setf phi (phi (delta-infinity) (delta-infinity)))
|
||||
(? phi 3 (crpr 0 15 0 15))
|
||||
|#
|
||||
|
||||
#| ;; Comparison with EAT.
|
||||
;; In Kenzo.
|
||||
(cat-init)
|
||||
(setf s (sphere 5))
|
||||
(setf p (crts-prdc s s))
|
||||
(setf b (basis p 8))
|
||||
(setf c (make-cmbn :degr 8
|
||||
:list (mapcar #'(lambda (item)
|
||||
(term (1+ (random 5)) item))
|
||||
b)))
|
||||
(setf phi (phi s s))
|
||||
(time (? phi c)))
|
||||
|#
|
||||
|
||||
#| ;; in EAT
|
||||
(setf s (sphere 5))
|
||||
(setf p (cpr-2ss s s))
|
||||
(setf b (sbs p 8))
|
||||
(setf c (make-cmb :dgr 8
|
||||
:lst (mapcar #'(lambda (item)
|
||||
(mnm (1+ (random 5)) item))
|
||||
b)))
|
||||
(setf phi (phi s s))
|
||||
(time (??? phi c))
|
||||
|#
|
||||
|
||||
(DEFUN INTR-AW (face1 face2)
|
||||
(declare (type face face1 face2))
|
||||
@ -371,14 +321,6 @@
|
||||
:list rslt)))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
#|
|
||||
(setf r (intr-aw #'delta-face #'delta-face))
|
||||
(funcall r 3 (crpr 0 15 0 15))
|
||||
(setf s (sphere 3))
|
||||
(setf f (face s))
|
||||
(setf r (intr-aw f f))
|
||||
(funcall r 3 (crpr 0 's3 0 's3))
|
||||
|#
|
||||
|
||||
(DEFUN AW (smst1 smst2
|
||||
&aux (crts-prdc (crts-prdc smst1 smst2))
|
||||
@ -397,10 +339,6 @@
|
||||
:strt :gnrt
|
||||
:orgn `(aw ,smst1 ,smst2))))
|
||||
|
||||
#|
|
||||
(setf aw (aw (delta-infinity) (delta-infinity)))
|
||||
(? aw (cmbn 3 1 (crpr 0 15 0 30) -1 (crpr 0 23 0 29)))
|
||||
|#
|
||||
|
||||
(DEFUN EZ (smst1 smst2)
|
||||
(declare (type simplicial-set smst1 smst2))
|
||||
@ -411,51 +349,6 @@
|
||||
:h (phi smst1 smst2)
|
||||
:orgn `(eilenberg-zilber ,smst1 ,smst2))))
|
||||
|
||||
#|
|
||||
(setf ez (ez (delta-infinity) (delta-infinity)))
|
||||
(setf *bc* (cmbn 3 1 (tnpr 0 1 3 30)
|
||||
10 (tnpr 1 96 2 896)
|
||||
100 (tnpr 2 7168 1 3)
|
||||
1000 (tnpr 3 15 0 4096)))
|
||||
(setf *tc* (cmbn 3 1 (crpr 0 15 0 480)
|
||||
100 (crpr 0 15 5 96)
|
||||
10 (crpr 6 3 0 480)
|
||||
1000 (crpr 6 3 1 224)))
|
||||
(pre-check-rdct ez)
|
||||
(check-rdct)
|
||||
|#
|
||||
|
||||
|
||||
#|
|
||||
;; Comparison EAT.
|
||||
;; In Kenzo.
|
||||
(cat-init)
|
||||
(setf s (sphere 5))
|
||||
(setf ez (ez s s))
|
||||
(setf b (basis (tcc ez) 8))
|
||||
(setf c (make-cmbn :degr 8
|
||||
:list (mapcar #'(lambda (item)
|
||||
(term (1+ (random 5)) item))
|
||||
b)))
|
||||
(pre-check-rdct ez)
|
||||
(setf +too-much-time+ -1)
|
||||
(time (? *id-gf-dh-hd* c))
|
||||
(time (? *id-gf-dh-hd* c))
|
||||
|#
|
||||
|
||||
#|
|
||||
;; in EAT
|
||||
(setf s (sphere 5))
|
||||
(setf ez (ez s s))
|
||||
(setf b (cbs (rdc-tcc ez) 8))
|
||||
(setf c (make-cmb :dgr 8
|
||||
:lst (mapcar #'(lambda (item)
|
||||
(mnm (1+ (random 5)) item))
|
||||
b)))
|
||||
(verif-rdc ez)
|
||||
(time (??? *id-gf-dh-hd* c))
|
||||
(time (??? *id-gf-dh-hd* c))
|
||||
|#
|
||||
|
||||
(DEFUN LEFT-CRTS-PRDC-EFHM (smst1 smst2)
|
||||
(declare (type simplicial-set smst1 smst2))
|
||||
@ -464,6 +357,7 @@
|
||||
:lrdct (trivial-rdct (crts-prdc smst1 smst2))
|
||||
:rrdct (ez smst1 smst2))))
|
||||
|
||||
|
||||
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'crts-prdc)))
|
||||
(declare (type simplicial-set smst))
|
||||
(the homotopy-equivalence
|
||||
@ -471,10 +365,3 @@
|
||||
(left-crts-prdc-efhm (second (orgn smst)) (third (orgn smst)))
|
||||
(tnsr-prdc (efhm (second (orgn smst)))
|
||||
(efhm (third (orgn smst)))))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf k (k-z 2))
|
||||
(setf k2 (crts-prdc k k))
|
||||
(homology k2 0 10)
|
||||
|#
|
||||
|
||||
120
test/eilenberg-zilber-test.lisp
Normal file
120
test/eilenberg-zilber-test.lisp
Normal file
@ -0,0 +1,120 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
|
||||
(test shuffle-sign
|
||||
(dotimes (i 30)
|
||||
(format t "~%~A => ~@D" (cat:hyphenize-list (cat:dlop-int-ext i))
|
||||
(cat:shuffle-sign i))))
|
||||
|
||||
|
||||
(test intr-eml
|
||||
(cat:intr-eml (cat:cmbn 3 1 (cat:tnpr 0 'a 3 'b)
|
||||
2 (cat:tnpr 2 'a 1 'b)
|
||||
3 (cat:tnpr 2 'aa 1 'bb)
|
||||
4 (cat:tnpr 3 'a 0 'b)))
|
||||
(cat:intr-eml (cat:cmbn 3 1 (cat:tnpr 1 'c 2 'd)
|
||||
10 (cat:tnpr 2 'a 1 'b)))
|
||||
(cat:intr-eml (cat:cmbn 3 10 (cat:tnpr 1 'c 2 'd)
|
||||
1 (cat:tnpr 2 'a 1 'b)
|
||||
100 (cat:tnpr 2 'aa 1 'bb)))
|
||||
(cat:intr-eml (cat:cmbn 3 10 (cat:tnpr 1 'c 2 'd)
|
||||
100 (cat:tnpr 1 'cc 2 'dd)
|
||||
1 (cat:tnpr 2 'a 1 'b))))
|
||||
|
||||
|
||||
(test eml
|
||||
(cat:cat-init)
|
||||
(let* ((d (cat:delta-infinity))
|
||||
(eml (cat:eml d d)))
|
||||
(cat:? eml (cat:cmbn 3 1 (cat:tnpr 0 1 3 30)
|
||||
10 (cat:tnpr 1 3 2 28)
|
||||
100 (cat:tnpr 2 7 1 24)
|
||||
1000 (cat:tnpr 3 15 0 16)))))
|
||||
|
||||
|
||||
(test intr-phi
|
||||
(cat:cat-init)
|
||||
(let* ((d (cat:delta-infinity))
|
||||
(rslt (cat:intr-phi d d)))
|
||||
(funcall rslt (cat:cmbn 3 1 (cat:crpr 0 15 0 15)))
|
||||
(funcall rslt (cat:cmbn 2 1 (cat:crpr 0 7 0 7)))
|
||||
(funcall rslt (cat:cmbn 1 1 (cat:crpr 0 3 0 3)))
|
||||
(funcall rslt (cat:cmbn 0 1 (cat:crpr 0 1 0 1)))))
|
||||
|
||||
|
||||
(test phi
|
||||
(cat:cat-init)
|
||||
(let ((phi (cat:phi (cat:delta-infinity) (cat:delta-infinity))))
|
||||
(cat:? phi 3 (cat:crpr 0 15 0 15))))
|
||||
|
||||
|
||||
(test eat
|
||||
(cat:cat-init)
|
||||
(let* ((s (cat:sphere 5))
|
||||
(p (cat:crts-prdc s s))
|
||||
(b (cat:basis p 8))
|
||||
(c (cat:make-cmbn :degr 8
|
||||
:list (mapcar #'(lambda (item)
|
||||
(cat:term (1+ (random 5))
|
||||
item))
|
||||
b)))
|
||||
(phi (cat:phi s s)))
|
||||
(time (cat:? phi c))))
|
||||
|
||||
|
||||
(test intr-aw
|
||||
(cat:cat-init)
|
||||
(let* ((r (cat:intr-aw #'cat:delta-face #'cat:delta-face))
|
||||
(s (cat:sphere 3))
|
||||
(f (cat:face s)))
|
||||
(funcall r 3 (cat:crpr 0 15 0 15))
|
||||
(setf r (cat:intr-aw f f))
|
||||
(funcall r 3 (cat:crpr 0 's3 0 's3))))
|
||||
|
||||
|
||||
(test aw
|
||||
(cat:cat-init)
|
||||
(let ((aw (cat:aw (cat:delta-infinity) (cat:delta-infinity))))
|
||||
(cat:? aw (cat:cmbn 3 1 (cat:crpr 0 15 0 30)
|
||||
-1 (cat:crpr 0 23 0 29)))))
|
||||
|
||||
|
||||
(test ez
|
||||
(cat:cat-init)
|
||||
(let ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity))))
|
||||
(setf cat:*bc* (cat:cmbn 3 1 (cat:tnpr 0 1 3 30)
|
||||
10 (cat:tnpr 1 96 2 896)
|
||||
100 (cat:tnpr 2 7168 1 3)
|
||||
1000 (cat:tnpr 3 15 0 4096)))
|
||||
(setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 15 0 480)
|
||||
100 (cat:crpr 0 15 5 96)
|
||||
10 (cat:crpr 6 3 0 480)
|
||||
1000 (cat:crpr 6 3 1 224)))
|
||||
(cat:pre-check-rdct ez)
|
||||
(check-rdct)))
|
||||
|
||||
|
||||
(test eat1
|
||||
(cat:cat-init)
|
||||
(let* ((s (cat:sphere 5))
|
||||
(ez (cat:ez s s))
|
||||
(b (cat:basis (cat:tcc ez) 8))
|
||||
(c (cat:make-cmbn :degr 8
|
||||
:list (mapcar #'(lambda (item)
|
||||
(cat:term (1+ (random 5))
|
||||
item))
|
||||
b))))
|
||||
(cat:pre-check-rdct ez)
|
||||
(setf cat:+too-much-time+ -1)
|
||||
(time (cat:? cat:*id-gf-dh-hd* c))
|
||||
(time (cat:? cat:*id-gf-dh-hd* c))))
|
||||
|
||||
|
||||
(test crts-prdc
|
||||
(cat:cat-init)
|
||||
(let* ((k (cat:k-z 2))
|
||||
(k2 (cat:crts-prdc k k)))
|
||||
(cat:homology k2 0 10)))
|
||||
Loading…
Reference in New Issue
Block a user