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

Applied Francis' changes to remedy issue #44. It's still failing.

Browse Source
This commit is contained in:
Gerd Heber 2015-11-24 20:14:03 -06:00
parent 90467b1895
commit ffdcb9cd7f
3 changed files with 180 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/cat-init.lisp
View File

@ -60,8 +60,8 @@
(format t "~% FILE ~2D: ~A" i (car mark))) (format t "~% FILE ~2D: ~A" i (car mark)))
(DEFCONSTANT +SOURCE-EXTENSION+ (DEFCONSTANT +SOURCE-EXTENSION+
#+(or allegro clisp lispworks) "cl" #+(or allegro lispworks) "cl"
#+(or ccl ecl sbcl) "lisp" #+(or clisp ccl ecl sbcl) "lisp"
#-(or allegro ccl clisp ecl lispworks sbcl) #-(or allegro ccl clisp ecl lispworks sbcl)
(error "Not an Allegro or CCL or CLisp or LispWorks or SBCL environment.")) (error "Not an Allegro or CCL or CLisp or LispWorks or SBCL environment."))

137
test/bar-test.lisp
View File

@ -59,7 +59,7 @@
(defun random-abar1 (length) (defun random-abar1 (length)
(let ((rslt nil)) (let ((rslt nil))
(dotimes (i length) (dotimes (i length)
(let* ((gmsm (random (cat:mask 7))) (let* ((gmsm (random (cat:mask 6)))
(dmns (1- (logcount gmsm)))) (dmns (1- (logcount gmsm))))
(when (plusp dmns) (when (plusp dmns)
(push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt)))) (push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt))))
@ -68,18 +68,18 @@
(test vrtc-bar (test vrtc-bar
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((v (cat:vrtc-bar (cat:soft-delta-infinity)))) (let ((v (cat:vrtc-bar (cat:delta-infinity))))
(dotimes (i 10) (dotimes (i 10)
(print (random-abar1 5))) (print (random-abar1 5)))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar1 3))) (let ((abar (random-abar1 3)))
(print abar) (print abar)
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar))) (print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar)) abar))
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car (print (cat:? v (cat:? v (apply #'+ (mapcar #'car
(cat:abar-list abar))) (cat:abar-list abar)))
abar)))))))) abar))))))))
(test bar-intr-hrzn-dffr (test bar-intr-hrzn-dffr
@ -177,65 +177,64 @@
3 (cat:crpr 0 14 0 14)))))) 3 (cat:crpr 0 14 0 14))))))
#|
(test vrtc-bar1 (test vrtc-bar1
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((tcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(a b c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn (1- degr) 1 'b 1 'd))
((b d) (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(tcc)))
(bcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(d (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(bcc)))
(f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn degr 1 'c 1 'd))
(b (cat:cmbn degr))
((c d) (cat:cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f)))
(g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
:intr #'identity :strt :cmbn :orgn '(g)))
(h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(ecase gnrt
((a b) (cat:cmbn
(1+ degr)
1 'a -1 'b -1 'c -1 'd))
((c d) (cat:cmbn (1+ degr)))))
:strt :gnrt :orgn '(h)))
(rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
(bar))
(cat:tcc rdct 3 'a)
(cat:g rdct (cat:f rdct 3 'a))
(cat:h rdct 3 'a)
(setf bar (cat:vrtc-bar rdct))
(cat:pre-check-rdct bar)
(aleat-tc)
(aleat-bc)
;;(loop (c))
(dotimes (i 10) (c))))) ;; degrees >= 15 is possible => error.
(let* ((tcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(a b c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn (1- degr) 1 'b 1 'd))
((b d) (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(tcc)))
(bcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(d (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(bcc)))
(f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn degr 1 'c 1 'd))
(b (cat:cmbn degr))
((c d) (cat:cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f)))
(g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
:intr #'identity :strt :cmbn :orgn '(g)))
(h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(ecase gnrt
((a b) (cat:cmbn
(1+ degr)
1 'a -1 'b -1 'c -1 'd))
((c d) (cat:cmbn (1+ degr)))))
:strt :gnrt :orgn '(h)))
(rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
(bar))
(cat:tcc rdct 3 'a)
(cat:g rdct (cat:f rdct 3 'a))
(cat:h rdct 3 'a)
(setf bar (cat:vrtc-bar rdct))
(cat:pre-check-rdct bar)
(aleat-tc)
(aleat-bc)
;;(loop (c))
(dotimes (i 10) (c))))) ;; degrees >= 15 is possible => error.
|#
(test homology (test homology
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((h (cat:efhm (cat:k-z-1))) (let* ((h (cat:efhm (cat:k-z-1)))
(b (cat:bar h))) (b (cat:bar h)))
(cat:homology (cat:rbcc b) 0 11)))) (cat:homology (cat:rbcc b) 0 11))))

218
test/common.lisp
View File

@ -22,36 +22,36 @@
(defun cdelta (dmns) (defun cdelta (dmns)
(the cat:chain-complex (the cat:chain-complex
(cat:build-chcm (cat:build-chcm
:cmpr #'cat:l-cmpr :cmpr #'cat:l-cmpr
:basis :locally-effective :basis :locally-effective
:bsgn '(0) :bsgn '(0)
:intr-dffr #'(lambda (degr gmsm) :intr-dffr #'(lambda (degr gmsm)
(cat:make-cmbn (cat:make-cmbn
:degr (1- degr) :degr (1- degr)
:list (do ((rslt cat:+empty-list+ :list (do ((rslt cat:+empty-list+
(cons (cons sign (cons (cons sign
(append (append
(subseq gmsm 0 nark) (subseq gmsm 0 nark)
(subseq gmsm (1+ nark)))) (subseq gmsm (1+ nark))))
rslt)) rslt))
(sign 1 (- sign)) (sign 1 (- sign))
(nark 0 (1+ nark))) (nark 0 (1+ nark)))
((> nark degr) rslt)))) ((> nark degr) rslt))))
:strt :gnrt :strt :gnrt
:orgn `(locally effective version of C_* delta ,dmns)))) :orgn `(locally effective version of C_* delta ,dmns))))
(defun make-f (tdmns bdmns) (defun make-f (tdmns bdmns)
(cat:build-mrph (cat:build-mrph
:sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0 :sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0
:intr #'(lambda (degr gmsm) :intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (let ((pos (position-if #'(lambda (vertex)
(>= vertex bdmns)) gmsm))) (>= vertex bdmns)) gmsm)))
(if pos (if pos
(if (< pos degr) (if (< pos degr)
(cat:zero-cmbn degr) (cat:zero-cmbn degr)
(cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns)))) (cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
(cat:cmbn degr 1 gmsm)))) (cat:cmbn degr 1 gmsm))))
:strt :gnrt :strt :gnrt
:orgn `(projection delta ,tdmns => delta ,bdmns))) :orgn `(projection delta ,tdmns => delta ,bdmns)))
@ -68,44 +68,44 @@
(cat:build-mrph (cat:build-mrph
:sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1 :sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1
:intr #'(lambda (degr gmsm) :intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (let ((pos (position-if #'(lambda (vertex)
(>= vertex bdmns)) gmsm))) (>= vertex bdmns)) gmsm)))
(if pos (if pos
(if (member bdmns gmsm) (if (member bdmns gmsm)
(cat:zero-cmbn (1+ degr)) (cat:zero-cmbn (1+ degr))
(cat:cmbn (1+ degr) (cat:-1-expt-n pos) (cat:cmbn (1+ degr) (cat:-1-expt-n pos)
(append (subseq gmsm 0 pos) (list bdmns) (append (subseq gmsm 0 pos) (list bdmns)
(subseq gmsm pos)))) (subseq gmsm pos))))
(cat:zero-cmbn (1+ degr))))) (cat:zero-cmbn (1+ degr)))))
:strt :gnrt :strt :gnrt
:orgn `(homotopy for delta ,tdmns => ,bdmns))) :orgn `(homotopy for delta ,tdmns => ,bdmns)))
(defun make-rdct (tdmns bdmns) (defun make-rdct (tdmns bdmns)
(let ((rdct (cat:build-rdct (let ((rdct (cat:build-rdct
:f (make-f tdmns bdmns) :f (make-f tdmns bdmns)
:g (make-g tdmns bdmns) :g (make-g tdmns bdmns)
:h (make-h tdmns bdmns) :h (make-h tdmns bdmns)
:orgn `(reduction delta ,tdmns ,bdmns)))) :orgn `(reduction delta ,tdmns ,bdmns))))
rdct)) rdct))
(defun cdelta1 (dmns) (defun cdelta1 (dmns)
(cat:build-chcm (cat:build-chcm
:cmpr #'cat:l-cmpr :cmpr #'cat:l-cmpr
:basis #'(lambda (n) :basis #'(lambda (n)
(mapcar #'cat:dlop-int-ext (funcall (cat:delta-n-basis dmns) n))) (mapcar #'cat:dlop-int-ext (funcall (cat:delta-n-basis dmns) n)))
:bsgn '(0) :bsgn '(0)
:intr-dffr #'(lambda (degr gmsm) :intr-dffr #'(lambda (degr gmsm)
(cat:make-cmbn (cat:make-cmbn
:degr (1- degr) :degr (1- degr)
:list (do ((rslt cat:+empty-list+ :list (do ((rslt cat:+empty-list+
(cons (cons sign (append (cons (cons sign (append
(subseq gmsm 0 nark) (subseq gmsm 0 nark)
(subseq gmsm (1+ nark)))) (subseq gmsm (1+ nark))))
rslt)) rslt))
(sign 1 (- sign)) (sign 1 (- sign))
(nark 0 (1+ nark))) (nark 0 (1+ nark)))
((> nark degr) rslt)))) ((> nark degr) rslt))))
:strt :gnrt :strt :gnrt
:orgn `(locally effective version of C_* delta ,dmns))) :orgn `(locally effective version of C_* delta ,dmns)))
@ -113,13 +113,13 @@
(cat:build-mrph (cat:build-mrph
:sorc (cdelta1 tdmns) :trgt (cdelta1 bdmns) :degr 0 :sorc (cdelta1 tdmns) :trgt (cdelta1 bdmns) :degr 0
:intr #'(lambda (degr gmsm) :intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (let ((pos (position-if #'(lambda (vertex)
(>= vertex bdmns)) gmsm))) (>= vertex bdmns)) gmsm)))
(if pos (if pos
(if (< pos degr) (if (< pos degr)
(cat:zero-cmbn degr) (cat:zero-cmbn degr)
(cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns)))) (cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
(cat:cmbn degr 1 gmsm)))) (cat:cmbn degr 1 gmsm))))
:strt :gnrt :strt :gnrt
:orgn `(projection delta ,tdmns => delta ,bdmns))) :orgn `(projection delta ,tdmns => delta ,bdmns)))
@ -136,58 +136,58 @@
(cat:build-mrph (cat:build-mrph
:sorc (cdelta1 tdmns) :trgt (cdelta1 tdmns) :degr +1 :sorc (cdelta1 tdmns) :trgt (cdelta1 tdmns) :degr +1
:intr #'(lambda (degr gmsm) :intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (let ((pos (position-if #'(lambda (vertex)
(>= vertex bdmns)) gmsm))) (>= vertex bdmns)) gmsm)))
(if pos (if pos
(if (member bdmns gmsm) (if (member bdmns gmsm)
(cat:zero-cmbn (1+ degr)) (cat:zero-cmbn (1+ degr))
(cat:cmbn (1+ degr) (cat:-1-expt-n pos) (cat:cmbn (1+ degr) (cat:-1-expt-n pos)
(append (subseq gmsm 0 pos) (list bdmns) (append (subseq gmsm 0 pos) (list bdmns)
(subseq gmsm pos)))) (subseq gmsm pos))))
(cat:zero-cmbn (1+ degr))))) (cat:zero-cmbn (1+ degr)))))
:strt :gnrt :strt :gnrt
:orgn `(homotopy for delta ,tdmns => ,bdmns))) :orgn `(homotopy for delta ,tdmns => ,bdmns)))
(defun make-rdct1 (tdmns bdmns) (defun make-rdct1 (tdmns bdmns)
(let ((rdct (cat:build-rdct (let ((rdct (cat:build-rdct
:f (make-f1 tdmns bdmns) :f (make-f1 tdmns bdmns)
:g (make-g1 tdmns bdmns) :g (make-g1 tdmns bdmns)
:h (make-h1 tdmns bdmns) :h (make-h1 tdmns bdmns)
:orgn `(reduction delta ,tdmns ,bdmns)))) :orgn `(reduction delta ,tdmns ,bdmns))))
rdct)) rdct))
(defun check-rdct () (defun check-rdct ()
(dolist (phi '(cat:*tdd* cat:*bdd* cat:*df-fd* cat:*dg-gd* cat:*id-fg* (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*)) cat:*id-gf-dh-hd* cat:*hh* cat:*fh* cat:*hg*))
(declare (type symbol phi)) (declare (type symbol phi))
(is (cat:cmbn-zero-p (is (cat:cmbn-zero-p
(cat:cmbn-? (eval phi) (cat:cmbn-? (eval phi)
(if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg* (if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg*
cat:*dg-gd* cat:*hg*)) cat:*dg-gd* cat:*hg*))
cat:*bc* cat:*bc*
cat:*tc*)))))) cat:*tc*))))))
(defun aleat-tc () (defun aleat-tc ()
(do ((tdegr 0 (+ tdegr degr)) (do ((tdegr 0 (+ tdegr degr))
(degr (+ 2 (random 3)) (+ 2 (random 3))) (degr (+ 2 (random 3)) (+ 2 (random 3)))
(gnrt (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)) (gnrt (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))
(intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))) (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)))
(rslt nil (cons (cat:brgn degr gnrt) rslt))) (rslt nil (cons (cat:brgn degr gnrt) rslt)))
((> tdegr 10) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar ((> tdegr 8) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt)))))) :list rslt))))))
(defun aleat-bc () (defun aleat-bc ()
(do ((tdegr 0 (+ tdegr degr)) (do ((tdegr 0 (+ tdegr degr))
(degr (1+ (random 4)) (1+ (random 4))) (degr (1+ (random 4)) (1+ (random 4)))
(gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)) (gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))
(intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))) (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)))
(rslt nil (cons (cat:brgn degr gnrt) rslt))) (rslt nil (cons (cat:brgn degr gnrt) rslt)))
((> tdegr 10) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar ((> tdegr 8) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt)))))) :list rslt))))))
(defun c () (defun c ()
@ -203,53 +203,53 @@
((>= cum-degr tot-degr~) (cat:make-abar :list rslt)) ((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
(setf degr (1+ (random max-degr))) (setf degr (1+ (random max-degr)))
(push (cat:brgn (1+ degr) (push (cat:brgn (1+ degr)
(let ((list (make-list degr))) (let ((list (make-list degr)))
(mapl (mapl
#'(lambda (sublist) #'(lambda (sublist)
(setf (car sublist) (- (random 21) 10))) (setf (car sublist) (- (random 21) 10)))
list) list)
list)) list))
rslt))) rslt)))
(defun random-allp (length) (defun random-allp (length)
(let ((rslt nil)) (let ((rslt nil))
(dotimes (i length) (dotimes (i length)
(let* ((gmsm (random (cat:mask 9))) (let* ((gmsm (random (cat:mask 9)))
(dmns (1- (logcount gmsm)))) (dmns (1- (logcount gmsm))))
(when (plusp dmns) (when (plusp dmns)
(push (cat:cbgn (1- dmns) gmsm) rslt)))) (push (cat:cbgn (1- dmns) gmsm) rslt))))
(cat:make-allp :list rslt))) (cat:make-allp :list rslt)))
(defun random-apowr (dmns max-expn) (defun random-apowr (dmns max-expn)
(loop (loop
(let* ((dgop (random (cat:2-exp (1- dmns)))) (let* ((dgop (random (cat:2-exp (1- dmns))))
(gmsm (- dmns (logcount dgop)))) (gmsm (- dmns (logcount dgop))))
(unless (< 0 gmsm 3) (unless (< 0 gmsm 3)
(return-from random-apowr (return-from random-apowr
(cat:apowr dgop gmsm (cat:srandom max-expn))))))) (cat:apowr dgop gmsm (cat:srandom max-expn)))))))
(defun random-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length) (defun random-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
(apply #'cat:nterm-add cmpr degr (apply #'cat:nterm-add cmpr degr
(mapcar #'(lambda (dummy) (mapcar #'(lambda (dummy)
(declare (ignore dummy)) (declare (ignore dummy))
(cat:term (cat:srandom max-cffc) (cat:term (cat:srandom max-cffc)
(random-crpr degr max-expn loop-length))) (random-crpr degr max-expn loop-length)))
(make-list cmbn-length)))) (make-list cmbn-length))))
(defun random-crpr (dmns max-expn length) (defun random-crpr (dmns max-expn length)
(loop (loop
(let ((loop (cat:normalize-loop dmns (let ((loop (cat:normalize-loop dmns
(random-niloop dmns max-expn length))) (random-niloop dmns max-expn length)))
(dgop (random (cat:2-exp dmns)))) (dgop (random (cat:2-exp dmns))))
(let ((absm (cat:2absm-acrpr (cat:absm dgop (- dmns (logcount dgop))) (let ((absm (cat:2absm-acrpr (cat:absm dgop (- dmns (logcount dgop)))
loop))) loop)))
(when (and (zerop (cat:dgop absm)) (when (and (zerop (cat:dgop absm))
(not (< (cat:gmsm1 (cat:gmsm absm)) 3))) (not (< (cat:gmsm1 (cat:gmsm absm)) 3)))
(return (cat:gmsm absm))))))) (return (cat:gmsm absm)))))))
(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length) (defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
@ -259,13 +259,13 @@
((zerop i) ((zerop i)
(apply #'cat:nterm-add cmpr degr rslt)) (apply #'cat:nterm-add cmpr degr rslt))
(setf term (setf term
(cat:term (cat:srandom max-cffc) (cat:term (cat:srandom max-cffc)
(cat:make-loop :list (random-niloop degr max-expn (cat:make-loop :list (random-niloop degr max-expn
loop-length)))))) loop-length))))))
(defun random-niloop (dmns max-expn length) (defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy) (mapcar #'(lambda (dummy)
(declare (ignore dummy)) (declare (ignore dummy))
(random-apowr (1+ dmns) max-expn)) (random-apowr (1+ dmns) max-expn))
(make-list length))) (make-list length)))