First batch of classifying spaces tests.
This commit is contained in:
Gerd Heber
parent
a75a2ee3d5
commit
23dd20c419
@ -149,6 +149,11 @@
|
||||
|
||||
+NULL-GBAR+
|
||||
CLASSIFYING-SPACE
|
||||
CLASSIFYING-SPACE-BASIS
|
||||
CLASSIFYING-SPACE-CMPR
|
||||
GBAR
|
||||
NORMALIZE-GBAR
|
||||
UNNORMALIZE-GBAR
|
||||
|
||||
;; combinations.lisp
|
||||
|
||||
@ -302,6 +307,7 @@
|
||||
LF
|
||||
LG
|
||||
MASK
|
||||
MAKE-GBAR
|
||||
RBCC
|
||||
RF
|
||||
RG
|
||||
|
||||
@ -60,7 +60,8 @@
|
||||
:dmns (- dmns (logcount r-dgop))
|
||||
:list (nreconc r-absm-list mark)))))
|
||||
(let ((absm (car mark)))
|
||||
(with-absm (dgop gmsm) absm
|
||||
(with-absm
|
||||
(dgop gmsm) absm
|
||||
(declare (ignore gmsm))
|
||||
(if (and (= dgop mask)
|
||||
(logbitp indx and-dgops))
|
||||
@ -72,7 +73,8 @@
|
||||
(setf (car sublist)
|
||||
(let ((absm (car sublist)))
|
||||
(declare (type absm absm))
|
||||
(with-absm (dgop gmsm) absm
|
||||
(with-absm
|
||||
(dgop gmsm) absm
|
||||
(absm (multiple-value-bind (q r)
|
||||
(floor dgop 2-indx)
|
||||
(declare (fixnum q r))
|
||||
@ -81,23 +83,6 @@
|
||||
r-absm-list))
|
||||
(push absm r-absm-list))))))))
|
||||
|
||||
#|
|
||||
()
|
||||
(normalize-gbar (list 0))
|
||||
(normalize-gbar (list 1 (absm 0 'i)))
|
||||
(normalize-gbar (list 2 (absm 1 'i) (absm 0 'i)))
|
||||
(normalize-gbar (list 2 (absm 0 'a) (absm 0 'i)))
|
||||
(normalize-gbar (list 4 (absm 0 'a) (absm 0 'b) (absm 0 'c) (absm 0 'i)))
|
||||
(normalize-gbar (list 4 (absm 7 'i) (absm 3 'i) (absm 1 'i) (absm 0 'i)))
|
||||
(normalize-gbar (list 4 (absm 0 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
||||
(normalize-gbar (list 4 (absm 1 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
||||
(normalize-gbar (list 4 (absm 2 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
||||
(normalize-gbar (list 4 (absm 4 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
||||
(normalize-gbar (list 4 (absm 3 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
||||
(normalize-gbar (list 4 (absm 5 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
||||
(normalize-gbar (list 4 (absm 6 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
||||
(normalize-gbar (list 4 (absm 1 'a) (absm 3 'i) (absm 1 'i) (absm 0 'i)))
|
||||
|#
|
||||
|
||||
(DEFUN UNNORMALIZE-GBAR (absm idnt)
|
||||
(declare
|
||||
@ -130,39 +115,6 @@
|
||||
(incf dgop3 2-indx))
|
||||
(push (ndgnr dgop3 (pop list)) rslt)))))))
|
||||
|
||||
#|
|
||||
()
|
||||
(unnormalize-gbar (absm 1 +null-gbar+) 'i)
|
||||
(unnormalize-gbar (absm 15 +null-gbar+) 'i)
|
||||
(normalize-gbar (unnormalize-gbar (absm 15 +null-gbar+) 'i))
|
||||
(unnormalize-gbar
|
||||
(absm 0 (make-gbar :dmns 4
|
||||
:list (list (absm 0 'a) (absm 0 'b)
|
||||
(absm 0 'c) (absm 0 'i)))) 'i)
|
||||
(normalize-gbar
|
||||
(unnormalize-gbar
|
||||
(absm 0 (make-gbar :dmns 4
|
||||
:list (list (absm 0 'a) (absm 0 'b)
|
||||
(absm 0 'c) (absm 0 'i)))) 'i))
|
||||
(unnormalize-gbar
|
||||
(absm 5 (make-gbar :dmns 4
|
||||
:list (list (absm 0 'a) (absm 0 'b)
|
||||
(absm 0 'c) (absm 0 'i)))) 'i)
|
||||
(normalize-gbar
|
||||
(unnormalize-gbar
|
||||
(absm 5 (make-gbar :dmns 4
|
||||
:list (list (absm 0 'a) (absm 0 'b)
|
||||
(absm 0 'c) (absm 0 'i)))) 'i))
|
||||
(unnormalize-gbar
|
||||
(absm 9 (make-gbar :dmns 4
|
||||
:list (list (absm 0 'a) (absm 0 'b)
|
||||
(absm 0 'c) (absm 0 'i)))) 'i)
|
||||
(normalize-gbar
|
||||
(unnormalize-gbar
|
||||
(absm 9 (make-gbar :dmns 4
|
||||
:list (list (absm 0 'a) (absm 0 'b)
|
||||
(absm 0 'c) (absm 0 'i)))) 'i))
|
||||
|#
|
||||
|
||||
(DEFUN GBAR (dmns &rest rest)
|
||||
(the gbar
|
||||
@ -177,12 +129,6 @@
|
||||
((endp mark) (nreverse rslt))
|
||||
(declare (list mark rslt)))))))
|
||||
|
||||
#|
|
||||
()
|
||||
(gbar 0)
|
||||
(gbar 1)
|
||||
(gbar 2 1 'a 2 'b)
|
||||
|#
|
||||
|
||||
(DEFUN CLASSIFYING-SPACE-CMPR (cmpr)
|
||||
(declare (type cmprf cmpr))
|
||||
@ -195,12 +141,6 @@
|
||||
(gbar-list gbar1) (gbar-list gbar2))))
|
||||
(the cmprf #'rslt)))
|
||||
|
||||
#|
|
||||
(setf cmpr (classifying-space-cmpr 's-cmpr))
|
||||
(funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 1 'a 0 'a))
|
||||
(funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 0 'b 0 'a))
|
||||
(funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 0 'a 0 'a))
|
||||
|#
|
||||
|
||||
(DEFUN CLASSIFYING-SPACE-BASIS (basis)
|
||||
(declare (type basis basis))
|
||||
@ -240,15 +180,6 @@
|
||||
(setf crts-basis (crts-prdc-basis basis #'rslt))
|
||||
(the basis #'rslt))))
|
||||
|
||||
#|
|
||||
()
|
||||
(cat-init)
|
||||
(setf k (k-z2-1))
|
||||
(setf b (classifying-space-basis (basis k)))
|
||||
(funcall b 0)
|
||||
(funcall b 1)
|
||||
(dotimes (i 5) (print (funcall b i)))
|
||||
|#
|
||||
|
||||
(DEFUN CLASSIFYING-SPACE-FACE (face sintr-grml)
|
||||
(declare
|
||||
@ -280,13 +211,13 @@
|
||||
(the face #'rslt)))
|
||||
|
||||
#|
|
||||
(setf om (loop-space (moore 2 2)))
|
||||
(setf face (classifying-space-face (face om) (sintr (grml om))))
|
||||
(setf gbar (gbar 4 0 (loop3 3 'm2 1 4 'n3 1)
|
||||
(setf om (loop-space (moore 2 2)))
|
||||
(setf face (classifying-space-face (face om) (sintr (grml om))))
|
||||
(setf gbar (gbar 4 0 (loop3 3 'm2 1 4 'n3 1)
|
||||
0 (loop3 0 'n3 1)
|
||||
0 (loop3 0 'm2 1)
|
||||
0 +null-loop+))
|
||||
(dotimes (i 5)
|
||||
(dotimes (i 5)
|
||||
(print (funcall face i 4 gbar)))
|
||||
|#
|
||||
|
||||
@ -301,14 +232,14 @@
|
||||
:orgn `(classifying-space ,smgr))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf c (classifying-space (k-z2-1)))
|
||||
(orgn c)
|
||||
(first (basis c 4))
|
||||
(? c 4 (first (basis c 4)))
|
||||
(? c *)
|
||||
(cprd c 4 ***)
|
||||
(dotimes (i 5)
|
||||
(cat-init)
|
||||
(setf c (classifying-space (k-z2-1)))
|
||||
(orgn c)
|
||||
(first (basis c 4))
|
||||
(? c 4 (first (basis c 4)))
|
||||
(? c *)
|
||||
(cprd c 4 ***)
|
||||
(dotimes (i 5)
|
||||
(print (face c i 4 (first (basis c 4)))))
|
||||
|#
|
||||
|
||||
@ -335,12 +266,12 @@
|
||||
(the sintr #'rslt)))
|
||||
|
||||
#|
|
||||
(setf grml (classifying-space-grml-sintr '() (sintr (grml (k-z-1)))))
|
||||
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||
(setf grml (classifying-space-grml-sintr '() (sintr (grml (k-z-1)))))
|
||||
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||
0 (gbar 3 0 '(-1 -2) 0 '(-3) 0 '())))
|
||||
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||
4 (gbar 2 0 '(-3) 0 '())))
|
||||
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||
1 (gbar 2 0 '(-3) 0 '())))
|
||||
|#
|
||||
|
||||
@ -362,8 +293,8 @@
|
||||
(the sintr #'rslt)))
|
||||
|
||||
#|
|
||||
(setf grin (classifying-space-grin-sintr (sintr (grin (k-z-1)))))
|
||||
(funcall grin 3 (gbar 3 0 '(1 2) 1 '() 0 '()))
|
||||
(setf grin (classifying-space-grin-sintr (sintr (grin (k-z-1)))))
|
||||
(funcall grin 3 (gbar 3 0 '(1 2) 1 '() 0 '()))
|
||||
|#
|
||||
|
||||
|
||||
@ -383,14 +314,14 @@
|
||||
'ab-simplicial-group)))
|
||||
|
||||
#|
|
||||
(setf k-z-1 (k-z-1))
|
||||
(setf k-z-2 (classifying-space k-z-1))
|
||||
(setf k-z-3 (classifying-space k-z-2))
|
||||
(homology k-z-3 0 10)
|
||||
(setf k-z2-1 (k-z2-1))
|
||||
(setf k-z2-2 (classifying-space k-z2-1))
|
||||
(setf k-z2-3 (classifying-space k-z2-2))
|
||||
(setf k-z2-4 (classifying-space k-z2-3))
|
||||
(setf k-z2-5 (classifying-space k-z2-4))
|
||||
(homology k-z2-5 0 7)
|
||||
(setf k-z-1 (k-z-1))
|
||||
(setf k-z-2 (classifying-space k-z-1))
|
||||
(setf k-z-3 (classifying-space k-z-2))
|
||||
(homology k-z-3 0 10)
|
||||
(setf k-z2-1 (k-z2-1))
|
||||
(setf k-z2-2 (classifying-space k-z2-1))
|
||||
(setf k-z2-3 (classifying-space k-z2-2))
|
||||
(setf k-z2-4 (classifying-space k-z2-3))
|
||||
(setf k-z2-5 (classifying-space k-z2-4))
|
||||
(homology k-z2-5 0 7)
|
||||
|#
|
||||
|
||||
103
test/classifying-spaces-test.lisp
Normal file
103
test/classifying-spaces-test.lisp
Normal file
@ -0,0 +1,103 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
|
||||
(test normalize-gbar
|
||||
(cat:normalize-gbar (list 0))
|
||||
(cat:normalize-gbar (list 1 (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 2 (cat:absm 1 'i) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 2 (cat:absm 0 'a) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 4 (cat:absm 0 'a) (cat:absm 0 'b)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 4 (cat:absm 7 'i) (cat:absm 3 'i)
|
||||
(cat:absm 1 'i) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 4 (cat:absm 0 'a) (cat:absm 3 'i)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 4 (cat:absm 1 'a) (cat:absm 3 'i)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 4 (cat:absm 2 'a) (cat:absm 3 'i)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 4 (cat:absm 4 'a) (cat:absm 3 'i)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 4 (cat:absm 3 'a) (cat:absm 3 'i)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 4 (cat:absm 5 'a) (cat:absm 3 'i)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 4 (cat:absm 6 'a) (cat:absm 3 'i)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||
(cat:normalize-gbar (list 4 (cat:absm 1 'a) (cat:absm 3 'i)
|
||||
(cat:absm 1 'i) (cat:absm 0 'i))))
|
||||
|
||||
|
||||
(test unnormalize-gbar
|
||||
(cat:unnormalize-gbar (cat:absm 1 cat:+null-gbar+) 'i)
|
||||
(cat:unnormalize-gbar (cat:absm 15 cat:+null-gbar+) 'i)
|
||||
(cat:normalize-gbar (cat:unnormalize-gbar
|
||||
(cat:absm 15 cat:+null-gbar+) 'i))
|
||||
(cat:unnormalize-gbar
|
||||
(cat:absm 0 (cat:make-gbar :dmns 4
|
||||
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
|
||||
(cat:normalize-gbar
|
||||
(cat:unnormalize-gbar
|
||||
(cat:absm 0 (cat:make-gbar :dmns 4
|
||||
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
|
||||
(cat:unnormalize-gbar
|
||||
(cat:absm 5 (cat:make-gbar :dmns 4
|
||||
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
|
||||
(cat:normalize-gbar
|
||||
(cat:unnormalize-gbar
|
||||
(cat:absm 5 (cat:make-gbar :dmns 4
|
||||
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
|
||||
(cat:unnormalize-gbar
|
||||
(cat:absm 9 (cat:make-gbar :dmns 4
|
||||
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
|
||||
(cat:normalize-gbar
|
||||
(cat:unnormalize-gbar
|
||||
(cat:absm 9 (cat:make-gbar :dmns 4
|
||||
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)))
|
||||
|
||||
|
||||
(test gbar
|
||||
(cat:gbar 0)
|
||||
(signals #-ecl simple-error
|
||||
#+ecl simple-type-error (cat:gbar 1))
|
||||
(cat:gbar 2 1 'a 2 'b))
|
||||
|
||||
|
||||
(test classifying-space-cmpr
|
||||
(let ((cmpr (cat:classifying-space-cmpr 'cat:s-cmpr)))
|
||||
(is (equal :less (funcall cmpr
|
||||
(cat:gbar 2 0 'a 0 'a)
|
||||
(cat:gbar 2 1 'a 0 'a))))
|
||||
(is (equal :less (funcall cmpr
|
||||
(cat:gbar 2 0 'a 0 'a)
|
||||
(cat:gbar 2 0 'b 0 'a))))
|
||||
(is (equal :equal (funcall cmpr
|
||||
(cat:gbar 2 0 'a 0 'a)
|
||||
(cat:gbar 2 0 'a 0 'a))))))
|
||||
|
||||
|
||||
(test classifying-space-basis
|
||||
(cat:cat-init)
|
||||
(let* ((k (cat:k-z2-1))
|
||||
(b (cat:classifying-space-basis (cat:basis k))))
|
||||
(funcall b 0)
|
||||
(funcall b 1)
|
||||
(dotimes (i 5) (print (funcall b i)))))
|
||||
#|
|
||||
()
|
||||
(cat-init)
|
||||
(setf k (k-z2-1))
|
||||
(setf b (classifying-space-basis (basis k)))
|
||||
(funcall b 0)
|
||||
(funcall b 1)
|
||||
(dotimes (i 5) (print (funcall b i)))
|
||||
|#
|
||||
Loading…
Reference in New Issue
Block a user