271 lines
9.3 KiB
Common Lisp
271 lines
9.3 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
|
|
|
|
;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING
|
|
;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING
|
|
;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING
|
|
|
|
(IN-PACKAGE #:cat)
|
|
|
|
(provide "disk-pasting")
|
|
|
|
(DEFUN DISK-PASTING-CMPR (cmpr new)
|
|
(declare
|
|
(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)))))
|
|
(the cmprf #'rslt)))
|
|
|
|
|
|
(DEFUN DISK-PASTING-BASIS (basis dmns new)
|
|
(declare
|
|
(type basis basis)
|
|
(fixnum dmns)
|
|
(symbol new))
|
|
(flet ((rslt (degr)
|
|
(declare (fixnum degr))
|
|
(if (= degr dmns)
|
|
(cons new (funcall basis dmns))
|
|
(funcall basis degr))))
|
|
(the basis #'rslt)))
|
|
|
|
|
|
(DEFUN DISK-PASTING-INTR-DFFR (old-dffr degr new bndr)
|
|
(declare
|
|
(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))))
|
|
(declare (type cmprf cmpr))
|
|
(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)))))))
|
|
(the intr-mrph #'rslt))))
|
|
|
|
|
|
(DEFUN CHCM-DISK-PASTING (chcm dmns new bndr)
|
|
(declare
|
|
(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))))
|
|
|
|
|
|
(DEFUN DISK-PASTING-FACE (cmpr face dmns new faces)
|
|
(declare
|
|
(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)
|
|
(declare (list mark))
|
|
(unless (typep (car mark) 'absm)
|
|
(setf (car mark) (absm 0 (car mark)))))
|
|
faces)
|
|
(flet ((rslt (indx dmns2 gmsm)
|
|
(declare
|
|
(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))))
|
|
(unless (check-faces cmpr #'rslt dmns new)
|
|
(error "The new simplicial-set is not constructed."))
|
|
(the face #'rslt)))
|
|
|
|
|
|
(DEFUN DISK-PASTING (smst dmns new faces)
|
|
(declare
|
|
(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
|
|
(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))))))
|
|
|
|
|
|
(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))
|
|
(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)))))))
|
|
(the intr-mrph #'rslt))))
|
|
|
|
|
|
(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))
|
|
(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))))
|
|
|
|
|
|
(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))
|
|
(let* ((lg (lg hmeq))
|
|
(rf (rf hmeq))
|
|
(rh (rh hmeq))
|
|
(t-bndr (cmbn-? lg bndr))
|
|
(rb-bndr (cmbn-? rf t-bndr))
|
|
(new-lbcc (or new-lbcc
|
|
(chcm-disk-pasting (lbcc hmeq)
|
|
dmns new bndr)))
|
|
(new-tcc (chcm-disk-pasting (tcc hmeq)
|
|
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))
|
|
(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))))
|
|
|
|
|
|
(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))))
|