diff --git a/src/anromero/homotopy.lisp b/src/anromero/homotopy.lisp index e925299..1b75e0e 100644 --- a/src/anromero/homotopy.lisp +++ b/src/anromero/homotopy.lisp @@ -11,11 +11,14 @@ (provide "homotopy") +(DEFVAR *test-comments* nil) (DEFUN CHML-CLSS-INTR-NOT-1REDUCED (chcm first) (declare (type chain-complex chcm) (fixnum first)) + (when *test-comments* + (print "Function CHML-CLSS-INTR-NOT-1REDUCED called")) (let* ((echcm (echcm chcm)) (cmpr (cmpr echcm)) (basis (basis echcm)) @@ -114,6 +117,8 @@ (declare (type chain-complex chcm) (fixnum first)) + (when *test-comments* + (print "Function CHML-CLSS-NOT-1REDUCED called")) (the morphism (build-mrph :sorc (echcm chcm) :trgt (z-chcm) :degr (- first) @@ -124,6 +129,8 @@ (DEFUN CHCM-HOMOLOGY-FORMAT (cc n) (declare (type chain-complex cc) (type fixnum n)) + (when *test-comments* + (print "Function CHCM-HOMOLOGY-FORMAT called")) (let ((rsl (homologie (chcm-mat cc n) (chcm-mat cc (1+ n)))) (str nil)) (declare (type list rsl)) @@ -138,16 +145,21 @@ (DEFUN HOMOLOGY-FORMAT (chcm degr1 &optional (degr2 (1+ degr1))) (declare (fixnum degr1 degr2)) + (when *test-comments* + (print "Function HOMOLOGY-FORMAT called")) (let ((result_hom nil)) (do ((degr degr1 (1+ degr))) ((>= degr degr2)) (declare (fixnum degr)) (setf result_hom (chcm-homology-format (echcm chcm) degr)) - (terpri) (clock) (terpri)) + (when *homology-verbose* + (terpri) (clock) (terpri))) result_hom)) (DEFUN FIRST-NON-NULL-HOMOLOGY-GROUP-AUX (chcm n limit) + (when *test-comments* + (print "Function FIRST-NON-NULL-HOMOLOGY-GROUP-AUX called")) (if (> n limit) nil (let ((hf (homology-format chcm n))) @@ -157,10 +169,14 @@ (DEFUN FIRST-NON-NULL-HOMOLOGY-GROUP (chcm limit) + (when *test-comments* + (print "Function FIRST-NON-NULL-HOMOLOGY-GROUP called")) (first-non-null-homology-group-aux chcm 1 limit)) (DEFUN COMPUTE-HOMOTOPY-Z-XSLT (n-hom obj indx) + (when *test-comments* + (print "Function COMPUTE-HOMOTOPY-Z-XSLT called")) (let* ((ch (if (= 0 (length (basis (echcm obj) 1))) (chml-clss (eval obj) indx) (chml-clss-not-1reduced (eval obj) indx))) (fib (z-whitehead (eval obj) (eval ch))) @@ -181,6 +197,8 @@ (DEFUN COMPUTE-HOMOTOPY-Z2-XSLT (n-hom obj indx) + (when *test-comments* + (print "Function COMPUTE-HOMOTOPY-Z2-XSLT called")) (let* ((ch (if (= 0 (length (basis (echcm obj) 1))) (chml-clss (eval obj) indx) (chml-clss-not-1reduced (eval obj) indx))) (fib (z2-whitehead (eval obj) (eval ch))) @@ -201,6 +219,8 @@ (DEFUN COMPUTE-HOMOTOPY-ZP-XSLT (n-hom obj indx n) + (when *test-comments* + (print "Function COMPUTE-HOMOTOPY-ZP-XSLT called")) (let* ((ch (if (= 0 (length (basis (echcm obj) 1))) (chml-clss (eval obj) indx) (chml-clss-not-1reduced (eval obj) indx))) (fib (zp-whitehead n (eval obj) (eval ch))) @@ -221,6 +241,8 @@ (DEFUN SPLIT-COMPONENTS (string) + (when *test-comments* + (print "Function SPLIT-COMPONENTS called")) (let ((term (if (string= string "") "" (if (string= string "NIL") nil (subseq string 0 2))))) @@ -233,6 +255,8 @@ (DEFUN CONSTRUCT-SPACE-ITERATIVE (chcm list indx) + (when *test-comments* + (print "Function CONSTRUCT-SPACE-ITERATIVE called")) (if (endp list) chcm (cond ((equal (car list) 1) (let* ((ch (if (= 0 (length (basis (echcm chcm) 1))) (chml-clss chcm indx) @@ -263,6 +287,8 @@ (DEFUN COMPUTE-HOMOTOPY-SEVERAL-XSLT (n-hom obj indx hom) + (when *test-comments* + (print "Function COMPUTE-HOMOTOPY-SEVERAL-XSLT called")) (let* ((ft (construct-space-iterative obj (split-components hom) indx)) (result (homology-format ft (1+ indx)))) (if (= (1+ indx) n-hom) @@ -278,6 +304,8 @@ (DEFUN COMPUTE-HOMOTOPY2-XSLT (n-hom obj degree hom) + (when *test-comments* + (print "Function COMPUTE-HOMOTOPY2-XSLT called")) (cond ((= n-hom 0) (format nil "Z") @@ -297,11 +325,15 @@ (DEFUN COMPUTE-HOMOTOPY (smst n-hom degree) + (when *test-comments* + (print "Function COMPUTE-HOMOTOPY called")) (let ((hom (homology-format smst (1+ degree)))) (compute-homotopy2-xslt n-hom smst degree hom))) (DEFUN HOMOTOPY (smst degr) + (when *test-comments* + (print "Function HOMOTOPY called")) (let (;; we obtain the first non null homology group (first-non-null (first-non-null-homology-group smst degr))) (if first-non-null @@ -319,6 +351,8 @@ (DEFUN HOMOTOPY-LIST (smst degr) + (when *test-comments* + (print "Function HOMOTOPY-LIST called")) (let (;; we obtain the first non null homology group (first-non-null (first-non-null-homology-group smst degr))) (if first-non-null diff --git a/src/homology-groups.lisp b/src/homology-groups.lisp index d2049bf..eaf9cb0 100644 --- a/src/homology-groups.lisp +++ b/src/homology-groups.lisp @@ -551,9 +551,10 @@ (declare (list sorc trgt) (type cmprf cmpr)) +(when *homology-verbose* (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) diff --git a/src/searching-homology.lisp b/src/searching-homology.lisp index 95333fd..d2814fa 100644 --- a/src/searching-homology.lisp +++ b/src/searching-homology.lisp @@ -21,7 +21,8 @@ ((>= degr degr2)) (declare (fixnum degr)) (chcm-homology (echcm chcm) degr) - (terpri) (clock) (terpri))) + (when *homology-verbose* + (terpri) (clock) (terpri)))) (DEFGENERIC SEARCH-EFHM (chcm orgn))