Extracted tests from serre.lisp.

kenzo-test.asd

@@ -35,6 +35,7 @@
 	       (:file "loop-spaces-test")
 	       (:file "ls-twisted-products-test")
 	       (:file "searching-homology-test")
+	       (:file "serre-test")
 	       (:file "simplicial-groups-test")
 	       (:file "simplicial-mrphs-test")
 	       (:file "simplicial-sets-test")

package.lisp

@@ -415,6 +415,9 @@
 	   ;; serre.lisp
 
 	   BROWN-REDUCTION
+	   FIBRATION-DTAU-D
+	   FIBRATION-DTAU-D-INTR
+	   RIGHT-SERRE-EFHM
 
 	   ;; simplicial-mrphs.lisp
 

src/serre.lisp

@@ -32,7 +32,8 @@
 	   (unless (plusp dmns)
 	     (return-from rslt
 	       (zero-cmbn dmns-1)))
-               (with-crpr (b-absm f-absm) crpr
+	   (with-crpr
+	       (b-absm f-absm) crpr
 	       (let ((tau-b
 		      (tw-a-sintr3 sintr-twist dmns
 				   b-absm fbspn)))
@@ -55,8 +56,10 @@
 			   (a-grml4 sintr-grml (1- dmns)
 				    tau-b deln-f))))
 		     (declare (type absm acrpr1 acrpr2))
-		      (with-absm (dgop1 crpr1) acrpr1
+		     (with-absm
-		      (with-absm (dgop2 crpr2) acrpr2
+			 (dgop1 crpr1) acrpr1
+			 (with-absm
+			     (dgop2 crpr2) acrpr2
 			     (if (zerop dgop1)
 				 (if (zerop dgop2)
 				     (dstr-add-term-to-cmbn
@@ -75,40 +78,6 @@
 				     (zero-cmbn dmns-1)))))))))))
     (the intr-mrph #'rslt)))
 
-#|
-  (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 dt-d (fibration-dtau-d-intr tw))
-  (funcall dt-d 0 (crpr 0 '* 0 0))
-  (funcall dt-d 3 (crpr 4 's2 0 3))
-  (funcall dt-d 3 (crpr 2 's2 0 3))
-  (funcall dt-d 3 (crpr 2 's2 5 1))
-  (funcall dt-d 2 (crpr 0 's2 0 2))
-  (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-kz)))
-  (setf dt-d (fibration-dtau-d-intr tw))
-  (funcall dt-d 0 (crpr 0 '* 0 nil))
-  (funcall dt-d 3 (crpr 4 's2 0 '(2 3 4)))
-  (funcall dt-d 3 (crpr 2 's2 0 '(2 3 4)))
-  (funcall dt-d 3 (crpr 2 's2 5 '(5)))
-  (funcall dt-d 2 (crpr 0 's2 0 '(3 -2)))
-|#
 
 (DEFUN FIBRATION-DTAU-D (fibration
 			 &aux (base (sorc fibration))
@@ -124,24 +93,6 @@
 	:strt :gnrt
 	:orgn `(fibration-dtau-d ,fibration))))
 
-#|
-  (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-kz)))
-  (setf dt-d (fibration-dtau-d tw))
-  (? dt-d 0 (crpr 0 '* 0 nil))
-  (? dt-d 3 (crpr 4 's2 0 '(2 3 4)))
-  (? dt-d 3 (crpr 2 's2 0 '(2 3 4)))
-  (? dt-d 3 (crpr 2 's2 5 '(5)))
-  (? dt-d 2 (crpr 0 's2 0 '(3 -2)))
-|#
 
 (DEFUN BROWN-REDUCTION (fibration
 		        &aux (base (sorc fibration))
@@ -166,36 +117,6 @@
 	   (dstr-change-sorc-trgt h :new-sorc total :new-trgt total)
 	   (values rslt b-perturbation)))))
 
-#|
-  (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 brown (brown-reduction tw))
-  (setf tcc (tcc brown) bcc (bcc brown))
-  (homology bcc 3)
-  (homology tcc 1 8)
-  (homology bcc 1 8)
-  (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 brown (brown-reduction tw))
-  (homology (tcc brown) 1 5)
-  (homology (bcc brown) 1 5)
-|#
 
 (DEFUN LEFT-SERRE-EFHM (fibration)
   (declare (type fibration fibration))
@@ -204,6 +125,7 @@
         :lrdct (trivial-rdct (fibration-total fibration))
 	:rrdct (brown-reduction fibration))))
 
+
 (DEFUN RIGHT-SERRE-EFHM (fibration
 			 &aux (base (sorc fibration))
 			   (fibre (trgt fibration))
@@ -238,21 +160,6 @@
 	       (dstr-change-sorc-trgt g :new-sorc lbcc)))
 	   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 rh (right-serre-efhm tw))
-  (setf rbcc (rbcc rh))
-  (homology rbcc 0 5)  
-|#
 
 (DEFUN FIBRATION-TOTAL-EFHM (fibration)
   (declare (type fibration fibration))
@@ -260,27 +167,9 @@
        (cmps (left-serre-efhm fibration)
 	     (right-serre-efhm fibration))))
 
+
 (DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'fibration-total)))
   (declare
    (type simplicial-set smst))
   (the homotopy-equivalence
        (fibration-total-efhm (second (orgn smst)))))
-
-#|
-  (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 2)))
-	     :orgn '(s2-tw-kz1)))
-  (setf p3r (fibration-total tw))
-  (homology p3r 1 )
-|#
-
-
-     
-  

test/serre-test.lisp

@@ -0,0 +1,130 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+
+(test fibration-dtau-d-intr
+      (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)))
+	     (dt-d (cat:fibration-dtau-d-intr tw)))
+	(funcall dt-d 0 (cat:crpr 0 '* 0 0))
+	(funcall dt-d 3 (cat:crpr 4 's2 0 3))
+	(funcall dt-d 3 (cat:crpr 2 's2 0 3))
+	(funcall dt-d 3 (cat:crpr 2 's2 5 1))
+	(funcall dt-d 2 (cat:crpr 0 's2 0 2))))
+
+(test fibration-dtau-d-intr1
+      (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-kz)))
+	     (dt-d (cat:fibration-dtau-d-intr tw)))
+	(funcall dt-d 0 (cat:crpr 0 '* 0 nil))
+	(funcall dt-d 3 (cat:crpr 4 's2 0 '(2 3 4)))
+	(funcall dt-d 3 (cat:crpr 2 's2 0 '(2 3 4)))
+	(funcall dt-d 3 (cat:crpr 2 's2 5 '(5)))
+	(funcall dt-d 2 (cat:crpr 0 's2 0 '(3 -2)))))
+
+
+(test fibration-dtau-d
+      (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-kz)))
+	     (dt-d (cat:fibration-dtau-d tw)))
+	(cat:? dt-d 0 (cat:crpr 0 '* 0 nil))
+	(cat:? dt-d 3 (cat:crpr 4 's2 0 '(2 3 4)))
+	(cat:? dt-d 3 (cat:crpr 2 's2 0 '(2 3 4)))
+	(cat:? dt-d 3 (cat:crpr 2 's2 5 '(5)))
+	(cat:? dt-d 2 (cat:crpr 0 's2 0 '(3 -2)))))
+
+
+(test brown-reduction
+      (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)))
+	     (brown (cat:brown-reduction tw))
+	     (tcc (cat:tcc brown))
+	     (bcc (cat:bcc brown)))
+	(cat:homology bcc 3)
+	(cat:homology tcc 1 8)
+	(cat:homology bcc 1 8)))
+
+#|
+(test brown-reduction1
+      (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-kz)))
+	     (brown (cat:brown-reduction tw)))
+	(cat:homology (cat:tcc brown) 1 5)
+	(cat:homology (cat:bcc brown) 1 5)))
+|#
+
+(test right-serre-efhm
+      (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)))
+	     (rh (cat:right-serre-efhm tw))
+	     (rbcc (cat:rbcc rh)))
+	(cat:homology rbcc 0 5)))
+
+
+(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)))
+	     (p3r (cat:fibration-total tw)))
+	(cat:homology p3r 1)))
+
+
+(test dummy
+      (is (not (null t))))