688 lines
22 KiB
Common Lisp
688 lines
22 KiB
Common Lisp
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
|
|
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
|
|
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
|
|
|
|
(IN-PACKAGE "COMMON-LISP-USER")
|
|
|
|
(PROVIDE "special-smsts")
|
|
|
|
;;; GMSM-FACES-INFO = (gmsm (simple-vector absm) . bndr)
|
|
;;; faces
|
|
|
|
(DEFUN FINITE-SS-PRE-TABLE (list)
|
|
(declare (list list))
|
|
(the list
|
|
(let ((pre-rslt +empty-list+)
|
|
(dmns-mark nil)
|
|
(gmsm-mark nil))
|
|
(declare (list pre-rslt dmns-mark gmsm-mark))
|
|
(dolist (item list)
|
|
(declare (type (or fixnum symbol list) item))
|
|
(cond ((typep item 'fixnum)
|
|
(let ((found (assoc item pre-rslt)))
|
|
(declare (list found))
|
|
(setf dmns-mark
|
|
(or found
|
|
(car (push (list item) pre-rslt)))
|
|
gmsm-mark nil)))
|
|
((symbolp item)
|
|
(when (assoc item (cdr dmns-mark))
|
|
(error "In BUILD-FINITE-SS, the symbol ~A is present two times."
|
|
item))
|
|
(setf gmsm-mark (car (push (list item) (cdr dmns-mark)))))
|
|
((listp item)
|
|
(unless gmsm-mark
|
|
(error "In BUILD-FINITE-SS, the face list ~A~@
|
|
is not after a symbol." item))
|
|
(nconc gmsm-mark item)
|
|
(setf gmsm-mark nil))
|
|
(t
|
|
(error "In BUILD-FINITE-SS, the argument ~A does not make sense." item))))
|
|
(do ((mark1 pre-rslt (cdr mark1)))
|
|
((endp mark1))
|
|
(declare (list mark1))
|
|
(do ((mark2 (rest mark1) (cdr mark2)))
|
|
((endp mark2))
|
|
(declare (list mark2))
|
|
(let ((inter (intersection (cdar mark1) (cdar mark2) :key #'first)))
|
|
(declare (list inter))
|
|
(when inter
|
|
(error "In BUILD-FINITE-SS, the symbol ~A is present two times."
|
|
(caar inter))))))
|
|
pre-rslt)))
|
|
|
|
#|
|
|
(setf p (finite-ss-pre-table '(0 v0 v1 v2)))
|
|
(finite-ss-pre-table '(0 v0 v0 v2))
|
|
(setf p (finite-ss-pre-table '(0 v0 v1 1 e0 e1 e2)))
|
|
(finite-ss-pre-table '(0 v0 v1 1 e0 e1 v1))
|
|
(setf p (finite-ss-pre-table '(0 v0 (v0 v0))))
|
|
(setf p (finite-ss-pre-table '(0 v0 v1 v2 0 v3)))
|
|
(finite-ss-pre-table '(0 v0 (v0 v0) (v1 v1)))
|
|
(finite-ss-pre-table '(0 (v0 v0) (v1 v1)))
|
|
(finite-ss-pre-table '(0 v0 (v0 v0) #(1 2))))
|
|
|#
|
|
|
|
(DEFUN FINITE-SS-PRE-TABLE-TABLE (pre-table)
|
|
(declare (list pre-table))
|
|
(let* ((maxdim (1+ (apply #'max (mapcar #'first pre-table))))
|
|
(table (make-array maxdim :initial-element +empty-list+)))
|
|
(declare
|
|
(fixnum maxdim)
|
|
(simple-vector table))
|
|
(dolist (item pre-table)
|
|
(declare (list item))
|
|
(setf (svref table (first item))
|
|
(sort (rest item) #'string< :key #'first)))
|
|
table))
|
|
|
|
#|
|
|
(setf p (finite-ss-pre-table-table
|
|
(finite-ss-pre-table '(2 v0 (e1 e2) v1 1 e0 e1 e2)))))
|
|
|#
|
|
|
|
(DEFUN FINITE-SS-FIND-GMSM (table gmsm dmns &optional (max-dmns (1+ dmns)))
|
|
(declare
|
|
(type gmsm gmsm)
|
|
(fixnum dmns max-dmns))
|
|
(do ((dmns dmns (1+ dmns)))
|
|
((>= dmns max-dmns) nil)
|
|
(declare (fixnum dmns))
|
|
(let ((found (find gmsm (svref table dmns) :test #'eq :key #'car)))
|
|
(declare (type (or cons null) found))
|
|
(when found
|
|
(return-from finite-ss-find-gmsm dmns)))))
|
|
|
|
(DEFUN FINITE-SS-FINISH-TABLE (table bspn)
|
|
(declare (simple-vector table))
|
|
(dotimes (dmns (length table))
|
|
(declare (fixnum dmns))
|
|
(finite-ss-finish-line table dmns bspn))
|
|
table)
|
|
|
|
(DEFUN FINITE-SS-FINISH-LINE (table dmns bspn)
|
|
(declare
|
|
(simple-vector table)
|
|
(fixnum dmns))
|
|
(setf (svref table dmns)
|
|
(mapcar
|
|
#'(lambda (entry)
|
|
(finite-ss-finish-entry table entry dmns bspn))
|
|
(svref table dmns))))
|
|
|
|
(DEFUN FINITE-SS-FINISH-ENTRY (table entry dmns bspn)
|
|
(declare
|
|
(simple-vector table)
|
|
(list entry)
|
|
(fixnum dmns)
|
|
(symbol bspn))
|
|
(let ((simplex (first entry))
|
|
(faces (rest entry)))
|
|
(declare
|
|
(symbol simplex)
|
|
(list faces))
|
|
(when (zerop dmns)
|
|
(return-from finite-ss-finish-entry
|
|
(make-gmsm-faces-info
|
|
:gmsm simplex :faces +s-empty-vector+
|
|
:bndr +zero-negative-cmbn+)))
|
|
(setf faces (nconc faces (make-list (1+ (- dmns (length faces)))
|
|
:initial-element bspn)))
|
|
(let ((rslt (make-gmsm-faces-info :gmsm simplex)))
|
|
(declare (cons rslt))
|
|
(flet ((process-face (face)
|
|
(declare (type (or symbol list) face))
|
|
(when (symbolp face)
|
|
(setf face (list face)))
|
|
(let* ((gmsm2 (car (last face)))
|
|
(dgop-ext (nbutlast face))
|
|
(dmns2 (finite-ss-find-gmsm table gmsm2 0 dmns)))
|
|
(declare
|
|
(symbol gmsm2)
|
|
(list dgop-ext)
|
|
(type (or fixnum null) dmns2))
|
|
(unless dmns2
|
|
(error "In BUILD-FINITE-SS, the face ~A is absent." gmsm2))
|
|
(when (zerop (length dgop-ext))
|
|
(setf dgop-ext (nreverse (<a-b< dmns2 (1- dmns)))))
|
|
(unless (= (+ (length dgop-ext) dmns2 1) dmns)
|
|
(error "In BUILD-FINITE-SS, the face ~A has a wrong dimension."
|
|
(append dgop-ext (list gmsm2))))
|
|
(absm (dgop-ext-int dgop-ext) gmsm2))))
|
|
(setf (info-faces rslt)
|
|
(map 'simple-vector #'process-face faces))
|
|
(setf (info-bndr rslt)
|
|
(apply #'nterm-add #'s-cmpr (1- dmns)
|
|
(do ((rslt +empty-list+)
|
|
(faces (info-faces rslt))
|
|
(indx dmns (1- indx)))
|
|
((minusp indx) rslt)
|
|
(declare
|
|
(list rslt)
|
|
(simple-vector faces)
|
|
(fixnum indx))
|
|
(let ((face (svref faces indx)))
|
|
(declare (type absm face))
|
|
(unless (degenerate-p face)
|
|
(push (term (-1-expt-n indx) (gmsm face))
|
|
rslt))))))
|
|
rslt))))
|
|
|
|
(DEFUN FINITE-SS-TABLE (list)
|
|
(declare (list list))
|
|
(setf list (cons 0 list))
|
|
(let* ((bspn (second list))
|
|
(pre-table (finite-ss-pre-table list))
|
|
(table (finite-ss-pre-table-table pre-table)))
|
|
(declare
|
|
(symbol bspn)
|
|
(list pre-table)
|
|
(simple-vector table))
|
|
;; (vector (vector gmsm-faces-info))
|
|
(finite-ss-finish-table table bspn)))
|
|
|
|
#|
|
|
(finite-ss-table '(*))
|
|
(finite-ss-table '(a b))
|
|
(finite-ss-table '(a b 1 c (b a)))
|
|
(finite-ss-table '(* 2 s2 3 s3))
|
|
(finite-ss-table '(s0 s1 s2 1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1) 2 s012 (s12 s02 s01)))
|
|
(finite-ss-table '(* 4 s4 ((2 1 0 *))))
|
|
(finite-ss-table '(* 4 s4 ((1 1 0 *))))
|
|
(finite-ss-table '(* 1 s (t)))
|
|
(finite-ss-table '(* 4 s4 ((1 0 *)))))
|
|
|#
|
|
|
|
(DEFUN FINITE-SS-BASIS (table)
|
|
(declare (simple-vector table))
|
|
(flet ((rslt (dmns)
|
|
(declare (fixnum dmns))
|
|
(the list
|
|
(if (< -1 dmns (length table))
|
|
(mapcar #'car (svref table dmns))
|
|
+empty-list+))))
|
|
#'rslt))
|
|
|
|
(DEFUN FINITE-SS-FACE (ind-smst table)
|
|
(declare
|
|
(symbol ind-smst)
|
|
(simple-vector table))
|
|
(flet ((rslt (indx dmns gmsm)
|
|
(declare
|
|
(fixnum indx dmns)
|
|
(symbol gmsm))
|
|
(let ((found (find gmsm (svref table dmns) :key #'car)))
|
|
(unless found
|
|
(error "In the finite simplicial set ~A,~@
|
|
the simplex ~A is absent in dimension ~D." (eval ind-smst) gmsm dmns))
|
|
(svref (info-faces found) indx))))
|
|
#'rslt))
|
|
|
|
(DEFUN FINITE-SS-INTR-BNDR (ind-smst table)
|
|
(declare
|
|
(symbol ind-smst)
|
|
(simple-vector table))
|
|
(flet ((rslt (dmns gmsm)
|
|
(declare
|
|
(fixnum dmns)
|
|
(symbol gmsm))
|
|
(let ((found (find gmsm (svref table dmns) :key #'car)))
|
|
(unless found
|
|
(error "In the finite simplicial set ~A,~@
|
|
the simplex ~A is absent in dimension ~D." (eval ind-smst) gmsm dmns))
|
|
(info-bndr found))))
|
|
#'rslt))
|
|
|
|
(DEFUN BUILD-FINITE-SS (list)
|
|
(declare (list list))
|
|
(let ((bspn (first list))
|
|
(table (finite-ss-table list))
|
|
(ind-smst (gensym)))
|
|
(declare
|
|
(symbol bspn ind-smst)
|
|
(simple-vector table))
|
|
;; (vector (vector gmsm-faces-info))
|
|
(let ((rslt (build-smst
|
|
:cmpr #'s-cmpr
|
|
:basis (finite-ss-basis table)
|
|
:bspn bspn
|
|
:face (finite-ss-face ind-smst table)
|
|
:intr-bndr (finite-ss-intr-bndr ind-smst table)
|
|
:bndr-strt :gnrt
|
|
:orgn `(build-finite-ss ,list))))
|
|
(setf (symbol-value ind-smst) rslt)
|
|
(unless (check-smst rslt 0 (length table))
|
|
(pop *smst-list*)
|
|
(pop *chcm-list*)
|
|
(pop *mrph-list*)
|
|
(return-from build-finite-ss nil))
|
|
rslt)))
|
|
|
|
#|
|
|
()
|
|
(cat-init)
|
|
(setf tr (build-finite-ss '(s0 s1 s2
|
|
1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
|
|
2 s012 (s12 s02 s01))))
|
|
(cmpr tr 's01 's02)
|
|
(basis tr 2)
|
|
(bspn tr)
|
|
(face tr 1 2 's012)
|
|
(? tr 2 's012)
|
|
(? tr *)
|
|
(inspect tr)
|
|
(mapcar #'(lambda (s) (length (eval s))) *list-list*)
|
|
(setf tr (build-finite-ss '(s0 s1 s2
|
|
1 s01 (s1 s1) s02 (s2 s0) s12 (s2 s1)
|
|
2 s012 (s12 s02 s01))))
|
|
(mapcar #'(lambda (s) (length (eval s))) *list-list*))
|
|
|#
|
|
|
|
(DEFUN SPHERE-CMPR (gmsm1 gmsm2)
|
|
(declare (ignore gmsm1 gmsm2))
|
|
(the cmpr :equal))
|
|
|
|
(DEFUN SPHERE-BASIS (dmns)
|
|
(declare (fixnum dmns))
|
|
(let ((fund-gmsm (intern (format nil "S~D" dmns))))
|
|
(declare (symbol fund-gmsm))
|
|
(flet ((rslt (dmns2)
|
|
(declare (fixnum dmns2))
|
|
(cond ((zerop dmns2)
|
|
(list '*))
|
|
((= dmns2 dmns)
|
|
(list fund-gmsm))
|
|
(t
|
|
+empty-list+))))
|
|
(the basis #'rslt))))
|
|
|
|
(DEFUN SPHERE-FACE (dmns)
|
|
(declare (fixnum dmns))
|
|
(let ((face (absm (mask (1- dmns)) '*)))
|
|
(declare (type absm face))
|
|
(flet ((rslt (indx dmns2 gmsm)
|
|
(declare (ignore indx dmns2 gmsm))
|
|
(the absm face)))
|
|
#'rslt)))
|
|
|
|
(DEFUN SPHERE (dmns)
|
|
(declare (fixnum dmns))
|
|
(unless (plusp dmns)
|
|
(error "In SPHERE, the dimension ~D should be positive." dmns))
|
|
(unless (< dmns +maximal-dimension+)
|
|
(error "In SPHERE, the dimension ~D should be < ~D."
|
|
dmns +maximal-dimension+))
|
|
(the simplicial-set
|
|
(let ((rslt (build-smst
|
|
:cmpr #'sphere-cmpr
|
|
:basis (sphere-basis dmns)
|
|
:bspn '*
|
|
:face (sphere-face dmns)
|
|
:intr-bndr #'zero-intr-dffr
|
|
:bndr-strt :cmbn
|
|
:orgn `(sphere ,dmns))))
|
|
(declare (type simplicial-set rslt))
|
|
(setf (slot-value (bndr rslt) 'orgn)
|
|
`(zero-mrph ,rslt ,rslt -1))
|
|
rslt)))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf s3 (sphere 3))
|
|
(funcall (cmpr s3) 's3 's3)
|
|
(dotimes (i 5)
|
|
(print (funcall (basis s3) i)))
|
|
(mapcar #'(lambda (i) (funcall (face s3) i 3 's3)) (<a-b> 0 3))
|
|
(? s3 3 's3)
|
|
(smst (idnm s3))
|
|
(chcm (idnm s3))
|
|
(setf d (bndr s3))
|
|
(add d d))
|
|
|#
|
|
|
|
(DEFUN SPHERE-WEDGE-BASIS (dmns-list)
|
|
(declare (list dmns-list))
|
|
(flet ((rslt (dmns)
|
|
(declare (fixnum dmns))
|
|
(when (zerop dmns)
|
|
(return-from rslt '(*)))
|
|
(do ((i (count dmns dmns-list) (1- i))
|
|
(basis +empty-list+
|
|
(cons (intern (format nil "S~D-~D" dmns i))
|
|
basis)))
|
|
((zerop i) basis)
|
|
(declare
|
|
(fixnum i)
|
|
(list basis)))))
|
|
(the basis #'rslt)))
|
|
|
|
(DEFUN SPHERE-WEDGE-FACE (indx dmns gmsm)
|
|
(declare
|
|
(ignore indx gmsm)
|
|
(fixnum dmns))
|
|
(the absm
|
|
(absm (mask (1- dmns)) '*)))
|
|
|
|
(DEFUN SPHERE-WEDGE (&rest dmns-list)
|
|
(declare (list dmns-list))
|
|
(the simplicial-set
|
|
(let ((rslt (build-smst
|
|
:cmpr #'s-cmpr
|
|
:basis (sphere-wedge-basis dmns-list)
|
|
:face #'sphere-wedge-face
|
|
:intr-bndr #'zero-intr-dffr
|
|
:bndr-strt :cmbn
|
|
:orgn `(sphere-wedge ,@dmns-list))))
|
|
(declare (type simplicial-set rslt))
|
|
(setf (slot-value (bndr rslt) 'orgn)
|
|
`(zero-mrph ,rslt ,rslt -1))
|
|
rslt)))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf w (sphere-wedge 3 2 3))
|
|
(funcall (cmpr w) 's3-1 's3-2)
|
|
(dotimes (i 5) (print (funcall (basis w) i)))
|
|
(funcall (face w) 2 3 's3-1)
|
|
(gnrt-? (bndr w) 3 's3-2))
|
|
|#
|
|
|
|
(DEFUN MOORE-CMPR (gmsm1 gmsm2)
|
|
(declare (ignore gmsm1 gmsm2))
|
|
(the cmpr :equal))
|
|
|
|
(DEFUN MOORE-BASIS (dmns)
|
|
(declare (fixnum dmns))
|
|
(let ((lgmsm1 (list (intern (format nil "M~D" dmns))))
|
|
(lgmsm2 (list (intern (format nil "N~D" (1+ dmns))))))
|
|
(declare (list lgmsm1 lgmsm2))
|
|
(flet ((rslt (dmns2)
|
|
(declare (fixnum dmns2))
|
|
(cond ((zerop dmns2) '(*))
|
|
((= dmns dmns2) lgmsm1)
|
|
((= (1+ dmns) dmns2) lgmsm2)
|
|
(t +empty-list+))))
|
|
(the basis #'rslt))))
|
|
|
|
(DEFUN MOORE-FACE (pii dmns)
|
|
(declare (fixnum pii dmns))
|
|
(let ((face (absm 0 (intern (format nil "M~D" dmns))))
|
|
(bspn1 (absm (mask (1- dmns)) '*))
|
|
(bspn2 (absm (mask dmns) '*))
|
|
(2pii (ash pii 1)))
|
|
(declare
|
|
(type absm face)
|
|
(type absm bspn1 bspn2)
|
|
(fixnum 2pii))
|
|
(flet ((rslt (indx dmns2 gmsm)
|
|
(declare
|
|
(fixnum indx dmns2)
|
|
(ignore gmsm))
|
|
(the absm
|
|
(if (= dmns dmns2)
|
|
bspn1
|
|
(if (oddp indx)
|
|
bspn2
|
|
(if (< indx 2pii)
|
|
face
|
|
bspn2))))))
|
|
(the face #'rslt))))
|
|
|
|
(DEFUN MOORE-INTR-BNDR (pii dmns)
|
|
(declare (fixnum pii dmns))
|
|
(let ((1+dmns (1+ dmns))
|
|
(gmsm1 (intern (format nil "M~D" dmns))))
|
|
(declare
|
|
(fixnum 1+dmns)
|
|
(type symbol gmsm1))
|
|
(flet ((rslt (cmbn)
|
|
(declare
|
|
(type cmbn cmbn))
|
|
(with-cmbn (degr list) cmbn
|
|
(unless list
|
|
(return-from rslt (zero-cmbn (1- (cmbn-degr cmbn)))))
|
|
(if (= degr 1+dmns)
|
|
(term-cmbn dmns (* (cffc (first list)) pii) gmsm1)
|
|
(zero-cmbn (1- (cmbn-degr cmbn)))))))
|
|
(the intr-mrph #'rslt))))
|
|
|
|
(DEFUN MOORE (pii dmns)
|
|
(declare (fixnum pii dmns))
|
|
(the simplicial-set
|
|
(build-smst
|
|
:cmpr #'moore-cmpr
|
|
:basis (moore-basis dmns)
|
|
:face (moore-face pii dmns)
|
|
:intr-bndr (moore-intr-bndr pii dmns)
|
|
:bndr-strt :cmbn
|
|
:orgn `(moore ,pii ,dmns))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf m4 (moore 2 4))
|
|
(cmpr m4 'n5 'n5)
|
|
(dotimes (i 7)
|
|
(print (basis m4 i)))
|
|
(mapcar #'(lambda (i) (face m4 i 5 'n5)) (<a-b> 0 5))
|
|
(? m4 4 'm4)
|
|
(? m4 5 'n5))
|
|
|#
|
|
|
|
(DEFUN R-PROJ-SPACE-CMPR (gmsm1 gmsm2)
|
|
(declare (ignore gmsm1 gmsm2))
|
|
(the cmpr :equal))
|
|
|
|
(DEFUN R-PROJ-SPACE-BASIS (k l)
|
|
(declare (fixnum k) (type (or (eql :infinity) fixnum) l))
|
|
(the basis
|
|
(progn
|
|
(when (eq l :infinity)
|
|
(setf l most-positive-fixnum))
|
|
(flet
|
|
((rslt (dmns)
|
|
(declare (fixnum dmns))
|
|
(the list
|
|
(if (or (minusp dmns)
|
|
(< 0 dmns k)
|
|
(>= dmns l))
|
|
+empty-list+
|
|
(list dmns)))))
|
|
(the basis #'rslt)))))
|
|
|
|
#|
|
|
()
|
|
(setf b (r-proj-space-basis 1 :infinity))
|
|
(dotimes (i 5) (print (funcall b i)))
|
|
(setf b (r-proj-space-basis 1 5))
|
|
(dotimes (i 8) (print (funcall b i)))
|
|
(setf b (r-proj-space-basis 3 :infinity))
|
|
(dotimes (i 5) (print (funcall b i)))
|
|
(setf b (r-proj-space-basis 3 6))
|
|
(dotimes (i 10) (print (funcall b i)))
|
|
|#
|
|
|
|
(DEFUN R-PROJ-SPACE-FACE (k)
|
|
(declare (fixnum k))
|
|
(flet ((rslt (indx dmns gmsm)
|
|
(declare
|
|
(fixnum indx dmns)
|
|
(ignore gmsm))
|
|
(if (<= dmns k)
|
|
(absm (mask (1- dmns)) 0)
|
|
(if (or (zerop indx)
|
|
(= indx dmns))
|
|
(absm 0 (1- dmns))
|
|
(if (= dmns (1+ k))
|
|
(absm (mask (1- dmns)) 0)
|
|
(absm (2-exp (1- indx)) (- dmns 2)))))))
|
|
(the face #'rslt)))
|
|
|
|
(DEFUN R-PROJ-SPACE-INTR-BNDR (k)
|
|
(declare (fixnum k))
|
|
(flet ((rslt (cmbn)
|
|
(declare (type cmbn cmbn))
|
|
(with-cmbn (degr list) cmbn
|
|
(unless list
|
|
(return-from rslt (zero-cmbn (1- degr))))
|
|
(if (<= degr k)
|
|
(zero-cmbn (1- degr))
|
|
(if (evenp degr)
|
|
(make-cmbn
|
|
:degr (1- degr)
|
|
:list (list (term (* 2 (-cffc list)) (1- degr))))
|
|
(zero-cmbn (1- degr)))))))
|
|
(the intr-mrph #'rslt)))
|
|
|
|
(DEFUN R-PROJ-SPACE (&optional (l :infinity) (k 1))
|
|
(declare (fixnum k) (type (or fixnum (eql :infinity))))
|
|
(assert
|
|
(and (typep k 'fixnum)
|
|
(plusp k)
|
|
(or (eq l :infinity)
|
|
(and (typep l 'fixnum)
|
|
(<= k l)))))
|
|
(the simplicial-set
|
|
(build-smst
|
|
:cmpr #'R-proj-space-cmpr
|
|
:basis (R-proj-space-basis k l)
|
|
:bspn 0
|
|
:face (R-proj-space-face k)
|
|
:intr-bndr (R-proj-space-intr-bndr k)
|
|
:bndr-strt :cmbn
|
|
:orgn `(R-proj-space ,k ,l))))
|
|
|
|
#|
|
|
()
|
|
(cat-init)
|
|
(setf p (R-proj-space))
|
|
(basis p 4)
|
|
(dotimes (i 5)
|
|
(print (face p i 4 4)))
|
|
(dotimes (i 5)
|
|
(print (? p i i)))
|
|
(setf dd (cmps p p))
|
|
(dotimes (i 6)
|
|
(print (? dd i i)))
|
|
(setf p (R-proj-space 3))
|
|
(dotimes (i 7)
|
|
(print (basis p i)))
|
|
(dotimes (i 5)
|
|
(print (face p i 4 4)))
|
|
(dotimes (i 7)
|
|
(print (? p i i)))
|
|
(setf dd (cmps p p))
|
|
(dotimes (i 7)
|
|
(print (? dd i i)))
|
|
|#
|
|
|
|
;;; Constructing a small simplicial subset
|
|
;;; from a combination of simplices.
|
|
|
|
(DEFUN CMBN-GMSMS (cmbn)
|
|
(declare (type cmbn cmbn))
|
|
(the list
|
|
;; Returns a list made of:
|
|
;; the degree of the combination;
|
|
;; the list of simplex generators of the combinations.
|
|
(cons (cmbn-degr cmbn) (mapcar #'cdr (cmbn-list cmbn)))))
|
|
|
|
#|
|
|
()
|
|
|#
|
|
|
|
(DEFUN GMSMS-SUBSMST (smst gmsms
|
|
&aux
|
|
(dmns (typecase gmsms
|
|
(cmbn (cmbn-degr gmsms))
|
|
(otherwise (first gmsms))))
|
|
(cmpr= #'(lambda (gmsm1 gmsm2)
|
|
(declare (type gmsm gmsm1 gmsm2))
|
|
(the boolean
|
|
(eq (cmpr smst gmsm1 gmsm2) :equal)))))
|
|
(declare
|
|
(type simplicial-set smst)
|
|
(type (or cmbn list) gmsms)
|
|
(fixnum dmns)
|
|
(type (function (gmsm gmsm) boolean) cmpr=))
|
|
(when (typep gmsms 'cmbn)
|
|
(setf gmsms (cmbn-gmsms gmsms)))
|
|
(the (values simplicial-set morphism)
|
|
(let ((prslt (make-array (1+ dmns) :initial-element +empty-list+)))
|
|
(declare (type simple-vector prslt))
|
|
(setf (svref prslt dmns) (rest gmsms))
|
|
(do ((d dmns (1- d)))
|
|
((zerop d))
|
|
(declare (fixnum d))
|
|
(dolist (gmsm (svref prslt d))
|
|
(declare (type gmsm gmsm))
|
|
(dotimes (iface (1+ d))
|
|
(declare (fixnum iface))
|
|
(with-absm (dgop gmsm) (face smst iface d gmsm)
|
|
(declare (fixnum dgop) (type gmsm gmsm))
|
|
(pushnew gmsm (svref prslt (- d 1 (logcount dgop)))
|
|
:test cmpr=)))))
|
|
(let ((rslt-basis #'(lambda (k)
|
|
(declare (fixnum dmns))
|
|
(the list
|
|
(if (<= 0 k dmns)
|
|
(aref prslt k)
|
|
+empty-list+)))))
|
|
(declare (type (function (fixnum) list) rslt-basis))
|
|
(let ((subsmst (build-smst
|
|
:cmpr (cmpr smst)
|
|
:basis rslt-basis
|
|
:bspn (let ((bspn (bspn smst)))
|
|
(declare (type gmsm bspn))
|
|
(pushnew bspn (svref prslt 0) :test cmpr=)
|
|
bspn)
|
|
:face (face smst)
|
|
:orgn `(gmsms-subsmst ,gmsms))))
|
|
(declare (type simplicial-set subsmst))
|
|
(values subsmst
|
|
(build-mrph :sorc subsmst
|
|
:trgt smst
|
|
:degr 0
|
|
:intr #'(lambda (cmbn)
|
|
(declare (type cmbn cmbn))
|
|
(the cmbn cmbn))
|
|
:strt :cmbn
|
|
:orgn `(gmsms-subsmst-incl ,gmsms))))))))
|
|
|
|
|
|
|
|
#|
|
|
()
|
|
(cat-init)
|
|
(setf k (k-z 2))
|
|
(setf efhm (efhm k))
|
|
(setf *homology-verbose* nil)
|
|
(chcm-homology-gen (rbcc efhm) 4)
|
|
(setf g (first *))
|
|
(setf cmbn (lf efhm (rg efhm g)))
|
|
(multiple-value-setq (kf incl) (gmsms-subsmst k cmbn))
|
|
(setf cone (cone incl))
|
|
(efhm cone)
|
|
(homology kf 0 5)
|
|
(homology (cone incl) 0 6)
|
|
|
|
(chcm-homology-gen (rbcc efhm) 8)
|
|
(setf g (first *))
|
|
(setf cmbn (lf efhm (rg efhm g)))
|
|
(multiple-value-setq (kf incl) (gmsms-subsmst k cmbn))
|
|
(setf cone (cone incl))
|
|
(efhm cone)
|
|
(homology kf 0 9)
|
|
(homology (cone incl) 0 10)
|
|
(dotimes (i 9) (print (length (basis kf i))))
|
|
|
|
()
|
|
(setf s2 (sphere 2))
|
|
(setf cl2 (chml-clss s2 2))
|
|
(setf f2 (z-whitehead s2 cl2))
|
|
(setf s3 (fibration-total f2))
|
|
(setf efhm (efhm s3))
|
|
(basis (rbcc efhm) 3)
|
|
(setf cmbn (lf efhm (rg efhm 3 (first (basis (rbcc efhm) 3)))))
|
|
(setf kf (gmsms-subsmst s3 cmbn))
|
|
(homology kf 0 4)
|
|
|# |