Extracted simple tests from homology-groups.lisp and searching-homology.lisp.
This commit is contained in:
Gerd Heber
parent
ded9d544ca
commit
911a74de68
@ -17,4 +17,6 @@
|
||||
(:file "circle")
|
||||
(:file "ccn")
|
||||
(:file "effective-homology-test")
|
||||
(:file "bicones-test")))
|
||||
(:file "bicones-test")
|
||||
(:file "homology-groups-test")
|
||||
(:file "searching-homology-test")))
|
||||
|
||||
@ -106,6 +106,7 @@
|
||||
|
||||
;; delta.lisp
|
||||
|
||||
DELTA
|
||||
DELTA-N-BASIS
|
||||
|
||||
;; effective-homology.lisp
|
||||
@ -121,6 +122,12 @@
|
||||
|
||||
FIBRATION-TOTAL
|
||||
|
||||
;; homology-groups
|
||||
|
||||
CHCM-HOMOLOGY
|
||||
CHCM-HOMOLOGY-GEN
|
||||
CHCM-MAT
|
||||
|
||||
;; k-pi-n.lisp
|
||||
|
||||
K-Z
|
||||
|
||||
@ -7,53 +7,53 @@
|
||||
(provide "homology-groups")
|
||||
|
||||
;;
|
||||
;; Computing ordinary homology-groups.
|
||||
;;
|
||||
;; Computing ordinary homology-groups.
|
||||
;;
|
||||
|
||||
|
||||
;; Functions.
|
||||
|
||||
(defun creer-matrice (n1 n2)
|
||||
(let ((mat (make-matrice
|
||||
:leftcol (make-array (1+ n1))
|
||||
:uplig (make-array (1+ n2)))))
|
||||
(setf (baselig mat 0) (make-t-mat :ilig 0 :icol 0))
|
||||
(setf (basecol mat 0) (baselig mat 0))
|
||||
(do ((i 1 (1+ i)))
|
||||
((> i n1))
|
||||
(setf (baselig mat i)
|
||||
(let ((mat (make-matrice
|
||||
:leftcol (make-array (1+ n1))
|
||||
:uplig (make-array (1+ n2)))))
|
||||
(setf (baselig mat 0) (make-t-mat :ilig 0 :icol 0))
|
||||
(setf (basecol mat 0) (baselig mat 0))
|
||||
(do ((i 1 (1+ i)))
|
||||
((> i n1))
|
||||
(setf (baselig mat i)
|
||||
(make-t-mat :ilig i :icol 0 :up (baselig mat (1- i))))
|
||||
(setf (left (baselig mat i)) (baselig mat i)))
|
||||
(do ((j 1 (1+ j)))
|
||||
((> j n2))
|
||||
(setf (basecol mat j)
|
||||
(setf (left (baselig mat i)) (baselig mat i)))
|
||||
(do ((j 1 (1+ j)))
|
||||
((> j n2))
|
||||
(setf (basecol mat j)
|
||||
(make-t-mat :ilig 0 :icol j :left (basecol mat (1- j))))
|
||||
(setf (up (basecol mat j)) (basecol mat j)))
|
||||
(setf (up (baselig mat 0)) (baselig mat n1))
|
||||
(setf (left (basecol mat 0)) (basecol mat n2))
|
||||
mat))
|
||||
(setf (up (basecol mat j)) (basecol mat j)))
|
||||
(setf (up (baselig mat 0)) (baselig mat n1))
|
||||
(setf (left (basecol mat 0)) (basecol mat n2))
|
||||
mat))
|
||||
|
||||
(defun chercher-hor (p ic)
|
||||
(do ((p2 p p1)
|
||||
(p1 (left p) (left p1)))
|
||||
((<= (icol p1) ic) p2)))
|
||||
(do ((p2 p p1)
|
||||
(p1 (left p) (left p1)))
|
||||
((<= (icol p1) ic) p2)))
|
||||
|
||||
(defun chercher-ver (p il)
|
||||
(do ((p2 p p1)
|
||||
(p1 (up p) (up p1)))
|
||||
((<= (ilig p1) il) p2)))
|
||||
(do ((p2 p p1)
|
||||
(p1 (up p) (up p1)))
|
||||
((<= (ilig p1) il) p2)))
|
||||
|
||||
(defun inserer-terme (pl pc val)
|
||||
(setf (left pl) (make-t-mat :val val
|
||||
:ilig (ilig pl)
|
||||
:icol (icol pc)
|
||||
:left (left pl)
|
||||
:up (up pc))
|
||||
(up pc) (left pl)))
|
||||
(setf (left pl) (make-t-mat :val val
|
||||
:ilig (ilig pl)
|
||||
:icol (icol pc)
|
||||
:left (left pl)
|
||||
:up (up pc))
|
||||
(up pc) (left pl)))
|
||||
|
||||
(defun supprimer-terme (pl pc)
|
||||
(setf (left pl) (left (left pl))
|
||||
(up pc) (up (up pc))))
|
||||
(setf (left pl) (left (left pl))
|
||||
(up pc) (up (up pc))))
|
||||
|
||||
(defun maj-terme (pl pc val)
|
||||
(if (= val 0)
|
||||
@ -63,176 +63,176 @@
|
||||
(inserer-terme pl pc val))))
|
||||
|
||||
(defun maj-ligne (mat il liste)
|
||||
(let ((ptl (baselig mat il)))
|
||||
(mapcar
|
||||
#'(lambda (elem)
|
||||
(maj-terme (chercher-hor ptl (first elem))
|
||||
(chercher-ver (basecol mat (first elem)) il)
|
||||
(second elem)))
|
||||
liste)
|
||||
ptl))
|
||||
(let ((ptl (baselig mat il)))
|
||||
(mapcar
|
||||
#'(lambda (elem)
|
||||
(maj-terme (chercher-hor ptl (first elem))
|
||||
(chercher-ver (basecol mat (first elem)) il)
|
||||
(second elem)))
|
||||
liste)
|
||||
ptl))
|
||||
|
||||
(defun maj-colonne (mat ic liste)
|
||||
(let ((ptc (basecol mat ic)))
|
||||
(mapcar
|
||||
#'(lambda (elem)
|
||||
(maj-terme (chercher-hor (baselig mat (first elem)) ic)
|
||||
(chercher-ver ptc (first elem))
|
||||
(second elem)))
|
||||
liste)
|
||||
ptc))
|
||||
(let ((ptc (basecol mat ic)))
|
||||
(mapcar
|
||||
#'(lambda (elem)
|
||||
(maj-terme (chercher-hor (baselig mat (first elem)) ic)
|
||||
(chercher-ver ptc (first elem))
|
||||
(second elem)))
|
||||
liste)
|
||||
ptc))
|
||||
|
||||
(defun maj-matrice (mat liste)
|
||||
(mapcar
|
||||
#'(lambda (elem) (apply #'maj-ligne mat elem))
|
||||
liste)
|
||||
#'(lambda (elem) (apply #'maj-ligne mat elem))
|
||||
liste)
|
||||
mat)
|
||||
|
||||
(defun disp-p (p)
|
||||
`((,(ilig p) ,(icol p) ,(val p))
|
||||
(,(ilig (left p)) ,(icol (left p)) ,(val (left p)))
|
||||
(,(ilig (up p)) ,(icol (up p)) ,(val (up p)))))
|
||||
`((,(ilig p) ,(icol p) ,(val p))
|
||||
(,(ilig (left p)) ,(icol (left p)) ,(val (left p)))
|
||||
(,(ilig (up p)) ,(icol (up p)) ,(val (up p)))))
|
||||
|
||||
(defun disp-ligne (mat il)
|
||||
(terpri)
|
||||
(princ "L")
|
||||
(princ il)
|
||||
(princ "=")
|
||||
(mapcar
|
||||
#'(lambda (elem)
|
||||
(princ "(")
|
||||
(princ (first elem))
|
||||
(princ ":")
|
||||
(princ (second elem))
|
||||
(princ ")"))
|
||||
(let ((ptl (baselig mat il))
|
||||
(res '()))
|
||||
(do ((pl (left ptl) (left pl)))
|
||||
((eq pl ptl))
|
||||
(push (list (icol pl) (val pl)) res))
|
||||
res))
|
||||
(terpri)
|
||||
(princ "L")
|
||||
(princ il)
|
||||
(princ "=")
|
||||
(mapcar
|
||||
#'(lambda (elem)
|
||||
(princ "(")
|
||||
(princ (first elem))
|
||||
(princ ":")
|
||||
(princ (second elem))
|
||||
(princ ")"))
|
||||
(let ((ptl (baselig mat il))
|
||||
(res '()))
|
||||
(do ((pl (left ptl) (left pl)))
|
||||
((eq pl ptl))
|
||||
(push (list (icol pl) (val pl)) res))
|
||||
res))
|
||||
(values ))
|
||||
|
||||
(defun disp-colonne (mat ic)
|
||||
(terpri)
|
||||
(princ "C")
|
||||
(princ ic)
|
||||
(princ "=")
|
||||
(mapcar
|
||||
#'(lambda (elem)
|
||||
(princ "(")
|
||||
(princ (first elem))
|
||||
(princ ":")
|
||||
(princ (second elem))
|
||||
(princ ")"))
|
||||
(let ((ptc (basecol mat ic))
|
||||
(res '()))
|
||||
(do ((pc (up ptc) (up pc)))
|
||||
((eq pc ptc))
|
||||
(push (list (ilig pc) (val pc)) res))
|
||||
res))
|
||||
(values ))
|
||||
(terpri)
|
||||
(princ "C")
|
||||
(princ ic)
|
||||
(princ "=")
|
||||
(mapcar
|
||||
#'(lambda (elem)
|
||||
(princ "(")
|
||||
(princ (first elem))
|
||||
(princ ":")
|
||||
(princ (second elem))
|
||||
(princ ")"))
|
||||
(let ((ptc (basecol mat ic))
|
||||
(res '()))
|
||||
(do ((pc (up ptc) (up pc)))
|
||||
((eq pc ptc))
|
||||
(push (list (ilig pc) (val pc)) res))
|
||||
res))
|
||||
(values ))
|
||||
|
||||
(defun nlig (mat) (1- (array-dimension (leftcol mat) 0)))
|
||||
(defun ncol (mat) (1- (array-dimension (uplig mat) 0)))
|
||||
|
||||
(defun disp-matrice (mat)
|
||||
(let ((nlig (nlig mat)))
|
||||
(do ((i 1 (1+ i)))
|
||||
((> i nlig))
|
||||
(disp-ligne mat i)))
|
||||
(done))
|
||||
(let ((nlig (nlig mat)))
|
||||
(do ((i 1 (1+ i)))
|
||||
((> i nlig))
|
||||
(disp-ligne mat i)))
|
||||
(done))
|
||||
|
||||
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setf (ext:package-lock :clos) nil))
|
||||
(DEFMETHOD PRINT-OBJECT ((mtrx matrice) stream)
|
||||
(declare (stream stream))
|
||||
(the matrice (progn
|
||||
(let ((nlig (nlig mtrx))
|
||||
(ncol (ncol mtrx)))
|
||||
(declare (fixnum nlig ncol))
|
||||
(format stream "~%========== MATRIX ~D lines + ~D columns ====="
|
||||
nlig ncol)
|
||||
(do ((ilig 1 (1+ ilig)))
|
||||
((> ilig nlig))
|
||||
(declare (fixnum ilig))
|
||||
(format stream "~%L~D=" ilig)
|
||||
(dolist (item (let ((baselig (baselig mtrx ilig)))
|
||||
(declare (type t-mat baselig))
|
||||
(do ((rslt +empty-list+ (cons t-mat rslt))
|
||||
(t-mat (left baselig) (left t-mat)))
|
||||
((eq t-mat baselig) rslt)
|
||||
(declare
|
||||
(list rslt)
|
||||
(type t-mat t-mat)))))
|
||||
(declare (type t-mat item))
|
||||
(format stream "[C~D=~D]" (icol item) (val item))))
|
||||
(format stream "~%========== END-MATRIX"))
|
||||
(let ((nlig (nlig mtrx))
|
||||
(ncol (ncol mtrx)))
|
||||
(declare (fixnum nlig ncol))
|
||||
(format stream "~%========== MATRIX ~D lines + ~D columns ====="
|
||||
nlig ncol)
|
||||
(do ((ilig 1 (1+ ilig)))
|
||||
((> ilig nlig))
|
||||
(declare (fixnum ilig))
|
||||
(format stream "~%L~D=" ilig)
|
||||
(dolist (item (let ((baselig (baselig mtrx ilig)))
|
||||
(declare (type t-mat baselig))
|
||||
(do ((rslt +empty-list+ (cons t-mat rslt))
|
||||
(t-mat (left baselig) (left t-mat)))
|
||||
((eq t-mat baselig) rslt)
|
||||
(declare
|
||||
(list rslt)
|
||||
(type t-mat t-mat)))))
|
||||
(declare (type t-mat item))
|
||||
(format stream "[C~D=~D]" (icol item) (val item))))
|
||||
(format stream "~%========== END-MATRIX"))
|
||||
mtrx)))
|
||||
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setf (ext:package-lock :clos) t))
|
||||
|
||||
|
||||
(defun disp-matrice-colonnes (mat)
|
||||
(let ((ncol (ncol mat)))
|
||||
(do ((i 1 (1+ i)))
|
||||
((> i ncol))
|
||||
(disp-colonne mat i)))
|
||||
(done))
|
||||
(let ((ncol (ncol mat)))
|
||||
(do ((i 1 (1+ i)))
|
||||
((> i ncol))
|
||||
(disp-colonne mat i)))
|
||||
(done))
|
||||
|
||||
(defun terme (mat i j)
|
||||
(let ((p (left (chercher-hor (baselig mat i) j))))
|
||||
(if (= j (icol p))
|
||||
(val (left p))
|
||||
nil)))
|
||||
(let ((p (left (chercher-hor (baselig mat i) j))))
|
||||
(if (= j (icol p))
|
||||
(val (left p))
|
||||
nil)))
|
||||
|
||||
(defun mat-aleat (n1 n2 dens x)
|
||||
(let ((mat (creer-matrice n1 n2))
|
||||
(n (truncate (* dens n1 n2)))
|
||||
(2x (* 2 x))
|
||||
(res nil))
|
||||
(dotimes (i n)
|
||||
(let* ((il (1+ (random n1)))
|
||||
(ic (1+ (random n2)))
|
||||
(val (let ((pval (- (random 2x) x)))
|
||||
(if (minusp pval)
|
||||
pval
|
||||
(1+ pval))))
|
||||
(elem (member il res
|
||||
:test #'(lambda (x y) (eql x (first y))))))
|
||||
(if elem
|
||||
(push (list ic val) (cadar elem))
|
||||
(push (list il (list (list ic val))) res))))
|
||||
(maj-matrice mat res)))
|
||||
(let ((mat (creer-matrice n1 n2))
|
||||
(n (truncate (* dens n1 n2)))
|
||||
(2x (* 2 x))
|
||||
(res nil))
|
||||
(dotimes (i n)
|
||||
(let* ((il (1+ (random n1)))
|
||||
(ic (1+ (random n2)))
|
||||
(val (let ((pval (- (random 2x) x)))
|
||||
(if (minusp pval)
|
||||
pval
|
||||
(1+ pval))))
|
||||
(elem (member il res
|
||||
:test #'(lambda (x y) (eql x (first y))))))
|
||||
(if elem
|
||||
(push (list ic val) (cadar elem))
|
||||
(push (list il (list (list ic val))) res))))
|
||||
(maj-matrice mat res)))
|
||||
|
||||
(defun op-elem (pl pc alpha)
|
||||
(if (eq (left pl) (up pc))
|
||||
(if (= alpha (val (left pl)))
|
||||
(supprimer-terme pl pc)
|
||||
(decf (val (left pl)) alpha))
|
||||
(inserer-terme pl pc (- alpha))))
|
||||
(if (eq (left pl) (up pc))
|
||||
(if (= alpha (val (left pl)))
|
||||
(supprimer-terme pl pc)
|
||||
(decf (val (left pl)) alpha))
|
||||
(inserer-terme pl pc (- alpha))))
|
||||
|
||||
(defun peigne-ver (mat ptl il)
|
||||
(if (< il (ilig ptl))
|
||||
(do ((res nil (cons (chercher-ver pl il)
|
||||
res))
|
||||
(pl (left ptl) (left pl)))
|
||||
((eq pl ptl) (nreverse res)))
|
||||
(do ((res nil (cons (chercher-ver (basecol mat (icol pl)) il)
|
||||
res))
|
||||
(pl (left ptl) (left pl)))
|
||||
((eq pl ptl) (nreverse res)))))
|
||||
(if (< il (ilig ptl))
|
||||
(do ((res nil (cons (chercher-ver pl il)
|
||||
res))
|
||||
(pl (left ptl) (left pl)))
|
||||
((eq pl ptl) (nreverse res)))
|
||||
(do ((res nil (cons (chercher-ver (basecol mat (icol pl)) il)
|
||||
res))
|
||||
(pl (left ptl) (left pl)))
|
||||
((eq pl ptl) (nreverse res)))))
|
||||
|
||||
(defun peigne-hor (mat ptc ic)
|
||||
(if (< ic (icol ptc))
|
||||
(do ((res nil (cons (chercher-hor pc ic)
|
||||
res))
|
||||
(pc (up ptc) (up pc)))
|
||||
((eq pc ptc) (nreverse res)))
|
||||
(do ((res nil (cons (chercher-hor (baselig mat (ilig pc)) ic)
|
||||
res))
|
||||
(pc (up ptc) (up pc)))
|
||||
((eq pc ptc) (nreverse res)))))
|
||||
(if (< ic (icol ptc))
|
||||
(do ((res nil (cons (chercher-hor pc ic)
|
||||
res))
|
||||
(pc (up ptc) (up pc)))
|
||||
((eq pc ptc) (nreverse res)))
|
||||
(do ((res nil (cons (chercher-hor (baselig mat (ilig pc)) ic)
|
||||
res))
|
||||
(pc (up ptc) (up pc)))
|
||||
((eq pc ptc) (nreverse res)))))
|
||||
|
||||
(defun op-lig (ptl1 ptl2 peigne lambda)
|
||||
(do ((pl1 (left ptl1) (left pl1))
|
||||
@ -471,70 +471,70 @@
|
||||
(prog ((B (identite (n-col M)))
|
||||
(res nil)
|
||||
(p1) (p2) (div))
|
||||
depart1
|
||||
(setf p1 (terme-minimal-matrice M))
|
||||
loop1
|
||||
(if (null p1)
|
||||
(go depart2)
|
||||
(if (= 1 (abs (val p1)))
|
||||
(go pivot1)
|
||||
(progn (setf p2 (reste-minimal-colonne M p1))
|
||||
(if (null p2)
|
||||
(progn (setf p2 (reste-minimal-ligne M p1))
|
||||
(if (null p2)
|
||||
(go pivot1)
|
||||
(go op-col1)))
|
||||
(go op-lig1)))))
|
||||
op-lig1
|
||||
(op-lig-n M (ilig p1) (ilig p2) (diviseur (val p2) (val p1)))
|
||||
(setf p1 p2)
|
||||
(go loop1)
|
||||
op-col1
|
||||
(setf div (diviseur (val p2) (val p1)))
|
||||
(op-col-n M (icol p1) (icol p2) div)
|
||||
(op-col-n B (icol p1) (icol p2) div)
|
||||
(op-lig-n N (icol p2) (icol p1) (- div))
|
||||
(setf p1 p2)
|
||||
(go loop1)
|
||||
pivot1
|
||||
(tuer-ligne N (icol p1))
|
||||
(pivot-parallele M B p1)
|
||||
(pivot M p1)
|
||||
(go depart1)
|
||||
depart1
|
||||
(setf p1 (terme-minimal-matrice M))
|
||||
loop1
|
||||
(if (null p1)
|
||||
(go depart2)
|
||||
(if (= 1 (abs (val p1)))
|
||||
(go pivot1)
|
||||
(progn (setf p2 (reste-minimal-colonne M p1))
|
||||
(if (null p2)
|
||||
(progn (setf p2 (reste-minimal-ligne M p1))
|
||||
(if (null p2)
|
||||
(go pivot1)
|
||||
(go op-col1)))
|
||||
(go op-lig1)))))
|
||||
op-lig1
|
||||
(op-lig-n M (ilig p1) (ilig p2) (diviseur (val p2) (val p1)))
|
||||
(setf p1 p2)
|
||||
(go loop1)
|
||||
op-col1
|
||||
(setf div (diviseur (val p2) (val p1)))
|
||||
(op-col-n M (icol p1) (icol p2) div)
|
||||
(op-col-n B (icol p1) (icol p2) div)
|
||||
(op-lig-n N (icol p2) (icol p1) (- div))
|
||||
(setf p1 p2)
|
||||
(go loop1)
|
||||
pivot1
|
||||
(tuer-ligne N (icol p1))
|
||||
(pivot-parallele M B p1)
|
||||
(pivot M p1)
|
||||
(go depart1)
|
||||
|
||||
depart2
|
||||
(setf p1 (terme-minimal-matrice N))
|
||||
loop2
|
||||
(if (null p1)
|
||||
(go depart3)
|
||||
(if (= 1 (abs (val p1)))
|
||||
(go pivot2)
|
||||
(progn (setf p2 (reste-minimal-ligne N p1))
|
||||
(if (null p2)
|
||||
(progn (setf p2 (reste-minimal-colonne N p1))
|
||||
(if (null p2)
|
||||
(go pivot2-torsion)
|
||||
(go op-lig2)))
|
||||
(go op-col2)))))
|
||||
op-lig2
|
||||
(setf div (diviseur (val p2) (val p1)))
|
||||
(op-col-n B (ilig p2) (ilig p1) (- div))
|
||||
(op-lig-n N (ilig p1) (ilig p2) div)
|
||||
(setf p1 p2)
|
||||
(go loop2)
|
||||
op-col2
|
||||
(op-col-n N (icol p1) (icol p2) (diviseur (val p2) (val p1)))
|
||||
(setf p1 p2)
|
||||
(go loop2)
|
||||
pivot2-torsion
|
||||
(setf res (cons (generateur-torsion-H* B N p1) res))
|
||||
pivot2
|
||||
(tuer-colonne B (ilig p1))
|
||||
(pivot N p1)
|
||||
(go depart2)
|
||||
depart2
|
||||
(setf p1 (terme-minimal-matrice N))
|
||||
loop2
|
||||
(if (null p1)
|
||||
(go depart3)
|
||||
(if (= 1 (abs (val p1)))
|
||||
(go pivot2)
|
||||
(progn (setf p2 (reste-minimal-ligne N p1))
|
||||
(if (null p2)
|
||||
(progn (setf p2 (reste-minimal-colonne N p1))
|
||||
(if (null p2)
|
||||
(go pivot2-torsion)
|
||||
(go op-lig2)))
|
||||
(go op-col2)))))
|
||||
op-lig2
|
||||
(setf div (diviseur (val p2) (val p1)))
|
||||
(op-col-n B (ilig p2) (ilig p1) (- div))
|
||||
(op-lig-n N (ilig p1) (ilig p2) div)
|
||||
(setf p1 p2)
|
||||
(go loop2)
|
||||
op-col2
|
||||
(op-col-n N (icol p1) (icol p2) (diviseur (val p2) (val p1)))
|
||||
(setf p1 p2)
|
||||
(go loop2)
|
||||
pivot2-torsion
|
||||
(setf res (cons (generateur-torsion-H* B N p1) res))
|
||||
pivot2
|
||||
(tuer-colonne B (ilig p1))
|
||||
(pivot N p1)
|
||||
(go depart2)
|
||||
|
||||
depart3
|
||||
(return (append res (terminer-H* B)))))
|
||||
depart3
|
||||
(return (append res (terminer-H* B)))))
|
||||
|
||||
|
||||
(DEFUN CHCM-MAT (chcm n)
|
||||
@ -551,7 +551,7 @@
|
||||
(type cmprf cmpr))
|
||||
(format t "~%Computing boundary-matrix in dimension ~D.
|
||||
Rank of the source-module : ~D.~2%"
|
||||
n (length sorc))
|
||||
n (length sorc))
|
||||
(let ((sorcl (length sorc))
|
||||
(mat (creer-matrice (length trgt) (length sorc)))
|
||||
(test #'(lambda (gnrt1 gnrt2)
|
||||
@ -569,47 +569,33 @@ Rank of the source-module : ~D.~2%"
|
||||
(when *homology-verbose*
|
||||
(clock)
|
||||
(format t "Computing the boundary of the generator ~D/~D (dimension ~D) :"
|
||||
i sorcl n)
|
||||
i sorcl n)
|
||||
(print (car mark)))
|
||||
(maj-colonne mat i
|
||||
(mapcar #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(list
|
||||
(1+ (position (gnrt term) trgt :test test))
|
||||
(cffc term)))
|
||||
(cmbn-list (? chcm n (car mark)))))
|
||||
(maj-colonne mat i
|
||||
(mapcar #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(list
|
||||
(1+ (position (gnrt term) trgt :test test))
|
||||
(cffc term)))
|
||||
(cmbn-list (? chcm n (car mark)))))
|
||||
(when *homology-verbose*
|
||||
(format t "~%End of computing.~2%")))
|
||||
mat)))
|
||||
mat)))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf d (delta 3))
|
||||
(chcm-mat d 2)
|
||||
(chcm-mat d 3)
|
||||
(chcm-mat d 4)
|
||||
|#
|
||||
|
||||
(defun chcm-homology (cc n)
|
||||
(declare (type chain-complex cc) (type fixnum n))
|
||||
(let ((rsl (homologie (chcm-mat cc n) (chcm-mat cc (1+ n)))))
|
||||
(declare (type list rsl))
|
||||
(declare (type list rsl))
|
||||
(format t "~3%Homology in dimension ~D :~%" n)
|
||||
(dolist (item rsl)
|
||||
(declare (type list item))
|
||||
(format t "~2%Component Z")
|
||||
(unless (zerop (first item))
|
||||
(unless (zerop (first item))
|
||||
(format t "/~DZ" (first item)))))
|
||||
(terpri) (terpri)
|
||||
(done))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf d (sphere 3))
|
||||
(chcm-homology d 2)
|
||||
(chcm-homology d 3)
|
||||
(chcm-homology d 4)
|
||||
|#
|
||||
|
||||
(defun chcm-homology-gen (cc n)
|
||||
(declare (type chain-complex cc) (type fixnum n))
|
||||
@ -620,7 +606,7 @@ Rank of the source-module : ~D.~2%"
|
||||
(dolist (item rsl)
|
||||
(declare (type list item))
|
||||
(format t "~%Component Z")
|
||||
(unless (zerop (first item))
|
||||
(unless (zerop (first item))
|
||||
(format t "/~DZ" (first item))))
|
||||
(terpri) (terpri)
|
||||
(setf rsl (mapcar #'cdr rsl))
|
||||
@ -629,22 +615,14 @@ Rank of the source-module : ~D.~2%"
|
||||
(mapcar #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(term (car term) (nth (cdr term) src)))
|
||||
item))
|
||||
rsl))
|
||||
item))
|
||||
rsl))
|
||||
(setf rsl (mapcar #'(lambda (item)
|
||||
(declare (type list item))
|
||||
(make-cmbn :degr n :list item))
|
||||
rsl))
|
||||
rsl))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf d (sphere 3))
|
||||
(chcm-homology-gen d 2)
|
||||
(chcm-homology-gen d 3)
|
||||
(chcm-homology-gen d 4)
|
||||
rsl))
|
||||
rsl))
|
||||
|
||||
|#
|
||||
|
||||
(defun chcm-homology-gen-old (cc n)
|
||||
(declare (type chain-complex cc) (type fixnum n))
|
||||
@ -655,18 +633,10 @@ Rank of the source-module : ~D.~2%"
|
||||
(dolist (item rsl)
|
||||
(declare (type list item))
|
||||
(format t "~2%Component Z")
|
||||
(unless (zerop (first item))
|
||||
(unless (zerop (first item))
|
||||
(format t "/~DZ" (first item)))
|
||||
(format t "~2%Generator :")
|
||||
(dolist (item2 (rest item))
|
||||
(declare (type cons item2))
|
||||
(format t "~%~D~6T* ~S" (car item2) (nth (cdr item2) src)))))
|
||||
(done))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf d (sphere 3))
|
||||
(chcm-homology-gen-old d 2)
|
||||
(chcm-homology-gen-old d 3)
|
||||
(chcm-homology-gen-old d 4)
|
||||
|#
|
||||
|
||||
@ -7,38 +7,37 @@
|
||||
(PROVIDE "searching-homology")
|
||||
|
||||
(DEFUN ECHCM (chcm)
|
||||
(rbcc (efhm chcm)))
|
||||
(rbcc (efhm chcm)))
|
||||
|
||||
|
||||
(DEFGENERIC HOMOLOGY (chcm degr1 &optional degr2))
|
||||
|
||||
|
||||
(DEFMETHOD HOMOLOGY ((chcm chain-complex) degr1 &optional (degr2 (1+ degr1)))
|
||||
(declare (fixnum degr1 degr2))
|
||||
(do ((degr degr1 (1+ degr)))
|
||||
((>= degr degr2))
|
||||
(declare (fixnum degr))
|
||||
(chcm-homology (echcm chcm) degr)
|
||||
(terpri) (clock) (terpri)))
|
||||
(declare (fixnum degr1 degr2))
|
||||
(do ((degr degr1 (1+ degr)))
|
||||
((>= degr degr2))
|
||||
(declare (fixnum degr))
|
||||
(chcm-homology (echcm chcm) degr)
|
||||
(terpri) (clock) (terpri)))
|
||||
|
||||
|
||||
(DEFGENERIC SEARCH-EFHM (chcm orgn))
|
||||
|
||||
|
||||
(DEFMETHOD SEARCH-EFHM (chcm orgn)
|
||||
(declare (ignore chcm orgn))
|
||||
nil)
|
||||
|
||||
|
||||
(DEFMETHOD SLOT-UNBOUND (class (chcm chain-complex) (slot-name (eql 'efhm)))
|
||||
(declare (ignore class))
|
||||
(the homotopy-equivalence
|
||||
(let ((efhm (search-efhm chcm (first (orgn chcm)))))
|
||||
(setf (efhm chcm)
|
||||
(or efhm
|
||||
(when (functionp (basis chcm))
|
||||
(trivial-hmeq chcm))
|
||||
(error "I don't know how to determine ~
|
||||
(declare (ignore class))
|
||||
(the homotopy-equivalence
|
||||
(let ((efhm (search-efhm chcm (first (orgn chcm)))))
|
||||
(setf (efhm chcm)
|
||||
(or efhm
|
||||
(when (functionp (basis chcm))
|
||||
(trivial-hmeq chcm))
|
||||
(error "I don't know how to determine ~
|
||||
the effective homology of:~@
|
||||
~A (Origin: ~A)." chcm (orgn chcm)))))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf d (delta 3))
|
||||
(homology d 0)
|
||||
|#
|
||||
|
||||
34
test/homology-groups-test.lisp
Normal file
34
test/homology-groups-test.lisp
Normal file
@ -0,0 +1,34 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
(test chcm-mat
|
||||
(progn
|
||||
(let ((d (cat:delta 3)))
|
||||
(princ (cat:chcm-mat d 2))
|
||||
(princ (cat:chcm-mat d 3))
|
||||
(princ (cat:chcm-mat d 4)))))
|
||||
|
||||
(test chcm-homology
|
||||
(progn
|
||||
(let ((d (cat:sphere 3)))
|
||||
(princ (cat:chcm-homology d 2))
|
||||
(princ (cat:chcm-homology d 3))
|
||||
(princ (cat:chcm-homology d 4)))))
|
||||
|
||||
(test chcm-homology-gen
|
||||
(progn
|
||||
(let ((d (cat:sphere 3)))
|
||||
(princ (cat:chcm-homology-gen d 2))
|
||||
(princ (cat:chcm-homology-gen d 3))
|
||||
(princ (cat:chcm-homology-gen d 4)))))
|
||||
|
||||
|
||||
#|
|
||||
()
|
||||
(setf d (sphere 3))
|
||||
(chcm-homology-gen-old d 2)
|
||||
(chcm-homology-gen-old d 3)
|
||||
(chcm-homology-gen-old d 4)
|
||||
|#
|
||||
10
test/searching-homology-test.lisp
Normal file
10
test/searching-homology-test.lisp
Normal file
@ -0,0 +1,10 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
(test homology
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let ((d (cat:delta 3)))
|
||||
(princ (cat:homology d 0)))))
|
||||
Loading…
Reference in New Issue
Block a user