;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS
;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS
;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "simplicial-sets")
(DEFUN DGOP-EXT-INT (ext-dgop)
(declare (list ext-dgop))
;; (list fixnum)
(when ext-dgop
(unless (apply #'> ext-dgop)
(error "In DGOP-EXT-INT, the external dgop ~A is not decreasing." ext-dgop)))
(the fixnum
(apply #'logxor (mapcar
#'(lambda (item)
(declare (fixnum item))
(the fixnum (2-exp item)))
ext-dgop))))
#|
(dgop-ext-int '())
(dgop-ext-int '(2 2))
(dgop-ext-int '(4 0))
|#
(DEFUN DGOP-INT-EXT (dgop)
(declare (fixnum dgop))
(unless (typep dgop 'dgop)
(error "In DXOP-INT-EXT, ~A is not a dxop." dgop))
(the list
(do ((dgop dgop (ash dgop -1))
(rslt +empty-list+)
(bmark 0 (1+ bmark)))
((zerop dgop) rslt)
(declare
(fixnum dgop bmark)
(list rslt))
(when (oddp dgop)
(push bmark rslt)))))
#|
(dgop-int-ext 0)
(dgop-int-ext 4)
(dgop-int-ext 63)
(dotimes (i 33)
(print (dgop-ext-int (dgop-int-ext i)))))
|#
(DEFUN HYPHENIZE-LIST (list)
(declare (list list))
(if list
(format nil "~D~{-~D~}" (first list) (rest list))
(format nil "-")))
#|
(hyphenize-list '())
(hyphenize-list '(3))
(hyphenize-list '(5 3 1)))
|#
#|
(absm-p 1)
(absm-p '(1))
(absm-p '(:absm nil)) ;; printer-error
(absm-p '(:absm 5 . a))
(absm-p '(:absm -5 . a)) ;; printer-error
|#
(DEFMETHOD PRINT-KEYCONS ((key (eql :absm)) cdr stream)
(setf cdr (cons :absm cdr))
(format stream
""
(hyphenize-list (dgop-int-ext (dgop cdr)))
(gmsm cdr))
cdr)
#|
(absm 5 'a)
|#
#|
(degenerate-p (absm 0 'a))
(degenerate-p (absm 4 'a))
(non-degenerate-p (absm 0 'a))
(non-degenerate-p (absm 4 'a)))
|#
(DEFVAR *SMST-LIST*)
(SETF *SMST-LIST* +empty-list+)
(PUSHNEW '*SMST-LIST* *list-list*)
(DEFUN FACE4 (smst indx dmns gmsm-or-absm)
(if (typep gmsm-or-absm 'absm)
(a-face4 (face1 smst) indx dmns gmsm-or-absm)
(funcall (face1 smst) indx dmns gmsm-or-absm)))
(DEFMETHOD PRINT-OBJECT ((smst simplicial-set) stream)
(the simplicial-set
(progn
(format stream "[K~D Simplicial-Set]" (idnm smst))
smst)))
(DEFUN SMST (n)
(declare (fixnum n))
(the (or simplicial-set null)
(find n *smst-list* :key #'idnm)))
(DEFUN BUILD-SMST
(&key cmpr basis bspn face face* intr-bndr bndr-strt
intr-dgnl dgnl-strt orgn)
(declare
(type cmprf cmpr)
(type basis basis)
(type gmsm bspn)
(type face face)
(type (or null face*) face*)
(type (or intr-mrph null) intr-bndr intr-dgnl)
(type (or strt null) bndr-strt dgnl-strt)
(list orgn))
(let ((already (find orgn *smst-list* :test #'equal :key #'orgn)))
(declare (type (or simplicial-set null) already))
(when already
(return-from build-smst already)))
(if intr-bndr
(unless bndr-strt
(error "In BUILD-SMST, an intr-bndr is given but not its strategy."))
(cond (face*
(setf bndr-strt :gnrt
intr-bndr (face*-bndr cmpr face*)))
(face
(setf bndr-strt :gnrt
intr-bndr (face-bndr cmpr face)))))
(if intr-dgnl
(unless dgnl-strt
(error "In BUILD-SMST, an intr-dgnl is given but not its strategy."))
(setf dgnl-strt :gnrt
intr-dgnl (intr-diagonal face)))
(the simplicial-set
(let ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bspn
:intr-dffr intr-bndr
:strt bndr-strt :orgn orgn)))
(change-chcm-to-clgb rslt
:intr-cprd intr-dgnl :cprd-strt dgnl-strt)
(setf (slot-value (dgnl rslt) 'orgn)
`(diagonal ,rslt))
(change-class rslt 'simplicial-set)
(setf (slot-value rslt 'face) face)
(push rslt *smst-list*)
rslt)))
(DEFUN A-BASIS2 (basis dmns)
(declare
(type basis basis)
(fixnum dmns))
(the list
(let ((basis-array (make-array (1+ dmns) :element-type 'list)))
(declare (type (vector list) basis-array))
(dotimes (i (1+ dmns))
(declare (fixnum i))
(setf (aref basis-array i) (funcall basis i)))
(do ((dgop (mask dmns) (1- dgop))
(rslt +empty-list+
(nconc (mapcar
#'(lambda (gmsm)
(declare (type gmsm gmsm))
(absm dgop gmsm))
(aref basis-array (- dmns (logcount dgop))))
rslt)))
((minusp dgop) rslt)))))
#|
(setf m (moore 2 2))
(dotimes (i 4)
(print (basis m i :dgnr)))
|#
(DEFUN INTR-DIAGONAL (face)
(declare (type face face))
(flet ((rslt (dmns gmsm)
(declare
(fixnum dmns)
(type gmsm gmsm))
(the cmbn
(let ((del-0-s +empty-list+)
(rslt +empty-list+))
(declare (list del-0-s rslt))
(do ((dmns dmns (1- dmns))
(iabsm (cons 0 gmsm) (cdr (ia-face4 face 0 dmns iabsm))))
((zerop dmns) (push iabsm del-0-s))
(declare
(fixnum dmns)
(cons iabsm))
(push iabsm del-0-s))
(do ((ldmns dmns (1- ldmns))
(rdmns 0 (1+ rdmns))
(iabsm (cons 0 gmsm) (cdr (ia-face4 face ldmns ldmns iabsm)))
(mark-del-0 del-0-s (cdr mark-del-0)))
((zerop ldmns) (push (term 1 (tnpr 0 (cdr iabsm) dmns gmsm))
rslt))
(declare
(fixnum ldmns rdmns)
(type gmsm gmsm)
(list mark-del-0))
(unless (or (plusp (car iabsm))
(plusp (caar mark-del-0)))
(push (term 1 (tnpr ldmns (cdr iabsm) rdmns (cdar mark-del-0)))
rslt)))
(make-cmbn :degr dmns :list rslt)))))
(the intr-mrph #'rslt)))
#|
(setf cmpr #'f-cmpr
face #'delta-face)
(setf diag (intr-diagonal face))
(funcall diag 4 (mask 5))
(funcall diag 0 4)
(setf cmpr #'s-cmpr
face (sphere-face 4))
(setf diag (intr-diagonal face))
(funcall diag 4 's4)
(funcall diag 0 '*)
(setf s4 (sphere 4))
(dgnl s4 4 's4)
|#
(DEFUN FACE-BNDR (cmpr face)
(declare
(type cmprf cmpr)
(type face face))
(flet ((rslt (dmns gmsm)
(declare
(fixnum dmns)
(type gmsm gmsm))
(the cmbn
(progn
(when (zerop dmns)
(return-from rslt +zero-negative-cmbn+))
(let ((pre-rslt +empty-list+))
(declare (list pre-rslt))
;; (list (cons cffc face))
(dotimes (indx (1+ dmns))
(declare (fixnum indx))
(let ((face (funcall face indx dmns gmsm)))
(declare (type absm face))
(unless (degenerate-p face)
(push (term (-1-expt-n indx) (gmsm face))
pre-rslt))))
(apply #'nterm-add cmpr (1- dmns) pre-rslt))))))
(the intr-mrph #'rslt)))
#|
(setf face #'(lambda (indx dmns gmsm)
(absm 0 (append
(subseq gmsm 0 indx)
(subseq gmsm (1+ indx))))))
(setf bndr (face-bndr #'l-cmpr face))
(funcall bndr 0 '(a))
(funcall bndr 1 '(a b))
(funcall bndr 2 '(a b c))
(funcall bndr 3 '(a b c d))
(funcall bndr 3 '(d c b a))
(funcall bndr 1 '(a a))
(funcall bndr 2 '(a a a))
(funcall bndr 3 '(a a a a))
(setf face #'(lambda (index dmns gmsm)
(absm (dgop-ext-int (nreverse ( dmns 1)
(let ((dmns-1 (1- dmns)))
(declare (fixnum dmns-1))
(dotimes (i dmns)
(declare (fixnum i))
(dotimes (j (1+ i))
(declare (fixnum j))
(let ((rslt1 (a-face4 face i dmns-1 (funcall face j dmns gmsm)))
(rslt2 (a-face4 face j dmns-1 (funcall face (1+ i) dmns gmsm))))
(declare (type absm rslt1 rslt2))
(unless (eq (a-cmpr3 cmpr rslt1 rslt2) :equal)
(cerror "CHECK-FACES will return NIL."
"Noncoherent boundary operators detected by CHECK-FACES :~@
Simplex => ~A~@
del_~D o del_~D => ~A~@
del_~D o del_~D => ~A"
gmsm i j rslt1 j (1+ i) rslt2)
(return-from check-faces nil)))))))
t)))
#|
(setf d (delta-infinity))
(check-faces #'f-cmpr (face d) 4 31)
|#
(DEFUN CHECK-SMST (smst dmns1 &optional (dmns2 (1+ dmns1)))
(declare
(type simplicial-set smst)
(fixnum dmns1 dmns2))
(with-slots (cmpr basis face) smst
(declare
(type cmprf cmpr)
(type face face))
(when (eq basis :locally-effective)
(error "In CHECK-SMST, the locally-effective simplicial-set ~A~@
cannot be checked." smst))
(do ((rslt t)
(dmns dmns1 (1+ dmns)))
((>= dmns dmns2) rslt)
(declare
(type boolean rslt)
(fixnum dmns))
(format t "~%Checking the ~D-simplices..." dmns)
(dolist (gmsm (funcall basis dmns))
(declare (type gmsm gmsm))
(unless (check-faces cmpr face dmns gmsm)
(setf rslt nil))))))
#|
(check-smst (delta-infinity) 5)
(check-smst (delta 3) 2)
(check-smst (delta 3) 2 4)
|#