120 lines
4.7 KiB
Common Lisp
120 lines
4.7 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
|
|
|
|
(in-package :kenzo-test)
|
|
|
|
(in-suite :kenzo)
|
|
|
|
(test bicn-cmbn
|
|
(let* ((comb-bic (cat:cmbn 3 2 (cat:bcnb 'b1) 4 (cat:bcnb 'b2)
|
|
6 (cat:bcnb 'b3) 3 (cat:bcnc 'c1)
|
|
5 (cat:bcnc 'c2) 7 (cat:bcnd 'd1))))
|
|
(cat:cmbn-list comb-bic)
|
|
(cat:dispatch-bicn-cmbn (cat:cmbn 3 3 (cat:bcnb 'b1)
|
|
4 (cat:bcnb 'b2)
|
|
33 (cat:bcnc 'c)
|
|
333 (cat:bcnd 'd)))))
|
|
|
|
(test bicn-cmbn-cmbn*
|
|
(is (cat:cmbn-non-zero-p
|
|
(cat:bicn-cmbn-cmbnb (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)))))
|
|
(is (cat:cmbn-zero-p
|
|
(cat:bicn-cmbn-cmbnb (cat:cmbn 3 2 (cat:bcnc 'b)))))
|
|
(is (cat:cmbn-non-zero-p
|
|
(cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)
|
|
3 (cat:bcnd 'c)))))
|
|
(is (cat:cmbn-zero-p
|
|
(cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 3 (cat:bcnd 'c)))))
|
|
(is (cat:cmbn-non-zero-p
|
|
(cat:bicn-cmbn-cmbnd (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)
|
|
3 (cat:bcnd 'c)))))
|
|
(is (cat:cmbn-zero-p
|
|
(cat:bicn-cmbn-cmbnd (cat:cmbn 3 2 (cat:bcnb 'b))))))
|
|
|
|
(test make-bicn-cmbn
|
|
(multiple-value-call #'cat:make-bicn-cmbn
|
|
(cat:dispatch-bicn-cmbn
|
|
(cat:cmbn 3 3 (cat:bcnb 'b1) 4 (cat:bcnb 'b2) 33 (cat:bcnc 'c)
|
|
333 (cat:bcnd 'd)))))
|
|
|
|
(test bicn-print
|
|
(let ((a (format nil "~A" (cat:bcnb 'a)))
|
|
(b (format nil "~A" (cat:bcnc 'b)))
|
|
(c (format nil "~A" (cat:bcnd 'c))))
|
|
(is (string= a "<BcnB A>"))
|
|
(is (string= b "<BcnC B>"))
|
|
(is (string= c "<BcnD C>"))))
|
|
|
|
(test bicone-cmpr
|
|
(let ((r (cat:bicone-cmpr #'cat:f-cmpr #'cat:f-cmpr #'cat:f-cmpr)))
|
|
(is (equal :less (funcall r (cat:bcnb 1) (cat:bcnc 0))))
|
|
(is (equal :less (funcall r (cat:bcnb 1) (cat:bcnb 2))))))
|
|
|
|
(test bicone-basis
|
|
(is (equal :locally-effective
|
|
(cat:bicone-basis :locally-effective
|
|
:locally-effective
|
|
:locally-effective)))
|
|
(let* ((b #'(lambda (degr)
|
|
(mapcar #'(lambda (item)
|
|
(cons degr item)) (cat:<a-b> 0 degr))))
|
|
(r (cat:bicone-basis b b b)))
|
|
(is (not (null (funcall r 3))))))
|
|
|
|
|
|
(test bicone
|
|
(progn
|
|
(cat:cat-init)
|
|
(let ((delta3 (cdelta1 3))
|
|
(bic (cat:bicone (make-rdct1 3 2) (make-rdct1 4 2))))
|
|
#|
|
|
(princ (cat:basis delta3 0))
|
|
(princ (cat:basis delta3 1))
|
|
(princ (cat:basis delta3 2))
|
|
(princ (cat:basis delta3 3))
|
|
(princ (cat:basis delta3 4))
|
|
|#
|
|
(princ (cat:basis bic 0))
|
|
(princ (cat:basis bic 1))
|
|
(princ (cat:basis bic 4))
|
|
(princ (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3))
|
|
4 (cat:bcnc '(0 1 2 3))
|
|
5 (cat:bcnd '(0 1 4)))))
|
|
(is (cat:cmbn-zero-p
|
|
(cat:? bic
|
|
(cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3))
|
|
4 (cat:bcnc '(0 1 2 3))
|
|
5 (cat:bcnd '(0 1 4))))))))))
|
|
|
|
|
|
(test cmps
|
|
(progn
|
|
(cat:cat-init)
|
|
(let* ((c (cat:build-chcm
|
|
:cmpr #'cat:s-cmpr
|
|
:basis #'(lambda (dmns) '(a))
|
|
:bsgn 'a
|
|
:intr-dffr #'cat:zero-intr-dffr
|
|
:strt :cmbn
|
|
:orgn '(c)))
|
|
(h1 (cat:trivial-hmeq c))
|
|
(h2 (cat:cmps h1 h1))
|
|
(h3 (cat:cmps h2 h2)))
|
|
(cat:pre-check-rdct (cat:lrdct h2))
|
|
(setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB 'a) 10 (cat:bcnC 'a)
|
|
100 (cat:bcnD 'a)))
|
|
(setf cat:*bc* (cat:cmbn 3 1 'a))
|
|
(check-rdct)
|
|
(cat:pre-check-rdct (cat:rrdct h2))
|
|
(check-rdct)
|
|
(setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB (cat:bcnB 'a))
|
|
10 (cat:bcnB (cat:bcnC 'a))
|
|
100 (cat:bcnB (cat:bcnD 'a))
|
|
1000 (cat:bcnC 'a)
|
|
10000 (cat:bcnD (cat:bcnB 'a))
|
|
5234 (cat:bcnD (cat:bcnC 'a))
|
|
223 (cat:bcnD (cat:bcnD 'a))))
|
|
(cat:pre-check-rdct (cat:lrdct h3))
|
|
(check-rdct)
|
|
(cat:pre-check-rdct (cat:rrdct h3))
|
|
(check-rdct))))
|