diff --git a/kenzo.asd b/kenzo.asd index f185647..b229f82 100644 --- a/kenzo.asd +++ b/kenzo.asd @@ -59,7 +59,8 @@ (:file "smith") (:file "sage-interface") (:file "finite-topological-spaces-aux") - (:file "finite-topological-spaces-class") + (:file "finite-topological-spaces-class") + (:file "finite-topological-spaces-core") (:module "anromero" :components ((:file "resolutions") diff --git a/src/finite-topological-spaces-aux.lisp b/src/finite-topological-spaces-aux.lisp index e282352..5cd65dd 100644 --- a/src/finite-topological-spaces-aux.lisp +++ b/src/finite-topological-spaces-aux.lisp @@ -97,6 +97,27 @@ rslt)))) +(DEFUN MATRICE-TO-LMTRX (mtrx) + (let* ((column-n (ncol mtrx)) + (rslt (make-array column-n))) + (dotimes (j column-n) + (let ((rsltj '()) + (columnj-pair-list + (let ((ptc (basecol mtrx (1+ j))) + (res '())) + (do ((pc (up ptc) (up pc))) + ((eq pc ptc)) + (push (list (ilig pc) (val pc)) res)) + res))) + + (mapcar #'(lambda (pair) + (push (list (1- (first pair)) (second pair)) rsltj)) + columnj-pair-list) + + (setf (svref rslt j) (nreverse rsltj) ))) + rslt)) + + (DEFUN SAFE-* (arg1 arg2) #| This is in 'NewSmith' |# (declare (type fixnum arg1 arg2)) diff --git a/src/finite-topological-spaces-class.lisp b/src/finite-topological-spaces-class.lisp index 973c130..47edfdb 100644 --- a/src/finite-topological-spaces-class.lisp +++ b/src/finite-topological-spaces-class.lisp @@ -79,8 +79,6 @@ (DEFUN SUBMATRIX (mtrx rows cols) #| Extract the submatrix of 'mtrx' formed by the rows whose indexes are in 'rows' and the columns whose indexes are in 'cols' |# - (declare (type matrice mtrx) - (type list rows cols)) (let ((rslt (creer-matrice (length rows) (length cols)))) (do ((k 1 (1+ k)) (columnas cols (cdr columnas))) @@ -230,18 +228,18 @@ `(stongmat (randomtop ,dim ,dens))) -(DEFUN ALTUR (stong lst) +(DEFUN HEIGHTS-AUX (stong lst) (if (null lst) NIL (let ((minimals (loop for n in lst if (null (loop for i from 0 to (1- (position n lst)) thereis (eq (terme stong (nth i lst) n) 1))) collect n))) - (cons minimals (altur stong (reverse (set-difference lst minimals))))))) + (cons minimals (heights-aux stong (set-difference lst minimals)))))) ; 'set-difference' must be in ascending order (DEFMETHOD HEIGHTS ((stong matrice)) #| List of elements separated by heights |# - (altur stong ( 1 (ncol stong)))) + (heights-aux stong ( 1 (ncol stong)))) (DEFCLASS FINITE-SPACE () @@ -334,7 +332,6 @@ (DEFMETHOD ADMISSIBLE-P ((topogenous matrice)) - (the boolean (let ((fin T) (stong (stongmat topogenous))) @@ -346,7 +343,6 @@ (DEFMETHOD ADMISSIBLE-P ((finspace finite-space)) - (the boolean (let ((fin T)) (do ((j 2 (1+ j))) ((or (null fin) (> j (ncol (top finspace)))) fin) diff --git a/src/finite-topological-spaces-core.lisp b/src/finite-topological-spaces-core.lisp new file mode 100644 index 0000000..8d0e68d --- /dev/null +++ b/src/finite-topological-spaces-core.lisp @@ -0,0 +1,124 @@ +;;;; -*- 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-core") + +;; +;; Point reductions: beat points and weak beat points +;; + + +(DEFUN DOWNBP (topogenous n list) + #| 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))) + thereis (and (eq (terme topogenous k n) 1) k)))) + + (unless (or (null maximal) + (loop for i in (subseq list 0 (position n list)) + thereis (not (eq (terme topogenous i maximal) (terme topogenous i n))))) + +TRUE+)))) + + +(DEFUN UPBP (topogenous n list) ; 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))) + thereis (and (eq (terme topogenous n k) 1) k)))) + (unless (or (null minimal) + (loop for i in (subseq list (1+ (position n list))) + thereis (not (eq (terme topogenous minimal i) (terme topogenous n i))))) + +TRUE+)))) + + +(DEFUN BEATPOINT (topogenous n list) ; T if Xn is a beat point of the submatrix 'list'x'list' + (the boolean + (if (< (1+ n) (/ (ncol topogenous) 2)) + (if (downbp topogenous n list) + +TRUE+ + (upbp topogenous n list)) + (if (upbp topogenous n list) + +TRUE+ + (downbp topogenous n list))))) + + +(DEFUN CORE_LIST (topogenous list) ; List of the elements of the core of the submatrix 'list'x'list' + (let ((eliminar NIL)) + (setf eliminar (loop for n in list + thereis (and (beatpoint topogenous n list) n))) + (if (null eliminar) + (return-from core_list list) + (core_list topogenous (remove eliminar list))))) + + +(DEFMACRO Un-N (topogenous n list) ; 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)) + + +(DEFMACRO Fn-N (topogenous n list) ; 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)) + + +(DEFMACRO LINK_LIST (topogenous n list) ; List of the elements in the link of Xn + `(append (Un-N ,topogenea ,n ,list) (Fn-N ,topogenous ,n ,list))) + + +(DEFUN WEAKPOINT (topogenous n list) ; 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) ; List of the elements of a "weak core" of the submatrix 'list'x'list' + (let ((eliminar NIL)) + (setf eliminar (loop for n in list + thereis (and (or (beatpoint topogenous n list) (weakpoint topogenous n list)) n))) + (if (null eliminar) + (return-from weakcore_list list) + (weakcore_list topogenous (remove eliminar list))))) + + +(DEFMETHOD CORE ((topogenous matrice) &optional list) ; Matrice of the core of 'topogenous' + (the matrice + (let* ((list2 (if list + list + ( 1 (nlig topogenous)))) + (corelist (core_list topogenous list2))) + (submatrix 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) *finite-space-list* :test #'equal :key #'orgn))) + (declare (type (or finite-space null) already)) + (if already + already + (build-finite-space :orgn `(CORE ,finspace) + :top (core (top finspace) list))))) + + +(DEFMETHOD WEAKCORE ((topogenous matrice) &optional list) ; Matrice of a "weak core" of 'topogenea' + (the matrice + (let* ((list2 (if list + list + ( 1 (nlig topogenous)))) + (weakcorelist (weakcore_list topogenous (core_list topogenous list2)))) + (submatrix 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) *finite-space-list* :test #'equal :key #'orgn))) + (declare (type (or finite-space null) already)) + (if already + already + (build-finite-space :orgn `(WEAK-CORE ,finspace) + :top (weakcore (top finspace) list))))) + + diff --git a/src/kenzo.fas b/src/kenzo.fas new file mode 100755 index 0000000..db5ed5f Binary files /dev/null and b/src/kenzo.fas differ