Extracted tests from ls-twisted-products.lisp.

kenzo-test.asd

@@ -33,6 +33,7 @@
 	       (:file "k-pi-n-test")
 	       (:file "kan-test")
 	       (:file "loop-spaces-test")
+	       (:file "ls-twisted-products-test")
 	       (:file "searching-homology-test")
 	       (:file "simplicial-groups-test")
 	       (:file "simplicial-mrphs-test")

package.lisp

@@ -121,6 +121,7 @@
 	   APOWR
 	   BCC
 	   BRGN
+	   BSPN
 	   CBGN
 	   CHAIN-COMPLEX
 	   CMBN-CMBN
@@ -139,6 +140,7 @@
 	   HOMOTOPY-EQUIVALENCE
 	   IABSM
 	   KAN
+	   LOOP-LIST
 	   LRDCT
 	   MAKE-ABAR
 	   MAKE-ALLP
@@ -340,6 +342,17 @@
 	   NORMALIZE-LOOP
 	   UNNORMALIZE-LOOP
 
+	   ;; ls-twisted-products.lisp
+
+	   ABSM-LOOPABSM
+	   CRTS-CONTRACTION
+	   CRTS-CONTRACTION-INTR
+	   DTAU-D-INTR
+	   POP-FIRST-ABSM
+	   SZCZARBA
+	   TNPR-CONTRACTION
+	   TWISTED-CRTS-PRDC
+
 	   ;; macros.lisp
 
 	   -1-EXPT-N
@@ -366,6 +379,7 @@
 	   F
 	   DFFR
 	   DGNL
+	   GMSM1
 	   GNRT
 	   GRIN
 	   GRML

src/ls-twisted-products.lisp

@@ -17,10 +17,12 @@
    (fixnum dmns)  ;; dimension of ABSM
    (type absm absm loop-absm))
   (the absm
-      (with-absm (dgop1 gmsm1) absm
+       (with-absm
+	   (dgop1 gmsm1) absm
 	   (when (logbitp (1- dmns) dgop1)
 	     (return-from absm-loopabsm loop-absm))
-         (with-absm (dgop2 loop2) loop-absm
+	   (with-absm
+	       (dgop2 loop2) loop-absm
 	       (let ((iloop2 (loop-list loop2)))
 		 (declare (list iloop2))
 		 (unless iloop2
@@ -28,7 +30,8 @@
 		     (absm dgop1 (make-loop :list (list (apowr 0 gmsm1 +1))))))
 		 (let ((apowr (first iloop2)))
 		   (declare (type apowr apowr))
-                  (with-apowr (dgop22 gmsm2 expn2) apowr
+		   (with-apowr
+		       (dgop22 gmsm2 expn2) apowr
 		       (if (and (= dgop1 (dgop*dgop dgop2 dgop22))
 				(eq :equal (funcall cmpr gmsm1 gmsm2)))
 			   ;; the absm is eaten by the first component of the loop
@@ -36,44 +39,37 @@
 			       ;; the first item of the loop disappears.
 			       (let ((iloop2-rest (rest iloop2)))
 				 (if iloop2-rest
-                                 (let ((loop-rest (normalize-loop (1- dmns) iloop2-rest)))
+				     (let ((loop-rest (normalize-loop
+						       (1- dmns) iloop2-rest)))
 				       (declare (type absm loop-rest))
-                                    (absm (dgop*dgop dgop2 (dgop loop-rest)) (gmsm loop-rest)))
+				       (absm (dgop*dgop dgop2 (dgop loop-rest))
+					     (gmsm loop-rest)))
 				     (absm (mask (1- dmns)) +null-loop+)))
 			       ;; the exponent of the first item is increased by 1
-                           (absm dgop2 (make-loop :list (cons (apowr dgop22 gmsm2 (1+ expn2))
+			       (absm dgop2 (make-loop :list
+						      (cons (apowr dgop22
+								   gmsm2
+								   (1+ expn2))
 							    (rest iloop2)))))
 			   ;; a concatenation must be done
-                        (multiple-value-bind (dgop dgop1 dgop2) (extract-common-dgop dgop1 dgop2)
+			   (multiple-value-bind (dgop dgop1 dgop2)
+			       (extract-common-dgop dgop1 dgop2)
 			     (declare (fixnum dgop dgop1 dgop2))
 			     (absm dgop
 				   (make-loop
 				    :list (cons (apowr dgop1 gmsm1 +1)
 						(if (zerop dgop2)
 						    iloop2
-                                             (mapcar #'(lambda (apowr)
+						    (mapcar
-                                                          (declare (type apowr apowr))
+						     #'(lambda (apowr)
-                                                          (cons (dgop*dgop dgop2 (apdgop apowr))
+							 (declare
+							  (type apowr apowr))
+							 (cons (dgop*dgop
+								dgop2 (apdgop
+								       apowr))
 							       (cdr apowr)))
 						     iloop2))))))))))))))
 
-#|
-()
-(setf cmpr (cmpr (deltab)))
-(absm-loopabsm cmpr 3 (absm 4 7) (absm 7 +null-loop+))
-(absm-loopabsm cmpr 3 (absm 0 15) (absm 7 +null-loop+))
-(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 4)))
-(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 4 1 12 -1)))
-(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 -1)))
-(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 -1 1 12 -1)))
-(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 4)))
-(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 2 7 4 1 14 -1)))
-(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 2 7 -1)))  ;; in principle illegal but works
-(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 2 7 -1 1 14 -1)))
-(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 0 15 -1 1 14 -1)))
-(absm-loopabsm cmpr 3 (absm 0 15) (absm 2 (loop3 0 7 -1 0 14 -1)))
-(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 28 -1 0 14 -1)))
-|#
 
 (DEFUN TWISTED-CRTS-PRDC-FACE (cmpr space-face loop-space-face non-twisted-face)
   (declare
@@ -90,9 +86,11 @@
 		      (funcall non-twisted-face indx dmns crpr)))
 		  (with-crpr (absm1 absm2) crpr
 			     (let ((face1 (a-face4 space-face dmns dmns absm1))
-                                    (face2 (a-face4 loop-space-face dmns dmns absm2)))
+				   (face2 (a-face4 loop-space-face dmns dmns
+						   absm2)))
 			       (declare (type absm face1 face2))
-                                (setf face2 (absm-loopabsm cmpr dmns absm1 face2))
+			       (setf face2 (absm-loopabsm cmpr dmns absm1
+							  face2))
 			       (2absm-acrpr face1 face2)))))))
     (the face #'rslt)))
 
@@ -107,7 +105,8 @@
 	  (type face space-face))
 	 (with-slots ((loop-space-face face)) loop-space
 	   (declare (type face loop-space-face))
-      (with-slots ((crts-prdc-cmpr cmpr) basis bsgn (crts-prdc-face face)) crts-prdc
+	   (with-slots ((crts-prdc-cmpr cmpr) basis bsgn (crts-prdc-face face))
+	       crts-prdc
 	     (declare
 	      (type cmprf crts-prdc-cmpr)
 	      (type basis basis)
@@ -118,43 +117,12 @@
 			  :basis basis
 			  :bspn bsgn
 			  :face (twisted-crts-prdc-face
-                                 space-cmpr space-face loop-space-face crts-prdc-face)
+                                 space-cmpr space-face loop-space-face
+				 crts-prdc-face)
 			  :orgn `(twisted-crts-prdc ,space))))
 	       (setf (slot-value rslt 'grmd) crts-prdc)
 	       rslt))))))
 
-#|
-  (setf p (r-proj-space 3))
-  (setf tw (twisted-crts-prdc p))
-  (defun random-apowr (dmns max-expn)
-     (loop
-        (let* ((dgop (random (2-exp (1- dmns))))
-               (gmsm (- dmns (logcount dgop))))
-           (unless (< 0 gmsm 3)
-              (return-from random-apowr
-                 (apowr dgop gmsm (srandom max-expn)))))))
-  (defun random-niloop (dmns max-expn length)
-     (mapcar #'(lambda (dummy)
-                  (random-apowr (1+ dmns) max-expn))
-        (make-list length)))
-  (defun random-crpr (dmns max-expn length)
-     (loop
-        (let ((loop (normalize-loop dmns (random-niloop dmns max-expn length)))
-              (dgop (random (2-exp dmns))))
-           (let ((absm (2absm-acrpr (absm dgop (- dmns (logcount dgop))) loop)))
-              (when (and (zerop (dgop absm))
-                         (not (< (gmsm1 (gmsm absm)) 3)))
-                 (return (gmsm absm)))))))
-  (setf cmpr (cmpr tw))
-  (defun random-cmbn (degr max-cffc max-expn loop-length cmbn-length)
-     (apply #'nterm-add cmpr degr
-        (mapcar #'(lambda (dummy)
-                     (term (srandom max-cffc) (random-crpr degr max-expn loop-length)))
-           (make-list cmbn-length))))
-  (setf c (random-cmbn 8 10 4 4 100))
-  (time (? tw (? tw c)))
-  (time (? tw (? tw c)))
-|#
 
 (DEFUN DTAU-D-INTR (crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face)
   (declare
@@ -171,25 +139,31 @@
 		  (declare (fixnum dmns-1))
 		  (when (logbitp dmns-1 (dgop1 crpr))
 		    (return-from rslt (zero-cmbn dmns-1)))
-                   (let ((face-tau (funcall twisted-crts-prdc-face dmns dmns crpr))
+		  (let ((face-tau (funcall twisted-crts-prdc-face dmns dmns
+					   crpr))
 			(face (funcall crts-prdc-face dmns dmns crpr))
 			(sign (-1-expt-n dmns)))
 		    (declare
 		     (type absm face-tau face)
 		     (fixnum sign))
-                      (with-absm (dgop-tau gmsm-tau) face-tau
+		    (with-absm
-                      (with-absm (dgop gmsm) face
+			(dgop-tau gmsm-tau) face-tau
+			(with-absm
+			    (dgop gmsm) face
 			    (if (plusp dgop-tau)
 				(if (plusp dgop)
 				    (zero-cmbn dmns-1)
 				    (term-cmbn dmns-1 (- sign) gmsm))
 				(if (plusp dgop)
 				    (term-cmbn dmns-1 sign gmsm-tau)
-                               (ecase (funcall crts-prdc-cmpr gmsm-tau gmsm)
+				    (ecase (funcall crts-prdc-cmpr gmsm-tau
+						    gmsm)
 				      (:less
-                                   (cmbn dmns-1 sign gmsm-tau (- sign) gmsm))
+				       (cmbn dmns-1 sign gmsm-tau (- sign)
+					     gmsm))
 				      (:greater
-                                   (cmbn dmns-1 (- sign) gmsm sign gmsm-tau))
+				       (cmbn dmns-1 (- sign) gmsm sign
+					     gmsm-tau))
 				      (:equal
 				       (error "Surprise in DTAU-D-INTR.~@
                                            Crpr = ~A~@
@@ -198,18 +172,6 @@
 					      crpr gmsm-tau gmsm))))))))))))
     (the intr-mrph #'rslt)))
 
-#|
-  (setf d (deltab))
-  (setf p (crts-prdc d (loop-space d)))
-  (setf tw (twisted-crts-prdc d))
-  (setf crts-prdc-cmpr (cmpr p)
-        crts-prdc-face (face p)
-        twisted-crts-prdc-face (face tw))
-  (setf delta (dtau-d-intr crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face))
-  (funcall delta 3 (crpr 0 15 0 (loop3 0 (- 2048 64) 1)))
-  (funcall delta 5 (crpr 10 15 5 (loop3 0 (- 2048 64) 1)))
-  (funcall delta 5 (crpr 5 15 10 (loop3 0 (- 2048 64) 1)))
-|#
 
 (DEFUN DTAU-D (space
 	       &aux (loop-space (loop-space space))
@@ -225,10 +187,12 @@
   (the morphism
        (build-mrph
 	:sorc crts-prdc :trgt crts-prdc :degr -1
-         :intr (dtau-d-intr crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face)
+	:intr (dtau-d-intr crts-prdc-cmpr crts-prdc-face
+			   twisted-crts-prdc-face)
 	:strt :gnrt
 	:orgn `(dtau-d ,space))))
 
+
 (DEFUN SZCZARBA (space
 		 &aux (loop-space (loop-space space))
 		   (twisted-crts-prdc (twisted-crts-prdc space))
@@ -249,19 +213,6 @@
 		 (slot-value h 'trgt) twisted-crts-prdc))
          (values szczarba bottom-perturbation))))
 
-#|
-  (cat-init)
-  (setf rdct (szczarba (deltab)))
-  (pre-check-rdct rdct)
-  (setf *tc* (cmbn 2 1 (crpr 0 7 0 (loop3 0 (- 512 32) 1)))
-        *bc* (cmbn 2 1 (tnpr 0 1 2 (loop3 0 (- 512 32) 1))
-                     10 (tnpr 1 (- 4096 1024) 1 (loop3 0 7 1))
-                     100 (tnpr 2 7 0 (loop3 0 (- 4096 1024) 1))))
-  (check-rdct) 
-  (setf bcc (bcc rdct))
-  (time (? bcc 5 (tnpr 5 (mask 6) 0 +null-loop+)))
-  (time (? bcc 6 (tnpr 6 (mask 7) 0 +null-loop+)))
-|#
 
 (DEFUN TWISTED-TNSR-PRDC (space
 			  &aux (szczarba (szczarba space)))
@@ -287,37 +238,26 @@
 	   (declare
 	    (type apowr apowr)
 	    (type iloop niloop-rest))
-            (with-apowr (dgop gmsm expn) apowr
+	   (with-apowr
+ 	       (dgop gmsm expn) apowr
 	       (let ((popped-absm (absm dgop gmsm)))
 		 (declare (type absm popped-absm))
 		 (cond ((< expn -1)
 			(values -1 popped-absm
 				(absm 0
 				      (make-loop
-                                  :list (cons (apowr dgop gmsm (1+ expn)) niloop-rest)))))
+				       :list (cons (apowr dgop gmsm (1+ expn))
+						   niloop-rest)))))
 		       ((> expn +1)
 			(values +1 popped-absm
 				(absm 0
 				      (make-loop
-                                  :list (cons (apowr dgop gmsm (1- expn)) niloop-rest)))))
+				       :list (cons (apowr dgop gmsm (1- expn))
+						   niloop-rest)))))
 		       (t
 			(values expn popped-absm
 				(normalize-loop dmns niloop-rest))))))))))
 
-#|
-()
-(pop-first-absm 4 (cdr +null-loop+))
-(pop-first-absm 4 (cdr (loop3 0 'a -2)))
-(pop-first-absm 4 (cdr (loop3 0 'a +2)))
-(pop-first-absm 4 (cdr (loop3 0 'a -1)))
-(pop-first-absm 4 (cdr (loop3 0 'a +1)))
-(pop-first-absm 4 (cdr (loop3 1 'a -2 2 'b 3)))
-(pop-first-absm 4 (cdr (loop3 0 'a +2 2 'b -3)))
-(pop-first-absm 4 (cdr (loop3 1 'a -1 2 'b 3)))
-(pop-first-absm 4 (cdr (loop3 0 'a +1 2 'b 5)))
-(pop-first-absm 4 (cdr (loop3 2 'a -1 1 'b 3)))
-(pop-first-absm 4 (cdr (loop3 2 'a +1 1 'b 3)))
-|#
 
 
 (DEFUN CRTS-CONTRACTION-INTR (base-cmpr base-bspn base-face crts-cmpr)
@@ -342,7 +282,8 @@
 				     (h-hat (loop-list (gmsm g-n))))
 				 (if (degenerate-p g-n)
 				     (h-tilde (1dgnr n x-n) g-n)
-           (2cmbn-add crts-cmpr (h-hat (loop-list (gmsm g-n)))
+				     (2cmbn-add crts-cmpr
+						(h-hat (loop-list (gmsm g-n)))
 						(h-tilde (1dgnr n x-n) g-n)))))
 			   (h-tilde (x-n+1 g-n)
 			     (declare (type absm x-n+1 g-n))
@@ -352,7 +293,8 @@
 			     (do ((i n (1- i))
 				  (dgop 0 (+ dgop (2-exp i)))
 				  (sign (-1-expt-n+1 n) (- sign))
-          (del-i x-n+1  (a-face4 base-face i (1+ i) del-i))
+				  (del-i x-n+1  (a-face4 base-face i (1+ i)
+							 del-i))
 				  (rslt (zero-cmbn n+1)))
 				 ((minusp i) rslt)
 			       (declare
@@ -362,126 +304,58 @@
 			       (let ((absm1 (ndgnr dgop del-i))
 				     (loop-absm2 (1dgnr i g-n)))
 				 (declare (type absm absm1 loop-absm2))
-           (unless (plusp (logand (dgop absm1) (dgop loop-absm2)))
+				 (unless (plusp (logand (dgop absm1)
+							(dgop loop-absm2)))
 				   (dstr-add-term-to-cmbn
 				    crts-cmpr
 				    sign (crpr absm1 loop-absm2)
 				    rslt)))))
 			   (h-hat (g-n)
 			     (declare (type iloop g-n))  ;;; ***
-     (multiple-value-bind (expn y-n+1 gp-n) (pop-first-absm n g-n)
+			     (multiple-value-bind (expn y-n+1 gp-n)
+				 (pop-first-absm n g-n)
 			       (declare
 				(fixnum expn)
 				(type (or absm null) y-n+1 gp-n))
 			       (ecase expn
 				 (0 (zero-cmbn (1+ n)))
 				 (+1
-            (let ((h-tildes (2cmbn-sbtr crts-cmpr
+				  (let ((h-tildes
-                               (h-tilde y-n+1 gp-n)
+					 (2cmbn-sbtr
-                               (h-tilde
+					  crts-cmpr (h-tilde y-n+1 gp-n)
-                                  (1dgnr n (a-face4 base-face (1+ n) (1+ n) y-n+1))
+					  (h-tilde (1dgnr n (a-face4 base-face
-                                  (absm 0 (make-loop :list g-n))))))
+								     (1+ n)
+								     (1+ n)
+								     y-n+1))
+						   (absm 0 (make-loop :list
+								      g-n))))))
 				    (declare (type cmbn h-tildes))
 				    (if (degenerate-p gp-n)
 					h-tildes
-                  (2cmbn-add crts-cmpr (h-hat (loop-list (gmsm gp-n))) h-tildes))))
+					(2cmbn-add crts-cmpr
+						   (h-hat (loop-list
+							     (gmsm gp-n)))
+						   h-tildes))))
 				 (-1
-            (let ((next-x-n (a-face4 base-face (1+ n) (1+ n) y-n+1))
+				  (let ((next-x-n (a-face4 base-face (1+ n)
-                  (h-tilde (h-tilde y-n+1 (absm 0 (make-loop :list g-n)))))
+							   (1+ n) y-n+1))
+					(h-tilde
+					 (h-tilde y-n+1
+						  (absm 0 (make-loop
+							   :list g-n)))))
 				    (declare
 				     (type absm next-x-n)
 				     (type cmbn h-tilde))
-               (if (zerop (logand (dgop next-x-n) (dgop gp-n)))
+				    (if (zerop (logand (dgop next-x-n)
+						       (dgop gp-n)))
 					(2cmbn-sbtr crts-cmpr
 						    (hh next-x-n gp-n) h-tilde)
 					(cmbn-opps h-tilde))))))))
-    
 		    (with-crpr (absm1 loop-absm2) crpr
 			       (hh absm1 loop-absm2)))))))
-    
     (the intr-mrph #'rslt)))
 
 
-#|
-()
-(cat-init)
-(setf delta (deltab))
-(setf tw (twisted-crts-prdc delta))
-(setf d (bndr tw))
-(setf base-cmpr (cmpr delta)
-  base-bspn (bspn delta)
-  base-face (face delta)
-  crts-cmpr (cmpr tw))
-(setf r (crts-contraction-intr base-cmpr base-bspn base-face crts-cmpr))
-(setf h (build-mrph :sorc tw :trgt tw :degr +1
-                    :intr r :strt :gnrt :orgn `(crts-contraction ,delta)))
-(setf z (i-sbtr (idnt-mrph tw) (cmps d h) (cmps h d)))
-(? z 0 (crpr 0 1 0 +null-loop+))
-(funcall r 0 (crpr 0 1 0 (loop3 0 96 1)))
-(? z 0 (crpr 0 1 0 (loop3 0 96 1)))
-(? z 0 (crpr 0 1 0 (loop3 0 96 1 0 (+ 256 128) 1)))
-(? z 0 (crpr 0 1 0 (loop3 0 96 1 0 (+ 256 128) 1 0 (+ 512 1024) 1)))
-(? z 0 (crpr 0 1 0 (loop3 0 96 2)))
-(? z 1 (crpr 0 3 0 (loop3 0 (+ 32 64 128) 1)))
-(? z 2 (crpr 0 7 0 (loop3 0 (+ 32 64 128 256) 1)))
-(? z 3 (crpr 2 7 1 (loop3 2 (+ 32 64 128) 2 4 (+ 32 64 128) -2)))
-(? z 3 (crpr 2 7 4 (loop3 2 (+ 32 64 128) 2 1 (+ 32 64 128) -2)))
-(? z 3 (crpr 2 7 1 (loop3 2 (+ 32 64 128) -2 4 (+ 32 64 128) 2)))
-(? z 3 (crpr 2 7 4 (loop3 2 (+ 32 64 128) -2 1 (+ 32 64 128) 2)))
-(? z 3 (crpr 1 7 2 (loop3 2 (+ 32 64 128) 2 4 (+ 32 64 128) -2)))
-(? z 3 (crpr 4 7 2 (loop3 2 (+ 32 64 128) 2 1 (+ 32 64 128) -2)))
-(? z 3 (crpr 1 7 2 (loop3 2 (+ 32 64 128) -2 4 (+ 32 64 128) 2)))
-(? z 3 (crpr 4 7 2 (loop3 2 (+ 32 64 128) -2 1 (+ 32 64 128) 2)))
-|#
- 
-
-#|
-  (cat-init)
-  (setf p (r-proj-space 3))
-  (setf tw (twisted-crts-prdc p))
-  (setf r (crts-contraction-intr (cmpr p) (bspn p) (face p) (cmpr tw)))
-  (defun random-apowr (dmns max-expn)
-     (loop
-        (let* ((dgop (random (2-exp (1- dmns))))
-               (gmsm (- dmns (logcount dgop))))
-           (unless (< 0 gmsm 3)
-              (return-from random-apowr
-                 (apowr dgop gmsm (srandom max-expn)))))))
-  (defun random-niloop (dmns max-expn length)
-     (mapcar #'(lambda (dummy)
-                  (random-apowr (1+ dmns) max-expn))
-        (make-list length)))
-  (defun random-crpr (dmns max-expn length)
-     (loop
-        (let ((loop (normalize-loop dmns (random-niloop dmns max-expn length)))
-              (dgop (random (2-exp dmns))))
-           (let ((absm (2absm-acrpr (absm dgop (- dmns (logcount dgop))) loop)))
-              (when (and (zerop (dgop absm))
-                         (not (< (gmsm1 (gmsm absm)) 3)))
-                 (return (gmsm absm)))))))
-  (setf cmpr (cmpr tw))
-  (defun random-cmbn (degr max-cffc max-expn loop-length cmbn-length)
-     (apply #'nterm-add cmpr degr
-        (mapcar #'(lambda (dummy)
-                     (term (srandom max-cffc) (random-crpr degr max-expn loop-length)))
-           (make-list cmbn-length))))
-  (setf h (build-mrph :sorc tw :trgt tw :degr +1
-             :intr r :strt :gnrt :orgn `(crts-contraction ,p)))
-  (setf d (bndr tw))
-  (setf z (i-sbtr (idnt-mrph tw) (cmps h d) (cmps d h)))
-  (setf c (random-cmbn 5 10 2 2 1))
-  (? z c)
-  (setf c (random-cmbn 6 10 3 3 3))
-  (? z c)
-  (setf c (random-cmbn 7 10 4 4 6))
-  (? z c)
-  (setf c (random-cmbn 8 10 4 4 20))
-  (? z c)
-  (? h c)
-  (? d *)
-  (length *)
-|#
-
 (DEFUN CRTS-CONTRACTION (space
 			 &aux (twisted-crts-prdc (twisted-crts-prdc space)))
   (declare (type simplicial-set space twisted-crts-prdc))
@@ -493,12 +367,6 @@
 	:strt :gnrt
 	:orgn `(crts-contraction ,space))))
 
-#|
-  (setf h (crts-contraction (deltab)))
-  (setf d (bndr (twisted-crts-prdc (deltab))))
-  (setf z (i-sbtr (idnt-mrph (sorc d)) (cmps d h) (cmps h d)))
-  (? z 3 (crpr 4 7 2 (loop3 2 (+ 32 64 128) -2 1 (+ 32 64 128) 2)))
-|#
 
 (DEFUN TNPR-CONTRACTION (space
 			 &aux
@@ -512,14 +380,3 @@
    (type morphism f g crts-contraction))
   (the morphism
        (i-cmps f crts-contraction g)))
-
-#|
-  (cat-init)
-  (setf delta (deltab))
-  (setf sz (szczarba (deltab)))
-  (setf tw (bcc sz))
-  (setf h (tnpr-contraction delta))
-  (setf z (i-sbtr (idnt-mrph tw) (cmps tw h) (cmps h tw)))
-  (time (? z 3 (tnpr 0 1 3 (loop3 0 (mask 5) 2 0 (* 32 (mask 5)) -1))))
-  (? h 4 (tnpr 0 1 0 (loop3 0 (mask 6) 1)))
-|#

test/common.lisp

@@ -170,22 +170,6 @@
 			 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)))
-
-
 (defun aleat-tc ()
   (do ((tdegr 0 (+ tdegr degr))
        (degr (+ 2 (random 3)) (+ 2 (random 3)))
@@ -210,3 +194,66 @@
   (aleat-tc)
   (aleat-bc)
   (check-rdct))
+
+
+(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)))
+
+
+(defun random-apowr (dmns max-expn)
+  (loop
+     (let* ((dgop (random (cat:2-exp (1- dmns))))
+	    (gmsm (- dmns (logcount dgop))))
+       (unless (< 0 gmsm 3)
+	 (return-from random-apowr
+	   (cat:apowr dgop gmsm (cat:srandom max-expn)))))))
+
+
+(defun random-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
+  (apply #'cat:nterm-add cmpr degr
+	 (mapcar #'(lambda (dummy)
+                     (cat:term (cat:srandom max-cffc)
+			       (random-crpr degr max-expn loop-length)))
+		 (make-list cmbn-length))))
+
+
+(defun random-crpr (dmns max-expn length)
+  (loop
+     (let ((loop (cat:normalize-loop dmns
+				     (random-niloop dmns max-expn length)))
+	   (dgop (random (cat:2-exp dmns))))
+       (let ((absm (cat:2absm-acrpr (cat:absm dgop (- dmns (logcount dgop)))
+				    loop)))
+	 (when (and (zerop (cat:dgop absm))
+		    (not (< (cat:gmsm1 (cat:gmsm absm)) 3)))
+	   (return (cat:gmsm absm)))))))
+
+
+(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
+  (do ((rslt cat:+empty-list+ (cons term rslt))
+       (i cmbn-length (1- i))
+       (term))
+      ((zerop i)
+       (apply #'cat:nterm-add cmpr degr rslt))
+    (setf term
+	  (cat:term (cat:srandom max-cffc)
+		    (cat:make-loop :list (random-niloop degr max-expn
+							loop-length))))))
+
+
+(defun random-niloop (dmns max-expn length)
+  (mapcar #'(lambda (dummy)
+	      (random-apowr (1+ dmns) max-expn))
+	  (make-list length)))

test/loop-spaces-test.lisp

@@ -179,33 +179,6 @@
 	    (cat:check-kan g i 4 (remove (nth i hat) hat))))))
 
 
-(defun random-apowr (dmns max-expn)
-  (loop
-     (let* ((dgop (random (cat:2-exp (1- dmns))))
-	    (gmsm (- dmns (logcount dgop))))
-       (unless (< 0 gmsm 3)
-	 (return-from random-apowr
-	   (cat:apowr dgop gmsm (cat:srandom max-expn)))))))
-
-
-(defun random-niloop (dmns max-expn length)
-  (mapcar #'(lambda (dummy)
-	      (random-apowr (1+ dmns) max-expn))
-	  (make-list length)))
-
-
-(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
-  (do ((rslt cat:+empty-list+ (cons term rslt))
-       (i cmbn-length (1- i))
-       (term))
-      ((zerop i)
-       (apply #'cat:nterm-add cmpr degr rslt))
-    (setf term
-	  (cat:term (cat:srandom max-cffc)
-		    (cat:make-loop :list (random-niloop degr max-expn
-							loop-length))))))
-
-
 (test loop-space2
       (cat:cat-init)
       (let* ((p (cat:r-proj-space 3))

test/ls-twisted-products-test.lisp

@@ -0,0 +1,181 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+
+(test absm-loopabsm
+      (let ((cmpr (cat:cmpr (cat:deltab))))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 4 7) (cat:absm 7 cat:+null-loop+))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 0 15) (cat:absm 7 cat:+null-loop+))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
+			   (cat:absm 2 (cat:loop3 0 7 4)))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
+			   (cat:absm 2 (cat:loop3 0 7 4 1 12 -1)))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
+			   (cat:absm 2 (cat:loop3 0 7 -1)))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
+			   (cat:absm 2 (cat:loop3 0 7 -1 1 12 -1)))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
+			   (cat:absm 2 (cat:loop3 0 7 4)))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
+			   (cat:absm 0 (cat:loop3 2 7 4 1 14 -1)))
+	;; in principle illegal but works
+	(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
+			   (cat:absm 0 (cat:loop3 2 7 -1)))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
+			   (cat:absm 0 (cat:loop3 2 7 -1 1 14 -1)))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
+			   (cat:absm 0 (cat:loop3 0 15 -1 1 14 -1)))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 0 15)
+			   (cat:absm 2 (cat:loop3 0 7 -1 0 14 -1)))
+	(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
+			   (cat:absm 2 (cat:loop3 0 28 -1 0 14 -1)))))
+
+
+(test twisted-crts-prdc
+      (cat:cat-init)
+      (let* ((p (cat:r-proj-space 3))
+	     (tw (cat:twisted-crts-prdc p))
+	     (cmpr (cat:cmpr tw))
+	     (c (random-cmbn cmpr 8 10 4 4 100)))
+	(time (cat:? tw (cat:? tw c)))
+	(time (cat:? tw (cat:? tw c)))))
+
+
+(test dtau-d-intr
+      (cat:cat-init)
+      (let* ((d (cat:deltab))
+	     (p (cat:crts-prdc d (cat:loop-space d)))
+	     (tw (cat:twisted-crts-prdc d))
+	     (crts-prdc-cmpr (cat:cmpr p))
+	     (crts-prdc-face (cat:face p))
+	     (twisted-crts-prdc-face (cat:face tw))
+	     (delta (cat:dtau-d-intr crts-prdc-cmpr crts-prdc-face
+				     twisted-crts-prdc-face)))
+	(funcall delta 3 (cat:crpr 0 15 0 (cat:loop3 0 (- 2048 64) 1)))
+	(funcall delta 5 (cat:crpr 10 15 5 (cat:loop3 0 (- 2048 64) 1)))
+	(funcall delta 5 (cat:crpr 5 15 10 (cat:loop3 0 (- 2048 64) 1)))))
+
+
+(test szczarba
+      (cat:cat-init)
+      (let ((rdct (cat:szczarba (cat:deltab)))
+	    bcc)
+	(cat:pre-check-rdct rdct)
+	(setf cat:*tc* (cat:cmbn 2 1 (cat:crpr 0 7 0
+					       (cat:loop3 0 (- 512 32) 1)))
+	      cat:*bc* (cat:cmbn 2 1 (cat:tnpr 0 1 2
+					       (cat:loop3 0 (- 512 32) 1))
+				 10 (cat:tnpr 1 (- 4096 1024) 1
+					      (cat:loop3 0 7 1))
+				 100 (cat:tnpr 2 7 0
+					       (cat:loop3 0 (- 4096 1024) 1))))
+	(check-rdct)
+	(setf bcc (cat:bcc rdct))
+	(time (cat:? bcc 5 (cat:tnpr 5 (cat:mask 6) 0 cat:+null-loop+)))
+	(time (cat:? bcc 6 (cat:tnpr 6 (cat:mask 7) 0 cat:+null-loop+)))))
+
+
+(test pop-first-absm
+      (cat:pop-first-absm 4 (cdr (cat:loop-list cat:+null-loop+)))
+      (cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a -2))))
+      (cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a +2))))
+      (cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a -1))))
+      (cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a +1))))
+      (cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 1 'a -2 2 'b 3))))
+      (cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a +2 2 'b -3))))
+      (cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 1 'a -1 2 'b 3))))
+      (cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a +1 2 'b 5))))
+      (cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 2 'a -1 1 'b 3))))
+      (cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 2 'a +1 1 'b 3)))))
+
+
+(test crts-contraction-intr
+      (cat:cat-init)
+      (let* ((delta (cat:deltab))
+	     (tw (cat:twisted-crts-prdc delta))
+	     (d (cat:bndr tw))
+	     (base-cmpr (cat:cmpr delta))
+	     (base-bspn (cat:bspn delta))
+	     (base-face (cat:face delta))
+	     (crts-cmpr (cat:cmpr tw))
+	     (r (cat:crts-contraction-intr base-cmpr base-bspn base-face
+					   crts-cmpr))
+	     (h (cat:build-mrph :sorc tw :trgt tw :degr +1
+				:intr r :strt :gnrt
+				:orgn `(crts-contraction ,delta)))
+	     (z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps d h) (cat:cmps h d))))
+	(cat:? z 0 (cat:crpr 0 1 0 cat:+null-loop+))
+	(funcall r 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1)))
+	(cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1)))
+	(cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1 0 (+ 256 128) 1)))
+	(cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1 0 (+ 256 128)
+					      1 0 (+ 512 1024) 1)))
+	(cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 2)))
+	(cat:? z 1 (cat:crpr 0 3 0 (cat:loop3 0 (+ 32 64 128) 1)))
+	(cat:? z 2 (cat:crpr 0 7 0 (cat:loop3 0 (+ 32 64 128 256) 1)))
+	(cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128)
+					      2 4 (+ 32 64 128) -2)))
+	(cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128)
+					      2 1 (+ 32 64 128) -2)))
+	(cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128)
+					      -2 4 (+ 32 64 128) 2)))
+	(cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128)
+					      -2 1 (+ 32 64 128) 2)))
+	(cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128)
+					      2 4 (+ 32 64 128) -2)))
+	(cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128)
+					      2 1 (+ 32 64 128) -2)))
+	(cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128)
+					      -2 4 (+ 32 64 128) 2)))
+	(cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128)
+					      -2 1 (+ 32 64 128) 2)))))
+
+
+(test crts-contraction
+      (cat:cat-init)
+      (let* ((p (cat:r-proj-space 3))
+	     (tw (cat:twisted-crts-prdc p))
+	     (cmpr (cat:cmpr tw))
+	     (r (cat:crts-contraction-intr (cat:cmpr p) (cat:bspn p)
+					   (cat:face p) (cat:cmpr tw)))
+	     (h (cat:build-mrph :sorc tw :trgt tw :degr +1
+				:intr r :strt :gnrt
+				:orgn `(cat:crts-contraction ,p)))
+	     (d (cat:bndr tw))
+	     (z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps h d) (cat:cmps d h)))
+	     (c (random-cmbn cmpr 5 10 2 2 1)))
+	(cat:? z c)
+	(setf c (random-cmbn cmpr 6 10 3 3 3))
+	(cat:? z c)
+	(setf c (random-cmbn cmpr 7 10 4 4 6))
+	(cat:? z c)
+	(setf c (random-cmbn cmpr 8 10 4 4 20))
+	(cat:? z c)
+	(cat:? h c)
+	(cat:? d (cat:? h c))
+	(print (length (cat:cmbn-list (cat:? d (cat:? h c)))))))
+
+
+(test crts-contraction1
+      (let* ((h (cat:crts-contraction (cat:deltab)))
+	     (d (cat:bndr (cat:twisted-crts-prdc (cat:deltab))))
+	     (z (cat:i-sbtr (cat:idnt-mrph (cat:sorc d)) (cat:cmps d h)
+			    (cat:cmps h d))))
+	(cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128)
+					      -2 1 (+ 32 64 128) 2)))))
+
+
+(test tnpr-contraction
+      (cat:cat-init)
+      (let* ((delta (cat:deltab))
+	     (sz (cat:szczarba (cat:deltab)))
+	     (tw (cat:bcc sz))
+	     (h (cat:tnpr-contraction delta))
+	     (z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps tw h)
+			    (cat:cmps h tw))))
+	(time (cat:? z 3 (cat:tnpr 0 1 3 (cat:loop3 0 (cat:mask 5)
+						    2 0 (* 32 (cat:mask 5))
+						    -1))))
+	(cat:? h 4 (cat:tnpr 0 1 0 (cat:loop3 0 (cat:mask 6) 1)))))