From 8043c1edfdf32a8cf5915b86ccd7b42feb7898d8 Mon Sep 17 00:00:00 2001
From: gheber <leberecht@beingandti.me>
Date: Wed, 31 Dec 2014 17:03:16 -0600
Subject: [PATCH] Added CCN test from Kenzo handbook.

---
 kenzo-test.asd |  3 +-
 package.lisp   |  4 +++
 test/ccn.lisp  | 92 ++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 98 insertions(+), 1 deletion(-)
 create mode 100644 test/ccn.lisp

diff --git a/kenzo-test.asd b/kenzo-test.asd
index d4bb497..c53521b 100644
--- a/kenzo-test.asd
+++ b/kenzo-test.asd
@@ -11,4 +11,5 @@
 	       (:file "chain-complexes-test")
 	       (:file "chcm-elementary-op-test")
 	       (:file "diabolo")
-	       (:file "circle")))
+	       (:file "circle")
+               (:file "ccn")))
diff --git a/package.lisp b/package.lisp
index eb7a166..a47169b 100644
--- a/package.lisp
+++ b/package.lisp
@@ -31,9 +31,12 @@
 	   CHAIN-COMPLEX
 	   CMBN-CMBN
 	   CMBN-DEGR
+	   DEGR
+	   DFFR1
 	   CMBN-LIST
 	   MAKE-CMBN
 	   MAKE-RESULT
+	   MORPHISM
 
 	   ;; combinations.lisp
 
@@ -63,6 +66,7 @@
 
 	   ;; macros.lisp
 
+	   ?
 	   BASIS
 	   BINOMIAL-P-Q
 	   CFFC
diff --git a/test/ccn.lisp b/test/ccn.lisp
new file mode 100644
index 0000000..1045f81
--- /dev/null
+++ b/test/ccn.lisp
@@ -0,0 +1,92 @@
+
+(in-package :kenzo-test)
+
+(in-suite :kenzo)
+
+(defun ccn ()
+  (the cat:chain-complex
+       (cat:build-chcm
+	:cmpr #'cat:f-cmpr
+	:basis #'(lambda (n)
+		   (cat:<a-b< (* 10 n) (* 10 (1+ n))))
+	:bsgn 0
+	:intr-dffr #'(lambda (dgr gnr)
+		       (if (evenp (+ dgr gnr))
+			   (cat:cmbn (1- dgr) 1 (- gnr 10))
+			   (cat:cmbn (1- dgr))))
+	:strt :gnrt
+	:orgn '(ccn))))
+
+
+(test ccn
+      (progn
+	(cat:cat-init)
+	(let* ((ccn (ccn))
+	       (upper-shift (cat:build-mrph
+			     :sorc ccn :trgt ccn :strt :gnrt :degr 1
+			     :intr #'(lambda (d gn) (cat:cmbn (1+ d)
+							      1 (+ gn 10)))
+			     :orgn '(ccn shift +10)))
+	       (lower-shift (cat:build-mrph
+			     :sorc ccn :trgt ccn :strt :gnrt :degr -1
+			     :intr #'(lambda (d gn) (cat:cmbn (1- d)
+							      1 (- gn 10)))
+			     :orgn '(ccn shift -10)))
+	       (comb1 (cat:? ccn 2 22))
+	       (combn (cat:cmbn 5 1 50 5 55 9 59))
+	       (d-combn (cat:? ccn combn))
+	       (dd-combn (cat:? ccn d-combn))
+	       (comb2 (cat:? upper-shift 0 6))
+	       (comb3 (cat:? lower-shift 5 51))
+	       (comb4 (cat:? lower-shift comb3))
+	       (identity? (cat:cmps upper-shift lower-shift))
+	       (comb5 (cat:cmbn 1 1 10 2 11 3 12 4 13))
+	       (comb6 (cat:? identity? comb5))
+	       (comb7 (cat:2cmbn-sbtr (cat:cmpr ccn) comb5 comb6))
+	       (upper2-shift (cat:cmps upper-shift upper-shift))
+	       (comb8 (cat:? upper2-shift comb5))
+	       (twice-up-shift (cat:add upper-shift upper-shift))
+	       (comb9 (cat:? twice-up-shift comb5))
+	       (up-d (cat:cmps upper-shift (cat:dffr1 ccn)))
+	       (d-up (cat:cmps (cat:dffr1 ccn) upper-shift))
+	       (comb10 (cat:? up-d 1 11))
+	       (comb11 (cat:? d-up 1 11))
+	       (comb12 (cat:cmbn 1 1 10 2 11 3 12 4 13 5 14 6 15))
+	       (comb13 (cat:? up-d comb12))
+	       (comb14 (cat:? d-up comb12))
+	       )
+	  (is (equal (cat:cmbn-degr comb1) 1))
+	  (is (equal (cat:cmbn-list comb1) '((1 . 12))))
+	  (is (null (cat:cmbn-non-zero-p (cat:? ccn comb1))))
+	  (is (equal (cat:cmbn-degr d-combn) 4))
+	  (is (equal (cat:cmbn-list d-combn) '((5 . 45) (9 . 49))))
+	  (is (equal (cat:cmbn-degr dd-combn) 3))
+	  (is (equal (cat:cmbn-list dd-combn) nil))
+	  (is (equal (cat:cmbn-degr comb2) 1))
+	  (is (equal (cat:cmbn-list comb2) '((1 . 16))))
+	  (is (equal (cat:cmbn-degr comb3) 4))
+	  (is (equal (cat:cmbn-list comb3) '((1 . 41))))
+	  (is (equal (cat:cmbn-degr comb4) 3))
+	  (is (equal (cat:cmbn-list comb4) '((1 . 31))))
+	  (is (equal (cat:degr identity?) 0))
+	  (is (equal (cat:cmbn-degr comb6) 1))
+	  (is (equal (cat:cmbn-list comb6) '((1 . 10) (2 . 11) (3 . 12)
+					     (4 . 13))))
+	  (is (equal (cat:cmbn-degr comb7) 1))
+	  (is (equal (cat:cmbn-list comb7) nil))
+	  (is (equal (cat:degr upper2-shift) 2))
+	  (is (equal (cat:cmbn-degr comb8) 3))
+	  (is (equal (cat:cmbn-list comb8) '((1 . 30) (2 . 31) (3 . 32)
+					     (4 . 33))))
+	  (is (equal (cat:degr twice-up-shift) 1))
+	  (is (equal (cat:cmbn-degr comb9) 2))
+	  (is (equal (cat:cmbn-list comb9) '((2 . 20) (4 . 21) (6 . 22)
+					     (8 . 23))))
+	  (is (equal (cat:cmbn-degr comb10) 1))
+	  (is (equal (cat:cmbn-list comb10) '((1 . 11))))
+	  (is (equal (cat:cmbn-degr comb11) 1))
+	  (is (equal (cat:cmbn-list comb11) nil))
+	  (is (equal (cat:cmbn-degr comb13) 1))
+	  (is (equal (cat:cmbn-list comb13) '((2 . 11) (4 . 13) (6 . 15))))
+	  (is (equal (cat:cmbn-degr comb14) 1))
+	  (is (equal (cat:cmbn-list comb14) '((1 . 10) (3 . 12) (5 . 14)))))))