;;;  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)
|#





Home page.