77 lines
1.8 KiB
Common Lisp
77 lines
1.8 KiB
Common Lisp
;;; CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS
|
|
;;; CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS
|
|
;;; CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS
|
|
|
|
(IN-PACKAGE #:cat)
|
|
|
|
(PROVIDE "cs-twisted-products")
|
|
|
|
(DEFUN SMGR-FIBRATION-SINTR (dmns gbar)
|
|
(declare
|
|
(ignore dmns)
|
|
(type gbar gbar))
|
|
(the absm
|
|
(first (gbar-list gbar))))
|
|
|
|
(DEFUN SMGR-FIBRATION (smgr)
|
|
(declare (type simplicial-group smgr))
|
|
(the fibration
|
|
(build-smmr
|
|
:sorc (classifying-space smgr)
|
|
:trgt smgr
|
|
:degr -1
|
|
:sintr #'smgr-fibration-sintr
|
|
:orgn `(simplicial-group-fibration ,smgr))))
|
|
|
|
|
|
(DEFUN SMGR-CRTS-CONTRACTION-INTR (idnt)
|
|
(declare
|
|
(type gmsm idnt))
|
|
(flet ((rslt (degr crpr
|
|
&aux (degr+1 (1+ degr)))
|
|
(declare
|
|
(fixnum degr degr+1)
|
|
(type crpr crpr))
|
|
(the cmbn
|
|
(with-crpr
|
|
(absm1 absm2) crpr
|
|
(if (= (dgop absm2) (mask degr))
|
|
(zero-cmbn degr+1)
|
|
(term-cmbn degr+1
|
|
(-1-expt-n+1 degr)
|
|
(crpr 0 (make-gbar
|
|
:dmns degr+1
|
|
:list (cons absm2
|
|
(rest
|
|
(unnormalize-gbar
|
|
absm1 idnt))))
|
|
(mask degr+1) idnt)))))))
|
|
(the intr-mrph #'rslt)))
|
|
|
|
|
|
(DEFUN SMGR-CRTS-CONTRACTION (smgr)
|
|
(declare (type simplicial-group smgr))
|
|
(the morphism
|
|
(build-mrph
|
|
:sorc (fibration-total (smgr-fibration smgr))
|
|
:trgt (fibration-total (smgr-fibration smgr))
|
|
:degr +1
|
|
:intr (smgr-crts-contraction-intr (bspn smgr))
|
|
:strt :gnrt
|
|
:orgn `(smgr-crts-contraction ,smgr))))
|
|
|
|
|
|
(DEFUN SMGR-TNPR-CONTRACTION (smgr
|
|
&aux (fibration (smgr-fibration smgr))
|
|
(brown (brown-reduction fibration))
|
|
(f (f brown))
|
|
(g (g brown))
|
|
(chi (smgr-crts-contraction smgr)))
|
|
(declare
|
|
(type simplicial-group smgr)
|
|
(type fibration fibration)
|
|
(type reduction brown)
|
|
(type morphism f g chi))
|
|
(the morphism
|
|
(i-cmps f chi g)))
|