diff --git a/src/cat-init.lisp b/src/cat-init.lisp index 7bd42d9..5df62b8 100644 --- a/src/cat-init.lisp +++ b/src/cat-init.lisp @@ -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.")) diff --git a/test/bar-test.lisp b/test/bar-test.lisp index 7eab3db..256c5f5 100644 --- a/test/bar-test.lisp +++ b/test/bar-test.lisp @@ -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)))) diff --git a/test/common.lisp b/test/common.lisp index 9d5e5e6..3196403 100644 --- a/test/common.lisp +++ b/test/common.lisp @@ -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)))