finite-topological-spaces-core.lisp file added

kenzo.asd

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

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))

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 (<a-b> 1 (ncol stong))))
+  (heights-aux stong (<a-b> 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)

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
+                       (<a-b> 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
+                       (<a-b> 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)))))
+
+