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

Extracted tests from ls-twisted-products.lisp.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-25 16:41:00 -05:00
parent 5528954480
commit f2da8526e4
6 changed files with 572 additions and 499 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -33,6 +33,7 @@
(:file "k-pi-n-test") (:file "k-pi-n-test")
(:file "kan-test") (:file "kan-test")
(:file "loop-spaces-test") (:file "loop-spaces-test")
(:file "ls-twisted-products-test")
(:file "searching-homology-test") (:file "searching-homology-test")
(:file "simplicial-groups-test") (:file "simplicial-groups-test")
(:file "simplicial-mrphs-test") (:file "simplicial-mrphs-test")

14
package.lisp
View File

@ -121,6 +121,7 @@
APOWR APOWR
BCC BCC
BRGN BRGN
BSPN
CBGN CBGN
CHAIN-COMPLEX CHAIN-COMPLEX
CMBN-CMBN CMBN-CMBN
@ -139,6 +140,7 @@
HOMOTOPY-EQUIVALENCE HOMOTOPY-EQUIVALENCE
IABSM IABSM
KAN KAN
LOOP-LIST
LRDCT LRDCT
MAKE-ABAR MAKE-ABAR
MAKE-ALLP MAKE-ALLP
@ -340,6 +342,17 @@
NORMALIZE-LOOP NORMALIZE-LOOP
UNNORMALIZE-LOOP UNNORMALIZE-LOOP
;; ls-twisted-products.lisp
ABSM-LOOPABSM
CRTS-CONTRACTION
CRTS-CONTRACTION-INTR
DTAU-D-INTR
POP-FIRST-ABSM
SZCZARBA
TNPR-CONTRACTION
TWISTED-CRTS-PRDC
;; macros.lisp ;; macros.lisp
-1-EXPT-N -1-EXPT-N
@ -366,6 +379,7 @@
F F
DFFR DFFR
DGNL DGNL
GMSM1
GNRT GNRT
GRIN GRIN
GRML GRML

765
src/ls-twisted-products.lisp
View File

@ -12,514 +12,371 @@
;; a loop-absm of dimension (1- DMNS). ;; a loop-absm of dimension (1- DMNS).
(DEFUN ABSM-LOOPABSM (cmpr dmns absm loop-absm) (DEFUN ABSM-LOOPABSM (cmpr dmns absm loop-absm)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(fixnum dmns) ;; dimension of ABSM (fixnum dmns) ;; dimension of ABSM
(type absm absm loop-absm)) (type absm absm loop-absm))
(the absm (the absm
(with-absm (dgop1 gmsm1) absm (with-absm
(when (logbitp (1- dmns) dgop1) (dgop1 gmsm1) absm
(return-from absm-loopabsm loop-absm)) (when (logbitp (1- dmns) dgop1)
(with-absm (dgop2 loop2) loop-absm (return-from absm-loopabsm loop-absm))
(let ((iloop2 (loop-list loop2))) (with-absm
(declare (list iloop2)) (dgop2 loop2) loop-absm
(unless iloop2 (let ((iloop2 (loop-list loop2)))
(return-from absm-loopabsm (declare (list iloop2))
(absm dgop1 (make-loop :list (list (apowr 0 gmsm1 +1)))))) (unless iloop2
(let ((apowr (first iloop2))) (return-from absm-loopabsm
(declare (type apowr apowr)) (absm dgop1 (make-loop :list (list (apowr 0 gmsm1 +1))))))
(with-apowr (dgop22 gmsm2 expn2) apowr (let ((apowr (first iloop2)))
(if (and (= dgop1 (dgop*dgop dgop2 dgop22)) (declare (type apowr apowr))
(eq :equal (funcall cmpr gmsm1 gmsm2))) (with-apowr
;; the absm is eaten by the first component of the loop (dgop22 gmsm2 expn2) apowr
(if (= -1 expn2) (if (and (= dgop1 (dgop*dgop dgop2 dgop22))
;; the first item of the loop disappears. (eq :equal (funcall cmpr gmsm1 gmsm2)))
(let ((iloop2-rest (rest iloop2))) ;; the absm is eaten by the first component of the loop
(if iloop2-rest (if (= -1 expn2)
(let ((loop-rest (normalize-loop (1- dmns) iloop2-rest))) ;; the first item of the loop disappears.
(declare (type absm loop-rest)) (let ((iloop2-rest (rest iloop2)))
(absm (dgop*dgop dgop2 (dgop loop-rest)) (gmsm loop-rest))) (if iloop2-rest
(absm (mask (1- dmns)) +null-loop+))) (let ((loop-rest (normalize-loop
;; the exponent of the first item is increased by 1 (1- dmns) iloop2-rest)))
(absm dgop2 (make-loop :list (cons (apowr dgop22 gmsm2 (1+ expn2)) (declare (type absm loop-rest))
(rest iloop2))))) (absm (dgop*dgop dgop2 (dgop loop-rest))
;; a concatenation must be done (gmsm loop-rest)))
(multiple-value-bind (dgop dgop1 dgop2) (extract-common-dgop dgop1 dgop2) (absm (mask (1- dmns)) +null-loop+)))
(declare (fixnum dgop dgop1 dgop2)) ;; the exponent of the first item is increased by 1
(absm dgop (absm dgop2 (make-loop :list
(make-loop (cons (apowr dgop22
:list (cons (apowr dgop1 gmsm1 +1) gmsm2
(if (zerop dgop2) (1+ expn2))
iloop2 (rest iloop2)))))
(mapcar #'(lambda (apowr) ;; a concatenation must be done
(declare (type apowr apowr)) (multiple-value-bind (dgop dgop1 dgop2)
(cons (dgop*dgop dgop2 (apdgop apowr)) (extract-common-dgop dgop1 dgop2)
(cdr apowr))) (declare (fixnum dgop dgop1 dgop2))
iloop2)))))))))))))) (absm dgop
(make-loop
:list (cons (apowr dgop1 gmsm1 +1)
(if (zerop dgop2)
iloop2
(mapcar
#'(lambda (apowr)
(declare
(type apowr apowr))
(cons (dgop*dgop
dgop2 (apdgop
apowr))
(cdr apowr)))
iloop2))))))))))))))
#|
()
(setf cmpr (cmpr (deltab)))
(absm-loopabsm cmpr 3 (absm 4 7) (absm 7 +null-loop+))
(absm-loopabsm cmpr 3 (absm 0 15) (absm 7 +null-loop+))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 4)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 4 1 12 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 -1 1 12 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 4)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 2 7 4 1 14 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 2 7 -1))) ;; in principle illegal but works
(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 2 7 -1 1 14 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 0 15 -1 1 14 -1)))
(absm-loopabsm cmpr 3 (absm 0 15) (absm 2 (loop3 0 7 -1 0 14 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 28 -1 0 14 -1)))
|#
(DEFUN TWISTED-CRTS-PRDC-FACE (cmpr space-face loop-space-face non-twisted-face) (DEFUN TWISTED-CRTS-PRDC-FACE (cmpr space-face loop-space-face non-twisted-face)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type face space-face loop-space-face non-twisted-face)) (type face space-face loop-space-face non-twisted-face))
(flet ((rslt (indx dmns crpr) (flet ((rslt (indx dmns crpr)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type crpr crpr)) (type crpr crpr))
(the absm (the absm
(progn (progn
(unless (= indx dmns) (unless (= indx dmns)
(return-from rslt (return-from rslt
(funcall non-twisted-face indx dmns crpr))) (funcall non-twisted-face indx dmns crpr)))
(with-crpr (absm1 absm2) crpr (with-crpr (absm1 absm2) crpr
(let ((face1 (a-face4 space-face dmns dmns absm1)) (let ((face1 (a-face4 space-face dmns dmns absm1))
(face2 (a-face4 loop-space-face dmns dmns absm2))) (face2 (a-face4 loop-space-face dmns dmns
(declare (type absm face1 face2)) absm2)))
(setf face2 (absm-loopabsm cmpr dmns absm1 face2)) (declare (type absm face1 face2))
(2absm-acrpr face1 face2))))))) (setf face2 (absm-loopabsm cmpr dmns absm1
(the face #'rslt))) face2))
(2absm-acrpr face1 face2)))))))
(the face #'rslt)))
(DEFUN TWISTED-CRTS-PRDC (space (DEFUN TWISTED-CRTS-PRDC (space
&aux (loop-space (loop-space space)) &aux (loop-space (loop-space space))
(crts-prdc (crts-prdc space loop-space))) (crts-prdc (crts-prdc space loop-space)))
(declare (type simplicial-set space loop-space crts-prdc)) (declare (type simplicial-set space loop-space crts-prdc))
(the simplicial-set (the simplicial-set
(with-slots ((space-cmpr cmpr) (space-face face)) space (with-slots ((space-cmpr cmpr) (space-face face)) space
(declare (declare
(type cmprf space-cmpr) (type cmprf space-cmpr)
(type face space-face)) (type face space-face))
(with-slots ((loop-space-face face)) loop-space (with-slots ((loop-space-face face)) loop-space
(declare (type face loop-space-face)) (declare (type face loop-space-face))
(with-slots ((crts-prdc-cmpr cmpr) basis bsgn (crts-prdc-face face)) crts-prdc (with-slots ((crts-prdc-cmpr cmpr) basis bsgn (crts-prdc-face face))
(declare crts-prdc
(type cmprf crts-prdc-cmpr) (declare
(type basis basis) (type cmprf crts-prdc-cmpr)
(type face crts-prdc-face) (type basis basis)
(type gmsm bsgn)) (type face crts-prdc-face)
(let ((rslt (build-smst (type gmsm bsgn))
:cmpr crts-prdc-cmpr (let ((rslt (build-smst
:basis basis :cmpr crts-prdc-cmpr
:bspn bsgn :basis basis
:face (twisted-crts-prdc-face :bspn bsgn
space-cmpr space-face loop-space-face crts-prdc-face) :face (twisted-crts-prdc-face
:orgn `(twisted-crts-prdc ,space)))) space-cmpr space-face loop-space-face
(setf (slot-value rslt 'grmd) crts-prdc) crts-prdc-face)
rslt)))))) :orgn `(twisted-crts-prdc ,space))))
(setf (slot-value rslt 'grmd) crts-prdc)
rslt))))))
#|
(setf p (r-proj-space 3))
(setf tw (twisted-crts-prdc p))
(defun random-apowr (dmns max-expn)
(loop
(let* ((dgop (random (2-exp (1- dmns))))
(gmsm (- dmns (logcount dgop))))
(unless (< 0 gmsm 3)
(return-from random-apowr
(apowr dgop gmsm (srandom max-expn)))))))
(defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy)
(random-apowr (1+ dmns) max-expn))
(make-list length)))
(defun random-crpr (dmns max-expn length)
(loop
(let ((loop (normalize-loop dmns (random-niloop dmns max-expn length)))
(dgop (random (2-exp dmns))))
(let ((absm (2absm-acrpr (absm dgop (- dmns (logcount dgop))) loop)))
(when (and (zerop (dgop absm))
(not (< (gmsm1 (gmsm absm)) 3)))
(return (gmsm absm)))))))
(setf cmpr (cmpr tw))
(defun random-cmbn (degr max-cffc max-expn loop-length cmbn-length)
(apply #'nterm-add cmpr degr
(mapcar #'(lambda (dummy)
(term (srandom max-cffc) (random-crpr degr max-expn loop-length)))
(make-list cmbn-length))))
(setf c (random-cmbn 8 10 4 4 100))
(time (? tw (? tw c)))
(time (? tw (? tw c)))
|#
(DEFUN DTAU-D-INTR (crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face) (DEFUN DTAU-D-INTR (crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face)
(declare (declare
(type cmprf crts-prdc-cmpr) (type cmprf crts-prdc-cmpr)
(type face crts-prdc-face twisted-crts-prdc-face)) (type face crts-prdc-face twisted-crts-prdc-face))
(flet ((rslt (dmns crpr) (flet ((rslt (dmns crpr)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type crpr crpr)) (type crpr crpr))
(when (zerop dmns) (when (zerop dmns)
(return-from rslt +zero-negative-cmbn+)) (return-from rslt +zero-negative-cmbn+))
(the cmbn (the cmbn
(let ((dmns-1 (1- dmns))) (let ((dmns-1 (1- dmns)))
(declare (fixnum dmns-1)) (declare (fixnum dmns-1))
(when (logbitp dmns-1 (dgop1 crpr)) (when (logbitp dmns-1 (dgop1 crpr))
(return-from rslt (zero-cmbn dmns-1))) (return-from rslt (zero-cmbn dmns-1)))
(let ((face-tau (funcall twisted-crts-prdc-face dmns dmns crpr)) (let ((face-tau (funcall twisted-crts-prdc-face dmns dmns
(face (funcall crts-prdc-face dmns dmns crpr)) crpr))
(sign (-1-expt-n dmns))) (face (funcall crts-prdc-face dmns dmns crpr))
(declare (sign (-1-expt-n dmns)))
(type absm face-tau face) (declare
(fixnum sign)) (type absm face-tau face)
(with-absm (dgop-tau gmsm-tau) face-tau (fixnum sign))
(with-absm (dgop gmsm) face (with-absm
(if (plusp dgop-tau) (dgop-tau gmsm-tau) face-tau
(if (plusp dgop) (with-absm
(zero-cmbn dmns-1) (dgop gmsm) face
(term-cmbn dmns-1 (- sign) gmsm)) (if (plusp dgop-tau)
(if (plusp dgop) (if (plusp dgop)
(term-cmbn dmns-1 sign gmsm-tau) (zero-cmbn dmns-1)
(ecase (funcall crts-prdc-cmpr gmsm-tau gmsm) (term-cmbn dmns-1 (- sign) gmsm))
(:less (if (plusp dgop)
(cmbn dmns-1 sign gmsm-tau (- sign) gmsm)) (term-cmbn dmns-1 sign gmsm-tau)
(:greater (ecase (funcall crts-prdc-cmpr gmsm-tau
(cmbn dmns-1 (- sign) gmsm sign gmsm-tau)) gmsm)
(:equal (:less
(error "Surprise in DTAU-D-INTR.~@ (cmbn dmns-1 sign gmsm-tau (- sign)
gmsm))
(:greater
(cmbn dmns-1 (- sign) gmsm sign
gmsm-tau))
(:equal
(error "Surprise in DTAU-D-INTR.~@
Crpr = ~A~@ Crpr = ~A~@
D-tau = ~A~@ D-tau = ~A~@
D = ~A" D = ~A"
crpr gmsm-tau gmsm)))))))))))) crpr gmsm-tau gmsm))))))))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
#|
(setf d (deltab))
(setf p (crts-prdc d (loop-space d)))
(setf tw (twisted-crts-prdc d))
(setf crts-prdc-cmpr (cmpr p)
crts-prdc-face (face p)
twisted-crts-prdc-face (face tw))
(setf delta (dtau-d-intr crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face))
(funcall delta 3 (crpr 0 15 0 (loop3 0 (- 2048 64) 1)))
(funcall delta 5 (crpr 10 15 5 (loop3 0 (- 2048 64) 1)))
(funcall delta 5 (crpr 5 15 10 (loop3 0 (- 2048 64) 1)))
|#
(DEFUN DTAU-D (space (DEFUN DTAU-D (space
&aux (loop-space (loop-space space)) &aux (loop-space (loop-space space))
(crts-prdc (crts-prdc space loop-space)) (crts-prdc (crts-prdc space loop-space))
(crts-prdc-cmpr (cmpr crts-prdc)) (crts-prdc-cmpr (cmpr crts-prdc))
(crts-prdc-face (face crts-prdc)) (crts-prdc-face (face crts-prdc))
(twisted-crts-prdc (twisted-crts-prdc space)) (twisted-crts-prdc (twisted-crts-prdc space))
(twisted-crts-prdc-face (face twisted-crts-prdc))) (twisted-crts-prdc-face (face twisted-crts-prdc)))
(declare (declare
(type simplicial-set space loop-space crts-prdc twisted-crts-prdc) (type simplicial-set space loop-space crts-prdc twisted-crts-prdc)
(type cmprf crts-prdc-cmpr) (type cmprf crts-prdc-cmpr)
(type face crts-prdc-face twisted-crts-prdc-face)) (type face crts-prdc-face twisted-crts-prdc-face))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc crts-prdc :trgt crts-prdc :degr -1 :sorc crts-prdc :trgt crts-prdc :degr -1
:intr (dtau-d-intr crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face) :intr (dtau-d-intr crts-prdc-cmpr crts-prdc-face
:strt :gnrt twisted-crts-prdc-face)
:orgn `(dtau-d ,space)))) :strt :gnrt
:orgn `(dtau-d ,space))))
(DEFUN SZCZARBA (space (DEFUN SZCZARBA (space
&aux (loop-space (loop-space space)) &aux (loop-space (loop-space space))
(twisted-crts-prdc (twisted-crts-prdc space)) (twisted-crts-prdc (twisted-crts-prdc space))
(ez (ez space loop-space)) (ez (ez space loop-space))
(dtau-d (dtau-d space))) (dtau-d (dtau-d space)))
(declare (declare
(type simplicial-set space loop-space twisted-crts-prdc) (type simplicial-set space loop-space twisted-crts-prdc)
(type reduction ez) (type reduction ez)
(type morphism dtau-d)) (type morphism dtau-d))
(the (values reduction morphism) (the (values reduction morphism)
(multiple-value-bind (szczarba bottom-perturbation) (multiple-value-bind (szczarba bottom-perturbation)
(add ez dtau-d) (add ez dtau-d)
(with-slots (tcc f g h) szczarba (with-slots (tcc f g h) szczarba
(setf tcc twisted-crts-prdc (setf tcc twisted-crts-prdc
(slot-value f 'sorc) twisted-crts-prdc (slot-value f 'sorc) twisted-crts-prdc
(slot-value g 'trgt) twisted-crts-prdc (slot-value g 'trgt) twisted-crts-prdc
(slot-value h 'sorc) twisted-crts-prdc (slot-value h 'sorc) twisted-crts-prdc
(slot-value h 'trgt) twisted-crts-prdc)) (slot-value h 'trgt) twisted-crts-prdc))
(values szczarba bottom-perturbation)))) (values szczarba bottom-perturbation))))
#|
(cat-init)
(setf rdct (szczarba (deltab)))
(pre-check-rdct rdct)
(setf *tc* (cmbn 2 1 (crpr 0 7 0 (loop3 0 (- 512 32) 1)))
*bc* (cmbn 2 1 (tnpr 0 1 2 (loop3 0 (- 512 32) 1))
10 (tnpr 1 (- 4096 1024) 1 (loop3 0 7 1))
100 (tnpr 2 7 0 (loop3 0 (- 4096 1024) 1))))
(check-rdct)
(setf bcc (bcc rdct))
(time (? bcc 5 (tnpr 5 (mask 6) 0 +null-loop+)))
(time (? bcc 6 (tnpr 6 (mask 7) 0 +null-loop+)))
|#
(DEFUN TWISTED-TNSR-PRDC (space (DEFUN TWISTED-TNSR-PRDC (space
&aux (szczarba (szczarba space))) &aux (szczarba (szczarba space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type reduction szczarba)) (type reduction szczarba))
(the chain-complex (the chain-complex
(bcc szczarba))) (bcc szczarba)))
;;; ;;;
;;; The important contraction. ;;; The important contraction.
;;; ;;;
(DEFUN POP-FIRST-ABSM (dmns iloop) (DEFUN POP-FIRST-ABSM (dmns iloop)
(declare (type iloop iloop)) (declare (type iloop iloop))
(the (values (member -1 0 1) (or nil absm) absm) (the (values (member -1 0 1) (or nil absm) absm)
(progn (progn
(unless iloop (unless iloop
(return-from pop-first-absm (return-from pop-first-absm
(values 0 nil iloop))) (values 0 nil iloop)))
(let ((apowr (first iloop)) (let ((apowr (first iloop))
(niloop-rest (rest iloop))) (niloop-rest (rest iloop)))
(declare (declare
(type apowr apowr) (type apowr apowr)
(type iloop niloop-rest)) (type iloop niloop-rest))
(with-apowr (dgop gmsm expn) apowr (with-apowr
(let ((popped-absm (absm dgop gmsm))) (dgop gmsm expn) apowr
(declare (type absm popped-absm)) (let ((popped-absm (absm dgop gmsm)))
(cond ((< expn -1) (declare (type absm popped-absm))
(values -1 popped-absm (cond ((< expn -1)
(absm 0 (values -1 popped-absm
(make-loop (absm 0
:list (cons (apowr dgop gmsm (1+ expn)) niloop-rest))))) (make-loop
((> expn +1) :list (cons (apowr dgop gmsm (1+ expn))
(values +1 popped-absm niloop-rest)))))
(absm 0 ((> expn +1)
(make-loop (values +1 popped-absm
:list (cons (apowr dgop gmsm (1- expn)) niloop-rest))))) (absm 0
(t (make-loop
(values expn popped-absm :list (cons (apowr dgop gmsm (1- expn))
(normalize-loop dmns niloop-rest)))))))))) niloop-rest)))))
(t
(values expn popped-absm
(normalize-loop dmns niloop-rest))))))))))
#|
()
(pop-first-absm 4 (cdr +null-loop+))
(pop-first-absm 4 (cdr (loop3 0 'a -2)))
(pop-first-absm 4 (cdr (loop3 0 'a +2)))
(pop-first-absm 4 (cdr (loop3 0 'a -1)))
(pop-first-absm 4 (cdr (loop3 0 'a +1)))
(pop-first-absm 4 (cdr (loop3 1 'a -2 2 'b 3)))
(pop-first-absm 4 (cdr (loop3 0 'a +2 2 'b -3)))
(pop-first-absm 4 (cdr (loop3 1 'a -1 2 'b 3)))
(pop-first-absm 4 (cdr (loop3 0 'a +1 2 'b 5)))
(pop-first-absm 4 (cdr (loop3 2 'a -1 1 'b 3)))
(pop-first-absm 4 (cdr (loop3 2 'a +1 1 'b 3)))
|#
(DEFUN CRTS-CONTRACTION-INTR (base-cmpr base-bspn base-face crts-cmpr) (DEFUN CRTS-CONTRACTION-INTR (base-cmpr base-bspn base-face crts-cmpr)
(declare (declare
(type cmprf base-cmpr crts-cmpr) (type cmprf base-cmpr crts-cmpr)
(type gmsm base-bspn) (type gmsm base-bspn)
(type face base-face)) (type face base-face))
(flet ((rslt (n crpr) (flet ((rslt (n crpr)
(declare (declare
(fixnum n) (fixnum n)
(type crpr crpr)) (type crpr crpr))
(the cmbn (the cmbn
(let ((n+1 (1+ n))) (let ((n+1 (1+ n)))
(declare (fixnum n+1)) (declare (fixnum n+1))
(labels ( (labels (
(hh (x-n g-n) (hh (x-n g-n)
(declare (type absm x-n g-n)) (declare (type absm x-n g-n))
(if (bspn-p base-cmpr base-bspn n x-n) (if (bspn-p base-cmpr base-bspn n x-n)
(if (degenerate-p g-n) (if (degenerate-p g-n)
(zero-cmbn n+1) (zero-cmbn n+1)
(h-hat (loop-list (gmsm g-n)))) (h-hat (loop-list (gmsm g-n))))
(if (degenerate-p g-n) (if (degenerate-p g-n)
(h-tilde (1dgnr n x-n) g-n) (h-tilde (1dgnr n x-n) g-n)
(2cmbn-add crts-cmpr (h-hat (loop-list (gmsm g-n))) (2cmbn-add crts-cmpr
(h-tilde (1dgnr n x-n) g-n))))) (h-hat (loop-list (gmsm g-n)))
(h-tilde (x-n+1 g-n) (h-tilde (1dgnr n x-n) g-n)))))
(declare (type absm x-n+1 g-n)) (h-tilde (x-n+1 g-n)
(when (bspn-p base-cmpr base-bspn n+1 x-n+1) (declare (type absm x-n+1 g-n))
(return-from h-tilde (when (bspn-p base-cmpr base-bspn n+1 x-n+1)
(zero-cmbn n+1))) (return-from h-tilde
(do ((i n (1- i)) (zero-cmbn n+1)))
(dgop 0 (+ dgop (2-exp i))) (do ((i n (1- i))
(sign (-1-expt-n+1 n) (- sign)) (dgop 0 (+ dgop (2-exp i)))
(del-i x-n+1 (a-face4 base-face i (1+ i) del-i)) (sign (-1-expt-n+1 n) (- sign))
(rslt (zero-cmbn n+1))) (del-i x-n+1 (a-face4 base-face i (1+ i)
((minusp i) rslt) del-i))
(declare (rslt (zero-cmbn n+1)))
(fixnum i dgop sign) ((minusp i) rslt)
(type absm del-i) (declare
(type cmbn rslt)) (fixnum i dgop sign)
(let ((absm1 (ndgnr dgop del-i)) (type absm del-i)
(loop-absm2 (1dgnr i g-n))) (type cmbn rslt))
(declare (type absm absm1 loop-absm2)) (let ((absm1 (ndgnr dgop del-i))
(unless (plusp (logand (dgop absm1) (dgop loop-absm2))) (loop-absm2 (1dgnr i g-n)))
(dstr-add-term-to-cmbn (declare (type absm absm1 loop-absm2))
crts-cmpr (unless (plusp (logand (dgop absm1)
sign (crpr absm1 loop-absm2) (dgop loop-absm2)))
rslt))))) (dstr-add-term-to-cmbn
(h-hat (g-n) crts-cmpr
(declare (type iloop g-n)) ;;; *** sign (crpr absm1 loop-absm2)
(multiple-value-bind (expn y-n+1 gp-n) (pop-first-absm n g-n) rslt)))))
(declare (h-hat (g-n)
(fixnum expn) (declare (type iloop g-n)) ;;; ***
(type (or absm null) y-n+1 gp-n)) (multiple-value-bind (expn y-n+1 gp-n)
(ecase expn (pop-first-absm n g-n)
(0 (zero-cmbn (1+ n))) (declare
(+1 (fixnum expn)
(let ((h-tildes (2cmbn-sbtr crts-cmpr (type (or absm null) y-n+1 gp-n))
(h-tilde y-n+1 gp-n) (ecase expn
(h-tilde (0 (zero-cmbn (1+ n)))
(1dgnr n (a-face4 base-face (1+ n) (1+ n) y-n+1)) (+1
(absm 0 (make-loop :list g-n)))))) (let ((h-tildes
(declare (type cmbn h-tildes)) (2cmbn-sbtr
(if (degenerate-p gp-n) crts-cmpr (h-tilde y-n+1 gp-n)
h-tildes (h-tilde (1dgnr n (a-face4 base-face
(2cmbn-add crts-cmpr (h-hat (loop-list (gmsm gp-n))) h-tildes)))) (1+ n)
(-1 (1+ n)
(let ((next-x-n (a-face4 base-face (1+ n) (1+ n) y-n+1)) y-n+1))
(h-tilde (h-tilde y-n+1 (absm 0 (make-loop :list g-n))))) (absm 0 (make-loop :list
(declare g-n))))))
(type absm next-x-n) (declare (type cmbn h-tildes))
(type cmbn h-tilde)) (if (degenerate-p gp-n)
(if (zerop (logand (dgop next-x-n) (dgop gp-n))) h-tildes
(2cmbn-sbtr crts-cmpr (2cmbn-add crts-cmpr
(hh next-x-n gp-n) h-tilde) (h-hat (loop-list
(cmbn-opps h-tilde)))))))) (gmsm gp-n)))
h-tildes))))
(with-crpr (absm1 loop-absm2) crpr (-1
(hh absm1 loop-absm2))))))) (let ((next-x-n (a-face4 base-face (1+ n)
(1+ n) y-n+1))
(h-tilde
(h-tilde y-n+1
(absm 0 (make-loop
:list g-n)))))
(declare
(type absm next-x-n)
(type cmbn h-tilde))
(if (zerop (logand (dgop next-x-n)
(dgop gp-n)))
(2cmbn-sbtr crts-cmpr
(hh next-x-n gp-n) h-tilde)
(cmbn-opps h-tilde))))))))
(with-crpr (absm1 loop-absm2) crpr
(hh absm1 loop-absm2)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
#|
()
(cat-init)
(setf delta (deltab))
(setf tw (twisted-crts-prdc delta))
(setf d (bndr tw))
(setf base-cmpr (cmpr delta)
base-bspn (bspn delta)
base-face (face delta)
crts-cmpr (cmpr tw))
(setf r (crts-contraction-intr base-cmpr base-bspn base-face crts-cmpr))
(setf h (build-mrph :sorc tw :trgt tw :degr +1
:intr r :strt :gnrt :orgn `(crts-contraction ,delta)))
(setf z (i-sbtr (idnt-mrph tw) (cmps d h) (cmps h d)))
(? z 0 (crpr 0 1 0 +null-loop+))
(funcall r 0 (crpr 0 1 0 (loop3 0 96 1)))
(? z 0 (crpr 0 1 0 (loop3 0 96 1)))
(? z 0 (crpr 0 1 0 (loop3 0 96 1 0 (+ 256 128) 1)))
(? z 0 (crpr 0 1 0 (loop3 0 96 1 0 (+ 256 128) 1 0 (+ 512 1024) 1)))
(? z 0 (crpr 0 1 0 (loop3 0 96 2)))
(? z 1 (crpr 0 3 0 (loop3 0 (+ 32 64 128) 1)))
(? z 2 (crpr 0 7 0 (loop3 0 (+ 32 64 128 256) 1)))
(? z 3 (crpr 2 7 1 (loop3 2 (+ 32 64 128) 2 4 (+ 32 64 128) -2)))
(? z 3 (crpr 2 7 4 (loop3 2 (+ 32 64 128) 2 1 (+ 32 64 128) -2)))
(? z 3 (crpr 2 7 1 (loop3 2 (+ 32 64 128) -2 4 (+ 32 64 128) 2)))
(? z 3 (crpr 2 7 4 (loop3 2 (+ 32 64 128) -2 1 (+ 32 64 128) 2)))
(? z 3 (crpr 1 7 2 (loop3 2 (+ 32 64 128) 2 4 (+ 32 64 128) -2)))
(? z 3 (crpr 4 7 2 (loop3 2 (+ 32 64 128) 2 1 (+ 32 64 128) -2)))
(? z 3 (crpr 1 7 2 (loop3 2 (+ 32 64 128) -2 4 (+ 32 64 128) 2)))
(? z 3 (crpr 4 7 2 (loop3 2 (+ 32 64 128) -2 1 (+ 32 64 128) 2)))
|#
#|
(cat-init)
(setf p (r-proj-space 3))
(setf tw (twisted-crts-prdc p))
(setf r (crts-contraction-intr (cmpr p) (bspn p) (face p) (cmpr tw)))
(defun random-apowr (dmns max-expn)
(loop
(let* ((dgop (random (2-exp (1- dmns))))
(gmsm (- dmns (logcount dgop))))
(unless (< 0 gmsm 3)
(return-from random-apowr
(apowr dgop gmsm (srandom max-expn)))))))
(defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy)
(random-apowr (1+ dmns) max-expn))
(make-list length)))
(defun random-crpr (dmns max-expn length)
(loop
(let ((loop (normalize-loop dmns (random-niloop dmns max-expn length)))
(dgop (random (2-exp dmns))))
(let ((absm (2absm-acrpr (absm dgop (- dmns (logcount dgop))) loop)))
(when (and (zerop (dgop absm))
(not (< (gmsm1 (gmsm absm)) 3)))
(return (gmsm absm)))))))
(setf cmpr (cmpr tw))
(defun random-cmbn (degr max-cffc max-expn loop-length cmbn-length)
(apply #'nterm-add cmpr degr
(mapcar #'(lambda (dummy)
(term (srandom max-cffc) (random-crpr degr max-expn loop-length)))
(make-list cmbn-length))))
(setf h (build-mrph :sorc tw :trgt tw :degr +1
:intr r :strt :gnrt :orgn `(crts-contraction ,p)))
(setf d (bndr tw))
(setf z (i-sbtr (idnt-mrph tw) (cmps h d) (cmps d h)))
(setf c (random-cmbn 5 10 2 2 1))
(? z c)
(setf c (random-cmbn 6 10 3 3 3))
(? z c)
(setf c (random-cmbn 7 10 4 4 6))
(? z c)
(setf c (random-cmbn 8 10 4 4 20))
(? z c)
(? h c)
(? d *)
(length *)
|#
(DEFUN CRTS-CONTRACTION (space (DEFUN CRTS-CONTRACTION (space
&aux (twisted-crts-prdc (twisted-crts-prdc space))) &aux (twisted-crts-prdc (twisted-crts-prdc space)))
(declare (type simplicial-set space twisted-crts-prdc)) (declare (type simplicial-set space twisted-crts-prdc))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc twisted-crts-prdc :trgt twisted-crts-prdc :degr +1 :sorc twisted-crts-prdc :trgt twisted-crts-prdc :degr +1
:intr (crts-contraction-intr (cmpr space) (bspn space) (face space) :intr (crts-contraction-intr (cmpr space) (bspn space) (face space)
(cmpr twisted-crts-prdc)) (cmpr twisted-crts-prdc))
:strt :gnrt :strt :gnrt
:orgn `(crts-contraction ,space)))) :orgn `(crts-contraction ,space))))
#|
(setf h (crts-contraction (deltab)))
(setf d (bndr (twisted-crts-prdc (deltab))))
(setf z (i-sbtr (idnt-mrph (sorc d)) (cmps d h) (cmps h d)))
(? z 3 (crpr 4 7 2 (loop3 2 (+ 32 64 128) -2 1 (+ 32 64 128) 2)))
|#
(DEFUN TNPR-CONTRACTION (space (DEFUN TNPR-CONTRACTION (space
&aux &aux
(szczarba (szczarba space)) (szczarba (szczarba space))
(f (f szczarba)) (f (f szczarba))
(g (g szczarba)) (g (g szczarba))
(crts-contraction (crts-contraction space))) (crts-contraction (crts-contraction space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type reduction szczarba) (type reduction szczarba)
(type morphism f g crts-contraction)) (type morphism f g crts-contraction))
(the morphism (the morphism
(i-cmps f crts-contraction g))) (i-cmps f crts-contraction g)))
#|
(cat-init)
(setf delta (deltab))
(setf sz (szczarba (deltab)))
(setf tw (bcc sz))
(setf h (tnpr-contraction delta))
(setf z (i-sbtr (idnt-mrph tw) (cmps tw h) (cmps h tw)))
(time (? z 3 (tnpr 0 1 3 (loop3 0 (mask 5) 2 0 (* 32 (mask 5)) -1))))
(? h 4 (tnpr 0 1 0 (loop3 0 (mask 6) 1)))
|#

79
test/common.lisp
View File

@ -170,22 +170,6 @@
cat:*tc*)))))) cat:*tc*))))))
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (cat:brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(defun aleat-tc () (defun aleat-tc ()
(do ((tdegr 0 (+ tdegr degr)) (do ((tdegr 0 (+ tdegr degr))
(degr (+ 2 (random 3)) (+ 2 (random 3))) (degr (+ 2 (random 3)) (+ 2 (random 3)))
@ -210,3 +194,66 @@
(aleat-tc) (aleat-tc)
(aleat-bc) (aleat-bc)
(check-rdct)) (check-rdct))
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (cat:brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(defun random-apowr (dmns max-expn)
(loop
(let* ((dgop (random (cat:2-exp (1- dmns))))
(gmsm (- dmns (logcount dgop))))
(unless (< 0 gmsm 3)
(return-from random-apowr
(cat:apowr dgop gmsm (cat:srandom max-expn)))))))
(defun random-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
(apply #'cat:nterm-add cmpr degr
(mapcar #'(lambda (dummy)
(cat:term (cat:srandom max-cffc)
(random-crpr degr max-expn loop-length)))
(make-list cmbn-length))))
(defun random-crpr (dmns max-expn length)
(loop
(let ((loop (cat:normalize-loop dmns
(random-niloop dmns max-expn length)))
(dgop (random (cat:2-exp dmns))))
(let ((absm (cat:2absm-acrpr (cat:absm dgop (- dmns (logcount dgop)))
loop)))
(when (and (zerop (cat:dgop absm))
(not (< (cat:gmsm1 (cat:gmsm absm)) 3)))
(return (cat:gmsm absm)))))))
(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
(do ((rslt cat:+empty-list+ (cons term rslt))
(i cmbn-length (1- i))
(term))
((zerop i)
(apply #'cat:nterm-add cmpr degr rslt))
(setf term
(cat:term (cat:srandom max-cffc)
(cat:make-loop :list (random-niloop degr max-expn
loop-length))))))
(defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy)
(random-apowr (1+ dmns) max-expn))
(make-list length)))

27
test/loop-spaces-test.lisp
View File

@ -179,33 +179,6 @@
(cat:check-kan g i 4 (remove (nth i hat) hat)))))) (cat:check-kan g i 4 (remove (nth i hat) hat))))))
(defun random-apowr (dmns max-expn)
(loop
(let* ((dgop (random (cat:2-exp (1- dmns))))
(gmsm (- dmns (logcount dgop))))
(unless (< 0 gmsm 3)
(return-from random-apowr
(cat:apowr dgop gmsm (cat:srandom max-expn)))))))
(defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy)
(random-apowr (1+ dmns) max-expn))
(make-list length)))
(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
(do ((rslt cat:+empty-list+ (cons term rslt))
(i cmbn-length (1- i))
(term))
((zerop i)
(apply #'cat:nterm-add cmpr degr rslt))
(setf term
(cat:term (cat:srandom max-cffc)
(cat:make-loop :list (random-niloop degr max-expn
loop-length))))))
(test loop-space2 (test loop-space2
(cat:cat-init) (cat:cat-init)
(let* ((p (cat:r-proj-space 3)) (let* ((p (cat:r-proj-space 3))

181
test/ls-twisted-products-test.lisp Normal file
View File

@ -0,0 +1,181 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(test absm-loopabsm
(let ((cmpr (cat:cmpr (cat:deltab))))
(cat:absm-loopabsm cmpr 3 (cat:absm 4 7) (cat:absm 7 cat:+null-loop+))
(cat:absm-loopabsm cmpr 3 (cat:absm 0 15) (cat:absm 7 cat:+null-loop+))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 7 4)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 7 4 1 12 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 7 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 7 -1 1 12 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 7 4)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 0 (cat:loop3 2 7 4 1 14 -1)))
;; in principle illegal but works
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 0 (cat:loop3 2 7 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 0 (cat:loop3 2 7 -1 1 14 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 0 (cat:loop3 0 15 -1 1 14 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 0 15)
(cat:absm 2 (cat:loop3 0 7 -1 0 14 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 28 -1 0 14 -1)))))
(test twisted-crts-prdc
(cat:cat-init)
(let* ((p (cat:r-proj-space 3))
(tw (cat:twisted-crts-prdc p))
(cmpr (cat:cmpr tw))
(c (random-cmbn cmpr 8 10 4 4 100)))
(time (cat:? tw (cat:? tw c)))
(time (cat:? tw (cat:? tw c)))))
(test dtau-d-intr
(cat:cat-init)
(let* ((d (cat:deltab))
(p (cat:crts-prdc d (cat:loop-space d)))
(tw (cat:twisted-crts-prdc d))
(crts-prdc-cmpr (cat:cmpr p))
(crts-prdc-face (cat:face p))
(twisted-crts-prdc-face (cat:face tw))
(delta (cat:dtau-d-intr crts-prdc-cmpr crts-prdc-face
twisted-crts-prdc-face)))
(funcall delta 3 (cat:crpr 0 15 0 (cat:loop3 0 (- 2048 64) 1)))
(funcall delta 5 (cat:crpr 10 15 5 (cat:loop3 0 (- 2048 64) 1)))
(funcall delta 5 (cat:crpr 5 15 10 (cat:loop3 0 (- 2048 64) 1)))))
(test szczarba
(cat:cat-init)
(let ((rdct (cat:szczarba (cat:deltab)))
bcc)
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 2 1 (cat:crpr 0 7 0
(cat:loop3 0 (- 512 32) 1)))
cat:*bc* (cat:cmbn 2 1 (cat:tnpr 0 1 2
(cat:loop3 0 (- 512 32) 1))
10 (cat:tnpr 1 (- 4096 1024) 1
(cat:loop3 0 7 1))
100 (cat:tnpr 2 7 0
(cat:loop3 0 (- 4096 1024) 1))))
(check-rdct)
(setf bcc (cat:bcc rdct))
(time (cat:? bcc 5 (cat:tnpr 5 (cat:mask 6) 0 cat:+null-loop+)))
(time (cat:? bcc 6 (cat:tnpr 6 (cat:mask 7) 0 cat:+null-loop+)))))
(test pop-first-absm
(cat:pop-first-absm 4 (cdr (cat:loop-list cat:+null-loop+)))
(cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a -2))))
(cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a +2))))
(cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a -1))))
(cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a +1))))
(cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 1 'a -2 2 'b 3))))
(cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a +2 2 'b -3))))
(cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 1 'a -1 2 'b 3))))
(cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 0 'a +1 2 'b 5))))
(cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 2 'a -1 1 'b 3))))
(cat:pop-first-absm 4 (cdr (cat:loop-list (cat:loop3 2 'a +1 1 'b 3)))))
(test crts-contraction-intr
(cat:cat-init)
(let* ((delta (cat:deltab))
(tw (cat:twisted-crts-prdc delta))
(d (cat:bndr tw))
(base-cmpr (cat:cmpr delta))
(base-bspn (cat:bspn delta))
(base-face (cat:face delta))
(crts-cmpr (cat:cmpr tw))
(r (cat:crts-contraction-intr base-cmpr base-bspn base-face
crts-cmpr))
(h (cat:build-mrph :sorc tw :trgt tw :degr +1
:intr r :strt :gnrt
:orgn `(crts-contraction ,delta)))
(z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps d h) (cat:cmps h d))))
(cat:? z 0 (cat:crpr 0 1 0 cat:+null-loop+))
(funcall r 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1)))
(cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1)))
(cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1 0 (+ 256 128) 1)))
(cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1 0 (+ 256 128)
1 0 (+ 512 1024) 1)))
(cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 2)))
(cat:? z 1 (cat:crpr 0 3 0 (cat:loop3 0 (+ 32 64 128) 1)))
(cat:? z 2 (cat:crpr 0 7 0 (cat:loop3 0 (+ 32 64 128 256) 1)))
(cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128)
2 4 (+ 32 64 128) -2)))
(cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128)
2 1 (+ 32 64 128) -2)))
(cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128)
-2 4 (+ 32 64 128) 2)))
(cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128)
-2 1 (+ 32 64 128) 2)))
(cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128)
2 4 (+ 32 64 128) -2)))
(cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128)
2 1 (+ 32 64 128) -2)))
(cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128)
-2 4 (+ 32 64 128) 2)))
(cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128)
-2 1 (+ 32 64 128) 2)))))
(test crts-contraction
(cat:cat-init)
(let* ((p (cat:r-proj-space 3))
(tw (cat:twisted-crts-prdc p))
(cmpr (cat:cmpr tw))
(r (cat:crts-contraction-intr (cat:cmpr p) (cat:bspn p)
(cat:face p) (cat:cmpr tw)))
(h (cat:build-mrph :sorc tw :trgt tw :degr +1
:intr r :strt :gnrt
:orgn `(cat:crts-contraction ,p)))
(d (cat:bndr tw))
(z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps h d) (cat:cmps d h)))
(c (random-cmbn cmpr 5 10 2 2 1)))
(cat:? z c)
(setf c (random-cmbn cmpr 6 10 3 3 3))
(cat:? z c)
(setf c (random-cmbn cmpr 7 10 4 4 6))
(cat:? z c)
(setf c (random-cmbn cmpr 8 10 4 4 20))
(cat:? z c)
(cat:? h c)
(cat:? d (cat:? h c))
(print (length (cat:cmbn-list (cat:? d (cat:? h c)))))))
(test crts-contraction1
(let* ((h (cat:crts-contraction (cat:deltab)))
(d (cat:bndr (cat:twisted-crts-prdc (cat:deltab))))
(z (cat:i-sbtr (cat:idnt-mrph (cat:sorc d)) (cat:cmps d h)
(cat:cmps h d))))
(cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128)
-2 1 (+ 32 64 128) 2)))))
(test tnpr-contraction
(cat:cat-init)
(let* ((delta (cat:deltab))
(sz (cat:szczarba (cat:deltab)))
(tw (cat:bcc sz))
(h (cat:tnpr-contraction delta))
(z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps tw h)
(cat:cmps h tw))))
(time (cat:? z 3 (cat:tnpr 0 1 3 (cat:loop3 0 (cat:mask 5)
2 0 (* 32 (cat:mask 5))
-1))))
(cat:? h 4 (cat:tnpr 0 1 0 (cat:loop3 0 (cat:mask 6) 1)))))