338 lines
9.6 KiB
Common Lisp
338 lines
9.6 KiB
Common Lisp
;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD
|
|
;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD
|
|
;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD
|
|
|
|
(IN-PACKAGE "COMMON-LISP-USER")
|
|
|
|
(provide "whitehead")
|
|
|
|
;;;
|
|
;;; Z
|
|
;;;
|
|
|
|
(DEFUN Z-WWHITEHEAD-SINTR (smst n chml-clss
|
|
&aux (face (face smst))
|
|
(k-z-n (k-z n))
|
|
(idnt (bspn k-z-n))
|
|
(efhm (efhm smst)))
|
|
(declare
|
|
(type simplicial-set smst)
|
|
(fixnum n)
|
|
(type morphism chml-clss)
|
|
(type face face)
|
|
(type ab-simplicial-group k-z-n)
|
|
(type gmsm idnt)
|
|
(type homotopy-equivalence efhm))
|
|
(setf chml-clss
|
|
(i-cmps chml-clss (rf efhm) (lg efhm)))
|
|
(flet ((rslt (dmns gmsm)
|
|
(declare
|
|
(fixnum dmns)
|
|
(type gmsm gmsm))
|
|
(if (< dmns n)
|
|
(absm (mask dmns) idnt)
|
|
(z-cocycle-gbar n dmns
|
|
(gmsm-cocycle face n dmns gmsm chml-clss)))))
|
|
(the sintr #'rslt)))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf k (k-z 2))
|
|
(setf ecc (echcm k))
|
|
(setf chml-clss
|
|
(build-mrph
|
|
:sorc ecc :trgt (z-chcm) :degr 2
|
|
:intr #'(lambda (degr gnrt)
|
|
(if (= degr 2)
|
|
(term-cmbn 0 1 :z-gnrt)
|
|
(zero-cmbn (- degr 2))))
|
|
:strt :gnrt :orgn '(fundamental-class k-z-2)))
|
|
(setf tw (z-wwhitehead-sintr k 2 chml-clss))
|
|
(a-sintr3 tw 1 (absm 1 +null-gbar+)) ;;; cf old-macro cancelled
|
|
(a-sintr3 tw 2 (absm 3 +null-gbar+)) ;;; in macros.cl
|
|
(funcall tw 2 (gbar 2 0 '(55) 0 '()))
|
|
(funcall tw 3 (gbar 3 0 '(12 23)
|
|
0 '(34)
|
|
0 '()))
|
|
(funcall tw 4 (gbar 4 0 '(12 23 34)
|
|
2 '(45)
|
|
0 '(56)
|
|
0 '()))
|
|
(setf k (k-z 3))
|
|
(setf ecc (echcm k))
|
|
(setf chml-clss
|
|
(build-mrph
|
|
:sorc ecc :trgt (z-chcm) :degr 3
|
|
:intr #'(lambda (degr gnrt)
|
|
(if (= degr 3)
|
|
(term-cmbn 0 -1 :z-gnrt)
|
|
(zero-cmbn (- degr 3))))
|
|
:strt :gnrt :orgn '(fundamental-class k-z-3)))
|
|
(setf tw (z-wwhitehead-sintr k 3 chml-clss))
|
|
(a-sintr3 tw 1 (absm 1 +null-gbar+))
|
|
(a-sintr3 tw 2 (absm 3 +null-gbar+))
|
|
(a-sintr3 tw 3 (absm 7 +null-gbar+))
|
|
(funcall tw 3 (z-fundamental-gmsm 3 55))
|
|
(equal (funcall tw 3 (z-fundamental-gmsm 3 55))
|
|
(absm 0 (z-fundamental-gmsm 3 55)))
|
|
(funcall tw 4 (gbar 4 0 (gbar 3 0 '(12 23) 0 '(34) 0 '())
|
|
0 (gbar 2 0 '(45) 0 '())
|
|
1 (gbar 0)
|
|
0 (gbar 0)))
|
|
|#
|
|
|
|
(DEFUN Z-WHITEHEAD-SINTR (smst n chml-clss
|
|
&aux (face (face smst))
|
|
(k-z-n-1 (k-z (1- n)))
|
|
(idnt (bspn k-z-n-1))
|
|
(efhm (efhm smst)))
|
|
(declare
|
|
(type simplicial-set smst)
|
|
(fixnum n)
|
|
(type morphism chml-clss)
|
|
(type face face)
|
|
(type ab-simplicial-group k-z-n-1)
|
|
(type gmsm idnt)
|
|
(type homotopy-equivalence efhm))
|
|
(setf chml-clss
|
|
(i-cmps chml-clss (rf efhm) (lg efhm)))
|
|
(flet ((rslt (dmns gmsm)
|
|
(declare
|
|
(fixnum dmns)
|
|
(type gmsm gmsm))
|
|
(if (< dmns n)
|
|
(absm (mask (1- dmns)) idnt)
|
|
(z-cocycle-gbar-head n dmns
|
|
(gmsm-cocycle face n dmns gmsm chml-clss)))))
|
|
(the sintr #'rslt)))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf k (k-z 2))
|
|
(setf ecc (echcm k))
|
|
(setf chml-clss
|
|
(build-mrph
|
|
:sorc ecc :trgt (z-chcm) :degr 2
|
|
:intr #'(lambda (degr gnrt)
|
|
(if (= degr 2)
|
|
(term-cmbn 0 1 :z-gnrt)
|
|
(zero-cmbn (- degr 2))))
|
|
:strt :gnrt :orgn '(fundamental-class k-z-2)))
|
|
(setf tw (z-whitehead-sintr k 2 chml-clss))
|
|
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) '())
|
|
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) '())
|
|
(funcall tw 2 (gbar 2 0 '(55) 0 '()))
|
|
(funcall tw 3 (gbar 3 0 '(12 23)
|
|
0 '(34)
|
|
0 '()))
|
|
(funcall tw 4 (gbar 4 0 '(12 23 34)
|
|
2 '(45)
|
|
0 '(56)
|
|
0 '()))
|
|
(setf k (k-z 3))
|
|
(setf ecc (echcm k))
|
|
(setf chml-clss
|
|
(build-mrph
|
|
:sorc ecc :trgt (z-chcm) :degr 3
|
|
:intr #'(lambda (degr gnrt)
|
|
(if (= degr 3)
|
|
(term-cmbn 0 -1 :z-gnrt)
|
|
(zero-cmbn (- degr 3))))
|
|
:strt :gnrt :orgn '(fundamental-class k-z-3)))
|
|
(setf tw (z-whitehead-sintr k 3 chml-clss))
|
|
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) +null-gbar+)
|
|
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) +null-gbar+)
|
|
(tw-a-sintr3 tw 3 (absm 7 +null-gbar+) +null-gbar+)
|
|
(funcall tw 3 (z-fundamental-gmsm 3 55))
|
|
(equal (funcall tw 3 (z-fundamental-gmsm 3 55))
|
|
(absm 0 (z-fundamental-gmsm 2 55)))
|
|
(funcall tw 4 (gbar 4 0 (gbar 3 0 '(12 23) 0 '(34) 0 '())
|
|
0 (gbar 2 0 '(45) 0 '())
|
|
1 (gbar 0)
|
|
0 (gbar 0)))
|
|
|#
|
|
|
|
(DEFUN Z-WHITEHEAD (smst chml-clss &aux (n (- (degr chml-clss))))
|
|
(declare
|
|
(type simplicial-set smst)
|
|
(fixnum n)
|
|
(type morphism chml-clss))
|
|
(the fibration
|
|
(build-smmr
|
|
:sorc smst :trgt (k-z (1- n)) :degr -1
|
|
:sintr (z-whitehead-sintr smst n chml-clss)
|
|
:orgn `(z-whitehead ,smst))))
|
|
|
|
;;;
|
|
;;; Z/2Z
|
|
;;;
|
|
|
|
(DEFUN Z2-WWHITEHEAD-SINTR (smst n chml-clss
|
|
&aux (face (face smst))
|
|
(k-z2-n (k-z2 n))
|
|
(idnt (bspn k-z2-n))
|
|
(efhm (efhm smst)))
|
|
(declare
|
|
(type simplicial-set smst)
|
|
(fixnum n)
|
|
(type morphism chml-clss)
|
|
(type face face)
|
|
(type ab-simplicial-group k-z2-n)
|
|
(type gmsm idnt)
|
|
(type homotopy-equivalence efhm))
|
|
(setf chml-clss
|
|
(i-cmps chml-clss (rf efhm) (lg efhm)))
|
|
(flet ((rslt (dmns gmsm)
|
|
(declare
|
|
(fixnum dmns)
|
|
(type gmsm gmsm))
|
|
(if (< dmns n)
|
|
(absm (mask dmns) idnt)
|
|
(z2-cocycle-gbar n dmns
|
|
(gmsm-cocycle face n dmns gmsm chml-clss)))))
|
|
(the sintr #'rslt)))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf k (k-z2 2))
|
|
(setf ecc (echcm k))
|
|
(setf chml-clss
|
|
(build-mrph
|
|
:sorc ecc :trgt (z-chcm) :degr 2
|
|
:intr #'(lambda (degr gnrt)
|
|
(if (= degr 2)
|
|
(term-cmbn 0 1 :z-gnrt)
|
|
(zero-cmbn (- degr 2))))
|
|
:strt :gnrt :orgn '(fundamental-class k-z-2)))
|
|
(setf tw (Z2-wwhitehead-sintr k 2 chml-clss))
|
|
(a-sintr3 tw 1 (absm 1 +null-gbar+))
|
|
(a-sintr3 tw 2 (absm 3 +null-gbar+))
|
|
(funcall tw 2 (gbar 2 0 1 0 0))
|
|
(funcall tw 3 (gbar 3 0 2
|
|
0 1
|
|
0 0))
|
|
(funcall tw 4 (gbar 4 0 3
|
|
2 1
|
|
0 1
|
|
0 0))
|
|
(setf k (k-z2 3))
|
|
(setf ecc (echcm k))
|
|
(setf chml-clss
|
|
(build-mrph
|
|
:sorc ecc :trgt (z-chcm) :degr 3
|
|
:intr #'(lambda (degr gnrt)
|
|
(if (= degr 3)
|
|
(term-cmbn 0 -1 :z-gnrt)
|
|
(zero-cmbn (- degr 3))))
|
|
:strt :gnrt :orgn '(fundamental-class k-z-3)))
|
|
(setf tw (Z2-wwhitehead-sintr k 3 chml-clss))
|
|
(a-sintr3 tw 1 (absm 1 +null-gbar+))
|
|
(a-sintr3 tw 2 (absm 3 +null-gbar+))
|
|
(a-sintr3 tw 3 (absm 7 +null-gbar+))
|
|
(funcall tw 3 (Z2-fundamental-gmsm 3 1))
|
|
(equal (funcall tw 3 (Z2-fundamental-gmsm 3 1))
|
|
(absm 0 (Z2-fundamental-gmsm 3 1)))
|
|
(funcall tw 4 (gbar 4 0 (gbar 3 0 2 0 1 0 0)
|
|
0 (gbar 2 0 1 0 0)
|
|
1 (gbar 0)
|
|
0 (gbar 0)))
|
|
|#
|
|
|
|
(DEFUN Z2-WHITEHEAD-SINTR (smst n chml-clss
|
|
&aux (face (face smst))
|
|
(k-z2-n-1 (k-z2 (1- n)))
|
|
(idnt (bspn k-z2-n-1))
|
|
(efhm (efhm smst)))
|
|
(declare
|
|
(type simplicial-set smst)
|
|
(fixnum n)
|
|
(type morphism chml-clss)
|
|
(type face face)
|
|
(type ab-simplicial-group k-z2-n-1)
|
|
(type gmsm idnt)
|
|
(type homotopy-equivalence efhm))
|
|
(setf chml-clss
|
|
(i-cmps chml-clss (rf efhm) (lg efhm)))
|
|
(flet ((rslt (dmns gmsm)
|
|
(declare
|
|
(fixnum dmns)
|
|
(type gmsm gmsm))
|
|
(if (< dmns n)
|
|
(absm (mask (1- dmns)) idnt)
|
|
(z2-cocycle-gbar-head n dmns
|
|
(gmsm-cocycle face n dmns gmsm chml-clss)))))
|
|
(the sintr #'rslt)))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf k (k-z2 2))
|
|
(setf ecc (echcm k))
|
|
(setf chml-clss
|
|
(build-mrph
|
|
:sorc ecc :trgt (z-chcm) :degr 2
|
|
:intr #'(lambda (degr gnrt)
|
|
(if (= degr 2)
|
|
(term-cmbn 0 1 :z-gnrt)
|
|
(zero-cmbn (- degr 2))))
|
|
:strt :gnrt :orgn '(fundamental-class k-z-2)))
|
|
(setf tw (Z2-whitehead-sintr k 2 chml-clss))
|
|
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) 0)
|
|
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) 0)
|
|
(funcall tw 2 (gbar 2 0 1 0 '()))
|
|
(funcall tw 3 (gbar 3 0 2
|
|
0 1
|
|
0 0))
|
|
(funcall tw 4 (gbar 4 0 3
|
|
2 1
|
|
0 1
|
|
0 0))
|
|
(setf k (k-z2 3))
|
|
(setf ecc (echcm k))
|
|
(setf chml-clss
|
|
(build-mrph
|
|
:sorc ecc :trgt (z-chcm) :degr 3
|
|
:intr #'(lambda (degr gnrt)
|
|
(if (= degr 3)
|
|
(term-cmbn 0 -1 :z-gnrt)
|
|
(zero-cmbn (- degr 3))))
|
|
:strt :gnrt :orgn '(fundamental-class k-z-3)))
|
|
(setf tw (Z2-whitehead-sintr k 3 chml-clss))
|
|
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) 0)
|
|
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) 0)
|
|
(tw-a-sintr3 tw 3 (absm 7 +null-gbar+) 0)
|
|
(funcall tw 3 (Z2-fundamental-gmsm 3 1))
|
|
(equal (funcall tw 3 (Z2-fundamental-gmsm 3 1))
|
|
(absm 0 (Z2-fundamental-gmsm 2 1)))
|
|
(funcall tw 4 (gbar 4 0 (gbar 3 0 2 0 1 0 0)
|
|
0 (gbar 2 0 1 0 0)
|
|
1 (gbar 0)
|
|
0 (gbar 0)))
|
|
|#
|
|
|
|
(DEFUN Z2-WHITEHEAD (smst chml-clss &aux (n (- (degr chml-clss))))
|
|
(declare
|
|
(type simplicial-set smst)
|
|
(fixnum n)
|
|
(type morphism chml-clss))
|
|
(the fibration
|
|
(build-smmr
|
|
:sorc smst :trgt (k-z2 (1- n)) :degr -1
|
|
:sintr (Z2-whitehead-sintr smst n chml-clss)
|
|
:orgn `(Z2-whitehead ,smst))))
|
|
|
|
#|
|
|
(setf m (moore 2 4))
|
|
(setf chml-clss
|
|
(build-mrph
|
|
:sorc m :trgt (z-chcm) :degr -4
|
|
:intr #'(lambda (dmns gmsm)
|
|
(if (= 4 dmns)
|
|
(cmbn 0 1 :z-gnrt)
|
|
(zero-cmbn (- dmns 4))))
|
|
:strt :gnrt
|
|
:orgn '(chml-clss moore 2 4)))
|
|
(setf mf (z2-whitehead m 4 chml-clss))
|
|
(setf mt (fibration-total mf))
|
|
(homology mt 0 10)
|
|
|#
|
|
|