From f670848a496bd96fdb686b44141865900bae30b1 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Fri, 24 Jul 2015 06:59:40 -0500 Subject: [PATCH] Extracted tests from fibrations.lisp. --- kenzo-test.asd | 1 + package.lisp | 4 + src/fibrations.lisp | 224 ++++++++++++++------------------------ test/fibrations-test.lisp | 74 +++++++++++++ 4 files changed, 161 insertions(+), 142 deletions(-) create mode 100644 test/fibrations-test.lisp diff --git a/kenzo-test.asd b/kenzo-test.asd index 1172a20..db499bd 100644 --- a/kenzo-test.asd +++ b/kenzo-test.asd @@ -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") diff --git a/package.lisp b/package.lisp index a0bff36..8cff08c 100644 --- a/package.lisp +++ b/package.lisp @@ -27,6 +27,10 @@ +ABBREVIATIONS+ WHAT-IS + ;; algebras.lisp + + HOPF + ;; bar.lisp +NULL-ABAR+ diff --git a/src/fibrations.lisp b/src/fibrations.lisp index 3898b75..e4303bd 100644 --- a/src/fibrations.lisp +++ b/src/fibrations.lisp @@ -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)) - ( 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))) diff --git a/test/fibrations-test.lisp b/test/fibrations-test.lisp new file mode 100644 index 0000000..085151a --- /dev/null +++ b/test/fibrations-test.lisp @@ -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: 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))))) +|#