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

Added first batch of ABAR tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-08 21:35:22 -05:00
parent 7776c92aaf
commit 8b2a7e835c
4 changed files with 615 additions and 565 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
kenzo-test.asd
View File

@ -20,4 +20,5 @@
(:file "bicones-test") (:file "bicones-test")
(:file "homology-groups-test") (:file "homology-groups-test")
(:file "searching-homology-test") (:file "searching-homology-test")
(:file "delta-test"))) (:file "delta-test")
(:file "bar-test")))

15
package.lisp
View File

@ -20,6 +20,16 @@
*TC* *TC*
*TDD* *TDD*
;; bar.lisp
ABAR
BAR-BASIS-LENGTH
BAR-BASIS
BAR-CMPR
BAR-INTR-HRZN-DFFR
BAR-INTR-VRTC-DFFR
VRTC-BAR
;; bicones.lisp ;; bicones.lisp
BICN-CMBN-CMBNB BICN-CMBN-CMBNB
@ -64,6 +74,7 @@
;; classes.lisp ;; classes.lisp
BCC BCC
BRGN
CHAIN-COMPLEX CHAIN-COMPLEX
CMBN-CMBN CMBN-CMBN
CMBN-DEGR CMBN-DEGR
@ -78,6 +89,7 @@
HOMOTOPY-EQUIVALENCE HOMOTOPY-EQUIVALENCE
IABSM IABSM
LRDCT LRDCT
MAKE-ABAR
MAKE-CMBN MAKE-CMBN
MAKE-RESULT MAKE-RESULT
MORPHISM MORPHISM
@ -146,11 +158,14 @@
;; k-pi-n.lisp ;; k-pi-n.lisp
K-Z K-Z
K-Z-1
;; macros.lisp ;; macros.lisp
-1-EXPT-N -1-EXPT-N
? ?
ABAR-LIST
APRD
BASIS BASIS
BCC BCC
BCNB BCNB

249
src/bar.lisp
View File

@ -23,13 +23,7 @@
(declare (list mark)) (declare (list mark))
(push (brgn (car mark) (cadr mark)) rslt)) (push (brgn (car mark) (cadr mark)) rslt))
(make-abar :list rslt)))) (make-abar :list rslt))))
#|
()
(abar )
(abar '(2 a 3 b))
(abar 2 'a 3 'b)
(abar 2 'a 3)) ;; error
|#
#-sbcl (DEFINE-CONSTANT +NULL-ABAR+ (make-abar :list +empty-list+)) #-sbcl (DEFINE-CONSTANT +NULL-ABAR+ (make-abar :list +empty-list+))
#+sbcl (DEFPARAMETER +NULL-ABAR+ (make-abar :list +empty-list+)) #+sbcl (DEFPARAMETER +NULL-ABAR+ (make-abar :list +empty-list+))
@ -68,7 +62,6 @@
;;; CLISP]+ ;;; CLISP]+
(DEFUN BAR-CMPR (cmpr) (DEFUN BAR-CMPR (cmpr)
(declare (type cmprf cmpr)) (declare (type cmprf cmpr))
(flet ((rslt (abar1 abar2) (flet ((rslt (abar1 abar2)
@ -87,14 +80,6 @@
list1 list2)))))) list1 list2))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
#|
(setf r (bar-cmpr #'s-cmpr))
(funcall r (abar) (abar))
(funcall r (abar 3 'a) (abar))
(funcall r (abar 3 'a) (abar 2 'a 1 'b))
(funcall r (abar 3 'a) (abar 3 'b))
(funcall r (abar 3 'a) (abar 3 'a)))
|#
(DEFUN BAR-BASIS-LENGTH (basis degr length) (DEFUN BAR-BASIS-LENGTH (basis degr length)
(declare (declare
@ -129,26 +114,6 @@
list1))) list1)))
(>a-b< 1 (1- degr)))))) (>a-b< 1 (1- degr))))))
#|
()
(setf basis #'(lambda (degr)
(list degr)))
(bar-basis-length basis 2 1)
(bar-basis-length basis 2 2)
(bar-basis-length basis 3 1)
(bar-basis-length basis 3 2)
(bar-basis-length basis 4 1)
(bar-basis-length basis 4 2)
(bar-basis-length basis 4 3)
(bar-basis-length basis 4 4)
(bar-basis-length basis 8 1)
(bar-basis-length basis 8 2)
(bar-basis-length basis 8 3)
(bar-basis-length basis 8 4)
(bar-basis-length basis 8 5)
(bar-basis-length basis 8 6)
(bar-basis-length basis 8 11))
|#
(DEFUN BAR-BASIS (basis) (DEFUN BAR-BASIS (basis)
(declare (type basis basis)) (declare (type basis basis))
@ -173,18 +138,6 @@
(>a-b> 0 (floor degr 2))))))) (>a-b> 0 (floor degr 2)))))))
#'rslt)))) #'rslt))))
#|
()
(setf basis #'(lambda (degr)
(list degr)))
(setf r (bar-basis basis))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(dotimes (i 7)
(print (funcall r i)))
(bar-basis :locally-effective))
|#
(DEFUN BAR-INTR-VRTC-DFFR (dffr) (DEFUN BAR-INTR-VRTC-DFFR (dffr)
(declare (type morphism dffr)) (declare (type morphism dffr))
@ -205,7 +158,8 @@
(type brgn brgn1) (type brgn brgn1)
(type iabar rest2)) (type iabar rest2))
(with-brgn (degr1 gnrt1) brgn1 (with-brgn (degr1 gnrt1) brgn1
(let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1- degr1) gnrt1))) (let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1- degr1)
gnrt1)))
(d-rest2 (rslt (- degr degr1) rest2)) (d-rest2 (rslt (- degr degr1) rest2))
(degr1-1 (1- degr1)) (degr1-1 (1- degr1))
(rest-sign (-1-expt-n degr1))) (rest-sign (-1-expt-n degr1)))
@ -218,7 +172,8 @@
(declare (type term term)) (declare (type term term))
(with-term (cffc gnrt) term (with-term (cffc gnrt) term
(term (- cffc) (term (- cffc)
(cons (brgn degr1-1 gnrt) rest2)))) (cons (brgn degr1-1 gnrt)
rest2))))
d-gnrt1) d-gnrt1)
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
@ -239,17 +194,10 @@
(term cffc (make-abar :list iabar)))) (term cffc (make-abar :list iabar))))
(rslt degr (abar-list abar)))))))) (rslt degr (abar-list abar))))))))
#|
(setf d (soft-delta-infinity))
(setf r (bar-intr-vrtc-dffr (dffr d)))
(funcall r 0 (abar))
(funcall r 3 (abar 3 (d 7)))
(funcall r 5 (abar 3 (d 7) 2 (d 3)))
(funcall r 5 (abar 2 (d 3) 3 (d 7))))
|#
(DEFGENERIC VRTC-BAR (chcm-hmeq-mrph)) (DEFGENERIC VRTC-BAR (chcm-hmeq-mrph))
(DEFMETHOD VRTC-BAR ((chcm chain-complex)) (DEFMETHOD VRTC-BAR ((chcm chain-complex))
(the chain-complex (the chain-complex
(with-slots (cmpr basis dffr) chcm (with-slots (cmpr basis dffr) chcm
@ -265,24 +213,6 @@
:strt :gnrt :strt :gnrt
:orgn `(vrtc-bar ,chcm))))) :orgn `(vrtc-bar ,chcm)))))
#|
(cat-init)
(setf v (vrtc-bar (soft-delta-infinity)))
(defun random-abar (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 7)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (brgn (1+ dmns) (d gmsm)) rslt))))
(make-abar :list rslt)))
(dotimes (i 10) (print (random-abar 5)))
(dotimes (i 10)
(let ((abar (random-abar 3)))
(print abar)
(print (? v (apply #'+ (mapcar #'car (abar-list abar))) abar))
(print (? v (? v (apply #'+ (mapcar #'car (abar-list abar))) abar)))))
|#
(DEFUN BAR-INTR-HRZN-DFFR (aprd) (DEFUN BAR-INTR-HRZN-DFFR (aprd)
(declare (type morphism aprd)) (declare (type morphism aprd))
@ -304,26 +234,44 @@
(with-brgn (degr1 gnrt1) brgn1 (with-brgn (degr1 gnrt1) brgn1
(with-brgn (degr2 gnrt2) brgn2 (with-brgn (degr2 gnrt2) brgn2
(let ((sign (-1-expt-n degr1)) (let ((sign (-1-expt-n degr1))
(aprd-brgn1-brgn2 (gnrt-? aprd (+ degr1 degr2 -2) (aprd-brgn1-brgn2
(tnpr (1- degr1) gnrt1 (gnrt-? aprd
(1- degr2) gnrt2))) (+ degr1 degr2 -2)
(aprd-rest1 (rslt (- degr degr1) rest1))) (tnpr (1- degr1)
gnrt1
(1- degr2)
gnrt2)))
(aprd-rest1 (rslt
(- degr degr1)
rest1)))
(declare (declare
(type icmbn aprd-brgn1-brgn2 aprd-rest1)) (type icmbn aprd-brgn1-brgn2
(with-cmbn (degr12 icmbn12) aprd-brgn1-brgn2 aprd-rest1))
(with-cmbn (degr12 icmbn12)
aprd-brgn1-brgn2
(incf degr12) (incf degr12)
(nconc (nconc
(mapcar (mapcar
#'(lambda (term2) #'(lambda (term2)
(declare (type term term2)) (declare (type term
(with-term (cffc2 iabar2) term2 term2))
(term (* sign cffc2) (cons brgn1 iabar2)))) (with-term (cffc2 iabar2)
term2
(term (* sign cffc2)
(cons brgn1
iabar2))))
aprd-rest1) aprd-rest1)
(mapcar (mapcar
#'(lambda (term1) #'(lambda (term1)
(declare (type term term1)) (declare (type term
(with-term (cffc1 gnrt12) term1 term1))
(term (* sign cffc1) (cons (brgn degr12 gnrt12) rest2)))) (with-term (cffc1 gnrt12)
term1
(term (* sign cffc1)
(cons (brgn
degr12
gnrt12)
rest2))))
icmbn12))))))))))) icmbn12)))))))))))
(the intr-mrph (the intr-mrph
#'(lambda (degr abar) #'(lambda (degr abar)
@ -335,18 +283,11 @@
:list (mapcar #'(lambda (term) :list (mapcar #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc iabar) term (with-term (cffc iabar) term
(term cffc (make-abar :list iabar)))) (term cffc
(make-abar
:list iabar))))
(rslt degr (abar-list abar))))))))) (rslt degr (abar-list abar)))))))))
#|
(setf k (k-z-1))
(setf r (bar-intr-hrzn-dffr (aprd k)))
(funcall r 0 (abar ))
(funcall r 3 (abar 3 '(2 3)))
(funcall r 6 (abar 3 '(2 3) 3 '(-2 -3)))
(funcall r 9 (abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3)))
(funcall r 11 (abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3))))
|#
(DEFUN BAR-HRZN-DFFR (algb) (DEFUN BAR-HRZN-DFFR (algb)
(declare (type algebra algb)) (declare (type algebra algb))
@ -359,9 +300,9 @@
:orgn `(bar-hrzn-dffr ,algb))))) :orgn `(bar-hrzn-dffr ,algb)))))
#| #|
(cat-init) (cat-init)
(setf h (bar-hrzn-dffr (k-z-1))) (setf h (bar-hrzn-dffr (k-z-1)))
(defun random-abar (tot-degr~ max-degr) (defun random-abar (tot-degr~ max-degr)
(do ((rslt nil) (do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1)) (cum-degr 0 (+ cum-degr degr 1))
(degr)) (degr))
@ -375,11 +316,11 @@
list) list)
list)) list))
rslt))) rslt)))
(dotimes (i 10) (print (random-abar 10 5))) (dotimes (i 10) (print (random-abar 10 5)))
(setf abar (random-abar 10 5)) (setf abar (random-abar 10 5))
(? h (apply #'+ (mapcar #'car (abar-list abar))) abar) (? h (apply #'+ (mapcar #'car (abar-list abar))) abar)
(? h (? h (apply #'+ (mapcar #'car (abar-list abar))) abar)) (? h (? h (apply #'+ (mapcar #'car (abar-list abar))) abar))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 10 3))) (let ((abar (random-abar 10 3)))
(print abar) (print abar)
(print (? h (apply #'+ (mapcar #'car (abar-list abar))) abar)) (print (? h (apply #'+ (mapcar #'car (abar-list abar))) abar))
@ -419,9 +360,9 @@
rslt)))) rslt))))
#| #|
(cat-init) (cat-init)
(setf b (bar (k-z-1))) (setf b (bar (k-z-1)))
(defun random-abar (tot-degr~ max-degr) (defun random-abar (tot-degr~ max-degr)
(do ((rslt nil) (do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1)) (cum-degr 0 (+ cum-degr degr 1))
(degr)) (degr))
@ -435,10 +376,10 @@
list) list)
list)) list))
rslt))) rslt)))
(setf abar (random-abar 10 3)) (setf abar (random-abar 10 3))
(? b (apply #'+ (mapcar #'car (abar-list abar))) abar) (? b (apply #'+ (mapcar #'car (abar-list abar))) abar)
(? b (? b (apply #'+ (mapcar #'car (abar-list abar))) abar)) (? b (? b (apply #'+ (mapcar #'car (abar-list abar))) abar))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 10 3))) (let ((abar (random-abar 10 3)))
(print abar) (print abar)
(print (? b (apply #'+ (mapcar #'car (abar-list abar))) abar)) (print (? b (apply #'+ (mapcar #'car (abar-list abar))) abar))
@ -480,10 +421,10 @@
(first cmbn-list) (first cmbn-list)
(ncmbn-bar (rest cmbn-list)))))) (ncmbn-bar (rest cmbn-list))))))
#| #|
(ncmbn-bar nil) (ncmbn-bar nil)
(ncmbn-bar (list (cmbn 3 2 'a 3 'b))) (ncmbn-bar (list (cmbn 3 2 'a 3 'b)))
(ncmbn-bar (list (cmbn 1 2 'a 3 'b) (cmbn 2 4 'c 5 'd))) (ncmbn-bar (list (cmbn 1 2 'a 3 'b) (cmbn 2 4 'c 5 'd)))
(ncmbn-bar (list (cmbn 1 2 'a 3 'b) (cmbn 1 4 'c 5 'd) (cmbn 1 6 'e 7 'f)))) (ncmbn-bar (list (cmbn 1 2 'a 3 'b) (cmbn 1 4 'c 5 'd) (cmbn 1 6 'e 7 'f))))
|# |#
(DEFUN MRPH-VRTC-BAR-INTR (mrph) (DEFUN MRPH-VRTC-BAR-INTR (mrph)
@ -502,12 +443,12 @@
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
#| #|
(setf cc (build-chcm :cmpr #'f-cmpr :strt :cmbn)) (setf cc (build-chcm :cmpr #'f-cmpr :strt :cmbn))
(setf m (build-mrph :sorc cc :trgt cc :degr 0 :intr (setf m (build-mrph :sorc cc :trgt cc :degr 0 :intr
#'(lambda (degr gnrt) (cmbn degr 2 gnrt 3 (1+ gnrt))) #'(lambda (degr gnrt) (cmbn degr 2 gnrt 3 (1+ gnrt)))
:strt :gnrt :orgn '(test))) :strt :gnrt :orgn '(test)))
(setf r (mrph-vrtc-bar-intr m)) (setf r (mrph-vrtc-bar-intr m))
(funcall r 4 (abar 2 3 2 4)) (funcall r 4 (abar 2 3 2 4))
|# |#
(DEFMETHOD VRTC-BAR ((mrph morphism)) (DEFMETHOD VRTC-BAR ((mrph morphism))
@ -523,10 +464,10 @@
:orgn `(vrtc-bar ,mrph))))) :orgn `(vrtc-bar ,mrph)))))
#| #|
(cat-init) (cat-init)
(setf f (aw (soft-delta-infinity) (soft-delta-infinity))) (setf f (aw (soft-delta-infinity) (soft-delta-infinity)))
(setf cf (vrtc-bar f)) (setf cf (vrtc-bar f))
(? cf 6 (abar 3 (crpr 0 (d 7) 0 (d 7)) 3 (crpr 0 (d 56) 0 (d 56)))) (? cf 6 (abar 3 (crpr 0 (d 7) 0 (d 7)) 3 (crpr 0 (d 56) 0 (d 56))))
|# |#
(DEFUN HMTP-VRTC-BAR-INTR (h gf) (DEFUN HMTP-VRTC-BAR-INTR (h gf)
@ -589,12 +530,12 @@
(rslt degr (abar-list abar)))))))) (rslt degr (abar-list abar))))))))
#| #|
(cat-init) (cat-init)
(setf ez (ez (delta-infinity) (delta-infinity))) (setf ez (ez (delta-infinity) (delta-infinity)))
(setf h (h ez) gf (cmps (g ez) (f ez))) (setf h (h ez) gf (cmps (g ez) (f ez)))
(setf r (hmtp-vrtc-bar-intr h gf)) (setf r (hmtp-vrtc-bar-intr h gf))
(funcall r 3 (abar 3 (crpr 0 7 0 7))) (funcall r 3 (abar 3 (crpr 0 7 0 7)))
(funcall r 9 (abar 3 (crpr 0 7 0 7) 3 (crpr 0 14 0 14) 3 (crpr 0 14 0 14))) (funcall r 9 (abar 3 (crpr 0 7 0 7) 3 (crpr 0 14 0 14) 3 (crpr 0 14 0 14)))
|# |#
(DEFUN HMTP-VRTC-BAR (h gf) (DEFUN HMTP-VRTC-BAR (h gf)
@ -627,8 +568,8 @@
:orgn `(vrtc-bar ,rdct)))))) :orgn `(vrtc-bar ,rdct))))))
#| #|
(cat-init) (cat-init)
(setf tcc (build-chcm (setf tcc (build-chcm
:cmpr #'s-cmpr :cmpr #'s-cmpr
:basis #'(lambda (degr) '(a b c d)) :basis #'(lambda (degr) '(a b c d))
:bsgn 'd :bsgn 'd
@ -639,7 +580,7 @@
(c (cmbn (1- degr) 1 'd)))) (c (cmbn (1- degr) 1 'd))))
:strt :gnrt :strt :gnrt
:orgn '(tcc))) :orgn '(tcc)))
(setf bcc (build-chcm (setf bcc (build-chcm
:cmpr #'s-cmpr :cmpr #'s-cmpr
:basis #'(lambda (degr) '(c d)) :basis #'(lambda (degr) '(c d))
:bsgn 'd :bsgn 'd
@ -649,48 +590,48 @@
(c (cmbn (1- degr) 1 'd)))) (c (cmbn (1- degr) 1 'd))))
:strt :gnrt :strt :gnrt
:orgn '(bcc))) :orgn '(bcc)))
(setf f (build-mrph :sorc tcc :trgt bcc :degr 0 (setf f (build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(a (cmbn degr 1 'c 1 'd)) (a (cmbn degr 1 'c 1 'd))
(b (cmbn degr)) (b (cmbn degr))
((c d) (cmbn degr 1 gnrt)))) ((c d) (cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f))) :strt :gnrt :orgn '(f)))
(setf g (build-mrph :sorc bcc :trgt tcc :degr 0 (setf g (build-mrph :sorc bcc :trgt tcc :degr 0
:intr #'identity :strt :cmbn :orgn '(g))) :intr #'identity :strt :cmbn :orgn '(g)))
(setf h (build-mrph :sorc tcc :trgt tcc :degr +1 (setf h (build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd)) ((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd))
((c d) (cmbn (1+ degr))))) ((c d) (cmbn (1+ degr)))))
:strt :gnrt :orgn '(h))) :strt :gnrt :orgn '(h)))
(setf rdct (build-rdct :f f :g g :h h :orgn '(rdct))) (setf rdct (build-rdct :f f :g g :h h :orgn '(rdct)))
(tcc rdct 3 'a) (tcc rdct 3 'a)
(g rdct (f rdct 3 'a)) (g rdct (f rdct 3 'a))
(h rdct 3 'a) (h rdct 3 'a)
(setf bar (vrtc-bar rdct)) (setf bar (vrtc-bar rdct))
(pre-check-rdct bar) (pre-check-rdct bar)
(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 (brgn degr gnrt) rslt))) (rslt nil (cons (brgn degr gnrt) rslt)))
((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-abar :list rslt)))))) ((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-abar :list rslt))))))
(aleat-tc) (aleat-tc)
(defun aleat-bc () (defun aleat-bc ()
(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 (+ 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 (brgn degr gnrt) rslt))) (rslt nil (cons (brgn degr gnrt) rslt)))
((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-abar :list rslt)))))) ((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-abar :list rslt))))))
(aleat-bc) (aleat-bc)
(defun c () (defun c ()
(aleat-tc) (aleat-tc)
(aleat-bc) (aleat-bc)
(check-rdct)) (check-rdct))
(loop (c)) ;; degrees >= 15 is possible => error. (loop (c)) ;; degrees >= 15 is possible => error.
|# |#
(DEFMETHOD VRTC-BAR ((hmeq homotopy-equivalence)) (DEFMETHOD VRTC-BAR ((hmeq homotopy-equivalence))
@ -712,11 +653,11 @@
(add (vrtc-bar hmeq) (bar-hrzn-dffr (lbcc hmeq)))))) (add (vrtc-bar hmeq) (bar-hrzn-dffr (lbcc hmeq))))))
#| #|
(cat-init) (cat-init)
(setf h (efhm (k-z-1))) (setf h (efhm (k-z-1)))
(setf b (bar h)) (setf b (bar h))
(inspect b) (inspect b)
(homology (rbcc b) 0 11) (homology (rbcc b) 0 11)
|# |#

93
test/bar-test.lisp Normal file
View File

@ -0,0 +1,93 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(test abar
(cat:abar )
(cat:abar '(2 a 3 b))
(cat:abar 2 'a 3 'b)
(signals simple-error (cat:abar 2 'a 3)))
(test bar-cmpr
(let ((r (cat:bar-cmpr #'cat:s-cmpr)))
(is (equal :equal (funcall r (cat:abar) (cat:abar))))
(is (equal :greater (funcall r (cat:abar 3 'a) (cat:abar))))
(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 2 'a 1 'b))))
(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 3 'b))))
(is (equal :equal (funcall r (cat:abar 3 'a) (cat:abar 3 'a))))))
(test bar-basis-length
(let ((basis #'(lambda (degr) (list degr))))
(cat:bar-basis-length basis 2 1)
(cat:bar-basis-length basis 2 2)
(cat:bar-basis-length basis 3 1)
(cat:bar-basis-length basis 3 2)
(cat:bar-basis-length basis 4 1)
(cat:bar-basis-length basis 4 2)
(cat:bar-basis-length basis 4 3)
(cat:bar-basis-length basis 4 4)
(cat:bar-basis-length basis 8 1)
(cat:bar-basis-length basis 8 2)
(cat:bar-basis-length basis 8 3)
(cat:bar-basis-length basis 8 4)
(cat:bar-basis-length basis 8 5)
(cat:bar-basis-length basis 8 6)
(cat:bar-basis-length basis 8 11)))
(test bar-basis
(let* ((basis #'(lambda (degr) (list degr)))
(r (cat:bar-basis basis)))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(dotimes (i 7)
(print (funcall r i)))
(cat:bar-basis :locally-effective)))
(test bar-intr-vrtc-dffr
(let* ((d (cat:soft-delta-infinity))
(r (cat:bar-intr-vrtc-dffr (cat:dffr d))))
(funcall r 0 (cat:abar))
(funcall r 3 (cat:abar 3 (cat:d 7)))
(funcall r 5 (cat:abar 3 (cat:d 7) 2 (cat:d 3)))
(funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7)))))
(defun random-abar (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (cat:mask 7)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt))))
(cat:make-abar :list rslt)))
(test vrtc-bar
(progn
(cat:cat-init)
(let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
(dotimes (i 10)
(print (random-abar 5)))
(dotimes (i 10)
(let ((abar (random-abar 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
(let* ((k (cat:k-z-1))
(r (cat:bar-intr-hrzn-dffr (cat:aprd k))))
(funcall r 0 (cat:abar ))
(funcall r 3 (cat:abar 3 '(2 3)))
(funcall r 6 (cat:abar 3 '(2 3) 3 '(-2 -3)))
(funcall r 9 (cat:abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3)))
(funcall r 11 (cat:abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3)))))
|#