Extracted tests from special-smsts.lisp.
This commit is contained in:
Gerd Heber
parent
c75d7183dc
commit
a1ca5821c3
@ -39,6 +39,7 @@
|
||||
(:file "simplicial-mrphs-test")
|
||||
(:file "simplicial-sets-test")
|
||||
(:file "smith-test")
|
||||
(:file "special-smsts-test")
|
||||
(:file "suspensions-test")
|
||||
(:file "tensor-products-test")
|
||||
(:file "various-test")
|
||||
|
||||
@ -14,6 +14,7 @@
|
||||
*FH*
|
||||
*HG*
|
||||
*HH*
|
||||
*HOMOLOGY-VERBOSE*
|
||||
*ID-FG*
|
||||
*ID-GF-DH-HD*
|
||||
*LIST-LIST*
|
||||
@ -140,6 +141,7 @@
|
||||
H
|
||||
HOMOTOPY-EQUIVALENCE
|
||||
IABSM
|
||||
IDNM
|
||||
KAN
|
||||
LOOP-LIST
|
||||
LRDCT
|
||||
@ -442,6 +444,7 @@
|
||||
NDGNR
|
||||
NFACE
|
||||
REMOVE-BIT
|
||||
SMST
|
||||
|
||||
;; smith.lisp
|
||||
|
||||
@ -476,10 +479,16 @@
|
||||
;; special-smsts.lisp
|
||||
|
||||
BUILD-FINITE-SS
|
||||
FINITE-SS-PRE-TABLE
|
||||
FINITE-SS-PRE-TABLE-TABLE
|
||||
FINITE-SS-TABLE
|
||||
GMSMS-SUBSMST
|
||||
MOORE
|
||||
R-PROJ-SPACE
|
||||
R-PROJ-SPACE-BASIS
|
||||
SPHERE
|
||||
SPHERE-FACE
|
||||
SPHERE-WEDGE
|
||||
|
||||
;; suspensions.lisp
|
||||
|
||||
|
||||
@ -44,24 +44,14 @@
|
||||
(do ((mark2 (rest mark1) (cdr mark2)))
|
||||
((endp mark2))
|
||||
(declare (list mark2))
|
||||
(let ((inter (intersection (cdar mark1) (cdar mark2) :key #'first)))
|
||||
(let ((inter (intersection (cdar mark1) (cdar mark2)
|
||||
:key #'first)))
|
||||
(declare (list inter))
|
||||
(when inter
|
||||
(error "In BUILD-FINITE-SS, the symbol ~A is present two times."
|
||||
(caar inter))))))
|
||||
pre-rslt)))
|
||||
|
||||
#|
|
||||
(setf p (finite-ss-pre-table '(0 v0 v1 v2)))
|
||||
(finite-ss-pre-table '(0 v0 v0 v2))
|
||||
(setf p (finite-ss-pre-table '(0 v0 v1 1 e0 e1 e2)))
|
||||
(finite-ss-pre-table '(0 v0 v1 1 e0 e1 v1))
|
||||
(setf p (finite-ss-pre-table '(0 v0 (v0 v0))))
|
||||
(setf p (finite-ss-pre-table '(0 v0 v1 v2 0 v3)))
|
||||
(finite-ss-pre-table '(0 v0 (v0 v0) (v1 v1)))
|
||||
(finite-ss-pre-table '(0 (v0 v0) (v1 v1)))
|
||||
(finite-ss-pre-table '(0 v0 (v0 v0) #(1 2))))
|
||||
|#
|
||||
|
||||
(DEFUN FINITE-SS-PRE-TABLE-TABLE (pre-table)
|
||||
(declare (list pre-table))
|
||||
@ -76,10 +66,6 @@
|
||||
(sort (rest item) #'string< :key #'first)))
|
||||
table))
|
||||
|
||||
#|
|
||||
(setf p (finite-ss-pre-table-table
|
||||
(finite-ss-pre-table '(2 v0 (e1 e2) v1 1 e0 e1 e2)))))
|
||||
|#
|
||||
|
||||
(DEFUN FINITE-SS-FIND-GMSM (table gmsm dmns &optional (max-dmns (1+ dmns)))
|
||||
(declare
|
||||
@ -93,6 +79,7 @@
|
||||
(when found
|
||||
(return-from finite-ss-find-gmsm dmns)))))
|
||||
|
||||
|
||||
(DEFUN FINITE-SS-FINISH-TABLE (table bspn)
|
||||
(declare (simple-vector table))
|
||||
(dotimes (dmns (length table))
|
||||
@ -100,6 +87,7 @@
|
||||
(finite-ss-finish-line table dmns bspn))
|
||||
table)
|
||||
|
||||
|
||||
(DEFUN FINITE-SS-FINISH-LINE (table dmns bspn)
|
||||
(declare
|
||||
(simple-vector table)
|
||||
@ -110,6 +98,7 @@
|
||||
(finite-ss-finish-entry table entry dmns bspn))
|
||||
(svref table dmns))))
|
||||
|
||||
|
||||
(DEFUN FINITE-SS-FINISH-ENTRY (table entry dmns bspn)
|
||||
(declare
|
||||
(simple-vector table)
|
||||
@ -168,6 +157,7 @@
|
||||
rslt))))))
|
||||
rslt))))
|
||||
|
||||
|
||||
(DEFUN FINITE-SS-TABLE (list)
|
||||
(declare (list list))
|
||||
(setf list (cons 0 list))
|
||||
@ -181,17 +171,6 @@
|
||||
;; (vector (vector gmsm-faces-info))
|
||||
(finite-ss-finish-table table bspn)))
|
||||
|
||||
#|
|
||||
(finite-ss-table '(*))
|
||||
(finite-ss-table '(a b))
|
||||
(finite-ss-table '(a b 1 c (b a)))
|
||||
(finite-ss-table '(* 2 s2 3 s3))
|
||||
(finite-ss-table '(s0 s1 s2 1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1) 2 s012 (s12 s02 s01)))
|
||||
(finite-ss-table '(* 4 s4 ((2 1 0 *))))
|
||||
(finite-ss-table '(* 4 s4 ((1 1 0 *))))
|
||||
(finite-ss-table '(* 1 s (t)))
|
||||
(finite-ss-table '(* 4 s4 ((1 0 *)))))
|
||||
|#
|
||||
|
||||
(DEFUN FINITE-SS-BASIS (table)
|
||||
(declare (simple-vector table))
|
||||
@ -203,6 +182,7 @@
|
||||
+empty-list+))))
|
||||
#'rslt))
|
||||
|
||||
|
||||
(DEFUN FINITE-SS-FACE (ind-smst table)
|
||||
(declare
|
||||
(symbol ind-smst)
|
||||
@ -214,10 +194,12 @@
|
||||
(let ((found (find gmsm (svref table dmns) :key #'car)))
|
||||
(unless found
|
||||
(error "In the finite simplicial set ~A,~@
|
||||
the simplex ~A is absent in dimension ~D." (eval ind-smst) gmsm dmns))
|
||||
the simplex ~A is absent in dimension ~D."
|
||||
(eval ind-smst) gmsm dmns))
|
||||
(svref (info-faces found) indx))))
|
||||
#'rslt))
|
||||
|
||||
|
||||
(DEFUN FINITE-SS-INTR-BNDR (ind-smst table)
|
||||
(declare
|
||||
(symbol ind-smst)
|
||||
@ -233,6 +215,7 @@
|
||||
(info-bndr found))))
|
||||
#'rslt))
|
||||
|
||||
|
||||
(DEFUN BUILD-FINITE-SS (list)
|
||||
(declare (list list))
|
||||
(let ((bspn (first list))
|
||||
@ -251,6 +234,7 @@
|
||||
:bndr-strt :gnrt
|
||||
:orgn `(build-finite-ss ,list))))
|
||||
(setf (symbol-value ind-smst) rslt)
|
||||
(inspect rslt)
|
||||
(unless (check-smst rslt 0 (length table))
|
||||
(pop *smst-list*)
|
||||
(pop *chcm-list*)
|
||||
@ -258,30 +242,12 @@
|
||||
(return-from build-finite-ss nil))
|
||||
rslt)))
|
||||
|
||||
#|
|
||||
()
|
||||
(cat-init)
|
||||
(setf tr (build-finite-ss '(s0 s1 s2
|
||||
1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
|
||||
2 s012 (s12 s02 s01))))
|
||||
(cmpr tr 's01 's02)
|
||||
(basis tr 2)
|
||||
(bspn tr)
|
||||
(face tr 1 2 's012)
|
||||
(? tr 2 's012)
|
||||
(? tr *)
|
||||
(inspect tr)
|
||||
(mapcar #'(lambda (s) (length (eval s))) *list-list*)
|
||||
(setf tr (build-finite-ss '(s0 s1 s2
|
||||
1 s01 (s1 s1) s02 (s2 s0) s12 (s2 s1)
|
||||
2 s012 (s12 s02 s01))))
|
||||
(mapcar #'(lambda (s) (length (eval s))) *list-list*))
|
||||
|#
|
||||
|
||||
(DEFUN SPHERE-CMPR (gmsm1 gmsm2)
|
||||
(declare (ignore gmsm1 gmsm2))
|
||||
(the cmpr :equal))
|
||||
|
||||
|
||||
(DEFUN SPHERE-BASIS (dmns)
|
||||
(declare (fixnum dmns))
|
||||
(let ((fund-gmsm (intern (format nil "S~D" dmns))))
|
||||
@ -296,6 +262,7 @@
|
||||
+empty-list+))))
|
||||
(the basis #'rslt))))
|
||||
|
||||
|
||||
(DEFUN SPHERE-FACE (dmns)
|
||||
(declare (fixnum dmns))
|
||||
(let ((face (absm (mask (1- dmns)) '*)))
|
||||
@ -305,6 +272,7 @@
|
||||
(the absm face)))
|
||||
#'rslt)))
|
||||
|
||||
|
||||
(DEFUN SPHERE (dmns)
|
||||
(declare (fixnum dmns))
|
||||
(unless (plusp dmns)
|
||||
@ -326,19 +294,6 @@
|
||||
`(zero-mrph ,rslt ,rslt -1))
|
||||
rslt)))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s3 (sphere 3))
|
||||
(funcall (cmpr s3) 's3 's3)
|
||||
(dotimes (i 5)
|
||||
(print (funcall (basis s3) i)))
|
||||
(mapcar #'(lambda (i) (funcall (face s3) i 3 's3)) (<a-b> 0 3))
|
||||
(? s3 3 's3)
|
||||
(smst (idnm s3))
|
||||
(chcm (idnm s3))
|
||||
(setf d (bndr s3))
|
||||
(add d d))
|
||||
|#
|
||||
|
||||
(DEFUN SPHERE-WEDGE-BASIS (dmns-list)
|
||||
(declare (list dmns-list))
|
||||
@ -356,6 +311,7 @@
|
||||
(list basis)))))
|
||||
(the basis #'rslt)))
|
||||
|
||||
|
||||
(DEFUN SPHERE-WEDGE-FACE (indx dmns gmsm)
|
||||
(declare
|
||||
(ignore indx gmsm)
|
||||
@ -378,19 +334,12 @@
|
||||
`(zero-mrph ,rslt ,rslt -1))
|
||||
rslt)))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf w (sphere-wedge 3 2 3))
|
||||
(funcall (cmpr w) 's3-1 's3-2)
|
||||
(dotimes (i 5) (print (funcall (basis w) i)))
|
||||
(funcall (face w) 2 3 's3-1)
|
||||
(gnrt-? (bndr w) 3 's3-2))
|
||||
|#
|
||||
|
||||
(DEFUN MOORE-CMPR (gmsm1 gmsm2)
|
||||
(declare (ignore gmsm1 gmsm2))
|
||||
(the cmpr :equal))
|
||||
|
||||
|
||||
(DEFUN MOORE-BASIS (dmns)
|
||||
(declare (fixnum dmns))
|
||||
(let ((lgmsm1 (list (intern (format nil "M~D" dmns))))
|
||||
@ -404,6 +353,7 @@
|
||||
(t +empty-list+))))
|
||||
(the basis #'rslt))))
|
||||
|
||||
|
||||
(DEFUN MOORE-FACE (pii dmns)
|
||||
(declare (fixnum pii dmns))
|
||||
(let ((face (absm 0 (intern (format nil "M~D" dmns))))
|
||||
@ -428,6 +378,7 @@
|
||||
bspn2))))))
|
||||
(the face #'rslt))))
|
||||
|
||||
|
||||
(DEFUN MOORE-INTR-BNDR (pii dmns)
|
||||
(declare (fixnum pii dmns))
|
||||
(let ((1+dmns (1+ dmns))
|
||||
@ -446,6 +397,7 @@
|
||||
(zero-cmbn (1- (cmbn-degr cmbn)))))))
|
||||
(the intr-mrph #'rslt))))
|
||||
|
||||
|
||||
(DEFUN MOORE (pii dmns)
|
||||
(declare (fixnum pii dmns))
|
||||
(the simplicial-set
|
||||
@ -457,21 +409,12 @@
|
||||
:bndr-strt :cmbn
|
||||
:orgn `(moore ,pii ,dmns))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf m4 (moore 2 4))
|
||||
(cmpr m4 'n5 'n5)
|
||||
(dotimes (i 7)
|
||||
(print (basis m4 i)))
|
||||
(mapcar #'(lambda (i) (face m4 i 5 'n5)) (<a-b> 0 5))
|
||||
(? m4 4 'm4)
|
||||
(? m4 5 'n5))
|
||||
|#
|
||||
|
||||
(DEFUN R-PROJ-SPACE-CMPR (gmsm1 gmsm2)
|
||||
(declare (ignore gmsm1 gmsm2))
|
||||
(the cmpr :equal))
|
||||
|
||||
|
||||
(DEFUN R-PROJ-SPACE-BASIS (k l)
|
||||
(declare (fixnum k) (type (or (eql :infinity) fixnum) l))
|
||||
(the basis
|
||||
@ -489,17 +432,6 @@
|
||||
(list dmns)))))
|
||||
(the basis #'rslt)))))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf b (r-proj-space-basis 1 :infinity))
|
||||
(dotimes (i 5) (print (funcall b i)))
|
||||
(setf b (r-proj-space-basis 1 5))
|
||||
(dotimes (i 8) (print (funcall b i)))
|
||||
(setf b (r-proj-space-basis 3 :infinity))
|
||||
(dotimes (i 5) (print (funcall b i)))
|
||||
(setf b (r-proj-space-basis 3 6))
|
||||
(dotimes (i 10) (print (funcall b i)))
|
||||
|#
|
||||
|
||||
(DEFUN R-PROJ-SPACE-FACE (k)
|
||||
(declare (fixnum k))
|
||||
@ -517,6 +449,7 @@
|
||||
(absm (2-exp (1- indx)) (- dmns 2)))))))
|
||||
(the face #'rslt)))
|
||||
|
||||
|
||||
(DEFUN R-PROJ-SPACE-INTR-BNDR (k)
|
||||
(declare (fixnum k))
|
||||
(flet ((rslt (cmbn)
|
||||
@ -551,29 +484,6 @@
|
||||
:bndr-strt :cmbn
|
||||
:orgn `(R-proj-space ,k ,l))))
|
||||
|
||||
#|
|
||||
()
|
||||
(cat-init)
|
||||
(setf p (R-proj-space))
|
||||
(basis p 4)
|
||||
(dotimes (i 5)
|
||||
(print (face p i 4 4)))
|
||||
(dotimes (i 5)
|
||||
(print (? p i i)))
|
||||
(setf dd (cmps p p))
|
||||
(dotimes (i 6)
|
||||
(print (? dd i i)))
|
||||
(setf p (R-proj-space 3))
|
||||
(dotimes (i 7)
|
||||
(print (basis p i)))
|
||||
(dotimes (i 5)
|
||||
(print (face p i 4 4)))
|
||||
(dotimes (i 7)
|
||||
(print (? p i i)))
|
||||
(setf dd (cmps p p))
|
||||
(dotimes (i 7)
|
||||
(print (? dd i i)))
|
||||
|#
|
||||
|
||||
;;; Constructing a small simplicial subset
|
||||
;;; from a combination of simplices.
|
||||
@ -586,9 +496,6 @@
|
||||
;; the list of simplex generators of the combinations.
|
||||
(cons (cmbn-degr cmbn) (mapcar #'cdr (cmbn-list cmbn)))))
|
||||
|
||||
#|
|
||||
()
|
||||
|#
|
||||
|
||||
(DEFUN GMSMS-SUBSMST (smst gmsms
|
||||
&aux
|
||||
@ -647,42 +554,3 @@
|
||||
(the cmbn cmbn))
|
||||
:strt :cmbn
|
||||
:orgn `(gmsms-subsmst-incl ,gmsms))))))))
|
||||
|
||||
|
||||
|
||||
#|
|
||||
()
|
||||
(cat-init)
|
||||
(setf k (k-z 2))
|
||||
(setf efhm (efhm k))
|
||||
(setf *homology-verbose* nil)
|
||||
(chcm-homology-gen (rbcc efhm) 4)
|
||||
(setf g (first *))
|
||||
(setf cmbn (lf efhm (rg efhm g)))
|
||||
(multiple-value-setq (kf incl) (gmsms-subsmst k cmbn))
|
||||
(setf cone (cone incl))
|
||||
(efhm cone)
|
||||
(homology kf 0 5)
|
||||
(homology (cone incl) 0 6)
|
||||
|
||||
(chcm-homology-gen (rbcc efhm) 8)
|
||||
(setf g (first *))
|
||||
(setf cmbn (lf efhm (rg efhm g)))
|
||||
(multiple-value-setq (kf incl) (gmsms-subsmst k cmbn))
|
||||
(setf cone (cone incl))
|
||||
(efhm cone)
|
||||
(homology kf 0 9)
|
||||
(homology (cone incl) 0 10)
|
||||
(dotimes (i 9) (print (length (basis kf i))))
|
||||
|
||||
()
|
||||
(setf s2 (sphere 2))
|
||||
(setf cl2 (chml-clss s2 2))
|
||||
(setf f2 (z-whitehead s2 cl2))
|
||||
(setf s3 (fibration-total f2))
|
||||
(setf efhm (efhm s3))
|
||||
(basis (rbcc efhm) 3)
|
||||
(setf cmbn (lf efhm (rg efhm 3 (first (basis (rbcc efhm) 3)))))
|
||||
(setf kf (gmsms-subsmst s3 cmbn))
|
||||
(homology kf 0 4)
|
||||
|#
|
||||
|
||||
162
test/special-smsts-test.lisp
Normal file
162
test/special-smsts-test.lisp
Normal file
@ -0,0 +1,162 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
(test finite-ss-pre-table
|
||||
(let ((p (cat:finite-ss-pre-table '(0 v0 v1 v2))))
|
||||
(signals simple-error (cat:finite-ss-pre-table '(0 v0 v0 v2)))
|
||||
(setf p (cat:finite-ss-pre-table '(0 v0 v1 1 e0 e1 e2)))
|
||||
(signals simple-error (cat:finite-ss-pre-table '(0 v0 v1 1 e0 e1 v1)))
|
||||
(setf p (cat:finite-ss-pre-table '(0 v0 (v0 v0))))
|
||||
(setf p (cat:finite-ss-pre-table '(0 v0 v1 v2 0 v3)))
|
||||
(signals simple-error (cat:finite-ss-pre-table '(0 v0 (v0 v0)
|
||||
(v1 v1))))
|
||||
(signals simple-error (cat:finite-ss-pre-table '(0 (v0 v0) (v1 v1))))
|
||||
(signals simple-error (cat:finite-ss-pre-table '(0 v0 (v0 v0)
|
||||
#(1 2))))))
|
||||
|
||||
|
||||
(test finite-ss-pre-table-table
|
||||
(let ((p (cat:finite-ss-pre-table-table
|
||||
(cat:finite-ss-pre-table '(2 v0 (e1 e2) v1 1 e0 e1 e2)))))))
|
||||
|
||||
|
||||
(test finite-ss-table
|
||||
(cat:finite-ss-table '(*))
|
||||
(cat:finite-ss-table '(a b))
|
||||
(cat:finite-ss-table '(a b 1 c (b a)))
|
||||
(cat:finite-ss-table '(* 2 s2 3 s3))
|
||||
(cat:finite-ss-table '(s0 s1 s2 1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
|
||||
2 s012 (s12 s02 s01)))
|
||||
(cat:finite-ss-table '(* 4 s4 ((2 1 0 *))))
|
||||
(signals simple-error (cat:finite-ss-table '(* 4 s4 ((1 1 0 *)))))
|
||||
(signals simple-error (cat:finite-ss-table '(* 1 s (t))))
|
||||
(signals simple-error (cat:finite-ss-table '(* 4 s4 ((1 0 *))))))
|
||||
|
||||
|
||||
#|
|
||||
TR is NIL. Why?
|
||||
|
||||
(test build-finite-ss
|
||||
(cat:cat-init)
|
||||
(let (tr (cat:build-finite-ss '(s0 s1 s2
|
||||
1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
|
||||
2 s012 (s12 s02 s01))))
|
||||
(cat:cmpr tr 's01 's02)
|
||||
(cat:basis tr 2)
|
||||
(cat:bspn tr)
|
||||
(cat:face tr 1 2 's012)
|
||||
(cat:? tr 2 's012)
|
||||
(cat:? tr (cat:? tr 2 's012))
|
||||
(mapcar #'(lambda (s) (length (eval s))) cat:*list-list*)
|
||||
(setf tr (cat:build-finite-ss '(s0 s1 s2
|
||||
1 s01 (s1 s1) s02 (s2 s0) s12 (s2 s1)
|
||||
2 s012 (s12 s02 s01))))
|
||||
(mapcar #'(lambda (s) (length (eval s))) cat:*list-list*)))
|
||||
|#
|
||||
|
||||
(test sphere
|
||||
(cat:cat-init)
|
||||
(let ((s3 (cat:sphere 3))
|
||||
d)
|
||||
(funcall (cat:cmpr s3) 's3 's3)
|
||||
(dotimes (i 5)
|
||||
(print (funcall (cat:basis s3) i)))
|
||||
(mapcar #'(lambda (i) (funcall (cat:face s3) i 3 's3)) (cat:<a-b> 0 3))
|
||||
(cat:? s3 3 's3)
|
||||
(cat:smst (cat:idnm s3))
|
||||
(cat:chcm (cat:idnm s3))
|
||||
(setf d (cat:bndr s3))
|
||||
(cat:add d d)))
|
||||
|
||||
|
||||
(test sphere-wedge
|
||||
(cat:cat-init)
|
||||
(let ((w (cat:sphere-wedge 3 2 3)))
|
||||
(funcall (cat:cmpr w) 's3-1 's3-2)
|
||||
(dotimes (i 5) (print (funcall (cat:basis w) i)))
|
||||
(funcall (cat:face w) 2 3 's3-1)
|
||||
(cat:gnrt-? (cat:bndr w) 3 's3-2)))
|
||||
|
||||
|
||||
(test moore
|
||||
(cat:cat-init)
|
||||
(let ((m4 (cat:moore 2 4)))
|
||||
(cat:cmpr m4 'n5 'n5)
|
||||
(dotimes (i 7)
|
||||
(print (cat:basis m4 i)))
|
||||
(mapcar #'(lambda (i) (cat:face m4 i 5 'n5)) (cat:<a-b> 0 5))
|
||||
(cat:? m4 4 'm4)
|
||||
(cat:? m4 5 'n5)))
|
||||
|
||||
|
||||
(test r-proj-space-basis
|
||||
(let ((b (cat:r-proj-space-basis 1 :infinity)))
|
||||
(dotimes (i 5) (print (funcall b i)))
|
||||
(setf b (cat:r-proj-space-basis 1 5))
|
||||
(dotimes (i 8) (print (funcall b i)))
|
||||
(setf b (cat:r-proj-space-basis 3 :infinity))
|
||||
(dotimes (i 5) (print (funcall b i)))
|
||||
(setf b (cat:r-proj-space-basis 3 6))
|
||||
(dotimes (i 10) (print (funcall b i)))))
|
||||
|
||||
|
||||
(test R-proj-space
|
||||
(cat:cat-init)
|
||||
(let ((p (cat:R-proj-space)))
|
||||
(cat:basis p 4)
|
||||
(dotimes (i 5)
|
||||
(print (cat:face p i 4 4)))
|
||||
(dotimes (i 5)
|
||||
(print (cat:? p i i)))
|
||||
(setf dd (cat:cmps p p))
|
||||
(dotimes (i 6)
|
||||
(print (cat:? dd i i)))
|
||||
(setf p (cat:R-proj-space 3))
|
||||
(dotimes (i 7)
|
||||
(print (cat:basis p i)))
|
||||
(dotimes (i 5)
|
||||
(print (cat:face p i 4 4)))
|
||||
(dotimes (i 7)
|
||||
(print (cat:? p i i)))
|
||||
(setf dd (cat:cmps p p))
|
||||
(dotimes (i 7)
|
||||
(print (cat:? dd i i)))))
|
||||
|
||||
|
||||
(test gmsms-subsmst
|
||||
(cat:cat-init)
|
||||
(let* ((k (cat:k-z 2))
|
||||
(efhm (cat:efhm k))
|
||||
g cmbn kf incl cone s2 cl2 f2 s3
|
||||
|
||||
)
|
||||
(setf cat:*homology-verbose* nil)
|
||||
(setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 4)))
|
||||
(setf cmbn (cat:lf efhm (cat:rg efhm g)))
|
||||
(multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn))
|
||||
(setf cone (cat:cone incl))
|
||||
(cat:efhm cone)
|
||||
(cat:homology kf 0 5)
|
||||
(cat:homology (cat:cone incl) 0 6)
|
||||
|
||||
(setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 8)))
|
||||
(setf cmbn (cat:lf efhm (cat:rg efhm g)))
|
||||
(multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn))
|
||||
(setf cone (cat:cone incl))
|
||||
(cat:efhm cone)
|
||||
(cat:homology kf 0 9)
|
||||
(cat:homology (cat:cone incl) 0 10)
|
||||
(dotimes (i 9) (print (length (cat:basis kf i))))
|
||||
|
||||
(setf s2 (cat:sphere 2))
|
||||
(setf cl2 (cat:chml-clss s2 2))
|
||||
(setf f2 (cat:z-whitehead s2 cl2))
|
||||
(setf s3 (cat:fibration-total f2))
|
||||
(setf efhm (cat:efhm s3))
|
||||
(cat:basis (cat:rbcc efhm) 3)
|
||||
(setf cmbn (cat:lf efhm (cat:rg efhm 3 (first (cat:basis
|
||||
(cat:rbcc efhm) 3)))))
|
||||
(setf kf (cat:gmsms-subsmst s3 cmbn))
|
||||
(cat:homology kf 0 4)))
|
||||
Loading…
Reference in New Issue
Block a user