home *** CD-ROM | disk | FTP | other *** search
/ vis-ftp.cs.umass.edu / vis-ftp.cs.umass.edu.tar / vis-ftp.cs.umass.edu / pub / Software / ASCENDER / ascendMar8.tar / UMass / ISR / grid.lisp < prev    next >
Lisp/Scheme  |  1995-04-11  |  14KB  |  335 lines
  1. ;;; -*- Mode:Common-Lisp; Package:ISR2;  Base:10 -*-
  2.  
  3. (in-package "ISR2")
  4.  
  5. (defstruct (grid (:constructor %make-grid)
  6.           (:print-function print-grid))
  7.   cells
  8.   cell-count
  9.   %frame
  10.   gss
  11.   row-min
  12.   row-max
  13.   col-min
  14.   col-max
  15.   row-size
  16.   col-size
  17.   row-cell-count
  18.   (logging-enabledp nil)
  19.   (store-count 0)
  20.   (retrieve-count 0)
  21.   (cell-per-rasterization 0)
  22.   (tokens-per-retrieve 0))
  23.  
  24. (defun print-grid (grid stream ignore)
  25.   "Print a short representation of a grid structure. Do not print either the
  26.     cells [because *print-array* might be true] or the GSS [to avoid a loop]."
  27.   (format stream "<GRID ~A Col ~D to ~D by ~D; Row ~D to ~D by ~D>"
  28.       (frame-name (grid-%frame grid)) (grid-col-min grid)
  29.       (grid-col-max grid) (grid-col-size grid) (grid-row-min grid)
  30.       (grid-row-max grid) (grid-row-size grid)))
  31.  
  32. (defun make-grid (frame-path row-min row-max row-size col-min col-max col-size)
  33.   "Makes a new ISR2 grid object. Frame-path must designate a frame and the grid 
  34.     will accept tokens only from this frame. The grid spans from row-min to row-max 
  35.     with cells of width row-size, and from col-min to col-max with cells of width 
  36.     col-size. Cells are numbered for access such that a point (row, col) is mapped 
  37.     onto cell (+ (* (floor row row-size) row-cell-count) (floor col col-size)),
  38.     where row-size-count is (ceiling (- row-max row-min) row-size)"
  39.   (let ((frame-handle (isr2:handle frame-path))
  40.     (row-cell-count (ceiling (- row-max row-min) row-size))
  41.     (col-cell-count (ceiling (- col-max col-min) col-size)))
  42.     (let ((grid (%make-grid :cells (make-array (* row-cell-count col-cell-count))
  43.                 :cell-count (* row-cell-count col-cell-count)
  44.                 :%frame (handle-frame frame-handle)
  45.                 :row-min row-min
  46.                 :row-max row-max
  47.                 :row-size row-size
  48.                 :col-min col-min
  49.                 :col-max col-max
  50.                 :col-size col-size
  51.                 :row-cell-count row-cell-count)))
  52.       (setf (grid-gss grid) (make-gss grid))
  53.       grid)))
  54.  
  55. (defstruct (gss (:constructor %make-gss)
  56.          (:print-function print-gss))
  57.   grid
  58.   frame
  59.   select)
  60.  
  61. (defun print-gss (gss stream ignore)
  62.   "Print a short representation of a gss"
  63.   (format stream "<GSS ~A>" (gss-grid gss)))
  64.  
  65. (defun make-gss (grid)
  66.   "Returns a new ISR2 grid subset (GSS) object from the specified grid,
  67.     capturing its current state.  This object is used for rasterization.
  68.     A GSS indicates which subset of grid cells is selected. There is an
  69.     implicit GSS associated with each grid, and insofar as the rasterization 
  70.     functions are concerned, grids and GSS's may be used interchangeably.
  71.     A grid may alway be used in place of a GSS, in which case
  72.     it indicates that the implicit subset associated directly with
  73.     the grid should be used."
  74.   (cond ((grid-p grid) t)
  75.     (t (error "Argument grid-path is neither a grid nor a path specifying a grid.")))
  76.   (%make-gss :grid grid
  77.          :frame (grid-%frame grid)
  78.          :select (make-array (grid-cell-count grid)
  79.                  :element-type '(unsigned-byte 32) :fill-pointer 0)))
  80.  
  81. ;;;;;;;;;;; Top level GSS storage and retrieval functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82.  
  83. (defun grid-store (gss token)
  84.   "Stores token in every grid cell selected in the GSS.
  85.     Returns a handle to the token given as the second argument."
  86.   (let ((gss (cond ((gss-p gss) gss)
  87.            ((grid-p gss) (grid-gss gss))
  88.            (t (error "Argument is not a gss or grid."))))
  89.     (token-handle (isr2:handle token)))
  90.     (let ((grid (gss-grid gss)))
  91.       (unless (eq (gss-frame gss) (handle-frame token-handle))
  92.     (error "Token is not from the appropriate frame"))
  93.       (dotimes (index (fill-pointer (gss-select gss)) token-handle)
  94.     (add-token-to-grid-cell grid token-handle (aref (gss-select gss) index))))))
  95.  
  96. (defun grid-retrieve (gss)
  97.   "Returns a TSS representing the union of the contents of the
  98.     cells selected in the GSS. If loggin is enabled, grid access 
  99.     statistics are updated."
  100.   (let* ((gss (cond ((gss-p gss) gss)
  101.             ((grid-p gss) (grid-gss gss))
  102.             (t (error "Argument is not a gss or grid."))))
  103.      (grid (gss-grid gss))
  104.      (cells (grid-cells grid))
  105.      (select (gss-select gss))
  106.      (bound (fill-pointer select))
  107.      (token-index-list (when (> bound 0) (copy-list (aref cells (aref select 0))))))
  108.     (do ((ctr 1 (1+ ctr)))
  109.     ((>= ctr bound) 
  110.      (make-handle :type :token-subset
  111.               :frame (grid-%frame grid)
  112.               :token-existence-array token-index-list))
  113.       (setf token-index-list
  114.         (merge-index-lists token-index-list (aref cells (aref select ctr)))))))
  115.  
  116. (defun grid-remove (gss token)
  117.   "Remove token from the grid cells indicated by the GSS.
  118.     Returns a handle to the token given as the second argument."
  119.   (let ((gss (cond ((gss-p gss) gss)
  120.            ((grid-p gss) (grid-gss gss))
  121.            (t (error "Argument is not a gss or grid."))))
  122.     (token-handle (isr2:handle token)))
  123.     (let ((grid (gss-grid gss)))
  124.       (dotimes (index (fill-pointer (gss-select gss)) token-handle)
  125.     (remove-token-from-grid-cell grid token-handle (aref (gss-select gss) index))))))
  126.  
  127. (defun grid-clear! (grid)
  128.   "Removes all tokens from grid. Returns the clean grid."
  129.   (unless (grid-p grid) (error "Argument is not a grid"))
  130.   (dotimes (index (grid-cell-count grid) grid)
  131.     (setf (aref (grid-cells grid) index) nil)))
  132.  
  133. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; GSS manipulation functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  134.  
  135. (defun grid-cells-selected (gss)
  136.   "A sorted list of integers indicating those cells
  137.     which are selected. Note that this is not very efficient
  138.     since the selected cells are not kept as a list internally and
  139.     are not sorted. Presumably, this is for top level use only."
  140.   (let ((gss (cond ((gss-p gss) gss)
  141.            ((grid-p gss) (grid-gss gss))
  142.            (t (error "Argument is not a gss, grid or path thereto.")))))
  143.     (let ((select-list nil))
  144.       (dotimes (ctr (fill-pointer (gss-select gss)) (sort select-list #'<))
  145.     (push (aref (gss-select gss) ctr) select-list)))))
  146.  
  147. (defun gss-union! (gss1 gss2)
  148.   "GSS1 is destructively modified to be the union [in terms of selected cells] of
  149.     of GSS1 and GSS2."
  150.   ;; This could be made more efficient.
  151.   (let ((gss1 (cond ((gss-p gss1) gss1)
  152.             ((grid-p gss1) (grid-gss gss1))
  153.             (t (error "Argument 1 is not a gss or grid."))))
  154.     (gss2 (cond ((gss-p gss2) gss2)
  155.             ((grid-p gss2) (grid-gss gss2))
  156.             (t (error "Argument 2 is not a gss or grid.")))))
  157.     (unless (eq (gss-grid gss1) (gss-grid gss2))
  158.       (error "Arguments 1 and 2 are GSSs to the same grid!"))
  159.     (let ((select1 (gss-select gss1))
  160.       (select2 (gss-select gss2)))
  161.       (dotimes (index2 (fill-pointer select2) gss1)
  162.     (block foo
  163.       (dotimes (index1 (fill-pointer select1) (vector-push (aref select2 index2) select1))
  164.         (when (eq (aref select1 index1) (aref select2 index2))
  165.           (return-from foo nil))))))))
  166.  
  167. (defun gss-union (gss1 gss2)
  168.   "Create a new gss that is the union of gss1 and gss2."
  169.   (let ((gss1 (cond ((gss-p gss1) gss1)
  170.             ((grid-p gss1) (grid-gss gss1))
  171.             (t (error "Argument 1 is not a gss or grid.")))))
  172.     (gss-union! (make-gss (gss-grid gss1)) gss2)))
  173.  
  174.  
  175. (defun gss-intersection! (gss1 gss2)
  176.   "GSS1 is destructively modified to be the union [in terms of selected cells] of
  177.     of GSS1 and GSS2."
  178.   ;; This could be made more efficient.
  179.   (let ((gss1 (cond ((gss-p gss1) gss1)
  180.             ((grid-p gss1) (grid-gss gss1))
  181.             (t (error "Argument 1 is not a gss or grid."))))
  182.     (gss2 (cond ((gss-p gss2) gss2)
  183.             ((grid-p gss2) (grid-gss gss2))
  184.             (t (error "Argument 2 is not a gss or grid.")))))
  185.     (unless (eq (gss-grid gss1) (gss-grid gss2))
  186.       (error "Arguments 1 and 2 are GSSs to the same grid!"))
  187.     (let ((select1 (gss-select gss1))
  188.       (select2 (gss-select gss2)))
  189.       (dotimes (index2 (fill-pointer select2))
  190.     (vector-push (vector-pop select2) select1))
  191.       (setf (gss-select gss1) (delete-duplicates select1))
  192.       gss1)))
  193.  
  194. (defun gss-intersection (gss1 gss2)
  195.   "Create a new gss which is the intersection of gss1 and gss2."
  196.   (let ((gss1 (cond ((gss-p gss1) gss1)
  197.             ((grid-p gss1) (grid-gss gss1))
  198.             (t (error "Argument 1 is not a gss or grid.")))))
  199.     (gss-intersection! (make-gss (gss-grid gss1)) gss2)))
  200.  
  201. (defun grid-select (gss cell-index &optional (out-of-bounds-error t))
  202.   "Force the specified grid cell to be selected. Argument must be a GSS.
  203.     If error-out-of-bounds-p is non-nil, an out of bounds index signals an error.
  204.     Otherwise, an out of bounds index results in the null action. Returns the
  205.     cell index if activated, NIL otherwise."
  206.   (unless (gss-p gss) (error "Argument is not a gss"))
  207.   (if (< -1 cell-index (grid-cell-count (gss-grid gss)))
  208.       (vector-push cell-index (gss-select gss))
  209.       (if out-of-bounds-error (error "Cell index is out of bounds") nil)))
  210.  
  211. (defun grid-unselect (grid-or-gss &optional cell-index)
  212.   "If cell-index is specified, unselect that index from gss. Otherwise,
  213.     unselect ALL indices from gss. Returns NIL if no cell-index was supplied,
  214.     the supplied cell-index otherwise."
  215.   (let ((gss (cond ((grid-p grid-or-gss) (grid-gss grid-or-gss))
  216.            ((gss-p grid-or-gss)  grid-or-gss)
  217.            (t (error "First argument is not a grid or gss.")))))
  218.     (if cell-index
  219.     (setf (gss-select gss) (delete cell-index (gss-select gss)))
  220.     (setf (fill-pointer (gss-select gss)) 0))
  221.     cell-index))
  222.  
  223. (defun grid-cell-tss (grid cell-index)
  224.   "Returns a TSS of all the tokens in cell-index."
  225.   (let ((grid (cond ((grid-p grid) grid)
  226.             ((gss-p grid) (gss-grid grid))
  227.             (t (error "First argument is not a grid or gss.")))))
  228.     (unless (<= cell-index (grid-cell-count grid))
  229.       (error "Index out of bounds"))
  230.     (make-handle :type :token-subset
  231.          :frame (grid-%frame grid)
  232.          :token-existence-array (copy-list (aref (grid-cells grid) cell-index)))))
  233.  
  234. ;;;;;;;;;;;;;;;;;;;;;;;;;;;; Internal storage and retrieval functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  235.  
  236. (defun add-token-to-grid-cell (grid token-handle cell-index)
  237.   "INTERNAL FUNCTION. DO NOT USE THIS."
  238.   (let* ((token-index (handle-token token-handle))
  239.      (token-list (aref (grid-cells grid) cell-index))
  240.      (first-elt (car token-list)))
  241.     (cond ((not first-elt)
  242.        (setf (aref (grid-cells grid) cell-index) (cons token-index token-list)))
  243.           ((< token-index first-elt)
  244.        (setf (aref (grid-cells grid) cell-index) (cons token-index token-list)))
  245.       ((= token-index first-elt) nil)
  246.       (t (do ((lst token-list (cdr lst))
  247.           (lst+ (cdr token-list) (cdr lst+)))
  248.          ((or (null lst+)
  249.               (<= token-index (car lst+)))
  250.           (when (or (null lst+) (< token-index (car lst+)))
  251.             (rplacd lst (cons token-index lst+)))))))))
  252.  
  253. (defun remove-token-from-grid-cell (grid token-handle cell-index)
  254.   "INTERNAL FUNCTION. DO NOT USE THIS."
  255.   (let* ((token-index (handle-token token-handle))
  256.      (token-list (aref (grid-cells grid) cell-index))
  257.      (first-elt (car token-list)))
  258.     (cond ((null first-elt) nil)
  259.           ((= token-index first-elt) 
  260.        (setf (aref (grid-cells grid) cell-index) (cdr token-list)))
  261.       (t (do ((lst token-list (cdr lst))
  262.           (lst+ (cdr token-list) (cdr lst+)))
  263.          ((or (null lst+)
  264.               (<= token-index (car lst+)))
  265.           (when (= token-index (car lst+)))
  266.             (rplacd lst (cdr lst+))))))))
  267.  
  268.  
  269. (defun merge-index-lists (list1 list2)
  270.   "Destructively merge list2 into list2. 
  271.     INTERNAL FUNCTION. DO NOT USE THIS."
  272.   ;; this is highly inefficient when list2 has a lot of elements smaller than first of list1.
  273.   (when (null list1) (return-from merge-index-lists (copy-list list2)))
  274.   (when (null list2) (return-from merge-index-lists list1))
  275.   (let ((ptr nil)
  276.     (car-1 (car list1)))
  277.     (do ((lst list2 (cdr lst))
  278.      (preface nil))
  279.     ((or (null lst)
  280.          (>= (car lst) car-1))
  281.      (setf ptr (nconc (reverse preface) list1))
  282.      (if (eql car-1 (car lst))  ;;this needs to be eql because (car lst) may be nil
  283.          (setf list2 (cdr lst))
  284.          (setf list2 lst)))
  285.       (setf preface (cons (car lst) preface)))
  286.     (loop 
  287.       (let ((second-1 (cadr list1))
  288.         (first-2 (car list2)))
  289.     (cond ((null list2) (return-from merge-index-lists ptr))
  290.           ((null second-1) (return-from merge-index-lists (nconc ptr (copy-list list2))))
  291.           ((= second-1 first-2)
  292.            (setf list1 (cdr list1))
  293.            (setf list2 (cdr list2)))
  294.           ((> second-1 first-2)
  295.            (rplacd list1 (cons first-2 (cdr list1)))
  296.            (setf list2 (cdr list2)))
  297.           (t (setf list1 (cdr list1))))))))
  298.  
  299.  
  300.  
  301.  
  302.  
  303.  
  304. ;;;;;;;;;;;;;;;;;;
  305.  
  306. ;;;;  Bruce:  what is this doing here???
  307.  
  308. #+:EXPLORER
  309. (defun display-selected-cells (gss &optional (window user::*image-display*))
  310.   (declare (special user::*image-display*))
  311.   (cond ((gss-p gss) t)
  312.     ((grid-p gss) (setf gss (grid-gss gss)))
  313.     (t (error "Argument must be a grid or gss.")))
  314.   (let ((grid (gss-grid gss)))
  315.     (map nil #'(lambda (cell-no)
  316.          (multiple-value-bind (row-cell col-cell)
  317.              (floor cell-no (grid-row-cell-count grid))
  318.            (send window :display-line (* col-cell (grid-col-size grid))
  319.                                   (* row-cell (grid-row-size grid))
  320.                           (* col-cell (grid-col-size grid))
  321.                           (* (1+ row-cell) (grid-row-size grid)))
  322.            (send window :display-line (* col-cell (grid-col-size grid))
  323.                                   (* row-cell (grid-row-size grid))
  324.                           (* (1+ col-cell) (grid-col-size grid))
  325.                           (* row-cell (grid-row-size grid)))
  326.            (send window :display-line (* (1+ col-cell) (grid-col-size grid))
  327.                                   (* row-cell (grid-row-size grid))
  328.                           (* (1+ col-cell) (grid-col-size grid))
  329.                           (* (1+ row-cell) (grid-row-size grid)))
  330.            (send window :display-line (* col-cell (grid-col-size grid))
  331.                                   (* (1+ row-cell) (grid-row-size grid))
  332.                           (* (1+ col-cell) (grid-col-size grid))
  333.                           (* (1+ row-cell) (grid-row-size grid)))))
  334.      (gss-select gss))))
  335.