;;;  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 ( 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 (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))))
         (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)) ( 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-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 (k 1) (l 15))
   (declare (fixnum k))
   (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))))

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


Home page.