Extracted tests from fibrations.lisp.

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

package.lisp

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

src/fibrations.lisp

@@ -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-absm
-		  (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
+		     (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)))
-|#

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