90 lines
2.4 KiB
Common Lisp
90 lines
2.4 KiB
Common Lisp
|
|
(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)))
|
|
|
|
)
|
|
|
|
))
|