First cl-space-efhm test extracted. This part seems to be affected by the

ICMBN-P issues.

kenzo-test.asd

@@ -23,4 +23,5 @@
 	       (:file "delta-test")
 	       (:file "bar-test")
 	       (:file "cartesian-products-test")
-	       (:file "cones-test")))
+	       (:file "cones-test")
+	       (:file "cl-space-efhm-test")))

package.lisp

@@ -86,6 +86,10 @@
 	   Z-CHCM
 	   ZERO-MRPH
 
+	   ;; cl-space-efhm.lisp
+
+	   CS-HAT-U-T
+
 	   ;; classes.lisp
 
 	   ABSM
@@ -101,6 +105,7 @@
 	   F
 	   FACE
 	   G
+	   GBAR
 	   GMSM
 	   H
 	   HOMOTOPY-EQUIVALENCE
@@ -114,6 +119,7 @@
 	   REDUCTION
 	   RRDCT
 	   TCC
+	   TNPR
 
 	   ;; combinations.lisp
 

src/cl-space-efhm.lisp

@@ -30,7 +30,9 @@
 			(with-tnpr (degr11 gbar11 degr12 gmsm12) tnpr1
 				   (let ((sign (-1-expt-n degr1))
 					 (brgn21 (first (abar-list abar2)))
-		       (bar22 (make-abar :list (rest (abar-list abar2)))))
+					 (bar22 (make-abar
+						 :list (rest (abar-list
+							      abar2)))))
 				     (declare
 				      (fixnum sign)
 				      (type brgn brgn21)
@@ -39,23 +41,42 @@
 						(let ((degr22 (- degr2 degr21)))
 						  (declare (fixnum degr22))
 						  (decf degr21) ;; = dmns(gmsm21)
-		     (let ((aprd (gnrt-? aprd (+ degr12 degr21)
+						  (let ((aprd
-					 (tnpr degr12 gmsm12 degr21 gmsm21))))
+							 (gnrt-? aprd
+								 (+ degr12
+								    degr21)
+								 (tnpr degr12
+								       gmsm12
+								       degr21
+								       gmsm21))))
 						    (declare (type cmbn aprd))
-		       (with-cmbn (degr12+21 list) aprd
+						    (with-cmbn (degr12+21 list)
-			 (make-cmbn :degr (1- degr)
+						      aprd
+						      (make-cmbn
+						       :degr (1- degr)
 						       :list
 						       (mapcar
 							#'(lambda (term)
-				 (declare (type term term))
+							    (declare
-				 (with-term (cffc gmsm) term
+							     (type term term))
-				   (term (* sign cffc)
+							    (with-term
-					 (tnpr (+ degr1 degr21)
+								(cffc gmsm) term
-					       (tnpr degr11 gbar11 degr12+21 gmsm)
+								(term (* sign
-					       degr22 bar22))))
+									 cffc)
+								      (tnpr
+								       (+ degr1
+									  degr21)
+								       (tnpr
+									degr11
+									gbar11
+									degr12+21
+									gmsm)
+								       degr22
+								       bar22))))
 							list)))))))))))
       (the intr-mrph #'rslt))))
 
+
 (DEFUN CS-HAT-RIGHT-PERTURBATION (smgr
 				  &aux (hat-u-u (cs-hat-u-u smgr)))
   (declare
@@ -70,6 +91,7 @@
 	:strt :gnrt
 	:orgn `(cs-hat-right-perturbation ,smgr))))
 
+
 (DEFUN CS-HAT-U-T (smgr
 		   &aux (hat-u-u (cs-hat-u-u smgr))
 		     (hat-right-perturbation
@@ -85,63 +107,6 @@
 	 ;; cf lp-space-efhm.lisp
 	 (add hat-u-u hat-right-perturbation))))
 
-#|
-  (cat-init)
-  (setf c (cs-hat-u-t (k-z-1)))
-  (defun random-abar (tot-degr~ max-degr)
-    (do ((rslt nil)
-         (cum-degr 0 (+ cum-degr degr 1))
-         (degr))
-        ((>= cum-degr tot-degr~) (make-abar :list rslt))
-       (setf degr (1+ (random max-degr)))
-       (push (brgn (1+ degr)
-                   (let ((list (make-list degr)))
-                     (mapl
-                       #'(lambda (sublist)
-                           (setf (car sublist) (- (random 21) 10)))
-                       list)
-                     list))
-             rslt)))
-  (dotimes (i 5) (print (random-abar 8 4)))
-  (setf abar (random-abar 8 4))
-  (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-  (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
-                   abar-degr abar))
-  (? c (+ 5 abar-degr) gnrt)
-  (? c *)
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 10)
-         (print (? c (+ 5 abar-degr) gnrt))
-         (print (? c (? c (+ 5 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
-                       abar-degr abar))
-      (unless (>= abar-degr 9)
-         (print (? c (+ 6 abar-degr) gnrt))
-         (print (? c (? c (+ 6 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
-	   	     abar-degr abar))
-      (unless (>= abar-degr 10)
-        (print (? c (+ 5 abar-degr) gnrt))
-        (print (? c (? c (+ 5 abar-degr) gnrt))))))
-  (dotimes (i 10)
-    (let ((abar (random-abar 8 4)))
-      (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
-      (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
-                       abar-degr abar))
-      (unless (>= abar-degr 11)
-         (print (? c (+ 4 abar-degr) gnrt))
-         (print (? c (? c (+ 4 abar-degr) gnrt))))))
-|#
 
 (DEFUN CS-HAT-LEFT-PERTURBATION (smgr
 				 &aux (fibration (smgr-fibration smgr))
@@ -163,6 +128,7 @@
 		 (slot-value rslt 'trgt) hat-u-t)
 	   rslt))))
 
+
 (DEFUN CS-HAT-T-U (smgr
 		   &aux (bar (bar smgr))
 		     (fibration (smgr-fibration smgr))

test/bar-test.lisp

@@ -56,7 +56,7 @@
 	(funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7)))))
 
 
-(defun random-abar (length)
+(defun random-abar1 (length)
   (let ((rslt nil))
     (dotimes (i length)
       (let* ((gmsm (random (cat:mask 7)))
@@ -71,9 +71,9 @@
 	(cat:cat-init)
 	(let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
 	  (dotimes (i 10)
-	    (print (random-abar 5)))
+	    (print (random-abar1 5)))
 	  (dotimes (i 10)
-	    (let ((abar (random-abar 3)))
+	    (let ((abar (random-abar1 3)))
 	      (print abar)
 	      (print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
 			    abar))
@@ -82,22 +82,6 @@
 				     abar))))))))
 
 
-(defun random-abar1 (tot-degr~ max-degr)
-  (do ((rslt nil)
-       (cum-degr 0 (+ cum-degr degr 1))
-       (degr))
-      ((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
-    (setf degr (1+ (random max-degr)))
-    (push (cat:brgn (1+ degr)
-		(let ((list (make-list degr)))
-		  (mapl
-		   #'(lambda (sublist)
-		       (setf (car sublist) (- (random 21) 10)))
-		   list)
-		  list))
-	  rslt)))
-
-
 #|
 (test bar-intr-hrzn-dffr
       (let* ((k (cat:k-z-1))

test/cl-space-efhm-test.lisp

@@ -0,0 +1,56 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+
+(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))
+	       (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)))
+	  (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)
+	    (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))))))
+	  |#
+	  )))

test/common.lisp

@@ -168,3 +168,19 @@
 				       cat:*dg-gd* cat:*hg*))
 			 cat:*bc*
 			 cat:*tc*))))))
+
+
+(defun random-abar (tot-degr~ max-degr)
+  (do ((rslt nil)
+       (cum-degr 0 (+ cum-degr degr 1))
+       (degr))
+      ((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
+    (setf degr (1+ (random max-degr)))
+    (push (cat:brgn (1+ degr)
+		(let ((list (make-list degr)))
+		  (mapl
+		   #'(lambda (sublist)
+		       (setf (car sublist) (- (random 21) 10)))
+		   list)
+		  list))
+	  rslt)))