321 lines
8.1 KiB
Common Lisp
321 lines
8.1 KiB
Common Lisp
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
|
|
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
|
|
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
|
|
|
|
(IN-PACKAGE "COMMON-LISP-USER")
|
|
|
|
(PROVIDE "suspensions")
|
|
|
|
(DEFUN SUSPENSION-CMPR (cmpr)
|
|
(declare (type cmprf cmpr))
|
|
(flet ((rslt (gnrt1 gnrt2)
|
|
(declare (type gnrt gnrt1 gnrt2))
|
|
(if (eq gnrt1 :s-bsgn)
|
|
:equal
|
|
(funcall cmpr gnrt1 gnrt2))))
|
|
(the cmprf #'rslt)))
|
|
|
|
#|
|
|
(setf cc (deltab))
|
|
(setf cmpr (suspension-cmpr (cmpr cc)))
|
|
(funcall cmpr :s-bsgn :s-bsgn)
|
|
(funcall cmpr 6 5)
|
|
|#
|
|
|
|
(DEFUN SUSPENSION-BASIS (basis)
|
|
(declare (type basis basis))
|
|
(when (eq basis :locally-effective)
|
|
(return-from suspension-basis :locally-effective))
|
|
(flet ((rslt (degr)
|
|
(declare (fixnum degr))
|
|
(case degr
|
|
(0 (list :s-bsgn))
|
|
(1 +empty-list+)
|
|
(otherwise (funcall basis (1- degr))))))
|
|
(the basis #'rslt)))
|
|
|
|
#|
|
|
(setf cc (sphere 2))
|
|
(setf basis (suspension-basis (basis cc)))
|
|
(dotimes (i 6)
|
|
(print (funcall basis i)))
|
|
(suspension-basis :locally-effective)
|
|
|#
|
|
|
|
(DEFUN SUSPENSION-INTR-DFFR (dffr)
|
|
(declare (type morphism dffr))
|
|
(flet ((rslt (cmbn)
|
|
(declare (type cmbn cmbn))
|
|
(with-cmbn (degr list) cmbn
|
|
(decf degr)
|
|
(if (<= degr 0)
|
|
(zero-cmbn degr)
|
|
(make-cmbn :degr degr
|
|
:list (cmbn-list
|
|
(cmbn-? dffr
|
|
(make-cmbn :degr degr
|
|
:list list))))))))
|
|
(the intr-mrph #'rslt)))
|
|
|
|
#|
|
|
(setf cc (deltab))
|
|
(setf intr (suspension-intr-dffr (dffr cc)))
|
|
(funcall intr (cmbn 0 3 :s-bsgn))
|
|
(funcall intr (cmbn 3 66 7))
|
|
|#
|
|
|
|
(DEFUN SUSPENSION (obj &optional (n 1))
|
|
(declare (type (or chain-complex morphism reduction
|
|
homotopy-equivalence) obj)
|
|
(fixnum n))
|
|
(if (= n 0)
|
|
obj
|
|
(suspension-1 (suspension obj (1- n)))))
|
|
|
|
(DEFMETHOD SUSPENSION-1 ((chcm chain-complex))
|
|
(the chain-complex
|
|
(with-slots (cmpr basis dffr) chcm
|
|
(build-chcm
|
|
:cmpr (suspension-cmpr cmpr)
|
|
:basis (suspension-basis basis)
|
|
:bsgn :s-bsgn
|
|
:intr-dffr (suspension-intr-dffr dffr)
|
|
:strt :cmbn
|
|
:orgn `(suspension ,chcm)))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf cc (deltab))
|
|
(setf scc (suspension cc))
|
|
(cmpr scc 7 11)
|
|
(basis scc 3) ;; error
|
|
(bsgn scc)
|
|
(? scc 3 11)
|
|
(setf scc (suspension cc 2))
|
|
(? scc 4 11)
|
|
|#
|
|
|
|
(DEFUN SUSPENSION-INTR-CPRD (cmbn)
|
|
(declare (type cmbn cmbn))
|
|
(the cmbn
|
|
(with-cmbn (degr list) cmbn
|
|
(if (zerop degr)
|
|
(make-cmbn :degr 0
|
|
:list (if list
|
|
(list (term (-cffc list)
|
|
(tnpr 0 :s-bsgn
|
|
0 :s-bsgn)))
|
|
+empty-list+))
|
|
(make-cmbn :degr degr
|
|
:list (let ((list1 +empty-list+)
|
|
(list2 +empty-list+))
|
|
(declare (list list1 list2))
|
|
(mapc
|
|
#'(lambda (term)
|
|
(declare (type term term))
|
|
(with-term (cffc gnrt) term
|
|
(push (term cffc
|
|
(tnpr 0 :s-bsgn
|
|
degr gnrt))
|
|
list1)
|
|
(push (term cffc
|
|
(tnpr degr gnrt
|
|
0 :s-bsgn))
|
|
list2)))
|
|
list)
|
|
(nreconc list1 (nreverse list2))))))))
|
|
|
|
#|
|
|
(suspension-intr-cprd (cmbn 0))
|
|
(suspension-intr-cprd (cmbn 0 5 :s-bsgn))
|
|
(suspension-intr-cprd (cmbn 3 4 7 5 11))
|
|
|#
|
|
|
|
(DEFMETHOD SUSPENSION-1 ((clgb coalgebra))
|
|
(the coalgebra
|
|
(let ((irslt (call-next-method)))
|
|
(declare (type (or chain-complex coalgebra) irslt))
|
|
(when (typep irslt 'coalgebra)
|
|
(return-from suspension-1 irslt))
|
|
(change-chcm-to-clgb irslt :intr-cprd #'suspension-intr-cprd
|
|
:cprd-strt :cmbn)
|
|
(setf (slot-value irslt 'orgn) `(suspension ,clgb))
|
|
(setf (slot-value (slot-value irslt 'cprd) 'orgn)
|
|
`(coproduct ,irslt))
|
|
irslt)))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf coal (deltab))
|
|
(setf scoal (suspension coal))
|
|
(setf scoal (suspension coal))
|
|
(? scoal 3 7)
|
|
(cprd scoal 3 7)
|
|
|#
|
|
|
|
(DEFUN SUSPENSION-FACE (face)
|
|
(declare (type face face))
|
|
(flet ((rslt (indx dmns gmsm)
|
|
(declare
|
|
(fixnum indx dmns)
|
|
(type gmsm gmsm))
|
|
(assert (> dmns 1))
|
|
(if (= indx dmns)
|
|
(absm (mask (1- dmns)) :s-bsgn)
|
|
(let ((irslt (funcall face indx (1- dmns) gmsm)))
|
|
(declare (type absm irslt))
|
|
(if (= (dgop irslt) (mask (- dmns 2)))
|
|
(absm (mask (1- dmns)) :s-bsgn)
|
|
irslt)))))
|
|
(the face #'rslt)))
|
|
|
|
#|
|
|
(setf ss (deltab))
|
|
(setf face (suspension-face (face ss)))
|
|
(funcall face 4 4 15)
|
|
(funcall face 0 4 15)
|
|
(check-faces #'f-cmpr face 4 15)
|
|
(check-faces #'f-cmpr face 3 7)
|
|
(check-faces #'f-cmpr face 2 3)
|
|
(setf m (moore 2 3))
|
|
(setf face (suspension-face (face m)))
|
|
(dotimes (i 5) (print (funcall face i 4 'm3)))
|
|
(dotimes (i 6) (print (funcall face i 5 'mm4)))
|
|
(check-faces #'s-cmpr face 4 'm3)
|
|
(check-faces #'s-cmpr face 5 'mm4)
|
|
|#
|
|
|
|
(DEFMETHOD SUSPENSION-1 ((smst simplicial-set))
|
|
(the simplicial-set
|
|
(let ((irslt (call-next-method)))
|
|
(declare (type coalgebra irslt))
|
|
(when (typep irslt 'simplicial-set)
|
|
(return-from suspension-1 irslt))
|
|
(change-class irslt 'simplicial-set)
|
|
(setf (slot-value irslt 'face)
|
|
(suspension-face (face smst)))
|
|
(setf (slot-value (slot-value irslt 'cprd) 'orgn)
|
|
`(diagonal ,irslt))
|
|
irslt)))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf d (deltab))
|
|
(setf sd (suspension d))
|
|
(setf sd (suspension d))
|
|
(inspect sd)
|
|
(? sd 3 7)
|
|
(cprd sd 3 7)
|
|
(face sd 3 3 7)
|
|
(face sd 2 3 7)
|
|
(setf m (moore 2 1))
|
|
(setf sm (suspension m))
|
|
(homology sm 0 5)
|
|
(setf ssm (suspension sm))
|
|
(homology ssm 0 6)
|
|
|#
|
|
|
|
(DEFUN SUSPENSION-INTR (mrph)
|
|
(declare (type morphism mrph))
|
|
(let ((mdegr (degr mrph)))
|
|
(declare (fixnum mdegr))
|
|
(flet ((rslt (cmbn)
|
|
(declare (type cmbn cmbn))
|
|
(with-cmbn (cdegr list) cmbn
|
|
(when (zerop cdegr)
|
|
(return-from rslt
|
|
(if (zerop mdegr)
|
|
cmbn
|
|
(zero-cmbn (+ mdegr cdegr)))))
|
|
(make-cmbn :degr (+ mdegr cdegr)
|
|
:list (cmbn-list
|
|
(cmbn-? mrph (make-cmbn :degr (1- cdegr)
|
|
:list list)))))))
|
|
(the intr-mrph #'rslt))))
|
|
|
|
#|
|
|
(setf f (idnt-mrph (deltab)))
|
|
(setf sf (suspension-intr f))
|
|
(funcall sf (cmbn 0 3 :s-bsgn))
|
|
(funcall sf (cmbn 2 4 3))
|
|
(setf d (dffr (deltab)))
|
|
(setf sd (suspension-intr d))
|
|
(funcall sd (cmbn 0 3 :s-bsgn))
|
|
(funcall sd (cmbn 2 4 3))
|
|
(funcall sd (cmbn 3 4 7))
|
|
|#
|
|
|
|
(DEFMETHOD SUSPENSION-1 ((mrph morphism))
|
|
(the morphism
|
|
(let ((orgn (orgn mrph)))
|
|
(declare (list orgn))
|
|
(when (eq (first orgn) 'zero-mrph)
|
|
(return-from suspension-1
|
|
(zero-mrph (suspension (sorc mrph))
|
|
(suspension (trgt mrph))
|
|
(degr mrph))))
|
|
(when (eq (first orgn) 'idnt-mrph)
|
|
(return-from suspension-1
|
|
(idnt-mrph (suspension (sorc mrph)))))
|
|
(build-mrph
|
|
:sorc (suspension (sorc mrph))
|
|
:trgt (suspension (trgt mrph))
|
|
:degr (degr mrph)
|
|
:intr (suspension-intr mrph)
|
|
:strt :cmbn
|
|
:orgn `(suspension ,mrph)))))
|
|
|
|
#|
|
|
(setf f (idnt-mrph (deltab)))
|
|
(setf sf (suspension f))
|
|
(? sf (cmbn 0 3 :s-bsgn))
|
|
(? sf (cmbn 2 4 3))
|
|
(setf d (dffr (deltab)))
|
|
(setf sd (suspension d))
|
|
(? sd (cmbn 0 3 :s-bsgn))
|
|
(? sd (cmbn 2 4 3))
|
|
(? sd (cmbn 3 4 7))
|
|
|#
|
|
|
|
(DEFMETHOD SUSPENSION-1 ((rdct reduction))
|
|
(the reduction (progn
|
|
(when (eq (first (orgn rdct)) 'trivial-rdct)
|
|
(return-from suspension-1
|
|
(trivial-rdct (suspension (second (orgn rdct))))))
|
|
(build-rdct
|
|
:f (suspension (f rdct))
|
|
:g (suspension (g rdct))
|
|
:h (suspension (h rdct))
|
|
:orgn `(suspension ,rdct)))))
|
|
|
|
#|
|
|
(setf rdct (ez (deltab) (deltab)))
|
|
(setf srdct (suspension rdct))
|
|
(pre-check-rdct srdct)
|
|
(setf *tc* (cmbn 4 1 (crpr 0 15 0 15)))
|
|
(setf *bc* (cmbn 4 1 (tnpr 0 1 3 15)
|
|
5 (tnpr 1 3 2 7)
|
|
10 (tnpr 2 7 1 3)
|
|
100 (tnpr 3 15 0 1)))
|
|
(check-rdct)
|
|
|#
|
|
|
|
(DEFMETHOD SUSPENSION-1 ((hmeq homotopy-equivalence))
|
|
(the homotopy-equivalence (progn
|
|
(when (eq (first (orgn hmeq)) 'trivial-hmeq)
|
|
(return-from suspension-1
|
|
(trivial-hmeq (suspension (second (orgn hmeq))))))
|
|
(build-hmeq
|
|
:lrdct (suspension (lrdct hmeq))
|
|
:rrdct (suspension (rrdct hmeq))
|
|
:orgn `(suspension ,hmeq)))))
|
|
|
|
(DEFMETHOD SEARCH-EFHM (suspension (orgn (eql 'suspension)))
|
|
(declare (type chain-complex suspension))
|
|
(suspension (efhm (second (orgn suspension)))))
|
|
|
|
#|
|
|
(setf sk (suspension (k-z 2)))
|
|
(homology sk 0 10)
|
|
|#
|
|
|