152 lines
5.5 KiB
Common Lisp
152 lines
5.5 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
|
|
|
|
(in-package :kenzo-test)
|
|
|
|
(in-suite :kenzo)
|
|
|
|
|
|
(test tnpr
|
|
(cat:tnpr 2 'a 3 'b)
|
|
(setf cat:*tnpr-with-degrees* t)
|
|
(cat:tnpr 2 'a 3 'b)
|
|
(setf cat:*tnpr-with-degrees* nil))
|
|
|
|
|
|
(test 2cmbn-tnpr
|
|
(setf cat:*tnpr-with-degrees* t)
|
|
(cat:2cmbn-tnpr (cat:cmbn 2 3 'a 4 'b -5 'c)
|
|
(cat:cmbn 3 4 'x -3 'y 2 'z)))
|
|
|
|
|
|
(test tnsr-prdc-cmpr
|
|
(let ((cmpr (cat:tnsr-prdc-cmpr #'cat:s-cmpr #'cat:s-cmpr)))
|
|
(is (equal :less (funcall cmpr
|
|
(cat:tnpr 2 'a 3 'b)
|
|
(cat:tnpr 3 'a 2 'b))))
|
|
(is (equal :greater (funcall cmpr
|
|
(cat:tnpr 3 'a 2 'b)
|
|
(cat:tnpr 2 'a 3 'b))))
|
|
(is (equal :less (funcall cmpr
|
|
(cat:tnpr 2 'a 3 'b)
|
|
(cat:tnpr 2 'b 3 'b))))
|
|
(is (equal :greater (funcall cmpr
|
|
(cat:tnpr 2 'b 3 'b)
|
|
(cat:tnpr 2 'a 3 'b))))
|
|
(is (equal :less (funcall cmpr
|
|
(cat:tnpr 2 'a 3 'a)
|
|
(cat:tnpr 2 'a 3 'b))))
|
|
(is (equal :greater (funcall cmpr
|
|
(cat:tnpr 2 'a 3 'c)
|
|
(cat:tnpr 2 'a 3 'b))))
|
|
(is (equal :equal (funcall cmpr
|
|
(cat:tnpr 2 'a 3 'b)
|
|
(cat:tnpr 2 'a 3 'b))))))
|
|
|
|
|
|
(defun bas (degr)
|
|
(case degr
|
|
(0 '(a b c))
|
|
(1 '(d))
|
|
(2 nil)
|
|
(3 '(x y))))
|
|
|
|
|
|
(test tnsr-prdc-basis
|
|
(let ((bas (cat:tnsr-prdc-basis #'bas #'bas)))
|
|
(dotimes (i 8)
|
|
(print (funcall bas i)))))
|
|
|
|
|
|
(test tnsr-prdc-intr-dffr
|
|
(cat:cat-init)
|
|
(let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr
|
|
:basis :locally-effective
|
|
:intr-dffr #'cat:zero-mrph
|
|
:strt :gnrt :orgn '(test-1)))
|
|
(dffr (cat:build-mrph
|
|
:sorc chcm :trgt chcm :degr -1
|
|
:intr #'(lambda (degr gnrt)
|
|
(ecase gnrt
|
|
(a (cat:cmbn (1- degr) 2 'd1a -3 'd2a))
|
|
(b (cat:cmbn (1- degr) 3 'd1b -4 'd2b))))
|
|
:strt :gnrt :orgn '(test-2)))
|
|
(rslt (cat:tnsr-prdc-intr-dffr dffr dffr)))
|
|
(funcall rslt 4 (cat:tnpr 2 'a 2 'b))
|
|
(funcall rslt 5 (cat:tnpr 3 'a 2 'b))
|
|
(funcall rslt 5 (cat:tnpr 2 'a 3 'b))
|
|
(funcall rslt 6 (cat:tnpr 3 'a 3 'b))))
|
|
|
|
|
|
(test tnsr-prdc
|
|
(let ((dd (cat:tnsr-prdc (cat:delta 2) (cat:delta 3))))
|
|
(cat:cmpr dd (cat:tnpr 2 7 2 11) (cat:tnpr 2 7 2 14))
|
|
(cat:basis dd 3)
|
|
(cat:? dd 4 (cat:tnpr 2 7 2 14))
|
|
(cat:? dd 3 (cat:tnpr 1 6 2 14))
|
|
(cat:? dd (cat:? dd 4 (cat:tnpr 2 7 2 14)))
|
|
(cat:? dd (cat:? dd 3 (cat:tnpr 1 6 2 14)))))
|
|
|
|
|
|
(test tnsr-prdc-intr
|
|
(cat:cat-init)
|
|
(let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr
|
|
:basis :locally-effective
|
|
:intr-dffr #'cat:zero-mrph
|
|
:strt :gnrt
|
|
:orgn '(test-1)))
|
|
|
|
(mrph (cat:build-mrph
|
|
:sorc chcm :trgt chcm :degr 0
|
|
:intr #'(lambda (degr gnrt)
|
|
(ecase gnrt
|
|
(a (cat:cmbn degr 2 'd1a -3 'd2a))
|
|
(b (cat:cmbn degr 3 'd1b -4 'd2b))))
|
|
:strt :gnrt :orgn '(test-2)))
|
|
(rslt (cat:tnsr-prdc-intr mrph mrph)))
|
|
(funcall rslt 6 (cat:tnpr 2 'a 4 'b))
|
|
(funcall rslt 5 (cat:tnpr 3 'a 2 'b))
|
|
(setf mrph (cat:build-mrph
|
|
:sorc chcm :trgt chcm :degr 1
|
|
:intr #'(lambda (degr gnrt)
|
|
(ecase gnrt
|
|
(a (cat:cmbn (1+ degr) 2 'd1a -3 'd2a))
|
|
(b (cat:cmbn (1+ degr) 3 'd1b -4 'd2b))))
|
|
:strt :gnrt :orgn '(test-3)))
|
|
(setf rslt (cat:tnsr-prdc-intr mrph mrph))
|
|
(funcall rslt 6 (cat:tnpr 2 'a 4 'b))
|
|
(funcall rslt 5 (cat:tnpr 3 'a 2 'b))))
|
|
|
|
|
|
(test tnsr-prdc
|
|
(cat:cat-init)
|
|
(let* ((d (cat:dffr (cat:delta-infinity)))
|
|
(dd (cat:tnsr-prdc d d))
|
|
(ddd (cat:cmps dd dd)))
|
|
(is (eq (cat:sorc dd) (cat:tnsr-prdc (cat:delta-infinity)
|
|
(cat:delta-infinity))))
|
|
(cat:? dd 5 (cat:tnpr 2 7 3 15))
|
|
(cat:? dd 5 (cat:tnpr 3 15 2 7))
|
|
(cat:? dd (cat:? dd 5 (cat:tnpr 2 7 3 15)))
|
|
(cat:? dd (cat:? dd 5 (cat:tnpr 3 15 2 7)))
|
|
(cat:? ddd 5 (cat:tnpr 2 7 3 15))
|
|
(cat:? ddd 5 (cat:tnpr 3 15 2 7))))
|
|
|
|
|
|
(test tnsr-prdc1
|
|
(cat:cat-init)
|
|
(let* ((r (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
|
|
(r2 (cat:tnsr-prdc r r)))
|
|
(setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:tnpr 1 3 1 3) 2
|
|
(cat:tnpr 1 3 1 3)))
|
|
cat:*tc* (cat:cmbn 2 1 (cat:tnpr 1 (cat:crpr 0 3 0 3) 1
|
|
(cat:crpr 0 3 0 3))))
|
|
(cat:pre-check-rdct r2)
|
|
(check-rdct)))
|
|
|
|
|
|
(test tnsr-prdc2
|
|
(cat:cat-init)
|
|
(let* ((k (cat:k-z 2))
|
|
(k2 (cat:tnsr-prdc k k)))
|
|
(cat:homology k2 0 10)))
|