154 lines
4.5 KiB
Common Lisp
154 lines
4.5 KiB
Common Lisp
;;; SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS
|
|
;;; SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS
|
|
;;; SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS
|
|
|
|
(IN-PACKAGE "COMMON-LISP-USER")
|
|
|
|
(PROVIDE "simplicial-hmtps")
|
|
|
|
(DEFTYPE HINTR () 'function)
|
|
;; (function (indx dmns gmsm) absm)
|
|
|
|
(DEFCLASS SIMPLICIAL-HMTP (morphism)
|
|
((hintr :type hintr :initarg :hintr :reader hintr)))
|
|
|
|
|
|
(DEFVAR *SMHMT-LIST*)
|
|
(SETF *SMHMT-LIST* +empty-list+)
|
|
(PUSHNEW '*SMHMT-LIST* *LIST-LIST*)
|
|
|
|
(DEFMETHOD PRINT-OBJECT ((smhmt simplicial-hmtp) stream)
|
|
(the simplicial-hmtp
|
|
(progn
|
|
(format stream "[K~D Simplicial-Homotopy K~D -> K~D]"
|
|
(idnm smhmt) (idnm (sorc smhmt)) (idnm (trgt smhmt)))
|
|
smhmt)))
|
|
|
|
(DEFUN SMHMT (idnm)
|
|
(declare (fixnum idnm))
|
|
(the (or null simplicial-hmtp)
|
|
(find idnm *smhmt-list* :key #'idnm)))
|
|
|
|
(DEFUN HINTR-INTR (cmpr hintr)
|
|
(declare (type hintr hintr)
|
|
(type cmprf cmpr))
|
|
(flet ((rslt (dmns gmsm)
|
|
(declare
|
|
(fixnum dmns)
|
|
(type gmsm gmsm))
|
|
(when (minusp dmns)
|
|
(return-from rslt (zero-cmbn (1+ dmns))))
|
|
(let ((cmbn (zero-cmbn (1+ dmns))))
|
|
(declare (type cmbn cmbn))
|
|
(do ((indx 0 (1+ indx)))
|
|
((> indx dmns) cmbn)
|
|
(declare (fixnum indx))
|
|
(let ((hmtp-i (funcall hintr indx dmns gmsm)))
|
|
(declare (type absm hmtp-i))
|
|
(if (non-degenerate-p hmtp-i)
|
|
(setf cmbn (2cmbn-add cmpr cmbn (term-cmbn (1+ dmns) (-1-expt-n indx) (gmsm hmtp-i))))))))))
|
|
(the intr-mrph #'rslt)))
|
|
|
|
(DEFUN BUILD-SMHMT (&key sorc trgt degr hintr intr strt orgn)
|
|
(declare
|
|
(type simplicial-set sorc trgt)
|
|
(fixnum degr)
|
|
(type hintr hint)
|
|
(type (or intr-mrph null) intr)
|
|
(type (or strt null) strt)
|
|
(list orgn))
|
|
(the simplicial-hmtp
|
|
(progn
|
|
(let ((already (find orgn *smhmt-list* :test #'equal :key #'orgn)))
|
|
(declare (type (or simplicial-hmtp null) already))
|
|
(when already
|
|
(return-from build-smhmt already)))
|
|
(unless (= 1 degr)
|
|
(error "In BUILD-SMHMT, the degree ~D is different to +1."
|
|
degr))
|
|
(if intr
|
|
(unless strt
|
|
(error "In BUILD-SMMR, an intr is given but not its strt"))
|
|
(let ((cmpr (cmpr sorc)))
|
|
(declare (type cmprf cmpr))
|
|
(setf strt :gnrt
|
|
intr (hintr-intr cmpr hintr))))
|
|
(let ((rslt (build-mrph
|
|
:sorc sorc :trgt trgt :degr degr
|
|
:intr intr :strt strt
|
|
:orgn orgn)))
|
|
(declare (type morphism rslt))
|
|
(change-class rslt 'simplicial-hmtp)
|
|
(setf (slot-value rslt 'hintr) hintr)
|
|
(push rslt *smhmt-list*)
|
|
rslt))))
|
|
|
|
|
|
#|
|
|
(setf d (delta 3))
|
|
(setf h (build-smhmt
|
|
:sorc d :trgt d :degr 1
|
|
:hintr #'(lambda (indx dmns gmsm)
|
|
(absm (dgop-ext-int (list indx)) gmsm))
|
|
:orgn '(simplicial-homotopy delta-3)))
|
|
(dotimes (indx 5)
|
|
(print (? h indx 4 (absm 8 15))))
|
|
(dotimes (indx 7)
|
|
(print (? h indx 6 (absm 45 11))))
|
|
(? h 2 11)
|
|
|#
|
|
|
|
|
|
|
|
(DEFMETHOD ?4 ((smhmt simplicial-hmtp) indx dmns absm-or-gmsm)
|
|
(declare
|
|
(fixnum indx dmns)
|
|
(type (or absm gmsm) absm-or-gmsm))
|
|
(the absm
|
|
(typecase absm-or-gmsm
|
|
(absm
|
|
(with-absm (dgop gmsm) absm-or-gmsm
|
|
(declare
|
|
(fixnum dgop)
|
|
(type gmsm gmsm))
|
|
(if (= 0 dgop)
|
|
(funcall (hintr smhmt) indx dmns gmsm)
|
|
(let* ((dgop1-ext (first (dgop-int-ext dgop)))
|
|
(dgop2 (remove-bit dgop dgop1-ext))
|
|
(absm2 (absm dgop2 gmsm)))
|
|
(declare
|
|
(fixnum dgop1-ext dgop2)
|
|
(type absm sbsm2))
|
|
(if (>= dgop1-ext indx)
|
|
(let ((smhmt-i (?4 smhmt indx (1- dmns) absm2)))
|
|
(declare (type absm smhmt-i))
|
|
(ndgnr (dgop-ext-int (list (1+ dgop1-ext))) smhmt-i))
|
|
(let ((smhmt-i-1 (?4 smhmt (1- indx) (1- dmns) absm2)))
|
|
(declare (type absm smhmt-i-1))
|
|
(ndgnr (dgop-ext-int (list dgop1-ext)) smhmt-i-1)))))))
|
|
(otherwise
|
|
(funcall (hintr smhmt) indx dmns absm-or-gmsm)))))
|
|
|
|
|
|
;; This macro definition changes the definition of the macro ? in the file macro.lsp
|
|
(DEFMACRO ? (&rest rest)
|
|
(ecase (length rest)
|
|
(2 `(?2 ,@rest))
|
|
(3 `(?3 ,@rest))
|
|
(4 `(?4 ,@rest))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|