finite topological spaces updated
This commit is contained in:
Julián Cuevas-Rozo
parent
04511eb168
commit
0eb1ea06d3
@ -62,6 +62,7 @@
|
||||
(:file "finite-topological-spaces-aux")
|
||||
(:file "finite-topological-spaces-class")
|
||||
(:file "finite-topological-spaces-core")
|
||||
(:file "finite-topological-spaces-homology")
|
||||
(:module "anromero"
|
||||
:components
|
||||
((:file "resolutions")
|
||||
|
||||
@ -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
|
||||
;;
|
||||
|
||||
@ -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
|
||||
list
|
||||
(<a-b> 1 (nlig topogenous))))
|
||||
(corelist (core_list topogenous list2)))
|
||||
(let ((corelist (core_list topogenous list)))
|
||||
(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)
|
||||
:top (core (top finspace) list)))))
|
||||
(let ((list2 (or list (<a-b> 1 (nlig (top finspace))))))
|
||||
(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
|
||||
list
|
||||
(<a-b> 1 (nlig topogenous))))
|
||||
(weakcorelist (weakcore_list topogenous (core_list topogenous list2))))
|
||||
(let ((weakcorelist (weakcore_list topogenous (core_list topogenous list))))
|
||||
(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)
|
||||
:top (weakcore (top finspace) list)))))
|
||||
(let ((list2 (or list (<a-b> 1 (nlig (top finspace))))))
|
||||
(build-finite-space :orgn (if list `(WEAK-CORE ,finspace ,list) `(WEAK-CORE ,finspace))
|
||||
:top (weakcore (top finspace) list2))))))
|
||||
|
||||
|
||||
|
||||
301
src/finite-topological-spaces-homology.lisp
Normal file
301
src/finite-topological-spaces-homology.lisp
Normal file
@ -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)))
|
||||
|
||||
BIN
src/kenzo.fas
BIN
src/kenzo.fas
Binary file not shown.
@ -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))))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user