Extracted cones tests.
This commit is contained in:
Gerd Heber
parent
fe065a7a13
commit
6a9a2f60b9
@ -22,4 +22,5 @@
|
||||
(:file "searching-homology-test")
|
||||
(:file "delta-test")
|
||||
(:file "bar-test")
|
||||
(:file "cartesian-products-test")))
|
||||
(:file "cartesian-products-test")
|
||||
(:file "cones-test")))
|
||||
|
||||
20
package.lisp
20
package.lisp
@ -135,6 +135,24 @@
|
||||
ZERO-CMBN
|
||||
ZERO-INTR-DFFR
|
||||
|
||||
;; cones.lisp
|
||||
|
||||
CMBN-CON0
|
||||
CMBN-CON1
|
||||
CONE
|
||||
CONE-2CMBN-APPEND
|
||||
CONE-2MRPH-DIAG
|
||||
CONE-2MRPH-DIAG-IMPL
|
||||
CONE-3MRPH-TRIANGLE
|
||||
CONE-3MRPH-TRIANGLE-IMPL
|
||||
CONE-BASIS
|
||||
CONE-CMBN-SPLIT
|
||||
CONE-CMPR
|
||||
TERM-CON0
|
||||
TERM-CON1
|
||||
TERM-UNCON
|
||||
|
||||
|
||||
;; delta.lisp
|
||||
|
||||
DELTA
|
||||
@ -199,6 +217,8 @@
|
||||
CMBN-NON-ZERO-P
|
||||
CMBN-ZERO-P
|
||||
CMPR
|
||||
CON0
|
||||
CON1
|
||||
CPRD
|
||||
CRPR
|
||||
D
|
||||
|
||||
116
src/cones.lisp
116
src/cones.lisp
@ -23,16 +23,6 @@
|
||||
(setf mark icon)))
|
||||
cone)))
|
||||
|
||||
#|
|
||||
()
|
||||
(con0 'a)
|
||||
(con1 'a)
|
||||
(con0 (con0 'a))
|
||||
(con0 (con1 'a))
|
||||
(con1 (con0 'a))
|
||||
(con1 (con1 'a))
|
||||
(con0 (con1 (con0 (con1 'a))))
|
||||
|#
|
||||
|
||||
(DEFUN CONE-CMPR (cmpr0 cmpr1)
|
||||
(declare (type cmprf cmpr0 cmpr1))
|
||||
@ -57,18 +47,6 @@
|
||||
(declare (ftype (function (cone cone) cmpr) rslt))
|
||||
#'rslt)))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf cmpr (cone-cmpr #'s-cmpr #'f-cmpr))
|
||||
(funcall cmpr (con0 'a) (con0 'b))
|
||||
(funcall cmpr (con0 'b) (con0 'b))
|
||||
(funcall cmpr (con0 'b) (con0 'a))
|
||||
(funcall cmpr (con0 'b) (con1 '2))
|
||||
(funcall cmpr (con1 '2) (con0 'b))
|
||||
(funcall cmpr (con1 '1) (con1 '2))
|
||||
(funcall cmpr (con1 '2) (con1 '2))
|
||||
(funcall cmpr (con1 '2) (con1 '1))
|
||||
|#
|
||||
|
||||
(DEFUN CONE-BASIS (basis0 basis1)
|
||||
(declare (type basis basis0 basis1))
|
||||
@ -88,35 +66,26 @@
|
||||
(declare (ftype (function (fixnum) list) rslt))
|
||||
#'rslt))))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf basis (cone-basis
|
||||
#'(lambda (n) (list n))
|
||||
#'(lambda (n) (list n))))
|
||||
(funcall basis 4)
|
||||
|#
|
||||
|
||||
(DEFUN TERM-CON0 (term)
|
||||
(declare (type term term))
|
||||
(the term
|
||||
(term (cffc term)
|
||||
(con0 (gnrt term)))))
|
||||
|
||||
|
||||
(DEFUN TERM-CON1 (term)
|
||||
(declare (type term term))
|
||||
(the term
|
||||
(term (cffc term)
|
||||
(con1 (gnrt term)))))
|
||||
|
||||
|
||||
(DEFUN TERM-UNCON (term)
|
||||
(declare (type term term))
|
||||
(the term
|
||||
(term (cffc term) (icon (gnrt term)))))
|
||||
|
||||
#|
|
||||
()
|
||||
(term-con0 (term 2 'a))
|
||||
(term-con1 (term 2 'a))
|
||||
(term-uncon (term 2 (con0 'a)))
|
||||
|#
|
||||
|
||||
(DEFUN CMBN-CON0 (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
@ -125,6 +94,7 @@
|
||||
:degr (cmbn-degr cmbn)
|
||||
:list (mapcar #'term-con0 (cmbn-list cmbn)))))
|
||||
|
||||
|
||||
(DEFUN CMBN-CON1 (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
@ -132,11 +102,6 @@
|
||||
:degr (cmbn-degr cmbn)
|
||||
:list (mapcar #'term-con1 (cmbn-list cmbn)))))
|
||||
|
||||
#|
|
||||
()
|
||||
(cmbn-con0 (cmbn 3 1 'a 2 'b))
|
||||
(cmbn-con1 (cmbn 3 1 'a 2 'b))
|
||||
|#
|
||||
|
||||
(DEFUN CONE-CMBN-SPLIT (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
@ -158,13 +123,6 @@
|
||||
(values (make-cmbn :degr degr :list list0)
|
||||
(make-cmbn :degr (1- degr) :list list1))))))
|
||||
|
||||
#|
|
||||
()
|
||||
(cone-cmbn-split
|
||||
(cmbn 3 4 (con0 'a) 5 (con1 'b)))
|
||||
(cone-cmbn-split (cmbn 3 4 (con0 'a)))
|
||||
(cone-cmbn-split (cmbn 3 4 (con1 'a)))
|
||||
|#
|
||||
|
||||
(DEFUN CONE-2CMBN-APPEND (cmbn0 cmbn1)
|
||||
(declare (type cmbn cmbn0 cmbn1))
|
||||
@ -174,10 +132,6 @@
|
||||
:list (append (mapcar #'term-con0 (cmbn-list cmbn0))
|
||||
(mapcar #'term-con1 (cmbn-list cmbn1))))))
|
||||
|
||||
#|
|
||||
()
|
||||
(cone-2cmbn-append (cmbn 3 4 'a) (cmbn 2 5 'b))
|
||||
|#
|
||||
|
||||
(DEFUN CONE-2MRPH-DIAG-IMPL (mrph0 mrph1)
|
||||
(declare (type morphism mrph0 mrph1))
|
||||
@ -192,12 +146,6 @@
|
||||
(? mrph1 cmbn1))))))
|
||||
#'rslt)))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf mrph (dffr (delta 4)))
|
||||
(setf rslt (cone-2mrph-diag-impl mrph mrph))
|
||||
(funcall rslt (cmbn 3 4 (con0 15) 5 (con1 7)))
|
||||
|#
|
||||
|
||||
(DEFUN CONE-3MRPH-TRIANGLE-IMPL (cmpr0 mrph0 mrph1 phi)
|
||||
(declare (ignore cmpr0) (type morphism mrph0 mrph1 phi))
|
||||
@ -215,17 +163,6 @@
|
||||
(? mrph1 (1- degr) gnrt))))))))
|
||||
#'rslt)))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf rslt (cone-3mrph-triangle-impl #'f-cmpr
|
||||
(dffr (delta 4))
|
||||
(dffr (delta 4))
|
||||
(idnt-mrph (delta 4))))
|
||||
(funcall rslt 4 (con0 '31))
|
||||
(funcall rslt 5 (con1 '31))
|
||||
(funcall rslt 4 (con1 '15))
|
||||
; (funcall rslt (cmbn 4 1 (con0 '31) 1 (con1 '15))) ;
|
||||
|#
|
||||
|
||||
(DEFUN CONE (mrph)
|
||||
(declare (type morphism mrph))
|
||||
@ -244,25 +181,6 @@
|
||||
:strt :gnrt
|
||||
:orgn `(cone ,mrph)))))
|
||||
|
||||
#|
|
||||
()
|
||||
(cat-init)
|
||||
(setf k (k-z 1))
|
||||
(setf u (idnt-mrph k))
|
||||
(setf c (cone u))
|
||||
(setf *tc* (cmbn 4 1 (con0 '(1 2 3 4))))
|
||||
(? c 4 (con0 '(1 2 3 4)))
|
||||
(? c *tc*)
|
||||
|#
|
||||
|
||||
|
||||
#|
|
||||
()
|
||||
(setf cone (cone (idnt-mrph (delta 4))))
|
||||
(? cone (cmbn 4 1 (con0 '31) -1 (con1 '15)))
|
||||
(? cone *)
|
||||
|#
|
||||
|
||||
|
||||
(DEFUN CONE-2MRPH-DIAG (sorc-cone trgt-cone mrph0 mrph1)
|
||||
(declare
|
||||
@ -280,13 +198,6 @@
|
||||
:strt :cmbn
|
||||
:orgn `(cone-2mrph-diag ,sorc-cone ,trgt-cone ,mrph0 ,mrph1)))))
|
||||
|
||||
#|
|
||||
()
|
||||
(setf idnt (idnt-mrph (delta 4)))
|
||||
(setf cone (cone idnt))
|
||||
(setf ff (cone-2mrph-diag cone cone idnt idnt))
|
||||
(? ff (cmbn 4 1 (con0 '31) 10 (con1 '15)))
|
||||
|#
|
||||
|
||||
(DEFUN CONE-3MRPH-TRIANGLE (sorc-cone trgt-cone mrph0 mrph1 phi)
|
||||
(declare
|
||||
@ -309,23 +220,6 @@
|
||||
:orgn `(cone-3mrph-triangle ,sorc-cone ,trgt-cone
|
||||
,mrph0 ,mrph1 ,phi)))))
|
||||
|
||||
#|
|
||||
()
|
||||
(cat-init)
|
||||
(setf d (delta 4))
|
||||
(setf df (dffr (delta 4)))
|
||||
(setf n (idnt-mrph d))
|
||||
(setf c (cone n))
|
||||
(setf z (sbtr (dffr c)
|
||||
(cone-3mrph-triangle c c df (n-mrph -1 df) n)))
|
||||
(? z 0 (con0 '1))
|
||||
(? z 1 (con1 '1))
|
||||
(? z 1 (con0 '3))
|
||||
(? z 2 (con1 '3))
|
||||
(? z 4 (con0 '31))
|
||||
(? z 5 (con1 '31))
|
||||
|#
|
||||
|
||||
|
||||
(DEFUN CONE-EFHM (cone)
|
||||
(declare (type chain-complex cone))
|
||||
|
||||
111
test/cones-test.lisp
Normal file
111
test/cones-test.lisp
Normal file
@ -0,0 +1,111 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
(test con-test
|
||||
(cat:con0 'a)
|
||||
(cat:con1 'a)
|
||||
(cat:con0 (cat:con0 'a))
|
||||
(cat:con0 (cat:con1 'a))
|
||||
(cat:con1 (cat:con0 'a))
|
||||
(cat:con1 (cat:con1 'a))
|
||||
(cat:con0 (cat:con1 (cat:con0 (cat:con1 'a)))))
|
||||
|
||||
|
||||
(test cone-cmpr
|
||||
(let ((cmpr (cat:cone-cmpr #'cat:s-cmpr #'cat:f-cmpr)))
|
||||
(is (equal :less (funcall cmpr (cat:con0 'a) (cat:con0 'b))))
|
||||
(is (equal :equal (funcall cmpr (cat:con0 'b) (cat:con0 'b))))
|
||||
(is (equal :greater (funcall cmpr (cat:con0 'b) (cat:con0 'a))))
|
||||
(is (equal :less (funcall cmpr (cat:con0 'b) (cat:con1 '2))))
|
||||
(is (equal :greater (funcall cmpr (cat:con1 '2) (cat:con0 'b))))
|
||||
(is (equal :less (funcall cmpr (cat:con1 '1) (cat:con1 '2))))
|
||||
(is (equal :equal (funcall cmpr (cat:con1 '2) (cat:con1 '2))))
|
||||
(is (equal :greater (funcall cmpr (cat:con1 '2) (cat:con1 '1))))))
|
||||
|
||||
|
||||
(test cone-basis
|
||||
(let ((basis (cat:cone-basis #'(lambda (n) (list n))
|
||||
#'(lambda (n) (list n)))))
|
||||
(funcall basis 4)))
|
||||
|
||||
|
||||
(test term-con
|
||||
(cat:term-con0 (cat:term 2 'a))
|
||||
(cat:term-con1 (cat:term 2 'a))
|
||||
(cat:term-uncon (cat:term 2 (cat:con0 'a))))
|
||||
|
||||
|
||||
(test cmbn-con
|
||||
(cat:cmbn-con0 (cat:cmbn 3 1 'a 2 'b))
|
||||
(cat:cmbn-con1 (cat:cmbn 3 1 'a 2 'b)))
|
||||
|
||||
|
||||
(test cone-cmbn-split
|
||||
(cat:cone-cmbn-split (cat:cmbn 3 4 (cat:con0 'a) 5 (cat:con1 'b)))
|
||||
(cat:cone-cmbn-split (cat:cmbn 3 4 (cat:con0 'a)))
|
||||
(cat:cone-cmbn-split (cat:cmbn 3 4 (cat:con1 'a))))
|
||||
|
||||
|
||||
(test cone-2cmbn-append
|
||||
(cat:cone-2cmbn-append (cat:cmbn 3 4 'a) (cat:cmbn 2 5 'b)))
|
||||
|
||||
|
||||
(test cone-2mrph-diag-impl
|
||||
(let* ((mrph (cat:dffr (cat:delta 4)))
|
||||
(rslt (cat:cone-2mrph-diag-impl mrph mrph)))
|
||||
(funcall rslt (cat:cmbn 3 4 (cat:con0 15) 5 (cat:con1 7)))))
|
||||
|
||||
|
||||
(test cone-3mrph-triangle-impl
|
||||
(let ((rslt (cat:cone-3mrph-triangle-impl #'cat:f-cmpr
|
||||
(cat:dffr (cat:delta 4))
|
||||
(cat:dffr (cat:delta 4))
|
||||
(cat:idnt-mrph (cat:delta 4)))))
|
||||
(funcall rslt 4 (cat:con0 '31))
|
||||
(funcall rslt 5 (cat:con1 '31))
|
||||
(funcall rslt 4 (cat:con1 '15))))
|
||||
|
||||
|
||||
(test cone
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let* ((k (cat:k-z 1))
|
||||
(u (cat:idnt-mrph k))
|
||||
(c (cat:cone u))
|
||||
(cone))
|
||||
(setf cat:*tc* (cat:cmbn 4 1 (cat:con0 '(1 2 3 4))))
|
||||
(cat:? c 4 (cat:con0 '(1 2 3 4)))
|
||||
(cat:? c cat:*tc*)
|
||||
|
||||
(setf cone (cat:cone (cat:idnt-mrph (cat:delta 4))))
|
||||
(cat:? cone (cat:cmbn 4 1 (cat:con0 '31) -1 (cat:con1 '15)))
|
||||
(cat:? cone
|
||||
(cat:? cone (cat:cmbn 4
|
||||
1 (cat:con0 '31) -1 (cat:con1 '15)))))))
|
||||
|
||||
|
||||
(test cone-2mrph-diag
|
||||
(let* ((idnt (cat:idnt-mrph (cat:delta 4)))
|
||||
(cone (cat:cone idnt))
|
||||
(ff (cat:cone-2mrph-diag cone cone idnt idnt)))
|
||||
(cat:? ff (cat:cmbn 4 1 (cat:con0 '31) 10 (cat:con1 '15)))))
|
||||
|
||||
|
||||
(test cone-3mrph-triangle
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let* ((d (cat:delta 4))
|
||||
(df (cat:dffr (cat:delta 4)))
|
||||
(n (cat:idnt-mrph d))
|
||||
(c (cat:cone n))
|
||||
(z (cat:sbtr (cat:dffr c)
|
||||
(cat:cone-3mrph-triangle c c df
|
||||
(cat:n-mrph -1 df) n))))
|
||||
(cat:? z 0 (cat:con0 '1))
|
||||
(cat:? z 1 (cat:con1 '1))
|
||||
(cat:? z 1 (cat:con0 '3))
|
||||
(cat:? z 2 (cat:con1 '3))
|
||||
(cat:? z 4 (cat:con0 '31))
|
||||
(cat:? z 5 (cat:con1 '31)))))
|
||||
Loading…
Reference in New Issue
Block a user