Extracted Kan tests.
This commit is contained in:
Gerd Heber
parent
ba6d13452a
commit
3fb780645b
@ -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")))
|
||||
|
||||
12
package.lisp
12
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
|
||||
|
||||
|
||||
205
src/kan.lisp
205
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))))
|
||||
|
||||
117
test/kan-test.lisp
Normal file
117
test/kan-test.lisp
Normal file
@ -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))))
|
||||
Loading…
Reference in New Issue
Block a user