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

Extracted last batch of CL-SPACE-EFHM tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-21 06:58:13 -05:00
parent 3d6c2812b9
commit 7093cbe4df
4 changed files with 150 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
kenzo-test.asd
View File

@ -17,7 +17,7 @@
(:file "chain-complexes-test")
(:file "chcm-elementary-op-test")
(:file "circle")
(:file "cl-space-efhm-test")
(:file "cl-space-efhm-test")
(:file "combinations-test")
(:file "cones-test")
(:file "delta-test")

7
package.lisp
View File

@ -98,11 +98,14 @@
CS-HAT-T-U
CS-HAT-U-T
CS-LEFT-HMEQ
CS-LEFT-HMEQ-HAT
CS-LEFT-HMEQ-LEFT-REDUCTION
CS-LEFT-HMEQ-RIGHT-REDUCTION
CS-PRE-LEFT-HMEQ-LEFT-REDUCTION
CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F
CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-G
CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION
CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F
CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G
@ -296,8 +299,12 @@
GRIN
I-SBTR
KFLL
LF
LG
MASK
RBCC
RF
RG
TERM
TERM-CMBN
TCC

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

@ -410,70 +410,11 @@
:h (cs-pre-left-hmeq-right-reduction-h smgr)
:orgn `(cs-pre-left-hmeq-right-reduction ,smgr))))
#|
(cat-init)
(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)))
(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)
(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 9)
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(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))
abar-degr abar))
(unless (>= abar-degr 8)
(setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(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))
abar-degr abar))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
(setf *bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(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))
abar-degr abar))
(unless (>= abar-degr 10)
(setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
(setf *bc* (cmbn abar-degr 1 abar))
(check-rdct))))
|#
(DEFUN CS-LEFT-HMEQ-RIGHT-REDUCTION (smgr
&aux (pre-reduction
(cs-pre-left-hmeq-right-reduction smgr))
(cs-pre-left-hmeq-right-reduction
smgr))
(perturbation
(cs-hat-right-perturbation smgr)))
(declare
@ -486,66 +427,6 @@
(slot-value perturbation 'trgt) (tcc pre-reduction))
(special-bpl-2 pre-reduction perturbation))))
#|
(cat-init)
(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)))
(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)
(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))
abar-degr abar))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 3 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(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))
abar-degr abar))
(unless (>= abar-degr 8)
(setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(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))
abar-degr abar))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
(setf *bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(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))
abar-degr abar))
(unless (>= abar-degr 10)
(setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
(setf *bc* (cmbn abar-degr 1 abar))
(check-rdct))))
|#
(DEFUN CS-LEFT-HMEQ (smgr)
(declare (type simplicial-group smgr))
@ -555,15 +436,6 @@
:rrdct (cs-left-hmeq-right-reduction smgr)
: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 *)
|#
(DEFUN CLASSIFYING-SPACE-EFHM (smgr)
(declare (type simplicial-group smgr))
@ -572,16 +444,7 @@
(declare (type homotopy-equivalence left-hmeq right-hmeq))
(cmps left-hmeq right-hmeq)))
(DEFMETHOD SEARCH-EFHM (classifying-space (orgn (eql 'classifying-space)))
(declare (type simplicial-set classifying-space))
(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)
|#

139
test/cl-space-efhm-test.lisp
View File

@ -3,6 +3,7 @@
(in-suite :kenzo)
(test cs-hat-u-t
(cat:cat-init)
(let* ((c (cat:cs-hat-u-t (cat:k-z-1)))
@ -308,3 +309,141 @@
(test cs-pre-left-hmeq-right-reduction-g
(let ((g (cat:cs-pre-left-hmeq-right-reduction-intr-g 'i)))
(funcall g (cat:cmbn 3 2 (cat:abar 1 'a 2 'b)))))
(test cs-pre-left-hmeq-right-reduction
(cat:cat-init)
(let ((rdct (cat:cs-pre-left-hmeq-right-reduction (cat:k-z-1)))
abar-degr
gnrt)
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0
(cat:tnpr 0 cat:+null-gbar+
0 '())
0 cat:+null-abar+))
cat:*bc* (cat:cmbn 0 1 cat:+null-abar+))
(check-rdct)
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 1
(cat:tnpr 0 cat:+null-gbar+
1 '(13))
0 cat:+null-abar+)))
(check-rdct)
(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 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 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 8)
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 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 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 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 10)
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))))
(test cs-left-hmeq-right-reduction
(cat:cat-init)
(let ((rdct (cat:cs-left-hmeq-right-reduction (cat:k-z-1)))
abar-degr
gnrt)
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1
(cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+
0 '())
0 cat:+null-abar+))
cat:*bc* (cat:cmbn 0 1 cat:+null-abar+))
(check-rdct)
(setf cat:*tc* (cat:cmbn 1 1
(cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+
1 '(13))
0 cat:+null-abar+)))
(check-rdct)
(dotimes (i 10)
(let ((abar (random-abar 4 2)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 3 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
1 '(4))
abar-degr abar))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 3 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 3 1)))
(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 '(5 6))
abar-degr abar))
(unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 3 1)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 1 '()
0 '()) 2 '(5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 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 10)
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))))
(test cs-left-hmeq
(cat:cat-init)
(let* ((h (cat:cs-left-hmeq (cat:k-z-1)))
(abar (cat:abar 2 '(2) 3 '(3 4))))
(cat:rf h
(cat:lg h
(cat:lf h
(cat:rg h 5 abar))))))
(test classifying-space
(cat:cat-init)
(let* ((k (cat:k-z-1))
(bk (cat:classifying-space k))
(obk (cat:loop-space bk)))
(cat:homology k 0 10)
(cat:homology bk 0 10)
(cat:homology obk 0 6)))