Extracted cartesian product tests.
This commit is contained in:
Gerd Heber
parent
34576fb375
commit
fe065a7a13
@ -21,4 +21,5 @@
|
||||
(:file "homology-groups-test")
|
||||
(:file "searching-homology-test")
|
||||
(:file "delta-test")
|
||||
(:file "bar-test")))
|
||||
(:file "bar-test")
|
||||
(:file "cartesian-products-test")))
|
||||
|
||||
17
package.lisp
17
package.lisp
@ -4,10 +4,6 @@
|
||||
(:use #:cl)
|
||||
(:export KENZO-VERSION
|
||||
|
||||
;; UFO
|
||||
|
||||
EFHM
|
||||
|
||||
;; kenzo.lisp
|
||||
|
||||
*BC*
|
||||
@ -50,6 +46,16 @@
|
||||
DISPATCH-BICN-CMBN
|
||||
MAKE-BICN-CMBN
|
||||
|
||||
;; cartesian-products.lisp
|
||||
|
||||
2ABSM-ACRPR
|
||||
CRTS-PRDC
|
||||
CRTS-PRDC-BASIS
|
||||
CRTS-PRDC-CMPR
|
||||
CRTS-PRDC-FACE
|
||||
CRTS-PRDC-FACE*
|
||||
EXTRACT-COMMON-DGOP
|
||||
|
||||
;; chain-complexes.lisp
|
||||
|
||||
?2
|
||||
@ -82,6 +88,7 @@
|
||||
|
||||
;; classes.lisp
|
||||
|
||||
ABSM
|
||||
BCC
|
||||
BRGN
|
||||
CHAIN-COMPLEX
|
||||
@ -90,6 +97,7 @@
|
||||
CMBN-LIST
|
||||
DEGR
|
||||
DFFR1
|
||||
EFHM
|
||||
F
|
||||
FACE
|
||||
G
|
||||
@ -211,6 +219,7 @@
|
||||
|
||||
;; simplicial-sets.lisp
|
||||
|
||||
DGOP*DGOP
|
||||
DLOP-EXT-INT
|
||||
DLOP-INT-EXT
|
||||
|
||||
|
||||
@ -14,313 +14,208 @@
|
||||
(ignore depth))
|
||||
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
|
||||
(format stream "<CrPr ~A ~A ~A ~A>"
|
||||
(hyphenize-list (dgop-int-ext dgop1)) gmsm1
|
||||
(hyphenize-list (dgop-int-ext dgop2)) gmsm2)
|
||||
(hyphenize-list (dgop-int-ext dgop1)) gmsm1
|
||||
(hyphenize-list (dgop-int-ext dgop2)) gmsm2)
|
||||
crpr))
|
||||
|
||||
|
||||
(DEFUN EXTRACT-COMMON-DGOP (dgop1 dgop2)
|
||||
(declare (fixnum dgop1 dgop2))
|
||||
(let ((dgop (logand dgop1 dgop2)))
|
||||
(declare (fixnum dgop))
|
||||
(do ((indx (1- (integer-length dgop)) (1- indx)))
|
||||
((minusp indx))
|
||||
(declare (fixnum indx))
|
||||
(when (logbitp indx dgop)
|
||||
(setf dgop1 (remove-bit dgop1 indx)
|
||||
dgop2 (remove-bit dgop2 indx))))
|
||||
(values dgop dgop1 dgop2)))
|
||||
(declare (fixnum dgop1 dgop2))
|
||||
(let ((dgop (logand dgop1 dgop2)))
|
||||
(declare (fixnum dgop))
|
||||
(do ((indx (1- (integer-length dgop)) (1- indx)))
|
||||
((minusp indx))
|
||||
(declare (fixnum indx))
|
||||
(when (logbitp indx dgop)
|
||||
(setf dgop1 (remove-bit dgop1 indx)
|
||||
dgop2 (remove-bit dgop2 indx))))
|
||||
(values dgop dgop1 dgop2)))
|
||||
|
||||
#|
|
||||
(dotimes (i 100)
|
||||
(dotimes (j 100)
|
||||
(multiple-value-bind (dgop dgop1 dgop2) (extract-common-dgop i j)
|
||||
(unless (and (= i (dgop*dgop dgop dgop1))
|
||||
(= j (dgop*dgop dgop dgop2)))
|
||||
(error "i = ~D, j = ~D, dgop = ~D, dgop1 = ~D, dgop2 = ~D"
|
||||
i j dgop dgop1 dgop2)))))
|
||||
|#
|
||||
|
||||
(DEFUN 2ABSM-ACRPR (absm1 absm2)
|
||||
(declare (type absm absm1 absm2))
|
||||
(the absm
|
||||
(with-absm (dgop1 gmsm1) absm1
|
||||
(with-absm (dgop2 gmsm2) absm2
|
||||
(multiple-value-bind (dgop dgop11 dgop22) (extract-common-dgop dgop1 dgop2)
|
||||
(declare (fixnum dgop dgop11 dgop22))
|
||||
(absm dgop
|
||||
(crpr dgop11 gmsm1 dgop22 gmsm2)))))))
|
||||
|
||||
#|
|
||||
(2absm-acrpr (absm 5 'a) (absm 3 'b))
|
||||
|#
|
||||
(declare (type absm absm1 absm2))
|
||||
(the absm
|
||||
(with-absm (dgop1 gmsm1) absm1
|
||||
(with-absm (dgop2 gmsm2) absm2
|
||||
(multiple-value-bind (dgop dgop11 dgop22)
|
||||
(extract-common-dgop dgop1 dgop2)
|
||||
(declare (fixnum dgop dgop11 dgop22))
|
||||
(absm dgop
|
||||
(crpr dgop11 gmsm1 dgop22 gmsm2)))))))
|
||||
|
||||
|
||||
#|
|
||||
(DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2)
|
||||
(declare (type cmprf cmpr1 cmpr2))
|
||||
(flet ((rslt (crpr1 crpr2)
|
||||
(declare (type crpr crpr1 crpr2))
|
||||
(the cmpr
|
||||
(declare (type cmprf cmpr1 cmpr2))
|
||||
(flet ((rslt (crpr1 crpr2)
|
||||
(declare (type crpr crpr1 crpr2))
|
||||
(the cmpr
|
||||
(let ((left-cons-1 (cadr crpr1))
|
||||
(left-cons-2 (cadr crpr2)))
|
||||
(declare (cons left-cons-1 left-cons-2))
|
||||
(lexico
|
||||
(f-cmpr (car left-cons-1) (car left-cons-2))
|
||||
(let ((right-cons-1 (cddr crpr1))
|
||||
(right-cons-2 (cddr crpr2)))
|
||||
(declare (cons right-cons-1 right-cons-2))
|
||||
(lexico
|
||||
(f-cmpr (car right-cons-1) (car right-cons-2))
|
||||
(funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2))
|
||||
(funcall cmpr2 (cdr right-cons-1) (cdr right-cons-2)))))))))
|
||||
(the cmprf #'rslt)))
|
||||
(declare (cons left-cons-1 left-cons-2))
|
||||
(lexico
|
||||
(f-cmpr (car left-cons-1) (car left-cons-2))
|
||||
(let ((right-cons-1 (cddr crpr1))
|
||||
(right-cons-2 (cddr crpr2)))
|
||||
(declare (cons right-cons-1 right-cons-2))
|
||||
(lexico
|
||||
(f-cmpr (car right-cons-1) (car right-cons-2))
|
||||
(funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2))
|
||||
(funcall cmpr2 (cdr right-cons-1) (cdr right-cons-2)))))))))
|
||||
(the cmprf #'rslt)))
|
||||
|#
|
||||
|
||||
(DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2)
|
||||
(declare (type cmprf cmpr1 cmpr2))
|
||||
(flet ((rslt (crpr1 crpr2)
|
||||
(declare (type crpr crpr1 crpr2))
|
||||
(the cmpr
|
||||
(lexico
|
||||
(f-cmpr (dgop1 crpr1) (dgop1 crpr2))
|
||||
(f-cmpr (dgop2 crpr1) (dgop2 crpr2))
|
||||
(funcall cmpr1 (gmsm1 crpr1) (gmsm1 crpr2))
|
||||
(funcall cmpr2 (gmsm2 crpr1) (gmsm2 crpr2))))))
|
||||
(the cmprf #'rslt)))
|
||||
(declare (type cmprf cmpr1 cmpr2))
|
||||
(flet ((rslt (crpr1 crpr2)
|
||||
(declare (type crpr crpr1 crpr2))
|
||||
(the cmpr
|
||||
(lexico
|
||||
(f-cmpr (dgop1 crpr1) (dgop1 crpr2))
|
||||
(f-cmpr (dgop2 crpr1) (dgop2 crpr2))
|
||||
(funcall cmpr1 (gmsm1 crpr1) (gmsm1 crpr2))
|
||||
(funcall cmpr2 (gmsm2 crpr1) (gmsm2 crpr2))))))
|
||||
(the cmprf #'rslt)))
|
||||
|
||||
|
||||
#|
|
||||
()
|
||||
(setf c (cmpr (delta-infinity)))
|
||||
(setf rslt (crts-prdc-cmpr c c))
|
||||
(funcall rslt (crpr 0 3 0 3) (crpr 1 1 0 3))
|
||||
(funcall rslt (crpr 4 3 0 7) (crpr 3 1 0 7))
|
||||
(funcall rslt (crpr 0 3 0 3) (crpr 0 3 1 1))
|
||||
(funcall rslt (crpr 0 3 0 3) (crpr 0 5 0 3))
|
||||
(funcall rslt (crpr 0 3 0 3) (crpr 0 3 0 5))
|
||||
(funcall rslt (crpr 0 3 0 3) (crpr 0 3 0 3)))
|
||||
|#
|
||||
|
||||
(DEFUN CRTS-PRDC-BASIS (basis1 basis2)
|
||||
(declare (type basis basis1 basis2))
|
||||
(when (or (eq basis1 :locally-effective)
|
||||
(eq basis2 :locally-effective))
|
||||
(return-from crts-prdc-basis :locally-effective))
|
||||
(flet ((rslt (dmns)
|
||||
(declare (fixnum dmns))
|
||||
(the list
|
||||
(declare (type basis basis1 basis2))
|
||||
(when (or (eq basis1 :locally-effective)
|
||||
(eq basis2 :locally-effective))
|
||||
(return-from crts-prdc-basis :locally-effective))
|
||||
(flet ((rslt (dmns)
|
||||
(declare (fixnum dmns))
|
||||
(the list
|
||||
(progn
|
||||
(when (minusp dmns)
|
||||
(return-from rslt +empty-list+))
|
||||
(let ((array1 (make-array (1+ dmns)))
|
||||
(array2 (make-array (1+ dmns)))
|
||||
(rslt +empty-list+)
|
||||
(mask (mask dmns)))
|
||||
(declare
|
||||
(simple-vector array1 array2)
|
||||
(list rslt)
|
||||
(fixnum mask))
|
||||
(dotimes (i (1+ dmns))
|
||||
(setf (svref array1 i) (funcall basis1 i)
|
||||
(svref array2 i) (funcall basis2 i)))
|
||||
(do ((dgop1 mask (1- dgop1)))
|
||||
((minusp dgop1))
|
||||
(declare (fixnum dgop1))
|
||||
(let ((dmns1 (- dmns (logcount dgop1))))
|
||||
(declare (fixnum dmns1))
|
||||
(do ((dgop2 mask (1- dgop2)))
|
||||
((minusp dgop2))
|
||||
(declare (fixnum dgop2))
|
||||
(unless (plusp (logand dgop1 dgop2))
|
||||
(setf rslt
|
||||
(nconc
|
||||
(mapcan
|
||||
#'(lambda (item1)
|
||||
(declare (type gmsm item1))
|
||||
(mapcar
|
||||
#'(lambda (item2)
|
||||
(declare (type gmsm item2))
|
||||
(crpr dgop1 item1 dgop2 item2))
|
||||
(svref array2 (- dmns (logcount dgop2)))))
|
||||
(svref array1 dmns1))
|
||||
rslt))))))
|
||||
rslt)))))
|
||||
(the basis #'rslt)))
|
||||
(when (minusp dmns)
|
||||
(return-from rslt +empty-list+))
|
||||
(let ((array1 (make-array (1+ dmns)))
|
||||
(array2 (make-array (1+ dmns)))
|
||||
(rslt +empty-list+)
|
||||
(mask (mask dmns)))
|
||||
(declare
|
||||
(simple-vector array1 array2)
|
||||
(list rslt)
|
||||
(fixnum mask))
|
||||
(dotimes (i (1+ dmns))
|
||||
(setf (svref array1 i) (funcall basis1 i)
|
||||
(svref array2 i) (funcall basis2 i)))
|
||||
(do ((dgop1 mask (1- dgop1)))
|
||||
((minusp dgop1))
|
||||
(declare (fixnum dgop1))
|
||||
(let ((dmns1 (- dmns (logcount dgop1))))
|
||||
(declare (fixnum dmns1))
|
||||
(do ((dgop2 mask (1- dgop2)))
|
||||
((minusp dgop2))
|
||||
(declare (fixnum dgop2))
|
||||
(unless (plusp (logand dgop1 dgop2))
|
||||
(setf rslt
|
||||
(nconc
|
||||
(mapcan
|
||||
#'(lambda (item1)
|
||||
(declare (type gmsm item1))
|
||||
(mapcar
|
||||
#'(lambda (item2)
|
||||
(declare (type gmsm item2))
|
||||
(crpr dgop1 item1 dgop2 item2))
|
||||
(svref array2 (- dmns
|
||||
(logcount dgop2)))))
|
||||
(svref array1 dmns1))
|
||||
rslt))))))
|
||||
rslt)))))
|
||||
(the basis #'rslt)))
|
||||
|
||||
#|
|
||||
(setf b (basis (delta 1)))
|
||||
(setf r (crts-prdc-basis b b))
|
||||
(funcall r 0)
|
||||
(funcall r 1)
|
||||
(funcall r 2)
|
||||
(funcall r 3)
|
||||
(setf d3 (basis (delta 3)))
|
||||
(setf r (crts-prdc-basis d3 d3))
|
||||
(time (dotimes (i 7)
|
||||
(print (length (funcall r i)))))
|
||||
(setf s3 (basis (sphere 3)))
|
||||
(setf p (crts-prdc-basis s3 s3))
|
||||
(dotimes (i 8)
|
||||
(print (funcall p i)))
|
||||
|#
|
||||
|
||||
(DEFUN CRTS-PRDC-FACE (face1 face2)
|
||||
(declare (type face face1 face2))
|
||||
(flet ((rslt (indx dmns crpr)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type crpr crpr))
|
||||
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
|
||||
(multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1)
|
||||
(declare
|
||||
(fixnum dgop1)
|
||||
(type (or null fixnum) del1))
|
||||
(multiple-value-bind (dgop2 del2) (1dlop-dgop indx dgop2)
|
||||
(declare
|
||||
(fixnum dgop2)
|
||||
(type (or null fixnum) del2))
|
||||
(when del1
|
||||
(let ((absm1 (funcall face1 del1 (- dmns (logcount dgop1)) gmsm1)))
|
||||
(declare (type absm absm1))
|
||||
(setf dgop1 (dgop*dgop dgop1 (dgop absm1))
|
||||
gmsm1 (gmsm absm1))))
|
||||
(when del2
|
||||
(let ((absm2 (funcall face2 del2 (- dmns (logcount dgop2)) gmsm2)))
|
||||
(declare (type absm absm2))
|
||||
(setf dgop2 (dgop*dgop dgop2 (dgop absm2))
|
||||
gmsm2 (gmsm absm2))))
|
||||
(multiple-value-bind (dgop dgop1 dgop2) (extract-common-dgop dgop1 dgop2)
|
||||
(declare (type face face1 face2))
|
||||
(flet ((rslt (indx dmns crpr)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type crpr crpr))
|
||||
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
|
||||
(multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1)
|
||||
(declare
|
||||
(fixnum dgop1)
|
||||
(type (or null fixnum) del1))
|
||||
(multiple-value-bind (dgop2 del2) (1dlop-dgop indx
|
||||
dgop2)
|
||||
(declare
|
||||
(fixnum dgop2)
|
||||
(type (or null fixnum) del2))
|
||||
(when del1
|
||||
(let ((absm1 (funcall face1 del1 (- dmns (logcount
|
||||
dgop1))
|
||||
gmsm1)))
|
||||
(declare (type absm absm1))
|
||||
(setf dgop1 (dgop*dgop dgop1 (dgop absm1))
|
||||
gmsm1 (gmsm absm1))))
|
||||
(when del2
|
||||
(let ((absm2 (funcall face2 del2 (- dmns (logcount
|
||||
dgop2))
|
||||
gmsm2)))
|
||||
(declare (type absm absm2))
|
||||
(setf dgop2 (dgop*dgop dgop2 (dgop absm2))
|
||||
gmsm2 (gmsm absm2))))
|
||||
(multiple-value-bind (dgop dgop1 dgop2)
|
||||
(extract-common-dgop dgop1 dgop2)
|
||||
(declare (fixnum dgop dgop1 dgop2))
|
||||
(absm dgop (crpr dgop1 gmsm1 dgop2 gmsm2))))))))
|
||||
(the face #'rslt)))
|
||||
(the face #'rslt)))
|
||||
|
||||
#|
|
||||
(setf d2 (delta 2))
|
||||
(setf b2 (basis d2))
|
||||
(setf f2 (face d2))
|
||||
(setf b (crts-prdc-basis b2 b2))
|
||||
(setf r (crts-prdc-face f2 f2))
|
||||
(dotimes (i 5)
|
||||
(unless (zerop i)
|
||||
(dolist (item (funcall b i))
|
||||
(dotimes (j (1+ i))
|
||||
(format t "~%del-~D ~A = ~A"
|
||||
j item (funcall r j i item))))))
|
||||
|#
|
||||
|
||||
(DEFUN CRTS-PRDC-FACE* (face1 face2)
|
||||
(declare (type face face1 face2))
|
||||
(flet ((rslt (indx dmns crpr)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type crpr crpr))
|
||||
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
|
||||
(multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1)
|
||||
(declare
|
||||
(fixnum dgop1)
|
||||
(type (or null fixnum) del1))
|
||||
(multiple-value-bind (dgop2 del2) (1dlop-dgop indx dgop2)
|
||||
(declare
|
||||
(fixnum dgop2)
|
||||
(type (or null fixnum) del2))
|
||||
(when del1
|
||||
(let ((absm1 (funcall face1 del1 (- dmns (logcount dgop1)) gmsm1)))
|
||||
(declare (type absm absm1))
|
||||
(setf dgop1 (dgop*dgop dgop1 (dgop absm1))
|
||||
gmsm1 (gmsm absm1))))
|
||||
(when del2
|
||||
(let ((absm2 (funcall face2 del2 (- dmns (logcount dgop2)) gmsm2)))
|
||||
(declare (type absm absm2))
|
||||
(setf dgop2 (dgop*dgop dgop2 (dgop absm2))
|
||||
gmsm2 (gmsm absm2))))
|
||||
(if (plusp (logand dgop1 dgop2))
|
||||
:degenerate
|
||||
(crpr dgop1 gmsm1 dgop2 gmsm2)))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
(declare (type face face1 face2))
|
||||
(flet ((rslt (indx dmns crpr)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type crpr crpr))
|
||||
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
|
||||
(multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1)
|
||||
(declare
|
||||
(fixnum dgop1)
|
||||
(type (or null fixnum) del1))
|
||||
(multiple-value-bind (dgop2 del2) (1dlop-dgop indx
|
||||
dgop2)
|
||||
(declare
|
||||
(fixnum dgop2)
|
||||
(type (or null fixnum) del2))
|
||||
(when del1
|
||||
(let ((absm1 (funcall face1 del1 (- dmns (logcount
|
||||
dgop1))
|
||||
gmsm1)))
|
||||
(declare (type absm absm1))
|
||||
(setf dgop1 (dgop*dgop dgop1 (dgop absm1))
|
||||
gmsm1 (gmsm absm1))))
|
||||
(when del2
|
||||
(let ((absm2 (funcall face2 del2 (- dmns (logcount
|
||||
dgop2))
|
||||
gmsm2)))
|
||||
(declare (type absm absm2))
|
||||
(setf dgop2 (dgop*dgop dgop2 (dgop absm2))
|
||||
gmsm2 (gmsm absm2))))
|
||||
(if (plusp (logand dgop1 dgop2))
|
||||
:degenerate
|
||||
(crpr dgop1 gmsm1 dgop2 gmsm2)))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
#|
|
||||
(setf d2 (delta 2))
|
||||
(setf b2 (basis d2))
|
||||
(setf f2 (face d2))
|
||||
(setf b (crts-prdc-basis b2 b2))
|
||||
(setf r (crts-prdc-face* f2 f2))
|
||||
(dotimes (i 5)
|
||||
(unless (zerop i)
|
||||
(dolist (item (coerce (funcall b i) 'list))
|
||||
(dotimes (j (1+ i))
|
||||
(format t "~%del-~D ~A = ~A"
|
||||
j item (funcall r j i item))))))
|
||||
(setf s3 (sphere 3))
|
||||
(setf b3 (basis s3))
|
||||
(setf f3 (face s3))
|
||||
(setf b (crts-prdc-basis b3 b3))
|
||||
(setf r (crts-prdc-face* f3 f3))
|
||||
(dotimes (i 7)
|
||||
(unless (zerop i)
|
||||
(dolist (item (coerce (funcall b i) 'list))
|
||||
(dotimes (j (1+ i))
|
||||
(format t "~%del-~D ~A = ~A"
|
||||
j item (funcall r j i item))))))
|
||||
|#
|
||||
|
||||
(DEFUN CRTS-PRDC (smst1 smst2)
|
||||
(declare (type simplicial-set smst1 smst2))
|
||||
(with-slots ((cmpr1 cmpr) (basis1 basis) (face1 face) (bspn1 bsgn)) smst1
|
||||
(declare (type simplicial-set smst1 smst2))
|
||||
(with-slots ((cmpr1 cmpr) (basis1 basis) (face1 face) (bspn1 bsgn)) smst1
|
||||
(declare
|
||||
(type cmprf cmpr1)
|
||||
(type basis basis1)
|
||||
(type face face1))
|
||||
(with-slots ((cmpr2 cmpr) (basis2 basis) (face2 face) (bspn2 bsgn)) smst2
|
||||
(declare
|
||||
(type cmprf cmpr1)
|
||||
(type basis basis1)
|
||||
(type face face1))
|
||||
(with-slots ((cmpr2 cmpr) (basis2 basis) (face2 face) (bspn2 bsgn)) smst2
|
||||
(declare
|
||||
(type cmprf cmpr2)
|
||||
(type basis basis2)
|
||||
(type face face2))
|
||||
(type cmprf cmpr2)
|
||||
(type basis basis2)
|
||||
(type face face2))
|
||||
(the simplicial-set
|
||||
(build-smst
|
||||
(build-smst
|
||||
:cmpr (crts-prdc-cmpr cmpr1 cmpr2)
|
||||
:basis (crts-prdc-basis basis1 basis2)
|
||||
:bspn (crpr 0 bspn1 0 bspn2)
|
||||
:face (crts-prdc-face face1 face2)
|
||||
:face* (crts-prdc-face* face1 face2)
|
||||
:orgn `(crts-prdc ,smst1 ,smst2))))))
|
||||
|
||||
#|
|
||||
(setf p (crts-prdc (delta 3) (delta 3)))
|
||||
(? p 0 (crpr 0 1 0 2))
|
||||
(? p 1 (crpr 0 3 0 3))
|
||||
(? p 2 (crpr 0 7 0 7))
|
||||
(? p 3 (crpr 0 15 0 15))
|
||||
(? p 4 (crpr 1 15 2 15))
|
||||
|#
|
||||
|
||||
#|
|
||||
;; For comparison with EAT.
|
||||
;; In CAT.
|
||||
(setf s5 (sphere 5))
|
||||
(setf p (crts-prdc s5 s5))
|
||||
(setf b (basis p))
|
||||
(setf d (bndr p))
|
||||
(setf basis (funcall b 10))
|
||||
(length basis)
|
||||
(setf c (make-cmbn :degr 10 :list (mapcar #'(lambda (item)
|
||||
(term (1+ (random 5)) item))
|
||||
basis)))
|
||||
(setf +too-much-time+ -1)
|
||||
(cmbn-? d (cmbn-? d c))
|
||||
(time (dotimes (i 5) (cmbn-? d (cmbn-? d c))))
|
||||
|#
|
||||
|
||||
#|
|
||||
;; In EAT.
|
||||
(setf s5 (sphere 5))
|
||||
(setf p (cpr-2ss s5 s5))
|
||||
(setf d (cc-d (ss-cc p)))
|
||||
(setf basis (sbs p 10))
|
||||
(length basis)
|
||||
(setf c (make-cmb :dgr 10 :lst (mapcar #'(lambda (item)
|
||||
(mnm (1+ (random 5)) item))
|
||||
basis)))
|
||||
(??? d (??? d c))
|
||||
(time (dotimes (i 5) (??? d (??? d c))))
|
||||
|#
|
||||
|
||||
114
test/cartesian-products-test.lisp
Normal file
114
test/cartesian-products-test.lisp
Normal file
@ -0,0 +1,114 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
(test extract-common-dgop
|
||||
(dotimes (i 100)
|
||||
(dotimes (j 100)
|
||||
(multiple-value-bind (dgop dgop1 dgop2) (cat:extract-common-dgop i j)
|
||||
(unless (and (= i (cat:dgop*dgop dgop dgop1))
|
||||
(= j (cat:dgop*dgop dgop dgop2)))
|
||||
(error "i = ~D, j = ~D, dgop = ~D, dgop1 = ~D, dgop2 = ~D"
|
||||
i j dgop dgop1 dgop2))))))
|
||||
|
||||
|
||||
(test 2absm-acrpr
|
||||
(cat:2absm-acrpr (cat:absm 5 'a) (cat:absm 3 'b)))
|
||||
|
||||
|
||||
(test crts-prdc-cmpr
|
||||
(let* ((c (cat:cmpr (cat:delta-infinity)))
|
||||
(rslt (cat:crts-prdc-cmpr c c)))
|
||||
(is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 1 1 0 3))))
|
||||
(is (equal :greater
|
||||
(funcall rslt (cat:crpr 4 3 0 7) (cat:crpr 3 1 0 7))))
|
||||
(is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 1 1))))
|
||||
(is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 5 0 3))))
|
||||
(is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 0 5))))
|
||||
(is (equal :equal
|
||||
(funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 0 3))))))
|
||||
|
||||
|
||||
(test crts-prdc-basis
|
||||
(let* ((b (cat:basis (cat:delta 1)))
|
||||
(r (cat:crts-prdc-basis b b))
|
||||
(d3 (cat:basis (cat:delta 3))))
|
||||
(funcall r 0)
|
||||
(funcall r 1)
|
||||
(funcall r 2)
|
||||
(funcall r 3)
|
||||
(setf r (cat:crts-prdc-basis d3 d3))
|
||||
(time (dotimes (i 7)
|
||||
(print (length (funcall r i)))))
|
||||
(setf s3 (cat:basis (cat:sphere 3)))
|
||||
(setf p (cat:crts-prdc-basis s3 s3))
|
||||
(dotimes (i 8)
|
||||
(print (funcall p i)))))
|
||||
|
||||
|
||||
(test crts-prdc-face
|
||||
(let* ((d2 (cat:delta 2))
|
||||
(b2 (cat:basis d2))
|
||||
(f2 (cat:face d2))
|
||||
(b (cat:crts-prdc-basis b2 b2))
|
||||
(r (cat:crts-prdc-face f2 f2)))
|
||||
(dotimes (i 5)
|
||||
(unless (zerop i)
|
||||
(dolist (item (funcall b i))
|
||||
(dotimes (j (1+ i))
|
||||
(format t "~%del-~D ~A = ~A"
|
||||
j item (funcall r j i item))))))))
|
||||
|
||||
|
||||
(test crts-prdc-face*
|
||||
(let* ((d2 (cat:delta 2))
|
||||
(b2 (cat:basis d2))
|
||||
(f2 (cat:face d2))
|
||||
(b (cat:crts-prdc-basis b2 b2))
|
||||
(r (cat:crts-prdc-face* f2 f2)))
|
||||
(dotimes (i 5)
|
||||
(unless (zerop i)
|
||||
(dolist (item (coerce (funcall b i) 'list))
|
||||
(dotimes (j (1+ i))
|
||||
(format t "~%del-~D ~A = ~A"
|
||||
j item (funcall r j i item)))))))
|
||||
(let* ((s3 (cat:sphere 3))
|
||||
(b3 (cat:basis s3))
|
||||
(f3 (cat:face s3))
|
||||
(b (cat:crts-prdc-basis b3 b3))
|
||||
(r (cat:crts-prdc-face* f3 f3)))
|
||||
(dotimes (i 7)
|
||||
(unless (zerop i)
|
||||
(dolist (item (coerce (funcall b i) 'list))
|
||||
(dotimes (j (1+ i))
|
||||
(format t "~%del-~D ~A = ~A"
|
||||
j item (funcall r j i item))))))))
|
||||
|
||||
|
||||
(test crts-prdc
|
||||
(let ((p (cat:crts-prdc (cat:delta 3) (cat:delta 3))))
|
||||
(cat:? p 0 (cat:crpr 0 1 0 2))
|
||||
(cat:? p 1 (cat:crpr 0 3 0 3))
|
||||
(cat:? p 2 (cat:crpr 0 7 0 7))
|
||||
(cat:? p 3 (cat:crpr 0 15 0 15))
|
||||
(cat:? p 4 (cat:crpr 1 15 2 15))))
|
||||
|
||||
|
||||
(test eat
|
||||
(let* ((s5 (cat:sphere 5))
|
||||
(p (cat:crts-prdc s5 s5))
|
||||
(b (cat:basis p))
|
||||
(d (cat:bndr p))
|
||||
(basis (funcall b 10))
|
||||
(c (cat:make-cmbn :degr 10
|
||||
:list (mapcar #'(lambda (item)
|
||||
(cat:term (1+ (random 5))
|
||||
item))
|
||||
basis))))
|
||||
(length basis)
|
||||
(setf cat:+too-much-time+ -1)
|
||||
(cat:cmbn-? d (cat:cmbn-? d c))
|
||||
(time
|
||||
(dotimes (i 5)
|
||||
(cat:cmbn-? d (cat:cmbn-? d c))))))
|
||||
Loading…
Reference in New Issue
Block a user