1072 lines
28 KiB
Common Lisp
1072 lines
28 KiB
Common Lisp
;;; K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1
|
|
;;; K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1
|
|
;;; K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1
|
|
|
|
(IN-PACKAGE "COMMON-LISP-USER")
|
|
|
|
(PROVIDE "k-pi-1")
|
|
|
|
(DEFUN K-Z-1-CMPR (gnrt1 gnrt2)
|
|
(declare (list gnrt1 gnrt2))
|
|
(the cmpr
|
|
(do ((mark1 gnrt1 (cdr mark1))
|
|
(mark2 gnrt2 (cdr mark2)))
|
|
((endp mark1) :equal)
|
|
(case (f-cmpr (car mark1) (car mark2))
|
|
(:equal)
|
|
(:less (return-from k-z-1-cmpr :less))
|
|
(:greater (return-from k-z-1-cmpr :greater))))))
|
|
|
|
#|
|
|
(k-z-1-cmpr '(1 1 2) '(1 2 2))
|
|
(k-z-1-cmpr '(1 1 2) '(1 1 2))
|
|
(k-z-1-cmpr '(1 1 2) '(1 1 -1))
|
|
|#
|
|
|
|
(DEFUN K-Z-1-FACE (indx dmns gmsm)
|
|
(declare
|
|
(fixnum indx dmns)
|
|
(list gmsm))
|
|
(the absm
|
|
(cond ((zerop indx) (absm 0 (rest gmsm)))
|
|
((= indx dmns) (absm 0 (butlast gmsm)))
|
|
(t
|
|
(do ((rslt +empty-list+ (cons (car mark) rslt))
|
|
(mark gmsm (cdr mark))
|
|
(i 1 (1+ i)))
|
|
((= i indx) (let ((new-k (+ (car mark) (cadr mark))))
|
|
(declare (fixnum new-k))
|
|
(if (zerop new-k)
|
|
(absm (2-exp (1- indx)) (nreconc rslt (cddr mark)))
|
|
(absm 0 (nreconc rslt (cons new-k (cddr mark)))))))
|
|
(declare
|
|
(list rslt mark)
|
|
(fixnum i)))))))
|
|
|
|
#|
|
|
(k-z-1-face 0 1 '(3))
|
|
(k-z-1-face 1 1 '(3))
|
|
(k-z-1-face 0 3 '(1 2 3))
|
|
(k-z-1-face 1 3 '(1 2 3))
|
|
(k-z-1-face 2 3 '(1 2 3))
|
|
(k-z-1-face 2 3 '(1 2 -2))
|
|
(k-z-1-face 3 3 '(1 2 3))
|
|
|#
|
|
|
|
(DEFUN Z-ABSM-BAR (absm)
|
|
(declare (type absm absm))
|
|
(the list
|
|
(with-absm (dgop bar1) absm
|
|
(do ((dgop dgop (ash dgop -1))
|
|
(rslt +empty-list+))
|
|
((and (zerop dgop) (endp bar1)) (nreverse rslt))
|
|
(declare
|
|
(fixnum dgop)
|
|
(list rslt))
|
|
(push (if (oddp dgop)
|
|
0
|
|
(pop bar1))
|
|
rslt)))))
|
|
|
|
#|
|
|
(z-absm-bar (absm 0 '()))
|
|
(z-absm-bar (absm 1 '()))
|
|
(z-absm-bar (absm 0 '(2)))
|
|
(dotimes (i 8)
|
|
(print (z-absm-bar (absm i '(3 6)))))
|
|
|#
|
|
|
|
(DEFUN Z-BAR-ABSM (bar)
|
|
(declare (list bar))
|
|
(the absm
|
|
(do ((rslt-dgop 0)
|
|
(rslt-bar +empty-list+)
|
|
(mark bar (cdr mark))
|
|
(bark 1 (+ bark bark)))
|
|
((endp mark) (absm rslt-dgop (nreverse rslt-bar)))
|
|
(declare
|
|
(fixnum rslt-dgop bark)
|
|
(list rslt-bar mark))
|
|
(let ((k-i (car mark)))
|
|
(declare (fixnum k-i))
|
|
(if (zerop k-i)
|
|
(incf rslt-dgop bark)
|
|
(push k-i rslt-bar))))))
|
|
|
|
#|
|
|
(z-bar-absm (z-absm-bar (absm 0 '())))
|
|
(z-bar-absm (z-absm-bar (absm 1 '())))
|
|
(z-bar-absm (z-absm-bar (absm 0 '(2))))
|
|
(dotimes (i 8)
|
|
(print (z-bar-absm (z-absm-bar (absm i '(3 6))))))
|
|
|#
|
|
|
|
(DEFUN K-Z-1-GRML (dmns crpr)
|
|
(declare
|
|
(fixnum dmns)
|
|
(type crpr crpr))
|
|
(the absm
|
|
(with-crpr (dgop1 bar1 dgop2 bar2) crpr
|
|
(do ((indx 1 (1+ indx))
|
|
(dgop1 dgop1 (ash dgop1 -1))
|
|
(dgop2 dgop2 (ash dgop2 -1))
|
|
(bark 1 (ash bark +1))
|
|
(rslt-dgop 0)
|
|
(rslt-bar +empty-list+))
|
|
((> indx dmns) (absm rslt-dgop (nreverse rslt-bar)))
|
|
(declare
|
|
(fixnum indx dgop1 dgop2 bark rslt-dgop)
|
|
(list rslt-bar))
|
|
(let ((item (if (evenp dgop1)
|
|
(if (evenp dgop2)
|
|
(+ (pop bar1) (pop bar2))
|
|
(pop bar1))
|
|
(if (evenp dgop2)
|
|
(pop bar2)
|
|
0))))
|
|
(declare (fixnum item))
|
|
(if (zerop item)
|
|
(incf rslt-dgop bark)
|
|
(push item rslt-bar)))))))
|
|
|
|
#|
|
|
(k-z-1-grml 0 (crpr 0 nil 0 nil))
|
|
(k-z-1-grml 1 (crpr 0 '(3) 0 '(4)))
|
|
(k-z-1-grml 1 (crpr 0 '(3) 0 '(-3)))
|
|
(k-z-1-grml 1 (crpr 0 '(3) 1 '()))
|
|
(k-z-1-grml 1 (crpr 1 '() 0 '(3)))
|
|
(k-z-1-grml 1 (crpr 1 '() 1 '()))
|
|
(k-z-1-grml 5 (crpr 24 '(2 2 3) 20 '(-2 2 4)))
|
|
|#
|
|
|
|
(DEFUN K-Z-1-GRIN (dmns bar)
|
|
(declare
|
|
(ignore dmns)
|
|
(list bar))
|
|
(the absm
|
|
(absm 0 (mapcar #'- bar))))
|
|
|
|
#|
|
|
(k-z-1-grin 3 '(2 3 -4))
|
|
(setf gmsm '(2 3 -4))
|
|
(k-z-1-grml 3 (crpr 0 gmsm 0 (gmsm (k-z-1-grin 3 gmsm))))
|
|
|#
|
|
|
|
#|
|
|
(DEFUN K-Z-1-KFLL (indx dmns hat)
|
|
(declare
|
|
(fixnum indx dmns)
|
|
(list hat))
|
|
(the absm
|
|
(cond ((= 1 dmns)
|
|
(absm 1 +empty-list+))
|
|
((zerop indx)
|
|
(let ((del-1 (first hat))
|
|
(del-2 (second hat)))
|
|
(declare (type absm del-1 del-2))
|
|
(with-absm (dgop1 bar1) del-1
|
|
(with-absm (dgop2 bar2) del-2
|
|
(let ((bar01 (if (oddp dgop2)
|
|
0
|
|
(first bar2)))
|
|
(bar02 (if (oddp dgop1)
|
|
0
|
|
(first bar1))))
|
|
(declare (fixnum bar01 bar02))
|
|
(let ((bar12 (- bar02 bar01)))
|
|
(declare (fixnum bar02))
|
|
(if (zerop bar01)
|
|
(1dgnr 0 del-1)
|
|
(if (zerop bar12)
|
|
(1gnr 1 del-1)
|
|
(let (del-01 (k-z-1-face 0 (1- dmns)
|
|
del-1))
|
|
(declare (type absm del-01))
|
|
(with-absm (dgop01 gmsm01) del-01
|
|
(absm (* 4 dgop01)
|
|
(cons bar01
|
|
(cons bar02 gmsm01)))))))))))))
|
|
((= 1 indx)
|
|
(let ((del-0 (first hat))
|
|
(del-2 (second hat)))
|
|
(declare (type absm del-0 del-2))
|
|
(with-absm (dgop0 gmsm0) del-0
|
|
(with-absm (dgop2 gmsm2) del-2
|
|
(if (oddp dgop2 )))))))))
|
|
|
|
|#
|
|
|
|
(DEFUN K-Z-1 ()
|
|
(the ab-simplicial-group
|
|
(build-ab-smgr
|
|
:cmpr #'k-z-1-cmpr
|
|
:basis :locally-effective
|
|
:bspn +empty-list+
|
|
:face #'k-z-1-face
|
|
:sintr-grml #'k-z-1-grml
|
|
:sintr-grin #'k-z-1-grin
|
|
:orgn '(k-z-1))))
|
|
|
|
#|
|
|
(setf k (k-z-1))
|
|
(defun aleat-list (max length)
|
|
(let ((rslt nil)
|
|
(2max (+ max max)))
|
|
(dotimes (i length)
|
|
(push (let ((k (- (random 2max) max)))
|
|
(if (zerop k)
|
|
max
|
|
k))
|
|
rslt))
|
|
rslt))
|
|
(? k (? k 14 (aleat-list 200 14)))
|
|
(setf zero? (add (idnt-mrph k) (grin k)))
|
|
(? zero? 14 (aleat-list 200 14))
|
|
|#
|
|
|
|
(DEFUN K-Z (n)
|
|
(declare (fixnum n))
|
|
(the ab-simplicial-group
|
|
(if (= n 1)
|
|
(k-z-1)
|
|
(classifying-space (k-z (1- n))))))
|
|
|
|
(DEFUN CIRCLE-CMPR (gnrt1 gnrt2)
|
|
(declare (ignore gnrt1 gnrt2))
|
|
(the cmpr :equal))
|
|
|
|
(DEFUN CIRCLE-BASIS (dmns)
|
|
(declare (fixnum dmns))
|
|
(the list
|
|
(case dmns
|
|
(0 '(*))
|
|
(1 '(s1))
|
|
(otherwise +empty-list+))))
|
|
|
|
(DEFUN CIRCLE ()
|
|
(the chain-complex
|
|
(build-chcm
|
|
:cmpr #'circle-cmpr
|
|
:basis #'circle-basis
|
|
:bsgn '*
|
|
:intr-dffr #'zero-intr-dffr
|
|
:strt :cmbn
|
|
:orgn '(circle))))
|
|
|
|
#|
|
|
(setf c (circle))
|
|
(cmpr c '* '*)
|
|
(basis c 1)
|
|
(? c 1 's1)
|
|
|#
|
|
|
|
(DEFUN KZ1-RDCT-F-INTR (cmbn)
|
|
(declare (type cmbn cmbn))
|
|
(the cmbn
|
|
(with-cmbn (degr list) cmbn
|
|
(case degr
|
|
(0 (if list
|
|
(term-cmbn 0 (-cffc list) '*)
|
|
(zero-cmbn 0)))
|
|
(1 (let ((rslt
|
|
(apply #'+
|
|
(mapcar
|
|
#'(lambda (term)
|
|
(declare (type term term))
|
|
(with-term (cffc gnrt) term
|
|
(the fixnum (* cffc
|
|
(first gnrt)))))
|
|
list))))
|
|
(if (zerop rslt)
|
|
(zero-cmbn 1)
|
|
(term-cmbn 1 rslt 's1))))
|
|
(otherwise (zero-cmbn degr))))))
|
|
|
|
#|
|
|
(kz1-rdct-f-intr (cmbn 0))
|
|
(kz1-rdct-f-intr (cmbn 0 4 '()))
|
|
(kz1-rdct-f-intr (cmbn 1))
|
|
(kz1-rdct-f-intr (cmbn 1 4 '(3)))
|
|
(kz1-rdct-f-intr (cmbn 1 4 '(3) 5 '(2)))
|
|
(kz1-rdct-f-intr (cmbn 1 4 '(3) -3 '(4)))
|
|
(kz1-rdct-f-intr (cmbn -3))
|
|
|#
|
|
|
|
(DEFUN KZ1-RDCT-F ()
|
|
(the morphism
|
|
(build-mrph
|
|
:sorc (k-z-1)
|
|
:trgt (circle)
|
|
:degr 0
|
|
:intr #'kz1-rdct-f-intr
|
|
:strt :cmbn
|
|
:orgn '(kz1-rdct-f))))
|
|
|
|
(DEFUN KZ1-RDCT-G-INTR (cmbn)
|
|
(declare (type cmbn cmbn))
|
|
(the cmbn
|
|
(with-cmbn (degr list) cmbn
|
|
(if list
|
|
(ecase degr
|
|
(0 (term-cmbn 0 (-cffc list) +empty-list+))
|
|
(1 (term-cmbn 1 (-cffc list) (list 1))))
|
|
(zero-cmbn degr)))))
|
|
|
|
(DEFUN KZ1-RDCT-G ()
|
|
(the morphism
|
|
(build-mrph
|
|
:sorc (circle)
|
|
:trgt (k-z-1)
|
|
:degr 0
|
|
:intr #'kz1-rdct-g-intr
|
|
:strt :cmbn
|
|
:orgn '(kz1-rdct-g))))
|
|
|
|
(DEFUN KZ1-RDCT-H-INTR (dmns bar)
|
|
(declare
|
|
(fixnum dmns)
|
|
(list bar))
|
|
(the cmbn
|
|
(progn
|
|
(when (zerop dmns)
|
|
(return-from kz1-rdct-h-intr (zero-cmbn +1)))
|
|
(let ((k1 (first bar))
|
|
(tail (rest bar)))
|
|
(declare
|
|
(fixnum k1)
|
|
(list tail))
|
|
(if (plusp k1)
|
|
(do ((rslt +empty-list+
|
|
(cons (term -1
|
|
(cons 1 (cons i tail)))
|
|
rslt))
|
|
(i (1- k1) (1- i)))
|
|
((zerop i) (make-cmbn :degr (1+ dmns)
|
|
:list rslt))
|
|
(declare
|
|
(list rslt)
|
|
(fixnum i)))
|
|
(do ((rslt +empty-list+
|
|
(cons (term +1
|
|
(cons 1 (cons i tail)))
|
|
rslt))
|
|
(i -1 (1- i)))
|
|
((< i k1) (make-cmbn :degr (1+ dmns)
|
|
:list rslt))))))))
|
|
|
|
#|
|
|
(kz1-rdct-h-intr 0 nil)
|
|
(kz1-rdct-h-intr 1 '(-4))
|
|
(kz1-rdct-h-intr 1 '(-1))
|
|
(kz1-rdct-h-intr 1 '(1))
|
|
(kz1-rdct-h-intr 1 '(4))
|
|
(kz1-rdct-h-intr 3 '(-4 3 5))
|
|
(kz1-rdct-h-intr 3 '(-1 3 -1))
|
|
(kz1-rdct-h-intr 3 '(1 2 2))
|
|
(kz1-rdct-h-intr 3 '(4 3 5))
|
|
|#
|
|
|
|
(DEFUN KZ1-RDCT-H ()
|
|
(the morphism
|
|
(build-mrph
|
|
:sorc (k-z-1)
|
|
:trgt (k-z-1)
|
|
:degr +1
|
|
:intr #'kz1-rdct-h-intr
|
|
:strt :gnrt
|
|
:orgn '(kz1-rdct-h))))
|
|
|
|
(DEFUN KZ1-RDCT ()
|
|
(the reduction
|
|
(build-rdct
|
|
:f (kz1-rdct-f)
|
|
:g (kz1-rdct-g)
|
|
:h (kz1-rdct-h)
|
|
:orgn '(kz1-rdct))))
|
|
|
|
#|
|
|
(pre-check-rdct (kz1-rdct))
|
|
(setf *tc* (cmbn 0 1 '()))
|
|
(setf *bc* (cmbn 0 1 '*))
|
|
(check-rdct)
|
|
(setf *tc* (cmbn 1 1 '(-4) 10 '(-1) 100 '(1) 1000 '(5)))
|
|
(setf *bc* (cmbn 1 1 's1))
|
|
(check-rdct)
|
|
(setf *tc* (cmbn 2 1 '(-4 2) 10 '(-1 3) 100 '(1 -4) 1000 '(5 5)))
|
|
(check-rdct)
|
|
(setf *tc* (cmbn 3 1 '(-4 -4 5) 10 '(-1 2 1)
|
|
100 '(1 4 2) 1000 '(5 1 -1)))
|
|
(check-rdct)
|
|
|#
|
|
|
|
(DEFUN KZ1-EFHM ()
|
|
(the homotopy-equivalence
|
|
(build-hmeq
|
|
:lrdct (trivial-rdct (k-z-1))
|
|
:rrdct (kz1-rdct)
|
|
:orgn '(kz1-efhm))))
|
|
|
|
(DEFMETHOD SEARCH-EFHM (k-z-1 (orgn (eql 'k-z-1)))
|
|
(declare (ignore k-z-1))
|
|
(kz1-efhm))
|
|
|
|
#|
|
|
(cat-init)
|
|
(homology (k-z-1) 1)
|
|
|#
|
|
|
|
(DEFUN K-Z2-1-GRML-INTR (dmns crpr)
|
|
(declare
|
|
(fixnum dmns)
|
|
(type crpr crpr))
|
|
(the absm
|
|
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
|
|
(declare (ignore gmsm1 gmsm2))
|
|
(let ((dgop (- (mask dmns) (logxor dgop1 dgop2))))
|
|
(declare (fixnum dgop))
|
|
(absm dgop (- dmns (logcount dgop)))))))
|
|
|
|
(DEFUN K-Z2-1-GRML ()
|
|
(the simplicial-mrph
|
|
(build-smmr
|
|
:sorc (crts-prdc (r-proj-space) (r-proj-space))
|
|
:trgt (r-proj-space)
|
|
:degr 0
|
|
:sintr #'k-z2-1-grml-intr
|
|
:orgn '(k-z2-1-grml))))
|
|
|
|
(DEFUN K-Z2-1-GRIN-INTR (dmns gmsm)
|
|
(declare
|
|
(ignore dmns)
|
|
(fixnum gmsm))
|
|
(the absm
|
|
(absm 0 gmsm)))
|
|
|
|
(DEFUN K-Z2-1-GRIN ()
|
|
(the simplicial-mrph
|
|
(build-smmr
|
|
:sorc (r-proj-space)
|
|
:trgt (r-proj-space)
|
|
:degr 0
|
|
:sintr #'k-z2-1-grin-intr
|
|
:intr #'identity
|
|
:strt :cmbn
|
|
:orgn '(k-z2-1-grin))))
|
|
|
|
(DEFUN K-Z2-1 ()
|
|
(the ab-simplicial-group
|
|
(let ((rslt (r-proj-space)))
|
|
(declare (type simplicial-set rslt))
|
|
(change-class rslt 'ab-simplicial-group)
|
|
(setf (slot-value rslt 'grml)
|
|
(k-z2-1-grml)
|
|
(slot-value rslt 'grin)
|
|
(k-z2-1-grin))
|
|
(pushnew rslt *smgr-list*)
|
|
rslt)))
|
|
|
|
#|
|
|
(setf k (k-z2-1))
|
|
(homology k 0 4)
|
|
|#
|
|
|
|
(DEFUN K-Z2 (n)
|
|
(declare (fixnum n))
|
|
(the ab-simplicial-group
|
|
(if (= n 1)
|
|
(k-z2-1)
|
|
(classifying-space (k-z2 (1- n))))))
|
|
|
|
#|
|
|
(setf k3 (k-z2 3))
|
|
(homology k3 7)
|
|
|#
|
|
|
|
(DEFUN Z2-ABSM-BAR (absm)
|
|
(declare (type absm absm))
|
|
(the list
|
|
(with-absm (dgop gmsm) absm
|
|
(do ((bmark (1- (+ (logcount dgop) gmsm)) (1- bmark))
|
|
(rslt +empty-list+
|
|
(cons (if (logbitp bmark dgop)
|
|
0 1)
|
|
rslt)))
|
|
((minusp bmark) rslt)
|
|
(declare
|
|
(fixnum bmark)
|
|
(list rslt))))))
|
|
|
|
(DEFUN Z2-BAR-ABSM (bar)
|
|
(declare (list bar))
|
|
(the absm
|
|
(do ((dgop 0)
|
|
(2-pwr 1 (+ 2-pwr 2-pwr))
|
|
(gmsm 0)
|
|
(mark bar (cdr mark)))
|
|
((endp mark) (absm dgop gmsm))
|
|
(declare
|
|
(fixnum dgop 2-pwr gmsm)
|
|
(list mark))
|
|
(if (zerop (car mark))
|
|
(incf dgop 2-pwr)
|
|
(incf gmsm)))))
|
|
|
|
#|
|
|
(dotimes (i 8) ;;; not really legal
|
|
(dotimes (j 8)
|
|
(print (z2-bar-absm (z2-absm-bar (absm i j))))))
|
|
|#
|
|
|
|
|
|
(DEFUN HOPF-FIBRATION-SINTR (n)
|
|
(declare (fixnum n))
|
|
(flet ((rslt (dmns gmsm)
|
|
(declare (ignore dmns gmsm))
|
|
(if (zerop n)
|
|
(absm 1 +empty-list+)
|
|
(absm 0 (list n)))))
|
|
(the sintr #'rslt)))
|
|
|
|
(DEFUN HOPF-FIBRATION (n)
|
|
(declare (fixnum n))
|
|
(the simplicial-mrph
|
|
(build-smmr
|
|
:sorc (sphere 2)
|
|
:trgt (k-z-1)
|
|
:degr -1
|
|
:sintr (hopf-fibration-sintr n)
|
|
:orgn `(hopf-fibration ,n))))
|
|
|
|
(DEFUN Z-FUNDAMENTAL-GMSM (dmns pi-elm) ;;; pi-elm not equal to 0
|
|
(declare (fixnum dmns pi-elm))
|
|
(the gmsm
|
|
(if (= 1 dmns)
|
|
(list pi-elm)
|
|
(let ((bspn (if (= 2 dmns) +empty-list+ +null-gbar+)))
|
|
(declare (type gmsm bspn))
|
|
(make-gbar :dmns dmns
|
|
:list (cons (absm 0 (z-fundamental-gmsm (1- dmns) pi-elm))
|
|
(mapcar
|
|
#'(lambda (k)
|
|
(declare (fixnum k))
|
|
(absm (mask k) bspn))
|
|
(nreverse (<a-b> 0 (- dmns 2))))))))))
|
|
|
|
#|
|
|
(z-fundamental-gmsm 1 33)
|
|
(z-fundamental-gmsm 2 33)
|
|
(z-fundamental-gmsm 3 33)
|
|
(z-fundamental-gmsm 4 33)
|
|
|#
|
|
|
|
(DEFUN INTERESTING-FACES (face small-dmns high-dmns gmsm)
|
|
(declare
|
|
(type face face)
|
|
(fixnum small-dmns high-dmns)
|
|
(type gmsm gmsm))
|
|
(the list
|
|
(let ((max (mask high-dmns)))
|
|
(declare (fixnum max))
|
|
(if (= small-dmns high-dmns)
|
|
(list (cons max (absm 0 gmsm)))
|
|
(do ((prev-list (interesting-faces face (1+ small-dmns) high-dmns gmsm))
|
|
(k (1- max) (1- k))
|
|
(rslt +empty-list+)
|
|
(count (binomial-n-p high-dmns small-dmns)))
|
|
((zerop count) rslt)
|
|
(declare
|
|
(list prev-list rslt)
|
|
(fixnum k count))
|
|
(when (= small-dmns (logcount k))
|
|
(decf count)
|
|
(do ((i 0 (1+ i)))
|
|
((not (logbitp i k))
|
|
(push (cons k
|
|
(a-face4 face
|
|
(- small-dmns -1
|
|
(if (= i (integer-length k)) (1+ i) i))
|
|
(1+ small-dmns)
|
|
(cdr (assoc (+ k (2-exp i)) prev-list))))
|
|
rslt)))))))))
|
|
|
|
#|
|
|
(setf d (delta 14))
|
|
(setf f (face d))
|
|
(do ((i 5 (1- i)))
|
|
((minusp i))
|
|
(print (interesting-faces f i 5 (mask 6))))
|
|
|#
|
|
|
|
(DEFUN GMSM-COCYCLE (face small-dmns high-dmns gmsm chml-clss)
|
|
(declare
|
|
(type face face)
|
|
(fixnum small-dmns high-dmns)
|
|
(type gmsm gmsm)
|
|
(type morphism chml-clss))
|
|
(the list
|
|
(let ((int-faces (interesting-faces face small-dmns high-dmns gmsm)))
|
|
(declare (list int-faces))
|
|
(mapc
|
|
#'(lambda (cons)
|
|
(declare (cons cons))
|
|
(setf (cdr cons)
|
|
(let ((absm (cdr cons)))
|
|
(declare (type absm absm))
|
|
(with-absm (dgop gmsm2) absm
|
|
(if (plusp dgop)
|
|
0
|
|
(let ((cmbn-list (cmbn-list (gnrt-? chml-clss
|
|
small-dmns gmsm2))))
|
|
(declare (list cmbn-list))
|
|
(if cmbn-list
|
|
(-cffc cmbn-list)
|
|
0)))))))
|
|
int-faces)
|
|
int-faces)))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf d (delta 10))
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -2
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 gmsm :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-1)))
|
|
(gmsm-cocycle (face d) 2 4 31 chml-clss)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -1
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 gmsm :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-2)))
|
|
(gmsm-cocycle (face d) 1 4 31 chml-clss)
|
|
|#
|
|
|
|
(DEFUN Z-COCYCLE-GBAR (n dmns cocycle)
|
|
;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z
|
|
(declare
|
|
(fixnum n dmns)
|
|
(list cocycle))
|
|
(the absm
|
|
(cond ((= n 1)
|
|
(z-bar-absm (nreverse (mapcar #'cdr cocycle))))
|
|
((= n dmns)
|
|
(let ((value (cdr (first cocycle))))
|
|
(declare (fixnum value))
|
|
(if (zerop value)
|
|
(absm (mask dmns) +null-gbar+)
|
|
(absm 0 (z-fundamental-gmsm dmns value)))))
|
|
(t
|
|
(let ((cocycle1 +empty-list+)
|
|
(cocycle2 +empty-list+))
|
|
(declare (list cocycle1 cocycle2))
|
|
(dolist (cons cocycle)
|
|
(declare (cons cons))
|
|
(if (evenp (car cons))
|
|
(push (cons (ash (car cons) -1) (cdr cons))
|
|
cocycle1)
|
|
(push (cons (ash (car cons) -1) (cdr cons))
|
|
cocycle2)))
|
|
(setf cocycle1 (nreverse cocycle1)
|
|
cocycle2 (nreverse cocycle2))
|
|
(mapc
|
|
#'(lambda (cons)
|
|
(declare (cons cons))
|
|
(when (evenp (car cons))
|
|
(decf (cdr cons)
|
|
(cdr (assoc (1+ (car cons)) cocycle1)))))
|
|
cocycle2)
|
|
(let ((head-absm (z-cocycle-gbar (1- n) (1- dmns) cocycle2))
|
|
(tail-absm (z-cocycle-gbar n (1- dmns) cocycle1)))
|
|
(declare (type absm head-absm tail-absm))
|
|
(normalize-gbar
|
|
(cons dmns
|
|
(cons head-absm
|
|
(rest (unnormalize-gbar tail-absm
|
|
(if (= n 2) () +null-gbar+))))))))))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf d (delta 10))
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -1
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 gmsm :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-1)))
|
|
(gmsm-cocycle (face d) 1 4 31 chml-clss)
|
|
(z-cocycle-gbar 1 4 *)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -2
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 gmsm :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-2)))
|
|
(gmsm-cocycle (face d) 2 2 7 chml-clss)
|
|
(z-cocycle-gbar 2 2 *)
|
|
(gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
|
|
(z-cocycle-gbar 2 2 *)
|
|
(gmsm-cocycle (face d) 2 3 15 chml-clss)
|
|
(z-cocycle-gbar 2 3 *)
|
|
(gmsm-cocycle (face d) 2 4 31 chml-clss)
|
|
(z-cocycle-gbar 2 4 *)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -3
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 gmsm :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-3)))
|
|
(gmsm-cocycle (face d) 3 4 31 chml-clss)
|
|
(z-cocycle-gbar 3 4 *)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -3
|
|
:intr #'(lambda (dmns gmsm)
|
|
(zero-cmbn 0))
|
|
:strt :gnrt
|
|
:orgn '(essai-33)))
|
|
(gmsm-cocycle (face d) 3 4 31 chml-clss)
|
|
(z-cocycle-gbar 3 4 *)
|
|
|#
|
|
|
|
(DEFUN Z-COCYCLE-GBAR-HEAD (n dmns cocycle)
|
|
;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z
|
|
(declare
|
|
(fixnum n dmns)
|
|
(list cocycle))
|
|
(the absm
|
|
(cond ((= n 1)
|
|
(error "In Z-COCYCLE-GBAR-HEAD, this point should not have been reached."))
|
|
; (z-bar-absm (nreverse (mapcar #'cdr cocycle))))
|
|
((= n dmns)
|
|
(let ((value (cdr (first cocycle))))
|
|
(declare (fixnum value))
|
|
(if (zerop value)
|
|
(if (= n 2)
|
|
(absm 1 +empty-list+)
|
|
(absm (mask (1- dmns)) +null-gbar+))
|
|
(absm 0 (z-fundamental-gmsm (1- dmns) value)))))
|
|
(t
|
|
(let ((cocycle1 +empty-list+)
|
|
(cocycle2 +empty-list+))
|
|
(declare (list cocycle1 cocycle2))
|
|
(dolist (cons cocycle)
|
|
(declare (cons cons))
|
|
(if (evenp (car cons))
|
|
(push (cons (ash (car cons) -1) (cdr cons))
|
|
cocycle1)
|
|
(push (cons (ash (car cons) -1) (cdr cons))
|
|
cocycle2)))
|
|
(setf cocycle1 (nreverse cocycle1)
|
|
cocycle2 (nreverse cocycle2))
|
|
(mapc
|
|
#'(lambda (cons)
|
|
(declare (cons cons))
|
|
(when (evenp (car cons))
|
|
(decf (cdr cons)
|
|
(cdr (assoc (1+ (car cons)) cocycle1)))))
|
|
cocycle2)
|
|
(z-cocycle-gbar (1- n) (1- dmns) cocycle2))))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf d (delta 10))
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -1
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 gmsm :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-1)))
|
|
(gmsm-cocycle (face d) 1 4 31 chml-clss)
|
|
(z-cocycle-gbar 1 4 *)
|
|
(z-cocycle-gbar-head 1 4 **)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -2
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 gmsm :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-2)))
|
|
(gmsm-cocycle (face d) 2 2 7 chml-clss)
|
|
(z-cocycle-gbar 2 2 *)
|
|
(z-cocycle-gbar-head 2 2 **)
|
|
(gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
|
|
(z-cocycle-gbar 2 2 *)
|
|
(z-cocycle-gbar-head 2 2 **)
|
|
(gmsm-cocycle (face d) 2 3 15 chml-clss)
|
|
(z-cocycle-gbar 2 3 *)
|
|
(z-cocycle-gbar-head 2 3 **)
|
|
(gmsm-cocycle (face d) 2 4 31 chml-clss)
|
|
(z-cocycle-gbar 2 4 *)
|
|
(z-cocycle-gbar-head 2 4 **)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -3
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 gmsm :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-3)))
|
|
(gmsm-cocycle (face d) 3 4 31 chml-clss)
|
|
(z-cocycle-gbar 3 4 *)
|
|
(z-cocycle-gbar-head 3 4 **)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -3
|
|
:intr #'(lambda (dmns gmsm)
|
|
(zero-cmbn 0))
|
|
:strt :gnrt
|
|
:orgn '(essai-33)))
|
|
(gmsm-cocycle (face d) 3 4 31 chml-clss)
|
|
(z-cocycle-gbar 3 4 *)
|
|
(z-cocycle-gbar-head 3 4 **)
|
|
|#
|
|
|
|
(DEFUN Z2-FUNDAMENTAL-GMSM (dmns pi-elm) ;; pi-elm not "equal" to 0, therefore 1.
|
|
(declare (fixnum dmns pi-elm))
|
|
(the gmsm
|
|
(if (= 1 dmns)
|
|
1
|
|
(let ((bspn (if (= 2 dmns) 0 +null-gbar+)))
|
|
(declare (type gmsm bspn))
|
|
(make-gbar :dmns dmns
|
|
:list (cons (absm 0 (Z2-fundamental-gmsm (1- dmns) pi-elm))
|
|
(mapcar
|
|
#'(lambda (k)
|
|
(declare (fixnum k))
|
|
(absm (mask k) bspn))
|
|
(nreverse (<a-b> 0 (- dmns 2))))))))))
|
|
|
|
#|
|
|
(Z2-fundamental-gmsm 1 1)
|
|
(Z2-fundamental-gmsm 2 1)
|
|
(Z2-fundamental-gmsm 3 1)
|
|
(Z2-fundamental-gmsm 4 1)
|
|
|#
|
|
|
|
(DEFUN Z2-COCYCLE-GBAR (n dmns cocycle)
|
|
;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z/2Z
|
|
(declare
|
|
(fixnum n dmns)
|
|
(list cocycle))
|
|
(the absm
|
|
(progn
|
|
(mapc
|
|
#'(lambda (cons)
|
|
(declare (cons cons))
|
|
(setf (cdr cons)
|
|
(if (evenp (cdr cons)) 0 1)))
|
|
cocycle)
|
|
(cond ((= n 1)
|
|
(z2-bar-absm (nreverse (mapcar #'cdr cocycle))))
|
|
((= n dmns)
|
|
(let ((value (cdr (first cocycle))))
|
|
(declare (fixnum value))
|
|
(if (zerop value)
|
|
(absm (mask dmns) +null-gbar+)
|
|
(absm 0 (z2-fundamental-gmsm dmns value)))))
|
|
(t
|
|
(let ((cocycle1 +empty-list+)
|
|
(cocycle2 +empty-list+))
|
|
(declare (list cocycle1 cocycle2))
|
|
(dolist (cons cocycle)
|
|
(declare (cons cons))
|
|
(if (evenp (car cons))
|
|
(push (cons (ash (car cons) -1) (cdr cons))
|
|
cocycle1)
|
|
(push (cons (ash (car cons) -1) (cdr cons))
|
|
cocycle2)))
|
|
(setf cocycle1 (nreverse cocycle1)
|
|
cocycle2 (nreverse cocycle2))
|
|
(mapc
|
|
#'(lambda (cons)
|
|
(declare (cons cons))
|
|
(when (evenp (car cons))
|
|
(setf (cdr cons)
|
|
(mod (- (cdr cons)
|
|
(cdr (assoc (1+ (car cons)) cocycle1)))
|
|
2))))
|
|
cocycle2)
|
|
(let ((head-absm (z2-cocycle-gbar (1- n) (1- dmns) cocycle2))
|
|
(tail-absm (z2-cocycle-gbar n (1- dmns) cocycle1)))
|
|
(declare (type absm head-absm tail-absm))
|
|
(normalize-gbar
|
|
(cons dmns
|
|
(cons head-absm
|
|
(rest (unnormalize-gbar tail-absm
|
|
(if (= n 2) 0 +null-gbar+)))))))))))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf d (delta 10))
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -1
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 (mod gmsm 2) :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-1)))
|
|
(gmsm-cocycle (face d) 1 4 31 chml-clss)
|
|
(z2-cocycle-gbar 1 4 *)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -2
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 (mod gmsm 2) :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-2)))
|
|
(gmsm-cocycle (face d) 2 2 7 chml-clss)
|
|
(z2-cocycle-gbar 2 2 *)
|
|
(gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
|
|
(z2-cocycle-gbar 2 2 *)
|
|
(gmsm-cocycle (face d) 2 3 15 chml-clss)
|
|
(z2-cocycle-gbar 2 3 *)
|
|
(gmsm-cocycle (face d) 2 4 31 chml-clss)
|
|
(z2-cocycle-gbar 2 4 *)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -3
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 (mod gmsm 2) :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-3)))
|
|
(gmsm-cocycle (face d) 3 4 31 chml-clss)
|
|
(z2-cocycle-gbar 3 4 *)
|
|
|#
|
|
|
|
(DEFUN Z2-COCYCLE-GBAR-HEAD (n dmns cocycle)
|
|
;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z/2Z
|
|
(declare
|
|
(fixnum n dmns)
|
|
(list cocycle))
|
|
(the absm
|
|
(progn
|
|
(mapc
|
|
#'(lambda (cons)
|
|
(setf (cdr cons)
|
|
(if (evenp (cdr cons)) 0 1)))
|
|
cocycle)
|
|
(cond ((= n 1)
|
|
(error "In Z2-COCYCLE-GBAR-HEAD, this point should not have been reached."))
|
|
; (z2-bar-absm (nreverse (mapcar #'cdr cocycle))))
|
|
((= n dmns)
|
|
(let ((value (cdr (first cocycle))))
|
|
(declare (fixnum value))
|
|
(if (zerop value)
|
|
(if (= n 2)
|
|
(absm 1 0)
|
|
(absm (mask (1- dmns)) +null-gbar+))
|
|
(absm 0 (z2-fundamental-gmsm (1- dmns) value)))))
|
|
(t
|
|
(let ((cocycle1 +empty-list+)
|
|
(cocycle2 +empty-list+))
|
|
(declare (list cocycle1 cocycle2))
|
|
(dolist (cons cocycle)
|
|
(declare (cons cons))
|
|
(if (evenp (car cons))
|
|
(push (cons (ash (car cons) -1) (cdr cons))
|
|
cocycle1)
|
|
(push (cons (ash (car cons) -1) (cdr cons))
|
|
cocycle2)))
|
|
(setf cocycle1 (nreverse cocycle1)
|
|
cocycle2 (nreverse cocycle2))
|
|
(mapc
|
|
#'(lambda (cons)
|
|
(declare (cons cons))
|
|
(when (evenp (car cons))
|
|
(setf (cdr cons)
|
|
(mod (- (cdr cons)
|
|
(cdr (assoc (1+ (car cons)) cocycle1)))
|
|
2))))
|
|
cocycle2)
|
|
(z2-cocycle-gbar (1- n) (1- dmns) cocycle2)))))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf d (delta 10))
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -1
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 (mod gmsm 2) :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-1)))
|
|
(gmsm-cocycle (face d) 1 4 31 chml-clss)
|
|
(z2-cocycle-gbar 1 4 *)
|
|
(z2-cocycle-gbar-head 1 4 **)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -2
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 (mod gmsm 2) :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-2)))
|
|
(gmsm-cocycle (face d) 2 2 7 chml-clss)
|
|
(z2-cocycle-gbar 2 2 *)
|
|
(z2-cocycle-gbar-head 2 2 **)
|
|
(gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
|
|
(z2-cocycle-gbar 2 2 *)
|
|
(z2-cocycle-gbar-head 2 2 **)
|
|
(gmsm-cocycle (face d) 2 3 15 chml-clss)
|
|
(z2-cocycle-gbar 2 3 *)
|
|
(z2-cocycle-gbar-head 2 3 **)
|
|
(gmsm-cocycle (face d) 2 4 31 chml-clss)
|
|
(z2-cocycle-gbar 2 4 *)
|
|
(z2-cocycle-gbar-head 2 4 **)
|
|
(setf chml-clss
|
|
(build-mrph :sorc d :trgt (z-chcm) :degr -3
|
|
:intr #'(lambda (dmns gmsm)
|
|
(term-cmbn 0 (mod gmsm 2) :gnrt-z))
|
|
:strt :gnrt
|
|
:orgn '(essai-3)))
|
|
(gmsm-cocycle (face d) 3 4 31 chml-clss)
|
|
(z2-cocycle-gbar 3 4 *)
|
|
(z2-cocycle-gbar-head 3 4 **)
|
|
|#
|
|
|
|
(DEFUN K-Z-FUNDAMENTAL-CLASS (n)
|
|
(declare (fixnum n))
|
|
(the morphism
|
|
(build-mrph
|
|
:sorc (k-z n) :trgt (z-chcm) :degr (- n)
|
|
:intr #'(lambda (dmns gmsm)
|
|
(declare
|
|
(fixnum dmns)
|
|
(type gmsm gmsm))
|
|
(if (= dmns n)
|
|
(do ((gmsm gmsm (gmsm (first (gbar-list gmsm))))
|
|
(dmns dmns (1- dmns)))
|
|
((= 1 dmns)
|
|
(term-cmbn 0 (first gmsm) :z-gnrt))
|
|
(declare
|
|
(type gmsm gmsm)
|
|
(fixnum dmns)))
|
|
(zero-cmbn (- dmns n))))
|
|
:strt :gnrt
|
|
:orgn `(k-z-fundamental-class ,n))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf c1 (k-z-fundamental-class 1))
|
|
(? c1 1 '(34))
|
|
(? c1 2 '(34 45))
|
|
(setf c3 (k-z-fundamental-class 3))
|
|
(? c3 3 (z-fundamental-gmsm 3 45))
|
|
|#
|
|
|
|
(DEFUN K-Z2-FUNDAMENTAL-CLASS (n)
|
|
(declare (fixnum n))
|
|
(the morphism
|
|
(build-mrph
|
|
:sorc (k-z2 n) :trgt (z-chcm) :degr (- n)
|
|
:intr #'(lambda (dmns gmsm)
|
|
(declare
|
|
(fixnum dmns)
|
|
(ignore gmsm))
|
|
(if (= dmns n)
|
|
(term-cmbn 0 1 :z-gnrt)
|
|
(zero-cmbn (- dmns n))))
|
|
:strt :gnrt
|
|
:orgn `(k-z2-fundamental-class ,n))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf c1 (k-z2-fundamental-class 1))
|
|
(? c1 1 1)
|
|
(? c1 2 2)
|
|
(setf c3 (k-z2-fundamental-class 3))
|
|
(? c3 3 (z2-fundamental-gmsm 3 1))
|
|
|#
|
|
|