First stab at BAR tests.

Created quite a few (related ?) issues...

package.lisp

@@ -4,6 +4,10 @@
   (:use #:cl)
   (:export KENZO-VERSION
 
+	   ;; UFO
+
+	   EFHM
+
 	   ;; kenzo.lisp
 
 	   *BC*
@@ -23,11 +27,16 @@
 	   ;; bar.lisp
 
 	   ABAR
+	   BAR
 	   BAR-BASIS-LENGTH
 	   BAR-BASIS
 	   BAR-CMPR
+	   BAR-HRZN-DFFR
 	   BAR-INTR-HRZN-DFFR
 	   BAR-INTR-VRTC-DFFR
+	   HMTP-VRTC-BAR-INTR
+	   MRPH-VRTC-BAR-INTR
+	   NCMBN-BAR
 	   VRTC-BAR
 
 	   ;; bicones.lisp
@@ -145,6 +154,11 @@
 	   TRIVIAL-HMEQ
 	   TRIVIAL-RDCT
 
+	   ;; eilenberg-zilber.lisp
+
+	   AW
+	   EZ
+
 	   ;; fibrations.lisp
 
 	   FIBRATION-TOTAL
@@ -178,7 +192,9 @@
 	   CMBN-ZERO-P
 	   CMPR
 	   CPRD
+	   CRPR
 	   D
+	   F
 	   DFFR
 	   DGNL
 	   GNRT

src/bar.lisp

@@ -299,33 +299,6 @@
 	  :intr (bar-intr-hrzn-dffr aprd) :strt :gnrt
 	  :orgn `(bar-hrzn-dffr ,algb)))))
 
-#|
-(cat-init)
-(setf h (bar-hrzn-dffr (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 10) (print (random-abar 10 5)))
-(setf abar (random-abar 10 5))
-(? h (apply #'+ (mapcar #'car (abar-list abar))) abar)
-(? h (? h (apply #'+ (mapcar #'car (abar-list abar))) abar))
-(dotimes (i 10)
-  (let ((abar (random-abar 10 3)))
-    (print abar)
-    (print (? h (apply #'+ (mapcar #'car (abar-list abar))) abar))
-    (print (? h (? h (apply #'+ (mapcar #'car (abar-list abar))) abar)))))
-|#
 
 (DEFUN BAR-INTR-DFFR (vrtc-dffr hrzn-dffr)
   (declare (type morphism vrtc-dffr hrzn-dffr))
@@ -340,8 +313,10 @@
 			     (cmbn-list (gnrt-? vrtc-dffr degr abar))))))
     (the intr-mrph #'rslt)))
 
+
 (DEFGENERIC BAR (algebra-or-hmeq))
 
+
 (DEFMETHOD BAR ((algebra algebra))
   (let ((vrtc-bar (vrtc-bar algebra))
 	(bar-hrzn-dffr (bar-hrzn-dffr algebra)))
@@ -359,32 +334,6 @@
 	   (setf (slot-value rslt 'grmd) (grmd vrtc-bar))
 	   rslt))))
 
-#|
-(cat-init)
-(setf b (bar (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)))
-(setf abar (random-abar 10 3))
-(? b (apply #'+ (mapcar #'car (abar-list abar))) abar)
-(? b (? b (apply #'+ (mapcar #'car (abar-list abar))) abar))
-(dotimes (i 10)
-  (let ((abar (random-abar 10 3)))
-    (print abar)
-    (print (? b (apply #'+ (mapcar #'car (abar-list abar))) abar))
-    (print (? b (? b (apply #'+ (mapcar #'car (abar-list abar))) abar)))))
-|#
 
 (DEFUN CMBN-ABAR-CMBN-TNPR (cmbn abar-cmbn)
   (declare (type cmbn cmbn abar-cmbn))
@@ -403,14 +352,21 @@
 						(declare (type brgn brgn1))
 						(mapcar
 						 #'(lambda (termr)
-						     (declare (type term termr))
+						     (declare (type term
-						     (with-term (cffcr abarr) termr
+								    termr))
-								(term (* cffc1 cffcr)
+						     (with-term (cffcr abarr)
-								      (make-abar
+						       termr
-								       :list (cons brgn1 (abar-list abarr))))))
+						       (term
+							(* cffc1 cffcr)
+							(make-abar
+							 :list (cons
+								brgn1
+								(abar-list
+								 abarr))))))
 						 listr))))
 			       list1))))))
 
+
 (DEFUN NCMBN-BAR (cmbn-list)
   (declare (list cmbn-list))
   (the cmbn
@@ -420,12 +376,7 @@
          (cmbn-abar-cmbn-tnpr
 	  (first cmbn-list)
 	  (ncmbn-bar (rest cmbn-list))))))
-#|
+
-(ncmbn-bar nil)
-(ncmbn-bar (list (cmbn 3 2 'a 3 'b)))
-(ncmbn-bar (list (cmbn 1 2 'a 3 'b) (cmbn 2 4 'c 5 'd)))
-(ncmbn-bar (list (cmbn 1 2 'a 3 'b) (cmbn 1 4 'c 5 'd) (cmbn 1 6 'e 7 'f))))
-|#
 
 (DEFUN MRPH-VRTC-BAR-INTR (mrph)
   (declare (type morphism mrph))
@@ -442,14 +393,6 @@
 			 (abar-list abar))))))
     (the intr-mrph #'rslt)))
 
-#|
-(setf cc (build-chcm :cmpr #'f-cmpr :strt :cmbn))
-(setf m (build-mrph :sorc cc :trgt cc :degr 0 :intr
-		    #'(lambda (degr gnrt) (cmbn degr 2 gnrt 3 (1+ gnrt)))
-		    :strt :gnrt :orgn '(test)))
-(setf r (mrph-vrtc-bar-intr m))
-(funcall r 4 (abar 2 3 2 4))
-|#
 
 (DEFMETHOD VRTC-BAR ((mrph morphism))
   (the morphism
@@ -463,12 +406,6 @@
             :strt :gnrt
             :orgn `(vrtc-bar ,mrph)))))
 
-#|
-(cat-init)
-(setf f (aw (soft-delta-infinity) (soft-delta-infinity)))
-(setf cf (vrtc-bar f))
-(? cf 6 (abar 3 (crpr 0 (d 7) 0 (d 7)) 3 (crpr 0 (d 56) 0 (d 56))))
-|#
 
 (DEFUN HMTP-VRTC-BAR-INTR (h gf)
   (declare (type morphism h gf))
@@ -484,11 +421,13 @@
 		(type brgn brgn1)
 		(list rest2))
 	       (with-brgn (degr1 gnrt1) brgn1
-			  (let ((h-gnrt1 (cmbn-list (gnrt-? h (1- degr1) gnrt1)))
+			  (let ((h-gnrt1 (cmbn-list (gnrt-? h (1- degr1)
+							    gnrt1)))
 				(h-rest2 (rslt (- degr degr1) rest2))
 				(degr1+1 (1+ degr1))
 				(rest-sign (-1-expt-n degr1))
-				(gf-gnrt1 (cmbn-list (gnrt-? gf (1- degr1) gnrt1))))
+				(gf-gnrt1 (cmbn-list (gnrt-? gf (1- degr1)
+							     gnrt1))))
 			    (declare
 			     (fixnum degr1+1 rest-sign)
 			     (type icmbn h-gnrt1 h-rest2 gf-gnrt1))
@@ -500,9 +439,13 @@
 					     (mapcar
 					      #'(lambda (term2)
 						  (declare (type term term2))
-						  (with-term (cffc2 iabar2) term2
+						  (with-term (cffc2 iabar2)
-							     (term (* rest-sign cffc1 cffc2)
+						    term2
-								   (cons (brgn degr1 gnrt11) iabar2))))
+						    (term (* rest-sign cffc1
+							     cffc2)
+							  (cons
+							   (brgn degr1 gnrt11)
+							   iabar2))))
 					      h-rest2)))
 			      gf-gnrt1)
 			     (mapcar
@@ -510,7 +453,9 @@
 				  (declare (type term term1))
 				  (with-term (cffc1 gnrt11) term1
 					     (term (- cffc1)
-						   (cons (brgn degr1+1 gnrt11) rest2))))
+						   (cons
+						    (brgn degr1+1 gnrt11)
+						    rest2))))
 			      h-gnrt1)))))))
     (the intr-mrph
 	 #'(lambda (degr abar)
@@ -529,14 +474,6 @@
 				    (term cffc (make-abar :list iabar))))
 		     (rslt degr (abar-list abar))))))))
 
-#|
-(cat-init)
-(setf ez (ez (delta-infinity) (delta-infinity)))
-(setf h (h ez) gf (cmps (g ez) (f ez)))
-(setf r (hmtp-vrtc-bar-intr h gf))
-(funcall r 3 (abar 3 (crpr 0 7 0 7)))
-(funcall r 9 (abar 3 (crpr 0 7 0 7) 3 (crpr 0 14 0 14) 3 (crpr 0 14 0 14)))
-|#
 
 (DEFUN HMTP-VRTC-BAR (h gf)
   (declare (type morphism h gf))
@@ -567,72 +504,6 @@
 	      :h (hmtp-vrtc-bar h (cmps g f))
 	      :orgn `(vrtc-bar ,rdct))))))
 
-#|
-(cat-init)
-(setf tcc (build-chcm
-	   :cmpr #'s-cmpr
-	   :basis #'(lambda (degr) '(a b c d))
-	   :bsgn 'd
-	   :intr-dffr #'(lambda (degr gnrt)
-			  (ecase gnrt
-			    (a (cmbn (1- degr) 1 'b 1 'd))
-			    ((b d) (cmbn (1- degr)))
-			    (c (cmbn (1- degr) 1 'd))))
-	   :strt :gnrt
-	   :orgn '(tcc)))
-(setf bcc (build-chcm
-	   :cmpr #'s-cmpr
-	   :basis #'(lambda (degr) '(c d))
-	   :bsgn 'd
-	   :intr-dffr #'(lambda (degr gnrt)
-			  (ecase gnrt
-			    (d (cmbn (1- degr)))
-			    (c (cmbn (1- degr) 1 'd))))
-	   :strt :gnrt
-	   :orgn '(bcc)))
-(setf f (build-mrph :sorc tcc :trgt bcc :degr 0
-		    :intr #'(lambda (degr gnrt)
-			      (ecase gnrt
-				(a (cmbn degr 1 'c 1 'd))
-				(b (cmbn degr))
-				((c d) (cmbn degr 1 gnrt))))
-		    :strt :gnrt :orgn '(f)))
-(setf g (build-mrph :sorc bcc :trgt tcc :degr 0
-		    :intr #'identity :strt :cmbn :orgn '(g)))
-(setf h (build-mrph :sorc tcc :trgt tcc :degr +1
-		    :intr #'(lambda (degr gnrt)
-			      (ecase gnrt
-				((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd))
-				((c d) (cmbn (1+ degr)))))
-		    :strt :gnrt :orgn '(h)))
-(setf rdct (build-rdct :f f :g g :h h :orgn '(rdct)))
-(tcc rdct 3 'a)
-(g rdct (f rdct 3 'a))
-(h rdct 3 'a)
-(setf bar (vrtc-bar rdct))
-(pre-check-rdct bar)
-(defun aleat-tc ()
-  (do ((tdegr 0 (+ tdegr degr))
-       (degr (+ 2 (random 3)) (+ 2 (random 3)))
-       (gnrt (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))
-	     (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)))
-       (rslt nil (cons (brgn degr gnrt) rslt)))
-      ((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-abar :list rslt))))))
-(aleat-tc)
-(defun aleat-bc ()
-  (do ((tdegr 0 (+ tdegr degr))
-       (degr (+ 2 (random 3)) (+ 2 (random 3)))
-       (gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))
-	     (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)))
-       (rslt nil (cons (brgn degr gnrt) rslt)))
-      ((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-abar :list rslt))))))
-(aleat-bc)
-(defun c ()
-  (aleat-tc)
-  (aleat-bc)
-  (check-rdct))
-(loop (c))  ;; degrees >= 15 is possible => error.
-|#
 
 (DEFMETHOD VRTC-BAR ((hmeq homotopy-equivalence))
   (the homotopy-equivalence

test/bar-test.lisp

@@ -81,6 +81,23 @@
 							  (cat:abar-list abar)))
 				     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))
@@ -90,4 +107,174 @@
 	(funcall r 6 (cat:abar 3 '(2 3) 3 '(-2 -3)))
 	(funcall r 9 (cat:abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3)))
 	(funcall r 11 (cat:abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3)))))
+
+
+(test bar-hrzn-dffr
+      (progn
+	(cat:cat-init)
+	(let ((h (cat:bar-hrzn-dffr (cat:k-z-1)))
+	      (abar))
+	  (dotimes (i 10)
+	    (print (random-abar1 10 5)))
+	  (setf abar (random-abar1 10 5))
+	  (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
+	  (cat:? h (cat:? h (apply #'+ (mapcar #'car
+					       (cat:abar-list abar))) abar))
+	  (dotimes (i 10)
+	    (setf abar (random-abar1 10 3))
+	    (print abar)
+	    (print (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar)))
+			  abar))
+	    (print (cat:? h (cat:? h (apply #'+ (mapcar #'car
+							(cat:abar-list abar)))
+				   abar)))))))
+
+
+(test bar
+      (progn
+	(cat:cat-init)
+	(let ((b (cat:bar (cat:k-z-1)))
+	      (abar (random-abar1 10 3)))
+	  (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
+	  (cat:? b (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
+			  abar))
+	  (dotimes (i 10)
+	    (let ((abar (random-abar1 10 3)))
+	      (print abar)
+	      (print (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
+			    abar))
+	      (print (cat:? b
+			    (cat:? b
+				   (apply #'+ (mapcar #'car
+						      (cat:abar-list abar)))
+				   abar))))))))
+
+|#
+
+(test ncmbn-bar
+      (cat:ncmbn-bar nil)
+      (cat:ncmbn-bar (list (cat:cmbn 3 2 'a 3 'b)))
+      (cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 2 4 'c 5 'd)))
+      (cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 1 4 'c 5 'd)
+			   (cat:cmbn 1 6 'e 7 'f))))
+
+#|
+(test mrph-vrtc-bar-intr
+      (let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr :strt :cmbn))
+	     (m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr
+				#'(lambda (degr gnrt)
+				    (cat:cmbn degr 2 gnrt 3 (1+ gnrt)))
+				:strt :gnrt :orgn '(test)))
+	     (r (cat:mrph-vrtc-bar-intr m)))
+	(funcall r 4 (cat:abar 2 3 2 4))))
+|#
+
+(test vrtc-bar
+      (progn
+	(cat:cat-init)
+	(let* ((f (cat:aw (cat:soft-delta-infinity)
+			  (cat:soft-delta-infinity)))
+	       (cf (cat:vrtc-bar f)))
+	  (cat:? cf 6 (cat:abar 3 (cat:crpr 0 (cat:d 7) 0 (cat:d 7)) 3
+				(cat:crpr 0 (cat:d 56) 0 (cat:d 56)))))))
+
+(test hmtp-vrtc-bar-intr
+      (progn
+	(cat:cat-init)
+	(let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
+	       (h (cat:h ez))
+	       (gf (cat:cmps (cat:g ez) (cat:f ez)))
+	       (r (cat:hmtp-vrtc-bar-intr h gf)))
+	  (funcall r 3 (cat:abar 3 (cat:crpr 0 7 0 7)))
+	  (funcall r 9 (cat:abar 3 (cat:crpr 0 7 0 7) 3 (cat:crpr 0 14 0 14)
+				 3 (cat:crpr 0 14 0 14))))))
+
+
+(defun aleat-tc ()
+  (do ((tdegr 0 (+ tdegr degr))
+       (degr (+ 2 (random 3)) (+ 2 (random 3)))
+       (gnrt (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))
+	     (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)))
+       (rslt nil (cons (cat:brgn degr gnrt) rslt)))
+      ((> tdegr 10) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar
+						  :list rslt))))))
+
+
+(defun aleat-bc ()
+  (do ((tdegr 0 (+ tdegr degr))
+       (degr (+ 2 (random 3)) (+ 2 (random 3)))
+       (gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))
+	     (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)))
+       (rslt nil (cons (cat:brgn degr gnrt) rslt)))
+      ((> tdegr 10) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar
+						  :list rslt))))))
+
+
+(defun c ()
+  (aleat-tc)
+  (aleat-bc)
+  (check-rdct))
+
+#|
+
+(test vrtc-bar
+      (progn
+	(cat:cat-init)
+
+	(let* ((tcc (cat:build-chcm
+		     :cmpr #'cat:s-cmpr
+		     :basis #'(lambda (degr) '(a b c d))
+		     :bsgn 'd
+		     :intr-dffr #'(lambda (degr gnrt)
+				    (ecase gnrt
+				      (a (cat:cmbn (1- degr) 1 'b 1 'd))
+				      ((b d) (cat:cmbn (1- degr)))
+				      (c (cat:cmbn (1- degr) 1 'd))))
+		     :strt :gnrt
+		     :orgn '(tcc)))
+	       (bcc (cat:build-chcm
+		     :cmpr #'cat:s-cmpr
+		     :basis #'(lambda (degr) '(c d))
+		     :bsgn 'd
+		     :intr-dffr #'(lambda (degr gnrt)
+				    (ecase gnrt
+				      (d (cat:cmbn (1- degr)))
+				      (c (cat:cmbn (1- degr) 1 'd))))
+		     :strt :gnrt
+		     :orgn '(bcc)))
+	       (f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
+				  :intr #'(lambda (degr gnrt)
+					    (ecase gnrt
+					      (a (cat:cmbn degr 1 'c 1 'd))
+					      (b (cat:cmbn degr))
+					      ((c d) (cat:cmbn degr 1 gnrt))))
+				  :strt :gnrt :orgn '(f)))
+	       (g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
+				  :intr #'identity :strt :cmbn :orgn '(g)))
+	       (h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
+				  :intr #'(lambda (degr gnrt)
+					    (ecase gnrt
+					      ((a b) (cat:cmbn
+						      (1+ degr)
+						      1 'a -1 'b -1 'c -1 'd))
+					      ((c d) (cat:cmbn (1+ degr)))))
+				  :strt :gnrt :orgn '(h)))
+	       (rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
+	       (bar))
+	  (cat:tcc rdct 3 'a)
+	  (cat:g rdct (cat:f rdct 3 'a))
+	  (cat:h rdct 3 'a)
+	  (setf bar (cat:vrtc-bar rdct))
+	  (cat:pre-check-rdct bar)
+	  (aleat-tc)
+	  (aleat-bc)
+	  (loop (c))))) ;; degrees >= 15 is possible => error.
+
+(test bar
+      (progn
+	(cat:cat-init)
+	(let* ((h (cat:efhm (cat:k-z-1)))
+	       (b (cat:bar h)))
+	  ;;(inspect b)
+	  (cat:homology (cat:rbcc b) 0 11))))
 |#