Added first batch of ABAR tests.
This commit is contained in:
Gerd Heber
parent
7776c92aaf
commit
8b2a7e835c
@ -20,4 +20,5 @@
|
||||
(:file "bicones-test")
|
||||
(:file "homology-groups-test")
|
||||
(:file "searching-homology-test")
|
||||
(:file "delta-test")))
|
||||
(:file "delta-test")
|
||||
(:file "bar-test")))
|
||||
|
||||
15
package.lisp
15
package.lisp
@ -20,6 +20,16 @@
|
||||
*TC*
|
||||
*TDD*
|
||||
|
||||
;; bar.lisp
|
||||
|
||||
ABAR
|
||||
BAR-BASIS-LENGTH
|
||||
BAR-BASIS
|
||||
BAR-CMPR
|
||||
BAR-INTR-HRZN-DFFR
|
||||
BAR-INTR-VRTC-DFFR
|
||||
VRTC-BAR
|
||||
|
||||
;; bicones.lisp
|
||||
|
||||
BICN-CMBN-CMBNB
|
||||
@ -64,6 +74,7 @@
|
||||
;; classes.lisp
|
||||
|
||||
BCC
|
||||
BRGN
|
||||
CHAIN-COMPLEX
|
||||
CMBN-CMBN
|
||||
CMBN-DEGR
|
||||
@ -78,6 +89,7 @@
|
||||
HOMOTOPY-EQUIVALENCE
|
||||
IABSM
|
||||
LRDCT
|
||||
MAKE-ABAR
|
||||
MAKE-CMBN
|
||||
MAKE-RESULT
|
||||
MORPHISM
|
||||
@ -146,11 +158,14 @@
|
||||
;; k-pi-n.lisp
|
||||
|
||||
K-Z
|
||||
K-Z-1
|
||||
|
||||
;; macros.lisp
|
||||
|
||||
-1-EXPT-N
|
||||
?
|
||||
ABAR-LIST
|
||||
APRD
|
||||
BASIS
|
||||
BCC
|
||||
BCNB
|
||||
|
||||
249
src/bar.lisp
249
src/bar.lisp
@ -23,13 +23,7 @@
|
||||
(declare (list mark))
|
||||
(push (brgn (car mark) (cadr mark)) 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 (DEFPARAMETER +NULL-ABAR+ (make-abar :list +empty-list+))
|
||||
@ -68,7 +62,6 @@
|
||||
;;; CLISP]+
|
||||
|
||||
|
||||
|
||||
(DEFUN BAR-CMPR (cmpr)
|
||||
(declare (type cmprf cmpr))
|
||||
(flet ((rslt (abar1 abar2)
|
||||
@ -87,14 +80,6 @@
|
||||
list1 list2))))))
|
||||
(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)
|
||||
(declare
|
||||
@ -129,26 +114,6 @@
|
||||
list1)))
|
||||
(>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)
|
||||
(declare (type basis basis))
|
||||
@ -173,18 +138,6 @@
|
||||
(>a-b> 0 (floor degr 2)))))))
|
||||
#'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)
|
||||
(declare (type morphism dffr))
|
||||
@ -205,7 +158,8 @@
|
||||
(type brgn brgn1)
|
||||
(type iabar rest2))
|
||||
(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))
|
||||
(degr1-1 (1- degr1))
|
||||
(rest-sign (-1-expt-n degr1)))
|
||||
@ -218,7 +172,8 @@
|
||||
(declare (type term term))
|
||||
(with-term (cffc gnrt) term
|
||||
(term (- cffc)
|
||||
(cons (brgn degr1-1 gnrt) rest2))))
|
||||
(cons (brgn degr1-1 gnrt)
|
||||
rest2))))
|
||||
d-gnrt1)
|
||||
(mapcar
|
||||
#'(lambda (term)
|
||||
@ -239,17 +194,10 @@
|
||||
(term cffc (make-abar :list iabar))))
|
||||
(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))
|
||||
|
||||
|
||||
(DEFMETHOD VRTC-BAR ((chcm chain-complex))
|
||||
(the chain-complex
|
||||
(with-slots (cmpr basis dffr) chcm
|
||||
@ -265,24 +213,6 @@
|
||||
:strt :gnrt
|
||||
: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)
|
||||
(declare (type morphism aprd))
|
||||
@ -304,26 +234,44 @@
|
||||
(with-brgn (degr1 gnrt1) brgn1
|
||||
(with-brgn (degr2 gnrt2) brgn2
|
||||
(let ((sign (-1-expt-n degr1))
|
||||
(aprd-brgn1-brgn2 (gnrt-? aprd (+ degr1 degr2 -2)
|
||||
(tnpr (1- degr1) gnrt1
|
||||
(1- degr2) gnrt2)))
|
||||
(aprd-rest1 (rslt (- degr degr1) rest1)))
|
||||
(aprd-brgn1-brgn2
|
||||
(gnrt-? aprd
|
||||
(+ degr1 degr2 -2)
|
||||
(tnpr (1- degr1)
|
||||
gnrt1
|
||||
(1- degr2)
|
||||
gnrt2)))
|
||||
(aprd-rest1 (rslt
|
||||
(- degr degr1)
|
||||
rest1)))
|
||||
(declare
|
||||
(type icmbn aprd-brgn1-brgn2 aprd-rest1))
|
||||
(with-cmbn (degr12 icmbn12) aprd-brgn1-brgn2
|
||||
(type icmbn aprd-brgn1-brgn2
|
||||
aprd-rest1))
|
||||
(with-cmbn (degr12 icmbn12)
|
||||
aprd-brgn1-brgn2
|
||||
(incf degr12)
|
||||
(nconc
|
||||
(mapcar
|
||||
#'(lambda (term2)
|
||||
(declare (type term term2))
|
||||
(with-term (cffc2 iabar2) term2
|
||||
(term (* sign cffc2) (cons brgn1 iabar2))))
|
||||
(declare (type term
|
||||
term2))
|
||||
(with-term (cffc2 iabar2)
|
||||
term2
|
||||
(term (* sign cffc2)
|
||||
(cons brgn1
|
||||
iabar2))))
|
||||
aprd-rest1)
|
||||
(mapcar
|
||||
#'(lambda (term1)
|
||||
(declare (type term term1))
|
||||
(with-term (cffc1 gnrt12) term1
|
||||
(term (* sign cffc1) (cons (brgn degr12 gnrt12) rest2))))
|
||||
(declare (type term
|
||||
term1))
|
||||
(with-term (cffc1 gnrt12)
|
||||
term1
|
||||
(term (* sign cffc1)
|
||||
(cons (brgn
|
||||
degr12
|
||||
gnrt12)
|
||||
rest2))))
|
||||
icmbn12)))))))))))
|
||||
(the intr-mrph
|
||||
#'(lambda (degr abar)
|
||||
@ -335,18 +283,11 @@
|
||||
:list (mapcar #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term (cffc iabar) term
|
||||
(term cffc (make-abar :list iabar))))
|
||||
(term cffc
|
||||
(make-abar
|
||||
:list iabar))))
|
||||
(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)
|
||||
(declare (type algebra algb))
|
||||
@ -359,9 +300,9 @@
|
||||
:orgn `(bar-hrzn-dffr ,algb)))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf h (bar-hrzn-dffr (k-z-1)))
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(cat-init)
|
||||
(setf h (bar-hrzn-dffr (k-z-1)))
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(do ((rslt nil)
|
||||
(cum-degr 0 (+ cum-degr degr 1))
|
||||
(degr))
|
||||
@ -375,11 +316,11 @@
|
||||
list)
|
||||
list))
|
||||
rslt)))
|
||||
(dotimes (i 10) (print (random-abar 10 5)))
|
||||
(setf abar (random-abar 10 5))
|
||||
(? h (apply #'+ (mapcar #'car (abar-list abar))) abar)
|
||||
(? h (? h (apply #'+ (mapcar #'car (abar-list abar))) abar))
|
||||
(dotimes (i 10)
|
||||
(dotimes (i 10) (print (random-abar 10 5)))
|
||||
(setf abar (random-abar 10 5))
|
||||
(? h (apply #'+ (mapcar #'car (abar-list abar))) abar)
|
||||
(? h (? h (apply #'+ (mapcar #'car (abar-list abar))) abar))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 10 3)))
|
||||
(print abar)
|
||||
(print (? h (apply #'+ (mapcar #'car (abar-list abar))) abar))
|
||||
@ -419,9 +360,9 @@
|
||||
rslt))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf b (bar (k-z-1)))
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(cat-init)
|
||||
(setf b (bar (k-z-1)))
|
||||
(defun random-abar (tot-degr~ max-degr)
|
||||
(do ((rslt nil)
|
||||
(cum-degr 0 (+ cum-degr degr 1))
|
||||
(degr))
|
||||
@ -435,10 +376,10 @@
|
||||
list)
|
||||
list))
|
||||
rslt)))
|
||||
(setf abar (random-abar 10 3))
|
||||
(? b (apply #'+ (mapcar #'car (abar-list abar))) abar)
|
||||
(? b (? b (apply #'+ (mapcar #'car (abar-list abar))) abar))
|
||||
(dotimes (i 10)
|
||||
(setf abar (random-abar 10 3))
|
||||
(? b (apply #'+ (mapcar #'car (abar-list abar))) abar)
|
||||
(? b (? b (apply #'+ (mapcar #'car (abar-list abar))) abar))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 10 3)))
|
||||
(print abar)
|
||||
(print (? b (apply #'+ (mapcar #'car (abar-list abar))) abar))
|
||||
@ -480,10 +421,10 @@
|
||||
(first cmbn-list)
|
||||
(ncmbn-bar (rest cmbn-list))))))
|
||||
#|
|
||||
(ncmbn-bar nil)
|
||||
(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 1 4 'c 5 'd) (cmbn 1 6 'e 7 'f))))
|
||||
(ncmbn-bar nil)
|
||||
(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 1 4 'c 5 'd) (cmbn 1 6 'e 7 'f))))
|
||||
|#
|
||||
|
||||
(DEFUN MRPH-VRTC-BAR-INTR (mrph)
|
||||
@ -502,12 +443,12 @@
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
#|
|
||||
(setf cc (build-chcm :cmpr #'f-cmpr :strt :cmbn))
|
||||
(setf m (build-mrph :sorc cc :trgt cc :degr 0 :intr
|
||||
(setf cc (build-chcm :cmpr #'f-cmpr :strt :cmbn))
|
||||
(setf m (build-mrph :sorc cc :trgt cc :degr 0 :intr
|
||||
#'(lambda (degr gnrt) (cmbn degr 2 gnrt 3 (1+ gnrt)))
|
||||
:strt :gnrt :orgn '(test)))
|
||||
(setf r (mrph-vrtc-bar-intr m))
|
||||
(funcall r 4 (abar 2 3 2 4))
|
||||
(setf r (mrph-vrtc-bar-intr m))
|
||||
(funcall r 4 (abar 2 3 2 4))
|
||||
|#
|
||||
|
||||
(DEFMETHOD VRTC-BAR ((mrph morphism))
|
||||
@ -523,10 +464,10 @@
|
||||
:orgn `(vrtc-bar ,mrph)))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf f (aw (soft-delta-infinity) (soft-delta-infinity)))
|
||||
(setf cf (vrtc-bar f))
|
||||
(? cf 6 (abar 3 (crpr 0 (d 7) 0 (d 7)) 3 (crpr 0 (d 56) 0 (d 56))))
|
||||
(cat-init)
|
||||
(setf f (aw (soft-delta-infinity) (soft-delta-infinity)))
|
||||
(setf cf (vrtc-bar f))
|
||||
(? 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)
|
||||
@ -589,12 +530,12 @@
|
||||
(rslt degr (abar-list abar))))))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf ez (ez (delta-infinity) (delta-infinity)))
|
||||
(setf h (h ez) gf (cmps (g ez) (f ez)))
|
||||
(setf r (hmtp-vrtc-bar-intr h gf))
|
||||
(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)))
|
||||
(cat-init)
|
||||
(setf ez (ez (delta-infinity) (delta-infinity)))
|
||||
(setf h (h ez) gf (cmps (g ez) (f ez)))
|
||||
(setf r (hmtp-vrtc-bar-intr h gf))
|
||||
(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)))
|
||||
|#
|
||||
|
||||
(DEFUN HMTP-VRTC-BAR (h gf)
|
||||
@ -627,8 +568,8 @@
|
||||
:orgn `(vrtc-bar ,rdct))))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf tcc (build-chcm
|
||||
(cat-init)
|
||||
(setf tcc (build-chcm
|
||||
:cmpr #'s-cmpr
|
||||
:basis #'(lambda (degr) '(a b c d))
|
||||
:bsgn 'd
|
||||
@ -639,7 +580,7 @@
|
||||
(c (cmbn (1- degr) 1 'd))))
|
||||
:strt :gnrt
|
||||
:orgn '(tcc)))
|
||||
(setf bcc (build-chcm
|
||||
(setf bcc (build-chcm
|
||||
:cmpr #'s-cmpr
|
||||
:basis #'(lambda (degr) '(c d))
|
||||
:bsgn 'd
|
||||
@ -649,48 +590,48 @@
|
||||
(c (cmbn (1- degr) 1 'd))))
|
||||
:strt :gnrt
|
||||
: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)
|
||||
(ecase gnrt
|
||||
(a (cmbn degr 1 'c 1 'd))
|
||||
(b (cmbn degr))
|
||||
((c d) (cmbn degr 1 gnrt))))
|
||||
: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)))
|
||||
(setf h (build-mrph :sorc tcc :trgt tcc :degr +1
|
||||
(setf h (build-mrph :sorc tcc :trgt tcc :degr +1
|
||||
:intr #'(lambda (degr gnrt)
|
||||
(ecase gnrt
|
||||
((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd))
|
||||
((c d) (cmbn (1+ degr)))))
|
||||
:strt :gnrt :orgn '(h)))
|
||||
(setf rdct (build-rdct :f f :g g :h h :orgn '(rdct)))
|
||||
(tcc rdct 3 'a)
|
||||
(g rdct (f rdct 3 'a))
|
||||
(h rdct 3 'a)
|
||||
(setf bar (vrtc-bar rdct))
|
||||
(pre-check-rdct bar)
|
||||
(defun aleat-tc ()
|
||||
(setf rdct (build-rdct :f f :g g :h h :orgn '(rdct)))
|
||||
(tcc rdct 3 'a)
|
||||
(g rdct (f rdct 3 'a))
|
||||
(h rdct 3 'a)
|
||||
(setf bar (vrtc-bar rdct))
|
||||
(pre-check-rdct bar)
|
||||
(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)))
|
||||
(rslt nil (cons (brgn degr gnrt) rslt)))
|
||||
((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-abar :list rslt))))))
|
||||
(aleat-tc)
|
||||
(defun aleat-bc ()
|
||||
(aleat-tc)
|
||||
(defun aleat-bc ()
|
||||
(do ((tdegr 0 (+ tdegr degr))
|
||||
(degr (+ 2 (random 3)) (+ 2 (random 3)))
|
||||
(gnrt (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)))
|
||||
((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-abar :list rslt))))))
|
||||
(aleat-bc)
|
||||
(defun c ()
|
||||
(aleat-bc)
|
||||
(defun c ()
|
||||
(aleat-tc)
|
||||
(aleat-bc)
|
||||
(check-rdct))
|
||||
(loop (c)) ;; degrees >= 15 is possible => error.
|
||||
(loop (c)) ;; degrees >= 15 is possible => error.
|
||||
|#
|
||||
|
||||
(DEFMETHOD VRTC-BAR ((hmeq homotopy-equivalence))
|
||||
@ -712,11 +653,11 @@
|
||||
(add (vrtc-bar hmeq) (bar-hrzn-dffr (lbcc hmeq))))))
|
||||
|
||||
#|
|
||||
(cat-init)
|
||||
(setf h (efhm (k-z-1)))
|
||||
(setf b (bar h))
|
||||
(inspect b)
|
||||
(homology (rbcc b) 0 11)
|
||||
(cat-init)
|
||||
(setf h (efhm (k-z-1)))
|
||||
(setf b (bar h))
|
||||
(inspect b)
|
||||
(homology (rbcc b) 0 11)
|
||||
|#
|
||||
|
||||
|
||||
|
||||
93
test/bar-test.lisp
Normal file
93
test/bar-test.lisp
Normal 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)))))
|
||||
|#
|
||||
Loading…
Reference in New Issue
Block a user