mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Extracted simplicial groups test.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-14 06:39:49 -05:00
parent 04eb103bad
commit 2672709129
4 changed files with 141 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -27,6 +27,7 @@
(:file "k-pi-n-test") (:file "k-pi-n-test")
(:file "kan-test") (:file "kan-test")
(:file "searching-homology-test") (:file "searching-homology-test")
(:file "simplicial-groups-test")
(:file "simplicial-mrphs-test") (:file "simplicial-mrphs-test")
(:file "simplicial-sets-test") (:file "simplicial-sets-test")
(:file "tensor-products-test") (:file "tensor-products-test")

1
package.lisp
View File

@ -236,6 +236,7 @@
;; kan.lisp ;; kan.lisp
CHECK-HAT CHECK-HAT
CHECK-KAN
SMST-KAN SMST-KAN
;; loop-spaces.lisp ;; loop-spaces.lisp

249
src/simplicial-groups.lisp
View File

@ -6,18 +6,20 @@
(PROVIDE "simplicial-groups") (PROVIDE "simplicial-groups")
(DEFUN SMGR (idnm) (DEFUN SMGR (idnm)
(declare (fixnum idnm)) (declare (fixnum idnm))
(the (or null simplicial-group) (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) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil)) (setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((smgr simplicial-group) stream) (DEFMETHOD PRINT-OBJECT ((smgr simplicial-group) stream)
(the simplicial-group (the simplicial-group
(progn (progn
(format stream "[K~D Simplicial-Group]" (idnm smgr)) (format stream "[K~D Simplicial-Group]" (idnm smgr))
smgr))) smgr)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -25,96 +27,101 @@
(setf (ext:package-lock :clos) nil)) (setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((smgr ab-simplicial-group) stream) (DEFMETHOD PRINT-OBJECT ((smgr ab-simplicial-group) stream)
(the simplicial-group (the simplicial-group
(progn (progn
(format stream "[K~D Abelian-Simplicial-Group]" (idnm smgr)) (format stream "[K~D Abelian-Simplicial-Group]" (idnm smgr))
smgr))) smgr)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
(DEFUN BUILD-SMGR (DEFUN BUILD-SMGR
(&key cmpr basis bspn (&key cmpr basis bspn
face face* intr-bndr bndr-strt face face* intr-bndr bndr-strt
intr-dgnl dgnl-strt intr-dgnl dgnl-strt
sintr-grml sintr-grin sintr-grml sintr-grin
orgn) orgn)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type basis basis) (type basis basis)
(type gmsm bspn) (type gmsm bspn)
(type face face) (type face face)
(type (or null face*) face*) (type (or null face*) face*)
(type (or intr-mrph null) intr-bndr intr-dgnl) (type (or intr-mrph null) intr-bndr intr-dgnl)
(type (or strt null) bndr-strt dgnl-strt) (type (or strt null) bndr-strt dgnl-strt)
(type sintr sintr-grml sintr-grin) (type sintr sintr-grml sintr-grin)
(list orgn)) (list orgn))
(let ((already (find orgn *smgr-list* :test #'equal :key #'orgn))) (let ((already (find orgn *smgr-list* :test #'equal :key #'orgn)))
(declare (type (or simplicial-group null) already)) (declare (type (or simplicial-group null) already))
(when already (when already
(return-from build-smgr already))) (return-from build-smgr already)))
(let ((rslt (build-smst (let ((rslt (build-smst
:cmpr cmpr :basis basis :bspn bspn :cmpr cmpr :basis basis :bspn bspn
:face face :face* face* :intr-bndr intr-bndr :face face :face* face* :intr-bndr intr-bndr
:bndr-strt bndr-strt :intr-dgnl intr-dgnl :bndr-strt bndr-strt :intr-dgnl intr-dgnl
:dgnl-strt dgnl-strt :orgn orgn))) :dgnl-strt dgnl-strt :orgn orgn)))
(declare (type simplicial-set rslt)) (declare (type simplicial-set rslt))
(change-class rslt 'simplicial-group) (change-class rslt 'simplicial-group)
(setf (slot-value rslt 'grml) (setf (slot-value rslt 'grml)
(build-smmr (build-smmr
:sorc (crts-prdc rslt rslt) :trgt rslt :degr 0 :sorc (crts-prdc rslt rslt) :trgt rslt :degr 0
:sintr sintr-grml :orgn `(group-multiplication ,rslt)) :sintr sintr-grml :orgn `(group-multiplication ,rslt))
(slot-value rslt 'grin) (slot-value rslt 'grin)
(build-smmr (build-smmr
:sorc rslt :trgt rslt :degr 0 :sorc rslt :trgt rslt :degr 0
:sintr sintr-grin :orgn `(group-inversion ,rslt))) :sintr sintr-grin :orgn `(group-inversion ,rslt)))
(push rslt *smgr-list*) (push rslt *smgr-list*)
rslt)) rslt))
(DEFUN A-GRML4 (sintr-grml dmns absm1 absm2) (DEFUN A-GRML4 (sintr-grml dmns absm1 absm2)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type absm absm1 absm2)) (type absm absm1 absm2))
(the absm (the absm
(let ((acrpr (2absm-acrpr absm1 absm2))) (let ((acrpr (2absm-acrpr absm1 absm2)))
(declare (type absm acrpr)) (declare (type absm acrpr))
(with-absm (dgop crpr) acrpr (with-absm (dgop crpr) acrpr
(ndgnr dgop (ndgnr dgop
(funcall sintr-grml (funcall sintr-grml
(- dmns (logcount dgop)) (- dmns (logcount dgop))
crpr)))))) crpr))))))
(DEFUN A-GRIN4 (sintr-grin dmns absm) (DEFUN A-GRIN4 (sintr-grin dmns absm)
(declare (declare
(type sintr sintr-grin) (type sintr sintr-grin)
(fixnum dmns) (fixnum dmns)
(type absm absm)) (type absm absm))
(the absm (the absm
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(absm dgop (absm dgop
(gmsm (gmsm
(funcall sintr-grin (- dmns (logcount dgop)) gmsm)))))) (funcall sintr-grin (- dmns (logcount dgop))
gmsm))))))
(DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group) (DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group)
(name (eql 'kfll))) (name (eql 'kfll)))
(declare (ignore class)) (declare (ignore class))
(the kfll (the kfll
(progn (progn
(push smgr *kan-list*) (push smgr *kan-list*)
(setf (slot-value smgr 'kfll) (smgr-kfll smgr))))) (setf (slot-value smgr 'kfll) (smgr-kfll smgr)))))
(DEFUN SMGR-KFLL-INTR (face sintr-grml sintr-grin) (DEFUN SMGR-KFLL-INTR (face sintr-grml sintr-grin)
(flet ((rslt (indx dmns hat (flet ((rslt (indx dmns hat
&aux (dmns-1 (1- dmns))) &aux (dmns-1 (1- dmns)))
(declare (declare
(fixnum indx dmns dmns-1) (fixnum indx dmns dmns-1)
(list hat)) (list hat))
(the absm (the absm
(let ((rslt (absm 0 nil))) (let ((rslt (absm 0 nil)))
(declare (type absm rslt)) (declare (type absm rslt))
(when (plusp indx) (when (plusp indx)
(setf rslt (1dgnr 0 (pop hat))) (setf rslt (1dgnr 0 (pop hat)))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((= i indx)) ((= i indx))
(declare (fixnum i)) (declare (fixnum i))
(setf rslt (setf rslt
(a-grml4 (a-grml4
@ -126,69 +133,61 @@
(a-grin4 (a-grin4
sintr-grin dmns-1 sintr-grin dmns-1
(a-face4 face (a-face4 face
i dmns rslt)) i dmns rslt))
(pop hat))))))) (pop hat)))))))
(when (< indx dmns) (when (< indx dmns)
(setf hat (reverse hat)) (setf hat (reverse hat))
(when (zerop indx) (when (zerop indx)
(setf rslt (1dgnr dmns-1 (pop hat)))) (setf rslt (1dgnr dmns-1 (pop hat))))
(do ((i (if (zerop indx) (do ((i (if (zerop indx)
dmns-1 dmns-1
dmns) dmns)
(1- i))) (1- i)))
((endp hat) rslt) ((endp hat) rslt)
(declare (declare
(type absm rslt) (type absm rslt)
(fixnum i)) (fixnum i))
(setf rslt (setf rslt
(a-grml4 (a-grml4
sintr-grml dmns sintr-grml dmns
rslt rslt
(1dgnr (1- i) (1dgnr (1- i)
(a-grml4 (a-grml4
sintr-grml dmns-1 sintr-grml dmns-1
(a-grin4 (a-grin4
sintr-grin dmns-1 sintr-grin dmns-1
(a-face4 (a-face4
face face
i dmns rslt)) i dmns rslt))
(pop hat))))))) (pop hat)))))))
rslt)))) rslt))))
(the kfll #'rslt))) (the kfll #'rslt)))
(DEFUN SMGR-KFLL (smgr) (DEFUN SMGR-KFLL (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(with-slots (face grml grin) smgr (with-slots (face grml grin) smgr
(declare (declare
(type face face) (type face face)
(type simplicial-mrph grml grin)) (type simplicial-mrph grml grin))
(smgr-kfll-intr face (sintr grml) (sintr 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) (DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group)
(name (eql 'aprd))) (name (eql 'aprd)))
(declare (ignore class)) (declare (ignore class))
(the morphism (the morphism
(progn (progn
(push smgr *hopf-list*) (push smgr *hopf-list*)
(setf (slot-value smgr 'aprd) (smgr-aprd smgr))))) (setf (slot-value smgr 'aprd) (smgr-aprd smgr)))))
(DEFUN SMGR-APRD (smgr) (DEFUN SMGR-APRD (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the morphism (the morphism
(let ((eml (eml smgr smgr)) (let ((eml (eml smgr smgr))
(grml (grml smgr))) (grml (grml smgr)))
(declare (declare
(type morphism eml) (type morphism eml)
(type simplicial-mrph grml)) (type simplicial-mrph grml))
(cmps grml eml)))) (cmps grml eml))))

15
test/simplicial-groups-test.lisp Normal file
View 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)))))
|#