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

First batch of k-pi-n tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-11 21:13:19 -05:00
parent dc99be9e18
commit c75796d4c7
4 changed files with 893 additions and 824 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
kenzo-test.asd
View File

@ -25,4 +25,6 @@
(:file "cartesian-products-test") (:file "cartesian-products-test")
(:file "cones-test") (:file "cones-test")
;;(:file "cl-space-efhm-test") ;;(:file "cl-space-efhm-test")
(:file "tensor-products-test"))) (:file "tensor-products-test")
(:file "k-pi-n-test")
))

19
package.lisp
View File

@ -206,8 +206,26 @@
;; k-pi-n.lisp ;; k-pi-n.lisp
CIRCLE
INTERESTING-FACES
GMSM-COCYCLE
K-Z K-Z
K-Z-1 K-Z-1
K-Z-1-CMPR
K-Z-1-FACE
K-Z-1-GRIN
K-Z-1-GRML
K-Z2
K-Z2-1
KZ1-RDCT
KZ1-RDCT-F-INTR
KZ1-RDCT-H-INTR
Z-ABSM-BAR
Z-BAR-ABSM
Z-FUNDAMENTAL-GMSM
Z2-ABSM-BAR
Z2-BAR-ABSM
Z-COCYCLE-GBAR
;; macros.lisp ;; macros.lisp
@ -235,6 +253,7 @@
DFFR DFFR
DGNL DGNL
GNRT GNRT
GRIN
I-SBTR I-SBTR
MASK MASK
RBCC RBCC

406
src/k-pi-n.lisp
View File

@ -17,11 +17,6 @@
(:less (return-from k-z-1-cmpr :less)) (:less (return-from k-z-1-cmpr :less))
(:greater (return-from k-z-1-cmpr :greater)))))) (:greater (return-from k-z-1-cmpr :greater))))))
#|
(k-z-1-cmpr '(1 1 2) '(1 2 2))
(k-z-1-cmpr '(1 1 2) '(1 1 2))
(k-z-1-cmpr '(1 1 2) '(1 1 -1))
|#
(DEFUN K-Z-1-FACE (indx dmns gmsm) (DEFUN K-Z-1-FACE (indx dmns gmsm)
(declare (declare
@ -37,21 +32,16 @@
((= i indx) (let ((new-k (+ (car mark) (cadr mark)))) ((= i indx) (let ((new-k (+ (car mark) (cadr mark))))
(declare (fixnum new-k)) (declare (fixnum new-k))
(if (zerop new-k) (if (zerop new-k)
(absm (2-exp (1- indx)) (nreconc rslt (cddr mark))) (absm (2-exp (1- indx))
(absm 0 (nreconc rslt (cons new-k (cddr mark))))))) (nreconc rslt (cddr mark)))
(absm 0
(nreconc rslt
(cons new-k
(cddr mark)))))))
(declare (declare
(list rslt mark) (list rslt mark)
(fixnum i))))))) (fixnum i)))))))
#|
(k-z-1-face 0 1 '(3))
(k-z-1-face 1 1 '(3))
(k-z-1-face 0 3 '(1 2 3))
(k-z-1-face 1 3 '(1 2 3))
(k-z-1-face 2 3 '(1 2 3))
(k-z-1-face 2 3 '(1 2 -2))
(k-z-1-face 3 3 '(1 2 3))
|#
(DEFUN Z-ABSM-BAR (absm) (DEFUN Z-ABSM-BAR (absm)
(declare (type absm absm)) (declare (type absm absm))
@ -68,13 +58,6 @@
(pop bar1)) (pop bar1))
rslt))))) rslt)))))
#|
(z-absm-bar (absm 0 '()))
(z-absm-bar (absm 1 '()))
(z-absm-bar (absm 0 '(2)))
(dotimes (i 8)
(print (z-absm-bar (absm i '(3 6)))))
|#
(DEFUN Z-BAR-ABSM (bar) (DEFUN Z-BAR-ABSM (bar)
(declare (list bar)) (declare (list bar))
@ -93,13 +76,6 @@
(incf rslt-dgop bark) (incf rslt-dgop bark)
(push k-i rslt-bar)))))) (push k-i rslt-bar))))))
#|
(z-bar-absm (z-absm-bar (absm 0 '())))
(z-bar-absm (z-absm-bar (absm 1 '())))
(z-bar-absm (z-absm-bar (absm 0 '(2))))
(dotimes (i 8)
(print (z-bar-absm (z-absm-bar (absm i '(3 6))))))
|#
(DEFUN K-Z-1-GRML (dmns crpr) (DEFUN K-Z-1-GRML (dmns crpr)
(declare (declare
@ -129,15 +105,6 @@
(incf rslt-dgop bark) (incf rslt-dgop bark)
(push item rslt-bar))))))) (push item rslt-bar)))))))
#|
(k-z-1-grml 0 (crpr 0 nil 0 nil))
(k-z-1-grml 1 (crpr 0 '(3) 0 '(4)))
(k-z-1-grml 1 (crpr 0 '(3) 0 '(-3)))
(k-z-1-grml 1 (crpr 0 '(3) 1 '()))
(k-z-1-grml 1 (crpr 1 '() 0 '(3)))
(k-z-1-grml 1 (crpr 1 '() 1 '()))
(k-z-1-grml 5 (crpr 24 '(2 2 3) 20 '(-2 2 4)))
|#
(DEFUN K-Z-1-GRIN (dmns bar) (DEFUN K-Z-1-GRIN (dmns bar)
(declare (declare
@ -146,11 +113,6 @@
(the absm (the absm
(absm 0 (mapcar #'- bar)))) (absm 0 (mapcar #'- bar))))
#|
(k-z-1-grin 3 '(2 3 -4))
(setf gmsm '(2 3 -4))
(k-z-1-grml 3 (crpr 0 gmsm 0 (gmsm (k-z-1-grin 3 gmsm))))
|#
#| #|
(DEFUN K-Z-1-KFLL (indx dmns hat) (DEFUN K-Z-1-KFLL (indx dmns hat)
@ -207,22 +169,6 @@
:sintr-grin #'k-z-1-grin :sintr-grin #'k-z-1-grin
:orgn '(k-z-1)))) :orgn '(k-z-1))))
#|
(setf k (k-z-1))
(defun aleat-list (max length)
(let ((rslt nil)
(2max (+ max max)))
(dotimes (i length)
(push (let ((k (- (random 2max) max)))
(if (zerop k)
max
k))
rslt))
rslt))
(? k (? k 14 (aleat-list 200 14)))
(setf zero? (add (idnt-mrph k) (grin k)))
(? zero? 14 (aleat-list 200 14))
|#
(DEFUN K-Z (n) (DEFUN K-Z (n)
(declare (fixnum n)) (declare (fixnum n))
@ -253,17 +199,12 @@
:strt :cmbn :strt :cmbn
:orgn '(circle)))) :orgn '(circle))))
#|
(setf c (circle))
(cmpr c '* '*)
(basis c 1)
(? c 1 's1)
|#
(DEFUN KZ1-RDCT-F-INTR (cmbn) (DEFUN KZ1-RDCT-F-INTR (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn
(degr list) cmbn
(case degr (case degr
(0 (if list (0 (if list
(term-cmbn 0 (-cffc list) '*) (term-cmbn 0 (-cffc list) '*)
@ -273,24 +214,15 @@
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc gnrt) term (with-term
(the fixnum (* cffc (cffc gnrt) term
(first gnrt))))) (the fixnum (* cffc (first gnrt)))))
list)))) list))))
(if (zerop rslt) (if (zerop rslt)
(zero-cmbn 1) (zero-cmbn 1)
(term-cmbn 1 rslt 's1)))) (term-cmbn 1 rslt 's1))))
(otherwise (zero-cmbn degr)))))) (otherwise (zero-cmbn degr))))))
#|
(kz1-rdct-f-intr (cmbn 0))
(kz1-rdct-f-intr (cmbn 0 4 '()))
(kz1-rdct-f-intr (cmbn 1))
(kz1-rdct-f-intr (cmbn 1 4 '(3)))
(kz1-rdct-f-intr (cmbn 1 4 '(3) 5 '(2)))
(kz1-rdct-f-intr (cmbn 1 4 '(3) -3 '(4)))
(kz1-rdct-f-intr (cmbn -3))
|#
(DEFUN KZ1-RDCT-F () (DEFUN KZ1-RDCT-F ()
(the morphism (the morphism
@ -312,6 +244,7 @@
(1 (term-cmbn 1 (-cffc list) (list 1)))) (1 (term-cmbn 1 (-cffc list) (list 1))))
(zero-cmbn degr))))) (zero-cmbn degr)))))
(DEFUN KZ1-RDCT-G () (DEFUN KZ1-RDCT-G ()
(the morphism (the morphism
(build-mrph (build-mrph
@ -322,6 +255,7 @@
:strt :cmbn :strt :cmbn
:orgn '(kz1-rdct-g)))) :orgn '(kz1-rdct-g))))
(DEFUN KZ1-RDCT-H-INTR (dmns bar) (DEFUN KZ1-RDCT-H-INTR (dmns bar)
(declare (declare
(fixnum dmns) (fixnum dmns)
@ -354,17 +288,6 @@
((< i k1) (make-cmbn :degr (1+ dmns) ((< i k1) (make-cmbn :degr (1+ dmns)
:list rslt)))))))) :list rslt))))))))
#|
(kz1-rdct-h-intr 0 nil)
(kz1-rdct-h-intr 1 '(-4))
(kz1-rdct-h-intr 1 '(-1))
(kz1-rdct-h-intr 1 '(1))
(kz1-rdct-h-intr 1 '(4))
(kz1-rdct-h-intr 3 '(-4 3 5))
(kz1-rdct-h-intr 3 '(-1 3 -1))
(kz1-rdct-h-intr 3 '(1 2 2))
(kz1-rdct-h-intr 3 '(4 3 5))
|#
(DEFUN KZ1-RDCT-H () (DEFUN KZ1-RDCT-H ()
(the morphism (the morphism
@ -376,6 +299,7 @@
:strt :gnrt :strt :gnrt
:orgn '(kz1-rdct-h)))) :orgn '(kz1-rdct-h))))
(DEFUN KZ1-RDCT () (DEFUN KZ1-RDCT ()
(the reduction (the reduction
(build-rdct (build-rdct
@ -384,20 +308,6 @@
:h (kz1-rdct-h) :h (kz1-rdct-h)
:orgn '(kz1-rdct)))) :orgn '(kz1-rdct))))
#|
(pre-check-rdct (kz1-rdct))
(setf *tc* (cmbn 0 1 '()))
(setf *bc* (cmbn 0 1 '*))
(check-rdct)
(setf *tc* (cmbn 1 1 '(-4) 10 '(-1) 100 '(1) 1000 '(5)))
(setf *bc* (cmbn 1 1 's1))
(check-rdct)
(setf *tc* (cmbn 2 1 '(-4 2) 10 '(-1 3) 100 '(1 -4) 1000 '(5 5)))
(check-rdct)
(setf *tc* (cmbn 3 1 '(-4 -4 5) 10 '(-1 2 1)
100 '(1 4 2) 1000 '(5 1 -1)))
(check-rdct)
|#
(DEFUN KZ1-EFHM () (DEFUN KZ1-EFHM ()
(the homotopy-equivalence (the homotopy-equivalence
@ -410,10 +320,6 @@
(declare (ignore k-z-1)) (declare (ignore k-z-1))
(kz1-efhm)) (kz1-efhm))
#|
(cat-init)
(homology (k-z-1) 1)
|#
(DEFUN K-Z2-1-GRML-INTR (dmns crpr) (DEFUN K-Z2-1-GRML-INTR (dmns crpr)
(declare (declare
@ -426,6 +332,7 @@
(declare (fixnum dgop)) (declare (fixnum dgop))
(absm dgop (- dmns (logcount dgop))))))) (absm dgop (- dmns (logcount dgop)))))))
(DEFUN K-Z2-1-GRML () (DEFUN K-Z2-1-GRML ()
(the simplicial-mrph (the simplicial-mrph
(build-smmr (build-smmr
@ -435,6 +342,7 @@
:sintr #'k-z2-1-grml-intr :sintr #'k-z2-1-grml-intr
:orgn '(k-z2-1-grml)))) :orgn '(k-z2-1-grml))))
(DEFUN K-Z2-1-GRIN-INTR (dmns gmsm) (DEFUN K-Z2-1-GRIN-INTR (dmns gmsm)
(declare (declare
(ignore dmns) (ignore dmns)
@ -442,6 +350,7 @@
(the absm (the absm
(absm 0 gmsm))) (absm 0 gmsm)))
(DEFUN K-Z2-1-GRIN () (DEFUN K-Z2-1-GRIN ()
(the simplicial-mrph (the simplicial-mrph
(build-smmr (build-smmr
@ -453,6 +362,7 @@
:strt :cmbn :strt :cmbn
:orgn '(k-z2-1-grin)))) :orgn '(k-z2-1-grin))))
(DEFUN K-Z2-1 () (DEFUN K-Z2-1 ()
(the ab-simplicial-group (the ab-simplicial-group
(let ((rslt (r-proj-space))) (let ((rslt (r-proj-space)))
@ -465,10 +375,6 @@
(pushnew rslt *smgr-list*) (pushnew rslt *smgr-list*)
rslt))) rslt)))
#|
(setf k (k-z2-1))
(homology k 0 4)
|#
(DEFUN K-Z2 (n) (DEFUN K-Z2 (n)
(declare (fixnum n)) (declare (fixnum n))
@ -477,10 +383,6 @@
(k-z2-1) (k-z2-1)
(classifying-space (k-z2 (1- n)))))) (classifying-space (k-z2 (1- n))))))
#|
(setf k3 (k-z2 3))
(homology k3 7)
|#
(DEFUN Z2-ABSM-BAR (absm) (DEFUN Z2-ABSM-BAR (absm)
(declare (type absm absm)) (declare (type absm absm))
@ -496,6 +398,7 @@
(fixnum bmark) (fixnum bmark)
(list rslt)))))) (list rslt))))))
(DEFUN Z2-BAR-ABSM (bar) (DEFUN Z2-BAR-ABSM (bar)
(declare (list bar)) (declare (list bar))
(the absm (the absm
@ -511,12 +414,6 @@
(incf dgop 2-pwr) (incf dgop 2-pwr)
(incf gmsm))))) (incf gmsm)))))
#|
(dotimes (i 8) ;;; not really legal
(dotimes (j 8)
(print (z2-bar-absm (z2-absm-bar (absm i j))))))
|#
(DEFUN HOPF-FIBRATION-SINTR (n) (DEFUN HOPF-FIBRATION-SINTR (n)
(declare (fixnum n)) (declare (fixnum n))
@ -527,6 +424,7 @@
(absm 0 (list n))))) (absm 0 (list n)))))
(the sintr #'rslt))) (the sintr #'rslt)))
(DEFUN HOPF-FIBRATION (n) (DEFUN HOPF-FIBRATION (n)
(declare (fixnum n)) (declare (fixnum n))
(the simplicial-mrph (the simplicial-mrph
@ -537,6 +435,7 @@
:sintr (hopf-fibration-sintr n) :sintr (hopf-fibration-sintr n)
:orgn `(hopf-fibration ,n)))) :orgn `(hopf-fibration ,n))))
(DEFUN Z-FUNDAMENTAL-GMSM (dmns pi-elm) ;;; pi-elm not equal to 0 (DEFUN Z-FUNDAMENTAL-GMSM (dmns pi-elm) ;;; pi-elm not equal to 0
(declare (fixnum dmns pi-elm)) (declare (fixnum dmns pi-elm))
(the gmsm (the gmsm
@ -545,19 +444,14 @@
(let ((bspn (if (= 2 dmns) +empty-list+ +null-gbar+))) (let ((bspn (if (= 2 dmns) +empty-list+ +null-gbar+)))
(declare (type gmsm bspn)) (declare (type gmsm bspn))
(make-gbar :dmns dmns (make-gbar :dmns dmns
:list (cons (absm 0 (z-fundamental-gmsm (1- dmns) pi-elm)) :list (cons (absm 0 (z-fundamental-gmsm (1- dmns)
pi-elm))
(mapcar (mapcar
#'(lambda (k) #'(lambda (k)
(declare (fixnum k)) (declare (fixnum k))
(absm (mask k) bspn)) (absm (mask k) bspn))
(nreverse (<a-b> 0 (- dmns 2)))))))))) (nreverse (<a-b> 0 (- dmns 2))))))))))
#|
(z-fundamental-gmsm 1 33)
(z-fundamental-gmsm 2 33)
(z-fundamental-gmsm 3 33)
(z-fundamental-gmsm 4 33)
|#
(DEFUN INTERESTING-FACES (face small-dmns high-dmns gmsm) (DEFUN INTERESTING-FACES (face small-dmns high-dmns gmsm)
(declare (declare
@ -569,7 +463,8 @@
(declare (fixnum max)) (declare (fixnum max))
(if (= small-dmns high-dmns) (if (= small-dmns high-dmns)
(list (cons max (absm 0 gmsm))) (list (cons max (absm 0 gmsm)))
(do ((prev-list (interesting-faces face (1+ small-dmns) high-dmns gmsm)) (do ((prev-list (interesting-faces face (1+ small-dmns) high-dmns
gmsm))
(k (1- max) (1- k)) (k (1- max) (1- k))
(rslt +empty-list+) (rslt +empty-list+)
(count (binomial-n-p high-dmns small-dmns))) (count (binomial-n-p high-dmns small-dmns)))
@ -584,18 +479,14 @@
(push (cons k (push (cons k
(a-face4 face (a-face4 face
(- small-dmns -1 (- small-dmns -1
(if (= i (integer-length k)) (1+ i) i)) (if (= i (integer-length k))
(1+ i)
i))
(1+ small-dmns) (1+ small-dmns)
(cdr (assoc (+ k (2-exp i)) prev-list)))) (cdr (assoc (+ k (2-exp i))
prev-list))))
rslt))))))))) rslt)))))))))
#|
(setf d (delta 14))
(setf f (face d))
(do ((i 5 (1- i)))
((minusp i))
(print (interesting-faces f i 5 (mask 6))))
|#
(DEFUN GMSM-COCYCLE (face small-dmns high-dmns gmsm chml-clss) (DEFUN GMSM-COCYCLE (face small-dmns high-dmns gmsm chml-clss)
(declare (declare
@ -615,8 +506,10 @@
(with-absm (dgop gmsm2) absm (with-absm (dgop gmsm2) absm
(if (plusp dgop) (if (plusp dgop)
0 0
(let ((cmbn-list (cmbn-list (gnrt-? chml-clss (let ((cmbn-list
small-dmns gmsm2)))) (cmbn-list (gnrt-? chml-clss
small-dmns
gmsm2))))
(declare (list cmbn-list)) (declare (list cmbn-list))
(if cmbn-list (if cmbn-list
(-cffc cmbn-list) (-cffc cmbn-list)
@ -624,24 +517,6 @@
int-faces) int-faces)
int-faces))) int-faces)))
#|
(cat-init)
(setf d (delta 10))
(setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -2
:intr #'(lambda (dmns gmsm)
(term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt
:orgn '(essai-1)))
(gmsm-cocycle (face d) 2 4 31 chml-clss)
(setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -1
:intr #'(lambda (dmns gmsm)
(term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt
:orgn '(essai-2)))
(gmsm-cocycle (face d) 1 4 31 chml-clss)
|#
(DEFUN Z-COCYCLE-GBAR (n dmns cocycle) (DEFUN Z-COCYCLE-GBAR (n dmns cocycle)
;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z ;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z
@ -683,51 +558,10 @@
(normalize-gbar (normalize-gbar
(cons dmns (cons dmns
(cons head-absm (cons head-absm
(rest (unnormalize-gbar tail-absm (rest (unnormalize-gbar
tail-absm
(if (= n 2) () +null-gbar+)))))))))))) (if (= n 2) () +null-gbar+))))))))))))
#|
(cat-init)
(setf d (delta 10))
(setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -1
:intr #'(lambda (dmns gmsm)
(term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt
:orgn '(essai-1)))
(gmsm-cocycle (face d) 1 4 31 chml-clss)
(z-cocycle-gbar 1 4 *)
(setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -2
:intr #'(lambda (dmns gmsm)
(term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt
:orgn '(essai-2)))
(gmsm-cocycle (face d) 2 2 7 chml-clss)
(z-cocycle-gbar 2 2 *)
(gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
(z-cocycle-gbar 2 2 *)
(gmsm-cocycle (face d) 2 3 15 chml-clss)
(z-cocycle-gbar 2 3 *)
(gmsm-cocycle (face d) 2 4 31 chml-clss)
(z-cocycle-gbar 2 4 *)
(setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -3
:intr #'(lambda (dmns gmsm)
(term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt
:orgn '(essai-3)))
(gmsm-cocycle (face d) 3 4 31 chml-clss)
(z-cocycle-gbar 3 4 *)
(setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -3
:intr #'(lambda (dmns gmsm)
(zero-cmbn 0))
:strt :gnrt
:orgn '(essai-33)))
(gmsm-cocycle (face d) 3 4 31 chml-clss)
(z-cocycle-gbar 3 4 *)
|#
(DEFUN Z-COCYCLE-GBAR-HEAD (n dmns cocycle) (DEFUN Z-COCYCLE-GBAR-HEAD (n dmns cocycle)
;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z ;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z
@ -737,7 +571,7 @@
(the absm (the absm
(cond ((= n 1) (cond ((= n 1)
(error "In Z-COCYCLE-GBAR-HEAD, this point should not have been reached.")) (error "In Z-COCYCLE-GBAR-HEAD, this point should not have been reached."))
; (z-bar-absm (nreverse (mapcar #'cdr cocycle)))) ;; (z-bar-absm (nreverse (mapcar #'cdr cocycle))))
((= n dmns) ((= n dmns)
(let ((value (cdr (first cocycle)))) (let ((value (cdr (first cocycle))))
(declare (fixnum value)) (declare (fixnum value))
@ -769,53 +603,53 @@
(z-cocycle-gbar (1- n) (1- dmns) cocycle2)))))) (z-cocycle-gbar (1- n) (1- dmns) cocycle2))))))
#| #|
(cat-init) (cat-init)
(setf d (delta 10)) (setf d (delta 10))
(setf chml-clss (setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -1 (build-mrph :sorc d :trgt (z-chcm) :degr -1
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(term-cmbn 0 gmsm :gnrt-z)) (term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-1))) :orgn '(essai-1)))
(gmsm-cocycle (face d) 1 4 31 chml-clss) (gmsm-cocycle (face d) 1 4 31 chml-clss)
(z-cocycle-gbar 1 4 *) (z-cocycle-gbar 1 4 *)
(z-cocycle-gbar-head 1 4 **) (z-cocycle-gbar-head 1 4 **)
(setf chml-clss (setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -2 (build-mrph :sorc d :trgt (z-chcm) :degr -2
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(term-cmbn 0 gmsm :gnrt-z)) (term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-2))) :orgn '(essai-2)))
(gmsm-cocycle (face d) 2 2 7 chml-clss) (gmsm-cocycle (face d) 2 2 7 chml-clss)
(z-cocycle-gbar 2 2 *) (z-cocycle-gbar 2 2 *)
(z-cocycle-gbar-head 2 2 **) (z-cocycle-gbar-head 2 2 **)
(gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal (gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
(z-cocycle-gbar 2 2 *) (z-cocycle-gbar 2 2 *)
(z-cocycle-gbar-head 2 2 **) (z-cocycle-gbar-head 2 2 **)
(gmsm-cocycle (face d) 2 3 15 chml-clss) (gmsm-cocycle (face d) 2 3 15 chml-clss)
(z-cocycle-gbar 2 3 *) (z-cocycle-gbar 2 3 *)
(z-cocycle-gbar-head 2 3 **) (z-cocycle-gbar-head 2 3 **)
(gmsm-cocycle (face d) 2 4 31 chml-clss) (gmsm-cocycle (face d) 2 4 31 chml-clss)
(z-cocycle-gbar 2 4 *) (z-cocycle-gbar 2 4 *)
(z-cocycle-gbar-head 2 4 **) (z-cocycle-gbar-head 2 4 **)
(setf chml-clss (setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -3 (build-mrph :sorc d :trgt (z-chcm) :degr -3
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(term-cmbn 0 gmsm :gnrt-z)) (term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-3))) :orgn '(essai-3)))
(gmsm-cocycle (face d) 3 4 31 chml-clss) (gmsm-cocycle (face d) 3 4 31 chml-clss)
(z-cocycle-gbar 3 4 *) (z-cocycle-gbar 3 4 *)
(z-cocycle-gbar-head 3 4 **) (z-cocycle-gbar-head 3 4 **)
(setf chml-clss (setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -3 (build-mrph :sorc d :trgt (z-chcm) :degr -3
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(zero-cmbn 0)) (zero-cmbn 0))
:strt :gnrt :strt :gnrt
:orgn '(essai-33))) :orgn '(essai-33)))
(gmsm-cocycle (face d) 3 4 31 chml-clss) (gmsm-cocycle (face d) 3 4 31 chml-clss)
(z-cocycle-gbar 3 4 *) (z-cocycle-gbar 3 4 *)
(z-cocycle-gbar-head 3 4 **) (z-cocycle-gbar-head 3 4 **)
|# |#
(DEFUN Z2-FUNDAMENTAL-GMSM (dmns pi-elm) ;; pi-elm not "equal" to 0, therefore 1. (DEFUN Z2-FUNDAMENTAL-GMSM (dmns pi-elm) ;; pi-elm not "equal" to 0, therefore 1.
@ -834,10 +668,10 @@
(nreverse (<a-b> 0 (- dmns 2)))))))))) (nreverse (<a-b> 0 (- dmns 2))))))))))
#| #|
(Z2-fundamental-gmsm 1 1) (Z2-fundamental-gmsm 1 1)
(Z2-fundamental-gmsm 2 1) (Z2-fundamental-gmsm 2 1)
(Z2-fundamental-gmsm 3 1) (Z2-fundamental-gmsm 3 1)
(Z2-fundamental-gmsm 4 1) (Z2-fundamental-gmsm 4 1)
|# |#
(DEFUN Z2-COCYCLE-GBAR (n dmns cocycle) (DEFUN Z2-COCYCLE-GBAR (n dmns cocycle)
@ -893,38 +727,38 @@
(if (= n 2) 0 +null-gbar+))))))))))))) (if (= n 2) 0 +null-gbar+)))))))))))))
#| #|
(cat-init) (cat-init)
(setf d (delta 10)) (setf d (delta 10))
(setf chml-clss (setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -1 (build-mrph :sorc d :trgt (z-chcm) :degr -1
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(term-cmbn 0 (mod gmsm 2) :gnrt-z)) (term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-1))) :orgn '(essai-1)))
(gmsm-cocycle (face d) 1 4 31 chml-clss) (gmsm-cocycle (face d) 1 4 31 chml-clss)
(z2-cocycle-gbar 1 4 *) (z2-cocycle-gbar 1 4 *)
(setf chml-clss (setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -2 (build-mrph :sorc d :trgt (z-chcm) :degr -2
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(term-cmbn 0 (mod gmsm 2) :gnrt-z)) (term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-2))) :orgn '(essai-2)))
(gmsm-cocycle (face d) 2 2 7 chml-clss) (gmsm-cocycle (face d) 2 2 7 chml-clss)
(z2-cocycle-gbar 2 2 *) (z2-cocycle-gbar 2 2 *)
(gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal (gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
(z2-cocycle-gbar 2 2 *) (z2-cocycle-gbar 2 2 *)
(gmsm-cocycle (face d) 2 3 15 chml-clss) (gmsm-cocycle (face d) 2 3 15 chml-clss)
(z2-cocycle-gbar 2 3 *) (z2-cocycle-gbar 2 3 *)
(gmsm-cocycle (face d) 2 4 31 chml-clss) (gmsm-cocycle (face d) 2 4 31 chml-clss)
(z2-cocycle-gbar 2 4 *) (z2-cocycle-gbar 2 4 *)
(setf chml-clss (setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -3 (build-mrph :sorc d :trgt (z-chcm) :degr -3
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(term-cmbn 0 (mod gmsm 2) :gnrt-z)) (term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-3))) :orgn '(essai-3)))
(gmsm-cocycle (face d) 3 4 31 chml-clss) (gmsm-cocycle (face d) 3 4 31 chml-clss)
(z2-cocycle-gbar 3 4 *) (z2-cocycle-gbar 3 4 *)
|# |#
(DEFUN Z2-COCYCLE-GBAR-HEAD (n dmns cocycle) (DEFUN Z2-COCYCLE-GBAR-HEAD (n dmns cocycle)
@ -975,44 +809,44 @@
(z2-cocycle-gbar (1- n) (1- dmns) cocycle2))))))) (z2-cocycle-gbar (1- n) (1- dmns) cocycle2)))))))
#| #|
(cat-init) (cat-init)
(setf d (delta 10)) (setf d (delta 10))
(setf chml-clss (setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -1 (build-mrph :sorc d :trgt (z-chcm) :degr -1
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(term-cmbn 0 (mod gmsm 2) :gnrt-z)) (term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-1))) :orgn '(essai-1)))
(gmsm-cocycle (face d) 1 4 31 chml-clss) (gmsm-cocycle (face d) 1 4 31 chml-clss)
(z2-cocycle-gbar 1 4 *) (z2-cocycle-gbar 1 4 *)
(z2-cocycle-gbar-head 1 4 **) (z2-cocycle-gbar-head 1 4 **)
(setf chml-clss (setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -2 (build-mrph :sorc d :trgt (z-chcm) :degr -2
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(term-cmbn 0 (mod gmsm 2) :gnrt-z)) (term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-2))) :orgn '(essai-2)))
(gmsm-cocycle (face d) 2 2 7 chml-clss) (gmsm-cocycle (face d) 2 2 7 chml-clss)
(z2-cocycle-gbar 2 2 *) (z2-cocycle-gbar 2 2 *)
(z2-cocycle-gbar-head 2 2 **) (z2-cocycle-gbar-head 2 2 **)
(gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal (gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
(z2-cocycle-gbar 2 2 *) (z2-cocycle-gbar 2 2 *)
(z2-cocycle-gbar-head 2 2 **) (z2-cocycle-gbar-head 2 2 **)
(gmsm-cocycle (face d) 2 3 15 chml-clss) (gmsm-cocycle (face d) 2 3 15 chml-clss)
(z2-cocycle-gbar 2 3 *) (z2-cocycle-gbar 2 3 *)
(z2-cocycle-gbar-head 2 3 **) (z2-cocycle-gbar-head 2 3 **)
(gmsm-cocycle (face d) 2 4 31 chml-clss) (gmsm-cocycle (face d) 2 4 31 chml-clss)
(z2-cocycle-gbar 2 4 *) (z2-cocycle-gbar 2 4 *)
(z2-cocycle-gbar-head 2 4 **) (z2-cocycle-gbar-head 2 4 **)
(setf chml-clss (setf chml-clss
(build-mrph :sorc d :trgt (z-chcm) :degr -3 (build-mrph :sorc d :trgt (z-chcm) :degr -3
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(term-cmbn 0 (mod gmsm 2) :gnrt-z)) (term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-3))) :orgn '(essai-3)))
(gmsm-cocycle (face d) 3 4 31 chml-clss) (gmsm-cocycle (face d) 3 4 31 chml-clss)
(z2-cocycle-gbar 3 4 *) (z2-cocycle-gbar 3 4 *)
(z2-cocycle-gbar-head 3 4 **) (z2-cocycle-gbar-head 3 4 **)
|# |#
(DEFUN K-Z-FUNDAMENTAL-CLASS (n) (DEFUN K-Z-FUNDAMENTAL-CLASS (n)
@ -1037,12 +871,12 @@
:orgn `(k-z-fundamental-class ,n)))) :orgn `(k-z-fundamental-class ,n))))
#| #|
(cat-init) (cat-init)
(setf c1 (k-z-fundamental-class 1)) (setf c1 (k-z-fundamental-class 1))
(? c1 1 '(34)) (? c1 1 '(34))
(? c1 2 '(34 45)) (? c1 2 '(34 45))
(setf c3 (k-z-fundamental-class 3)) (setf c3 (k-z-fundamental-class 3))
(? c3 3 (z-fundamental-gmsm 3 45)) (? c3 3 (z-fundamental-gmsm 3 45))
|# |#
(DEFUN K-Z2-FUNDAMENTAL-CLASS (n) (DEFUN K-Z2-FUNDAMENTAL-CLASS (n)
@ -1061,11 +895,11 @@
:orgn `(k-z2-fundamental-class ,n)))) :orgn `(k-z2-fundamental-class ,n))))
#| #|
(cat-init) (cat-init)
(setf c1 (k-z2-fundamental-class 1)) (setf c1 (k-z2-fundamental-class 1))
(? c1 1 1) (? c1 1 1)
(? c1 2 2) (? c1 2 2)
(setf c3 (k-z2-fundamental-class 3)) (setf c3 (k-z2-fundamental-class 3))
(? c3 3 (z2-fundamental-gmsm 3 1)) (? c3 3 (z2-fundamental-gmsm 3 1))
|# |#

214
test/k-pi-n-test.lisp Normal file
View File

@ -0,0 +1,214 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(test k-z-1-cmpr
(is (equal :less (cat:k-z-1-cmpr '(1 1 2) '(1 2 2))))
(is (equal :equal (cat:k-z-1-cmpr '(1 1 2) '(1 1 2))))
(is (equal :greater (cat:k-z-1-cmpr '(1 1 2) '(1 1 -1)))))
(test k-z-1-face
(cat:k-z-1-face 0 1 '(3))
(cat:k-z-1-face 1 1 '(3))
(cat:k-z-1-face 0 3 '(1 2 3))
(cat:k-z-1-face 1 3 '(1 2 3))
(cat:k-z-1-face 2 3 '(1 2 3))
(cat:k-z-1-face 2 3 '(1 2 -2))
(cat:k-z-1-face 3 3 '(1 2 3)))
(test z-absm-bar
(cat:z-absm-bar (cat:absm 0 '()))
(cat:z-absm-bar (cat:absm 1 '()))
(cat:z-absm-bar (cat:absm 0 '(2)))
(dotimes (i 8)
(print (cat:z-absm-bar (cat:absm i '(3 6))))))
(test z-bar-absm
(cat:z-bar-absm (cat:z-absm-bar (cat:absm 0 '())))
(cat:z-bar-absm (cat:z-absm-bar (cat:absm 1 '())))
(cat:z-bar-absm (cat:z-absm-bar (cat:absm 0 '(2))))
(dotimes (i 8)
(print (cat:z-bar-absm (cat:z-absm-bar (cat:absm i '(3 6)))))))
(test k-z-1-grml
(cat:k-z-1-grml 0 (cat:crpr 0 nil 0 nil))
(cat:k-z-1-grml 1 (cat:crpr 0 '(3) 0 '(4)))
(cat:k-z-1-grml 1 (cat:crpr 0 '(3) 0 '(-3)))
(cat:k-z-1-grml 1 (cat:crpr 0 '(3) 1 '()))
(cat:k-z-1-grml 1 (cat:crpr 1 '() 0 '(3)))
(cat:k-z-1-grml 1 (cat:crpr 1 '() 1 '()))
(cat:k-z-1-grml 5 (cat:crpr 24 '(2 2 3) 20 '(-2 2 4))))
(test k-z-1-grin
(cat:k-z-1-grin 3 '(2 3 -4))
(let ((gmsm '(2 3 -4)))
(cat:k-z-1-grml 3 (cat:crpr 0 gmsm 0
(cat:gmsm (cat:k-z-1-grin 3 gmsm))))))
(defun aleat-list (max length)
(let ((rslt nil)
(2max (+ max max)))
(dotimes (i length)
(push (let ((k (- (random 2max) max)))
(if (zerop k)
max
k))
rslt))
rslt))
(test k-z-1
(let ((k (cat:k-z-1))
zero?)
(cat:? k (cat:? k 14 (aleat-list 200 14)))
(setf zero? (cat:add (cat:idnt-mrph k) (cat:grin k)))
(cat:? zero? 14 (aleat-list 200 14))))
(test circle
(let ((c (cat:circle)))
(cat:cmpr c '* '*)
(cat:basis c 1)
(cat:? c 1 's1)))
(test kz1-rdct-f-intr
(cat:kz1-rdct-f-intr (cat:cmbn 0))
(cat:kz1-rdct-f-intr (cat:cmbn 0 4 '()))
(cat:kz1-rdct-f-intr (cat:cmbn 1))
(cat:kz1-rdct-f-intr (cat:cmbn 1 4 '(3)))
(cat:kz1-rdct-f-intr (cat:cmbn 1 4 '(3) 5 '(2)))
(cat:kz1-rdct-f-intr (cat:cmbn 1 4 '(3) -3 '(4)))
(cat:kz1-rdct-f-intr (cat:cmbn -3)))
(test kz1-rdct-h-intr
(cat:kz1-rdct-h-intr 0 nil)
(cat:kz1-rdct-h-intr 1 '(-4))
(cat:kz1-rdct-h-intr 1 '(-1))
(cat:kz1-rdct-h-intr 1 '(1))
(cat:kz1-rdct-h-intr 1 '(4))
(cat:kz1-rdct-h-intr 3 '(-4 3 5))
(cat:kz1-rdct-h-intr 3 '(-1 3 -1))
(cat:kz1-rdct-h-intr 3 '(1 2 2))
(cat:kz1-rdct-h-intr 3 '(4 3 5)))
(test kz1-rdct
(cat:cat-init)
(cat:pre-check-rdct (cat:kz1-rdct))
(setf cat:*tc* (cat:cmbn 0 1 '()))
(setf cat:*bc* (cat:cmbn 0 1 '*))
(check-rdct)
(setf cat:*tc* (cat:cmbn 1 1 '(-4) 10 '(-1) 100 '(1) 1000 '(5)))
(setf cat:*bc* (cat:cmbn 1 1 's1))
(check-rdct)
(setf cat:*tc* (cat:cmbn 2 1 '(-4 2) 10 '(-1 3) 100 '(1 -4) 1000 '(5 5)))
(check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 '(-4 -4 5) 10 '(-1 2 1)
100 '(1 4 2) 1000 '(5 1 -1)))
(check-rdct))
(test k-z-1-homology
(cat:cat-init)
(cat:homology (cat:k-z-1) 1))
(test k-z2-1-homology
(let ((k (cat:k-z2-1)))
(cat:homology k 0 4)))
#|
(test k-z2-homology
(let ((k3 (cat:k-z2 3)))
(cat:homology k3 7)))
|#
(test z2-bar-absm
(dotimes (i 8) ;;; not really legal
(dotimes (j 8)
(print (cat:z2-bar-absm (cat:z2-absm-bar (cat:absm i j)))))))
(test z-fundamental-gmsm
(cat:z-fundamental-gmsm 1 33)
(cat:z-fundamental-gmsm 2 33)
(cat:z-fundamental-gmsm 3 33)
(cat:z-fundamental-gmsm 4 33))
(test interesting-faces
(let* ((d (cat:delta 14))
(f (cat:face d)))
(do ((i 5 (1- i)))
((minusp i))
(print (cat:interesting-faces f i 5 (cat:mask 6))))))
(test gmsm-cocycle
(cat:cat-init)
(let* ((d (cat:delta 10))
(chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2
:intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm
:gnrt-z))
:strt :gnrt
:orgn '(essai-1))))
(cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)
(setf chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1
:intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm
:gnrt-z))
:strt :gnrt
:orgn '(essai-2)))
(cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss)))
#|
(test z-cocycle-gbar
(cat:cat-init)
(let* ((d (cat:delta 10))
(chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1
:intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm
:gnrt-z))
:strt :gnrt
:orgn '(essai-1))))
(cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss)
(cat:z-cocycle-gbar 1 4 *)
(setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2
:intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt
:orgn '(essai-2)))
(cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)
(cat:z-cocycle-gbar 2 2 *)
(cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss) ;; normally illegal
(cat:z-cocycle-gbar 2 2 *)
(cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss)
(cat:z-cocycle-gbar 2 3 *)
(cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)
(cat:z-cocycle-gbar 2 4 *)
(setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3
:intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt
:orgn '(essai-3)))
(cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)
(cat:z-cocycle-gbar 3 4 *)
(setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3
:intr #'(lambda (dmns gmsm)
(cat:zero-cmbn 0))
:strt :gnrt
:orgn '(essai-33)))
(cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)
(cat:z-cocycle-gbar 3 4 *)))
|#