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 "eilenberg-zilber-test")
(:file "effective-homology-test")
(:file "fibrations-test")
(:file "homology-groups-test")
(:file "k-pi-n-test")
(:file "kan-test")

4
package.lisp
View File

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

72
src/fibrations.lisp
View File

@ -52,15 +52,6 @@
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))
@ -84,34 +75,6 @@
(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))
@ -139,8 +102,10 @@
(declare (list mark))
(let ((absm (car mark)))
(declare (type absm absm))
(with-absm (dgop crpr) absm
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(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))
@ -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)))
|#

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)))))
|#