Added first batch of ABAR tests.

kenzo-test.asd

@@ -20,4 +20,5 @@
 	       (:file "bicones-test")
 	       (:file "homology-groups-test")
 	       (:file "searching-homology-test")
-	       (:file "delta-test")))
+	       (:file "delta-test")
+	       (:file "bar-test")))

package.lisp

@@ -20,6 +20,16 @@
 	   *TC*
 	   *TDD*
 
+	   ;; bar.lisp
+
+	   ABAR
+	   BAR-BASIS-LENGTH
+	   BAR-BASIS
+	   BAR-CMPR
+	   BAR-INTR-HRZN-DFFR
+	   BAR-INTR-VRTC-DFFR
+	   VRTC-BAR
+
 	   ;; bicones.lisp
 
 	   BICN-CMBN-CMBNB
@@ -64,6 +74,7 @@
 	   ;; classes.lisp
 
 	   BCC
+	   BRGN
 	   CHAIN-COMPLEX
 	   CMBN-CMBN
 	   CMBN-DEGR
@@ -78,6 +89,7 @@
 	   HOMOTOPY-EQUIVALENCE
 	   IABSM
 	   LRDCT
+	   MAKE-ABAR
 	   MAKE-CMBN
 	   MAKE-RESULT
 	   MORPHISM
@@ -146,11 +158,14 @@
 	   ;; k-pi-n.lisp
 
 	   K-Z
+	   K-Z-1
 
 	   ;; macros.lisp
 
 	   -1-EXPT-N
 	   ?
+	   ABAR-LIST
+	   APRD
 	   BASIS
 	   BCC
 	   BCNB

src/bar.lisp

@@ -23,13 +23,7 @@
 	   (declare (list mark))
 	   (push (brgn (car mark) (cadr mark)) rslt))
 	 (make-abar :list rslt))))
-#|
+
-()
-(abar )
-(abar '(2 a 3 b))
-(abar 2 'a 3 'b)
-(abar 2 'a 3))  ;; error
-|#
 
 #-sbcl (DEFINE-CONSTANT +NULL-ABAR+ (make-abar :list +empty-list+))
 #+sbcl (DEFPARAMETER +NULL-ABAR+ (make-abar :list +empty-list+))
@@ -68,7 +62,6 @@
 ;;; CLISP]+
 
 
-
 (DEFUN BAR-CMPR (cmpr)
   (declare (type cmprf cmpr))
   (flet ((rslt (abar1 abar2)
@@ -87,14 +80,6 @@
 		    list1 list2))))))
     (the cmprf #'rslt)))
 
-#|
-  (setf r (bar-cmpr #'s-cmpr))
-  (funcall r (abar) (abar))
-  (funcall r (abar 3 'a) (abar))
-  (funcall r (abar 3 'a) (abar 2 'a 1 'b))
-  (funcall r (abar 3 'a) (abar 3 'b))
-  (funcall r (abar 3 'a) (abar 3 'a)))
-|#
 
 (DEFUN BAR-BASIS-LENGTH (basis degr length)
   (declare
@@ -129,26 +114,6 @@
 		 list1)))
 	  (>a-b< 1 (1- degr))))))
 
-#|
-()
-(setf basis #'(lambda (degr)
-                (list degr)))
-(bar-basis-length basis 2 1)
-(bar-basis-length basis 2 2)
-(bar-basis-length basis 3 1)
-(bar-basis-length basis 3 2)
-(bar-basis-length basis 4 1)
-(bar-basis-length basis 4 2)
-(bar-basis-length basis 4 3)
-(bar-basis-length basis 4 4)
-(bar-basis-length basis 8 1)
-(bar-basis-length basis 8 2)
-(bar-basis-length basis 8 3)
-(bar-basis-length basis 8 4)
-(bar-basis-length basis 8 5)
-(bar-basis-length basis 8 6)
-(bar-basis-length basis 8 11))
-|#
 
 (DEFUN BAR-BASIS (basis)
   (declare (type basis basis))
@@ -173,18 +138,6 @@
 			(>a-b> 0 (floor degr 2)))))))
 	   #'rslt))))
 
-#|
-()
-(setf basis #'(lambda (degr)
-                (list degr)))
-(setf r (bar-basis basis))
-(funcall r 0)
-(funcall r 1)
-(funcall r 2)
-(dotimes (i 7)
-  (print (funcall r i)))
-(bar-basis :locally-effective))
-|#
 
 (DEFUN BAR-INTR-VRTC-DFFR (dffr)
   (declare (type morphism dffr))
@@ -205,7 +158,8 @@
 		  (type brgn brgn1)
 		  (type iabar rest2))
 		 (with-brgn (degr1 gnrt1) brgn1
-                (let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1- degr1) gnrt1)))
+			    (let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1- degr1)
+							      gnrt1)))
 				  (d-rest2 (rslt (- degr degr1) rest2))
 				  (degr1-1 (1- degr1))
 				  (rest-sign (-1-expt-n degr1)))
@@ -218,7 +172,8 @@
 				    (declare (type term term))
 				    (with-term (cffc gnrt) term
 					       (term (- cffc)
-				     (cons (brgn degr1-1 gnrt) rest2))))
+						     (cons (brgn degr1-1 gnrt)
+							   rest2))))
 				d-gnrt1)
 			       (mapcar
 				#'(lambda (term)
@@ -239,17 +194,10 @@
 				    (term cffc (make-abar :list iabar))))
 		     (rslt degr (abar-list abar))))))))
 
-#|
-  (setf d (soft-delta-infinity))
-  (setf r (bar-intr-vrtc-dffr (dffr d)))
-  (funcall r 0 (abar))
-  (funcall r 3 (abar 3 (d 7)))
-  (funcall r 5 (abar 3 (d 7) 2 (d 3)))
-  (funcall r 5 (abar 2 (d 3) 3 (d 7))))
-|#
 
 (DEFGENERIC VRTC-BAR (chcm-hmeq-mrph))
 
+
 (DEFMETHOD VRTC-BAR ((chcm chain-complex))
   (the chain-complex
        (with-slots (cmpr basis dffr) chcm
@@ -265,24 +213,6 @@
 	  :strt :gnrt
 	  :orgn `(vrtc-bar ,chcm)))))
 
-#|
-  (cat-init)
-  (setf v (vrtc-bar (soft-delta-infinity)))
-  (defun random-abar (length)
-     (let ((rslt nil))
-        (dotimes (i length)
-           (let* ((gmsm (random (mask 7)))
-                  (dmns (1- (logcount gmsm))))
-              (when (plusp dmns)
-                 (push (brgn (1+ dmns) (d gmsm)) rslt))))
-        (make-abar :list rslt)))
-  (dotimes (i 10) (print (random-abar 5)))
-  (dotimes (i 10)
-     (let ((abar (random-abar 3)))
-        (print abar)
-        (print (? v (apply #'+ (mapcar #'car (abar-list abar))) abar))
-        (print (? v (? v (apply #'+ (mapcar #'car (abar-list abar))) abar)))))
-|#
 
 (DEFUN BAR-INTR-HRZN-DFFR (aprd)
   (declare (type morphism aprd))
@@ -304,26 +234,44 @@
 		      (with-brgn (degr1 gnrt1) brgn1
 				 (with-brgn (degr2 gnrt2) brgn2
 					    (let ((sign (-1-expt-n degr1))
-				 (aprd-brgn1-brgn2 (gnrt-? aprd (+ degr1 degr2 -2)
+						  (aprd-brgn1-brgn2
-							   (tnpr (1- degr1) gnrt1
+						   (gnrt-? aprd
-								 (1- degr2) gnrt2)))
+							   (+ degr1 degr2 -2)
-				 (aprd-rest1 (rslt (- degr degr1) rest1)))				  
+							   (tnpr (1- degr1)
+								 gnrt1
+								 (1- degr2)
+								 gnrt2)))
+						  (aprd-rest1 (rslt
+							       (- degr degr1)
+							       rest1)))
 					      (declare
-			      (type icmbn aprd-brgn1-brgn2 aprd-rest1))
+					       (type icmbn aprd-brgn1-brgn2
-			     (with-cmbn (degr12 icmbn12) aprd-brgn1-brgn2
+						     aprd-rest1))
+					      (with-cmbn (degr12 icmbn12)
+						aprd-brgn1-brgn2
 						(incf degr12)
 						(nconc
 						 (mapcar
 						  #'(lambda (term2)
-				     (declare (type term term2))
+						      (declare (type term
-				     (with-term (cffc2 iabar2) term2
+								     term2))
-				       (term (* sign cffc2) (cons brgn1 iabar2))))
+						      (with-term (cffc2 iabar2)
+							term2
+							(term (* sign cffc2)
+							      (cons brgn1
+								    iabar2))))
 						  aprd-rest1)
 						 (mapcar
 						  #'(lambda (term1)
-				      (declare (type term term1))
+						      (declare (type term
-				      (with-term (cffc1 gnrt12) term1
+								     term1))
-					(term (* sign cffc1) (cons (brgn degr12 gnrt12) rest2))))
+						      (with-term (cffc1 gnrt12)
+							term1
+							(term (* sign cffc1)
+							      (cons (brgn
+								     degr12
+								     gnrt12)
+								    rest2))))
 						  icmbn12)))))))))))
     (the intr-mrph
          #'(lambda (degr abar)
@@ -335,18 +283,11 @@
 			     :list (mapcar #'(lambda (term)
 					       (declare (type term term))
 					       (with-term (cffc iabar) term
-                                          (term cffc (make-abar :list iabar))))
+							  (term cffc
+								(make-abar
+								 :list iabar))))
 					   (rslt degr (abar-list abar)))))))))
 
-#|
-  (setf k (k-z-1))
-  (setf r (bar-intr-hrzn-dffr (aprd k)))
-  (funcall r 0 (abar ))
-  (funcall r 3 (abar 3 '(2 3)))
-  (funcall r 6 (abar 3 '(2 3) 3 '(-2 -3)))
-  (funcall r 9 (abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3)))
-  (funcall r 11 (abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3))))
-|#
 
 (DEFUN BAR-HRZN-DFFR (algb)
   (declare (type algebra algb))

test/bar-test.lisp

@@ -0,0 +1,93 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(test abar
+      (cat:abar )
+      (cat:abar '(2 a 3 b))
+      (cat:abar 2 'a 3 'b)
+      (signals simple-error (cat:abar 2 'a 3)))
+
+(test bar-cmpr
+      (let ((r (cat:bar-cmpr #'cat:s-cmpr)))
+	(is (equal :equal (funcall r (cat:abar) (cat:abar))))
+	(is (equal :greater (funcall r (cat:abar 3 'a) (cat:abar))))
+	(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 2 'a 1 'b))))
+	(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 3 'b))))
+	(is (equal :equal (funcall r (cat:abar 3 'a) (cat:abar 3 'a))))))
+
+(test bar-basis-length
+      (let ((basis #'(lambda (degr) (list degr))))
+	(cat:bar-basis-length basis 2 1)
+	(cat:bar-basis-length basis 2 2)
+	(cat:bar-basis-length basis 3 1)
+	(cat:bar-basis-length basis 3 2)
+	(cat:bar-basis-length basis 4 1)
+	(cat:bar-basis-length basis 4 2)
+	(cat:bar-basis-length basis 4 3)
+	(cat:bar-basis-length basis 4 4)
+	(cat:bar-basis-length basis 8 1)
+	(cat:bar-basis-length basis 8 2)
+	(cat:bar-basis-length basis 8 3)
+	(cat:bar-basis-length basis 8 4)
+	(cat:bar-basis-length basis 8 5)
+	(cat:bar-basis-length basis 8 6)
+	(cat:bar-basis-length basis 8 11)))
+
+
+(test bar-basis
+      (let* ((basis #'(lambda (degr) (list degr)))
+	     (r (cat:bar-basis basis)))
+	(funcall r 0)
+	(funcall r 1)
+	(funcall r 2)
+	(dotimes (i 7)
+	  (print (funcall r i)))
+	(cat:bar-basis :locally-effective)))
+
+
+(test bar-intr-vrtc-dffr
+      (let* ((d (cat:soft-delta-infinity))
+	     (r (cat:bar-intr-vrtc-dffr (cat:dffr d))))
+	(funcall r 0 (cat:abar))
+	(funcall r 3 (cat:abar 3 (cat:d 7)))
+	(funcall r 5 (cat:abar 3 (cat:d 7) 2 (cat:d 3)))
+	(funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7)))))
+
+
+(defun random-abar (length)
+  (let ((rslt nil))
+    (dotimes (i length)
+      (let* ((gmsm (random (cat:mask 7)))
+	     (dmns (1- (logcount gmsm))))
+	(when (plusp dmns)
+	  (push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt))))
+    (cat:make-abar :list rslt)))
+
+
+(test vrtc-bar
+      (progn
+	(cat:cat-init)
+	(let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
+	  (dotimes (i 10)
+	    (print (random-abar 5)))
+	  (dotimes (i 10)
+	    (let ((abar (random-abar 3)))
+	      (print abar)
+	      (print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
+			    abar))
+	      (print (cat:? v (cat:? v (apply #'+ (mapcar #'car
+							  (cat:abar-list abar)))
+				     abar))))))))
+
+#|
+(test bar-intr-hrzn-dffr
+      (let* ((k (cat:k-z-1))
+	     (r (cat:bar-intr-hrzn-dffr (cat:aprd k))))
+	(funcall r 0 (cat:abar ))
+	(funcall r 3 (cat:abar 3 '(2 3)))
+	(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)))))
+|#