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

149
src/cartesian-products.lisp
View File

@ -31,30 +31,18 @@
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)
(extract-common-dgop dgop1 dgop2)
(declare (fixnum dgop dgop11 dgop22)) (declare (fixnum dgop dgop11 dgop22))
(absm dgop (absm dgop
(crpr dgop11 gmsm1 dgop22 gmsm2))))))) (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)
@ -90,18 +78,6 @@
(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)
@ -142,28 +118,13 @@
#'(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
(logcount dgop2)))))
(svref array1 dmns1)) (svref array1 dmns1))
rslt)))))) rslt))))))
rslt))))) rslt)))))
(the basis #'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))
@ -176,38 +137,31 @@
(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
dgop2)
(declare (declare
(fixnum dgop2) (fixnum dgop2)
(type (or null fixnum) del2)) (type (or null fixnum) del2))
(when del1 (when del1
(let ((absm1 (funcall face1 del1 (- dmns (logcount dgop1)) gmsm1))) (let ((absm1 (funcall face1 del1 (- dmns (logcount
dgop1))
gmsm1)))
(declare (type absm absm1)) (declare (type absm absm1))
(setf dgop1 (dgop*dgop dgop1 (dgop absm1)) (setf dgop1 (dgop*dgop dgop1 (dgop absm1))
gmsm1 (gmsm absm1)))) gmsm1 (gmsm absm1))))
(when del2 (when del2
(let ((absm2 (funcall face2 del2 (- dmns (logcount dgop2)) gmsm2))) (let ((absm2 (funcall face2 del2 (- dmns (logcount
dgop2))
gmsm2)))
(declare (type absm absm2)) (declare (type absm absm2))
(setf dgop2 (dgop*dgop dgop2 (dgop absm2)) (setf dgop2 (dgop*dgop dgop2 (dgop absm2))
gmsm2 (gmsm absm2)))) gmsm2 (gmsm absm2))))
(multiple-value-bind (dgop dgop1 dgop2) (extract-common-dgop dgop1 dgop2) (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))
@ -220,17 +174,22 @@
(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
dgop2)
(declare (declare
(fixnum dgop2) (fixnum dgop2)
(type (or null fixnum) del2)) (type (or null fixnum) del2))
(when del1 (when del1
(let ((absm1 (funcall face1 del1 (- dmns (logcount dgop1)) gmsm1))) (let ((absm1 (funcall face1 del1 (- dmns (logcount
dgop1))
gmsm1)))
(declare (type absm absm1)) (declare (type absm absm1))
(setf dgop1 (dgop*dgop dgop1 (dgop absm1)) (setf dgop1 (dgop*dgop dgop1 (dgop absm1))
gmsm1 (gmsm absm1)))) gmsm1 (gmsm absm1))))
(when del2 (when del2
(let ((absm2 (funcall face2 del2 (- dmns (logcount dgop2)) gmsm2))) (let ((absm2 (funcall face2 del2 (- dmns (logcount
dgop2))
gmsm2)))
(declare (type absm absm2)) (declare (type absm absm2))
(setf dgop2 (dgop*dgop dgop2 (dgop absm2)) (setf dgop2 (dgop*dgop dgop2 (dgop absm2))
gmsm2 (gmsm absm2)))) gmsm2 (gmsm absm2))))
@ -239,30 +198,6 @@
(crpr dgop1 gmsm1 dgop2 gmsm2))))))) (crpr dgop1 gmsm1 dgop2 gmsm2)))))))
(the intr-mrph #'rslt))) (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))
@ -284,43 +219,3 @@
: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))))))