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

Extracted disk pasting tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-23 17:58:15 -05:00
parent 80a94c4c72
commit c921cb9c2b
4 changed files with 320 additions and 290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -25,6 +25,7 @@
(:file "cs-twisted-products-test") (:file "cs-twisted-products-test")
(:file "delta-test") (:file "delta-test")
(:file "diabolo") (:file "diabolo")
(:file "disk-pasting-test")
(:file "effective-homology-test") (:file "effective-homology-test")
(:file "homology-groups-test") (:file "homology-groups-test")
(:file "k-pi-n-test") (:file "k-pi-n-test")

9
package.lisp
View File

@ -241,10 +241,19 @@
;; disk-pasting.lisp ;; disk-pasting.lisp
CHCM-DISK-PASTING
DISK-PASTING DISK-PASTING
DISK-PASTING-BASIS
DISK-PASTING-CMPR
DISK-PASTING-FACE
DISK-PASTING-INTR-DFFR
HMEQ-DISK-PASTING
MRPH-DISK-PASTING
MRPH-DISK-PASTING-INTR
;; effective-homology.lisp ;; effective-homology.lisp
BUILD-HMEQ
BUILD-RDCT BUILD-RDCT
CHECK-RDCT CHECK-RDCT
CMPS CMPS

128
src/disk-pasting.lisp
View File

@ -21,16 +21,6 @@
(funcall cmpr gnrt1 gnrt2))))) (funcall cmpr gnrt1 gnrt2)))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
#|
(setf c (delta 3))
(setf cmpr (disk-pasting-cmpr (cmpr c) 'new))
(funcall cmpr 'new 'new)
(funcall cmpr 'new 5)
(funcall cmpr 5 'new)
(funcall cmpr 5 5)
(funcall cmpr 5 6)
(funcall cmpr 6 5)
|#
(DEFUN DISK-PASTING-BASIS (basis dmns new) (DEFUN DISK-PASTING-BASIS (basis dmns new)
(declare (declare
@ -44,12 +34,6 @@
(funcall basis degr)))) (funcall basis degr))))
(the basis #'rslt))) (the basis #'rslt)))
#|
(setf c (delta 3))
(setf basis (disk-pasting-basis (basis c) 3 'new))
(funcall basis 3)
(funcall basis 2)
|#
(DEFUN DISK-PASTING-INTR-DFFR (old-dffr degr new bndr) (DEFUN DISK-PASTING-INTR-DFFR (old-dffr degr new bndr)
(declare (declare
@ -80,19 +64,6 @@
:list (rest list))))))) :list (rest list)))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
#|
(cat-init)
(setf c (delta 3))
(setf intr (disk-pasting-intr-dffr (dffr c) 3 'new (cmbn 2 1 7)))
(setf intr (disk-pasting-intr-dffr (dffr c) 3 'new (? c 3 15)))
(funcall intr (cmbn 2 1 7))
(funcall intr (cmbn 3))
(funcall intr (cmbn 3 1 15))
(funcall intr (cmbn 3 1 'new 1 15))
(funcall intr (cmbn 3 1 'new -1 15))
(funcall intr (cmbn 3 -1 'new 1 15))
(funcall intr (cmbn 3 -1 'new -1 15))
|#
(DEFUN CHCM-DISK-PASTING (chcm dmns new bndr) (DEFUN CHCM-DISK-PASTING (chcm dmns new bndr)
(declare (declare
@ -117,11 +88,6 @@
(setf (slot-value rslt 'bsgn) (slot-value chcm 'bsgn))) (setf (slot-value rslt 'bsgn) (slot-value chcm 'bsgn)))
rslt)))) rslt))))
#|
(setf c (delta 3))
(setf s3 (chcm-disk-pasting c 3 'new (? c 3 15)))
(homology s3 0 5))
|#
(DEFUN DISK-PASTING-FACE (cmpr face dmns new faces) (DEFUN DISK-PASTING-FACE (cmpr face dmns new faces)
(declare (declare
@ -151,15 +117,6 @@
(error "The new simplicial-set is not constructed.")) (error "The new simplicial-set is not constructed."))
(the face #'rslt))) (the face #'rslt)))
#|
(cat-init)
(setf c (delta 3))
(setf face (disk-pasting-face (cmpr c) (face c)
3 'new (list 14 (absm 0 13) 11 7)))
(funcall face 0 2 7)
(funcall face 0 3 15)
(dotimes (i 4) (print (funcall face i 3 'new)))
|#
(DEFUN DISK-PASTING (smst dmns new faces) (DEFUN DISK-PASTING (smst dmns new faces)
(declare (declare
@ -201,13 +158,6 @@
:bndr-strt :cmbn :bndr-strt :cmbn
:orgn `(disk-pasting ,smst ,dmns ,new ,faces)))))) :orgn `(disk-pasting ,smst ,dmns ,new ,faces))))))
#|
(setf d2 (delta 2))
(setf s2 (disk-pasting d2 2 'new '(6 5 3)))
(homology s2 0 4)
(setf s2xs2 (crts-prdc s2 s2))
(homology s2xs2 0 6)
|#
(DEFUN MRPH-DISK-PASTING-INTR (mrph trgt-cmpr dmns new new-im) (DEFUN MRPH-DISK-PASTING-INTR (mrph trgt-cmpr dmns new new-im)
(declare (declare
@ -237,17 +187,6 @@
:list (rest list))))))) :list (rest list)))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
#|
(setf m (idnt-mrph (delta 3)))
(setf intr
(mrph-disk-pasting-intr m (cmpr (delta 3))
3 'new (cmbn 3 -1 15)))
(funcall intr (cmbn 2 3 7))
(funcall intr (cmbn 3))
(funcall intr (cmbn 3 4 15))
(funcall intr (cmbn 3 1 'new 1 15))
(funcall intr (cmbn 3 -1 'new 1 15))
|#
(DEFUN MRPH-DISK-PASTING (mrph new-sorc new-trgt dmns new new-im) (DEFUN MRPH-DISK-PASTING (mrph new-sorc new-trgt dmns new new-im)
(declare (declare
@ -265,13 +204,6 @@
:orgn `(mrph-disk-pasting ,mrph ,new-sorc ,new-trgt :orgn `(mrph-disk-pasting ,mrph ,new-sorc ,new-trgt
,dmns ,new ,new-im)))) ,dmns ,new ,new-im))))
#|
(setf d (delta 3))
(setf m (idnt-mrph d))
(setf sorc (chcm-disk-pasting d 3 'new (? d 3 15)))
(setf nm (mrph-disk-pasting m sorc sorc 3 'new (cmbn 3 1 'new)))
(? nm (cmbn 3 2 'new 3 15))
|#
(DEFUN HMEQ-DISK-PASTING (hmeq dmns new bndr &key new-lbcc) (DEFUN HMEQ-DISK-PASTING (hmeq dmns new bndr &key new-lbcc)
(declare (declare
@ -321,58 +253,6 @@
dmns new (zero-cmbn 1+dmns))) dmns new (zero-cmbn 1+dmns)))
:orgn `(hmeq-disk-pasting ,hmeq ,dmns ,new ,bndr)))) :orgn `(hmeq-disk-pasting ,hmeq ,dmns ,new ,bndr))))
#|
(cat-init)
(setf tcc
(build-chcm
:cmpr #'s-cmpr
:basis #'(lambda (degr)
(case degr
(0 (list 'a))
(1 (list 'b))
(otherwise nil)))
:intr-dffr #'(lambda (degr gnrt)
(if (= 1 degr)
(cmbn 0 1 'a)
(zero-cmbn (1- degr))))
:strt :gnrt
:orgn '(z-z)))
(setf bcc
(build-chcm
:cmpr #'s-cmpr
:basis #'(lambda (degr) nil)
:intr-dffr #'(lambda (degr gnrt) (error "Impossible."))
:strt :gnrt
:orgn '(zero)))
(setf rh (build-mrph
:sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(if (zerop degr)
(cmbn 1 1 'b)
(zero-cmbn 2)))
:strt :gnrt
:orgn '(rh)))
(setf hmeq (build-hmeq
:lrdct (trivial-rdct tcc)
:rrdct (build-rdct
:f (zero-mrph tcc bcc 0)
:g (zero-mrph bcc tcc 0)
:h rh
:orgn '(rrdct))))
(setf nhmeq (hmeq-disk-pasting hmeq 1 'new (cmbn 0 1 'a)))
(pre-check-rdct (lrdct nhmeq))
(setf *tc* (cmbn 0 1 'a))
(setf *bc* *tc*)
(check-rdct)
(setf *tc* (cmbn 1 1 'new 10 'b))
(setf *bc* *tc*)
(check-rdct)
(pre-check-rdct (rrdct nhmeq))
(setf *bc* (zero-cmbn 0))
(check-rdct)
(setf *tc* (cmbn 0 1 'a))
(check-rdct)
|#
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'disk-pasting))) (DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'disk-pasting)))
(declare (type simplicial-set smst)) (declare (type simplicial-set smst))
@ -386,11 +266,3 @@
(hmeq-disk-pasting (efhm old-smst) (hmeq-disk-pasting (efhm old-smst)
dmns new (? smst dmns new) dmns new (? smst dmns new)
:new-lbcc smst)))) :new-lbcc smst))))
#|
(cat-init)
(setf d (delta 2))
(setf s2 (disk-pasting d 2 'new '(6 5
3)))
(homology s2 0 4)
|#

148
test/disk-pasting-test.lisp Normal file
View File

@ -0,0 +1,148 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(test disk-pasting-cmpr
(let* ((c (cat:delta 3))
(cmpr (cat:disk-pasting-cmpr (cat:cmpr c) 'new)))
(is (equal :equal (funcall cmpr 'new 'new)))
(is (equal :less (funcall cmpr 'new 5)))
(is (equal :greater (funcall cmpr 5 'new)))
(is (equal :equal (funcall cmpr 5 5)))
(is (equal :less (funcall cmpr 5 6)))
(is (equal :greater (funcall cmpr 6 5)))))
(test disk-pasting-basis
(cat:cat-init)
(let* ((c (cat:delta 3))
(basis (cat:disk-pasting-basis (cat:basis c) 3 'new)))
(funcall basis 3)
(funcall basis 2)))
(test disk-pasting-intr-dffr
(cat:cat-init)
(let* ((c (cat:delta 3))
intr)
(signals simple-error
(setf intr (cat:disk-pasting-intr-dffr
(cat:dffr c) 3 'new (cat:cmbn 2 1 7))))
(setf intr (cat:disk-pasting-intr-dffr (cat:dffr c)
3 'new (cat:? c 3 15)))
(funcall intr (cat:cmbn 2 1 7))
(funcall intr (cat:cmbn 3))
(funcall intr (cat:cmbn 3 1 15))
(funcall intr (cat:cmbn 3 1 'new 1 15))
(funcall intr (cat:cmbn 3 1 'new -1 15))
(funcall intr (cat:cmbn 3 -1 'new 1 15))
(funcall intr (cat:cmbn 3 -1 'new -1 15))))
(test chcm-disk-pasting
(cat:cat-init)
(let* ((c (cat:delta 3))
(s3 (cat:chcm-disk-pasting c 3 'new (cat:? c 3 15))))
(cat:homology s3 0 5)))
(test disk-pasting-face
(cat:cat-init)
(let* ((c (cat:delta 3))
(face (cat:disk-pasting-face (cat:cmpr c) (cat:face c)
3 'new
(list 14 (cat:absm 0 13) 11 7))))
(funcall face 0 2 7)
(funcall face 0 3 15)
(dotimes (i 4) (print (funcall face i 3 'new)))))
(test disk-pasting
(cat:cat-init)
(let* ((d2 (cat:delta 2))
(s2 (cat:disk-pasting d2 2 'new '(6 5 3)))
s2xs2)
(cat:homology s2 0 4)
(setf s2xs2 (cat:crts-prdc s2 s2))
(cat:homology s2xs2 0 6)))
(test mrph-disk-pasting-intr
(cat:cat-init)
(let* ((m (cat:idnt-mrph (cat:delta 3)))
(intr (cat:mrph-disk-pasting-intr m (cat:cmpr (cat:delta 3))
3 'new (cat:cmbn 3 -1 15))))
(funcall intr (cat:cmbn 2 3 7))
(funcall intr (cat:cmbn 3))
(funcall intr (cat:cmbn 3 4 15))
(funcall intr (cat:cmbn 3 1 'new 1 15))
(funcall intr (cat:cmbn 3 -1 'new 1 15))))
(test mrph-disk-pasting
(cat:cat-init)
(let* ((d (cat:delta 3))
(m (cat:idnt-mrph d))
(sorc (cat:chcm-disk-pasting d 3 'new (cat:? d 3 15)))
(nm (cat:mrph-disk-pasting m sorc sorc 3 'new
(cat:cmbn 3 1 'new))))
(cat:? nm (cat:cmbn 3 2 'new 3 15))))
(test disk-pasting1
(cat:cat-init)
(let* ((d (cat:delta 2))
(s2 (cat:disk-pasting d 2 'new '(6 5 3))))
(cat:homology s2 0 4)))
(test hmeq-disk-pasting
(cat:cat-init)
(let* ((tcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr)
(case degr
(0 (list 'a))
(1 (list 'b))
(otherwise nil)))
:intr-dffr #'(lambda (degr gnrt)
(if (= 1 degr)
(cat:cmbn 0 1 'a)
(cat:zero-cmbn (1- degr))))
:strt :gnrt
:orgn '(z-z)))
(bcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) nil)
:intr-dffr #'(lambda (degr gnrt) (error "Impossible."))
:strt :gnrt
:orgn '(zero)))
(rh (cat:build-mrph
:sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(if (zerop degr)
(cat:cmbn 1 1 'b)
(cat:zero-cmbn 2)))
:strt :gnrt
:orgn '(rh)))
(hmeq (cat:build-hmeq
:lrdct (cat:trivial-rdct tcc)
:rrdct (cat:build-rdct
:f (cat:zero-mrph tcc bcc 0)
:g (cat:zero-mrph bcc tcc 0)
:h rh
:orgn '(rrdct))))
(nhmeq (cat:hmeq-disk-pasting hmeq 1 'new (cat:cmbn 0 1 'a))))
(cat:pre-check-rdct (cat:lrdct nhmeq))
(setf cat:*tc* (cat:cmbn 0 1 'a))
(setf cat:*bc* cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 1 1 'new 10 'b))
(setf cat:*bc* cat:*tc*)
(check-rdct)
(cat:pre-check-rdct (cat:rrdct nhmeq))
(setf cat:*bc* (cat:zero-cmbn 0))
(check-rdct)
(setf cat:*tc* (cat:cmbn 0 1 'a))
(check-rdct)))