Formatting updates.

src/cl-space-efhm.lisp

@@ -17,6 +17,7 @@
   (the chain-complex
        (tnsr-prdc clsp-tnsr-smgr bar)))
 
+
 (DEFUN CS-HAT-RIGHT-PERTURBATION-INTR (smgr)
   (declare (type simplicial-group smgr))
   (let ((aprd (aprd smgr)))
@@ -24,55 +25,43 @@
 	     (declare
 	      (fixnum degr)
 	      (type tnpr tnpr))
-	     (with-tnpr (degr1 tnpr1 degr2 abar2) tnpr
+	     (with-tnpr
+		 (degr1 tnpr1 degr2 abar2) tnpr
 		 (when (zerop degr2)
 		   (return-from rslt (zero-cmbn (1- degr))))
-			(with-tnpr (degr11 gbar11 degr12 gmsm12) tnpr1
+		 (with-tnpr
+		     (degr11 gbar11 degr12 gmsm12) tnpr1
 		     (let ((sign (-1-expt-n degr1))
 			   (brgn21 (first (abar-list abar2)))
-					 (bar22 (make-abar
+			   (bar22 (make-abar :list (rest (abar-list abar2)))))
-						 :list (rest (abar-list
-							      abar2)))))
 		       (declare
 			(fixnum sign)
 			(type brgn brgn21)
 			(type abar bar22))
-				     (with-brgn (degr21 gmsm21) brgn21
+		       (with-brgn
+			   (degr21 gmsm21) brgn21
 			   (let ((degr22 (- degr2 degr21)))
 			     (declare (fixnum degr22))
 			     (decf degr21) ;; = dmns(gmsm21)
-						  (let ((aprd
+			     (let ((aprd (gnrt-? aprd (+ degr12 degr21)
-							 (gnrt-? aprd
+						 (tnpr degr12 gmsm12
-								 (+ degr12
+						       degr21 gmsm21))))
-								    degr21)
-								 (tnpr degr12
-								       gmsm12
-								       degr21
-								       gmsm21))))
 			       (declare (type cmbn aprd))
-						    (with-cmbn (degr12+21 list)
+			       (with-cmbn
-						      aprd
+				   (degr12+21 list) aprd
 				   (make-cmbn
 				    :degr (1- degr)
 				    :list
 				    (mapcar
 				     #'(lambda (term)
-							    (declare
+					 (declare (type term term))
-							     (type term term))
 					 (with-term
 					     (cffc gmsm) term
-								(term (* sign
+					     (term (* sign cffc)
-									 cffc)
+						   (tnpr (+ degr1 degr21)
-								      (tnpr
+							 (tnpr degr11 gbar11
-								       (+ degr1
+							       degr12+21 gmsm)
-									  degr21)
+							 degr22 bar22))))
-								       (tnpr
-									degr11
-									gbar11
-									degr12+21
-									gmsm)
-								       degr22
-								       bar22))))
 				     list)))))))))))
       (the intr-mrph #'rslt))))
 

test/circle.lisp

@@ -3,26 +3,11 @@
 
 (in-suite :kenzo)
 
-(defun circle ()
-  (the cat:chain-complex
-       (cat:build-chcm
-	:cmpr #'(lambda (gnrt1 gnrt2)
-		  (declare (ignore gnrt1 gnrt2))
-		  (the cat:cmpr :equal))
-	:basis #'(lambda (dmns)
-		   (the list
-			(case dmns (0 '(*)) (1 '(s1))
-			      (otherwise cat:+empty-list+))))
-	:bsgn '*
-	:intr-dffr #'cat:zero-intr-dffr
-	:strt :cmbn
-	:orgn '(circle))))
-
 
 (test circle
       (progn
 	(cat:cat-init)
-	(let ((circle (circle)))
+	(let ((circle (cat:circle)))
 	  (is (equal (cat:basis circle 0) '(*)))
 	  (is (equal (cat:basis circle 1) '(s1)))
 	  (is (equal (cat:basis circle 2) cat:+empty-list+)))))

test/cl-space-efhm-test.lisp

@@ -5,7 +5,6 @@
 
 
 (test cs-hat-u-t
-      (progn
       (cat:cat-init)
       (let* ((c (cat:cs-hat-u-t (cat:k-z-1)))
 	     (abar (random-abar 8 4))
@@ -13,7 +12,6 @@
 	     (gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
 					 2 '(4 5))
 			     abar-degr abar)))
-	  (dotimes (i 5) (print (random-abar 8 4)))
 	(cat:? c (+ 5 abar-degr) gnrt)
 	(cat:? c (cat:? c (+ 5 abar-degr) gnrt))
 	(dotimes (i 10)
@@ -50,4 +48,53 @@
 				 abar-degr abar))
 	    (unless (>= abar-degr 11)
 	      (print (cat:? c (+ 4 abar-degr) gnrt))
-		(print (cat:? c (cat:? c (+ 4 abar-degr) gnrt)))))))))
+	      (print (cat:? c (cat:? c (+ 4 abar-degr) gnrt))))))))
+
+
+(test cs-hat-t-u
+      (cat:cat-init)
+      (dotimes (i 5) (print (random-abar 8 4)))
+      (let* ((c (cat:cs-hat-t-u (cat:k-z-1)))
+	     (abar (random-abar 8 4))
+	     (abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
+	     (gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
+					 2 '(4 5))
+			     abar-degr abar)))
+	(cat:? c (+ 5 abar-degr) gnrt)
+	(cat:? c (cat:? c (+ 5 abar-degr) gnrt))
+	(dotimes (i 10)
+	  (let ((abar (random-abar 8 4)))
+	    (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
+	    (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
+							 0 '()) 2 '(4 5))
+				 abar-degr abar))
+	    (unless (>= abar-degr 10)
+	      (print (cat:? c (+ 5 abar-degr) gnrt))
+	      (print (cat:? c (cat:? c (+ 5 abar-degr) gnrt))))))
+	(dotimes (i 10)
+	  (let ((abar (random-abar 8 4)))
+	    (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
+	    (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
+							 0 '()) 3 '(4 5 6))
+				 abar-degr abar))
+	    (unless (>= abar-degr 9)
+	      (print (cat:? c (+ 6 abar-degr) gnrt))
+	      (print (cat:? c (cat:? c (+ 6 abar-degr) gnrt))))))
+	(dotimes (i 10)
+	  (let ((abar (random-abar 8 4)))
+	    (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
+	    (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
+					     3 '(4 5 6))
+				 abar-degr abar))
+	    (unless (>= abar-degr 10)
+	      (print (cat:? c (+ 5 abar-degr) gnrt))
+	      (print (cat:? c (cat:? c (+ 5 abar-degr) gnrt))))))
+	(dotimes (i 10)
+	  (let ((abar (random-abar 8 4)))
+	    (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
+	    (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
+					     2 '(4 5))
+				 abar-degr abar))
+	    (unless (>= abar-degr 11)
+	      (print (cat:? c (+ 4 abar-degr) gnrt))
+	      (print (cat:? c (cat:? c (+ 4 abar-degr) gnrt))))))))