Extracted disk pasting tests.
This commit is contained in:
Gerd Heber
parent
80a94c4c72
commit
c921cb9c2b
@ -25,6 +25,7 @@
|
||||
(:file "cs-twisted-products-test")
|
||||
(:file "delta-test")
|
||||
(:file "diabolo")
|
||||
(:file "disk-pasting-test")
|
||||
(:file "effective-homology-test")
|
||||
(:file "homology-groups-test")
|
||||
(:file "k-pi-n-test")
|
||||
|
||||
@ -241,10 +241,19 @@
|
||||
|
||||
;; disk-pasting.lisp
|
||||
|
||||
CHCM-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
|
||||
|
||||
BUILD-HMEQ
|
||||
BUILD-RDCT
|
||||
CHECK-RDCT
|
||||
CMPS
|
||||
|
||||
@ -21,16 +21,6 @@
|
||||
(funcall cmpr gnrt1 gnrt2)))))
|
||||
(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)
|
||||
(declare
|
||||
@ -44,12 +34,6 @@
|
||||
(funcall basis degr))))
|
||||
(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)
|
||||
(declare
|
||||
@ -80,19 +64,6 @@
|
||||
:list (rest list)))))))
|
||||
(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)
|
||||
(declare
|
||||
@ -117,11 +88,6 @@
|
||||
(setf (slot-value rslt 'bsgn) (slot-value chcm 'bsgn)))
|
||||
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)
|
||||
(declare
|
||||
@ -151,15 +117,6 @@
|
||||
(error "The new simplicial-set is not constructed."))
|
||||
(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)
|
||||
(declare
|
||||
@ -201,13 +158,6 @@
|
||||
:bndr-strt :cmbn
|
||||
: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)
|
||||
(declare
|
||||
@ -237,17 +187,6 @@
|
||||
:list (rest list)))))))
|
||||
(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)
|
||||
(declare
|
||||
@ -265,13 +204,6 @@
|
||||
:orgn `(mrph-disk-pasting ,mrph ,new-sorc ,new-trgt
|
||||
,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)
|
||||
(declare
|
||||
@ -321,58 +253,6 @@
|
||||
dmns new (zero-cmbn 1+dmns)))
|
||||
: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)))
|
||||
(declare (type simplicial-set smst))
|
||||
@ -386,11 +266,3 @@
|
||||
(hmeq-disk-pasting (efhm old-smst)
|
||||
dmns new (? smst dmns new)
|
||||
: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
148
test/disk-pasting-test.lisp
Normal 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)))
|
||||
Loading…
Reference in New Issue
Block a user