Homotopy computation of simplicial sets which are simply connected but not necessarily 1-reduced considered
This commit is contained in:
parent
6330fb3f9b
commit
8c144478b5
@ -12,6 +12,116 @@
|
||||
(provide "homotopy")
|
||||
|
||||
|
||||
(DEFUN CHML-CLSS-INTR-NOT-1REDUCED (chcm first)
|
||||
(declare
|
||||
(type chain-complex chcm)
|
||||
(fixnum first))
|
||||
(let* ((echcm (echcm chcm))
|
||||
(cmpr (cmpr echcm))
|
||||
(basis (basis echcm))
|
||||
(f-basis (funcall basis first))
|
||||
(mtrx1 (gnrt-list-to-mtrx (kernel (chcm-mtrx echcm first))))
|
||||
(mtrx2 (chcm-mtrx echcm (1+ first)))
|
||||
(smith-list-1 (smith mtrx1))
|
||||
(p1 (first smith-list-1))
|
||||
(p1-1 (second smith-list-1))
|
||||
(d1 (third smith-list-1))
|
||||
(p1-1Xmtrx2 (mtrx-prdc p1-1 mtrx2))
|
||||
(p1Xd1 (copy-mtrx p1))
|
||||
(d1-1Xp1-1Xmtrx2 (copy-mtrx p1-1Xmtrx2)))
|
||||
(declare
|
||||
(list smith-list-1)
|
||||
(type matrix p1 p1-1 d1 p1-1Xmtrx2 p1Xd1 d1-1Xp1-1Xmtrx2))
|
||||
(progn
|
||||
(let* ((line-n-1 (line-number p1))
|
||||
(column-n-1 (column-number p1)))
|
||||
(declare (type fixnum line-n-1 column-n-1))
|
||||
(dotimes (ic column-n-1)
|
||||
(declare (type fixnum ic))
|
||||
(if (and (< ic (line-number d1)) (< ic (column-number d1)))
|
||||
(let ((d (aref d1 ic ic)))
|
||||
(declare (type fixnum d))
|
||||
(dotimes (il line-n-1)
|
||||
(declare (type fixnum il))
|
||||
(if (and (not (eql 1 d)) (not (eql 0 d)))
|
||||
(setf (aref p1Xd1 il ic) (* d (aref p1Xd1 il ic)))))))))
|
||||
(let* ((line-n-2 (line-number p1-1Xmtrx2))
|
||||
(column-n-2 (column-number p1-1Xmtrx2)))
|
||||
(declare (type fixnum line-n-2 column-n-2))
|
||||
(dotimes (il line-n-2)
|
||||
(declare (type fixnum il))
|
||||
(if (and (< il (line-number d1)) (< il (column-number d1)))
|
||||
(let ((d (aref d1 il il)))
|
||||
(if (and (not (eql 1 d)) (not (eql 0 d)))
|
||||
(dotimes (ic column-n-2)
|
||||
(declare (type fixnum ic))
|
||||
(setf (aref d1-1Xp1-1Xmtrx2 il ic)
|
||||
(floor (aref d1-1Xp1-1Xmtrx2 il ic) d))))))))
|
||||
(let* ((mtrx-list (smith d1-1Xp1-1Xmtrx2))
|
||||
(smith (third mtrx-list))
|
||||
(p-1 (mtrx-prdc (second mtrx-list) p1-1))
|
||||
|
||||
(n (line-number smith))
|
||||
(m (column-number smith))
|
||||
(diag-indx
|
||||
(dotimes (indx (min n m)
|
||||
(if (> n m)
|
||||
m
|
||||
(error "In CHML-CLSS, the cohomology-ring ~@
|
||||
is null.")))
|
||||
(declare (fixnum indx))
|
||||
(unless (= 1 (aref smith indx indx))
|
||||
(return indx)))
|
||||
))
|
||||
(declare
|
||||
(type chain-complex echcm)
|
||||
(type cmprf cmpr)
|
||||
(type basis basis)
|
||||
(fixnum n m diag-indx)
|
||||
(list f-basis mtrx-list)
|
||||
(type matrix p-1 smith))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(with-cmbn
|
||||
(degr list) cmbn
|
||||
(unless (= degr first)
|
||||
(return-from rslt (zero-cmbn (- degr first))))
|
||||
(do ((rslt 0)
|
||||
(bmark f-basis)
|
||||
(ic 0)
|
||||
(cmark list (cdr cmark)))
|
||||
((endp cmark)
|
||||
(if (zerop rslt)
|
||||
(zero-cmbn 0)
|
||||
(term-cmbn 0 rslt :z-gnrt)))
|
||||
(declare
|
||||
(fixnum rslt)
|
||||
(list bmark cmark))
|
||||
(with--term
|
||||
(cffc gnrt) cmark
|
||||
(loop
|
||||
(when (eq :equal (funcall cmpr gnrt (car bmark)))
|
||||
(return))
|
||||
(pop bmark)
|
||||
(incf ic))
|
||||
(incf rslt (* cffc (aref p-1 diag-indx ic)))
|
||||
(pop bmark)
|
||||
(incf ic))))))
|
||||
(the intr-mrph #'rslt))))))
|
||||
|
||||
|
||||
(DEFUN CHML-CLSS-NOT-1REDUCED (chcm first)
|
||||
(declare
|
||||
(type chain-complex chcm)
|
||||
(fixnum first))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc (echcm chcm) :trgt (z-chcm) :degr (- first)
|
||||
:intr (chml-clss-intr-not-1reduced chcm first)
|
||||
:strt :cmbn
|
||||
:orgn `(chml-clss-not-1reduced ,chcm ,first))))
|
||||
|
||||
|
||||
(DEFUN CHCM-HOMOLOGY-FORMAT (cc n)
|
||||
(declare (type chain-complex cc) (type fixnum n))
|
||||
(let ((rsl (homologie (chcm-mat cc n) (chcm-mat cc (1+ n))))
|
||||
@ -29,12 +139,12 @@
|
||||
(DEFUN HOMOLOGY-FORMAT (chcm degr1 &optional (degr2 (1+ degr1)))
|
||||
(declare (fixnum degr1 degr2))
|
||||
(let ((result_hom nil))
|
||||
(do ((degr degr1 (1+ degr)))
|
||||
((>= degr degr2))
|
||||
(declare (fixnum degr))
|
||||
(setf result_hom (chcm-homology-format (echcm chcm) degr))
|
||||
(terpri) (clock) (terpri))
|
||||
result_hom))
|
||||
(do ((degr degr1 (1+ degr)))
|
||||
((>= degr degr2))
|
||||
(declare (fixnum degr))
|
||||
(setf result_hom (chcm-homology-format (echcm chcm) degr))
|
||||
(terpri) (clock) (terpri))
|
||||
result_hom))
|
||||
|
||||
|
||||
(DEFUN FIRST-NON-NULL-HOMOLOGY-GROUP-AUX (chcm n limit)
|
||||
@ -44,14 +154,15 @@
|
||||
(if hf
|
||||
(1- n)
|
||||
(first-non-null-homology-group-aux chcm (1+ n) limit)))))
|
||||
|
||||
|
||||
|
||||
|
||||
(DEFUN FIRST-NON-NULL-HOMOLOGY-GROUP (chcm limit)
|
||||
(first-non-null-homology-group-aux chcm 1 limit))
|
||||
|
||||
|
||||
(DEFUN COMPUTE-HOMOTOPY-Z-XSLT (n-hom obj indx)
|
||||
(let* ((ch (chml-clss (eval obj) indx))
|
||||
(let* ((ch (if (= 0 (length (basis (echcm obj) 1))) (chml-clss (eval obj) indx)
|
||||
(chml-clss-not-1reduced (eval obj) indx)))
|
||||
(fib (z-whitehead (eval obj) (eval ch)))
|
||||
(ft (fibration-total (eval fib)))
|
||||
(result (homology-format (eval ft) (1+ indx))))
|
||||
@ -64,13 +175,14 @@
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
|
||||
(compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))))
|
||||
|
||||
|
||||
(DEFUN COMPUTE-HOMOTOPY-Z2-XSLT (n-hom obj indx)
|
||||
(let* ((ch (chml-clss (eval obj) indx))
|
||||
(let* ((ch (if (= 0 (length (basis (echcm obj) 1))) (chml-clss (eval obj) indx)
|
||||
(chml-clss-not-1reduced (eval obj) indx)))
|
||||
(fib (z2-whitehead (eval obj) (eval ch)))
|
||||
(ft (fibration-total (eval fib)))
|
||||
(result (homology-format (eval ft) (1+ indx))))
|
||||
@ -79,17 +191,18 @@
|
||||
(if (string= "NIL" result) ;; nil
|
||||
(let ((first-non-null (first-non-null-homology-group ft n-hom)))
|
||||
(if first-non-null (compute-homotopy ft n-hom first-non-null) nil))
|
||||
(if (string= "Z " result)
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(if (string= "Z " result)
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
|
||||
(compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))))
|
||||
|
||||
|
||||
(DEFUN COMPUTE-HOMOTOPY-ZP-XSLT (n-hom obj indx n)
|
||||
(let* ((ch (chml-clss (eval obj) indx))
|
||||
(let* ((ch (if (= 0 (length (basis (echcm obj) 1))) (chml-clss (eval obj) indx)
|
||||
(chml-clss-not-1reduced (eval obj) indx)))
|
||||
(fib (zp-whitehead n (eval obj) (eval ch)))
|
||||
(ft (fibration-total (eval fib)))
|
||||
(result (homology-format (eval ft) (1+ indx))))
|
||||
@ -98,19 +211,19 @@
|
||||
(if (string= "NIL" result) ;; nil
|
||||
(let ((first-non-null (first-non-null-homology-group ft n-hom)))
|
||||
(if first-non-null (compute-homotopy ft n-hom first-non-null) nil))
|
||||
(if (string= "Z " result)
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
|
||||
(compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))))
|
||||
(if (string= "Z " result)
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
|
||||
(compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))))
|
||||
|
||||
|
||||
(DEFUN SPLIT-COMPONENTS (string)
|
||||
(let ((term (if (string= string "") ""
|
||||
(if (string= string "NIL") nil
|
||||
(subseq string 0 2)))))
|
||||
(subseq string 0 2)))))
|
||||
(if (string= term "Z ")
|
||||
(cons 1 (split-components (subseq string 2)))
|
||||
(if (string= term "Z/")
|
||||
@ -122,27 +235,30 @@
|
||||
(DEFUN CONSTRUCT-SPACE-ITERATIVE (chcm list indx)
|
||||
(if (endp list)
|
||||
chcm
|
||||
(cond ((equal (car list) 1) (let* ((ch (chml-clss chcm indx))
|
||||
(cond ((equal (car list) 1) (let* ((ch (if (= 0 (length (basis (echcm chcm) 1))) (chml-clss chcm indx)
|
||||
(chml-clss-not-1reduced chcm indx)))
|
||||
(fib (z-whitehead chcm ch))
|
||||
(ft (fibration-total fib)))
|
||||
(if (endp (cdr list)) ft
|
||||
(progn
|
||||
(kill-epis ft 1 indx)
|
||||
(construct-space-iterative ft (cdr list) indx)))))
|
||||
((equal (car list) 2) (let* ((ch (chml-clss chcm indx))
|
||||
(progn
|
||||
(kill-epi ft 1)
|
||||
(construct-space-iterative ft (cdr list) indx)))))
|
||||
((equal (car list) 2) (let* ((ch (if (= 0 (length (basis (echcm chcm) 1))) (chml-clss chcm indx)
|
||||
(chml-clss-not-1reduced chcm indx)))
|
||||
(fib (z2-whitehead chcm ch))
|
||||
(ft (fibration-total fib)))
|
||||
(if (endp (cdr list)) ft
|
||||
(progn
|
||||
(kill-epis ft 1 indx)
|
||||
(construct-space-iterative ft (cdr list) indx)))))
|
||||
(t (let* ((ch (chml-clss chcm indx))
|
||||
(progn
|
||||
(kill-epi ft 2)
|
||||
(construct-space-iterative ft (cdr list) indx)))))
|
||||
(t (let* ((ch (if (= 0 (length (basis (echcm chcm) 1))) (chml-clss chcm indx)
|
||||
(chml-clss-not-1reduced chcm indx)))
|
||||
(fib (zp-whitehead (car list) chcm ch))
|
||||
(ft (fibration-total fib)))
|
||||
(if (endp (cdr list)) ft
|
||||
(progn
|
||||
(kill-epis ft 1 indx)
|
||||
(construct-space-iterative ft (cdr list) indx)))))
|
||||
(progn
|
||||
(kill-epi ft (cdr list))
|
||||
(construct-space-iterative ft (cdr list) indx)))))
|
||||
)))
|
||||
|
||||
|
||||
@ -152,20 +268,20 @@
|
||||
(if (= (1+ indx) n-hom)
|
||||
(homology-format (eval ft) n-hom)
|
||||
(if (string= "NIL" result) nil
|
||||
(if (string= "Z " result)
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
|
||||
(compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))))
|
||||
(if (string= "Z " result)
|
||||
(compute-homotopy-z-xslt n-hom ft (1+ indx))
|
||||
(if (string= "Z/2Z " result)
|
||||
(compute-homotopy-z2-xslt n-hom ft (1+ indx))
|
||||
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
|
||||
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
|
||||
(compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))))
|
||||
|
||||
|
||||
(DEFUN COMPUTE-HOMOTOPY2-XSLT (n-hom obj degree hom)
|
||||
(cond
|
||||
((= n-hom 0)
|
||||
(format nil "Z")
|
||||
)
|
||||
(format nil "Z")
|
||||
)
|
||||
((< n-hom (1+ degree) )
|
||||
(format nil ""))
|
||||
((= n-hom (1+ degree))
|
||||
@ -185,7 +301,6 @@
|
||||
(compute-homotopy2-xslt n-hom smst degree hom)))
|
||||
|
||||
|
||||
|
||||
(DEFUN HOMOTOPY (smst degr)
|
||||
(let (;; we obtain the first non null homology group
|
||||
(first-non-null (first-non-null-homology-group smst degr)))
|
||||
@ -199,7 +314,7 @@
|
||||
(format t "/~DZ" item)))
|
||||
(terpri) (terpri)))
|
||||
(progn
|
||||
(format t "~3%Homotopy in dimension ~D :~2%" degr)
|
||||
(format t "~3%Homotopy in dimension ~D :~2%" degr)
|
||||
(terpri) (terpri)))))
|
||||
|
||||
|
||||
@ -211,8 +326,3 @@
|
||||
nil)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user