Start interface with sage and homotopy
This commit is contained in:
parent
5d80fe983b
commit
a80dd83a67
GPG Key ID:
DD0114EDB7410592
11
kenzo.asd
11
kenzo.asd
@ -56,11 +56,16 @@
|
||||
(:file "cl-space-efhm")
|
||||
(:file "whitehead")
|
||||
(:file "smith")
|
||||
#|
|
||||
(:file "sage-interface")
|
||||
|
||||
(:module "anromero"
|
||||
:components
|
||||
((:file "bicomplexes")
|
||||
(:file "filtered-complexes")
|
||||
(:file "spectral-sequences")))
|
||||
|#
|
||||
(:file "spectral-sequences")
|
||||
(:file "resolutions")
|
||||
(:file "cylinders")
|
||||
(:file "fundamental-classes")
|
||||
(:file "homotopy")))
|
||||
|
||||
))))
|
||||
|
||||
133
package.lisp
133
package.lisp
@ -4,6 +4,10 @@
|
||||
(:use #:cl)
|
||||
(:export #:KENZO-VERSION
|
||||
|
||||
;; sage-interface.lisp
|
||||
|
||||
#:ITOA
|
||||
|
||||
;; kenzo.lisp
|
||||
|
||||
#:*BC*
|
||||
@ -600,4 +604,133 @@
|
||||
#:Z2-WHITEHEAD
|
||||
#:Z2-WHITEHEAD-SINTR
|
||||
|
||||
;; anromero
|
||||
|
||||
|
||||
;; cylinders.lisp
|
||||
|
||||
#:DISPATCH-CYLN-CMBN
|
||||
#:CYLN-CMBN-CMBNA1
|
||||
#:CYLN-CMBN-CMBNB
|
||||
#:CYLN-CMBN-CMBNA2
|
||||
#:MAKE-CYLN-CMBN
|
||||
#:CYLNX-CMPR
|
||||
#:CYLINDER-CMPR
|
||||
#:CYLINDER-BASIS
|
||||
#:CYLINDER-INTR-DFFR
|
||||
#:CYLINDER
|
||||
#:CYLINDER-RRDCT
|
||||
#:CYLINDER-LRDCT
|
||||
|
||||
#:CYLNX
|
||||
#:ICYLN
|
||||
#:CYLNA1
|
||||
#:CYLNB
|
||||
#:CYLNA2
|
||||
#:WITH-CYLN
|
||||
|
||||
|
||||
;; resolutions.lisp
|
||||
|
||||
#:ZGGNRT-P
|
||||
#:ZGTERM-P
|
||||
#:IZGCMBN-P
|
||||
#:ZGCMBN-P
|
||||
#:GROUP
|
||||
#:AB-GROUP
|
||||
#:GROUP-MRPH
|
||||
#:ZGCC
|
||||
#:ZGMRPH
|
||||
#:BUILD-GROUP
|
||||
#:BUILD-GRMR
|
||||
#:ZGGNRT-CMPR
|
||||
#:ZGCHCM-BASIS
|
||||
#:ZGMRPH-GNRT-GNRT
|
||||
#:ZGMRPH-GNRT-ZGGNRT
|
||||
#:ZGMRPH-GNRT-ZGCMBN
|
||||
#:ZGMRPH-ZGGNRT-ZGGNRT
|
||||
#:ZGMRPH-ZGGNRT-ZGCMBN
|
||||
#:ZGMRPH-GNRT-?
|
||||
#:ZGMRPH-ZGGNRT-?
|
||||
#:ZGMRPH-ZGCMBN-?
|
||||
#:IZGMRPH-IMRPH
|
||||
#:INTR-ZGCHCM-MRPH
|
||||
#:BUILD-ZGCHCM
|
||||
#:BUILD-ZGMRPH
|
||||
#:ZGCMBN-TWI
|
||||
#:ZGMRPH-TWI-INTR
|
||||
#:ZGMRPH-TWI
|
||||
#:CHCM-TWI
|
||||
#:CYCLICGROUP
|
||||
#:Z-GROUP
|
||||
#:CYCLICGROUP-ZGCHCM
|
||||
#:CYCLICGROUP-RSLTN
|
||||
#:BAR-ZGCMPR
|
||||
#:BAR-ZGBASIS
|
||||
#:BAR-BNDR-I
|
||||
#:BAR-BNDR-INTR
|
||||
#:BAR-ZGCHCM
|
||||
#:BAR-CNTRHMTP-INTR
|
||||
#:BAR-F-INTR
|
||||
#:BAR-G-INTR
|
||||
#:BAR-RSLTN
|
||||
#:K-G-1-CMPR
|
||||
#:K-G-1-BASIS
|
||||
#:K-G-1-FACE
|
||||
#:G-ABSM-BAR
|
||||
#:G-BAR-ABSM
|
||||
#:K-G-1-GRML
|
||||
#:K-G-1-GRIN
|
||||
#:K-G-0-BASIS
|
||||
#:K-G-0-FACE
|
||||
#:K-G-0-GRML
|
||||
#:K-G-0-GRIN
|
||||
#:K-ZP-1
|
||||
#:K-ZP
|
||||
#:UNIV-FBRT-INTR
|
||||
#:UNIV-FBRT-TW
|
||||
#:RSLTN-ZGCHCM
|
||||
#:RSLTN-CNTRHMTP
|
||||
#:2RSLTN-ZGMRPH-INTR
|
||||
#:2RSLTN-ZGMRPH
|
||||
#:2RSLTN-HMTPOP-INTR
|
||||
#:2RSLTN-HMTPOP
|
||||
#:K-CM-N
|
||||
|
||||
#:ZGGNRT
|
||||
#:ZGGNRT1
|
||||
#:ZGGNRT2
|
||||
#:WITH-ZGGNRT
|
||||
#:ZGTERM
|
||||
#:WITH-ZGTERM
|
||||
#:BUILD-AB-GROUP
|
||||
|
||||
|
||||
|
||||
;; homotopy.lisp
|
||||
|
||||
#:CHCM-HOMOLOGY-FORMAT
|
||||
#:HOMOLOGY-FORMAT
|
||||
#:FIRST-NON-NULL-HOMOLOGY-GROUP-AUX
|
||||
#:FIRST-NON-NULL-HOMOLOGY-GROUP
|
||||
#:COMPUTE-HOMOTOPY-Z-XSLT
|
||||
#:COMPUTE-HOMOTOPY-Z2-XSLT
|
||||
#:COMPUTE-HOMOTOPY-ZP-XSLT
|
||||
#:SPLIT-COMPONENTS
|
||||
#:CONSTRUCT-SPACE-ITERATIVE
|
||||
#:COMPUTE-HOMOTOPY-SEVERAL-XSLT
|
||||
#:COMPUTE-HOMOTOPY2-XSLT
|
||||
#:COMPUTE-HOMOTOPY
|
||||
#:HOMOTOPY
|
||||
#:HOMOTOPY-LIST
|
||||
|
||||
;; fundamental-classes.lisp
|
||||
|
||||
#:ZP-FUNDAMENTAL-GMSM
|
||||
#:ZP-COCYCLE-GBAR
|
||||
#:ZP-COCYCLE-GBAR-HEAD
|
||||
#:ZP-WHITEHEAD-SINTR
|
||||
#:ZP-WHITEHEAD
|
||||
|
||||
|
||||
))
|
||||
|
||||
368
src/anromero/cylinders.lisp
Normal file
368
src/anromero/cylinders.lisp
Normal file
@ -0,0 +1,368 @@
|
||||
;;; CYLINDERS CYLINDERS CYLINDERS CYLINDERS CYLINDERS CYLINDERS CYLINDERS
|
||||
;;; CYLINDERS CYLINDERS CYLINDERS CYLINDERS CYLINDERS CYLINDERS CYLINDERS
|
||||
;;; CYLINDERS CYLINDERS CYLINDERS CYLINDERS CYLINDERS CYLINDERS CYLINDERS
|
||||
|
||||
|
||||
(IN-PACKAGE #:cat)
|
||||
|
||||
(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)))))))
|
||||
|
||||
|
||||
(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))))))
|
||||
|
||||
|
||||
(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))))))))
|
||||
|
||||
|
||||
(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)))
|
||||
|
||||
|
||||
(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)
|
||||
(let ((cylnx1 (cylnx cyln1)))
|
||||
(declare (type (member :cylna1 :cylnb :cylna2) cylnx1))
|
||||
(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)))
|
||||
|
||||
|
||||
(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)))))
|
||||
|
||||
|
||||
(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)
|
||||
(ignore cmbna2))
|
||||
(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)))))))))
|
||||
|
||||
|
||||
;; Redefined in file "effective-homotopy"
|
||||
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'k-g-1)))
|
||||
(declare (type simplicial-group smst))
|
||||
(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)))
|
||||
(the homotopy-equivalence
|
||||
(build-hmeq :lrdct lrdct :rrdct rrdct :orgn `(efhm of ,smst)))))
|
||||
|
||||
168
src/anromero/fundamental-classes.lisp
Normal file
168
src/anromero/fundamental-classes.lisp
Normal file
@ -0,0 +1,168 @@
|
||||
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
|
||||
|
||||
;; FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES
|
||||
;; FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES
|
||||
;; FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES FUNDAMENTAL-CLASSES
|
||||
|
||||
|
||||
(IN-PACKAGE #:cat)
|
||||
|
||||
(provide "fundamental-classes")
|
||||
|
||||
|
||||
(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))))))))))
|
||||
|
||||
|
||||
(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))))
|
||||
|
||||
|
||||
193
src/anromero/homotopy.lisp
Normal file
193
src/anromero/homotopy.lisp
Normal file
@ -0,0 +1,193 @@
|
||||
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
|
||||
|
||||
;;; HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY
|
||||
;;; HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY
|
||||
;;; HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY
|
||||
|
||||
;;; Authors: Jonathan Heras and Ana Romero
|
||||
|
||||
(IN-PACKAGE #:cat)
|
||||
|
||||
(provide "homotopy")
|
||||
|
||||
|
||||
(DEFUN CHCM-HOMOLOGY-FORMAT (cc n)
|
||||
(declare (type chain-complex cc) (type fixnum n))
|
||||
(let ((rsl (homologie (chcm-mat cc n) (chcm-mat cc (1+ n))))
|
||||
(str nil))
|
||||
(declare (type list rsl))
|
||||
(dolist (item rsl)
|
||||
(declare (type list item))
|
||||
(setf str (concatenate 'string str (format nil "Z")))
|
||||
(unless (zerop (first item))
|
||||
(setf str (concatenate 'string str (format nil "/~DZ" (first item)))))
|
||||
(setf str (concatenate 'string str " ")))
|
||||
str))
|
||||
|
||||
|
||||
(DEFUN HOMOLOGY-FORMAT (chcm degr1 &optional (degr2 (1+ degr1)))
|
||||
(declare (fixnum degr1 degr2))
|
||||
(let ((result_hom nil))
|
||||
(do ((degr degr1 (1+ degr)))
|
||||
((>= degr degr2))
|
||||
(declare (fixnum degr))
|
||||
(setf result_hom (chcm-homology-format (echcm chcm) degr))
|
||||
(terpri) (clock) (terpri))
|
||||
result_hom))
|
||||
|
||||
|
||||
(DEFUN FIRST-NON-NULL-HOMOLOGY-GROUP-AUX (chcm n limit)
|
||||
(if (> n limit)
|
||||
nil
|
||||
(let ((hf (homology-format chcm n)))
|
||||
(if hf
|
||||
(1- n)
|
||||
(first-non-null-homology-group-aux chcm (1+ n) limit)))))
|
||||
|
||||
|
||||
(DEFUN FIRST-NON-NULL-HOMOLOGY-GROUP (chcm limit)
|
||||
(first-non-null-homology-group-aux chcm 1 limit))
|
||||
|
||||
|
||||
(DEFUN COMPUTE-HOMOTOPY-Z-XSLT (n-hom obj indx)
|
||||
(let* ((ch (chml-clss (eval obj) indx))
|
||||
(fib (z-whitehead (eval obj) (eval ch)))
|
||||
(ft (fibration-total (eval fib)))
|
||||
(result (homology-format (eval ft) (1+ indx))))
|
||||
(if (= (1+ indx) n-hom)
|
||||
(homology-format (eval ft) n-hom)
|
||||
(if (string= "Z " result)
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
|
||||
(compute-homotopy-several-xslt n-hom ft (1+ indx) result)))))))
|
||||
|
||||
|
||||
(DEFUN COMPUTE-HOMOTOPY-Z2-XSLT (n-hom obj indx)
|
||||
(let* ((ch (chml-clss (eval obj) indx))
|
||||
(fib (z2-whitehead (eval obj) (eval ch)))
|
||||
(ft (fibration-total (eval fib)))
|
||||
(result (homology-format (eval ft) (1+ indx))))
|
||||
(if (= (1+ indx) n-hom)
|
||||
(homology-format (eval ft) n-hom)
|
||||
(if (string= "Z " result)
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
|
||||
(compute-homotopy-several-xslt n-hom ft (1+ indx) result)))))))
|
||||
|
||||
|
||||
(DEFUN COMPUTE-HOMOTOPY-ZP-XSLT (n-hom obj indx n)
|
||||
(let* ((ch (chml-clss (eval obj) indx))
|
||||
(fib (zp-whitehead n (eval obj) (eval ch)))
|
||||
(ft (fibration-total (eval fib)))
|
||||
(result (homology-format (eval ft) (1+ indx))))
|
||||
(if (= (1+ indx) n-hom)
|
||||
(homology-format (eval ft) n-hom)
|
||||
(if (string= "Z " result)
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
|
||||
(compute-homotopy-several-xslt n-hom ft (1+ indx) result)))))))
|
||||
|
||||
|
||||
(DEFUN SPLIT-COMPONENTS (string)
|
||||
(let ((term (if (string= string "") "" (subseq string 0 2))))
|
||||
(if (string= term "Z ")
|
||||
(cons 1 (split-components (subseq string 2)))
|
||||
(if (string= term "Z/")
|
||||
(cons (read-from-string (subseq string 2 (search "Z" string :start2 2)))
|
||||
(split-components (subseq string (+ 2 (search "Z" string :start2 2)))))
|
||||
nil))))
|
||||
|
||||
|
||||
(DEFUN CONSTRUCT-SPACE-ITERATIVE (chcm list indx)
|
||||
(if (endp list)
|
||||
chcm
|
||||
(cond ((equal (car list) 1) (let* ((ch (chml-clss chcm indx))
|
||||
(fib (z-whitehead chcm ch))
|
||||
(ft (fibration-total fib)))
|
||||
(construct-space-iterative ft (cdr list) indx)))
|
||||
((equal (car list) 2) (let* ((ch (chml-clss chcm indx))
|
||||
(fib (z2-whitehead chcm ch))
|
||||
(ft (fibration-total fib)))
|
||||
(construct-space-iterative ft (cdr list) indx)))
|
||||
(t (let* ((ch (chml-clss chcm indx))
|
||||
(fib (zp-whitehead (car list) chcm ch))
|
||||
(ft (fibration-total fib)))
|
||||
(construct-space-iterative ft (cdr list) indx)))
|
||||
)))
|
||||
|
||||
|
||||
(DEFUN COMPUTE-HOMOTOPY-SEVERAL-XSLT (n-hom obj indx hom)
|
||||
(let* ((ft (construct-space-iterative obj (split-components hom) indx))
|
||||
(result (homology-format ft (1+ indx))))
|
||||
(if (= (1+ indx) n-hom)
|
||||
(homology-format (eval ft) n-hom)
|
||||
(if (string= "Z " result)
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
|
||||
(compute-homotopy-several-xslt n-hom ft (1+ indx) result)))))))
|
||||
|
||||
|
||||
(DEFUN COMPUTE-HOMOTOPY2-XSLT (n-hom obj degree hom)
|
||||
(cond
|
||||
((= n-hom 0)
|
||||
(format nil "Z")
|
||||
)
|
||||
((< n-hom (1+ degree) )
|
||||
(format nil ""))
|
||||
((= n-hom (1+ degree))
|
||||
(homology-format (eval obj) n-hom))
|
||||
((string= hom "Z ")
|
||||
(compute-homotopy-z-xslt n-hom obj (1+ degree)))
|
||||
((string= hom "Z/2Z ")
|
||||
(compute-homotopy-z2-xslt n-hom obj (1+ degree)))
|
||||
((and (string= (subseq hom 0 2) "Z/") (string= (subseq hom (search "Z" hom :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom obj (1+ degree) (read-from-string (subseq hom 2 (search "Z" hom :start2 2)))))
|
||||
(t
|
||||
(compute-homotopy-several-xslt n-hom obj (1+ degree) hom))))
|
||||
|
||||
|
||||
(DEFUN COMPUTE-HOMOTOPY (smst n-hom degree)
|
||||
(let ((hom (homology-format smst (1+ degree))))
|
||||
(compute-homotopy2-xslt n-hom smst degree hom)))
|
||||
|
||||
|
||||
|
||||
(DEFUN HOMOTOPY (smst degr)
|
||||
(let (;; we obtain the first non null homology group
|
||||
(first-non-null (first-non-null-homology-group smst degr)))
|
||||
(if first-non-null
|
||||
(progn
|
||||
(let ((result (split-components (compute-homotopy smst degr first-non-null))))
|
||||
(format t "~3%Homotopy in dimension ~D :~%" degr)
|
||||
(dolist (item result)
|
||||
(format t "~2%Component Z")
|
||||
(unless (equal item 1)
|
||||
(format t "/~DZ" item)))
|
||||
(terpri) (terpri)))
|
||||
(progn
|
||||
(format t "~3%Homotopy in dimension ~D :~2%" degr)
|
||||
(terpri) (terpri)))))
|
||||
|
||||
|
||||
(DEFUN HOMOTOPY-LIST (smst degr)
|
||||
(let (;; we obtain the first non null homology group
|
||||
(first-non-null (first-non-null-homology-group smst degr)))
|
||||
(if first-non-null
|
||||
(split-components (compute-homotopy smst degr first-non-null))
|
||||
nil)))
|
||||
|
||||
|
||||
|
||||
|
||||
1347
src/anromero/resolutions.lisp
Normal file
1347
src/anromero/resolutions.lisp
Normal file
File diff suppressed because it is too large
Load Diff
170
src/sage-interface.lisp
Normal file
170
src/sage-interface.lisp
Normal file
@ -0,0 +1,170 @@
|
||||
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
|
||||
|
||||
|
||||
|
||||
(IN-PACKAGE #:cat)
|
||||
|
||||
(PROVIDE "sage-interface")
|
||||
|
||||
|
||||
|
||||
(DEFVAR *ASCII-NUM-START* 48)
|
||||
|
||||
(DEFVAR *ASCII-NUM-END* 57)
|
||||
|
||||
|
||||
(DEFUN ITOA (value)
|
||||
(if (not (integerp value)) (error "Wrong type"))
|
||||
(if (zerop value)
|
||||
(return-from itoa "0"))
|
||||
(let ((negative? nil))
|
||||
(if (< value 0)
|
||||
(progn
|
||||
(setf negative? t)
|
||||
(setf value (abs value))))
|
||||
(loop
|
||||
for num = value then (floor num 10)
|
||||
for reminder = (mod num 10)
|
||||
while (> num 0)
|
||||
collect
|
||||
(code-char (+ reminder *ASCII-NUM-START*)) into result
|
||||
finally
|
||||
(if negative? (push #\- (cdr (last result))))
|
||||
(return (format nil "~{~a~}" (nreverse result))))))
|
||||
|
||||
|
||||
|
||||
(DEFUN STRCAT (&rest strings) (apply 'concatenate 'string strings))
|
||||
|
||||
|
||||
(DEFMACRO GEN (num1 num2)
|
||||
`(read-from-string (strcat "G" (itoa ,num1) "G" (itoa ,num2))))
|
||||
|
||||
|
||||
|
||||
(DEFUN KBASIS (schcm)
|
||||
(flet ((rslt (dim)
|
||||
(let ((pair (assoc dim schcm)))
|
||||
(if (null pair)
|
||||
NIL
|
||||
(loop for k from 0 to (1- (array-dimension (cdr pair) 1))
|
||||
collect (gen dim k))))))
|
||||
(the basis #'rslt)))
|
||||
|
||||
|
||||
|
||||
(DEFUN KDFFR (schcm)
|
||||
(flet ((frslt (dim gnr)
|
||||
(let* ((sep (1+ (position #\G (subseq (write-to-string gnr) 1))))
|
||||
(dim_gnr (read-from-string (subseq (write-to-string gnr) 1 sep)))
|
||||
(num_gnr (read-from-string (subseq (write-to-string gnr) (1+ sep)))))
|
||||
(declare (fixnum dim_gnr num_gnr))
|
||||
(unless (equal dim dim_gnr) ;It's not working
|
||||
(error "WRONG DIMENSION!!!"))
|
||||
(let ((pair (assoc dim schcm))
|
||||
(rslt (cmbn (1- dim))))
|
||||
(if (null pair)
|
||||
rslt
|
||||
(let ((dif (cdr pair)))
|
||||
(unless (< -1 num_gnr (array-dimension dif 1))
|
||||
(error "WRONG GENERATOR!!!"))
|
||||
(setf (cmbn-list rslt) (loop for i from 0 to (1- (array-dimension dif 0))
|
||||
unless (eq (aref dif i num_gnr) 0)
|
||||
collect (term (aref dif i num_gnr) (gen (1- dim) i))))
|
||||
rslt))))))
|
||||
#'frslt))
|
||||
|
||||
|
||||
|
||||
(DEFUN G-CMPR (GnGm1 GnGm2)
|
||||
(let* ((sep (1+ (position #\G (subseq (write-to-string GnGm1) 1))))
|
||||
(m1 (read-from-string (subseq (write-to-string GnGm1) (1+ sep))))
|
||||
(m2 (read-from-string (subseq (write-to-string GnGm2) (1+ sep)))))
|
||||
(declare (fixnum m1 m2))
|
||||
(the cmpr
|
||||
(if (< m1 m2)
|
||||
:less
|
||||
(if (= m1 m2)
|
||||
:equal
|
||||
:greater)))))
|
||||
|
||||
|
||||
|
||||
(DEFUN CONVERTMATRICE (matrice)
|
||||
(let* ((numfil (nlig matrice))
|
||||
(numcol (ncol matrice))
|
||||
(rslt (make-array (list numfil numcol) :initial-element 0)))
|
||||
(dotimes (i numfil)
|
||||
(dotimes (j numcol)
|
||||
(let ((Mij (entry matrice (1+ i) (1+ j))))
|
||||
(unless (zerop Mij)
|
||||
(setf (aref rslt i j) Mij)))))
|
||||
rslt))
|
||||
|
||||
|
||||
|
||||
(DEFUN ENTRY (mat i j)
|
||||
(let ((p (left (chercher-hor (baselig mat i) j))))
|
||||
(if (= j (icol p))
|
||||
(val p)
|
||||
0)))
|
||||
|
||||
|
||||
|
||||
(DEFUN CHCM-MAT2 (chcm n)
|
||||
(declare
|
||||
(type chain-complex chcm)
|
||||
(type fixnum n))
|
||||
(let ((sorc (basis chcm n))
|
||||
(trgt (basis chcm (1- n)))
|
||||
(cmpr (cmpr chcm)))
|
||||
(declare
|
||||
(list sorc trgt)
|
||||
(type cmprf cmpr))
|
||||
(let ((sorcl (length sorc))
|
||||
(mat (creer-matrice (length trgt) (length sorc)))
|
||||
(test #'(lambda (gnrt1 gnrt2)
|
||||
(eq (funcall cmpr gnrt1 gnrt2) :equal))))
|
||||
(declare
|
||||
(type fixnum sorcl)
|
||||
(type matrice mat)
|
||||
(function test))
|
||||
(do ((i 1 (1+ i))
|
||||
(mark sorc (cdr mark)))
|
||||
((endp mark))
|
||||
(declare
|
||||
(type fixnum i)
|
||||
(list mark))
|
||||
(maj-colonne mat i
|
||||
(mapcar #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(list
|
||||
(1+ (position (gnrt term) trgt :test test))
|
||||
(cffc term)))
|
||||
(cmbn-list (? chcm n (car mark))))))
|
||||
mat)))
|
||||
|
||||
|
||||
|
||||
(DEFUN BUILD-FINITE-SS2 (list)
|
||||
(declare (list list))
|
||||
(let ((bspn (first list))
|
||||
(table (finite-ss-table list))
|
||||
(ind-smst (gensym)))
|
||||
(declare
|
||||
(symbol bspn ind-smst)
|
||||
(simple-vector table))
|
||||
;; (vector (vector gmsm-faces-info))
|
||||
(let ((rslt (build-smst
|
||||
:cmpr #'s-cmpr
|
||||
:basis (finite-ss-basis table)
|
||||
:bspn bspn
|
||||
:face (finite-ss-face ind-smst table)
|
||||
:intr-bndr (finite-ss-intr-bndr ind-smst table)
|
||||
:bndr-strt :gnrt
|
||||
:orgn `(build-finite-ss ,list))))
|
||||
(setf (symbol-value ind-smst) rslt)
|
||||
rslt)))
|
||||
|
||||
(DEFUN MAKE-ARRAY-FROM-LISTS (list)
|
||||
(make-array (list (length list) (length (first list))) :initial-contents list))
|
||||
Loading…
Reference in New Issue
Block a user