mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

First batch of classifying spaces tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-22 03:21:51 -05:00
parent a75a2ee3d5
commit 23dd20c419
3 changed files with 312 additions and 272 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
package.lisp
View File

@ -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

77
src/classifying-spaces.lisp
View File

@ -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

103
test/classifying-spaces-test.lisp Normal file
View 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)))
|#