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

All files compile w/ SBCL

Browse Source
This commit is contained in:
gheber 2014-12-24 23:08:33 -06:00
parent 80c82ea6ac
commit 6851846a71
39 changed files with 291 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
kenzo-test.asd
View File

@ -7,4 +7,7 @@
:pathname #P"test/"
:components ((:file "package")
(:file "combinations-test")
(:file "various-test")))
(:file "various-test")
(:file "chain-complexes-test")
(:file "diabolo")
(:file "circle")))

33
kenzo.asd
View File

@ -18,5 +18,36 @@
(:file "classes")
(:file "combinations")
(:file "chain-complexes")
(:file "chcm-elementary-op")))))
(:file "chcm-elementary-op")
(:file "effective-homology")
(:file "homology-groups")
(:file "searching-homology")
(:file "cones")
(:file "bicones")
(:file "tensor-products")
(:file "coalgebras")
(:file "cobar")
(:file "algebras")
(:file "bar")
(:file "simplicial-sets")
(:file "simplicial-mrphs")
(:file "delta")
(:file "special-smsts")
(:file "suspensions")
(:file "disk-pasting")
(:file "cartesian-products")
(:file "eilenberg-zilber")
(:file "kan")
(:file "simplicial-groups")
(:file "fibrations")
(:file "loop-spaces")
(:file "ls-twisted-products")
(:file "lp-space-efhm")
(:file "classifying-spaces")
(:file "k-pi-n")
(:file "serre")
(:file "cs-twisted-products")
(:file "cl-space-efhm")
(:file "whitehead")
(:file "smith")))))

13
package.lisp
View File

@ -7,13 +7,19 @@
;; chain-complexes.lisp
BUILD-CHCM
CAT-INIT
DO-CONTROL
;; chcm-elementary-op.lisp
;; classes.lisp
CHAIN-COMPLEX
CMBN-CMBN
CMBN-DEGR
CMBN-LIST
MAKE-RESULT
;; combinations.lisp
@ -35,15 +41,20 @@
;; macros.lisp
BASIS
BINOMIAL-P-Q
CFFC
GNRT
CMBN-NON-ZERO-P
CMBN-ZERO-P
CMPR
DFFR
GNRT
TERM
TERM-CMBN
;; various.lisp
+EMPTY-LIST+
<A-B<
<A-B>
>A-B<

2
src/algebras.lisp
View File

@ -2,7 +2,7 @@
;;; ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS
;;; ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "algebras")

6
src/bar.lisp
View File

@ -6,7 +6,7 @@
;;; MAC-LANE signs (p. 306)
;;;
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "bar")
@ -31,8 +31,8 @@
(abar 2 'a 3)) ;; error
|#
(DEFCONSTANT +NULL-ABAR+ (make-abar :list +empty-list+))
#-sbcl (DEFCONSTANT +NULL-ABAR+ (make-abar :list +empty-list+))
#+sbcl (DEFPARAMETER +NULL-ABAR+ (make-abar :list +empty-list+))
;;; -[CLISP
#|

2
src/bicones.lisp
View File

@ -2,7 +2,7 @@
;;; BICONES BICONES BICONES BICONES BICONES BICONES BICONES BICONES
;;; BICONES BICONES BICONES BICONES BICONES BICONES BICONES BICONES
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "bicones")

2
src/cartesian-products.lisp
View File

@ -2,7 +2,7 @@
;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS
;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "cartesian-products")

88
src/chain-complexes.lisp
View File

@ -111,11 +111,6 @@
result)
#|
()
(make-result :gnrt 'a :value '(a a) :clnm 23 :rntm 2.345)
|#
(DEFPARAMETER +MAXIMAL-DIMENSION+ 15)
(DEFVAR *MRPH-LIST*)
@ -361,7 +356,7 @@
(/ runtime internal-time-units-per-second))))
(declare (single-float rntm))
(incf *results-cmlt-tm* rntm)
rntm)))
rntm)))
(mapl #'(lambda (mark)
(declare (cons mark))
(incf (car mark) runtime))
@ -380,7 +375,7 @@
(:less (setf right middle))
(:greater (setf left middle)))))))
(DEFUN MRPH-CMBN (scmpr2 tcmpr2 intr cmbn memory)
(declare
(type intr-mrph intr)
@ -419,15 +414,6 @@
~A and ~A are in a wrong order." (cdar mark2) (cdar mark1)))))
cmbn)
#|
(do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'c))
(do-control #'s-cmpr (cmbn 0 1 'b 1 'b -1 'c))
(do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
(setf *cmbn-control* nil)
(control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
(setf *cmbn-control* t)
(control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
|#
#|
(DEFVAR *PROFILER-STACK*)
@ -495,38 +481,6 @@
;; (profiler-off mrph)
))))))))
#|
()
(cat-init)
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf ff (build-mrph :sorc cc :trgt cc :degr 0
:intr #'(lambda (degr n) (cmbn degr 1 n))
:strt :gnrt :orgn '(test)))
(setf ff (build-mrph :sorc cc :trgt cc :degr 0
:intr #'(lambda (degr n) (cmbn degr 1 n))
:strt :gnrt :orgn '(test)))
(dotimes (i 20)
(let ((n (- (random 50) 50)))
(format t "~%~D ~D" n (gnrt-? ff 0 n))))
(setf +too-much-time+ -1)
(dotimes (i 20)
(let ((n (- (random 50) 50)))
(format t "~%~D ~D" n (gnrt-? ff 0 n))))
(setf +too-much-time+ 50)
|#
(DEFUN CMBN-? (mrph cmbn)
(declare
@ -565,41 +519,3 @@
cmbn (svref (rslts mrph) (cmbn-degr cmbn))))
;; (profiler-off mrph)
)))))))))
#|
()
(cat-init)
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf *n* 10)
(defun ff (degr i)
(do ((*2n* (ash *n* 1))
(rslt +empty-list+
(cons (cons (let ((cffc (- (random *2n*) *n*)))
(if (minusp cffc) cffc (1+ cffc)))
(decf gnrt (1+ (random *n*))))
rslt))
(gnrt i)
(k 0 (1+ k)))
((= k *n*)
(make-cmbn
:degr 0
:list rslt))))
(ff 0 20)
(compile 'ff)
(setf mrph (build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(cmbn-? mrph (cmbn 0 1 100))
(cmbn-? mrph *)
(cmbn-? mrph *)
(cmbn-? mrph *)
(cmbn-? mrph *)
(cmbn-? mrph *)
(time (cmbn-? mrph *))
(inspect mrph)
|#

4
src/cl-space-efhm.lisp
View File

@ -2,7 +2,7 @@
;;; CL-SPACE-EFHM CL-SPACE-EFHM CL-SPACE-EFHM CL-SPACE-EFHM
;;; CL-SPACE-EFHM CL-SPACE-EFHM CL-SPACE-EFHM CL-SPACE-EFHM
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(provide "cl-space-efhm")
@ -872,4 +872,4 @@
(homology bk 0 10)
(setf obk (loop-space bk))
(homology obk 0 6)
|#
|#

5
src/classifying-spaces.lisp
View File

@ -2,11 +2,12 @@
;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES
;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(provide "classifying-spaces")
(DEFCONSTANT +NULL-GBAR+ (make-gbar :dmns 0 :list +empty-list+))
#-sbcl (DEFCONSTANT +NULL-GBAR+ (make-gbar :dmns 0 :list +empty-list+))
#+sbcl (DEFPARAMETER +NULL-GBAR+ (make-gbar :dmns 0 :list +empty-list+))
(DEFUN GBAR-PRINT (gbar stream depth)
(declare

2
src/coalgebras.lisp
View File

@ -2,7 +2,7 @@
;;; COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS
;;; COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "coalgebras")

8
src/cobar.lisp
View File

@ -2,7 +2,7 @@
;;; COBAR COBAR COBAR COBAR COBAR COBAR COBAR COBAR COBAR
;;; COBAR COBAR COBAR COBAR COBAR COBAR COBAR COBAR COBAR
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "cobar")
@ -28,7 +28,9 @@
(allp 2 'a 3)) ;; error
|#
(DEFCONSTANT +NULL-ALLP+ (make-allp :list +empty-list+))
#-sbcl(DEFCONSTANT +NULL-ALLP+ (make-allp :list +empty-list+))
#+sbcl (DEFPARAMETER +NULL-ALLP+ (make-allp :list +empty-list+))
(DEFUN ALLP-PRINT (allp stream depth)
(declare
@ -705,4 +707,4 @@
(setf h (left-hmeq (sphere 3)))
(setf c (cobar h))
(inspect c)
|#
|#

2
src/cones.lisp
View File

@ -2,7 +2,7 @@
;;; CONES CONES CONES CONES CONES CONES CONES CONES CONES CONES
;;; CONES CONES CONES CONES CONES CONES CONES CONES CONES CONES
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "cones")

4
src/cs-twisted-products.lisp
View File

@ -2,7 +2,7 @@
;;; CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS
;;; CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "cs-twisted-products")
@ -143,4 +143,4 @@
0 '())))
(? chi *tc*)
(check-rdct)
|#
|#

2
src/delta.lisp
View File

@ -2,7 +2,7 @@
;;; DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA
;;; DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "delta")

2
src/disk-pasting.lisp
View File

@ -2,7 +2,7 @@
;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING
;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(provide "disk-pasting")

2
src/effective-homology.lisp
View File

@ -2,7 +2,7 @@
;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY
;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "effective-homology")

4
src/eilenberg-zilber.lisp
View File

@ -2,7 +2,7 @@
;;; EILENBERG-ZILBER EILENBERG-ZILBER EILENBERG-ZILBER
;;; EILENBERG-ZILBER EILENBERG-ZILBER EILENBERG-ZILBER
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "eilenberg-zilber")
@ -477,4 +477,4 @@
(setf k (k-z 2))
(setf k2 (crts-prdc k k))
(homology k2 0 10)
|#
|#

4
src/fibrations.lisp
View File

@ -2,7 +2,7 @@
;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS
;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "fibrations")
@ -182,4 +182,4 @@
(dotimes (i 5)
(print (kfll total i 4 (remove (nth i hat) hat)))
(check-kan total i 4 (remove (nth i hat) hat)))
|#
|#

2
src/homology-groups.lisp
View File

@ -2,7 +2,7 @@
;; HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS
;; HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(provide "homology-groups")

2
src/k-pi-n.lisp
View File

@ -2,7 +2,7 @@
;;; K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1
;;; K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "k-pi-1")

4
src/kan.lisp
View File

@ -2,7 +2,7 @@
;;; KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN
;;; KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(provide "kan")
@ -195,4 +195,4 @@
Del-~D(Fill) = ~A~@
Hat-~D = ~A"
rslt i del-i-rslt i x-i)))))))
(done))))
(done))))

5
src/loop-spaces.lisp
View File

@ -2,11 +2,12 @@
;;; LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES
;;; LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "loop-spaces")
(DEFCONSTANT +NULL-LOOP+ (make-loop :list +empty-list+))
#-sbcl (DEFCONSTANT +NULL-LOOP+ (make-loop :list +empty-list+))
#+sbcl (DEFPARAMETER +NULL-LOOP+ (make-loop :list +empty-list+))
;;; NILOOP = non-normalized iloop; a common dgop is possible.

2
src/lp-space-efhm.lisp
View File

@ -2,7 +2,7 @@
;;; LP-SPACE-EFHM LP-SPACE-EFHM LP-SPACE-EFHM LP-SPACE-EFHM
;;; LP-SPACE-EFHM LP-SPACE-EFHM LP-SPACE-EFHM LP-SPACE-EFHM
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "lp-space-efhm")

2
src/ls-twisted-products.lisp
View File

@ -2,7 +2,7 @@
;;; LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS
;;; LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "ls-twisted-products")

2
src/searching-homology.lisp
View File

@ -2,7 +2,7 @@
;;; SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY
;;; SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "searching-homology")

4
src/serre.lisp
View File

@ -2,7 +2,7 @@
;;; SERRE SERRE SERRE SERRE SERRE SERRE SERRE SERRE SERRE
;;; SERRE SERRE SERRE SERRE SERRE SERRE SERRE SERRE SERRE
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "serre")
@ -283,4 +283,4 @@

4
src/simplicial-groups.lisp
View File

@ -2,7 +2,7 @@
;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS
;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "simplicial-groups")
@ -195,4 +195,4 @@
(type simplicial-mrph grml))
(cmps grml eml))))

2
src/simplicial-mrphs.lisp
View File

@ -2,7 +2,7 @@
;;; SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS
;;; SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "simplicial-mrphs")

2
src/simplicial-sets.lisp
View File

@ -2,7 +2,7 @@
;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS
;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "simplicial-sets")

2
src/smith.lisp
View File

@ -2,7 +2,7 @@
;;; SMITH SMITH SMITH SMITH SMITH SMITH SMITH SMITH
;;; SMITH SMITH SMITH SMITH SMITH SMITH SMITH SMITH
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "smith")

4
src/special-smsts.lisp
View File

@ -2,7 +2,7 @@
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "special-smsts")
@ -685,4 +685,4 @@
(setf cmbn (lf efhm (rg efhm 3 (first (basis (rbcc efhm) 3)))))
(setf kf (gmsms-subsmst s3 cmbn))
(homology kf 0 4)
|#
|#

4
src/suspensions.lisp
View File

@ -2,7 +2,7 @@
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "suspensions")
@ -318,4 +318,4 @@
(setf sk (suspension (k-z 2)))
(homology sk 0 10)
|#

4
src/tensor-products.lisp
View File

@ -2,7 +2,7 @@
;;; TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS
;;; TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(PROVIDE "tensor-products")
@ -366,4 +366,4 @@
(setf k (k-z 2))
(setf k2 (tnsr-prdc k k))
(homology k2 0 10)
|#
|#

4
src/whitehead.lisp
View File

@ -2,7 +2,7 @@
;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD
;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD
(IN-PACKAGE "COMMON-LISP-USER")
(IN-PACKAGE #:cat)
(provide "whitehead")
@ -335,4 +335,4 @@
(setf mt (fibration-total mf))
(homology mt 0 10)
|#

110
test/chain-complexes-test.lisp Normal file
View File

@ -0,0 +1,110 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(test result-print
(let ((rslt (format nil "~a"
(cat:make-result :gnrt 'a :value '(a a)
:clnm 23 :rntm 2.345))))
(is (equal rslt (format nil "~{~a~}"
'(#\Newline "<Rslt>" #\Newline
" GNRT-> A" #\Newline
" VALUE-> (A A)" #\Newline
" CLNM-> 23" #\Newline
" RNTM-> 2.345"))))))
#|
(do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'c))
(do-control #'s-cmpr (cmbn 0 1 'b 1 'b -1 'c))
(do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
(setf *cmbn-control* nil)
(control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
(setf *cmbn-control* t)
(control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
|#
(test do-control
(let ((comb (cat:do-control #'cat:s-cmpr (cat:cmbn 0 1 'a 1 'b -1 'c))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a) (1 . b) (-1 . c)))))
(signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'b 1 'b -1 'c)))
(signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'a 1 'b -1 'b)))
(setf cat:*cmbn-control* nil))
#|
()
(cat-init)
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf ff (build-mrph :sorc cc :trgt cc :degr 0
:intr #'(lambda (degr n) (cmbn degr 1 n))
:strt :gnrt :orgn '(test)))
(setf ff (build-mrph :sorc cc :trgt cc :degr 0
:intr #'(lambda (degr n) (cmbn degr 1 n))
:strt :gnrt :orgn '(test)))
(dotimes (i 20)
(let ((n (- (random 50) 50)))
(format t "~%~D ~D" n (gnrt-? ff 0 n))))
(setf +too-much-time+ -1)
(dotimes (i 20)
(let ((n (- (random 50) 50)))
(format t "~%~D ~D" n (gnrt-? ff 0 n))))
(setf +too-much-time+ 50)
|#
#|
()
(cat-init)
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf *n* 10)
(defun ff (degr i)
(do ((*2n* (ash *n* 1))
(rslt +empty-list+
(cons (cons (let ((cffc (- (random *2n*) *n*)))
(if (minusp cffc) cffc (1+ cffc)))
(decf gnrt (1+ (random *n*))))
rslt))
(gnrt i)
(k 0 (1+ k)))
((= k *n*)
(make-cmbn
:degr 0
:list rslt))))
(ff 0 20)
(compile 'ff)
(setf mrph (build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(cmbn-? mrph (cmbn 0 1 100))
(cmbn-? mrph *)
(cmbn-? mrph *)
(cmbn-? mrph *)
(cmbn-? mrph *)
(cmbn-? mrph *)
(time (cmbn-? mrph *))
(inspect mrph)
|#

26
test/circle.lisp Normal file
View File

@ -0,0 +1,26 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(defun circle ()
(the cat:chain-complex
(cat:build-chcm
:cmpr #'(lambda (gnrt1 gnrt2) (the cat:cmpr :equal))
:basis #'(lambda (dmns)
(the list
(case dmns (0 '(*)) (1 '(s1))
(otherwise cat:+empty-list+))))
:bsgn '*
:intr-dffr #'cat:zero-intr-dffr
:strt :cmbn
:orgn '(circle))))
(test circle
(progn
(cat:cat-init)
(let ((circle (circle)))
(is (equal (cat:basis circle 0) '(*)))
(is (equal (cat:basis circle 1) '(s1)))
(is (equal (cat:basis circle 2) cat:+empty-list+)))))

49
test/diabolo.lisp Normal file
View File

@ -0,0 +1,49 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(defun diabolo-basis (dmn)
(case dmn
(0 '(s0 s1 s2 s3 s4 s5))
(1 '(s01 s02 s12 s23 s34 s35 s45))
(2 '(s345))
(otherwise nil)))
(defun diabolo-pure-dffr (dmn gnr)
(unless (<= 0 dmn 2)
(error "Incorrect dimension for diabolo-dp."))
(case dmn
(0 (cat:cmbn -1))
(1 (case gnr
(s01 (cat:cmbn 0 -1 's0 1 's1))
(s02 (cat:cmbn 0 -1 's0 1 's2))
(s12 (cat:cmbn 0 -1 's1 1 's2))
(s23 (cat:cmbn 0 -1 's2 1 's3))
(s34 (cat:cmbn 0 -1 's3 1 's4))
(s35 (cat:cmbn 0 -1 's3 1 's5))
(s45 (cat:cmbn 0 -1 's4 1 's5))))
(2 (case gnr
(s345 (cat:cmbn 1 1 's34 -1 's35 1 's45))))
(otherwise (error "Bad generator for complex diabolo."))))
(test diabolo
(progn
(cat:cat-init)
(let ((diabolo (cat:build-chcm :cmpr #'cat:s-cmpr
:basis #'diabolo-basis
:bsgn 's0
:intr-dffr #'diabolo-pure-dffr
:strt :GNRT
:orgn '(diabolo-for-example))))
(is (equal (cat:basis diabolo 0) '(s0 s1 s2 s3 s4 s5)))
(is (equal (cat:basis diabolo 1) '(s01 s02 s12 s23 s34 s35 s45)))
(is (equal (cat:basis diabolo 2) '(s345)))
(is (null (cat:basis diabolo 10)))
(let* ((comb (cat:dffr diabolo 2 's345))
(comb1 (cat:dffr diabolo comb)))
(is (equal (cat:cmbn-degr comb) 1))
(is (equal (cat:cmbn-list comb) '((1 . s34) (-1 . s35) (1 . s45))))
(is (equal (cat:cmbn-degr comb1) 0))
(is (equal (cat:cmbn-list comb1) nil))))))

7
test/various-test.lisp
View File

@ -7,11 +7,12 @@
(let ((rslt '(1 5 10 10 5 1)))
(dotimes (i 6)
(is (equal (cat:binomial-n-p 5 i)
(nth i rslt)))))
(nth i rslt))))))
(let ((rslt '(1 4 3 1 1 1)))
(test binomial-p-q
(let ((rslt '(1 5 10 10 5 1)))
(dotimes (i 6)
(is (equal (cat:binomial-n-p (- 5 i) i)
(is (equal (cat:binomial-p-q (- 5 i) i)
(nth i rslt))))))
(test <a-b<