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

Added bicone tests and refactored common functions.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-05 19:19:10 -05:00
parent cbe1401e76
commit ded9d544ca
10 changed files with 810 additions and 655 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
kenzo-test.asd
View File

@ -8,6 +8,7 @@
:depends-on (:kenzo :fiveam) :depends-on (:kenzo :fiveam)
:pathname #P"test/" :pathname #P"test/"
:components ((:file "package") :components ((:file "package")
(:file "common")
(:file "combinations-test") (:file "combinations-test")
(:file "various-test") (:file "various-test")
(:file "chain-complexes-test") (:file "chain-complexes-test")
@ -15,4 +16,5 @@
(:file "diabolo") (:file "diabolo")
(:file "circle") (:file "circle")
(:file "ccn") (:file "ccn")
(:file "effective-homology-test"))) (:file "effective-homology-test")
(:file "bicones-test")))

23
package.lisp
View File

@ -20,6 +20,17 @@
*TC* *TC*
*TDD* *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 ;; chain-complexes.lisp
?2 ?2
@ -70,6 +81,7 @@
MORPHISM MORPHISM
ORGN ORGN
REDUCTION REDUCTION
RRDCT
TCC TCC
;; combinations.lisp ;; combinations.lisp
@ -92,6 +104,10 @@
ZERO-CMBN ZERO-CMBN
ZERO-INTR-DFFR ZERO-INTR-DFFR
;; delta.lisp
DELTA-N-BASIS
;; effective-homology.lisp ;; effective-homology.lisp
BUILD-RDCT BUILD-RDCT
@ -115,6 +131,9 @@
? ?
BASIS BASIS
BCC BCC
BCNB
BCNC
BCND
BINOMIAL-P-Q BINOMIAL-P-Q
CFFC CFFC
CMBN-NON-ZERO-P CMBN-NON-ZERO-P
@ -132,6 +151,10 @@
HOMOLOGY HOMOLOGY
;; simplicial-sets.lisp
DLOP-INT-EXT
;; smith.lisp ;; smith.lisp
CHML-CLSS CHML-CLSS

700
src/bicones.lisp
View File

@ -7,438 +7,374 @@
(PROVIDE "bicones") (PROVIDE "bicones")
(DEFUN DISPATCH-BICN-CMBN (cmbn) (DEFUN DISPATCH-BICN-CMBN (cmbn)
(declare (type cmbn cmbn)) "(DISPATCH-BICN-CMBN CMBN) splits the bicone combination CMBN into three
(the (values cmbn cmbn cmbn) combinations and returns 3 values."
(with-cmbn (degr list) cmbn (declare (type cmbn cmbn))
(let ((listb +empty-list+) (the (values cmbn cmbn cmbn)
(listc +empty-list+) (with-cmbn (degr list) cmbn
(listd +empty-list+)) (let ((listb +empty-list+)
(declare (list listb listc listd)) (listc +empty-list+)
(dolist (term list) (listd +empty-list+))
(declare (type term term)) (declare (list listb listc listd))
(with-term (cffc bicn) term (dolist (term list)
(with-bicn (bcnx ibicn) bicn (declare (type term term))
(ecase bcnx (with-term (cffc bicn) term
(:bcnb (push (term cffc ibicn) listb)) (with-bicn (bcnx ibicn) bicn
(:bcnc (push (term cffc ibicn) listc)) (ecase bcnx
(:bcnd (push (term cffc ibicn) listd)))))) (:bcnb (push (term cffc ibicn)
(values listb))
(make-cmbn :degr degr :list (nreverse listb)) (:bcnc (push (term cffc ibicn)
(make-cmbn :degr (1+ degr) :list (nreverse listc)) listc))
(make-cmbn :degr degr :list (nreverse listd))))))) (:bcnd (push (term cffc ibicn)
listd))))))
#| (values
() (make-cmbn :degr degr :list (nreverse listb))
(dispatch-bicn-cmbn (cmbn 3 3 (bcnb 'b1) 4 (bcnb 'b2) 33 (bcnc 'c) 333 (bcnd 'd))) (make-cmbn :degr (1+ degr) :list (nreverse listc))
|# (make-cmbn :degr degr :list (nreverse listd)))))))
(DEFUN BICN-CMBN-CMBNB (cmbn) (DEFUN BICN-CMBN-CMBNB (cmbn)
(declare (type cmbn 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 (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(make-cmbn :degr degr (make-cmbn
:list (do ((rslt +empty-list+) :degr degr
(mark list (cdr mark))) :list (do ((rslt +empty-list+)
((endp mark) (nreverse rslt)) (mark list (cdr mark)))
(declare (list rslt mark)) ((endp mark) (nreverse rslt))
(with--term (cffc bicn) mark (declare (list rslt mark))
(with-bicn (bcnx gnrtB) bicn (with--term (cffc bicn) mark
(if (eq bcnx :bcnB) (with-bicn (bcnx gnrtB) bicn
(push (term cffc gnrtB) rslt) (if (eq bcnx :bcnB)
(return (nreverse rslt)))))))))) (push (term cffc gnrtB)
rslt)
(return
(nreverse rslt))))))))))
(DEFUN BICN-CMBN-CMBNC (cmbn) (DEFUN BICN-CMBN-CMBNC (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn "(BICN-CMBN-CMBNC CMBN) extracts from the bicone combination CMBN of degree
(with-cmbn (degr list) cmbn n the C-component as a legal combination of degree n+1 in C. If the C-component
(make-cmbn :degr (1+ degr) is empty, the null combination of degree n+1 in C is returned."
:list (do ((rslt +empty-list+) (the cmbn
(mark (member :bcnc list (with-cmbn (degr list) cmbn
;; Correction 1-1-2 (make-cmbn
:key #'(lambda (term) :degr (1+ degr)
(declare (type term term)) :list (do ((rslt +empty-list+)
(bcnx (gnrt term)))) (mark (member :bcnc list
(cdr mark))) ;; Correction 1-1-2
((endp mark) (nreverse rslt)) :key #'(lambda (term)
(declare (list rslt mark)) (declare (type term term))
(with--term (cffc bicn) mark (bcnx (gnrt term))))
(with-bicn (bcnx gnrtC) bicn (cdr mark)))
(if (eq bcnx :bcnC) ((endp mark) (nreverse rslt))
(push (term cffc gnrtC) rslt) (declare (list rslt mark))
(return (nreverse rslt)))))))))) (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) (DEFUN BICN-CMBN-CMBND (cmbn)
(declare (type cmbn 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 (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(make-cmbn :degr degr (make-cmbn
:list (mapcar :degr degr
#'(lambda (term) :list (mapcar
(declare (type term term)) #'(lambda (term)
(with-term (cffc bicn) term (declare (type term term))
(term cffc (ibicn bicn)))) (with-term (cffc bicn) term
(member :bcnd list (term cffc (ibicn bicn))))
:key #'(lambda (term) (member
(declare (type term term)) :bcnd list
(the keyword (bcnx (gnrt term)))))))))) :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) (DEFUN MAKE-BICN-CMBN (cmbnb cmbnc cmbnd)
(declare (type cmbn cmbnb cmbnc cmbnd)) (declare (type cmbn cmbnb cmbnc cmbnd))
(the cmbn "(MAKE-BICN-CMBN CMBNB CMBNC CMBND) constructs a bicone combination from
(with-cmbn (degrb listb) cmbnb CMBNB, CMBNC and CMBND, which belong to chain complexes B, C, D, respectively.
(with-cmbn (degrc listc) cmbnc Combinations CMBNB and CMBND must be of the same degree n and combination
(with-cmbn (degrd listd) cmbnd CMBNC must be of degree n+1, yiedling a bicone combination of degree n."
(unless (= degrb (1- degrc) degrd) (the cmbn
(error "In MAKE-BICN-CMBN, the degrees are not coherent.")) (with-cmbn
(make-cmbn :degr degrb (degrb listb) cmbnb
:list (nconc (with-cmbn
(mapcar #'(lambda (termb) (degrc listc) cmbnc
(declare (type term termb)) (with-cmbn
(with-term (cffc gnrtb) termb (degrd listd) cmbnd
(term cffc (bcnb gnrtb)))) (unless (= degrb (1- degrc) degrd)
listb) (error "In MAKE-BICN-CMBN, the degrees are not coherent."))
(mapcar #'(lambda (termc) (make-cmbn
(declare (type term termc)) :degr degrb
(with-term (cffc gnrtc) termc :list (nconc
(term cffc (bcnc gnrtc)))) (mapcar #'(lambda (termb)
listc) (declare (type term termb))
(mapcar #'(lambda (termd) (with-term (cffc gnrtb) termb
(declare (type term termd)) (term cffc (bcnb gnrtb))))
(with-term (cffc gnrtd) termd listb)
(term cffc (bcnd gnrtd)))) (mapcar #'(lambda (termc)
listd)))))))) (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) (DEFUN BICN-PRINT (bicn stream depth)
(declare (declare
(type bicn bicn) (stream stream) (type bicn bicn) (stream stream)
(ignore depth)) (ignore depth))
(the bicn (the bicn
(with-bicn (bcnx ibicn) bicn (with-bicn (bcnx ibicn) bicn
;; Correction 1-1-2 ;; Correction 1-1-2
(format stream "<Bcn~A ~A>" (format stream "<Bcn~A ~A>"
;; Correction 1-1-3 ;; Correction 1-1-3
(ecase bcnx (:bcnb #\B) (:bcnc #\C) (:bcnd #\D)) (ecase bcnx (:bcnb #\B) (:bcnc #\C) (:bcnd #\D))
ibicn) ibicn)
bicn))) bicn)))
#|
()
(bcnb 'a)
(bcnc 'b)
(bcnd 'c)
|#
(DEFUN BICONE-CMPR (cmprb cmprc cmprd) (DEFUN BICONE-CMPR (cmprb cmprc cmprd)
(declare (type cmprf cmprb cmprc cmprd)) (declare (type cmprf cmprb cmprc cmprd))
(flet ((rslt (bicn1 bicn2) "(BICONE-CMPR CMPRB CMPRC CMPRD) returns a comparison function for bicone
(declare (type bicn bicn1 bicn2)) generators, which is contructed from the comparison functions CMPRB, CMPRC
(let ((bcnx1 (bcnx bicn1))) and CMPRD."
(declare (type (member :bcnb :bcnc :bcnd) bcnx1)) (flet ((rslt (bicn1 bicn2)
(lexico (declare (type bicn bicn1 bicn2))
(s-cmpr bcnx1 (bcnx bicn2)) (let ((bcnx1 (bcnx bicn1)))
(case bcnx1 (declare (type (member :bcnb :bcnc :bcnd) bcnx1))
(:bcnb (funcall cmprb (ibicn bicn1) (ibicn bicn2))) (lexico
(:bcnc (funcall cmprc (ibicn bicn1) (ibicn bicn2))) (s-cmpr bcnx1 (bcnx bicn2))
(:bcnd (funcall cmprd (ibicn bicn1) (ibicn bicn2)))))))) (case bcnx1
(the cmprf #'rslt))) (: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) (DEFUN BICONE-BASIS (basisb basisc basisd)
(declare (type basis basisb basisc basisd)) (declare (type basis basisb basisc basisd))
(the basis "(BICONE-BASIS BASISB BASISC BASISD) returns a bicone basis function built
(if (or (eq :locally-effective basisb) from the basis functions BASISB, BASISC and BASISD. If at least one is
(eq :locally-effective basisc) locally effective, the function returns the symbol :locally-effective."
(eq :locally-effective basisd)) (the basis
:locally-effective (if (or (eq :locally-effective basisb)
(flet ((rslt (degr) (eq :locally-effective basisc)
(declare (fixnum degr)) (eq :locally-effective basisd))
(append :locally-effective
(mapcar #'(lambda (item) (flet ((rslt (degr)
(declare (type gnrt item)) (declare (fixnum degr))
(bcnb item)) (append
(funcall basisb degr)) (mapcar #'(lambda (item)
(mapcar #'(lambda (item) (declare (type gnrt item))
(declare (type gnrt item)) (bcnb item))
(bcnc item)) (funcall basisb degr))
(funcall basisc (1+ degr))) (mapcar #'(lambda (item)
(mapcar #'(lambda (item) (declare (type gnrt item))
(declare (type gnrt item)) (bcnc item))
(bcnd item)) (funcall basisc (1+ degr)))
(funcall basisd degr))))) (mapcar #'(lambda (item)
(the basis #'rslt))))) (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) (DEFUN BICONE-INTR-DFFR (cmprc dffrb dffrc dffrd f1 f2)
(declare (declare
(type cmprf cmprc) (type cmprf cmprc)
(type morphism dffrb dffrc dffrd f1 f2)) (type morphism dffrb dffrc dffrd f1 f2))
(flet ((rslt (cmbn) "(BICONE-INTR-DFFR CMPRC DFFRB DFFRC DFFRD F1 F2) "
(declare (type cmbn cmbn)) (flet ((rslt (cmbn)
(the cmbn (declare (type cmbn cmbn))
(multiple-value-bind (cmbnb cmbnc cmbnd) (dispatch-bicn-cmbn cmbn) (the cmbn
(declare (type cmbn cmbnb cmbnc cmbnd)) (multiple-value-bind (cmbnb cmbnc cmbnd)
(let ((dffrb (cmbn-? dffrb cmbnb)) (dispatch-bicn-cmbn cmbn)
(dffrc (cmbn-? dffrc cmbnc)) (declare (type cmbn cmbnb cmbnc cmbnd))
(dffrd (cmbn-? dffrd cmbnd)) (let ((dffrb (cmbn-? dffrb cmbnb))
(f1 (cmbn-? f1 cmbnb)) (dffrc (cmbn-? dffrc cmbnc))
(f2 (cmbn-? f2 cmbnd))) (dffrd (cmbn-? dffrd cmbnd))
(declare (type cmbn dffrb dffrc dffrd f1 f2)) (f1 (cmbn-? f1 cmbnb))
(let ((cmbnc (2cmbn-sbtr cmprc (2cmbn-add cmprc f1 f2) dffrc))) (f2 (cmbn-? f2 cmbnd)))
(declare (type cmbn cmbnc)) (declare (type cmbn dffrb dffrc dffrd f1 f2))
(make-bicn-cmbn dffrb cmbnc dffrd))))))) (let ((cmbnc (2cmbn-sbtr cmprc
(the intr-mrph #'rslt))) (2cmbn-add cmprc f1 f2)
dffrc)))
(declare (type cmbn cmbnc))
(make-bicn-cmbn dffrb cmbnc dffrd)))))))
(the intr-mrph #'rslt)))
(DEFUN BICONE (rdct1 rdct2) (DEFUN BICONE (rdct1 rdct2)
(declare (type reduction rdct1 rdct2)) (declare (type reduction rdct1 rdct2))
(the chain-complex "(BICONE RDCT1 RDCT2) returns the bicone chain complex from the reductions
(with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f)) rdct1 RDCT1 and RDCT2. B is the top chain complex of RDCT1 and D is the top chain
(declare complex of RDCT2. The bottom chain complexes of RDCT1 and RDCT2 must be the
(type chain-complex tcc1 bcc1) same, and C is that chain complex."
(type morphism f1)) (the chain-complex
(with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f)) rdct2 (with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f)) rdct1
(declare (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 chain-complex tcc2 bcc2)
(type morphism f2)) (type morphism f2))
(unless (eq bcc1 bcc2) (unless (eq bcc1 bcc2)
(error "In BICONE, both reductions have different BCC's.")) (error "In BICONE, both reductions have different BCC's."))
(let ((rslt (build-chcm (let ((rslt (build-chcm
:cmpr (bicone-cmpr (cmpr tcc1) (cmpr bcc1) (cmpr tcc2)) :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 :bsgn :undefined
:intr-dffr (bicone-intr-dffr (cmpr bcc1) :intr-dffr (bicone-intr-dffr (cmpr bcc1)
(dffr tcc1) (dffr bcc1) (dffr tcc2) (dffr tcc1) (dffr bcc1)
f1 f2) (dffr tcc2)
f1 f2)
:strt :cmbn :strt :cmbn
:orgn `(bicone ,rdct1 ,rdct2)))) :orgn `(bicone ,rdct1 ,rdct2))))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
; (slot-makunbound rslt 'bsgn) ; (slot-makunbound rslt 'bsgn)
rslt))))) 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) (DEFMETHOD CMPS ((hmeq1 homotopy-equivalence) (hmeq2 homotopy-equivalence)
(declare (ignore dummy)) &optional dummy)
(the homotopy-equivalence (declare (ignore dummy))
(progn "(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)) (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) (with-slots ((cc-A lbcc) (cc-B tcc) (cc-C rbcc)
(f1 lf) (g1 lg) (h1 lh) (f2 rf) (g2 rg) (h2 rh)) hmeq1 (f1 lf) (g1 lg) (h1 lh) (f2 rf) (g2 rg) (h2 rh)) hmeq1
(declare (declare
(type chain-complex cc-A cc-B cc-C) (type chain-complex cc-A cc-B cc-C)
(type morphism f1 g1 h1 f2 g2 h2)) (type morphism f1 g1 h1 f2 g2 h2))
(with-slots ((cc-C2 lbcc) (cc-D tcc) (cc-E rbcc) (with-slots ((cc-C2 lbcc) (cc-D tcc) (cc-E rbcc)
(f3 lf) (g3 lg) (h3 lh) (f4 rf) (g4 rg) (h4 rh)) hmeq2 (f3 lf) (g3 lg) (h3 lh) (f4 rf) (g4 rg) (h4 rh)) hmeq2
(declare (declare
(type chain-complex cc-C2 cc-D cc-E) (type chain-complex cc-C2 cc-D cc-E)
(type morphism f3 g3 h3 f4 g4 h4)) (type morphism f3 g3 h3 f4 g4 h4))
(unless (eq (grmd cc-C) (grmd cc-C2)) (unless (eq (grmd cc-C) (grmd cc-C2))
(error "In (CMPS HMEQ HMEQ), both hmeq's may not be composed.")) (error "In (CMPS HMEQ HMEQ), both hmeq's may not be composed."))
(let ((bicone (bicone (rrdct hmeq1) (lrdct hmeq2))) (let ((bicone (bicone (rrdct hmeq1) (lrdct hmeq2)))
(cmpr-B (cmpr cc-B)) (cmpr-B (cmpr cc-B))
(cmpr-D (cmpr cc-D))) (cmpr-D (cmpr cc-D)))
(declare (type chain-complex bicone)) (declare (type chain-complex bicone))
(let ((lf (build-mrph (let ((lf (build-mrph
:sorc bicone :trgt cc-A :degr 0 :sorc bicone :trgt cc-A :degr 0
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(cmbn-? f1 (bicn-cmbn-cmbnB cmbn))) (cmbn-? f1 (bicn-cmbn-cmbnB cmbn)))
:strt :cmbn :strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 lf))) :orgn `(cmps ,hmeq1 ,hmeq2 lf)))
(lg (build-mrph (lg (build-mrph
:sorc cc-A :trgt bicone :degr 0 :sorc cc-A :trgt bicone :degr 0
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(let* ((cmbnB (cmbn-? g1 cmbn)) (let* ((cmbnB (cmbn-? g1 cmbn))
(cmbnC (zero-cmbn (1+ (cmbn-degr cmbn)))) (cmbnC (zero-cmbn
(cmbnD (cmbn-? g3 (cmbn-? f2 (cmbn-opps cmbnB))))) (1+ (cmbn-degr cmbn))))
(declare (type cmbn cmbnB cmbnC cmbnD)) (cmbnD (cmbn-? g3
(make-bicn-cmbn cmbnB cmbnC cmbnD))) (cmbn-? f2
:strt :cmbn (cmbn-opps
:orgn `(cmps ,hmeq1 ,hmeq2 lg))) cmbnB)))))
(declare (type cmbn cmbnB cmbnC cmbnD))
(make-bicn-cmbn cmbnB cmbnC cmbnD)))
:strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 lg)))
(lh (build-mrph (lh (build-mrph
:sorc bicone :trgt bicone :degr +1 :sorc bicone :trgt bicone :degr +1
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(multiple-value-bind (cmbnB cmbnC cmbnD) (multiple-value-bind (cmbnB cmbnC cmbnD)
(dispatch-bicn-cmbn cmbn) (dispatch-bicn-cmbn cmbn)
(declare (type cmbn cmbnB cmbnC cmbnD)) (declare (type cmbn cmbnB cmbnC cmbnD))
(setf cmbnB (cmbn-? h1 cmbnB)) (setf cmbnB (cmbn-? h1 cmbnB))
(let ((cmbnC (zero-cmbn (1+ (cmbn-degr cmbnC)))) (let ((cmbnC (zero-cmbn
(cmbnD1 (cmbn-? g3 (cmbn-? f2 cmbnB))) (1+ (cmbn-degr cmbnC))))
(cmbnD2 (cmbn-? g3 cmbnC)) ;; let, not let* (cmbnD1 (cmbn-? g3
(cmbnD3 (cmbn-? h3 cmbnD))) (cmbn-? f2 cmbnB)))
(declare (type cmbn cmbnC cmbnD1 cmbnD2 cmbnD3)) (cmbnD2 (cmbn-? g3 cmbnC)) ;; let, not let*
(make-bicn-cmbn (cmbnD3 (cmbn-? h3 cmbnD)))
cmbnB (declare (type cmbn cmbnC cmbnD1 cmbnD2
cmbnC cmbnD3))
(2cmbn-sbtr cmpr-D (make-bicn-cmbn
(2cmbn-add cmpr-D cmbnD2 cmbnD3) cmbnB
cmbnD1))))) cmbnC
:strt :cmbn (2cmbn-sbtr cmpr-D
:orgn `(cmps ,hmeq1 ,hmeq2 lh))) (2cmbn-add cmpr-D cmbnD2
cmbnD3)
cmbnD1)))))
:strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 lh)))
(rf (build-mrph (rf (build-mrph
:sorc bicone :trgt cc-E :degr 0 :sorc bicone :trgt cc-E :degr 0
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(cmbn-? f4 (bicn-cmbn-cmbnD cmbn))) (cmbn-? f4 (bicn-cmbn-cmbnD cmbn)))
:strt :cmbn :strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 rf))) :orgn `(cmps ,hmeq1 ,hmeq2 rf)))
(rg (build-mrph (rg (build-mrph
:sorc cc-E :trgt bicone :degr 0 :sorc cc-E :trgt bicone :degr 0
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(let* ((cmbnD (cmbn-? g4 cmbn)) (let* ((cmbnD (cmbn-? g4 cmbn))
(cmbnC (zero-cmbn (1+ (cmbn-degr cmbn)))) (cmbnC (zero-cmbn
(cmbnB (cmbn-? g2 (cmbn-? f3 (cmbn-opps cmbnD))))) (1+ (cmbn-degr cmbn))))
(declare (type cmbn cmbnD cmbnC cmbnB)) (cmbnB
(make-bicn-cmbn cmbnB cmbnC cmbnD))) (cmbn-?
:strt :cmbn g2 (cmbn-? f3 (cmbn-opps cmbnD)))))
:orgn `(cmps ,hmeq1 ,hmeq2 rg))) (declare (type cmbn cmbnD cmbnC cmbnB))
(make-bicn-cmbn cmbnB cmbnC cmbnD)))
:strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 rg)))
(rh (build-mrph (rh (build-mrph
:sorc bicone :trgt bicone :degr +1 :sorc bicone :trgt bicone :degr +1
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(multiple-value-bind (cmbnB cmbnC cmbnD) (multiple-value-bind (cmbnB cmbnC cmbnD)
(dispatch-bicn-cmbn cmbn) (dispatch-bicn-cmbn cmbn)
(declare (type cmbn cmbnB cmbnC cmbnD)) (declare (type cmbn cmbnB cmbnC cmbnD))
(setf cmbnD (cmbn-? h4 cmbnD)) (setf cmbnD (cmbn-? h4 cmbnD))
(let ((cmbnC (zero-cmbn (1+ (cmbn-degr cmbnC)))) (let ((cmbnC (zero-cmbn
(cmbnB1 (cmbn-? g2 (cmbn-? f3 cmbnD))) (1+ (cmbn-degr cmbnC))))
(cmbnB2 (cmbn-? g2 cmbnC)) ;; let, not let* (cmbnB1 (cmbn-? g2
(cmbnB3 (cmbn-? h2 cmbnB))) (cmbn-? f3 cmbnD)))
(declare (type cmbn cmbnC cmbnB1 cmbnB2 cmbnB3)) (cmbnB2 (cmbn-? g2 cmbnC)) ;; let, not let*
(make-bicn-cmbn (cmbnB3 (cmbn-? h2 cmbnB)))
(2cmbn-sbtr cmpr-B (declare (type cmbn cmbnC cmbnB1 cmbnB2
(2cmbn-add cmpr-B cmbnB2 cmbnB3) cmbnB3))
cmbnB1) (make-bicn-cmbn
cmbnC (2cmbn-sbtr cmpr-B
cmbnD)))) (2cmbn-add cmpr-B cmbnB2
:strt :cmbn cmbnB3)
:orgn `(cmps ,hmeq1 ,hmeq2 rh)))) cmbnB1)
(declare cmbnC
(type morphism lf lg lh rf rg rh)) cmbnD))))
(build-hmeq :lf lf :lg lg :lh lh :rf rf :rg rg :rh rh :strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2))))))))) :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
(cat-init) :orgn `(cmps ,hmeq1 ,hmeq2)))))))))
(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)
|#

331
src/cones.lisp
View File

@ -12,16 +12,16 @@
(stream stream) (stream stream)
(ignore depth)) (ignore depth))
(the cone (the cone
(with-cone (conx icon) cone (with-cone (conx icon) cone
(format stream "<CONE ~D" conx) (format stream "<CONE ~D" conx)
(do ((mark icon)) (do ((mark icon))
((not (typep mark 'cone)) ((not (typep mark 'cone))
(format stream " ~A>" mark)) (format stream " ~A>" mark))
(declare (type gnrt icon)) (declare (type gnrt icon))
(with-cone (conx icon) mark (with-cone (conx icon) mark
(format stream "-~D" conx) (format stream "-~D" conx)
(setf mark icon))) (setf mark icon)))
cone))) cone)))
#| #|
() ()
@ -37,25 +37,25 @@
(DEFUN CONE-CMPR (cmpr0 cmpr1) (DEFUN CONE-CMPR (cmpr0 cmpr1)
(declare (type cmprf cmpr0 cmpr1)) (declare (type cmprf cmpr0 cmpr1))
(the cmprf (the cmprf
(flet ((rslt (gnrt1 gnrt2) (flet ((rslt (gnrt1 gnrt2)
(declare (type cone gnrt1 gnrt2)) (declare (type cone gnrt1 gnrt2))
(the cmpr (the cmpr
(let ((ind1 (conx gnrt1)) (let ((ind1 (conx gnrt1))
(ind2 (conx gnrt2)) (ind2 (conx gnrt2))
(gnrt11 (icon gnrt1)) (gnrt11 (icon gnrt1))
(gnrt22 (icon gnrt2))) (gnrt22 (icon gnrt2)))
(declare (declare
(fixnum ind1 ind2) (fixnum ind1 ind2)
(type gnrt gnrt11 gnrt22)) (type gnrt gnrt11 gnrt22))
(ecase ind1 (ecase ind1
(0 (ecase ind2 (0 (ecase ind2
(0 (funcall cmpr0 gnrt11 gnrt22)) (0 (funcall cmpr0 gnrt11 gnrt22))
(1 :less))) (1 :less)))
(1 (ecase ind2 (1 (ecase ind2
(0 :greater) (0 :greater)
(1 (funcall cmpr1 gnrt11 gnrt22))))))))) (1 (funcall cmpr1 gnrt11 gnrt22)))))))))
(declare (ftype (function (cone cone) cmpr) rslt)) (declare (ftype (function (cone cone) cmpr) rslt))
#'rslt))) #'rslt)))
#| #|
() ()
@ -73,20 +73,20 @@
(DEFUN CONE-BASIS (basis0 basis1) (DEFUN CONE-BASIS (basis0 basis1)
(declare (type basis basis0 basis1)) (declare (type basis basis0 basis1))
(the basis (the basis
(progn (progn
(when (or (eq basis0 :locally-effective) (when (or (eq basis0 :locally-effective)
(eq basis1 :locally-effective)) (eq basis1 :locally-effective))
(return-from cone-basis :locally-effective)) (return-from cone-basis :locally-effective))
(flet ((rslt (degr) (flet ((rslt (degr)
(declare (type fixnum degr)) (declare (type fixnum degr))
(the list (the list
(append (append
(mapcar #'(lambda (item) (con0 item)) (mapcar #'(lambda (item) (con0 item))
(funcall basis0 degr)) (funcall basis0 degr))
(mapcar #'(lambda (item) (con1 item)) (mapcar #'(lambda (item) (con1 item))
(funcall basis1 (1- degr))))))) (funcall basis1 (1- degr)))))))
(declare (ftype (function (fixnum) list) rslt)) (declare (ftype (function (fixnum) list) rslt))
#'rslt)))) #'rslt))))
#| #|
() ()
@ -99,17 +99,17 @@
(DEFUN TERM-CON0 (term) (DEFUN TERM-CON0 (term)
(declare (type term term)) (declare (type term term))
(the term (the term
(term (cffc term) (term (cffc term)
(con0 (gnrt term))))) (con0 (gnrt term)))))
(DEFUN TERM-CON1 (term) (DEFUN TERM-CON1 (term)
(declare (type term term)) (declare (type term term))
(the term (the term
(term (cffc term) (term (cffc term)
(con1 (gnrt term))))) (con1 (gnrt term)))))
(DEFUN TERM-UNCON (term) (DEFUN TERM-UNCON (term)
(declare (type term term)) (declare (type term term))
(the term (the term
(term (cffc term) (icon (gnrt term))))) (term (cffc term) (icon (gnrt term)))))
#| #|
() ()
@ -121,16 +121,16 @@
(DEFUN CMBN-CON0 (cmbn) (DEFUN CMBN-CON0 (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(make-cmbn (make-cmbn
:degr (cmbn-degr cmbn) :degr (cmbn-degr cmbn)
:list (mapcar #'term-con0 (cmbn-list cmbn))))) :list (mapcar #'term-con0 (cmbn-list cmbn)))))
(DEFUN CMBN-CON1 (cmbn) (DEFUN CMBN-CON1 (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(make-cmbn (make-cmbn
:degr (cmbn-degr cmbn) :degr (cmbn-degr cmbn)
:list (mapcar #'term-con1 (cmbn-list cmbn))))) :list (mapcar #'term-con1 (cmbn-list cmbn)))))
#| #|
() ()
@ -141,22 +141,22 @@
(DEFUN CONE-CMBN-SPLIT (cmbn) (DEFUN CONE-CMBN-SPLIT (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the (values cmbn cmbn) (the (values cmbn cmbn)
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((list0 +empty-list+) (let ((list0 +empty-list+)
(list1 +empty-list+)) (list1 +empty-list+))
(declare (type list list0 list1)) (declare (type list list0 list1))
(do ((mark list (cdr mark))) (do ((mark list (cdr mark)))
((endp mark) ((endp mark)
(setf list0 (nreverse list0) (setf list0 (nreverse list0)
list1 +empty-list+)) list1 +empty-list+))
(declare (type list mark)) (declare (type list mark))
(when (eql 1 (conx (cdar mark))) (when (eql 1 (conx (cdar mark)))
(setf list0 (nreverse list0) (setf list0 (nreverse list0)
list1 (mapcar #'term-uncon mark)) list1 (mapcar #'term-uncon mark))
(return)) (return))
(push (term-uncon (car mark)) list0)) (push (term-uncon (car mark)) list0))
(values (make-cmbn :degr degr :list list0) (values (make-cmbn :degr degr :list list0)
(make-cmbn :degr (1- degr) :list list1)))))) (make-cmbn :degr (1- degr) :list list1))))))
#| #|
() ()
@ -169,10 +169,10 @@
(DEFUN CONE-2CMBN-APPEND (cmbn0 cmbn1) (DEFUN CONE-2CMBN-APPEND (cmbn0 cmbn1)
(declare (type cmbn cmbn0 cmbn1)) (declare (type cmbn cmbn0 cmbn1))
(the cmbn (the cmbn
(make-cmbn (make-cmbn
:degr (cmbn-degr cmbn0) :degr (cmbn-degr cmbn0)
:list (append (mapcar #'term-con0 (cmbn-list cmbn0)) :list (append (mapcar #'term-con0 (cmbn-list cmbn0))
(mapcar #'term-con1 (cmbn-list cmbn1)))))) (mapcar #'term-con1 (cmbn-list cmbn1))))))
#| #|
() ()
@ -182,15 +182,15 @@
(DEFUN CONE-2MRPH-DIAG-IMPL (mrph0 mrph1) (DEFUN CONE-2MRPH-DIAG-IMPL (mrph0 mrph1)
(declare (type morphism mrph0 mrph1)) (declare (type morphism mrph0 mrph1))
(the intr-mrph (the intr-mrph
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(multiple-value-bind (cmbn0 cmbn1) (multiple-value-bind (cmbn0 cmbn1)
(cone-cmbn-split cmbn) (cone-cmbn-split cmbn)
(declare (type cmbn cmbn0 cmbn1)) (declare (type cmbn cmbn0 cmbn1))
(cone-2cmbn-append (? mrph0 cmbn0) (cone-2cmbn-append (? mrph0 cmbn0)
(? mrph1 cmbn1)))))) (? mrph1 cmbn1))))))
#'rslt))) #'rslt)))
#| #|
() ()
@ -202,18 +202,18 @@
(DEFUN CONE-3MRPH-TRIANGLE-IMPL (cmpr0 mrph0 mrph1 phi) (DEFUN CONE-3MRPH-TRIANGLE-IMPL (cmpr0 mrph0 mrph1 phi)
(declare (ignore cmpr0) (type morphism mrph0 mrph1 phi)) (declare (ignore cmpr0) (type morphism mrph0 mrph1 phi))
(the intr-mrph (the intr-mrph
(flet ((rslt (degr gnrt) (flet ((rslt (degr gnrt)
(declare (type fixnum degr) (type gnrt gnrt)) (declare (type fixnum degr) (type gnrt gnrt))
(the cmbn (the cmbn
(ecase (conx gnrt) (ecase (conx gnrt)
(0 (cmbn-con0 (? mrph0 degr (icon gnrt)))) (0 (cmbn-con0 (? mrph0 degr (icon gnrt))))
(1 (1
(let ((gnrt (icon gnrt))) (let ((gnrt (icon gnrt)))
(declare (type gnrt gnrt)) (declare (type gnrt gnrt))
(cone-2cmbn-append (cone-2cmbn-append
(? phi (1- degr) gnrt) (? phi (1- degr) gnrt)
(? mrph1 (1- degr) gnrt)))))))) (? mrph1 (1- degr) gnrt))))))))
#'rslt))) #'rslt)))
#| #|
() ()
@ -224,25 +224,25 @@
(funcall rslt 4 (con0 '31)) (funcall rslt 4 (con0 '31))
(funcall rslt 5 (con1 '31)) (funcall rslt 5 (con1 '31))
(funcall rslt 4 (con1 '15)) (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) (DEFUN CONE (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(the chain-complex (the chain-complex
(let ((chcm0 (trgt mrph)) (let ((chcm0 (trgt mrph))
(chcm1 (sorc mrph))) (chcm1 (sorc mrph)))
(declare (type chain-complex chcm0 chcm1)) (declare (type chain-complex chcm0 chcm1))
(build-chcm (build-chcm
:cmpr (cone-cmpr (cmpr chcm0) (cmpr chcm1)) :cmpr (cone-cmpr (cmpr chcm0) (cmpr chcm1))
:basis (cone-basis (basis chcm0) (basis chcm1)) :basis (cone-basis (basis chcm0) (basis chcm1))
:bsgn (con0 (bsgn chcm0)) :bsgn (con0 (bsgn chcm0))
:intr-dffr (cone-3mrph-triangle-impl (cmpr chcm0) :intr-dffr (cone-3mrph-triangle-impl (cmpr chcm0)
(dffr chcm0) (dffr chcm0)
(n-mrph -1 (dffr chcm1)) (n-mrph -1 (dffr chcm1))
mrph) mrph)
:strt :gnrt :strt :gnrt
:orgn `(cone ,mrph))))) :orgn `(cone ,mrph)))))
#| #|
() ()
@ -269,16 +269,16 @@
(type chain-complex sorc-cone trgt-cone) (type chain-complex sorc-cone trgt-cone)
(type morphism mrph0 mrph1)) (type morphism mrph0 mrph1))
(the morphism (the morphism
(progn (progn
(unless (= (degr mrph0) (degr mrph1)) (unless (= (degr mrph0) (degr mrph1))
(error "Non-coherent degrees in CONE-2MRPH-DIAG.")) (error "Non-coherent degrees in CONE-2MRPH-DIAG."))
(build-mrph (build-mrph
:sorc sorc-cone :sorc sorc-cone
:trgt trgt-cone :trgt trgt-cone
:degr (degr mrph0) :degr (degr mrph0)
:intr (cone-2mrph-diag-impl mrph0 mrph1) :intr (cone-2mrph-diag-impl mrph0 mrph1)
:strt :cmbn :strt :cmbn
:orgn `(cone-2mrph-diag ,sorc-cone ,trgt-cone ,mrph0 ,mrph1))))) :orgn `(cone-2mrph-diag ,sorc-cone ,trgt-cone ,mrph0 ,mrph1)))))
#| #|
() ()
@ -293,21 +293,21 @@
(type chain-complex sorc-cone trgt-cone) (type chain-complex sorc-cone trgt-cone)
(type morphism mrph0 mrph1 phi)) (type morphism mrph0 mrph1 phi))
(the morphism (the morphism
(progn (progn
(unless (= (degr mrph0) (degr mrph1)) (unless (= (degr mrph0) (degr mrph1))
(error "Non-coherent degrees in CONE-3MRPH-TRIANGLE.")) (error "Non-coherent degrees in CONE-3MRPH-TRIANGLE."))
(unless (= (1+ (degr mrph0)) (degr phi)) (unless (= (1+ (degr mrph0)) (degr phi))
(error "Non-coherent-degrees in CONE-3MRPH-TRIANGLE.")) (error "Non-coherent-degrees in CONE-3MRPH-TRIANGLE."))
(build-mrph (build-mrph
:sorc sorc-cone :sorc sorc-cone
:trgt trgt-cone :trgt trgt-cone
:degr (degr mrph0) :degr (degr mrph0)
:intr (cone-3mrph-triangle-impl :intr (cone-3mrph-triangle-impl
(cmpr (trgt phi)) (cmpr (trgt phi))
mrph0 mrph1 phi) mrph0 mrph1 phi)
:strt :gnrt :strt :gnrt
:orgn `(cone-3mrph-triangle ,sorc-cone ,trgt-cone :orgn `(cone-3mrph-triangle ,sorc-cone ,trgt-cone
,mrph0 ,mrph1 ,phi))))) ,mrph0 ,mrph1 ,phi)))))
#| #|
() ()
@ -330,39 +330,38 @@
(DEFUN CONE-EFHM (cone) (DEFUN CONE-EFHM (cone)
(declare (type chain-complex cone)) (declare (type chain-complex cone))
(the homotopy-equivalence (the homotopy-equivalence
(let* ((phi (second (orgn cone))) (let* ((phi (second (orgn cone)))
(chcm0 (trgt phi)) (chcm1 (sorc phi)) (chcm0 (trgt phi)) (chcm1 (sorc phi))
(efhm0 (efhm chcm0)) (efhm1 (efhm chcm1)) (efhm0 (efhm chcm0)) (efhm1 (efhm chcm1))
(lf0 (lf efhm0)) (lg0 (lg efhm0)) (lh0 (lh efhm0)) (lf0 (lf efhm0)) (lg0 (lg efhm0)) (lh0 (lh efhm0))
(rf0 (rf efhm0)) (rg0 (rg efhm0)) (rh0 (rh efhm0)) (rf0 (rf efhm0)) (rg0 (rg efhm0)) (rh0 (rh efhm0))
(lf1 (lf efhm1)) (lg1 (lg efhm1)) (lh1 (lh efhm1)) (lf1 (lf efhm1)) (lg1 (lg efhm1)) (lh1 (lh efhm1))
(rf1 (rf efhm1)) (rg1 (rg efhm1)) (rh1 (rh efhm1)) (rf1 (rf efhm1)) (rg1 (rg efhm1)) (rh1 (rh efhm1))
(hphi (cmps lg0 (cmps phi lf1))) (hphi (cmps lg0 (cmps phi lf1)))
(ephi (cmps rf0 (cmps hphi rg1))) (ephi (cmps rf0 (cmps hphi rg1)))
(hcone (cone hphi)) (hcone (cone hphi))
(econe (cone ephi)) (econe (cone ephi))
(LF (cone-2mrph-diag hcone cone lf0 lf1)) (LF (cone-2mrph-diag hcone cone lf0 lf1))
(LG (cone-2mrph-diag cone hcone lg0 lg1)) (LG (cone-2mrph-diag cone hcone lg0 lg1))
(LH (cone-2mrph-diag hcone hcone lh0 (n-mrph -1 lh1))) (LH (cone-2mrph-diag hcone hcone lh0 (n-mrph -1 lh1)))
(RF (cone-3mrph-triangle hcone econe rf0 rf1 (RF (cone-3mrph-triangle hcone econe rf0 rf1
(cmps rf0 (cmps hphi rh1)))) (cmps rf0 (cmps hphi rh1))))
(RG (cone-3mrph-triangle econe hcone rg0 rg1 (RG (cone-3mrph-triangle econe hcone rg0 rg1
(n-mrph -1 (cmps rh0 (cmps hphi rg1))))) (n-mrph -1 (cmps rh0 (cmps hphi rg1)))))
(RH (cone-3mrph-triangle hcone hcone rh0 (n-mrph -1 rh1) (RH (cone-3mrph-triangle hcone hcone rh0 (n-mrph -1 rh1)
(cmps rh0 (cmps hphi rh1))))) (cmps rh0 (cmps hphi rh1)))))
(declare (declare
(type chain-complex chcm0 chcm1 hcone econe) (type chain-complex chcm0 chcm1 hcone econe)
(type morphism phi lf0 lg0 lh0 rf0 rg0 rh0 lf1 lg1 lh1 rf1 rg1 rh1 (type morphism phi lf0 lg0 lh0 rf0 rg0 rh0 lf1 lg1 lh1 rf1 rg1 rh1
hphi ephi LF LG LH RF RG RH)) hphi ephi LF LG LH RF RG RH))
(build-hmeq (build-hmeq
:lrdct (build-rdct :f LF :g LG :h LH :lrdct (build-rdct :f LF :g LG :h LH
:orgn `(cone-efhm ,cone lrdct)) :orgn `(cone-efhm ,cone lrdct))
:rrdct (build-rdct :f RF :g RG :h RH :rrdct (build-rdct :f RF :g RG :h RH
:orgn `(cone-efhm ,cone rrdct)) :orgn `(cone-efhm ,cone rrdct))
:orgn `(cone-efhm ,cone))))) :orgn `(cone-efhm ,cone)))))
(DEFMETHOD SEARCH-EFHM (chcm (orgn (eql 'cone))) (DEFMETHOD SEARCH-EFHM (chcm (orgn (eql 'cone)))
(declare (type chain-complex chcm)) (declare (type chain-complex chcm))
(the homotopy-equivalence (the homotopy-equivalence
(cone-efhm chcm))) (cone-efhm chcm)))

6
src/macros.lisp
View File

@ -352,12 +352,18 @@
,@body)))) ,@body))))
(DEFMACRO BCNB (gnrt) (DEFMACRO BCNB (gnrt)
"(BCNB GNRT) returns the representation of the generator GNRT belonging to the
chain complex B."
`(make-bicn :bcnx :bcnb :ibicn ,gnrt)) `(make-bicn :bcnx :bcnb :ibicn ,gnrt))
(DEFMACRO BCNC (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)) `(make-bicn :bcnx :bcnc :ibicn ,gnrt))
(DEFMACRO BCND (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)) `(make-bicn :bcnx :bcnd :ibicn ,gnrt))
(DEFMACRO WITH-BICN ((bcnx ibicn) bicn . body) (DEFMACRO WITH-BICN ((bcnx ibicn) bicn . body)

118
test/bicones-test.lisp Normal file
View 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))))

15
test/chain-complexes-test.lisp
View File

@ -45,20 +45,7 @@
(is (equal (cat:cmbn-list comb) (cons (cons 1 n) nil)))))))) (is (equal (cat:cmbn-list comb) (cons (cons 1 n) nil))))))))
(defparameter *n* 10) (setf *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))))
(test cmbn-? (test cmbn-?
(progn (progn

15
test/chcm-elementary-op-test.lisp
View File

@ -44,20 +44,7 @@
(is (eq -zi -zi2))))) (is (eq -zi -zi2)))))
(defparameter *n* 5) (setf *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))))
(test cmps (test cmps
(progn (progn

170
test/common.lisp Normal file
View 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*))))))

83
test/effective-homology-test.lisp
View File

@ -3,27 +3,6 @@
(in-suite :kenzo) (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 (test cdelta
(progn (progn
(cat:cat-init) (cat:cat-init)
@ -38,63 +17,6 @@
(signals simple-error (equal (cat:basis cc 5) cat:+empty-list+))))) (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 (test make-rdct
(progn (progn
(cat:cat-init) (cat:cat-init)
@ -106,6 +28,7 @@
(setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
(check-rdct)))) (check-rdct))))
(test cmps (test cmps
(progn (progn
(cat:cat-init) (cat:cat-init)
@ -118,6 +41,7 @@
(setf cat:*bc* (cat:cmbn 2 1 '(0 1 3))) (setf cat:*bc* (cat:cmbn 2 1 '(0 1 3)))
(check-rdct)))) (check-rdct))))
(test zero-mrph (test zero-mrph
(progn (progn
(cat:cat-init) (cat:cat-init)
@ -129,6 +53,7 @@
(setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
(check-rdct)))) (check-rdct))))
(test opps (test opps
(progn (progn
(cat:cat-init) (cat:cat-init)
@ -140,6 +65,7 @@
(setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
(check-rdct)))) (check-rdct))))
;; an absurd reduction ; just to test bpl-*-sigma ;; an absurd reduction ; just to test bpl-*-sigma
(test bpl-*-sigma (test bpl-*-sigma
(progn (progn
@ -175,6 +101,7 @@
(cat:gnrt-? (cat:dffr (cat:tcc new-rdct)) 3 '(3 5)) (cat:gnrt-? (cat:dffr (cat:tcc new-rdct)) 3 '(3 5))
(cat:gnrt-? (cat:dffr (cat:bcc new-rdct)) 3 '(3 5))))) (cat:gnrt-? (cat:dffr (cat:bcc new-rdct)) 3 '(3 5)))))
(test trivial-hmeq (test trivial-hmeq
(progn (progn
(cat:cat-init) (cat:cat-init)