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)))
(DEFCONSTANT +SOURCE-EXTENSION+
#+(or allegro clisp lispworks) "cl"
#+(or ccl ecl sbcl) "lisp"
#+(or allegro lispworks) "cl"
#+(or clisp ccl ecl sbcl) "lisp"
#-(or allegro ccl clisp ecl lispworks sbcl)
(error "Not an Allegro or CCL or CLisp or LispWorks or SBCL environment."))

139
test/bar-test.lisp
View File

@ -1,4 +1,4 @@
(in-package :kenzo-test)
(in-suite :kenzo)
@ -59,7 +59,7 @@
(defun random-abar1 (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (cat:mask 7)))
(let* ((gmsm (random (cat:mask 6)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt))))
@ -68,18 +68,18 @@
(test vrtc-bar
(progn
(cat:cat-init)
(let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
(dotimes (i 10)
(print (random-abar1 5)))
(dotimes (i 10)
(let ((abar (random-abar1 3)))
(print abar)
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar))
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car
(cat:abar-list abar)))
abar))))))))
(cat:cat-init)
(let ((v (cat:vrtc-bar (cat:delta-infinity))))
(dotimes (i 10)
(print (random-abar1 5)))
(dotimes (i 10)
(let ((abar (random-abar1 3)))
(print abar)
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar))
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car
(cat:abar-list abar)))
abar))))))))
(test bar-intr-hrzn-dffr
@ -177,65 +177,64 @@
3 (cat:crpr 0 14 0 14))))))
#|
(test vrtc-bar1
(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
(progn
(cat:cat-init)
(let* ((h (cat:efhm (cat:k-z-1)))
(b (cat:bar h)))
(cat:homology (cat:rbcc b) 0 11))))
(cat:cat-init)
(let* ((h (cat:efhm (cat:k-z-1)))
(b (cat:bar h)))
(cat:homology (cat:rbcc b) 0 11))))

218
test/common.lisp
View File

@ -22,36 +22,36 @@
(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))))
: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))))
(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)))
@ -68,44 +68,44 @@
(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)))))
(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))))
: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)))
(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))))
(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)))
@ -113,13 +113,13 @@
(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))))
(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)))
@ -136,58 +136,58 @@
(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)))))
(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))))
: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*))
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*))))))
(cat:cmbn-? (eval phi)
(if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg*
cat:*dg-gd* cat:*hg*))
cat:*bc*
cat:*tc*))))))
(defun aleat-tc ()
(do ((tdegr 0 (+ tdegr degr))
(degr (+ 2 (random 3)) (+ 2 (random 3)))
(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)))
((> tdegr 10) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt))))))
((> tdegr 8) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt))))))
(defun aleat-bc ()
(do ((tdegr 0 (+ tdegr degr))
(degr (1+ (random 4)) (1+ (random 4)))
(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)))
((> tdegr 10) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt))))))
((> tdegr 8) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt))))))
(defun c ()
@ -203,53 +203,53 @@
((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (cat:brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (cat:mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cat:cbgn (1- dmns) gmsm) rslt))))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cat:cbgn (1- dmns) gmsm) rslt))))
(cat:make-allp :list rslt)))
(defun random-apowr (dmns max-expn)
(loop
(let* ((dgop (random (cat:2-exp (1- dmns))))
(gmsm (- dmns (logcount dgop))))
(gmsm (- dmns (logcount dgop))))
(unless (< 0 gmsm 3)
(return-from random-apowr
(cat:apowr dgop gmsm (cat:srandom max-expn)))))))
(return-from random-apowr
(cat:apowr dgop gmsm (cat:srandom max-expn)))))))
(defun random-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
(apply #'cat:nterm-add cmpr degr
(mapcar #'(lambda (dummy)
(declare (ignore dummy))
(mapcar #'(lambda (dummy)
(declare (ignore dummy))
(cat:term (cat:srandom max-cffc)
(random-crpr degr max-expn loop-length)))
(make-list cmbn-length))))
(random-crpr degr max-expn loop-length)))
(make-list cmbn-length))))
(defun random-crpr (dmns max-expn length)
(loop
(let ((loop (cat:normalize-loop dmns
(random-niloop dmns max-expn length)))
(dgop (random (cat:2-exp dmns))))
(random-niloop dmns max-expn length)))
(dgop (random (cat:2-exp dmns))))
(let ((absm (cat:2absm-acrpr (cat:absm dgop (- dmns (logcount dgop)))
loop)))
(when (and (zerop (cat:dgop absm))
(not (< (cat:gmsm1 (cat:gmsm absm)) 3)))
(return (cat:gmsm absm)))))))
loop)))
(when (and (zerop (cat:dgop absm))
(not (< (cat:gmsm1 (cat:gmsm absm)) 3)))
(return (cat:gmsm absm)))))))
(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
@ -259,13 +259,13 @@
((zerop i)
(apply #'cat:nterm-add cmpr degr rslt))
(setf term
(cat:term (cat:srandom max-cffc)
(cat:make-loop :list (random-niloop degr max-expn
loop-length))))))
(cat:term (cat:srandom max-cffc)
(cat:make-loop :list (random-niloop degr max-expn
loop-length))))))
(defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy)
(declare (ignore dummy))
(random-apowr (1+ dmns) max-expn))
(make-list length)))
(declare (ignore dummy))
(random-apowr (1+ dmns) max-expn))
(make-list length)))