Added bicone tests and refactored common functions.
This commit is contained in:
Gerd Heber
parent
cbe1401e76
commit
ded9d544ca
@ -8,6 +8,7 @@
|
||||
:depends-on (:kenzo :fiveam)
|
||||
:pathname #P"test/"
|
||||
:components ((:file "package")
|
||||
(:file "common")
|
||||
(:file "combinations-test")
|
||||
(:file "various-test")
|
||||
(:file "chain-complexes-test")
|
||||
@ -15,4 +16,5 @@
|
||||
(:file "diabolo")
|
||||
(:file "circle")
|
||||
(:file "ccn")
|
||||
(:file "effective-homology-test")))
|
||||
(:file "effective-homology-test")
|
||||
(:file "bicones-test")))
|
||||
|
||||
23
package.lisp
23
package.lisp
@ -20,6 +20,17 @@
|
||||
*TC*
|
||||
*TDD*
|
||||
|
||||
;; bicones.lisp
|
||||
|
||||
BICN-CMBN-CMBNB
|
||||
BICN-CMBN-CMBNC
|
||||
BICN-CMBN-CMBND
|
||||
BICONE
|
||||
BICONE-BASIS
|
||||
BICONE-CMPR
|
||||
DISPATCH-BICN-CMBN
|
||||
MAKE-BICN-CMBN
|
||||
|
||||
;; chain-complexes.lisp
|
||||
|
||||
?2
|
||||
@ -70,6 +81,7 @@
|
||||
MORPHISM
|
||||
ORGN
|
||||
REDUCTION
|
||||
RRDCT
|
||||
TCC
|
||||
|
||||
;; combinations.lisp
|
||||
@ -92,6 +104,10 @@
|
||||
ZERO-CMBN
|
||||
ZERO-INTR-DFFR
|
||||
|
||||
;; delta.lisp
|
||||
|
||||
DELTA-N-BASIS
|
||||
|
||||
;; effective-homology.lisp
|
||||
|
||||
BUILD-RDCT
|
||||
@ -115,6 +131,9 @@
|
||||
?
|
||||
BASIS
|
||||
BCC
|
||||
BCNB
|
||||
BCNC
|
||||
BCND
|
||||
BINOMIAL-P-Q
|
||||
CFFC
|
||||
CMBN-NON-ZERO-P
|
||||
@ -132,6 +151,10 @@
|
||||
|
||||
HOMOLOGY
|
||||
|
||||
;; simplicial-sets.lisp
|
||||
|
||||
DLOP-INT-EXT
|
||||
|
||||
;; smith.lisp
|
||||
|
||||
CHML-CLSS
|
||||
|
||||
700
src/bicones.lisp
700
src/bicones.lisp
@ -7,438 +7,374 @@
|
||||
(PROVIDE "bicones")
|
||||
|
||||
(DEFUN DISPATCH-BICN-CMBN (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the (values cmbn cmbn cmbn)
|
||||
(with-cmbn (degr list) cmbn
|
||||
(let ((listb +empty-list+)
|
||||
(listc +empty-list+)
|
||||
(listd +empty-list+))
|
||||
(declare (list listb listc listd))
|
||||
(dolist (term list)
|
||||
(declare (type term term))
|
||||
(with-term (cffc bicn) term
|
||||
(with-bicn (bcnx ibicn) bicn
|
||||
(ecase bcnx
|
||||
(:bcnb (push (term cffc ibicn) listb))
|
||||
(:bcnc (push (term cffc ibicn) listc))
|
||||
(:bcnd (push (term cffc ibicn) listd))))))
|
||||
(values
|
||||
(make-cmbn :degr degr :list (nreverse listb))
|
||||
(make-cmbn :degr (1+ degr) :list (nreverse listc))
|
||||
(make-cmbn :degr degr :list (nreverse listd)))))))
|
||||
|
||||
#|
|
||||
()
|
||||
(dispatch-bicn-cmbn (cmbn 3 3 (bcnb 'b1) 4 (bcnb 'b2) 33 (bcnc 'c) 333 (bcnd 'd)))
|
||||
|#
|
||||
"(DISPATCH-BICN-CMBN CMBN) splits the bicone combination CMBN into three
|
||||
combinations and returns 3 values."
|
||||
(declare (type cmbn cmbn))
|
||||
(the (values cmbn cmbn cmbn)
|
||||
(with-cmbn (degr list) cmbn
|
||||
(let ((listb +empty-list+)
|
||||
(listc +empty-list+)
|
||||
(listd +empty-list+))
|
||||
(declare (list listb listc listd))
|
||||
(dolist (term list)
|
||||
(declare (type term term))
|
||||
(with-term (cffc bicn) term
|
||||
(with-bicn (bcnx ibicn) bicn
|
||||
(ecase bcnx
|
||||
(:bcnb (push (term cffc ibicn)
|
||||
listb))
|
||||
(:bcnc (push (term cffc ibicn)
|
||||
listc))
|
||||
(:bcnd (push (term cffc ibicn)
|
||||
listd))))))
|
||||
(values
|
||||
(make-cmbn :degr degr :list (nreverse listb))
|
||||
(make-cmbn :degr (1+ degr) :list (nreverse listc))
|
||||
(make-cmbn :degr degr :list (nreverse listd)))))))
|
||||
|
||||
|
||||
(DEFUN BICN-CMBN-CMBNB (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
"(BICN-CMBN-CMBNB CMBN) extracts from the bicone combination CMBN of degree
|
||||
n the B-component as a legal combination of degree n in B. If the B-component
|
||||
is empty, the null combination of degree n in B is returned."
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn :degr degr
|
||||
:list (do ((rslt +empty-list+)
|
||||
(mark list (cdr mark)))
|
||||
((endp mark) (nreverse rslt))
|
||||
(declare (list rslt mark))
|
||||
(with--term (cffc bicn) mark
|
||||
(with-bicn (bcnx gnrtB) bicn
|
||||
(if (eq bcnx :bcnB)
|
||||
(push (term cffc gnrtB) rslt)
|
||||
(return (nreverse rslt))))))))))
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn
|
||||
:degr degr
|
||||
:list (do ((rslt +empty-list+)
|
||||
(mark list (cdr mark)))
|
||||
((endp mark) (nreverse rslt))
|
||||
(declare (list rslt mark))
|
||||
(with--term (cffc bicn) mark
|
||||
(with-bicn (bcnx gnrtB) bicn
|
||||
(if (eq bcnx :bcnB)
|
||||
(push (term cffc gnrtB)
|
||||
rslt)
|
||||
(return
|
||||
(nreverse rslt))))))))))
|
||||
|
||||
(DEFUN BICN-CMBN-CMBNC (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn :degr (1+ degr)
|
||||
:list (do ((rslt +empty-list+)
|
||||
(mark (member :bcnc list
|
||||
;; Correction 1-1-2
|
||||
:key #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(bcnx (gnrt term))))
|
||||
(cdr mark)))
|
||||
((endp mark) (nreverse rslt))
|
||||
(declare (list rslt mark))
|
||||
(with--term (cffc bicn) mark
|
||||
(with-bicn (bcnx gnrtC) bicn
|
||||
(if (eq bcnx :bcnC)
|
||||
(push (term cffc gnrtC) rslt)
|
||||
(return (nreverse rslt))))))))))
|
||||
(declare (type cmbn cmbn))
|
||||
"(BICN-CMBN-CMBNC CMBN) extracts from the bicone combination CMBN of degree
|
||||
n the C-component as a legal combination of degree n+1 in C. If the C-component
|
||||
is empty, the null combination of degree n+1 in C is returned."
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn
|
||||
:degr (1+ degr)
|
||||
:list (do ((rslt +empty-list+)
|
||||
(mark (member :bcnc list
|
||||
;; Correction 1-1-2
|
||||
:key #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(bcnx (gnrt term))))
|
||||
(cdr mark)))
|
||||
((endp mark) (nreverse rslt))
|
||||
(declare (list rslt mark))
|
||||
(with--term (cffc bicn) mark
|
||||
(with-bicn (bcnx gnrtC) bicn
|
||||
(if (eq bcnx :bcnC)
|
||||
(push (term cffc gnrtC)
|
||||
rslt)
|
||||
(return
|
||||
(nreverse rslt))))))))))
|
||||
|
||||
|
||||
(DEFUN BICN-CMBN-CMBND (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
"(BICN-CMBN-CMBND CMBN) extracts from the bicone combination CMBN of degree
|
||||
n the D-component as a legal combination of degree n in D. If the D-component
|
||||
is empty, the null combination of degree n in D is returned."
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn :degr degr
|
||||
:list (mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term (cffc bicn) term
|
||||
(term cffc (ibicn bicn))))
|
||||
(member :bcnd list
|
||||
:key #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(the keyword (bcnx (gnrt term))))))))))
|
||||
(with-cmbn (degr list) cmbn
|
||||
(make-cmbn
|
||||
:degr degr
|
||||
:list (mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term (cffc bicn) term
|
||||
(term cffc (ibicn bicn))))
|
||||
(member
|
||||
:bcnd list
|
||||
:key #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(the keyword (bcnx (gnrt term))))))))))
|
||||
|
||||
#|
|
||||
()
|
||||
(bicn-cmbn-cmbnb (cmbn 3 1 (bcnb 'a) 2 (bcnc 'b)))
|
||||
(bicn-cmbn-cmbnb (cmbn 3 2 (bcnc 'b)))
|
||||
(bicn-cmbn-cmbnc (cmbn 3 1 (bcnb 'a) 2 (bcnc 'b) 3 (bcnd 'c)))
|
||||
(bicn-cmbn-cmbnc (cmbn 3 1 (bcnb 'a) 3 (bcnd 'c)))
|
||||
(bicn-cmbn-cmbnd (cmbn 3 1 (bcnb 'a) 2 (bcnc 'b) 3 (bcnd 'c)))
|
||||
(bicn-cmbn-cmbnd (cmbn 3 2 (bcnb 'b)))
|
||||
|#
|
||||
|
||||
(DEFUN MAKE-BICN-CMBN (cmbnb cmbnc cmbnd)
|
||||
(declare (type cmbn cmbnb cmbnc cmbnd))
|
||||
(the cmbn
|
||||
(with-cmbn (degrb listb) cmbnb
|
||||
(with-cmbn (degrc listc) cmbnc
|
||||
(with-cmbn (degrd listd) cmbnd
|
||||
(unless (= degrb (1- degrc) degrd)
|
||||
(error "In MAKE-BICN-CMBN, the degrees are not coherent."))
|
||||
(make-cmbn :degr degrb
|
||||
:list (nconc
|
||||
(mapcar #'(lambda (termb)
|
||||
(declare (type term termb))
|
||||
(with-term (cffc gnrtb) termb
|
||||
(term cffc (bcnb gnrtb))))
|
||||
listb)
|
||||
(mapcar #'(lambda (termc)
|
||||
(declare (type term termc))
|
||||
(with-term (cffc gnrtc) termc
|
||||
(term cffc (bcnc gnrtc))))
|
||||
listc)
|
||||
(mapcar #'(lambda (termd)
|
||||
(declare (type term termd))
|
||||
(with-term (cffc gnrtd) termd
|
||||
(term cffc (bcnd gnrtd))))
|
||||
listd))))))))
|
||||
(declare (type cmbn cmbnb cmbnc cmbnd))
|
||||
"(MAKE-BICN-CMBN CMBNB CMBNC CMBND) constructs a bicone combination from
|
||||
CMBNB, CMBNC and CMBND, which belong to chain complexes B, C, D, respectively.
|
||||
Combinations CMBNB and CMBND must be of the same degree n and combination
|
||||
CMBNC must be of degree n+1, yiedling a bicone combination of degree n."
|
||||
(the cmbn
|
||||
(with-cmbn
|
||||
(degrb listb) cmbnb
|
||||
(with-cmbn
|
||||
(degrc listc) cmbnc
|
||||
(with-cmbn
|
||||
(degrd listd) cmbnd
|
||||
(unless (= degrb (1- degrc) degrd)
|
||||
(error "In MAKE-BICN-CMBN, the degrees are not coherent."))
|
||||
(make-cmbn
|
||||
:degr degrb
|
||||
:list (nconc
|
||||
(mapcar #'(lambda (termb)
|
||||
(declare (type term termb))
|
||||
(with-term (cffc gnrtb) termb
|
||||
(term cffc (bcnb gnrtb))))
|
||||
listb)
|
||||
(mapcar #'(lambda (termc)
|
||||
(declare (type term termc))
|
||||
(with-term (cffc gnrtc) termc
|
||||
(term cffc (bcnc gnrtc))))
|
||||
listc)
|
||||
(mapcar #'(lambda (termd)
|
||||
(declare (type term termd))
|
||||
(with-term (cffc gnrtd) termd
|
||||
(term cffc (bcnd gnrtd))))
|
||||
listd))))))))
|
||||
|
||||
#|
|
||||
()
|
||||
(multiple-value-call #'make-bicn-cmbn
|
||||
(dispatch-bicn-cmbn (cmbn 3 3 (bcnb 'b1) 4 (bcnb 'b2) 33 (bcnc 'c) 333 (bcnd 'd))))
|
||||
|#
|
||||
|
||||
(DEFUN BICN-PRINT (bicn stream depth)
|
||||
(declare
|
||||
(type bicn bicn) (stream stream)
|
||||
(ignore depth))
|
||||
(the bicn
|
||||
(with-bicn (bcnx ibicn) bicn
|
||||
;; Correction 1-1-2
|
||||
(format stream "<Bcn~A ~A>"
|
||||
;; Correction 1-1-3
|
||||
(ecase bcnx (:bcnb #\B) (:bcnc #\C) (:bcnd #\D))
|
||||
ibicn)
|
||||
bicn)))
|
||||
(with-bicn (bcnx ibicn) bicn
|
||||
;; Correction 1-1-2
|
||||
(format stream "<Bcn~A ~A>"
|
||||
;; Correction 1-1-3
|
||||
(ecase bcnx (:bcnb #\B) (:bcnc #\C) (:bcnd #\D))
|
||||
ibicn)
|
||||
bicn)))
|
||||
|
||||
#|
|
||||
()
|
||||
(bcnb 'a)
|
||||
(bcnc 'b)
|
||||
(bcnd 'c)
|
||||
|#
|
||||
|
||||
(DEFUN BICONE-CMPR (cmprb cmprc cmprd)
|
||||
(declare (type cmprf cmprb cmprc cmprd))
|
||||
(flet ((rslt (bicn1 bicn2)
|
||||
(declare (type bicn bicn1 bicn2))
|
||||
(let ((bcnx1 (bcnx bicn1)))
|
||||
(declare (type (member :bcnb :bcnc :bcnd) bcnx1))
|
||||
(lexico
|
||||
(s-cmpr bcnx1 (bcnx bicn2))
|
||||
(case bcnx1
|
||||
(:bcnb (funcall cmprb (ibicn bicn1) (ibicn bicn2)))
|
||||
(:bcnc (funcall cmprc (ibicn bicn1) (ibicn bicn2)))
|
||||
(:bcnd (funcall cmprd (ibicn bicn1) (ibicn bicn2))))))))
|
||||
(the cmprf #'rslt)))
|
||||
(declare (type cmprf cmprb cmprc cmprd))
|
||||
"(BICONE-CMPR CMPRB CMPRC CMPRD) returns a comparison function for bicone
|
||||
generators, which is contructed from the comparison functions CMPRB, CMPRC
|
||||
and CMPRD."
|
||||
(flet ((rslt (bicn1 bicn2)
|
||||
(declare (type bicn bicn1 bicn2))
|
||||
(let ((bcnx1 (bcnx bicn1)))
|
||||
(declare (type (member :bcnb :bcnc :bcnd) bcnx1))
|
||||
(lexico
|
||||
(s-cmpr bcnx1 (bcnx bicn2))
|
||||
(case bcnx1
|
||||
(:bcnb (funcall cmprb (ibicn bicn1) (ibicn bicn2)))
|
||||
(:bcnc (funcall cmprc (ibicn bicn1) (ibicn bicn2)))
|
||||
(:bcnd (funcall cmprd (ibicn bicn1) (ibicn bicn2))))))))
|
||||
(the cmprf #'rslt)))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf r (bicone-cmpr #'f-cmpr #'f-cmpr #'f-cmpr))
|
||||
(funcall r (bcnb 1) (bcnc 0))
|
||||
(funcall r (bcnb 1) (bcnb 2))
|
||||
|#
|
||||
|
||||
(DEFUN BICONE-BASIS (basisb basisc basisd)
|
||||
(declare (type basis basisb basisc basisd))
|
||||
(the basis
|
||||
(if (or (eq :locally-effective basisb)
|
||||
(eq :locally-effective basisc)
|
||||
(eq :locally-effective basisd))
|
||||
:locally-effective
|
||||
(flet ((rslt (degr)
|
||||
(declare (fixnum degr))
|
||||
(append
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(bcnb item))
|
||||
(funcall basisb degr))
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(bcnc item))
|
||||
(funcall basisc (1+ degr)))
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(bcnd item))
|
||||
(funcall basisd degr)))))
|
||||
(the basis #'rslt)))))
|
||||
(declare (type basis basisb basisc basisd))
|
||||
"(BICONE-BASIS BASISB BASISC BASISD) returns a bicone basis function built
|
||||
from the basis functions BASISB, BASISC and BASISD. If at least one is
|
||||
locally effective, the function returns the symbol :locally-effective."
|
||||
(the basis
|
||||
(if (or (eq :locally-effective basisb)
|
||||
(eq :locally-effective basisc)
|
||||
(eq :locally-effective basisd))
|
||||
:locally-effective
|
||||
(flet ((rslt (degr)
|
||||
(declare (fixnum degr))
|
||||
(append
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(bcnb item))
|
||||
(funcall basisb degr))
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(bcnc item))
|
||||
(funcall basisc (1+ degr)))
|
||||
(mapcar #'(lambda (item)
|
||||
(declare (type gnrt item))
|
||||
(bcnd item))
|
||||
(funcall basisd degr)))))
|
||||
(the basis #'rslt)))))
|
||||
|
||||
#|
|
||||
()
|
||||
(bicone-basis :locally-effective :locally-effective :locally-effective)
|
||||
(setf b #'(lambda (degr) (mapcar #'(lambda (item) (cons degr item)) (<a-b> 0 degr))))
|
||||
(setf r (bicone-basis b b b))
|
||||
(funcall r 3)
|
||||
|#
|
||||
|
||||
(DEFUN BICONE-INTR-DFFR (cmprc dffrb dffrc dffrd f1 f2)
|
||||
(declare
|
||||
(type cmprf cmprc)
|
||||
(type morphism dffrb dffrc dffrd f1 f2))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(multiple-value-bind (cmbnb cmbnc cmbnd) (dispatch-bicn-cmbn cmbn)
|
||||
(declare (type cmbn cmbnb cmbnc cmbnd))
|
||||
(let ((dffrb (cmbn-? dffrb cmbnb))
|
||||
(dffrc (cmbn-? dffrc cmbnc))
|
||||
(dffrd (cmbn-? dffrd cmbnd))
|
||||
(f1 (cmbn-? f1 cmbnb))
|
||||
(f2 (cmbn-? f2 cmbnd)))
|
||||
(declare (type cmbn dffrb dffrc dffrd f1 f2))
|
||||
(let ((cmbnc (2cmbn-sbtr cmprc (2cmbn-add cmprc f1 f2) dffrc)))
|
||||
(declare (type cmbn cmbnc))
|
||||
(make-bicn-cmbn dffrb cmbnc dffrd)))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
(declare
|
||||
(type cmprf cmprc)
|
||||
(type morphism dffrb dffrc dffrd f1 f2))
|
||||
"(BICONE-INTR-DFFR CMPRC DFFRB DFFRC DFFRD F1 F2) "
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(multiple-value-bind (cmbnb cmbnc cmbnd)
|
||||
(dispatch-bicn-cmbn cmbn)
|
||||
(declare (type cmbn cmbnb cmbnc cmbnd))
|
||||
(let ((dffrb (cmbn-? dffrb cmbnb))
|
||||
(dffrc (cmbn-? dffrc cmbnc))
|
||||
(dffrd (cmbn-? dffrd cmbnd))
|
||||
(f1 (cmbn-? f1 cmbnb))
|
||||
(f2 (cmbn-? f2 cmbnd)))
|
||||
(declare (type cmbn dffrb dffrc dffrd f1 f2))
|
||||
(let ((cmbnc (2cmbn-sbtr cmprc
|
||||
(2cmbn-add cmprc f1 f2)
|
||||
dffrc)))
|
||||
(declare (type cmbn cmbnc))
|
||||
(make-bicn-cmbn dffrb cmbnc dffrd)))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
|
||||
|
||||
(DEFUN BICONE (rdct1 rdct2)
|
||||
(declare (type reduction rdct1 rdct2))
|
||||
(the chain-complex
|
||||
(with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f)) rdct1
|
||||
(declare
|
||||
(type chain-complex tcc1 bcc1)
|
||||
(type morphism f1))
|
||||
(with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f)) rdct2
|
||||
(declare (type reduction rdct1 rdct2))
|
||||
"(BICONE RDCT1 RDCT2) returns the bicone chain complex from the reductions
|
||||
RDCT1 and RDCT2. B is the top chain complex of RDCT1 and D is the top chain
|
||||
complex of RDCT2. The bottom chain complexes of RDCT1 and RDCT2 must be the
|
||||
same, and C is that chain complex."
|
||||
(the chain-complex
|
||||
(with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f)) rdct1
|
||||
(declare
|
||||
(type chain-complex tcc1 bcc1)
|
||||
(type morphism f1))
|
||||
(with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f)) rdct2
|
||||
(declare
|
||||
(type chain-complex tcc2 bcc2)
|
||||
(type morphism f2))
|
||||
(unless (eq bcc1 bcc2)
|
||||
(error "In BICONE, both reductions have different BCC's."))
|
||||
(let ((rslt (build-chcm
|
||||
(unless (eq bcc1 bcc2)
|
||||
(error "In BICONE, both reductions have different BCC's."))
|
||||
(let ((rslt (build-chcm
|
||||
:cmpr (bicone-cmpr (cmpr tcc1) (cmpr bcc1) (cmpr tcc2))
|
||||
:basis (bicone-basis (basis tcc1) (basis bcc1) (basis tcc2))
|
||||
:basis (bicone-basis (basis tcc1) (basis bcc1)
|
||||
(basis tcc2))
|
||||
:bsgn :undefined
|
||||
:intr-dffr (bicone-intr-dffr (cmpr bcc1)
|
||||
(dffr tcc1) (dffr bcc1) (dffr tcc2)
|
||||
f1 f2)
|
||||
(dffr tcc1) (dffr bcc1)
|
||||
(dffr tcc2)
|
||||
f1 f2)
|
||||
:strt :cmbn
|
||||
:orgn `(bicone ,rdct1 ,rdct2))))
|
||||
(declare (type chain-complex rslt))
|
||||
; (slot-makunbound rslt 'bsgn)
|
||||
rslt)))))
|
||||
(declare (type chain-complex rslt))
|
||||
; (slot-makunbound rslt 'bsgn)
|
||||
rslt)))))
|
||||
|
||||
#|
|
||||
()
|
||||
(cat-init)
|
||||
(progn
|
||||
(defun cdelta (dmns)
|
||||
(build-chcm
|
||||
:cmpr #'l-cmpr
|
||||
:basis #'(lambda (n)
|
||||
(mapcar #'dlop-int-ext (funcall (delta-n-basis dmns) n)))
|
||||
:bsgn '(0)
|
||||
:intr-dffr #'(lambda (degr gmsm)
|
||||
(make-cmbn
|
||||
:degr (1- degr)
|
||||
:list (do ((rslt +empty-list+
|
||||
(cons (cons sign (append
|
||||
(subseq gmsm 0 nark)
|
||||
(subseq gmsm (1+ nark))))
|
||||
rslt))
|
||||
(sign 1 (- sign))
|
||||
(nark 0 (1+ nark)))
|
||||
((> nark degr) rslt))))
|
||||
:strt :gnrt
|
||||
:orgn `(locally effective version of C_* delta ,dmns)))
|
||||
(defun make-f (tdmns bdmns)
|
||||
(build-mrph
|
||||
:sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0
|
||||
:intr #'(lambda (degr gmsm)
|
||||
(let ((pos (position-if #'(lambda (vertex) (>= vertex bdmns)) gmsm)))
|
||||
(if pos
|
||||
(if (< pos degr)
|
||||
(zero-cmbn degr)
|
||||
(cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
|
||||
(cmbn degr 1 gmsm))))
|
||||
:strt :gnrt
|
||||
:orgn `(projection delta ,tdmns => delta ,bdmns)))
|
||||
(defun make-g (tdmns bdmns)
|
||||
(build-mrph
|
||||
:sorc (cdelta bdmns) :trgt (cdelta tdmns) :degr 0
|
||||
:intr #'identity
|
||||
:strt :cmbn
|
||||
:orgn `(injection delta ,bdmns => delta ,tdmns)))
|
||||
(defun make-h (tdmns bdmns)
|
||||
(build-mrph
|
||||
:sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1
|
||||
:intr #'(lambda (degr gmsm)
|
||||
(let ((pos (position-if #'(lambda (vertex) (>= vertex bdmns)) gmsm)))
|
||||
(if pos
|
||||
(if (member bdmns gmsm)
|
||||
(zero-cmbn (1+ degr))
|
||||
(cmbn (1+ degr) (-1-expt-n pos)
|
||||
(append (subseq gmsm 0 pos) (list bdmns) (subseq gmsm pos))))
|
||||
(zero-cmbn (1+ degr)))))
|
||||
:strt :gnrt
|
||||
:orgn `(homotopy for delta ,tdmns => ,bdmns)))
|
||||
(defun make-rdct (tdmns bdmns)
|
||||
(setf rdct (build-rdct
|
||||
:f (make-f tdmns bdmns)
|
||||
:g (make-g tdmns bdmns)
|
||||
:h (make-h tdmns bdmns)
|
||||
:orgn `(reduction delta ,tdmns ,bdmns)))))
|
||||
(setf b (bicone (make-rdct 3 2) (make-rdct 4 2)))
|
||||
(basis b 1)
|
||||
(? b (cmbn 1 3 (bcnb '(0 3)) 4 (bcnc '(0 1 2)) 5 (bcnd '(0 4))))
|
||||
|#
|
||||
|
||||
(DEFMETHOD CMPS ((hmeq1 homotopy-equivalence) (hmeq2 homotopy-equivalence) &optional dummy)
|
||||
(declare (ignore dummy))
|
||||
(the homotopy-equivalence
|
||||
(progn
|
||||
(DEFMETHOD CMPS ((hmeq1 homotopy-equivalence) (hmeq2 homotopy-equivalence)
|
||||
&optional dummy)
|
||||
(declare (ignore dummy))
|
||||
"(CMPS HMEQ1 HMEQ2 &OPTIONAL DUMMY) constructs a homotopy equivalence
|
||||
by composition of the homotopy equivalences HMEQ1 and HMEQ2."
|
||||
(the homotopy-equivalence
|
||||
(progn
|
||||
(when (eq 'trivial-hmeq (orgn hmeq2))
|
||||
(return-from cmps hmeq1))
|
||||
(return-from cmps hmeq1))
|
||||
(with-slots ((cc-A lbcc) (cc-B tcc) (cc-C rbcc)
|
||||
(f1 lf) (g1 lg) (h1 lh) (f2 rf) (g2 rg) (h2 rh)) hmeq1
|
||||
(declare
|
||||
(type chain-complex cc-A cc-B cc-C)
|
||||
(type morphism f1 g1 h1 f2 g2 h2))
|
||||
(with-slots ((cc-C2 lbcc) (cc-D tcc) (cc-E rbcc)
|
||||
(f3 lf) (g3 lg) (h3 lh) (f4 rf) (g4 rg) (h4 rh)) hmeq2
|
||||
(declare
|
||||
(type chain-complex cc-C2 cc-D cc-E)
|
||||
(type morphism f3 g3 h3 f4 g4 h4))
|
||||
(unless (eq (grmd cc-C) (grmd cc-C2))
|
||||
(declare
|
||||
(type chain-complex cc-A cc-B cc-C)
|
||||
(type morphism f1 g1 h1 f2 g2 h2))
|
||||
(with-slots ((cc-C2 lbcc) (cc-D tcc) (cc-E rbcc)
|
||||
(f3 lf) (g3 lg) (h3 lh) (f4 rf) (g4 rg) (h4 rh)) hmeq2
|
||||
(declare
|
||||
(type chain-complex cc-C2 cc-D cc-E)
|
||||
(type morphism f3 g3 h3 f4 g4 h4))
|
||||
(unless (eq (grmd cc-C) (grmd cc-C2))
|
||||
(error "In (CMPS HMEQ HMEQ), both hmeq's may not be composed."))
|
||||
(let ((bicone (bicone (rrdct hmeq1) (lrdct hmeq2)))
|
||||
(cmpr-B (cmpr cc-B))
|
||||
(cmpr-D (cmpr cc-D)))
|
||||
(let ((bicone (bicone (rrdct hmeq1) (lrdct hmeq2)))
|
||||
(cmpr-B (cmpr cc-B))
|
||||
(cmpr-D (cmpr cc-D)))
|
||||
(declare (type chain-complex bicone))
|
||||
(let ((lf (build-mrph
|
||||
:sorc bicone :trgt cc-A :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(cmbn-? f1 (bicn-cmbn-cmbnB cmbn)))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 lf)))
|
||||
:sorc bicone :trgt cc-A :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(cmbn-? f1 (bicn-cmbn-cmbnB cmbn)))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 lf)))
|
||||
(lg (build-mrph
|
||||
:sorc cc-A :trgt bicone :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(let* ((cmbnB (cmbn-? g1 cmbn))
|
||||
(cmbnC (zero-cmbn (1+ (cmbn-degr cmbn))))
|
||||
(cmbnD (cmbn-? g3 (cmbn-? f2 (cmbn-opps cmbnB)))))
|
||||
(declare (type cmbn cmbnB cmbnC cmbnD))
|
||||
(make-bicn-cmbn cmbnB cmbnC cmbnD)))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 lg)))
|
||||
:sorc cc-A :trgt bicone :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(let* ((cmbnB (cmbn-? g1 cmbn))
|
||||
(cmbnC (zero-cmbn
|
||||
(1+ (cmbn-degr cmbn))))
|
||||
(cmbnD (cmbn-? g3
|
||||
(cmbn-? f2
|
||||
(cmbn-opps
|
||||
cmbnB)))))
|
||||
(declare (type cmbn cmbnB cmbnC cmbnD))
|
||||
(make-bicn-cmbn cmbnB cmbnC cmbnD)))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 lg)))
|
||||
(lh (build-mrph
|
||||
:sorc bicone :trgt bicone :degr +1
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(multiple-value-bind (cmbnB cmbnC cmbnD)
|
||||
(dispatch-bicn-cmbn cmbn)
|
||||
(declare (type cmbn cmbnB cmbnC cmbnD))
|
||||
(setf cmbnB (cmbn-? h1 cmbnB))
|
||||
(let ((cmbnC (zero-cmbn (1+ (cmbn-degr cmbnC))))
|
||||
(cmbnD1 (cmbn-? g3 (cmbn-? f2 cmbnB)))
|
||||
(cmbnD2 (cmbn-? g3 cmbnC)) ;; let, not let*
|
||||
(cmbnD3 (cmbn-? h3 cmbnD)))
|
||||
(declare (type cmbn cmbnC cmbnD1 cmbnD2 cmbnD3))
|
||||
(make-bicn-cmbn
|
||||
cmbnB
|
||||
cmbnC
|
||||
(2cmbn-sbtr cmpr-D
|
||||
(2cmbn-add cmpr-D cmbnD2 cmbnD3)
|
||||
cmbnD1)))))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 lh)))
|
||||
:sorc bicone :trgt bicone :degr +1
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(multiple-value-bind (cmbnB cmbnC cmbnD)
|
||||
(dispatch-bicn-cmbn cmbn)
|
||||
(declare (type cmbn cmbnB cmbnC cmbnD))
|
||||
(setf cmbnB (cmbn-? h1 cmbnB))
|
||||
(let ((cmbnC (zero-cmbn
|
||||
(1+ (cmbn-degr cmbnC))))
|
||||
(cmbnD1 (cmbn-? g3
|
||||
(cmbn-? f2 cmbnB)))
|
||||
(cmbnD2 (cmbn-? g3 cmbnC)) ;; let, not let*
|
||||
(cmbnD3 (cmbn-? h3 cmbnD)))
|
||||
(declare (type cmbn cmbnC cmbnD1 cmbnD2
|
||||
cmbnD3))
|
||||
(make-bicn-cmbn
|
||||
cmbnB
|
||||
cmbnC
|
||||
(2cmbn-sbtr cmpr-D
|
||||
(2cmbn-add cmpr-D cmbnD2
|
||||
cmbnD3)
|
||||
cmbnD1)))))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 lh)))
|
||||
(rf (build-mrph
|
||||
:sorc bicone :trgt cc-E :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(cmbn-? f4 (bicn-cmbn-cmbnD cmbn)))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 rf)))
|
||||
:sorc bicone :trgt cc-E :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(cmbn-? f4 (bicn-cmbn-cmbnD cmbn)))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 rf)))
|
||||
(rg (build-mrph
|
||||
:sorc cc-E :trgt bicone :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(let* ((cmbnD (cmbn-? g4 cmbn))
|
||||
(cmbnC (zero-cmbn (1+ (cmbn-degr cmbn))))
|
||||
(cmbnB (cmbn-? g2 (cmbn-? f3 (cmbn-opps cmbnD)))))
|
||||
(declare (type cmbn cmbnD cmbnC cmbnB))
|
||||
(make-bicn-cmbn cmbnB cmbnC cmbnD)))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 rg)))
|
||||
:sorc cc-E :trgt bicone :degr 0
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(let* ((cmbnD (cmbn-? g4 cmbn))
|
||||
(cmbnC (zero-cmbn
|
||||
(1+ (cmbn-degr cmbn))))
|
||||
(cmbnB
|
||||
(cmbn-?
|
||||
g2 (cmbn-? f3 (cmbn-opps cmbnD)))))
|
||||
(declare (type cmbn cmbnD cmbnC cmbnB))
|
||||
(make-bicn-cmbn cmbnB cmbnC cmbnD)))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 rg)))
|
||||
(rh (build-mrph
|
||||
:sorc bicone :trgt bicone :degr +1
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(multiple-value-bind (cmbnB cmbnC cmbnD)
|
||||
(dispatch-bicn-cmbn cmbn)
|
||||
(declare (type cmbn cmbnB cmbnC cmbnD))
|
||||
(setf cmbnD (cmbn-? h4 cmbnD))
|
||||
(let ((cmbnC (zero-cmbn (1+ (cmbn-degr cmbnC))))
|
||||
(cmbnB1 (cmbn-? g2 (cmbn-? f3 cmbnD)))
|
||||
(cmbnB2 (cmbn-? g2 cmbnC)) ;; let, not let*
|
||||
(cmbnB3 (cmbn-? h2 cmbnB)))
|
||||
(declare (type cmbn cmbnC cmbnB1 cmbnB2 cmbnB3))
|
||||
(make-bicn-cmbn
|
||||
(2cmbn-sbtr cmpr-B
|
||||
(2cmbn-add cmpr-B cmbnB2 cmbnB3)
|
||||
cmbnB1)
|
||||
cmbnC
|
||||
cmbnD))))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 rh))))
|
||||
(declare
|
||||
(type morphism lf lg lh rf rg rh))
|
||||
(build-hmeq :lf lf :lg lg :lh lh :rf rf :rg rg :rh rh
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2)))))))))
|
||||
|
||||
#|
|
||||
()
|
||||
(cat-init)
|
||||
(setf c (build-chcm
|
||||
:cmpr #'s-cmpr
|
||||
:basis #'(lambda (dmns) '(a))
|
||||
:bsgn 'a
|
||||
:intr-dffr #'zero-intr-dffr
|
||||
:strt :cmbn
|
||||
:orgn '(c)))
|
||||
(setf h1 (trivial-hmeq c))
|
||||
(setf h2 (cmps h1 h1))
|
||||
(pre-check-rdct (lrdct h2))
|
||||
(setf *tc* (cmbn 3 1 (bcnB 'a) 10 (bcnC 'a) 100 (bcnD 'a)))
|
||||
(setf *bc* (cmbn 3 1 'a))
|
||||
(check-rdct)
|
||||
(pre-check-rdct (rrdct h2))
|
||||
(check-rdct)
|
||||
(setf h3 (cmps h2 h2))
|
||||
(setf *tc* (cmbn 3 1 (bcnB (bcnB 'a)) 10 (bcnB (bcnC 'a)) 100 (bcnB (bcnD 'a))
|
||||
1000 (bcnC 'a)
|
||||
10000 (bcnD (bcnB 'a)) 5234 (bcnD (bcnC 'a)) 223 (bcnD (bcnD 'a))))
|
||||
(pre-check-rdct (lrdct h3))
|
||||
(check-rdct)
|
||||
(pre-check-rdct (rrdct h3))
|
||||
(check-rdct)
|
||||
|#
|
||||
:sorc bicone :trgt bicone :degr +1
|
||||
:intr #'(lambda (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(multiple-value-bind (cmbnB cmbnC cmbnD)
|
||||
(dispatch-bicn-cmbn cmbn)
|
||||
(declare (type cmbn cmbnB cmbnC cmbnD))
|
||||
(setf cmbnD (cmbn-? h4 cmbnD))
|
||||
(let ((cmbnC (zero-cmbn
|
||||
(1+ (cmbn-degr cmbnC))))
|
||||
(cmbnB1 (cmbn-? g2
|
||||
(cmbn-? f3 cmbnD)))
|
||||
(cmbnB2 (cmbn-? g2 cmbnC)) ;; let, not let*
|
||||
(cmbnB3 (cmbn-? h2 cmbnB)))
|
||||
(declare (type cmbn cmbnC cmbnB1 cmbnB2
|
||||
cmbnB3))
|
||||
(make-bicn-cmbn
|
||||
(2cmbn-sbtr cmpr-B
|
||||
(2cmbn-add cmpr-B cmbnB2
|
||||
cmbnB3)
|
||||
cmbnB1)
|
||||
cmbnC
|
||||
cmbnD))))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 rh))))
|
||||
(declare
|
||||
(type morphism lf lg lh rf rg rh))
|
||||
(build-hmeq :lf lf :lg lg :lh lh :rf rf :rg rg :rh rh
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2)))))))))
|
||||
|
||||
331
src/cones.lisp
331
src/cones.lisp
@ -12,16 +12,16 @@
|
||||
(stream stream)
|
||||
(ignore depth))
|
||||
(the cone
|
||||
(with-cone (conx icon) cone
|
||||
(format stream "<CONE ~D" conx)
|
||||
(do ((mark icon))
|
||||
((not (typep mark 'cone))
|
||||
(format stream " ~A>" mark))
|
||||
(declare (type gnrt icon))
|
||||
(with-cone (conx icon) mark
|
||||
(format stream "-~D" conx)
|
||||
(setf mark icon)))
|
||||
cone)))
|
||||
(with-cone (conx icon) cone
|
||||
(format stream "<CONE ~D" conx)
|
||||
(do ((mark icon))
|
||||
((not (typep mark 'cone))
|
||||
(format stream " ~A>" mark))
|
||||
(declare (type gnrt icon))
|
||||
(with-cone (conx icon) mark
|
||||
(format stream "-~D" conx)
|
||||
(setf mark icon)))
|
||||
cone)))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -37,25 +37,25 @@
|
||||
(DEFUN CONE-CMPR (cmpr0 cmpr1)
|
||||
(declare (type cmprf cmpr0 cmpr1))
|
||||
(the cmprf
|
||||
(flet ((rslt (gnrt1 gnrt2)
|
||||
(declare (type cone gnrt1 gnrt2))
|
||||
(the cmpr
|
||||
(let ((ind1 (conx gnrt1))
|
||||
(ind2 (conx gnrt2))
|
||||
(gnrt11 (icon gnrt1))
|
||||
(gnrt22 (icon gnrt2)))
|
||||
(declare
|
||||
(fixnum ind1 ind2)
|
||||
(type gnrt gnrt11 gnrt22))
|
||||
(ecase ind1
|
||||
(0 (ecase ind2
|
||||
(0 (funcall cmpr0 gnrt11 gnrt22))
|
||||
(1 :less)))
|
||||
(1 (ecase ind2
|
||||
(0 :greater)
|
||||
(1 (funcall cmpr1 gnrt11 gnrt22)))))))))
|
||||
(declare (ftype (function (cone cone) cmpr) rslt))
|
||||
#'rslt)))
|
||||
(flet ((rslt (gnrt1 gnrt2)
|
||||
(declare (type cone gnrt1 gnrt2))
|
||||
(the cmpr
|
||||
(let ((ind1 (conx gnrt1))
|
||||
(ind2 (conx gnrt2))
|
||||
(gnrt11 (icon gnrt1))
|
||||
(gnrt22 (icon gnrt2)))
|
||||
(declare
|
||||
(fixnum ind1 ind2)
|
||||
(type gnrt gnrt11 gnrt22))
|
||||
(ecase ind1
|
||||
(0 (ecase ind2
|
||||
(0 (funcall cmpr0 gnrt11 gnrt22))
|
||||
(1 :less)))
|
||||
(1 (ecase ind2
|
||||
(0 :greater)
|
||||
(1 (funcall cmpr1 gnrt11 gnrt22)))))))))
|
||||
(declare (ftype (function (cone cone) cmpr) rslt))
|
||||
#'rslt)))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -73,20 +73,20 @@
|
||||
(DEFUN CONE-BASIS (basis0 basis1)
|
||||
(declare (type basis basis0 basis1))
|
||||
(the basis
|
||||
(progn
|
||||
(when (or (eq basis0 :locally-effective)
|
||||
(eq basis1 :locally-effective))
|
||||
(return-from cone-basis :locally-effective))
|
||||
(flet ((rslt (degr)
|
||||
(declare (type fixnum degr))
|
||||
(the list
|
||||
(append
|
||||
(mapcar #'(lambda (item) (con0 item))
|
||||
(funcall basis0 degr))
|
||||
(mapcar #'(lambda (item) (con1 item))
|
||||
(funcall basis1 (1- degr)))))))
|
||||
(declare (ftype (function (fixnum) list) rslt))
|
||||
#'rslt))))
|
||||
(progn
|
||||
(when (or (eq basis0 :locally-effective)
|
||||
(eq basis1 :locally-effective))
|
||||
(return-from cone-basis :locally-effective))
|
||||
(flet ((rslt (degr)
|
||||
(declare (type fixnum degr))
|
||||
(the list
|
||||
(append
|
||||
(mapcar #'(lambda (item) (con0 item))
|
||||
(funcall basis0 degr))
|
||||
(mapcar #'(lambda (item) (con1 item))
|
||||
(funcall basis1 (1- degr)))))))
|
||||
(declare (ftype (function (fixnum) list) rslt))
|
||||
#'rslt))))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -99,17 +99,17 @@
|
||||
(DEFUN TERM-CON0 (term)
|
||||
(declare (type term term))
|
||||
(the term
|
||||
(term (cffc term)
|
||||
(con0 (gnrt term)))))
|
||||
(term (cffc term)
|
||||
(con0 (gnrt term)))))
|
||||
(DEFUN TERM-CON1 (term)
|
||||
(declare (type term term))
|
||||
(the term
|
||||
(term (cffc term)
|
||||
(con1 (gnrt term)))))
|
||||
(term (cffc term)
|
||||
(con1 (gnrt term)))))
|
||||
(DEFUN TERM-UNCON (term)
|
||||
(declare (type term term))
|
||||
(the term
|
||||
(term (cffc term) (icon (gnrt term)))))
|
||||
(term (cffc term) (icon (gnrt term)))))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -121,16 +121,16 @@
|
||||
(DEFUN CMBN-CON0 (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(make-cmbn
|
||||
:degr (cmbn-degr cmbn)
|
||||
:list (mapcar #'term-con0 (cmbn-list cmbn)))))
|
||||
(make-cmbn
|
||||
:degr (cmbn-degr cmbn)
|
||||
:list (mapcar #'term-con0 (cmbn-list cmbn)))))
|
||||
|
||||
(DEFUN CMBN-CON1 (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(make-cmbn
|
||||
:degr (cmbn-degr cmbn)
|
||||
:list (mapcar #'term-con1 (cmbn-list cmbn)))))
|
||||
(make-cmbn
|
||||
:degr (cmbn-degr cmbn)
|
||||
:list (mapcar #'term-con1 (cmbn-list cmbn)))))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -141,22 +141,22 @@
|
||||
(DEFUN CONE-CMBN-SPLIT (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the (values cmbn cmbn)
|
||||
(with-cmbn (degr list) cmbn
|
||||
(let ((list0 +empty-list+)
|
||||
(list1 +empty-list+))
|
||||
(declare (type list list0 list1))
|
||||
(do ((mark list (cdr mark)))
|
||||
((endp mark)
|
||||
(setf list0 (nreverse list0)
|
||||
list1 +empty-list+))
|
||||
(declare (type list mark))
|
||||
(when (eql 1 (conx (cdar mark)))
|
||||
(setf list0 (nreverse list0)
|
||||
list1 (mapcar #'term-uncon mark))
|
||||
(return))
|
||||
(push (term-uncon (car mark)) list0))
|
||||
(values (make-cmbn :degr degr :list list0)
|
||||
(make-cmbn :degr (1- degr) :list list1))))))
|
||||
(with-cmbn (degr list) cmbn
|
||||
(let ((list0 +empty-list+)
|
||||
(list1 +empty-list+))
|
||||
(declare (type list list0 list1))
|
||||
(do ((mark list (cdr mark)))
|
||||
((endp mark)
|
||||
(setf list0 (nreverse list0)
|
||||
list1 +empty-list+))
|
||||
(declare (type list mark))
|
||||
(when (eql 1 (conx (cdar mark)))
|
||||
(setf list0 (nreverse list0)
|
||||
list1 (mapcar #'term-uncon mark))
|
||||
(return))
|
||||
(push (term-uncon (car mark)) list0))
|
||||
(values (make-cmbn :degr degr :list list0)
|
||||
(make-cmbn :degr (1- degr) :list list1))))))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -169,10 +169,10 @@
|
||||
(DEFUN CONE-2CMBN-APPEND (cmbn0 cmbn1)
|
||||
(declare (type cmbn cmbn0 cmbn1))
|
||||
(the cmbn
|
||||
(make-cmbn
|
||||
:degr (cmbn-degr cmbn0)
|
||||
:list (append (mapcar #'term-con0 (cmbn-list cmbn0))
|
||||
(mapcar #'term-con1 (cmbn-list cmbn1))))))
|
||||
(make-cmbn
|
||||
:degr (cmbn-degr cmbn0)
|
||||
:list (append (mapcar #'term-con0 (cmbn-list cmbn0))
|
||||
(mapcar #'term-con1 (cmbn-list cmbn1))))))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -182,15 +182,15 @@
|
||||
(DEFUN CONE-2MRPH-DIAG-IMPL (mrph0 mrph1)
|
||||
(declare (type morphism mrph0 mrph1))
|
||||
(the intr-mrph
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(multiple-value-bind (cmbn0 cmbn1)
|
||||
(cone-cmbn-split cmbn)
|
||||
(declare (type cmbn cmbn0 cmbn1))
|
||||
(cone-2cmbn-append (? mrph0 cmbn0)
|
||||
(? mrph1 cmbn1))))))
|
||||
#'rslt)))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(multiple-value-bind (cmbn0 cmbn1)
|
||||
(cone-cmbn-split cmbn)
|
||||
(declare (type cmbn cmbn0 cmbn1))
|
||||
(cone-2cmbn-append (? mrph0 cmbn0)
|
||||
(? mrph1 cmbn1))))))
|
||||
#'rslt)))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -202,18 +202,18 @@
|
||||
(DEFUN CONE-3MRPH-TRIANGLE-IMPL (cmpr0 mrph0 mrph1 phi)
|
||||
(declare (ignore cmpr0) (type morphism mrph0 mrph1 phi))
|
||||
(the intr-mrph
|
||||
(flet ((rslt (degr gnrt)
|
||||
(declare (type fixnum degr) (type gnrt gnrt))
|
||||
(the cmbn
|
||||
(ecase (conx gnrt)
|
||||
(0 (cmbn-con0 (? mrph0 degr (icon gnrt))))
|
||||
(1
|
||||
(let ((gnrt (icon gnrt)))
|
||||
(declare (type gnrt gnrt))
|
||||
(cone-2cmbn-append
|
||||
(? phi (1- degr) gnrt)
|
||||
(? mrph1 (1- degr) gnrt))))))))
|
||||
#'rslt)))
|
||||
(flet ((rslt (degr gnrt)
|
||||
(declare (type fixnum degr) (type gnrt gnrt))
|
||||
(the cmbn
|
||||
(ecase (conx gnrt)
|
||||
(0 (cmbn-con0 (? mrph0 degr (icon gnrt))))
|
||||
(1
|
||||
(let ((gnrt (icon gnrt)))
|
||||
(declare (type gnrt gnrt))
|
||||
(cone-2cmbn-append
|
||||
(? phi (1- degr) gnrt)
|
||||
(? mrph1 (1- degr) gnrt))))))))
|
||||
#'rslt)))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -224,25 +224,25 @@
|
||||
(funcall rslt 4 (con0 '31))
|
||||
(funcall rslt 5 (con1 '31))
|
||||
(funcall rslt 4 (con1 '15))
|
||||
; (funcall rslt (cmbn 4 1 (con0 '31) 1 (con1 '15)))
|
||||
; (funcall rslt (cmbn 4 1 (con0 '31) 1 (con1 '15))) ;
|
||||
|#
|
||||
|
||||
(DEFUN CONE (mrph)
|
||||
(declare (type morphism mrph))
|
||||
(the chain-complex
|
||||
(let ((chcm0 (trgt mrph))
|
||||
(chcm1 (sorc mrph)))
|
||||
(declare (type chain-complex chcm0 chcm1))
|
||||
(build-chcm
|
||||
:cmpr (cone-cmpr (cmpr chcm0) (cmpr chcm1))
|
||||
:basis (cone-basis (basis chcm0) (basis chcm1))
|
||||
:bsgn (con0 (bsgn chcm0))
|
||||
:intr-dffr (cone-3mrph-triangle-impl (cmpr chcm0)
|
||||
(dffr chcm0)
|
||||
(n-mrph -1 (dffr chcm1))
|
||||
mrph)
|
||||
:strt :gnrt
|
||||
:orgn `(cone ,mrph)))))
|
||||
(let ((chcm0 (trgt mrph))
|
||||
(chcm1 (sorc mrph)))
|
||||
(declare (type chain-complex chcm0 chcm1))
|
||||
(build-chcm
|
||||
:cmpr (cone-cmpr (cmpr chcm0) (cmpr chcm1))
|
||||
:basis (cone-basis (basis chcm0) (basis chcm1))
|
||||
:bsgn (con0 (bsgn chcm0))
|
||||
:intr-dffr (cone-3mrph-triangle-impl (cmpr chcm0)
|
||||
(dffr chcm0)
|
||||
(n-mrph -1 (dffr chcm1))
|
||||
mrph)
|
||||
:strt :gnrt
|
||||
:orgn `(cone ,mrph)))))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -269,16 +269,16 @@
|
||||
(type chain-complex sorc-cone trgt-cone)
|
||||
(type morphism mrph0 mrph1))
|
||||
(the morphism
|
||||
(progn
|
||||
(unless (= (degr mrph0) (degr mrph1))
|
||||
(error "Non-coherent degrees in CONE-2MRPH-DIAG."))
|
||||
(build-mrph
|
||||
:sorc sorc-cone
|
||||
:trgt trgt-cone
|
||||
:degr (degr mrph0)
|
||||
:intr (cone-2mrph-diag-impl mrph0 mrph1)
|
||||
:strt :cmbn
|
||||
:orgn `(cone-2mrph-diag ,sorc-cone ,trgt-cone ,mrph0 ,mrph1)))))
|
||||
(progn
|
||||
(unless (= (degr mrph0) (degr mrph1))
|
||||
(error "Non-coherent degrees in CONE-2MRPH-DIAG."))
|
||||
(build-mrph
|
||||
:sorc sorc-cone
|
||||
:trgt trgt-cone
|
||||
:degr (degr mrph0)
|
||||
:intr (cone-2mrph-diag-impl mrph0 mrph1)
|
||||
:strt :cmbn
|
||||
:orgn `(cone-2mrph-diag ,sorc-cone ,trgt-cone ,mrph0 ,mrph1)))))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -293,21 +293,21 @@
|
||||
(type chain-complex sorc-cone trgt-cone)
|
||||
(type morphism mrph0 mrph1 phi))
|
||||
(the morphism
|
||||
(progn
|
||||
(unless (= (degr mrph0) (degr mrph1))
|
||||
(error "Non-coherent degrees in CONE-3MRPH-TRIANGLE."))
|
||||
(unless (= (1+ (degr mrph0)) (degr phi))
|
||||
(error "Non-coherent-degrees in CONE-3MRPH-TRIANGLE."))
|
||||
(build-mrph
|
||||
:sorc sorc-cone
|
||||
:trgt trgt-cone
|
||||
:degr (degr mrph0)
|
||||
:intr (cone-3mrph-triangle-impl
|
||||
(cmpr (trgt phi))
|
||||
mrph0 mrph1 phi)
|
||||
:strt :gnrt
|
||||
:orgn `(cone-3mrph-triangle ,sorc-cone ,trgt-cone
|
||||
,mrph0 ,mrph1 ,phi)))))
|
||||
(progn
|
||||
(unless (= (degr mrph0) (degr mrph1))
|
||||
(error "Non-coherent degrees in CONE-3MRPH-TRIANGLE."))
|
||||
(unless (= (1+ (degr mrph0)) (degr phi))
|
||||
(error "Non-coherent-degrees in CONE-3MRPH-TRIANGLE."))
|
||||
(build-mrph
|
||||
:sorc sorc-cone
|
||||
:trgt trgt-cone
|
||||
:degr (degr mrph0)
|
||||
:intr (cone-3mrph-triangle-impl
|
||||
(cmpr (trgt phi))
|
||||
mrph0 mrph1 phi)
|
||||
:strt :gnrt
|
||||
:orgn `(cone-3mrph-triangle ,sorc-cone ,trgt-cone
|
||||
,mrph0 ,mrph1 ,phi)))))
|
||||
|
||||
#|
|
||||
()
|
||||
@ -330,39 +330,38 @@
|
||||
(DEFUN CONE-EFHM (cone)
|
||||
(declare (type chain-complex cone))
|
||||
(the homotopy-equivalence
|
||||
(let* ((phi (second (orgn cone)))
|
||||
(chcm0 (trgt phi)) (chcm1 (sorc phi))
|
||||
(efhm0 (efhm chcm0)) (efhm1 (efhm chcm1))
|
||||
(lf0 (lf efhm0)) (lg0 (lg efhm0)) (lh0 (lh efhm0))
|
||||
(rf0 (rf efhm0)) (rg0 (rg efhm0)) (rh0 (rh efhm0))
|
||||
(lf1 (lf efhm1)) (lg1 (lg efhm1)) (lh1 (lh efhm1))
|
||||
(rf1 (rf efhm1)) (rg1 (rg efhm1)) (rh1 (rh efhm1))
|
||||
(hphi (cmps lg0 (cmps phi lf1)))
|
||||
(ephi (cmps rf0 (cmps hphi rg1)))
|
||||
(hcone (cone hphi))
|
||||
(econe (cone ephi))
|
||||
(LF (cone-2mrph-diag hcone cone lf0 lf1))
|
||||
(LG (cone-2mrph-diag cone hcone lg0 lg1))
|
||||
(LH (cone-2mrph-diag hcone hcone lh0 (n-mrph -1 lh1)))
|
||||
(RF (cone-3mrph-triangle hcone econe rf0 rf1
|
||||
(cmps rf0 (cmps hphi rh1))))
|
||||
(RG (cone-3mrph-triangle econe hcone rg0 rg1
|
||||
(n-mrph -1 (cmps rh0 (cmps hphi rg1)))))
|
||||
(RH (cone-3mrph-triangle hcone hcone rh0 (n-mrph -1 rh1)
|
||||
(cmps rh0 (cmps hphi rh1)))))
|
||||
(declare
|
||||
(type chain-complex chcm0 chcm1 hcone econe)
|
||||
(type morphism phi lf0 lg0 lh0 rf0 rg0 rh0 lf1 lg1 lh1 rf1 rg1 rh1
|
||||
hphi ephi LF LG LH RF RG RH))
|
||||
(build-hmeq
|
||||
:lrdct (build-rdct :f LF :g LG :h LH
|
||||
:orgn `(cone-efhm ,cone lrdct))
|
||||
:rrdct (build-rdct :f RF :g RG :h RH
|
||||
:orgn `(cone-efhm ,cone rrdct))
|
||||
:orgn `(cone-efhm ,cone)))))
|
||||
(let* ((phi (second (orgn cone)))
|
||||
(chcm0 (trgt phi)) (chcm1 (sorc phi))
|
||||
(efhm0 (efhm chcm0)) (efhm1 (efhm chcm1))
|
||||
(lf0 (lf efhm0)) (lg0 (lg efhm0)) (lh0 (lh efhm0))
|
||||
(rf0 (rf efhm0)) (rg0 (rg efhm0)) (rh0 (rh efhm0))
|
||||
(lf1 (lf efhm1)) (lg1 (lg efhm1)) (lh1 (lh efhm1))
|
||||
(rf1 (rf efhm1)) (rg1 (rg efhm1)) (rh1 (rh efhm1))
|
||||
(hphi (cmps lg0 (cmps phi lf1)))
|
||||
(ephi (cmps rf0 (cmps hphi rg1)))
|
||||
(hcone (cone hphi))
|
||||
(econe (cone ephi))
|
||||
(LF (cone-2mrph-diag hcone cone lf0 lf1))
|
||||
(LG (cone-2mrph-diag cone hcone lg0 lg1))
|
||||
(LH (cone-2mrph-diag hcone hcone lh0 (n-mrph -1 lh1)))
|
||||
(RF (cone-3mrph-triangle hcone econe rf0 rf1
|
||||
(cmps rf0 (cmps hphi rh1))))
|
||||
(RG (cone-3mrph-triangle econe hcone rg0 rg1
|
||||
(n-mrph -1 (cmps rh0 (cmps hphi rg1)))))
|
||||
(RH (cone-3mrph-triangle hcone hcone rh0 (n-mrph -1 rh1)
|
||||
(cmps rh0 (cmps hphi rh1)))))
|
||||
(declare
|
||||
(type chain-complex chcm0 chcm1 hcone econe)
|
||||
(type morphism phi lf0 lg0 lh0 rf0 rg0 rh0 lf1 lg1 lh1 rf1 rg1 rh1
|
||||
hphi ephi LF LG LH RF RG RH))
|
||||
(build-hmeq
|
||||
:lrdct (build-rdct :f LF :g LG :h LH
|
||||
:orgn `(cone-efhm ,cone lrdct))
|
||||
:rrdct (build-rdct :f RF :g RG :h RH
|
||||
:orgn `(cone-efhm ,cone rrdct))
|
||||
:orgn `(cone-efhm ,cone)))))
|
||||
|
||||
(DEFMETHOD SEARCH-EFHM (chcm (orgn (eql 'cone)))
|
||||
(declare (type chain-complex chcm))
|
||||
(the homotopy-equivalence
|
||||
(cone-efhm chcm)))
|
||||
|
||||
(cone-efhm chcm)))
|
||||
|
||||
@ -352,12 +352,18 @@
|
||||
,@body))))
|
||||
|
||||
(DEFMACRO BCNB (gnrt)
|
||||
"(BCNB GNRT) returns the representation of the generator GNRT belonging to the
|
||||
chain complex B."
|
||||
`(make-bicn :bcnx :bcnb :ibicn ,gnrt))
|
||||
|
||||
(DEFMACRO BCNC (gnrt)
|
||||
"(BCNC GNRT) returns the representation of the generator GNRT belonging to the
|
||||
chain complex C."
|
||||
`(make-bicn :bcnx :bcnc :ibicn ,gnrt))
|
||||
|
||||
(DEFMACRO BCND (gnrt)
|
||||
"(BCND GNRT) returns the representation of the generator GNRT belonging to the
|
||||
chain complex D."
|
||||
`(make-bicn :bcnx :bcnd :ibicn ,gnrt))
|
||||
|
||||
(DEFMACRO WITH-BICN ((bcnx ibicn) bicn . body)
|
||||
|
||||
118
test/bicones-test.lisp
Normal file
118
test/bicones-test.lisp
Normal file
@ -0,0 +1,118 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
(test bicn-cmbn
|
||||
(let* ((comb-bic (cat:cmbn 3 2 (cat:bcnb 'b1) 4 (cat:bcnb 'b2)
|
||||
6 (cat:bcnb 'b3) 3 (cat:bcnc 'c1)
|
||||
5 (cat:bcnc 'c2) 7 (cat:bcnd 'd1))))
|
||||
(cat:cmbn-list comb-bic)
|
||||
(cat:dispatch-bicn-cmbn (cat:cmbn 3 3 (cat:bcnb 'b1)
|
||||
4 (cat:bcnb 'b2)
|
||||
33 (cat:bcnc 'c)
|
||||
333 (cat:bcnd 'd)))))
|
||||
|
||||
(test bicn-cmbn-cmbn*
|
||||
(is (cat:cmbn-non-zero-p
|
||||
(cat:bicn-cmbn-cmbnb (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)))))
|
||||
(is (cat:cmbn-zero-p
|
||||
(cat:bicn-cmbn-cmbnb (cat:cmbn 3 2 (cat:bcnc 'b)))))
|
||||
(is (cat:cmbn-non-zero-p
|
||||
(cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)
|
||||
3 (cat:bcnd 'c)))))
|
||||
(is (cat:cmbn-zero-p
|
||||
(cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 3 (cat:bcnd 'c)))))
|
||||
(is (cat:cmbn-non-zero-p
|
||||
(cat:bicn-cmbn-cmbnd (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)
|
||||
3 (cat:bcnd 'c)))))
|
||||
(is (cat:cmbn-zero-p
|
||||
(cat:bicn-cmbn-cmbnd (cat:cmbn 3 2 (cat:bcnb 'b))))))
|
||||
|
||||
(test make-bicn-cmbn
|
||||
(multiple-value-call #'cat:make-bicn-cmbn
|
||||
(cat:dispatch-bicn-cmbn
|
||||
(cat:cmbn 3 3 (cat:bcnb 'b1) 4 (cat:bcnb 'b2) 33 (cat:bcnc 'c)
|
||||
333 (cat:bcnd 'd)))))
|
||||
|
||||
(test bicn-print
|
||||
(let ((a (format nil "~A" (cat:bcnb 'a)))
|
||||
(b (format nil "~A" (cat:bcnc 'b)))
|
||||
(c (format nil "~A" (cat:bcnd 'c))))
|
||||
(is (string= a "<BcnB A>"))
|
||||
(is (string= b "<BcnC B>"))
|
||||
(is (string= c "<BcnD C>"))))
|
||||
|
||||
(test bicone-cmpr
|
||||
(let ((r (cat:bicone-cmpr #'cat:f-cmpr #'cat:f-cmpr #'cat:f-cmpr)))
|
||||
(is (equal :less (funcall r (cat:bcnb 1) (cat:bcnc 0))))
|
||||
(is (equal :less (funcall r (cat:bcnb 1) (cat:bcnb 2))))))
|
||||
|
||||
(test bicone-basis
|
||||
(is (equal :locally-effective
|
||||
(cat:bicone-basis :locally-effective
|
||||
:locally-effective
|
||||
:locally-effective)))
|
||||
(let* ((b #'(lambda (degr)
|
||||
(mapcar #'(lambda (item)
|
||||
(cons degr item)) (cat:<a-b> 0 degr))))
|
||||
(r (cat:bicone-basis b b b)))
|
||||
(is (not (null (funcall r 3))))))
|
||||
|
||||
|
||||
(test bicone
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let ((delta3 (cdelta1 3))
|
||||
(bic (cat:bicone (make-rdct1 3 2) (make-rdct1 4 2))))
|
||||
#|
|
||||
(princ (cat:basis delta3 0))
|
||||
(princ (cat:basis delta3 1))
|
||||
(princ (cat:basis delta3 2))
|
||||
(princ (cat:basis delta3 3))
|
||||
(princ (cat:basis delta3 4))
|
||||
|#
|
||||
(princ (cat:basis bic 0))
|
||||
(princ (cat:basis bic 1))
|
||||
(princ (cat:basis bic 4))
|
||||
(princ (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3))
|
||||
4 (cat:bcnc '(0 1 2 3))
|
||||
5 (cat:bcnd '(0 1 4)))))
|
||||
(is (cat:cmbn-zero-p
|
||||
(cat:? bic
|
||||
(cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3))
|
||||
4 (cat:bcnc '(0 1 2 3))
|
||||
5 (cat:bcnd '(0 1 4))))))))))
|
||||
|
||||
|
||||
(test cmps
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let* ((c (cat:build-chcm
|
||||
:cmpr #'cat:s-cmpr
|
||||
:basis #'(lambda (dmns) '(a))
|
||||
:bsgn 'a
|
||||
:intr-dffr #'cat:zero-intr-dffr
|
||||
:strt :cmbn
|
||||
:orgn '(c)))
|
||||
(h1 (cat:trivial-hmeq c))
|
||||
(h2 (cat:cmps h1 h1))
|
||||
(h3 (cat:cmps h2 h2)))
|
||||
(cat:pre-check-rdct (cat:lrdct h2))
|
||||
(setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB 'a) 10 (cat:bcnC 'a)
|
||||
100 (cat:bcnD 'a)))
|
||||
(setf cat:*bc* (cat:cmbn 3 1 'a))
|
||||
(check-rdct)
|
||||
(cat:pre-check-rdct (cat:rrdct h2))
|
||||
(check-rdct)
|
||||
(setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB (cat:bcnB 'a))
|
||||
10 (cat:bcnB (cat:bcnC 'a))
|
||||
100 (cat:bcnB (cat:bcnD 'a))
|
||||
1000 (cat:bcnC 'a)
|
||||
10000 (cat:bcnD (cat:bcnB 'a))
|
||||
5234 (cat:bcnD (cat:bcnC 'a))
|
||||
223 (cat:bcnD (cat:bcnD 'a))))
|
||||
(cat:pre-check-rdct (cat:lrdct h3))
|
||||
(check-rdct)
|
||||
(cat:pre-check-rdct (cat:rrdct h3))
|
||||
(check-rdct))))
|
||||
@ -45,20 +45,7 @@
|
||||
(is (equal (cat:cmbn-list comb) (cons (cons 1 n) nil))))))))
|
||||
|
||||
|
||||
(defparameter *n* 10)
|
||||
(defun ff (degr i)
|
||||
(do ((2*n* (ash *n* 1))
|
||||
(rslt cat:+empty-list+
|
||||
(cons (cons (let ((cffc (- (random 2*n*) *n*)))
|
||||
(if (minusp cffc) cffc (1+ cffc)))
|
||||
(decf gnrt (1+ (random *n*))))
|
||||
rslt))
|
||||
(gnrt i)
|
||||
(k 0 (1+ k)))
|
||||
((= k *n*)
|
||||
(cat:make-cmbn
|
||||
:degr degr
|
||||
:list rslt))))
|
||||
(setf *n* 10)
|
||||
|
||||
(test cmbn-?
|
||||
(progn
|
||||
|
||||
@ -44,20 +44,7 @@
|
||||
(is (eq -zi -zi2)))))
|
||||
|
||||
|
||||
(defparameter *n* 5)
|
||||
(defun ff (degr i)
|
||||
(do ((2*n* (ash *n* 1))
|
||||
(rslt cat:+empty-list+
|
||||
(cons (cons (let ((cffc (- (random 2*n*) *n*)))
|
||||
(if (minusp cffc) cffc (1+ cffc)))
|
||||
(decf gnrt (1+ (random *n*))))
|
||||
rslt))
|
||||
(gnrt i)
|
||||
(k 0 (1+ k)))
|
||||
((= k *n*)
|
||||
(cat:make-cmbn
|
||||
:degr degr
|
||||
:list rslt))))
|
||||
(setf *n* 5)
|
||||
|
||||
(test cmps
|
||||
(progn
|
||||
|
||||
170
test/common.lisp
Normal file
170
test/common.lisp
Normal file
@ -0,0 +1,170 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(def-suite :kenzo)
|
||||
|
||||
(defparameter *n* -1)
|
||||
|
||||
(defun ff (degr i)
|
||||
(declare (special *n*))
|
||||
(do ((2*n* (ash *n* 1))
|
||||
(rslt cat:+empty-list+
|
||||
(cons (cons (let ((cffc (- (random 2*n*) *n*)))
|
||||
(if (minusp cffc) cffc (1+ cffc)))
|
||||
(decf gnrt (1+ (random *n*))))
|
||||
rslt))
|
||||
(gnrt i)
|
||||
(k 0 (1+ k)))
|
||||
((= k *n*)
|
||||
(cat:make-cmbn :degr degr :list rslt))))
|
||||
|
||||
|
||||
(defun cdelta (dmns)
|
||||
(the cat:chain-complex
|
||||
(cat:build-chcm
|
||||
:cmpr #'cat:l-cmpr
|
||||
:basis :locally-effective
|
||||
:bsgn '(0)
|
||||
:intr-dffr #'(lambda (degr gmsm)
|
||||
(cat:make-cmbn
|
||||
:degr (1- degr)
|
||||
:list (do ((rslt cat:+empty-list+
|
||||
(cons (cons sign
|
||||
(append
|
||||
(subseq gmsm 0 nark)
|
||||
(subseq gmsm (1+ nark))))
|
||||
rslt))
|
||||
(sign 1 (- sign))
|
||||
(nark 0 (1+ nark)))
|
||||
((> nark degr) rslt))))
|
||||
:strt :gnrt
|
||||
:orgn `(locally effective version of C_* delta ,dmns))))
|
||||
|
||||
|
||||
(defun make-f (tdmns bdmns)
|
||||
(cat:build-mrph
|
||||
:sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0
|
||||
:intr #'(lambda (degr gmsm)
|
||||
(let ((pos (position-if #'(lambda (vertex)
|
||||
(>= vertex bdmns)) gmsm)))
|
||||
(if pos
|
||||
(if (< pos degr)
|
||||
(cat:zero-cmbn degr)
|
||||
(cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
|
||||
(cat:cmbn degr 1 gmsm))))
|
||||
:strt :gnrt
|
||||
:orgn `(projection delta ,tdmns => delta ,bdmns)))
|
||||
|
||||
|
||||
(defun make-g (tdmns bdmns)
|
||||
(cat:build-mrph
|
||||
:sorc (cdelta bdmns) :trgt (cdelta tdmns) :degr 0
|
||||
:intr #'identity
|
||||
:strt :cmbn
|
||||
:orgn `(injection delta ,bdmns => delta ,tdmns)))
|
||||
|
||||
|
||||
(defun make-h (tdmns bdmns)
|
||||
(cat:build-mrph
|
||||
:sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1
|
||||
:intr #'(lambda (degr gmsm)
|
||||
(let ((pos (position-if #'(lambda (vertex)
|
||||
(>= vertex bdmns)) gmsm)))
|
||||
(if pos
|
||||
(if (member bdmns gmsm)
|
||||
(cat:zero-cmbn (1+ degr))
|
||||
(cat:cmbn (1+ degr) (cat:-1-expt-n pos)
|
||||
(append (subseq gmsm 0 pos) (list bdmns)
|
||||
(subseq gmsm pos))))
|
||||
(cat:zero-cmbn (1+ degr)))))
|
||||
:strt :gnrt
|
||||
:orgn `(homotopy for delta ,tdmns => ,bdmns)))
|
||||
|
||||
|
||||
(defun make-rdct (tdmns bdmns)
|
||||
(let ((rdct (cat:build-rdct
|
||||
:f (make-f tdmns bdmns)
|
||||
:g (make-g tdmns bdmns)
|
||||
:h (make-h tdmns bdmns)
|
||||
:orgn `(reduction delta ,tdmns ,bdmns))))
|
||||
rdct))
|
||||
|
||||
(defun cdelta1 (dmns)
|
||||
(cat:build-chcm
|
||||
:cmpr #'cat:l-cmpr
|
||||
:basis #'(lambda (n)
|
||||
(mapcar #'cat:dlop-int-ext (funcall (cat:delta-n-basis dmns) n)))
|
||||
:bsgn '(0)
|
||||
:intr-dffr #'(lambda (degr gmsm)
|
||||
(cat:make-cmbn
|
||||
:degr (1- degr)
|
||||
:list (do ((rslt cat:+empty-list+
|
||||
(cons (cons sign (append
|
||||
(subseq gmsm 0 nark)
|
||||
(subseq gmsm (1+ nark))))
|
||||
rslt))
|
||||
(sign 1 (- sign))
|
||||
(nark 0 (1+ nark)))
|
||||
((> nark degr) rslt))))
|
||||
:strt :gnrt
|
||||
:orgn `(locally effective version of C_* delta ,dmns)))
|
||||
|
||||
(defun make-f1 (tdmns bdmns)
|
||||
(cat:build-mrph
|
||||
:sorc (cdelta1 tdmns) :trgt (cdelta1 bdmns) :degr 0
|
||||
:intr #'(lambda (degr gmsm)
|
||||
(let ((pos (position-if #'(lambda (vertex)
|
||||
(>= vertex bdmns)) gmsm)))
|
||||
(if pos
|
||||
(if (< pos degr)
|
||||
(cat:zero-cmbn degr)
|
||||
(cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
|
||||
(cat:cmbn degr 1 gmsm))))
|
||||
:strt :gnrt
|
||||
:orgn `(projection delta ,tdmns => delta ,bdmns)))
|
||||
|
||||
|
||||
(defun make-g1 (tdmns bdmns)
|
||||
(cat:build-mrph
|
||||
:sorc (cdelta1 bdmns) :trgt (cdelta1 tdmns) :degr 0
|
||||
:intr #'identity
|
||||
:strt :cmbn
|
||||
:orgn `(injection delta ,bdmns => delta ,tdmns)))
|
||||
|
||||
|
||||
(defun make-h1 (tdmns bdmns)
|
||||
(cat:build-mrph
|
||||
:sorc (cdelta1 tdmns) :trgt (cdelta1 tdmns) :degr +1
|
||||
:intr #'(lambda (degr gmsm)
|
||||
(let ((pos (position-if #'(lambda (vertex)
|
||||
(>= vertex bdmns)) gmsm)))
|
||||
(if pos
|
||||
(if (member bdmns gmsm)
|
||||
(cat:zero-cmbn (1+ degr))
|
||||
(cat:cmbn (1+ degr) (cat:-1-expt-n pos)
|
||||
(append (subseq gmsm 0 pos) (list bdmns)
|
||||
(subseq gmsm pos))))
|
||||
(cat:zero-cmbn (1+ degr)))))
|
||||
:strt :gnrt
|
||||
:orgn `(homotopy for delta ,tdmns => ,bdmns)))
|
||||
|
||||
|
||||
(defun make-rdct1 (tdmns bdmns)
|
||||
(let ((rdct (cat:build-rdct
|
||||
:f (make-f1 tdmns bdmns)
|
||||
:g (make-g1 tdmns bdmns)
|
||||
:h (make-h1 tdmns bdmns)
|
||||
:orgn `(reduction delta ,tdmns ,bdmns))))
|
||||
rdct))
|
||||
|
||||
|
||||
(defun check-rdct ()
|
||||
(dolist (phi '(cat:*tdd* cat:*bdd* cat:*df-fd* cat:*dg-gd* cat:*id-fg*
|
||||
cat:*id-gf-dh-hd* cat:*hh* cat:*fh* cat:*hg*))
|
||||
(declare (type symbol phi))
|
||||
(is (cat:cmbn-zero-p
|
||||
(cat:cmbn-? (eval phi)
|
||||
(if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg*
|
||||
cat:*dg-gd* cat:*hg*))
|
||||
cat:*bc*
|
||||
cat:*tc*))))))
|
||||
@ -3,27 +3,6 @@
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
(defun cdelta (dmns)
|
||||
(the cat:chain-complex
|
||||
(cat:build-chcm
|
||||
:cmpr #'cat:l-cmpr
|
||||
:basis :locally-effective
|
||||
:bsgn '(0)
|
||||
:intr-dffr #'(lambda (degr gmsm)
|
||||
(cat:make-cmbn
|
||||
:degr (1- degr)
|
||||
:list (do ((rslt cat:+empty-list+
|
||||
(cons (cons sign
|
||||
(append
|
||||
(subseq gmsm 0 nark)
|
||||
(subseq gmsm (1+ nark))))
|
||||
rslt))
|
||||
(sign 1 (- sign))
|
||||
(nark 0 (1+ nark)))
|
||||
((> nark degr) rslt))))
|
||||
:strt :gnrt
|
||||
:orgn `(locally effective version of C_* delta ,dmns))))
|
||||
|
||||
(test cdelta
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
@ -38,63 +17,6 @@
|
||||
(signals simple-error (equal (cat:basis cc 5) cat:+empty-list+)))))
|
||||
|
||||
|
||||
(defun make-f (tdmns bdmns)
|
||||
(cat:build-mrph
|
||||
:sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0
|
||||
:intr #'(lambda (degr gmsm)
|
||||
(let ((pos (position-if #'(lambda (vertex)
|
||||
(>= vertex bdmns)) gmsm)))
|
||||
(if pos
|
||||
(if (< pos degr)
|
||||
(cat:zero-cmbn degr)
|
||||
(cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
|
||||
(cat:cmbn degr 1 gmsm))))
|
||||
:strt :gnrt
|
||||
:orgn `(projection delta ,tdmns => delta ,bdmns)))
|
||||
|
||||
(defun make-g (tdmns bdmns)
|
||||
(cat:build-mrph
|
||||
:sorc (cdelta bdmns) :trgt (cdelta tdmns) :degr 0
|
||||
:intr #'identity
|
||||
:strt :cmbn
|
||||
:orgn `(injection delta ,bdmns => delta ,tdmns)))
|
||||
|
||||
(defun make-h (tdmns bdmns)
|
||||
(cat:build-mrph
|
||||
:sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1
|
||||
:intr #'(lambda (degr gmsm)
|
||||
(let ((pos (position-if #'(lambda (vertex)
|
||||
(>= vertex bdmns)) gmsm)))
|
||||
(if pos
|
||||
(if (member bdmns gmsm)
|
||||
(cat:zero-cmbn (1+ degr))
|
||||
(cat:cmbn (1+ degr) (cat:-1-expt-n pos)
|
||||
(append (subseq gmsm 0 pos) (list bdmns)
|
||||
(subseq gmsm pos))))
|
||||
(cat:zero-cmbn (1+ degr)))))
|
||||
:strt :gnrt
|
||||
:orgn `(homotopy for delta ,tdmns => ,bdmns)))
|
||||
|
||||
(defun make-rdct (tdmns bdmns)
|
||||
(let ((rdct (cat:build-rdct
|
||||
:f (make-f tdmns bdmns)
|
||||
:g (make-g tdmns bdmns)
|
||||
:h (make-h tdmns bdmns)
|
||||
:orgn `(reduction delta ,tdmns ,bdmns))))
|
||||
rdct))
|
||||
|
||||
|
||||
(defun check-rdct ()
|
||||
(dolist (phi '(cat:*tdd* cat:*bdd* cat:*df-fd* cat:*dg-gd* cat:*id-fg*
|
||||
cat:*id-gf-dh-hd* cat:*hh* cat:*fh* cat:*hg*))
|
||||
(declare (type symbol phi))
|
||||
(is (cat:cmbn-zero-p
|
||||
(cat:cmbn-? (eval phi)
|
||||
(if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg*
|
||||
cat:*dg-gd* cat:*hg*))
|
||||
cat:*bc*
|
||||
cat:*tc*))))))
|
||||
|
||||
(test make-rdct
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
@ -106,6 +28,7 @@
|
||||
(setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
|
||||
(check-rdct))))
|
||||
|
||||
|
||||
(test cmps
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
@ -118,6 +41,7 @@
|
||||
(setf cat:*bc* (cat:cmbn 2 1 '(0 1 3)))
|
||||
(check-rdct))))
|
||||
|
||||
|
||||
(test zero-mrph
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
@ -129,6 +53,7 @@
|
||||
(setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
|
||||
(check-rdct))))
|
||||
|
||||
|
||||
(test opps
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
@ -140,6 +65,7 @@
|
||||
(setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
|
||||
(check-rdct))))
|
||||
|
||||
|
||||
;; an absurd reduction ; just to test bpl-*-sigma
|
||||
(test bpl-*-sigma
|
||||
(progn
|
||||
@ -175,6 +101,7 @@
|
||||
(cat:gnrt-? (cat:dffr (cat:tcc new-rdct)) 3 '(3 5))
|
||||
(cat:gnrt-? (cat:dffr (cat:bcc new-rdct)) 3 '(3 5)))))
|
||||
|
||||
|
||||
(test trivial-hmeq
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user