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

Extracted Eilenberg-Zilber tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-24 03:27:25 -05:00
parent c921cb9c2b
commit 84004e8556
4 changed files with 425 additions and 407 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
kenzo-test.asd
View File

@ -10,6 +10,7 @@
:components ((:file "package") :components ((:file "package")
(:file "common") (:file "common")
;; === test files === ;; === test files ===
#|
(:file "bar-test") (:file "bar-test")
(:file "bicones-test") (:file "bicones-test")
(:file "cartesian-products-test") (:file "cartesian-products-test")
@ -26,6 +27,9 @@
(:file "delta-test") (:file "delta-test")
(:file "diabolo") (:file "diabolo")
(:file "disk-pasting-test") (:file "disk-pasting-test")
|#
(:file "eilenberg-zilber-test")
#|
(:file "effective-homology-test") (:file "effective-homology-test")
(:file "homology-groups-test") (:file "homology-groups-test")
(:file "k-pi-n-test") (:file "k-pi-n-test")
@ -36,4 +40,5 @@
(:file "simplicial-sets-test") (:file "simplicial-sets-test")
(:file "tensor-products-test") (:file "tensor-products-test")
(:file "various-test") (:file "various-test")
|#
)) ))

6
package.lisp
View File

@ -264,7 +264,13 @@
;; eilenberg-zilber.lisp ;; eilenberg-zilber.lisp
AW AW
EML
EZ EZ
INTR-AW
INTR-EML
INTR-PHI
PHI
SHUFFLE-SIGN
;; fibrations.lisp ;; fibrations.lisp

699
src/eilenberg-zilber.lisp
View File

@ -7,474 +7,361 @@
(PROVIDE "eilenberg-zilber") (PROVIDE "eilenberg-zilber")
(DEFUN SHUFFLE-SIGN (dgop) (DEFUN SHUFFLE-SIGN (dgop)
(declare (fixnum dgop)) (declare (fixnum dgop))
(the fixnum (the fixnum
(do ((rslt +1) (do ((rslt +1)
(bit-position (- (integer-length dgop) 2) (1- bit-position)) (bit-position (- (integer-length dgop) 2) (1- bit-position))
(factor -1)) (factor -1))
((minusp bit-position) rslt) ((minusp bit-position) rslt)
(declare (fixnum rslt bit-position factor)) (declare (fixnum rslt bit-position factor))
(if (logbitp bit-position dgop) (if (logbitp bit-position dgop)
(setf factor (- factor)) (setf factor (- factor))
(setf rslt (* rslt 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) (DEFUN INTR-EML (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(when (cmbn-zero-p cmbn) (when (cmbn-zero-p cmbn)
(return-from intr-eml cmbn)) (return-from intr-eml cmbn))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn
(let* ((limits (make-array (+ degr 2))) (degr list) cmbn
(rslt (list nil)) (let* ((limits (make-array (+ degr 2)))
(rslt-mark rslt) (rslt (list nil))
(mask (mask degr))) (rslt-mark rslt)
(declare (mask (mask degr)))
(simple-vector limits) (declare
(list rslt rslt-mark) (simple-vector limits)
(fixnum mask)) (list rslt rslt-mark)
(do ((mark list (member i mark (fixnum mask))
:test #'< (do ((mark list (member i mark
:key #'(lambda (term) :test #'<
(declare (type term term)) :key #'(lambda (term)
(degr1 (gnrt term))))) (declare (type term term))
(i 0 (1+ i))) (degr1 (gnrt term)))))
((> i degr) (setf (svref limits i) nil)) (i 0 (1+ i)))
(declare ((> i degr) (setf (svref limits i) nil))
(list mark) (declare
(fixnum i)) (list mark)
(setf (svref limits i) mark)) (fixnum i))
(dotimes (dgop1 (1+ mask)) (setf (svref limits i) mark))
(declare (fixnum dgop1)) (dotimes (dgop1 (1+ mask))
(let* ((i (- degr (logcount dgop1))) (declare (fixnum dgop1))
(dgop2 (- mask dgop1)) (let* ((i (- degr (logcount dgop1)))
(sign (shuffle-sign dgop2))) (dgop2 (- mask dgop1))
(declare (fixnum i dgop2 sign)) (sign (shuffle-sign dgop2)))
(do ((mark (svref limits i) (cdr mark)) (declare (fixnum i dgop2 sign))
(stop (svref limits (1+ i)))) (do ((mark (svref limits i) (cdr mark))
((eq mark stop)) (stop (svref limits (1+ i))))
(declare (list mark stop)) ((eq mark stop))
(with--term (cffc tnpr) mark (declare (list mark stop))
(setf rslt-mark (with--term
(setf (cdr rslt-mark) (cffc tnpr) mark
(list (term (setf rslt-mark
(* sign cffc) (setf (cdr rslt-mark)
(crpr (list (term
dgop1 (gnrt1 tnpr) (* sign cffc)
dgop2 (gnrt2 tnpr)))))))))) (crpr
(make-cmbn dgop1 (gnrt1 tnpr)
:degr degr dgop2 (gnrt2 tnpr))))))))))
:list (rest rslt)))))) (make-cmbn
: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) (DEFUN EML (smst1 smst2)
(build-mrph (build-mrph
:sorc (tnsr-prdc smst1 smst2) :sorc (tnsr-prdc smst1 smst2)
:trgt (crts-prdc smst1 smst2) :trgt (crts-prdc smst1 smst2)
:degr 0 :degr 0
:intr #'intr-eml :intr #'intr-eml
:strt :cmbn :strt :cmbn
:orgn `(eml ,smst1 ,smst2))) :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 (DEFUN INTR-PHI (smst1 smst2
&aux (crts-prdc (crts-prdc smst1 smst2)) &aux (crts-prdc (crts-prdc smst1 smst2))
(cmpr (cmpr crts-prdc)) (cmpr (cmpr crts-prdc))
(face1 (face smst1)) (face1 (face smst1))
(face2 (face smst2))) (face2 (face smst2)))
(declare (declare
(type simplicial-set smst1 smst2 crts-prdc) (type simplicial-set smst1 smst2 crts-prdc)
(type cmprf cmpr) (type cmprf cmpr)
(type face face1 face2)) (type face face1 face2))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(when (cmbn-zero-p cmbn) (when (cmbn-zero-p cmbn)
(return-from rslt (zero-cmbn (1+ (cmbn-degr cmbn))))) (return-from rslt (zero-cmbn (1+ (cmbn-degr cmbn)))))
(the cmbn (the cmbn
(let* ((n (cmbn-degr cmbn)) (let* ((n (cmbn-degr cmbn))
(n+1 (1+ n)) (n+1 (1+ n))
(array-pq (make-array (list (1+ n+1) (1+ n+1))))) (array-pq (make-array (list (1+ n+1) (1+ n+1)))))
(declare (declare
(fixnum n n+1) (fixnum n n+1)
(simple-array array-pq)) (simple-array array-pq))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((> i n+1)) ((> i n+1))
(declare (fixnum i)) (declare (fixnum i))
(do ((p i (1+ p)) (do ((p i (1+ p))
(q n+1 (1- q))) (q n+1 (1- q)))
((> p n+1)) ((> p n+1))
(declare (fixnum p q)) (declare (fixnum p q))
(setf (aref array-pq p q) (zero-cmbn i)))) (setf (aref array-pq p q) (zero-cmbn i))))
(dolist (term (cmbn-list cmbn)) (dolist (term (cmbn-list cmbn))
(declare (type term term)) (declare (type term term))
(with-term (cffc crpr) term (with-term
(let ((absm1 (absm1 crpr)) (cffc crpr) term
(absm2 (absm2 crpr))) (let ((absm1 (absm1 crpr))
(declare (type absm absm1 absm2)) (absm2 (absm2 crpr)))
(do ((n-alpha n (1- n-alpha)) (declare (type absm absm1 absm2))
(left-d absm1 (a-face4 face1 n-alpha n-alpha left-d))) (do ((n-alpha n (1- n-alpha))
((zerop n-alpha)) (left-d absm1 (a-face4 face1 n-alpha n-alpha
(declare left-d)))
(fixnum n-alpha) ((zerop n-alpha))
(type absm left-d)) (declare
(do ((beta 0 (1+ beta)) (fixnum n-alpha)
(i n-alpha (1- i)) ;; pseudo-degree (type absm left-d))
(sign (-1-expt-n n-alpha) (- sign)) (do ((beta 0 (1+ beta))
(right-d absm2 (i n-alpha (1- i)) ;; pseudo-degree
(a-face4 face2 (1- i) dim-right-d right-d)) (sign (-1-expt-n n-alpha) (- sign))
(dim-right-d n (1- dim-right-d))) (right-d absm2
((= beta n-alpha)) (a-face4 face2 (1- i) dim-right-d
(declare right-d))
(fixnum beta i sign dim-right-d) (dim-right-d n (1- dim-right-d)))
(type absm right-d)) ((= beta n-alpha))
(let ((absm1 (1dgnr (1- i) left-d))) (declare
(declare (type absm absm1)) (fixnum beta i sign dim-right-d)
(with-absm (dgop1 gmsm1) absm1 (type absm right-d))
(with-absm (dgop2 gmsm2) right-d (let ((absm1 (1dgnr (1- i) left-d)))
(or (> (integer-length dgop1) i) (declare (type absm absm1))
(> (integer-length dgop2) i) (with-absm
(plusp (logand dgop1 dgop2)) (dgop1 gmsm1) absm1
(dstr-add-term-to-cmbn (with-absm
cmpr (dgop2 gmsm2) right-d
(* sign cffc) (or (> (integer-length dgop1) i)
(crpr dgop1 gmsm1 dgop2 gmsm2) (> (integer-length dgop2) i)
(aref array-pq (1+ n-alpha) (- n beta)))))))))))) (plusp (logand dgop1 dgop2))
(dstr-add-term-to-cmbn
cmpr
(* sign cffc)
(crpr dgop1 gmsm1 dgop2 gmsm2)
(aref array-pq (1+ n-alpha)
(- n beta))))))))))))
;; array-pq))) ;; in case of debugging ;; array-pq))) ;; in case of debugging
(intr-phi-2 array-pq cmpr) (intr-phi-2 array-pq cmpr)
)))) ))))
(the intr-mrph #'rslt))) (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) (DEFUN INTR-PHI-22 (array-pq cmpr)
(declare (declare
(type (simple-array cmbn (* *)) array-pq) (type (simple-array cmbn (* *)) array-pq)
(type cmprf cmpr)) (type cmprf cmpr))
; (format t " -22- ") ; (format t " -22- ") ;
(the cmbn (the cmbn
(let* ((n+1 (1- (array-dimension array-pq 0))) (let* ((n+1 (1- (array-dimension array-pq 0)))
(n (1- n+1))) (n (1- n+1)))
(declare (fixnum n n+1)) (declare (fixnum n n+1))
(flet ((step-i (i) (flet ((step-i (i)
(declare (fixnum i)) (declare (fixnum i))
(do ((p (1+ i) (1+ p)) (do ((p (1+ i) (1+ p))
(p-1 i p) (p-1 i p)
(q n+1 q-1) (q n+1 q-1)
(q-1 n (1- q-1)) (q-1 n (1- q-1))
(sign t (not sign)) (sign t (not sign))
(ibit (2-exp i))) (ibit (2-exp i)))
((> p n+1)) ((> p n+1))
(declare (declare
(fixnum p p-1 q q-1 ibit) (fixnum p p-1 q q-1 ibit)
(type boolean sign)) (type boolean sign))
(setf (aref array-pq p q) (setf (aref array-pq p q)
(2cmbn-add cmpr (2cmbn-add cmpr
(aref array-pq p q) (aref array-pq p q)
(make-cmbn (make-cmbn
:degr (1+ i) :degr (1+ i)
:list (nconc :list (nconc
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc crpr) term (with-term (cffc crpr) term
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(term cffc (crpr (term cffc (crpr
dgop1 gmsm1 dgop1 gmsm1
(+ ibit dgop2) gmsm2))))) (+ ibit dgop2) gmsm2)))))
(cmbn-list (aref array-pq p q-1))) (cmbn-list (aref array-pq p q-1)))
(let ((list (cmbn-list (aref array-pq p-1 q)))) (let ((list (cmbn-list (aref array-pq p-1 q))))
(declare (list lst)) (declare (list lst))
(unless sign (unless sign
(dolist (term list) (dolist (term list)
(declare (type term term)) (declare (type term term))
(setf (cffc term) (- (cffc term))))) (setf (cffc term) (- (cffc term)))))
(dolist (term list) (dolist (term list)
(declare (type term term)) (declare (type term term))
(incf (dgop1 (gnrt term)) ibit)) (incf (dgop1 (gnrt term)) ibit))
list)))))))) list))))))))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((= i n+1)) ((= i n+1))
(declare (type fixnum i)) (declare (type fixnum i))
(step-i i)) (step-i i))
(aref array-pq n+1 n+1))))) (aref array-pq n+1 n+1)))))
|# |#
(DEFUN INTR-PHI-2 (array-pq cmpr) (DEFUN INTR-PHI-2 (array-pq cmpr)
(declare (declare
(type (simple-array cmbn (* *)) array-pq) (type (simple-array cmbn (* *)) array-pq)
(type cmprf cmpr)) (type cmprf cmpr))
; (format t " -2- ") ; (format t " -2- ")
(the cmbn (the cmbn
(let* ((n+1 (1- (array-dimension array-pq 0))) (let* ((n+1 (1- (array-dimension array-pq 0)))
(n (1- n+1)) (n (1- n+1))
(cmbn-list +empty-list+)) (cmbn-list +empty-list+))
(declare (declare
(fixnum n n+1) (fixnum n n+1)
(list cmbn-list)) (list cmbn-list))
(do ((i 1 (1+ i)) (do ((i 1 (1+ i))
(cmbn-i (list nil) (list nil)) (cmbn-i (list nil) (list nil))
(mask (mask n) (ash mask -1))) (mask (mask n) (ash mask -1)))
((= i n+1)) ((= i n+1))
(declare (declare
(fixnum i mask) (fixnum i mask)
(list cmbn-i)) (list cmbn-i))
(let ((cmbn-i-tail cmbn-i)) (let ((cmbn-i-tail cmbn-i))
(declare (list cmbn-i-tail)) (declare (list cmbn-i-tail))
(do ((dgop1 0 (1+ dgop1))) (do ((dgop1 0 (1+ dgop1)))
((> dgop1 mask) ((> dgop1 mask)
(push (make-cmbn (push (make-cmbn
:degr n+1 :degr n+1
:list (rest cmbn-i)) :list (rest cmbn-i))
cmbn-list)) cmbn-list))
(declare (fixnum dgop1)) (declare (fixnum dgop1))
(let ((p (- n+1 (logcount dgop1))) (let ((p (- n+1 (logcount dgop1)))
(dgop2 (- mask dgop1))) (dgop2 (- mask dgop1)))
(declare (fixnum p dgop2)) (declare (fixnum p dgop2))
(unless (= p i) (unless (= p i)
(let ((q (- (+ n+1 i) p)) (let ((q (- (+ n+1 i) p))
(sign (shuffle-sign dgop2)) (sign (shuffle-sign dgop2))
(dgop1-ashed (ash dgop1 i)) (dgop1-ashed (ash dgop1 i))
(dgop2-ashed (ash dgop2 i))) (dgop2-ashed (ash dgop2 i)))
(declare (fixnum q sign dgop1-ashed dgop2-ashed)) (declare (fixnum q sign dgop1-ashed dgop2-ashed))
(dolist (term (cmbn-list (aref array-pq p q))) (dolist (term (cmbn-list (aref array-pq p q)))
(declare (type term term)) (declare (type term term))
(with-term (cffc crpr) term (with-term
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (cffc crpr) term
(setf cmbn-i-tail (with-crpr
(setf (cdr cmbn-i-tail) (dgop1 gmsm1 dgop2 gmsm2) crpr
(list (term (* sign cffc) (setf cmbn-i-tail
(crpr (setf (cdr cmbn-i-tail)
(+ dgop1 dgop1-ashed) gmsm1 (list (term (* sign cffc)
(+ dgop2 dgop2-ashed) (crpr
gmsm2)))))))))))))) (+ dgop1 dgop1-ashed)
gmsm1
(+ dgop2 dgop2-ashed)
gmsm2))))))))))))))
(if cmbn-list (if cmbn-list
(apply #'ncmbn-add cmpr cmbn-list) (apply #'ncmbn-add cmpr cmbn-list)
(zero-cmbn n+1))))) (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) (DEFUN PHI (smst1 smst2)
(declare (type simplicial-set smst1 smst2)) (declare (type simplicial-set smst1 smst2))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc (crts-prdc smst1 smst2) :sorc (crts-prdc smst1 smst2)
:trgt (crts-prdc smst1 smst2) :trgt (crts-prdc smst1 smst2)
:degr +1 :degr +1
:intr (intr-phi smst1 smst2) :intr (intr-phi smst1 smst2)
:strt :cmbn :strt :cmbn
:orgn `(phi ,smst1 ,smst2)))) :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) (DEFUN INTR-AW (face1 face2)
(declare (type face face1 face2)) (declare (type face face1 face2))
(flet ((rslt (dmns crpr) (flet ((rslt (dmns crpr)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type crpr crpr)) (type crpr crpr))
(the cmbn (the cmbn
(let ((absm1 (absm1 crpr)) (let ((absm1 (absm1 crpr))
(absm2 (absm2 crpr)) (absm2 (absm2 crpr))
(rslt +empty-list+) (rslt +empty-list+)
(del-0-s +empty-list+)) (del-0-s +empty-list+))
(declare (declare
(type absm absm1 absm2) (type absm absm1 absm2)
(list rslt del-0-s)) (list rslt del-0-s))
(do ((face absm2 (a-face4 face2 0 dmns2 face)) (do ((face absm2 (a-face4 face2 0 dmns2 face))
(dmns2 dmns (1- dmns2))) (dmns2 dmns (1- dmns2)))
((zerop dmns2) (push face del-0-s)) ((zerop dmns2) (push face del-0-s))
(declare (declare
(type absm face) (type absm face)
(fixnum dmns)) (fixnum dmns))
(push face del-0-s)) (push face del-0-s))
(do ((face absm1 (a-face4 face1 dmns1 dmns1 face)) (do ((face absm1 (a-face4 face1 dmns1 dmns1 face))
(dmns1 dmns (1- dmns1)) (dmns1 dmns (1- dmns1))
(dmns2 0 (1+ dmns2)) (dmns2 0 (1+ dmns2))
(mark del-0-s (cdr mark))) (mark del-0-s (cdr mark)))
((zerop dmns1) ((zerop dmns1)
(unless (degenerate-p absm2) (unless (degenerate-p absm2)
(push (push
(term 1 (term 1
(tnpr 0 (gmsm face) dmns (gmsm absm2))) (tnpr 0 (gmsm face) dmns (gmsm absm2)))
rslt))) rslt)))
(declare (declare
(type absm face) (type absm face)
(fixnum dmns1 dmns2) (fixnum dmns1 dmns2)
(list mark)) (list mark))
(unless (or (degenerate-p face) (unless (or (degenerate-p face)
(degenerate-p (car mark))) (degenerate-p (car mark)))
(push (push
(term 1 (term 1
(tnpr dmns1 (gmsm face) dmns2 (gmsm (car mark)))) (tnpr dmns1 (gmsm face) dmns2 (gmsm (car mark))))
rslt))) rslt)))
(make-cmbn (make-cmbn
:degr dmns :degr dmns
:list rslt))))) :list rslt)))))
(the intr-mrph #'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 (DEFUN AW (smst1 smst2
&aux (crts-prdc (crts-prdc smst1 smst2)) &aux (crts-prdc (crts-prdc smst1 smst2))
(tnsr-prdc (tnsr-prdc smst1 smst2)) (tnsr-prdc (tnsr-prdc smst1 smst2))
(face1 (face smst1)) (face1 (face smst1))
(face2 (face smst2))) (face2 (face smst2)))
(declare (declare
(type simplicial-set smst1 smst2) (type simplicial-set smst1 smst2)
(type face face1 face2)) (type face face1 face2))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc crts-prdc :sorc crts-prdc
:trgt tnsr-prdc :trgt tnsr-prdc
:degr 0 :degr 0
:intr (intr-aw face1 face2) :intr (intr-aw face1 face2)
:strt :gnrt :strt :gnrt
:orgn `(aw ,smst1 ,smst2)))) :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) (DEFUN EZ (smst1 smst2)
(declare (type simplicial-set smst1 smst2)) (declare (type simplicial-set smst1 smst2))
(the reduction (the reduction
(build-rdct (build-rdct
:f (aw smst1 smst2) :f (aw smst1 smst2)
:g (eml smst1 smst2) :g (eml smst1 smst2)
:h (phi smst1 smst2) :h (phi smst1 smst2)
:orgn `(eilenberg-zilber ,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) (DEFUN LEFT-CRTS-PRDC-EFHM (smst1 smst2)
(declare (type simplicial-set smst1 smst2)) (declare (type simplicial-set smst1 smst2))
(the homotopy-equivalence (the homotopy-equivalence
(build-hmeq (build-hmeq
:lrdct (trivial-rdct (crts-prdc smst1 smst2)) :lrdct (trivial-rdct (crts-prdc smst1 smst2))
:rrdct (ez smst1 smst2)))) :rrdct (ez smst1 smst2))))
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'crts-prdc))) (DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'crts-prdc)))
(declare (type simplicial-set smst)) (declare (type simplicial-set smst))
(the homotopy-equivalence (the homotopy-equivalence
(cmps (cmps
(left-crts-prdc-efhm (second (orgn smst)) (third (orgn smst))) (left-crts-prdc-efhm (second (orgn smst)) (third (orgn smst)))
(tnsr-prdc (efhm (second (orgn smst))) (tnsr-prdc (efhm (second (orgn smst)))
(efhm (third (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
View 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)))