Extracted simplicial groups test.
This commit is contained in:
Gerd Heber
parent
04eb103bad
commit
2672709129
@ -27,6 +27,7 @@
|
||||
(:file "k-pi-n-test")
|
||||
(:file "kan-test")
|
||||
(:file "searching-homology-test")
|
||||
(:file "simplicial-groups-test")
|
||||
(:file "simplicial-mrphs-test")
|
||||
(:file "simplicial-sets-test")
|
||||
(:file "tensor-products-test")
|
||||
|
||||
@ -236,6 +236,7 @@
|
||||
;; kan.lisp
|
||||
|
||||
CHECK-HAT
|
||||
CHECK-KAN
|
||||
SMST-KAN
|
||||
|
||||
;; loop-spaces.lisp
|
||||
|
||||
@ -6,18 +6,20 @@
|
||||
|
||||
(PROVIDE "simplicial-groups")
|
||||
|
||||
|
||||
(DEFUN SMGR (idnm)
|
||||
(declare (fixnum idnm))
|
||||
(the (or null simplicial-group)
|
||||
(find idnm *smgr-list* :key #'idnm)))
|
||||
(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)))
|
||||
(progn
|
||||
(format stream "[K~D Simplicial-Group]" (idnm smgr))
|
||||
smgr)))
|
||||
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setf (ext:package-lock :clos) t))
|
||||
|
||||
@ -25,96 +27,101 @@
|
||||
(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)))
|
||||
(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))
|
||||
(&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))
|
||||
(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))))))
|
||||
(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))
|
||||
(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))))))
|
||||
(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)))
|
||||
(name (eql 'kfll)))
|
||||
(declare (ignore class))
|
||||
(the kfll
|
||||
(progn
|
||||
(push smgr *kan-list*)
|
||||
(setf (slot-value smgr 'kfll) (smgr-kfll smgr)))))
|
||||
(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 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
|
||||
@ -126,69 +133,61 @@
|
||||
(a-grin4
|
||||
sintr-grin dmns-1
|
||||
(a-face4 face
|
||||
i dmns rslt))
|
||||
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)))
|
||||
(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))))
|
||||
(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)))
|
||||
(name (eql 'aprd)))
|
||||
(declare (ignore class))
|
||||
(the morphism
|
||||
(progn
|
||||
(push smgr *hopf-list*)
|
||||
(setf (slot-value smgr 'aprd) (smgr-aprd smgr)))))
|
||||
(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))))
|
||||
|
||||
|
||||
(let ((eml (eml smgr smgr))
|
||||
(grml (grml smgr)))
|
||||
(declare
|
||||
(type morphism eml)
|
||||
(type simplicial-mrph grml))
|
||||
(cmps grml eml))))
|
||||
|
||||
15
test/simplicial-groups-test.lisp
Normal file
15
test/simplicial-groups-test.lisp
Normal file
@ -0,0 +1,15 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
#|
|
||||
(test check-kan
|
||||
(cat:cat-init)
|
||||
(let* ((k (cat:k-z-1))
|
||||
(rslt '(1 10 100))
|
||||
(hat (mapcar #'(lambda (i) (cat:face k i 3 rslt))
|
||||
(cat:<a-b> 0 3))))
|
||||
(dotimes (i 4)
|
||||
(cat:check-kan k i 3 (remove (nth i hat) hat :test #'equal)))))
|
||||
|#
|
||||
Loading…
Reference in New Issue
Block a user