Extracted tests from ls-twisted-products.lisp.
This commit is contained in:
Gerd Heber
parent
5528954480
commit
f2da8526e4
@ -33,6 +33,7 @@
|
||||
(:file "k-pi-n-test")
|
||||
(:file "kan-test")
|
||||
(:file "loop-spaces-test")
|
||||
(:file "ls-twisted-products-test")
|
||||
(:file "searching-homology-test")
|
||||
(:file "simplicial-groups-test")
|
||||
(:file "simplicial-mrphs-test")
|
||||
|
||||
14
package.lisp
14
package.lisp
@ -121,6 +121,7 @@
|
||||
APOWR
|
||||
BCC
|
||||
BRGN
|
||||
BSPN
|
||||
CBGN
|
||||
CHAIN-COMPLEX
|
||||
CMBN-CMBN
|
||||
@ -139,6 +140,7 @@
|
||||
HOMOTOPY-EQUIVALENCE
|
||||
IABSM
|
||||
KAN
|
||||
LOOP-LIST
|
||||
LRDCT
|
||||
MAKE-ABAR
|
||||
MAKE-ALLP
|
||||
@ -340,6 +342,17 @@
|
||||
NORMALIZE-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
|
||||
|
||||
-1-EXPT-N
|
||||
@ -366,6 +379,7 @@
|
||||
F
|
||||
DFFR
|
||||
DGNL
|
||||
GMSM1
|
||||
GNRT
|
||||
GRIN
|
||||
GRML
|
||||
|
||||
@ -12,514 +12,371 @@
|
||||
;; a loop-absm of dimension (1- DMNS).
|
||||
|
||||
(DEFUN ABSM-LOOPABSM (cmpr dmns absm loop-absm)
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(fixnum dmns) ;; dimension of ABSM
|
||||
(type absm absm loop-absm))
|
||||
(the absm
|
||||
(with-absm (dgop1 gmsm1) absm
|
||||
(when (logbitp (1- dmns) dgop1)
|
||||
(return-from absm-loopabsm loop-absm))
|
||||
(with-absm (dgop2 loop2) loop-absm
|
||||
(let ((iloop2 (loop-list loop2)))
|
||||
(declare (list iloop2))
|
||||
(unless iloop2
|
||||
(return-from absm-loopabsm
|
||||
(absm dgop1 (make-loop :list (list (apowr 0 gmsm1 +1))))))
|
||||
(let ((apowr (first iloop2)))
|
||||
(declare (type apowr apowr))
|
||||
(with-apowr (dgop22 gmsm2 expn2) apowr
|
||||
(if (and (= dgop1 (dgop*dgop dgop2 dgop22))
|
||||
(eq :equal (funcall cmpr gmsm1 gmsm2)))
|
||||
;; the absm is eaten by the first component of the loop
|
||||
(if (= -1 expn2)
|
||||
;; the first item of the loop disappears.
|
||||
(let ((iloop2-rest (rest iloop2)))
|
||||
(if iloop2-rest
|
||||
(let ((loop-rest (normalize-loop (1- dmns) iloop2-rest)))
|
||||
(declare (type absm loop-rest))
|
||||
(absm (dgop*dgop dgop2 (dgop loop-rest)) (gmsm loop-rest)))
|
||||
(absm (mask (1- dmns)) +null-loop+)))
|
||||
;; the exponent of the first item is increased by 1
|
||||
(absm dgop2 (make-loop :list (cons (apowr dgop22 gmsm2 (1+ expn2))
|
||||
(rest iloop2)))))
|
||||
;; a concatenation must be done
|
||||
(multiple-value-bind (dgop dgop1 dgop2) (extract-common-dgop dgop1 dgop2)
|
||||
(declare (fixnum dgop dgop1 dgop2))
|
||||
(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))))))))))))))
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(fixnum dmns) ;; dimension of ABSM
|
||||
(type absm absm loop-absm))
|
||||
(the absm
|
||||
(with-absm
|
||||
(dgop1 gmsm1) absm
|
||||
(when (logbitp (1- dmns) dgop1)
|
||||
(return-from absm-loopabsm loop-absm))
|
||||
(with-absm
|
||||
(dgop2 loop2) loop-absm
|
||||
(let ((iloop2 (loop-list loop2)))
|
||||
(declare (list iloop2))
|
||||
(unless iloop2
|
||||
(return-from absm-loopabsm
|
||||
(absm dgop1 (make-loop :list (list (apowr 0 gmsm1 +1))))))
|
||||
(let ((apowr (first iloop2)))
|
||||
(declare (type apowr apowr))
|
||||
(with-apowr
|
||||
(dgop22 gmsm2 expn2) apowr
|
||||
(if (and (= dgop1 (dgop*dgop dgop2 dgop22))
|
||||
(eq :equal (funcall cmpr gmsm1 gmsm2)))
|
||||
;; the absm is eaten by the first component of the loop
|
||||
(if (= -1 expn2)
|
||||
;; the first item of the loop disappears.
|
||||
(let ((iloop2-rest (rest iloop2)))
|
||||
(if iloop2-rest
|
||||
(let ((loop-rest (normalize-loop
|
||||
(1- dmns) iloop2-rest)))
|
||||
(declare (type absm loop-rest))
|
||||
(absm (dgop*dgop dgop2 (dgop loop-rest))
|
||||
(gmsm loop-rest)))
|
||||
(absm (mask (1- dmns)) +null-loop+)))
|
||||
;; the exponent of the first item is increased by 1
|
||||
(absm dgop2 (make-loop :list
|
||||
(cons (apowr dgop22
|
||||
gmsm2
|
||||
(1+ expn2))
|
||||
(rest iloop2)))))
|
||||
;; a concatenation must be done
|
||||
(multiple-value-bind (dgop dgop1 dgop2)
|
||||
(extract-common-dgop dgop1 dgop2)
|
||||
(declare (fixnum dgop dgop1 dgop2))
|
||||
(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)
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type face space-face loop-space-face non-twisted-face))
|
||||
(flet ((rslt (indx dmns crpr)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type crpr crpr))
|
||||
(the absm
|
||||
(progn
|
||||
(unless (= indx dmns)
|
||||
(return-from rslt
|
||||
(funcall non-twisted-face indx dmns crpr)))
|
||||
(with-crpr (absm1 absm2) crpr
|
||||
(let ((face1 (a-face4 space-face dmns dmns absm1))
|
||||
(face2 (a-face4 loop-space-face dmns dmns absm2)))
|
||||
(declare (type absm face1 face2))
|
||||
(setf face2 (absm-loopabsm cmpr dmns absm1 face2))
|
||||
(2absm-acrpr face1 face2)))))))
|
||||
(the face #'rslt)))
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type crpr crpr))
|
||||
(the absm
|
||||
(progn
|
||||
(unless (= indx dmns)
|
||||
(return-from rslt
|
||||
(funcall non-twisted-face indx dmns crpr)))
|
||||
(with-crpr (absm1 absm2) crpr
|
||||
(let ((face1 (a-face4 space-face dmns dmns absm1))
|
||||
(face2 (a-face4 loop-space-face dmns dmns
|
||||
absm2)))
|
||||
(declare (type absm face1 face2))
|
||||
(setf face2 (absm-loopabsm cmpr dmns absm1
|
||||
face2))
|
||||
(2absm-acrpr face1 face2)))))))
|
||||
(the face #'rslt)))
|
||||
|
||||
(DEFUN TWISTED-CRTS-PRDC (space
|
||||
&aux (loop-space (loop-space space))
|
||||
(crts-prdc (crts-prdc space loop-space)))
|
||||
(declare (type simplicial-set space loop-space crts-prdc))
|
||||
(the simplicial-set
|
||||
(with-slots ((space-cmpr cmpr) (space-face face)) space
|
||||
&aux (loop-space (loop-space space))
|
||||
(crts-prdc (crts-prdc space loop-space)))
|
||||
(declare (type simplicial-set space loop-space crts-prdc))
|
||||
(the simplicial-set
|
||||
(with-slots ((space-cmpr cmpr) (space-face face)) space
|
||||
(declare
|
||||
(type cmprf space-cmpr)
|
||||
(type face space-face))
|
||||
(with-slots ((loop-space-face face)) loop-space
|
||||
(declare (type face loop-space-face))
|
||||
(with-slots ((crts-prdc-cmpr cmpr) basis bsgn (crts-prdc-face face)) crts-prdc
|
||||
(declare
|
||||
(type cmprf crts-prdc-cmpr)
|
||||
(type basis basis)
|
||||
(type face crts-prdc-face)
|
||||
(type gmsm bsgn))
|
||||
(let ((rslt (build-smst
|
||||
:cmpr crts-prdc-cmpr
|
||||
:basis basis
|
||||
:bspn bsgn
|
||||
:face (twisted-crts-prdc-face
|
||||
space-cmpr space-face loop-space-face crts-prdc-face)
|
||||
:orgn `(twisted-crts-prdc ,space))))
|
||||
(setf (slot-value rslt 'grmd) crts-prdc)
|
||||
rslt))))))
|
||||
(type cmprf space-cmpr)
|
||||
(type face space-face))
|
||||
(with-slots ((loop-space-face face)) loop-space
|
||||
(declare (type face loop-space-face))
|
||||
(with-slots ((crts-prdc-cmpr cmpr) basis bsgn (crts-prdc-face face))
|
||||
crts-prdc
|
||||
(declare
|
||||
(type cmprf crts-prdc-cmpr)
|
||||
(type basis basis)
|
||||
(type face crts-prdc-face)
|
||||
(type gmsm bsgn))
|
||||
(let ((rslt (build-smst
|
||||
:cmpr crts-prdc-cmpr
|
||||
:basis basis
|
||||
:bspn bsgn
|
||||
:face (twisted-crts-prdc-face
|
||||
space-cmpr space-face loop-space-face
|
||||
crts-prdc-face)
|
||||
: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)
|
||||
(declare
|
||||
(type cmprf crts-prdc-cmpr)
|
||||
(type face crts-prdc-face twisted-crts-prdc-face))
|
||||
(flet ((rslt (dmns crpr)
|
||||
(declare
|
||||
(fixnum dmns)
|
||||
(type crpr crpr))
|
||||
(when (zerop dmns)
|
||||
(return-from rslt +zero-negative-cmbn+))
|
||||
(the cmbn
|
||||
(declare
|
||||
(type cmprf crts-prdc-cmpr)
|
||||
(type face crts-prdc-face twisted-crts-prdc-face))
|
||||
(flet ((rslt (dmns crpr)
|
||||
(declare
|
||||
(fixnum dmns)
|
||||
(type crpr crpr))
|
||||
(when (zerop dmns)
|
||||
(return-from rslt +zero-negative-cmbn+))
|
||||
(the cmbn
|
||||
(let ((dmns-1 (1- dmns)))
|
||||
(declare (fixnum dmns-1))
|
||||
(when (logbitp dmns-1 (dgop1 crpr))
|
||||
(return-from rslt (zero-cmbn dmns-1)))
|
||||
(let ((face-tau (funcall twisted-crts-prdc-face dmns dmns crpr))
|
||||
(face (funcall crts-prdc-face dmns dmns crpr))
|
||||
(sign (-1-expt-n dmns)))
|
||||
(declare
|
||||
(type absm face-tau face)
|
||||
(fixnum sign))
|
||||
(with-absm (dgop-tau gmsm-tau) face-tau
|
||||
(with-absm (dgop gmsm) face
|
||||
(if (plusp dgop-tau)
|
||||
(if (plusp dgop)
|
||||
(zero-cmbn dmns-1)
|
||||
(term-cmbn dmns-1 (- sign) gmsm))
|
||||
(if (plusp dgop)
|
||||
(term-cmbn dmns-1 sign gmsm-tau)
|
||||
(ecase (funcall crts-prdc-cmpr gmsm-tau gmsm)
|
||||
(:less
|
||||
(cmbn dmns-1 sign gmsm-tau (- sign) gmsm))
|
||||
(:greater
|
||||
(cmbn dmns-1 (- sign) gmsm sign gmsm-tau))
|
||||
(:equal
|
||||
(error "Surprise in DTAU-D-INTR.~@
|
||||
(declare (fixnum dmns-1))
|
||||
(when (logbitp dmns-1 (dgop1 crpr))
|
||||
(return-from rslt (zero-cmbn dmns-1)))
|
||||
(let ((face-tau (funcall twisted-crts-prdc-face dmns dmns
|
||||
crpr))
|
||||
(face (funcall crts-prdc-face dmns dmns crpr))
|
||||
(sign (-1-expt-n dmns)))
|
||||
(declare
|
||||
(type absm face-tau face)
|
||||
(fixnum sign))
|
||||
(with-absm
|
||||
(dgop-tau gmsm-tau) face-tau
|
||||
(with-absm
|
||||
(dgop gmsm) face
|
||||
(if (plusp dgop-tau)
|
||||
(if (plusp dgop)
|
||||
(zero-cmbn dmns-1)
|
||||
(term-cmbn dmns-1 (- sign) gmsm))
|
||||
(if (plusp dgop)
|
||||
(term-cmbn dmns-1 sign gmsm-tau)
|
||||
(ecase (funcall crts-prdc-cmpr gmsm-tau
|
||||
gmsm)
|
||||
(:less
|
||||
(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~@
|
||||
D-tau = ~A~@
|
||||
D = ~A"
|
||||
crpr gmsm-tau gmsm))))))))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
crpr gmsm-tau gmsm))))))))))))
|
||||
(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
|
||||
&aux (loop-space (loop-space space))
|
||||
(crts-prdc (crts-prdc space loop-space))
|
||||
(crts-prdc-cmpr (cmpr crts-prdc))
|
||||
(crts-prdc-face (face crts-prdc))
|
||||
(twisted-crts-prdc (twisted-crts-prdc space))
|
||||
(twisted-crts-prdc-face (face twisted-crts-prdc)))
|
||||
(declare
|
||||
(type simplicial-set space loop-space crts-prdc twisted-crts-prdc)
|
||||
(type cmprf crts-prdc-cmpr)
|
||||
(type face crts-prdc-face twisted-crts-prdc-face))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc crts-prdc :trgt crts-prdc :degr -1
|
||||
:intr (dtau-d-intr crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face)
|
||||
:strt :gnrt
|
||||
:orgn `(dtau-d ,space))))
|
||||
&aux (loop-space (loop-space space))
|
||||
(crts-prdc (crts-prdc space loop-space))
|
||||
(crts-prdc-cmpr (cmpr crts-prdc))
|
||||
(crts-prdc-face (face crts-prdc))
|
||||
(twisted-crts-prdc (twisted-crts-prdc space))
|
||||
(twisted-crts-prdc-face (face twisted-crts-prdc)))
|
||||
(declare
|
||||
(type simplicial-set space loop-space crts-prdc twisted-crts-prdc)
|
||||
(type cmprf crts-prdc-cmpr)
|
||||
(type face crts-prdc-face twisted-crts-prdc-face))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc crts-prdc :trgt crts-prdc :degr -1
|
||||
:intr (dtau-d-intr crts-prdc-cmpr crts-prdc-face
|
||||
twisted-crts-prdc-face)
|
||||
:strt :gnrt
|
||||
:orgn `(dtau-d ,space))))
|
||||
|
||||
|
||||
(DEFUN SZCZARBA (space
|
||||
&aux (loop-space (loop-space space))
|
||||
(twisted-crts-prdc (twisted-crts-prdc space))
|
||||
(ez (ez space loop-space))
|
||||
(dtau-d (dtau-d space)))
|
||||
&aux (loop-space (loop-space space))
|
||||
(twisted-crts-prdc (twisted-crts-prdc space))
|
||||
(ez (ez space loop-space))
|
||||
(dtau-d (dtau-d space)))
|
||||
(declare
|
||||
(type simplicial-set space loop-space twisted-crts-prdc)
|
||||
(type reduction ez)
|
||||
(type morphism dtau-d))
|
||||
(the (values reduction morphism)
|
||||
(multiple-value-bind (szczarba bottom-perturbation)
|
||||
(add ez dtau-d)
|
||||
(with-slots (tcc f g h) szczarba
|
||||
(setf tcc twisted-crts-prdc
|
||||
(slot-value f 'sorc) twisted-crts-prdc
|
||||
(slot-value g 'trgt) twisted-crts-prdc
|
||||
(slot-value h 'sorc) twisted-crts-prdc
|
||||
(slot-value h 'trgt) twisted-crts-prdc))
|
||||
(multiple-value-bind (szczarba bottom-perturbation)
|
||||
(add ez dtau-d)
|
||||
(with-slots (tcc f g h) szczarba
|
||||
(setf tcc twisted-crts-prdc
|
||||
(slot-value f 'sorc) twisted-crts-prdc
|
||||
(slot-value g 'trgt) twisted-crts-prdc
|
||||
(slot-value h 'sorc) twisted-crts-prdc
|
||||
(slot-value h 'trgt) twisted-crts-prdc))
|
||||
(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
|
||||
&aux (szczarba (szczarba space)))
|
||||
(declare
|
||||
(type simplicial-set space)
|
||||
(type reduction szczarba))
|
||||
(the chain-complex
|
||||
(bcc szczarba)))
|
||||
&aux (szczarba (szczarba space)))
|
||||
(declare
|
||||
(type simplicial-set space)
|
||||
(type reduction szczarba))
|
||||
(the chain-complex
|
||||
(bcc szczarba)))
|
||||
|
||||
;;;
|
||||
;;; The important contraction.
|
||||
;;;
|
||||
|
||||
(DEFUN POP-FIRST-ABSM (dmns iloop)
|
||||
(declare (type iloop iloop))
|
||||
(the (values (member -1 0 1) (or nil absm) absm)
|
||||
(progn
|
||||
(declare (type iloop iloop))
|
||||
(the (values (member -1 0 1) (or nil absm) absm)
|
||||
(progn
|
||||
(unless iloop
|
||||
(return-from pop-first-absm
|
||||
(values 0 nil iloop)))
|
||||
(return-from pop-first-absm
|
||||
(values 0 nil iloop)))
|
||||
(let ((apowr (first iloop))
|
||||
(niloop-rest (rest iloop)))
|
||||
(declare
|
||||
(type apowr apowr)
|
||||
(type iloop niloop-rest))
|
||||
(with-apowr (dgop gmsm expn) apowr
|
||||
(let ((popped-absm (absm dgop gmsm)))
|
||||
(declare (type absm popped-absm))
|
||||
(cond ((< expn -1)
|
||||
(values -1 popped-absm
|
||||
(absm 0
|
||||
(make-loop
|
||||
:list (cons (apowr dgop gmsm (1+ expn)) niloop-rest)))))
|
||||
((> expn +1)
|
||||
(values +1 popped-absm
|
||||
(absm 0
|
||||
(make-loop
|
||||
:list (cons (apowr dgop gmsm (1- expn)) niloop-rest)))))
|
||||
(t
|
||||
(values expn popped-absm
|
||||
(normalize-loop dmns niloop-rest))))))))))
|
||||
(declare
|
||||
(type apowr apowr)
|
||||
(type iloop niloop-rest))
|
||||
(with-apowr
|
||||
(dgop gmsm expn) apowr
|
||||
(let ((popped-absm (absm dgop gmsm)))
|
||||
(declare (type absm popped-absm))
|
||||
(cond ((< expn -1)
|
||||
(values -1 popped-absm
|
||||
(absm 0
|
||||
(make-loop
|
||||
:list (cons (apowr dgop gmsm (1+ expn))
|
||||
niloop-rest)))))
|
||||
((> expn +1)
|
||||
(values +1 popped-absm
|
||||
(absm 0
|
||||
(make-loop
|
||||
:list (cons (apowr dgop gmsm (1- expn))
|
||||
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)
|
||||
(declare
|
||||
(type cmprf base-cmpr crts-cmpr)
|
||||
(type gmsm base-bspn)
|
||||
(type face base-face))
|
||||
|
||||
(flet ((rslt (n crpr)
|
||||
(declare
|
||||
(fixnum n)
|
||||
(type crpr crpr))
|
||||
(the cmbn
|
||||
(declare
|
||||
(type cmprf base-cmpr crts-cmpr)
|
||||
(type gmsm base-bspn)
|
||||
(type face base-face))
|
||||
|
||||
(flet ((rslt (n crpr)
|
||||
(declare
|
||||
(fixnum n)
|
||||
(type crpr crpr))
|
||||
(the cmbn
|
||||
(let ((n+1 (1+ n)))
|
||||
(declare (fixnum n+1))
|
||||
(labels (
|
||||
(hh (x-n g-n)
|
||||
(declare (type absm x-n g-n))
|
||||
(if (bspn-p base-cmpr base-bspn n x-n)
|
||||
(if (degenerate-p g-n)
|
||||
(zero-cmbn n+1)
|
||||
(h-hat (loop-list (gmsm g-n))))
|
||||
(if (degenerate-p g-n)
|
||||
(h-tilde (1dgnr n x-n) g-n)
|
||||
(2cmbn-add crts-cmpr (h-hat (loop-list (gmsm g-n)))
|
||||
(h-tilde (1dgnr n x-n) g-n)))))
|
||||
(h-tilde (x-n+1 g-n)
|
||||
(declare (type absm x-n+1 g-n))
|
||||
(when (bspn-p base-cmpr base-bspn n+1 x-n+1)
|
||||
(return-from h-tilde
|
||||
(zero-cmbn n+1)))
|
||||
(do ((i n (1- i))
|
||||
(dgop 0 (+ dgop (2-exp i)))
|
||||
(sign (-1-expt-n+1 n) (- sign))
|
||||
(del-i x-n+1 (a-face4 base-face i (1+ i) del-i))
|
||||
(rslt (zero-cmbn n+1)))
|
||||
((minusp i) rslt)
|
||||
(declare
|
||||
(fixnum i dgop sign)
|
||||
(type absm del-i)
|
||||
(type cmbn rslt))
|
||||
(let ((absm1 (ndgnr dgop del-i))
|
||||
(loop-absm2 (1dgnr i g-n)))
|
||||
(declare (type absm absm1 loop-absm2))
|
||||
(unless (plusp (logand (dgop absm1) (dgop loop-absm2)))
|
||||
(dstr-add-term-to-cmbn
|
||||
crts-cmpr
|
||||
sign (crpr absm1 loop-absm2)
|
||||
rslt)))))
|
||||
(h-hat (g-n)
|
||||
(declare (type iloop g-n)) ;;; ***
|
||||
(multiple-value-bind (expn y-n+1 gp-n) (pop-first-absm n g-n)
|
||||
(declare
|
||||
(fixnum expn)
|
||||
(type (or absm null) y-n+1 gp-n))
|
||||
(ecase expn
|
||||
(0 (zero-cmbn (1+ n)))
|
||||
(+1
|
||||
(let ((h-tildes (2cmbn-sbtr crts-cmpr
|
||||
(h-tilde y-n+1 gp-n)
|
||||
(h-tilde
|
||||
(1dgnr n (a-face4 base-face (1+ n) (1+ n) y-n+1))
|
||||
(absm 0 (make-loop :list g-n))))))
|
||||
(declare (type cmbn h-tildes))
|
||||
(if (degenerate-p gp-n)
|
||||
h-tildes
|
||||
(2cmbn-add crts-cmpr (h-hat (loop-list (gmsm gp-n))) h-tildes))))
|
||||
(-1
|
||||
(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)))))))
|
||||
|
||||
(declare (fixnum n+1))
|
||||
(labels (
|
||||
(hh (x-n g-n)
|
||||
(declare (type absm x-n g-n))
|
||||
(if (bspn-p base-cmpr base-bspn n x-n)
|
||||
(if (degenerate-p g-n)
|
||||
(zero-cmbn n+1)
|
||||
(h-hat (loop-list (gmsm g-n))))
|
||||
(if (degenerate-p g-n)
|
||||
(h-tilde (1dgnr n x-n) g-n)
|
||||
(2cmbn-add crts-cmpr
|
||||
(h-hat (loop-list (gmsm g-n)))
|
||||
(h-tilde (1dgnr n x-n) g-n)))))
|
||||
(h-tilde (x-n+1 g-n)
|
||||
(declare (type absm x-n+1 g-n))
|
||||
(when (bspn-p base-cmpr base-bspn n+1 x-n+1)
|
||||
(return-from h-tilde
|
||||
(zero-cmbn n+1)))
|
||||
(do ((i n (1- i))
|
||||
(dgop 0 (+ dgop (2-exp i)))
|
||||
(sign (-1-expt-n+1 n) (- sign))
|
||||
(del-i x-n+1 (a-face4 base-face i (1+ i)
|
||||
del-i))
|
||||
(rslt (zero-cmbn n+1)))
|
||||
((minusp i) rslt)
|
||||
(declare
|
||||
(fixnum i dgop sign)
|
||||
(type absm del-i)
|
||||
(type cmbn rslt))
|
||||
(let ((absm1 (ndgnr dgop del-i))
|
||||
(loop-absm2 (1dgnr i g-n)))
|
||||
(declare (type absm absm1 loop-absm2))
|
||||
(unless (plusp (logand (dgop absm1)
|
||||
(dgop loop-absm2)))
|
||||
(dstr-add-term-to-cmbn
|
||||
crts-cmpr
|
||||
sign (crpr absm1 loop-absm2)
|
||||
rslt)))))
|
||||
(h-hat (g-n)
|
||||
(declare (type iloop g-n)) ;;; ***
|
||||
(multiple-value-bind (expn y-n+1 gp-n)
|
||||
(pop-first-absm n g-n)
|
||||
(declare
|
||||
(fixnum expn)
|
||||
(type (or absm null) y-n+1 gp-n))
|
||||
(ecase expn
|
||||
(0 (zero-cmbn (1+ n)))
|
||||
(+1
|
||||
(let ((h-tildes
|
||||
(2cmbn-sbtr
|
||||
crts-cmpr (h-tilde y-n+1 gp-n)
|
||||
(h-tilde (1dgnr n (a-face4 base-face
|
||||
(1+ n)
|
||||
(1+ n)
|
||||
y-n+1))
|
||||
(absm 0 (make-loop :list
|
||||
g-n))))))
|
||||
(declare (type cmbn h-tildes))
|
||||
(if (degenerate-p gp-n)
|
||||
h-tildes
|
||||
(2cmbn-add crts-cmpr
|
||||
(h-hat (loop-list
|
||||
(gmsm gp-n)))
|
||||
h-tildes))))
|
||||
(-1
|
||||
(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)))
|
||||
|
||||
|
||||
#|
|
||||
()
|
||||
(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
|
||||
&aux (twisted-crts-prdc (twisted-crts-prdc space)))
|
||||
(declare (type simplicial-set space twisted-crts-prdc))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc twisted-crts-prdc :trgt twisted-crts-prdc :degr +1
|
||||
:intr (crts-contraction-intr (cmpr space) (bspn space) (face space)
|
||||
(cmpr twisted-crts-prdc))
|
||||
:strt :gnrt
|
||||
:orgn `(crts-contraction ,space))))
|
||||
&aux (twisted-crts-prdc (twisted-crts-prdc space)))
|
||||
(declare (type simplicial-set space twisted-crts-prdc))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc twisted-crts-prdc :trgt twisted-crts-prdc :degr +1
|
||||
:intr (crts-contraction-intr (cmpr space) (bspn space) (face space)
|
||||
(cmpr twisted-crts-prdc))
|
||||
:strt :gnrt
|
||||
: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
|
||||
&aux
|
||||
&aux
|
||||
(szczarba (szczarba space))
|
||||
(f (f szczarba))
|
||||
(g (g szczarba))
|
||||
(crts-contraction (crts-contraction space)))
|
||||
(declare
|
||||
(type simplicial-set space)
|
||||
(type reduction szczarba)
|
||||
(type morphism f g crts-contraction))
|
||||
(the morphism
|
||||
(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)))
|
||||
|#
|
||||
(declare
|
||||
(type simplicial-set space)
|
||||
(type reduction szczarba)
|
||||
(type morphism f g crts-contraction))
|
||||
(the morphism
|
||||
(i-cmps f crts-contraction g)))
|
||||
|
||||
@ -170,22 +170,6 @@
|
||||
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 ()
|
||||
(do ((tdegr 0 (+ tdegr degr))
|
||||
(degr (+ 2 (random 3)) (+ 2 (random 3)))
|
||||
@ -210,3 +194,66 @@
|
||||
(aleat-tc)
|
||||
(aleat-bc)
|
||||
(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)))
|
||||
|
||||
@ -179,33 +179,6 @@
|
||||
(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
|
||||
(cat:cat-init)
|
||||
(let* ((p (cat:r-proj-space 3))
|
||||
|
||||
181
test/ls-twisted-products-test.lisp
Normal file
181
test/ls-twisted-products-test.lisp
Normal 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)))))
|
||||
Loading…
Reference in New Issue
Block a user