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

Extracted cartesian product tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-09 18:56:23 -05:00
parent 34576fb375
commit fe065a7a13
4 changed files with 295 additions and 276 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
kenzo-test.asd
View File

@ -21,4 +21,5 @@
(:file "homology-groups-test") (:file "homology-groups-test")
(:file "searching-homology-test") (:file "searching-homology-test")
(:file "delta-test") (:file "delta-test")
(:file "bar-test"))) (:file "bar-test")
(:file "cartesian-products-test")))

17
package.lisp
View File

@ -4,10 +4,6 @@
(:use #:cl) (:use #:cl)
(:export KENZO-VERSION (:export KENZO-VERSION
;; UFO
EFHM
;; kenzo.lisp ;; kenzo.lisp
*BC* *BC*
@ -50,6 +46,16 @@
DISPATCH-BICN-CMBN DISPATCH-BICN-CMBN
MAKE-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 ;; chain-complexes.lisp
?2 ?2
@ -82,6 +88,7 @@
;; classes.lisp ;; classes.lisp
ABSM
BCC BCC
BRGN BRGN
CHAIN-COMPLEX CHAIN-COMPLEX
@ -90,6 +97,7 @@
CMBN-LIST CMBN-LIST
DEGR DEGR
DFFR1 DFFR1
EFHM
F F
FACE FACE
G G
@ -211,6 +219,7 @@
;; simplicial-sets.lisp ;; simplicial-sets.lisp
DGOP*DGOP
DLOP-EXT-INT DLOP-EXT-INT
DLOP-INT-EXT DLOP-INT-EXT

437
src/cartesian-products.lisp
View File

@ -14,313 +14,208 @@
(ignore depth)) (ignore depth))
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(format stream "<CrPr ~A ~A ~A ~A>" (format stream "<CrPr ~A ~A ~A ~A>"
(hyphenize-list (dgop-int-ext dgop1)) gmsm1 (hyphenize-list (dgop-int-ext dgop1)) gmsm1
(hyphenize-list (dgop-int-ext dgop2)) gmsm2) (hyphenize-list (dgop-int-ext dgop2)) gmsm2)
crpr)) crpr))
(DEFUN EXTRACT-COMMON-DGOP (dgop1 dgop2) (DEFUN EXTRACT-COMMON-DGOP (dgop1 dgop2)
(declare (fixnum dgop1 dgop2)) (declare (fixnum dgop1 dgop2))
(let ((dgop (logand dgop1 dgop2))) (let ((dgop (logand dgop1 dgop2)))
(declare (fixnum dgop)) (declare (fixnum dgop))
(do ((indx (1- (integer-length dgop)) (1- indx))) (do ((indx (1- (integer-length dgop)) (1- indx)))
((minusp indx)) ((minusp indx))
(declare (fixnum indx)) (declare (fixnum indx))
(when (logbitp indx dgop) (when (logbitp indx dgop)
(setf dgop1 (remove-bit dgop1 indx) (setf dgop1 (remove-bit dgop1 indx)
dgop2 (remove-bit dgop2 indx)))) dgop2 (remove-bit dgop2 indx))))
(values dgop dgop1 dgop2))) (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) (DEFUN 2ABSM-ACRPR (absm1 absm2)
(declare (type absm absm1 absm2)) (declare (type absm absm1 absm2))
(the absm (the absm
(with-absm (dgop1 gmsm1) absm1 (with-absm (dgop1 gmsm1) absm1
(with-absm (dgop2 gmsm2) absm2 (with-absm (dgop2 gmsm2) absm2
(multiple-value-bind (dgop dgop11 dgop22) (extract-common-dgop dgop1 dgop2) (multiple-value-bind (dgop dgop11 dgop22)
(declare (fixnum dgop dgop11 dgop22)) (extract-common-dgop dgop1 dgop2)
(absm dgop (declare (fixnum dgop dgop11 dgop22))
(crpr dgop11 gmsm1 dgop22 gmsm2))))))) (absm dgop
(crpr dgop11 gmsm1 dgop22 gmsm2)))))))
#|
(2absm-acrpr (absm 5 'a) (absm 3 'b))
|#
#| #|
(DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2) (DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2)
(declare (type cmprf cmpr1 cmpr2)) (declare (type cmprf cmpr1 cmpr2))
(flet ((rslt (crpr1 crpr2) (flet ((rslt (crpr1 crpr2)
(declare (type crpr crpr1 crpr2)) (declare (type crpr crpr1 crpr2))
(the cmpr (the cmpr
(let ((left-cons-1 (cadr crpr1)) (let ((left-cons-1 (cadr crpr1))
(left-cons-2 (cadr crpr2))) (left-cons-2 (cadr crpr2)))
(declare (cons left-cons-1 left-cons-2)) (declare (cons left-cons-1 left-cons-2))
(lexico (lexico
(f-cmpr (car left-cons-1) (car left-cons-2)) (f-cmpr (car left-cons-1) (car left-cons-2))
(let ((right-cons-1 (cddr crpr1)) (let ((right-cons-1 (cddr crpr1))
(right-cons-2 (cddr crpr2))) (right-cons-2 (cddr crpr2)))
(declare (cons right-cons-1 right-cons-2)) (declare (cons right-cons-1 right-cons-2))
(lexico (lexico
(f-cmpr (car right-cons-1) (car right-cons-2)) (f-cmpr (car right-cons-1) (car right-cons-2))
(funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2)) (funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2))
(funcall cmpr2 (cdr right-cons-1) (cdr right-cons-2))))))))) (funcall cmpr2 (cdr right-cons-1) (cdr right-cons-2)))))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
|# |#
(DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2) (DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2)
(declare (type cmprf cmpr1 cmpr2)) (declare (type cmprf cmpr1 cmpr2))
(flet ((rslt (crpr1 crpr2) (flet ((rslt (crpr1 crpr2)
(declare (type crpr crpr1 crpr2)) (declare (type crpr crpr1 crpr2))
(the cmpr (the cmpr
(lexico (lexico
(f-cmpr (dgop1 crpr1) (dgop1 crpr2)) (f-cmpr (dgop1 crpr1) (dgop1 crpr2))
(f-cmpr (dgop2 crpr1) (dgop2 crpr2)) (f-cmpr (dgop2 crpr1) (dgop2 crpr2))
(funcall cmpr1 (gmsm1 crpr1) (gmsm1 crpr2)) (funcall cmpr1 (gmsm1 crpr1) (gmsm1 crpr2))
(funcall cmpr2 (gmsm2 crpr1) (gmsm2 crpr2)))))) (funcall cmpr2 (gmsm2 crpr1) (gmsm2 crpr2))))))
(the cmprf #'rslt))) (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) (DEFUN CRTS-PRDC-BASIS (basis1 basis2)
(declare (type basis basis1 basis2)) (declare (type basis basis1 basis2))
(when (or (eq basis1 :locally-effective) (when (or (eq basis1 :locally-effective)
(eq basis2 :locally-effective)) (eq basis2 :locally-effective))
(return-from crts-prdc-basis :locally-effective)) (return-from crts-prdc-basis :locally-effective))
(flet ((rslt (dmns) (flet ((rslt (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(the list (the list
(progn (progn
(when (minusp dmns) (when (minusp dmns)
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(let ((array1 (make-array (1+ dmns))) (let ((array1 (make-array (1+ dmns)))
(array2 (make-array (1+ dmns))) (array2 (make-array (1+ dmns)))
(rslt +empty-list+) (rslt +empty-list+)
(mask (mask dmns))) (mask (mask dmns)))
(declare (declare
(simple-vector array1 array2) (simple-vector array1 array2)
(list rslt) (list rslt)
(fixnum mask)) (fixnum mask))
(dotimes (i (1+ dmns)) (dotimes (i (1+ dmns))
(setf (svref array1 i) (funcall basis1 i) (setf (svref array1 i) (funcall basis1 i)
(svref array2 i) (funcall basis2 i))) (svref array2 i) (funcall basis2 i)))
(do ((dgop1 mask (1- dgop1))) (do ((dgop1 mask (1- dgop1)))
((minusp dgop1)) ((minusp dgop1))
(declare (fixnum dgop1)) (declare (fixnum dgop1))
(let ((dmns1 (- dmns (logcount dgop1)))) (let ((dmns1 (- dmns (logcount dgop1))))
(declare (fixnum dmns1)) (declare (fixnum dmns1))
(do ((dgop2 mask (1- dgop2))) (do ((dgop2 mask (1- dgop2)))
((minusp dgop2)) ((minusp dgop2))
(declare (fixnum dgop2)) (declare (fixnum dgop2))
(unless (plusp (logand dgop1 dgop2)) (unless (plusp (logand dgop1 dgop2))
(setf rslt (setf rslt
(nconc (nconc
(mapcan (mapcan
#'(lambda (item1) #'(lambda (item1)
(declare (type gmsm item1)) (declare (type gmsm item1))
(mapcar (mapcar
#'(lambda (item2) #'(lambda (item2)
(declare (type gmsm item2)) (declare (type gmsm item2))
(crpr dgop1 item1 dgop2 item2)) (crpr dgop1 item1 dgop2 item2))
(svref array2 (- dmns (logcount dgop2))))) (svref array2 (- dmns
(svref array1 dmns1)) (logcount dgop2)))))
rslt)))))) (svref array1 dmns1))
rslt))))) rslt))))))
(the basis #'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) (DEFUN CRTS-PRDC-FACE (face1 face2)
(declare (type face face1 face2)) (declare (type face face1 face2))
(flet ((rslt (indx dmns crpr) (flet ((rslt (indx dmns crpr)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type crpr crpr)) (type crpr crpr))
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1) (multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1)
(declare (declare
(fixnum dgop1) (fixnum dgop1)
(type (or null fixnum) del1)) (type (or null fixnum) del1))
(multiple-value-bind (dgop2 del2) (1dlop-dgop indx dgop2) (multiple-value-bind (dgop2 del2) (1dlop-dgop indx
(declare dgop2)
(fixnum dgop2) (declare
(type (or null fixnum) del2)) (fixnum dgop2)
(when del1 (type (or null fixnum) del2))
(let ((absm1 (funcall face1 del1 (- dmns (logcount dgop1)) gmsm1))) (when del1
(declare (type absm absm1)) (let ((absm1 (funcall face1 del1 (- dmns (logcount
(setf dgop1 (dgop*dgop dgop1 (dgop absm1)) dgop1))
gmsm1 (gmsm absm1)))) gmsm1)))
(when del2 (declare (type absm absm1))
(let ((absm2 (funcall face2 del2 (- dmns (logcount dgop2)) gmsm2))) (setf dgop1 (dgop*dgop dgop1 (dgop absm1))
(declare (type absm absm2)) gmsm1 (gmsm absm1))))
(setf dgop2 (dgop*dgop dgop2 (dgop absm2)) (when del2
gmsm2 (gmsm absm2)))) (let ((absm2 (funcall face2 del2 (- dmns (logcount
(multiple-value-bind (dgop dgop1 dgop2) (extract-common-dgop dgop1 dgop2) 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)) (declare (fixnum dgop dgop1 dgop2))
(absm dgop (crpr dgop1 gmsm1 dgop2 gmsm2)))))))) (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) (DEFUN CRTS-PRDC-FACE* (face1 face2)
(declare (type face face1 face2)) (declare (type face face1 face2))
(flet ((rslt (indx dmns crpr) (flet ((rslt (indx dmns crpr)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type crpr crpr)) (type crpr crpr))
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1) (multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1)
(declare (declare
(fixnum dgop1) (fixnum dgop1)
(type (or null fixnum) del1)) (type (or null fixnum) del1))
(multiple-value-bind (dgop2 del2) (1dlop-dgop indx dgop2) (multiple-value-bind (dgop2 del2) (1dlop-dgop indx
(declare dgop2)
(fixnum dgop2) (declare
(type (or null fixnum) del2)) (fixnum dgop2)
(when del1 (type (or null fixnum) del2))
(let ((absm1 (funcall face1 del1 (- dmns (logcount dgop1)) gmsm1))) (when del1
(declare (type absm absm1)) (let ((absm1 (funcall face1 del1 (- dmns (logcount
(setf dgop1 (dgop*dgop dgop1 (dgop absm1)) dgop1))
gmsm1 (gmsm absm1)))) gmsm1)))
(when del2 (declare (type absm absm1))
(let ((absm2 (funcall face2 del2 (- dmns (logcount dgop2)) gmsm2))) (setf dgop1 (dgop*dgop dgop1 (dgop absm1))
(declare (type absm absm2)) gmsm1 (gmsm absm1))))
(setf dgop2 (dgop*dgop dgop2 (dgop absm2)) (when del2
gmsm2 (gmsm absm2)))) (let ((absm2 (funcall face2 del2 (- dmns (logcount
(if (plusp (logand dgop1 dgop2)) dgop2))
:degenerate gmsm2)))
(crpr dgop1 gmsm1 dgop2 gmsm2))))))) (declare (type absm absm2))
(the intr-mrph #'rslt))) (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) (DEFUN CRTS-PRDC (smst1 smst2)
(declare (type simplicial-set smst1 smst2)) (declare (type simplicial-set smst1 smst2))
(with-slots ((cmpr1 cmpr) (basis1 basis) (face1 face) (bspn1 bsgn)) smst1 (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 (declare
(type cmprf cmpr1) (type cmprf cmpr2)
(type basis basis1) (type basis basis2)
(type face face1)) (type face face2))
(with-slots ((cmpr2 cmpr) (basis2 basis) (face2 face) (bspn2 bsgn)) smst2
(declare
(type cmprf cmpr2)
(type basis basis2)
(type face face2))
(the simplicial-set (the simplicial-set
(build-smst (build-smst
:cmpr (crts-prdc-cmpr cmpr1 cmpr2) :cmpr (crts-prdc-cmpr cmpr1 cmpr2)
:basis (crts-prdc-basis basis1 basis2) :basis (crts-prdc-basis basis1 basis2)
:bspn (crpr 0 bspn1 0 bspn2) :bspn (crpr 0 bspn1 0 bspn2)
:face (crts-prdc-face face1 face2) :face (crts-prdc-face face1 face2)
:face* (crts-prdc-face* face1 face2) :face* (crts-prdc-face* face1 face2)
:orgn `(crts-prdc ,smst1 ,smst2)))))) :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
View 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))))))