553 lines
18 KiB
Common Lisp
553 lines
18 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 "CAT")
|
|
|
|
(PROVIDE "special-smsts")
|
|
|
|
;;; GMSM-FACES-INFO = (gmsm (simple-vector absm) . dffr)
|
|
;;; 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 bsgn)
|
|
(declare (simple-vector table))
|
|
(dotimes (dmns (length table))
|
|
(declare (fixnum dmns))
|
|
(finite-ss-finish-line table dmns bsgn))
|
|
table)
|
|
|
|
(DEFUN FINITE-SS-FINISH-LINE (table dmns bsgn)
|
|
(declare
|
|
(simple-vector table)
|
|
(fixnum dmns))
|
|
(setf (svref table dmns)
|
|
(mapcar
|
|
#'(lambda (entry)
|
|
(finite-ss-finish-entry table entry dmns bsgn))
|
|
(svref table dmns))))
|
|
|
|
(DEFUN FINITE-SS-FINISH-ENTRY (table entry dmns bsgn)
|
|
(declare
|
|
(simple-vector table)
|
|
(list entry)
|
|
(fixnum dmns)
|
|
(symbol bsgn))
|
|
(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+
|
|
:dffr +zero-negative-cmbn+)))
|
|
(setf faces (nconc faces (make-list (1+ (- dmns (length faces)))
|
|
:initial-element bsgn)))
|
|
(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-dffr 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* ((bsgn (second list))
|
|
(pre-table (finite-ss-pre-table list))
|
|
(table (finite-ss-pre-table-table pre-table)))
|
|
(declare
|
|
(symbol bsgn)
|
|
(list pre-table)
|
|
(simple-vector table))
|
|
;; (vector (vector gmsm-faces-info))
|
|
(finite-ss-finish-table table bsgn)))
|
|
|
|
#|
|
|
(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-DFFR-INTR (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-dffr found))))
|
|
#'rslt))
|
|
|
|
(DEFUN BUILD-FINITE-SS (list)
|
|
(declare (list list))
|
|
(let ((bsgn (first list))
|
|
(table (finite-ss-table list))
|
|
(ind-smst (gensym)))
|
|
(declare
|
|
(symbol bsgn ind-smst)
|
|
(simple-vector table))
|
|
;; (vector (vector gmsm-faces-info))
|
|
(let ((rslt (simplicial-set
|
|
:cmpr #'s-cmpr
|
|
:basis (finite-ss-basis table)
|
|
:bsgn bsgn
|
|
:face (finite-ss-face ind-smst table)
|
|
:dffr-intr (finite-ss-dffr-intr ind-smst table)
|
|
:dffr-strt :gnrt
|
|
:dfnt `(build-finite-ss ,list))))
|
|
(set ind-smst rslt)
|
|
(unless (check-smst rslt 0 (length table))
|
|
;; ??? (pop *k-list*)
|
|
;; ??? (pop *k-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)
|
|
(bsgn tr)
|
|
(face tr 1 2 's012)
|
|
(? tr 2 's012)
|
|
(? tr *)
|
|
(inspect tr)
|
|
(mapcar #'(lambda (s) (length (eval s))) *k-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))) *k-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 absm))
|
|
(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 (simplicial-set
|
|
:cmpr #'sphere-cmpr
|
|
:basis (sphere-basis dmns)
|
|
:bsgn '*
|
|
:face (sphere-face dmns)
|
|
:dffr-intr #'zero-dffr-intr
|
|
:dffr-strt :cmbn
|
|
:dfnt `(sphere ,dmns))))
|
|
(declare (type simplicial-set rslt))
|
|
(setf (slot-value (dffr rslt) 'dfnt)
|
|
`(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 (dffr 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 (simplicial-set
|
|
:cmpr #'s-cmpr
|
|
:bsgn '*
|
|
:basis (sphere-wedge-basis dmns-list)
|
|
:face #'sphere-wedge-face
|
|
:dffr-intr #'zero-dffr-intr
|
|
:dffr-strt :cmbn
|
|
:dfnt `(sphere-wedge ,@dmns-list))))
|
|
(declare (type simplicial-set rslt))
|
|
(setf (slot-value (dffr rslt) 'dfnt)
|
|
`(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-? (dffr 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 (symbol gmsm1 gmsm2))
|
|
(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))))
|
|
(bsgn1 (absm (mask (1- dmns)) '*))
|
|
(bsgn2 (absm (mask dmns) '*))
|
|
(2pii (ash pii 1)))
|
|
(declare
|
|
(type absm face)
|
|
(type absm bsgn1 bsgn2)
|
|
(fixnum 2pii))
|
|
(flet ((rslt (indx dmns2 gmsm)
|
|
(declare
|
|
(fixnum indx dmns2)
|
|
(ignore gmsm))
|
|
(the absm
|
|
(if (= dmns dmns2)
|
|
bsgn1
|
|
(if (oddp indx)
|
|
bsgn2
|
|
(if (< indx 2pii)
|
|
face
|
|
bsgn2))))))
|
|
(the face #'rslt))))
|
|
|
|
(DEFUN MOORE-DFFR-INTR (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 #'rslt))))
|
|
|
|
(DEFUN MOORE (pii dmns)
|
|
(declare (fixnum pii dmns))
|
|
(the simplicial-set
|
|
(simplicial-set
|
|
:bsgn '*
|
|
:cmpr #'moore-cmpr
|
|
:basis (moore-basis dmns)
|
|
:face (moore-face pii dmns)
|
|
:dffr-intr (moore-dffr-intr pii dmns)
|
|
:dffr-strt :cmbn
|
|
:dfnt `(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 &optional (l 15))
|
|
(declare (fixnum k))
|
|
(flet ((rslt (dmns)
|
|
(declare (fixnum dmns))
|
|
(the list
|
|
(if (or (minusp dmns)
|
|
(< 0 dmns k)
|
|
(>= dmns l))
|
|
+empty-list+
|
|
(list dmns)))))
|
|
(the basis #'rslt)))
|
|
|
|
(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-DFFR-INTR (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 #'rslt)))
|
|
|
|
(DEFUN R-PROJ-SPACE (&optional (k 1) (l 15))
|
|
(declare (fixnum k))
|
|
(the simplicial-set
|
|
(simplicial-set
|
|
:cmpr #'R-proj-space-cmpr
|
|
:basis (R-proj-space-basis k l)
|
|
:bsgn 0
|
|
:face (R-proj-space-face k)
|
|
:dffr-intr (R-proj-space-dffr-intr k)
|
|
:dffr-strt :cmbn
|
|
:dfnt `(R-proj-space ,k))))
|
|
|
|
#|
|
|
(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)))
|
|
|#
|