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

Merge branch 'testing' of https://github.com/miguelmarco/kenzo into testing

Browse Source
This commit is contained in:
Ana Romero 2019-09-23 12:39:35 +02:00
commit 8616ed1968
5 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) (slot-makunbound chcm 'bsgn)
chcm))) 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 ;; First we build the three chain complexes

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

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

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

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

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

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

BIN
src/kenzo.fas
View File

Binary file not shown.