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