163 lines
4.5 KiB
Common Lisp
163 lines
4.5 KiB
Common Lisp
;;; 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))))
|
|
|
|
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf (ext:package-lock :clos) nil))
|
|
(DEFMETHOD PRINT-OBJECT ((smmr simplicial-mrph) stream)
|
|
(the simplicial-mrph
|
|
(progn
|
|
(if (= -1 (degr smmr))
|
|
(format stream "[K~D Fibration K~D -> K~D]"
|
|
(idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr)))
|
|
(format stream "[K~D Simplicial-Morphism K~D -> K~D]"
|
|
(idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr))))
|
|
smmr)))
|
|
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf (ext:package-lock :clos) t))
|
|
|
|
|
|
(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 sintr)
|
|
(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)
|
|
|#
|
|
|
|
#| ????
|
|
(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)))))
|
|
|
|
(DEFUN A-SINTR3 (sintr dmns absm)
|
|
(declare
|
|
(type sintr sintr)
|
|
(fixnum dmns)
|
|
(type absm absm))
|
|
(the absm
|
|
(with-absm (dgop gmsm) absm
|
|
(ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm)))))
|
|
|# ;;; ????
|
|
|
|
|
|
(DEFUN TW-A-SINTR3 (sintr dmns absm bspn)
|
|
(declare
|
|
(type sintr sintr)
|
|
(fixnum dmns)
|
|
(type absm absm)
|
|
(type gmsm bspn))
|
|
(the absm
|
|
(with-absm (dgop gmsm) absm
|
|
(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)))))))
|
|
|
|
#|
|
|
(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)))))))
|
|
|#
|