643 lines
15 KiB
Common Lisp
643 lines
15 KiB
Common Lisp
;;;============================================================================
|
|
;;;
|
|
;;; Subject: Examples to test the pushout
|
|
;;;
|
|
;;;
|
|
;;;----------------------------------------------------------------------------
|
|
;;;
|
|
;;; Author: Jónathan Heras Vicente
|
|
;;;
|
|
;;; 13/10/09
|
|
;;;
|
|
;;;============================================================================
|
|
|
|
|
|
;;; Adapted by Julián Cuevas, Jose Divasón, Miguel Marco Buzunariz and Ana Romero.
|
|
;; August 2019
|
|
;;; Most of the examples have been collected from the rest of the development
|
|
;;; and unified in this file.
|
|
|
|
;; ====================================
|
|
;; Examples cones2.lisp
|
|
;; ====================================
|
|
|
|
#|
|
|
()
|
|
(setf basis (cone-basis2
|
|
#'(lambda (n) (list n))
|
|
#'(lambda (n) (list n))))
|
|
(funcall basis 4)
|
|
|#
|
|
|
|
#|
|
|
()
|
|
(cone-cmbn-split2
|
|
(cmbn 3 4 (con0 'a) 5 (con1 'b)))
|
|
(cone-cmbn-split2 (cmbn 3 4 (con0 'a)))
|
|
(cone-cmbn-split2 (cmbn 3 4 (con1 'a)))
|
|
|#
|
|
|
|
#|
|
|
()
|
|
(cmbn-con02 (cmbn 3 1 'a 2 'b))
|
|
|#
|
|
|
|
#|
|
|
()
|
|
(setf mrph (dffr (delta 4)))
|
|
(setf rslt (cone-2mrph-diag-impl2 mrph mrph))
|
|
(funcall rslt (cmbn 3 4 (con0 15) 5 (con1 7)))
|
|
|#
|
|
|
|
|
|
#|
|
|
()
|
|
(setf rslt (cone-3mrph-triangle-impl2 #'f-cmpr
|
|
(dffr (delta 4))
|
|
(dffr (delta 4))
|
|
(idnt-mrph (delta 4))))
|
|
(funcall rslt 4 (con0 '31))
|
|
(funcall rslt 5 (con1 '31))
|
|
(funcall rslt 4 (con1 '15))
|
|
; (funcall rslt (cmbn 4 1 (con0 '31) 1 (con1 '15)))
|
|
|#
|
|
|
|
|
|
#|
|
|
()
|
|
(cat-init)
|
|
(setf k (k-z 1))
|
|
(setf u (idnt-mrph k))
|
|
(setf c (cone2 u))
|
|
(setf *tc* (cmbn 3 1 (con0 '(1 2 3 4))))
|
|
(? c 3 (con0 '(1 2 3 4)))
|
|
(? c *tc*)
|
|
|#
|
|
|
|
|
|
#|
|
|
()
|
|
(setf idnt (idnt-mrph (delta 4)))
|
|
(setf cone (cone2 idnt))
|
|
(setf ff (cone-2mrph-diag2 cone cone idnt idnt))
|
|
(? ff (cmbn 4 1 (con0 '31) 10 (con1 '15)))
|
|
|#
|
|
|
|
#|
|
|
()
|
|
(cat-init)
|
|
(setf d (delta 4))
|
|
(setf df (dffr (delta 4)))
|
|
(setf n (idnt-mrph d))
|
|
(setf c (cone n))
|
|
(setf z (sbtr (dffr c)
|
|
(cone-3mrph-triangle c c df (n-mrph -1 df) n)))
|
|
(? z 0 (con0 '1))
|
|
(? z 1 (con1 '1))
|
|
(? z 1 (con0 '3))
|
|
(? z 2 (con1 '3))
|
|
(? z 4 (con0 '31))
|
|
(? z 5 (con1 '31))
|
|
|#
|
|
|
|
|
|
;; ====================================
|
|
;; Examples direct-sum.lisp
|
|
;; ====================================
|
|
|
|
|
|
#|
|
|
()
|
|
(direct-sum-gsm 0 'a)
|
|
(direct-sum-gsm 1 'b)
|
|
|#
|
|
|
|
#|
|
|
()
|
|
(setf cmpr (direct-sum-cmpr #'s-cmpr #'f-cmpr))
|
|
(funcall cmpr (direct-sum-gsm 0 'a) (direct-sum-gsm 0 'b))
|
|
(funcall cmpr (direct-sum-gsm 0 'b) (direct-sum-gsm 0 'b))
|
|
(funcall cmpr (direct-sum-gsm 0 'b) (direct-sum-gsm 0 'a))
|
|
(funcall cmpr (direct-sum-gsm 0 'b) (direct-sum-gsm 1 '2))
|
|
(funcall cmpr (direct-sum-gsm 1 '2) (direct-sum-gsm 0 'b))
|
|
(funcall cmpr (direct-sum-gsm 1 '1) (direct-sum-gsm 1 '2))
|
|
(funcall cmpr (direct-sum-gsm 1 '2) (direct-sum-gsm 1 '2))
|
|
(funcall cmpr (direct-sum-gsm 1 '2) (direct-sum-gsm 1 '1))
|
|
|#
|
|
|
|
|
|
#|
|
|
(setf basis (direct-sum-basis
|
|
#'(lambda (n) (list n))
|
|
#'(lambda (n) (list n))))
|
|
(funcall basis 4)
|
|
|#
|
|
|
|
|
|
#|
|
|
()
|
|
(TERM-d-sum-0 (term 2 'a))
|
|
(TERM-d-sum-1 (term 2 'a))
|
|
|#
|
|
|
|
#|
|
|
()
|
|
(direct-sum-cmbn-split
|
|
(cmbn 3 4 (direct-sum-gsm 0 'a) 5 (direct-sum-gsm 1 'b)))
|
|
(cone-cmbn-split (cmbn 3 4 (direct-sum-gsm 0 'a)))
|
|
(cone-cmbn-split (cmbn 3 4 (direct-sum-gsm 1 'a)))
|
|
|#
|
|
|
|
#|
|
|
()
|
|
(direct-sum-2cmbn-append (cmbn 3 4 'a) (cmbn 2 5 'b))
|
|
|#
|
|
|
|
|
|
#|
|
|
()
|
|
(setf mrph (dffr (delta 4)))
|
|
(setf rslt (direct-sum-dffr mrph mrph))
|
|
(funcall rslt (cmbn 3 4 (direct-sum-gsm 0 15) 5 (direct-sum-gsm 1 7)))
|
|
|#
|
|
|
|
#|
|
|
()
|
|
(setf s3 (sphere 3))
|
|
(setf s3+s3 (direct-sum s3 s3))
|
|
|
|
|#
|
|
|
|
|
|
#|
|
|
|
|
(cat-init)
|
|
(setf s3xs3 (crts-prdc (sphere 3) (sphere 3)))
|
|
(setf s3xs3+s3xs3-efhm (direct-sum-efhm s3xs3 s3xs3))
|
|
(setf lrdct (lrdct s3xs3+s3xs3-efhm))
|
|
|
|
(pre-check-rdct lrdct)
|
|
(setf *tc* (cmbn 3 1 (first (basis (k 40) 3)) -2 (second (basis (k 40) 3)) 3 (third (basis (k 40) 3))))
|
|
(setf *bc* (cmbn 4 -1 (first (basis (k 38) 4)) -5 (second (basis (k 38) 4)) 7 (third (basis (k 38) 4)) -4 (fourth (basis (k 38) 4))))
|
|
(check-rdct)
|
|
|
|
(setf rrdct (rrdct s3xs3+s3xs3-efhm))
|
|
|
|
(pre-check-rdct rrdct)
|
|
(setf *tc* (cmbn 2 1 (first (basis (k 40) 2)) -2 (second (basis (k 40) 2)) 3 (third (basis (k 40) 2))))
|
|
(setf *bc* (cmbn 3 -1 (first (basis (k 42) 3)) -5 (second (basis (k 42) 3)) 7 (third (basis (k 42) 3)) -4 (fourth (basis (k 42) 3))))
|
|
(check-rdct)
|
|
|
|
|#
|
|
|
|
#|
|
|
()
|
|
(setf ls3 (loop-space (sphere 3)))
|
|
(setf s3 (sphere 3))
|
|
(setf ls3+s3 (direct-sum ls3 s3))
|
|
|
|
(homology ls3+s3 0 6)
|
|
|
|
|#
|
|
|
|
|
|
|
|
;; ====================================
|
|
;; Examples remove-covers.lisp
|
|
;; ====================================
|
|
|
|
#|
|
|
(setf s3xI (crts-prdc (sphere 3) (delta 1)))
|
|
|
|
(setf basis (remove-covers-basis
|
|
(basis s3xI)))
|
|
(funcall basis 4)
|
|
|#
|
|
|
|
#|
|
|
|
|
|
|
(setf rcs3 (remove-covers (sphere 3)))
|
|
|
|
(homology rcs3 0 6)
|
|
|
|
|#
|
|
|
|
|
|
#|
|
|
|
|
(cat-init)
|
|
(setf s3xs3 (crts-prdc (sphere 3) (sphere 3)))
|
|
(setf rcs3xs3-efhm (remove-covers-efhm (remove-covers s3xs3)))
|
|
(setf lrdct (lrdct rcs3xs3-efhm))
|
|
|
|
(pre-check-rdct lrdct)
|
|
(setf *tc* (cmbn 3 1 (first (basis (k 117) 3)) -2 (second (basis (k 117) 3)) 4 (third (basis (k 117) 3))))
|
|
(setf *bc* (cmbn 4 -1 (first (basis (k 21) 4)) -5 (second (basis (k 21) 4)) 7 (third (basis (k 21) 4))))
|
|
(check-rdct)
|
|
|
|
(setf rrdct (rrdct rcs3xs3-efhm))
|
|
|
|
(pre-check-rdct rrdct)
|
|
(setf *tc* (cmbn 3 1 (first (basis (k 117) 3)) -2 (second (basis (k 117) 3)) 4 (third (basis (k 117) 3))))
|
|
(setf *bc* (cmbn 4 -1 (first (basis (k 120) 4)) -5 (second (basis (k 120) 4)) 3 (car (last (basis (k 120) 4)))))
|
|
(check-rdct)
|
|
|
|
|#
|
|
|
|
|
|
#|
|
|
|
|
(setf rcls3 (remove-covers (loop-space (sphere 3))))
|
|
|
|
(homology rcls3 0 6)
|
|
|
|
|#
|
|
|
|
|
|
|
|
;; ====================================
|
|
;; Examples suspension2.lisp
|
|
;; ====================================
|
|
|
|
|
|
|
|
#|
|
|
(setf cc (sphere 2))
|
|
(setf basis (suspension2-basis (basis cc)))
|
|
(dotimes (i 6)
|
|
(print (funcall basis i)))
|
|
(suspension-basis :locally-effective)
|
|
|#
|
|
|
|
#|
|
|
(setf cc (deltab))
|
|
(setf intr (suspension2-intr-dffr (dffr cc)))
|
|
(funcall intr (cmbn 3 66 7))
|
|
|#
|
|
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf cc (deltab))
|
|
(setf scc (suspension2 cc))
|
|
(cmpr scc 7 11)
|
|
(basis scc 3) ;; error
|
|
(bsgn scc)
|
|
(? scc 3 11)
|
|
|#
|
|
|
|
#|
|
|
(setf f (idnt-mrph (deltab)))
|
|
(setf sf (suspension2-intr f))
|
|
(funcall sf (cmbn 2 4 3))
|
|
(setf d (dffr (deltab)))
|
|
(setf sd (suspension2-intr d))
|
|
(funcall sd (cmbn 2 4 3))
|
|
(funcall sd (cmbn 3 4 7))
|
|
|#
|
|
|
|
#|
|
|
(setf f (idnt-mrph (deltab)))
|
|
(setf sf (suspension2 f))
|
|
(? sf (cmbn 2 4 3))
|
|
(setf d (dffr (deltab)))
|
|
(setf sd (suspension2 d))
|
|
(? sd (cmbn 2 4 3))
|
|
(? sd (cmbn 3 4 7))
|
|
|#
|
|
|
|
|
|
#|
|
|
|
|
(cat-init)
|
|
(setf s3xs3 (crts-prdc (sphere 3) (sphere 3)))
|
|
(setf s3xs3-efhm (efhm s3xs3))
|
|
(setf s_2-s3xs3-efhm (suspension2 s3xs3-efhm))
|
|
(setf lrdct (lrdct s_2-s3xs3-efhm))
|
|
|
|
(pre-check-rdct lrdct)
|
|
(setf *tc* (cmbn 3 1 (first (basis (k 38) 3)) -2 (second (basis (k 38) 3))))
|
|
(setf *bc* (cmbn 4 -1 (first (basis (k 40) 4)) -5 (second (basis (k 40) 4)) 7 (third (basis (k 40) 4))))
|
|
(check-rdct)
|
|
|
|
(setf rrdct (rrdct s_2-s3xs3-efhm))
|
|
|
|
(pre-check-rdct rrdct)
|
|
(setf *tc* (cmbn 3 1 (first (basis (k 38) 3)) -2 (second (basis (k 38) 3))))
|
|
(setf *bc* (cmbn 4 -1 (first (basis (k 46) 4)) -5 (second (basis (k 46) 4))))
|
|
(check-rdct)
|
|
|
|
|#
|
|
|
|
|
|
|
|
#|
|
|
(setf sk (suspension2 (k-z 2)))
|
|
(homology sk 0 10)
|
|
|#
|
|
|
|
|
|
|
|
;; ====================================
|
|
;; Examples Pushout.lisp
|
|
;; ====================================
|
|
|
|
|
|
|
|
|
|
#|
|
|
(setf s3 (sphere 3))
|
|
(setf s3xs3 (crts-prdc (sphere 3) (sphere 3)))
|
|
|
|
(setf f (build-smmr :sorc s3xs3 :trgt s3 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(absm (dgop1 gmsm) (gmsm1 gmsm)))
|
|
:orgn `(first ,s3xs3)))
|
|
|
|
(setf g (build-smmr :sorc s3xs3 :trgt s3 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(absm (dgop2 gmsm) (gmsm2 gmsm)))
|
|
:orgn `(second ,s3xs3)))
|
|
|
|
|
|
(setf p (pushout-cmpr (cmpr (crts-prdc s3xs3 (delta 1)))
|
|
(cmpr s3)
|
|
(cmpr s3)))
|
|
|
|
;;;JJJ Coherent examples.
|
|
|
|
(funcall p (pushout-gsm 0 (crpr 0 (crpr 0 's3 7 '*) 7 1))
|
|
(pushout-gsm 0 (crpr 0 (crpr 0 's3 7 '*) 7 1)))
|
|
(funcall p (pushout-gsm 0 (crpr 0 (crpr 0 's3 7 '*) 7 1))
|
|
(pushout-gsm 0 (crpr 0 (crpr 7 '* 0 's3) 7 1)))
|
|
(funcall p (pushout-gsm 0 (crpr 0 (crpr 7 '* 0 's3) 7 1))
|
|
(pushout-gsm 0 (crpr 0 (crpr 0 's3 7 '*) 7 1)))
|
|
(funcall p (pushout-gsm 0 (crpr 0 (crpr 0 's3 7 '*) 7 1))
|
|
(pushout-gsm 1 's3))
|
|
(funcall p (pushout-gsm 1 's3) (pushout-gsm 1 's3))
|
|
(funcall p (pushout-gsm 1 's3) (pushout-gsm 2 's3))
|
|
(funcall p (pushout-gsm 2 's3) (pushout-gsm 1 's3))
|
|
|#
|
|
|
|
|
|
#|
|
|
(setf s3 (sphere 3))
|
|
(setf s3xs3 (crts-prdc (sphere 3) (sphere 3)))
|
|
|
|
(setf f (build-smmr :sorc s3xs3 :trgt s3 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(absm (dgop1 gmsm) (gmsm1 gmsm)))
|
|
:orgn `(first ,s3xs3)))
|
|
|
|
(setf g (build-smmr :sorc s3xs3 :trgt s3 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(absm (dgop2 gmsm) (gmsm2 gmsm)))
|
|
:orgn `(second ,s3xs3)))
|
|
|
|
|
|
(setf p-basis (pushout-basis (basis (crts-prdc s3xs3 (delta 1)))
|
|
(basis s3)
|
|
(basis s3)))
|
|
|
|
(dolist (item (funcall p-basis 3))
|
|
(print item))
|
|
|
|
|
|
|#
|
|
|
|
|
|
#|
|
|
(setf s3 (sphere 3))
|
|
(setf s3xs3 (crts-prdc (sphere 3) (sphere 3)))
|
|
|
|
(setf f (build-smmr :sorc s3xs3 :trgt s3 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(absm (dgop1 gmsm) (gmsm1 gmsm)))
|
|
:orgn `(first ,s3xs3)))
|
|
|
|
(setf g (build-smmr :sorc s3xs3 :trgt s3 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(absm (dgop2 gmsm) (gmsm2 gmsm)))
|
|
:orgn `(second ,s3xs3)))
|
|
|
|
|
|
(setf p-face (pushout-face (face (crts-prdc s3xs3 (delta 1)))
|
|
(face s3)
|
|
(face s3) f g))
|
|
|
|
(setf p-basis (pushout-basis (basis (crts-prdc s3xs3 (delta 1)))
|
|
(basis s3) (basis s3)))
|
|
|
|
(map nil #'print (funcall p-basis 3))
|
|
|
|
(dolist (item (funcall p-basis 3))
|
|
(terpri)
|
|
(print item)
|
|
(dotimes (i 4)
|
|
(print (funcall p-face i 3 item))))
|
|
|
|
|#
|
|
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf s3 (sphere 3))
|
|
(setf s3xs3 (crts-prdc (sphere 3) (sphere 3)))
|
|
|
|
(setf f (build-smmr :sorc s3xs3 :trgt s3 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(absm (dgop1 gmsm) (gmsm1 gmsm)))
|
|
:orgn `(first ,s3xs3)))
|
|
|
|
(setf g (build-smmr :sorc s3xs3 :trgt s3 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(absm (dgop2 gmsm) (gmsm2 gmsm)))
|
|
:orgn `(second ,s3xs3)))
|
|
(setf p (pushout f g))
|
|
|
|
|
|
;;;JJJ Very useful: several bugs so discovered.
|
|
|
|
(check-smst p 0 8)
|
|
|
|
|#
|
|
|
|
|
|
#|
|
|
()
|
|
(cat-init)
|
|
(setf unipunctual (build-finite-ss '(x)))
|
|
(setf k-z (k-z 1))
|
|
|
|
|
|
(setf f (build-smmr :sorc unipunctual :trgt k-z :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(if (= dmns 0)
|
|
(absm 0 (bspn k-z))
|
|
nil
|
|
))
|
|
:orgn `(triv ,unipunctual ,k-z)))
|
|
|
|
|
|
(setf p (pushout f f))
|
|
|
|
(homology p 0 3)
|
|
|
|
|#
|
|
|
|
|
|
#|
|
|
|
|
(setf wkk (wedge (k-z 2) (k-z 2)))
|
|
(homology wkk 0 10)
|
|
(setf wedge-loop (wedge (loop-space (sphere 3)) (loop-space (sphere 3))))
|
|
(homology wedge-loop 0 10)
|
|
|
|
|#
|
|
|
|
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf s3*s4 (join (sphere 3) (sphere 4)))
|
|
(homology s3*s4 0 9)
|
|
(setf k-z2*k-z2 (join (k-z2 1) (k-z2 1)))
|
|
(homology k-z2*k-z2 0 10)
|
|
|
|
|#
|
|
|
|
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf s3*s4 (join (sphere 3) (sphere 4)))
|
|
(setf hom-equ (efhm s3*s4))
|
|
(setf lrdct (lrdct hom-equ))
|
|
(pre-check-rdct lrdct)
|
|
(setf *bc* (CMBN 3 2 (CAR (basis (k 28) 3)) -8 (CADR (basis (k 28) 3)) 7 (CADDR (basis (k 28) 3))))
|
|
(SETF *tc* (CMBN 2 -1 (CAR (basis (k 195) 2)) 4 (CADR (basis (k 195) 2)) -5 (CADDR (basis (k 195) 2))))
|
|
(check-rdct)
|
|
|
|
(setf rrdct (rrdct hom-equ))
|
|
(pre-check-rdct rrdct)
|
|
(setf *bc* (CMBN 3 2 (CAR (basis (k 198) 3)) -8 (CADR (basis (k 198) 3)) 7 (CADDR (basis (k 198) 3))))
|
|
(SETF *tc* (CMBN 2 -1 (CAR (basis (k 195) 2)) 4 (CADR (basis (k 195) 2)) -5 (CADDR (basis (k 195) 2))))
|
|
(check-rdct)
|
|
|#
|
|
|
|
|
|
;;;----------------------------------------------------------------------------
|
|
;;;
|
|
;;; Subject: Disjoint Union (Direct Sum)
|
|
;;;
|
|
;;; X = \emptyset
|
|
;;;
|
|
;;;----------------------------------------------------------------------------
|
|
|
|
|
|
(IN-PACKAGE #:cat)
|
|
(setf s3 (sphere 3))
|
|
(setf s4 (sphere 4))
|
|
(setf nil-ss (build-finite-ss nil))
|
|
|
|
(setf f (build-smmr :sorc nil-ss :trgt s3 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
nil)
|
|
:orgn `(triv ,nil-ss ,s3)))
|
|
|
|
(setf g (build-smmr :sorc nil-ss :trgt s4 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
nil)
|
|
:orgn `(triv ,nil-ss ,s4)))
|
|
|
|
(setf p (pushout f g))
|
|
|
|
(homology p 0 6)
|
|
|
|
(cat-init)
|
|
(setf l2s3 (loop-space (sphere 3) 2))
|
|
(setf l3s4 (loop-space (sphere 4) 3))
|
|
(setf nil-ss (build-finite-ss nil))
|
|
|
|
(setf f (build-smmr :sorc nil-ss :trgt l2s3 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
nil)
|
|
:orgn `(triv ,nil-ss ,l2s3)))
|
|
|
|
(setf g (build-smmr :sorc nil-ss :trgt l3s4 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
nil)
|
|
:orgn `(triv ,nil-ss ,l3s4)))
|
|
|
|
(setf p (pushout f g))
|
|
(setf ds (direct-sum l2s3 l3s4))
|
|
|
|
(homology p 0 6)
|
|
(homology ds 0 6)
|
|
|
|
|
|
|
|
;;;----------------------------------------------------------------------------
|
|
;;;
|
|
;;; Subject: Suspension
|
|
;;;
|
|
;;; Arbitrary X, Y=Z={*}
|
|
;;;
|
|
;;;----------------------------------------------------------------------------
|
|
|
|
(cat-init)
|
|
(setf ls3 (loop-space (sphere 3)))
|
|
(setf unipunctual (build-finite-ss '(x)))
|
|
|
|
(setf f (build-smmr :sorc ls3 :trgt unipunctual :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(if (and (equal dmns 0)
|
|
(equal gmsm (bsgn ls3)))
|
|
'x
|
|
nil))
|
|
:orgn `(triv ,ls3 ,unipunctual)))
|
|
|
|
(setf p (pushout f f))
|
|
|
|
(homology p 0 6)
|
|
|
|
(homology (suspension2 (loop-space (sphere 3))) 0 6)
|
|
|
|
|
|
;;;----------------------------------------------------------------------------
|
|
;;;
|
|
;;; Subject: P^2(C)
|
|
;;;
|
|
;;; X = X3, Y = S^2, Z = {x}
|
|
;;;
|
|
;;; Homology groups of P^2(C) -> (Z,0,Z,0,Z)
|
|
;;;
|
|
;;;----------------------------------------------------------------------------
|
|
|
|
(cat-init)
|
|
(setf s2 (sphere 2))
|
|
(setf ch2 ( chml-clss s2 2))
|
|
(setf f2 (z-whitehead s2 ch2))
|
|
(setf x3 (fibration-total f2))
|
|
(setf unipunctual (build-finite-ss '(x)))
|
|
|
|
(setf f (build-smmr :sorc x3 :trgt s2 :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(declare (ignore dmns))
|
|
(absm (dgop1 gmsm) (gmsm1 gmsm)))
|
|
:orgn `(proj ,x3 ,s2)))
|
|
|
|
(setf g (build-smmr :sorc x3 :trgt unipunctual :degr 0
|
|
:sintr #'(lambda (dmns gmsm)
|
|
(if (and (equal dmns 0)
|
|
(equal gmsm (bsgn x3)))
|
|
'x
|
|
nil))
|
|
:orgn `(proj ,x3 ,unipunctual)))
|
|
|
|
(setf p (pushout f g))
|
|
|
|
(homology p 0 10)
|
|
|