Functions for change a chain complex to a filtered

chain complex modified
Example of bicomplex added

src/anromero/bicomplexes.lisp

@@ -373,8 +373,64 @@
       (slot-makunbound chcm 'bsgn)
       chcm)))
 
+
+
 #|
-;; Example of bicomplex from a list of morphisms of two chain complexes
+;; EXAMPLE OF BICOMPLEX
+
+(cat-init)
+
+
+(defun bcbasis (degr1 degr2)
+     (if (and (= degr1 0) (= degr2 1)) (return-from bcbasis '(a1 a2)))
+     (if (and (= degr1 1) (= degr2 0)) (return-from bcbasis '(b)))
+     (if (and (= degr1 1) (= degr2 1)) (return-from bcbasis '(c1 c2)))
+     (if (and (= degr1 2) (= degr2 0))  (return-from bcbasis '(d1 d2)))
+     (return-from bcbasis nil))
+
+(defun dif1 (degr1 degr2 gnrt)
+     (if (and (= degr1 1) (= degr2 1) (eql gnrt 'c1)) (return-from dif1 (list (cons 2 'a1))))
+     (if (and (= degr1 1) (= degr2 1) (eql gnrt 'c2)) (return-from dif1 (list (cons 2 'a2))))
+     (if (and (= degr1 2) (= degr2 0) (eql gnrt 'd1)) (return-from dif1 (list (cons 2 'b))))
+     (return-from dif1 nil))
+
+(defun dif2 (degr1 degr2 gnrt)
+     (if (and (= degr1 1) (= degr2 1) (eql gnrt 'c1)) (return-from dif2 (list (cons 1 'b))))
+     (return-from dif2 nil))
+
+(setf bc (build-bicm :cmpr #'s-cmpr :bcbasis #'bcbasis :dffr1 #'dif1 :dffr2 #'dif2
+          :orgn '(Bicomplex1)))
+
+(basis bc 1)
+
+(change-bicm-to-flcc bc)
+
+
+(do ((r 1 (1+ r)))
+    ((> r 3))
+   (dotimes (n 3)
+      (dotimes (p (+ n 1))
+         (let ((q (- n p)))
+            (spsq-group bc r p q)
+            (terpri)
+            (terpri)
+            ))))
+
+(SPSQ-DFFR-OF-ONE-ELEMENT bc 1 1 1 '(1))
+
+(SPSQ-DFFR-OF-ONE-ELEMENT bc 2 2 0 '(1 0))
+
+(SPSQ-DFFR-OF-ONE-ELEMENT bc 2 2 0 '(0 1))
+
+(spsq-cnvg bc 4)
+
+|#
+
+
+
+
+#|
+;; EXAMPLE OF BICOMPLEX FROM A LIST OF MORPHISMS OF TWO CHAIN COMPLEXES
 
 ;; First we build the three chain complexes
 

src/anromero/filtered-complexes.lisp

@@ -64,34 +64,10 @@
         rslt))))
 
 
-;; Function that changes a chain complex chcm to a filtered complex, with filtration
+(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm chain-complex) flin)
-;; index of a generator defined by the function flin, and origin orgn. 
-#|(DEFUN CHANGE-CHCM-TO-FLCC (chcm &key flin orgn)
   (declare
    (type chain-complex chcm)
-      (type chcm-flin flin)
+   (type chcm-flin flin))
-      (type list orgn))
-   (the FILTERED-CHAIN-COMPLEX
-      (progn
-         (change-class chcm 'FILTERED-CHAIN-COMPLEX)
-         ;;(setf orgn (list (orgn chcm) 'then orgn))
-         (let ((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)))
-         (setf (slot-value chcm 'flin) flin)
-         ;;(setf (slot-value chcm 'orgn) orgn)
-         (push chcm *flcc-list*)
-         chcm)))
-|#
-
-
-(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm chain-complex) flin flin-orgn)
-   (declare
-      (type chain-complex chcm)
-      (type chcm-flin flin)
-      ;;(type list flin-orgn)
-)
   (the FILTERED-CHAIN-COMPLEX
     (progn
       (change-class chcm 'FILTERED-CHAIN-COMPLEX)
@@ -225,7 +201,7 @@
 
 ;; Matrix of the differential application of degree "degr" of the subcomplex
 ;; F_pX, where p=fltr-index and X=fltrcm.
-(defun FLCC-DFFR-MTRX (fltrcm degr fltr-index)
+(DEFUN FLCC-DFFR-MTRX (fltrcm degr fltr-index)
   (declare
    (type FILTERED-CHAIN-COMPLEX fltrcm)
    (fixnum degr fltr-index))
@@ -343,11 +319,9 @@
         (push rslt *flclgb-list*)
         rslt))))
 
-(defmethod change-chcm-to-flcc ((chcm coalgebra) flin flin-orgn )
+(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm coalgebra) flin)
   (declare      
-      (type chcm-flin flin)
+   (type chcm-flin flin))
-      ;;(type list flin-orgn)
-)
   (the FILTERED-COALGEBRA
     (progn
       (change-class chcm 'FILTERED-COALGEBRA)
@@ -412,17 +386,13 @@
         (push rslt *flalgb-list*)
         rslt))))
 
-(defmethod change-chcm-to-flcc ((chcm algebra) flin flin-orgn )
+(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm algebra) flin)
   (declare      
-      (type chcm-flin flin)
+   (type chcm-flin flin))
-      ;;(list flin-orgn)
-)
   (the FILTERED-ALGEBRA
     (progn
       (change-class chcm 'FILTERED-ALGEBRA)
-       ;;(setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
+      (let* ((orgn (orgn chcm))
-        (let* (
-              (orgn (orgn chcm))
              (already (find orgn *flalgb-list* :key #'orgn :test #'equal)))
         (declare (type (or null FILTERED-ALGEBRA) already))
         (when already
@@ -456,17 +426,13 @@
   (the (or FILTERED-HOPF-ALGEBRA null)
     (find idnm *flhopf-list* :key #'idnm)))
 
-(defmethod change-chcm-to-flcc ((chcm hopf-algebra) flin flin-orgn )
+(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm hopf-algebra) flin)
   (declare      
-      (type chcm-flin flin)
+   (type chcm-flin flin))
-      ;;(list flin-orgn)
-)
   (the FILTERED-hopf-algebra
     (progn
       (change-class chcm 'FILTERED-hopf-ALGEBRA)
-        ;;(setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
+      (let* ((orgn (orgn chcm))
-        (let* (
-               (orgn (orgn chcm))
              (already (find orgn *flhopf-list* :key #'orgn :test #'equal)))
         (declare (type (or null FILTERED-HOPF-ALGEBRA) already))
         (when already
@@ -531,17 +497,13 @@
         (push rslt *flsmst-list*)
         rslt))))
 
-(defmethod change-chcm-to-flcc ((chcm simplicial-set) flin flin-orgn )
+(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm simplicial-set) flin)
   (declare      
-      (type chcm-flin flin)
+   (type chcm-flin flin))
-      ;;(list flin-orgn)
-)
   (the FILTERED-SIMPLICIAL-SET
     (progn
       (change-class chcm 'FILTERED-SIMPLICIAL-SET)
-;;        (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
+      (let* ((orgn (orgn chcm))
-        (let* (
-               (orgn (orgn chcm))
              (already (find orgn *flsmst-list* :key #'orgn :test #'equal)))
         (declare (type (or null FILTERED-SIMPLICIAL-SET) already))
         (when already
@@ -575,17 +537,13 @@
   (the (or filtered-kan null)
     (find idnm *flkan-list* :key #'idnm)))
 
-(defmethod change-chcm-to-flcc ((chcm kan) flin flin-orgn )
+(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm kan) flin)
   (declare      
-      (type chcm-flin flin)
+   (type chcm-flin flin))
-      ;;(list flin-orgn)
-)
   (the FILTERED-KAN
     (progn
       (change-class chcm 'FILTERED-KAN)
-        ;; (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
+      (let* ((orgn (orgn chcm))
-        (let* (
-               (orgn (orgn chcm))
              (already (find orgn *flkan-list* :key #'orgn :test #'equal)))
         (declare (type (or null FILTERED-KAN) already))
         (when already
@@ -668,18 +626,13 @@
 (DEFMACRO BUILD-FlABSMGR (&rest rest)
   `(change-class (build-flsmgr ,@rest) 'filtered-ab-simplicial-group))
 
-(defmethod change-chcm-to-flcc ((chcm simplicial-group) flin flin-orgn )
+(defmethod CHANGE-CHCM-TO-FLCC ((chcm simplicial-group) flin)
   (declare   
-      
+   (type chcm-flin flin))
-      (type chcm-flin flin)
-      ;;(list flin-orgn)
-)
   (the FILTERED-SIMPLICIAL-GROUP
     (progn
       (change-class chcm 'FILTERED-SIMPLICIAL-GROUP)
-        ;; (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
+      (let* ((orgn (orgn chcm))
-        (let* (
-               (orgn (orgn chcm))
              (already (find orgn *flsmgr-list* :key #'orgn :test #'equal)))
         (declare (type (or null FILTERED-SIMPLICIAL-GROUP) already))
         (when already
@@ -688,16 +641,12 @@
         (push chcm *flsmgr-list*)
         chcm))))
 
-(defmethod change-chcm-to-flcc ((chcm ab-simplicial-group) flin flin-orgn )
+(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm ab-simplicial-group) flin)
   (declare
-      
+     (type chcm-flin flin))
-      (type chcm-flin flin)
-      ;;(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))
       (let* (
              (orgn (orgn chcm))
              (already (find orgn *flabsmgr-list* :key #'orgn :test #'equal)))
@@ -743,7 +692,7 @@
     (declare       
      (type chcm-flin flin))
     (the FILTERED-CHAIN-COMPLEX
-        (change-chcm-to-flcc bc flin 'Bicomplex-Flin))))
+      (change-chcm-to-flcc bc flin))))
 
 #|
 (defun bas (degr1 degr2)
@@ -805,7 +754,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)
 
 
 (setf basis7 (basis bar2 7))
@@ -884,7 +833,7 @@
 
 ;; BICONES
  
-(defun bicone-flin (flinb flinc flind)
+(DEFUN BICONE-FLIN (flinb flinc flind)
   (declare (type chcm-flin flinb flinc flind))
   (flet ((rslt (degr bicn)
                (declare 

src/anromero/persistent-homology.lisp

@@ -479,7 +479,7 @@
             rslt)))
 
 
-(setf triangle (change-chcm-to-flcc triangle triangle-flin 'triangle-flin))
+(setf triangle (change-chcm-to-flcc triangle triangle-flin))
 
 
 (dotimes (p 8)

src/anromero/spectral-sequences.lisp

@@ -396,7 +396,7 @@
 (cat-init)
 (setq kz2 (k-z2-1))
 (setq fcc (bar kz2))
-(Change-Chcm-TO-Flcc fcc abar-flin `(abar-flin))
+(Change-Chcm-TO-Flcc fcc abar-flin)
 (fltr-chcm-z-mtrx fcc 2 3 2)
 (fltr-chcm-z-mtrx fcc 1 2 4)
 |#
@@ -1141,11 +1141,11 @@
 (setq k3 (k-z2 3))
 (Setq hmtp-eq3 (efhm k3))
 (setq ek3 (rbcc hmtp-eq3))
-(change-chcm-to-flcc ek3 :flin abar-flin :orgn `(filtered-chain-complex ,ek3))
+(change-chcm-to-flcc ek3 abar-flin)
 (setf k3-flin
   #'(lambda (degr gnrt)
       (flin ek3 (rf hmtp-eq3 (lg hmtp-eq3 degr gnrt)))))
-(change-chcm-to-flcc k3 :flin k3-flin :orgn `(filtered-chain-complex ,k3))
+(change-chcm-to-flcc k3 k3-flin)
 (hmtp-eq-fltr-order hmtp-eq3 3)
 (hmtp-eq-fltr-order hmtp-eq3 5)
 |#
@@ -1162,7 +1162,7 @@
     (Change-Chcm-TO-Flcc eff-chcm 
                          #'(lambda (degr gnrt)
                              (flin fltrcm (lf hmtp-eq (rg hmtp-eq degr gnrt))))
-                         (orgn eff-chcm))))
+                         )))
 
 
 
@@ -1235,8 +1235,7 @@
          (eff-chcm (rbcc hmtp-eq)))
     (declare
      (type homotopy-equivalence hmtp-eq)
-     (type chain-complex eff-chcm)
+     (type chain-complex eff-chcm))
-     )
     (progn
       (if (not (typep eff-chcm 'filtered-chain-complex))
           (translate-filtration hmtp-eq))
@@ -1617,8 +1616,8 @@
     (declare (type simplicial-set fltrcm)
              (type chain-complex ecc))
     (progn
-      (change-chcm-to-flcc fltrcm crpr-flin 'crpr-flin)
+      (change-chcm-to-flcc fltrcm crpr-flin)
-      (change-chcm-to-flcc ecc tnpr-flin 'tnpr-flin)
+      (change-chcm-to-flcc ecc tnpr-flin)
       (the spectral-sequence
         (build-ss fltrcm `(Serre-Spectral-Sequence ,f))))))
 
@@ -1629,8 +1628,8 @@
   (let ((ecc (rbcc (efhm x))))
     (declare (type chain-complex ecc))
     (progn
-      (change-chcm-to-flcc x crpr-flin 'crpr-flin)
+      (change-chcm-to-flcc x crpr-flin)
-      (change-chcm-to-flcc ecc tnpr-flin 'tnpr-flin)
+      (change-chcm-to-flcc ecc tnpr-flin)
       (the spectral-sequence
         (build-ss x   `(Serre-Spectral-Sequence ,x))))))
 
@@ -1661,7 +1660,7 @@
      (type simplicial-set ox)
      (type chain-complex ecc))
     (progn
-      (change-chcm-to-flcc ecc cobar-flin 'cobar-flin)
+      (change-chcm-to-flcc ecc cobar-flin)
       (the spectral-sequence
         (build-ss ecc `(Eilenberg-Moore-Spectral-Sequence ,x))))))