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

Updated infrastructure.

Browse Source 
* Quicklisp
* DEFINE-CONSTANT macro
* First batch of files compiles w/ SBCL
* Simple regression tests for combinations
This commit is contained in:
gheber 2014-12-24 08:16:17 -06:00
parent 64e1beaa77
commit 8ea70b812d
13 changed files with 432 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
*.FASL
*.fasl
*.lisp-temp

16
README.md Normal file
View File

@ -0,0 +1,16 @@
# Welcome to Kenzo
*!!! UNDER CONSTRUCTION !!!*
This is a repackaged version of the Kenzo program by Francis Sergeraert
and Xavier Dousson. The original version of the program can be found
at http://www-fourier.ujf-grenoble.fr/~sergerar/Kenzo/ .
This version aims to update its infrastructure by providing the following:
1. Installation via the [Quicklisp](http://www.quicklisp.org/beta/) library
manager
2. A simple regression test suite based on
[FiveAM](http://common-lisp.net/project/fiveam/)
(Based on tests scattered throughout the source code in comments.)
3. Support for [SBCL](http://www.sbcl.org/)

8
kenzo-test.asd Normal file
View File

@ -0,0 +1,8 @@
(defsystem :kenzo-test
:description "Test suite for kenzo"
:serial t
:version "0.1"
:depends-on (:kenzo :fiveam)
:pathname #P"test/"
:components ((:file "combinations-test")))

22
kenzo.asd Normal file
View File

@ -0,0 +1,22 @@
;;;; kenzo.asd
(in-package :cl-user)
(defpackage :kenzo-asd
(:use :cl :asdf))
(in-package :kenzo-asd)
(asdf:defsystem #:kenzo
:description "A repackaged version of the Kenzo program by Francis Sergeraert and Xavier Dousson"
:serial t
:components ((:file "package")
(:file "kenzo")
(:module "src"
:components ((:file "macros")
(:file "various")
(:file "classes")
(:file "combinations")
(:file "chain-complexes")
(:file "chcm-elementary-op")))))

22
kenzo.lisp Normal file
View File

@ -0,0 +1,22 @@
;;;; kenzo.lisp
(IN-PACKAGE #:cat)
;;; "kenzo" goes here. Hacks and glory await!
(DEFUN KENZO-VERSION ()
(format t "~%*** Kenzo-Version 1.1.7 ***~2%")
(values))
;;(PROCLAIM '(OPTIMIZE (speed 3) (safety 1) (space 0) (debug 0)))
(DECLAIM '(OPTIMIZE (speed 0) (space 0) (debug 3)))
(DEFVAR *CMBN-CONTROL*)
(SETF *CMBN-CONTROL* T)
;; Don't mess with ANSI's definition of DEFCONSTANT!
(DEFMACRO DEFINE-CONSTANT (name value &optional doc)
`(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
,@(when doc (list doc))))

48
package.lisp Normal file
View File

@ -0,0 +1,48 @@
;;;; package.lisp
(defpackage #:cat
(:use #:cl)
(:export KENZO-VERSION
*CMBN-CONTROL*
;; chain-complexes.lisp
;; chcm-elementary-op.lisp
;; classes.lisp
CMBN-CMBN
CMBN-DEGR
CMBN-LIST
;; combinations.lisp
2CMBN-ADD
2CMBN-SBTR
2N-2CMBN
CMBN
CMBN-OPPS
DSTR-ADD-TERM-TO-CMBN
F-CMPR
L-CMPR
MAPLEXICO
N-CMBN
NCMBN-ADD
NTERM-ADD
S-CMPR
ZERO-CMBN
ZERO-INTR-DFFR
;; macros.lisp
CFFC
GNRT
CMBN-NON-ZERO-P
CMBN-ZERO-P
TERM
TERM-CMBN
;; various.lisp
))

2
src/chain-complexes.lisp
View File

@ -2,7 +2,7 @@
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES ;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES ;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
(IN-PACKAGE "COMMON-LISP-USER") (IN-PACKAGE #:cat)
(PROVIDE "chain-complexes") (PROVIDE "chain-complexes")

4
src/chcm-elementary-op.lisp
View File

@ -2,7 +2,7 @@
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP ;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP ;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
(IN-PACKAGE "COMMON-LISP-USER") (IN-PACKAGE #:cat)
(PROVIDE "chcm-elementary-op") (PROVIDE "chcm-elementary-op")
@ -460,4 +460,4 @@
(setf (slot-value new-chcm 'bsgn) bsgn) (setf (slot-value new-chcm 'bsgn) bsgn)
(slot-makunbound new-chcm 'bsgn)) (slot-makunbound new-chcm 'bsgn))
(setf (slot-value new-chcm 'grmd) (grmd chcm)) (setf (slot-value new-chcm 'grmd) (grmd chcm))
new-chcm)))))) new-chcm))))))

7
src/classes.lisp
View File

@ -2,7 +2,7 @@
;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES ;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES
;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES ;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES
(IN-PACKAGE "COMMON-LISP-USER") (IN-PACKAGE #:cat)
(PROVIDE "classes") (PROVIDE "classes")
@ -489,6 +489,8 @@
(setf excl:*enable-package-locked-errors* nil)) (setf excl:*enable-package-locked-errors* nil))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :common-lisp) nil)) (setf (ext:package-lock :common-lisp) nil))
#+sbcl(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:unlock-package :common-lisp))
(DEFSTRUCT (LOOP (:print-function loop-print)) (DEFSTRUCT (LOOP (:print-function loop-print))
(list #+allegro :type #+allegro iloop)) (list #+allegro :type #+allegro iloop))
@ -498,7 +500,8 @@
(setf excl:*enable-package-locked-errors* t)) (setf excl:*enable-package-locked-errors* t))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :common-lisp) t)) (setf (ext:package-lock :common-lisp) t))
#+sbcl(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:lock-package :common-lisp))
;;; ;;;

153
src/combinations.lisp
View File

@ -2,7 +2,7 @@
;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS ;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS
;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS ;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS
(IN-PACKAGE "COMMON-LISP-USER") (IN-PACKAGE #:cat)
(provide "combinations") (provide "combinations")
@ -50,14 +50,6 @@
(:less (return-from maplexico :less)) (:less (return-from maplexico :less))
(:greater (return-from maplexico :greater)))))) (:greater (return-from maplexico :greater))))))
#|
(maplexico #'f-cmpr '(1 2 3) '(1 3))
(maplexico #'f-cmpr '(1 2 3) '(1 1))
(maplexico #'f-cmpr '(1 1) '(1 1 0))
(maplexico #'f-cmpr '(1 1 0) '(1 1))
(maplexico #'f-cmpr '(1 1) '(1 1))
(maplexico #'f-cmpr nil nil)
|#
(DEFUN S-CMPR (symbol1 symbol2) (DEFUN S-CMPR (symbol1 symbol2)
(declare (symbol symbol1 symbol2)) (declare (symbol symbol1 symbol2))
@ -97,24 +89,6 @@
(f-cmpr (first list1) (first list2)) (f-cmpr (first list1) (first list2))
(l-cmpr (rest list1) (rest list2)))))) (l-cmpr (rest list1) (rest list2))))))
#|
(s-cmpr 'a 'b)
(s-cmpr 'b 'b)
(s-cmpr 'c 'b)
(f-cmpr 1 2)
(f-cmpr 2 2)
(f-cmpr 3 2)
(l-cmpr nil nil)
(l-cmpr nil '(1))
(l-cmpr '(1) nil)
(l-cmpr '(a) '(a))
(l-cmpr '(a) '(1))
(l-cmpr '(1) '(a))
(l-cmpr '(1) '(1))
(l-cmpr '(1 a) '(1 1))
(l-cmpr '(1 a) '(1 a b)))
|#
;;;; ;;;;
;;;; COMBINATIONS ;;;; COMBINATIONS
@ -143,14 +117,6 @@
(declare (list rslt mark)))))) (declare (list rslt mark))))))
#|
(cmbn 2)
(cmbn 2 2 'a)
(cmbn 2 'a)
(cmbn 2 2 'a -3 'b))
(term-cmbn 3 -5 'a)
|#
#+allegro #+allegro
(setf *print-pretty* nil) (setf *print-pretty* nil)
@ -181,27 +147,15 @@
:degr degr :degr degr
:list +empty-list+))) :list +empty-list+)))
#|
(zero-cmbn 3))
|#
(DEFUN ZERO-INTR-DFFR (cmbn) (DEFUN ZERO-INTR-DFFR (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (zero-cmbn (1- (cmbn-degr cmbn))))) (the cmbn (zero-cmbn (1- (cmbn-degr cmbn)))))
#|
(zero-intr-dffr (cmbn 2))
|#
(DEFCONSTANT +ZERO-NEGATIVE-CMBN+ (DEFINE-CONSTANT +ZERO-NEGATIVE-CMBN+
(make-cmbn :degr -1 :list +empty-list+)) (make-cmbn :degr -1 :list +empty-list+))
#|
(cmbn-non-zero-p (cmbn 0))
(cmbn-non-zero-p (cmbn 0 1 'a)))
(cmbn-zero-p (cmbn 0))
(cmbn-zero-p (cmbn 0 1 'a)))
|#
(DEFUN CMBN-OPPS (cmbn) (DEFUN CMBN-OPPS (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
@ -215,11 +169,6 @@
(term (- cffc) gnrt))) (term (- cffc) gnrt)))
list))))) list)))))
#|
(setf c (cmbn 0 1 'a -2 'b))
(cmbn-opps c)
(symbol-value 'c))
|#
(DEFUN N-CMBN (n cmbn) (DEFUN N-CMBN (n cmbn)
;; n is assumed non-zero ;; n is assumed non-zero
@ -238,13 +187,6 @@
(term (* n cffc) gnrt))) (term (* n cffc) gnrt)))
list)))))) list))))))
#|
(setf c (cmbn 2 3 'a))
(setf c2 (n-cmbn 1 c))
(eq c c2)
(n-cmbn -1 c)
(n-cmbn -3 c))
|#
(DEFUN 2CMBN-ADD (cmpr cmbn1 cmbn2) (DEFUN 2CMBN-ADD (cmpr cmbn1 cmbn2)
(declare (declare
@ -305,17 +247,6 @@
:exit)) :exit))
(make-cmbn :degr degr1 :list pre-rslt))))))) (make-cmbn :degr degr1 :list pre-rslt)))))))
#|
(2cmbn-add #'s-cmpr (cmbn 0) (cmbn 1))
(2cmbn-add #'s-cmpr (cmbn 0) (cmbn 0))
(2cmbn-add #'s-cmpr (cmbn 0 1 'a) (cmbn 0))
(2cmbn-add #'s-cmpr (cmbn 0 1 'a) (cmbn 0 2 'a))
(2cmbn-add #'s-cmpr (cmbn 0 1 'a) (cmbn 0 -1 'a))
(2cmbn-add #'s-cmpr (cmbn 0 1 'a) (cmbn 0 2 'b))
(2cmbn-add #'s-cmpr (cmbn 0 2 'b) (cmbn 0 1 'a))
(2cmbn-add #'s-cmpr (cmbn 0 1 'a -2 'b) (cmbn 0 2 'b))
(2cmbn-add #'s-cmpr (cmbn 0 2 'b) (cmbn 0 1 'a 3 'c)))
|#
(DEFUN 2CMBN-SBTR (cmpr cmbn1 cmbn2) (DEFUN 2CMBN-SBTR (cmpr cmbn1 cmbn2)
(declare (declare
@ -385,29 +316,6 @@
:degr degr1 :degr degr1
:list pre-rslt))))))) :list pre-rslt)))))))
#|
(2cmbn-sbtr #'s-cmpr (cmbn 0) (cmbn 1))
(2cmbn-sbtr #'s-cmpr (cmbn 0) (cmbn 0))
(2cmbn-sbtr #'s-cmpr (cmbn 0) (cmbn 0 1 'a))
(2cmbn-sbtr #'s-cmpr (cmbn 0 2 'b) (cmbn 0))
(2cmbn-sbtr #'s-cmpr (cmbn 0 3 'b) (cmbn 0 3 'b))
(2cmbn-sbtr #'s-cmpr (cmbn 0 3 'b) (cmbn 0 4 'b))
(2cmbn-sbtr #'s-cmpr
(cmbn 0 1 'a 2 'c 2 'd 3 'g)
(cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h))
(2cmbn-sbtr #'s-cmpr
(cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h)
(cmbn 0 1 'a 2 'c 2 'd 3 'g))
(2cmbn-sbtr #'s-cmpr
(cmbn 0 1 'c -2 'd 4 'f -3 'g)
(cmbn 0 1 'a 2 'c 2 'd 3 'g))
(2cmbn-sbtr #'s-cmpr
(cmbn 0 1 'b 2 'a)
(cmbn 0 1 'a 1 'b))) ;;; !!!
(2cmbn-sbtr #'s-cmpr
(cmbn 0 1 'b 2 'c)
(cmbn 0 1 'a 1 'b)))
|#
(DEFUN 2N-2CMBN (cmpr n1 cmbn1 n2 cmbn2) (DEFUN 2N-2CMBN (cmpr n1 cmbn1 n2 cmbn2)
;; n1 * cmbn1 + n2 * cmbn2 ;; n1 * cmbn1 + n2 * cmbn2
@ -491,21 +399,6 @@
:degr degr1 :degr degr1
:list pre-rslt))))))) :list pre-rslt)))))))
#|
(2n-2cmbn #'s-cmpr 3 (cmbn 0) 4 (cmbn 1))
(2n-2cmbn #'s-cmpr 3 (cmbn 0) 4 (cmbn 0))
(2n-2cmbn #'s-cmpr 3 (cmbn 0 1 'a) 4 (cmbn 0))
(2n-2cmbn #'s-cmpr 3 (cmbn 0 1 'a 2 'b 3 'c )
1 (cmbn 0 -3 'a 2 'b 4 'd))
(2n-2cmbn #'s-cmpr 3 (cmbn 0 -3 'a 2 'b 4 'd)
1 (cmbn 0 1 'a 2 'b 3 'c ))
(2n-2cmbn #'s-cmpr 1 (cmbn 0 1 'a 2 'b 3 'c )
1 (cmbn 0 -3 'a 2 'b 4 'd))
(2n-2cmbn #'s-cmpr 1 (cmbn 0 -3 'a 2 'b 4 'd)
1 (cmbn 0 1 'a 2 'b 3 'c ))
(2n-2cmbn #'s-cmpr 1 (cmbn 0 -3 'a 2 'b 4 'd)
3 (cmbn 0 1 'a 2 'b 3 'c )))
|#
(DEFUN CMBN-CMBN (cmpr n-cmbn-list) (DEFUN CMBN-CMBN (cmpr n-cmbn-list)
;; n-cmbn-list = list of (cons n cmbn) ;; n-cmbn-list = list of (cons n cmbn)
@ -553,14 +446,6 @@
(push (2cmbn-add cmpr (car mark2) (car mark1)) (push (2cmbn-add cmpr (car mark2) (car mark1))
new-rslt))))))) new-rslt)))))))
#|
(setf cons (cons 3 (cmbn 0 4 'a)))
(cmbn-cmbn #'s-cmpr (make-list 5 :initial-element cons))
(dotimes (i 10)
(print
(cffc (first (cmbn-list
(cmbn-cmbn #'s-cmpr (make-list (1+ i) :initial-element cons))))))))
|#
(DEFUN NTERM-ADD (cmpr degr &rest rest) (DEFUN NTERM-ADD (cmpr degr &rest rest)
(declare (declare
@ -593,14 +478,6 @@
:degr degr :degr degr
:list (delete 0 rslt :key #'car))))) :list (delete 0 rslt :key #'car)))))
#|
(nterm-add #'s-cmpr 11)
(nterm-add #'s-cmpr 11 (term 1 'a))
(nterm-add #'s-cmpr 11 (term 1 'a) (term 2 'b))
(nterm-add #'s-cmpr 11 (term 1 'b) (term 2 'a) (term 3 'aa)
(term -2 'aa) (term -2 'a) (term 4 'aab)
(term 5 'c))
|#
(DEFUN NCMBN-ADD (cmpr cmbn &rest rest) (DEFUN NCMBN-ADD (cmpr cmbn &rest rest)
(declare (declare
@ -612,10 +489,6 @@
(cons 1 cmbn)) (cons 1 cmbn))
(cons cmbn rest))))) (cons cmbn rest)))))
#|
(setf c (cmbn 3 4 'a))
(ncmbn-add #'s-cmpr c c c c c)
|#
(DEFUN DSTR-ADD-TERM-TO-CMBN (cmpr cffc gnrt cmbn) (DEFUN DSTR-ADD-TERM-TO-CMBN (cmpr cffc gnrt cmbn)
(declare (declare
@ -650,25 +523,3 @@
(return))) (return)))
(:greater))) (:greater)))
cmbn))) cmbn)))
#|
()
(setf c (zero-cmbn 10))
(dstr-add-term-to-cmbn #'s-cmpr 3 'f c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr 3 'g c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr 3 'a c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr 3 'd c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr -3 'd c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr -2 'a c)
(dstr-add-term-to-cmbn #'s-cmpr -1 'a c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr -3 'g c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr -3 'f c)
(eq * c))
|#

2
src/macros.lisp
View File

@ -2,7 +2,7 @@
;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS ;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS
;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS ;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS
(IN-PACKAGE "COMMON-LISP-USER") (IN-PACKAGE #:cat)
(PROVIDE "macros") (PROVIDE "macros")

16
src/various.lisp
View File

@ -2,30 +2,30 @@
;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS ;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS
;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS ;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS
(IN-PACKAGE "COMMON-LISP-USER") (IN-PACKAGE #:cat)
(PROVIDE "various") (PROVIDE "various")
(DEFCONSTANT +EMPTY-LIST+ '()) (DEFINE-CONSTANT +EMPTY-LIST+ '())
(DEFCONSTANT +F-EMPTY-VECTOR+ (DEFINE-CONSTANT +F-EMPTY-VECTOR+
(make-array 0 :element-type 'fixnum)) (make-array 0 :element-type 'fixnum))
(DEFCONSTANT +S-EMPTY-VECTOR+ (DEFINE-CONSTANT +S-EMPTY-VECTOR+
#()) #())
(DEFCONSTANT +TRUE+ t) (DEFINE-CONSTANT +TRUE+ t)
(DEFCONSTANT +FALSE+ nil) (DEFINE-CONSTANT +FALSE+ nil)
(DEFCONSTANT +2-EXP+ (DEFINE-CONSTANT +2-EXP+
(let ((rslt (make-array (integer-length most-positive-fixnum) (let ((rslt (make-array (integer-length most-positive-fixnum)
:element-type 'fixnum))) :element-type 'fixnum)))
(declare (type (array fixnum 1) rslt)) (declare (type (array fixnum 1) rslt))
(dotimes (i (integer-length most-positive-fixnum) rslt) (dotimes (i (integer-length most-positive-fixnum) rslt)
(setf (aref rslt i) (the fixnum (expt 2 i)))))) (setf (aref rslt i) (the fixnum (expt 2 i))))))
(DEFCONSTANT +MASK+ (DEFINE-CONSTANT +MASK+
(let ((rslt (make-array (integer-length most-positive-fixnum) (let ((rslt (make-array (integer-length most-positive-fixnum)
:element-type 'fixnum))) :element-type 'fixnum)))
(declare (type (array fixnum 1) rslt)) (declare (type (array fixnum 1) rslt))

294
test/combinations-test.lisp Normal file
View File

@ -0,0 +1,294 @@
(defpackage :kenzo-test
(:use :cl :fiveam))
(in-package :kenzo-test)
(def-suite :kenzo)
(in-suite :kenzo)
(test f-cmpr
(is (equal (cat:f-cmpr 1 2) :less))
(is (equal (cat:f-cmpr 2 2) :equal))
(is (equal (cat:f-cmpr 3 2) :greater))
(is (equal (cat:maplexico #'cat:f-cmpr '(1 2 3) '(1 3)) :less))
(is (equal (cat:maplexico #'cat:f-cmpr '(1 2 3) '(1 1)) :greater))
(is (equal (cat:maplexico #'cat:f-cmpr '(1 1) '(1 1 0)) :less))
(is (equal (cat:maplexico #'cat:f-cmpr '(1 1 0) '(1 1)) :greater))
(is (equal (cat:maplexico #'cat:f-cmpr '(1 1) '(1 1)) :equal))
(is (equal (cat:maplexico #'cat:f-cmpr nil nil) :equal)))
(test l-cmpr
(is (equal (cat:l-cmpr nil nil) :equal))
(is (equal (cat:l-cmpr nil '(1)) :less))
(is (equal (cat:l-cmpr '(1) nil) :greater))
(is (equal (cat:l-cmpr '(a) '(a)) :equal))
(is (equal (cat:l-cmpr '(a) '(1)) :greater))
(is (equal (cat:l-cmpr '(1) '(a)) :less))
(is (equal (cat:l-cmpr '(1) '(1)) :equal))
(is (equal (cat:l-cmpr '(1 a) '(1 1)) :greater))
(is (equal (cat:l-cmpr '(1 a) '(1 a b)) :less)))
(test s-cmpr
(is (equal (cat:s-cmpr 'a 'b) :less))
(is (equal (cat:s-cmpr 'b 'b) :equal))
(is (equal (cat:s-cmpr 'c 'b) :greater)))
(test cmbn
(let ((comb (cat:cmbn 2)))
(is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) nil)))
(let ((comb (cat:cmbn 2 2 'a)))
(is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) '((2 . a)))))
(let ((comb (cat:cmbn 2 'a)))
(is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) '((a)))))
(let ((comb (cat:cmbn 2 2 'a -3 'b)))
(is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) '((2 . a) (-3 . b)))))
(let ((comb (cat:term-cmbn 3 -5 'a)))
(is (equal (cat:cmbn-degr comb) 3))
(is (equal (cat:cmbn-list comb) '((-5 . a))))))
(test zero-cmbn
(let ((comb (cat:zero-cmbn 3)))
(is (equal (cat:cmbn-degr comb) 3))
(is (equal (cat:cmbn-list comb) nil)))
(let ((comb (cat:zero-intr-dffr (cat:cmbn 2))))
(is (equal (cat:cmbn-degr comb) 1))
(is (equal (cat:cmbn-list comb) nil)))
(is (null (cat:cmbn-non-zero-p (cat:cmbn 0))))
(is (equal (cat:cmbn-non-zero-p (cat:cmbn 0 1 'a)) '((1 . a))))
(is (cat:cmbn-zero-p (cat:cmbn 0)))
(is (null (cat:cmbn-zero-p (cat:cmbn 0 1 'a)))))
(test cmbn-opps
(let* ((comb (cat:cmbn 0 1 'a -2 'b))
(comb1 (cat:cmbn-opps comb)))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a) (-2 . b))))
(is (equal (cat:cmbn-degr comb1) 0))
(is (equal (cat:cmbn-list comb1) '((-1 . a) (2 . b))))))
(test n-cmbn
(let* ((comb (cat:cmbn 2 3 'a))
(comb1 (cat:n-cmbn 1 comb))
(comb2 (cat:n-cmbn -1 comb))
(comb3 (cat:n-cmbn -3 comb)))
(is (eq comb comb1))
(is (equal (cat:cmbn-degr comb2) 2))
(is (equal (cat:cmbn-list comb2) '((-3 . a))))
(is (equal (cat:cmbn-degr comb3) 2))
(is (equal (cat:cmbn-list comb3) '((-9 . a))))))
(test 2cmbn-add
(signals simple-error (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 1)))
(is (cat:cmbn-zero-p (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 0))))
(let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a)))))
(let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 2 'a))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((3 . a)))))
(let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 -1 'a))))
(is (cat:cmbn-zero-p comb)))
(let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 2 'b))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a) (2 . b)))))
(let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a -2 'b)
(cat:cmbn 0 2 'b))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a)))))
(let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 2 'b)
(cat:cmbn 0 1 'a 3 'c))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a) (2 . b) (3 . c))))))
(test 2cmbn-sbtr
(signals simple-error (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 1)))
(is (cat:cmbn-zero-p (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 0))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 0 1 'a))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . a)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 2 'b) (cat:cmbn 0))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((2 . b)))))
(is (cat:cmbn-zero-p (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 3 'b)
(cat:cmbn 0 3 'b))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 3 'b) (cat:cmbn 0 4 'b))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . b)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr
(cat:cmbn 0 1 'a 2 'c 2 'd 3 'g)
(cat:cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a) (1 . c) (4 . d) (-4 . f) (6 . g)
(-4 . h)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr
(cat:cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h)
(cat:cmbn 0 1 'a 2 'c 2 'd 3 'g))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . a) (-1 . c) (-4 . d) (4 . f)
(-6 . g) (4 . h)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr
(cat:cmbn 0 1 'c -2 'd 4 'f -3 'g)
(cat:cmbn 0 1 'a 2 'c 2 'd 3 'g))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . a) (-1 . c) (-4 . d) (4 . f)
(-6 . g)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 1 'b 2 'a)
(cat:cmbn 0 1 'a 1 'b))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . a) (2 . a)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 1 'b 2 'c)
(cat:cmbn 0 1 'a 1 'b))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . a) (2 . c))))))
(test 2n-2cmbn
(signals simple-error (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0)
4 (cat:cmbn 1)))
(is (cat:cmbn-zero-p (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0)
4 (cat:cmbn 0))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0 1 'a) 4 (cat:cmbn 0))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((3 . a)))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr
3 (cat:cmbn 0 1 'a 2 'b 3 'c)
1 (cat:cmbn 0 -3 'a 2 'b 4 'd))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((8 . b) (9 . c) (4 . d)))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr
3 (cat:cmbn 0 -3 'a 2 'b 4 'd)
1 (cat:cmbn 0 1 'a 2 'b 3 'c))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-8 . a) (8 . b) (3 . c) (12 . d)))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr
1 (cat:cmbn 0 1 'a 2 'b 3 'c)
1 (cat:cmbn 0 -3 'a 2 'b 4 'd))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-2 . a) (4 . b) (3 . c) (4 . d)))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr
1 (cat:cmbn 0 -3 'a 2 'b 4 'd)
1 (cat:cmbn 0 1 'a 2 'b 3 'c))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-2 . a) (4 . b) (3 . c) (4 . d)))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr
1 (cat:cmbn 0 -3 'a 2 'b 4 'd)
3 (cat:cmbn 0 1 'a 2 'b 3 'c))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((8 . b) (9 . c) (4 . d))))))
(test cmbn-cmbn
(let* ((cons (cons 3 (cat:cmbn 0 4 'a)))
(comb (cat:cmbn-cmbn #'cat:s-cmpr
(make-list 5 :initial-element cons))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((60 . a)))))
(let* ((cffc '(12 24 36 48 60 72 84 96 108 120))
(cons (cons 3 (cat:cmbn 0 4 'a))))
(dotimes (i 10)
(is (equal (nth i cffc)
(cat:cffc (first (cat:cmbn-list
(cat:cmbn-cmbn #'cat:s-cmpr
(make-list (1+ i)
:initial-element
cons))))))))))
(test nterm-add
(let ((comb (cat:nterm-add #'cat:s-cmpr 11)))
(is (equal (cat:cmbn-degr comb) 11))
(is (equal (cat:cmbn-list comb) nil)))
(let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'a))))
(is (equal (cat:cmbn-degr comb) 11))
(is (equal (cat:cmbn-list comb) '((1 . a)))))
(let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'a)
(cat:term 2 'b))))
(is (equal (cat:cmbn-degr comb) 11))
(is (equal (cat:cmbn-list comb) '((1 . a) (2 . b)))))
(let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'b)
(cat:term 2 'a) (cat:term 3 'aa)
(cat:term -2 'aa) (cat:term -2 'a)
(cat:term 4 'aa) (cat:term 5 'c))))
(is (equal (cat:cmbn-degr comb) 11))
(is (equal (cat:cmbn-list comb) '((5 . aa) (1 . b) (5 . c))))))
(test ncmbn-add
(let* ((c (cat:cmbn 3 4 'a))
(comb (cat:ncmbn-add #'cat:s-cmpr c c c c c)))
(is (equal (cat:cmbn-degr comb) 3))
(is (equal (cat:cmbn-list comb) '((20 . a))))))
(test dstr-add-term-to-cmbn
(let* ((c (cat:zero-cmbn 10))
(comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'f c)))
(is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . f))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'g c))
(is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . f) (3 . g))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'a c))
(is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . a) (3 . f) (3 . g))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'd c))
(is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . a) (3 . d) (3 . f) (3 . g))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'd c))
(is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . a) (3 . f) (3 . g))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -2 'a c))
(is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((1 . a) (3 . f) (3 . g))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -1 'a c))
(is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . f) (3 . g))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'g c))
(is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . f))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'f c))
(is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) nil))))