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

Extracted tests from smith.lisp.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-26 18:09:57 -05:00
parent 3d3b44b5a4
commit 9eece57056
4 changed files with 995 additions and 898 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -38,6 +38,7 @@
(:file "simplicial-groups-test") (:file "simplicial-groups-test")
(:file "simplicial-mrphs-test") (:file "simplicial-mrphs-test")
(:file "simplicial-sets-test") (:file "simplicial-sets-test")
(:file "smith-test")
(:file "suspensions-test") (:file "suspensions-test")
(:file "tensor-products-test") (:file "tensor-products-test")
(:file "various-test") (:file "various-test")

33
package.lisp
View File

@ -372,6 +372,9 @@
CMBN-NON-ZERO-P CMBN-NON-ZERO-P
CMBN-ZERO-P CMBN-ZERO-P
CMPR CMPR
COLUMN-MINUS-5
COLUMN-OP-5
COLUMN-SWAP-5
CON0 CON0
CON1 CON1
CPRD CPRD
@ -382,12 +385,16 @@
DGNL DGNL
GMSM1 GMSM1
GNRT GNRT
GNRT-NAME
GRIN GRIN
GRML GRML
I-SBTR I-SBTR
KFLL KFLL
LF LF
LG LG
LINE-MINUS-5
LINE-OP-5
LINE-SWAP-5
MASK MASK
MAKE-GBAR MAKE-GBAR
RBCC RBCC
@ -438,7 +445,33 @@
;; smith.lisp ;; smith.lisp
CHCM-MTRX
CHML-CLSS 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 ;; special-smsts.lisp

378
src/smith.lisp
View File

@ -26,9 +26,6 @@
(- (random 2max+1) max)))) (- (random 2max+1) max))))
rslt))) rslt)))
#|
(random-matrix 2 3 10)
|#
(DEFUN IDNT-MTRX (n) (DEFUN IDNT-MTRX (n)
(declare (fixnum n)) (declare (fixnum n))
@ -45,10 +42,6 @@
(setf (aref rslt i i) 1)) (setf (aref rslt i i) 1))
rslt))) rslt)))
#|
()
(idnt-mtrx 3)
|#
(DEFUN COPY-MTRX (mtrx) (DEFUN COPY-MTRX (mtrx)
(declare (type matrix mtrx)) (declare (type matrix mtrx))
@ -66,10 +59,6 @@
(setf (aref rslt il ic) (aref mtrx il ic)))) (setf (aref rslt il ic) (aref mtrx il ic))))
rslt)))) rslt))))
#|
(setf m (random-matrix 3 4 10))
(equalp m (copy-mtrx m))
|#
(DEFUN LEFT-SUBMATRIX (mtrx k) (DEFUN LEFT-SUBMATRIX (mtrx k)
(declare (type matrix mtrx)) (declare (type matrix mtrx))
@ -88,10 +77,6 @@
(setf (aref rslt il ic) (aref mtrx il ic)))) (setf (aref rslt il ic) (aref mtrx il ic))))
rslt)))) rslt))))
#|
(setf m (random-matrix 3 4 10))
(left-submatrix m 2)
|#
(DEFUN MTRX-PRDC (mtrx1 mtrx2) (DEFUN MTRX-PRDC (mtrx1 mtrx2)
(declare (type matrix mtrx1 mtrx2)) (declare (type matrix mtrx1 mtrx2))
@ -117,12 +102,6 @@
((= k mtrx1-column-n) (setf (aref rslt il ic) sum))))) ((= k mtrx1-column-n) (setf (aref rslt il ic) sum)))))
rslt)))) 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) (DEFUN CHCM-MTRX (chcm degr)
(declare (declare
@ -159,7 +138,8 @@
(declare (declare
(list mark1 mark2) (list mark1 mark2)
(fixnum i)) (fixnum i))
(with--term (cffc gnrt) mark1 (with--term
(cffc gnrt) mark1
(loop (loop
(cond ((eq :equal (funcall cmpr gnrt (car mark2))) (cond ((eq :equal (funcall cmpr gnrt (car mark2)))
(setf (aref rslt i j) cffc) (setf (aref rslt i j) cffc)
@ -170,16 +150,6 @@
(pop mark2)))))))) (pop mark2))))))))
rslt))))) 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) (DEFUN LINE-OP (mtrx begin lambda line1 line2)
;; line2 := line2 + lambda * line1 ;; line2 := line2 + lambda * line1
@ -196,23 +166,6 @@
(* lambda (aref mtrx line1 j)))) (* lambda (aref mtrx line1 j))))
mtrx))) 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) (DEFUN COLUMN-OP (mtrx begin lambda column1 column2)
(declare (declare
@ -228,23 +181,6 @@
(* lambda (aref mtrx i column1)))) (* lambda (aref mtrx i column1))))
mtrx))) 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) (DEFUN LINE-SWAP (mtrx begin line1 line2)
(declare (declare
@ -259,22 +195,6 @@
(rotatef (aref mtrx line1 j) (aref mtrx line2 j))) (rotatef (aref mtrx line1 j) (aref mtrx line2 j)))
mtrx))) 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) (DEFUN COLUMN-SWAP (mtrx begin column1 column2)
(declare (declare
@ -288,22 +208,6 @@
(rotatef (aref mtrx i column1) (aref mtrx i column2))) (rotatef (aref mtrx i column1) (aref mtrx i column2)))
mtrx))) 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) (DEFUN LINE-MINUS (mtrx begin line)
(declare (declare
@ -329,27 +233,6 @@
(setf (aref mtrx i column) (- (aref mtrx i column)))) (setf (aref mtrx i column) (- (aref mtrx i column))))
mtrx))) 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) (DEFUN MINIMAL-TERM (matrix begin)
(declare (declare
@ -379,10 +262,6 @@
min-il il min-il il
min-ic ic)))))))) min-ic ic))))))))
#|
(setf m (random-matrix 4 5 10))
(minimal-term m 1)
|#
(DEFUN MINIMAL-REST-1 (matrix begin) (DEFUN MINIMAL-REST-1 (matrix begin)
(declare (declare
@ -399,7 +278,8 @@
(do ((ic (1+ begin) (1+ ic))) (do ((ic (1+ begin) (1+ ic)))
((= ic column-number)) ((= ic column-number))
(declare (fixnum ic)) (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)))))) corner))))))
(declare (fixnum term)) (declare (fixnum term))
(when (= term 1) (when (= term 1)
@ -413,7 +293,8 @@
(do ((il (1+ begin) (1+ il))) (do ((il (1+ begin) (1+ il)))
((= il line-number)) ((= il line-number))
(declare (fixnum il)) (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)))))) corner))))))
(declare (fixnum term)) (declare (fixnum term))
(when (= term 1) (when (= term 1)
@ -426,10 +307,6 @@
min-ic begin))))) min-ic begin)))))
(values min min-il min-ic)))) (values min min-il min-ic))))
#|
(setf m (random-matrix 4 5 10))
(minimal-rest-1 m 1)
|#
(DEFUN MINIMAL-REST-2 (matrix begin) (DEFUN MINIMAL-REST-2 (matrix begin)
(declare (declare
@ -449,7 +326,8 @@
(do ((ic (1+ begin) (1+ ic))) (do ((ic (1+ begin) (1+ ic)))
((= ic column-number)) ((= ic column-number))
(declare (fixnum il)) (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)))))) corner))))))
(declare (fixnum term)) (declare (fixnum term))
(when (= 1 term) (when (= 1 term)
@ -462,11 +340,6 @@
min-ic ic)))))) min-ic ic))))))
(values min min-il min-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) (DEFUN MINIMAL-TERM-TOP-LEFT (mtrx-list begin il ic)
(declare (declare
@ -482,18 +355,6 @@
mtrx-list))) 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) (DEFUN PIVOTT (mtrx-list begin)
(declare (declare
(list mtrx-list) (list mtrx-list)
@ -507,28 +368,18 @@
((= il line-number)) ((= il line-number))
(declare (fixnum il)) (declare (fixnum il))
(line-op-5 mtrx-list begin (line-op-5 mtrx-list begin
(- (round (aref (third mtrx-list) il begin) corner)) (- (round (aref (third mtrx-list) il begin)
corner))
begin il)) begin il))
(do ((ic (1+ begin) (1+ ic))) (do ((ic (1+ begin) (1+ ic)))
((= ic column-number)) ((= ic column-number))
(declare (fixnum ic)) (declare (fixnum ic))
(column-op-5 mtrx-list begin (column-op-5 mtrx-list begin
(- (round (aref (third mtrx-list) begin ic) corner)) (- (round (aref (third mtrx-list) begin ic)
corner))
begin ic))) begin ic)))
mtrx-list))) 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) (DEFUN LIST-SMITH (mtrx-list)
(declare (list mtrx-list)) (declare (list mtrx-list))
@ -539,18 +390,21 @@
(type matrix matrix) (type matrix matrix)
(fixnum begin)) (fixnum begin))
(loop (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)) (declare (fixnum term il ic))
;; (format t "~%*BEGIN* = ~D ; MIN = ~D." begin term) ;; (format t "~%*BEGIN* = ~D ; MIN = ~D." begin term)
(when (zerop term) (when (zerop term)
(return-from list-smith mtrx-list)) (return-from list-smith mtrx-list))
(minimal-term-top-left mtrx-list begin il ic)) (minimal-term-top-left mtrx-list begin il ic))
(loop (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)) (declare (fixnum term il ic))
(cond ((zerop term) (cond ((zerop term)
(pivott mtrx-list begin) (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 (declare
(fixnum term il) (fixnum term il)
(ignore ic)) (ignore ic))
@ -560,7 +414,8 @@
((= il begin) ((= il begin)
(column-op-5 mtrx-list begin (column-op-5 mtrx-list begin
(- (round (aref matrix begin ic) (- (round (aref matrix begin ic)
(aref matrix begin begin))) (aref matrix begin
begin)))
begin ic) begin ic)
(column-swap-5 mtrx-list begin begin ic) (column-swap-5 mtrx-list begin begin ic)
(when (minusp (aref matrix begin begin)) (when (minusp (aref matrix begin begin))
@ -577,17 +432,6 @@
(incf begin))) (incf begin)))
mtrx-list))) 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) (DEFUN SMITH (matrix)
(declare (type matrix matrix)) (declare (type matrix matrix))
@ -624,10 +468,6 @@
(fixnum i) (fixnum i)
(list rslt))))) (list rslt)))))
#|
(gnrt-name 4)
(gnrt-name-basis 4)
|#
(DEFUN ECHCM-KILL-EPI-F-INTR (cmpr first n m f+1-basis mtrx-list) (DEFUN ECHCM-KILL-EPI-F-INTR (cmpr first n m f+1-basis mtrx-list)
(declare (declare
@ -642,7 +482,8 @@
(type matrix q-1)) (type matrix q-1))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (degr list) cmbn (with-cmbn
(degr list) cmbn
(when (= degr first) (when (= degr first)
(return-from rslt (zero-cmbn degr))) (return-from rslt (zero-cmbn degr)))
(unless (= degr f+1) (unless (= degr f+1)
@ -657,8 +498,10 @@
(declare (declare
(list cmbn-mark basis-mark) (list cmbn-mark basis-mark)
(fixnum ic)) (fixnum ic))
(with--term (cffc gnrt) cmbn-mark (with--term
(loop (when (eq :equal (funcall cmpr gnrt (car basis-mark))) (cffc gnrt) cmbn-mark
(loop (when (eq :equal (funcall cmpr gnrt
(car basis-mark)))
(return)) (return))
(pop basis-mark) (pop basis-mark)
(incf ic)) (incf ic))
@ -680,15 +523,6 @@
(push (term cffc (gnrt-name il)) term-list)))))))) (push (term cffc (gnrt-name il)) term-list))))))))
(the intr-mrph #'rslt)))) (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) (DEFUN ECHCM-KILL-EPI-G-INTR (first n m f+1-basis mtrx-list)
(declare (declare
@ -702,7 +536,8 @@
(type matrix q)) (type matrix q))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (degr list) cmbn (with-cmbn
(degr list) cmbn
(unless (= degr f+1) (unless (= degr f+1)
(return-from rslt cmbn)) (return-from rslt cmbn))
(let ((rslt-cffcs (make-array m :element-type 'fixnum (let ((rslt-cffcs (make-array m :element-type 'fixnum
@ -715,7 +550,8 @@
(declare (declare
(list cmbn-mark basis-mark) (list cmbn-mark basis-mark)
(fixnum ic)) (fixnum ic))
(with--term (cffc gnrt) cmbn-mark (with--term
(cffc gnrt) cmbn-mark
(loop (when (eq :equal (s-cmpr gnrt (car basis-mark))) (loop (when (eq :equal (s-cmpr gnrt (car basis-mark)))
(return)) (return))
(pop basis-mark) (pop basis-mark)
@ -738,15 +574,6 @@
(push (term cffc (nth il f+1-basis)) term-list)))))))) (push (term cffc (nth il f+1-basis)) term-list))))))))
(the intr-mrph #'rslt)))) (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) (DEFUN ECHCM-KILL-EPI-H-INTR (cmpr first n m f-basis f+1-basis mtrx-list)
(declare (declare
@ -758,7 +585,8 @@
(declare (type matrix lqxp-1)) (declare (type matrix lqxp-1))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (degr list) cmbn (with-cmbn
(degr list) cmbn
(unless (= degr first) (unless (= degr first)
(return-from rslt (zero-cmbn (1+ degr)))) (return-from rslt (zero-cmbn (1+ degr))))
(let ((rslt-cffcs (make-array m :element-type 'fixnum (let ((rslt-cffcs (make-array m :element-type 'fixnum
@ -771,8 +599,10 @@
(declare (declare
(list cmbn-mark basis-mark) (list cmbn-mark basis-mark)
(fixnum ic)) (fixnum ic))
(with--term (cffc gnrt) cmbn-mark (with--term
(loop (when (eq :equal (funcall cmpr gnrt (car basis-mark))) (cffc gnrt) cmbn-mark
(loop (when (eq :equal (funcall cmpr gnrt
(car basis-mark)))
(return)) (return))
(pop basis-mark) (pop basis-mark)
(incf ic)) (incf ic))
@ -794,15 +624,6 @@
(push (term cffc (nth il f+1-basis)) term-list)))))))) (push (term cffc (nth il f+1-basis)) term-list))))))))
(the intr-mrph #'rslt)))) (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) (DEFUN ECHCM-WITHOUT-EPI (echcm first n m intr-f)
(declare (declare
@ -842,6 +663,7 @@
:strt :cmbn :strt :cmbn
:orgn `(echcm-without-epi ,echcm))))) :orgn `(echcm-without-epi ,echcm)))))
(DEFUN ECHCM-KILL-EPI (echcm first) (DEFUN ECHCM-KILL-EPI (echcm first)
(declare (declare
(type chain-complex echcm) (type chain-complex echcm)
@ -890,63 +712,6 @@
:orgn `(echcm-kill-epi-h ,echcm)) :orgn `(echcm-kill-epi-h ,echcm))
:orgn `(echcm-kill-epi ,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) (DEFUN KILL-EPI (chcm first)
(declare (declare
@ -966,6 +731,7 @@
:rrdct (cmps last-rdct (rrdct efhm)) :rrdct (cmps last-rdct (rrdct efhm))
:orgn `(kill-epi ,chcm ,first))))))) :orgn `(kill-epi ,chcm ,first)))))))
(DEFUN KILL-EPIS (chcm first end) (DEFUN KILL-EPIS (chcm first end)
(declare (declare
(type chain-complex chcm) (type chain-complex chcm)
@ -977,30 +743,6 @@
(kill-epi chcm indx)) (kill-epi chcm indx))
(efhm chcm)))) (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) (DEFUN CHML-CLSS-INTR (chcm first)
(declare (declare
@ -1032,7 +774,8 @@
(type matrix p-1 smith)) (type matrix p-1 smith))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (degr list) cmbn (with-cmbn
(degr list) cmbn
(unless (= degr first) (unless (= degr first)
(return-from rslt (zero-cmbn (- degr first)))) (return-from rslt (zero-cmbn (- degr first))))
(do ((rslt 0) (do ((rslt 0)
@ -1046,7 +789,8 @@
(declare (declare
(fixnum rslt) (fixnum rslt)
(list bmark cmark)) (list bmark cmark))
(with--term (cffc gnrt) cmark (with--term
(cffc gnrt) cmark
(loop (loop
(when (eq :equal (funcall cmpr gnrt (car bmark))) (when (eq :equal (funcall cmpr gnrt (car bmark)))
(return)) (return))
@ -1057,25 +801,6 @@
(incf ic)))))) (incf ic))))))
(the intr-mrph #'rslt)))) (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) (DEFUN CHML-CLSS (chcm first)
(declare (declare
@ -1087,22 +812,3 @@
:intr (chml-clss-intr chcm first) :intr (chml-clss-intr chcm first)
:strt :cmbn :strt :cmbn
:orgn `(chml-clss ,chcm ,first)))) :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
View 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)))