Extracted tests from smith.lisp.
This commit is contained in:
Gerd Heber
parent
3d3b44b5a4
commit
9eece57056
@ -38,6 +38,7 @@
|
||||
(:file "simplicial-groups-test")
|
||||
(:file "simplicial-mrphs-test")
|
||||
(:file "simplicial-sets-test")
|
||||
(:file "smith-test")
|
||||
(:file "suspensions-test")
|
||||
(:file "tensor-products-test")
|
||||
(:file "various-test")
|
||||
|
||||
33
package.lisp
33
package.lisp
@ -372,6 +372,9 @@
|
||||
CMBN-NON-ZERO-P
|
||||
CMBN-ZERO-P
|
||||
CMPR
|
||||
COLUMN-MINUS-5
|
||||
COLUMN-OP-5
|
||||
COLUMN-SWAP-5
|
||||
CON0
|
||||
CON1
|
||||
CPRD
|
||||
@ -382,12 +385,16 @@
|
||||
DGNL
|
||||
GMSM1
|
||||
GNRT
|
||||
GNRT-NAME
|
||||
GRIN
|
||||
GRML
|
||||
I-SBTR
|
||||
KFLL
|
||||
LF
|
||||
LG
|
||||
LINE-MINUS-5
|
||||
LINE-OP-5
|
||||
LINE-SWAP-5
|
||||
MASK
|
||||
MAKE-GBAR
|
||||
RBCC
|
||||
@ -438,7 +445,33 @@
|
||||
|
||||
;; smith.lisp
|
||||
|
||||
CHCM-MTRX
|
||||
CHML-CLSS
|
||||
CHML-CLSS-INTR
|
||||
COLUMN-MINUS
|
||||
COLUMN-OP
|
||||
COLUMN-SWAP
|
||||
COPY-MTRX
|
||||
ECHCM-KILL-EPI
|
||||
ECHCM-KILL-EPI-F-INTR
|
||||
ECHCM-KILL-EPI-G-INTR
|
||||
ECHCM-KILL-EPI-H-INTR
|
||||
GNRT-NAME-BASIS
|
||||
IDNT-MTRX
|
||||
KILL-EPI
|
||||
KILL-EPIS
|
||||
LEFT-SUBMATRIX
|
||||
LINE-MINUS
|
||||
LINE-OP
|
||||
LINE-SWAP
|
||||
LIST-SMITH
|
||||
MINIMAL-REST-1
|
||||
MINIMAL-REST-2
|
||||
MINIMAL-TERM
|
||||
MINIMAL-TERM-TOP-LEFT
|
||||
MTRX-PRDC
|
||||
PIVOTT
|
||||
RANDOM-MATRIX
|
||||
|
||||
;; special-smsts.lisp
|
||||
|
||||
|
||||
378
src/smith.lisp
378
src/smith.lisp
@ -26,9 +26,6 @@
|
||||
(- (random 2max+1) max))))
|
||||
rslt)))
|
||||
|
||||
#|
|
||||
(random-matrix 2 3 10)
|
||||
|#
|
||||
|
||||
(DEFUN IDNT-MTRX (n)
|
||||
(declare (fixnum n))
|
||||
@ -45,10 +42,6 @@
|
||||
(setf (aref rslt i i) 1))
|
||||
rslt)))
|
||||
|
||||
#|
|
||||
()
|
||||
(idnt-mtrx 3)
|
||||
|#
|
||||
|
||||
(DEFUN COPY-MTRX (mtrx)
|
||||
(declare (type matrix mtrx))
|
||||
@ -66,10 +59,6 @@
|
||||
(setf (aref rslt il ic) (aref mtrx il ic))))
|
||||
rslt))))
|
||||
|
||||
#|
|
||||
(setf m (random-matrix 3 4 10))
|
||||
(equalp m (copy-mtrx m))
|
||||
|#
|
||||
|
||||
(DEFUN LEFT-SUBMATRIX (mtrx k)
|
||||
(declare (type matrix mtrx))
|
||||
@ -88,10 +77,6 @@
|
||||
(setf (aref rslt il ic) (aref mtrx il ic))))
|
||||
rslt))))
|
||||
|
||||
#|
|
||||
(setf m (random-matrix 3 4 10))
|
||||
(left-submatrix m 2)
|
||||
|#
|
||||
|
||||
(DEFUN MTRX-PRDC (mtrx1 mtrx2)
|
||||
(declare (type matrix mtrx1 mtrx2))
|
||||
@ -117,12 +102,6 @@
|
||||
((= k mtrx1-column-n) (setf (aref rslt il ic) sum)))))
|
||||
rslt))))
|
||||
|
||||
#|
|
||||
(setf m1 (random-matrix 2 3 10))
|
||||
(setf m2 (random-matrix 3 2 10))
|
||||
(mtrx-prdc m1 m2)
|
||||
(mtrx-prdc m2 m1)
|
||||
|#
|
||||
|
||||
(DEFUN CHCM-MTRX (chcm degr)
|
||||
(declare
|
||||
@ -159,7 +138,8 @@
|
||||
(declare
|
||||
(list mark1 mark2)
|
||||
(fixnum i))
|
||||
(with--term (cffc gnrt) mark1
|
||||
(with--term
|
||||
(cffc gnrt) mark1
|
||||
(loop
|
||||
(cond ((eq :equal (funcall cmpr gnrt (car mark2)))
|
||||
(setf (aref rslt i j) cffc)
|
||||
@ -170,16 +150,6 @@
|
||||
(pop mark2))))))))
|
||||
rslt)))))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf d (delta 5))
|
||||
(chcm-mtrx d 3)
|
||||
(setf m (moore 2 2))
|
||||
(dotimes (i 5)
|
||||
(print (chcm-mtrx m i)))
|
||||
(dotimes (i 6)
|
||||
(print (array-dimensions (chcm-mtrx m i))))
|
||||
|#
|
||||
|
||||
(DEFUN LINE-OP (mtrx begin lambda line1 line2)
|
||||
;; line2 := line2 + lambda * line1
|
||||
@ -196,23 +166,6 @@
|
||||
(* lambda (aref mtrx line1 j))))
|
||||
mtrx)))
|
||||
|
||||
#|
|
||||
(setf m (random-matrix 3 4 10))
|
||||
(line-op m 1 3 2 0)
|
||||
|#
|
||||
|
||||
;; mtrx-list = (P P^-1 M Q Q^-1)
|
||||
|
||||
#|
|
||||
(setf p (idnt-mtrx 4) p-1 (idnt-mtrx 4)
|
||||
m (random-matrix 4 5 10)
|
||||
q (idnt-mtrx 5) q-1 (idnt-mtrx 5))
|
||||
(setf list (list p p-1 m q q-1))
|
||||
(setf t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(line-op-5 list 0 3 1 3)
|
||||
(equalp t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(mtrx-prdc p p-1)
|
||||
|#
|
||||
|
||||
(DEFUN COLUMN-OP (mtrx begin lambda column1 column2)
|
||||
(declare
|
||||
@ -228,23 +181,6 @@
|
||||
(* lambda (aref mtrx i column1))))
|
||||
mtrx)))
|
||||
|
||||
#|
|
||||
(setf m (random-matrix 3 4 10))
|
||||
(column-op m 1 3 2 0)
|
||||
|#
|
||||
|
||||
#|
|
||||
(setf p (idnt-mtrx 4) p-1 (idnt-mtrx 4)
|
||||
m (random-matrix 4 5 10)
|
||||
q (idnt-mtrx 5) q-1 (idnt-mtrx 5))
|
||||
(setf list (list p p-1 m q q-1))
|
||||
(setf t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(column-op-5 list 0 3 1 3)
|
||||
(equalp t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(mtrx-prdc p p-1)
|
||||
(mtrx-prdc q q-1)
|
||||
|#
|
||||
|
||||
|
||||
(DEFUN LINE-SWAP (mtrx begin line1 line2)
|
||||
(declare
|
||||
@ -259,22 +195,6 @@
|
||||
(rotatef (aref mtrx line1 j) (aref mtrx line2 j)))
|
||||
mtrx)))
|
||||
|
||||
#|
|
||||
(setf m (random-matrix 3 4 10))
|
||||
(line-swap m 1 0 2)
|
||||
|#
|
||||
|
||||
#|
|
||||
(setf p (idnt-mtrx 4) p-1 (idnt-mtrx 4)
|
||||
m (random-matrix 4 5 10)
|
||||
q (idnt-mtrx 5) q-1 (idnt-mtrx 5))
|
||||
(setf list (list p p-1 m q q-1))
|
||||
(setf t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(line-swap-5 list 0 1 3)
|
||||
(equalp t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(mtrx-prdc p p-1)
|
||||
(mtrx-prdc q q-1)
|
||||
|#
|
||||
|
||||
(DEFUN COLUMN-SWAP (mtrx begin column1 column2)
|
||||
(declare
|
||||
@ -288,22 +208,6 @@
|
||||
(rotatef (aref mtrx i column1) (aref mtrx i column2)))
|
||||
mtrx)))
|
||||
|
||||
#|
|
||||
(setf m (random-matrix 3 4 10))
|
||||
(column-swap m 1 0 2)
|
||||
|#
|
||||
|
||||
#|
|
||||
(setf p (idnt-mtrx 4) p-1 (idnt-mtrx 4)
|
||||
m (random-matrix 4 5 10)
|
||||
q (idnt-mtrx 5) q-1 (idnt-mtrx 5))
|
||||
(setf list (list p p-1 m q q-1))
|
||||
(setf t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(column-swap-5 list 0 1 3)
|
||||
(equalp t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(mtrx-prdc p p-1)
|
||||
(mtrx-prdc q q-1)
|
||||
|#
|
||||
|
||||
(DEFUN LINE-MINUS (mtrx begin line)
|
||||
(declare
|
||||
@ -329,27 +233,6 @@
|
||||
(setf (aref mtrx i column) (- (aref mtrx i column))))
|
||||
mtrx)))
|
||||
|
||||
#|
|
||||
(setf m (random-matrix 3 4 10))
|
||||
(line-minus m 1 2)
|
||||
(column-minus m 1 2)
|
||||
|#
|
||||
|
||||
#|
|
||||
(setf p (idnt-mtrx 4) p-1 (idnt-mtrx 4)
|
||||
m (random-matrix 4 5 10)
|
||||
q (idnt-mtrx 5) q-1 (idnt-mtrx 5))
|
||||
(setf list (list p p-1 m q q-1))
|
||||
(setf t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(line-minus-5 list 0 3)
|
||||
(equalp t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(mtrx-prdc p p-1)
|
||||
(mtrx-prdc q q-1)
|
||||
(column-minus-5 list 0 2)
|
||||
(equalp t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(mtrx-prdc p p-1)
|
||||
(mtrx-prdc q q-1)
|
||||
|#
|
||||
|
||||
(DEFUN MINIMAL-TERM (matrix begin)
|
||||
(declare
|
||||
@ -379,10 +262,6 @@
|
||||
min-il il
|
||||
min-ic ic))))))))
|
||||
|
||||
#|
|
||||
(setf m (random-matrix 4 5 10))
|
||||
(minimal-term m 1)
|
||||
|#
|
||||
|
||||
(DEFUN MINIMAL-REST-1 (matrix begin)
|
||||
(declare
|
||||
@ -399,7 +278,8 @@
|
||||
(do ((ic (1+ begin) (1+ ic)))
|
||||
((= ic column-number))
|
||||
(declare (fixnum ic))
|
||||
(let ((term (abs (second (multiple-value-list (round (aref matrix begin ic)
|
||||
(let ((term (abs (second (multiple-value-list
|
||||
(round (aref matrix begin ic)
|
||||
corner))))))
|
||||
(declare (fixnum term))
|
||||
(when (= term 1)
|
||||
@ -413,7 +293,8 @@
|
||||
(do ((il (1+ begin) (1+ il)))
|
||||
((= il line-number))
|
||||
(declare (fixnum il))
|
||||
(let ((term (abs (second (multiple-value-list (round (aref matrix il begin)
|
||||
(let ((term (abs (second (multiple-value-list
|
||||
(round (aref matrix il begin)
|
||||
corner))))))
|
||||
(declare (fixnum term))
|
||||
(when (= term 1)
|
||||
@ -426,10 +307,6 @@
|
||||
min-ic begin)))))
|
||||
(values min min-il min-ic))))
|
||||
|
||||
#|
|
||||
(setf m (random-matrix 4 5 10))
|
||||
(minimal-rest-1 m 1)
|
||||
|#
|
||||
|
||||
(DEFUN MINIMAL-REST-2 (matrix begin)
|
||||
(declare
|
||||
@ -449,7 +326,8 @@
|
||||
(do ((ic (1+ begin) (1+ ic)))
|
||||
((= ic column-number))
|
||||
(declare (fixnum il))
|
||||
(let ((term (abs (second (multiple-value-list (round (aref matrix il ic)
|
||||
(let ((term (abs (second (multiple-value-list
|
||||
(round (aref matrix il ic)
|
||||
corner))))))
|
||||
(declare (fixnum term))
|
||||
(when (= 1 term)
|
||||
@ -462,11 +340,6 @@
|
||||
min-ic ic))))))
|
||||
(values min min-il min-ic))))
|
||||
|
||||
#|
|
||||
(setf m (random-matrix 4 5 10))
|
||||
(minimal-rest-2 m 1)
|
||||
|#
|
||||
|
||||
|
||||
(DEFUN MINIMAL-TERM-TOP-LEFT (mtrx-list begin il ic)
|
||||
(declare
|
||||
@ -482,18 +355,6 @@
|
||||
mtrx-list)))
|
||||
|
||||
|
||||
#|
|
||||
(setf p (idnt-mtrx 4) p-1 (idnt-mtrx 4)
|
||||
m (random-matrix 4 5 10)
|
||||
q (idnt-mtrx 5) q-1 (idnt-mtrx 5))
|
||||
(setf list (list p p-1 m q q-1))
|
||||
(setf t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(minimal-term-top-left list 0 1 3)
|
||||
(equalp t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(mtrx-prdc p p-1)
|
||||
(mtrx-prdc q q-1))
|
||||
|#
|
||||
|
||||
(DEFUN PIVOTT (mtrx-list begin)
|
||||
(declare
|
||||
(list mtrx-list)
|
||||
@ -507,28 +368,18 @@
|
||||
((= il line-number))
|
||||
(declare (fixnum il))
|
||||
(line-op-5 mtrx-list begin
|
||||
(- (round (aref (third mtrx-list) il begin) corner))
|
||||
(- (round (aref (third mtrx-list) il begin)
|
||||
corner))
|
||||
begin il))
|
||||
(do ((ic (1+ begin) (1+ ic)))
|
||||
((= ic column-number))
|
||||
(declare (fixnum ic))
|
||||
(column-op-5 mtrx-list begin
|
||||
(- (round (aref (third mtrx-list) begin ic) corner))
|
||||
(- (round (aref (third mtrx-list) begin ic)
|
||||
corner))
|
||||
begin ic)))
|
||||
mtrx-list)))
|
||||
|
||||
#|
|
||||
(setf p (idnt-mtrx 4) p-1 (idnt-mtrx 4)
|
||||
m (random-matrix 4 5 10)
|
||||
q (idnt-mtrx 5) q-1 (idnt-mtrx 5))
|
||||
(setf (aref m 0 0) -1)
|
||||
(setf list (list p p-1 m q q-1))
|
||||
(setf t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(pivott list 0)
|
||||
(equalp t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(mtrx-prdc p p-1)
|
||||
(mtrx-prdc q q-1)
|
||||
|#
|
||||
|
||||
(DEFUN LIST-SMITH (mtrx-list)
|
||||
(declare (list mtrx-list))
|
||||
@ -539,18 +390,21 @@
|
||||
(type matrix matrix)
|
||||
(fixnum begin))
|
||||
(loop
|
||||
(multiple-value-bind (term il ic) (minimal-term matrix begin)
|
||||
(multiple-value-bind (term il ic)
|
||||
(minimal-term matrix begin)
|
||||
(declare (fixnum term il ic))
|
||||
;; (format t "~%*BEGIN* = ~D ; MIN = ~D." begin term)
|
||||
(when (zerop term)
|
||||
(return-from list-smith mtrx-list))
|
||||
(minimal-term-top-left mtrx-list begin il ic))
|
||||
(loop
|
||||
(multiple-value-bind (term il ic) (minimal-rest-1 matrix begin)
|
||||
(multiple-value-bind (term il ic)
|
||||
(minimal-rest-1 matrix begin)
|
||||
(declare (fixnum term il ic))
|
||||
(cond ((zerop term)
|
||||
(pivott mtrx-list begin)
|
||||
(multiple-value-bind (term il ic) (minimal-rest-2 matrix begin)
|
||||
(multiple-value-bind (term il ic)
|
||||
(minimal-rest-2 matrix begin)
|
||||
(declare
|
||||
(fixnum term il)
|
||||
(ignore ic))
|
||||
@ -560,7 +414,8 @@
|
||||
((= il begin)
|
||||
(column-op-5 mtrx-list begin
|
||||
(- (round (aref matrix begin ic)
|
||||
(aref matrix begin begin)))
|
||||
(aref matrix begin
|
||||
begin)))
|
||||
begin ic)
|
||||
(column-swap-5 mtrx-list begin begin ic)
|
||||
(when (minusp (aref matrix begin begin))
|
||||
@ -577,17 +432,6 @@
|
||||
(incf begin)))
|
||||
mtrx-list)))
|
||||
|
||||
#|
|
||||
(setf p (idnt-mtrx 4) p-1 (idnt-mtrx 4)
|
||||
m (random-matrix 4 5 10)
|
||||
q (idnt-mtrx 5) q-1 (idnt-mtrx 5))
|
||||
(setf list (list p p-1 m q q-1))
|
||||
(setf t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(third (list-smith list))
|
||||
(equalp t1 (mtrx-prdc p (mtrx-prdc m q-1)))
|
||||
(mtrx-prdc p p-1)
|
||||
(mtrx-prdc q q-1)
|
||||
|#
|
||||
|
||||
(DEFUN SMITH (matrix)
|
||||
(declare (type matrix matrix))
|
||||
@ -624,10 +468,6 @@
|
||||
(fixnum i)
|
||||
(list rslt)))))
|
||||
|
||||
#|
|
||||
(gnrt-name 4)
|
||||
(gnrt-name-basis 4)
|
||||
|#
|
||||
|
||||
(DEFUN ECHCM-KILL-EPI-F-INTR (cmpr first n m f+1-basis mtrx-list)
|
||||
(declare
|
||||
@ -642,7 +482,8 @@
|
||||
(type matrix q-1))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(with-cmbn (degr list) cmbn
|
||||
(with-cmbn
|
||||
(degr list) cmbn
|
||||
(when (= degr first)
|
||||
(return-from rslt (zero-cmbn degr)))
|
||||
(unless (= degr f+1)
|
||||
@ -657,8 +498,10 @@
|
||||
(declare
|
||||
(list cmbn-mark basis-mark)
|
||||
(fixnum ic))
|
||||
(with--term (cffc gnrt) cmbn-mark
|
||||
(loop (when (eq :equal (funcall cmpr gnrt (car basis-mark)))
|
||||
(with--term
|
||||
(cffc gnrt) cmbn-mark
|
||||
(loop (when (eq :equal (funcall cmpr gnrt
|
||||
(car basis-mark)))
|
||||
(return))
|
||||
(pop basis-mark)
|
||||
(incf ic))
|
||||
@ -680,15 +523,6 @@
|
||||
(push (term cffc (gnrt-name il)) term-list))))))))
|
||||
(the intr-mrph #'rslt))))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf q-1 (random-matrix 5 5 10))
|
||||
(setf f (echcm-kill-epi-f-intr #'s-cmpr 2 2 5 '(a b c d e)
|
||||
(list 0 0 0 0 q-1)))
|
||||
(funcall f (cmbn 2 1 'a))
|
||||
(funcall f (cmbn 4 1 'a))
|
||||
(funcall f (cmbn 3 1 'a 10 'b 100 'c 1000 'd 10000 'e))
|
||||
|#
|
||||
|
||||
(DEFUN ECHCM-KILL-EPI-G-INTR (first n m f+1-basis mtrx-list)
|
||||
(declare
|
||||
@ -702,7 +536,8 @@
|
||||
(type matrix q))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(with-cmbn (degr list) cmbn
|
||||
(with-cmbn
|
||||
(degr list) cmbn
|
||||
(unless (= degr f+1)
|
||||
(return-from rslt cmbn))
|
||||
(let ((rslt-cffcs (make-array m :element-type 'fixnum
|
||||
@ -715,7 +550,8 @@
|
||||
(declare
|
||||
(list cmbn-mark basis-mark)
|
||||
(fixnum ic))
|
||||
(with--term (cffc gnrt) cmbn-mark
|
||||
(with--term
|
||||
(cffc gnrt) cmbn-mark
|
||||
(loop (when (eq :equal (s-cmpr gnrt (car basis-mark)))
|
||||
(return))
|
||||
(pop basis-mark)
|
||||
@ -738,15 +574,6 @@
|
||||
(push (term cffc (nth il f+1-basis)) term-list))))))))
|
||||
(the intr-mrph #'rslt))))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf q (random-matrix 5 5 10))
|
||||
(setf g (echcm-kill-epi-g-intr 2 2 5 '(a b c d e)
|
||||
(list 0 0 0 q 0)))
|
||||
(funcall g (cmbn 2))
|
||||
(funcall g (cmbn 4 1 'a))
|
||||
(funcall g (cmbn 3 1 :gn-0 10 :gn-1 100 :gn-2))
|
||||
|#
|
||||
|
||||
(DEFUN ECHCM-KILL-EPI-H-INTR (cmpr first n m f-basis f+1-basis mtrx-list)
|
||||
(declare
|
||||
@ -758,7 +585,8 @@
|
||||
(declare (type matrix lqxp-1))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(with-cmbn (degr list) cmbn
|
||||
(with-cmbn
|
||||
(degr list) cmbn
|
||||
(unless (= degr first)
|
||||
(return-from rslt (zero-cmbn (1+ degr))))
|
||||
(let ((rslt-cffcs (make-array m :element-type 'fixnum
|
||||
@ -771,8 +599,10 @@
|
||||
(declare
|
||||
(list cmbn-mark basis-mark)
|
||||
(fixnum ic))
|
||||
(with--term (cffc gnrt) cmbn-mark
|
||||
(loop (when (eq :equal (funcall cmpr gnrt (car basis-mark)))
|
||||
(with--term
|
||||
(cffc gnrt) cmbn-mark
|
||||
(loop (when (eq :equal (funcall cmpr gnrt
|
||||
(car basis-mark)))
|
||||
(return))
|
||||
(pop basis-mark)
|
||||
(incf ic))
|
||||
@ -794,15 +624,6 @@
|
||||
(push (term cffc (nth il f+1-basis)) term-list))))))))
|
||||
(the intr-mrph #'rslt))))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf p-1 (random-matrix 2 2 10))
|
||||
(setf q (random-matrix 5 5 10))
|
||||
(setf h (echcm-kill-epi-h-intr #'s-cmpr 2 2 5 '(a b) '(a b c d e)
|
||||
(list 0 p-1 0 q 0)))
|
||||
(funcall h (cmbn 2 1 'a 1000 'b))
|
||||
(funcall h (cmbn 4 1 'a))
|
||||
|#
|
||||
|
||||
(DEFUN ECHCM-WITHOUT-EPI (echcm first n m intr-f)
|
||||
(declare
|
||||
@ -842,6 +663,7 @@
|
||||
:strt :cmbn
|
||||
:orgn `(echcm-without-epi ,echcm)))))
|
||||
|
||||
|
||||
(DEFUN ECHCM-KILL-EPI (echcm first)
|
||||
(declare
|
||||
(type chain-complex echcm)
|
||||
@ -890,63 +712,6 @@
|
||||
:orgn `(echcm-kill-epi-h ,echcm))
|
||||
:orgn `(echcm-kill-epi ,echcm))))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s3 (sphere 3))
|
||||
(setf s3-chml-clss (chml-clss 's3))
|
||||
(setf s3-fibration (z-whitehead s3 3 s3-chml-clss))
|
||||
(setf s3-4 (fibration-total s3-fibration))
|
||||
(setf ecc (echcm s3-4))
|
||||
(setf rdct (echcm-kill-epi ecc 2))
|
||||
(pre-check-rdct rdct)
|
||||
(setf *tc* (cmbn 0 1 (bsgn ecc))
|
||||
*bc* *tc*)
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 2 1 (first (basis ecc 2))))
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 3 1 (first (basis ecc 3))))
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 4 1 (first (basis ecc 4)))
|
||||
*bc* *tc*)
|
||||
(check-rdct)
|
||||
(setf s3-4-chml-clss (chml-clss 's3-4))
|
||||
(setf s3-4-fibration (z2-whitehead s3-4 4 s3-4-chml-clss))
|
||||
(setf s3-5 (fibration-total s3-4-fibration))
|
||||
(setf ecc (echcm s3-5))
|
||||
(dotimes (i 7)
|
||||
(format t "~%DIM = ~D ; LENGTH = ~D" i (length (basis ecc i))))
|
||||
(setf rdct1 (echcm-kill-epi ecc 2))
|
||||
(setf rdct2 (echcm-kill-epi (bcc rdct1) 3))
|
||||
(setf rdct3 (echcm-kill-epi (bcc rdct2) 4))
|
||||
(setf rdct12 (cmps rdct2 rdct1))
|
||||
(setf rdct123 (cmps rdct3 rdct12))
|
||||
(pre-check-rdct rdct123)
|
||||
(setf *tc* (cmbn 0 1 (bsgn ecc)) *bc* *tc*)
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 2 1 (first (basis ecc 2))))
|
||||
(check-rdct)
|
||||
(let ((b3 (basis ecc 3)))
|
||||
(setf *tc* (cmbn 3 1 (first b3) 10 (second b3))))
|
||||
(check-rdct)
|
||||
(let ((b4 (basis ecc 4)))
|
||||
(setf *tc* (cmbn 4 1 (first b4) 10 (second b4))))
|
||||
(check-rdct)
|
||||
(let ((b5 (basis ecc 5)))
|
||||
(setf *tc* (cmbn 5 1 (first b5)
|
||||
10 (second b5)
|
||||
100 (third b5)
|
||||
1000 (fourth b5))))
|
||||
(check-rdct)
|
||||
(let ((b6 (basis ecc 6)))
|
||||
(setf *tc* (cmbn 6 1 (first b6)
|
||||
10 (second b6)
|
||||
100 (third b6)
|
||||
1000 (fourth b6)
|
||||
10000 (fifth b6)
|
||||
100000 (sixth b6)
|
||||
1000000 (seventh b6))))
|
||||
(check-rdct)
|
||||
|#
|
||||
|
||||
(DEFUN KILL-EPI (chcm first)
|
||||
(declare
|
||||
@ -966,6 +731,7 @@
|
||||
:rrdct (cmps last-rdct (rrdct efhm))
|
||||
:orgn `(kill-epi ,chcm ,first)))))))
|
||||
|
||||
|
||||
(DEFUN KILL-EPIS (chcm first end)
|
||||
(declare
|
||||
(type chain-complex chcm)
|
||||
@ -977,30 +743,6 @@
|
||||
(kill-epi chcm indx))
|
||||
(efhm chcm))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s3 (sphere 3))
|
||||
(setf s3-chml-clss (chml-clss 's3))
|
||||
(setf s3-fibration (z-whitehead s3 3 s3-chml-clss))
|
||||
(setf s3-4 (fibration-total s3-fibration))
|
||||
(setf s3-4-chml-clss (chml-clss 's3-4))
|
||||
(setf s3-4-fibration (z2-whitehead s3-4 4 s3-4-chml-clss))
|
||||
(setf s3-5 (fibration-total s3-4-fibration))
|
||||
(time (homology s3-5 6))
|
||||
(kill-epis s3-5 2 5)
|
||||
(homology s3-5 0 7)
|
||||
|
||||
(cat-init)
|
||||
(setf s3 (sphere 3))
|
||||
(setf s3-chml-clss (chml-clss 's3))
|
||||
(setf s3-fibration (z-whitehead s3 3 s3-chml-clss))
|
||||
(setf s3-4 (fibration-total s3-fibration))
|
||||
(kill-epi s3-4 2)
|
||||
(setf s3-4-chml-clss (chml-clss 's3-4))
|
||||
(setf s3-4-fibration (z2-whitehead s3-4 4 s3-4-chml-clss))
|
||||
(setf s3-5 (fibration-total s3-4-fibration))
|
||||
(time (homology s3-5 6))
|
||||
|#
|
||||
|
||||
(DEFUN CHML-CLSS-INTR (chcm first)
|
||||
(declare
|
||||
@ -1032,7 +774,8 @@
|
||||
(type matrix p-1 smith))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(with-cmbn (degr list) cmbn
|
||||
(with-cmbn
|
||||
(degr list) cmbn
|
||||
(unless (= degr first)
|
||||
(return-from rslt (zero-cmbn (- degr first))))
|
||||
(do ((rslt 0)
|
||||
@ -1046,7 +789,8 @@
|
||||
(declare
|
||||
(fixnum rslt)
|
||||
(list bmark cmark))
|
||||
(with--term (cffc gnrt) cmark
|
||||
(with--term
|
||||
(cffc gnrt) cmark
|
||||
(loop
|
||||
(when (eq :equal (funcall cmpr gnrt (car bmark)))
|
||||
(return))
|
||||
@ -1057,25 +801,6 @@
|
||||
(incf ic))))))
|
||||
(the intr-mrph #'rslt))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s3 (sphere 3))
|
||||
(setf c (chml-clss-intr s3 3))
|
||||
(funcall c (cmbn 3 5 's3))
|
||||
(setf s3-chml-clss (chml-clss 's3))
|
||||
(setf s3-fibration (z-whitehead s3 3 s3-chml-clss))
|
||||
(setf s3-4 (fibration-total s3-fibration))
|
||||
(kill-epi s3-4 2)
|
||||
(setf c (chml-clss-intr s3-4 4))
|
||||
(funcall c (cmbn 4 5 (first (basis (echcm s3-4) 4))))
|
||||
(setf s3-4-chml-clss (chml-clss 's3-4))
|
||||
(setf s3-4-fibration (z2-whitehead s3-4 4 s3-4-chml-clss))
|
||||
(setf s3-5 (fibration-total s3-4-fibration))
|
||||
(kill-epis s3-5 3 5)
|
||||
(setf c (chml-clss-intr s3-5 5))
|
||||
(let ((b5 (basis (echcm s3-5) 5)))
|
||||
(funcall c (cmbn 5 1 (first b5) 10 (second b5))))
|
||||
|#
|
||||
|
||||
(DEFUN CHML-CLSS (chcm first)
|
||||
(declare
|
||||
@ -1087,22 +812,3 @@
|
||||
:intr (chml-clss-intr chcm first)
|
||||
:strt :cmbn
|
||||
:orgn `(chml-clss ,chcm ,first))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s3 (sphere 3))
|
||||
(setf s3-chml-clss (chml-clss s3 3))
|
||||
(setf s3-fibration (z-whitehead s3 3 s3-chml-clss))
|
||||
(setf s3-4 (fibration-total s3-fibration))
|
||||
(homology s3-4 0 6)
|
||||
(kill-epi s3-4 2)
|
||||
(setf s3-4-chml-clss (chml-clss s3-4 4))
|
||||
(setf s3-4-fibration (z2-whitehead s3-4 4 s3-4-chml-clss))
|
||||
(setf s3-5 (fibration-total s3-4-fibration))
|
||||
(homology s3-5 0 6)
|
||||
(kill-epis s3-5 3 5)
|
||||
(setf s3-5-chml-clss (chml-clss s3-5 5))
|
||||
(setf s3-5-fibration (z2-whitehead s3-5 5 s3-5-chml-clss))
|
||||
(setf s3-6 (fibration-total s3-5-fibration))
|
||||
(homology s3-6 0 7)
|
||||
|#
|
||||
|
||||
357
test/smith-test.lisp
Normal file
357
test/smith-test.lisp
Normal file
@ -0,0 +1,357 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
(test random-matrix
|
||||
(cat:random-matrix 2 3 10))
|
||||
|
||||
|
||||
(test idnt-mtrx
|
||||
(cat:idnt-mtrx 3))
|
||||
|
||||
|
||||
(test copy-mtrx
|
||||
(let ((m (cat:random-matrix 3 4 10)))
|
||||
(is (equalp m (cat:copy-mtrx m)))))
|
||||
|
||||
|
||||
(test left-submatrix
|
||||
(let ((m (cat:random-matrix 3 4 10)))
|
||||
(cat:left-submatrix m 2)))
|
||||
|
||||
|
||||
(test mtrx-prdc
|
||||
(let ((m1 (cat:random-matrix 2 3 10))
|
||||
(m2 (cat:random-matrix 3 2 10)))
|
||||
(cat:mtrx-prdc m1 m2)
|
||||
(cat:mtrx-prdc m2 m1)))
|
||||
|
||||
|
||||
(test chcm-mtrx
|
||||
(cat:cat-init)
|
||||
(let ((d (cat:delta 5))
|
||||
(m (cat:moore 2 2)))
|
||||
(cat:chcm-mtrx d 3)
|
||||
(dotimes (i 5)
|
||||
(print (cat:chcm-mtrx m i)))
|
||||
(dotimes (i 6)
|
||||
(print (array-dimensions (cat:chcm-mtrx m i))))))
|
||||
|
||||
|
||||
(test line-op
|
||||
(let ((m (cat:random-matrix 3 4 10)))
|
||||
(cat:line-op m 1 3 2 0)))
|
||||
|
||||
;; mtrx-list = (P P^-1 M Q Q^-1)
|
||||
|
||||
(test line-op-5
|
||||
(let* ((p (cat:idnt-mtrx 4))
|
||||
(p-1 (cat:idnt-mtrx 4))
|
||||
(m (cat:random-matrix 4 5 10))
|
||||
(q (cat:idnt-mtrx 5) )
|
||||
(q-1 (cat:idnt-mtrx 5))
|
||||
(list (list p p-1 m q q-1))
|
||||
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:line-op-5 list 0 3 1 3)
|
||||
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:mtrx-prdc p p-1)))
|
||||
|
||||
|
||||
(test column-op
|
||||
(let ((m (cat:random-matrix 3 4 10)))
|
||||
(cat:column-op m 1 3 2 0)))
|
||||
|
||||
|
||||
(test column-op-5
|
||||
(let* ((p (cat:idnt-mtrx 4))
|
||||
(p-1 (cat:idnt-mtrx 4))
|
||||
(m (cat:random-matrix 4 5 10))
|
||||
(q (cat:idnt-mtrx 5))
|
||||
(q-1 (cat:idnt-mtrx 5))
|
||||
(list (list p p-1 m q q-1))
|
||||
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:column-op-5 list 0 3 1 3)
|
||||
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:mtrx-prdc p p-1)
|
||||
(cat:mtrx-prdc q q-1)))
|
||||
|
||||
|
||||
(test line-swap
|
||||
(let ((m (cat:random-matrix 3 4 10)))
|
||||
(cat:line-swap m 1 0 2)))
|
||||
|
||||
|
||||
(test line-swap-5
|
||||
(let* ((p (cat:idnt-mtrx 4))
|
||||
(p-1 (cat:idnt-mtrx 4))
|
||||
(m (cat:random-matrix 4 5 10))
|
||||
(q (cat:idnt-mtrx 5))
|
||||
(q-1 (cat:idnt-mtrx 5))
|
||||
(list (list p p-1 m q q-1))
|
||||
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:line-swap-5 list 0 1 3)
|
||||
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:mtrx-prdc p p-1)
|
||||
(cat:mtrx-prdc q q-1)))
|
||||
|
||||
|
||||
(test column-swap
|
||||
(let ((m (cat:random-matrix 3 4 10)))
|
||||
(cat:column-swap m 1 0 2)))
|
||||
|
||||
|
||||
(test column-swap-5
|
||||
(let* ((p (cat:idnt-mtrx 4))
|
||||
(p-1 (cat:idnt-mtrx 4))
|
||||
(m (cat:random-matrix 4 5 10))
|
||||
(q (cat:idnt-mtrx 5))
|
||||
(q-1 (cat:idnt-mtrx 5))
|
||||
(list (list p p-1 m q q-1))
|
||||
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:column-swap-5 list 0 1 3)
|
||||
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:mtrx-prdc p p-1)
|
||||
(cat:mtrx-prdc q q-1)))
|
||||
|
||||
|
||||
(test column-minus
|
||||
(let ((m (cat:random-matrix 3 4 10)))
|
||||
(cat:line-minus m 1 2)
|
||||
(cat:column-minus m 1 2)))
|
||||
|
||||
|
||||
(test column-minus-5
|
||||
(let* ((p (cat:idnt-mtrx 4))
|
||||
(p-1 (cat:idnt-mtrx 4))
|
||||
(m (cat:random-matrix 4 5 10))
|
||||
(q (cat:idnt-mtrx 5))
|
||||
(q-1 (cat:idnt-mtrx 5))
|
||||
(list (list p p-1 m q q-1))
|
||||
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:line-minus-5 list 0 3)
|
||||
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:mtrx-prdc p p-1)
|
||||
(cat:mtrx-prdc q q-1)
|
||||
(cat:column-minus-5 list 0 2)
|
||||
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:mtrx-prdc p p-1)
|
||||
(cat:mtrx-prdc q q-1)))
|
||||
|
||||
|
||||
(test minimal-term
|
||||
(let ((m (cat:random-matrix 4 5 10)))
|
||||
(cat:minimal-term m 1)))
|
||||
|
||||
|
||||
(test minimal-rest-1
|
||||
(let ((m (cat:random-matrix 4 5 10)))
|
||||
(cat:minimal-rest-1 m 1)))
|
||||
|
||||
|
||||
(test minimal-rest-2
|
||||
(let ((m (cat:random-matrix 4 5 10)))
|
||||
(cat:minimal-rest-2 m 1)))
|
||||
|
||||
|
||||
(test minimal-term-top-left
|
||||
(let* ((p (cat:idnt-mtrx 4))
|
||||
(p-1 (cat:idnt-mtrx 4))
|
||||
(m (cat:random-matrix 4 5 10))
|
||||
(q (cat:idnt-mtrx 5))
|
||||
(q-1 (cat:idnt-mtrx 5))
|
||||
(list (list p p-1 m q q-1))
|
||||
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:minimal-term-top-left list 0 1 3)
|
||||
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:mtrx-prdc p p-1)
|
||||
(cat:mtrx-prdc q q-1)))
|
||||
|
||||
|
||||
(test minimal-term-top-left
|
||||
(let* ((p (cat:idnt-mtrx 4))
|
||||
(p-1 (cat:idnt-mtrx 4))
|
||||
(m (cat:random-matrix 4 5 10))
|
||||
(q (cat:idnt-mtrx 5))
|
||||
(q-1 (cat:idnt-mtrx 5))
|
||||
(list (list p p-1 m q q-1))
|
||||
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:pivott list 0)
|
||||
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:mtrx-prdc p p-1)
|
||||
(cat:mtrx-prdc q q-1)))
|
||||
|
||||
(test list-smith
|
||||
(let* ((p (cat:idnt-mtrx 4))
|
||||
(p-1 (cat:idnt-mtrx 4))
|
||||
(m (cat:random-matrix 4 5 10))
|
||||
(q (cat:idnt-mtrx 5))
|
||||
(q-1 (cat:idnt-mtrx 5))
|
||||
(list (list p p-1 m q q-1))
|
||||
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(third (cat:list-smith list))
|
||||
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
|
||||
(cat:mtrx-prdc p p-1)
|
||||
(cat:mtrx-prdc q q-1)))
|
||||
|
||||
|
||||
(test gnrt-name-basis
|
||||
(cat:gnrt-name 4)
|
||||
(cat:gnrt-name-basis 4))
|
||||
|
||||
|
||||
(test echcm-kill-epi-f-intr
|
||||
(let* ((q-1 (cat:random-matrix 5 5 10))
|
||||
(f (cat:echcm-kill-epi-f-intr #'cat:s-cmpr 2 2 5 '(a b c d e)
|
||||
(list 0 0 0 0 q-1))))
|
||||
(funcall f (cat:cmbn 2 1 'a))
|
||||
(funcall f (cat:cmbn 4 1 'a))
|
||||
(funcall f (cat:cmbn 3 1 'a 10 'b 100 'c 1000 'd 10000 'e))))
|
||||
|
||||
#|
|
||||
(test echcm-kill-epi-g-intr
|
||||
(let* ((q (cat:random-matrix 5 5 10))
|
||||
(g (cat:echcm-kill-epi-g-intr 2 2 5 '(a b c d e)
|
||||
(list 0 0 0 q 0))))
|
||||
(funcall g (cat:cmbn 2))
|
||||
(funcall g (cat:cmbn 4 1 'a))
|
||||
(funcall g (cat:cmbn 3 1 :gn-0 10 :gn-1 100 :gn-2))))
|
||||
|#
|
||||
|
||||
(test echcm-kill-epi-h-intr
|
||||
(let* ((p-1 (cat:random-matrix 2 2 10))
|
||||
(q (cat:random-matrix 5 5 10))
|
||||
(h (cat:echcm-kill-epi-h-intr #'cat:s-cmpr 2 2 5 '(a b)
|
||||
'(a b c d e)
|
||||
(list 0 p-1 0 q 0))))
|
||||
(funcall h (cat:cmbn 2 1 'a 1000 'b))
|
||||
(funcall h (cat:cmbn 4 1 'a))))
|
||||
|
||||
|
||||
(test echcm-kill-epi
|
||||
(cat:cat-init)
|
||||
(let* ((s3 (cat:sphere 3))
|
||||
(s3-chml-clss (cat:chml-clss s3 3))
|
||||
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
|
||||
(s3-4 (cat:fibration-total s3-fibration))
|
||||
(ecc (cat:echcm s3-4))
|
||||
(rdct (cat:echcm-kill-epi ecc 2))
|
||||
s3-4-chml-clss s3-4-fibration s3-5
|
||||
rdct1 rdct2 rdct3 rdct12 rdct123)
|
||||
(cat:pre-check-rdct rdct)
|
||||
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc))
|
||||
cat:*bc* cat:*tc*)
|
||||
(check-rdct)
|
||||
(setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2))))
|
||||
(check-rdct)
|
||||
(setf cat:*tc* (cat:cmbn 3 1 (first (cat:basis ecc 3))))
|
||||
(check-rdct)
|
||||
(setf cat:*tc* (cat:cmbn 4 1 (first (cat:basis ecc 4)))
|
||||
cat:*bc* cat:*tc*)
|
||||
(check-rdct)
|
||||
(setf s3-4-chml-clss (cat:chml-clss s3-4 4))
|
||||
(setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
|
||||
(setf s3-5 (cat:fibration-total s3-4-fibration))
|
||||
(setf ecc (cat:echcm s3-5))
|
||||
(dotimes (i 7)
|
||||
(format t "~%DIM = ~D ; LENGTH = ~D" i (length (cat:basis ecc i))))
|
||||
(setf rdct1 (cat:echcm-kill-epi ecc 2))
|
||||
(setf rdct2 (cat:echcm-kill-epi (cat:bcc rdct1) 3))
|
||||
(setf rdct3 (cat:echcm-kill-epi (cat:bcc rdct2) 4))
|
||||
(setf rdct12 (cat:cmps rdct2 rdct1))
|
||||
(setf rdct123 (cat:cmps rdct3 rdct12))
|
||||
(cat:pre-check-rdct rdct123)
|
||||
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc)) cat:*bc* cat:*tc*)
|
||||
(check-rdct)
|
||||
(setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2))))
|
||||
(check-rdct)
|
||||
(let ((b3 (cat:basis ecc 3)))
|
||||
(setf cat:*tc* (cat:cmbn 3 1 (first b3) 10 (second b3))))
|
||||
(check-rdct)
|
||||
(let ((b4 (cat:basis ecc 4)))
|
||||
(setf cat:*tc* (cat:cmbn 4 1 (first b4) 10 (second b4))))
|
||||
(check-rdct)
|
||||
(let ((b5 (cat:basis ecc 5)))
|
||||
(setf cat:*tc* (cat:cmbn 5 1 (first b5)
|
||||
10 (second b5)
|
||||
100 (third b5)
|
||||
1000 (fourth b5))))
|
||||
(check-rdct)
|
||||
(let ((b6 (cat:basis ecc 6)))
|
||||
(setf cat:*tc* (cat:cmbn 6 1 (first b6)
|
||||
10 (second b6)
|
||||
100 (third b6)
|
||||
1000 (fourth b6)
|
||||
10000 (fifth b6)
|
||||
100000 (sixth b6)
|
||||
1000000 (seventh b6))))
|
||||
(check-rdct)))
|
||||
|
||||
|
||||
(test kill-epis
|
||||
(cat:cat-init)
|
||||
(let* ((s3 (cat:sphere 3))
|
||||
(s3-chml-clss (cat:chml-clss s3 3))
|
||||
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
|
||||
(s3-4 (cat:fibration-total s3-fibration))
|
||||
(s3-4-chml-clss (cat:chml-clss s3-4 4))
|
||||
(s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
|
||||
(s3-5 (cat:fibration-total s3-4-fibration)))
|
||||
(time (cat:homology s3-5 6))
|
||||
(cat:kill-epis s3-5 2 5)
|
||||
(cat:homology s3-5 0 7)))
|
||||
|
||||
|
||||
(test kill-epi
|
||||
(cat:cat-init)
|
||||
(let* ((s3 (cat:sphere 3))
|
||||
(s3-chml-clss (cat:chml-clss s3 3))
|
||||
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
|
||||
(s3-4 (cat:fibration-total s3-fibration))
|
||||
s3-4-chml-clss s3-4-fibration s3-5)
|
||||
(cat:kill-epi s3-4 2)
|
||||
(setf s3-4-chml-clss (cat:chml-clss s3-4 4))
|
||||
(setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
|
||||
(setf s3-5 (cat:fibration-total s3-4-fibration))
|
||||
(time (cat:homology s3-5 6))))
|
||||
|
||||
|
||||
(test chml-clss-intr
|
||||
(cat:cat-init)
|
||||
(let* ((s3 (cat:sphere 3))
|
||||
(c (cat:chml-clss-intr s3 3))
|
||||
(s3-chml-clss (cat:chml-clss s3 3))
|
||||
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
|
||||
(s3-4 (cat:fibration-total s3-fibration))
|
||||
s3-4-chml-clss s3-4-fibration s3-5)
|
||||
(funcall c (cat:cmbn 3 5 's3))
|
||||
(cat:kill-epi s3-4 2)
|
||||
(setf c (cat:chml-clss-intr s3-4 4))
|
||||
(funcall c (cat:cmbn 4 5 (first (cat:basis (cat:echcm s3-4) 4))))
|
||||
(setf s3-4-chml-clss (cat:chml-clss s3-4 4))
|
||||
(setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
|
||||
(setf s3-5 (cat:fibration-total s3-4-fibration))
|
||||
(cat:kill-epis s3-5 3 5)
|
||||
(setf c (cat:chml-clss-intr s3-5 5))
|
||||
(let ((b5 (cat:basis (cat:echcm s3-5) 5)))
|
||||
(funcall c (cat:cmbn 5 1 (first b5) 10 (second b5))))))
|
||||
|
||||
|
||||
(test chml-clss
|
||||
(cat:cat-init)
|
||||
(let* ((s3 (cat:sphere 3))
|
||||
(s3-chml-clss (cat:chml-clss s3 3))
|
||||
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
|
||||
(s3-4 (cat:fibration-total s3-fibration))
|
||||
s3-4-chml-clss s3-4-fibration s3-5 s3-5-chml-clss s3-5-fibration)
|
||||
(cat:homology s3-4 0 6)
|
||||
(cat:kill-epi s3-4 2)
|
||||
(setf s3-4-chml-clss (cat:chml-clss s3-4 4))
|
||||
(setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
|
||||
(setf s3-5 (cat:fibration-total s3-4-fibration))
|
||||
(cat:homology s3-5 0 6)
|
||||
(cat:kill-epis s3-5 3 5)
|
||||
(setf s3-5-chml-clss (cat:chml-clss s3-5 5))
|
||||
(setf s3-5-fibration (cat:z2-whitehead s3-5 s3-5-chml-clss))
|
||||
(setf s3-6 (cat:fibration-total s3-5-fibration))
|
||||
(cat:homology s3-6 0 7)))
|
||||
Loading…
Reference in New Issue
Block a user