From 3fb780645b7b332cac4129aed61f879c6a13311a Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Mon, 13 Jul 2015 18:50:45 -0500 Subject: [PATCH] Extracted Kan tests. --- kenzo-test.asd | 27 +++--- package.lisp | 12 +++ src/kan.lisp | 205 +++++++++++++-------------------------------- test/kan-test.lisp | 117 ++++++++++++++++++++++++++ 4 files changed, 199 insertions(+), 162 deletions(-) create mode 100644 test/kan-test.lisp diff --git a/kenzo-test.asd b/kenzo-test.asd index e44e8a1..bb654d5 100644 --- a/kenzo-test.asd +++ b/kenzo-test.asd @@ -9,23 +9,24 @@ :pathname #P"test/" :components ((:file "package") (:file "common") - (:file "combinations-test") - (:file "various-test") + ;; === test files === + (:file "bar-test") + (:file "bicones-test") + (:file "cartesian-products-test") + (:file "ccn") (:file "chain-complexes-test") (:file "chcm-elementary-op-test") - (:file "diabolo") (:file "circle") - (:file "ccn") - (:file "effective-homology-test") - (:file "bicones-test") - (:file "homology-groups-test") - (:file "searching-homology-test") - (:file "delta-test") - (:file "bar-test") - (:file "cartesian-products-test") + (:file "combinations-test") (:file "cones-test") ;;(:file "cl-space-efhm-test") - (:file "tensor-products-test") + (:file "delta-test") + (:file "diabolo") + (:file "effective-homology-test") + (:file "homology-groups-test") (:file "k-pi-n-test") + (:file "kan-test") + (:file "searching-homology-test") (:file "simplicial-sets-test") - )) + (:file "tensor-products-test") + (:file "various-test"))) diff --git a/package.lisp b/package.lisp index 9717b21..3e7e712 100644 --- a/package.lisp +++ b/package.lisp @@ -233,6 +233,16 @@ Z2-BAR-ABSM Z-COCYCLE-GBAR + ;; kan.lisp + + CHECK-HAT + SMST-KAN + + ;; loop-spaces.lisp + + GDELTAB + LOOP3 + ;; macros.lisp -1-EXPT-N @@ -261,11 +271,13 @@ GNRT GRIN I-SBTR + KFLL MASK RBCC TERM TERM-CMBN TCC + WITH-ABSM ;; searching-homology.lisp diff --git a/src/kan.lisp b/src/kan.lisp index e3ed3cc..4dc6eeb 100644 --- a/src/kan.lisp +++ b/src/kan.lisp @@ -9,121 +9,37 @@ (DEFUN KAN (idnm) (declare (fixnum idnm)) (the (or null simplicial-group) - (find idnm *kan-list* :key #'idnm))) + (find idnm *kan-list* :key #'idnm))) + #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) nil)) (DEFMETHOD PRINT-OBJECT ((kan kan) stream) (the kan - (progn - (format stream "[K~D Kan-Simplicial-Set]" (idnm kan)) - kan))) + (progn + (format stream "[K~D Kan-Simplicial-Set]" (idnm kan)) + kan))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) + (DEFUN SMST-KAN (smst kfll) (declare - (type simplicial-set smst) - (type kfll kfll)) + (type simplicial-set smst) + (type kfll kfll)) (the kan - (progn - (change-class smst 'kan) - (setf (slot-value smst 'kfll) kfll) - (pushnew smst *kan-list*) - smst))) + (progn + (change-class smst 'kan) + (setf (slot-value smst 'kfll) kfll) + (pushnew smst *kan-list*) + smst))) -#| - (setf d (delta-infinity)) - (defun vertex-i (absm i) - (with-absm (dgop gmsm) absm - (let ((dgop (nreverse (dgop-int-ext dgop))) - (gmsm (dlop-int-ext gmsm))) - (do ((dgop-mark dgop) - (gmsm-mark gmsm) - (ii 0 (1+ ii))) - ((= i ii) (car gmsm-mark)) - (if (and dgop-mark - (= ii (car dgop-mark))) - (pop dgop-mark) - (pop gmsm-mark)))))) - (vertex-i (absm 0 1) 0) - (vertex-i (absm 1 1) 0) - (vertex-i (absm 1 1) 1) - (vertex-i (absm 0 3) 0) - (vertex-i (absm 0 3) 1) - (vertex-i (absm 3 1) 0) - (vertex-i (absm 3 1) 1) - (vertex-i (absm 3 1) 2) - (vertex-i (absm 1 3) 0) - (vertex-i (absm 1 3) 1) - (vertex-i (absm 1 3) 2) - (vertex-i (absm 2 3) 0) - (vertex-i (absm 2 3) 1) - (vertex-i (absm 2 3) 2) - (vertex-i (absm 0 7) 0) - (vertex-i (absm 0 7) 1) - (vertex-i (absm 0 7) 2) - (defun absm-int-ext (absm) - (with-absm (dgop gmsm) absm - (do ((dgop (nreverse (dgop-int-ext dgop))) - (gmsm (rest (dlop-int-ext gmsm))) - (i 0 (1+ i)) - (rslt (list (first (dlop-int-ext gmsm))))) - ((and (endp dgop) (endp gmsm)) (nreverse rslt)) - (if dgop - (if (= i (car dgop)) - (progn - (pop dgop) - (push (first rslt) rslt)) - (push (pop gmsm) rslt)) - (return (nreconc rslt gmsm)))))) - (defun absm-ext-int (vlist) - (do ((dgop nil) - (gmsm (list (first vlist))) - (mark (rest vlist) (cdr mark)) - (idgop 0 (1+ idgop))) - ((endp mark) (absm (dgop-ext-int dgop) - (dgop-ext-int gmsm))) - (if (= (first gmsm) (car mark)) - (push idgop dgop) - (push (car mark) gmsm)))) - (absm-ext-int '(0 0 0 1 2 3 3 3)) - (absm-ext-int '(0 1 1 1 2)) - (absm-int-ext (absm-ext-int '(0 0 0 1 2 3 3 3))) - (absm-int-ext (absm-ext-int '(0 1 1 1 2))) - (defun dkfll (indx dmns hat) - (cond ((= 1 dmns) - (absm 1 (gmsm (first hat)))) - ((= 0 indx) - (let ((del-1 (absm-int-ext (first hat))) - (del-2 (absm-int-ext (second hat)))) - (absm-ext-int - (cons (first del-1) - (cons (second del-2) (rest del-1)))))) - ((= 1 indx) - (let ((del-0 (absm-int-ext (first hat))) - (del-2 (absm-int-ext (second hat)))) - (absm-ext-int - (cons (first del-2) del-0)))) - (t - (let ((del-0 (absm-int-ext (first hat))) - (del-1 (absm-int-ext (second hat)))) - (absm-ext-int - (cons (first del-1) del-0)))))) - (smst-kan d #'dkfll) - (kfll d 0 1 (list (absm 0 1))) - (kfll d 0 2 (list (absm 0 5) (absm 0 3))) - (kfll d 1 2 (list (absm 0 6) (absm 0 3))) - (kfll d 2 2 (list (absm 0 6) (absm 0 5))) - (kfll d 0 2 (list (absm 0 3) (absm 0 3))) - (kfll d 1 2 (list (absm 1 2) (absm 0 3))) -|# (DEFUN CHECK-HAT (kan indx dmns hat) (declare - (type kan kan) - (fixnum indx dmns) ;;; dmns like in (funcall kfll ...) - (list hat)) + (type kan kan) + (fixnum indx dmns) ;;; dmns like in (funcall kfll ...) + (list hat)) (assert (= dmns (length hat))) (setf hat (append (subseq hat 0 indx) @@ -132,63 +48,54 @@ (do ((cmpr (cmpr kan)) (j 0 (1+ j))) ((> j dmns) t) - (declare - (type cmprf cmpr) - (fixnum j)) - (unless (= j indx) - (let ((del-j (nth j hat))) - (declare (type absm del-j)) - (do ((i j (1+ i))) - ((= i dmns)) - (declare (fixnum i)) - (unless (= i (1- indx)) - (let ((del-i-del-j (face kan i (1- dmns) del-j)) - (del-j-del-i+1 (face kan j (1- dmns) - (nth (1+ i) hat)))) - (declare (type absm del-i-del-j del-j-del-i+1)) - (assert (eq :equal - (a-cmpr3 cmpr del-i-del-j del-j-del-i+1)))))))))) - -#| - (setf od (gdeltab)) - (setf s (loop3 0 31 2)) - (setf faces (mapcar #'(lambda (indx) (face od indx 3 s)) - '(0 1 2 3))) - (delete (nth 1 faces) faces) - (check-hat od 1 3 faces) - (setf (nth 2 faces) (nth 1 faces)) - (check-hat od 1 3 faces) -|# + (declare + (type cmprf cmpr) + (fixnum j)) + (unless (= j indx) + (let ((del-j (nth j hat))) + (declare (type absm del-j)) + (do ((i j (1+ i))) + ((= i dmns)) + (declare (fixnum i)) + (unless (= i (1- indx)) + (let ((del-i-del-j (face kan i (1- dmns) del-j)) + (del-j-del-i+1 (face kan j (1- dmns) + (nth (1+ i) hat)))) + (declare (type absm del-i-del-j del-j-del-i+1)) + (assert (eq :equal + (a-cmpr3 cmpr del-i-del-j del-j-del-i+1)))))))))) (DEFUN CHECK-KAN (kan indx dmns hat) (declare - (type kan kan) - (fixnum indx dmns) - (list hat)) + (type kan kan) + (fixnum indx dmns) + (list hat)) (the (values) - (let ((rslt (kfll kan indx dmns hat)) - (cmpr (cmpr kan)) - (face (face kan))) - (declare + (let ((rslt (kfll kan indx dmns hat)) + (cmpr (cmpr kan)) + (face (face kan))) + (declare (type absm rslt) (type cmprf cmpr) (type face face)) - (check-hat kan indx dmns hat) - (do ((i 0 (1+ i))) - ((> i dmns)) - (declare (fixnum i)) - (unless (= i indx) - (let ((x-i (pop hat)) - (del-i-rslt (a-face4 face i dmns rslt))) - (declare (type absm x-i del-i-rslt)) - (with-absm (dgop1 gmsm1) x-i - (with-absm (dgop2 gmsm2) del-i-rslt - (unless (and (= dgop1 dgop2) - (eq (funcall cmpr gmsm1 gmsm2) :equal)) - (error "Wrong result:~@ + (check-hat kan indx dmns hat) + (do ((i 0 (1+ i))) + ((> i dmns)) + (declare (fixnum i)) + (unless (= i indx) + (let ((x-i (pop hat)) + (del-i-rslt (a-face4 face i dmns rslt))) + (declare (type absm x-i del-i-rslt)) + (with-absm (dgop1 gmsm1) x-i + (with-absm + (dgop2 gmsm2) del-i-rslt + (unless (and (= dgop1 dgop2) + (eq (funcall cmpr gmsm1 gmsm2) + :equal)) + (error "Wrong result:~@ Fill = ~A~@ Del-~D(Fill) = ~A~@ Hat-~D = ~A" - rslt i del-i-rslt i x-i))))))) - (done)))) + rslt i del-i-rslt i x-i))))))) + (done)))) diff --git a/test/kan-test.lisp b/test/kan-test.lisp new file mode 100644 index 0000000..2b39fc1 --- /dev/null +++ b/test/kan-test.lisp @@ -0,0 +1,117 @@ + +(in-package :kenzo-test) + +(in-suite :kenzo) + +(defun vertex-i (absm i) + (cat:with-absm + (dgop gmsm) absm + (let ((dgop (nreverse (cat:dgop-int-ext dgop))) + (gmsm (cat:dlop-int-ext gmsm))) + (do ((dgop-mark dgop) + (gmsm-mark gmsm) + (ii 0 (1+ ii))) + ((= i ii) (car gmsm-mark)) + (if (and dgop-mark + (= ii (car dgop-mark))) + (pop dgop-mark) + (pop gmsm-mark)))))) + + +(test vertex-i + (let ((d (cat:delta-infinity))) + (vertex-i (cat:absm 0 1) 0) + (vertex-i (cat:absm 1 1) 0) + (vertex-i (cat:absm 1 1) 1) + (vertex-i (cat:absm 0 3) 0) + (vertex-i (cat:absm 0 3) 1) + (vertex-i (cat:absm 3 1) 0) + (vertex-i (cat:absm 3 1) 1) + (vertex-i (cat:absm 3 1) 2) + (vertex-i (cat:absm 1 3) 0) + (vertex-i (cat:absm 1 3) 1) + (vertex-i (cat:absm 1 3) 2) + (vertex-i (cat:absm 2 3) 0) + (vertex-i (cat:absm 2 3) 1) + (vertex-i (cat:absm 2 3) 2) + (vertex-i (cat:absm 0 7) 0) + (vertex-i (cat:absm 0 7) 1) + (vertex-i (cat:absm 0 7) 2))) + + +(defun absm-int-ext (absm) + (cat:with-absm + (dgop gmsm) absm + (do ((dgop (nreverse (cat:dgop-int-ext dgop))) + (gmsm (rest (cat:dlop-int-ext gmsm))) + (i 0 (1+ i)) + (rslt (list (first (cat:dlop-int-ext gmsm))))) + ((and (endp dgop) (endp gmsm)) (nreverse rslt)) + (if dgop + (if (= i (car dgop)) + (progn + (pop dgop) + (push (first rslt) rslt)) + (push (pop gmsm) rslt)) + (return (nreconc rslt gmsm)))))) + + +(defun absm-ext-int (vlist) + (do ((dgop nil) + (gmsm (list (first vlist))) + (mark (rest vlist) (cdr mark)) + (idgop 0 (1+ idgop))) + ((endp mark) (cat:absm (cat:dgop-ext-int dgop) + (cat:dgop-ext-int gmsm))) + (if (= (first gmsm) (car mark)) + (push idgop dgop) + (push (car mark) gmsm)))) + + +(test absm-int-ext + (absm-ext-int '(0 0 0 1 2 3 3 3)) + (absm-ext-int '(0 1 1 1 2)) + (absm-int-ext (absm-ext-int '(0 0 0 1 2 3 3 3))) + (absm-int-ext (absm-ext-int '(0 1 1 1 2)))) + + +(defun dkfll (indx dmns hat) + (cond ((= 1 dmns) + (cat:absm 1 (cat:gmsm (first hat)))) + ((= 0 indx) + (let ((del-1 (absm-int-ext (first hat))) + (del-2 (absm-int-ext (second hat)))) + (absm-ext-int + (cons (first del-1) + (cons (second del-2) (rest del-1)))))) + ((= 1 indx) + (let ((del-0 (absm-int-ext (first hat))) + (del-2 (absm-int-ext (second hat)))) + (absm-ext-int + (cons (first del-2) del-0)))) + (t + (let ((del-0 (absm-int-ext (first hat))) + (del-1 (absm-int-ext (second hat)))) + (absm-ext-int + (cons (first del-1) del-0)))))) + + +(let ((d (cat:delta-infinity))) + (cat:smst-kan d #'dkfll) + (cat:kfll d 0 1 (list (cat:absm 0 1))) + (cat:kfll d 0 2 (list (cat:absm 0 5) (cat:absm 0 3))) + (cat:kfll d 1 2 (list (cat:absm 0 6) (cat:absm 0 3))) + (cat:kfll d 2 2 (list (cat:absm 0 6) (cat:absm 0 5))) + (cat:kfll d 0 2 (list (cat:absm 0 3) (cat:absm 0 3))) + (cat:kfll d 1 2 (list (cat:absm 1 2) (cat:absm 0 3)))) + + +(test check-hat + (let* ((od (cat:gdeltab)) + (s (cat:loop3 0 31 2)) + (faces (mapcar #'(lambda (indx) (cat:face od indx 3 s)) + '(0 1 2 3)))) + (delete (nth 1 faces) faces) + (cat:check-hat od 1 3 faces) + (setf (nth 2 faces) (nth 1 faces)) + (signals simple-error (cat:check-hat od 1 3 faces))))