198 lines
5.3 KiB
Common Lisp
198 lines
5.3 KiB
Common Lisp
;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS
|
|
;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS
|
|
;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS
|
|
|
|
(IN-PACKAGE "COMMON-LISP-USER")
|
|
|
|
(PROVIDE "simplicial-groups")
|
|
|
|
(DEFVAR *SMGR-LIST*)
|
|
(SETF *SMGR-LIST* +empty-list+)
|
|
(PUSHNEW '*SMGR-LIST* *list-list*)
|
|
|
|
(DEFUN SMGR (idnm)
|
|
(declare (fixnum idnm))
|
|
(the (or null simplicial-group)
|
|
(find idnm *smgr-list* :key #'idnm)))
|
|
|
|
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf (ext:package-lock :clos) nil))
|
|
(DEFMETHOD PRINT-OBJECT ((smgr simplicial-group) stream)
|
|
(the simplicial-group
|
|
(progn
|
|
(format stream "[K~D Simplicial-Group]" (idnm smgr))
|
|
smgr)))
|
|
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf (ext:package-lock :clos) t))
|
|
|
|
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf (ext:package-lock :clos) nil))
|
|
(DEFMETHOD PRINT-OBJECT ((smgr ab-simplicial-group) stream)
|
|
(the simplicial-group
|
|
(progn
|
|
(format stream "[K~D Abelian-Simplicial-Group]" (idnm smgr))
|
|
smgr)))
|
|
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf (ext:package-lock :clos) t))
|
|
|
|
|
|
(DEFUN BUILD-SMGR
|
|
(&key cmpr basis bspn
|
|
face face* intr-bndr bndr-strt
|
|
intr-dgnl dgnl-strt
|
|
sintr-grml sintr-grin
|
|
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)
|
|
(type sintr sintr-grml sintr-grin)
|
|
(list orgn))
|
|
(let ((already (find orgn *smgr-list* :test #'equal :key #'orgn)))
|
|
(declare (type (or simplicial-group null) already))
|
|
(when already
|
|
(return-from build-smgr already)))
|
|
(let ((rslt (build-smst
|
|
:cmpr cmpr :basis basis :bspn bspn
|
|
:face face :face* face* :intr-bndr intr-bndr
|
|
:bndr-strt bndr-strt :intr-dgnl intr-dgnl
|
|
:dgnl-strt dgnl-strt :orgn orgn)))
|
|
(declare (type simplicial-set rslt))
|
|
(change-class rslt 'simplicial-group)
|
|
(setf (slot-value rslt 'grml)
|
|
(build-smmr
|
|
:sorc (crts-prdc rslt rslt) :trgt rslt :degr 0
|
|
:sintr sintr-grml :orgn `(group-multiplication ,rslt))
|
|
(slot-value rslt 'grin)
|
|
(build-smmr
|
|
:sorc rslt :trgt rslt :degr 0
|
|
:sintr sintr-grin :orgn `(group-inversion ,rslt)))
|
|
(push rslt *smgr-list*)
|
|
rslt))
|
|
|
|
(DEFUN A-GRML4 (sintr-grml dmns absm1 absm2)
|
|
(declare
|
|
(fixnum dmns)
|
|
(type absm absm1 absm2))
|
|
(the absm
|
|
(let ((acrpr (2absm-acrpr absm1 absm2)))
|
|
(declare (type absm acrpr))
|
|
(with-absm (dgop crpr) acrpr
|
|
(ndgnr dgop
|
|
(funcall sintr-grml
|
|
(- dmns (logcount dgop))
|
|
crpr))))))
|
|
|
|
(DEFUN A-GRIN4 (sintr-grin dmns absm)
|
|
(declare
|
|
(type sintr sintr-grin)
|
|
(fixnum dmns)
|
|
(type absm absm))
|
|
(the absm
|
|
(with-absm (dgop gmsm) absm
|
|
(absm dgop
|
|
(gmsm
|
|
(funcall sintr-grin (- dmns (logcount dgop)) gmsm))))))
|
|
|
|
(DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group)
|
|
(name (eql 'kfll)))
|
|
(declare (ignore class))
|
|
(the kfll
|
|
(progn
|
|
(push smgr *kan-list*)
|
|
(setf (slot-value smgr 'kfll) (smgr-kfll smgr)))))
|
|
|
|
(DEFUN SMGR-KFLL-INTR (face sintr-grml sintr-grin)
|
|
(flet ((rslt (indx dmns hat
|
|
&aux (dmns-1 (1- dmns)))
|
|
(declare
|
|
(fixnum indx dmns dmns-1)
|
|
(list hat))
|
|
(the absm
|
|
(let ((rslt (absm 0 nil)))
|
|
(declare (type absm rslt))
|
|
(when (plusp indx)
|
|
(setf rslt (1dgnr 0 (pop hat)))
|
|
(do ((i 1 (1+ i)))
|
|
((= i indx))
|
|
(declare (fixnum i))
|
|
(setf rslt
|
|
(a-grml4
|
|
sintr-grml dmns
|
|
rslt
|
|
(1dgnr i
|
|
(a-grml4
|
|
sintr-grml dmns-1
|
|
(a-grin4
|
|
sintr-grin dmns-1
|
|
(a-face4 face
|
|
i dmns rslt))
|
|
(pop hat)))))))
|
|
(when (< indx dmns)
|
|
(setf hat (reverse hat))
|
|
(when (zerop indx)
|
|
(setf rslt (1dgnr dmns-1 (pop hat))))
|
|
(do ((i (if (zerop indx)
|
|
dmns-1
|
|
dmns)
|
|
(1- i)))
|
|
((endp hat) rslt)
|
|
(declare
|
|
(type absm rslt)
|
|
(fixnum i))
|
|
(setf rslt
|
|
(a-grml4
|
|
sintr-grml dmns
|
|
rslt
|
|
(1dgnr (1- i)
|
|
(a-grml4
|
|
sintr-grml dmns-1
|
|
(a-grin4
|
|
sintr-grin dmns-1
|
|
(a-face4
|
|
face
|
|
i dmns rslt))
|
|
(pop hat)))))))
|
|
rslt))))
|
|
(the kfll #'rslt)))
|
|
|
|
(DEFUN SMGR-KFLL (smgr)
|
|
(declare (type simplicial-group smgr))
|
|
(with-slots (face grml grin) smgr
|
|
(declare
|
|
(type face face)
|
|
(type simplicial-mrph grml grin))
|
|
(smgr-kfll-intr face (sintr grml) (sintr grin))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf k (k-z-1))
|
|
(setf rslt '(1 10 100))
|
|
(setf hat (mapcar #'(lambda (i) (face k i 3 rslt)) (<a-b> 0 3)))
|
|
(dotimes (i 4)
|
|
(check-kan k i 3 (remove (nth i hat) hat :test #'equal)))
|
|
|#
|
|
|
|
(DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group)
|
|
(name (eql 'aprd)))
|
|
(declare (ignore class))
|
|
(the morphism
|
|
(progn
|
|
(push smgr *hopf-list*)
|
|
(setf (slot-value smgr 'aprd) (smgr-aprd smgr)))))
|
|
|
|
(DEFUN SMGR-APRD (smgr)
|
|
(declare (type simplicial-group smgr))
|
|
(the morphism
|
|
(let ((eml (eml smgr smgr))
|
|
(grml (grml smgr)))
|
|
(declare
|
|
(type morphism eml)
|
|
(type simplicial-mrph grml))
|
|
(cmps grml eml))))
|
|
|
|
|