diff --git a/kenzo.asd b/kenzo.asd index df9bb72..f608950 100644 --- a/kenzo.asd +++ b/kenzo.asd @@ -49,5 +49,10 @@ (:file "cs-twisted-products") (:file "cl-space-efhm") (:file "whitehead") - (:file "smith"))))) + (:file "smith") + (:module "anromero" + :components + ((:file "bicomplexes") + (:file "filtered-complexes") + (:file "spectral-sequences"))))))) diff --git a/package.lisp b/package.lisp index 0a2721b..0fea7cf 100644 --- a/package.lisp +++ b/package.lisp @@ -41,6 +41,7 @@ F G H + IABSM MAKE-CMBN MAKE-RESULT MORPHISM diff --git a/src/anromero/bicomplexes.lisp b/src/anromero/bicomplexes.lisp new file mode 100644 index 0000000..0b9f798 --- /dev/null +++ b/src/anromero/bicomplexes.lisp @@ -0,0 +1,269 @@ +;; BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES +;; BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES +;; BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES + +(IN-PACKAGE #:cat) + +(PROVIDE "bicomplexes") + +(DEFMETHOD PRINT-KEYCONS ((car (eql :BcGnrt)) cdr stream) + (declare + (cons cdr) + (stream stream)) + (the (eql t) + (let* + ((cdr (cons car cdr)) + (degr1 (BcGnrt-Degr1 cdr)) + (degr2 (BcGnrt-Degr2 cdr)) + (gnrt (BcGnrt-gnrt cdr))) + (progn + (format stream "")) + t))) + + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; TYPES FOR BICOMPLEXES ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; TYPE BcGnrt (a generator in a Bicomplex) +(DEFUN BcGnrt-p (object) + (declare (type any object)) + (the boolean + (and (consp object) + (eql :BcGnrt (car object)) + (consp (cdr object)) + (consp (cadr object)) + (typep (caadr object) 'fixnum) + (typep (cdadr object) 'fixnum)))) +(DEFTYPE BcGnrt () '(satisfies BcGnrt-p)) + +#| +(typep `(:BcGnrt ,(cons 5 6) u) 'BcGnrt) +(typep `(:BcGnrt ,(cons 3 2) '(f g)) 'BcGnrt) +(typep `(:BcGnrt ,(cons 4 5.4) u) 'BcGnrt) +|# + + +;; TYPE BcBasis (basis of a Bicomplex, function of the variables p and q or +;; ":locally-effective") +(DEFTYPE BcBASIS () '(or function (eql :locally-effective))) + ;; (function (degr degr) (list gnrt)) + + +;; TYPE Bicomplex +(DEFUN OrgnBiCmpl-p (object) + (declare (type chain-complex object)) + (let* ((orgn (orgn object))) + (the boolean + (and (consp orgn) + (eql (car orgn) 'BiCmpl))))) +(DEFTYPE Bicomplex () '(satisfies OrgnBiCmpl-p)) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; FUCTIONS FOR THE REPRESENTATION OF (GENERAL) BICOMPLEXES ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; Function that builds a generator of a Bicomplex from two degrees and +;; a simple generator. +(DEFUN build-BcGnrt (degr1 degr2 gnrt) + (declare + (type fixnum degr1 degr2) + (type any gnrt)) + (list :BcGnrt (cons degr1 degr2) gnrt)) + +#| +(build-BcGnrt 2 3 'c) +(typep (build-BcGnrt 2 2 'd) 'BcGnrt) +|# + + +;; Function that returns the first degree from a bicomplex' generator. +(DEFUN BcGnrt-Degr1 (BcGnrt) + (declare (type BcGnrt BcGnrt)) + (caadr BcGnrt)) + +;; Function that returns the second degree from a bicomplex' generator. +(DEFUN BcGnrt-Degr2 (BcGnrt) + (declare (type BcGnrt BcGnrt)) + (cdadr BcGnrt)) + +;; Function that returns the original generator from a bicomplex' generator. +(DEFUN BcGnrt-Gnrt (BcGnrt) + (declare (type BcGnrt BcGnrt)) + (caddr BcGnrt)) + +#| +(build-BcGnrt 5 6 8) +(BcGnrt-Degr1 (build-BcGnrt 5 6 8)) +(BcGnrt-Degr2 (build-BcGnrt 6 4 '(4 6))) +(BcGnrt-Gnrt (build-BcGnrt 6 4 '(4 6))) +(BcGnrt-Gnrt (build-BcGnrt 2 8 'u)) +|# + + +;; Comparison function of a bicomplex. +(defun BC-CMPR (cmpr) + (declare (type cmprf cmpr)) + (flet ((comp (bc1 bc2) + (declare (type BcGnrt bc1 bc2)) + (let ((degr11 (BcGnrt-Degr1 bc1)) + (degr21 (BcGnrt-Degr2 bc1)) + (degr12 (BcGnrt-Degr1 bc2)) + (degr22 (BcGnrt-Degr2 bc2)) + (gnrt1 (BcGnrt-Gnrt bc1)) + (gnrt2 (BcGnrt-Gnrt bc2))) + (declare + (type fixnum degr11 degr21 degr12 degr22) + (type any gnrt1 gnrt2)) + (lexico + (f-cmpr degr11 degr12) + (f-cmpr degr21 degr22) + (funcall cmpr gnrt1 gnrt2))))) + (the cmprf #'comp))) + +#| +(setf cmpr (BC-CMPR #'s-cmpr)) +(funcall cmpr (build-BcGnrt 5 6 'a) (build-BcGnrt 7 8 'b)) +(funcall cmpr (build-BcGnrt 8 6 'a) (build-BcGnrt 7 8 'b)) +(funcall cmpr (build-BcGnrt 8 5 'c) (build-BcGnrt 8 6 'b)) +(funcall cmpr (build-BcGnrt 8 5 'c) (build-BcGnrt 8 5 'b)) +|# + +;; Basis of a bicomplex (from a function of type BcBasis). +(DEFUN BC-BASIS (bcbasis) + (declare (type BcBasis bcbasis)) + (when (eq bcbasis :locally-effective) + (return-from bc-basis :locally-effective)) + (flet ((bas (degr) + (declare (type fixnum degr)) + (the list + (progn + (when (minusp degr) + (return-from bas +empty-list+)) + (mapcan + #'(lambda (degr1) + (declare (type fixnum degr1)) + (let* ((degr2 (- degr degr1)) + (basis (funcall bcbasis degr1 degr2))) + (declare + (fixnum degr2) + (list basis)) + (the list + (mapcar + #'(lambda (gnrt) + (declare (type gnrt gnrt)) + (the BcGnrt + (build-BcGnrt degr1 degr2 gnrt))) + basis))) + ) + ( 0 degr)))))) + (the basis #'bas))) + +#| +(defun bas (degr1 degr2) + (if (and (= degr1 0) (= degr2 1)) (return-from bas '(a))) + (if (and (= degr1 1) (= degr2 0)) (return-from bas '(b))) + (if (and (= degr1 1) (= degr2 1)) (return-from bas '(c))) + (if (and (= degr1 2) (= degr2 0)) (return-from bas '(d))) + (return-from bas nil)) +(setf basis (BC-BASIS #'bas)) +(dotimes (i 5) + (print (funcall basis i))) +|# + +;; Differential function of a Bicomplex (from the differential functions, +;; dffr1=horizontal dffr, dffr2=vertical dffr). +(DEFUN BC-INTR-DFFR (dffr1 dffr2) + (declare (type function dffr1 dffr2)) + (flet ((dif (degr bc) + (declare + (fixnum degr) + (type BcGnrt bc)) + (the cmbn + (let* ((degr1 (BcGnrt-Degr1 bc)) + (degr2 (BcGnrt-Degr2 bc)) + (gnrt (BcGnrt-Gnrt bc)) + (degr1-1 (1- degr1)) + (degr2-1 (1- degr2)) + (list1 (funcall dffr1 degr1 degr2 gnrt)) + (list2 (funcall dffr2 degr1 degr2 gnrt))) + (declare (type fixnum degr1 degr2 degr1-1) + (list list1 list2)) + (make-cmbn + :degr (1- degr) + :list (nconc + (mapcar + #'(lambda (term1) + (declare (type term term1)) + (let* ((cffc1 (cffc term1)) + (gnrt1 (gnrt term1))) + (declare (type fixnum cffc1) + (type gnrt gnrt1)) + (term cffc1 (build-BcGnrt degr1-1 degr2 gnrt1)))) + list1) + (mapcar + #'(lambda (term2) + (declare (type term term2)) + (let* ((cffc2 (cffc term2)) + (gnrt2 (gnrt term2))) + (declare (type fixnum cffc2) + (type gnrt gnrt2)) + (term cffc2 (build-BcGnrt degr1 degr2-1 gnrt2)))) + list2))))))) + (the intr-mrph #'dif))) + +#| +(defun dif1 (degr1 degr2 gnrt) + (if (and (= degr1 1) (= degr2 1) (eql gnrt 'c)) (return-from dif1 (list (cons 2 'a)))) + (if (and (= degr1 2) (= degr2 0) (eql gnrt 'd)) (return-from dif1 (list (cons 2 'b)))) + (return-from dif1 nil)) +(defun dif2 (degr1 degr2 gnrt) + (if (and (= degr1 1) (= degr2 1) (eql gnrt 'c)) (return-from dif2 (list (cons 1 'b)))) + (return-from dif2 nil)) +(setf dif (BC-INTR-DFFR #'dif1 #'dif2)) +(funcall dif 2 (build-BcGnrt 1 1 'c)) +|# + +;; Function that builds a bicomplex from a basis function, the two differential +;; functions and the original comparison. +(DEFUN BUILD-BICM (&key bcbasis dffr1 dffr2 cmpr orgn) + (declare + (type BCbasis bcbasis) + (type function dffr1 dffr2) + (type cmprf cmpr) + (type list orgn)) + (the chain-complex + (let ((chcm + (build-chcm + :cmpr (BC-CMPR cmpr) + :basis (BC-BASIS bcbasis) + :intr-dffr (BC-INTR-DFFR dffr1 dffr2) + :strt :gnrt + :orgn orgn))) + (declare (type chain-complex chcm)) + (slot-makunbound chcm 'bsgn) + chcm))) + +#| +(setf bc (Build-Bicm :bcbasis #'bas :dffr1 #'dif1 :dffr2 #'dif2 :cmpr 's-cmpr + :orgn '(BC-test))) +(dotimes (i 5) + (print (basis bc i))) +(cmpr bc (build-BcGnrt 0 1 'a) (build-BcGnrt 1 1 'c)) + +(? bc (? bc 2 (build-BcGnrt 1 1 'c))) +(? bc 2 (build-BcGnrt 2 0 'd)) +(? bc 2 '(:BcGnrt (1 . 1) c)) +(? bc (cmbn 2 3 '(:BcGnrt (1 . 1) c))) +(? bc 1 (build-bicm 0 1 'a)) +|# + + + + + diff --git a/src/anromero/filtered-complexes.lisp b/src/anromero/filtered-complexes.lisp new file mode 100644 index 0000000..1006143 --- /dev/null +++ b/src/anromero/filtered-complexes.lisp @@ -0,0 +1,848 @@ +;; FILTERED-COMPLEXES FILTERED-COMPLEXES FILTERED-COMPLEXES FILTERED-COMPLEXES +;; FILTERED-COMPLEXES FILTERED-COMPLEXES FILTERED-COMPLEXES FILTERED-COMPLEXES +;; FILTERED-COMPLEXES FILTERED-COMPLEXES FILTERED-COMPLEXES FILTERED-COMPLEXES + +(IN-PACKAGE #:cat) + +(provide "filtered-complexes") + +(DEFTYPE degr () 'fixnum) + +(DEFTYPE CHCM-FLIN () 'function) +;; '(function (degr gnrt) degr) + + +(DEFCLASS FILTERED-CHAIN-COMPLEX (chain-complex) + ((flin :type chcm-flin :initarg :flin :reader flin1))) + +(DEFVAR *flcc-list*) +(SETF *flcc-list* +empty-list+) +(PUSHNEW '*flcc-list* *list-list*) + +(DEFMETHOD PRINT-OBJECT ((flcm FILTERED-CHAIN-COMPLEX) stream) + (the FILTERED-CHAIN-COMPLEX + (progn + (format stream "[K~D Filtered-Chain-Complex]" (idnm flcm)) + flcm))) + +(DEFUN FLCC (idnm) + (declare (type fixnum idnm)) + (the (or FILTERED-CHAIN-COMPLEX null) + (find idnm *flcc-list* :key #'idnm))) + + +;; Function that builds a filtered chain complex. +(DEFUN BUILD-FLCC + (&key cmpr basis bsgn intr-dffr dffr-strt flin orgn) + (declare + (type cmprf cmpr) + (type intr-mrph intr-dffr) + (type basis basis) + (type gnrt bsgn) + (type strt dffr-strt) + (type Chcm-Flin flin) + (list orgn)) + (the FILTERED-CHAIN-COMPLEX + (progn + (let ((already (find orgn *flcc-list* :key #'orgn :test #'equal))) + (declare (type (or null FILTERED-CHAIN-COMPLEX) already)) + (when already + (return-from build-flcc already))) + (let ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bsgn + :intr-dffr intr-dffr :strt dffr-strt + :orgn orgn))) + (declare (type chain-complex rslt)) + (change-class rslt 'FILTERED-CHAIN-COMPLEX) + (setf (slot-value rslt 'flin) flin) + (push rslt *flcc-list*) + rslt)))) + + +;; Function that changes a chain complex chcm to a filtered complex, with filtration +;; 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) + (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) + (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 ((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))) + + +(DEFMACRO FLIN (&rest rest) + (ecase (length rest) + (1 `(flin1 ,@rest)) + (2 `(flin2 ,@rest)) + (3 `(flin3 ,@rest)))) + +(DEFUN FLIN3 (object degr gnrt) + (declare + (type FILTERED-CHAIN-COMPLEX object) + (fixnum degr) + (type gnrt gnrt)) + (the fixnum + (with-slots (flin) object + (declare (type chcm-flin flin)) + (funcall flin degr gnrt)))) + +(DEFUN FLIN2 (object cmbn) + (declare + (type FILTERED-CHAIN-COMPLEX object) + (type cmbn cmbn)) + (the fixnum + (with-slots (flin) object + (declare (type chcm-flin flin)) + (with-cmbn (degr cmbn-list) cmbn + (declare + (fixnum degr) + (list cmbn-list)) + (labels ((list-max (list) + (declare (type list list)) + (let* ((max-int (car list))) + (do ((mark1 list (cdr mark1))) + ((endp mark1)) + (setq max-int (max max-int (car mark1)))) + max-int))) + (if (endp cmbn-list) + 0 + (list-max + (mapcar + #'(lambda (term) + (flin3 object degr (gnrt term))) + cmbn-list)))))))) + + + +;; Function that returns the min and max of the filtration index of the elements of the basis +;; for degree degr +(DEFUN FLIN-MIN-MAX (fltrcm degr) + (declare (type FILTERED-CHAIN-COMPLEX fltrcm) + (type fixnum degr)) + (when (eq (basis fltrcm) :locally-effective) + (error "flin-min-max cannot work with a LOCALLY-EFFECTIVE chain complex.")) + (the list + (let* ((basis (basis fltrcm degr))) + (declare (list basis)) + (if (endp basis) + (list 0 0) + (let* ((min (flin fltrcm degr (first basis))) + (max min)) + (declare (type fixnum min max)) + (dolist (gnrt (cdr basis)) + (let ((aux (flin fltrcm degr gnrt))) + (declare (type fixnum aux)) + (if (< aux min) + (setf min aux) + (if (> aux max) + (setf max aux))))) + (list min max)))))) + + + +;; Function that returns the elements of the basis that have bidegree (p,q). +(DEFUN BIGRD-BASIS (fltrcm p q) + (declare (type FILTERED-CHAIN-COMPLEX fltrcm) + (type fixnum p q)) + (when (eq (basis fltrcm) :locally-effective) + (error "Bigrd-Basis cannot work with a LOCALLY-EFFECTIVE chain complex.")) + (the list + (let* ((degr (+ p q)) + (basis (basis fltrcm degr))) + (declare + (type list basis) + (fixnum degr)) + (mapcan + #'(lambda (gnrt) + (declare (type gnrt gnrt)) + (if (= (flin fltrcm degr gnrt) p) + (list gnrt) + nil)) + basis)))) + +;; Function that returns the elements of the basis of degree "degr" that have +;; filtration index <= "fltr-index". +(DEFUN FLTRD-BASIS (fltrcm degr fltr-index) + (declare (type FILTERED-CHAIN-COMPLEX fltrcm) + (type fixnum degr fltr-index)) + (when (eq (basis fltrcm) :locally-effective) + (error "Fltrd-Basis cannot work with a LOCALLY-EFFECTIVE chain complex.")) + (let ((min (first (flin-min-max fltrcm degr)))) + (declare (type fixnum min)) + (the list + (mapcan + #'(lambda (i) + (bigrd-basis fltrcm i (- degr i))) + ( min fltr-index))))) + +;; Function that returns the elements of the basis with degree "degr", +;; ordered by the filtration index. +(DEFUN ORDERED-BASIS (fltrcm degr) + (declare + (type FILTERED-CHAIN-COMPLEX fltrcm) + (fixnum degr)) + (when (eq (basis fltrcm) :locally-effective) + (error "Ordered-Basis cannot work with a LOCALLY-EFFECTIVE chain complex.")) + (the list + (let ((max (second (flin-min-max fltrcm degr)))) + (declare (type fixnum max)) + (fltrd-basis fltrcm degr max)))) + +;; 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) + (declare + (type FILTERED-CHAIN-COMPLEX fltrcm) + (fixnum degr fltr-index)) + (when (eq (basis fltrcm) :locally-effective) + (error "flcc-dffr-mtrx cannot work with a LOCALLY-EFFECTIVE chain complex.")) + (the matrix + (let* ((cmpr (cmpr1 fltrcm)) + (dffr (dffr fltrcm)) + (sbasis (fltrd-basis fltrcm degr fltr-index)) + (tbasis (ordered-basis fltrcm (1- degr))) + ;; If the differential application in the filtered complex respects the filtration, + ;; i.e., d(F_pA_n) \in (F_pA)_{n-1}, the target basis is (fltrd-basis fltrcm (1- degr) fltr-index) + (srank (length sbasis)) + (trank (length tbasis))) + (declare + (type cmprf cmpr) + (type morphism dffr) + (fixnum degr) + (list sbasis tbasis) + (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)) + (do ((j 0 (1+ j)) + (mark sbasis (cdr mark))) + ((endp mark)) + (declare + (fixnum j) + (list mark)) + (let ((cmbn (gnrt-? dffr degr (car mark)))) + (declare (type cmbn cmbn)) + (do ((mark1 (cmbn-list cmbn) (cdr mark1))) + ((endp mark1)) + (declare (list mark1)) + (with--term (cffc gnrt) mark1 + (declare + (fixnum cffc) + (type gnrt gnrt)) + (do ((mark2 tbasis (cdr mark2)) + (i 0 (1+ i)) + (found nil)) + ((or (endp mark2) found)) + (declare + (list mark2) + (fixnum i)) + (if (eq :equal (funcall cmpr gnrt (car mark2))) + (progn + (setq found 1) + (setf (aref rslt i j) cffc)))))))) + rslt)))) + + +;; OTHER CLASSES THAT INHERIT FROM FILTERED-CHAIN-COMPLEX + + +(DEFCLASS FILTERED-COALGEBRA (filtered-chain-complex coalgebra) + ()) + +(DEFVAR *FLCLGB-LIST*) +(SETF *FLCLGB-LIST* +empty-list+) +(PUSHNEW '*FLCLGB-LIST* *list-list*) + +(DEFMETHOD PRINT-OBJECT ((flclgb FILTERED-COALGEBRA) stream) + (the FILTERED-COALGEBRA + (progn + (format stream "[K~D FILTERED-COALGEBRA]" (idnm flclgb)) + flclgb))) + +(DEFUN FltrClgb (idnm) + (declare (type fixnum idnm)) + (the (or FILTERED-COALGEBRA null) + (find idnm *flclgb-list* :key #'idnm))) + +;; Function that builds a filtered coalgebra. +(DEFUN BUILD-FltrClgb + (&key cmpr basis bsgn intr-dffr dffr-strt intr-cprd cprd-strt flin orgn) + (declare + (type cmprf cmpr) + (type intr-mrph intr-dffr intr-cprd) + (type basis basis) + (type gnrt bsgn) + (type strt dffr-strt cprd-strt) + (type chcm-flin flin) + (list orgn)) + (the FILTERED-COALGEBRA + (progn + (let ((already (find orgn *flclgb-list* :key #'orgn :test #'equal))) + (declare (type (or null FILTERED-COALGEBRA) already)) + (when already + (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 + :orgn orgn))) + (declare (type coalgebra rslt)) + (change-class rslt 'FILTERED-COALGEBRA) + (setf (slot-value rslt 'flin) flin) + (push rslt *flclgb-list*) + rslt)))) + +(defmethod change-chcm-to-flcc ((chcm coalgebra) flin flin-orgn ) + (declare + + (type chcm-flin flin) + (list flin-orgn)) + (the FILTERED-COALGEBRA + (progn + (change-class chcm 'FILTERED-COALGEBRA) + (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn)) + (let ((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))) + (setf (slot-value chcm 'flin) flin) + (setf (slot-value chcm 'orgn) orgn) + (push chcm *flCLGB-list*) + chcm))) + + +(DEFCLASS FILTERED-ALGEBRA (filtered-chain-complex algebra) + ()) + +(DEFVAR *FLALGB-LIST*) +(SETF *FLALGB-LIST* +empty-list+) +(PUSHNEW '*FLALGB-LIST* *list-list*) + +(DEFMETHOD PRINT-OBJECT ((flalgb FILTERED-ALGEBRA) stream) + (the FILTERED-ALGEBRA + (progn + (format stream "[K~D FILTERED-ALGEBRA]" (idnm flalgb)) + flalgb))) + +(DEFUN FltrAlgb (idnm) + (declare (type fixnum idnm)) + (the (or FILTERED-ALGEBRA null) + (find idnm *flalgb-list* :key #'idnm))) + +;; Function that builds a filtered algebra. +(DEFUN BUILD-FltrAlgb + (&key cmpr basis bsgn intr-dffr dffr-strt intr-aprd aprd-strt flin orgn) + (declare + (type cmprf cmpr) + (type intr-mrph intr-dffr intr-aprd) + (type basis basis) + (type gnrt bsgn) + (type strt dffr-strt aprd-strt) + (type chcm-flin flin) + (list orgn)) + (the FILTERED-ALGEBRA + (progn + (let ((already (find orgn *flalgb-list* :key #'orgn :test #'equal))) + (declare (type (or null FILTERED-ALGEBRA) already)) + (when already + (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 + :orgn orgn))) + (declare (type algebra rslt)) + (change-class rslt 'FILTERED-ALGEBRA) + (setf (slot-value rslt 'flin) flin) + (push rslt *flalgb-list*) + rslt)))) + +(defmethod change-chcm-to-flcc ((chcm algebra) flin flin-orgn ) + (declare + + (type chcm-flin flin) + (list flin-orgn)) + (the FILTERED-ALGEBRA + (progn + (change-class chcm 'FILTERED-ALGEBRA) + (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn)) + (let ((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))) + (setf (slot-value chcm 'flin) flin) + (setf (slot-value chcm 'orgn) orgn) + (push chcm *flaLGB-list*) + chcm))) + + +(DEFCLASS FILTERED-HOPF-ALGEBRA (filtered-chain-complex hopf-algebra) + ()) + +(DEFVAR *FLHOPF-LIST*) +(SETF *FLHOPF-LIST* +empty-list+) +(PUSHNEW '*FLHOPF-LIST* *list-list*) + +(DEFMETHOD PRINT-OBJECT ((flhopf FILTERED-HOPF-ALGEBRA) stream) + (the FILTERED-HOPF-ALGEBRA + (progn + (format stream "[K~D FILTERED-HOPF-ALGEBRA]" (idnm flhopf)) + flhopf))) + +(DEFUN FltrHopf (idnm) + (declare (type fixnum idnm)) + (the (or FILTERED-HOPF-ALGEBRA null) + (find idnm *flhopf-list* :key #'idnm))) + +(defmethod change-chcm-to-flcc ((chcm hopf-algebra) flin flin-orgn ) + (declare + + (type chcm-flin flin) + (list flin-orgn)) + (the FILTERED-hofp-algebra + (progn + (change-class chcm 'FILTERED-hopf-COALGEBRA) + (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn)) + (let ((already (find orgn *flhopf-list* :key #'orgn :test #'equal))) + (declare (type (or null FILTERED-HOPF-COALGEBRA) already)) + (when 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))) + + +(DEFCLASS FILTERED-SIMPLICIAL-SET (FILTERED-CHAIN-COMPLEX simplicial-set ) + ()) + +(DEFVAR *FLSMST-LIST*) +(SETF *FLSMST-LIST* +empty-list+) +(PUSHNEW '*FLSMST-LIST* *list-list*) + +(DEFMETHOD PRINT-OBJECT ((flsmst filtered-simplicial-set) stream) + (the filtered-simplicial-set + (progn + (format stream "[K~D Filtered-Simplicial-Set]" (idnm flsmst)) + flsmst))) + +(DEFUN FltrSmSet (idnm) + (declare (type fixnum idnm)) + (the (or filtered-simplicial-set null) + (find idnm *flsmst-list* :key #'idnm))) + + + +;; Function that builds a filtered simplicial set +(DEFUN BUILD-FltrSmSt + (&key cmpr basis bspn face face* intr-bndr bndr-strt intr-dgnl dgnl-strt flin orgn) + (declare + (type cmprf cmpr) + (type basis basis) + (type gmsm bspn) + (type face face) + (type (or null face*) face*) + (type (or intr-mrph null) intr-bndr intr-dgnl) + (type (or strt null) bndr-strt dgnl-strt) + (type chcm-flin flin) + (list orgn)) + (the FILTERED-SIMPLICIAL-SET + (progn + (let ((already (find orgn *flsmst-list* :key #'orgn :test #'equal))) + (declare (type (or null FILTERED-SIMPLICIAL-SET) already)) + (when already + (return-from build-FltrSmst already))) + (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))) + (declare (type simplicial-set rslt)) + (change-class rslt 'FILTERED-SIMPLICIAL-SET) + (setf (slot-value rslt 'flin) flin) + (push rslt *flsmst-list*) + rslt)))) + +(defmethod change-chcm-to-flcc ((chcm simplicial-set) flin flin-orgn ) + (declare + + (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) flin-orgn)) + (let ((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))) + (setf (slot-value chcm 'flin) flin) + (setf (slot-value chcm 'orgn) orgn) + (push chcm *flsmst-list*) + chcm))) + + +(DEFCLASS FILTERED-KAN (FILTERED-CHAIN-COMPLEX KAN ) + ()) + +(DEFVAR *FLKAN-LIST*) +(SETF *FLKAN-LIST* +empty-list+) +(PUSHNEW '*FLKAN-LIST* *list-list*) + +(DEFMETHOD PRINT-OBJECT ((flkan filtered-kan) stream) + (the filtered-kan + (progn + (format stream "[K~D Filtered-Kan-Simplicial-Set]" (idnm flkan)) + flkan))) + +(DEFUN FltrKan (idnm) + (declare (type fixnum idnm)) + (the (or filtered-kan null) + (find idnm *flkan-list* :key #'idnm))) + +(defmethod change-chcm-to-flcc ((chcm kan) flin flin-orgn ) + (declare + + (type chcm-flin flin) + (list flin-orgn)) + (the FILTERED-KAN + (progn + (change-class chcm 'FILTERED-KAN) + (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn)) + (let ((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))) + (setf (slot-value chcm 'flin) flin) + (setf (slot-value chcm 'orgn) orgn) + (push chcm *flkan-list*) + chcm))) + + +(DEFCLASS FILTERED-SIMPLICIAL-GROUP (FILTERED-CHAIN-COMPLEX SIMPLICIAL-GROUP ) + ()) + +(DEFCLASS FILTERED-AB-SIMPLICIAL-GROUP (FILTERED-CHAIN-COMPLEX AB-SIMPLICIAL-GROUP ) + ()) + +(DEFVAR *FLSMGR-LIST*) +(SETF *FLSMGR-LIST* +empty-list+) +(PUSHNEW '*FLSMGR-LIST* *list-list*) + +(DEFMETHOD PRINT-OBJECT ((flsmgr filtered-simplicial-group) stream) + (the filtered-simplicial-group + (progn + (format stream "[K~D Filtered-Simplicial-Group]" (idnm flsmgr)) + flsmgr))) + +(DEFMETHOD PRINT-OBJECT ((flsmgr filtered-ab-simplicial-group) stream) + (the filtered-simplicial-group + (progn + (format stream "[K~D Filtered-Abelian-Simplicial-Group]" (idnm flsmgr)) + flsmgr))) + +(DEFUN FltrSmgr (idnm) + (declare (type fixnum idnm)) + (the (or filtered-simplicial-group null) + (find idnm *flsmgr-list* :key #'idnm))) + +(DEFUN BUILD-FltrSmGr + (&key cmpr basis bspn face face* intr-bndr bndr-strt intr-dgnl dgnl-strt + sintr-grml sintr-grin flin orgn) + (declare + (type cmprf cmpr) + (type basis basis) + (type gmsm bspn) + (type face face) + (type (or null face*) face*) + (type (or intr-mrph null) intr-bndr intr-dgnl) + (type (or strt null) bndr-strt dgnl-strt) + (type sintr sintr-grml sintr-grin) + (type chcm-flin flin) + (list orgn)) + (the FILTERED-SIMPLICIAL-GROUP + (progn + (let ((already (find orgn *flsmgr-list* :key #'orgn :test #'equal))) + (declare (type (or null FILTERED-SIMPLICIAL-GROUP) already)) + (when already + (return-from build-FltrSmgr already))) + (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 + :sintr-grin sintr-grin :orgn orgn))) + (declare (type simplicial-group rslt)) + (change-class rslt 'FILTERED-SIMPLICIAL-GROUP) + (setf (slot-value rslt 'flin) flin) + (push rslt *flsmgr-list*) + rslt)))) + +(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 ) + (declare + + (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 ((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))) + (setf (slot-value chcm 'flin) flin) + (setf (slot-value chcm 'orgn) orgn) + (push chcm *flsmgr-list*) + chcm))) + +(defmethod change-chcm-to-flcc ((chcm ab-simplicial-group) flin flin-orgn ) + (declare + + (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 ((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))) + (setf (slot-value chcm 'flin) flin) + (setf (slot-value chcm 'orgn) orgn) + (push chcm *flabsmgr-list*) + chcm))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; EXAMPLES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; BICOMPLEXES + +;; Filtration index function of a Bicomplex (first degree of a generator). +(setf BCflin + #'(lambda (degr gnrt) + (declare + (type fixnum degr) + (type gnrt gnrt)) + (let* ((degr1 (BcGnrt-Degr1 gnrt)) + (degr2 (BcGnrt-Degr2 gnrt))) + (declare (type fixnum degr1 degr2)) + (if (= degr (+ degr1 degr2)) + degr1 + 0)))) + +#| +(funcall BCflin 5 (build-bcgnrt 2 3 'a)) +(funcall BCflin 7 (build-bcgnrt 6 1 'c)) +|# + +;; Function that changes the bicomplex bc to a filtered complex, with filtration +;; index of a generator defined as its first degree. +(defun CHANGE-BICM-TO-FLCC (bc) + (declare + (type bicomplex bc)) + (let* ((orgn (orgn bc)) + (flin BCflin)) + (declare + (type list orgn) + (type chcm-flin flin)) + (the FILTERED-CHAIN-COMPLEX + (change-chcm-to-flcc bc flin '(Bicomplex-Flin))))) + +#| +(defun bas (degr1 degr2) + (if (and (= degr1 0) (= degr2 1)) (return-from bas '(a))) + (if (and (= degr1 1) (= degr2 0)) (return-from bas '(b))) + (if (and (= degr1 1) (= degr2 1)) (return-from bas '(c))) + (if (and (= degr1 2) (= degr2 0)) (return-from bas '(d))) + (return-from bas nil)) + +(defun dif1 (degr1 degr2 gnrt) + (if (and (= degr1 1) (= degr2 1) (eql gnrt 'c)) (return-from dif1 (list (cons 2 'a)))) + (if (and (= degr1 2) (= degr2 0) (eql gnrt 'd)) (return-from dif1 (list (cons 2 'b)))) + (return-from dif1 nil)) +(defun dif2 (degr1 degr2 gnrt) + (if (and (= degr1 1) (= degr2 1) (eql gnrt 'c)) (return-from dif2 (list (cons 1 'b)))) + (return-from dif2 nil)) + +(setf bc (Build-Bicm :bcbasis #'bas :dffr1 #'dif1 :dffr2 #'dif2 :cmpr 's-cmpr + :orgn '(BC-test))) + +(change-bicm-to-flcc bc) +(flin bc 1 (build-bcgnrt 0 1 'a)) +(flin bc (cmbn 2 4 (build-bcgnrt 1 1 'c))) +(flin bc (cmbn 2 4 (build-bcgnrt 1 1 'c) 2 (build-bcgnrt 2 0 'd))) +(bigrd-basis bc 1 1) +(bigrd-basis bc 2 0) +(fltrd-basis bc 2 1) +(ordered-basis bc 2) +(flcc-dffr-mtrx bc 2 1) +(flcc-dffr-mtrx bc 2 2) +|# + + +;; BARS + +#| +(defun abar-bidegree (abar) + (declare (type abar abar)) + (the list + (let ((p (1- (length abar))) + (q 0)) + (declare (type fixnum p q)) + (setf q (apply #'+ (mapcar #'car (rest abar)))) + (decf q p) + (return-from abar-bidegree (list p q))))) +|# + +(setf abar-flin + #'(lambda (degr abar) + (declare (type fixnum degr) + (type abar abar)) + (let* ((abar-bidgr (abar-bidegree abar)) + (degr1 (first abar-bidgr)) + (degr2 (second abar-bidgr))) + (if (= degr (+ degr1 degr2)) + degr1 + 0)))) + +#| +(setq kz2 (k-z2-1)) +(setq bar2 (bar kz2)) + +(change-chcm-to-flcc bar2 abar-flin '(abar-flin)) + + +(setf basis7 (basis bar2 7)) + +(mapcar + #'(lambda (gnrt) + (flin bar2 7 gnrt)) + basis7) + +(flin bar2 (cmbn 7 (first basis7) (second basis7))) + +(bigrd-basis bar2 2 5) +(bigrd-basis bar2 3 4) +(fltrd-basis bar2 7 2) +(ordered-basis bar2 7) +(flcc-dffr-mtrx bar2 7 2) +(flcc-dffr-mtrx bar2 7 3) +|# + +;; COBAR + +#| +(defun allp-bidegree (allp) + (declare (type allp allp)) + (the list + (let ((p (1- (length allp))) + (q 0)) + (declare (type fixnum p q)) + (setf q (apply #'+ (mapcar #'car (rest allp)))) + (incf q p) + (return-from allp-bidegree (list (- p) q))))) +|# + +(setf cobar-flin + #'(lambda (degr allp) + (declare (type fixnum degr) + (type allp allp)) + (let* ((allp-bidgr (allp-bidegree allp)) + (degr1 (first allp-bidgr)) + (degr2 (second allp-bidgr))) + (if (= degr (+ degr1 degr2)) + degr1 + 0)))) + +;; TENSOR PRODUCTS + +(setf tnpr-flin + #'(lambda (degr tnpr) + (declare + (type fixnum degr) + (type tnpr tnpr)) + (the fixnum + (degr1 tnpr)))) + + +;; FIBRATIONS (CARTESIAN PRODUCTS AND TWISTED PRODUCTS) + +#| +(setf crpr-flin + #'(lambda (degr crpr) + (declare + (type fixnum degr) + (type crpr crpr)) + (let* ((b (cadr crpr)) + (dgop (car b))) + (declare + (type iabsm b) + (type fixnum dgop)) + (the fixnum + (- degr (length (dgop-int-ext dgop))))))) +|# + +#| +(funcall fbrt-flin 3 '(:crpr (1 . s2) 0 . 3)) +(funcall fbrt-flin 4 '(:crpr (5 . s2) 0 . 3)) +|# + + +;; BICONES + +(defun bicone-flin (flinb flinc flind) + (declare (type chcm-flin flinb flinc flind)) + (flet ((rslt (degr bicn) + (declare + (type bicn bicn) + (type degr degr)) + (let ((bcnx (bcnx bicn))) + (declare (type (member :bcnb :bcnc :bcnd) bcnx)) + (if (eql :bcnb bcnx) + (funcall flinb degr (ibicn bicn)) + (if (eql :bcnc bcnx) + (funcall flinc degr (ibicn bicn)) + (funcall flind degr (ibicn bicn))))))) + (the chcm-flin #'rslt))) diff --git a/src/anromero/spectral-sequences.lisp b/src/anromero/spectral-sequences.lisp new file mode 100644 index 0000000..ae173a1 --- /dev/null +++ b/src/anromero/spectral-sequences.lisp @@ -0,0 +1,1357 @@ +;; SPECTRAL-SEQUENCES SPECTRAL-SEQUENCES SPECTRAL-SEQUENCES SPECTRAL-SEQUENCES +;; SPECTRAL-SEQUENCES SPECTRAL-SEQUENCES SPECTRAL-SEQUENCES SPECTRAL-SEQUENCES +;; SPECTRAL-SEQUENCES SPECTRAL-SEQUENCES SPECTRAL-SEQUENCES SPECTRAL-SEQUENCES + + +(IN-PACKAGE #:cat) + +(provide "spectral-sequences") + +;; Auxiliary functions to deal with matrices + +(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 + (let ((line-n (line-number mtrx)) + (column-n (column-number mtrx))) + (declare (type fixnum line-n column-n)) + (assert (<= first-line last-line (1- line-n))) + (assert (<= first-col last-col (1- column-n))) + (let* ((line-num (+ (- last-line first-line) 1)) + (column-num (+ (- last-col first-col) 1)) + (rslt (make-array (list line-num column-num) + :element-type 'fixnum))) + (declare (type fixnum line-num column-num) + (type matrix rslt)) + (dotimes (il line-num) + (declare (type fixnum il)) + (dotimes (ic column-num) + (declare (type fixnum ic)) + (setf (aref rslt il ic) + (aref mtrx (+ il first-line) (+ ic first-col))))) + rslt)))) + +#| +(setf m (random-matrix 4 6 10)) +(submatrix m 1 3 2 4) +|# + + +(Defun column-j (mtrx j) + (declare (type matrix mtrx) + (type fixnum j)) + (assert (< j (column-number mtrx))) + (the list + (let ((line-n (line-number mtrx))) + (declare (type fixnum line-n)) + (mapcar + #'(lambda (i) + (declare (type fixnum i)) + (aref mtrx i j)) + ( 0 (1- line-n)))))) + +#| +(setf m (random-matrix 4 6 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) + (declare (type matrix mtrx1 mtrx2)) + (the matrix + (let* ((line-n-1 (line-number mtrx1)) + (column-n-1 (column-number mtrx1)) + (line-n-2 (line-number mtrx2)) + (column-n-2 (column-number mtrx2)) + (line-n (max line-n-1 line-n-2)) + (column-n (+ column-n-1 column-n-2))) + (declare (type fixnum line-n-1 column-n-1 line-n-2 + column-n-2 line-n column-n)) + (let ((rslt + #-ACLPC + (make-array (list line-n column-n) + :element-type 'fixnum + :initial-element 0) + #+ACLPC + (if (or (zerop line-n) (zerop column-n)) + (make-array (list line-n column-n) + :element-type 'fixnum) + (make-array (list line-n column-n) + :element-type 'fixnum + :initial-element 0)))) + (declare (type matrix rslt)) + (do ((j 0 (1+ j))) + ((>= j column-n-1)) + (declare (type fixnum j)) + (do ((i 0 (1+ i))) + ((>= i line-n-1)) + (declare (type fixnum i)) + (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)))) + rslt)))) + +#| +(setf m1 (random-matrix 3 4 10)) +(setf m2 (random-matrix 4 2 10)) +(mtrx-conc m1 m2) +(mtrx-conc m2 m1) +|# + + +;; Functions related with submodules and matrices + +;; 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) + (declare (type matrix mtrx)) + (the list + (let* ((smith-list (smith mtrx)) + (m (third smith-list)) + (q (fourth smith-list)) + (min (min (line-number mtrx) (column-number mtrx))) + (rslt nil)) + (declare + (type list smith-list rslt) + (type matrix m q) + (type fixnum min)) + (progn + (do ((j (1- (column-number mtrx)) (1- j))) + ((< j min)) + (declare (type fixnum j)) + (setq rslt (nconc (list (column-j q j)) rslt))) + (do ((i (1- min) (1- i))) + ((or (< i 0) (not (eql 0 (aref m i i))))) + (declare (type fixnum i)) + (setq rslt (nconc (list (column-j q i)) rslt))) + rslt)))) + +#| +(setf m (random-matrix 3 4 10)) +(kernel m) +|# + + +;; 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) + (declare (type list gnrt-list)) + (the matrix + (let* ((column-n (length gnrt-list)) + (line-n (length (car gnrt-list))) + (rslt + #-ACLPC + (make-array (list line-n column-n) + :element-type 'fixnum + :initial-element 0) + #+ACLPC + (if (or (zerop line-n) (zerop column-n)) + (make-array (list line-n column-n) + :element-type 'fixnum) + (make-array (list line-n column-n) + :element-type 'fixnum + :initial-element 0)))) + (declare + (type fixnum column-n line-n) + (type matrix rslt)) + (do ((j 0 (1+ j)) + (mark2 gnrt-list (cdr mark2))) + ((endp mark2)) + (declare + (type fixnum j) + (list mark2)) + (if (eql line-n (length (car mark2))) + (do ((i 0 (1+ i)) + (mark1 (car mark2) (cdr mark1))) + ((endp mark1)) + (declare + (type fixnum i) + (list mark1)) + (setf (aref rslt i j) (car mark1))))) + rslt))) + +#| +(setq gnrt-list (list '(2 4 6 8) '(0 1 0 0) '(0 3 3 3))) +(Gnrt-List-to-Mtrx gnrt-list) +|# + +;; Returns the list of columns of the matrix mtrx. +(defun gnrt-mtrx-to-list (mtrx) + (declare (type matrix mtrx)) + (the list + (let* ((column-n (column-number mtrx))) + (declare (type fixnum column-n)) + (mapcar + #'(lambda (j) + (declare (type fixnum j)) + (column-j mtrx j)) + ( 0 (1- column-n)))))) + +#| +(setf m (random-matrix 3 4 10)) +(gnrt-mtrx-to-list m) +|# + +;; Returns the representation basis-divisors of a quotient of submodules B/C +;; 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) + (declare (type matrix mtrx1 mtrx2)) + (the list + (let* ((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 s1 p1-1Xmtrx2 p1Xd1 d1-1Xp1)) + (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* ((smith-list-2 (smith d1-1Xp1-1Xmtrx2)) + (p2 (first smith-list-2)) + (basis-mtrx (mtrx-prdc p1Xd1 p2)) + (div-mtrx (third smith-list-2)) + (cmbns nil) + (divs nil)) + (declare + (list smith-list-2 cmbns divs) + (type matrix p2 basis-mtrx div-mtrx)) + (do ((i 0 (1+ i))) + ((or (>= i (line-number d1)) (>= i (column-number d1)) + (eql 0 (aref d1 i i)))) + (declare (type fixnum i)) + (progn + (setq cmbns (nconc cmbns (list (column-j basis-mtrx i)))) + (if (and (< i (line-number div-mtrx)) (< i (column-number div-mtrx))) + (setq divs (nconc divs (list (aref div-mtrx i i)))) + (setq divs (nconc divs (list 0)))))) + (list cmbns divs)))))) + +#| +(setf m1 (gnrt-list-to-mtrx '((1 1 1 1) (0 2 0 3) (1 0 0 0)))) +(setf m2 (gnrt-list-to-mtrx '((2 3 1 4) (0 1 1 1)))) +(mtrx-quotient m1 m2) +|# + + + +;; SPECIFIC FUNCTIONS FOR THE COMPUTATION OF SPECTRAL SEQUENCES +;; OF EFFECTIVE FILTERED COMPLEXES. + + +;; GROUPS + +;; Returns the matrix that defines Z^r_{p,q} (a submatrix of the +;; 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) + (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))) + ( (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 ( (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)) + (do ((j 0 (1+ j)) + (mark sbasis (cdr mark))) + ((endp mark)) + (declare + (type fixnum j) + (list mark)) + (let ((cmbn (gnrt-? dffr degr (car mark)))) + (declare (type cmbn cmbn)) + (do ((mark1 (cmbn-list cmbn) (cdr mark1))) + ((endp mark1)) + (declare (list mark1)) + (with--term (cffc gnrt) mark1 + (declare + (type fixnum cffc) + (type gnrt gnrt)) + (do ((mark2 tbasis (cdr mark2)) + (i 0 (1+ i)) + (found nil)) + ((or (endp mark2) found)) + (declare + (list mark2) + (type fixnum i)) + (if (eq :equal (funcall cmpr gnrt (car mark2))) + (progn + (setq found 1) + (setf (aref rslt i j) cffc)))))))) + rslt))))) + +#| +(cat-init) +(setq kz2 (k-z2-1)) +(setq fcc (bar kz2)) +(Change-Chcm-TO-Flcc fcc abar-flin `(abar-flin)) +(FLTR-CHCM-Z-MTRX fcc 2 3 2) +(FLTR-CHCM-Z-MTRX fcc 1 2 4) +|# + + +;; 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) + (declare (type filtered-chain-complex fltrcm) + (type fixnum r p q)) + (the list + (let* ((degr (+ p q)) + (all-basis-gnrt-list (fltr-basis-gnrt-list fltrcm degr p))) + (declare + (type fixnum degr) + (list all-basis-gnrt-list)) + (if (= 0 r) + all-basis-gnrt-list + (let* ((mat (FLTR-CHCM-Z-MTRX fltrcm r p q)) + (line-n (line-number mat)) + (column-n (column-number mat))) + (declare + (type matrix mat) + (type fixnum line-n column-n)) + (if (= 0 column-n) nil + (if (= 0 line-n) + all-basis-gnrt-list + (kernel mat)))))))) +#| +(Fltr-Chcm-Z-Gnrt-List fcc 2 3 2) +(Fltr-Chcm-Z-Gnrt-List fcc 1 2 4) +|# + +;; 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) + (declare + (type filtered-chain-complex fltrcm) + (type fixnum degr fltr-index)) + (the list + (let* ((all-basis (fltrd-basis fltrcm degr fltr-index)) + (basis-l (length all-basis)) + (rslt + (the list + (mapcar + #'(lambda (i) + (nconc (make-list (1- i) :initial-element 0) + (list 1) (make-list (- basis-l i) :initial-element 0))) + ( 1 basis-l))))) + rslt))) + +#| +(fltr-basis-gnrt-list fcc 6 2) +|# + + +;; 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) + (the matrix + (let* ((degr (+ p q)) + (fltr-p-basis (fltrd-basis fltrcm degr p)) + (p-basis-l (length fltr-p-basis)) + (z1-list (fltr-chcm-z-gnrt-list fltrcm r p q)) + (fltr-p-1-list (fltr-basis-gnrt-list fltrcm degr (1- p))) + (z1-mtrx (gnrt-list-to-mtrx z1-list)) + (fltr-p-1-mtrx (gnrt-list-to-mtrx fltr-p-1-list)) + (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 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) + num1-mtrx + (let* ((num-line-n p-basis-l) + (num-column-n (column-number num1-mtrx)) + (rslt + #-ACLPC (make-array (list num-line-n num-column-n) + :element-type 'fixnum + :initial-element 0) + #+ACLPC + (if (or (zerop num-line-n) (zerop num-column-n)) + (make-array (list num-line-n num-column-n) + :element-type 'fixnum) + (make-array (list num-line-n num-column-n) + :element-type 'fixnum + :initial-element 0)))) + (declare + (type fixnum num-lin-n num-column-n) + (type matrix rslt)) + (do ((j 0 (1+ j))) + ((>= j num-column-n)) + (declare (type fixnum j)) + (do ((i 0 (1+ i))) + ((>= i num1-line-n)) + (declare (type fixnum i)) + (Setf (aref rslt i j) (aref num1-mtrx i j)))) + rslt))))) + +#| +(spsq-num-mtrx fcc 2 3 2) +(spsq-num-mtrx fcc 1 2 4) +|# + +;; 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) + (the matrix + (let* ((degr (+ p q)) + (fltr-p-basis (fltrd-basis fltrcm degr p)) + (p-basis-l (length fltr-p-basis)) + (fltr-p-1-list (fltr-basis-gnrt-list fltrcm degr (1- p))) + (z2-list (fltr-chcm-z-gnrt-list fltrcm (1- r) (1- (+ p r)) (+ 2 (- q r)))) + (z2-mtrx (gnrt-list-to-mtrx z2-list)) + (fltr-p-1-mtrx (gnrt-list-to-mtrx fltr-p-1-list)) + (dffr-mtrx (flcc-dffr-mtrx fltrcm (1+ degr) (1- (+ p r)))) + (nil-mtrx + #-ACLPC (make-array (list 0 0) + :element-type 'fixnum + :initial-element 0) + #+ACLPC (make-array (list 0 0) + :element-type 'fixnum)) + (dffr-z2-mtrx + (if (or (= 0 (array-total-size z2-mtrx)) (= 0 (array-total-size dffr-mtrx))) + nil-mtrx + (mtrx-prdc dffr-mtrx z2-mtrx))) + (bnd-z2-line-n p-basis-l) + (bnd-z2-column-n (column-number dffr-z2-mtrx)) + (bnd-z2-mtrx + (if (or (= 0 bnd-z2-line-n) (= 0 bnd-z2-column-n)) + nil-mtrx + (submatrix dffr-z2-mtrx 0 (1- bnd-z2-line-n) 0 (1- bnd-z2-column-n)))) + (den1-mtrx (mtrx-conc bnd-z2-mtrx fltr-p-1-mtrx)) + (den-column-n (column-number den1-mtrx)) + (den-line-n p-basis-l) + (rslt + #-ACLPC (make-array (list den-line-n den-column-n) + :element-type 'fixnum + :initial-element 0) + #+ACLPC + (if (or (zerop den-line-n) (zerop den-column-n)) + (make-array (list den-line-n den-column-n) + :element-type 'fixnum) + (make-array (list den-line-n den-column-n) + :element-type 'fixnum + :initial-element 0)))) + (declare + (list fltr-p-basis fltr-p-1-list z2-list) + (type fixnum degr p-basis-l bnd-z2-line-n bnd-z2-column-n den-column-n den-line-n) + (type matrix z2-mtrx fltr-p-1-mtrx dffr-mtrx nil-mtrx + dffr-z2-mtrx bnd-z2-mtrx den1-mtrx rslt)) + (do ((j 0 (1+ j))) + ((>= j den-column-n)) + (declare (type fixnum j)) + (do ((i 0 (1+ i))) + ((>= i (min den-line-n (line-number den1-mtrx)))) + (declare (type fixnum i)) + (Setf (aref rslt i j) (aref den1-mtrx i j)))) + rslt))) + +#| +(spsq-den-mtrx fcc 2 3 2) +(spsq-den-mtrx fcc 1 2 4) +|# + +;; 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) + (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 matrix num-mtrx den-mtrx)) + (progn + (if (= 0 (array-total-size num-mtrx)) + (progn + (setq cmbn-list nil) + (setq divs nil)) + (if (= 0 (array-total-size den-mtrx)) + (progn + (setq cmbn-list (gnrt-mtrx-to-list num-mtrx)) + (setq divs (make-list (length cmbn-list) :initial-element 0))) + (let ((quotient-list (mtrx-quotient num-mtrx den-mtrx))) + (declare (list quotient-list)) + (setq cmbn-list (first quotient-list) + divs (second quotient-list))))) + (list + (mapcar + #'(lambda (int-list) + (declare (list int-list)) + (the cmbn + (let* ((cmbn (cmbn degr)) + (cmpr (cmpr fltrcm))) + (declare + (type cmbn cmbn) + (type cmprf cmpr)) + (do ((mark1 int-list (cdr mark1)) + (mark2 fltr-p-basis (cdr mark2))) + ((or (endp mark1) (endp mark2))) + (declare (type list mark1 mark2)) + (if (not (= 0 (car mark1))) + (setq cmbn (2cmbn-add cmpr cmbn + (cmbn degr (car mark1) (car mark2)))))) + cmbn))) + cmbn-list) + divs))))) + +#| +(do ((r 1 (1+ r))) + ((> r 3)) + (dotimes (n 8) + (dotimes (p (+ n 1)) + (let ((q (- n p))) + (print (list r p q)) + (princ (eff-spsq-basis-dvs fcc r p q)) + )))) +|# + + +(defun eff-spsq-gnrts (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)) + (basis (first basis-dvs)) + (dvs (second basis-dvs)) + (rslt nil)) + (declare (type list basis-dvs basis dvs rslt)) + (do ((mark1 basis (cdr mark1)) + (mark2 dvs (cdr mark2))) + ((endp mark1)) + (if (not (eql 1 (car mark2))) + (setf rslt (append rslt (list (car mark1)))))) + rslt)) + + +;; 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) + (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)) + (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))) + +#| +(do ((r 1 (1+ r))) + ((> r 3)) + (dotimes (n 8) + (dotimes (p (+ n 1)) + (let ((q (- n p))) + (eff-spsq-group fcc r p q) + (terpri) + (terpri) + )))) +|# + + + +;; DIFFERENTIAL FUNCTIONS + +;; Auxiliary functions to deal with coefficients of elements with regard to +;; some generators or elements of a basis. + + +;; 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) + (declare + (type list vctr) + (type matrix gnrt-mtrx)) + (the list + (let* ((C (gnrt-list-to-mtrx (list vctr))) + (B (copy-mtrx gnrt-mtrx)) + (smith-list (smith B)) + (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 + #-ACLPC + (make-array (list line-n 1) + :element-type 'fixnum + :initial-element 0) + #+ACLPC + (if (zerop line-n) + (make-array (list line-n 1) + :element-type 'fixnum) + (make-array (list line-n 1) + :element-type 'fixnum + :initial-element 0))) + (end nil)) + (declare + (type matrix C B p-1 D q q-1 C2 A2) + (type list smith-list) + (type fixnum line-n)) + (do ((i 0 (1+ i))) + ((or (>= i (column-number D)) (>= i (line-number D)) end)) + (declare (type fixnum i)) + (let* ((di (aref D i i))) + (declare (type fixnum di)) + (if (eql 0 di) + (setq found 1) + (progn + (setf (aref A2 i 0) (floor (aref C2 i 0) di)))))) + (let* ((A (mtrx-prdc Q A2))) + (declare (type matrix A)) + (column-j A 0))))) + +#| +(setf m (gnrt-list-to-mtrx '((1 0 0 0) (2 3 4 5) (0 1 0 3)))) +(setq vctr '(5 9 8 19)) +(vctr-coordinates vctr m) +|# + +;; 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) + (declare + (type cmbn cmbn) + (type list basis) + (type cmprf cmpr)) + (the list + (let* ((rslt nil) + (mark1 (cmbn-list cmbn)) + (term (car mark1)) + (cffc (cffc term)) + (gnrt (gnrt term))) + (declare + (type list rslt mark1) + (type term term) + (type cffc cffc) + (type gnrt gnrt)) + (do ((mark2 basis (cdr mark2))) + ((endp mark2)) + (declare + (type list mark2)) + (if (endp mark1) + (setq rslt (nconc rslt (list 0))) + (if (eq :equal (funcall cmpr gnrt (car mark2))) + (progn + (setq rslt (nconc rslt (list cffc))) + (pop mark1) + (setq term (car mark1)) + (setq cffc (cffc term) gnrt (gnrt term))) + (setq rslt (nconc rslt (list 0)))))) + rslt))) + +#| +(setf basis (list 'a 'b 'c 'd 'e 'f)) +(setq cmbn (cmbn 2 3 'a 5 'c 8 'f)) +(cmbn-cffc-list cmbn basis #'s-cmpr) +|# + +;; 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) + (declare + (type cmbn cmbn) + (type list gnrt-list basis) + (type cmprf cmpr)) + (the list + (let* ((vctr (cmbn-cffc-list cmbn basis cmpr)) + (B (gnrt-list-to-mtrx + (mapcar + #'(lambda (cmbn2) + (declare (type cmbn cmbn2)) + (cmbn-cffc-list cmbn2 basis cmpr)) + gnrt-list)))) + (declare + (type list vctr) + (type matrix B)) + (vctr-coordinates vctr B)))) + +#| +(setf basis (list 'a 'b 'c 'd 'e 'f)) +(setq cmbn (cmbn 2 3 'a 5 'c 6 'f)) +(setq gnrt-list (list (cmbn 2 1 'a 2 'd 2 'f) (cmbn 2 5 'c -6 'd))) +(cmbn-coordinates cmbn gnrt-list basis #'s-cmpr) +|# + + +;; Main function to compute the differential of an element in the spectral sequence + + +;; Function 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. (Only for finitely generated complexes) +(defun eff-spsq-dffr (fltrcm r p q int-list) + (declare + (type filtered-chain-complex fltrcm) + (type fixnum r p q) + (list int-list)) + (the list + (let* ((cmpr (cmpr1 fltrcm)) + (degr (+ p q)) + (sbasis (fltrd-basis fltrcm degr p)) + (tbasis (fltrd-basis fltrcm (1- degr) (- p r))) + (num-mtrx (spsq-num-mtrx fltrcm r p q)) + (den-mtrx (spsq-den-mtrx fltrcm r p q)) + (Z-gnrt-list (Fltr-Chcm-Z-Gnrt-List fltrcm r p q)) + (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-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 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) + (type matrix num-mtrx den-mtrx) + (type cmbn cmbn)) + (progn + (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 s-gnrt-list (cdr mark1)) + (mark2 s-dvs (cdr mark2)) + (mark3 int-list)) + ((endp mark1)) + (declare (list mark1 mark2 mark3)) + (if (not (eql 1 (car mark2))) + (progn + (setq selement (2list-add selement (n-list (car mark3) (car mark1)))) + (pop mark3))))) + (let* ((selt-coord (vctr-coordinates selement num-mtrx))) + (declare (list selt-coord)) + (do ((mark1 z-gnrt-list (cdr mark1)) + (mark2 selt-coord (cdr mark2))) + ((endp mark1)) + (declare (list mark1 mark2)) + (if (not (eql 0 (car mark2))) + (setq cmbn (2cmbn-add cmpr cmbn (n-cmbn (car mark2) + (funcall + #'(lambda (int-list) + (declare (list int-list)) + (the cmbn + (let* ((cmbn2 (cmbn degr))) + (declare + (type cmbn cmbn)) + (do ((mark3 int-list (cdr mark3)) + (mark4 sbasis (cdr mark4))) + ((or (endp mark3) (endp mark4))) + (declare (type list mark3 mark4)) + (if (not (= 0 (car mark3))) + (setq cmbn2 (2cmbn-add cmpr cmbn2 + (cmbn degr (car mark3) (car mark4)))))) + cmbn2))) + (car mark1)))))))) + (let* ((dffr-cmbn (dffr fltrcm cmbn)) + (crdnt (cmbn-coordinates dffr-cmbn t-gnrt-list tbasis cmpr)) + (rslt nil)) + (declare + (type cmbn dffr-cmbn) + (type list crdnt rslt)) + (do ((mark1 t-dvs (cdr mark1)) + (mark2 crdnt (cdr mark2))) + ((endp mark1)) + (declare (list mark1 mark2)) + (if (not (eql 1 (car mark1))) + (if (eql 0 (car mark1)) + (setq rslt (nconc rslt (list (car mark2)))) + (setq rslt (nconc rslt (list (mod (car mark2) (car mark1)))))))) + rslt))))) + +#| +(eff-spsq-dffr fcc 1 2 3 '(1)) +(eff-spsq-dffr fcc 1 2 5 '(0 1)) +(eff-spsq-dffr fcc 1 2 5 '(1 0)) +(eff-spsq-dffr fcc 1 3 4 '(1 0)) +(eff-spsq-dffr fcc 1 3 4 '(0 1)) +|# + +;; CONVERGENCE OF THE SPECTRAL SEQUENCE + +;; Function that determines if at level r and for degree n the E^r_{p,q} of the +;; filtered complex fltrcm with p+q=degr are equal to E^\infty_{p,q} (i.e., it +;; determines if the convergence of the spectral sequence has been reached at +;; level r for the degree n). The list hmlg-cmpns contains the "components" of +;; 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) + (declare + (type filtered-chain-complex fltrcm) + (type fixnum r degr) + (type list hmlg-cmpns)) + (let* ((min-max (flin-min-max fltrcm degr)) + (min (first min-max)) + (max (second min-max)) + (spsq-cmpns + (mapcan + #'(lambda (p) + (declare (type fixnum p)) + (let* ((q (- degr p))) + (declare (type fixnum q)) + (second (eff-spsq-basis-dvs fltrcm r p q)))) + ( min max))) + (mark2 hmlg-cmpns) + (hmlg-prdc 1) + (spsq-prdc 1)) + (declare + (type function spsq) + (type list spsq-cmpns mark2) + (type fixnum hmlg-prdc spsq-prdc)) + (progn + (do ((mark1 spsq-cmpns (cdr mark1))) + ((endp mark1)) + (declare (type list mark1)) + (if (eql 0 (car mark1)) + (if (not (eql 0 (car mark2))) + (return-from eff-compare-spsq-with-homology nil) + (pop mark2)) + (setq spsq-prdc (* spsq-prdc (car mark1))))) + (do ((mark3 mark2 (cdr mark3))) + ((endp mark3)) + (declare (type list mark3)) + (setq hmlg-prdc (* hmlg-prdc (car mark3)))) + (if (eql hmlg-prdc spsq-prdc) + 't + nil)))) + +#| +(homology fcc 5) +(eff-compare-spsq-with-homology fcc 1 5 '(2)) +(homology fcc 6) +(eff-compare-spsq-with-homology fcc 1 6 '(2)) +|# + +;; Function that determines the level r at which for degree n the E^r_{p,q} of the +;; 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) + (declare + (type filtered-chain-complex fltrcm) + (type fixnum degr)) + (the fixnum + (let* ((hmlg-dvs-gnrs (homologie (chcm-mat fltrcm degr) (chcm-mat fltrcm (1+ degr)))) + (hmlg-cmpns (reverse + (mapcar + #'(lambda (l) + (first l)) + hmlg-dvs-gnrs))) + (cnvg-r 0)) + (declare + (list hmlg-dvs-gnrs hmlg-cmpns) + (type fixnum cnvg-r)) + (do ((r 1 (1+ r))) + ((> cnvg-r 0)) + (declare (type fixnum r)) + (if (eff-compare-spsq-with-homology fltrcm r degr hmlg-cmpns) + (setq cnvg-r r))) + cnvg-r))) + +#| +(eff-spsq-cnvg fcc 5) +(eff-spsq-cnvg fcc 6) +|# + +;; EFFECTIVE HOMOLOGY + + +;; Function that returns the order of filtration t (with regard to the filtration in the +;; left complex, which is translated to the top and right ones) of the homotopy in the right reduction, +;; 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) + (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 + is a LOCALLY-EFFECTIVE chain complex.")) + (mapcar + #'(lambda (gnrt) + (declare (type gnrt gnrt)) + (setq max (max max (- (flin lcc (lf hmtp-eq (rh hmtp-eq degr gnrt))) + (flin lcc (lf hmtp-eq degr gnrt)))))) + (basis tcc degr)) + max)) + +#| +(setf hmtp-eq (efhm fcc)) ;; Trivial homotopy equivalence +(hmtp-eq-fltr-order hmtp-eq 3) + +(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)) +(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)) +(hmtp-eq-fltr-order hmtp-eq3 3) +(hmtp-eq-fltr-order hmtp-eq3 5) +|# + +;; 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) + (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 + #'(lambda (degr gnrt) + (flin fltrcm (lf hmtp-eq (rg hmtp-eq degr gnrt)))) + :orgn (orgn eff-chcm)))) + + + +;; Function that returns the representation basis-divisors of E^r_{p,q} for a filtered +;; complex fltrcm with effective homology, computing the E^r_{p,q} of the effective complex +;; in the right side of the homotopy equivalence. +;; 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 +;; filtration order < r). If not, we define the filtration in the effective +;; 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)) 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) + (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)) + (eff-spsq-dffr eff-chcm r p q int-list)))) + +;; Function that determines the level r at which for degree n the E^r_{p,q} (with p+q=degr) +;; 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) + (declare + (type filtered-chain-complex fltrcm) + (type fixnum degr)) + (let* ((hmtp-eq (efhm fltrcm)) + (eff-chcm (rbcc hmtp-eq))) + (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-cnvg eff-chcm degr)))) + + + + + +;; Homology filtration + + +(defun homology-gnrt-list (chcm degr) + (declare (type cc 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)) + (mapcar #'(lambda (item) + (declare (type list item)) + (let ((cmbn (cmbn degr)) + (cmpr (cmpr chcm))) + (dolist (item2 (rest item)) + (declare (type cons item2)) + (setf cmbn (2cmbn-add cmpr cmbn (cmbn degr (car item2) (nth (cdr item2) src))))) + cmbn)) + hom-dvs-gnrts))) + + + + +(defun homology-fltr1 (fltrcm degr fltr-index) + (declare + (type filtered-chain-complex fltrcm) + (type fixnum degr fltr-index)) + (let* ((r (spsq-cnvg fltrcm degr)) + (cmpr (cmpr1 fltrcm)) + (total-basis (fltrd-basis fltrcm degr fltr-index)) + (dffr-mtrx (FLTR-CHCM-Z-MTRX fltrcm r fltr-index (- degr fltr-index))) + (fltrt-basis + (mapcan #'(lambda (p) + (let* ((q (- degr p)) + (num-mtrx (spsq-num-mtrx fltrcm r p q)) + (den-mtrx (spsq-den-mtrx fltrcm r p q)) + (Z-gnrt-list (Fltr-Chcm-Z-Gnrt-List fltrcm r p q)) + (ss-basis-dvs (mtrx-quotient (copy-mtrx num-mtrx) den-mtrx)) + (ss-gnrt-list (first ss-basis-dvs)) + (ss-dvs (second ss-basis-dvs)) + (rslt nil)) + (declare + (type fcmpr 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)) + (declare (type list mark1 mark2)) + (if (not (eql 1 (car mark2))) + (let* ((selt (first mark1)) + ;;(coord (cmbn-cffc-list selt total-basis cmpr)) + (cmbn (cmbn degr))) + (progn + (let* ((selt-coord (vctr-coordinates selt num-mtrx))) + (declare (list selt-coord)) + (do ((mark3 z-gnrt-list (cdr mark3)) + (mark4 selt-coord (cdr mark4))) + ((endp mark3)) + (declare (list mark3 mark4)) + (if (not (eql 0 (car mark4))) + (setq cmbn (2cmbn-add cmpr cmbn (n-cmbn (car mark4) + (funcall + #'(lambda (int-list) + (declare (list int-list)) + (the cmbn + (let* ((cmbn2 (cmbn degr))) + (declare + (type cmbn + cmbn2)) + (do (( + mark5 int-list (cdr + mark5)) + (mark6 total-basis (cdr mark6))) + ((or (endp mark5) (endp mark6))) + (declare (type list mark5 mark6)) + (if (not (= 0 (car mark5))) + (setq cmbn2 (2cmbn-add cmpr cmbn2 + (cmbn degr (car + mark5) (car + mark6)))))) + cmbn2))) + (car mark3)))))))) + (setf rslt (nconc rslt (list cmbn))) + rslt))))))) + ( 0 fltr-index)))) + (if (not (endp fltrt-basis)) + (let ((fltrt-mtrx + (gnrt-list-to-mtrx + (mapcar #'(lambda (cmbn) + (cmbn-cff-list cmbn total-basis cmpr)) + (fltrt-basis)))) + (num-mtrx (mtrx-conc fltrt-mtrx dffr-mtrx))) + (mtrx-quotient num-mtrx dffr-mtrx)) + nil))) + + + +(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)) + (dffr-mtrx (FLTR-CHCM-Z-MTRX fltrcm (+ 2 (- degr min+1)) (1+ degr) 0)) + (num-mtrx (mtrx-conc (gnrt-list-to-mtrx z-gnrts) dffr-mtrx)) + (basis-divs (mtrx-quotient num-mtrx dffr-mtrx)) + (divs (second basis-divs))) + (format t "Filtration F_~D H_~D" p degr) + (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)) + ))))) + + +(defun hmlg-fltr (fltrcm degr p) + (declare + (type filtered-chain-complex fltrcm) + (type fixnum degr)) + (let* ((hmtp-eq (efhm fltrcm)) + (eff-chcm (rbcc hmtp-eq))) + (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-hmlg-fltr eff-chcm degr p)))) + + + + +(DEFTYPE ss-type () '(member :serre :eilenberg-moore :filtration)) + + + +(defclass OUTPUT-SPECTRAL-SEQUENCE () + ((hmeq :type homotopy-equivalence :initarg hmeq :reader hmeq) + (eff-flin :type chcm-fltrindex :initarg eff-flin :reader eff-flin) + (bgn :type fixnum :initarg bgn :reader bgn) + ;; IDentification NuMber + (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm) + ;; ORiGiN + (orgn :type list :initarg :orgn :reader orgn))) + + +(DEFVAR *oss-list*) +(SETF *oss-list* +empty-list+) +(PUSHNEW '*oss-list* *list-list*) + +(DEFMETHOD PRINT-OBJECT ((oss OUTPUT-SPECTRAL-SEQUENCE) stream) +(the output-spectral-sequence + (progn + (format stream "[K~D output-spectral-sequence]" (idnm oss)) + oss))) + +(DEFUN Oss (idnm) + (declare (type fixnum idnm)) + (the (or OUTPUT-SPECTRAL-SEQUENCE null) + (find idnm *oss-list* :key #'idnm))) + + +(DEFUN BUILD-oss (&key hmeq eff-flin bgn orgn) + (declare + (type homotopy-equivalence hmeq) + (type chcm-fltrindex eff-flin) + (type fixnum bgn) + (type list orgn)) + (the output-spectral-sequence + (progn + (let ((already (find orgn *oss-list* :test #'equal :key #'orgn))) + (declare (type (or output-spectral-sequence null) already)) + (when already + (return-from build-oss already))) + (let ((oss (make-instance 'output-spectral-sequence + :hmeq hmeq + :eff-flin eff-flin + :bgn bgn + :orgn orgn))) + (declare (type output-spectral-sequence oss)) + (push oss *oss-list*) + oss)))) + +;;(defun serre-ss (fibration) + +#|(defun serre-ss (f) + (declare (type fibration f)) + (let* ((X (fibration-total f)) + (hmeq (efhm X)) + (eX (rbcc efhm)) +|# diff --git a/src/classes.lisp b/src/classes.lisp index 39278c1..b6b9910 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -338,7 +338,6 @@ ;; DLOP = DeL OPerator (DEFTYPE DLOP () 'dgop) -#| ;; IABSM = Internal ABstract SiMplex (DEFUN IABSM-P (object) (declare (type any object)) @@ -348,7 +347,6 @@ (typep (cdr object) 'gmsm)))) (DEFTYPE IABSM () '(satisfies iabsm-p)) -|# (DEFSTRUCT (ABSM (:conc-name nil) (:print-function absm-print)) (dgop #+allegro :type #+allegro dgop)