mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Functions for change a chain complex to a filtered

Browse Source 
chain complex modified
Example of bicomplex added
This commit is contained in:
Ana Romero Ibáñez 2019-09-16 18:45:53 +02:00
parent 676b634a8a
commit 8f0d75b105
4 changed files with 585 additions and 581 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
src/anromero/bicomplexes.lisp
View File

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

111
src/anromero/filtered-complexes.lisp
View File

@ -9,7 +9,7 @@
(DEFTYPE degr () 'fixnum)
(DEFTYPE CHCM-FLIN () 'function)
;; '(function (degr gnrt) degr)
;; '(function (degr gnrt) degr)
(DEFCLASS FILTERED-CHAIN-COMPLEX (chain-complex)
@ -22,7 +22,7 @@
#+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
(the FILTERED-CHAIN-COMPLEX
(progn
(format stream "[K~D Filtered-Chain-Complex]" (idnm flcm))
flcm)))
@ -64,34 +64,10 @@
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)
(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm chain-complex) flin)
(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)
)
(type chcm-flin flin))
(the FILTERED-CHAIN-COMPLEX
(progn
(change-class chcm 'FILTERED-CHAIN-COMPLEX)
@ -225,7 +201,7 @@
;; Matrix of the differential application of degree "degr" of the subcomplex
;; F_pX, where p=fltr-index and X=fltrcm.
(defun FLCC-DFFR-MTRX (fltrcm degr fltr-index)
(DEFUN FLCC-DFFR-MTRX (fltrcm degr fltr-index)
(declare
(type FILTERED-CHAIN-COMPLEX fltrcm)
(fixnum degr fltr-index))
@ -304,7 +280,7 @@
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((flclgb FILTERED-COALGEBRA) stream)
(the FILTERED-COALGEBRA
(the FILTERED-COALGEBRA
(progn
(format stream "[K~D FILTERED-COALGEBRA]" (idnm flclgb))
flclgb)))
@ -343,11 +319,9 @@
(push rslt *flclgb-list*)
rslt))))
(defmethod change-chcm-to-flcc ((chcm coalgebra) flin flin-orgn )
(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm coalgebra) flin)
(declare
(type chcm-flin flin)
;;(type list flin-orgn)
)
(type chcm-flin flin))
(the FILTERED-COALGEBRA
(progn
(change-class chcm 'FILTERED-COALGEBRA)
@ -373,7 +347,7 @@
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((flalgb FILTERED-ALGEBRA) stream)
(the FILTERED-ALGEBRA
(the FILTERED-ALGEBRA
(progn
(format stream "[K~D FILTERED-ALGEBRA]" (idnm flalgb))
flalgb)))
@ -412,17 +386,13 @@
(push rslt *flalgb-list*)
rslt))))
(defmethod change-chcm-to-flcc ((chcm algebra) flin flin-orgn )
(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm algebra) flin)
(declare
(type chcm-flin flin)
;;(list flin-orgn)
)
(type chcm-flin flin))
(the FILTERED-ALGEBRA
(progn
(change-class chcm 'FILTERED-ALGEBRA)
;;(setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
(let* (
(orgn (orgn chcm))
(let* ((orgn (orgn chcm))
(already (find orgn *flalgb-list* :key #'orgn :test #'equal)))
(declare (type (or null FILTERED-ALGEBRA) already))
(when already
@ -444,7 +414,7 @@
#+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
(the FILTERED-HOPF-ALGEBRA
(progn
(format stream "[K~D FILTERED-HOPF-ALGEBRA]" (idnm flhopf))
flhopf)))
@ -456,17 +426,13 @@
(the (or FILTERED-HOPF-ALGEBRA null)
(find idnm *flhopf-list* :key #'idnm)))
(defmethod change-chcm-to-flcc ((chcm hopf-algebra) flin flin-orgn )
(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm hopf-algebra) flin)
(declare
(type chcm-flin flin)
;;(list flin-orgn)
)
(type chcm-flin flin))
(the FILTERED-hopf-algebra
(progn
(change-class chcm 'FILTERED-hopf-ALGEBRA)
;;(setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
(let* (
(orgn (orgn chcm))
(let* ((orgn (orgn chcm))
(already (find orgn *flhopf-list* :key #'orgn :test #'equal)))
(declare (type (or null FILTERED-HOPF-ALGEBRA) already))
(when already
@ -531,17 +497,13 @@
(push rslt *flsmst-list*)
rslt))))
(defmethod change-chcm-to-flcc ((chcm simplicial-set) flin flin-orgn )
(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm simplicial-set) flin)
(declare
(type chcm-flin flin)
;;(list flin-orgn)
)
(type chcm-flin flin))
(the FILTERED-SIMPLICIAL-SET
(progn
(change-class chcm 'FILTERED-SIMPLICIAL-SET)
;; (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
(let* (
(orgn (orgn chcm))
(let* ((orgn (orgn chcm))
(already (find orgn *flsmst-list* :key #'orgn :test #'equal)))
(declare (type (or null FILTERED-SIMPLICIAL-SET) already))
(when already
@ -575,17 +537,13 @@
(the (or filtered-kan null)
(find idnm *flkan-list* :key #'idnm)))
(defmethod change-chcm-to-flcc ((chcm kan) flin flin-orgn )
(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm kan) flin)
(declare
(type chcm-flin flin)
;;(list flin-orgn)
)
(type chcm-flin flin))
(the FILTERED-KAN
(progn
(change-class chcm 'FILTERED-KAN)
;; (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) (list flin-orgn)))
(let* (
(orgn (orgn chcm))
(let* ((orgn (orgn chcm))
(already (find orgn *flkan-list* :key #'orgn :test #'equal)))
(declare (type (or null FILTERED-KAN) already))
(when already
@ -668,18 +626,13 @@
(DEFMACRO BUILD-FlABSMGR (&rest rest)
`(change-class (build-flsmgr ,@rest) 'filtered-ab-simplicial-group))
(defmethod change-chcm-to-flcc ((chcm simplicial-group) flin flin-orgn )
(defmethod CHANGE-CHCM-TO-FLCC ((chcm simplicial-group) flin)
(declare
(type chcm-flin flin)
;;(list flin-orgn)
)
(type chcm-flin flin))
(the FILTERED-SIMPLICIAL-GROUP
(progn
(change-class chcm 'FILTERED-SIMPLICIAL-GROUP)
;; (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
(let* (
(orgn (orgn chcm))
(let* ((orgn (orgn chcm))
(already (find orgn *flsmgr-list* :key #'orgn :test #'equal)))
(declare (type (or null FILTERED-SIMPLICIAL-GROUP) already))
(when already
@ -688,16 +641,12 @@
(push chcm *flsmgr-list*)
chcm))))
(defmethod change-chcm-to-flcc ((chcm ab-simplicial-group) flin flin-orgn )
(DEFMETHOD CHANGE-CHCM-TO-FLCC ((chcm ab-simplicial-group) flin)
(declare
(type chcm-flin flin)
;;(list flin-orgn)
)
(type chcm-flin flin))
(the FILTERED-AB-SIMPLICIAL-GROUP
(progn
(change-class chcm 'AB-FILTERED-SIMPLICIAL-GROUP)
;; (setf orgn (append (orgn chcm) (list 'FILTERED-WITH) flin-orgn))
(let* (
(orgn (orgn chcm))
(already (find orgn *flabsmgr-list* :key #'orgn :test #'equal)))
@ -743,7 +692,7 @@
(declare
(type chcm-flin flin))
(the FILTERED-CHAIN-COMPLEX
(change-chcm-to-flcc bc flin 'Bicomplex-Flin))))
(change-chcm-to-flcc bc flin))))
#|
(defun bas (degr1 degr2)
@ -805,7 +754,7 @@
(setq kz2 (k-z2-1))
(setq bar2 (bar kz2))
(change-chcm-to-flcc bar2 abar-flin 'abar-flin)
(change-chcm-to-flcc bar2 abar-flin)
(setf basis7 (basis bar2 7))
@ -884,7 +833,7 @@
;; BICONES
(defun bicone-flin (flinb flinc flind)
(DEFUN BICONE-FLIN (flinb flinc flind)
(declare (type chcm-flin flinb flinc flind))
(flet ((rslt (degr bicn)
(declare

2
src/anromero/persistent-homology.lisp
View File

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

21
src/anromero/spectral-sequences.lisp
View File

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