diff --git a/kenzo-test.asd b/kenzo-test.asd index bb654d5..de76e07 100644 --- a/kenzo-test.asd +++ b/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") + )) diff --git a/package.lisp b/package.lisp index 3e7e712..1b525dc 100644 --- a/package.lisp +++ b/package.lisp @@ -283,6 +283,10 @@ HOMOLOGY + ;; simplicial-mrphs.lisp + + BUILD-SMMR + ;; simplicial-sets.lisp 1DGNR diff --git a/src/simplicial-mrphs.lisp b/src/simplicial-mrphs.lisp index d72a832..c726420 100644 --- a/src/simplicial-mrphs.lisp +++ b/src/simplicial-mrphs.lisp @@ -8,29 +8,30 @@ (DEFMETHOD ?3 ((smmr simplicial-mrph) dmns absm-or-gmsm) (declare - (fixnum dmns) - (type (or absm gmsm) absm-or-gmsm)) + (fixnum dmns) + (type (or absm gmsm) absm-or-gmsm)) (typecase absm-or-gmsm - (absm - (with-absm (dgop gmsm) absm-or-gmsm - (let ((gmsm-smmr (funcall (sintr smmr) - (- dmns (logcount dgop)) gmsm))) - (declare (type absm gmsm-smmr)) - (ndgnr dgop gmsm-smmr)))) - (otherwise - (funcall (sintr smmr) dmns absm-or-gmsm)))) + (absm + (with-absm (dgop gmsm) absm-or-gmsm + (let ((gmsm-smmr (funcall (sintr smmr) + (- dmns (logcount dgop)) gmsm))) + (declare (type absm gmsm-smmr)) + (ndgnr dgop gmsm-smmr)))) + (otherwise + (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 - (if (= -1 (degr smmr)) - (format stream "[K~D Fibration K~D -> K~D]" - (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr))) - (format stream "[K~D Simplicial-Morphism K~D -> K~D]" - (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr)))) - smmr))) + (progn + (if (= -1 (degr smmr)) + (format stream "[K~D Fibration K~D -> K~D]" + (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr))) + (format stream "[K~D Simplicial-Morphism K~D -> K~D]" + (idnm smmr) (idnm (sorc smmr)) (idnm (trgt 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)) - (flet ((rslt (dmns gmsm) - (declare - (fixnum dmns) - (type gmsm gmsm)) - (when (minusp dmns) - (return-from rslt (zero-cmbn dmns))) - (let ((rslt (funcall sintr dmns gmsm))) - (declare (type absm rslt)) - (if (degenerate-p rslt) - (zero-cmbn dmns) - (term-cmbn dmns 1 (gmsm rslt)))))) - (the intr-mrph #'rslt))) + (declare (type sintr sintr)) + (flet ((rslt (dmns gmsm) + (declare + (fixnum dmns) + (type gmsm gmsm)) + (when (minusp dmns) + (return-from rslt (zero-cmbn dmns))) + (let ((rslt (funcall sintr dmns gmsm))) + (declare (type absm rslt)) + (if (degenerate-p rslt) + (zero-cmbn dmns) + (term-cmbn dmns 1 (gmsm rslt)))))) + (the intr-mrph #'rslt))) + (DEFUN BUILD-SMMR (&key sorc trgt degr sintr intr strt orgn) - (declare - (type simplicial-set sorc trgt) - (fixnum degr) - (type sintr sintr) - (type (or intr-mrph null) intr) - (type (or strt null) strt) - (list orgn)) - (the simplicial-mrph - (progn + (declare + (type simplicial-set sorc trgt) + (fixnum degr) + (type sintr sintr) + (type (or intr-mrph null) intr) + (type (or strt null) strt) + (list orgn)) + (the simplicial-mrph + (progn (let ((already (find orgn *smmr-list* :test #'equal :key #'orgn))) - (declare (type (or simplicial-mrph null) already)) - (when already - (return-from build-smmr already))) + (declare (type (or simplicial-mrph null) already)) + (when 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")) - (setf strt :gnrt - intr (sintr-intr sintr))) - (setf intr nil strt :gnrt)) + (error "In BUILD-SMMR, an intr is given but not its strt")) + (setf strt :gnrt + intr (sintr-intr sintr))) + (setf intr nil strt :gnrt)) (let ((rslt (build-mrph - :sorc sorc :trgt trgt :degr degr - :intr intr :strt strt - :orgn orgn))) + :sorc sorc :trgt trgt :degr degr + :intr intr :strt strt + :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 m (build-smmr - :sorc d :trgt d :degr 0 - :sintr #'(lambda (dmns gmsm) - (absm 0 gmsm)) - :orgn '(identity delta-3))) - (setf m2 (build-smmr - :sorc d :trgt d :degr 0 - :sintr #'(lambda (dmns gmsm) - (absm (mask dmns) 1)) - :orgn '(null delta-3))) - (? m2 2 7) +(setf d (delta 3)) +(setf m (build-smmr + :sorc d :trgt d :degr 0 + :sintr #'(lambda (dmns gmsm) + (absm 0 gmsm)) + :orgn '(identity delta-3))) +(setf m2 (build-smmr + :sorc d :trgt d :degr 0 + :sintr #'(lambda (dmns gmsm) + (absm (mask dmns) 1)) + :orgn '(null delta-3))) +(? m2 2 7) ;; (s? m2 2 7) |# -#| ???? +#| ???? (DEFUN IA-SINTR3 (sintr dmns iabsm) (declare - (type sintr sintr) - (fixnum dmns) - (type iabsm iabsm)) + (type sintr sintr) + (fixnum dmns) + (type iabsm iabsm)) (the absm - (with-iabsm (dgop gmsm) iabsm - (ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm))))) + (with-iabsm (dgop gmsm) iabsm + (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 - (ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm))))) + (with-absm (dgop gmsm) absm + (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 - (let ((dmns-1 (1- dmns))) - (declare (fixnum dmns-1)) - (if (logbitp dmns-1 dgop) - (absm (mask dmns-1) bspn) - (ndgnr dgop (funcall sintr - (- dmns (logcount dgop)) - gmsm))))))) + (with-absm (dgop gmsm) absm + (let ((dmns-1 (1- dmns))) + (declare (fixnum dmns-1)) + (if (logbitp dmns-1 dgop) + (absm (mask dmns-1) bspn) + (ndgnr dgop (funcall sintr + (- dmns (logcount dgop)) + gmsm))))))) #| (DEFUN TW-IA-SINTR3 (sintr dmns iabsm bspn) (declare - (type sintr sintr) - (fixnum dmns) - (type iabsm iabsm) - (type gmsm bspn)) + (type sintr sintr) + (fixnum dmns) + (type iabsm iabsm) + (type gmsm bspn)) (the absm - (with-iabsm (dgop gmsm) iabsm - (let ((dmns-1 (1- dmns))) - (declare (fixnum dmns-1)) - (if (logbitp dmns-1 dgop) - (absm (mask dmns-1) bspn) - (ndgnr dgop (funcall sintr - (- dmns (logcount dgop)) - gmsm))))))) + (with-iabsm (dgop gmsm) iabsm + (let ((dmns-1 (1- dmns))) + (declare (fixnum dmns-1)) + (if (logbitp dmns-1 dgop) + (absm (mask dmns-1) bspn) + (ndgnr dgop (funcall sintr + (- dmns (logcount dgop)) + gmsm))))))) |# diff --git a/test/simplicial-mrphs-test.lisp b/test/simplicial-mrphs-test.lisp new file mode 100644 index 0000000..c89741b --- /dev/null +++ b/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) + ))