Extracted simplicial morphism tests.

kenzo-test.asd

@@ -27,6 +27,8 @@
 	       (:file "k-pi-n-test")
 	       (:file "kan-test")
 	       (:file "searching-homology-test")
+	       (:file "simplicial-mrphs-test")
 	       (:file "simplicial-sets-test")
 	       (:file "tensor-products-test")
-	       (:file "various-test")))
+	       (:file "various-test")
+	       ))

package.lisp

@@ -283,6 +283,10 @@
 
 	   HOMOLOGY
 
+	   ;; simplicial-mrphs.lisp
+
+	   BUILD-SMMR
+
 	   ;; simplicial-sets.lisp
 
 	   1DGNR

src/simplicial-mrphs.lisp

@@ -8,29 +8,30 @@
 
 (DEFMETHOD ?3 ((smmr simplicial-mrph) dmns absm-or-gmsm)
   (declare
-     (fixnum dmns)
+   (fixnum dmns)
-     (type (or absm gmsm) absm-or-gmsm))
+   (type (or absm gmsm) absm-or-gmsm))
   (typecase absm-or-gmsm
-     (absm
+    (absm
-      (with-absm (dgop gmsm) absm-or-gmsm
+     (with-absm (dgop gmsm) absm-or-gmsm
-         (let ((gmsm-smmr (funcall (sintr smmr)
+		(let ((gmsm-smmr (funcall (sintr smmr)
-			     (- dmns (logcount dgop)) gmsm)))
+					  (- dmns (logcount dgop)) gmsm)))
-	   (declare (type absm gmsm-smmr))
+		  (declare (type absm gmsm-smmr))
-	   (ndgnr dgop gmsm-smmr))))
+		  (ndgnr dgop gmsm-smmr))))
-     (otherwise
+    (otherwise
-      (funcall (sintr smmr) dmns absm-or-gmsm))))  
+     (funcall (sintr smmr) dmns absm-or-gmsm))))  
+
 
 #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((smmr simplicial-mrph) stream)
   (the simplicial-mrph
-     (progn
+       (progn
-       (if (= -1 (degr smmr))
+	 (if (= -1 (degr smmr))
-	   (format stream "[K~D Fibration K~D -> K~D]"
+	     (format stream "[K~D Fibration K~D -> K~D]"
-		   (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr)))
+		     (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr)))
-	 (format stream "[K~D Simplicial-Morphism K~D -> K~D]"
+	     (format stream "[K~D Simplicial-Morphism K~D -> K~D]"
-		 (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr))))
+		     (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr))))
-       smmr)))
+	 smmr)))
 #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (ext:package-lock :clos) t))
 
@@ -38,48 +39,50 @@
 (DEFUN SMMR (idnm)
   (declare (fixnum idnm))
   (the (or null simplicial-mrph)
-     (find idnm *smmr-list* :key #'idnm)))
+       (find idnm *smmr-list* :key #'idnm)))
+
 
 (DEFUN SINTR-INTR (sintr)
-   (declare (type sintr sintr))
+  (declare (type sintr sintr))
-   (flet ((rslt (dmns gmsm)
+  (flet ((rslt (dmns gmsm)
-	     (declare
+	   (declare
-	        (fixnum dmns)
+	    (fixnum dmns)
-		(type gmsm gmsm))
+	    (type gmsm gmsm))
-	     (when (minusp dmns)
+	   (when (minusp dmns)
-		(return-from rslt (zero-cmbn dmns)))
+	     (return-from rslt (zero-cmbn dmns)))
-	     (let ((rslt (funcall sintr dmns gmsm)))
+	   (let ((rslt (funcall sintr dmns gmsm)))
-	        (declare (type absm rslt))
+	     (declare (type absm rslt))
-		(if (degenerate-p rslt)
+	     (if (degenerate-p rslt)
-		   (zero-cmbn dmns)
+		 (zero-cmbn dmns)
-		   (term-cmbn dmns 1 (gmsm rslt))))))
+		 (term-cmbn dmns 1 (gmsm rslt))))))
-       (the intr-mrph #'rslt)))
+    (the intr-mrph #'rslt)))
+
 
 (DEFUN BUILD-SMMR (&key sorc trgt degr sintr intr strt orgn)
-   (declare
+  (declare
-      (type simplicial-set sorc trgt)
+   (type simplicial-set sorc trgt)
-      (fixnum degr)
+   (fixnum degr)
-      (type sintr sintr)
+   (type sintr sintr)
-      (type (or intr-mrph null) intr)
+   (type (or intr-mrph null) intr)
-      (type (or strt null) strt)
+   (type (or strt null) strt)
-      (list orgn))
+   (list orgn))
-   (the simplicial-mrph
+  (the simplicial-mrph
-      (progn
+       (progn
 	 (let ((already (find orgn *smmr-list* :test #'equal :key #'orgn)))
-	    (declare (type (or simplicial-mrph null) already))
+	   (declare (type (or simplicial-mrph null) already))
-	    (when already
+	   (when already
-	       (return-from build-smmr already)))
+	     (return-from build-smmr already)))
 	 (if (zerop degr)
 	     (if intr
 		 (unless strt
-			 (error "In BUILD-SMMR, an intr is given but not its strt"))
+		   (error "In BUILD-SMMR, an intr is given but not its strt"))
-	       (setf strt :gnrt
+		 (setf strt :gnrt
-		     intr (sintr-intr sintr)))
+		       intr (sintr-intr sintr)))
-	   (setf intr nil strt :gnrt))
+	     (setf intr nil strt :gnrt))
 	 (let ((rslt (build-mrph
-		        :sorc sorc :trgt trgt :degr degr
+		      :sorc sorc :trgt trgt :degr degr
-			:intr intr :strt strt
+		      :intr intr :strt strt
-			:orgn orgn)))
+		      :orgn orgn)))
 	   (declare (type morphism rslt))
 	   (change-class rslt 'simplicial-mrph)
 	   (setf (slot-value rslt 'sintr) sintr)
@@ -87,30 +90,30 @@
 	   rslt))))
 
 #|
-  (setf d (delta 3))
+(setf d (delta 3))
-  (setf m (build-smmr
+(setf m (build-smmr
-            :sorc d :trgt d :degr 0
+	 :sorc d :trgt d :degr 0
-            :sintr #'(lambda (dmns gmsm)
+	 :sintr #'(lambda (dmns gmsm)
-                        (absm 0 gmsm))
+		    (absm 0 gmsm))
-            :orgn '(identity delta-3)))
+	 :orgn '(identity delta-3)))
-  (setf m2 (build-smmr
+(setf m2 (build-smmr
-            :sorc d :trgt d :degr 0
+	  :sorc d :trgt d :degr 0
-            :sintr #'(lambda (dmns gmsm)
+	  :sintr #'(lambda (dmns gmsm)
-                       (absm (mask dmns) 1))
+		     (absm (mask dmns) 1))
-            :orgn '(null delta-3)))
+	  :orgn '(null delta-3)))
-  (? m2 2 7)
+(? m2 2 7)
 ;;  (s? m2 2 7)
 |#
 
 #|  ????
 (DEFUN IA-SINTR3 (sintr dmns iabsm)
   (declare
-     (type sintr sintr)
+   (type sintr sintr)
-     (fixnum dmns)
+   (fixnum dmns)
-     (type iabsm iabsm))
+   (type iabsm iabsm))
   (the absm
-     (with-iabsm (dgop gmsm) iabsm
+       (with-iabsm (dgop gmsm) iabsm
-	(ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm)))))
+		   (ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm)))))
 
 (DEFUN A-SINTR3 (sintr dmns absm)
   (declare
@@ -118,8 +121,8 @@
    (fixnum dmns)
    (type absm absm))
   (the absm
-     (with-absm (dgop gmsm) absm
+       (with-absm (dgop gmsm) absm
-       (ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm)))))
+		  (ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm)))))
 |# ;;; ????
 
 
@@ -130,29 +133,29 @@
    (type absm absm)
    (type gmsm bspn))
   (the absm
-    (with-absm (dgop gmsm) absm
+       (with-absm (dgop gmsm) absm
-      (let ((dmns-1 (1- dmns)))
+		  (let ((dmns-1 (1- dmns)))
-        (declare (fixnum dmns-1))
+		    (declare (fixnum dmns-1))
-        (if (logbitp dmns-1 dgop)
+		    (if (logbitp dmns-1 dgop)
-          (absm (mask dmns-1) bspn)
+			(absm (mask dmns-1) bspn)
-          (ndgnr dgop (funcall sintr
+			(ndgnr dgop (funcall sintr
-                        (- dmns (logcount dgop))
+					     (- dmns (logcount dgop))
-                        gmsm)))))))
+					     gmsm)))))))
 
 #|
 (DEFUN TW-IA-SINTR3 (sintr dmns iabsm bspn)
   (declare
-     (type sintr sintr)
+   (type sintr sintr)
-     (fixnum dmns)
+   (fixnum dmns)
-     (type iabsm iabsm)
+   (type iabsm iabsm)
-     (type gmsm bspn))
+   (type gmsm bspn))
   (the absm
-     (with-iabsm (dgop gmsm) iabsm
+       (with-iabsm (dgop gmsm) iabsm
-	(let ((dmns-1 (1- dmns)))
+		   (let ((dmns-1 (1- dmns)))
-	  (declare (fixnum dmns-1))
+		     (declare (fixnum dmns-1))
-	  (if (logbitp dmns-1 dgop)
+		     (if (logbitp dmns-1 dgop)
-	     (absm (mask dmns-1) bspn)
+			 (absm (mask dmns-1) bspn)
-	     (ndgnr dgop (funcall sintr
+			 (ndgnr dgop (funcall sintr
-			    (- dmns (logcount dgop))
+					      (- dmns (logcount dgop))
-                           gmsm)))))))
+					      gmsm)))))))
 |#

test/simplicial-mrphs-test.lisp

@@ -0,0 +1,19 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+
+(test build-smmr
+      (let* ((d (cat:delta 3))
+	     (m (cat:build-smmr
+		 :sorc d :trgt d :degr 0
+		 :sintr #'(lambda (dmns gmsm) (cat:absm 0 gmsm))
+		 :orgn '(identity delta-3)))
+	     (m2 (cat:build-smmr
+		  :sorc d :trgt d :degr 0
+		  :sintr #'(lambda (dmns gmsm) (cat:absm (cat:mask dmns) 1))
+		  :orgn '(null delta-3))))
+	(cat:? m2 2 7)
+	;;  (s? m2 2 7)
+	))