Added examples from Ana Romero's website
http://www.unirioja.es/cu/anromero/research2.html
This commit is contained in:
gheber
parent
be5d0c9bf0
commit
e3cfc0ad9b
1107
examples/anromero/bousfield-kan/gamma.lsp
Normal file
1107
examples/anromero/bousfield-kan/gamma.lsp
Normal file
File diff suppressed because it is too large
Load Diff
153
examples/anromero/bousfield-kan/simplicial-hmtps.lsp
Normal file
153
examples/anromero/bousfield-kan/simplicial-hmtps.lsp
Normal file
@ -0,0 +1,153 @@
|
||||
;;; SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS
|
||||
;;; SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS
|
||||
;;; SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS SIMPLICIAL-HMTPS
|
||||
|
||||
(IN-PACKAGE "COMMON-LISP-USER")
|
||||
|
||||
(PROVIDE "simplicial-hmtps")
|
||||
|
||||
(DEFTYPE HINTR () 'function)
|
||||
;; (function (indx dmns gmsm) absm)
|
||||
|
||||
(DEFCLASS SIMPLICIAL-HMTP (morphism)
|
||||
((hintr :type hintr :initarg :hintr :reader hintr)))
|
||||
|
||||
|
||||
(DEFVAR *SMHMT-LIST*)
|
||||
(SETF *SMHMT-LIST* +empty-list+)
|
||||
(PUSHNEW '*SMHMT-LIST* *LIST-LIST*)
|
||||
|
||||
(DEFMETHOD PRINT-OBJECT ((smhmt simplicial-hmtp) stream)
|
||||
(the simplicial-hmtp
|
||||
(progn
|
||||
(format stream "[K~D Simplicial-Homotopy K~D -> K~D]"
|
||||
(idnm smhmt) (idnm (sorc smhmt)) (idnm (trgt smhmt)))
|
||||
smhmt)))
|
||||
|
||||
(DEFUN SMHMT (idnm)
|
||||
(declare (fixnum idnm))
|
||||
(the (or null simplicial-hmtp)
|
||||
(find idnm *smhmt-list* :key #'idnm)))
|
||||
|
||||
(DEFUN HINTR-INTR (cmpr hintr)
|
||||
(declare (type hintr hintr)
|
||||
(type cmprf cmpr))
|
||||
(flet ((rslt (dmns gmsm)
|
||||
(declare
|
||||
(fixnum dmns)
|
||||
(type gmsm gmsm))
|
||||
(when (minusp dmns)
|
||||
(return-from rslt (zero-cmbn (1+ dmns))))
|
||||
(let ((cmbn (zero-cmbn (1+ dmns))))
|
||||
(declare (type cmbn cmbn))
|
||||
(do ((indx 0 (1+ indx)))
|
||||
((> indx dmns) cmbn)
|
||||
(declare (fixnum indx))
|
||||
(let ((hmtp-i (funcall hintr indx dmns gmsm)))
|
||||
(declare (type absm hmtp-i))
|
||||
(if (non-degenerate-p hmtp-i)
|
||||
(setf cmbn (2cmbn-add cmpr cmbn (term-cmbn (1+ dmns) (-1-expt-n indx) (gmsm hmtp-i))))))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
(DEFUN BUILD-SMHMT (&key sorc trgt degr hintr intr strt orgn)
|
||||
(declare
|
||||
(type simplicial-set sorc trgt)
|
||||
(fixnum degr)
|
||||
(type hintr hint)
|
||||
(type (or intr-mrph null) intr)
|
||||
(type (or strt null) strt)
|
||||
(list orgn))
|
||||
(the simplicial-hmtp
|
||||
(progn
|
||||
(let ((already (find orgn *smhmt-list* :test #'equal :key #'orgn)))
|
||||
(declare (type (or simplicial-hmtp null) already))
|
||||
(when already
|
||||
(return-from build-smhmt already)))
|
||||
(unless (= 1 degr)
|
||||
(error "In BUILD-SMHMT, the degree ~D is different to +1."
|
||||
degr))
|
||||
(if intr
|
||||
(unless strt
|
||||
(error "In BUILD-SMMR, an intr is given but not its strt"))
|
||||
(let ((cmpr (cmpr sorc)))
|
||||
(declare (type cmprf cmpr))
|
||||
(setf strt :gnrt
|
||||
intr (hintr-intr cmpr hintr))))
|
||||
(let ((rslt (build-mrph
|
||||
:sorc sorc :trgt trgt :degr degr
|
||||
:intr intr :strt strt
|
||||
:orgn orgn)))
|
||||
(declare (type morphism rslt))
|
||||
(change-class rslt 'simplicial-hmtp)
|
||||
(setf (slot-value rslt 'hintr) hintr)
|
||||
(push rslt *smhmt-list*)
|
||||
rslt))))
|
||||
|
||||
|
||||
#|
|
||||
(setf d (delta 3))
|
||||
(setf h (build-smhmt
|
||||
:sorc d :trgt d :degr 1
|
||||
:hintr #'(lambda (indx dmns gmsm)
|
||||
(absm (dgop-ext-int (list indx)) gmsm))
|
||||
:orgn '(simplicial-homotopy delta-3)))
|
||||
(dotimes (indx 5)
|
||||
(print (? h indx 4 (absm 8 15))))
|
||||
(dotimes (indx 7)
|
||||
(print (? h indx 6 (absm 45 11))))
|
||||
(? h 2 11)
|
||||
|#
|
||||
|
||||
|
||||
|
||||
(DEFMETHOD ?4 ((smhmt simplicial-hmtp) indx dmns absm-or-gmsm)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type (or absm gmsm) absm-or-gmsm))
|
||||
(the absm
|
||||
(typecase absm-or-gmsm
|
||||
(absm
|
||||
(with-absm (dgop gmsm) absm-or-gmsm
|
||||
(declare
|
||||
(fixnum dgop)
|
||||
(type gmsm gmsm))
|
||||
(if (= 0 dgop)
|
||||
(funcall (hintr smhmt) indx dmns gmsm)
|
||||
(let* ((dgop1-ext (first (dgop-int-ext dgop)))
|
||||
(dgop2 (remove-bit dgop dgop1-ext))
|
||||
(absm2 (absm dgop2 gmsm)))
|
||||
(declare
|
||||
(fixnum dgop1-ext dgop2)
|
||||
(type absm sbsm2))
|
||||
(if (>= dgop1-ext indx)
|
||||
(let ((smhmt-i (?4 smhmt indx (1- dmns) absm2)))
|
||||
(declare (type absm smhmt-i))
|
||||
(ndgnr (dgop-ext-int (list (1+ dgop1-ext))) smhmt-i))
|
||||
(let ((smhmt-i-1 (?4 smhmt (1- indx) (1- dmns) absm2)))
|
||||
(declare (type absm smhmt-i-1))
|
||||
(ndgnr (dgop-ext-int (list dgop1-ext)) smhmt-i-1)))))))
|
||||
(otherwise
|
||||
(funcall (hintr smhmt) indx dmns absm-or-gmsm)))))
|
||||
|
||||
|
||||
;; This macro definition changes the definition of the macro ? in the file macro.lsp
|
||||
(DEFMACRO ? (&rest rest)
|
||||
(ecase (length rest)
|
||||
(2 `(?2 ,@rest))
|
||||
(3 `(?3 ,@rest))
|
||||
(4 `(?4 ,@rest))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
270
examples/anromero/filtered-complexes/bicomplexes.lsp
Normal file
270
examples/anromero/filtered-complexes/bicomplexes.lsp
Normal file
@ -0,0 +1,270 @@
|
||||
;; BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES
|
||||
;; BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES
|
||||
;; BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES BICOMPLEXES
|
||||
|
||||
|
||||
(IN-PACKAGE "COMMON-LISP-USER")
|
||||
|
||||
(PROVIDE "bicomplexes")
|
||||
|
||||
(DEFMETHOD PRINT-KEYCONS ((car (eql :BcGnrt)) cdr stream)
|
||||
(declare
|
||||
(cons cdr)
|
||||
(stream stream))
|
||||
(the (eql t)
|
||||
(let*
|
||||
((cdr (cons car cdr))
|
||||
(degr1 (BcGnrt-Degr1 cdr))
|
||||
(degr2 (BcGnrt-Degr2 cdr))
|
||||
(gnrt (BcGnrt-gnrt cdr)))
|
||||
(progn
|
||||
(format stream "<BcGnrt ")
|
||||
(format stream "[~D ~D] ~A" degr1 degr2 gnrt)
|
||||
(format stream ">"))
|
||||
t)))
|
||||
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; TYPES FOR BICOMPLEXES ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; TYPE BcGnrt (a generator in a Bicomplex)
|
||||
(DEFUN BcGnrt-p (object)
|
||||
(declare (type any object))
|
||||
(the boolean
|
||||
(and (consp object)
|
||||
(eql :BcGnrt (car object))
|
||||
(consp (cdr object))
|
||||
(consp (cadr object))
|
||||
(typep (caadr object) 'fixnum)
|
||||
(typep (cdadr object) 'fixnum))))
|
||||
(DEFTYPE BcGnrt () '(satisfies BcGnrt-p))
|
||||
|
||||
#|
|
||||
(typep `(:BcGnrt ,(cons 5 6) u) 'BcGnrt)
|
||||
(typep `(:BcGnrt ,(cons 3 2) '(f g)) 'BcGnrt)
|
||||
(typep `(:BcGnrt ,(cons 4 5.4) u) 'BcGnrt)
|
||||
|#
|
||||
|
||||
|
||||
;; TYPE BcBasis (basis of a Bicomplex, function of the variables p and q or
|
||||
;; ":locally-effective")
|
||||
(DEFTYPE BcBASIS () '(or function (eql :locally-effective)))
|
||||
;; (function (degr degr) (list gnrt))
|
||||
|
||||
|
||||
;; TYPE Bicomplex
|
||||
(DEFUN OrgnBiCmpl-p (object)
|
||||
(declare (type chain-complex object))
|
||||
(let* ((orgn (orgn object)))
|
||||
(the boolean
|
||||
(and (consp orgn)
|
||||
(eql (car orgn) 'BiCmpl)))))
|
||||
(DEFTYPE Bicomplex () '(satisfies OrgnBiCmpl-p))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; FUCTIONS FOR THE REPRESENTATION OF (GENERAL) BICOMPLEXES ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;; Function that builds a generator of a Bicomplex from two degrees and
|
||||
;; a simple generator.
|
||||
(DEFUN build-BcGnrt (degr1 degr2 gnrt)
|
||||
(declare
|
||||
(type fixnum degr1 degr2)
|
||||
(type any gnrt))
|
||||
(list :BcGnrt (cons degr1 degr2) gnrt))
|
||||
|
||||
#|
|
||||
(build-BcGnrt 2 3 'c)
|
||||
(typep (build-BcGnrt 2 2 'd) 'BcGnrt)
|
||||
|#
|
||||
|
||||
|
||||
;; Function that returns the first degree from a bicomplex' generator.
|
||||
(DEFUN BcGnrt-Degr1 (BcGnrt)
|
||||
(declare (type BcGnrt BcGnrt))
|
||||
(caadr BcGnrt))
|
||||
|
||||
;; Function that returns the second degree from a bicomplex' generator.
|
||||
(DEFUN BcGnrt-Degr2 (BcGnrt)
|
||||
(declare (type BcGnrt BcGnrt))
|
||||
(cdadr BcGnrt))
|
||||
|
||||
;; Function that returns the original generator from a bicomplex' generator.
|
||||
(DEFUN BcGnrt-Gnrt (BcGnrt)
|
||||
(declare (type BcGnrt BcGnrt))
|
||||
(caddr BcGnrt))
|
||||
|
||||
#|
|
||||
(build-BcGnrt 5 6 8)
|
||||
(BcGnrt-Degr1 (build-BcGnrt 5 6 8))
|
||||
(BcGnrt-Degr2 (build-BcGnrt 6 4 '(4 6)))
|
||||
(BcGnrt-Gnrt (build-BcGnrt 6 4 '(4 6)))
|
||||
(BcGnrt-Gnrt (build-BcGnrt 2 8 'u))
|
||||
|#
|
||||
|
||||
|
||||
;; Comparison function of a bicomplex.
|
||||
(defun BC-CMPR (cmpr)
|
||||
(declare (type cmprf cmpr))
|
||||
(flet ((comp (bc1 bc2)
|
||||
(declare (type BcGnrt bc1 bc2))
|
||||
(let ((degr11 (BcGnrt-Degr1 bc1))
|
||||
(degr21 (BcGnrt-Degr2 bc1))
|
||||
(degr12 (BcGnrt-Degr1 bc2))
|
||||
(degr22 (BcGnrt-Degr2 bc2))
|
||||
(gnrt1 (BcGnrt-Gnrt bc1))
|
||||
(gnrt2 (BcGnrt-Gnrt bc2)))
|
||||
(declare
|
||||
(type fixnum degr11 degr21 degr12 degr22)
|
||||
(type any gnrt1 gnrt2))
|
||||
(lexico
|
||||
(f-cmpr degr11 degr12)
|
||||
(f-cmpr degr21 degr22)
|
||||
(funcall cmpr gnrt1 gnrt2)))))
|
||||
(the cmprf #'comp)))
|
||||
|
||||
#|
|
||||
(setf cmpr (BC-CMPR #'s-cmpr))
|
||||
(funcall cmpr (build-BcGnrt 5 6 'a) (build-BcGnrt 7 8 'b))
|
||||
(funcall cmpr (build-BcGnrt 8 6 'a) (build-BcGnrt 7 8 'b))
|
||||
(funcall cmpr (build-BcGnrt 8 5 'c) (build-BcGnrt 8 6 'b))
|
||||
(funcall cmpr (build-BcGnrt 8 5 'c) (build-BcGnrt 8 5 'b))
|
||||
|#
|
||||
|
||||
;; Basis of a bicomplex (from a function of type BcBasis).
|
||||
(DEFUN BC-BASIS (bcbasis)
|
||||
(declare (type BcBasis bcbasis))
|
||||
(when (eq bcbasis :locally-effective)
|
||||
(return-from bc-basis :locally-effective))
|
||||
(flet ((bas (degr)
|
||||
(declare (type fixnum degr))
|
||||
(the list
|
||||
(progn
|
||||
(when (minusp degr)
|
||||
(return-from bas +empty-list+))
|
||||
(mapcan
|
||||
#'(lambda (degr1)
|
||||
(declare (type fixnum degr1))
|
||||
(let* ((degr2 (- degr degr1))
|
||||
(basis (funcall bcbasis degr1 degr2)))
|
||||
(declare
|
||||
(fixnum degr2)
|
||||
(list basis))
|
||||
(the list
|
||||
(mapcar
|
||||
#'(lambda (gnrt)
|
||||
(declare (type gnrt gnrt))
|
||||
(the BcGnrt
|
||||
(build-BcGnrt degr1 degr2 gnrt)))
|
||||
basis)))
|
||||
)
|
||||
(<a-b> 0 degr))))))
|
||||
(the basis #'bas)))
|
||||
|
||||
#|
|
||||
(defun bas (degr1 degr2)
|
||||
(if (and (= degr1 0) (= degr2 1)) (return-from bas '(a)))
|
||||
(if (and (= degr1 1) (= degr2 0)) (return-from bas '(b)))
|
||||
(if (and (= degr1 1) (= degr2 1)) (return-from bas '(c)))
|
||||
(if (and (= degr1 2) (= degr2 0)) (return-from bas '(d)))
|
||||
(return-from bas nil))
|
||||
(setf basis (BC-BASIS #'bas))
|
||||
(dotimes (i 5)
|
||||
(print (funcall basis i)))
|
||||
|#
|
||||
|
||||
;; Differential function of a Bicomplex (from the differential functions,
|
||||
;; dffr1=horizontal dffr, dffr2=vertical dffr).
|
||||
(DEFUN BC-INTR-DFFR (dffr1 dffr2)
|
||||
(declare (type function dffr1 dffr2))
|
||||
(flet ((dif (degr bc)
|
||||
(declare
|
||||
(fixnum degr)
|
||||
(type BcGnrt bc))
|
||||
(the cmbn
|
||||
(let* ((degr1 (BcGnrt-Degr1 bc))
|
||||
(degr2 (BcGnrt-Degr2 bc))
|
||||
(gnrt (BcGnrt-Gnrt bc))
|
||||
(degr1-1 (1- degr1))
|
||||
(degr2-1 (1- degr2))
|
||||
(list1 (funcall dffr1 degr1 degr2 gnrt))
|
||||
(list2 (funcall dffr2 degr1 degr2 gnrt)))
|
||||
(declare (type fixnum degr1 degr2 degr1-1 gegr2-1)
|
||||
(list list1 list2))
|
||||
(make-cmbn
|
||||
:degr (1- degr)
|
||||
:list (nconc
|
||||
(mapcar
|
||||
#'(lambda (term1)
|
||||
(declare (type term term1))
|
||||
(let* ((cffc1 (cffc term1))
|
||||
(gnrt1 (gnrt term1)))
|
||||
(declare (type fixnum cffc1)
|
||||
(type gnrt gnrt1))
|
||||
(term cffc1 (build-BcGnrt degr1-1 degr2 gnrt1))))
|
||||
list1)
|
||||
(mapcar
|
||||
#'(lambda (term2)
|
||||
(declare (type term term2))
|
||||
(let* ((cffc2 (cffc term2))
|
||||
(gnrt2 (gnrt term2)))
|
||||
(declare (type fixnum cffc2)
|
||||
(type gnrt gnrt2))
|
||||
(term cffc2 (build-BcGnrt degr1 degr2-1 gnrt2))))
|
||||
list2)))))))
|
||||
(the intr-mrph #'dif)))
|
||||
|
||||
#|
|
||||
(defun dif1 (degr1 degr2 gnrt)
|
||||
(if (and (= degr1 1) (= degr2 1) (eql gnrt 'c)) (return-from dif1 (list (cons 2 'a))))
|
||||
(if (and (= degr1 2) (= degr2 0) (eql gnrt 'd)) (return-from dif1 (list (cons 2 'b))))
|
||||
(return-from dif1 nil))
|
||||
(defun dif2 (degr1 degr2 gnrt)
|
||||
(if (and (= degr1 1) (= degr2 1) (eql gnrt 'c)) (return-from dif2 (list (cons 1 'b))))
|
||||
(return-from dif2 nil))
|
||||
(setf dif (BC-INTR-DFFR #'dif1 #'dif2))
|
||||
(funcall dif 2 (build-BcGnrt 1 1 'c))
|
||||
|#
|
||||
|
||||
;; Function that builds a bicomplex from a basis function, the two differential
|
||||
;; functions and the original comparison.
|
||||
(DEFUN BUILD-BICM (&key bcbasis dffr1 dffr2 cmpr orgn)
|
||||
(declare
|
||||
(type BCbasis bcbasis)
|
||||
(type function dffr1 dffr2)
|
||||
(type cmprf cmpr)
|
||||
(list (orgn)))
|
||||
(the chain-complex
|
||||
(let ((chcm
|
||||
(build-chcm
|
||||
:cmpr (BC-CMPR cmpr)
|
||||
:basis (BC-BASIS bcbasis)
|
||||
:intr-dffr (BC-INTR-DFFR dffr1 dffr2)
|
||||
:strt :gnrt
|
||||
:orgn orgn)))
|
||||
(declare (type chain-complex chcm))
|
||||
(slot-makunbound chcm 'bsgn)
|
||||
chcm)))
|
||||
|
||||
#|
|
||||
(setf bc (Build-Bicm :bcbasis #'bas :dffr1 #'dif1 :dffr2 #'dif2 :cmpr 's-cmpr
|
||||
:orgn '(BC-test)))
|
||||
(dotimes (i 5)
|
||||
(print (basis bc i)))
|
||||
(cmpr bc (build-BcGnrt 0 1 'a) (build-BcGnrt 1 1 'c))
|
||||
|
||||
(? bc (? bc 2 (build-BcGnrt 1 1 'c)))
|
||||
(? bc 2 (build-BcGnrt 2 0 'd))
|
||||
(? bc 2 '(:BcGnrt (1 . 1) c))
|
||||
(? bc (cmbn 2 3 '(:BcGnrt (1 . 1) c)))
|
||||
(? bc 1 (build-bicm 0 1 'a))
|
||||
|#
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
843
examples/anromero/filtered-complexes/filtered-complexes.lsp
Normal file
843
examples/anromero/filtered-complexes/filtered-complexes.lsp
Normal file
@ -0,0 +1,843 @@
|
||||
;; 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 "COMMON-LISP-USER")
|
||||
|
||||
(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)))
|
||||
(<a-b> 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 found))
|
||||
(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)))
|
||||
1359
examples/anromero/filtered-complexes/spectral-sequences.lsp
Normal file
1359
examples/anromero/filtered-complexes/spectral-sequences.lsp
Normal file
File diff suppressed because it is too large
Load Diff
464
examples/anromero/homology-of-groups/OMparsers.lisp
Normal file
464
examples/anromero/homology-of-groups/OMparsers.lisp
Normal file
@ -0,0 +1,464 @@
|
||||
(in-package :user)
|
||||
|
||||
|
||||
|
||||
|
||||
(defun OMgetNextLabel (s)
|
||||
(let* ((p1 (search "<" s)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end p1)
|
||||
(let ((p1 (search "<" s))
|
||||
(p2 (if (search " " s) (min (search ">" s) (search " " s))
|
||||
(search ">" s) )))
|
||||
(subseq s (1+ p1) p2))))
|
||||
|
||||
(defun OMgetNextSymbol (s)
|
||||
(let* ((p1 (search "cd=" s))
|
||||
(p2 (search "name=" s))
|
||||
(p3 (search "/>" s))
|
||||
(rslt1 (subseq s (+ 3 p1) p2))
|
||||
(rslt2 (subseq s (+ 5 p2) p3))
|
||||
)
|
||||
(OMLispSymbol (list (delete #\" (delete #\space rslt1)) (delete #\" (delete #\space rslt2))))
|
||||
))
|
||||
|
||||
(defun OMparseNextInteger (s)
|
||||
(if (not (equal (OMgetNextLabel s) "OMI"))
|
||||
(error "The next token is not an integer")
|
||||
(let* ((p1 (search "<OMI>" s))
|
||||
(p2 (search "</OMI>" s))
|
||||
(rslt (parse-integer (subseq s (+ 5 p1) p2))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 p2))
|
||||
rslt
|
||||
)))
|
||||
|
||||
(defun OMparseNextString (s)
|
||||
(if (not (equal (OMgetNextLabel s) "OMSTR"))
|
||||
(error "The next token is not a string")
|
||||
(let* ((p1 (search "<OMSTR>" s))
|
||||
(p2 (search "</OMSTR>" s))
|
||||
(rslt (subseq s (+ 7 p1) p2)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 8 p2))
|
||||
rslt
|
||||
)))
|
||||
|
||||
(defun OMparseNextVar (s)
|
||||
(if (not (equal (OMgetNextLabel s) "OMV"))
|
||||
(error "The next token is not a variable")
|
||||
(let* ((p1 (search "<OMV>" s))
|
||||
(p2 (search "</OMV>" s))
|
||||
(rslt (intern (subseq s (+ 5 p1) p2))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 p2))
|
||||
rslt
|
||||
)))
|
||||
|
||||
(defun OMparseNextSymbol (s)
|
||||
(if (not (equal (OMgetNextLabel s) "OMS"))
|
||||
(error "The next token is not a symbol")
|
||||
(let* ((rslt (OMgetNextSymbol s))
|
||||
(p (search "/>" s))
|
||||
)
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 2 p))
|
||||
rslt
|
||||
)))
|
||||
|
||||
(DEFTYPE direct-symbol () '(member list cyclicgroup))
|
||||
|
||||
|
||||
(defun OMLispSymbol (list)
|
||||
(let ((cd (first list))
|
||||
(name (second list)))
|
||||
(if (equal cd "list1")
|
||||
(if (equal name "list")
|
||||
'list)
|
||||
(if (equal cd "resolutions")
|
||||
(if (equal name "zgcombination")
|
||||
"zgcombination"
|
||||
(if (equal name "zgterm")
|
||||
"zgterm"
|
||||
(if (equal name "zggnrt")
|
||||
"zggnrt"
|
||||
(if (equal name "resolution")
|
||||
"resolution"))))
|
||||
(if (equal cd "group1")
|
||||
(if (equal name "cyclic_group")
|
||||
'cyclicgroup))))))
|
||||
|
||||
(defun OMparseNextApplication (s)
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next token is not an application")
|
||||
(let* ((p1 (search "<OMA>" s)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 p1))
|
||||
(let ((head (if (equal (OMgetNextLabel s) "OMS")
|
||||
(OMparseNextSymbol s)
|
||||
(OMparseNextObject s)))
|
||||
(rest nil))
|
||||
(if (typep head 'direct-symbol)
|
||||
(do ((rest nil (append rest (list nextobj))))
|
||||
((equal (OMgetNextLabel s) "/OMA") (let ((p (search "</OMA>" s)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 p1))
|
||||
(eval (append (list head) rest))))
|
||||
(setf nextobj (OMparseNextObject s))
|
||||
)
|
||||
(if (equal head "resolution")
|
||||
(OMparseResolution s)
|
||||
(error "imposible to parse")
|
||||
))))))
|
||||
|
||||
|
||||
|
||||
|
||||
(defun OMparseNextObject (s)
|
||||
(progn
|
||||
(if (equal (OMgetNextLabel s) "OMOBJ")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 7 (search "<OMOBJ>" s))))
|
||||
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
|
||||
(let ((rslt
|
||||
(if (equal (OMgetNextLabel s) "OMI")
|
||||
(OMparseNextInteger s)
|
||||
(if (equal (OMgetNextLabel s) "OMSTR")
|
||||
(OMparseNextString s)
|
||||
(if (equal (OMgetNextLabel s) "OMV")
|
||||
(OMparseNextVar s)
|
||||
(if (equal (OMgetNextLabel s) "OMS")
|
||||
(OMLispSymbol(OMparseNextSymbol s))
|
||||
(if (equal (OMgetNextLabel s) "OMA")
|
||||
(OMparseNextApplication s)
|
||||
(error "imposible to parse"))))))))
|
||||
(progn
|
||||
(if (equal (OMgetNextLabel s) "/OMOBJ")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 8 (search "</OMOBJ>" s))))
|
||||
rslt))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(defun OMparseZggnrt (s grbasis zgbasis-degr)
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) "zggnrt"))
|
||||
(error "This is not specified as a zggnrt")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let* ((i1 (OMparseNextInteger s))
|
||||
(i2 (OMparseNextInteger s)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(zggnrt (nth (1- i1) grbasis) (nth (1- i2) zgbasis-degr))))))))
|
||||
|
||||
|
||||
(defun OMparseZgterm (s degr grbasis zgbasis)
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) "zgterm"))
|
||||
(error "This is not specified as a zgterm")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let* ((coeff (OMparseNextInteger s))
|
||||
(zggnrt (OMparseZggnrt s grbasis (funcall zgbasis degr))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(term-cmbn degr coeff zggnrt )))))))
|
||||
|
||||
(defun OMparseZgcmbn (s degr grbasis grcmpr zgbasis zgcmpr)
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) "zgcombination"))
|
||||
(error "This is not specified as a zgcombination")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((cmbn-list nil))
|
||||
(do ((term-list nil (push (cons 1 nexttermcmbn) term-list)))
|
||||
((equal (OMgetNextLabel s) "/OMA") (setf cmbn-list term-list) )
|
||||
(setf nexttermcmbn (OMparseZgterm s degr grbasis zgbasis))
|
||||
)
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(if cmbn-list
|
||||
(cmbn-cmbn (zggnrt-cmpr grcmpr zgcmpr) cmbn-list)
|
||||
(zero-cmbn degr))))))))
|
||||
|
||||
(defun OMparseZgboundaryList (s grbasis grcmpr zgbasis zgcmpr maxdegr)
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt nil))
|
||||
(dotimes (i maxdegr)
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt-i nil))
|
||||
(do ((aux nil (push cmbn aux)))
|
||||
((equal (OMgetNextLabel s) "/OMA") (setf rslt-i aux))
|
||||
(setf cmbn (OMparseZgcmbn s i grbasis grcmpr zgbasis zgcmpr)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(push (nreverse rslt-i) rslt)))))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(nreverse rslt)))))))
|
||||
|
||||
|
||||
(defun OMparseContractinghmtpList (s grbasis grcmpr zgbasis zgcmpr maxdegr)
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt nil))
|
||||
(dotimes (i (1- maxdegr))
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt-i nil))
|
||||
(do ((mark1 (funcall zgbasis (1+ i)) (cdr mark1)))
|
||||
((endp mark1) (push (nreverse rslt-i) rslt))
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt-i-g nil))
|
||||
|
||||
(do ((mark2 grbasis (cdr mark2)))
|
||||
((endp mark2) (push (nreverse rslt-i-g) rslt-i))
|
||||
(setf cmbn (OMparseZgcmbn s (1+ i) grbasis grcmpr zgbasis zgcmpr))
|
||||
(push cmbn rslt-i-g))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
))))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
))))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(nreverse rslt)))))))
|
||||
|
||||
|
||||
|
||||
(defun OMrsltnZgbasis (rank-list maxdegr)
|
||||
(flet ((rslt (degr)
|
||||
(declare (fixnum degr))
|
||||
(if (> degr maxdegr) (error "unknown basis for this degree")
|
||||
(if (< degr 0) nil
|
||||
(let ((rank (nth degr rank-list))
|
||||
(list nil))
|
||||
(dotimes (i rank)
|
||||
(push (concatenate 'string "g" (Write-to-string degr) (Write-to-string (1+ i))) list))
|
||||
(nreverse list))))))
|
||||
|
||||
(the basis #'rslt)))
|
||||
|
||||
(defun OMrsltnZgboundary-intr (Zgboundary-list zgbasis maxdegr)
|
||||
(flet ((rslt (degr gnrt)
|
||||
(declare (fixnum degr) (type gnrt gnrt))
|
||||
(if (> degr maxdegr) (error "unknown basis for this degree")
|
||||
(if (< degr 1) (zero-cmbn (1- degr))
|
||||
(nth (position gnrt (funcall zgbasis degr) :test #'equal) (nth (1- degr) Zgboundary-list))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
(defun OMrsltnCntrHmtp-intr (Zgcontractinghmtp-list zgbasis grbasis maxdegr)
|
||||
(flet ((rslt (degr zggnrt)
|
||||
(declare (fixnum degr) (type zggnrt zggnrt))
|
||||
(if (> degr (1- maxdegr)) (error "unknown basis for this degree")
|
||||
(with-zggnrt (gnrt1 gnrt2) zggnrt
|
||||
(let ((gnrt1-pos (position gnrt1 grbasis :test #'equal))
|
||||
(gnrt2-pos (position gnrt2 (funcall zgbasis degr) :test #'equal)))
|
||||
(nth gnrt1-pos (nth gnrt2-pos (nth degr Zgcontractinghmtp-list))))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(defun OMparseResolution (s)
|
||||
;;(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
;; (error "The next label is not an application")
|
||||
;; (progn
|
||||
;; (delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
;; (if (not (equal (OMgetNextSymbol s) "resolution"))
|
||||
;; (error "This is not specified as a resolution")
|
||||
;; (progn
|
||||
;; (OMparseNextSymbol s)
|
||||
(let* ((group (OMparseNextObject s))
|
||||
(maxdegr (OMparseNextObject s))
|
||||
(rank-list (OMparseNextObject s))
|
||||
(zgbasis (OMrsltnZgbasis rank-list maxdegr)))
|
||||
(with-slots ((grcmpr cmpr) (grbasis elements) nullel) group
|
||||
(let* ((zgboundary-list (OMparseZgboundaryList s grbasis grcmpr zgbasis #'s-cmpr maxdegr))
|
||||
(cntrchmtp-list (OMparseContractinghmtpList s grbasis grcmpr zgbasis #'s-cmpr maxdegr))
|
||||
(zgchcm (BUILD-ZGCHCM :group group :zgcmpr #'s-cmpr :zgbasis zgbasis :zgbsgn "g00"
|
||||
:intr-zgbndr (OMrsltnZgboundary-intr Zgboundary-list zgbasis maxdegr)
|
||||
:zgbndr-strt :gnrt :orgn `(ZG-Chain complex for ,group obtained from HAP)))
|
||||
(cmpr (cmpr1 zgchcm))
|
||||
(f-intr #'(lambda (degr zggnrt)
|
||||
(if (zerop degr) (cmbn degr 1 :zgnrt) (zero-cmbn degr))))
|
||||
(g-intr #'(lambda (degr gnrt)
|
||||
(if (zerop degr) (cmbn degr 1 (zggnrt nullel "g01")) (zero-cmbn degr))))
|
||||
(h-intr (OMrsltnCntrHmtp-intr cntrchmtp-list zgbasis grbasis maxdegr))
|
||||
|
||||
(f (build-mrph :sorc zgchcm :trgt (z-chcm) :degr 0 :intr f-intr :strt :gnrt :orgn `(f-mrph for ,group obtained from HAP)))
|
||||
(g (build-mrph :sorc (z-chcm) :trgt zgchcm :degr 0 :intr g-intr :strt :gnrt :orgn `(g-mrph for ,group obtained from HAP)))
|
||||
(h (build-mrph :sorc zgchcm :trgt zgchcm :degr 1 :intr h-intr :strt :gnrt :orgn `(h-mrph for ,group obtained from HAP))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(build-rdct :f f :g g :h h :orgn `(Resolution of ,group obtained from HAP))))))
|
||||
;;;))))
|
||||
|
||||
(defun FileToString (FileName)
|
||||
(with-open-file (f FileName :direction :input)
|
||||
(labels ((getString (f s)
|
||||
(let* ((aux (read-line f nil 'EOF)))
|
||||
(if (not (string= aux 'EOF))
|
||||
(getString f (concatenate 'string s (if (not (string= s "")) (format nil "~%")) aux))
|
||||
s))))
|
||||
(getString f ""))))
|
||||
|
||||
|
||||
|
||||
#|
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(cat-init)
|
||||
(load "omparsers.lisp")
|
||||
(setf s (filetostring "resolution.log"))
|
||||
(setf rsltn1 (OmparseNextObject s))
|
||||
(setf group (group1 (tcc rsltn1)))
|
||||
(setf (slot-value group 'resolution) rsltn1)
|
||||
(setf k-g-1 (k-g-1 group))
|
||||
(setf k-g-2 (k-g group 2))
|
||||
(setf k-g-3 (k-g group 3))
|
||||
|
||||
(homology k-g-1 0 6)
|
||||
(homology k-g-2 0 6)
|
||||
(homology k-g-3 0 6)
|
||||
|
||||
|
||||
|
||||
(if (equal (OMgetNextLabel s) "OMOBJ")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 7 (search "<OMOBJ>" s))))
|
||||
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
|
||||
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application"))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) "resolution"))
|
||||
(error "This is not specified as a resolution"))
|
||||
|
||||
(OMparseNextSymbol s)
|
||||
|
||||
(setf group (OMparseNextObject s))
|
||||
(setf maxdegr (OMparseNextObject s))
|
||||
(setf rank-list (OMparseNextObject s))
|
||||
(setf zgbasis (OMrsltnZgbasis rank-list maxdegr))
|
||||
|
||||
(setf grcmpr (cmpr1 group) grbasis (elements group) nullel (nullel group))
|
||||
(setf zgcmpr #'s-cmpr)
|
||||
(setf zgboundary-list (OMparseZgboundaryList s grbasis grcmpr zgbasis #'s-cmpr maxdegr))
|
||||
;;(setf cntrchmtp-list (OMparseContractinghmtpList s grbasis grcmpr zgbasis #'s-cmpr maxdegr))
|
||||
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application"))
|
||||
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list"))
|
||||
(OMparseNextSymbol s)
|
||||
|
||||
(setf rslt nil)
|
||||
|
||||
(setf i 0)
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application"))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(OMparseNextSymbol s)
|
||||
(setf rslt-i nil)
|
||||
|
||||
(setf mark1 zgbasis)
|
||||
|
||||
|
||||
(dotimes (i maxdegr)
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt-i nil))
|
||||
(do ((mark1 (funcall zgbasis (1+ i)) (cdr mark1)))
|
||||
((endp mark1) (push rslt-i rslt))
|
||||
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt-i-g nil))
|
||||
|
||||
(do ((mark2 grbasis (cdr mark2)))
|
||||
((endp mark2) (push rslt-i-g rslt-i))
|
||||
(setf cmbn (OMparseZgcmbn s (1+ i) grbasis grcmpr zgbasis zgcmpr))
|
||||
(push cmbn rslt-i-g))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
))))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
))))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
rslt)))))
|
||||
|
||||
|
||||
|
||||
|#
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
462
examples/anromero/homology-of-groups/cylinders.lisp
Normal file
462
examples/anromero/homology-of-groups/cylinders.lisp
Normal file
@ -0,0 +1,462 @@
|
||||
;;; CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS
|
||||
;;; CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS
|
||||
;;; CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS
|
||||
|
||||
(IN-PACKAGE "COMMON-LISP-USER")
|
||||
|
||||
(PROVIDE "CYCLINDERS")
|
||||
|
||||
|
||||
(DEFUN CYLN-P (object)
|
||||
(declare (type any object))
|
||||
(the boolean
|
||||
(and (consp object)
|
||||
(typep (car object) '(member :CYLNA1 :CYLNB :CYLNA2))
|
||||
(typep (cdr object) 'gnrt))))
|
||||
|
||||
(DEFTYPE CYLN () '(satisfies CYLN-P))
|
||||
|
||||
;; MACROS
|
||||
|
||||
(DEFMACRO CYLNX (CYLN)
|
||||
`(car ,CYLN))
|
||||
|
||||
(DEFMACRO ICYLN (CYLN)
|
||||
`(cdr ,CYLN))
|
||||
|
||||
(DEFMACRO CYLNA1 (gnrt)
|
||||
`(cons :CYLNA1 ,gnrt))
|
||||
|
||||
(DEFMACRO CYLNB (gnrt)
|
||||
`(cons :CYLNB ,gnrt))
|
||||
|
||||
(DEFMACRO CYLNA2 (gnrt)
|
||||
`(cons :CYLNA2 ,gnrt))
|
||||
|
||||
(DEFMACRO WITH-CYLN ((CYLNx iCYLN) CYLN . body)
|
||||
`(let ((,CYLNx (CYLNx ,CYLN))
|
||||
(,iCYLN (iCYLN ,CYLN)))
|
||||
(declare
|
||||
(type (member :CYLNA1 :CYLNB :CYLNA2) ,CYLNx)
|
||||
(type gnrt ,iCYLN))
|
||||
,@body))
|
||||
|
||||
|
||||
(DEFUN DISPATCH-CYLN-CMBN (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the (values cmbn cmbn cmbn)
|
||||
(with-cmbn (degr list) cmbn
|
||||
(let ((listA1 +empty-list+)
|
||||
(listB +empty-list+)
|
||||
(listA2 +empty-list+))
|
||||
(declare (list listA1 listB listA2))
|
||||
(dolist (term list)
|
||||
(declare (type term term))
|
||||
(with-term (cffc cyln) term
|
||||
(with-cyln (cylnx icyln) cyln
|
||||
(ecase cylnx
|
||||
(:cylnA1 (push (term cffc icyln) listA1))
|
||||
(:cylnB (push (term cffc icyln) listB))
|
||||
(:cylnA2 (push (term cffc icyln) listA2))))))
|
||||
(values
|
||||
(make-cmbn :degr (1- degr) :list (nreverse listA1))
|
||||
(make-cmbn :degr degr :list (nreverse listB))
|
||||
(make-cmbn :degr degr :list (nreverse listA2)))))))
|
||||
|
||||
#|
|
||||
(dispatch-CYLN-cmbn (cmbn 3 3 (cylnA1 'a11) 4 (cylnA1 'a12) 33 (cylnB 'b) 333 (cylnA2 'a2)))
|
||||
|#
|
||||
|
||||
(DEFUN CYLN-CMBN-CMBNA1 (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn :degr (1- degr)
|
||||
:list (do ((rslt +empty-list+)
|
||||
(mark list (cdr mark)))
|
||||
((endp mark) (nreverse rslt))
|
||||
(declare (list rslt mark))
|
||||
(with--term (cffc CYLN) mark
|
||||
(with-CYLN (CYLNx gnrtA1) CYLN
|
||||
(if (eq CYLNx :CYLNA1)
|
||||
(push (term cffc gnrtA1) rslt)
|
||||
(return (nreverse rslt))))))))))
|
||||
|
||||
(DEFUN CYLN-CMBN-CMBNB (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn :degr degr
|
||||
:list (do ((rslt +empty-list+)
|
||||
(mark (member :CYLNb list :key #'cadr) (cdr mark)))
|
||||
((endp mark) (nreverse rslt))
|
||||
(declare (list rslt mark))
|
||||
(with--term (cffc CYLN) mark
|
||||
(with-CYLN (CYLNx gnrtB) CYLN
|
||||
(if (eq CYLNx :CYLNB)
|
||||
(push (term cffc gnrtB) rslt)
|
||||
(return (nreverse rslt))))))))))
|
||||
|
||||
(DEFUN CYLN-CMBN-CMBNA2 (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn :degr degr
|
||||
:list (mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term (cffc CYLN) term
|
||||
(term cffc (iCYLN CYLN))))
|
||||
(member :CYLNA2 list :key #'cadr))))))
|
||||
|
||||
#|
|
||||
|
||||
(CYLN-cmbn-cmbnA1 (cmbn 3 1 (CYLNA1 'a) 2 (CYLNB 'b)))
|
||||
(CYLN-cmbn-cmbnA1 (cmbn 3 2 (CYLNB 'b)))
|
||||
(CYLN-cmbn-cmbnB (cmbn 3 1 (CYLNA1 'a) 2 (CYLNB 'b) 3 (CYLNA2 'c)))
|
||||
(CYLN-cmbn-cmbnB (cmbn 3 1 (CYLNA1 'a) 3 (CYLNA2 'c)))
|
||||
(CYLN-cmbn-cmbnA2 (cmbn 3 1 (CYLNA1 'a) 2 (CYLNB 'b) 3 (CYLNA2 'c)))
|
||||
(CYLN-cmbn-cmbnA2 (cmbn 3 2 (CYLNA1 'b)))
|
||||
|#
|
||||
|
||||
(DEFUN MAKE-CYLN-CMBN (cmbnA1 cmbnB cmbnA2)
|
||||
(declare (type cmbn cmbnA1 cmbnB cmbnA2))
|
||||
(the cmbn
|
||||
(with-cmbn (degrA1 listA1) cmbnA1
|
||||
(with-cmbn (degrB listB) cmbnB
|
||||
(with-cmbn (degrA2 listA2) cmbnA2
|
||||
(unless (= (1+ degrA1) degrB degrA2)
|
||||
(error "In MAKE-CYLN-CMBN, the degrees are not coherent."))
|
||||
(make-cmbn :degr degrB
|
||||
:list (nconc
|
||||
(mapcar #'(lambda (termA1)
|
||||
(declare (type term termA1))
|
||||
(with-term (cffc gnrtA1) termA1
|
||||
(term cffc (CYLNA1 gnrtA1))))
|
||||
listA1)
|
||||
(mapcar #'(lambda (termB)
|
||||
(declare (type term termB))
|
||||
(with-term (cffc gnrtB) termB
|
||||
(term cffc (CYLNB gnrtB))))
|
||||
listB)
|
||||
(mapcar #'(lambda (termA2)
|
||||
(declare (type term termA2))
|
||||
(with-term (cffc gnrtA2) termA2
|
||||
(term cffc (CYLNA2 gnrtA2))))
|
||||
listA2))))))))
|
||||
|
||||
#|
|
||||
(multiple-value-call #'make-CYLN-cmbn
|
||||
(dispatch-CYLN-cmbn (cmbn 3 3 (CYLNA1 'A11) 4 (CYLNA1 'A12) 33 (CYLNB 'B) 333 (CYLNA2 'A2))))
|
||||
|#
|
||||
|
||||
(DEFMETHOD PRINT-KEYCONS ((car (eql :CYLNA1)) cdr stream)
|
||||
(declare
|
||||
(type gnrt cdr)
|
||||
(stream stream))
|
||||
(the (eql t)
|
||||
(progn
|
||||
(format stream "<CylnA1 ~A>" cdr)
|
||||
t)))
|
||||
|
||||
(DEFMETHOD PRINT-KEYCONS ((car (eql :CYLNB)) cdr stream)
|
||||
(declare
|
||||
(type gnrt cdr)
|
||||
(stream stream))
|
||||
(the (eql t)
|
||||
(progn
|
||||
(format stream "<CylnB ~A>" cdr)
|
||||
t)))
|
||||
|
||||
(DEFMETHOD PRINT-KEYCONS ((car (eql :CYLNA2)) cdr stream)
|
||||
(declare
|
||||
(type gnrt cdr)
|
||||
(stream stream))
|
||||
(the (eql t)
|
||||
(progn
|
||||
(format stream "<CylnA2 ~A>" cdr)
|
||||
t)))
|
||||
|
||||
#|
|
||||
(CYLNa1 'a)
|
||||
(CYLNB 'b)
|
||||
(CYLNA2 'c)
|
||||
|#
|
||||
|
||||
(DEFUN cylnX-CMPR (s1 s2)
|
||||
(declare (symbol s1 s2))
|
||||
(the cmpr
|
||||
(if (string= s1 s2) :equal
|
||||
(if (string= s1 :cylnA1) :less
|
||||
(if (string= s2 :cylnA1) :greater
|
||||
(if (string= s1 :cylnB) :less
|
||||
:greater))))))
|
||||
|
||||
|
||||
(DEFUN CYLINDER-CMPR (cmprA cmprB)
|
||||
(declare (type cmprf cmpra cmprb))
|
||||
(flet ((rslt (cyln1 cyln2)
|
||||
(declare (type cyln cyln1 cyln2))
|
||||
(let ((cylnx1 (cylnx cyln1)))
|
||||
(declare (type (member :cylnA1 :cylnB :cylnA2) cylnx))
|
||||
(lexico
|
||||
(cylnX-CMPR cylnx1 (cylnx cyln2))
|
||||
(case cylnx1
|
||||
(:cylnA1 (funcall cmprA (icyln cyln1) (icyln cyln2)))
|
||||
(:cylnB (funcall cmprB (icyln cyln1) (icyln cyln2)))
|
||||
(:cylnA2 (funcall cmprA (icyln cyln1) (icyln cyln2))))))))
|
||||
(the cmprf #'rslt)))
|
||||
|
||||
#|
|
||||
(setf r (cylinder-cmpr #'f-cmpr #'f-cmpr ))
|
||||
(funcall r (cylnA1 1) (cylnB 0))
|
||||
(funcall r (cylnA1 1) (cylnA1 2))
|
||||
(funcall r (cylnB 0) (cylnA1 1))
|
||||
(funcall r (cylnA1 2) (cylnA1 1))
|
||||
|#
|
||||
|
||||
(DEFUN CYLINDER-BASIS (basisA basisB)
|
||||
(declare (type basis basisA basisB))
|
||||
(the basis
|
||||
(if (or (eq :locally-effective basisA)
|
||||
(eq :locally-effective basisB)
|
||||
)
|
||||
:locally-effective
|
||||
(flet ((rslt (degr)
|
||||
(declare (fixnum degr))
|
||||
(append
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(cylnA1 item))
|
||||
(funcall basisA (1- degr)))
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(cylnB item))
|
||||
(funcall basisB degr))
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(cylnA2 item))
|
||||
(funcall basisA degr)))))
|
||||
(the basis #'rslt)))))
|
||||
|
||||
#|
|
||||
(CYLINDER-basis :locally-effective :locally-effective )
|
||||
(setf b #'(lambda (degr) (mapcar #'(lambda (item) (cons degr item)) (<a-b> 0 degr))))
|
||||
(setf r (CYLINDER-basis b b))
|
||||
(funcall r 3)
|
||||
|#
|
||||
|
||||
(DEFUN CYLINDER-INTR-DFFR (cmprA cmprB dffrA dffrB f)
|
||||
(declare
|
||||
(type cmprf cmprA cmprB)
|
||||
(type morphism dffrA dffrB f))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(multiple-value-bind (cmbnA1 cmbnB cmbnA2) (dispatch-cyln-cmbn cmbn)
|
||||
(declare (type cmbn cmbnA1 cmbnB cmbnA2))
|
||||
(let ((dffrA1-cmbn (cmbn-? dffrA cmbnA1))
|
||||
(dffrB-cmbn (cmbn-? dffrB cmbnB))
|
||||
(dffrA2-cmbn (cmbn-? dffrA cmbnA2))
|
||||
(f-cmbn (cmbn-? f cmbnA1))
|
||||
)
|
||||
(declare (type cmbn dffrA1-cmbn dffrB-cmbn dffrA2-cmbn f-cmbn))
|
||||
(let ((cmbnB (2cmbn-add cmprB f-cmbn dffrB-cmbn))
|
||||
(cmbnA2 (2cmbn-sbtr cmprA dffrA2-cmbn cmbnA1)))
|
||||
(declare (type cmbn cmbnB cmbnA2))
|
||||
(make-cyln-cmbn (cmbn-opps dffrA1-cmbn) cmbnB cmbnA2)))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
|
||||
(DEFUN CYLINDER (f)
|
||||
(declare (type morphism f))
|
||||
(the chain-complex
|
||||
(with-slots (sorc trgt) f
|
||||
(declare
|
||||
(type chain-complex sorc trgt ))
|
||||
(let ((rslt (build-chcm
|
||||
:cmpr (cylinder-cmpr (cmpr sorc) (cmpr trgt))
|
||||
:basis (cylinder-basis (basis sorc) (basis trgt))
|
||||
:bsgn :undefined
|
||||
:intr-dffr (cylinder-intr-dffr (cmpr sorc) (cmpr trgt)
|
||||
(dffr sorc) (dffr trgt) f)
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder ,f))))
|
||||
(declare (type chain-complex rslt))
|
||||
(slot-makunbound rslt 'bsgn)
|
||||
rslt))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(defun cylinder-rrdct (f)
|
||||
(declare (type morphism f))
|
||||
(the reduction
|
||||
(with-slots (sorc (Bcc trgt)) f
|
||||
(with-slots ((cmprb cmpr)) Bcc
|
||||
(let ((cylinder (cylinder f)))
|
||||
(let ((rf (build-mrph
|
||||
:sorc cylinder :trgt Bcc :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(2cmbn-add cmprB (cyln-cmbn-cmbnB cmbn) (cmbn-? f (cyln-cmbn-cmbnA2 cmbn))))
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder ,f rf)))
|
||||
(rg (build-mrph
|
||||
:sorc Bcc :trgt cylinder :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(let* ((cmbnA1 (zero-cmbn (1- (cmbn-degr cmbn))))
|
||||
(cmbnA2 (zero-cmbn (cmbn-degr cmbn))))
|
||||
(declare (type cmbn cmbnA1 cmbnA2))
|
||||
(make-cyln-cmbn cmbnA1 cmbn cmbnA2)))
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder ,f rg)))
|
||||
(rh (build-mrph
|
||||
:sorc cylinder :trgt cylinder :degr +1
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(let* ((cmbnA1 (cmbn-opps (cyln-cmbn-cmbnA2 cmbn)))
|
||||
(cmbnB (zero-cmbn (1+ (cmbn-degr cmbn))))
|
||||
(cmbnA2 (zero-cmbn (1+ (cmbn-degr cmbn)))))
|
||||
(declare (type cmbn cmbnA1 cmbnB cmbnA2))
|
||||
(make-cyln-cmbn cmbnA1 cmbnB cmbnA2)))
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder ,f rh))))
|
||||
(declare
|
||||
(type chain-complex cylinder)
|
||||
(type morphism rf rg rh))
|
||||
(build-rdct :f rf :g rg :h rh :orgn `(cylinder right reduction ,f))))))))
|
||||
|
||||
|
||||
(defun cylinder-lrdct (f g h k)
|
||||
(declare (type morphism f g h k))
|
||||
(the reduction
|
||||
(with-slots ((Acc sorc) (Bcc trgt)) f
|
||||
(with-slots ((cmprA cmpr)) Acc
|
||||
(with-slots ((cmprb cmpr)) Bcc
|
||||
(let ((cylinder (cylinder f)))
|
||||
(let ((lf (build-mrph
|
||||
:sorc cylinder :trgt Acc :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(2cmbn-sbtr cmprA
|
||||
(2cmbn-add cmpra (cyln-cmbn-cmbnA2 cmbn) (cmbn-? g (cyln-cmbn-cmbnB cmbn)))
|
||||
(cmbn-? h (cyln-cmbn-cmbnA1 cmbn))))
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder hmtpeq ,f lf)))
|
||||
(lg (build-mrph
|
||||
:sorc Acc :trgt cylinder :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(let* ((cmbnA1 (zero-cmbn (1- (cmbn-degr cmbn))))
|
||||
(cmbnB (zero-cmbn (cmbn-degr cmbn)))
|
||||
)
|
||||
(declare (type cmbn cmbnA1 cmbnB ))
|
||||
(make-cyln-cmbn cmbnA1 cmbnB cmbn)))
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder hmtpeq ,f lg)))
|
||||
(lh (build-mrph
|
||||
:sorc cylinder :trgt cylinder :degr +1
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(multiple-value-bind (cmbnA1 cmbnB cmbnA2)
|
||||
(dispatch-cyln-cmbn cmbn)
|
||||
(let* ((cmbnA11 (cmbn-opps (cmbn-? h cmbnA1)))
|
||||
(cmbnA12 (cmbn-opps (cmbn-? g (cmbn-? k (cmbn-? f cmbnA1)))))
|
||||
(cmbnA13 (cmbn-? g (cmbn-? f (cmbn-? h cmbnA1))))
|
||||
(cmbnA14 (cmbn-? g cmbnB))
|
||||
(cmbnB1 (cmbn-opps (cmbn-? k (cmbn-? k (cmbn-? f cmbnA1)))))
|
||||
(cmbnB2 (cmbn-? k (cmbn-? f (cmbn-? h cmbnA1))))
|
||||
(cmbnB3 (cmbn-? k cmbnB))
|
||||
(cmbnA21 (cmbn-opps (cmbn-? h (cmbn-? h cmbnA1))))
|
||||
(cmbnA22 (cmbn-opps (cmbn-? h (cmbn-? g (cmbn-? k (cmbn-? f cmbnA1))))))
|
||||
(cmbnA23 (cmbn-? h (cmbn-? g (cmbn-? f (cmbn-? h cmbnA1)))))
|
||||
(cmbnA24 (cmbn-? g (cmbn-? k (cmbn-? k (cmbn-? f cmbnA1)))))
|
||||
(cmbnA25 (cmbn-opps (cmbn-? g (cmbn-? k (cmbn-? f (cmbn-? h cmbnA1))))))
|
||||
(cmbnA26 (cmbn-? h (cmbn-? g cmbnB)))
|
||||
(cmbnA27 (cmbn-opps (cmbn-? g (cmbn-? k cmbnB)))))
|
||||
(declare (type cmbn cmbnA11 cmbnA12 cmbnA13 cmbnA14
|
||||
cmbnB1 cmbnB2 cmbnB3
|
||||
cmbnA21 cmbnA22 cmbnA23 cmbnA24 cmbnA25 cmbnA26 cmbnA27))
|
||||
(make-cyln-cmbn (ncmbn-add cmprA cmbnA11 cmbnA12 cmbnA13 cmbnA14)
|
||||
(ncmbn-add cmprB cmbnB1 cmbnB2 cmbnB3)
|
||||
(ncmbn-add cmprA cmbnA21 cmbnA22 cmbnA23 cmbnA24 cmbnA25 cmbnA26 cmbnA27)))))
|
||||
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder hmtpeq ,f lh))))
|
||||
(declare
|
||||
(type chain-complex cylinder)
|
||||
(type morphism lf lg lh))
|
||||
(build-rdct :f lf :g lg :h lh :orgn `(cylinder left reduction ,f ,g ,h ,k)))))))))
|
||||
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf z3 (cyclicgroup 3))
|
||||
(setf rsltn1 (cyclicgroup-rsltn 3))
|
||||
(setf rsltn2 (bar-rsltn z3))
|
||||
(setf f (zgmrph-twi (2rsltn-zgmrph rsltn1 rsltn2)))
|
||||
(setf g (zgmrph-twi (2rsltn-zgmrph rsltn2 rsltn1)))
|
||||
(setf h (zgmrph-twi (2rsltn-hmtpop rsltn1 rsltn2)))
|
||||
(setf k (zgmrph-twi (2rsltn-hmtpop rsltn2 rsltn1)))
|
||||
(setf Acc (sorc f) Bcc (trgt f))
|
||||
|
||||
|
||||
(setf rrdct (cylinder-rrdct f))
|
||||
(setf lrdct (cylinder-lrdct f g h k))
|
||||
|
||||
(setf lf (f lrdct) lg (g lrdct) lh (h lrdct))
|
||||
(setf rf (f rrdct) rg (g rrdct) rh (h rrdct))
|
||||
|
||||
(pre-check-rdct rrdct)
|
||||
(setf *tc* (cmbn 3 1 (cylnA1 2) 10 (cylnB '(1 2 1)) 100 (cylnA2 3)))
|
||||
(setf *bc* (cmbn 3 1 '(1 1 2)))
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 4 10 (cylnB '(1 2 1 1)) 5 (cylnB '(1 2 2 1)) 100 (cylnA2 4)))
|
||||
(setf *bc* (cmbn 2 5 '(1 1) 7 '(2 1) -4 '(2 2)))
|
||||
(check-rdct)
|
||||
|
||||
|
||||
(pre-check-rdct lrdct)
|
||||
|
||||
(setf *tc* (cmbn 3 1 (cylnA1 2) 10 (cylnB '(1 2 1)) 100 (cylnA2 3)))
|
||||
(setf *bc* (cmbn 3 1 3))
|
||||
(check-rdct)
|
||||
|
||||
(setf *tc* (cmbn 4 10 (cylnB '(1 2 1 1)) 5 (cylnB '(1 2 2 1)) 100 (cylnA2 4)))
|
||||
(setf *bc* (cmbn 2 1 2))
|
||||
(check-rdct)
|
||||
|#
|
||||
|
||||
|
||||
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'k-g-1)))
|
||||
(declare (type simplicial-group smst))
|
||||
(the homotopy-equivalence
|
||||
(let* ((group (second (orgn smst)))
|
||||
(rsltn1 (bar-rsltn group))
|
||||
(rsltn2 (resolution group))
|
||||
(f (zgmrph-twi (2rsltn-zgmrph rsltn1 rsltn2)))
|
||||
(g (zgmrph-twi (2rsltn-zgmrph rsltn2 rsltn1)))
|
||||
(h (zgmrph-twi (2rsltn-hmtpop rsltn1 rsltn2)))
|
||||
(k (zgmrph-twi (2rsltn-hmtpop rsltn2 rsltn1)))
|
||||
(rrdct (cylinder-rrdct f))
|
||||
(lrdct (cylinder-lrdct f g h k)))
|
||||
(build-hmeq :lrdct lrdct :rrdct rrdct :orgn `(cylinder-hmeq ,f ,g ,h ,k )))))
|
||||
|
||||
#|
|
||||
(setf z3 (cyclicgroup 3))
|
||||
(setf k-z3-1 (k-g-1 z3))
|
||||
|
||||
(cat-init)
|
||||
(setf z4 (cyclicgroup 4))
|
||||
(setf k-z4-1 (k-g-1 z4))
|
||||
(setf k-z4-2 (classifying-space k-z4-1))
|
||||
|
||||
(cat-init)
|
||||
(setf z2 (cyclicgroup 2))
|
||||
(setf k-z2-1 (k-g-1 z2))
|
||||
(setf k-z2-2 (classifying-space k-z2-1))
|
||||
|#
|
||||
|
||||
52
examples/anromero/homology-of-groups/kzs.LSP
Normal file
52
examples/anromero/homology-of-groups/kzs.LSP
Normal file
@ -0,0 +1,52 @@
|
||||
|
||||
(load "file-list.lisp")
|
||||
|
||||
(load-cfiles)
|
||||
|
||||
(load "resolutions.lisp")
|
||||
|
||||
(load "cylinders.lisp")
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
(setf kz22 (k-zp 2 2))
|
||||
(setf kz23 (k-zp 2 3))
|
||||
(setf kz32 (k-zp 3 2))
|
||||
(setf kz33 (k-zp 3 3))
|
||||
(setf kz42 (k-zp 4 2))
|
||||
(setf kz43 (k-zp 4 3))
|
||||
(setf kz52 (k-zp 5 2))
|
||||
(setf kz53 (k-zp 5 3))
|
||||
|
||||
|
||||
(print "homology of kz22")
|
||||
(time (homology kz22 0 7))
|
||||
|
||||
(print "homology of kz23")
|
||||
(time (homology kz23 0 7))
|
||||
|
||||
(print "homology of kz32")
|
||||
(time (homology kz32 0 7))
|
||||
|
||||
(print "homology of kz33")
|
||||
(time (homology kz33 0 7))
|
||||
|
||||
(print "homology of kz42")
|
||||
(time (homology kz42 0 7))
|
||||
|
||||
(print "homology of kz43")
|
||||
(time (homology kz43 0 7))
|
||||
|
||||
(print "homology of kz52")
|
||||
(time (homology kz52 0 7))
|
||||
|
||||
(print "homology of kz53")
|
||||
(time (homology kz53 0 7))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
1600
examples/anromero/homology-of-groups/resolutions.lisp
Normal file
1600
examples/anromero/homology-of-groups/resolutions.lisp
Normal file
File diff suppressed because it is too large
Load Diff
843
examples/anromero/persistent-homology/filtered-complexes.lsp
Normal file
843
examples/anromero/persistent-homology/filtered-complexes.lsp
Normal file
@ -0,0 +1,843 @@
|
||||
;; 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 "COMMON-LISP-USER")
|
||||
|
||||
(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)))
|
||||
(<a-b> 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 found))
|
||||
(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)))
|
||||
501
examples/anromero/persistent-homology/persistent-homology.cl
Normal file
501
examples/anromero/persistent-homology/persistent-homology.cl
Normal file
@ -0,0 +1,501 @@
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(defun eff-prst-hmlg-basis-dvs-quotient (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 (1+ p) p q))
|
||||
(den-mtrx (spsq-den-mtrx fltrcm r p q))
|
||||
(cmbn-list nil)
|
||||
(divs nil))
|
||||
(declare
|
||||
(list fltr-p-basis cmbn-list divs)
|
||||
(type fixnum degr p-basis-l)
|
||||
(type matrix num-mtrx den-mtrx))
|
||||
(progn
|
||||
(if (= 0 (array-total-size num-mtrx))
|
||||
(progn
|
||||
(setq cmbn-list nil)
|
||||
(setq divs nil))
|
||||
(if (= 0 (array-total-size den-mtrx))
|
||||
(progn
|
||||
(setq cmbn-list (gnrt-mtrx-to-list num-mtrx))
|
||||
(setq divs (make-list (length cmbn-list) :initial-element 0)))
|
||||
(let ((quotient-list (mtrx-quotient num-mtrx den-mtrx)))
|
||||
(declare (list quotient-list))
|
||||
(setq cmbn-list (first quotient-list)
|
||||
divs (second quotient-list)))))
|
||||
(list
|
||||
(mapcar
|
||||
#'(lambda (int-list)
|
||||
(declare (list int-list))
|
||||
(the cmbn
|
||||
(let* ((cmbn (cmbn degr))
|
||||
(cmpr (cmpr fltrcm)))
|
||||
(declare
|
||||
(type cmbn cmbn)
|
||||
(type cmprf cmpr))
|
||||
(do ((mark1 int-list (cdr mark1))
|
||||
(mark2 fltr-p-basis (cdr mark2)))
|
||||
((or (endp mark1) (endp mark2)))
|
||||
(declare (type list mark1 mark2))
|
||||
(if (not (= 0 (car mark1)))
|
||||
(setq cmbn (2cmbn-add cmpr cmbn
|
||||
(cmbn degr (car mark1) (car mark2))))))
|
||||
cmbn)))
|
||||
cmbn-list)
|
||||
divs)))))
|
||||
|
||||
;; (setf fltrcm triangle r 1 p 5 q -4)
|
||||
;; (setf degr (+ p q))
|
||||
;; (setf fltr-p-basis (fltrd-basis fltrcm degr p))
|
||||
;; (setf p-basis-l (length fltr-p-basis))
|
||||
;; (setf z1-list (fltr-chcm-z-gnrt-list fltrcm r p q))
|
||||
;;(eff-prst-hmlg-basis-dvs-2 fltrcm r p q)
|
||||
;;(eff-prst-hmlg-basis-dvs-2 fltrcm r 1 -1)
|
||||
;;(eff-prst-hmlg-basis-dvs-2 fltrcm r 2 -2)
|
||||
;;(eff-prst-hmlg-basis-dvs-2 fltrcm r 3 -3)
|
||||
;;(eff-prst-hmlg-basis-dvs-2 fltrcm r 4 -4)
|
||||
;;(eff-prst-hmlg-basis-dvs-2 fltrcm r 5 -5)
|
||||
|
||||
(defun eff-prst-hmlg-basis-dvs-total (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))
|
||||
(fltr-p-1-list (fltr-basis-gnrt-list fltrcm degr (1- p)))
|
||||
(z1-list (fltr-chcm-z-gnrt-list fltrcm (1+ p) p q))
|
||||
(z1-mtrx (gnrt-list-to-mtrx z1-list))
|
||||
(z2-list (fltr-chcm-z-gnrt-list fltrcm (1- r) (1- (+ p r)) (+ 2 (- q r))))
|
||||
(z2-mtrx (gnrt-list-to-mtrx z2-list))
|
||||
(fltr-p-1-mtrx (gnrt-list-to-mtrx fltr-p-1-list))
|
||||
(dffr-mtrx (flcc-dffr-mtrx fltrcm (1+ degr) (1- (+ p r))))
|
||||
(nil-mtrx
|
||||
#-ACLPC (make-array (list 0 0)
|
||||
:element-type 'fixnum
|
||||
:initial-element 0)
|
||||
#+ACLPC (make-array (list 0 0)
|
||||
:element-type 'fixnum))
|
||||
(dffr-z2-mtrx
|
||||
(if (or (= 0 (array-total-size z2-mtrx)) (= 0 (array-total-size dffr-mtrx)))
|
||||
nil-mtrx
|
||||
(mtrx-prdc dffr-mtrx z2-mtrx)))
|
||||
(bnd-z2-line-n p-basis-l)
|
||||
(bnd-z2-column-n (column-number dffr-z2-mtrx))
|
||||
(bnd-z2-mtrx
|
||||
(if (or (= 0 bnd-z2-line-n) (= 0 bnd-z2-column-n))
|
||||
nil-mtrx
|
||||
(submatrix dffr-z2-mtrx 0 (1- bnd-z2-line-n) 0 (1- bnd-z2-column-n))))
|
||||
(num-mtrx z1-mtrx)
|
||||
(den-mtrx bnd-z2-mtrx)
|
||||
(cmbn-list nil)
|
||||
(divs nil))
|
||||
(declare
|
||||
(list fltr-p-basis cmbn-list divs)
|
||||
(type fixnum degr p-basis-l)
|
||||
(type matrix num-mtrx den-mtrx))
|
||||
(progn
|
||||
(if (= 0 (array-total-size num-mtrx))
|
||||
(progn
|
||||
(setq cmbn-list nil)
|
||||
(setq divs nil))
|
||||
(if (= 0 (array-total-size den-mtrx))
|
||||
(progn
|
||||
(setq cmbn-list (gnrt-mtrx-to-list num-mtrx))
|
||||
(setq divs (make-list (length cmbn-list) :initial-element 0)))
|
||||
(let ((quotient-list (mtrx-quotient num-mtrx den-mtrx)))
|
||||
(declare (list quotient-list))
|
||||
(setq cmbn-list (first quotient-list)
|
||||
divs (second quotient-list)))))
|
||||
(list
|
||||
(mapcar
|
||||
#'(lambda (int-list)
|
||||
(declare (list int-list))
|
||||
(the cmbn
|
||||
(let* ((cmbn (cmbn degr))
|
||||
(cmpr (cmpr fltrcm)))
|
||||
(declare
|
||||
(type cmbn cmbn)
|
||||
(type cmprf cmpr))
|
||||
(do ((mark1 int-list (cdr mark1))
|
||||
(mark2 fltr-p-basis (cdr mark2)))
|
||||
((or (endp mark1) (endp mark2)))
|
||||
(declare (type list mark1 mark2))
|
||||
(if (not (= 0 (car mark1)))
|
||||
(setq cmbn (2cmbn-add cmpr cmbn
|
||||
(cmbn degr (car mark1) (car mark2))))))
|
||||
cmbn)))
|
||||
cmbn-list)
|
||||
divs)))))
|
||||
|
||||
|
||||
(defun eff-prst-hmlg-basis-dvs-bar (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-den-mtrx fltrcm r p q))
|
||||
(den-mtrx (spsq-den-mtrx fltrcm (- r 1) p q))
|
||||
(cmbn-list nil)
|
||||
(divs nil))
|
||||
(declare
|
||||
(list fltr-p-basis cmbn-list divs)
|
||||
(type fixnum degr p-basis-l)
|
||||
(type matrix num-mtrx den-mtrx))
|
||||
(progn
|
||||
(if (= 0 (array-total-size num-mtrx))
|
||||
(progn
|
||||
(setq cmbn-list nil)
|
||||
(setq divs nil))
|
||||
(if (= 0 (array-total-size den-mtrx))
|
||||
(progn
|
||||
(setq cmbn-list (gnrt-mtrx-to-list num-mtrx))
|
||||
(setq divs (make-list (length cmbn-list) :initial-element 0)))
|
||||
(let ((quotient-list (mtrx-quotient num-mtrx den-mtrx)))
|
||||
(declare (list quotient-list))
|
||||
(setq cmbn-list (first quotient-list)
|
||||
divs (second quotient-list)))))
|
||||
(list
|
||||
(mapcar
|
||||
#'(lambda (int-list)
|
||||
(declare (list int-list))
|
||||
(the cmbn
|
||||
(let* ((cmbn (cmbn degr))
|
||||
(cmpr (cmpr fltrcm)))
|
||||
(declare
|
||||
(type cmbn cmbn)
|
||||
(type cmprf cmpr))
|
||||
(do ((mark1 int-list (cdr mark1))
|
||||
(mark2 fltr-p-basis (cdr mark2)))
|
||||
((or (endp mark1) (endp mark2)))
|
||||
(declare (type list mark1 mark2))
|
||||
(if (not (= 0 (car mark1)))
|
||||
(setq cmbn (2cmbn-add cmpr cmbn
|
||||
(cmbn degr (car mark1) (car mark2))))))
|
||||
cmbn)))
|
||||
cmbn-list)
|
||||
divs)))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(defun eff-prst-hmlg-gnrts-total (FltrCm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((basis-dvs (eff-prst-hmlg-basis-dvs-total 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))
|
||||
|
||||
(defun eff-prst-hmlg-gnrts-quotient (FltrCm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((basis-dvs (eff-prst-hmlg-basis-dvs-quotient 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))
|
||||
|
||||
(defun eff-prst-hmlg-gnrts-bar (FltrCm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((basis-dvs (eff-prst-hmlg-basis-dvs-bar 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))
|
||||
|
||||
|
||||
(defun eff-prst-hmlg-group-total (fltrcm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((basis-dvs (eff-prst-hmlg-basis-dvs-total fltrcm r p q))
|
||||
(cmbns (first basis-dvs))
|
||||
(divs (second basis-dvs)))
|
||||
(declare (list basis-dvs cmbns divs))
|
||||
|
||||
(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-prst-hmlg-group-quotient (fltrcm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((basis-dvs (eff-prst-hmlg-basis-dvs-quotient fltrcm r p q))
|
||||
(cmbns (first basis-dvs))
|
||||
(divs (second basis-dvs)))
|
||||
(declare (list basis-dvs cmbns divs))
|
||||
|
||||
(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-prst-hmlg-group-bar (fltrcm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((basis-dvs (eff-prst-hmlg-basis-dvs-bar fltrcm r p q))
|
||||
(cmbns (first basis-dvs))
|
||||
(divs (second basis-dvs)))
|
||||
(declare (list basis-dvs cmbns divs))
|
||||
|
||||
(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 prst-hmlg-group-total-rpq (fltrcm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((hmtp-eq (efhm fltrcm))
|
||||
(eff-chcm (rbcc hmtp-eq))
|
||||
(degr (+ p q)))
|
||||
(declare
|
||||
(type homotopy-equivalence hmtp-eq)
|
||||
(type chain-complex eff-chcm)
|
||||
(type fixnum degr))
|
||||
(progn
|
||||
(if (not (typep eff-chcm 'filtered-chain-complex))
|
||||
(translate-filtration hmtp-eq))
|
||||
(eff-prst-hmlg-group-total eff-chcm r p q))))
|
||||
|
||||
(defun prst-hmlg-group-quotient-rpq (fltrcm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((hmtp-eq (efhm fltrcm))
|
||||
(eff-chcm (rbcc hmtp-eq))
|
||||
(degr (+ p q)))
|
||||
(declare
|
||||
(type homotopy-equivalence hmtp-eq)
|
||||
(type chain-complex eff-chcm)
|
||||
(type fixnum degr))
|
||||
(progn
|
||||
(if (not (typep eff-chcm 'filtered-chain-complex))
|
||||
(translate-filtration hmtp-eq))
|
||||
(eff-prst-hmlg-group-quotient eff-chcm r p q))))
|
||||
|
||||
(defun prst-hmlg-group-bar-rpq (fltrcm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((hmtp-eq (efhm fltrcm))
|
||||
(eff-chcm (rbcc hmtp-eq))
|
||||
(degr (+ p q)))
|
||||
(declare
|
||||
(type homotopy-equivalence hmtp-eq)
|
||||
(type chain-complex eff-chcm)
|
||||
(type fixnum degr))
|
||||
(progn
|
||||
(if (not (typep eff-chcm 'filtered-chain-complex))
|
||||
(translate-filtration hmtp-eq))
|
||||
(eff-prst-hmlg-group-bar eff-chcm r p q))))
|
||||
|
||||
(defun prst-hmlg-gnrts-total-rpq (FltrCm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((hmtp-eq (efhm fltrcm))
|
||||
(eff-chcm (rbcc hmtp-eq))
|
||||
(degr (+ p q)))
|
||||
(declare
|
||||
(type homotopy-equivalence hmtp-eq)
|
||||
(type chain-complex eff-chcm)
|
||||
(type fixnum degr))
|
||||
(progn
|
||||
(if (not (typep eff-chcm 'filtered-chain-complex))
|
||||
(translate-filtration hmtp-eq))
|
||||
(eff-prst-hmlg-gnrts-total eff-chcm r p q))))
|
||||
|
||||
(defun prst-hmlg-gnrts-quotient-rpq (FltrCm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((hmtp-eq (efhm fltrcm))
|
||||
(eff-chcm (rbcc hmtp-eq))
|
||||
(degr (+ p q)))
|
||||
(declare
|
||||
(type homotopy-equivalence hmtp-eq)
|
||||
(type chain-complex eff-chcm)
|
||||
(type fixnum degr))
|
||||
(progn
|
||||
(if (not (typep eff-chcm 'filtered-chain-complex))
|
||||
(translate-filtration hmtp-eq))
|
||||
(eff-prst-hmlg-gnrts-quotient eff-chcm r p q))))
|
||||
|
||||
(defun prst-hmlg-gnrts-bar-rpq (FltrCm r p q)
|
||||
(declare
|
||||
(type filtered-chain-complex fltrcm)
|
||||
(type fixnum r p q))
|
||||
(let* ((hmtp-eq (efhm fltrcm))
|
||||
(eff-chcm (rbcc hmtp-eq))
|
||||
(degr (+ p q)))
|
||||
(declare
|
||||
(type homotopy-equivalence hmtp-eq)
|
||||
(type chain-complex eff-chcm)
|
||||
(type fixnum degr))
|
||||
(progn
|
||||
(if (not (typep eff-chcm 'filtered-chain-complex))
|
||||
(translate-filtration hmtp-eq))
|
||||
(eff-prst-hmlg-gnrts-bar eff-chcm r p q))))
|
||||
|
||||
(defun total-prst-hmlg-gnrts (fltrcm i j n)
|
||||
(prst-hmlg-gnrts-total-rpq fltrcm (1+ (- j i)) i (- n i) ))
|
||||
|
||||
(defun total-prst-hmlg-group (fltrcm i j n)
|
||||
(format t "Persistent Homology H^{~D,~D}_~D" i j n)
|
||||
(prst-hmlg-group-total-rpq fltrcm (1+ (- j i)) i (- n i) ))
|
||||
|
||||
(defun prst-hmlg-gnrts-quotient (fltrcm i j n)
|
||||
(prst-hmlg-gnrts-quotient-rpq fltrcm (1+ (- j i)) i (- n i) ))
|
||||
|
||||
(defun prst-hmlg-group-quotient (fltrcm i j n)
|
||||
(format t "Persistent Homology H^{~D,~D}_~D" i j n)
|
||||
(prst-hmlg-group-quotient-rpq fltrcm (1+ (- j i)) i (- n i) ))
|
||||
|
||||
|
||||
(defun prst-hmlg-gnrts (fltrcm i j n)
|
||||
(prst-hmlg-gnrts-bar-rpq fltrcm (1+ (- j i)) i (- n i) ))
|
||||
|
||||
(defun prst-hmlg-group (fltrcm i j n)
|
||||
(format t "Persistent Homology B^{~D,~D}_~D" i j n)
|
||||
(prst-hmlg-group-bar-rpq fltrcm (1+ (- j i)) i (- n i) ))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; EXAMPLE: TRIANGLE
|
||||
|
||||
|
||||
(defun contains-element (list element)
|
||||
(let ((rslt nil))
|
||||
(dotimes (i (length list))
|
||||
(if (eq element (nth i list))
|
||||
(setf rslt 't)))
|
||||
rslt))
|
||||
|
||||
|
||||
|
||||
(setf triangle
|
||||
(build-finite-ss
|
||||
'(a b c
|
||||
1 ab (b a) ac (c a) bc (c b)
|
||||
2 abc (bc ac ab) )))
|
||||
|
||||
|
||||
|
||||
(setf triangle-flin
|
||||
#'(lambda (degr gnrt)
|
||||
(declare
|
||||
(type fixnum degr)
|
||||
(type gnrt gnrt))
|
||||
(let (
|
||||
(l1 (list 'a))
|
||||
(l2 (list 'b))
|
||||
(l3 (list 'c))
|
||||
(l4 (list 'ab))
|
||||
(l5 (list 'bc))
|
||||
(l6 (list 'ac))
|
||||
(l7 (list 'abc))
|
||||
(rslt -1))
|
||||
|
||||
(if (contains-element l1 gnrt) (setf rslt 1)
|
||||
(if (contains-element l2 gnrt) (setf rslt 2)
|
||||
(if (contains-element l3 gnrt) (setf rslt 3)
|
||||
(if (contains-element l4 gnrt) (setf rslt 4)
|
||||
(if (contains-element l5 gnrt) (setf rslt 5)
|
||||
(if (contains-element l6 gnrt) (setf rslt 6)
|
||||
(if (contains-element l7 gnrt) (setf rslt 7)
|
||||
|
||||
|
||||
)))))))
|
||||
rslt)))
|
||||
|
||||
|
||||
(setf triangle (change-chcm-to-flcc triangle triangle-flin 'triangle-flin))
|
||||
|
||||
|
||||
(dotimes (p 8)
|
||||
(print (spsq-group triangle 1 p (- 0 p)))
|
||||
(print (spsq-group triangle 1 p (- 1 p)))
|
||||
(print (spsq-group triangle 1 p (- 2 p)))
|
||||
(print (spsq-group triangle 1 p (- 3 p))))
|
||||
|
||||
|
||||
(dotimes (p 8)
|
||||
(print (spsq-group triangle 2 p (- 0 p)))
|
||||
(print (spsq-group triangle 2 p (- 1 p)))
|
||||
(print (spsq-group triangle 2 p (- 2 p)))
|
||||
(print (spsq-group triangle 2 p (- 3 p))))
|
||||
|
||||
|
||||
(dotimes (n 3)
|
||||
(dotimes (p 8)
|
||||
(print (prst-hmlg-group triangle p p n))
|
||||
(print (prst-hmlg-group triangle p (1+ p) n))
|
||||
(print (prst-hmlg-group triangle p (+ 2 p) n))
|
||||
(print (prst-hmlg-group triangle p (+ 3 p) n))
|
||||
(print (prst-hmlg-group triangle p (+ 4 p) n))
|
||||
))
|
||||
|
||||
|
||||
|
||||
|
||||
1359
examples/anromero/persistent-homology/spectral-sequences.lsp
Normal file
1359
examples/anromero/persistent-homology/spectral-sequences.lsp
Normal file
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,469 @@
|
||||
(in-package :user)
|
||||
|
||||
|
||||
|
||||
|
||||
(defun OMgetNextLabel (s)
|
||||
(let* ((p1 (search "<" s)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end p1)
|
||||
(let ((p1 (search "<" s))
|
||||
(p2 (if (search " " s) (min (search ">" s) (search " " s))
|
||||
(search ">" s) )))
|
||||
(subseq s (1+ p1) p2))))
|
||||
|
||||
(defun OMgetNextSymbol (s)
|
||||
(let* ((p1 (search "cd=" s))
|
||||
(p2 (search "name=" s))
|
||||
(p3 (search "/>" s))
|
||||
(rslt1 (subseq s (+ 3 p1) p2))
|
||||
(rslt2 (subseq s (+ 5 p2) p3))
|
||||
)
|
||||
(OMLispSymbol (list (delete #\" (delete #\space rslt1)) (delete #\" (delete #\space rslt2))))
|
||||
))
|
||||
|
||||
(defun OMparseNextInteger (s)
|
||||
(if (not (equal (OMgetNextLabel s) "OMI"))
|
||||
(error "The next token is not an integer")
|
||||
(let* ((p1 (search "<OMI>" s))
|
||||
(p2 (search "</OMI>" s))
|
||||
(rslt (parse-integer (subseq s (+ 5 p1) p2))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 p2))
|
||||
rslt
|
||||
)))
|
||||
|
||||
(defun OMparseNextString (s)
|
||||
(if (not (equal (OMgetNextLabel s) "OMSTR"))
|
||||
(error "The next token is not a string")
|
||||
(let* ((p1 (search "<OMSTR>" s))
|
||||
(p2 (search "</OMSTR>" s))
|
||||
(rslt (subseq s (+ 7 p1) p2)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 8 p2))
|
||||
rslt
|
||||
)))
|
||||
|
||||
(defun OMparseNextVar (s)
|
||||
(if (not (equal (OMgetNextLabel s) "OMV"))
|
||||
(error "The next token is not a variable")
|
||||
(let* ((p1 (search "<OMV>" s))
|
||||
(p2 (search "</OMV>" s))
|
||||
(rslt (intern (subseq s (+ 5 p1) p2))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 p2))
|
||||
rslt
|
||||
)))
|
||||
|
||||
(defun OMparseNextSymbol (s)
|
||||
(if (not (equal (OMgetNextLabel s) "OMS"))
|
||||
(error "The next token is not a symbol")
|
||||
(let* ((rslt (OMgetNextSymbol s))
|
||||
(p (search "/>" s))
|
||||
)
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 2 p))
|
||||
rslt
|
||||
)))
|
||||
|
||||
(DEFTYPE direct-symbol () '(member list cyclicgroup symmetricgroup))
|
||||
|
||||
|
||||
(defun OMLispSymbol (list)
|
||||
(let ((cd (first list))
|
||||
(name (second list)))
|
||||
(if (equal cd "list1")
|
||||
(if (equal name "list")
|
||||
'list)
|
||||
(if (equal cd "resolutions")
|
||||
(if (equal name "zgcombination")
|
||||
"zgcombination"
|
||||
(if (equal name "zgterm")
|
||||
"zgterm"
|
||||
(if (equal name "zggnrt")
|
||||
"zggnrt"
|
||||
(if (equal name "resolution")
|
||||
"resolution"))))
|
||||
(if (equal cd "group1")
|
||||
(if (equal name "cyclic_group")
|
||||
'cyclicgroup
|
||||
(if (equal name "symmetric_group")
|
||||
'symmetricgroup)
|
||||
)
|
||||
)))))
|
||||
|
||||
(defun OMparseNextApplication (s)
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next token is not an application")
|
||||
(let* ((p1 (search "<OMA>" s)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 p1))
|
||||
(let ((head (if (equal (OMgetNextLabel s) "OMS")
|
||||
(OMparseNextSymbol s)
|
||||
(OMparseNextObject s)))
|
||||
(rest nil))
|
||||
(if (typep head 'direct-symbol)
|
||||
(do ((rest nil (append rest (list nextobj))))
|
||||
((equal (OMgetNextLabel s) "/OMA") (let ((p (search "</OMA>" s)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 p1))
|
||||
(eval (append (list head) rest))))
|
||||
(setf nextobj (OMparseNextObject s))
|
||||
)
|
||||
(if (equal head "resolution")
|
||||
(OMparseResolution s)
|
||||
(error "imposible to parse")
|
||||
))))))
|
||||
|
||||
|
||||
|
||||
|
||||
(defun OMparseNextObject (s)
|
||||
(progn
|
||||
(if (equal (OMgetNextLabel s) "OMOBJ")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 7 (search "<OMOBJ>" s))))
|
||||
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
|
||||
(let ((rslt
|
||||
(if (equal (OMgetNextLabel s) "OMI")
|
||||
(OMparseNextInteger s)
|
||||
(if (equal (OMgetNextLabel s) "OMSTR")
|
||||
(OMparseNextString s)
|
||||
(if (equal (OMgetNextLabel s) "OMV")
|
||||
(OMparseNextVar s)
|
||||
(if (equal (OMgetNextLabel s) "OMS")
|
||||
(OMLispSymbol(OMparseNextSymbol s))
|
||||
(if (equal (OMgetNextLabel s) "OMA")
|
||||
(OMparseNextApplication s)
|
||||
(error "imposible to parse"))))))))
|
||||
(progn
|
||||
(if (and (not (equal s "")) (equal (OMgetNextLabel s) "/OMOBJ"))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 8 (search "</OMOBJ>" s))))
|
||||
rslt))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(defun OMparseZggnrt (s grbasis zgbasis-degr)
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) "zggnrt"))
|
||||
(error "This is not specified as a zggnrt")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let* ((i1 (OMparseNextInteger s))
|
||||
(i2 (OMparseNextInteger s)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(zggnrt (nth (1- i1) grbasis) (nth (1- i2) zgbasis-degr))))))))
|
||||
|
||||
|
||||
(defun OMparseZgterm (s degr grbasis zgbasis)
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) "zgterm"))
|
||||
(error "This is not specified as a zgterm")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let* ((coeff (OMparseNextInteger s))
|
||||
(zggnrt (OMparseZggnrt s grbasis (funcall zgbasis degr))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(term-cmbn degr coeff zggnrt )))))))
|
||||
|
||||
(defun OMparseZgcmbn (s degr grbasis grcmpr zgbasis zgcmpr)
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) "zgcombination"))
|
||||
(error "This is not specified as a zgcombination")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((cmbn-list nil))
|
||||
(do ((term-list nil (push (cons 1 nexttermcmbn) term-list)))
|
||||
((equal (OMgetNextLabel s) "/OMA") (setf cmbn-list term-list) )
|
||||
(setf nexttermcmbn (OMparseZgterm s degr grbasis zgbasis))
|
||||
)
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(if cmbn-list
|
||||
(cmbn-cmbn (zggnrt-cmpr grcmpr zgcmpr) cmbn-list)
|
||||
(zero-cmbn degr))))))))
|
||||
|
||||
(defun OMparseZgboundaryList (s grbasis grcmpr zgbasis zgcmpr maxdegr)
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt nil))
|
||||
(dotimes (i maxdegr)
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt-i nil))
|
||||
(do ((aux nil (push cmbn aux)))
|
||||
((equal (OMgetNextLabel s) "/OMA") (setf rslt-i aux))
|
||||
(setf cmbn (OMparseZgcmbn s i grbasis grcmpr zgbasis zgcmpr)))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(push (nreverse rslt-i) rslt)))))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(nreverse rslt)))))))
|
||||
|
||||
|
||||
(defun OMparseContractinghmtpList (s grbasis grcmpr zgbasis zgcmpr maxdegr)
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt nil))
|
||||
(dotimes (i (1- maxdegr))
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt-i nil))
|
||||
(do ((mark1 (funcall zgbasis i) (cdr mark1)))
|
||||
((endp mark1) (push (nreverse rslt-i) rslt))
|
||||
(progn
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt-i-g nil))
|
||||
|
||||
(do ((mark2 grbasis (cdr mark2)))
|
||||
((endp mark2) (push (nreverse rslt-i-g) rslt-i))
|
||||
(setf cmbn (OMparseZgcmbn s (1+ i) grbasis grcmpr zgbasis zgcmpr))
|
||||
(push cmbn rslt-i-g))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
)))))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
))))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(nreverse rslt)))))))
|
||||
|
||||
|
||||
|
||||
(defun OMrsltnZgbasis (rank-list maxdegr)
|
||||
(flet ((rslt (degr)
|
||||
(declare (fixnum degr))
|
||||
(if (> degr maxdegr) (error "unknown basis for this degree")
|
||||
(if (< degr 0) nil
|
||||
(let ((rank (nth degr rank-list))
|
||||
(list nil))
|
||||
(dotimes (i rank)
|
||||
(push (concatenate 'string "g" (Write-to-string degr) (Write-to-string (1+ i))) list))
|
||||
(nreverse list))))))
|
||||
|
||||
(the basis #'rslt)))
|
||||
|
||||
(defun OMrsltnZgboundary-intr (Zgboundary-list zgbasis maxdegr)
|
||||
(flet ((rslt (degr gnrt)
|
||||
(declare (fixnum degr) (type gnrt gnrt))
|
||||
(if (> degr maxdegr) (error "unknown basis for this degree")
|
||||
(if (< degr 1) (zero-cmbn (1- degr))
|
||||
(nth (position gnrt (funcall zgbasis degr) :test #'equal) (nth (1- degr) Zgboundary-list))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
(defun OMrsltnCntrHmtp-intr (Zgcontractinghmtp-list zgbasis grbasis maxdegr)
|
||||
(flet ((rslt (degr zggnrt)
|
||||
(declare (fixnum degr) (type zggnrt zggnrt))
|
||||
(if (> degr (1- maxdegr)) (error "unknown basis for this degree")
|
||||
(with-zggnrt (gnrt1 gnrt2) zggnrt
|
||||
(let ((gnrt1-pos (position gnrt1 grbasis :test #'equal))
|
||||
(gnrt2-pos (position gnrt2 (funcall zgbasis degr) :test #'equal)))
|
||||
(nth gnrt1-pos (nth gnrt2-pos (nth degr Zgcontractinghmtp-list))))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(defun OMparseResolution (s)
|
||||
;;(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
;; (error "The next label is not an application")
|
||||
;; (progn
|
||||
;; (delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
;; (if (not (equal (OMgetNextSymbol s) "resolution"))
|
||||
;; (error "This is not specified as a resolution")
|
||||
;; (progn
|
||||
;; (OMparseNextSymbol s)
|
||||
(let* ((group (OMparseNextObject s))
|
||||
(maxdegr (OMparseNextObject s))
|
||||
(rank-list (OMparseNextObject s))
|
||||
(zgbasis (OMrsltnZgbasis rank-list maxdegr)))
|
||||
(with-slots ((grcmpr cmpr) (grbasis elements) nullel) group
|
||||
(let* ((zgboundary-list (OMparseZgboundaryList s grbasis grcmpr zgbasis #'s-cmpr maxdegr))
|
||||
(cntrchmtp-list (OMparseContractinghmtpList s grbasis grcmpr zgbasis #'s-cmpr maxdegr))
|
||||
(zgchcm (BUILD-ZGCHCM :group group :zgcmpr #'s-cmpr :zgbasis zgbasis :zgbsgn "g00"
|
||||
:intr-zgbndr (OMrsltnZgboundary-intr Zgboundary-list zgbasis maxdegr)
|
||||
:zgbndr-strt :gnrt :orgn `(ZG-Chain complex for ,group obtained from HAP)))
|
||||
(cmpr (cmpr1 zgchcm))
|
||||
(f-intr #'(lambda (degr zggnrt)
|
||||
(if (zerop degr) (cmbn degr 1 :zgnrt) (zero-cmbn degr))))
|
||||
(g-intr #'(lambda (degr gnrt)
|
||||
(if (zerop degr) (cmbn degr 1 (zggnrt nullel "g01")) (zero-cmbn degr))))
|
||||
(h-intr (OMrsltnCntrHmtp-intr cntrchmtp-list zgbasis grbasis maxdegr))
|
||||
|
||||
(f (build-mrph :sorc zgchcm :trgt (z-chcm) :degr 0 :intr f-intr :strt :gnrt :orgn `(f-mrph for ,group obtained from HAP)))
|
||||
(g (build-mrph :sorc (z-chcm) :trgt zgchcm :degr 0 :intr g-intr :strt :gnrt :orgn `(g-mrph for ,group obtained from HAP)))
|
||||
(h (build-mrph :sorc zgchcm :trgt zgchcm :degr 1 :intr h-intr :strt :gnrt :orgn `(h-mrph for ,group obtained from HAP))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
(build-rdct :f f :g g :h h :orgn `(Resolution of ,group obtained from HAP))))))
|
||||
;;;))))
|
||||
|
||||
(defun FileToString (FileName)
|
||||
(with-open-file (f FileName :direction :input)
|
||||
(labels ((getString (f s)
|
||||
(let* ((aux (read-line f nil 'EOF)))
|
||||
(if (not (string= aux 'EOF))
|
||||
(getString f (concatenate 'string s (if (not (string= s "")) (format nil "~%")) aux))
|
||||
s))))
|
||||
(getString f ""))))
|
||||
|
||||
|
||||
|
||||
#|
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(cat-init)
|
||||
(load "omparsers.lisp")
|
||||
(setf s (filetostring "resolution.log"))
|
||||
(setf rsltn1 (OmparseNextObject s))
|
||||
(setf group (group1 (tcc rsltn1)))
|
||||
(setf (slot-value group 'resolution) rsltn1)
|
||||
(setf k-g-1 (k-g-1 group))
|
||||
(setf k-g-2 (k-g group 2))
|
||||
(setf k-g-3 (k-g group 3))
|
||||
|
||||
(homology k-g-1 0 6)
|
||||
(homology k-g-2 0 6)
|
||||
(homology k-g-3 0 6)
|
||||
|
||||
|
||||
|
||||
(if (equal (OMgetNextLabel s) "OMOBJ")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 7 (search "<OMOBJ>" s))))
|
||||
|
||||
(if (equal (subseq (OMgetNextLabel s) 0 3) "!--")
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 4 (search "--/>" s))))
|
||||
|
||||
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application"))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) "resolution"))
|
||||
(error "This is not specified as a resolution"))
|
||||
|
||||
(OMparseNextSymbol s)
|
||||
|
||||
(setf group (OMparseNextObject s))
|
||||
(setf maxdegr (OMparseNextObject s))
|
||||
(setf rank-list (OMparseNextObject s))
|
||||
(setf zgbasis (OMrsltnZgbasis rank-list maxdegr))
|
||||
|
||||
(setf grcmpr (cmpr1 group) grbasis (elements group) nullel (nullel group))
|
||||
(setf zgcmpr #'s-cmpr)
|
||||
(setf zgboundary-list (OMparseZgboundaryList s grbasis grcmpr zgbasis #'s-cmpr maxdegr))
|
||||
;;(setf cntrchmtp-list (OMparseContractinghmtpList s grbasis grcmpr zgbasis #'s-cmpr maxdegr))
|
||||
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application"))
|
||||
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list"))
|
||||
(OMparseNextSymbol s)
|
||||
|
||||
(setf rslt nil)
|
||||
|
||||
(setf i 0)
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application"))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(OMparseNextSymbol s)
|
||||
(setf rslt-i nil)
|
||||
|
||||
(setf mark1 zgbasis)
|
||||
|
||||
|
||||
(dotimes (i maxdegr)
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt-i nil))
|
||||
(do ((mark1 (funcall zgbasis (1+ i)) (cdr mark1)))
|
||||
((endp mark1) (push rslt-i rslt))
|
||||
|
||||
(if (not (equal (OMgetNextLabel s) "OMA"))
|
||||
(error "The next label is not an application")
|
||||
(progn
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 5 (search "<OMA>" s)))
|
||||
(if (not (equal (OMgetNextSymbol s) 'list))
|
||||
(error "This is not specified as a list")
|
||||
(progn
|
||||
(OMparseNextSymbol s)
|
||||
(let ((rslt-i-g nil))
|
||||
|
||||
(do ((mark2 grbasis (cdr mark2)))
|
||||
((endp mark2) (push rslt-i-g rslt-i))
|
||||
(setf cmbn (OMparseZgcmbn s (1+ i) grbasis grcmpr zgbasis zgcmpr))
|
||||
(push cmbn rslt-i-g))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
))))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
))))))
|
||||
(delete-if #'(lambda (item) t) s :start 0 :end (+ 6 (search "</OMA>" s)))
|
||||
rslt)))))
|
||||
|
||||
|
||||
|
||||
|#
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,454 @@
|
||||
;;; CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS
|
||||
;;; CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS
|
||||
;;; CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS CYLIDERS
|
||||
|
||||
(IN-PACKAGE "COMMON-LISP-USER")
|
||||
|
||||
(PROVIDE "CYCLINDERS")
|
||||
|
||||
|
||||
;; MACROS
|
||||
|
||||
(DEFMACRO CYLNX (CYLN)
|
||||
`(car ,CYLN))
|
||||
|
||||
(DEFMACRO ICYLN (CYLN)
|
||||
`(cdr ,CYLN))
|
||||
|
||||
(DEFMACRO CYLNA1 (gnrt)
|
||||
`(cons :CYLNA1 ,gnrt))
|
||||
|
||||
(DEFMACRO CYLNB (gnrt)
|
||||
`(cons :CYLNB ,gnrt))
|
||||
|
||||
(DEFMACRO CYLNA2 (gnrt)
|
||||
`(cons :CYLNA2 ,gnrt))
|
||||
|
||||
(DEFMACRO WITH-CYLN ((CYLNx iCYLN) CYLN . body)
|
||||
`(let ((,CYLNx (CYLNx ,CYLN))
|
||||
(,iCYLN (iCYLN ,CYLN)))
|
||||
(declare
|
||||
(type (member :CYLNA1 :CYLNB :CYLNA2) ,CYLNx)
|
||||
(type gnrt ,iCYLN))
|
||||
,@body))
|
||||
|
||||
|
||||
(DEFUN DISPATCH-CYLN-CMBN (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the (values cmbn cmbn cmbn)
|
||||
(with-cmbn (degr list) cmbn
|
||||
(let ((listA1 +empty-list+)
|
||||
(listB +empty-list+)
|
||||
(listA2 +empty-list+))
|
||||
(declare (list listA1 listB listA2))
|
||||
(dolist (term list)
|
||||
(declare (type term term))
|
||||
(with-term (cffc cyln) term
|
||||
(with-cyln (cylnx icyln) cyln
|
||||
(ecase cylnx
|
||||
(:cylnA1 (push (term cffc icyln) listA1))
|
||||
(:cylnB (push (term cffc icyln) listB))
|
||||
(:cylnA2 (push (term cffc icyln) listA2))))))
|
||||
(values
|
||||
(make-cmbn :degr (1- degr) :list (nreverse listA1))
|
||||
(make-cmbn :degr degr :list (nreverse listB))
|
||||
(make-cmbn :degr degr :list (nreverse listA2)))))))
|
||||
|
||||
#|
|
||||
(dispatch-CYLN-cmbn (cmbn 3 3 (cylnA1 'a11) 4 (cylnA1 'a12) 33 (cylnB 'b) 333 (cylnA2 'a2)))
|
||||
|#
|
||||
|
||||
(DEFUN CYLN-CMBN-CMBNA1 (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn :degr (1- degr)
|
||||
:list (do ((rslt +empty-list+)
|
||||
(mark list (cdr mark)))
|
||||
((endp mark) (nreverse rslt))
|
||||
(declare (list rslt mark))
|
||||
(with--term (cffc CYLN) mark
|
||||
(with-CYLN (CYLNx gnrtA1) CYLN
|
||||
(if (eq CYLNx :CYLNA1)
|
||||
(push (term cffc gnrtA1) rslt)
|
||||
(return (nreverse rslt))))))))))
|
||||
|
||||
(DEFUN CYLN-CMBN-CMBNB (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn :degr degr
|
||||
:list (do ((rslt +empty-list+)
|
||||
(mark (member :CYLNb list :key #'cadr) (cdr mark)))
|
||||
((endp mark) (nreverse rslt))
|
||||
(declare (list rslt mark))
|
||||
(with--term (cffc CYLN) mark
|
||||
(with-CYLN (CYLNx gnrtB) CYLN
|
||||
(if (eq CYLNx :CYLNB)
|
||||
(push (term cffc gnrtB) rslt)
|
||||
(return (nreverse rslt))))))))))
|
||||
|
||||
(DEFUN CYLN-CMBN-CMBNA2 (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn :degr degr
|
||||
:list (mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term (cffc CYLN) term
|
||||
(term cffc (iCYLN CYLN))))
|
||||
(member :CYLNA2 list :key #'cadr))))))
|
||||
|
||||
#|
|
||||
|
||||
(CYLN-cmbn-cmbnA1 (cmbn 3 1 (CYLNA1 'a) 2 (CYLNB 'b)))
|
||||
(CYLN-cmbn-cmbnA1 (cmbn 3 2 (CYLNB 'b)))
|
||||
(CYLN-cmbn-cmbnB (cmbn 3 1 (CYLNA1 'a) 2 (CYLNB 'b) 3 (CYLNA2 'c)))
|
||||
(CYLN-cmbn-cmbnB (cmbn 3 1 (CYLNA1 'a) 3 (CYLNA2 'c)))
|
||||
(CYLN-cmbn-cmbnA2 (cmbn 3 1 (CYLNA1 'a) 2 (CYLNB 'b) 3 (CYLNA2 'c)))
|
||||
(CYLN-cmbn-cmbnA2 (cmbn 3 2 (CYLNA1 'b)))
|
||||
|#
|
||||
|
||||
(DEFUN MAKE-CYLN-CMBN (cmbnA1 cmbnB cmbnA2)
|
||||
(declare (type cmbn cmbnA1 cmbnB cmbnA2))
|
||||
(the cmbn
|
||||
(with-cmbn (degrA1 listA1) cmbnA1
|
||||
(with-cmbn (degrB listB) cmbnB
|
||||
(with-cmbn (degrA2 listA2) cmbnA2
|
||||
(unless (= (1+ degrA1) degrB degrA2)
|
||||
(error "In MAKE-CYLN-CMBN, the degrees are not coherent."))
|
||||
(make-cmbn :degr degrB
|
||||
:list (nconc
|
||||
(mapcar #'(lambda (termA1)
|
||||
(declare (type term termA1))
|
||||
(with-term (cffc gnrtA1) termA1
|
||||
(term cffc (CYLNA1 gnrtA1))))
|
||||
listA1)
|
||||
(mapcar #'(lambda (termB)
|
||||
(declare (type term termB))
|
||||
(with-term (cffc gnrtB) termB
|
||||
(term cffc (CYLNB gnrtB))))
|
||||
listB)
|
||||
(mapcar #'(lambda (termA2)
|
||||
(declare (type term termA2))
|
||||
(with-term (cffc gnrtA2) termA2
|
||||
(term cffc (CYLNA2 gnrtA2))))
|
||||
listA2))))))))
|
||||
|
||||
#|
|
||||
(multiple-value-call #'make-CYLN-cmbn
|
||||
(dispatch-CYLN-cmbn (cmbn 3 3 (CYLNA1 'A11) 4 (CYLNA1 'A12) 33 (CYLNB 'B) 333 (CYLNA2 'A2))))
|
||||
|#
|
||||
|
||||
(DEFMETHOD PRINT-KEYCONS ((car (eql :CYLNA1)) cdr stream)
|
||||
(declare
|
||||
(type gnrt cdr)
|
||||
(stream stream))
|
||||
(the (eql t)
|
||||
(progn
|
||||
(format stream "<CylnA1 ~A>" cdr)
|
||||
t)))
|
||||
|
||||
(DEFMETHOD PRINT-KEYCONS ((car (eql :CYLNB)) cdr stream)
|
||||
(declare
|
||||
(type gnrt cdr)
|
||||
(stream stream))
|
||||
(the (eql t)
|
||||
(progn
|
||||
(format stream "<CylnB ~A>" cdr)
|
||||
t)))
|
||||
|
||||
(DEFMETHOD PRINT-KEYCONS ((car (eql :CYLNA2)) cdr stream)
|
||||
(declare
|
||||
(type gnrt cdr)
|
||||
(stream stream))
|
||||
(the (eql t)
|
||||
(progn
|
||||
(format stream "<CylnA2 ~A>" cdr)
|
||||
t)))
|
||||
|
||||
#|
|
||||
(CYLNa1 'a)
|
||||
(CYLNB 'b)
|
||||
(CYLNA2 'c)
|
||||
|#
|
||||
|
||||
(DEFUN cylnX-CMPR (s1 s2)
|
||||
(declare (symbol s1 s2))
|
||||
(the cmpr
|
||||
(if (string= s1 s2) :equal
|
||||
(if (string= s1 :cylnA1) :less
|
||||
(if (string= s2 :cylnA1) :greater
|
||||
(if (string= s1 :cylnB) :less
|
||||
:greater))))))
|
||||
|
||||
|
||||
(DEFUN CYLINDER-CMPR (cmprA cmprB)
|
||||
(declare (type cmprf cmpra cmprb))
|
||||
(flet ((rslt (cyln1 cyln2)
|
||||
(declare (type cyln cyln1 cyln2))
|
||||
(let ((cylnx1 (cylnx cyln1)))
|
||||
(declare (type (member :cylnA1 :cylnB :cylnA2) cylnx))
|
||||
(lexico
|
||||
(cylnX-CMPR cylnx1 (cylnx cyln2))
|
||||
(case cylnx1
|
||||
(:cylnA1 (funcall cmprA (icyln cyln1) (icyln cyln2)))
|
||||
(:cylnB (funcall cmprB (icyln cyln1) (icyln cyln2)))
|
||||
(:cylnA2 (funcall cmprA (icyln cyln1) (icyln cyln2))))))))
|
||||
(the cmprf #'rslt)))
|
||||
|
||||
#|
|
||||
(setf r (cylinder-cmpr #'f-cmpr #'f-cmpr ))
|
||||
(funcall r (cylnA1 1) (cylnB 0))
|
||||
(funcall r (cylnA1 1) (cylnA1 2))
|
||||
(funcall r (cylnB 0) (cylnA1 1))
|
||||
(funcall r (cylnA1 2) (cylnA1 1))
|
||||
|#
|
||||
|
||||
(DEFUN CYLINDER-BASIS (basisA basisB)
|
||||
(declare (type basis basisA basisB))
|
||||
(the basis
|
||||
(if (or (eq :locally-effective basisA)
|
||||
(eq :locally-effective basisB)
|
||||
)
|
||||
:locally-effective
|
||||
(flet ((rslt (degr)
|
||||
(declare (fixnum degr))
|
||||
(append
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(cylnA1 item))
|
||||
(funcall basisA (1- degr)))
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(cylnB item))
|
||||
(funcall basisB degr))
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(cylnA2 item))
|
||||
(funcall basisA degr)))))
|
||||
(the basis #'rslt)))))
|
||||
|
||||
#|
|
||||
(CYLINDER-basis :locally-effective :locally-effective )
|
||||
(setf b #'(lambda (degr) (mapcar #'(lambda (item) (cons degr item)) (<a-b> 0 degr))))
|
||||
(setf r (CYLINDER-basis b b))
|
||||
(funcall r 3)
|
||||
|#
|
||||
|
||||
(DEFUN CYLINDER-INTR-DFFR (cmprA cmprB dffrA dffrB f)
|
||||
(declare
|
||||
(type cmprf cmprA cmprB)
|
||||
(type morphism dffrA dffrB f))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(multiple-value-bind (cmbnA1 cmbnB cmbnA2) (dispatch-cyln-cmbn cmbn)
|
||||
(declare (type cmbn cmbnA1 cmbnB cmbnA2))
|
||||
(let ((dffrA1-cmbn (cmbn-? dffrA cmbnA1))
|
||||
(dffrB-cmbn (cmbn-? dffrB cmbnB))
|
||||
(dffrA2-cmbn (cmbn-? dffrA cmbnA2))
|
||||
(f-cmbn (cmbn-? f cmbnA1))
|
||||
)
|
||||
(declare (type cmbn dffrA1-cmbn dffrB-cmbn dffrA2-cmbn f-cmbn))
|
||||
(let ((cmbnB (2cmbn-add cmprB f-cmbn dffrB-cmbn))
|
||||
(cmbnA2 (2cmbn-sbtr cmprA dffrA2-cmbn cmbnA1)))
|
||||
(declare (type cmbn cmbnB cmbnA2))
|
||||
(make-cyln-cmbn (cmbn-opps dffrA1-cmbn) cmbnB cmbnA2)))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
|
||||
(DEFUN CYLINDER (f)
|
||||
(declare (type morphism f))
|
||||
(the chain-complex
|
||||
(with-slots (sorc trgt) f
|
||||
(declare
|
||||
(type chain-complex sorc trgt ))
|
||||
(let ((rslt (build-chcm
|
||||
:cmpr (cylinder-cmpr (cmpr sorc) (cmpr trgt))
|
||||
:basis (cylinder-basis (basis sorc) (basis trgt))
|
||||
:bsgn :undefined
|
||||
:intr-dffr (cylinder-intr-dffr (cmpr sorc) (cmpr trgt)
|
||||
(dffr sorc) (dffr trgt) f)
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder ,f))))
|
||||
(declare (type chain-complex rslt))
|
||||
(slot-makunbound rslt 'bsgn)
|
||||
rslt))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(defun cylinder-rrdct (f)
|
||||
(declare (type morphism f))
|
||||
(the reduction
|
||||
(with-slots (sorc (Bcc trgt)) f
|
||||
(with-slots ((cmprb cmpr)) Bcc
|
||||
(let ((cylinder (cylinder f)))
|
||||
(let ((rf (build-mrph
|
||||
:sorc cylinder :trgt Bcc :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(2cmbn-add cmprB (cyln-cmbn-cmbnB cmbn) (cmbn-? f (cyln-cmbn-cmbnA2 cmbn))))
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder ,f rf)))
|
||||
(rg (build-mrph
|
||||
:sorc Bcc :trgt cylinder :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(let* ((cmbnA1 (zero-cmbn (1- (cmbn-degr cmbn))))
|
||||
(cmbnA2 (zero-cmbn (cmbn-degr cmbn))))
|
||||
(declare (type cmbn cmbnA1 cmbnA2))
|
||||
(make-cyln-cmbn cmbnA1 cmbn cmbnA2)))
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder ,f rg)))
|
||||
(rh (build-mrph
|
||||
:sorc cylinder :trgt cylinder :degr +1
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(let* ((cmbnA1 (cmbn-opps (cyln-cmbn-cmbnA2 cmbn)))
|
||||
(cmbnB (zero-cmbn (1+ (cmbn-degr cmbn))))
|
||||
(cmbnA2 (zero-cmbn (1+ (cmbn-degr cmbn)))))
|
||||
(declare (type cmbn cmbnA1 cmbnB cmbnA2))
|
||||
(make-cyln-cmbn cmbnA1 cmbnB cmbnA2)))
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder ,f rh))))
|
||||
(declare
|
||||
(type chain-complex cylinder)
|
||||
(type morphism rf rg rh))
|
||||
(build-rdct :f rf :g rg :h rh :orgn `(cylinder right reduction ,f))))))))
|
||||
|
||||
|
||||
(defun cylinder-lrdct (f g h k)
|
||||
(declare (type morphism f g h k))
|
||||
(the reduction
|
||||
(with-slots ((Acc sorc) (Bcc trgt)) f
|
||||
(with-slots ((cmprA cmpr)) Acc
|
||||
(with-slots ((cmprb cmpr)) Bcc
|
||||
(let ((cylinder (cylinder f)))
|
||||
(let ((lf (build-mrph
|
||||
:sorc cylinder :trgt Acc :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(2cmbn-sbtr cmprA
|
||||
(2cmbn-add cmpra (cyln-cmbn-cmbnA2 cmbn) (cmbn-? g (cyln-cmbn-cmbnB cmbn)))
|
||||
(cmbn-? h (cyln-cmbn-cmbnA1 cmbn))))
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder hmtpeq ,f lf)))
|
||||
(lg (build-mrph
|
||||
:sorc Acc :trgt cylinder :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(let* ((cmbnA1 (zero-cmbn (1- (cmbn-degr cmbn))))
|
||||
(cmbnB (zero-cmbn (cmbn-degr cmbn)))
|
||||
)
|
||||
(declare (type cmbn cmbnA1 cmbnB ))
|
||||
(make-cyln-cmbn cmbnA1 cmbnB cmbn)))
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder hmtpeq ,f lg)))
|
||||
(lh (build-mrph
|
||||
:sorc cylinder :trgt cylinder :degr +1
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(multiple-value-bind (cmbnA1 cmbnB cmbnA2)
|
||||
(dispatch-cyln-cmbn cmbn)
|
||||
(let* ((cmbnA11 (cmbn-opps (cmbn-? h cmbnA1)))
|
||||
(cmbnA12 (cmbn-opps (cmbn-? g (cmbn-? k (cmbn-? f cmbnA1)))))
|
||||
(cmbnA13 (cmbn-? g (cmbn-? f (cmbn-? h cmbnA1))))
|
||||
(cmbnA14 (cmbn-? g cmbnB))
|
||||
(cmbnB1 (cmbn-opps (cmbn-? k (cmbn-? k (cmbn-? f cmbnA1)))))
|
||||
(cmbnB2 (cmbn-? k (cmbn-? f (cmbn-? h cmbnA1))))
|
||||
(cmbnB3 (cmbn-? k cmbnB))
|
||||
(cmbnA21 (cmbn-opps (cmbn-? h (cmbn-? h cmbnA1))))
|
||||
(cmbnA22 (cmbn-opps (cmbn-? h (cmbn-? g (cmbn-? k (cmbn-? f cmbnA1))))))
|
||||
(cmbnA23 (cmbn-? h (cmbn-? g (cmbn-? f (cmbn-? h cmbnA1)))))
|
||||
(cmbnA24 (cmbn-? g (cmbn-? k (cmbn-? k (cmbn-? f cmbnA1)))))
|
||||
(cmbnA25 (cmbn-opps (cmbn-? g (cmbn-? k (cmbn-? f (cmbn-? h cmbnA1))))))
|
||||
(cmbnA26 (cmbn-? h (cmbn-? g cmbnB)))
|
||||
(cmbnA27 (cmbn-opps (cmbn-? g (cmbn-? k cmbnB)))))
|
||||
(declare (type cmbn cmbnA11 cmbnA12 cmbnA13 cmbnA14
|
||||
cmbnB1 cmbnB2 cmbnB3
|
||||
cmbnA21 cmbnA22 cmbnA23 cmbnA24 cmbnA25 cmbnA26 cmbnA27))
|
||||
(make-cyln-cmbn (ncmbn-add cmprA cmbnA11 cmbnA12 cmbnA13 cmbnA14)
|
||||
(ncmbn-add cmprB cmbnB1 cmbnB2 cmbnB3)
|
||||
(ncmbn-add cmprA cmbnA21 cmbnA22 cmbnA23 cmbnA24 cmbnA25 cmbnA26 cmbnA27)))))
|
||||
|
||||
:strt :cmbn
|
||||
:orgn `(cylinder hmtpeq ,f lh))))
|
||||
(declare
|
||||
(type chain-complex cylinder)
|
||||
(type morphism lf lg lh))
|
||||
(build-rdct :f lf :g lg :h lh :orgn `(cylinder left reduction ,f)))))))))
|
||||
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf z3 (cyclicgroup 3))
|
||||
|
||||
(setf rsltn1 (cyclicgroup-rsltn 3))
|
||||
(setf rsltn2 (bar-rsltn z3))
|
||||
(setf f (zgmrph-twi (2rsltn-zgmrph rsltn1 rsltn2)))
|
||||
(setf g (zgmrph-twi (2rsltn-zgmrph rsltn2 rsltn1)))
|
||||
(setf h (zgmrph-twi (2rsltn-hmtpop rsltn1 rsltn2)))
|
||||
(setf k (zgmrph-twi (2rsltn-hmtpop rsltn2 rsltn1)))
|
||||
(setf Acc (sorc f) Bcc (trgt f))
|
||||
|
||||
|
||||
(setf rrdct (cylinder-rrdct f))
|
||||
(setf lrdct (cylinder-lrdct f g h k))
|
||||
|
||||
(setf lf (f lrdct) lg (g lrdct) lh (h lrdct))
|
||||
(setf rf (f rrdct) rg (g rrdct) rh (h rrdct))
|
||||
|
||||
(pre-check-rdct rrdct)
|
||||
(setf *tc* (cmbn 3 1 (cylnA1 2) 10 (cylnB '(1 2 1)) 100 (cylnA2 3)))
|
||||
(setf *bc* (cmbn 3 1 '(1 1 2)))
|
||||
(check-rdct)
|
||||
(setf *tc* (cmbn 4 10 (cylnB '(1 2 1 1)) 5 (cylnB '(1 2 2 1)) 100 (cylnA2 4)))
|
||||
(setf *bc* (cmbn 2 5 '(1 1) 7 '(2 1) -4 '(2 2)))
|
||||
(check-rdct)
|
||||
|
||||
|
||||
(pre-check-rdct lrdct)
|
||||
|
||||
(setf *tc* (cmbn 3 1 (cylnA1 2) 10 (cylnB '(1 2 1)) 100 (cylnA2 3)))
|
||||
(setf *bc* (cmbn 3 1 3))
|
||||
(check-rdct)
|
||||
|
||||
(setf *tc* (cmbn 4 10 (cylnB '(1 2 1 1)) 5 (cylnB '(1 2 2 1)) 100 (cylnA2 4)))
|
||||
(setf *bc* (cmbn 2 1 2))
|
||||
(check-rdct)
|
||||
|#
|
||||
|
||||
|
||||
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'k-g-1)))
|
||||
(declare (type simplicial-group smst))
|
||||
(the homotopy-equivalence
|
||||
(let* ((group (second (orgn smst)))
|
||||
(rsltn1 (bar-rsltn group))
|
||||
(rsltn2 (resolution group))
|
||||
(f (zgmrph-twi (2rsltn-zgmrph rsltn1 rsltn2)))
|
||||
(g (zgmrph-twi (2rsltn-zgmrph rsltn2 rsltn1)))
|
||||
(h (zgmrph-twi (2rsltn-hmtpop rsltn1 rsltn2)))
|
||||
(k (zgmrph-twi (2rsltn-hmtpop rsltn2 rsltn1)))
|
||||
(rrdct (cylinder-rrdct f))
|
||||
(lrdct (cylinder-lrdct f g h k)))
|
||||
(build-hmeq :lrdct lrdct :rrdct rrdct :orgn `(efhm of ,smst)))))
|
||||
|
||||
#|
|
||||
(setf z3 (cyclicgroup 3))
|
||||
(setf k-z3-1 (k-g-1 z3))
|
||||
|
||||
(cat-init)
|
||||
(setf z4 (cyclicgroup 4))
|
||||
(setf k-z4-1 (k-g-1 z4))
|
||||
(setf k-z4-2 (classifying-space k-z4-1))
|
||||
|
||||
(cat-init)
|
||||
(setf z2 (cyclicgroup 2))
|
||||
(setf k-z2-1 (k-g-1 z2))
|
||||
(setf k-z2-2 (classifying-space k-z2-1))
|
||||
|#
|
||||
|
||||
@ -0,0 +1,173 @@
|
||||
;; Fundamental classes
|
||||
(IN-PACKAGE "COMMON-LISP-USER")
|
||||
|
||||
|
||||
(DEFUN Zp-FUNDAMENTAL-GMSM (p dmns pi-elm) ;; pi-elm not "equal" to 0
|
||||
(declare (fixnum dmns pi-elm))
|
||||
(the gmsm
|
||||
(if (= 1 dmns)
|
||||
(list pi-elm)
|
||||
(let ((bspn (if (= 2 dmns) nil +null-gbar+)))
|
||||
(declare (type gmsm bspn))
|
||||
(make-gbar :dmns dmns
|
||||
:list (cons (absm 0 (Zp-fundamental-gmsm p (1- dmns) pi-elm))
|
||||
(mapcar
|
||||
#'(lambda (k)
|
||||
(declare (fixnum k))
|
||||
(absm (mask k) bspn))
|
||||
(nreverse (<a-b> 0 (- dmns 2))))))))))
|
||||
#|
|
||||
|
||||
(Zp-fundamental-gmsm 2 1 1)
|
||||
(Zp-fundamental-gmsm 2 2 1)
|
||||
(Zp-fundamental-gmsm 2 3 1)
|
||||
(Zp-fundamental-gmsm 2 4 1)
|
||||
|
||||
(Zp-fundamental-gmsm 5 1 1)
|
||||
(Zp-fundamental-gmsm 5 4 1)
|
||||
|
||||
|#
|
||||
|
||||
|
||||
(DEFUN Zp-COCYCLE-GBAR (p n dmns cocycle)
|
||||
;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z/pZ
|
||||
(declare
|
||||
(fixnum p n dmns)
|
||||
(list cocycle))
|
||||
(the absm
|
||||
(progn
|
||||
(mapc
|
||||
#'(lambda (cons)
|
||||
(declare (cons cons))
|
||||
(setf (cdr cons)
|
||||
(mod (cdr cons) p)))
|
||||
cocycle)
|
||||
(cond ((= n 1)
|
||||
(g-bar-absm (cyclicgroup p) (nreverse (mapcar #'cdr cocycle))))
|
||||
((= n dmns)
|
||||
(let ((value (cdr (first cocycle))))
|
||||
(declare (fixnum value))
|
||||
(if (zerop value)
|
||||
(absm (mask dmns) +null-gbar+)
|
||||
(absm 0 (zp-fundamental-gmsm p dmns value)))))
|
||||
(t
|
||||
(let ((cocycle1 +empty-list+)
|
||||
(cocycle2 +empty-list+))
|
||||
(declare (list cocycle1 cocycle2))
|
||||
(dolist (cons cocycle)
|
||||
(declare (cons cons))
|
||||
(if (evenp (car cons))
|
||||
(push (cons (ash (car cons) -1) (cdr cons))
|
||||
cocycle1)
|
||||
(push (cons (ash (car cons) -1) (cdr cons))
|
||||
cocycle2)))
|
||||
(setf cocycle1 (nreverse cocycle1)
|
||||
cocycle2 (nreverse cocycle2))
|
||||
(mapc
|
||||
#'(lambda (cons)
|
||||
(declare (cons cons))
|
||||
(when (evenp (car cons))
|
||||
(setf (cdr cons)
|
||||
(mod (- (cdr cons)
|
||||
(cdr (assoc (1+ (car cons)) cocycle1)))
|
||||
p))))
|
||||
cocycle2)
|
||||
(let ((head-absm (zp-cocycle-gbar p (1- n) (1- dmns) cocycle2))
|
||||
(tail-absm (zp-cocycle-gbar p n (1- dmns) cocycle1)))
|
||||
(declare (type absm head-absm tail-absm))
|
||||
(normalize-gbar
|
||||
(cons dmns
|
||||
(cons head-absm
|
||||
(rest (unnormalize-gbar tail-absm
|
||||
(if (= n 2) () +null-gbar+)))))))))))))
|
||||
|
||||
|
||||
(DEFUN Zp-COCYCLE-GBAR-HEAD (p n dmns cocycle)
|
||||
;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z/pZ
|
||||
(declare
|
||||
(fixnum n dmns)
|
||||
(list cocycle))
|
||||
(the absm
|
||||
(progn
|
||||
(mapc
|
||||
#'(lambda (cons)
|
||||
(declare (cons cons))
|
||||
(setf (cdr cons)
|
||||
(mod (cdr cons) p)))
|
||||
cocycle)
|
||||
(cond ((= n 1)
|
||||
(error "In Zp-COCYCLE-GBAR-HEAD, this point should not have been reached."))
|
||||
; (zp-bar-absm (nreverse (mapcar #'cdr cocycle))))
|
||||
((= n dmns)
|
||||
(let ((value (cdr (first cocycle))))
|
||||
(declare (fixnum value))
|
||||
(if (zerop value)
|
||||
(if (= n 2)
|
||||
(absm 1 +empty-list+)
|
||||
(absm (mask (1- dmns)) +null-gbar+))
|
||||
(absm 0 (zp-fundamental-gmsm p (1- dmns) value)))))
|
||||
(t
|
||||
(let ((cocycle1 +empty-list+)
|
||||
(cocycle2 +empty-list+))
|
||||
(declare (list cocycle1 cocycle2))
|
||||
(dolist (cons cocycle)
|
||||
(declare (cons cons))
|
||||
(if (evenp (car cons))
|
||||
(push (cons (ash (car cons) -1) (cdr cons))
|
||||
cocycle1)
|
||||
(push (cons (ash (car cons) -1) (cdr cons))
|
||||
cocycle2)))
|
||||
(setf cocycle1 (nreverse cocycle1)
|
||||
cocycle2 (nreverse cocycle2))
|
||||
(mapc
|
||||
#'(lambda (cons)
|
||||
(declare (cons cons))
|
||||
(when (evenp (car cons))
|
||||
(setf (cdr cons)
|
||||
(mod (- (cdr cons)
|
||||
(cdr (assoc (1+ (car cons)) cocycle1)))
|
||||
p))))
|
||||
cocycle2)
|
||||
(zp-cocycle-gbar p (1- n) (1- dmns) cocycle2)))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(DEFUN Zp-WHITEHEAD-SINTR (p smst n chml-clss
|
||||
&aux (face (face smst))
|
||||
(k-zp-n-1 (k-zp p (1- n)))
|
||||
(idnt (bspn k-zp-n-1))
|
||||
(efhm (efhm smst)))
|
||||
(declare
|
||||
(type simplicial-set smst)
|
||||
(fixnum n)
|
||||
(type morphism chml-clss)
|
||||
(type face face)
|
||||
(type ab-simplicial-group k-zp-n-1)
|
||||
(type gmsm idnt)
|
||||
(type homotopy-equivalence efhm))
|
||||
(setf chml-clss
|
||||
(i-cmps chml-clss (rf efhm) (lg efhm)))
|
||||
(flet ((rslt (dmns gmsm)
|
||||
(declare
|
||||
(fixnum dmns)
|
||||
(type gmsm gmsm))
|
||||
(if (< dmns n)
|
||||
(absm (mask (1- dmns)) idnt)
|
||||
(zp-cocycle-gbar-head p n dmns
|
||||
(gmsm-cocycle face n dmns gmsm chml-clss)))))
|
||||
(the sintr #'rslt)))
|
||||
|
||||
(DEFUN Zp-WHITEHEAD (p smst chml-clss &aux (n (- (degr chml-clss))))
|
||||
(declare
|
||||
(type simplicial-set smst)
|
||||
(fixnum p n)
|
||||
(type morphism chml-clss))
|
||||
(the fibration
|
||||
(build-smmr
|
||||
:sorc smst :trgt (k-zp p (1- n)) :degr -1
|
||||
:sintr (Zp-whitehead-sintr p smst n chml-clss)
|
||||
:orgn `(Zp-whitehead ,p ,smst))))
|
||||
|
||||
|
||||
@ -0,0 +1,153 @@
|
||||
|
||||
(defun permgr-elements (l)
|
||||
(declare (type 'list l))
|
||||
(let* ((n (length (first l)))
|
||||
(end nil)
|
||||
(rslt (list (<a-b> 1 n))))
|
||||
|
||||
(while (not end)
|
||||
(progn
|
||||
(setf end t)
|
||||
(mapcar #'(lambda (p)
|
||||
(progn
|
||||
(mapcar #'(lambda (p2)
|
||||
(let ((p*p2 (permgr-mult p p2))
|
||||
(pos -1))
|
||||
(do ((j 0 (1+ j)))
|
||||
((or (not (equal pos -1)) (>= j (length rslt))))
|
||||
(if (equal (l-cmpr p*p2 (nth j rslt)) :less)
|
||||
(setf pos j)
|
||||
(if (equal (l-cmpr p*p2 (nth j rslt)) :equal)
|
||||
(setf pos -2)
|
||||
(if (and (equal j (1- (length rslt))) (equal pos -1))
|
||||
(setf pos (length rslt))))))
|
||||
(if (> pos -1)
|
||||
(progn
|
||||
(setf rslt (append (subseq rslt 0 pos) (list p*p2) (subseq rslt pos (length rslt))))
|
||||
(setf end nil))))
|
||||
|
||||
(let ((p2*p (permgr-mult p2 p))
|
||||
(pos -1))
|
||||
(do ((j 0 (1+ j)))
|
||||
((or (not (equal pos -1)) (>= j (length rslt))))
|
||||
(if (equal (l-cmpr p2*p (nth j rslt)) :less)
|
||||
(setf pos j)
|
||||
(if (equal (l-cmpr p2*p (nth j rslt)) :equal)
|
||||
(setf pos -2)
|
||||
(if (and (equal j (1- (length rslt))) (equal pos -1))
|
||||
(setf pos (length rslt))))))
|
||||
(if (> pos -1)
|
||||
(progn
|
||||
(setf rslt (append (subseq rslt 0 pos) (list p2*p) (subseq rslt pos (length rslt))))
|
||||
(setf end nil)))
|
||||
|
||||
|
||||
))
|
||||
rslt)
|
||||
))
|
||||
l)))
|
||||
rslt))
|
||||
|
||||
|
||||
|
||||
#|
|
||||
(permgr-elements (list '(2 3 1) '(2 1 3)))
|
||||
(permgr-elements (list '(2 3 4 1) '(2 1 3 4)))
|
||||
(permgr-elements (list '(2 3 4 5 1) '(2 1 3 4 5)))
|
||||
|
||||
|#
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(defun permgr-mult (p1 p2)
|
||||
(declare (type 'list p1 p2))
|
||||
(mapcar #'(lambda (i)
|
||||
(nth (1- i) p2))
|
||||
p1))
|
||||
|
||||
#|
|
||||
(permgr-mult '(1 3 2) '(1 2 3))
|
||||
(permgr-mult '(1 5 4 3 2) '(1 2 3 5 4))
|
||||
|#
|
||||
|
||||
(defun permgr-inv (p1)
|
||||
(declare (type 'list p1))
|
||||
(mapcar #'(lambda (i)
|
||||
(1+ (position i p1)))
|
||||
(<a-b> 1 (length p1))))
|
||||
|
||||
#|
|
||||
(permgr-inv '(1 3 2 5 4))
|
||||
(permgr-mult '(1 3 2 5 4) '(1 3 2 5 4))
|
||||
(permgr-mult '(1 5 2 3 4) (permgr-inv '(1 5 2 3 4)))
|
||||
(permgr-mult '(5 4 3 1 2) (permgr-inv '(5 4 3 1 2)))
|
||||
|#
|
||||
|
||||
|
||||
|
||||
(defun permutationgroup (l)
|
||||
(declare (type 'list l))
|
||||
(build-group :elements (permgr-elements l)
|
||||
:cmpr #'l-cmpr
|
||||
:mult #'permgr-mult
|
||||
:inv #'permgr-inv
|
||||
:nullel (<a-b> 1 (length (first l))) :orgn `(Permutation group generated by ,l)
|
||||
))
|
||||
|
||||
|
||||
#|
|
||||
(setf s3 (permutationgroup (list '(2 3 1) '(2 1 3))))
|
||||
|#
|
||||
|
||||
|
||||
|
||||
(defun symmetricgroup (n)
|
||||
(let* ((l (list (append (<a-b> 2 n) (list 1)) (append (list 2 1) (<a-b> 3 n))))
|
||||
(rslt (permutationgroup l)))
|
||||
(setf (slot-value rslt 'orgn) `(Symmetric group ,n))
|
||||
rslt))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf s3 (symmetricgroup 3))
|
||||
(elements s3)
|
||||
|
||||
(setf s4 (symmetricgroup 4))
|
||||
(elements s4)
|
||||
|
||||
|
||||
|
||||
|
||||
|#
|
||||
|
||||
|
||||
|
||||
(defun alternatinggroup (n)
|
||||
(let* ((l (list
|
||||
(if (or (eq n 1) (eq n 2)) nil
|
||||
(if (eq n 3) (list '(2 3 1))
|
||||
(if (oddp n) (list (append (<a-b> 2 n) (list 1)) (append (<a-b> 1 (- n 3)) (list (1- n) n (- n 2))))
|
||||
(list (append (<a-b> 2 (1- n)) (list 1 n)) (append (<a-b> 1 (- n 3)) (list (1- n) n (- n 2)))))))))
|
||||
(rslt (permutationgroup l)))
|
||||
(setf (slot-value rslt 'orgn) `(Alternating group ,n))
|
||||
rslt))
|
||||
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf a3 (alternatinggroup 3))
|
||||
(elements a3)
|
||||
|
||||
(setf a4 (alternatinggroup 4))
|
||||
(elements a4)
|
||||
|
||||
|
||||
|
||||
|#
|
||||
|
||||
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user