From f3ed77bd9c5e3308d0a859024dd976432aebaf4f Mon Sep 17 00:00:00 2001 From: Ana Romero Date: Thu, 27 Jun 2019 17:29:55 +0200 Subject: [PATCH] Computation of spectral sequences added. --- kenzo.asd | 143 +- src/anromero/bicomplexes.lisp | 2 +- src/anromero/filtered-complexes.lisp | 1756 +++++++++++---------- src/anromero/resolutions.lisp | 2 + src/anromero/spectral-sequences.lisp | 2156 ++++++++++++++------------ src/cat-init.lisp | 199 +-- 6 files changed, 2237 insertions(+), 2021 deletions(-) diff --git a/kenzo.asd b/kenzo.asd index e066433..b03c3bb 100644 --- a/kenzo.asd +++ b/kenzo.asd @@ -1,72 +1,71 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* - -(in-package :cl-user) - -(defpackage :kenzo-asd - (:use :cl :asdf)) - -(in-package :kenzo-asd) - -(asdf:defsystem #:kenzo - :description "A Symbolic Software for Effective Homology Computation by Francis Sergeraert" - :version "1.1.7" - :author "Francis Sergeraert " - :license "GPLv3" - :serial t - :components - ((:file "package") - (:module "src" - :components - ( - (:file "kenzo") - (:file "abbreviations") - (:file "macros") - (:file "various") - (:file "classes") - (:file "combinations") - (:file "chain-complexes") - (:file "chcm-elementary-op") - (:file "effective-homology") - (:file "homology-groups") - (:file "searching-homology") - (:file "cones") - (:file "bicones") - (:file "tensor-products") - (:file "coalgebras") - (:file "cobar") - (:file "algebras") - (:file "bar") - (:file "simplicial-sets") - (:file "simplicial-mrphs") - (:file "delta") - (:file "special-smsts") - (:file "suspensions") - (:file "disk-pasting") - (:file "cartesian-products") - (:file "eilenberg-zilber") - (:file "kan") - (:file "simplicial-groups") - (:file "fibrations") - (:file "loop-spaces") - (:file "ls-twisted-products") - (:file "lp-space-efhm") - (:file "classifying-spaces") - (:file "k-pi-n") - (:file "serre") - (:file "cs-twisted-products") - (:file "cl-space-efhm") - (:file "whitehead") - (:file "smith") - (:module "anromero" - :components - ((:file "resolutions") - (:file "cylinders") - (:file "fundamental-classes") - (:file "homotopy") - (:file "bicomplexes"))) - #| - ((:file "bicomplexes") - (:file "filtered-complexes") - (:file "spectral-sequences"))) - |# - )))) +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + +(in-package :cl-user) + +(defpackage :kenzo-asd + (:use :cl :asdf)) + +(in-package :kenzo-asd) + +(asdf:defsystem #:kenzo + :description "A Symbolic Software for Effective Homology Computation by Francis Sergeraert" + :version "1.1.7" + :author "Francis Sergeraert " + :license "GPLv3" + :serial t + :components + ((:file "package") + (:module "src" + :components + ( + (:file "kenzo") + (:file "abbreviations") + (:file "macros") + (:file "various") + (:file "classes") + (:file "combinations") + (:file "chain-complexes") + (:file "chcm-elementary-op") + (:file "effective-homology") + (:file "homology-groups") + (:file "searching-homology") + (:file "cones") + (:file "bicones") + (:file "tensor-products") + (:file "coalgebras") + (:file "cobar") + (:file "algebras") + (:file "bar") + (:file "simplicial-sets") + (:file "simplicial-mrphs") + (:file "delta") + (:file "special-smsts") + (:file "suspensions") + (:file "disk-pasting") + (:file "cartesian-products") + (:file "eilenberg-zilber") + (:file "kan") + (:file "simplicial-groups") + (:file "fibrations") + (:file "loop-spaces") + (:file "ls-twisted-products") + (:file "lp-space-efhm") + (:file "classifying-spaces") + (:file "k-pi-n") + (:file "serre") + (:file "cs-twisted-products") + (: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 "filtered-complexes") + (:file "spectral-sequences") + (:file "persistent-homology") + )))))) diff --git a/src/anromero/bicomplexes.lisp b/src/anromero/bicomplexes.lisp index 0b9f798..62d69db 100644 --- a/src/anromero/bicomplexes.lisp +++ b/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))) diff --git a/src/anromero/filtered-complexes.lisp b/src/anromero/filtered-complexes.lisp index 1006143..78525c9 100644 --- a/src/anromero/filtered-complexes.lisp +++ b/src/anromero/filtered-complexes.lisp @@ -1,848 +1,908 @@ -;; 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))) +;; 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*) + +#+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)) + (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) + (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) + (let* ((orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn))) + (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* + "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)) + (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-cprd :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) + ;;(type list flin-orgn) +) + (the FILTERED-COALGEBRA + (progn + (change-class chcm 'FILTERED-COALGEBRA) + (let* ((orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn))) + (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* + "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)) + (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-aprd :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) (list flin-orgn))) + (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)) + (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* + "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)) + (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-hopf-algebra + (progn + (change-class chcm 'FILTERED-hopf-ALGEBRA) + ;;(setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn))) + (let* ( + (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)) + (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* + "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)) + (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-strt :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) (list flin-orgn))) + (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)) + (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* + "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)) + (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) (list flin-orgn))) + (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)) + (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* + "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 + (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))) +#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (ext:package-lock :clos) t)) + +(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-strt :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* ( + (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)) + (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* ( + (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)) + (setf (slot-value chcm 'flin) flin) + (setf (slot-value chcm 'orgn) orgn) + (push chcm *flabsmgr-list*) + chcm)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; EXAMPLES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; BICOMPLEXES + +(DEFVAR BCFlin) + +;; 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* ((flin BCflin)) + (declare + (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))))) + +(DEFVAR abar-flin) +(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))))) + +(DEFVAR cobar-flin) +(setf cobar-flin + #'(lambda (degr allp) + (declare (ignore degr) + (type allp allp)) + (with-allp (l) allp + (the fixnum + (- (length l)))))) + + +;; TENSOR PRODUCTS + + +(DEFVAR tnpr-flin) +(setf tnpr-flin + #'(lambda (degr tnpr) + (declare + (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 + (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/resolutions.lisp b/src/anromero/resolutions.lisp index 0841a50..327b106 100644 --- a/src/anromero/resolutions.lisp +++ b/src/anromero/resolutions.lisp @@ -650,6 +650,8 @@ + + (DEFUN ZGCMBN-TWI (zgcmpr zgcmbn) ;;(declare (type zgcmbn zgcmbn)) (with-cmbn (degr list) zgcmbn diff --git a/src/anromero/spectral-sequences.lisp b/src/anromero/spectral-sequences.lisp index ae173a1..4318801 100644 --- a/src/anromero/spectral-sequences.lisp +++ b/src/anromero/spectral-sequences.lisp @@ -7,30 +7,31 @@ (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)) +(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))) + (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)))) + :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)) @@ -38,65 +39,66 @@ |# -(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)))))) +(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)))) +(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)) @@ -111,28 +113,28 @@ ;; 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)))) +(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)) @@ -142,41 +144,41 @@ ;; 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 +(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) - #+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))) + :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))) @@ -184,16 +186,16 @@ |# ;; 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)))))) +(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)) @@ -204,63 +206,63 @@ ;; 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)))))) +(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 d1 p1-1Xmtrx2 p1Xd1 d1-1Xp1-1Xmtrx2)) + (progn + (let* ((line-n-1 (line-number p1)) + (column-n-1 (column-number p1))) + (declare (type fixnum line-n-1 column-n-1)) + (dotimes (ic column-n-1) + (declare (type fixnum ic)) + (if (and (< ic (line-number d1)) (< ic (column-number d1))) + (let ((d (aref d1 ic ic))) + (declare (type fixnum d)) + (dotimes (il line-n-1) + (declare (type fixnum il)) + (if (and (not (eql 1 d)) (not (eql 0 d))) + (setf (aref p1Xd1 il ic) (* d (aref p1Xd1 il ic))))))))) + (let* ((line-n-2 (line-number p1-1Xmtrx2)) + (column-n-2 (column-number p1-1Xmtrx2))) + (declare (type fixnum line-n-2 column-n-2)) + (dotimes (il line-n-2) + (declare (type fixnum il)) + (if (and (< il (line-number d1)) (< il (column-number d1))) + (let ((d (aref d1 il il))) + (if (and (not (eql 1 d)) (not (eql 0 d))) + (dotimes (ic column-n-2) + (declare (type fixnum ic)) + (setf (aref d1-1Xp1-1Xmtrx2 il ic) + (floor (aref d1-1Xp1-1Xmtrx2 il ic) d)))))))) + (let* ((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)))) @@ -280,73 +282,119 @@ ;; 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)) + (type filtered-chain-complex fltrcm) + (type fixnum r p q)) (the matrix (let* ((cmpr (cmpr1 fltrcm)) - (dffr (dffr fltrcm)) - (degr (+ p q)) + (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))) + (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)) + ;; 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 + (trank (length tbasis))) + (declare (type fixnum srank trank)) + (let ((rslt #-ACLPC - (make-array (list trank srank) - :element-type 'fixnum - :initial-element 0) + (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))))) + (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))))) + + + +(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))) + ( (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)) + + rslt))))) + #| (cat-init) @@ -360,27 +408,27 @@ ;; 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)))))))) +(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) @@ -389,21 +437,21 @@ ;; 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))) +(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) @@ -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)) @@ -423,36 +471,36 @@ (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) + (declare + (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) 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))))) + (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-line-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) @@ -461,60 +509,60 @@ ;; 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)) +(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 - (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))) - + (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) @@ -522,116 +570,114 @@ ;; 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)) +(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)) + (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) + (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 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))) + (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)) + (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))) + (declare (type list mark1 mark2)) + (if (not (= 0 (car mark1))) (setq cmbn (2cmbn-add cmpr cmbn - (cmbn degr (car mark1) (car mark2)))))) + (cmbn degr (car mark1) (car mark2)))))) cmbn))) - cmbn-list) - divs))))) + 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)) - )))) + (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)) +(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)) - - + (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))) +(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)) + (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))) #| (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) - )))) + (dotimes (n 8) + (dotimes (p (+ n 1)) + (let ((q (- n p))) + (eff-spsq-group fcc r p q) + (terpri) + (terpri) + )))) |# @@ -644,49 +690,48 @@ ;; 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) +(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)) + (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))))) + :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 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 (not (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)))) @@ -696,36 +741,36 @@ ;; 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))) +(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))) + (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)) @@ -736,23 +781,23 @@ ;; 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)) +(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)))) + (declare + (type list vctr) + (type matrix B)) + (vctr-coordinates vctr B)))) #| (setf basis (list 'a 'b 'c 'd 'e 'f)) @@ -769,96 +814,96 @@ ;; 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 +(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 (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 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) + (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))))) - + (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)) @@ -876,46 +921,46 @@ ;; 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)))) +(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))) + (mark2 hmlg-cmpns) + (hmlg-prdc 1) + (spsq-prdc 1)) + (declare + (type function spsq-cmpns) + (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) + (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)))) - + nil)))) + #| (homology fcc 5) (eff-compare-spsq-with-homology fcc 1 5 '(2)) @@ -927,27 +972,27 @@ ;; 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)) +(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))) + (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) @@ -962,29 +1007,26 @@ ;; 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 +(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)) + (max 0)) + (declare + (type chain-complex lcc tcc) + (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 + (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)) + (flin lcc (lf hmtp-eq degr gnrt)))))) + (basis tcc degr)) + max)) #| (setf hmtp-eq (efhm fcc)) ;; Trivial homotopy equivalence @@ -995,8 +1037,8 @@ (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))))) + #'(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) @@ -1005,19 +1047,19 @@ ;; 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)))) - - - +(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 + #'(lambda (degr gnrt) + (flin fltrcm (lf hmtp-eq (rg hmtp-eq degr gnrt)))) + (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. @@ -1027,52 +1069,51 @@ ;; 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)) +(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)) + ) + (declare + (type homotopy-equivalence hmtp-eq) + (type chain-complex eff-chcm) + ) + (progn + (if (not (typep eff-chcm 'filtered-chain-complex)) (translate-filtration hmtp-eq)) - (eff-spsq-dffr eff-chcm r p q int-list)))) - + (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)) +(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)))) + (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-GNRT-LIST (chcm 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)))) + ) + (declare (type list src hom-dvs-gnrts )) + (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) +#| +(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 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)) + (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)) + #'(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-cffc-list cmbn total-basis cmpr)) + (fltrd-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)) + (min-max+1 (flin-min-max fltrcm (1+ degr))) + (min+1 (first 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 SPECTRAL-SEQUENCE () + (;; FiLTeRedchainCoMplex + (fltrcm :type filtered-chain-complex :initarg :fltrcm :reader fltrcm) + ;; ReSuLTS + (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 *ss-list* + "The variable *SS-LIST* is bound to a list of user created spectral sequences") +(SETF *ss-list* +empty-list+) +(PUSHNEW '*ss-list* *list-list*) + + +#+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 Spectral-Sequence]" (idnm ss)) + ss))) +#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (ext:package-lock :clos) t)) + + +(DEFUN SS (idnm) + (declare (type fixnum idnm)) + (the (or SPECTRAL-SEQUENCE null) + (find idnm *ss-list* :key #'idnm))) + + +(DEFUN BUILD-ss (fltrcm orgn) + (declare + (type filtered-chain-complex fltrcm) + (type list orgn)) + (the spectral-sequence + (progn + (let ((already (find orgn *ss-list* :test #'equal :key #'orgn))) + (declare (type (or spectral-sequence null) already)) + (when already + (return-from build-ss already))) + (let ((ss (make-instance 'spectral-sequence + :fltrcm fltrcm + :orgn orgn + :group-rslts +empty-list+ + :dffr-rslts +empty-list+))) + (declare (type spectral-sequence ss)) + (push ss *ss-list*) + ss)))) + + +(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* ((fltrcm (fibration-total f)) + (ecc (rbcc (efhm fltrcm)))) + (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)))) + +|# + diff --git a/src/cat-init.lisp b/src/cat-init.lisp index 15da0f3..9a2c80f 100644 --- a/src/cat-init.lisp +++ b/src/cat-init.lisp @@ -1,95 +1,104 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* - -;;; FILES FILES FILES FILES FILES FILES FILES FILES FILES FILES -;;; FILES FILES FILES FILES FILES FILES FILES FILES FILES FILES -;;; FILES FILES FILES FILES FILES FILES FILES FILES FILES FILES - -(DEFPACKAGE :CAT - (:USE CL)) - -(IN-PACKAGE "COMMON-LISP-USER") - -(DEFUN KENZO-VERSION () - (format t "~%*** Kenzo-Version 1.1.7 ***~2%") - (values)) - -(PROCLAIM '(OPTIMIZE (speed 3) (safety 1) (space 0) (debug 0))) - -(DEFCONSTANT +FILE-LIST+ - '("kenzo" - "macros" - "various" - "classes" - "combinations" - "chain-complexes" - "chcm-elementary-op" - "effective-homology" - "homology-groups" - "searching-homology" - "cones" - "bicones" - "tensor-products" - "coalgebras" - "cobar" - "algebras" - "bar" - "simplicial-sets" - "simplicial-mrphs" - "delta" - "special-smsts" - "suspensions" - "disk-pasting" - "cartesian-products" - "eilenberg-zilber" - "kan" - "simplicial-groups" - "fibrations" - "loop-spaces" - "ls-twisted-products" - "lp-space-efhm" - "classifying-spaces" - "k-pi-n" - "serre" - "cs-twisted-products" - "cl-space-efhm" - "whitehead" - "smith")) - -(DO ((i 1 (1+ i)) - (mark +file-list+ (cdr mark))) - ((endp mark) (terpri)) - (format t "~% FILE ~2D: ~A" i (car mark))) - -(DEFCONSTANT +SOURCE-EXTENSION+ - #+(or allegro lispworks) "cl" - #+(or 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.")) - -(DEFCONSTANT +COMPILED-EXTENSION+ - #+(or allegro sbcl) "fasl" - #+ccl "lafsl" - #+ (or clisp ecl) "fas" - #+lispworks "ofasl") - -(DEFUN LOAD-SFILES () - (mapc #'(lambda (file-name) - (load (concatenate 'string file-name "." +source-extension+))) - +file-list+)) - -(DEFVAR *CMBN-CONTROL*) -(SETF *CMBN-CONTROL* T) - -#+SBCL (DECLAIM (SB-EXT:MUFFLE-CONDITIONS style-warning compiler-note)) - -(DEFUN COMPILE-FILES () - (format t "~%*CMBN-CONTROL* = ~A~2%" *cmbn-control*) - (mapc #'(lambda (file-name) - (compile-file (concatenate 'string file-name "." +source-extension+)) - (load (concatenate 'string file-name "." +compiled-extension+))) - +file-list+)) - -(DEFUN LOAD-CFILES () - (mapc #'(lambda (file-name) - (load (concatenate 'string file-name "." +compiled-extension+))) - +file-list+)) +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + +;;; FILES FILES FILES FILES FILES FILES FILES FILES FILES FILES +;;; FILES FILES FILES FILES FILES FILES FILES FILES FILES FILES +;;; FILES FILES FILES FILES FILES FILES FILES FILES FILES FILES + +(DEFPACKAGE :CAT + (:USE CL)) + +(IN-PACKAGE "COMMON-LISP-USER") + +(DEFUN KENZO-VERSION () + (format t "~%*** Kenzo-Version 1.1.7 ***~2%") + (values)) + +(PROCLAIM '(OPTIMIZE (speed 3) (safety 1) (space 0) (debug 0))) + +(DEFCONSTANT +FILE-LIST+ + '("kenzo" + "macros" + "various" + "classes" + "combinations" + "chain-complexes" + "chcm-elementary-op" + "effective-homology" + "homology-groups" + "searching-homology" + "cones" + "bicones" + "tensor-products" + "coalgebras" + "cobar" + "algebras" + "bar" + "simplicial-sets" + "simplicial-mrphs" + "delta" + "special-smsts" + "suspensions" + "disk-pasting" + "cartesian-products" + "eilenberg-zilber" + "kan" + "simplicial-groups" + "fibrations" + "loop-spaces" + "ls-twisted-products" + "lp-space-efhm" + "classifying-spaces" + "k-pi-n" + "serre" + "cs-twisted-products" + "cl-space-efhm" + "whitehead" + "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))) + ((endp mark) (terpri)) + (format t "~% FILE ~2D: ~A" i (car mark))) + +(DEFCONSTANT +SOURCE-EXTENSION+ + #+(or lispworks) "cl" + #+(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.")) + +(DEFCONSTANT +COMPILED-EXTENSION+ + #+(or allegro sbcl) "fasl" + #+ccl "lafsl" + #+ (or clisp ecl) "fas" + #+lispworks "ofasl") + +(DEFUN LOAD-SFILES () + (mapc #'(lambda (file-name) + (load (concatenate 'string file-name "." +source-extension+))) + +file-list+)) + +(DEFVAR *CMBN-CONTROL*) +(SETF *CMBN-CONTROL* T) + +#+SBCL (DECLAIM (SB-EXT:MUFFLE-CONDITIONS style-warning compiler-note)) + +(DEFUN COMPILE-FILES () + (format t "~%*CMBN-CONTROL* = ~A~2%" *cmbn-control*) + (mapc #'(lambda (file-name) + (compile-file (concatenate 'string file-name "." +source-extension+)) + (load (concatenate 'string file-name "." +compiled-extension+))) + +file-list+)) + +(DEFUN LOAD-CFILES () + (mapc #'(lambda (file-name) + (load (concatenate 'string file-name "." +compiled-extension+))) + +file-list+))