Homotopy computation of simplicial sets which are simply connected but not necessarily 1-reduced considered

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))))
@@ -51,7 +161,8 @@
 
 
 (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))))
@@ -70,7 +181,8 @@
 
 
 (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))))
@@ -89,7 +201,8 @@
 
 
 (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))))
@@ -122,26 +235,29 @@
 (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)
+                                      (kill-epi ft 1)
                                       (construct-space-iterative ft (cdr list) indx)))))
-          ((equal (car list) 2) (let* ((ch (chml-clss chcm 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)
+                                      (kill-epi ft 2)
                                       (construct-space-iterative ft (cdr list) indx)))))
-          (t (let* ((ch (chml-clss chcm 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)
+                   (kill-epi ft (cdr list))
                    (construct-space-iterative ft (cdr list) indx)))))
           )))   
 
@@ -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)))
@@ -211,8 +326,3 @@
       nil)))
 
 
-
-
-
-
-