Merge branch 'testing' of https://github.com/miguelmarco/kenzo into testing

This commit is contained in:
carlos alquezar 2019-05-27 20:24:05 +02:00
commit 32c9546a0b

View File

@ -8,18 +8,13 @@
;;;; Chain complexes
;;;;; Chain complexes ;;;;;
(DEFVAR *ASCII-NUM-START* 48)
(DEFVAR *ASCII-NUM-END* 57)
(DEFUN ITOA (value)
(if (not (integerp value)) (error "Wrong type"))
(if (zerop value)
@ -40,17 +35,15 @@
(return (format nil "~{~a~}" (nreverse result))))))
(DEFUN STRCAT (&rest strings) (apply 'concatenate 'string strings))
(DEFMACRO GEN (num1 num2)
`(read-from-string (strcat "G" (itoa ,num1) "G" (itoa ,num2))))
(DEFUN KBASIS (schcm)
#| Provide the slot :basis of the KenzoSimplicialSet obtained by applying the function 'KChainComplex' to 'schcm' |#
(flet ((rslt (dim)
(let ((pair (assoc dim schcm)))
(if (null pair)
@ -60,8 +53,8 @@
(the basis #'rslt)))
(DEFUN KDFFR (schcm)
#| Provide the slot :intr-dffr of the KenzoSimplicialSet obtained by applying the function 'KChainComplex' to 'schcm' |#
(flet ((frslt (dim gnr)
(let* ((sep (1+ (position #\G (subseq (write-to-string gnr) 1))))
(dim_gnr (read-from-string (subseq (write-to-string gnr) 1 sep)))
@ -83,8 +76,8 @@
#'frslt))
(DEFUN G-CMPR (GnGm1 GnGm2)
#| Provide the slot :cmpr of the KenzoSimplicialSet obtained by applying the function 'KChainComplex' to 'schcm' |#
(let* ((sep (1+ (position #\G (subseq (write-to-string GnGm1) 1))))
(m1 (read-from-string (subseq (write-to-string GnGm1) (1+ sep))))
(m2 (read-from-string (subseq (write-to-string GnGm2) (1+ sep)))))
@ -97,8 +90,16 @@
:greater)))))
(DEFUN ENTRY (mat i j)
#| Provide the entry in row 'i' and column 'j' of the matrice 'mat' |#
(let ((p (left (chercher-hor (baselig mat i) j))))
(if (= j (icol p))
(val p)
0)))
(DEFUN CONVERTMATRICE (matrice)
#| Convert a matrix of type matrice to an array |#
(let* ((numfil (nlig matrice))
(numcol (ncol matrice))
(rslt (make-array (list numfil numcol) :initial-element 0)))
@ -110,16 +111,8 @@
rslt))
(DEFUN ENTRY (mat i j)
(let ((p (left (chercher-hor (baselig mat i) j))))
(if (= j (icol p))
(val p)
0)))
(DEFUN CHCM-MAT2 (chcm n)
#| The same 'chcm-mat' function but it does not print on screen intermediate computations |#
(declare
(type chain-complex chcm)
(type fixnum n))
@ -153,41 +146,51 @@
mat)))
(DEFUN MAKE-ARRAY-TO-LISTS (array)
#| Convert an array to a list formed by the array's rows |#
(loop for i below (array-dimension array 0)
collect (loop for j below (array-dimension array 1)
collect (aref array i j))))
(DEFUN MAKE-ARRAY-FROM-LISTS (nrows ncols list)
#| Construct an array from a list formed by the array's rows |#
(make-array (list nrows ncols) :initial-contents list))
(DEFUN BASIS_AUX1 (kchcm dim)
(basis kchcm dim))
(DEFUN ORGN_AUX1 (kchcm)
(orgn kchcm))
(DEFUN DFFR_AUX1(kchcm dim cmbn_list)
#| Differential of a comb with dimension 'dim' and 'cmbn_list' as its cmbn-list |#
(let ((comb (cmbn dim)))
(setf (cmbn-list comb) cmbn_list)
(dffr kchcm comb)))
(DEFUN KCHAINCOMPLEX_AUX1 (chcm str_orgn)
#| Construct a chain complex in Kenzo from the information of the assoc list 'chcm' constructed from a dictionary whose values are matrices |#
(build-chcm :cmpr #'G-CMPR
:strt :GNRT
:basis (kbasis chcm)
:intr-dffr (kdffr chcm)
:orgn `(KChainComplex ,str_orgn)))
;;;; Simplicial sets
;;;;; Simplicial Sets ;;;;;
(DEFUN KABSTRACTSIMPLEX_AUX1 (degeneracies name)
(absm (dgop-ext-int degeneracies) name))
(DEFUN BUILD-FINITE-SS2 (list)
#| The same 'build-finite-ss' function but it does not check the face relations of the simplices in 'list' ('check-smst' omitted) |#
(declare (list list))
(let ((bspn (first list))
(table (finite-ss-table list))
@ -208,5 +211,17 @@
rslt)))
(DEFUN SFINITESIMPLICIALSET_AUX1 (finitess limit)
#| Construct a list (L0 L1 ... Lm), with m <= 'limit', where each list Lk is formed by lists of the form (S (a0 ... ak)), where each aj is a face of the k-simplex S |#
(let ((rslt NIL))
(do ((k 1 (1+ k))) ((> k limit))
(let ((dimk NIL))
(dolist (simplex (basis finitess k))
(let ((faces NIL))
(do ((i k (1- i))) ((< i 0))
(push (face finitess i k simplex) faces))
(push (cons simplex faces) dimk)))
(push dimk rslt)))
(reverse rslt)))