;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (IN-PACKAGE #:cat) (PROVIDE "sage-interface") ;;;;; 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) (return-from itoa "0")) (let ((negative? nil)) (if (< value 0) (progn (setf negative? t) (setf value (abs value)))) (loop for num = value then (floor num 10) for reminder = (mod num 10) while (> num 0) collect (code-char (+ reminder *ASCII-NUM-START*)) into result finally (if negative? (push #\- (cdr (last result)))) (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) NIL (loop for k from 0 to (1- (array-dimension (cdr pair) 1)) collect (gen dim k)))))) (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))) (num_gnr (read-from-string (subseq (write-to-string gnr) (1+ sep))))) (declare (fixnum dim_gnr num_gnr)) (unless (equal dim dim_gnr) ;It's not working (error "WRONG DIMENSION!!!")) (let ((pair (assoc dim schcm)) (rslt (cmbn (1- dim)))) (if (null pair) rslt (let ((dif (cdr pair))) (unless (< -1 num_gnr (array-dimension dif 1)) (error "WRONG GENERATOR!!!")) (setf (cmbn-list rslt) (loop for i from 0 to (1- (array-dimension dif 0)) unless (eq (aref dif i num_gnr) 0) collect (term (aref dif i num_gnr) (gen (1- dim) i)))) rslt)))))) #'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))))) (declare (fixnum m1 m2)) (the cmpr (if (< m1 m2) :less (if (= m1 m2) :equal :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) :element-type 'fixnum :initial-element 0))) (dotimes (i numfil) (dotimes (j numcol) (let ((Mij (entry matrice (1+ i) (1+ j)))) (unless (zerop Mij) (setf (aref rslt i j) Mij))))) rslt)) (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)) (let ((sorc (basis chcm n)) (trgt (basis chcm (1- n))) (cmpr (cmpr chcm))) (declare (list sorc trgt) (type cmprf cmpr)) (let ((sorcl (length sorc)) (mat (creer-matrice (length trgt) (length sorc))) (test #'(lambda (gnrt1 gnrt2) (eq (funcall cmpr gnrt1 gnrt2) :equal)))) (declare (type fixnum sorcl) (type matrice mat) (function test)) (do ((i 1 (1+ i)) (mark sorc (cdr mark))) ((endp mark)) (declare (type fixnum i) (list mark)) (maj-colonne mat i (mapcar #'(lambda (term) (declare (type term term)) (list (1+ (position (gnrt term) trgt :test test)) (cffc term))) (cmbn-list (? chcm n (car mark)))))) 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 DFFR-AUX(kchcm) (dffr kchcm)) (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 ;;;;; (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)) (ind-smst (gensym))) (declare (symbol bspn ind-smst) (simple-vector table)) ;; (vector (vector gmsm-faces-info)) (let ((rslt (build-smst :cmpr #'s-cmpr :basis (finite-ss-basis table) :bspn bspn :face (finite-ss-face ind-smst table) :intr-bndr (finite-ss-intr-bndr ind-smst table) :bndr-strt :gnrt :orgn `(build-finite-ss ,list)))) (setf (symbol-value ind-smst) rslt) 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))) ;;;;; Morphisms between Chain Complexes ;;;;; (DEFUN BUILD-MRPH-AUX (sorc trgt degr intr strt orgn) (build-mrph :sorc sorc :trgt trgt :degr degr :intr intr :strt strt :orgn orgn)) (DEFUN SORC-AUX (mrph) (sorc mrph)) (DEFUN TRGT-AUX (mrph) (trgt mrph)) (DEFUN DEGR-AUX (mrph) (degr mrph)) (DEFUN CHANGE-SORC-TRGT-AUX (mrph source target) (change-sorc-trgt mrph :new-sorc source :new-trgt target)) (DEFUN DSTR-CHANGE-SORC-TRGT-AUX (mrph source target) (dstr-change-sorc-trgt mrph :new-sorc source :new-trgt target)) (DEFUN EVALUATION-AUX1 (kchcm dim cmbn_list) (let ((comb (cmbn dim))) (setf (cmbn-list comb) cmbn_list) (? kchcm comb))) (DEFUN KINTR (smrph) #| Provide the slot :intr of the KenzoMorphismChainComplex obtained by applying the function 'KMorphismChainComplex' 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))) (num_gnr (read-from-string (subseq (write-to-string gnr) (1+ sep))))) (declare (fixnum dim_gnr num_gnr)) (unless (equal dim dim_gnr) ;It's not working (error "WRONG DIMENSION!!!")) (let ((pair (assoc dim smrph)) (rslt (cmbn dim))) (if (null pair) rslt (let ((mtrx (cdr pair))) (unless (< -1 num_gnr (array-dimension mtrx 1)) (error "WRONG GENERATOR!!!")) (setf (cmbn-list rslt) (loop for i from 0 to (1- (array-dimension mtrx 0)) unless (eq (aref mtrx i num_gnr) 0) collect (term (aref mtrx i num_gnr) (gen dim i)))) rslt)))))) #'frslt)) (DEFUN KMORPHISMCHAINCOMPLEX_AUX1 (mrph sorc trgt) #| Construct a chain complex morphism in Kenzo from the information of the assoc list 'mrph' constructed from a dictionary whose values are matrices |# (build-mrph :sorc sorc :trgt trgt :strt :GNRT :intr (kintr mrph) :orgn `(KMorphismChainComplex ,sorc ,trgt ,mrph)))