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

Added effective homology test.

Browse Source
This commit is contained in:
gheber 2015-01-01 18:52:53 -06:00
parent ad86b8c500
commit fe0f5a3e96
3 changed files with 97 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
package.lisp
View File

@ -30,15 +30,20 @@
;; classes.lisp
BCC
CHAIN-COMPLEX
CMBN-CMBN
CMBN-DEGR
CMBN-LIST
DEGR
DFFR1
CMBN-LIST
F
G
H
MAKE-CMBN
MAKE-RESULT
MORPHISM
TCC
;; combinations.lisp
@ -82,6 +87,7 @@
CMPR
DFFR
GNRT
I-SBTR
TERM
TERM-CMBN

69
src/effective-homology.lisp
View File

@ -111,74 +111,7 @@
(declare (type homotopy-equivalence hmeq))
(push hmeq *hmeq-list*)
hmeq))))))
#|
(cat-init)
(progn ;;;; reused in another test
(defun cdelta (dmns)
(build-chcm
:cmpr #'l-cmpr
:basis :locally-effective
: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 rdct (make-rdct 6 3))
(setf f (f rdct) g (g rdct) h (h rdct)
tcc (tcc rdct) bcc (bcc rdct))
(setf dh (cmps (dffr tcc) h))
(setf hd (cmps h (dffr tcc)))
(setf gf (cmps g f))
(setf id-gf-dh-hd (i-sbtr (idnt-mrph tcc) gf dh hd))
(setf c (cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) 1000 '(2 3 4)))
(cmbn-? id-gf-dh-hd c)
|#
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))

89
test/effective-homology-test.lisp Normal file
View File

@ -0,0 +1,89 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(defun cdelta (dmns)
(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))
(test cdelta
(progn
(cat:cat-init)
(let* ((rdct (make-rdct 6 3))
(f (cat:f rdct))
(g (cat:g rdct))
(h (cat:h rdct))
(tcc (cat:tcc rdct))
(bcc (cat:bcc rdct))
(dh (cat:cmps (cat:dffr tcc) h))
(hd (cat:cmps h (cat:dffr tcc)))
(gf (cat:cmps g f))
(id-gf-dh-hd (cat:i-sbtr (cat:idnt-mrph tcc) gf dh hd))
(c (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4)
1000 '(2 3 4)))
(comb (cat:cmbn-? id-gf-dh-hd c)))
)
))