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))
|
||||
|
||||
@ -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