Extracted tests from fibrations.lisp.
This commit is contained in:
Gerd Heber
parent
a8d9d55b76
commit
f670848a49
@ -28,6 +28,7 @@
|
||||
(:file "disk-pasting-test")
|
||||
(:file "eilenberg-zilber-test")
|
||||
(:file "effective-homology-test")
|
||||
(:file "fibrations-test")
|
||||
(:file "homology-groups-test")
|
||||
(:file "k-pi-n-test")
|
||||
(:file "kan-test")
|
||||
|
||||
@ -27,6 +27,10 @@
|
||||
+ABBREVIATIONS+
|
||||
WHAT-IS
|
||||
|
||||
;; algebras.lisp
|
||||
|
||||
HOPF
|
||||
|
||||
;; bar.lisp
|
||||
|
||||
+NULL-ABAR+
|
||||
|
||||
@ -7,142 +7,107 @@
|
||||
(PROVIDE "fibrations")
|
||||
|
||||
(DEFUN FIBRATION-TOTAL-FACE (fibration
|
||||
&aux (base (sorc fibration))
|
||||
(bface (face base))
|
||||
(fibr (trgt fibration))
|
||||
(fbspn (bspn fibr))
|
||||
(fface (face fibr))
|
||||
(grml (grml fibr))
|
||||
(sintr-grml (sintr grml))
|
||||
(totl (crts-prdc base fibr))
|
||||
(uface (face totl))
|
||||
(sintr-twist (sintr fibration)))
|
||||
&aux (base (sorc fibration))
|
||||
(bface (face base))
|
||||
(fibr (trgt fibration))
|
||||
(fbspn (bspn fibr))
|
||||
(fface (face fibr))
|
||||
(grml (grml fibr))
|
||||
(sintr-grml (sintr grml))
|
||||
(totl (crts-prdc base fibr))
|
||||
(uface (face totl))
|
||||
(sintr-twist (sintr fibration)))
|
||||
(declare
|
||||
(type fibration fibration)
|
||||
(type simplicial-mrph grml)
|
||||
(type simplicial-set base totl)
|
||||
(type simplicial-group fibr)
|
||||
(type gmsm fbspn)
|
||||
(type face bface fface uface)
|
||||
(type sintr sintr-grml sintr-twist))
|
||||
(type fibration fibration)
|
||||
(type simplicial-mrph grml)
|
||||
(type simplicial-set base totl)
|
||||
(type simplicial-group fibr)
|
||||
(type gmsm fbspn)
|
||||
(type face bface fface uface)
|
||||
(type sintr sintr-grml sintr-twist))
|
||||
(flet ((rslt (indx dmns crpr)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type crpr crpr))
|
||||
(the absm
|
||||
(progn
|
||||
(when (< indx dmns)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type crpr crpr))
|
||||
(the absm
|
||||
(progn
|
||||
(when (< indx dmns)
|
||||
(return-from rslt
|
||||
(funcall uface indx dmns crpr)))
|
||||
(with-crpr (b-absm f-absm) crpr
|
||||
(let ((deln-b
|
||||
(a-face4 bface dmns dmns
|
||||
b-absm))
|
||||
(deln-f
|
||||
(a-face4 fface dmns dmns
|
||||
f-absm))
|
||||
(tau-b
|
||||
(tw-a-sintr3 sintr-twist dmns
|
||||
b-absm fbspn)))
|
||||
(declare
|
||||
( type absm deln-b deln-f tau-b))
|
||||
(2absm-acrpr
|
||||
deln-b
|
||||
(a-grml4 sintr-grml (1- dmns)
|
||||
tau-b deln-f))))))))
|
||||
(the face #'rslt)))
|
||||
(funcall uface indx dmns crpr)))
|
||||
(with-crpr (b-absm f-absm) crpr
|
||||
(let ((deln-b
|
||||
(a-face4 bface dmns dmns
|
||||
b-absm))
|
||||
(deln-f
|
||||
(a-face4 fface dmns dmns
|
||||
f-absm))
|
||||
(tau-b
|
||||
(tw-a-sintr3 sintr-twist dmns
|
||||
b-absm fbspn)))
|
||||
(declare
|
||||
( type absm deln-b deln-f tau-b))
|
||||
(2absm-acrpr
|
||||
deln-b
|
||||
(a-grml4 sintr-grml (1- dmns)
|
||||
tau-b deln-f))))))))
|
||||
(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
|
||||
&aux (base (sorc fibration))
|
||||
(fibre (trgt fibration))
|
||||
(untwisted-prdc
|
||||
(crts-prdc base fibre)))
|
||||
&aux (base (sorc fibration))
|
||||
(fibre (trgt fibration))
|
||||
(untwisted-prdc
|
||||
(crts-prdc base fibre)))
|
||||
(declare (type fibration fibration))
|
||||
(the simplicial-set
|
||||
(let ((rslt (build-smst
|
||||
(let ((rslt (build-smst
|
||||
:cmpr (cmpr untwisted-prdc)
|
||||
:basis (basis untwisted-prdc)
|
||||
:bspn (bspn untwisted-prdc)
|
||||
:face (fibration-total-face fibration)
|
||||
:orgn `(fibration-total ,fibration))))
|
||||
(declare (type simplicial-set rslt))
|
||||
(setf (slot-value rslt 'grmd) untwisted-prdc)
|
||||
(when (and (typep base 'kan)
|
||||
(typep fibre 'kan))
|
||||
(change-class rslt 'kan)
|
||||
(setf (slot-value rslt 'kfll)
|
||||
(fibration-kfll fibration)))
|
||||
rslt)))
|
||||
(declare (type simplicial-set rslt))
|
||||
(setf (slot-value rslt 'grmd) untwisted-prdc)
|
||||
(when (and (typep base 'kan)
|
||||
(typep fibre 'kan))
|
||||
(change-class rslt 'kan)
|
||||
(setf (slot-value rslt 'kfll)
|
||||
(fibration-kfll fibration)))
|
||||
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
|
||||
&aux (sintr-twist (sintr twist))
|
||||
(base (sorc twist))
|
||||
(fibre (trgt twist))
|
||||
(fbspn (bspn fibre))
|
||||
(bkfll (kfll base))
|
||||
(fkfll (kfll fibre))
|
||||
(sintr-grml (sintr (grml fibre)))
|
||||
(sintr-grin (sintr (grin fibre))))
|
||||
&aux (sintr-twist (sintr twist))
|
||||
(base (sorc twist))
|
||||
(fibre (trgt twist))
|
||||
(fbspn (bspn fibre))
|
||||
(bkfll (kfll base))
|
||||
(fkfll (kfll fibre))
|
||||
(sintr-grml (sintr (grml fibre)))
|
||||
(sintr-grin (sintr (grin fibre))))
|
||||
(declare
|
||||
(type fibration twist)
|
||||
(type kan base fibre)
|
||||
(type gmsm fbspn)
|
||||
(type kfll bkfll fkfll)
|
||||
(type sintr sintr-grml sintr-grin))
|
||||
(type fibration twist)
|
||||
(type kan base fibre)
|
||||
(type gmsm fbspn)
|
||||
(type kfll bkfll fkfll)
|
||||
(type sintr sintr-grml sintr-grin))
|
||||
(flet ((rslt (indx dmns hat)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(list hat))
|
||||
(fixnum indx dmns)
|
||||
(list hat))
|
||||
(let (bhat fhat)
|
||||
(declare (type list bhat fhat))
|
||||
(do ((mark hat (cdr mark)))
|
||||
((endp mark))
|
||||
(declare (list mark))
|
||||
(let ((absm (car mark)))
|
||||
(declare (type absm absm))
|
||||
(with-absm (dgop crpr) absm
|
||||
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
|
||||
(push (absm (dgop*dgop dgop dgop1) gmsm1) bhat)
|
||||
(push (absm (dgop*dgop dgop dgop2) gmsm2) fhat)))))
|
||||
(declare (list mark))
|
||||
(let ((absm (car mark)))
|
||||
(declare (type absm absm))
|
||||
(with-absm
|
||||
(dgop crpr) absm
|
||||
(with-crpr
|
||||
(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))
|
||||
(let ((bkfll (funcall bkfll indx dmns bhat)))
|
||||
(declare (type absm bkfll))
|
||||
@ -150,36 +115,11 @@
|
||||
(setf (first fhat)
|
||||
(a-grml4 sintr-grml (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))))
|
||||
(setf fhat (nreverse fhat))
|
||||
(let ((fkfll (funcall fkfll indx dmns fhat)))
|
||||
(declare (type absm fkfll))
|
||||
(2absm-acrpr bkfll fkfll))))))
|
||||
(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)))
|
||||
|#
|
||||
(the kfll #'rslt)))
|
||||
|
||||
74
test/fibrations-test.lisp
Normal file
74
test/fibrations-test.lisp
Normal 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)))))
|
||||
|#
|
||||
Loading…
Reference in New Issue
Block a user