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

452
src/disk-pasting.lisp
View File

@ -8,55 +8,39 @@
(DEFUN DISK-PASTING-CMPR (cmpr new) (DEFUN DISK-PASTING-CMPR (cmpr new)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(symbol new)) (symbol new))
(flet ((rslt (gnrt1 gnrt2) (flet ((rslt (gnrt1 gnrt2)
(declare (type gnrt gnrt1 gnrt2)) (declare (type gnrt gnrt1 gnrt2))
(if (eq gnrt1 new) (if (eq gnrt1 new)
(if (eq gnrt2 new) (if (eq gnrt2 new)
:equal :equal
:less) :less)
(if (eq gnrt2 new) (if (eq gnrt2 new)
:greater :greater
(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
(type basis basis) (type basis basis)
(fixnum dmns) (fixnum dmns)
(symbol new)) (symbol new))
(flet ((rslt (degr) (flet ((rslt (degr)
(declare (fixnum degr)) (declare (fixnum degr))
(if (= degr dmns) (if (= degr dmns)
(cons new (funcall basis dmns)) (cons new (funcall basis dmns))
(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
(type morphism old-dffr) (type morphism old-dffr)
(fixnum degr) (fixnum degr)
(symbol new) (symbol new)
(type cmbn bndr)) (type cmbn bndr))
(when (cmbn-non-zero-p (cmbn-? old-dffr bndr)) (when (cmbn-non-zero-p (cmbn-? old-dffr bndr))
(error "In CHCM-DISK-PASTING, the given boundary has a non-null boundary.")) (error "In CHCM-DISK-PASTING, the given boundary has a non-null boundary."))
(let ((cmpr (cmpr (trgt old-dffr)))) (let ((cmpr (cmpr (trgt old-dffr))))
@ -64,72 +48,54 @@
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (degr2 list) cmbn (with-cmbn (degr2 list) cmbn
(unless (= degr degr2) (unless (= degr degr2)
(return-from rslt (return-from rslt
(cmbn-? old-dffr cmbn))) (cmbn-? old-dffr cmbn)))
(unless list (unless list
(return-from rslt (return-from rslt
(zero-cmbn (1- degr)))) (zero-cmbn (1- degr))))
(unless (eq (-gnrt list) new) (unless (eq (-gnrt list) new)
(return-from rslt (return-from rslt
(cmbn-? old-dffr cmbn))) (cmbn-? old-dffr cmbn)))
(2cmbn-add cmpr (2cmbn-add cmpr
(n-cmbn (-cffc list) bndr) (n-cmbn (-cffc list) bndr)
(cmbn-? old-dffr (cmbn-? old-dffr
(make-cmbn :degr degr (make-cmbn :degr degr
: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
(type chain-complex chcm) (type chain-complex chcm)
(fixnum dmns) (fixnum dmns)
(symbol new) (symbol new)
(type cmbn bndr)) (type cmbn bndr))
(the chain-complex (the chain-complex
(with-slots (cmpr basis dffr) chcm (with-slots (cmpr basis dffr) chcm
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type basis basis) (type basis basis)
(type morphism dffr)) (type morphism dffr))
(let ((rslt (build-chcm (let ((rslt (build-chcm
:cmpr (disk-pasting-cmpr cmpr new) :cmpr (disk-pasting-cmpr cmpr new)
:basis (disk-pasting-basis basis dmns new) :basis (disk-pasting-basis basis dmns new)
:intr-dffr (disk-pasting-intr-dffr dffr dmns new bndr) :intr-dffr (disk-pasting-intr-dffr dffr dmns new bndr)
:strt :cmbn :strt :cmbn
:orgn `(chcm-disk-pasting ,chcm ,dmns ,new ,bndr)))) :orgn `(chcm-disk-pasting ,chcm ,dmns ,new ,bndr))))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
(when (slot-boundp chcm 'bsgn) (when (slot-boundp chcm 'bsgn)
(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
(type cmprf cmpr) (type cmprf cmpr)
(type face face) (type face face)
(fixnum dmns) (fixnum dmns)
(symbol new) (symbol new)
(list faces)) (list faces))
(unless (= (1+ dmns) (length faces)) (unless (= (1+ dmns) (length faces))
(error "In DISK-PASTING, non-coherent arguments.")) (error "In DISK-PASTING, non-coherent arguments."))
(mapl #'(lambda (mark) (mapl #'(lambda (mark)
@ -139,147 +105,113 @@
faces) faces)
(flet ((rslt (indx dmns2 gmsm) (flet ((rslt (indx dmns2 gmsm)
(declare (declare
(fixnum indx dmns2) (fixnum indx dmns2)
(type gmsm gmsm)) (type gmsm gmsm))
(unless (= dmns dmns2) (unless (= dmns dmns2)
(return-from rslt (return-from rslt
(funcall face indx dmns2 gmsm))) (funcall face indx dmns2 gmsm)))
(if (eq gmsm new) (if (eq gmsm new)
(nth indx faces) (nth indx faces)
(funcall face indx dmns gmsm)))) (funcall face indx dmns gmsm))))
(unless (check-faces cmpr #'rslt dmns new) (unless (check-faces cmpr #'rslt dmns new)
(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
(type simplicial-set smst) (type simplicial-set smst)
(fixnum dmns) (fixnum dmns)
(symbol new) (symbol new)
(list faces)) (list faces))
(the simplicial-set (the simplicial-set
(with-slots (cmpr basis bsgn face dffr) smst (with-slots (cmpr basis bsgn face dffr) smst
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type basis basis) (type basis basis)
(type gmsm bsgn) (type gmsm bsgn)
(type face face) (type face face)
(type morphism dffr)) (type morphism dffr))
(let ((new-face (disk-pasting-face (cmpr smst) face (let ((new-face (disk-pasting-face (cmpr smst) face
dmns new faces)) dmns new faces))
(new-bndr (zero-cmbn (1- dmns)))) (new-bndr (zero-cmbn (1- dmns))))
(declare (declare
(type face new-face) (type face new-face)
(type cmbn new-bndr)) (type cmbn new-bndr))
(do ((mark faces (cdr mark)) (do ((mark faces (cdr mark))
(sign 1 (- sign))) (sign 1 (- sign)))
((endp mark)) ((endp mark))
(declare (declare
(list mark) (list mark)
(fixnum sign)) (fixnum sign))
(let ((absm (car mark))) (let ((absm (car mark)))
(declare (type absm absm)) (declare (type absm absm))
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(unless (plusp dgop) (unless (plusp dgop)
(dstr-add-term-to-cmbn cmpr sign gmsm new-bndr))))) (dstr-add-term-to-cmbn cmpr sign gmsm new-bndr)))))
(build-smst (build-smst
:cmpr (disk-pasting-cmpr cmpr new) :cmpr (disk-pasting-cmpr cmpr new)
:basis (disk-pasting-basis basis dmns new) :basis (disk-pasting-basis basis dmns new)
:bspn bsgn :bspn bsgn
:face new-face :face new-face
:intr-bndr (disk-pasting-intr-dffr dffr dmns new new-bndr) :intr-bndr (disk-pasting-intr-dffr dffr dmns new new-bndr)
: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
(type morphism mrph) (type morphism mrph)
(type cmprf trgt-cmpr) (type cmprf trgt-cmpr)
(fixnum dmns) (fixnum dmns)
(symbol new) (symbol new)
(type cmbn new-im)) (type cmbn new-im))
(let ((mrph-degr (degr mrph))) (let ((mrph-degr (degr mrph)))
(declare (fixnum mrph-degr)) (declare (fixnum mrph-degr))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(unless (= degr dmns) (unless (= degr dmns)
(return-from rslt (return-from rslt
(cmbn-? mrph cmbn))) (cmbn-? mrph cmbn)))
(unless list (unless list
(return-from rslt (return-from rslt
(zero-cmbn (+ degr mrph-degr)))) (zero-cmbn (+ degr mrph-degr))))
(unless (eq new (-gnrt list)) (unless (eq new (-gnrt list))
(return-from rslt (return-from rslt
(cmbn-? mrph cmbn))) (cmbn-? mrph cmbn)))
(2cmbn-add trgt-cmpr (2cmbn-add trgt-cmpr
(n-cmbn (-cffc list) new-im) (n-cmbn (-cffc list) new-im)
(cmbn-? mrph (cmbn-? mrph
(make-cmbn :degr degr (make-cmbn :degr degr
: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
(type morphism mrph) (type morphism mrph)
(type chain-complex new-sorc new-trgt) (type chain-complex new-sorc new-trgt)
(fixnum dmns) (fixnum dmns)
(symbol new) (symbol new)
(type cmbn new-im)) (type cmbn new-im))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc new-sorc :trgt new-trgt :degr (degr mrph) :sorc new-sorc :trgt new-trgt :degr (degr mrph)
:intr (mrph-disk-pasting-intr mrph (cmpr new-trgt) :intr (mrph-disk-pasting-intr mrph (cmpr new-trgt)
dmns new new-im) dmns new new-im)
:strt :cmbn :strt :cmbn
: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
(type homotopy-equivalence hmeq) (type homotopy-equivalence hmeq)
(fixnum dmns) (fixnum dmns)
(symbol new) (symbol new)
(type cmbn bndr) (type cmbn bndr)
(type (or null chain-complex) new-lbcc)) (type (or null chain-complex) new-lbcc))
(let* ((lg (lg hmeq)) (let* ((lg (lg hmeq))
(rf (rf hmeq)) (rf (rf hmeq))
(rh (rh hmeq)) (rh (rh hmeq))
@ -289,108 +221,48 @@
(chcm-disk-pasting (lbcc hmeq) (chcm-disk-pasting (lbcc hmeq)
dmns new bndr))) dmns new bndr)))
(new-tcc (chcm-disk-pasting (tcc hmeq) (new-tcc (chcm-disk-pasting (tcc hmeq)
dmns new t-bndr)) dmns new t-bndr))
(new-rbcc (chcm-disk-pasting (rbcc hmeq) (new-rbcc (chcm-disk-pasting (rbcc hmeq)
dmns new rb-bndr)) dmns new rb-bndr))
(1+dmns (1+ dmns))) (1+dmns (1+ dmns)))
(declare (declare
(type morphism lg rf rh) (type morphism lg rf rh)
(type cmbn t-bndr rb-bndr) (type cmbn t-bndr rb-bndr)
(type chain-complex new-lbcc new-tcc new-rbcc) (type chain-complex new-lbcc new-tcc new-rbcc)
(fixnum 1+dmns)) (fixnum 1+dmns))
(build-hmeq (build-hmeq
:lrdct (build-rdct :lrdct (build-rdct
:f (mrph-disk-pasting (lf hmeq) new-tcc new-lbcc :f (mrph-disk-pasting (lf hmeq) new-tcc new-lbcc
dmns new (cmbn dmns 1 new)) dmns new (cmbn dmns 1 new))
:g (mrph-disk-pasting lg new-lbcc new-tcc :g (mrph-disk-pasting lg new-lbcc new-tcc
dmns new (cmbn dmns 1 new)) dmns new (cmbn dmns 1 new))
:h (mrph-disk-pasting (lh hmeq) new-tcc new-tcc :h (mrph-disk-pasting (lh hmeq) new-tcc new-tcc
dmns new (zero-cmbn 1+dmns))) dmns new (zero-cmbn 1+dmns)))
:rrdct (build-rdct :rrdct (build-rdct
:f (mrph-disk-pasting rf new-tcc new-rbcc :f (mrph-disk-pasting rf new-tcc new-rbcc
dmns new (cmbn dmns 1 new)) dmns new (cmbn dmns 1 new))
:g (mrph-disk-pasting (rg hmeq) new-rbcc new-tcc :g (mrph-disk-pasting (rg hmeq) new-rbcc new-tcc
dmns new dmns new
(make-cmbn (make-cmbn
:degr dmns :degr dmns
:list (cons (term 1 new) :list (cons (term 1 new)
(cmbn-list (cmbn-list
(cmbn-opps (cmbn-opps
(cmbn-? rh t-bndr)))))) (cmbn-? rh t-bndr))))))
:h (mrph-disk-pasting rh new-tcc new-tcc :h (mrph-disk-pasting rh new-tcc new-tcc
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))
(the homotopy-equivalence (the homotopy-equivalence
(destructuring-bind (old-smst dmns new faces) (rest (orgn smst)) (destructuring-bind (old-smst dmns new faces) (rest (orgn smst))
(declare (declare
(type simplicial-set old-smst) (type simplicial-set old-smst)
(fixnum dmns) (fixnum dmns)
(symbol new) (symbol new)
(ignore faces)) (ignore faces))
(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)))