385 lines
17 KiB
Common Lisp
385 lines
17 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
|
|
|
|
;;; LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS
|
|
;;; LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS
|
|
;;; LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS
|
|
|
|
(IN-PACKAGE #:cat)
|
|
|
|
(PROVIDE "ls-twisted-products")
|
|
|
|
;; ABSM-LOOPABSM is the "twisted" product of ABSM, a simplex of the base
|
|
;; space of dimension DMNS by LOOP-ABSM, a simplex of the corresponding
|
|
;; loop-space, of dimension (1- DMNS). The returned object is
|
|
;; 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))))))))))))))
|
|
|
|
|
|
(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)))
|
|
|
|
(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
|
|
(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))))))
|
|
|
|
|
|
(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
|
|
(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.~@
|
|
Crpr = ~A~@
|
|
D-tau = ~A~@
|
|
D = ~A"
|
|
crpr gmsm-tau gmsm))))))))))))
|
|
(the intr-mrph #'rslt)))
|
|
|
|
|
|
(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))))
|
|
|
|
|
|
(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)))
|
|
(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))
|
|
(values szczarba bottom-perturbation))))
|
|
|
|
|
|
(DEFUN TWISTED-TNSR-PRDC (space
|
|
&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
|
|
(unless 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))))))))))
|
|
|
|
|
|
|
|
(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
|
|
(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)))))))
|
|
(the intr-mrph #'rslt)))
|
|
|
|
|
|
(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))))
|
|
|
|
|
|
(DEFUN TNPR-CONTRACTION (space
|
|
&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)))
|