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
|
||||
|
||||
137
src/bar.lisp
137
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))
|
||||
|
||||
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