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

Extracted tests from special-smsts.lisp.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-27 18:27:45 -05:00
parent c75d7183dc
commit a1ca5821c3
4 changed files with 594 additions and 554 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -39,6 +39,7 @@
(:file "simplicial-mrphs-test") (:file "simplicial-mrphs-test")
(:file "simplicial-sets-test") (:file "simplicial-sets-test")
(:file "smith-test") (:file "smith-test")
(:file "special-smsts-test")
(:file "suspensions-test") (:file "suspensions-test")
(:file "tensor-products-test") (:file "tensor-products-test")
(:file "various-test") (:file "various-test")

9
package.lisp
View File

@ -14,6 +14,7 @@
*FH* *FH*
*HG* *HG*
*HH* *HH*
*HOMOLOGY-VERBOSE*
*ID-FG* *ID-FG*
*ID-GF-DH-HD* *ID-GF-DH-HD*
*LIST-LIST* *LIST-LIST*
@ -140,6 +141,7 @@
H H
HOMOTOPY-EQUIVALENCE HOMOTOPY-EQUIVALENCE
IABSM IABSM
IDNM
KAN KAN
LOOP-LIST LOOP-LIST
LRDCT LRDCT
@ -442,6 +444,7 @@
NDGNR NDGNR
NFACE NFACE
REMOVE-BIT REMOVE-BIT
SMST
;; smith.lisp ;; smith.lisp
@ -476,10 +479,16 @@
;; special-smsts.lisp ;; special-smsts.lisp
BUILD-FINITE-SS BUILD-FINITE-SS
FINITE-SS-PRE-TABLE
FINITE-SS-PRE-TABLE-TABLE
FINITE-SS-TABLE
GMSMS-SUBSMST
MOORE MOORE
R-PROJ-SPACE R-PROJ-SPACE
R-PROJ-SPACE-BASIS
SPHERE SPHERE
SPHERE-FACE SPHERE-FACE
SPHERE-WEDGE
;; suspensions.lisp ;; suspensions.lisp

176
src/special-smsts.lisp
View File

@ -44,24 +44,14 @@
(do ((mark2 (rest mark1) (cdr mark2))) (do ((mark2 (rest mark1) (cdr mark2)))
((endp mark2)) ((endp mark2))
(declare (list 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)) (declare (list inter))
(when inter (when inter
(error "In BUILD-FINITE-SS, the symbol ~A is present two times." (error "In BUILD-FINITE-SS, the symbol ~A is present two times."
(caar inter)))))) (caar inter))))))
pre-rslt))) 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) (DEFUN FINITE-SS-PRE-TABLE-TABLE (pre-table)
(declare (list pre-table)) (declare (list pre-table))
@ -76,10 +66,6 @@
(sort (rest item) #'string< :key #'first))) (sort (rest item) #'string< :key #'first)))
table)) 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))) (DEFUN FINITE-SS-FIND-GMSM (table gmsm dmns &optional (max-dmns (1+ dmns)))
(declare (declare
@ -93,6 +79,7 @@
(when found (when found
(return-from finite-ss-find-gmsm dmns))))) (return-from finite-ss-find-gmsm dmns)))))
(DEFUN FINITE-SS-FINISH-TABLE (table bspn) (DEFUN FINITE-SS-FINISH-TABLE (table bspn)
(declare (simple-vector table)) (declare (simple-vector table))
(dotimes (dmns (length table)) (dotimes (dmns (length table))
@ -100,6 +87,7 @@
(finite-ss-finish-line table dmns bspn)) (finite-ss-finish-line table dmns bspn))
table) table)
(DEFUN FINITE-SS-FINISH-LINE (table dmns bspn) (DEFUN FINITE-SS-FINISH-LINE (table dmns bspn)
(declare (declare
(simple-vector table) (simple-vector table)
@ -110,6 +98,7 @@
(finite-ss-finish-entry table entry dmns bspn)) (finite-ss-finish-entry table entry dmns bspn))
(svref table dmns)))) (svref table dmns))))
(DEFUN FINITE-SS-FINISH-ENTRY (table entry dmns bspn) (DEFUN FINITE-SS-FINISH-ENTRY (table entry dmns bspn)
(declare (declare
(simple-vector table) (simple-vector table)
@ -168,6 +157,7 @@
rslt)))))) rslt))))))
rslt)))) rslt))))
(DEFUN FINITE-SS-TABLE (list) (DEFUN FINITE-SS-TABLE (list)
(declare (list list)) (declare (list list))
(setf list (cons 0 list)) (setf list (cons 0 list))
@ -181,17 +171,6 @@
;; (vector (vector gmsm-faces-info)) ;; (vector (vector gmsm-faces-info))
(finite-ss-finish-table table bspn))) (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) (DEFUN FINITE-SS-BASIS (table)
(declare (simple-vector table)) (declare (simple-vector table))
@ -203,6 +182,7 @@
+empty-list+)))) +empty-list+))))
#'rslt)) #'rslt))
(DEFUN FINITE-SS-FACE (ind-smst table) (DEFUN FINITE-SS-FACE (ind-smst table)
(declare (declare
(symbol ind-smst) (symbol ind-smst)
@ -214,10 +194,12 @@
(let ((found (find gmsm (svref table dmns) :key #'car))) (let ((found (find gmsm (svref table dmns) :key #'car)))
(unless found (unless found
(error "In the finite simplicial set ~A,~@ (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)))) (svref (info-faces found) indx))))
#'rslt)) #'rslt))
(DEFUN FINITE-SS-INTR-BNDR (ind-smst table) (DEFUN FINITE-SS-INTR-BNDR (ind-smst table)
(declare (declare
(symbol ind-smst) (symbol ind-smst)
@ -233,6 +215,7 @@
(info-bndr found)))) (info-bndr found))))
#'rslt)) #'rslt))
(DEFUN BUILD-FINITE-SS (list) (DEFUN BUILD-FINITE-SS (list)
(declare (list list)) (declare (list list))
(let ((bspn (first list)) (let ((bspn (first list))
@ -251,6 +234,7 @@
:bndr-strt :gnrt :bndr-strt :gnrt
:orgn `(build-finite-ss ,list)))) :orgn `(build-finite-ss ,list))))
(setf (symbol-value ind-smst) rslt) (setf (symbol-value ind-smst) rslt)
(inspect rslt)
(unless (check-smst rslt 0 (length table)) (unless (check-smst rslt 0 (length table))
(pop *smst-list*) (pop *smst-list*)
(pop *chcm-list*) (pop *chcm-list*)
@ -258,30 +242,12 @@
(return-from build-finite-ss nil)) (return-from build-finite-ss nil))
rslt))) 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) (DEFUN SPHERE-CMPR (gmsm1 gmsm2)
(declare (ignore gmsm1 gmsm2)) (declare (ignore gmsm1 gmsm2))
(the cmpr :equal)) (the cmpr :equal))
(DEFUN SPHERE-BASIS (dmns) (DEFUN SPHERE-BASIS (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(let ((fund-gmsm (intern (format nil "S~D" dmns)))) (let ((fund-gmsm (intern (format nil "S~D" dmns))))
@ -296,6 +262,7 @@
+empty-list+)))) +empty-list+))))
(the basis #'rslt)))) (the basis #'rslt))))
(DEFUN SPHERE-FACE (dmns) (DEFUN SPHERE-FACE (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(let ((face (absm (mask (1- dmns)) '*))) (let ((face (absm (mask (1- dmns)) '*)))
@ -305,6 +272,7 @@
(the absm face))) (the absm face)))
#'rslt))) #'rslt)))
(DEFUN SPHERE (dmns) (DEFUN SPHERE (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(unless (plusp dmns) (unless (plusp dmns)
@ -326,19 +294,6 @@
`(zero-mrph ,rslt ,rslt -1)) `(zero-mrph ,rslt ,rslt -1))
rslt))) 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) (DEFUN SPHERE-WEDGE-BASIS (dmns-list)
(declare (list dmns-list)) (declare (list dmns-list))
@ -356,6 +311,7 @@
(list basis))))) (list basis)))))
(the basis #'rslt))) (the basis #'rslt)))
(DEFUN SPHERE-WEDGE-FACE (indx dmns gmsm) (DEFUN SPHERE-WEDGE-FACE (indx dmns gmsm)
(declare (declare
(ignore indx gmsm) (ignore indx gmsm)
@ -378,19 +334,12 @@
`(zero-mrph ,rslt ,rslt -1)) `(zero-mrph ,rslt ,rslt -1))
rslt))) 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) (DEFUN MOORE-CMPR (gmsm1 gmsm2)
(declare (ignore gmsm1 gmsm2)) (declare (ignore gmsm1 gmsm2))
(the cmpr :equal)) (the cmpr :equal))
(DEFUN MOORE-BASIS (dmns) (DEFUN MOORE-BASIS (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(let ((lgmsm1 (list (intern (format nil "M~D" dmns)))) (let ((lgmsm1 (list (intern (format nil "M~D" dmns))))
@ -404,6 +353,7 @@
(t +empty-list+)))) (t +empty-list+))))
(the basis #'rslt)))) (the basis #'rslt))))
(DEFUN MOORE-FACE (pii dmns) (DEFUN MOORE-FACE (pii dmns)
(declare (fixnum pii dmns)) (declare (fixnum pii dmns))
(let ((face (absm 0 (intern (format nil "M~D" dmns)))) (let ((face (absm 0 (intern (format nil "M~D" dmns))))
@ -428,6 +378,7 @@
bspn2)))))) bspn2))))))
(the face #'rslt)))) (the face #'rslt))))
(DEFUN MOORE-INTR-BNDR (pii dmns) (DEFUN MOORE-INTR-BNDR (pii dmns)
(declare (fixnum pii dmns)) (declare (fixnum pii dmns))
(let ((1+dmns (1+ dmns)) (let ((1+dmns (1+ dmns))
@ -446,6 +397,7 @@
(zero-cmbn (1- (cmbn-degr cmbn))))))) (zero-cmbn (1- (cmbn-degr cmbn)))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
(DEFUN MOORE (pii dmns) (DEFUN MOORE (pii dmns)
(declare (fixnum pii dmns)) (declare (fixnum pii dmns))
(the simplicial-set (the simplicial-set
@ -457,21 +409,12 @@
:bndr-strt :cmbn :bndr-strt :cmbn
:orgn `(moore ,pii ,dmns)))) :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) (DEFUN R-PROJ-SPACE-CMPR (gmsm1 gmsm2)
(declare (ignore gmsm1 gmsm2)) (declare (ignore gmsm1 gmsm2))
(the cmpr :equal)) (the cmpr :equal))
(DEFUN R-PROJ-SPACE-BASIS (k l) (DEFUN R-PROJ-SPACE-BASIS (k l)
(declare (fixnum k) (type (or (eql :infinity) fixnum) l)) (declare (fixnum k) (type (or (eql :infinity) fixnum) l))
(the basis (the basis
@ -489,17 +432,6 @@
(list dmns))))) (list dmns)))))
(the basis #'rslt))))) (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) (DEFUN R-PROJ-SPACE-FACE (k)
(declare (fixnum k)) (declare (fixnum k))
@ -517,6 +449,7 @@
(absm (2-exp (1- indx)) (- dmns 2))))))) (absm (2-exp (1- indx)) (- dmns 2)))))))
(the face #'rslt))) (the face #'rslt)))
(DEFUN R-PROJ-SPACE-INTR-BNDR (k) (DEFUN R-PROJ-SPACE-INTR-BNDR (k)
(declare (fixnum k)) (declare (fixnum k))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
@ -551,29 +484,6 @@
:bndr-strt :cmbn :bndr-strt :cmbn
:orgn `(R-proj-space ,k ,l)))) :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 ;;; Constructing a small simplicial subset
;;; from a combination of simplices. ;;; from a combination of simplices.
@ -586,9 +496,6 @@
;; the list of simplex generators of the combinations. ;; the list of simplex generators of the combinations.
(cons (cmbn-degr cmbn) (mapcar #'cdr (cmbn-list cmbn))))) (cons (cmbn-degr cmbn) (mapcar #'cdr (cmbn-list cmbn)))))
#|
()
|#
(DEFUN GMSMS-SUBSMST (smst gmsms (DEFUN GMSMS-SUBSMST (smst gmsms
&aux &aux
@ -647,42 +554,3 @@
(the cmbn cmbn)) (the cmbn cmbn))
:strt :cmbn :strt :cmbn
:orgn `(gmsms-subsmst-incl ,gmsms)))))))) :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
View 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)))