From 7093cbe4df457c1047b7c96d205cac9fbb9549c8 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Tue, 21 Jul 2015 06:58:13 -0500 Subject: [PATCH] Extracted last batch of CL-SPACE-EFHM tests. --- kenzo-test.asd | 2 +- package.lisp | 7 ++ src/cl-space-efhm.lisp | 143 +---------------------------------- test/cl-space-efhm-test.lisp | 139 ++++++++++++++++++++++++++++++++++ 4 files changed, 150 insertions(+), 141 deletions(-) diff --git a/kenzo-test.asd b/kenzo-test.asd index b51c07e..f3c1365 100644 --- a/kenzo-test.asd +++ b/kenzo-test.asd @@ -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") diff --git a/package.lisp b/package.lisp index 63a12cd..08a261b 100644 --- a/package.lisp +++ b/package.lisp @@ -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 diff --git a/src/cl-space-efhm.lisp b/src/cl-space-efhm.lisp index bb9463d..27164ef 100644 --- a/src/cl-space-efhm.lisp +++ b/src/cl-space-efhm.lisp @@ -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) -|# diff --git a/test/cl-space-efhm-test.lisp b/test/cl-space-efhm-test.lisp index 33f58d2..e9d7105 100644 --- a/test/cl-space-efhm-test.lisp +++ b/test/cl-space-efhm-test.lisp @@ -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)))