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

Extracted tests from fibrations.lisp.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-24 06:59:40 -05:00
parent a8d9d55b76
commit f670848a49
4 changed files with 161 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -28,6 +28,7 @@
(:file "disk-pasting-test") (:file "disk-pasting-test")
(:file "eilenberg-zilber-test") (:file "eilenberg-zilber-test")
(:file "effective-homology-test") (:file "effective-homology-test")
(:file "fibrations-test")
(:file "homology-groups-test") (:file "homology-groups-test")
(:file "k-pi-n-test") (:file "k-pi-n-test")
(:file "kan-test") (:file "kan-test")

4
package.lisp
View File

@ -27,6 +27,10 @@
+ABBREVIATIONS+ +ABBREVIATIONS+
WHAT-IS WHAT-IS
;; algebras.lisp
HOPF
;; bar.lisp ;; bar.lisp
+NULL-ABAR+ +NULL-ABAR+

224
src/fibrations.lisp
View File

@ -7,142 +7,107 @@
(PROVIDE "fibrations") (PROVIDE "fibrations")
(DEFUN FIBRATION-TOTAL-FACE (fibration (DEFUN FIBRATION-TOTAL-FACE (fibration
&aux (base (sorc fibration)) &aux (base (sorc fibration))
(bface (face base)) (bface (face base))
(fibr (trgt fibration)) (fibr (trgt fibration))
(fbspn (bspn fibr)) (fbspn (bspn fibr))
(fface (face fibr)) (fface (face fibr))
(grml (grml fibr)) (grml (grml fibr))
(sintr-grml (sintr grml)) (sintr-grml (sintr grml))
(totl (crts-prdc base fibr)) (totl (crts-prdc base fibr))
(uface (face totl)) (uface (face totl))
(sintr-twist (sintr fibration))) (sintr-twist (sintr fibration)))
(declare (declare
(type fibration fibration) (type fibration fibration)
(type simplicial-mrph grml) (type simplicial-mrph grml)
(type simplicial-set base totl) (type simplicial-set base totl)
(type simplicial-group fibr) (type simplicial-group fibr)
(type gmsm fbspn) (type gmsm fbspn)
(type face bface fface uface) (type face bface fface uface)
(type sintr sintr-grml sintr-twist)) (type sintr sintr-grml sintr-twist))
(flet ((rslt (indx dmns crpr) (flet ((rslt (indx dmns crpr)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type crpr crpr)) (type crpr crpr))
(the absm (the absm
(progn (progn
(when (< indx dmns) (when (< indx dmns)
(return-from rslt (return-from rslt
(funcall uface indx dmns crpr))) (funcall uface indx dmns crpr)))
(with-crpr (b-absm f-absm) crpr (with-crpr (b-absm f-absm) crpr
(let ((deln-b (let ((deln-b
(a-face4 bface dmns dmns (a-face4 bface dmns dmns
b-absm)) b-absm))
(deln-f (deln-f
(a-face4 fface dmns dmns (a-face4 fface dmns dmns
f-absm)) f-absm))
(tau-b (tau-b
(tw-a-sintr3 sintr-twist dmns (tw-a-sintr3 sintr-twist dmns
b-absm fbspn))) b-absm fbspn)))
(declare (declare
( type absm deln-b deln-f tau-b)) ( type absm deln-b deln-f tau-b))
(2absm-acrpr (2absm-acrpr
deln-b deln-b
(a-grml4 sintr-grml (1- dmns) (a-grml4 sintr-grml (1- dmns)
tau-b deln-f)))))))) tau-b deln-f))))))))
(the face #'rslt))) (the face #'rslt)))
#|
(cat-init)
(setf h (hopf 1))
(setf sf (serre-face h))
(funcall sf 0 2 (crpr 0 's2 0 '(2 4)))
(funcall sf 1 2 (crpr 0 's2 0 '(2 4)))
(funcall sf 2 2 (crpr 0 's2 0 '(2 4)))
(funcall sf 3 3 (crpr 1 's2 2 '(2 4)))
|#
(DEFUN FIBRATION-TOTAL (fibration (DEFUN FIBRATION-TOTAL (fibration
&aux (base (sorc fibration)) &aux (base (sorc fibration))
(fibre (trgt fibration)) (fibre (trgt fibration))
(untwisted-prdc (untwisted-prdc
(crts-prdc base fibre))) (crts-prdc base fibre)))
(declare (type fibration fibration)) (declare (type fibration fibration))
(the simplicial-set (the simplicial-set
(let ((rslt (build-smst (let ((rslt (build-smst
:cmpr (cmpr untwisted-prdc) :cmpr (cmpr untwisted-prdc)
:basis (basis untwisted-prdc) :basis (basis untwisted-prdc)
:bspn (bspn untwisted-prdc) :bspn (bspn untwisted-prdc)
:face (fibration-total-face fibration) :face (fibration-total-face fibration)
:orgn `(fibration-total ,fibration)))) :orgn `(fibration-total ,fibration))))
(declare (type simplicial-set rslt)) (declare (type simplicial-set rslt))
(setf (slot-value rslt 'grmd) untwisted-prdc) (setf (slot-value rslt 'grmd) untwisted-prdc)
(when (and (typep base 'kan) (when (and (typep base 'kan)
(typep fibre 'kan)) (typep fibre 'kan))
(change-class rslt 'kan) (change-class rslt 'kan)
(setf (slot-value rslt 'kfll) (setf (slot-value rslt 'kfll)
(fibration-kfll fibration))) (fibration-kfll fibration)))
rslt))) rslt)))
#|
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 (list 1)))
:orgn '(s2-tw-kz1)))
(setf e (fibration-total tw))
(homology e 2)
(homology e 0 8)
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z2-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 1))
:orgn '(s2-tw-kz2)))
(setf e (fibration-total tw))
(homology e 2)
(homology e 0 8)
|#
(DEFUN FIBRATION-KFLL (twist (DEFUN FIBRATION-KFLL (twist
&aux (sintr-twist (sintr twist)) &aux (sintr-twist (sintr twist))
(base (sorc twist)) (base (sorc twist))
(fibre (trgt twist)) (fibre (trgt twist))
(fbspn (bspn fibre)) (fbspn (bspn fibre))
(bkfll (kfll base)) (bkfll (kfll base))
(fkfll (kfll fibre)) (fkfll (kfll fibre))
(sintr-grml (sintr (grml fibre))) (sintr-grml (sintr (grml fibre)))
(sintr-grin (sintr (grin fibre)))) (sintr-grin (sintr (grin fibre))))
(declare (declare
(type fibration twist) (type fibration twist)
(type kan base fibre) (type kan base fibre)
(type gmsm fbspn) (type gmsm fbspn)
(type kfll bkfll fkfll) (type kfll bkfll fkfll)
(type sintr sintr-grml sintr-grin)) (type sintr sintr-grml sintr-grin))
(flet ((rslt (indx dmns hat) (flet ((rslt (indx dmns hat)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(list hat)) (list hat))
(let (bhat fhat) (let (bhat fhat)
(declare (type list bhat fhat)) (declare (type list bhat fhat))
(do ((mark hat (cdr mark))) (do ((mark hat (cdr mark)))
((endp mark)) ((endp mark))
(declare (list mark)) (declare (list mark))
(let ((absm (car mark))) (let ((absm (car mark)))
(declare (type absm absm)) (declare (type absm absm))
(with-absm (dgop crpr) absm (with-absm
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (dgop crpr) absm
(push (absm (dgop*dgop dgop dgop1) gmsm1) bhat) (with-crpr
(push (absm (dgop*dgop dgop dgop2) gmsm2) fhat))))) (dgop1 gmsm1 dgop2 gmsm2) crpr
(push (absm (dgop*dgop dgop dgop1) gmsm1) bhat)
(push (absm (dgop*dgop dgop dgop2) gmsm2) fhat)))))
(setf bhat (nreverse bhat)) (setf bhat (nreverse bhat))
(let ((bkfll (funcall bkfll indx dmns bhat))) (let ((bkfll (funcall bkfll indx dmns bhat)))
(declare (type absm bkfll)) (declare (type absm bkfll))
@ -150,36 +115,11 @@
(setf (first fhat) (setf (first fhat)
(a-grml4 sintr-grml (1- dmns) (a-grml4 sintr-grml (1- dmns)
(a-grin4 sintr-grin (1- dmns) (a-grin4 sintr-grin (1- dmns)
(tw-a-sintr3 sintr-twist dmns bkfll fbspn)) (tw-a-sintr3 sintr-twist dmns bkfll
fbspn))
(first fhat)))) (first fhat))))
(setf fhat (nreverse fhat)) (setf fhat (nreverse fhat))
(let ((fkfll (funcall fkfll indx dmns fhat))) (let ((fkfll (funcall fkfll indx dmns fhat)))
(declare (type absm fkfll)) (declare (type absm fkfll))
(2absm-acrpr bkfll fkfll)))))) (2absm-acrpr bkfll fkfll))))))
(the kfll #'rslt))) (the kfll #'rslt)))
#|
(cat-init)
(load "r-proj-space")
(setf tw (kdivide-z2-twist opr opr-chml-clss))
(setf pr-4 (fibration-total tw))
(setf absm (absm 0 (crpr 0 (loop3 0 5 2) 0 4)))
(setf hat (mapcar #'(lambda (i) (face pr-4 i 4 absm))
(<a-b> 0 4)))
(dotimes (i 5)
(print (kfll pr-4 i 4 (remove (nth i hat) hat)))
(check-kan pr-4 i 4 (remove (nth i hat) hat)))
|#
#|
(cat-init)
(setf os3-fibration os3-fibration)
(setf total (fibration-total os3-fibration))
(setf absm (absm 1 (crpr 0 (loop3 1 's3 1 2 's3 -2)
0 '(-2 1 1))))
(setf hat (mapcar #'(lambda (i) (face total i 4 absm))
'(0 1 2 3 4)))
(dotimes (i 5)
(print (kfll total i 4 (remove (nth i hat) hat)))
(check-kan total i 4 (remove (nth i hat) hat)))
|#

74
test/fibrations-test.lisp Normal file
View File

@ -0,0 +1,74 @@
(in-package :kenzo-test)
(in-suite :kenzo)
#|
(test fibration-total-face
(cat:cat-init)
(let* ((h (cat:hopf 1))
(sf (cat:serre-face h)))
(funcall sf 0 2 (cat:crpr 0 's2 0 '(2 4)))
(funcall sf 1 2 (cat:crpr 0 's2 0 '(2 4)))
(funcall sf 2 2 (cat:crpr 0 's2 0 '(2 4)))
(funcall sf 3 3 (cat:crpr 1 's2 2 '(2 4)))))
|#
(test fibration-total
(cat:cat-init)
(let* ((s2 (cat:sphere 2))
(k (cat:k-z-1))
(tw (cat:build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(cat:absm 0 (list 1)))
:orgn '(s2-tw-kz1)))
(e (cat:fibration-total tw)))
(cat:homology e 2)
(cat:homology e 0 8)))
(test fibration-total1
(cat:cat-init)
(let* ((s2 (cat:sphere 2))
(k (cat:k-z2-1))
(tw (cat:build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(cat:absm 0 1))
:orgn '(s2-tw-kz2)))
(e (cat:fibration-total tw)))
(cat:homology e 2)
(cat:homology e 0 8)))
#|
(test fibration-total2
(cat:cat-init)
(let* ((tw (cat:kdivide-z2-twist opr opr-chml-clss))
(pr-4 (cat:fibration-total tw))
(absm (cat:absm 0 (cat:crpr 0 (cat:loop3 0 5 2) 0 4)))
(hat (mapcar #'(lambda (i) (cat:face pr-4 i 4 absm))
(cat:<a-b> 0 4))))
(dotimes (i 5)
(print (cat:kfll pr-4 i 4 (remove (nth i hat) hat)))
(cat:check-kan pr-4 i 4 (remove (nth i hat) hat)))))
(test fibration-total3
(cat:cat-init)
(let* ((os3-fibration os3-fibration)
(total (cat:fibration-total os3-fibration))
(absm (cat:absm 1 (cat:crpr 0 (cat:loop3 1 's3 1 2 's3 -2)
0 '(-2 1 1))))
(hat (mapcar #'(lambda (i) (cat:face total i 4 absm))
'(0 1 2 3 4))))
(dotimes (i 5)
(print (kfll total i 4 (remove (nth i hat) hat)))
(check-kan total i 4 (remove (nth i hat) hat)))))
|#