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

First cl-space-efhm test extracted. This part seems to be affected by the

Browse Source 
ICMBN-P issues.
This commit is contained in:
Gerd Heber 2015-07-10 06:58:06 -05:00
parent 6a9a2f60b9
commit 89975ca8fa
6 changed files with 756 additions and 727 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
kenzo-test.asd
View File

@ -23,4 +23,5 @@
(:file "delta-test") (:file "delta-test")
(:file "bar-test") (:file "bar-test")
(:file "cartesian-products-test") (:file "cartesian-products-test")
(:file "cones-test"))) (:file "cones-test")
(:file "cl-space-efhm-test")))

6
package.lisp
View File

@ -86,6 +86,10 @@
Z-CHCM Z-CHCM
ZERO-MRPH ZERO-MRPH
;; cl-space-efhm.lisp
CS-HAT-U-T
;; classes.lisp ;; classes.lisp
ABSM ABSM
@ -101,6 +105,7 @@
F F
FACE FACE
G G
GBAR
GMSM GMSM
H H
HOMOTOPY-EQUIVALENCE HOMOTOPY-EQUIVALENCE
@ -114,6 +119,7 @@
REDUCTION REDUCTION
RRDCT RRDCT
TCC TCC
TNPR
;; combinations.lisp ;; combinations.lisp

278
src/cl-space-efhm.lisp
View File

@ -30,7 +30,9 @@
(with-tnpr (degr11 gbar11 degr12 gmsm12) tnpr1 (with-tnpr (degr11 gbar11 degr12 gmsm12) tnpr1
(let ((sign (-1-expt-n degr1)) (let ((sign (-1-expt-n degr1))
(brgn21 (first (abar-list abar2))) (brgn21 (first (abar-list abar2)))
(bar22 (make-abar :list (rest (abar-list abar2))))) (bar22 (make-abar
:list (rest (abar-list
abar2)))))
(declare (declare
(fixnum sign) (fixnum sign)
(type brgn brgn21) (type brgn brgn21)
@ -39,23 +41,42 @@
(let ((degr22 (- degr2 degr21))) (let ((degr22 (- degr2 degr21)))
(declare (fixnum degr22)) (declare (fixnum degr22))
(decf degr21) ;; = dmns(gmsm21) (decf degr21) ;; = dmns(gmsm21)
(let ((aprd (gnrt-? aprd (+ degr12 degr21) (let ((aprd
(tnpr degr12 gmsm12 degr21 gmsm21)))) (gnrt-? aprd
(+ degr12
degr21)
(tnpr degr12
gmsm12
degr21
gmsm21))))
(declare (type cmbn aprd)) (declare (type cmbn aprd))
(with-cmbn (degr12+21 list) aprd (with-cmbn (degr12+21 list)
(make-cmbn :degr (1- degr) aprd
(make-cmbn
:degr (1- degr)
:list :list
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare
(with-term (cffc gmsm) term (type term term))
(term (* sign cffc) (with-term
(tnpr (+ degr1 degr21) (cffc gmsm) term
(tnpr degr11 gbar11 degr12+21 gmsm) (term (* sign
degr22 bar22)))) cffc)
(tnpr
(+ degr1
degr21)
(tnpr
degr11
gbar11
degr12+21
gmsm)
degr22
bar22))))
list))))))))))) list)))))))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
(DEFUN CS-HAT-RIGHT-PERTURBATION (smgr (DEFUN CS-HAT-RIGHT-PERTURBATION (smgr
&aux (hat-u-u (cs-hat-u-u smgr))) &aux (hat-u-u (cs-hat-u-u smgr)))
(declare (declare
@ -70,6 +91,7 @@
:strt :gnrt :strt :gnrt
:orgn `(cs-hat-right-perturbation ,smgr)))) :orgn `(cs-hat-right-perturbation ,smgr))))
(DEFUN CS-HAT-U-T (smgr (DEFUN CS-HAT-U-T (smgr
&aux (hat-u-u (cs-hat-u-u smgr)) &aux (hat-u-u (cs-hat-u-u smgr))
(hat-right-perturbation (hat-right-perturbation
@ -85,63 +107,6 @@
;; cf lp-space-efhm.lisp ;; cf lp-space-efhm.lisp
(add hat-u-u hat-right-perturbation)))) (add hat-u-u hat-right-perturbation))))
#|
(cat-init)
(setf c (cs-hat-u-t (k-z-1)))
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(dotimes (i 5) (print (random-abar 8 4)))
(setf abar (random-abar 8 4))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(? c (+ 5 abar-degr) gnrt)
(? c *)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (? c (+ 6 abar-degr) gnrt))
(print (? c (? c (+ 6 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 11)
(print (? c (+ 4 abar-degr) gnrt))
(print (? c (? c (+ 4 abar-degr) gnrt))))))
|#
(DEFUN CS-HAT-LEFT-PERTURBATION (smgr (DEFUN CS-HAT-LEFT-PERTURBATION (smgr
&aux (fibration (smgr-fibration smgr)) &aux (fibration (smgr-fibration smgr))
@ -163,6 +128,7 @@
(slot-value rslt 'trgt) hat-u-t) (slot-value rslt 'trgt) hat-u-t)
rslt)))) rslt))))
(DEFUN CS-HAT-T-U (smgr (DEFUN CS-HAT-T-U (smgr
&aux (bar (bar smgr)) &aux (bar (bar smgr))
(fibration (smgr-fibration smgr)) (fibration (smgr-fibration smgr))
@ -181,9 +147,9 @@
rslt))) rslt)))
#| #|
(cat-init) (cat-init)
(setf c (cs-hat-t-u (k-z-1))) (setf c (cs-hat-t-u (k-z-1)))
(defun random-abar (tot-degr~ max-degr) (defun random-abar (tot-degr~ max-degr)
(do ((rslt nil) (do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1)) (cum-degr 0 (+ cum-degr degr 1))
(degr)) (degr))
@ -197,14 +163,14 @@
list) list)
list)) list))
rslt))) rslt)))
(dotimes (i 5) (print (random-abar 8 4))) (dotimes (i 5) (print (random-abar 8 4)))
(setf abar (random-abar 8 4)) (setf abar (random-abar 8 4))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar)) abar-degr abar))
(? c (+ 5 abar-degr) gnrt) (? c (+ 5 abar-degr) gnrt)
(? c *) (? c *)
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
@ -212,7 +178,7 @@
(unless (>= abar-degr 10) (unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt)) (print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt)))))) (print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6)) (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
@ -220,7 +186,7 @@
(unless (>= abar-degr 9) (unless (>= abar-degr 9)
(print (? c (+ 6 abar-degr) gnrt)) (print (? c (+ 6 abar-degr) gnrt))
(print (? c (? c (+ 6 abar-degr) gnrt)))))) (print (? c (? c (+ 6 abar-degr) gnrt))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6)) (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
@ -228,7 +194,7 @@
(unless (>= abar-degr 10) (unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt)) (print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt)))))) (print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
@ -250,9 +216,9 @@
(add hat-t-u hat-right-perturbation))) (add hat-t-u hat-right-perturbation)))
#| #|
(cat-init) (cat-init)
(setf c (cs-left-hmeq-hat (k-z-1))) (setf c (cs-left-hmeq-hat (k-z-1)))
(defun random-abar (tot-degr~ max-degr) (defun random-abar (tot-degr~ max-degr)
(do ((rslt nil) (do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1)) (cum-degr 0 (+ cum-degr degr 1))
(degr)) (degr))
@ -266,7 +232,7 @@
list) list)
list)) list))
rslt))) rslt)))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
@ -274,7 +240,7 @@
(unless (>= abar-degr 10) (unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt)) (print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt)))))) (print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6)) (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
@ -282,7 +248,7 @@
(unless (>= abar-degr 9) (unless (>= abar-degr 9)
(print (? c (+ 6 abar-degr) gnrt)) (print (? c (+ 6 abar-degr) gnrt))
(print (? c (? c (+ 6 abar-degr) gnrt)))))) (print (? c (? c (+ 6 abar-degr) gnrt))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6)) (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
@ -290,7 +256,7 @@
(unless (>= abar-degr 10) (unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt)) (print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt)))))) (print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
@ -322,7 +288,7 @@
list)))))) list))))))
#| #|
(cs-pre-left-hmeq-left-reduction-intr-f (cs-pre-left-hmeq-left-reduction-intr-f
(cmbn 6 100 (tnpr 4 (tnpr 2 'a 2 'b) 2 'c) (cmbn 6 100 (tnpr 4 (tnpr 2 'a 2 'b) 2 'c)
10 (tnpr 6 (tnpr 2 'a 4 'b) 0 'c) 10 (tnpr 6 (tnpr 2 'a 4 'b) 0 'c)
50 (tnpr 6 (tnpr 6 'a 0 'b) 0 'c) 50 (tnpr 6 (tnpr 6 'a 0 'b) 0 'c)
@ -365,8 +331,8 @@
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
#| #|
(setf g (cs-pre-left-hmeq-left-reduction-intr-g '())) (setf g (cs-pre-left-hmeq-left-reduction-intr-g '()))
(funcall g (cmbn 3 14 (gbar 3 0 'a 1 'b 0 '()))) (funcall g (cmbn 3 14 (gbar 3 0 'a 1 'b 0 '())))
|# |#
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-G (smgr (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-G (smgr
@ -444,8 +410,8 @@
:orgn `(cs-pre-left-hmeq-left-reduction ,smgr)))) :orgn `(cs-pre-left-hmeq-left-reduction ,smgr))))
#| #|
(cat-init) (cat-init)
(defun random-abar (tot-degr~ max-degr) (defun random-abar (tot-degr~ max-degr)
(do ((rslt nil) (do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1)) (cum-degr 0 (+ cum-degr degr 1))
(degr)) (degr))
@ -459,14 +425,14 @@
list) list)
list)) list))
rslt))) rslt)))
(setf rdct (cs-pre-left-hmeq-left-reduction (k-z-1))) (setf rdct (cs-pre-left-hmeq-left-reduction (k-z-1)))
(pre-check-rdct rdct) (pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+)) (setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
*bc* (cmbn 0 1 +null-gbar+)) *bc* (cmbn 0 1 +null-gbar+))
(check-rdct) (check-rdct)
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+))) (setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
(check-rdct) (check-rdct)
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
@ -476,7 +442,7 @@
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt) (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
*bc* (cmbn 2 1 gbar)) *bc* (cmbn 2 1 gbar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6)) (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
@ -486,7 +452,7 @@
(setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt) (setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
*bc* (cmbn 3 1 gbar)) *bc* (cmbn 3 1 gbar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6)) (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
@ -496,7 +462,7 @@
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)) (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
(setf *bc* (cmbn 4 1 gbar)) (setf *bc* (cmbn 4 1 gbar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
@ -535,8 +501,8 @@
#| #|
(cat-init) (cat-init)
(defun random-abar (tot-degr~ max-degr) (defun random-abar (tot-degr~ max-degr)
(do ((rslt nil) (do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1)) (cum-degr 0 (+ cum-degr degr 1))
(degr)) (degr))
@ -550,14 +516,14 @@
list) list)
list)) list))
rslt))) rslt)))
(setf rdct (cs-left-hmeq-left-reduction (k-z-1))) (setf rdct (cs-left-hmeq-left-reduction (k-z-1)))
(pre-check-rdct rdct) (pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+)) (setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
*bc* (cmbn 0 1 +null-gbar+)) *bc* (cmbn 0 1 +null-gbar+))
(check-rdct) (check-rdct)
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+))) (setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
(check-rdct) (check-rdct)
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
@ -567,7 +533,7 @@
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt) (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
*bc* (cmbn 2 1 gbar)) *bc* (cmbn 2 1 gbar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6)) (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
@ -577,7 +543,7 @@
(setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt) (setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
*bc* (cmbn 3 1 gbar)) *bc* (cmbn 3 1 gbar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6)) (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
@ -587,7 +553,7 @@
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)) (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
(setf *bc* (cmbn 4 1 gbar)) (setf *bc* (cmbn 4 1 gbar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
@ -617,7 +583,7 @@
:list (nreverse rslt)))))) :list (nreverse rslt))))))
#| #|
(cs-pre-left-hmeq-right-reduction-intr-f (cs-pre-left-hmeq-right-reduction-intr-f
(cmbn 4 2 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i) (cmbn 4 2 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i)
4 (abar 2 'a 2 'b)) 4 (abar 2 'a 2 'b))
3 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i) 3 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i)
@ -659,8 +625,8 @@
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
#| #|
(setf g (cs-pre-left-hmeq-right-reduction-intr-g 'i)) (setf g (cs-pre-left-hmeq-right-reduction-intr-g 'i))
(funcall g (cmbn 3 2 (abar 1 'a 2 'b))) (funcall g (cmbn 3 2 (abar 1 'a 2 'b)))
|# |#
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (smgr (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (smgr
@ -699,8 +665,8 @@
:orgn `(cs-pre-left-hmeq-right-reduction ,smgr)))) :orgn `(cs-pre-left-hmeq-right-reduction ,smgr))))
#| #|
(cat-init) (cat-init)
(defun random-abar (tot-degr~ max-degr) (defun random-abar (tot-degr~ max-degr)
(do ((rslt nil) (do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1)) (cum-degr 0 (+ cum-degr degr 1))
(degr)) (degr))
@ -714,14 +680,14 @@
list) list)
list)) list))
rslt))) rslt)))
(setf rdct (cs-pre-left-hmeq-right-reduction (k-z-1))) (setf rdct (cs-pre-left-hmeq-right-reduction (k-z-1)))
(pre-check-rdct rdct) (pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+)) (setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
*bc* (cmbn 0 1 +null-abar+)) *bc* (cmbn 0 1 +null-abar+))
(check-rdct) (check-rdct)
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+))) (setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
(check-rdct) (check-rdct)
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
@ -730,7 +696,7 @@
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt) (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar)) *bc* (cmbn abar-degr 1 abar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6)) (setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
@ -739,7 +705,7 @@
(setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt) (setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar)) *bc* (cmbn abar-degr 1 abar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6)) (setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
@ -748,7 +714,7 @@
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)) (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
(setf *bc* (cmbn abar-degr 1 abar)) (setf *bc* (cmbn abar-degr 1 abar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
@ -775,8 +741,8 @@
(special-bpl-2 pre-reduction perturbation)))) (special-bpl-2 pre-reduction perturbation))))
#| #|
(cat-init) (cat-init)
(defun random-abar (tot-degr~ max-degr) (defun random-abar (tot-degr~ max-degr)
(do ((rslt nil) (do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1)) (cum-degr 0 (+ cum-degr degr 1))
(degr)) (degr))
@ -790,14 +756,14 @@
list) list)
list)) list))
rslt))) rslt)))
(setf rdct (cs-left-hmeq-right-reduction (k-z-1))) (setf rdct (cs-left-hmeq-right-reduction (k-z-1)))
(pre-check-rdct rdct) (pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+)) (setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
*bc* (cmbn 0 1 +null-abar+)) *bc* (cmbn 0 1 +null-abar+))
(check-rdct) (check-rdct)
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+))) (setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
(check-rdct) (check-rdct)
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 4 2))) (let ((abar (random-abar 4 2)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 3 (tnpr 2 (gbar 2 0 '(3) 0 '()) 1 '(4)) (setf gnrt (tnpr 3 (tnpr 2 (gbar 2 0 '(3) 0 '()) 1 '(4))
@ -806,7 +772,7 @@
(setf *tc* (cmbn (+ 3 abar-degr) 1 gnrt) (setf *tc* (cmbn (+ 3 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar)) *bc* (cmbn abar-degr 1 abar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 3 1))) (let ((abar (random-abar 3 1)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(5 6)) (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(5 6))
@ -815,7 +781,7 @@
(setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt) (setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar)) *bc* (cmbn abar-degr 1 abar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 3 1))) (let ((abar (random-abar 3 1)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 1 '() 0 '()) 2 '(5 6)) (setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 1 '() 0 '()) 2 '(5 6))
@ -824,7 +790,7 @@
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)) (setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
(setf *bc* (cmbn abar-degr 1 abar)) (setf *bc* (cmbn abar-degr 1 abar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5)) (setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
@ -844,13 +810,13 @@
:orgn `(cs-left-hmeq ,smgr)))) :orgn `(cs-left-hmeq ,smgr))))
#| #|
(cat-init) (cat-init)
(setf h (cs-left-hmeq (k-z-1))) (setf h (cs-left-hmeq (k-z-1)))
(setf abar (abar 2 '(2) 3 '(3 4))) (setf abar (abar 2 '(2) 3 '(3 4)))
(rg h 5 abar) (rg h 5 abar)
(lf h *) (lf h *)
(lg h *) (lg h *)
(rf h *) (rf h *)
|# |#
(DEFUN CLASSIFYING-SPACE-EFHM (smgr) (DEFUN CLASSIFYING-SPACE-EFHM (smgr)
@ -865,11 +831,11 @@
(classifying-space-efhm (second (orgn classifying-space)))) (classifying-space-efhm (second (orgn classifying-space))))
#| #|
(cat-init) (cat-init)
(setf k (k-z-1)) (setf k (k-z-1))
(homology k 0 10) (homology k 0 10)
(setf bk (classifying-space k)) (setf bk (classifying-space k))
(homology bk 0 10) (homology bk 0 10)
(setf obk (loop-space bk)) (setf obk (loop-space bk))
(homology obk 0 6) (homology obk 0 6)
|# |#

22
test/bar-test.lisp
View File

@ -56,7 +56,7 @@
(funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7))))) (funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7)))))
(defun random-abar (length) (defun random-abar1 (length)
(let ((rslt nil)) (let ((rslt nil))
(dotimes (i length) (dotimes (i length)
(let* ((gmsm (random (cat:mask 7))) (let* ((gmsm (random (cat:mask 7)))
@ -71,9 +71,9 @@
(cat:cat-init) (cat:cat-init)
(let ((v (cat:vrtc-bar (cat:soft-delta-infinity)))) (let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
(dotimes (i 10) (dotimes (i 10)
(print (random-abar 5))) (print (random-abar1 5)))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 3))) (let ((abar (random-abar1 3)))
(print abar) (print abar)
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar))) (print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar)) abar))
@ -82,22 +82,6 @@
abar)))))))) abar))))))))
(defun random-abar1 (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (cat:brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
#| #|
(test bar-intr-hrzn-dffr (test bar-intr-hrzn-dffr
(let* ((k (cat:k-z-1)) (let* ((k (cat:k-z-1))

56
test/cl-space-efhm-test.lisp Normal file
View File

@ -0,0 +1,56 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(test cs-hat-u-t
(progn
(cat:cat-init)
(let* ((c (cat:cs-hat-u-t (cat:k-z-1)))
(abar (random-abar 8 4))
(abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
2 '(4 5))
abar-degr abar)))
(dotimes (i 5) (print (random-abar 8 4)))
#|
(cat:? c (+ 5 abar-degr) gnrt)
(cat:? c (cat:? c (+ 5 abar-degr) gnrt))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (cat:? c (+ 6 abar-degr) gnrt))
(print (cat:? c (cat:? c (+ 6 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6)) abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 11)
(print (cat:? c (+ 4 abar-degr) gnrt))
(print (cat:? c (cat:? c (+ 4 abar-degr) gnrt))))))
|#
)))

16
test/common.lisp
View File

@ -168,3 +168,19 @@
cat:*dg-gd* cat:*hg*)) cat:*dg-gd* cat:*hg*))
cat:*bc* cat:*bc*
cat:*tc*)))))) cat:*tc*))))))
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (cat:brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))