;;;  SIMPLICIAL-MRPHS  SIMPLICIAL-MRPHS  SIMPLICIAL-MRPHS
;;;  SIMPLICIAL-MRPHS  SIMPLICIAL-MRPHS  SIMPLICIAL-MRPHS
;;;  SIMPLICIAL-MRPHS  SIMPLICIAL-MRPHS  SIMPLICIAL-MRPHS

(IN-PACKAGE "COMMON-LISP-USER")

(PROVIDE "simplicial-mrphs")

(DEFVAR *SMMR-LIST*)
(SETF *SMMR-LIST* +empty-list+)
(PUSHNEW '*SMMR-LIST* *LIST-LIST*)

(DEFMETHOD ?3 ((smmr simplicial-mrph) dmns absm-or-gmsm)
  (declare
     (fixnum dmns)
     (type (or absm gmsm) absm-or-gmsm))
  (typecase absm-or-gmsm
     (absm
      (with-absm (dgop gmsm) absm-or-gmsm
         (let ((gmsm-smmr (funcall (sintr smmr)
                 (- dmns (logcount dgop)) gmsm)))
       (declare (type absm gmsm-smmr))
       (ndgnr dgop gmsm-smmr))))
     (otherwise
      (funcall (sintr smmr) dmns absm-or-gmsm))))

(DEFMETHOD PRINT-OBJECT ((smmr simplicial-mrph) stream)
  (the simplicial-mrph
     (progn
       (if (= -1 (degr smmr))
       (format stream "[K~D Fibration]" (idnm smmr))
     (format stream "[K~D Simplicial-Morphism]" (idnm smmr)))
       smmr)))

(DEFUN SMMR (idnm)
  (declare (fixnum idnm))
  (the (or null simplicial-mrph)
     (find idnm *smmr-list* :key #'idnm)))

(DEFUN SINTR-INTR (sintr)
   (declare (type sintr sintr))
   (flet ((rslt (dmns gmsm)
         (declare
            (fixnum dmns)
        (type gmsm gmsm))
         (when (minusp dmns)
        (return-from rslt (zero-cmbn dmns)))
         (let ((rslt (funcall sintr dmns gmsm)))
            (declare (type absm rslt))
        (if (degenerate-p rslt)
           (zero-cmbn dmns)
           (term-cmbn dmns 1 (gmsm rslt))))))
       (the intr-mrph #'rslt)))

(DEFUN BUILD-SMMR (&key sorc trgt degr sintr intr strt orgn)
   (declare
      (type simplicial-set sorc trgt)
      (fixnum degr)
      (type sintr sint)
      (type (or intr-mrph null) intr)
      (type (or strt null) strt)
      (list orgn))
   (the simplicial-mrph
      (progn
     (let ((already (find orgn *smmr-list* :test #'equal :key #'orgn)))
        (declare (type (or simplicial-mrph null) already))
        (when already
           (return-from build-smmr already)))
     (if (zerop degr)
         (if intr
         (unless strt
             (error "In BUILD-SMMR, an intr is given but not its strt"))
           (setf strt :gnrt
             intr (sintr-intr sintr)))
       (setf intr nil strt :gnrt))
     (let ((rslt (build-mrph
                :sorc sorc :trgt trgt :degr degr
            :intr intr :strt strt
            :orgn orgn)))
       (declare (type morphism rslt))
       (change-class rslt 'simplicial-mrph)
       (setf (slot-value rslt 'sintr) sintr)
       (push rslt *smmr-list*)
       rslt))))

#|
  (setf d (delta 3))
  (setf m (build-smmr
            :sorc d :trgt d :degr 0
            :sintr #'(lambda (dmns gmsm)
                        (absm 0 gmsm))
            :orgn '(identity delta-3)))
  (setf m2 (build-smmr
            :sorc d :trgt d :degr 0
            :sintr #'(lambda (dmns gmsm)
                       (absm (mask dmns) 1))
            :orgn '(null delta-3)))
  (? m2 2 7)
;;  (s? m2 2 7)
|#

(DEFMACRO WITH-IABSM ((dgop gmsm) iabsm . body)
  `(let ((,dgop (car ,iabsm))
     (,gmsm (cdr ,iabsm)))
     (declare
        (fixnum ,dgop)
    (type gmsm ,gmsm))
     ,@body))

#|
  (macroexpand-1 '(with-iabsm (dgop gmsm) iabsm
                    (statement-1)
                    (statement-2)))
|#

(DEFMACRO A-SINTR3 (sintr dmns absm)
  ;; BE CAREFUL: works only if  degr (sintr) = 0.
  ;; if degr = -1 (fibration), use tw-a-sintr3
  `(ia-sintr3 ,sintr ,dmns (cdr ,absm)))

(DEFUN IA-SINTR3 (sintr dmns iabsm)
  (declare
     (type sintr sintr)
     (fixnum dmns)
     (type iabsm iabsm))
  (the absm
     (with-iabsm (dgop gmsm) iabsm
    (ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm)))))

(DEFMACRO TW-A-SINTR3 (sintr dmns absm bspn)
  `(tw-ia-sintr3 ,sintr ,dmns (cdr ,absm) ,bspn))

(DEFUN TW-IA-SINTR3 (sintr dmns iabsm bspn)
  (declare
     (type sintr sintr)
     (fixnum dmns)
     (type iabsm iabsm)
     (type gmsm bspn))
  (the absm
     (with-iabsm (dgop gmsm) iabsm
    (let ((dmns-1 (1- dmns)))
      (declare (fixnum dmns-1))
      (if (logbitp dmns-1 dgop)
         (absm (mask dmns-1) bspn)
         (ndgnr dgop (funcall sintr
                (- dmns (logcount dgop))
                gmsm)))))))



Home page.