150 lines
5.1 KiB
Common Lisp
150 lines
5.1 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
|
|
|
|
(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)))
|