Extracted tensor product tests.
This commit is contained in:
Gerd Heber
parent
2f7b5d9128
commit
6fc2688b58
@ -9,6 +9,7 @@
|
||||
:pathname #P"test/"
|
||||
:components ((:file "package")
|
||||
(:file "common")
|
||||
#|
|
||||
(:file "combinations-test")
|
||||
(:file "various-test")
|
||||
(:file "chain-complexes-test")
|
||||
@ -24,4 +25,6 @@
|
||||
(:file "bar-test")
|
||||
(:file "cartesian-products-test")
|
||||
(:file "cones-test")
|
||||
(:file "cl-space-efhm-test")))
|
||||
(:file "cl-space-efhm-test")
|
||||
|#
|
||||
(:file "tensor-products-test")))
|
||||
|
||||
13
package.lisp
13
package.lisp
@ -19,6 +19,7 @@
|
||||
*LIST-LIST*
|
||||
*TC*
|
||||
*TDD*
|
||||
*TNPR-WITH-DEGREES*
|
||||
|
||||
;; bar.lisp
|
||||
|
||||
@ -88,6 +89,7 @@
|
||||
|
||||
;; cl-space-efhm.lisp
|
||||
|
||||
CS-HAT-T-U
|
||||
CS-HAT-U-T
|
||||
|
||||
;; classes.lisp
|
||||
@ -118,6 +120,7 @@
|
||||
ORGN
|
||||
REDUCTION
|
||||
RRDCT
|
||||
SORC
|
||||
TCC
|
||||
TNPR
|
||||
|
||||
@ -258,6 +261,16 @@
|
||||
SPHERE
|
||||
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
|
||||
|
||||
+EMPTY-LIST+
|
||||
|
||||
@ -1,3 +1,6 @@
|
||||
|
||||
(DECLAIM (OPTIMIZE (speed 0) (space 0) (debug 3)))
|
||||
|
||||
(require 'asdf)
|
||||
|
||||
(asdf:operate 'asdf:load-op 'kenzo-test)
|
||||
|
||||
@ -7,7 +7,6 @@
|
||||
(values))
|
||||
|
||||
;;(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!
|
||||
|
||||
|
||||
@ -12,351 +12,252 @@
|
||||
(type tnpr tnpr) (stream stream)
|
||||
(ignore depth))
|
||||
(the tnpr
|
||||
(progn
|
||||
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
|
||||
(format stream
|
||||
"<TnPr~:[~*~; ~D~] ~A~:[~*~; ~D~] ~A>"
|
||||
*tnpr-with-degrees* degr1 gnrt1
|
||||
*tnpr-with-degrees* degr2 gnrt2))
|
||||
tnpr)))
|
||||
(progn
|
||||
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
|
||||
(format stream
|
||||
"<TnPr~:[~*~; ~D~] ~A~:[~*~; ~D~] ~A>"
|
||||
*tnpr-with-degrees* degr1 gnrt1
|
||||
*tnpr-with-degrees* degr2 gnrt2))
|
||||
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)
|
||||
(declare (type cmbn cmbn1 cmbn2))
|
||||
(the cmbn
|
||||
(with-cmbn (degr1 list1) cmbn1
|
||||
(with-cmbn (degr2 list2) cmbn2
|
||||
(make-cmbn
|
||||
:degr (+ degr1 degr2)
|
||||
:list (mapcan
|
||||
#'(lambda (term1)
|
||||
(declare (type term term1))
|
||||
(the list
|
||||
(with-term (cffc1 gnrt1) term1
|
||||
(mapcar
|
||||
#'(lambda (term2)
|
||||
(declare (type term term2))
|
||||
(the term
|
||||
(term
|
||||
(* cffc1 (cffc term2))
|
||||
(tnpr degr1 gnrt1 degr2 (gnrt term2)))))
|
||||
list2))))
|
||||
list1))))))
|
||||
#|
|
||||
(setf *tnpr-with-degrees* t)
|
||||
(2cmbn-tnpr (cmbn 2 3 'a 4 'b -5 'c) (cmbn 3 4 'x -3 'y 2 'z)))
|
||||
|#
|
||||
|
||||
(declare (type cmbn cmbn1 cmbn2))
|
||||
(the cmbn
|
||||
(with-cmbn
|
||||
(degr1 list1) cmbn1
|
||||
(with-cmbn
|
||||
(degr2 list2) cmbn2
|
||||
(make-cmbn
|
||||
:degr (+ degr1 degr2)
|
||||
:list (mapcan
|
||||
#'(lambda (term1)
|
||||
(declare (type term term1))
|
||||
(the list
|
||||
(with-term
|
||||
(cffc1 gnrt1) term1
|
||||
(mapcar
|
||||
#'(lambda (term2)
|
||||
(declare (type term term2))
|
||||
(the term
|
||||
(term
|
||||
(* cffc1 (cffc term2))
|
||||
(tnpr degr1 gnrt1 degr2
|
||||
(gnrt term2)))))
|
||||
list2))))
|
||||
list1))))))
|
||||
|
||||
#|
|
||||
(DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2)
|
||||
(declare (type cmprf cmpr1 cmpr2))
|
||||
(flet ((rslt (tnpr1 tnpr2)
|
||||
(declare (type tnpr tnpr1 tnpr2))
|
||||
(let ((left-cons-1 (cadr tnpr1))
|
||||
(left-cons-2 (cadr tnpr2)))
|
||||
(declare (cons left-cons-1 left-cons-2))
|
||||
(lexico
|
||||
(f-cmpr (car left-cons-1) (car left-cons-2))
|
||||
(funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2))
|
||||
(funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2))))))
|
||||
(the cmprf #'rslt)))
|
||||
(declare (type cmprf cmpr1 cmpr2))
|
||||
(flet ((rslt (tnpr1 tnpr2)
|
||||
(declare (type tnpr tnpr1 tnpr2))
|
||||
(let ((left-cons-1 (cadr tnpr1))
|
||||
(left-cons-2 (cadr tnpr2)))
|
||||
(declare (cons left-cons-1 left-cons-2))
|
||||
(lexico
|
||||
(f-cmpr (car left-cons-1) (car left-cons-2))
|
||||
(funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2))
|
||||
(funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2))))))
|
||||
(the cmprf #'rslt)))
|
||||
|#
|
||||
(DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2)
|
||||
(declare (type cmprf cmpr1 cmpr2))
|
||||
(flet ((rslt (tnpr1 tnpr2)
|
||||
(declare (type tnpr tnpr1 tnpr2))
|
||||
(the cmpr
|
||||
(lexico
|
||||
(f-cmpr (degr1 tnpr1) (degr1 tnpr2))
|
||||
(funcall cmpr1 (gnrt1 tnpr1) (gnrt1 tnpr2))
|
||||
(funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2))))))
|
||||
(lexico
|
||||
(f-cmpr (degr1 tnpr1) (degr1 tnpr2))
|
||||
(funcall cmpr1 (gnrt1 tnpr1) (gnrt1 tnpr2))
|
||||
(funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2))))))
|
||||
(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)
|
||||
(declare (type basis basis1 basis2))
|
||||
(when (or (eq basis1 :locally-effective)
|
||||
(eq basis2 :locally-effective))
|
||||
(return-from tnsr-prdc-basis :locally-effective))
|
||||
(flet ((rslt (degr)
|
||||
(declare (fixnum degr))
|
||||
(the list
|
||||
(declare (type basis basis1 basis2))
|
||||
(when (or (eq basis1 :locally-effective)
|
||||
(eq basis2 :locally-effective))
|
||||
(return-from tnsr-prdc-basis :locally-effective))
|
||||
(flet ((rslt (degr)
|
||||
(declare (fixnum degr))
|
||||
(the list
|
||||
(progn
|
||||
(when (minusp degr)
|
||||
(return-from rslt +empty-list+))
|
||||
(mapcan
|
||||
#'(lambda (degr1)
|
||||
(declare (fixnum degr1))
|
||||
(let* ((basis1 (funcall basis1 degr1))
|
||||
(degr2 (- degr degr1))
|
||||
(basis2 (funcall basis2 degr2)))
|
||||
(declare
|
||||
(fixnum degr2)
|
||||
(list basis1 basis2))
|
||||
(the list
|
||||
(mapcan
|
||||
#'(lambda (gnrt1)
|
||||
(declare (type gnrt gnrt1))
|
||||
(the list
|
||||
(mapcar
|
||||
#'(lambda (gnrt2)
|
||||
(declare (type gnrt gnrt2))
|
||||
(the tnpr
|
||||
(tnpr degr1 gnrt1 degr2 gnrt2)))
|
||||
basis2)))
|
||||
basis1))))
|
||||
(<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))))
|
||||
|#
|
||||
(when (minusp degr)
|
||||
(return-from rslt +empty-list+))
|
||||
(mapcan
|
||||
#'(lambda (degr1)
|
||||
(declare (fixnum degr1))
|
||||
(let* ((basis1 (funcall basis1 degr1))
|
||||
(degr2 (- degr degr1))
|
||||
(basis2 (funcall basis2 degr2)))
|
||||
(declare
|
||||
(fixnum degr2)
|
||||
(list basis1 basis2))
|
||||
(the list
|
||||
(mapcan
|
||||
#'(lambda (gnrt1)
|
||||
(declare (type gnrt gnrt1))
|
||||
(the list
|
||||
(mapcar
|
||||
#'(lambda (gnrt2)
|
||||
(declare (type gnrt gnrt2))
|
||||
(the tnpr
|
||||
(tnpr degr1 gnrt1 degr2
|
||||
gnrt2)))
|
||||
basis2)))
|
||||
basis1))))
|
||||
(<a-b> 0 degr))))))
|
||||
(the basis #'rslt)))
|
||||
|
||||
|
||||
(DEFUN TNSR-PRDC-INTR-DFFR (dffr1 dffr2)
|
||||
(declare (type morphism dffr1 dffr2))
|
||||
(flet ((rslt (degr tnpr)
|
||||
(declare
|
||||
(fixnum degr)
|
||||
(type tnpr tnpr))
|
||||
(the cmbn
|
||||
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
|
||||
(let ((degr1-1 (1- degr1))
|
||||
(degr2-1 (1- degr2))
|
||||
(sign (oddp degr1))
|
||||
(list1 (cmbn-list (gnrt-? dffr1 degr1 gnrt1)))
|
||||
(list2 (cmbn-list (gnrt-? dffr2 degr2 gnrt2))))
|
||||
(declare
|
||||
(declare (type morphism dffr1 dffr2))
|
||||
(flet ((rslt (degr tnpr)
|
||||
(declare
|
||||
(fixnum degr)
|
||||
(type tnpr tnpr))
|
||||
(the cmbn
|
||||
(with-tnpr
|
||||
(degr1 gnrt1 degr2 gnrt2) tnpr
|
||||
(let ((degr1-1 (1- degr1))
|
||||
(degr2-1 (1- degr2))
|
||||
(sign (oddp degr1))
|
||||
(list1 (cmbn-list (gnrt-? dffr1 degr1 gnrt1)))
|
||||
(list2 (cmbn-list (gnrt-? dffr2 degr2 gnrt2))))
|
||||
(declare
|
||||
(fixnum degr1-1 degr2-1)
|
||||
(boolean sign)
|
||||
(list list1 list2))
|
||||
(make-cmbn
|
||||
:degr (1- degr)
|
||||
:list (nconc
|
||||
(mapcar
|
||||
#'(lambda (term1)
|
||||
(declare (type term term1))
|
||||
(with-term (cffc1 gnrt1) term1
|
||||
(term cffc1
|
||||
(tnpr degr1-1 gnrt1 degr2 gnrt2))))
|
||||
list1)
|
||||
(mapcar
|
||||
#'(lambda (term2)
|
||||
(declare (type term term2))
|
||||
(with-term (cffc2 gnrt2) term2
|
||||
(term (if sign (- cffc2) cffc2)
|
||||
(tnpr degr1 gnrt1 degr2-1 gnrt2))))
|
||||
list2))))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
(make-cmbn
|
||||
:degr (1- degr)
|
||||
:list (nconc
|
||||
(mapcar
|
||||
#'(lambda (term1)
|
||||
(declare (type term term1))
|
||||
(with-term
|
||||
(cffc1 gnrt1) term1
|
||||
(term cffc1 (tnpr degr1-1 gnrt1
|
||||
degr2 gnrt2))))
|
||||
list1)
|
||||
(mapcar
|
||||
#'(lambda (term2)
|
||||
(declare (type term term2))
|
||||
(with-term (cffc2 gnrt2) term2
|
||||
(term (if sign (- cffc2) cffc2)
|
||||
(tnpr degr1 gnrt1
|
||||
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))
|
||||
|
||||
(DEFMETHOD TNSR-PRDC ((chcm1 chain-complex) (chcm2 chain-complex))
|
||||
(the chain-complex
|
||||
(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
|
||||
(the chain-complex
|
||||
(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
|
||||
(type cmprf cmpr2)
|
||||
(type basis basis2)
|
||||
(type morphism dffr2))
|
||||
(let ((rslt
|
||||
(build-chcm
|
||||
:cmpr (tnsr-prdc-cmpr cmpr1 cmpr2)
|
||||
:basis (tnsr-prdc-basis basis1 basis2)
|
||||
:intr-dffr (tnsr-prdc-intr-dffr dffr1 dffr2)
|
||||
:strt :gnrt
|
||||
:orgn `(tnsr-prdc ,chcm1 ,chcm2))))
|
||||
(declare (type chain-complex rslt))
|
||||
(if (and (slot-boundp chcm1 'bsgn)
|
||||
(slot-boundp chcm2 'bsgn))
|
||||
(setf (slot-value rslt 'bsgn)
|
||||
(tnpr 0 (bsgn chcm1) 0 (bsgn chcm2)))
|
||||
(slot-makunbound rslt 'bsgn))
|
||||
rslt)))))
|
||||
(let ((rslt
|
||||
(build-chcm
|
||||
:cmpr (tnsr-prdc-cmpr cmpr1 cmpr2)
|
||||
:basis (tnsr-prdc-basis basis1 basis2)
|
||||
:intr-dffr (tnsr-prdc-intr-dffr dffr1 dffr2)
|
||||
:strt :gnrt
|
||||
:orgn `(tnsr-prdc ,chcm1 ,chcm2))))
|
||||
(declare (type chain-complex rslt))
|
||||
(if (and (slot-boundp chcm1 'bsgn)
|
||||
(slot-boundp chcm2 'bsgn))
|
||||
(setf (slot-value rslt 'bsgn)
|
||||
(tnpr 0 (bsgn chcm1) 0 (bsgn chcm2)))
|
||||
(slot-makunbound rslt 'bsgn))
|
||||
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)
|
||||
(declare
|
||||
(type morphism mrph1 mrph2))
|
||||
(let ((mrph2-sign (oddp (degr mrph2))))
|
||||
(declare (type boolean mrph2-sign))
|
||||
(flet ((rslt (degr tnpr)
|
||||
(declare
|
||||
(ignore degr)
|
||||
(type tnpr tnpr))
|
||||
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
|
||||
(let ((rslt (2cmbn-tnpr
|
||||
(gnrt-? mrph1 degr1 gnrt1)
|
||||
(gnrt-? mrph2 degr2 gnrt2))))
|
||||
(declare (type cmbn rslt))
|
||||
(when (and mrph2-sign
|
||||
(oddp degr1))
|
||||
(mapc #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(setf (the fixnum (cffc term))
|
||||
(the fixnum (- (cffc term)))))
|
||||
(cmbn-list rslt)))
|
||||
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)))
|
||||
|#
|
||||
|
||||
(declare
|
||||
(type morphism mrph1 mrph2))
|
||||
(let ((mrph2-sign (oddp (degr mrph2))))
|
||||
(declare (type boolean mrph2-sign))
|
||||
(flet ((rslt (degr tnpr)
|
||||
(declare
|
||||
(ignore degr)
|
||||
(type tnpr tnpr))
|
||||
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
|
||||
(let ((rslt (2cmbn-tnpr
|
||||
(gnrt-? mrph1 degr1 gnrt1)
|
||||
(gnrt-? mrph2 degr2 gnrt2))))
|
||||
(declare (type cmbn rslt))
|
||||
(when (and mrph2-sign
|
||||
(oddp degr1))
|
||||
(mapc #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(setf (the fixnum (cffc term))
|
||||
(the fixnum (- (cffc term)))))
|
||||
(cmbn-list rslt)))
|
||||
rslt))))
|
||||
(the intr-mrph #'rslt))))
|
||||
|
||||
|
||||
(DEFMETHOD TNSR-PRDC ((mrph1 morphism) (mrph2 morphism))
|
||||
(the morphism
|
||||
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr)) mrph1
|
||||
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr)) mrph2
|
||||
(the morphism
|
||||
(progn
|
||||
(when (and (eq 'idnt-mrph (first (orgn mrph1)))
|
||||
(eq 'idnt-mrph (first (orgn mrph2))))
|
||||
(return-from tnsr-prdc
|
||||
(idnt-mrph (tnsr-prdc sorc1 sorc2))))
|
||||
(when (or (eq 'zero-mrph (first (orgn mrph1)))
|
||||
(eq 'zero-mrph (first (orgn mrph2))))
|
||||
(return-from tnsr-prdc
|
||||
(zero-mrph (tnsr-prdc sorc1 sorc2)
|
||||
(tnsr-prdc trgt1 trgt2)
|
||||
(+ degr1 degr2))))
|
||||
(build-mrph
|
||||
:sorc (tnsr-prdc sorc1 sorc2)
|
||||
:trgt (tnsr-prdc trgt1 trgt2)
|
||||
:degr (+ degr1 degr2)
|
||||
:intr (tnsr-prdc-intr mrph1 mrph2)
|
||||
:strt :gnrt
|
||||
:orgn `(tnsr-prdc ,mrph1 ,mrph2))))))))
|
||||
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr)) mrph1
|
||||
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr)) mrph2
|
||||
(the morphism
|
||||
(progn
|
||||
(when (and (eq 'idnt-mrph (first (orgn mrph1)))
|
||||
(eq 'idnt-mrph (first (orgn mrph2))))
|
||||
(return-from tnsr-prdc
|
||||
(idnt-mrph (tnsr-prdc sorc1 sorc2))))
|
||||
(when (or (eq 'zero-mrph (first (orgn mrph1)))
|
||||
(eq 'zero-mrph (first (orgn mrph2))))
|
||||
(return-from tnsr-prdc
|
||||
(zero-mrph (tnsr-prdc sorc1 sorc2)
|
||||
(tnsr-prdc trgt1 trgt2)
|
||||
(+ degr1 degr2))))
|
||||
(build-mrph
|
||||
:sorc (tnsr-prdc sorc1 sorc2)
|
||||
:trgt (tnsr-prdc trgt1 trgt2)
|
||||
:degr (+ degr1 degr2)
|
||||
:intr (tnsr-prdc-intr mrph1 mrph2)
|
||||
:strt :gnrt
|
||||
: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))
|
||||
(the reduction
|
||||
(progn
|
||||
(when (and (eq 'trivial-rdct (first (orgn rdct1)))
|
||||
(eq 'trivial-rdct (first (orgn rdct2))))
|
||||
(return-from tnsr-prdc
|
||||
(progn
|
||||
(when (and (eq 'trivial-rdct (first (orgn rdct1)))
|
||||
(eq 'trivial-rdct (first (orgn rdct2))))
|
||||
(return-from tnsr-prdc
|
||||
(trivial-rdct (tnsr-prdc (bcc rdct1) (bcc rdct2)))))
|
||||
(with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f) (g1 g) (h1 h)) rdct1
|
||||
(declare
|
||||
(type chain-complex tcc1 bcc1)
|
||||
(type morphism f1 g1 h1))
|
||||
(with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f) (g2 g) (h2 h)) rdct2
|
||||
(declare
|
||||
(type chain-complex tcc2 bcc2)
|
||||
(type morphism f2 g2 h2))
|
||||
(build-rdct
|
||||
:f (tnsr-prdc f1 f2)
|
||||
:g (tnsr-prdc g1 g2)
|
||||
:h (add
|
||||
(tnsr-prdc h1 (cmps g2 f2))
|
||||
(tnsr-prdc (idnt-mrph tcc1) h2))
|
||||
:orgn `(tnsr-prdc ,rdct1 ,rdct2)))))))
|
||||
(with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f) (g1 g) (h1 h)) rdct1
|
||||
(declare
|
||||
(type chain-complex tcc1 bcc1)
|
||||
(type morphism f1 g1 h1))
|
||||
(with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f) (g2 g) (h2 h)) rdct2
|
||||
(declare
|
||||
(type chain-complex tcc2 bcc2)
|
||||
(type morphism f2 g2 h2))
|
||||
(build-rdct
|
||||
:f (tnsr-prdc f1 f2)
|
||||
:g (tnsr-prdc g1 g2)
|
||||
:h (add
|
||||
(tnsr-prdc h1 (cmps g2 f2))
|
||||
(tnsr-prdc (idnt-mrph tcc1) h2))
|
||||
: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)
|
||||
(hmeq2 homotopy-equivalence))
|
||||
(the homotopy-equivalence
|
||||
(build-hmeq
|
||||
(build-hmeq
|
||||
:lrdct (tnsr-prdc (lrdct hmeq1) (lrdct hmeq2))
|
||||
:rrdct (tnsr-prdc (rrdct hmeq1) (rrdct hmeq2))
|
||||
:orgn `(tnsr-prdc ,hmeq1 ,hmeq2))))
|
||||
@ -366,10 +267,3 @@
|
||||
(the homotopy-equivalence
|
||||
(tnsr-prdc (efhm (second (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
150
test/tensor-products-test.lisp
Normal 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)))
|
||||
|#
|
||||
Loading…
Reference in New Issue
Block a user