First cl-space-efhm test extracted. This part seems to be affected by the
ICMBN-P issues.
This commit is contained in:
Gerd Heber
parent
6a9a2f60b9
commit
89975ca8fa
@ -23,4 +23,5 @@
|
||||
(:file "delta-test")
|
||||
(:file "bar-test")
|
||||
(:file "cartesian-products-test")
|
||||
(:file "cones-test")))
|
||||
(:file "cones-test")
|
||||
(:file "cl-space-efhm-test")))
|
||||
|
||||
@ -86,6 +86,10 @@
|
||||
Z-CHCM
|
||||
ZERO-MRPH
|
||||
|
||||
;; cl-space-efhm.lisp
|
||||
|
||||
CS-HAT-U-T
|
||||
|
||||
;; classes.lisp
|
||||
|
||||
ABSM
|
||||
@ -101,6 +105,7 @@
|
||||
F
|
||||
FACE
|
||||
G
|
||||
GBAR
|
||||
GMSM
|
||||
H
|
||||
HOMOTOPY-EQUIVALENCE
|
||||
@ -114,6 +119,7 @@
|
||||
REDUCTION
|
||||
RRDCT
|
||||
TCC
|
||||
TNPR
|
||||
|
||||
;; combinations.lisp
|
||||
|
||||
|
||||
@ -30,7 +30,9 @@
|
||||
(with-tnpr (degr11 gbar11 degr12 gmsm12) tnpr1
|
||||
(let ((sign (-1-expt-n degr1))
|
||||
(brgn21 (first (abar-list abar2)))
|
||||
(bar22 (make-abar :list (rest (abar-list abar2)))))
|
||||
(bar22 (make-abar
|
||||
:list (rest (abar-list
|
||||
abar2)))))
|
||||
(declare
|
||||
(fixnum sign)
|
||||
(type brgn brgn21)
|
||||
@ -39,23 +41,42 @@
|
||||
(let ((degr22 (- degr2 degr21)))
|
||||
(declare (fixnum degr22))
|
||||
(decf degr21) ;; = dmns(gmsm21)
|
||||
(let ((aprd (gnrt-? aprd (+ degr12 degr21)
|
||||
(tnpr degr12 gmsm12 degr21 gmsm21))))
|
||||
(let ((aprd
|
||||
(gnrt-? aprd
|
||||
(+ degr12
|
||||
degr21)
|
||||
(tnpr degr12
|
||||
gmsm12
|
||||
degr21
|
||||
gmsm21))))
|
||||
(declare (type cmbn aprd))
|
||||
(with-cmbn (degr12+21 list) aprd
|
||||
(make-cmbn :degr (1- degr)
|
||||
(with-cmbn (degr12+21 list)
|
||||
aprd
|
||||
(make-cmbn
|
||||
:degr (1- degr)
|
||||
:list
|
||||
(mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term (cffc gmsm) term
|
||||
(term (* sign cffc)
|
||||
(tnpr (+ degr1 degr21)
|
||||
(tnpr degr11 gbar11 degr12+21 gmsm)
|
||||
degr22 bar22))))
|
||||
(declare
|
||||
(type term term))
|
||||
(with-term
|
||||
(cffc gmsm) term
|
||||
(term (* sign
|
||||
cffc)
|
||||
(tnpr
|
||||
(+ degr1
|
||||
degr21)
|
||||
(tnpr
|
||||
degr11
|
||||
gbar11
|
||||
degr12+21
|
||||
gmsm)
|
||||
degr22
|
||||
bar22))))
|
||||
list)))))))))))
|
||||
(the intr-mrph #'rslt))))
|
||||
|
||||
|
||||
(DEFUN CS-HAT-RIGHT-PERTURBATION (smgr
|
||||
&aux (hat-u-u (cs-hat-u-u smgr)))
|
||||
(declare
|
||||
@ -70,6 +91,7 @@
|
||||
:strt :gnrt
|
||||
:orgn `(cs-hat-right-perturbation ,smgr))))
|
||||
|
||||
|
||||
(DEFUN CS-HAT-U-T (smgr
|
||||
&aux (hat-u-u (cs-hat-u-u smgr))
|
||||
(hat-right-perturbation
|
||||
@ -85,63 +107,6 @@
|
||||
;; cf lp-space-efhm.lisp
|
||||
(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
|
||||
&aux (fibration (smgr-fibration smgr))
|
||||
@ -163,6 +128,7 @@
|
||||
(slot-value rslt 'trgt) hat-u-t)
|
||||
rslt))))
|
||||
|
||||
|
||||
(DEFUN CS-HAT-T-U (smgr
|
||||
&aux (bar (bar smgr))
|
||||
(fibration (smgr-fibration smgr))
|
||||
@ -181,9 +147,9 @@
|
||||
rslt)))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf c (cs-hat-t-u (k-z-1)))
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(cat-init)
|
||||
(setf c (cs-hat-t-u (k-z-1)))
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(do ((rslt nil)
|
||||
(cum-degr 0 (+ cum-degr degr 1))
|
||||
(degr))
|
||||
@ -197,14 +163,14 @@
|
||||
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))
|
||||
(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)
|
||||
(? 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))
|
||||
@ -212,7 +178,7 @@
|
||||
(unless (>= abar-degr 10)
|
||||
(print (? c (+ 5 abar-degr) gnrt))
|
||||
(print (? c (? c (+ 5 abar-degr) gnrt))))))
|
||||
(dotimes (i 10)
|
||||
(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))
|
||||
@ -220,7 +186,7 @@
|
||||
(unless (>= abar-degr 9)
|
||||
(print (? c (+ 6 abar-degr) gnrt))
|
||||
(print (? c (? c (+ 6 abar-degr) gnrt))))))
|
||||
(dotimes (i 10)
|
||||
(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))
|
||||
@ -228,7 +194,7 @@
|
||||
(unless (>= abar-degr 10)
|
||||
(print (? c (+ 5 abar-degr) gnrt))
|
||||
(print (? c (? c (+ 5 abar-degr) gnrt))))))
|
||||
(dotimes (i 10)
|
||||
(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))
|
||||
@ -250,9 +216,9 @@
|
||||
(add hat-t-u hat-right-perturbation)))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf c (cs-left-hmeq-hat (k-z-1)))
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(cat-init)
|
||||
(setf c (cs-left-hmeq-hat (k-z-1)))
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(do ((rslt nil)
|
||||
(cum-degr 0 (+ cum-degr degr 1))
|
||||
(degr))
|
||||
@ -266,7 +232,7 @@
|
||||
list)
|
||||
list))
|
||||
rslt)))
|
||||
(dotimes (i 10)
|
||||
(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))
|
||||
@ -274,7 +240,7 @@
|
||||
(unless (>= abar-degr 10)
|
||||
(print (? c (+ 5 abar-degr) gnrt))
|
||||
(print (? c (? c (+ 5 abar-degr) gnrt))))))
|
||||
(dotimes (i 10)
|
||||
(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))
|
||||
@ -282,7 +248,7 @@
|
||||
(unless (>= abar-degr 9)
|
||||
(print (? c (+ 6 abar-degr) gnrt))
|
||||
(print (? c (? c (+ 6 abar-degr) gnrt))))))
|
||||
(dotimes (i 10)
|
||||
(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))
|
||||
@ -290,7 +256,7 @@
|
||||
(unless (>= abar-degr 10)
|
||||
(print (? c (+ 5 abar-degr) gnrt))
|
||||
(print (? c (? c (+ 5 abar-degr) gnrt))))))
|
||||
(dotimes (i 10)
|
||||
(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))
|
||||
@ -322,7 +288,7 @@
|
||||
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)
|
||||
10 (tnpr 6 (tnpr 2 'a 4 'b) 0 'c)
|
||||
50 (tnpr 6 (tnpr 6 'a 0 'b) 0 'c)
|
||||
@ -365,8 +331,8 @@
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
#|
|
||||
(setf g (cs-pre-left-hmeq-left-reduction-intr-g '()))
|
||||
(funcall g (cmbn 3 14 (gbar 3 0 'a 1 'b 0 '())))
|
||||
(setf g (cs-pre-left-hmeq-left-reduction-intr-g '()))
|
||||
(funcall g (cmbn 3 14 (gbar 3 0 'a 1 'b 0 '())))
|
||||
|#
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-G (smgr
|
||||
@ -444,8 +410,8 @@
|
||||
:orgn `(cs-pre-left-hmeq-left-reduction ,smgr))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(cat-init)
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(do ((rslt nil)
|
||||
(cum-degr 0 (+ cum-degr degr 1))
|
||||
(degr))
|
||||
@ -459,14 +425,14 @@
|
||||
list)
|
||||
list))
|
||||
rslt)))
|
||||
(setf rdct (cs-pre-left-hmeq-left-reduction (k-z-1)))
|
||||
(pre-check-rdct rdct)
|
||||
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
|
||||
(setf rdct (cs-pre-left-hmeq-left-reduction (k-z-1)))
|
||||
(pre-check-rdct rdct)
|
||||
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
|
||||
*bc* (cmbn 0 1 +null-gbar+))
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
|
||||
(check-rdct)
|
||||
(dotimes (i 10)
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
|
||||
(check-rdct)
|
||||
(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))
|
||||
@ -476,7 +442,7 @@
|
||||
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
|
||||
*bc* (cmbn 2 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 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))
|
||||
@ -486,7 +452,7 @@
|
||||
(setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
|
||||
*bc* (cmbn 3 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 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))
|
||||
@ -496,7 +462,7 @@
|
||||
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf *bc* (cmbn 4 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
|
||||
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
|
||||
@ -535,8 +501,8 @@
|
||||
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(cat-init)
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(do ((rslt nil)
|
||||
(cum-degr 0 (+ cum-degr degr 1))
|
||||
(degr))
|
||||
@ -550,14 +516,14 @@
|
||||
list)
|
||||
list))
|
||||
rslt)))
|
||||
(setf rdct (cs-left-hmeq-left-reduction (k-z-1)))
|
||||
(pre-check-rdct rdct)
|
||||
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
|
||||
(setf rdct (cs-left-hmeq-left-reduction (k-z-1)))
|
||||
(pre-check-rdct rdct)
|
||||
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
|
||||
*bc* (cmbn 0 1 +null-gbar+))
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
|
||||
(check-rdct)
|
||||
(dotimes (i 10)
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
|
||||
(check-rdct)
|
||||
(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))
|
||||
@ -567,7 +533,7 @@
|
||||
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
|
||||
*bc* (cmbn 2 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 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))
|
||||
@ -577,7 +543,7 @@
|
||||
(setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
|
||||
*bc* (cmbn 3 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 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))
|
||||
@ -587,7 +553,7 @@
|
||||
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf *bc* (cmbn 4 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
|
||||
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
|
||||
@ -617,7 +583,7 @@
|
||||
: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)
|
||||
4 (abar 2 'a 2 'b))
|
||||
3 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i)
|
||||
@ -659,8 +625,8 @@
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
#|
|
||||
(setf g (cs-pre-left-hmeq-right-reduction-intr-g 'i))
|
||||
(funcall g (cmbn 3 2 (abar 1 'a 2 'b)))
|
||||
(setf g (cs-pre-left-hmeq-right-reduction-intr-g 'i))
|
||||
(funcall g (cmbn 3 2 (abar 1 'a 2 'b)))
|
||||
|#
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (smgr
|
||||
@ -699,8 +665,8 @@
|
||||
:orgn `(cs-pre-left-hmeq-right-reduction ,smgr))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(cat-init)
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(do ((rslt nil)
|
||||
(cum-degr 0 (+ cum-degr degr 1))
|
||||
(degr))
|
||||
@ -714,14 +680,14 @@
|
||||
list)
|
||||
list))
|
||||
rslt)))
|
||||
(setf rdct (cs-pre-left-hmeq-right-reduction (k-z-1)))
|
||||
(pre-check-rdct rdct)
|
||||
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
|
||||
(setf rdct (cs-pre-left-hmeq-right-reduction (k-z-1)))
|
||||
(pre-check-rdct rdct)
|
||||
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
|
||||
*bc* (cmbn 0 1 +null-abar+))
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
|
||||
(check-rdct)
|
||||
(dotimes (i 10)
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
|
||||
(check-rdct)
|
||||
(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))
|
||||
@ -730,7 +696,7 @@
|
||||
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
|
||||
*bc* (cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 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))
|
||||
@ -739,7 +705,7 @@
|
||||
(setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
|
||||
*bc* (cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 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))
|
||||
@ -748,7 +714,7 @@
|
||||
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf *bc* (cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
|
||||
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
|
||||
@ -775,8 +741,8 @@
|
||||
(special-bpl-2 pre-reduction perturbation))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(cat-init)
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(do ((rslt nil)
|
||||
(cum-degr 0 (+ cum-degr degr 1))
|
||||
(degr))
|
||||
@ -790,14 +756,14 @@
|
||||
list)
|
||||
list))
|
||||
rslt)))
|
||||
(setf rdct (cs-left-hmeq-right-reduction (k-z-1)))
|
||||
(pre-check-rdct rdct)
|
||||
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
|
||||
(setf rdct (cs-left-hmeq-right-reduction (k-z-1)))
|
||||
(pre-check-rdct rdct)
|
||||
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
|
||||
*bc* (cmbn 0 1 +null-abar+))
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
|
||||
(check-rdct)
|
||||
(dotimes (i 10)
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
|
||||
(check-rdct)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 4 2)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
|
||||
(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)
|
||||
*bc* (cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 3 1)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
|
||||
(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)
|
||||
*bc* (cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 3 1)))
|
||||
(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))
|
||||
@ -824,7 +790,7 @@
|
||||
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf *bc* (cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
|
||||
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
|
||||
@ -844,13 +810,13 @@
|
||||
:orgn `(cs-left-hmeq ,smgr))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf h (cs-left-hmeq (k-z-1)))
|
||||
(setf abar (abar 2 '(2) 3 '(3 4)))
|
||||
(rg h 5 abar)
|
||||
(lf h *)
|
||||
(lg h *)
|
||||
(rf h *)
|
||||
(cat-init)
|
||||
(setf h (cs-left-hmeq (k-z-1)))
|
||||
(setf abar (abar 2 '(2) 3 '(3 4)))
|
||||
(rg h 5 abar)
|
||||
(lf h *)
|
||||
(lg h *)
|
||||
(rf h *)
|
||||
|#
|
||||
|
||||
(DEFUN CLASSIFYING-SPACE-EFHM (smgr)
|
||||
@ -865,11 +831,11 @@
|
||||
(classifying-space-efhm (second (orgn classifying-space))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf k (k-z-1))
|
||||
(homology k 0 10)
|
||||
(setf bk (classifying-space k))
|
||||
(homology bk 0 10)
|
||||
(setf obk (loop-space bk))
|
||||
(homology obk 0 6)
|
||||
(cat-init)
|
||||
(setf k (k-z-1))
|
||||
(homology k 0 10)
|
||||
(setf bk (classifying-space k))
|
||||
(homology bk 0 10)
|
||||
(setf obk (loop-space bk))
|
||||
(homology obk 0 6)
|
||||
|#
|
||||
|
||||
@ -56,7 +56,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))
|
||||
(dotimes (i length)
|
||||
(let* ((gmsm (random (cat:mask 7)))
|
||||
@ -71,9 +71,9 @@
|
||||
(cat:cat-init)
|
||||
(let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
|
||||
(dotimes (i 10)
|
||||
(print (random-abar 5)))
|
||||
(print (random-abar1 5)))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 3)))
|
||||
(let ((abar (random-abar1 3)))
|
||||
(print abar)
|
||||
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
|
||||
abar))
|
||||
@ -82,22 +82,6 @@
|
||||
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
|
||||
(let* ((k (cat:k-z-1))
|
||||
|
||||
56
test/cl-space-efhm-test.lisp
Normal file
56
test/cl-space-efhm-test.lisp
Normal 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))))))
|
||||
|#
|
||||
)))
|
||||
@ -168,3 +168,19 @@
|
||||
cat:*dg-gd* cat:*hg*))
|
||||
cat:*bc*
|
||||
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)))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user