diff --git a/src/anromero/homotopy.lisp b/src/anromero/homotopy.lisp index f4aadfa..e925299 100644 --- a/src/anromero/homotopy.lisp +++ b/src/anromero/homotopy.lisp @@ -12,6 +12,116 @@ (provide "homotopy") +(DEFUN CHML-CLSS-INTR-NOT-1REDUCED (chcm first) + (declare + (type chain-complex chcm) + (fixnum first)) + (let* ((echcm (echcm chcm)) + (cmpr (cmpr echcm)) + (basis (basis echcm)) + (f-basis (funcall basis first)) + (mtrx1 (gnrt-list-to-mtrx (kernel (chcm-mtrx echcm first)))) + (mtrx2 (chcm-mtrx echcm (1+ first))) + (smith-list-1 (smith mtrx1)) + (p1 (first smith-list-1)) + (p1-1 (second smith-list-1)) + (d1 (third smith-list-1)) + (p1-1Xmtrx2 (mtrx-prdc p1-1 mtrx2)) + (p1Xd1 (copy-mtrx p1)) + (d1-1Xp1-1Xmtrx2 (copy-mtrx p1-1Xmtrx2))) + (declare + (list smith-list-1) + (type matrix p1 p1-1 d1 p1-1Xmtrx2 p1Xd1 d1-1Xp1-1Xmtrx2)) + (progn + (let* ((line-n-1 (line-number p1)) + (column-n-1 (column-number p1))) + (declare (type fixnum line-n-1 column-n-1)) + (dotimes (ic column-n-1) + (declare (type fixnum ic)) + (if (and (< ic (line-number d1)) (< ic (column-number d1))) + (let ((d (aref d1 ic ic))) + (declare (type fixnum d)) + (dotimes (il line-n-1) + (declare (type fixnum il)) + (if (and (not (eql 1 d)) (not (eql 0 d))) + (setf (aref p1Xd1 il ic) (* d (aref p1Xd1 il ic))))))))) + (let* ((line-n-2 (line-number p1-1Xmtrx2)) + (column-n-2 (column-number p1-1Xmtrx2))) + (declare (type fixnum line-n-2 column-n-2)) + (dotimes (il line-n-2) + (declare (type fixnum il)) + (if (and (< il (line-number d1)) (< il (column-number d1))) + (let ((d (aref d1 il il))) + (if (and (not (eql 1 d)) (not (eql 0 d))) + (dotimes (ic column-n-2) + (declare (type fixnum ic)) + (setf (aref d1-1Xp1-1Xmtrx2 il ic) + (floor (aref d1-1Xp1-1Xmtrx2 il ic) d)))))))) + (let* ((mtrx-list (smith d1-1Xp1-1Xmtrx2)) + (smith (third mtrx-list)) + (p-1 (mtrx-prdc (second mtrx-list) p1-1)) + + (n (line-number smith)) + (m (column-number smith)) + (diag-indx + (dotimes (indx (min n m) + (if (> n m) + m + (error "In CHML-CLSS, the cohomology-ring ~@ + is null."))) + (declare (fixnum indx)) + (unless (= 1 (aref smith indx indx)) + (return indx))) + )) + (declare + (type chain-complex echcm) + (type cmprf cmpr) + (type basis basis) + (fixnum n m diag-indx) + (list f-basis mtrx-list) + (type matrix p-1 smith)) + (flet ((rslt (cmbn) + (declare (type cmbn cmbn)) + (with-cmbn + (degr list) cmbn + (unless (= degr first) + (return-from rslt (zero-cmbn (- degr first)))) + (do ((rslt 0) + (bmark f-basis) + (ic 0) + (cmark list (cdr cmark))) + ((endp cmark) + (if (zerop rslt) + (zero-cmbn 0) + (term-cmbn 0 rslt :z-gnrt))) + (declare + (fixnum rslt) + (list bmark cmark)) + (with--term + (cffc gnrt) cmark + (loop + (when (eq :equal (funcall cmpr gnrt (car bmark))) + (return)) + (pop bmark) + (incf ic)) + (incf rslt (* cffc (aref p-1 diag-indx ic))) + (pop bmark) + (incf ic)))))) + (the intr-mrph #'rslt)))))) + + +(DEFUN CHML-CLSS-NOT-1REDUCED (chcm first) + (declare + (type chain-complex chcm) + (fixnum first)) + (the morphism + (build-mrph + :sorc (echcm chcm) :trgt (z-chcm) :degr (- first) + :intr (chml-clss-intr-not-1reduced chcm first) + :strt :cmbn + :orgn `(chml-clss-not-1reduced ,chcm ,first)))) + + (DEFUN CHCM-HOMOLOGY-FORMAT (cc n) (declare (type chain-complex cc) (type fixnum n)) (let ((rsl (homologie (chcm-mat cc n) (chcm-mat cc (1+ n)))) @@ -29,12 +139,12 @@ (DEFUN HOMOLOGY-FORMAT (chcm degr1 &optional (degr2 (1+ degr1))) (declare (fixnum degr1 degr2)) (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)) - result_hom)) + (do ((degr degr1 (1+ degr))) + ((>= degr degr2)) + (declare (fixnum degr)) + (setf result_hom (chcm-homology-format (echcm chcm) degr)) + (terpri) (clock) (terpri)) + result_hom)) (DEFUN FIRST-NON-NULL-HOMOLOGY-GROUP-AUX (chcm n limit) @@ -44,14 +154,15 @@ (if hf (1- n) (first-non-null-homology-group-aux chcm (1+ n) limit))))) - - + + (DEFUN FIRST-NON-NULL-HOMOLOGY-GROUP (chcm limit) (first-non-null-homology-group-aux chcm 1 limit)) (DEFUN COMPUTE-HOMOTOPY-Z-XSLT (n-hom obj indx) - (let* ((ch (chml-clss (eval obj) indx)) + (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))) (ft (fibration-total (eval fib))) (result (homology-format (eval ft) (1+ indx)))) @@ -64,13 +175,14 @@ (compute-homotopy-z-xslt n-hom ft (1+ indx)) (if (string= "Z/2Z " result) (compute-homotopy-z2-xslt n-hom ft (1+ indx)) - (if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) + (if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) (compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2)))) (compute-homotopy-several-xslt n-hom ft (1+ indx) result)))))))) (DEFUN COMPUTE-HOMOTOPY-Z2-XSLT (n-hom obj indx) - (let* ((ch (chml-clss (eval obj) indx)) + (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))) (ft (fibration-total (eval fib))) (result (homology-format (eval ft) (1+ indx)))) @@ -79,17 +191,18 @@ (if (string= "NIL" result) ;; nil (let ((first-non-null (first-non-null-homology-group ft n-hom))) (if first-non-null (compute-homotopy ft n-hom first-non-null) nil)) - (if (string= "Z " result) - (compute-homotopy-z-xslt n-hom ft (1+ indx)) - (if (string= "Z/2Z " result) - (compute-homotopy-z2-xslt n-hom ft (1+ indx)) - (if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) + (if (string= "Z " result) + (compute-homotopy-z-xslt n-hom ft (1+ indx)) + (if (string= "Z/2Z " result) + (compute-homotopy-z2-xslt n-hom ft (1+ indx)) + (if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) (compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2)))) (compute-homotopy-several-xslt n-hom ft (1+ indx) result)))))))) (DEFUN COMPUTE-HOMOTOPY-ZP-XSLT (n-hom obj indx n) - (let* ((ch (chml-clss (eval obj) indx)) + (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))) (ft (fibration-total (eval fib))) (result (homology-format (eval ft) (1+ indx)))) @@ -98,19 +211,19 @@ (if (string= "NIL" result) ;; nil (let ((first-non-null (first-non-null-homology-group ft n-hom))) (if first-non-null (compute-homotopy ft n-hom first-non-null) nil)) - (if (string= "Z " result) - (compute-homotopy-z-xslt n-hom ft (1+ indx)) - (if (string= "Z/2Z " result) - (compute-homotopy-z2-xslt n-hom ft (1+ indx)) - (if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) - (compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2)))) - (compute-homotopy-several-xslt n-hom ft (1+ indx) result)))))))) + (if (string= "Z " result) + (compute-homotopy-z-xslt n-hom ft (1+ indx)) + (if (string= "Z/2Z " result) + (compute-homotopy-z2-xslt n-hom ft (1+ indx)) + (if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) + (compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2)))) + (compute-homotopy-several-xslt n-hom ft (1+ indx) result)))))))) (DEFUN SPLIT-COMPONENTS (string) (let ((term (if (string= string "") "" (if (string= string "NIL") nil - (subseq string 0 2))))) + (subseq string 0 2))))) (if (string= term "Z ") (cons 1 (split-components (subseq string 2))) (if (string= term "Z/") @@ -122,27 +235,30 @@ (DEFUN CONSTRUCT-SPACE-ITERATIVE (chcm list indx) (if (endp list) chcm - (cond ((equal (car list) 1) (let* ((ch (chml-clss chcm indx)) + (cond ((equal (car list) 1) (let* ((ch (if (= 0 (length (basis (echcm chcm) 1))) (chml-clss chcm indx) + (chml-clss-not-1reduced chcm indx))) (fib (z-whitehead chcm ch)) (ft (fibration-total fib))) (if (endp (cdr list)) ft - (progn - (kill-epis ft 1 indx) - (construct-space-iterative ft (cdr list) indx))))) - ((equal (car list) 2) (let* ((ch (chml-clss chcm indx)) + (progn + (kill-epi ft 1) + (construct-space-iterative ft (cdr list) indx))))) + ((equal (car list) 2) (let* ((ch (if (= 0 (length (basis (echcm chcm) 1))) (chml-clss chcm indx) + (chml-clss-not-1reduced chcm indx))) (fib (z2-whitehead chcm ch)) (ft (fibration-total fib))) (if (endp (cdr list)) ft - (progn - (kill-epis ft 1 indx) - (construct-space-iterative ft (cdr list) indx))))) - (t (let* ((ch (chml-clss chcm indx)) + (progn + (kill-epi ft 2) + (construct-space-iterative ft (cdr list) indx))))) + (t (let* ((ch (if (= 0 (length (basis (echcm chcm) 1))) (chml-clss chcm indx) + (chml-clss-not-1reduced chcm indx))) (fib (zp-whitehead (car list) chcm ch)) (ft (fibration-total fib))) (if (endp (cdr list)) ft - (progn - (kill-epis ft 1 indx) - (construct-space-iterative ft (cdr list) indx))))) + (progn + (kill-epi ft (cdr list)) + (construct-space-iterative ft (cdr list) indx))))) ))) @@ -152,20 +268,20 @@ (if (= (1+ indx) n-hom) (homology-format (eval ft) n-hom) (if (string= "NIL" result) nil - (if (string= "Z " result) - (compute-homotopy-z-xslt n-hom ft (1+ indx)) - (if (string= "Z/2Z " result) - (compute-homotopy-z2-xslt n-hom ft (1+ indx)) - (if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) - (compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2)))) - (compute-homotopy-several-xslt n-hom ft (1+ indx) result)))))))) + (if (string= "Z " result) + (compute-homotopy-z-xslt n-hom ft (1+ indx)) + (if (string= "Z/2Z " result) + (compute-homotopy-z2-xslt n-hom ft (1+ indx)) + (if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) + (compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2)))) + (compute-homotopy-several-xslt n-hom ft (1+ indx) result)))))))) (DEFUN COMPUTE-HOMOTOPY2-XSLT (n-hom obj degree hom) (cond ((= n-hom 0) - (format nil "Z") - ) + (format nil "Z") + ) ((< n-hom (1+ degree) ) (format nil "")) ((= n-hom (1+ degree)) @@ -185,7 +301,6 @@ (compute-homotopy2-xslt n-hom smst degree hom))) - (DEFUN HOMOTOPY (smst degr) (let (;; we obtain the first non null homology group (first-non-null (first-non-null-homology-group smst degr))) @@ -199,7 +314,7 @@ (format t "/~DZ" item))) (terpri) (terpri))) (progn - (format t "~3%Homotopy in dimension ~D :~2%" degr) + (format t "~3%Homotopy in dimension ~D :~2%" degr) (terpri) (terpri))))) @@ -211,8 +326,3 @@ nil))) - - - - -