finite topological spaces updated

kenzo.asd

@@ -61,7 +61,8 @@
              (:file "sage-interface")
              (:file "finite-topological-spaces-aux")     
              (:file "finite-topological-spaces-class")
-             (:file "finite-topological-spaces-core")          
+             (:file "finite-topological-spaces-core")
+             (:file "finite-topological-spaces-homology")         
              (:module "anromero"
              :components
 	     ((:file "resolutions")

src/finite-topological-spaces-class.lisp

@@ -31,35 +31,6 @@
     rslt))
 
 
-(DEFUN CONVERTMATRICE (matrice)
-  #| Convert a 'matrice' to an 'array' |#
-  (let* ((numfil (nlig matrice))
-         (numcol (ncol matrice))
-         (rslt (make-array (list numfil numcol) :initial-element 0)))
-    (dotimes (i numfil)
-      (dotimes (j numcol)
-        (let ((Mij (terme matrice (1+ i) (1+ j))))
-          (unless (zerop Mij)
-            (setf (aref rslt i j) Mij)))))
-    rslt))
-
-
-(DEFUN VER (matrix)
-  (let ((mat '()))
-    (typecase matrix
-      (matrice (setf mat matrix))
-      (T (setf mat (convertarray matrix))))
-    (format t "~%")
-    (format t "           ========== MATRIX ~A row(s) + ~A column(s) ==========~%~%" (nlig mat) (ncol mat))
-    (do ((i 1 (1+ i))) ((> i (nlig mat)))
-      (format t "           ")
-      (do ((j 1 (1+ j))) ((> j (ncol mat)))
-        (if (< (terme mat i j) 0)
-            (format t " ~A " (terme mat i j))
-          (format t "  ~A " (terme mat i j))))
-      (format t "  ~%"))))
-
-
 (DEFUN EXTRACT-COLUMN2 (mtrx icol list)
   #| Modification of 'EXTRACT-COLUMN' in order to extract only the elements in the column 'icol' whose row indexes are in the list 'list' |#
   (declare (type matrice mtrx) (type fixnum icol) (type list list))
@@ -404,6 +375,110 @@
                           :top topogenous)))
 
 
+;;
+;;  Barycentric subdivision
+;;
+
+
+(DEFUN RELAC (topogenous)
+  #| Chains of length 2 |#
+  (declare (type matrice topogenous))
+  (let* ((dim (nlig topogenous))
+         (rslt (creer-matrice dim dim)))
+    (declare (type fixnum dim))   
+    (do ((i 1 (1+ i))) ((> i dim) rslt)
+      (do ((j (1+ i) (1+ j))) ((> j dim))
+        (if (eq (terme topogenous i j) 1)
+            (insert-term rslt i j (list (list i j))))))))
+
+
+(DEFUN BOUNDARYOPERATORS (topogenous)
+  (let* ((relac (relac topogenous))
+         (diferenciales NIL)
+         (nuevo relac)
+         (dim (nlig topogenous))
+         (parada 0)
+         (dim_n 0)
+         (Cn NIL))
+
+    (do ((i 1 (1+ i))) ((> i (1- dim)))
+      (do ((j (1+ i) (1+ j))) ((> j dim))
+        (unless (eq (terme topogenous i j) 0)
+          (setf Cn (append Cn (list (list i j)))))))
+
+    (setf dim_n (length Cn))
+    
+    (push (let ((D1 (creer-matrice dim dim_n)))
+            (dotimes (i dim)
+              (dotimes (j dim_n)
+                (if (find (1+ i) (nth j Cn))
+                    (insert-term D1 (1+ i)  (1+ j) 1))))
+            D1) diferenciales)
+            
+    (if (> dim 1)
+        (do ((long 2 (1+ long))) ((or (> long dim) (eq parada 1)))
+          (let ((dim_n-1 dim_n)
+                (Cn-1 Cn)
+                (anterior nuevo))
+            
+            (setf dim_n 0 Cn NIL nuevo (creer-matrice dim dim))
+            
+            (do ((i 1 (1+ i))) ((> i (- (1+ dim) long)))
+              (do ((j (1+ i) (1+ j))) ((> j dim))
+                (let ((cadenasij NIL))
+                  (do ((r i (1+ r))) ((> r j))
+                    (let ((termeir (terme anterior i r)))
+                      (unless (or (eq termeir 0) (eq (terme relac r j) 0))
+                        (setf cadenasij (append cadenasij (mapcar #'(lambda (x) (append x (list j))) termeir))))))
+                  (if cadenasij
+                      (progn (insert-term nuevo i j cadenasij)
+                        (setf Cn (append Cn cadenasij)))))))
+            
+            (setf dim_n (length Cn))
+            
+            (if (eq dim_n 0)
+                (setf parada 1)
+              (push (let ((Dn (creer-matrice dim_n-1 dim_n)))
+                      (dotimes (i dim_n-1)
+                        (dotimes (j dim_n)
+                          (if (subsetp (nth i Cn-1) (nth j Cn))
+                              (insert-term Dn (1+ i) (1+ j) 1))))
+                      Dn) diferenciales)))))
+    (return-from BOUNDARYOPERATORS (reverse diferenciales))))
+
+
+(DEFUN BLOCKS (list)
+  (let ((rslt (identite (let ((suma (nlig (car list))))
+                          (dolist (x list)
+                            (setf suma (+ suma (ncol x))))
+                          suma))))
+    (do* ((lst list (cdr lst)) 
+          (kfilas 0 (if (null lst) 0 (+ kfilas (nlig dif))))
+          (kcolumnas (nlig (car list)) (if (null lst) 0 (+ kcolumnas (ncol dif))))
+          (dif (car lst) (car lst))) ((endp lst))
+      
+      (do ((i 1 (1+ i))) ((> i (nlig dif)))
+        (do ((j 1 (1+ j))) ((> j (ncol dif)))
+          (unless (eq (terme dif i j) 0)
+            (insert-term rslt (+ i kfilas) (+ j kcolumnas) 1)))))
+      rslt))
+
+
+(DEFMETHOD BAR_SUBDIVISION ((topogenous matrice))
+  #| Topogenous matrice of the barycentric subdivision of 'topogenous' |#
+  (topmat (blocks (boundaryoperators topogenous))))
+
+
+(DEFMETHOD BAR_SUBDIVISION ((finspace finite-space))
+  #| Finite-Space whose 'top' is the barycentric subdivision of (top 'finspace') |#
+  (let ((already (find `(BARYCENTRIC-SUBDIVISION ,finspace) *finite-space-list* :test #'equal :key #'orgn)))
+    (declare (type (or finite-space null) already))
+    (if already
+        already
+      (build-finite-space :orgn `(BARYCENTRIC-SUBDIVISION ,finspace)
+                          :stong (blocks (boundaryoperators (top finspace)))))))
+
+
 ;;
 ;;  Special examples of Finite topological spaces
 ;;

src/finite-topological-spaces-core.lisp

@@ -13,7 +13,7 @@
 ;;
 
 
-(DEFUN DOWNBP (topogenous n list)
+(DEFUN DOWNBP (topogenous n &optional (list (<a-b> 1 (nlig topogenous))))
   #| T if Xn is a down beat point of the submatrix 'list'x'list' |#
   (the boolean
        (let ((maximal (loop for k in (reverse (subseq list 0 (position n list)))
@@ -25,7 +25,7 @@
            +TRUE+))))
 
 
-(DEFUN UPBP (topogenous n list)
+(DEFUN UPBP (topogenous n &optional (list (<a-b> 1 (nlig topogenous))))
   #| T if Xn is an up beat point of the submatrix 'list'x'list' |#
   (the boolean
        (let ((minimal (loop for k in (subseq list (1+ (position n list)))
@@ -36,7 +36,7 @@
            +TRUE+))))
 
 
-(DEFUN BEATPOINT (topogenous n list) 
+(DEFUN BEATPOINT (topogenous n &optional (list (<a-b> 1 (nlig topogenous)))) 
   #| T if Xn is a beat point of the submatrix 'list'x'list' |#
   (the boolean
        (if (< (1+ n) (/ (ncol topogenous) 2))
@@ -48,7 +48,7 @@
            (downbp topogenous n list)))))
 
 
-(DEFUN CORE_LIST (topogenous list)
+(DEFUN CORE_LIST (topogenous &optional (list (<a-b> 1 (nlig topogenous))))
   #| List of the elements of the core of the submatrix 'list'x'list' |#
   (let ((eliminar NIL))
     (setf eliminar (loop for n in list
@@ -58,33 +58,33 @@
       (core_list topogenous (remove eliminar list)))))
 
 
-(DEFUN Un-N (topogenous n list)
+(DEFUN Un-N (topogenous n &optional (list (<a-b> 1 (nlig topogenous))))
   #| List of the elements in Un-{Xn} |#
   (loop for i in (subseq list 0 (position n list))
        when (eq (terme topogenous i n) 1)
        collect i))
 
 
-(DEFUN Fn-N (topogenous n list)
+(DEFUN Fn-N (topogenous n &optional (list (<a-b> 1 (nlig topogenous))))
   #| List of the elements in Fn-{Xn} |#
   (loop for j in (subseq list (1+ (position n list)))
        when (eq (terme topogenous n j) 1)
        collect j))
 
 
-(DEFUN LINK_LIST (topogenous n list)
+(DEFUN LINK_LIST (topogenous n &optional (list (<a-b> 1 (nlig topogenous))))
   #| List of the elements in the link of Xn |#
   (append (Un-N topogenous n list) (Fn-N topogenous n list)))
 
 
-(DEFUN WEAKPOINT (topogenous n list)
+(DEFUN WEAKPOINT (topogenous n &optional (list (<a-b> 1 (nlig topogenous))))
   #| T if Xn is a weak beat point of the submatrix 'list'x'list' |#
   (the boolean
        (or (eq (length (core_list topogenous (Un-N topogenous n list))) 1)
            (eq (length (core_list topogenous (Fn-N topogenous n list))) 1))))
   
   
-(DEFUN WEAKCORE_LIST (topogenous list)
+(DEFUN WEAKCORE_LIST (topogenous &optional (list (<a-b> 1 (nlig topogenous))))
   #| List of the elements of a "weak core" of the submatrix 'list'x'list' |#
   (let ((eliminar NIL))
     (setf eliminar (loop for n in list
@@ -94,43 +94,39 @@
       (weakcore_list topogenous (remove eliminar list)))))
 
 
-(DEFMETHOD CORE ((topogenous matrice) &optional list)
+(DEFMETHOD CORE ((topogenous matrice) &optional (list (<a-b> 1 (nlig topogenous))))
   #| Matrice of the core of 'topogenous' |#
   (the matrice
-       (let* ((list2 (if list
+       (let ((corelist (core_list topogenous list)))
-                         list
-                       (<a-b> 1 (nlig topogenous))))
-              (corelist (core_list topogenous list2)))
          (sub-matrix topogenous corelist corelist))))
 
 
 (DEFMETHOD CORE ((finspace finite-space) &optional list)
   #| Finite-Space whose 'top' is the topogenous matrix of the core of (top 'finspace') |#
-  (let ((already (find `(CORE ,finspace ,list) *finite-space-list* :test #'equal :key #'orgn)))
+  (let ((already (find (if list `(CORE ,finspace ,list) `(CORE ,finspace)) *finite-space-list* :test #'equal :key #'orgn)))
     (declare (type (or finite-space null) already))
     (if already
         already
-      (build-finite-space :orgn `(CORE ,finspace ,list)
+      (let ((list2 (or list (<a-b> 1 (nlig (top finspace))))))
-                          :top (core (top finspace) list)))))
+        (build-finite-space :orgn (if list `(CORE ,finspace ,list) `(CORE ,finspace))
+                            :top (core (top finspace) list2))))))
 
 
-(DEFMETHOD WEAKCORE ((topogenous matrice) &optional list)
+(DEFMETHOD WEAKCORE ((topogenous matrice) &optional (list (<a-b> 1 (nlig topogenous))))
   #| Matrice of a "weak core" of 'topogenous' |#
   (the matrice
-       (let* ((list2 (if list
+       (let ((weakcorelist (weakcore_list topogenous (core_list topogenous list))))
-                         list
-                       (<a-b> 1 (nlig topogenous))))
-              (weakcorelist (weakcore_list topogenous (core_list topogenous list2))))
          (sub-matrix topogenous weakcorelist weakcorelist))))
 
 
 (DEFMETHOD WEAKCORE ((finspace finite-space) &optional list)
   #| Finite-Space whose 'top' is the topogenous matrix of a "weak core" of (top 'finspace') |#
-  (let ((already (find `(WEAK-CORE ,finspace ,list) *finite-space-list* :test #'equal :key #'orgn)))
+  (let ((already (find (if list `(WEAK-CORE ,finspace ,list) `(WEAK-CORE ,finspace)) *finite-space-list* :test #'equal :key #'orgn)))
     (declare (type (or finite-space null) already))
     (if already
         already
-      (build-finite-space :orgn `(WEAK-CORE ,finspace ,list)
+      (let ((list2 (or list (<a-b> 1 (nlig (top finspace))))))
-                          :top (weakcore (top finspace) list)))))
+        (build-finite-space :orgn (if list `(WEAK-CORE ,finspace ,list) `(WEAK-CORE ,finspace))
+                            :top (weakcore (top finspace) list2))))))
 
 

src/finite-topological-spaces-homology.lisp

@@ -0,0 +1,301 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
+
+;;  FINITE-TOPOLOGICAL-SPACES  FINITE-TOPOLOGICAL-SPACES  FINITE-TOPOLOGICAL-SPACES 
+;;  FINITE-TOPOLOGICAL-SPACES  FINITE-TOPOLOGICAL-SPACES  FINITE-TOPOLOGICAL-SPACES 
+;;  FINITE-TOPOLOGICAL-SPACES  FINITE-TOPOLOGICAL-SPACES  FINITE-TOPOLOGICAL-SPACES 
+
+(IN-PACKAGE #:cat)
+
+(PROVIDE "finite-topological-spaces-homology")
+
+;;
+;;  Homology of h-regular spaces
+;;
+
+
+(DEFUN COLUMN-J (mtrx j)
+   (declare (type matrix mtrx)
+            (type fixnum j))
+   (assert (< j (column-number mtrx)))
+   (the list
+     (let ((line-n (line-number mtrx)))
+        (declare (type fixnum line-n))
+        (mapcar
+         #'(lambda (i)
+             (declare (type fixnum i))
+             (aref mtrx i j))
+         (<a-b> 0 (1- line-n))))))
+
+
+(DEFUN KERNEL (mtrx)
+   (declare (type matrix mtrx))
+   (the list
+     (let* ((smith-list (smith mtrx))
+            (m (third smith-list))
+            (q (fourth smith-list))
+            (min (min (line-number mtrx) (column-number mtrx)))
+            (rslt nil))
+        (declare
+          (type list smith-list rslt)
+          (type matrix m q)
+          (type fixnum min))
+        (progn
+         (do ((j (1- (column-number mtrx)) (1- j)))
+             ((< j min))
+            (declare (type fixnum j))
+            (setq rslt (nconc (list (column-j q j)) rslt)))
+         (do ((i (1- min) (1- i)))
+             ((or (< i 0) (not (eql  0 (aref m i i)))))
+            (declare (type fixnum i))
+            (setq rslt (nconc (list (column-j q i)) rslt)))
+         rslt))))
+
+
+(DEFMETHOD H-REGULAR-DIF ((finspace finite-space))
+  (let ((diferenciales NIL)
+        (aristas (matrice-to-lmtrx (nilpot (stong finspace))))
+        (alturas (heights finspace)))
+    (declare (type list diferenciales))
+    (dotimes (dimension (length alturas))
+      (let* ((Cn (nth dimension alturas))
+             (dim_n (length Cn)))
+        (if (zerop dimension)
+            (push (creer-matrice 0 (length Cn)) diferenciales)
+          (let* ((Cn-1 (nth (1- dimension) alturas))
+                 (dim_n-1 (length Cn-1))
+                 (rslt (creer-matrice dim_n-1 dim_n)))
+            (case dimension          
+              (1 (progn (push (do ((group Cn (cdr group))
+                                   (posicion 1 (1+ posicion)))
+                                  ((endp group) rslt)
+                                (let ((colj (aref aristas (1- (car group)))))
+                                  (insert-term rslt (1+ (position (1+ (car (first colj))) Cn-1))  posicion -1)
+                                  (insert-term rslt (1+ (position (1+ (car (second colj))) Cn-1)) posicion  1)))
+                              diferenciales)))
+              
+              (otherwise (push (let ((Cn-2 (<a-b> 1 (length (nth (- dimension 2) alturas))))
+                                     (dn-1 (first diferenciales))
+                                     (group Cn))
+                                 (do ((posicion 1 (1+ posicion)))
+                                     ((null group) rslt)
+                                   (let* ((maxUj (mapcar #'(lambda (v) (1+ (car v))) (aref aristas (1- (pop group)))))
+                                          (cols (posiciones-1 maxUj Cn-1))
+                                          (ker (car (kernel (make-array (list (length Cn-2) (length cols))
+                                                                        :element-type 'fixnum
+                                                                        :initial-contents (loop for i in Cn-2
+                                                                                                collect (loop for j in cols
+                                                                                                              collect (terme dn-1 i j))))))))
+                                     (do ((ker ker (cdr ker))
+                                          (cols cols (cdr cols)))
+                                         ((endp cols))
+                                       (insert-term rslt (car cols) posicion (car ker))))))
+                               diferenciales)))))))
+    (return-from H-REGULAR-DIF (reverse diferenciales))))
+    
+    
+(DEFMETHOD H-REGULAR-DIF ((topogenous matrice))
+  (let ((finspace (build-finite-space :top topogenous)))
+    (H-REGULAR-DIF finspace)))
+
+
+(DEFUN POSICIONES (pos list)
+  (loop for x in pos
+    collect (nth (1- x) list)))
+
+
+(DEFUN POSICIONES-1 (list1 list2)   ; 'list1' is a sublist of 'list2'
+  (loop for x in list1
+        collect (1+ (position x list2 :test #'equal))))
+
+
+(DEFUN D21-1 (blocks size)
+  #| Modify 'blocks' in order to obtain an identity matrix in the submatrix 'size'x'size' |#
+  (declare (type fixnum size))
+  (the matrice
+       (let ((rslt (copier-matrice blocks)))
+         (unless (or (< (nlig rslt) size) (< (ncol rslt) size) (= size 0))
+           (loop for k from 1 to size
+                 do (progn
+                      ;(if (eq (terme rslt k k) 0)
+                          ;(0column-swap rslt k (loop for j from (1+ k) to size
+                                   ;                  when (not (eq (terme rslt k j) 0))
+                                    ;                 return j)))
+                      (unless (eq (terme rslt k k) 1)
+                        (0column-op rslt (1- (terme rslt k k)) k k))
+                      (loop for j from 1 to size
+                            if (not (eq j k))
+                            do (unless (eq (terme rslt k j) 0)
+                                 (0column-op rslt (- (terme rslt k j)) k j))))))
+         rslt)))
+
+
+
+(DEFUN RESTA (mtrx1 mtrx2)
+  (let ((rslt (creer-matrice (nlig mtrx1) (ncol mtrx2))))
+    (loop for i from 1 to (nlig mtrx1)
+          do (loop for j from 1 to (ncol mtrx1)
+                   do (insert-term rslt i j (- (terme mtrx1 i j) (terme mtrx2 i j)))))
+    rslt))
+
+
+(DEFUN FINAL (matrix corte) ; 'matrix' is the result of the function D21-1 and 'corte' is the 'size' in D21-1 function
+  (let ((d31 (sub-matrix matrix
+                        (>a-b> corte (nlig matrix))
+                        (<a-b> 1 corte)))
+        (d23 (sub-matrix matrix
+                        (<a-b> 1 corte )
+                        (>a-b> corte (ncol matrix))))
+        (d33 (sub-matrix matrix
+                        (>a-b> corte (nlig matrix))
+                        (>a-b> corte (ncol matrix)))))
+    (resta d33 (matrice-prdc d31 d23))))
+
+
+(DEFSTRUCT (TSC (:conc-name nil))
+  name diferencial group targets sources critical)
+
+
+(DEFMACRO DESCOMP (name)
+  `(setf ,name (make-TSC)
+         (sources ,name) (reverse (intersection sou summands))
+         (targets ,name) (reverse (intersection tar summands))
+         (critical ,name) (let ((cri summands))
+                            (dolist (x (append (targets ,name) (sources ,name)))
+                              (setf cri (remove x cri)))
+                            cri)))
+
+
+(DEFMETHOD DVF-H-REGULAR-DIF ((finspace finite-space) &key sou tar) 
+  (let* ((groups NIL)
+         (diferenciales NIL)
+         (dn-3 NIL)
+         (dn-2 NIL)
+         (dn-1 NIL)
+         (dn NIL)
+         (alturas (heights finspace))
+         (height (length alturas))) 
+    (declare (type list groups diferenciales)
+             (type fixnum height))
+    (setf dn-3 (make-TSC))
+    (dotimes (dimension height)
+      (let ((summands (nth dimension alturas)))
+        (case dimension
+          (0  (progn (descomp dn-2)
+                ;;; Computing C0':
+                (push (mapcar #'(lambda (u) (list (list 1 u))) summands) groups)
+                ;;; Computing d0:
+                (push (creer-matrice 0 (length (critical dn-2))) diferenciales)))
+          
+          (1  (progn (descomp dn-1)
+                ;;; Computing C1':
+                (push (loop for x in summands
+                            collect (let* ((primer1 (find-if #'(lambda (y) (= (terme (top finspace) y x) 1))
+                                                             (<a-b< 1 (nlig (top finspace)))))
+                                           (segundo1 (find-if #'(lambda (y) (= (terme (top finspace) y x) 1))
+                                                              (>a-b> primer1 (nlig (top finspace))))))
+                                      (list (list 1 segundo1 x) (list -1 primer1 x)))) groups)
+                
+                ;;; Computing d1'':
+                (push (let ((rslt (creer-matrice (length (second groups)) (length summands))))
+                        (dolist (x (apply #'append (first groups)))
+                          (insert-term rslt (1+ (position (second x) (first alturas) :test #'equal)) 
+                                       (1+ (position (third x) (second alturas) :test #'equal))
+                                       (first x)))
+                        rslt) diferenciales)))
+          
+          (otherwise (progn (descomp dn)
+                       (let ((rslt NIL)
+                             (Cn-1 (first groups))
+                             (Cn-2 (second groups)))
+                         
+                         ;;; Cálculo de Cn' (rslt):
+                         (dolist (x (reverse summands))
+                           (let ((pseudo NIL)
+                                 (list_fil NIL)
+                                 (list_col NIL)
+                                 (kernel NIL))
+                             
+                             (setf list_fil (loop for k from 0 to (1- (length Cn-2)) 
+                                                   when (= (terme (top finspace) (car (last (first (nth k Cn-2)))) x) 1)
+                                                   collect k)
+                                   list_col (loop for k from 0 to (1- (length Cn-1))
+                                                   when (= (terme (top finspace) (car (last (first (nth k Cn-1)))) x) 1)
+                                                   collect k)
+                                   
+                                 kernel (car (kernel (convertmatrice (sub-matrix (first diferenciales)
+                                                                                (mapcar #'(lambda (x) (1+ x)) list_fil)
+                                                                                (mapcar #'(lambda (x) (1+ x)) list_col))))))
+                             
+                             (do ((lst list_col (cdr lst))
+                                  (ker kernel (cdr ker)))
+                                 ((endp lst))
+                               (unless (equal (car ker) 0)
+                                 (let ((actualizar (nth (car lst) Cn-1)))
+                                   (dolist (z actualizar)
+                                     (push (reverse (cons x (reverse (cons (* (car ker) (car z)) (cdr z))))) pseudo)))))
+                             
+                             (push pseudo rslt)))
+                         
+                         ;;; Computing dn'' (rslt2):
+                         (push (let ((rslt2 (creer-matrice (length Cn-1) (length summands))))
+                               (dotimes (j (length summands) rslt2)
+                                 (let ((next-to-last 0))
+                                   (do ((tj (nth j rslt) (remove-if #'(lambda (elto)
+                                                                        (equal next-to-last (second (reverse elto))))
+                                                                    tj)))
+                                       ((null tj))
+                                     
+                                     (setf next-to-last (second (reverse (first tj))))
+                                     (let* ((g (nth (position next-to-last (nth (1- dimension) alturas)) Cn-1))
+                                            (ui (car (last g))))
+                                       (dolist (l tj)
+                                         (if (equal (cdr ui) (reverse (cdr (reverse (cdr l)))))
+                                             (progn
+                                               (insert-term rslt2 (1+ (position g Cn-1)) (1+ j) (* (first ui) (first l)))
+                                               (return))))))))) diferenciales)
+                         (setf groups (list (car groups)))
+                         (push rslt groups))
+                       
+                       (unless (= dimension 2)
+                         (setf (third diferenciales)
+                               (final
+                                (d21-1
+                                 (sub-matrix (third diferenciales)
+                                            (posiciones-1 (append (sources dn-3) (critical dn-3)) (nth (- dimension 3) alturas))
+                                            (posiciones-1 (append (targets dn-2) (critical dn-2)) (nth (- dimension 2) alturas)))
+                                 (length (targets dn-2)))
+                                (length (targets dn-2)))))
+                       
+                       (setf dn-3 dn-2
+                             dn-2 dn-1
+                             dn-1 dn))))))
+    
+    ;;; Modify the last 2 matrices
+    (unless (= height 1)
+      (unless (= height 2)
+        (setf (second diferenciales)
+              (final
+               (d21-1
+                (sub-matrix (second diferenciales)
+                           (posiciones-1 (append (sources dn-3) (critical dn-3)) (nth (- height 3) alturas))
+                           (posiciones-1 (append (targets dn-2) (critical dn-2)) (nth (- height 2) alturas)))
+                (length (targets dn-2)))
+               (length (targets dn-2)))))
+      
+      (setf (first diferenciales)
+            (final
+             (d21-1
+              (sub-matrix (first diferenciales)
+                         (posiciones-1 (append (sources dn-2) (critical dn-2)) (nth (- height 2) alturas))
+                         (posiciones-1 (append (targets dn-1) (critical dn-1)) (nth (- height 1) alturas)))
+              (length (targets dn-1)))
+             (length (targets dn-1)))))
+
+    (return-from DVF-H-REGULAR-DIF (reverse diferenciales))))
+
+
+(DEFMETHOD DVF-H-REGULAR-DIF ((topogenous matrice) &key sou tar)
+  (let ((finspace (build-finite-space :top topogenous
+                                      :stong (stongmat topogenous))))
+        (DVF-H-REGULAR-DIF finspace :sou sou :tar tar)))
+

src/sage-interface.lisp

@@ -102,7 +102,7 @@
 #| 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)))
+         (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))))