mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Computation of homotopy groups (null groups included)

Browse Source
This commit is contained in:
Ana Romero 2019-05-08 18:04:18 +02:00
parent a80dd83a67
commit 4ffed16284
2 changed files with 213 additions and 204 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
kenzo.asd
View File

@ -17,7 +17,8 @@
((:file "package") ((:file "package")
(:module "src" (:module "src"
:components :components
((:file "kenzo") (
(:file "kenzo")
(:file "abbreviations") (:file "abbreviations")
(:file "macros") (:file "macros")
(:file "various") (:file "various")
@ -55,17 +56,17 @@
(:file "cs-twisted-products") (:file "cs-twisted-products")
(:file "cl-space-efhm") (:file "cl-space-efhm")
(:file "whitehead") (:file "whitehead")
(:file "smith") (:file "smith")
(:file "sage-interface")
(:module "anromero" (:module "anromero"
:components :components
((:file "resolutions")
(:file "cylinders")
(:file "fundamental-classes")
(:file "homotopy")
(:file "bicomplexes")))
#|
((:file "bicomplexes") ((:file "bicomplexes")
(:file "filtered-complexes") (:file "filtered-complexes")
(:file "spectral-sequences") (:file "spectral-sequences")))
(:file "resolutions") |#
(:file "cylinders") ))))
(:file "fundamental-classes")
(:file "homotopy")))
))))

394
src/anromero/homotopy.lisp
View File

@ -1,193 +1,201 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
;;; HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY ;;; HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY
;;; HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY ;;; HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY
;;; HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY ;;; HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY HOMOTOPY
;;; Authors: Jonathan Heras and Ana Romero ;;; Authors: Jonathan Heras and Ana Romero
(IN-PACKAGE #:cat)
(IN-PACKAGE #:cat)
(provide "homotopy")
(provide "homotopy")
(DEFUN CHCM-HOMOLOGY-FORMAT (cc n)
(declare (type chain-complex cc) (type fixnum n)) (DEFUN CHCM-HOMOLOGY-FORMAT (cc n)
(let ((rsl (homologie (chcm-mat cc n) (chcm-mat cc (1+ n)))) (declare (type chain-complex cc) (type fixnum n))
(str nil)) (let ((rsl (homologie (chcm-mat cc n) (chcm-mat cc (1+ n))))
(declare (type list rsl)) (str nil))
(dolist (item rsl) (declare (type list rsl))
(declare (type list item)) (dolist (item rsl)
(setf str (concatenate 'string str (format nil "Z"))) (declare (type list item))
(unless (zerop (first item)) (setf str (concatenate 'string str (format nil "Z")))
(setf str (concatenate 'string str (format nil "/~DZ" (first item))))) (unless (zerop (first item))
(setf str (concatenate 'string str " "))) (setf str (concatenate 'string str (format nil "/~DZ" (first item)))))
str)) (setf str (concatenate 'string str " ")))
str))
(DEFUN HOMOLOGY-FORMAT (chcm degr1 &optional (degr2 (1+ degr1)))
(declare (fixnum degr1 degr2)) (DEFUN HOMOLOGY-FORMAT (chcm degr1 &optional (degr2 (1+ degr1)))
(let ((result_hom nil)) (declare (fixnum degr1 degr2))
(do ((degr degr1 (1+ degr))) (let ((result_hom nil))
((>= degr degr2)) (do ((degr degr1 (1+ degr)))
(declare (fixnum degr)) ((>= degr degr2))
(setf result_hom (chcm-homology-format (echcm chcm) degr)) (declare (fixnum degr))
(terpri) (clock) (terpri)) (setf result_hom (chcm-homology-format (echcm chcm) degr))
result_hom)) (terpri) (clock) (terpri))
result_hom))
(DEFUN FIRST-NON-NULL-HOMOLOGY-GROUP-AUX (chcm n limit)
(if (> n limit) (DEFUN FIRST-NON-NULL-HOMOLOGY-GROUP-AUX (chcm n limit)
nil (if (> n limit)
(let ((hf (homology-format chcm n))) nil
(if hf (let ((hf (homology-format chcm n)))
(1- n) (if hf
(first-non-null-homology-group-aux chcm (1+ n) limit))))) (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 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)) (DEFUN COMPUTE-HOMOTOPY-Z-XSLT (n-hom obj indx)
(fib (z-whitehead (eval obj) (eval ch))) (let* ((ch (chml-clss (eval obj) indx))
(ft (fibration-total (eval fib))) (fib (z-whitehead (eval obj) (eval ch)))
(result (homology-format (eval ft) (1+ indx)))) (ft (fibration-total (eval fib)))
(if (= (1+ indx) n-hom) (result (homology-format (eval ft) (1+ indx))))
(homology-format (eval ft) n-hom) (if (= (1+ indx) n-hom)
(if (string= "Z " result) (homology-format (eval ft) n-hom)
(compute-homotopy-z-xslt n-hom ft (1+ indx)) (if (string= "NIL" result) result
(if (string= "Z/2Z " result) (if (string= "Z " result)
(compute-homotopy-z2-xslt n-hom ft (1+ indx)) (compute-homotopy-z-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/2Z " result)
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2)))) (compute-homotopy-z2-xslt n-hom ft (1+ indx))
(compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))) (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))
(fib (z2-whitehead (eval obj) (eval ch))) (DEFUN COMPUTE-HOMOTOPY-Z2-XSLT (n-hom obj indx)
(ft (fibration-total (eval fib))) (let* ((ch (chml-clss (eval obj) indx))
(result (homology-format (eval ft) (1+ indx)))) (fib (z2-whitehead (eval obj) (eval ch)))
(if (= (1+ indx) n-hom) (ft (fibration-total (eval fib)))
(homology-format (eval ft) n-hom) (result (homology-format (eval ft) (1+ indx))))
(if (string= "Z " result) (if (= (1+ indx) n-hom)
(compute-homotopy-z-xslt n-hom ft (1+ indx)) (homology-format (eval ft) n-hom)
(if (string= "Z/2Z " result) (if (string= "NIL" result) result
(compute-homotopy-z2-xslt n-hom ft (1+ indx)) (if (string= "Z " result)
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) (compute-homotopy-z-xslt n-hom ft (1+ indx))
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2)))) (if (string= "Z/2Z " result)
(compute-homotopy-several-xslt n-hom ft (1+ indx) 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))))
(DEFUN COMPUTE-HOMOTOPY-ZP-XSLT (n-hom obj indx n) (compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))))
(let* ((ch (chml-clss (eval obj) indx))
(fib (zp-whitehead n (eval obj) (eval ch)))
(ft (fibration-total (eval fib))) (DEFUN COMPUTE-HOMOTOPY-ZP-XSLT (n-hom obj indx n)
(result (homology-format (eval ft) (1+ indx)))) (let* ((ch (chml-clss (eval obj) indx))
(if (= (1+ indx) n-hom) (fib (zp-whitehead n (eval obj) (eval ch)))
(homology-format (eval ft) n-hom) (ft (fibration-total (eval fib)))
(if (string= "Z " result) (result (homology-format (eval ft) (1+ indx))))
(compute-homotopy-z-xslt n-hom ft (1+ indx)) (if (= (1+ indx) n-hom)
(if (string= "Z/2Z " result) (homology-format (eval ft) n-hom)
(compute-homotopy-z2-xslt n-hom ft (1+ indx)) (if (string= "NIL" result) result
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) (if (string= "Z " result)
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2)))) (compute-homotopy-z-xslt n-hom ft (1+ indx))
(compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))) (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"))
(DEFUN SPLIT-COMPONENTS (string) (compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2))))
(let ((term (if (string= string "") "" (subseq string 0 2)))) (compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))))
(if (string= term "Z ")
(cons 1 (split-components (subseq string 2)))
(if (string= term "Z/") (DEFUN SPLIT-COMPONENTS (string)
(cons (read-from-string (subseq string 2 (search "Z" string :start2 2))) (let ((term (if (string= string "") ""
(split-components (subseq string (+ 2 (search "Z" string :start2 2))))) (if (string= string "NIL") NIL
nil)))) (subseq string 0 2)))))
(if (string= term "Z ")
(cons 1 (split-components (subseq string 2)))
(DEFUN CONSTRUCT-SPACE-ITERATIVE (chcm list indx) (if (string= term "Z/")
(if (endp list) (cons (read-from-string (subseq string 2 (search "Z" string :start2 2)))
chcm (split-components (subseq string (+ 2 (search "Z" string :start2 2)))))
(cond ((equal (car list) 1) (let* ((ch (chml-clss chcm indx)) nil))))
(fib (z-whitehead chcm ch))
(ft (fibration-total fib)))
(construct-space-iterative ft (cdr list) indx))) (DEFUN CONSTRUCT-SPACE-ITERATIVE (chcm list indx)
((equal (car list) 2) (let* ((ch (chml-clss chcm indx)) (if (endp list)
(fib (z2-whitehead chcm ch)) chcm
(ft (fibration-total fib))) (cond ((equal (car list) 1) (let* ((ch (chml-clss chcm indx))
(construct-space-iterative ft (cdr list) indx))) (fib (z-whitehead chcm ch))
(t (let* ((ch (chml-clss chcm indx)) (ft (fibration-total fib)))
(fib (zp-whitehead (car list) chcm ch)) (construct-space-iterative ft (cdr list) indx)))
(ft (fibration-total fib))) ((equal (car list) 2) (let* ((ch (chml-clss chcm indx))
(construct-space-iterative ft (cdr list) indx))) (fib (z2-whitehead chcm ch))
))) (ft (fibration-total fib)))
(construct-space-iterative ft (cdr list) indx)))
(t (let* ((ch (chml-clss chcm indx))
(DEFUN COMPUTE-HOMOTOPY-SEVERAL-XSLT (n-hom obj indx hom) (fib (zp-whitehead (car list) chcm ch))
(let* ((ft (construct-space-iterative obj (split-components hom) indx)) (ft (fibration-total fib)))
(result (homology-format ft (1+ indx)))) (construct-space-iterative ft (cdr list) indx)))
(if (= (1+ indx) n-hom) )))
(homology-format (eval ft) n-hom)
(if (string= "Z " result)
(compute-homotopy-z-xslt n-hom ft (1+ indx)) (DEFUN COMPUTE-HOMOTOPY-SEVERAL-XSLT (n-hom obj indx hom)
(if (string= "Z/2Z " result) (let* ((ft (construct-space-iterative obj (split-components hom) indx))
(compute-homotopy-z2-xslt n-hom ft (1+ indx)) (result (homology-format ft (1+ indx))))
(if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z")) (if (= (1+ indx) n-hom)
(compute-homotopy-zp-xslt n-hom ft (1+ indx) (read-from-string (subseq result 2 (search "Z" result :start2 2)))) (homology-format (eval ft) n-hom)
(compute-homotopy-several-xslt n-hom ft (1+ indx) result))))))) (if (string= "NIL" result) result
(if (string= "Z " result)
(compute-homotopy-z-xslt n-hom ft (1+ indx))
(DEFUN COMPUTE-HOMOTOPY2-XSLT (n-hom obj degree hom) (if (string= "Z/2Z " result)
(cond (compute-homotopy-z2-xslt n-hom ft (1+ indx))
((= n-hom 0) (if (and (string= (subseq result 0 2) "Z/") (string= (subseq result (search "Z" result :start2 2)) "Z"))
(format nil "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))))))))
((< n-hom (1+ degree) )
(format nil ""))
((= n-hom (1+ degree)) (DEFUN COMPUTE-HOMOTOPY2-XSLT (n-hom obj degree hom)
(homology-format (eval obj) n-hom)) (cond
((string= hom "Z ") ((= n-hom 0)
(compute-homotopy-z-xslt n-hom obj (1+ degree))) (format nil "Z")
((string= hom "Z/2Z ") )
(compute-homotopy-z2-xslt n-hom obj (1+ degree))) ((< n-hom (1+ degree) )
((and (string= (subseq hom 0 2) "Z/") (string= (subseq hom (search "Z" hom :start2 2)) "Z")) (format nil ""))
(compute-homotopy-zp-xslt n-hom obj (1+ degree) (read-from-string (subseq hom 2 (search "Z" hom :start2 2))))) ((= n-hom (1+ degree))
(t (homology-format (eval obj) n-hom))
(compute-homotopy-several-xslt n-hom obj (1+ degree) hom)))) ((string= hom "Z ")
(compute-homotopy-z-xslt n-hom obj (1+ degree)))
((string= hom "Z/2Z ")
(DEFUN COMPUTE-HOMOTOPY (smst n-hom degree) (compute-homotopy-z2-xslt n-hom obj (1+ degree)))
(let ((hom (homology-format smst (1+ degree)))) ((and (string= (subseq hom 0 2) "Z/") (string= (subseq hom (search "Z" hom :start2 2)) "Z"))
(compute-homotopy2-xslt n-hom smst degree hom))) (compute-homotopy-zp-xslt n-hom obj (1+ degree) (read-from-string (subseq hom 2 (search "Z" hom :start2 2)))))
(t
(compute-homotopy-several-xslt n-hom obj (1+ degree) hom))))
(DEFUN HOMOTOPY (smst degr)
(let (;; we obtain the first non null homology group (DEFUN COMPUTE-HOMOTOPY (smst n-hom degree)
(first-non-null (first-non-null-homology-group smst degr))) (let ((hom (homology-format smst (1+ degree))))
(if first-non-null (compute-homotopy2-xslt n-hom smst degree hom)))
(progn
(let ((result (split-components (compute-homotopy smst degr first-non-null))))
(format t "~3%Homotopy in dimension ~D :~%" degr)
(dolist (item result) (DEFUN HOMOTOPY (smst degr)
(format t "~2%Component Z") (let (;; we obtain the first non null homology group
(unless (equal item 1) (first-non-null (first-non-null-homology-group smst degr)))
(format t "/~DZ" item))) (if first-non-null
(terpri) (terpri))) (progn
(progn (let ((result (split-components (compute-homotopy smst degr first-non-null))))
(format t "~3%Homotopy in dimension ~D :~2%" degr) (format t "~3%Homotopy in dimension ~D :~%" degr)
(terpri) (terpri))))) (dolist (item result)
(format t "~2%Component Z")
(unless (equal item 1)
(DEFUN HOMOTOPY-LIST (smst degr) (format t "/~DZ" item)))
(let (;; we obtain the first non null homology group (terpri) (terpri)))
(first-non-null (first-non-null-homology-group smst degr))) (progn
(if first-non-null (format t "~3%Homotopy in dimension ~D :~2%" degr)
(split-components (compute-homotopy smst degr first-non-null)) (terpri) (terpri)))))
nil)))
(DEFUN HOMOTOPY-LIST (smst degr)
(let (;; we obtain the first non null homology group
(first-non-null (first-non-null-homology-group smst degr)))
(if first-non-null
(split-components (compute-homotopy smst degr first-non-null))
nil)))