Computation of spectral sequences added.

kenzo.asd

@@ -57,16 +57,15 @@
              (:file "cl-space-efhm")
              (:file "whitehead")
              (:file "smith")
+             (:file "sage-interface")             
              (:module "anromero"
              :components
 	     ((:file "resolutions")
 	     (:file "cylinders")
              (:file "fundamental-classes")
              (:file "homotopy")	     
-		(:file "bicomplexes")))
+             (:file "bicomplexes")
-		#|
-             ((:file "bicomplexes")
              (:file "filtered-complexes")
-             (:file "spectral-sequences")))
+             (:file "spectral-sequences")
-             |#
+	     (:file "persistent-homology")             
-            ))))
+            ))))))

src/anromero/bicomplexes.lisp

@@ -250,7 +250,7 @@
         chcm)))
 
 #|
-(setf bc (Build-Bicm :bcbasis #'bas :dffr1 #'dif1 :dffr2 #'dif2 :cmpr 's-cmpr 
+(setf bc (Build-Bicm :bcbasis #'bas :dffr1 #'dif1 :dffr2 #'dif2 :cmpr #'s-cmpr 
           :orgn '(BC-test)))
 (dotimes (i 5)
    (print (basis bc i)))

src/anromero/filtered-complexes.lisp

@@ -19,11 +19,17 @@
 (SETF *flcc-list* +empty-list+)
 (PUSHNEW '*flcc-list* *list-list*)
 
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((flcm FILTERED-CHAIN-COMPLEX) stream)
 (the FILTERED-CHAIN-COMPLEX
    (progn
       (format stream "[K~D Filtered-Chain-Complex]" (idnm flcm))
      flcm)))
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) t))
+
+
 
 (DEFUN FLCC (idnm)
    (declare (type fixnum idnm))
@@ -64,7 +70,7 @@
    (declare
       (type chain-complex chcm)
       (type chcm-flin flin)
- (list orgn))
+      (type list orgn))
    (the FILTERED-CHAIN-COMPLEX
       (progn
          (change-class chcm 'FILTERED-CHAIN-COMPLEX)
@@ -84,18 +90,19 @@
    (declare
       (type chain-complex chcm)
       (type chcm-flin flin)
-   (list flin-orgn))
+      ;;(type list flin-orgn)
+)
    (the FILTERED-CHAIN-COMPLEX
       (progn
          (change-class chcm 'FILTERED-CHAIN-COMPLEX)
-         (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+        (let* ((orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
-         (let ((already (find orgn *flcc-list* :key #'orgn :test #'equal)))
+               (already (find orgn *flcc-list* :key #'orgn :test #'equal)))
           (declare (type (or null FILTERED-CHAIN-COMPLEX) already))
           (when already
-	     (return-from change-chcm-to-flcc already)))
+            (return-from change-chcm-to-flcc already))
          (setf (slot-value chcm 'flin) flin)
          (setf (slot-value chcm 'orgn) orgn)
-         (push chcm *flcc-list*)
+         (push chcm *flcc-list*))
          chcm)))
 
 
@@ -289,15 +296,21 @@
 (DEFCLASS FILTERED-COALGEBRA (filtered-chain-complex coalgebra)
     ())
 
-(DEFVAR *FLCLGB-LIST*)
+(DEFVAR *FLCLGB-LIST*
+    "The variable *FLCLGB-LIST* is bound to a list of user created filtered coalgebras")
+
 (SETF *FLCLGB-LIST* +empty-list+)
 (PUSHNEW '*FLCLGB-LIST* *list-list*)
 
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((flclgb FILTERED-COALGEBRA) stream)
 (the FILTERED-COALGEBRA
    (progn
       (format stream "[K~D FILTERED-COALGEBRA]" (idnm flclgb))
      flclgb)))
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) t))
 
 (DEFUN FltrClgb (idnm)
    (declare (type fixnum idnm))
@@ -323,7 +336,7 @@
                (return-from build-FltrClgb already)))
          (let ((rslt (build-clgb :cmpr cmpr :basis basis :bsgn bsgn
                         :intr-dffr intr-dffr :dffr-strt dffr-strt
-				 :intr-cprd intr-cprf :cprd-strt cprd-strt
+                       :intr-cprd intr-cprd :cprd-strt cprd-strt
                         :orgn orgn)))
             (declare (type coalgebra rslt))
             (change-class rslt 'FILTERED-COALGEBRA)
@@ -333,35 +346,41 @@
 
 (defmethod change-chcm-to-flcc ((chcm coalgebra) flin flin-orgn )
    (declare      
-   
       (type chcm-flin flin)
-   (list flin-orgn))
+      ;;(type list flin-orgn)
+)
    (the FILTERED-COALGEBRA
       (progn
          (change-class chcm 'FILTERED-COALGEBRA)
-         (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+        (let* ((orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
-         (let ((already (find orgn *flclgb-list* :key #'orgn :test #'equal)))
+              (already (find orgn *flclgb-list* :key #'orgn :test #'equal)))
             (declare (type (or null FILTERED-COALGEBRA) already))
             (when already
-	     (return-from change-chcm-to-flcc already)))
+               (return-from change-chcm-to-flcc already))
          (setf (slot-value chcm 'flin) flin)
           (setf (slot-value chcm 'orgn) orgn)
           (push chcm *flCLGB-list*)
-         chcm)))
+         chcm))))
 
 
 (DEFCLASS FILTERED-ALGEBRA (filtered-chain-complex algebra)
     ())
 
-(DEFVAR *FLALGB-LIST*)
+(DEFVAR *FLALGB-LIST*
+    "The variable *FLALGB-LIST* is bound to a list of user created filtered algebras.")
+
 (SETF *FLALGB-LIST* +empty-list+)
 (PUSHNEW '*FLALGB-LIST* *list-list*)
 
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((flalgb FILTERED-ALGEBRA) stream)
 (the FILTERED-ALGEBRA
    (progn
       (format stream "[K~D FILTERED-ALGEBRA]" (idnm flalgb))
      flalgb)))
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) t))
 
 (DEFUN FltrAlgb (idnm)
    (declare (type fixnum idnm))
@@ -387,7 +406,7 @@
                (return-from build-FltrAlgb already)))
          (let ((rslt (build-algb :cmpr cmpr :basis basis :bsgn bsgn
                         :intr-dffr intr-dffr :dffr-strt dffr-strt
-				 :intr-aprd intr-aprf :aprd-strt aprd-strt
+                       :intr-aprd intr-aprd :aprd-strt aprd-strt
                         :orgn orgn)))
             (declare (type algebra rslt))
             (change-class rslt 'FILTERED-ALGEBRA)
@@ -397,35 +416,43 @@
 
 (defmethod change-chcm-to-flcc ((chcm algebra) flin flin-orgn )
    (declare      
-   
       (type chcm-flin flin)
-   (list flin-orgn))
+      ;;(list flin-orgn)
+)
    (the FILTERED-ALGEBRA
       (progn
          (change-class chcm 'FILTERED-ALGEBRA)
-         (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+       ;;(setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
-         (let ((already (find orgn *flalgb-list* :key #'orgn :test #'equal)))
+        (let* (
+              (orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+              (already (find orgn *flalgb-list* :key #'orgn :test #'equal)))
             (declare (type (or null FILTERED-ALGEBRA) already))
             (when already
-	     (return-from change-chcm-to-flcc already)))
+               (return-from change-chcm-to-flcc already))
          (setf (slot-value chcm 'flin) flin)
           (setf (slot-value chcm 'orgn) orgn)
           (push chcm *flaLGB-list*)
-         chcm)))
+         chcm))))
 
 
 (DEFCLASS FILTERED-HOPF-ALGEBRA (filtered-chain-complex hopf-algebra)
     ())
 
-(DEFVAR *FLHOPF-LIST*)
+(DEFVAR *FLHOPF-LIST*
+    "The variable *FLHOPF-LIST* is bound to a list of user created filtered Hopf algebras.")
+
 (SETF *FLHOPF-LIST* +empty-list+)
 (PUSHNEW '*FLHOPF-LIST* *list-list*)
 
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((flhopf FILTERED-HOPF-ALGEBRA) stream)
 (the FILTERED-HOPF-ALGEBRA
    (progn
       (format stream "[K~D FILTERED-HOPF-ALGEBRA]" (idnm flhopf))
      flhopf)))
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) t))
 
 (DEFUN FltrHopf (idnm)
    (declare (type fixnum idnm))
@@ -434,35 +461,43 @@
 
 (defmethod change-chcm-to-flcc ((chcm hopf-algebra) flin flin-orgn )
    (declare      
-   
       (type chcm-flin flin)
-   (list flin-orgn))
+      ;;(list flin-orgn)
-  (the FILTERED-hofp-algebra
+)
+   (the FILTERED-hopf-algebra
       (progn
-         (change-class chcm 'FILTERED-hopf-COALGEBRA)
+         (change-class chcm 'FILTERED-hopf-ALGEBRA)
-	 (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+        ;;(setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
-         (let ((already (find orgn *flhopf-list* :key #'orgn :test #'equal)))
+        (let* (
-	   (declare (type (or null FILTERED-HOPF-COALGEBRA) already))
+               (orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+               (already (find orgn *flhopf-list* :key #'orgn :test #'equal)))
+          (declare (type (or null FILTERED-HOPF-ALGEBRA) already))
           (when already
-	     (return-from change-chcm-to-flcc already)))
+               (return-from change-chcm-to-flcc already))
          (setf (slot-value chcm 'flin) flin)
           (setf (slot-value chcm 'orgn) orgn) 
           (push chcm *flhopf-list*)
-         chcm)))
+         chcm))))
 
 
 (DEFCLASS FILTERED-SIMPLICIAL-SET (FILTERED-CHAIN-COMPLEX simplicial-set )
     ())
 
-(DEFVAR *FLSMST-LIST*)
+(DEFVAR *FLSMST-LIST*
+    "The variable *FLSMST-LIST* is bound to a list of user created filtered simplicial sets")
+
 (SETF *FLSMST-LIST* +empty-list+)
 (PUSHNEW '*FLSMST-LIST* *list-list*)
 
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((flsmst filtered-simplicial-set) stream)
  (the filtered-simplicial-set
    (progn
       (format stream "[K~D Filtered-Simplicial-Set]" (idnm flsmst))
      flsmst)))
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) t))
 
 (DEFUN FltrSmSet (idnm)
    (declare (type fixnum idnm))
@@ -493,7 +528,7 @@
          (let ((rslt (build-smst :cmpr cmpr :basis basis :bspn bspn
                        :face face :face* face* :intr-bndr intr-bndr 
                        :bndr-strt bndr-strt :intr-dgnl intr-dgnl 
-				 :dgnl-strt dgnl :orgn orgn)))
+                       :dgnl-strt dgnl-strt :orgn orgn)))
             (declare (type simplicial-set rslt))
             (change-class rslt 'FILTERED-SIMPLICIAL-SET)
             (setf (slot-value rslt 'flin) flin)
@@ -502,35 +537,43 @@
 
 (defmethod change-chcm-to-flcc ((chcm simplicial-set) flin flin-orgn )
    (declare      
-   
       (type chcm-flin flin)
-   (list flin-orgn))
+      ;;(list flin-orgn)
+)
    (the FILTERED-SIMPLICIAL-SET
       (progn
          (change-class chcm 'FILTERED-SIMPLICIAL-SET)
-         (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+;;        (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
-         (let ((already (find orgn *flsmst-list* :key #'orgn :test #'equal)))
+        (let* (
+               (orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
+               (already (find orgn *flsmst-list* :key #'orgn :test #'equal)))
             (declare (type (or null FILTERED-SIMPLICIAL-SET) already))
             (when already
-	     (return-from change-chcm-to-flcc already)))
+               (return-from change-chcm-to-flcc already))
          (setf (slot-value chcm 'flin) flin)
          (setf (slot-value chcm 'orgn) orgn)
          (push chcm *flsmst-list*)
-         chcm)))
+         chcm))))
 
 
 (DEFCLASS FILTERED-KAN (FILTERED-CHAIN-COMPLEX KAN )
     ())
 
-(DEFVAR *FLKAN-LIST*)
+(DEFVAR *FLKAN-LIST*
+    "The variable *FLKAN-LIST* is bound to a list of user created filtered Kan complexes")
+
 (SETF *FLKAN-LIST* +empty-list+)
 (PUSHNEW '*FLKAN-LIST* *list-list*)
 
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((flkan filtered-kan) stream)
  (the filtered-kan
    (progn
       (format stream "[K~D Filtered-Kan-Simplicial-Set]" (idnm flkan))
      flkan)))
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) t))
 
 (DEFUN FltrKan (idnm)
    (declare (type fixnum idnm))
@@ -539,21 +582,23 @@
 
 (defmethod change-chcm-to-flcc ((chcm kan) flin flin-orgn )
    (declare      
-   
       (type chcm-flin flin)
-   (list flin-orgn))
+      ;;(list flin-orgn)
+)
    (the FILTERED-KAN
       (progn
          (change-class chcm 'FILTERED-KAN)
-         (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+        ;; (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
-         (let ((already (find orgn *flkan-list* :key #'orgn :test #'equal)))
+        (let* (
+               (orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
+               (already (find orgn *flkan-list* :key #'orgn :test #'equal)))
             (declare (type (or null FILTERED-KAN) already))
             (when already
-	     (return-from change-chcm-to-flcc already)))
+               (return-from change-chcm-to-flcc already))
          (setf (slot-value chcm 'flin) flin)
          (setf (slot-value chcm 'orgn) orgn)
          (push chcm *flkan-list*)
-         chcm)))
+         chcm))))
 
 
 (DEFCLASS FILTERED-SIMPLICIAL-GROUP (FILTERED-CHAIN-COMPLEX SIMPLICIAL-GROUP )
@@ -562,10 +607,20 @@
 (DEFCLASS FILTERED-AB-SIMPLICIAL-GROUP (FILTERED-CHAIN-COMPLEX AB-SIMPLICIAL-GROUP )
     ())
 
-(DEFVAR *FLSMGR-LIST*)
+(DEFVAR *FLSMGR-LIST*
+    "The variable *FLSMGR-LIST* is bound to a list of user created filtered simplicial groups")
+    
 (SETF *FLSMGR-LIST* +empty-list+)
 (PUSHNEW '*FLSMGR-LIST* *list-list*)
 
+(DEFVAR *FLABSMGR-LIST*
+    "The variable *FLABSMGR-LIST* is bound to a list of user created filtered simplicial abelian groups")
+
+(SETF *FLABSMGR-LIST* +empty-list+)
+(PUSHNEW '*FLABSMGR-LIST* *list-list*)
+
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) nil))
 (DEFMETHOD PRINT-OBJECT ((flsmgr filtered-simplicial-group) stream)
  (the filtered-simplicial-group
    (progn
@@ -577,6 +632,8 @@
    (progn
       (format stream "[K~D Filtered-Abelian-Simplicial-Group]" (idnm flsmgr))
      flsmgr)))
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) t))
 
 (DEFUN FltrSmgr (idnm)
    (declare (type fixnum idnm))
@@ -606,7 +663,7 @@
          (let ((rslt (build-smgr :cmpr cmpr :basis basis :bspn bspn
                        :face face :face* face* :intr-bndr intr-bndr 
                        :bndr-strt bndr-strt :intr-dgnl intr-dgnl 
-				 :dgnl-strt dgnl :sintr-grml sintr-grml
+                       :dgnl-strt dgnl-strt :sintr-grml sintr-grml
                        :sintr-grin sintr-grin :orgn orgn)))
             (declare (type simplicial-group rslt))
             (change-class rslt 'FILTERED-SIMPLICIAL-GROUP)
@@ -621,37 +678,43 @@
    (declare
       
       (type chcm-flin flin)
-   (list flin-orgn))
+      ;;(list flin-orgn)
+)
    (the FILTERED-SIMPLICIAL-GROUP
       (progn
          (change-class chcm 'FILTERED-SIMPLICIAL-GROUP)
-         (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+        ;; (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
-         (let ((already (find orgn *flsmgr-list* :key #'orgn :test #'equal)))
+        (let* (
+               (orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
+               (already (find orgn *flsmgr-list* :key #'orgn :test #'equal)))
             (declare (type (or null FILTERED-SIMPLICIAL-GROUP) already))
             (when already
-	     (return-from change-chcm-to-flcc already)))
+               (return-from change-chcm-to-flcc already))
          (setf (slot-value chcm 'flin) flin)
          (setf (slot-value chcm 'orgn) orgn)
          (push chcm *flsmgr-list*)
-         chcm)))
+         chcm))))
 
 (defmethod change-chcm-to-flcc ((chcm ab-simplicial-group) flin flin-orgn )
    (declare
       
       (type chcm-flin flin)
-   (list flin-orgn))
+      ;;(list flin-orgn)
+)
    (the FILTERED-AB-SIMPLICIAL-GROUP
       (progn
          (change-class chcm 'AB-FILTERED-SIMPLICIAL-GROUP)
-         (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+      ;;   (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
-         (let ((already (find orgn *flabsmgr-list* :key #'orgn :test #'equal)))
+        (let* (
+               (orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
+               (already (find orgn *flabsmgr-list* :key #'orgn :test #'equal)))
             (declare (type (or null FILTERED-AB-SIMPLICIAL-GROUP) already))
             (when already
-	     (return-from change-chcm-to-flcc already)))
+               (return-from change-chcm-to-flcc already))
          (setf (slot-value chcm 'flin) flin)
         (setf (slot-value chcm 'orgn) orgn) 
         (push chcm *flabsmgr-list*)
-         chcm)))
+         chcm))))
 
         
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;    EXAMPLES    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -659,6 +722,8 @@
 
 ;; BICOMPLEXES
 
+(DEFVAR BCFlin)
+
 ;; Filtration index function of a Bicomplex (first degree of a generator).
 (setf BCflin 
       #'(lambda (degr gnrt)
@@ -682,13 +747,11 @@
 (defun CHANGE-BICM-TO-FLCC (bc)
    (declare 
      (type bicomplex bc))
-  (let* ((orgn (orgn bc))
+   (let* ((flin BCflin))
-	 (flin BCflin))
       (declare       
-     (type list orgn)
        (type chcm-flin flin))
       (the FILTERED-CHAIN-COMPLEX
-	 (change-chcm-to-flcc bc flin '(Bicomplex-Flin)))))
+        (change-chcm-to-flcc bc flin 'Bicomplex-Flin))))
 
 #|
 (defun bas (degr1 degr2)
@@ -724,7 +787,6 @@
 
 ;; BARS
 
-#|
 (defun abar-bidegree (abar)
     (declare (type abar abar))
     (the list
@@ -734,8 +796,8 @@
         (setf q (apply #'+ (mapcar #'car (rest abar))))
         (decf q p)
         (return-from abar-bidegree (list p q)))))
-|#
 
+(DEFVAR abar-flin)
 (setf abar-flin 
       #'(lambda (degr abar)
        (declare (type fixnum degr)
@@ -751,7 +813,7 @@
 (setq kz2 (k-z2-1))
 (setq bar2 (bar kz2))
 
-(change-chcm-to-flcc bar2 abar-flin '(abar-flin))
+(change-chcm-to-flcc bar2 abar-flin 'abar-flin)
 
 
 (setf basis7 (basis bar2 7))
@@ -773,7 +835,6 @@
 
 ;; COBAR
 
-#|
 (defun allp-bidegree (allp)
     (declare (type allp allp))
     (the list
@@ -783,33 +844,32 @@
         (setf q (apply #'+ (mapcar #'car (rest allp))))
         (incf q p)
         (return-from allp-bidegree (list (- p) q)))))
-|#
 
+(DEFVAR cobar-flin)
 (setf cobar-flin 
  #'(lambda (degr allp)
-	  (declare (type fixnum degr)
+      (declare (ignore degr)
                (type allp allp))
-	  (let* ((allp-bidgr (allp-bidegree allp))
+      (with-allp (l) allp
-		 (degr1 (first allp-bidgr))
+        (the fixnum
-		 (degr2 (second allp-bidgr)))
+          (- (length l))))))
-	    (if (=  degr (+ degr1 degr2))
+
-		degr1
-		0))))
 
 ;; TENSOR PRODUCTS 
 
+
+(DEFVAR tnpr-flin)
 (setf tnpr-flin 
       #'(lambda (degr tnpr)
           (declare 
-	   (type fixnum degr)
+            (ignore degr)
             (type tnpr tnpr))
        (the fixnum
          (degr1 tnpr))))
 
-
 ;; FIBRATIONS (CARTESIAN PRODUCTS AND TWISTED PRODUCTS)
 
-#|
+(DEFVAR crpr-flin)
 (setf crpr-flin 
       #'(lambda (degr crpr)
           (declare
@@ -822,7 +882,6 @@
               (type fixnum dgop))
              (the fixnum
                (- degr (length (dgop-int-ext dgop)))))))
-|#
 
 #|
 (funcall fbrt-flin 3 '(:crpr (1 . s2) 0 . 3))
@@ -830,6 +889,7 @@
 |# 
  
 
+
 ;; BICONES
  
 (defun bicone-flin (flinb flinc flind)

src/anromero/resolutions.lisp

@@ -650,6 +650,8 @@
 
 
 
+
+
 (DEFUN ZGCMBN-TWI (zgcmpr zgcmbn)
   ;;(declare (type zgcmbn zgcmbn))
   (with-cmbn (degr list) zgcmbn

src/anromero/spectral-sequences.lisp

@@ -7,9 +7,10 @@
 
 (provide "spectral-sequences")
 
+
 ;; Auxiliary functions to deal with matrices
 
-(defun submatrix (mtrx first-line last-line first-col last-col)
+(DEFUN SUBMATRIX (mtrx first-line last-line first-col last-col)
   (declare (type matrix mtrx)
            (type fixnum first-line last-line first-col last-col))
   (the matrix
@@ -38,7 +39,7 @@
 |#
 
 
-(Defun column-j (mtrx j)
+(DEFUN COLUMN-J (mtrx j)
   (declare (type matrix mtrx)
            (type fixnum j))
   (assert (< j (column-number mtrx)))
@@ -56,9 +57,10 @@
 (column-j m 2)
 |#
 
+
 ;; Function that concatenates two matrices (if their line number is different, the 
 ;; needed zeros are added. 
-(defun mtrx-conc (mtrx1 mtrx2)
+(DEFUN MTRX-CONC (mtrx1 mtrx2)
   (declare (type matrix mtrx1 mtrx2))
   (the matrix
     (let* ((line-n-1 (line-number mtrx1))
@@ -88,14 +90,14 @@
           (do ((i 0 (1+ i)))
               ((>= i line-n-1))
             (declare (type fixnum i))
-                 (Setf (aref rslt i j) (aref mtrx1 i j))))
+            (setf (aref rslt i j) (aref mtrx1 i j))))
         (do ((j 0 (1+ j)))
             ((>= j column-n-2))
           (declare (type fixnum j))
           (do ((i 0 (1+ i)))
               ((>= i line-n-2))
             (declare (type fixnum i))
-                 (Setf (aref rslt i (+ column-n-1 j)) (aref mtrx2 i j))))
+            (setf (aref rslt i (+ column-n-1 j)) (aref mtrx2 i j))))
         rslt))))
 
 #|
@@ -111,7 +113,7 @@
 ;; Function that returns a list of generators of the kernel of a matrix.
 ;; Each generator is a list of integers which represent its coordinates
 ;; in the initial basis.
-(defun kernel (mtrx)
+(DEFUN KERNEL (mtrx)
   (declare (type matrix mtrx))
   (the list
     (let* ((smith-list (smith mtrx))
@@ -142,7 +144,7 @@
 
 ;; Returns a matrix which has as columns the elements of the list.
 ;; (Each element in the list is a list of integers).
-(defun Gnrt-List-to-Mtrx (gnrt-list)
+(DEFUN GNRT-LIST-TO-MTRX (gnrt-list)
   (declare (type list gnrt-list))
   (the matrix
     (let* ((column-n (length gnrt-list))
@@ -184,7 +186,7 @@
 |# 
 
 ;; Returns the list of columns of the matrix mtrx.
-(defun gnrt-mtrx-to-list (mtrx)
+(DEFUN GNRT-MTRX-TO-LIST (mtrx)
   (declare (type matrix mtrx))
   (the list
     (let* ((column-n (column-number mtrx)))
@@ -204,7 +206,7 @@
 ;; which are the images of the matrices mtrx1 and mtrx2, where basis=list
 ;; of combinations (c_1...c_m) that forms a basis for B and divisors=list of
 ;; integers (n_1....n_m) such that (n_1*c_1,...,n_m*c_m) forms a basis for C. 
-(defun mtrx-quotient (mtrx1 mtrx2)
+(DEFUN MTRX-QUOTIENT (mtrx1 mtrx2)
   (declare (type matrix mtrx1 mtrx2))
   (the list
     (let* ((smith-list-1 (smith mtrx1))
@@ -216,7 +218,7 @@
            (d1-1Xp1-1Xmtrx2 (copy-mtrx p1-1Xmtrx2)))
       (declare
        (list smith-list-1)
-         (type matrix p1 p1-1 s1 p1-1Xmtrx2 p1Xd1 d1-1Xp1))
+       (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)))
@@ -280,7 +282,7 @@
 ;; differential matrix M, such that the elements of Z^r_{p,q} are those that
 ;; when we apply M to them we obtain zero, i.e. Z^r_{p,q}=Ker M). Only can be applied
 ;; to a finitely generated complex. 
-(defun FLTR-CHCM-Z-MTRX (fltrcm r p q)
+(DEFUN FLTR-CHCM-Z-MTRX (fltrcm r p q)
   (declare
    (type filtered-chain-complex fltrcm)
    (type fixnum r p q))
@@ -348,6 +350,52 @@
                           (setf (aref rslt i j) cffc))))))))
           rslt)))))
 
+
+
+(DEFUN FLTR-CHCM-Z-MTRX2 (fltrcm r p q)
+  (declare
+   (type filtered-chain-complex fltrcm)
+   (type fixnum r p q))
+  (the matrix
+    (let* ((cmpr (cmpr1 fltrcm))
+           (dffr (dffr fltrcm))
+           (degr (+ p q))
+           (sbasis (fltrd-basis fltrcm degr p))
+           (tbasis 
+            (mapcan 
+                #'(lambda (i)
+                    (declare (type fixnum i))
+                    (bigrd-basis fltrcm i (- (1- degr) i)))
+              (<a-b> (1+ (- p r)) p)))) ;; We suppose that the differential
+      ;; respects the filtration, i.e., 
+      ;; d(F_pX) \in F_p(dX). If not, we must
+      ;; consider (<a-b> (1+ (-p r)) t(degr),
+      ;; where t(degr)=max{flin(x), x \in X_degr}.
+      (declare
+       (type cmprf cmpr)
+       (type morphism dffr)
+       (type fixnum degr)
+       (list sbasis tbasis))
+      (let ((srank (length sbasis))
+            (trank (length tbasis)))
+        (declare (type fixnum srank trank))
+        (let ((rslt 
+               #-ACLPC
+               (make-array (list trank srank)
+                           :element-type 'fixnum
+                           :initial-element 0)
+               #+ACLPC
+               (if (or (zerop srank) (zerop trank))
+                   (make-array (list trank srank)
+                               :element-type 'fixnum)
+                 (make-array (list trank srank)
+                             :element-type 'fixnum
+                             :initial-element 0))))               
+          (declare (type matrix rslt))
+          
+          rslt)))))
+
+
 #|
 (cat-init)
 (setq kz2 (k-z2-1))
@@ -360,7 +408,7 @@
 
 ;; Returns a list of generators (list of coordinates) of Z^r_{p,q}
 ;; (only for finitely generated complexes)
-(defun Fltr-Chcm-Z-Gnrt-List (FltrCm r p q)
+(DEFUN FLTR-CHCM-Z-GNRT-LIST (FltrCm r p q)
   (declare (type filtered-chain-complex fltrcm)
            (type fixnum r p q))
   (the list
@@ -371,7 +419,7 @@
        (list all-basis-gnrt-list))
       (if (= 0 r)
           all-basis-gnrt-list
-               (let* ((mat (FLTR-CHCM-Z-MTRX fltrcm r p q))
+        (let* ((mat (fltr-chcm-z-mtrx fltrcm r p q))
                (line-n (line-number mat))
                (column-n (column-number mat)))
           (declare 
@@ -389,7 +437,7 @@
 ;; Returns a list of lists with the coordinates of the elements of
 ;; the basis of F_pX_n (with p=fltr-index, n=degr), that are lists with
 ;; the form (0...0 i 0...0) (only for finitely generated complexes)
-(defun fltr-basis-gnrt-list (FltrCm degr fltr-index)
+(DEFUN FLTR-BASIS-GNRT-LIST (fltrcm degr fltr-index)
   (declare 
    (type filtered-chain-complex fltrcm)
    (type fixnum degr fltr-index))
@@ -412,7 +460,7 @@
 
 ;; Returns the matrix of the generators of the numerator in E^r_{p,q}
 ;; (Only for finitely generated complexes)
-(defun spsq-num-mtrx (FltrCm r p q)
+(DEFUN SPSQ-NUM-MTRX (fltrcm r p q)
   (the matrix
     (let* ((degr (+ p q))
            (fltr-p-basis (fltrd-basis fltrcm degr p))
@@ -424,7 +472,7 @@
            (num1-mtrx (mtrx-conc z1-mtrx fltr-p-1-mtrx))
            (num1-line-n (line-number num1-mtrx)))
       (declare
-        (type fixnum degr num1-line-n)
+       (type fixnum degr p-basis-l num1-line-n)
        (type list fltr-p-basis  z1-list fltr-p-1-list)
        (type matrix z1-mtrx fltr-p-1-mtrx num1-mtrx))
       (if (eql num1-line-n p-basis-l)
@@ -443,7 +491,7 @@
                               :element-type 'fixnum
                               :initial-element 0))))
           (declare
-              (type fixnum num-lin-n num-column-n)
+           (type fixnum num-line-n num-column-n)
            (type matrix rslt))
           (do ((j 0 (1+ j)))
               ((>= j num-column-n))
@@ -451,7 +499,7 @@
             (do ((i 0 (1+ i)))
                 ((>= i num1-line-n))
               (declare (type fixnum i))
-                   (Setf (aref rslt i j) (aref num1-mtrx i j))))
+              (setf (aref rslt i j) (aref num1-mtrx i j))))
           rslt)))))
 
 #|
@@ -461,7 +509,7 @@
 
 ;; Returns the matrix of the generators of the denominator in E^r_{p,q}
 ;; (Only for finitely generated complexes) 
-(defun spsq-den-mtrx (FltrCm r p q)
+(DEFUN SPSQ-DEN-MTRX (fltrCm r p q)
   (the matrix
     (let* ((degr (+ p q))
            (fltr-p-basis (fltrd-basis fltrcm degr p))
@@ -522,21 +570,20 @@
 
 ;; Function that returns the representation basis-divisors of E^r_{p,q} of a
 ;; finitely generated complex. 
-(defun eff-spsq-basis-dvs (FltrCm r p q)
+(DEFUN EFF-SPSQ-BASIS-DVS (FltrCm r p q)
   (declare 
    (type filtered-chain-complex fltrcm)
    (type fixnum r p q))
   (the list
     (let* ((degr (+ p q))
            (fltr-p-basis (fltrd-basis fltrcm degr p))
-            (p-basis-l (length fltr-p-basis))
            (num-mtrx (spsq-num-mtrx fltrcm r p q))
            (den-mtrx (spsq-den-mtrx fltrcm r p q)) 
            (cmbn-list nil)
            (divs nil))
       (declare
        (list fltr-p-basis cmbn-list divs)
-         (type fixnum degr p-basis-l)
+       (type fixnum degr)
        (type matrix num-mtrx den-mtrx))
       (progn
         (if (= 0 (array-total-size num-mtrx))
@@ -584,7 +631,7 @@
 |# 
 
 
-(defun eff-spsq-gnrts (FltrCm r p q)
+(DEFUN EFF-SPSQ-GNRTS (FltrCm r p q)
   (declare 
    (type filtered-chain-complex fltrcm)
    (type fixnum r p q))
@@ -603,14 +650,13 @@
 
 ;; Function that presents on the screen the components of the E^r_{p,q}
 ;; of the spectral sequence of a filtered complex.
-(defun eff-spsq-group (fltrcm r p q)
+(DEFUN EFF-SPSQ-GROUP (fltrcm r p q)
   (declare 
    (type filtered-chain-complex fltrcm)
    (type fixnum r p q))  
   (let* ((basis-dvs (eff-spsq-basis-dvs fltrcm r p q))
-          (cmbns (first basis-dvs))
          (divs (second basis-dvs)))
-      (declare (list basis-dvs cmbns divs))
+    (declare (list basis-dvs divs))
     (format t "Spectral sequence E^~D_{~D,~D}" r p q)
     (dolist (item divs)
       (declare (type fixnum item))
@@ -644,7 +690,7 @@
 
 ;; Function that returns the coordinates of a vector vctr with regard to
 ;; the basis whose elements are the columns of the matrix gnrt-mtrx.
-(defun vctr-coordinates (vctr gnrt-mtrx)
+(DEFUN VCTR-COORDINATES (vctr gnrt-mtrx)
   (declare 
    (type list vctr)
    (type matrix gnrt-mtrx))
@@ -655,7 +701,6 @@
            (p-1 (second smith-list))
            (D (third smith-list))
            (q (fourth smith-list))
-            (q-1 (fifth smith-list))
            (C2 (mtrx-prdc p-1 C))
            (line-n (column-number B))
            (A2 
@@ -672,7 +717,7 @@
                           :initial-element 0)))
            (end nil))
       (declare 
-          (type matrix C B p-1 D q q-1 C2 A2)
+       (type matrix C B p-1 D q  C2 A2)
        (type list smith-list)
        (type fixnum line-n ))
       (do ((i 0 (1+ i)))
@@ -680,8 +725,8 @@
         (declare (type fixnum i))
         (let* ((di (aref D i i)))
           (declare (type fixnum di))
-              (if (eql 0 di)
+          (if (not (eql 0 di))
-                 (setq found 1)
+              ;;(setq found 1)
               (progn
                 (setf (aref A2 i 0) (floor (aref C2 i 0) di))))))
       (let* ((A (mtrx-prdc Q A2)))
@@ -696,7 +741,7 @@
 
 ;; Function that returns the list of coefficients of the combination "cmbn"
 ;; in the basis (list of generators) "basis" (with comparison function "cmpr").
-(defun cmbn-cffc-list (cmbn basis cmpr)
+(DEFUN CMBN-CFFC-LIST (cmbn basis cmpr)
   (declare 
    (type cmbn cmbn)
    (type list basis)
@@ -736,7 +781,7 @@
 ;; Function that returns the list of coordinates of the combination "cmbn" in the basis
 ;; formed by the combinations in the list "gnrt-list". All these combinations are combinations
 ;; of the generators in "basis" ("cmpr" is the comparison function). 
-(defun cmbn-coordinates (cmbn gnrt-list basis cmpr)
+(DEFUN CMBN-COORDINATES (cmbn gnrt-list basis cmpr)
   (declare 
    (type cmbn cmbn)
    (type list gnrt-list basis)
@@ -769,7 +814,7 @@
 ;; on each of the components of E^r_{p-r,q+r-1} of the differential 
 ;; d: E^r_{p,q} --> E^r_{p-r,q+r-1} applied to the element of E^r_{p,q}
 ;; which has as coordinates the list int-list. (Only for finitely generated complexes)
-(defun eff-spsq-dffr (fltrcm r p q int-list)
+(DEFUN EFF-SPSQ-DFFR (fltrcm r p q int-list)
   (declare
    (type filtered-chain-complex fltrcm)
    (type fixnum r p q)
@@ -785,13 +830,13 @@
            (s-basis-dvs (mtrx-quotient (copy-mtrx num-mtrx) den-mtrx))
            (s-gnrt-list (first s-basis-dvs))
            (s-dvs (second s-basis-dvs))
-            (t-basis-dvs (spsq-basis-dvs fltrcm r (- p r) (1- (+ q r))))
+           (t-basis-dvs (eff-spsq-basis-dvs fltrcm r (- p r) (1- (+ q r))))
            (t-gnrt-list (first t-basis-dvs))
            (t-dvs (second t-basis-dvs))
            (selement (make-list (length sbasis) :initial-element 0))
            (cmbn (cmbn degr)))
       (declare 
-          (type fcmpr cmpr)
+       (type cmprf cmpr)
        (type fixnum degr)
        (type list sbasis tbasis z-gnrt-list s-basis-dvs s-gnrt-list s-dvs
              t-basis-dvs t-gnrt-list t-dvs selement)
@@ -876,7 +921,7 @@
 ;; the homology group of the complex. It begins with m zeros if the free part of the
 ;; group is Z^m and the rest of the list contains the torsion coefficients.
 ;; (only for finitely generated complexes). 
-(defun eff-compare-spsq-with-homology (fltrcm r degr hmlg-cmpns)
+(DEFUN EFF-COMPARE-SPSQ-WITH-HOMOLOGY (fltrcm r degr hmlg-cmpns)
   (declare
    (type filtered-chain-complex fltrcm)
    (type fixnum r degr)
@@ -896,7 +941,7 @@
          (hmlg-prdc 1)
          (spsq-prdc 1))
     (declare 
-        (type function spsq)
+     (type function spsq-cmpns)
      (type list spsq-cmpns mark2)
      (type fixnum hmlg-prdc spsq-prdc))
     (progn
@@ -927,7 +972,7 @@
 ;; filtered complex fltrcm with p+q=degr are equal to E^\infty_{p,q} (i.e., it 
 ;; determines the level r which the convergence of the spectral sequence has been 
 ;; reached at for the degree n).            
-(defun eff-spsq-cnvg (fltrcm degr)
+(DEFUN EFF-SPSQ-CNVG (fltrcm degr)
   (declare 
    (type filtered-chain-complex fltrcm)
    (type fixnum degr))
@@ -962,18 +1007,15 @@
 ;; which will determine the level r (=t+1) up to which the spectral sequences E^r_p,q 
 ;; (with p+q=n) of the left and right complexes are isomorphic. This function can only be used
 ;; when the top complex is effective (we need to obtain the elements in the basis of this complex). 
-(defun hmtp-eq-fltr-order (hmtp-eq degr)
+(DEFUN HMTP-EQ-FLTR-ORDER (hmtp-eq degr)
   (declare 
    (type HOMOTOPY-EQUIVALENCE hmtp-eq)
    (type fixnum degr))
   (let* ((lcc (lbcc hmtp-eq))
          (tcc (tcc hmtp-eq))
-          (lf (lf hmtp-eq))
-          (rh (rh hmtp-eq))
          (max 0))
     (declare
      (type chain-complex lcc tcc)
-       (type morphism lf rh)
      (type fixnum max))
     (when (eq (basis tcc) :locally-effective)
       (error "Hmtp-eq-fltr-order cannot work when the top complex of the homotopy equivalence
@@ -1005,16 +1047,16 @@
 ;; Function that changes the right bottom chain complex in a homotopy equivalence into 
 ;; a filtered complex, with a filtration defined translating the filtration in the left complex 
 ;; (which must be a filtered complex). 
-(defun translate-filtration (hmtp-eq)
+(DEFUN TRANSLATE-FILTRATION (hmtp-eq)
   (declare
    (type homotopy-equivalence hmtp-eq))
   (let ((fltrcm (lbcc hmtp-eq))
         (eff-chcm (rbcc hmtp-eq)))
     (declare (type chain-complex fltrcm eff-chcm))
-      (Change-Chcm-TO-Flcc eff-chcm :flin
+    (Change-Chcm-TO-Flcc eff-chcm 
                          #'(lambda (degr gnrt)
                              (flin fltrcm (lf hmtp-eq (rg hmtp-eq degr gnrt))))
-                                 :orgn (orgn eff-chcm))))
+                         (orgn eff-chcm))))
 
 
 
@@ -1027,17 +1069,16 @@
 ;; complex translating the filtration in the original filtered complex FltrCm, suposing that the 
 ;; homotopy in the right side is compatible with the filtration in the left complex for such r (we 
 ;; supose that flin(rh(lf(y)))-flin(lf(y))<r for every y in the top complex). 
-(defun spsq-basis-dvs (FltrCm r p q)
+(DEFMETHOD SPSQ-BASIS-DVS ((FltrCm filtered-chain-complex) r p q)
   (declare 
-     (type filtered-chain-complex fltrcm)
       (type fixnum r p q))
   (let* ((hmtp-eq (efhm fltrcm))
          (eff-chcm (rbcc hmtp-eq))
-          (degr (+ p q)))
+         )
     (declare 
      (type homotopy-equivalence hmtp-eq)
      (type chain-complex eff-chcm)
-        (type fixnum degr))
+     )
     (progn
       (if (not (typep eff-chcm 'filtered-chain-complex))
           (translate-filtration hmtp-eq))
@@ -1056,23 +1097,23 @@
 |# 
 
 
-(defun spsq-gnrts (fltrcm r p q)
+(DEFUN SPSQ-GNRTS (fltrcm r p q)
   (declare
    (type filtered-chain-complex fltrcm)
    (type fixnum r p q))
   (let* ((hmtp-eq (efhm fltrcm))
          (eff-chcm (rbcc hmtp-eq))
-          (degr (+ p q)))
+         )
     (declare
      (type homotopy-equivalence hmtp-eq)
      (type chain-complex eff-chcm)
-       (type fixnum degr))
+     )
     (progn
       (if (not (typep eff-chcm 'filtered-chain-complex))
           (translate-filtration hmtp-eq))
       (eff-spsq-gnrts eff-chcm r p q))))
 
-;; Function that presents on the screen the components of the E^r_{p,q}
+;; Method that presents on the screen the components of the E^r_{p,q}
 ;; of the spectral sequence of a filtered complex fltrcm with effective homology.
 ;; If the effective complex is a filtered complex, we supose that both reductions in the equi-
 ;; valence are compatible with the filtrations (f and g respect the filtration index and h has
@@ -1080,38 +1121,38 @@
 ;; complex translating the filtration in the original filtered complex FltrCm, suposing that the 
 ;; homotopy in the right side is compatible with the filtration in the left complex for such r (we 
 ;; supose that flin(rh(lf(y)))-flin(lf(y))<r for every y in the top complex). 
-(defun spsq-group (fltrcm r p q)
+(DEFMETHOD SPSQ-GROUP ((fltrcm FILTERED-CHAIN-COMPLEX) r p q)
   (declare
    (type filtered-chain-complex fltrcm)
    (type fixnum r p q))
   (let* ((hmtp-eq (efhm fltrcm))
          (eff-chcm (rbcc hmtp-eq))
-          (degr (+ p q)))
+         )
     (declare
      (type homotopy-equivalence hmtp-eq)
      (type chain-complex eff-chcm)
-       (type fixnum degr))
+     )
     (progn
       (if (not (typep eff-chcm 'filtered-chain-complex))
           (translate-filtration hmtp-eq))
       (eff-spsq-group eff-chcm r p q))))
 
-;; Function that returns the list of integers which correspond to the coordinates
+;; Method that returns the list of integers which correspond to the coordinates
 ;; on each of the components of E^r_{p-r,q+r-1} of the differential 
 ;; d: E^r_{p,q} --> E^r_{p-r,q+r-1} applied to the element of E^r_{p,q}
 ;; which has as coordinates the list int-list.
-(defun spsq-dffr (fltrcm r p q int-list)
+(DEFMETHOD SPSQ-DFFR ((fltrcm FILTERED-CHAIN-COMPLEX) r p q int-list)
   (declare
    (type filtered-chain-complex fltrcm)
    (type fixnum p q r)
    (type list int-list))
   (let* ((hmtp-eq (efhm fltrcm))
          (eff-chcm (rbcc hmtp-eq))
-          (degr (+ p q)))
+         )
     (declare
      (type homotopy-equivalence hmtp-eq)
      (type chain-complex eff-chcm)
-       (type fixnum degr))
+     )
     (progn
       (if (not (typep eff-chcm 'filtered-chain-complex))
           (translate-filtration hmtp-eq))
@@ -1121,7 +1162,7 @@
 ;; of the filtered complex fltrcm (with effective homology) are equal to E^\infty_{p,q} (i.e., it 
 ;; determines the level r which the convergence of the spectral sequence has been 
 ;; reached at for the degree n).
-(defun spsq-cnvg (fltrcm degr)
+(DEFUN SPSQ-CNVG (fltrcm degr)
   (declare
    (type filtered-chain-complex fltrcm)
    (type fixnum degr))
@@ -1143,12 +1184,13 @@
 ;; Homology filtration
 
 
-(defun homology-gnrt-list (chcm degr)
+(DEFUN HOMOLOGY-GNRT-LIST (chcm degr)
-     (declare (type cc chcm) (type fixnum degr))
+  (declare (type chain-complex chcm) 
+           (type fixnum degr))
   (let ((src (cons :unused (basis chcm degr)))
         (hom-dvs-gnrts (homologie (chcm-mat chcm degr) (chcm-mat chcm (1+ degr))))
-           (rslt nil))
+        )
-        (declare (type list src hom-dvs-gnrts rslt))
+    (declare (type list src hom-dvs-gnrts ))
     (mapcar #'(lambda (item)
                 (declare (type list item))
                 (let ((cmbn (cmbn degr))
@@ -1161,8 +1203,8 @@
 
 
 
-
+#|
-(defun homology-fltr1 (fltrcm degr fltr-index)
+(DEFUN HOMOLOGY-FLTR1 (fltrcm degr fltr-index)
   (declare
    (type filtered-chain-complex fltrcm)
    (type fixnum degr fltr-index))
@@ -1181,22 +1223,10 @@
                              (ss-dvs (second ss-basis-dvs))
                              (rslt nil))
                         (declare 
-                            (type fcmpr cmpr)
+                         (type cmprf cmpr)
                          (type fixnum r q)
                          (type list total-basis z-gnrt-list ss-basis-dvs ss-gnrt-list ss-dvs rslt)
                          (type matrix num-mtrx den-mtrx))
-                          (labels ((2list-add (list1 list2)
-                                     (declare (type list list1 list2))
-                                     (the list
-                                       (mapcar #'+ list1 list2)))
-                                   (n-list (n list)
-                                     (declare
-                                       (type list list)
-                                       (type fixnum n))
-                                     (the list
-                                       (mapcar #'(lambda (i)
-                                                   (* n i))
-                                         list))))
                         (do ((mark1 ss-gnrt-list (cdr mark1))
                              (mark2 ss-dvs (cdr mark2)))
                             ((endp mark1))
@@ -1236,30 +1266,28 @@
                                                                                            cmbn2)))
                                                                                    (car mark3))))))))
                                   (setf rslt (nconc rslt (list cmbn)))
-                                       rslt)))))))
+                                  rslt))))))
             (<a-b> 0 fltr-index))))
     (if (not (endp fltrt-basis))
-          (let ((fltrt-mtrx
+        (let* ((fltrt-mtrx
                 (gnrt-list-to-mtrx
                  (mapcar #'(lambda (cmbn)
-                                (cmbn-cff-list cmbn total-basis cmpr))
+                             (cmbn-cffc-list cmbn total-basis cmpr))
-                      (fltrt-basis))))
+                   (fltrd-basis))))
                (num-mtrx (mtrx-conc fltrt-mtrx dffr-mtrx)))
           (mtrx-quotient num-mtrx dffr-mtrx))
       nil)))
+|#
 
 
-
+(DEFUN EFF-HMLG-FLTR (fltrcm degr p)
-(defun eff-hmlg-fltr (fltrcm degr p)
   (declare
    (type filtered-chain-complex fltrcm)
    (type fixnum degr p))
   (let* ((min-max-1 (flin-min-max fltrcm (1- degr)))
          (min-1 (first min-max-1))
-          (max-1 (second min-max-1))
          (min-max+1 (flin-min-max fltrcm (1+ degr)))
          (min+1 (first min-max+1))
-          (max+1 (second min-max+1))
          (r (1+ (- p min-1)))
          (q (- degr p))
          (Z-gnrts (Fltr-Chcm-Z-Gnrt-List FltrCm r p q))
@@ -1278,7 +1306,7 @@
             )))))
 
 
-(defun hmlg-fltr (fltrcm degr p)
+(DEFUN HMLG-FLTR (fltrcm degr p)
   (declare
    (type filtered-chain-complex fltrcm)
    (type fixnum degr))
@@ -1296,62 +1324,180 @@
 
 
 
-(DEFTYPE ss-type () '(member :serre :eilenberg-moore :filtration))
+;;(DEFTYPE ss-type () '(member :serre :eilenberg-moore :filtration))
 
 
-
+(DEFCLASS SPECTRAL-SEQUENCE ()
-(defclass OUTPUT-SPECTRAL-SEQUENCE ()
+  (;; FiLTeRedchainCoMplex
-    ((hmeq :type homotopy-equivalence :initarg hmeq :reader hmeq)
+   (fltrcm :type filtered-chain-complex :initarg :fltrcm :reader fltrcm)
-     (eff-flin :type chcm-fltrindex :initarg eff-flin :reader eff-flin)
+   ;; ReSuLTS
-     (bgn :type fixnum :initarg bgn :reader bgn)
+   (group-rslts :type list :initarg :group-rslts :reader group-rslts)
+   (dffr-rslts :type list :initarg :dffr-rslts :reader dffr-rslts)
    ;; IDentification NuMber      
    (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)      
    ;; ORiGiN      
    (orgn :type list :initarg :orgn :reader orgn)))
 
 
-(DEFVAR *oss-list*)
+(DEFVAR *ss-list*
-(SETF *oss-list* +empty-list+)
+    "The variable *SS-LIST* is bound to a list of user created spectral sequences")
-(PUSHNEW '*oss-list* *list-list*)
+(SETF *ss-list* +empty-list+)
+(PUSHNEW '*ss-list* *list-list*)
 
-(DEFMETHOD PRINT-OBJECT ((oss OUTPUT-SPECTRAL-SEQUENCE) stream)
+
-(the output-spectral-sequence
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) nil))
+(DEFMETHOD PRINT-OBJECT ((ss SPECTRAL-SEQUENCE) stream)
+  (the spectral-sequence
     (progn
-      (format stream "[K~D output-spectral-sequence]" (idnm oss))
+      (format stream "[K~D Spectral-Sequence]" (idnm ss))
-     oss)))
+      ss)))
+#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (ext:package-lock :clos) t))
 
-(DEFUN Oss (idnm)
+
+(DEFUN SS (idnm)
   (declare (type fixnum idnm))
-   (the (or OUTPUT-SPECTRAL-SEQUENCE null)
+  (the (or SPECTRAL-SEQUENCE null)
-      (find idnm *oss-list* :key #'idnm)))
+    (find idnm *ss-list* :key #'idnm)))
 
 
-(DEFUN BUILD-oss (&key hmeq eff-flin bgn orgn)
+(DEFUN BUILD-ss (fltrcm orgn)
   (declare
-      (type homotopy-equivalence hmeq)
+   (type filtered-chain-complex fltrcm)
-      (type chcm-fltrindex eff-flin)
-      (type fixnum bgn)
    (type list orgn))
-   (the output-spectral-sequence
+  (the spectral-sequence
     (progn
-         (let ((already (find orgn *oss-list* :test #'equal :key #'orgn)))
+      (let ((already (find orgn *ss-list* :test #'equal :key #'orgn)))
-            (declare (type (or output-spectral-sequence null) already))
+        (declare (type (or spectral-sequence null) already))
         (when already
-               (return-from build-oss already)))
+          (return-from build-ss already)))
-         (let ((oss (make-instance 'output-spectral-sequence
+      (let ((ss (make-instance 'spectral-sequence
-                        :hmeq hmeq
+                   :fltrcm fltrcm
-                        :eff-flin eff-flin
+                  :orgn orgn
-                        :bgn bgn
+                  :group-rslts +empty-list+
-                        :orgn orgn)))
+                  :dffr-rslts +empty-list+)))
-            (declare (type output-spectral-sequence oss))
+        (declare (type spectral-sequence ss))
-            (push oss *oss-list*)
+        (push ss *ss-list*)
-            oss))))
+        ss))))
 
-;;(defun serre-ss (fibration)
 
-#|(defun serre-ss (f)
+(DEFMETHOD SPSQ-BASIS-DVS ((ss SPECTRAL-SEQUENCE) r p q)
+  (declare
+   (type fixnum r p q))
+  (let* ((fltrcm (fltrcm ss))
+         (rslts (group-rslts ss))
+         (pos (position (list r p q nil) rslts :test #'(lambda (l1 l2)
+                                                    (and
+                                                     (eq (first l1) (first l2))
+                                                     (eq (second l1) (second l2))
+                                                     (eq (third l1) (third l2)))))))
+    (the list
+      (if pos (fourth (nth pos rslts))
+        (let ((basis-dvs (spsq-basis-dvs fltrcm r p q)))
+          (declare (type list basis-dvs))
+          (progn
+            (push (list r p q basis-dvs) rslts)
+            (setf (slot-value ss 'group-rslts) rslts)
+            basis-dvs))))))
+
+        
+(DEFMETHOD SPSQ-GROUP ((ss SPECTRAL-SEQUENCE) r p q)
+  (declare
+   (type spectral-sequence ss)
+   (type fixnum r p q))  
+  (let* ((basis-dvs (SPSQ-BASIS-DVS SS r p q))
+         (divs (second basis-dvs)))
+    (declare (list basis-dvs divs))
+    (format t "Spectral sequence E^~D_{~D,~D}" r p q)
+    (dolist (item divs)
+      (declare (type fixnum item))
+      (if (not (eql 1 item))
+          (progn
+            (format t "~2%Component Z")
+            (unless (zerop item) 
+              (format t "/~DZ" item))
+            )))
+    (terpri)))
+
+
+;; Method that returns the list of integers which correspond to the coordinates
+;; on each of the components of E^r_{p-r,q+r-1} of the differential 
+;; d: E^r_{p,q} --> E^r_{p-r,q+r-1} applied to the element of E^r_{p,q}
+;; which has as coordinates the list int-list.
+(DEFMETHOD SPSQ-DFFR ((ss SPECTRAL-SEQUENCE) r p q int-list)
+  (declare
+   (type spectral-sequence ss)
+   (type fixnum p q r)
+   (type list int-list))
+  (let* ((fltrcm (fltrcm ss))
+         (rslts (dffr-rslts ss))
+         (pos (position (list r p q int-list nil) rslts :test #'(lambda (l1 l2)
+                                                    (and
+                                                     (eq (first l1) (first l2))
+                                                     (eq (second l1) (second l2))
+                                                     (eq (third l1) (third l2))
+                                                     (eq (fourth l1) (fourth l2)))))))
+    (the list
+      (if pos (fifth (nth pos rslts))
+        (let ((l (spsq-dffr fltrcm r p q int-list)))
+          (declare (type list l))
+          (progn
+            (push (list r p q int-list l) rslts)
+            (setf (slot-value ss 'dffr-rslts) rslts)
+            l))))))
+
+
+(DEFUN SERRE-SS (f)
   (declare (type fibration f))
-   (let* ((X (fibration-total f))
+  (let* ((fltrcm (fibration-total f))
-          (hmeq (efhm X))
+         (ecc (rbcc (efhm fltrcm))))
-          (eX (rbcc efhm))
+    (progn
+      (change-chcm-to-flcc fltrcm crpr-flin 'crpr-flin)
+      (change-chcm-to-flcc ecc tnpr-flin 'tnpr-flin)
+      (build-ss fltrcm   `(Serre-Spectral-Sequence ,f)))))
+
+
+(DEFUN EILENBERG-MOORE-SS (x)
+  (declare (type simplicial-set x))
+  (let* ((ox (loop-space x))
+         (ecc (rbcc (efhm OX))))
+    (progn
+      (change-chcm-to-flcc ecc cobar-flin 'cobar-flin)
+      (build-ss ecc `(Eilenberg-Moore-Spectral-Sequence ,x)))))
+
+
+#|
+(cat-init)
+(progn
+  (setf s3 (sphere 3))
+  (setf k3 (chml-clss s3 3))
+  (setf F3 (z-whitehead s3 k3)))
+
+
+(setf sss (serre-ss f3))
+
+
+(setf r 2)
+
+  (dotimes (n 8)
+    (dotimes (p (1+ n))
+      (let ((q (- n p)))
+        (spsq-group sss r p q))))
+
+
+
+
+(cat-init)
+(setf ss2 (eilenberg-moore-ss (loop-space (sphere 3))))
+(setf effox (rbcc (efhm (fltrcm ss2))))
+
+(spsq-group effOX 1 -2 6)
+
+(dotimes (n 9)
+    (dotimes (p (1+ n))
+      (let ((q (+ n p)))
+        (spsq-group ss2 1 (- p) q))))
+
 |#
+       

src/cat-init.lisp

@@ -53,7 +53,16 @@
     "cs-twisted-products"
     "cl-space-efhm"
     "whitehead"
-    "smith"))
+    "smith"
+    "anromero\\resolutions"
+    "anromero\\cylinders"
+    "anromero\\fundamental-classes"
+    "anromero\\homotopy"
+    "anromero\\bicomplexes"
+    "anromero\\filtered-complexes"
+    "anromero\\spectral-sequences"
+    "anromero\\persistent-homology"
+    ))
 
 (DO ((i 1 (1+ i))
      (mark +file-list+ (cdr mark)))
@@ -61,8 +70,8 @@
   (format t "~% FILE ~2D: ~A" i (car mark)))
 
 (DEFCONSTANT +SOURCE-EXTENSION+
-  #+(or allegro lispworks) "cl"
+  #+(or lispworks) "cl"
-  #+(or clisp ccl ecl sbcl) "lisp"
+  #+(or allegro clisp ccl ecl sbcl) "lisp"
   #-(or allegro ccl clisp ecl lispworks sbcl)
   (error "Not an Allegro or CCL or CLisp or LispWorks or SBCL environment."))