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

Extracted tensor product tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-11 17:46:41 -05:00
parent 2f7b5d9128
commit 6fc2688b58
6 changed files with 367 additions and 305 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
kenzo-test.asd
View File

@ -9,6 +9,7 @@
:pathname #P"test/" :pathname #P"test/"
:components ((:file "package") :components ((:file "package")
(:file "common") (:file "common")
#|
(:file "combinations-test") (:file "combinations-test")
(:file "various-test") (:file "various-test")
(:file "chain-complexes-test") (:file "chain-complexes-test")
@ -24,4 +25,6 @@
(:file "bar-test") (:file "bar-test")
(:file "cartesian-products-test") (:file "cartesian-products-test")
(:file "cones-test") (:file "cones-test")
(:file "cl-space-efhm-test"))) (:file "cl-space-efhm-test")
|#
(:file "tensor-products-test")))

13
package.lisp
View File

@ -19,6 +19,7 @@
*LIST-LIST* *LIST-LIST*
*TC* *TC*
*TDD* *TDD*
*TNPR-WITH-DEGREES*
;; bar.lisp ;; bar.lisp
@ -88,6 +89,7 @@
;; cl-space-efhm.lisp ;; cl-space-efhm.lisp
CS-HAT-T-U
CS-HAT-U-T CS-HAT-U-T
;; classes.lisp ;; classes.lisp
@ -118,6 +120,7 @@
ORGN ORGN
REDUCTION REDUCTION
RRDCT RRDCT
SORC
TCC TCC
TNPR TNPR
@ -258,6 +261,16 @@
SPHERE SPHERE
BUILD-FINITE-SS BUILD-FINITE-SS
;; tensor-products.lisp
2CMBN-TNPR
TNSR-PRDC
TNSR-PRDC-BASIS
TNSR-PRDC-CMPR
TNSR-PRDC-INTR
TNSR-PRDC-INTR-DFFR
TNPR-PRINT
;; various.lisp ;; various.lisp
+EMPTY-LIST+ +EMPTY-LIST+

3
run-kenzo-test.lisp
View File

@ -1,3 +1,6 @@
(DECLAIM (OPTIMIZE (speed 0) (space 0) (debug 3)))
(require 'asdf) (require 'asdf)
(asdf:operate 'asdf:load-op 'kenzo-test) (asdf:operate 'asdf:load-op 'kenzo-test)

1
src/kenzo.lisp
View File

@ -7,7 +7,6 @@
(values)) (values))
;;(PROCLAIM '(OPTIMIZE (speed 3) (safety 1) (space 0) (debug 0))) ;;(PROCLAIM '(OPTIMIZE (speed 3) (safety 1) (space 0) (debug 0)))
(DECLAIM (OPTIMIZE (speed 0) (space 0) (debug 3)))
;; Don't mess with ANSI's definition of DEFCONSTANT! ;; Don't mess with ANSI's definition of DEFCONSTANT!

500
src/tensor-products.lisp
View File

@ -12,351 +12,252 @@
(type tnpr tnpr) (stream stream) (type tnpr tnpr) (stream stream)
(ignore depth)) (ignore depth))
(the tnpr (the tnpr
(progn (progn
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr (with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
(format stream (format stream
"<TnPr~:[~*~; ~D~] ~A~:[~*~; ~D~] ~A>" "<TnPr~:[~*~; ~D~] ~A~:[~*~; ~D~] ~A>"
*tnpr-with-degrees* degr1 gnrt1 *tnpr-with-degrees* degr1 gnrt1
*tnpr-with-degrees* degr2 gnrt2)) *tnpr-with-degrees* degr2 gnrt2))
tnpr))) tnpr)))
#|
(tnpr 2 'a 3 'b)
(setf *tnpr-with-degrees* t)
(tnpr 2 'a 3 'b)
(setf *tnpr-with-degrees* nil)
|#
(DEFUN 2CMBN-TNPR (cmbn1 cmbn2) (DEFUN 2CMBN-TNPR (cmbn1 cmbn2)
(declare (type cmbn cmbn1 cmbn2)) (declare (type cmbn cmbn1 cmbn2))
(the cmbn (the cmbn
(with-cmbn (degr1 list1) cmbn1 (with-cmbn
(with-cmbn (degr2 list2) cmbn2 (degr1 list1) cmbn1
(make-cmbn (with-cmbn
:degr (+ degr1 degr2) (degr2 list2) cmbn2
:list (mapcan (make-cmbn
#'(lambda (term1) :degr (+ degr1 degr2)
(declare (type term term1)) :list (mapcan
(the list #'(lambda (term1)
(with-term (cffc1 gnrt1) term1 (declare (type term term1))
(mapcar (the list
#'(lambda (term2) (with-term
(declare (type term term2)) (cffc1 gnrt1) term1
(the term (mapcar
(term #'(lambda (term2)
(* cffc1 (cffc term2)) (declare (type term term2))
(tnpr degr1 gnrt1 degr2 (gnrt term2))))) (the term
list2)))) (term
list1)))))) (* cffc1 (cffc term2))
#| (tnpr degr1 gnrt1 degr2
(setf *tnpr-with-degrees* t) (gnrt term2)))))
(2cmbn-tnpr (cmbn 2 3 'a 4 'b -5 'c) (cmbn 3 4 'x -3 'y 2 'z))) list2))))
|# list1))))))
#| #|
(DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2) (DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2)
(declare (type cmprf cmpr1 cmpr2)) (declare (type cmprf cmpr1 cmpr2))
(flet ((rslt (tnpr1 tnpr2) (flet ((rslt (tnpr1 tnpr2)
(declare (type tnpr tnpr1 tnpr2)) (declare (type tnpr tnpr1 tnpr2))
(let ((left-cons-1 (cadr tnpr1)) (let ((left-cons-1 (cadr tnpr1))
(left-cons-2 (cadr tnpr2))) (left-cons-2 (cadr tnpr2)))
(declare (cons left-cons-1 left-cons-2)) (declare (cons left-cons-1 left-cons-2))
(lexico (lexico
(f-cmpr (car left-cons-1) (car left-cons-2)) (f-cmpr (car left-cons-1) (car left-cons-2))
(funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2)) (funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2))
(funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2)))))) (funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
|# |#
(DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2) (DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2)
(declare (type cmprf cmpr1 cmpr2)) (declare (type cmprf cmpr1 cmpr2))
(flet ((rslt (tnpr1 tnpr2) (flet ((rslt (tnpr1 tnpr2)
(declare (type tnpr tnpr1 tnpr2)) (declare (type tnpr tnpr1 tnpr2))
(the cmpr (the cmpr
(lexico (lexico
(f-cmpr (degr1 tnpr1) (degr1 tnpr2)) (f-cmpr (degr1 tnpr1) (degr1 tnpr2))
(funcall cmpr1 (gnrt1 tnpr1) (gnrt1 tnpr2)) (funcall cmpr1 (gnrt1 tnpr1) (gnrt1 tnpr2))
(funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2)))))) (funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
#|
(setf cmpr (tnsr-prdc-cmpr #'s-cmpr #'s-cmpr))
(funcall cmpr (tnpr 2 'a 3 'b) (tnpr 3 'a 2 'b))
(funcall cmpr (tnpr 3 'a 2 'b) (tnpr 2 'a 3 'b))
(funcall cmpr (tnpr 2 'a 3 'b) (tnpr 2 'b 3 'b))
(funcall cmpr (tnpr 2 'b 3 'b) (tnpr 2 'a 3 'b))
(funcall cmpr (tnpr 2 'a 3 'a) (tnpr 2 'a 3 'b))
(funcall cmpr (tnpr 2 'a 3 'c) (tnpr 2 'a 3 'b))
(funcall cmpr (tnpr 2 'a 3 'b) (tnpr 2 'a 3 'b)))
|#
(DEFUN TNSR-PRDC-BASIS (basis1 basis2) (DEFUN TNSR-PRDC-BASIS (basis1 basis2)
(declare (type basis basis1 basis2)) (declare (type basis basis1 basis2))
(when (or (eq basis1 :locally-effective) (when (or (eq basis1 :locally-effective)
(eq basis2 :locally-effective)) (eq basis2 :locally-effective))
(return-from tnsr-prdc-basis :locally-effective)) (return-from tnsr-prdc-basis :locally-effective))
(flet ((rslt (degr) (flet ((rslt (degr)
(declare (fixnum degr)) (declare (fixnum degr))
(the list (the list
(progn (progn
(when (minusp degr) (when (minusp degr)
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(mapcan (mapcan
#'(lambda (degr1) #'(lambda (degr1)
(declare (fixnum degr1)) (declare (fixnum degr1))
(let* ((basis1 (funcall basis1 degr1)) (let* ((basis1 (funcall basis1 degr1))
(degr2 (- degr degr1)) (degr2 (- degr degr1))
(basis2 (funcall basis2 degr2))) (basis2 (funcall basis2 degr2)))
(declare (declare
(fixnum degr2) (fixnum degr2)
(list basis1 basis2)) (list basis1 basis2))
(the list (the list
(mapcan (mapcan
#'(lambda (gnrt1) #'(lambda (gnrt1)
(declare (type gnrt gnrt1)) (declare (type gnrt gnrt1))
(the list (the list
(mapcar (mapcar
#'(lambda (gnrt2) #'(lambda (gnrt2)
(declare (type gnrt gnrt2)) (declare (type gnrt gnrt2))
(the tnpr (the tnpr
(tnpr degr1 gnrt1 degr2 gnrt2))) (tnpr degr1 gnrt1 degr2
basis2))) gnrt2)))
basis1)))) basis2)))
(<a-b> 0 degr)))))) basis1))))
(the basis #'rslt))) (<a-b> 0 degr))))))
(the basis #'rslt)))
#|
(defun bas (degr)
(case degr
(0 '(a b c))
(1 '(d))
(2 nil)
(3 '(x y))))
(setf bas (tnsr-prdc-basis #'bas #'bas))
(dotimes (i 8)
(print (funcall bas i))))
|#
(DEFUN TNSR-PRDC-INTR-DFFR (dffr1 dffr2) (DEFUN TNSR-PRDC-INTR-DFFR (dffr1 dffr2)
(declare (type morphism dffr1 dffr2)) (declare (type morphism dffr1 dffr2))
(flet ((rslt (degr tnpr) (flet ((rslt (degr tnpr)
(declare (declare
(fixnum degr) (fixnum degr)
(type tnpr tnpr)) (type tnpr tnpr))
(the cmbn (the cmbn
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr (with-tnpr
(let ((degr1-1 (1- degr1)) (degr1 gnrt1 degr2 gnrt2) tnpr
(degr2-1 (1- degr2)) (let ((degr1-1 (1- degr1))
(sign (oddp degr1)) (degr2-1 (1- degr2))
(list1 (cmbn-list (gnrt-? dffr1 degr1 gnrt1))) (sign (oddp degr1))
(list2 (cmbn-list (gnrt-? dffr2 degr2 gnrt2)))) (list1 (cmbn-list (gnrt-? dffr1 degr1 gnrt1)))
(declare (list2 (cmbn-list (gnrt-? dffr2 degr2 gnrt2))))
(declare
(fixnum degr1-1 degr2-1) (fixnum degr1-1 degr2-1)
(boolean sign) (boolean sign)
(list list1 list2)) (list list1 list2))
(make-cmbn (make-cmbn
:degr (1- degr) :degr (1- degr)
:list (nconc :list (nconc
(mapcar (mapcar
#'(lambda (term1) #'(lambda (term1)
(declare (type term term1)) (declare (type term term1))
(with-term (cffc1 gnrt1) term1 (with-term
(term cffc1 (cffc1 gnrt1) term1
(tnpr degr1-1 gnrt1 degr2 gnrt2)))) (term cffc1 (tnpr degr1-1 gnrt1
list1) degr2 gnrt2))))
(mapcar list1)
#'(lambda (term2) (mapcar
(declare (type term term2)) #'(lambda (term2)
(with-term (cffc2 gnrt2) term2 (declare (type term term2))
(term (if sign (- cffc2) cffc2) (with-term (cffc2 gnrt2) term2
(tnpr degr1 gnrt1 degr2-1 gnrt2)))) (term (if sign (- cffc2) cffc2)
list2)))))))) (tnpr degr1 gnrt1
(the intr-mrph #'rslt))) degr2-1 gnrt2))))
list2))))))))
(the intr-mrph #'rslt)))
#|
(cat-init)
(setf chcm (build-chcm :cmpr #'s-cmpr :strt :gnrt :orgn '(test-1)))
(setf dffr (build-mrph :sorc chcm :trgt chcm :degr -1
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cmbn (1- degr) 2 'd1a -3 'd2a))
(b (cmbn (1- degr) 3 'd1b -4 'd2b))))
:strt :gnrt :orgn '(test-2)))
(setf rslt (tnsr-prdc-intr-dffr dffr dffr))
(funcall rslt 4 (tnpr 2 'a 2 'b))
(funcall rslt 5 (tnpr 3 'a 2 'b))
(funcall rslt 5 (tnpr 2 'a 3 'b))
(funcall rslt 6 (tnpr 3 'a 3 'b)))
|#
(DEFGENERIC TNSR-PRDC (chcm-hmeq-mrph-rdct1 chcm-hmeq-mrph-rdct2)) (DEFGENERIC TNSR-PRDC (chcm-hmeq-mrph-rdct1 chcm-hmeq-mrph-rdct2))
(DEFMETHOD TNSR-PRDC ((chcm1 chain-complex) (chcm2 chain-complex)) (DEFMETHOD TNSR-PRDC ((chcm1 chain-complex) (chcm2 chain-complex))
(the chain-complex (the chain-complex
(with-slots ((cmpr1 cmpr) (basis1 basis) (dffr1 dffr)) chcm1 (with-slots ((cmpr1 cmpr) (basis1 basis) (dffr1 dffr)) chcm1
(declare
(type cmprf cmpr1)
(type basis basis1)
(type morphism dffr1))
(with-slots ((cmpr2 cmpr) (basis2 basis) (dffr2 dffr)) chcm2
(declare (declare
(type cmprf cmpr1)
(type basis basis1)
(type morphism dffr1))
(with-slots ((cmpr2 cmpr) (basis2 basis) (dffr2 dffr)) chcm2
(declare
(type cmprf cmpr2) (type cmprf cmpr2)
(type basis basis2) (type basis basis2)
(type morphism dffr2)) (type morphism dffr2))
(let ((rslt (let ((rslt
(build-chcm (build-chcm
:cmpr (tnsr-prdc-cmpr cmpr1 cmpr2) :cmpr (tnsr-prdc-cmpr cmpr1 cmpr2)
:basis (tnsr-prdc-basis basis1 basis2) :basis (tnsr-prdc-basis basis1 basis2)
:intr-dffr (tnsr-prdc-intr-dffr dffr1 dffr2) :intr-dffr (tnsr-prdc-intr-dffr dffr1 dffr2)
:strt :gnrt :strt :gnrt
:orgn `(tnsr-prdc ,chcm1 ,chcm2)))) :orgn `(tnsr-prdc ,chcm1 ,chcm2))))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
(if (and (slot-boundp chcm1 'bsgn) (if (and (slot-boundp chcm1 'bsgn)
(slot-boundp chcm2 'bsgn)) (slot-boundp chcm2 'bsgn))
(setf (slot-value rslt 'bsgn) (setf (slot-value rslt 'bsgn)
(tnpr 0 (bsgn chcm1) 0 (bsgn chcm2))) (tnpr 0 (bsgn chcm1) 0 (bsgn chcm2)))
(slot-makunbound rslt 'bsgn)) (slot-makunbound rslt 'bsgn))
rslt))))) rslt)))))
#|
(setf dd (tnsr-prdc (delta 2) (delta 3)))
(cmpr dd (tnpr 2 7 2 11) (tnpr 2 7 2 14))
(basis dd 3)
(? dd 4 (tnpr 2 7 2 14))
(? dd 3 (tnpr 1 6 2 14))
(? dd (? dd 4 (tnpr 2 7 2 14)))
(? dd (? dd 3 (tnpr 1 6 2 14))))
|#
(DEFUN TNSR-PRDC-INTR (mrph1 mrph2) (DEFUN TNSR-PRDC-INTR (mrph1 mrph2)
(declare (declare
(type morphism mrph1 mrph2)) (type morphism mrph1 mrph2))
(let ((mrph2-sign (oddp (degr mrph2)))) (let ((mrph2-sign (oddp (degr mrph2))))
(declare (type boolean mrph2-sign)) (declare (type boolean mrph2-sign))
(flet ((rslt (degr tnpr) (flet ((rslt (degr tnpr)
(declare (declare
(ignore degr) (ignore degr)
(type tnpr tnpr)) (type tnpr tnpr))
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr (with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
(let ((rslt (2cmbn-tnpr (let ((rslt (2cmbn-tnpr
(gnrt-? mrph1 degr1 gnrt1) (gnrt-? mrph1 degr1 gnrt1)
(gnrt-? mrph2 degr2 gnrt2)))) (gnrt-? mrph2 degr2 gnrt2))))
(declare (type cmbn rslt)) (declare (type cmbn rslt))
(when (and mrph2-sign (when (and mrph2-sign
(oddp degr1)) (oddp degr1))
(mapc #'(lambda (term) (mapc #'(lambda (term)
(declare (type term term)) (declare (type term term))
(setf (the fixnum (cffc term)) (setf (the fixnum (cffc term))
(the fixnum (- (cffc term))))) (the fixnum (- (cffc term)))))
(cmbn-list rslt))) (cmbn-list rslt)))
rslt)))) rslt))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
#|
(cat-init)
(setf chcm (build-chcm :cmpr #'s-cmpr :strt :gnrt :orgn '(test-1)))
(setf mrph (build-mrph :sorc chcm :trgt chcm :degr 0
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cmbn degr 2 'd1a -3 'd2a))
(b (cmbn degr 3 'd1b -4 'd2b))))
:strt :gnrt :orgn '(test-2)))
(setf rslt (tnsr-prdc-intr mrph mrph))
(funcall rslt 6 (tnpr 2 'a 4 'b))
(funcall rslt 5 (tnpr 3 'a 2 'b))
(setf mrph (build-mrph :sorc chcm :trgt chcm :degr 1
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cmbn (1+ degr) 2 'd1a -3 'd2a))
(b (cmbn (1+ degr) 3 'd1b -4 'd2b))))
:strt :gnrt :orgn '(test-3)))
(setf rslt (tnsr-prdc-intr mrph mrph))
(funcall rslt 6 (tnpr 2 'a 4 'b))
(funcall rslt 5 (tnpr 3 'a 2 'b)))
|#
(DEFMETHOD TNSR-PRDC ((mrph1 morphism) (mrph2 morphism)) (DEFMETHOD TNSR-PRDC ((mrph1 morphism) (mrph2 morphism))
(the morphism (the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr)) mrph1 (with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr)) mrph1
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr)) mrph2 (with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr)) mrph2
(the morphism (the morphism
(progn (progn
(when (and (eq 'idnt-mrph (first (orgn mrph1))) (when (and (eq 'idnt-mrph (first (orgn mrph1)))
(eq 'idnt-mrph (first (orgn mrph2)))) (eq 'idnt-mrph (first (orgn mrph2))))
(return-from tnsr-prdc (return-from tnsr-prdc
(idnt-mrph (tnsr-prdc sorc1 sorc2)))) (idnt-mrph (tnsr-prdc sorc1 sorc2))))
(when (or (eq 'zero-mrph (first (orgn mrph1))) (when (or (eq 'zero-mrph (first (orgn mrph1)))
(eq 'zero-mrph (first (orgn mrph2)))) (eq 'zero-mrph (first (orgn mrph2))))
(return-from tnsr-prdc (return-from tnsr-prdc
(zero-mrph (tnsr-prdc sorc1 sorc2) (zero-mrph (tnsr-prdc sorc1 sorc2)
(tnsr-prdc trgt1 trgt2) (tnsr-prdc trgt1 trgt2)
(+ degr1 degr2)))) (+ degr1 degr2))))
(build-mrph (build-mrph
:sorc (tnsr-prdc sorc1 sorc2) :sorc (tnsr-prdc sorc1 sorc2)
:trgt (tnsr-prdc trgt1 trgt2) :trgt (tnsr-prdc trgt1 trgt2)
:degr (+ degr1 degr2) :degr (+ degr1 degr2)
:intr (tnsr-prdc-intr mrph1 mrph2) :intr (tnsr-prdc-intr mrph1 mrph2)
:strt :gnrt :strt :gnrt
:orgn `(tnsr-prdc ,mrph1 ,mrph2)))))))) :orgn `(tnsr-prdc ,mrph1 ,mrph2))))))))
#|
(cat-init)
(setf d (dffr (delta-infinity)))
(setf dd (tnsr-prdc d d))
(eq (sorc dd) (tnsr-prdc (delta-infinity) (delta-infinity)))
(? dd 5 (tnpr 2 7 3 15))
(? dd 5 (tnpr 3 15 2 7))
(? dd (? dd 5 (tnpr 2 7 3 15)))
(? dd (? dd 5 (tnpr 3 15 2 7)))
(setf ddd (cmps dd dd))
(? ddd 5 (tnpr 2 7 3 15))
(? ddd 5 (tnpr 3 15 2 7))
|#
(DEFMETHOD TNSR-PRDC ((rdct1 reduction) (rdct2 reduction)) (DEFMETHOD TNSR-PRDC ((rdct1 reduction) (rdct2 reduction))
(the reduction (the reduction
(progn (progn
(when (and (eq 'trivial-rdct (first (orgn rdct1))) (when (and (eq 'trivial-rdct (first (orgn rdct1)))
(eq 'trivial-rdct (first (orgn rdct2)))) (eq 'trivial-rdct (first (orgn rdct2))))
(return-from tnsr-prdc (return-from tnsr-prdc
(trivial-rdct (tnsr-prdc (bcc rdct1) (bcc rdct2))))) (trivial-rdct (tnsr-prdc (bcc rdct1) (bcc rdct2)))))
(with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f) (g1 g) (h1 h)) rdct1 (with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f) (g1 g) (h1 h)) rdct1
(declare (declare
(type chain-complex tcc1 bcc1) (type chain-complex tcc1 bcc1)
(type morphism f1 g1 h1)) (type morphism f1 g1 h1))
(with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f) (g2 g) (h2 h)) rdct2 (with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f) (g2 g) (h2 h)) rdct2
(declare (declare
(type chain-complex tcc2 bcc2) (type chain-complex tcc2 bcc2)
(type morphism f2 g2 h2)) (type morphism f2 g2 h2))
(build-rdct (build-rdct
:f (tnsr-prdc f1 f2) :f (tnsr-prdc f1 f2)
:g (tnsr-prdc g1 g2) :g (tnsr-prdc g1 g2)
:h (add :h (add
(tnsr-prdc h1 (cmps g2 f2)) (tnsr-prdc h1 (cmps g2 f2))
(tnsr-prdc (idnt-mrph tcc1) h2)) (tnsr-prdc (idnt-mrph tcc1) h2))
:orgn `(tnsr-prdc ,rdct1 ,rdct2))))))) :orgn `(tnsr-prdc ,rdct1 ,rdct2)))))))
#|
(cat-init)
(setf r (ez (delta-infinity) (delta-infinity)))
(setf r2 (tnsr-prdc r r))
(setf *bc* (cmbn 4 1 (tnpr 2 (tnpr 1 3 1 3) 2 (tnpr 1 3 1 3)))
*tc* (cmbn 2 1 (tnpr 1 (crpr 0 3 0 3) 1 (crpr 0 3 0 3))))
(pre-check-rdct r2)
(check-rdct)
|#
(DEFMETHOD TNSR-PRDC ((hmeq1 homotopy-equivalence) (DEFMETHOD TNSR-PRDC ((hmeq1 homotopy-equivalence)
(hmeq2 homotopy-equivalence)) (hmeq2 homotopy-equivalence))
(the homotopy-equivalence (the homotopy-equivalence
(build-hmeq (build-hmeq
:lrdct (tnsr-prdc (lrdct hmeq1) (lrdct hmeq2)) :lrdct (tnsr-prdc (lrdct hmeq1) (lrdct hmeq2))
:rrdct (tnsr-prdc (rrdct hmeq1) (rrdct hmeq2)) :rrdct (tnsr-prdc (rrdct hmeq1) (rrdct hmeq2))
:orgn `(tnsr-prdc ,hmeq1 ,hmeq2)))) :orgn `(tnsr-prdc ,hmeq1 ,hmeq2))))
@ -366,10 +267,3 @@
(the homotopy-equivalence (the homotopy-equivalence
(tnsr-prdc (efhm (second (orgn chcm))) (tnsr-prdc (efhm (second (orgn chcm)))
(efhm (third (orgn chcm)))))) (efhm (third (orgn chcm))))))
#|
(cat-init)
(setf k (k-z 2))
(setf k2 (tnsr-prdc k k))
(homology k2 0 10)
|#

150
test/tensor-products-test.lisp Normal file
View File

@ -0,0 +1,150 @@
(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)))
|#