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
|
||||
|
||||
260
src/bicones.lisp
260
src/bicones.lisp
@ -7,6 +7,8 @@
|
||||
(PROVIDE "bicones")
|
||||
|
||||
(DEFUN DISPATCH-BICN-CMBN (cmbn)
|
||||
"(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
|
||||
@ -19,25 +21,27 @@
|
||||
(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))))))
|
||||
(: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)))
|
||||
|#
|
||||
|
||||
|
||||
(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
|
||||
(make-cmbn
|
||||
:degr degr
|
||||
:list (do ((rslt +empty-list+)
|
||||
(mark list (cdr mark)))
|
||||
((endp mark) (nreverse rslt))
|
||||
@ -45,14 +49,20 @@
|
||||
(with--term (cffc bicn) mark
|
||||
(with-bicn (bcnx gnrtB) bicn
|
||||
(if (eq bcnx :bcnB)
|
||||
(push (term cffc gnrtB) rslt)
|
||||
(return (nreverse rslt))))))))))
|
||||
(push (term cffc gnrtB)
|
||||
rslt)
|
||||
(return
|
||||
(nreverse rslt))))))))))
|
||||
|
||||
(DEFUN BICN-CMBN-CMBNC (cmbn)
|
||||
(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)
|
||||
(make-cmbn
|
||||
:degr (1+ degr)
|
||||
:list (do ((rslt +empty-list+)
|
||||
(mark (member :bcnc list
|
||||
;; Correction 1-1-2
|
||||
@ -65,44 +75,50 @@
|
||||
(with--term (cffc bicn) mark
|
||||
(with-bicn (bcnx gnrtC) bicn
|
||||
(if (eq bcnx :bcnC)
|
||||
(push (term cffc gnrtC) rslt)
|
||||
(return (nreverse rslt))))))))))
|
||||
(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
|
||||
(make-cmbn
|
||||
:degr degr
|
||||
:list (mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term (cffc bicn) term
|
||||
(term cffc (ibicn bicn))))
|
||||
(member :bcnd list
|
||||
(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))
|
||||
"(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
|
||||
(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
|
||||
(make-cmbn
|
||||
:degr degrb
|
||||
:list (nconc
|
||||
(mapcar #'(lambda (termb)
|
||||
(declare (type term termb))
|
||||
@ -120,11 +136,6 @@
|
||||
(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
|
||||
@ -139,15 +150,12 @@
|
||||
ibicn)
|
||||
bicn)))
|
||||
|
||||
#|
|
||||
()
|
||||
(bcnb 'a)
|
||||
(bcnc 'b)
|
||||
(bcnd 'c)
|
||||
|#
|
||||
|
||||
(DEFUN BICONE-CMPR (cmprb cmprc cmprd)
|
||||
(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)))
|
||||
@ -160,15 +168,12 @@
|
||||
(: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))
|
||||
"(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)
|
||||
@ -191,22 +196,17 @@
|
||||
(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))
|
||||
"(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)
|
||||
(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))
|
||||
@ -214,13 +214,21 @@
|
||||
(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)))
|
||||
(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))
|
||||
"(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
|
||||
@ -234,10 +242,12 @@
|
||||
(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)
|
||||
(dffr tcc1) (dffr bcc1)
|
||||
(dffr tcc2)
|
||||
f1 f2)
|
||||
:strt :cmbn
|
||||
:orgn `(bicone ,rdct1 ,rdct2))))
|
||||
@ -245,73 +255,12 @@
|
||||
; (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)
|
||||
(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))
|
||||
@ -344,8 +293,12 @@
|
||||
: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)))))
|
||||
(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
|
||||
@ -358,16 +311,20 @@
|
||||
(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)))
|
||||
(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))
|
||||
(declare (type cmbn cmbnC cmbnD1 cmbnD2
|
||||
cmbnD3))
|
||||
(make-bicn-cmbn
|
||||
cmbnB
|
||||
cmbnC
|
||||
(2cmbn-sbtr cmpr-D
|
||||
(2cmbn-add cmpr-D cmbnD2 cmbnD3)
|
||||
(2cmbn-add cmpr-D cmbnD2
|
||||
cmbnD3)
|
||||
cmbnD1)))))
|
||||
:strt :cmbn
|
||||
:orgn `(cmps ,hmeq1 ,hmeq2 lh)))
|
||||
@ -383,8 +340,11 @@
|
||||
: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)))))
|
||||
(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
|
||||
@ -397,14 +357,18 @@
|
||||
(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)))
|
||||
(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))
|
||||
(declare (type cmbn cmbnC cmbnB1 cmbnB2
|
||||
cmbnB3))
|
||||
(make-bicn-cmbn
|
||||
(2cmbn-sbtr cmpr-B
|
||||
(2cmbn-add cmpr-B cmbnB2 cmbnB3)
|
||||
(2cmbn-add cmpr-B cmbnB2
|
||||
cmbnB3)
|
||||
cmbnB1)
|
||||
cmbnC
|
||||
cmbnD))))
|
||||
@ -414,31 +378,3 @@
|
||||
(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)
|
||||
|#
|
||||
|
||||
@ -224,7 +224,7 @@
|
||||
(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)
|
||||
@ -365,4 +365,3 @@
|
||||
(declare (type chain-complex chcm))
|
||||
(the homotopy-equivalence
|
||||
(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