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