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 / isr2pixels.lisp < prev    next >
Text File  |  1995-04-11  |  7KB  |  176 lines
  1. ;;;; -*- Mode:Common-Lisp; Package:ISR2;  Base:10 -*-
  2. ;;;
  3. ;;; ISRPIXELS.LISP - low level pixel twiddling
  4. ;;; author:  Bruce Draper
  5. ;;; revisions:  John Brolio, Bob Collins
  6. ;;; Copyright 1987 by University of Massachusetts
  7. ;;; revised 7/31/88 for ISR2 by Bruce Draper
  8.  
  9. (in-package "ISR2")
  10.  
  11. ;;(provide 'new-isr2-pixel-stuff)
  12.  
  13. (defmacro for-each-pixel (pixelmap &body body)
  14.  " Applies BODY for each pixel in the bitplane, with the
  15.  following variables set
  16.     USER::$PIXEL$ - 1 if pixel is set, 0 if it is off
  17.     USER::$ROW$ - the current row
  18.     USER::$COL$ - the current col"
  19.   (let ((bp (gensym))
  20.     (ext (gensym))
  21.     (y-index (gensym))
  22.     (x-index (gensym))
  23.     (minx (gensym))
  24.     (maxx (gensym))
  25.     (maxy (gensym))
  26.     (x-offset (gensym)))
  27.     `(let* ((,bp (pixelmap-bitplane ,pixelmap))
  28.         (,ext (pixelmap-extents ,pixelmap))
  29.         (,maxx (extents-maxx ,ext))
  30.         (,minx (extents-minx ,ext))
  31.         (,maxy (extents-maxy ,ext))
  32.         (,x-offset (- ,minx (extents-byte-bound ,ext))))
  33.        (do ((USER::$ROW$ (extents-miny ,ext) (1+ USER::$ROW$))
  34.         (,y-index 0 (1+ ,y-index)))
  35.        ((> USER::$ROW$ ,maxy) nil)
  36.        (declare (special USER::$ROW$))
  37.      (do ((USER::$COL$ ,minx (1+ USER::$COL$))
  38.           (,x-index ,x-offset (1+ ,x-index)))
  39.          ((> USER::$COL$ ,maxx) nil)
  40.          (declare (special USER::$COL$))
  41.        (let ((USER::$PIXEL$ (aref ,bp ,y-index ,x-index)))
  42.         (declare (special USER::$PIXEL$))
  43.          ,@body))))))
  44.  
  45. (defmacro for-every-image-pixel ((pixelmap &rest var-image-pairs) &body body)
  46.  " Applies BODY for each pixel in the bitplane, with the
  47.  following variables set
  48.     USER::$VALUE$ - 1 if pixel is set, 0 if it is off
  49.     USER::$ROW$ - the current row
  50.     USER::$COL$ - the current col"
  51.   (let ((bp (gensym))
  52.     (ext (gensym))
  53.     (y-index (gensym))
  54.     (x-index (gensym))
  55.     (minx (gensym))
  56.     (maxx (gensym))
  57.     (maxy (gensym))
  58.     (x-offset (gensym))
  59.     (setf-expressions nil))
  60.     `(let* ((,bp (pixelmap-bitplane ,pixelmap))
  61.         (,ext (pixelmap-extents ,pixelmap))
  62.         (,maxx (extents-maxx ,ext))
  63.         (,minx (extents-minx ,ext))
  64.         (,maxy (extents-maxy ,ext))
  65.         (,x-offset (- ,minx (extents-byte-bound ,ext)))
  66.         ,@(mapcar #'car var-image-pairs)
  67.         )
  68.        (do ((USER::$ROW$ (extents-miny ,ext) (1+ USER::$ROW$))
  69.         (,y-index 0 (1+ ,y-index)))
  70.        ((> USER::$ROW$ ,maxy) nil)
  71.        (declare (special USER::$ROW$))
  72.      (do ((USER::$COL$ ,minx (1+ USER::$COL$))
  73.           (,x-index ,x-offset (1+ ,x-index)))
  74.          ((> USER::$COL$ ,maxx) nil)
  75.          (declare (special USER::$COL$))
  76.        (when (= 1 (aref ,bp ,y-index ,x-index))
  77.          ,@(dolist (pair var-image-pairs setf-expressions)
  78.         (push `(setf ,(car pair) (aref ,(cadr pair) USER::$ROW$ USER::$COL$ ))
  79.               setf-expressions))
  80.          ,@body))))))
  81.  
  82. (defmacro for-every-image-pixel* ((pixelmap &rest var-image-pairs) &body body)
  83.  " Applies BODY for each pixel in the bitplane, with the
  84.  following variables set
  85.     USER::$PIX$ - the current value of the pixelmap (1 or 0)
  86.     USER::$ROW$ - the current row
  87.     USER::$COL$ - the current col
  88.     USER::Y-INDEX - the current row index into the bitplane
  89.     USER::X-INDEX - the current col index into the bitplane"
  90.   (let ((bp (gensym))
  91.     (ext (gensym))
  92.     (minx (gensym))
  93.     (maxx (gensym))
  94.     (maxy (gensym))
  95.     (x-offset (gensym))
  96.     (setf-expressions nil))
  97.     `(let* ((,bp (pixelmap-bitplane ,pixelmap))
  98.         (,ext (pixelmap-extents ,pixelmap))
  99.         (,maxx (extents-maxx ,ext))
  100.         (,minx (extents-minx ,ext))
  101.         (,maxy (extents-maxy ,ext))
  102.         (,x-offset (- ,minx (extents-byte-bound ,ext)))
  103.         ,@(mapcar #'car var-image-pairs)
  104.         (USER::$PIX$ 0)
  105.         )
  106.        (declare (special USER::$PIX$))
  107.        (do ((USER::$ROW$ (extents-miny ,ext) (1+ USER::$ROW$))
  108.         (USER::Y-INDEX 0 (1+ USER::Y-INDEX)))
  109.        ((> USER::$ROW$ ,maxy) nil)
  110.        (declare (special USER::$ROW$ USER::Y-INDEX))
  111.      (do ((USER::$COL$ ,minx (1+ USER::$COL$))
  112.           (USER::X-INDEX ,x-offset (1+ USER::X-INDEX)))
  113.          ((> USER::$COL$ ,maxx) nil)
  114.          (declare (special USER::$COL$ USER::X-INDEX))
  115.        (setf USER::$PIX$ (aref ,bp USER::Y-INDEX USER::X-INDEX))
  116.        ,@(dolist (pair var-image-pairs setf-expressions)
  117.            (push `(setf ,(car pair) (aref ,(cadr pair) USER::$ROW$ USER::$COL$ ))
  118.              setf-expressions))
  119.          ,@body)))))
  120.  
  121.  
  122.  
  123. (defun read-label-plane (plane-array frame)
  124.   "Read a label-plane into a set of ISR tokens. For each label in the
  125.     label plane, a token with a matching index is created."
  126.   (unless (path? frame) 
  127.     (create frame)
  128.     (define-feature `(,frame "<?>" extents) "Extents box to Region" :extents)
  129.     (define-feature `(,frame "<?>" bitplane) "Bitplane of Region" :bitplane)
  130.     (define-pixelmap-feature `(,frame "<?>" pixelmap) ""))
  131.   (let ((extents-array (label-plane-extents plane-array)))
  132.     (dotimes (ctr (length extents-array) frame)
  133.       (unless (< (extents-maxx (aref extents-array ctr))
  134.          (extents-minx (aref extents-array ctr)))
  135.     (let* ((bitplane (make-bitplane (aref extents-array ctr)))
  136.            (pixelmap (make-pixelmap :bitplane bitplane :extents (aref extents-array ctr))))
  137.       (for-every-image-pixel* (pixelmap (image-pixel plane-array))
  138.         (if (= ctr (aref plane-array USER::$ROW$ USER::$COL$))
  139.         (setf (aref bitplane USER::Y-INDEX USER::X-INDEX) 1) 
  140.         (setf (aref bitplane USER::Y-INDEX USER::X-INDEX) 0)))
  141.       (unless (path? `(,frame ,ctr)) (create `(,frame ,ctr)))
  142.       (setf (value `(,frame ,ctr extents)) (aref extents-array ctr))
  143.       (setf (value `(,frame ,ctr bitplane)) bitplane))))))
  144.  
  145. (defun label-plane-extents (plane-array)
  146.   (let ((max-label (1+ (max-label plane-array)))
  147.     (plane-row-size (array-dimension plane-array 0))
  148.     (plane-col-size (array-dimension plane-array 1)))
  149.     (let ((minrow (make-array max-label :initial-element plane-row-size))
  150.       (mincol (make-array max-label :initial-element plane-col-size))
  151.       (maxrow (make-array max-label :initial-element 0))
  152.       (maxcol (make-array max-label :initial-element 0)))
  153.       (dotimes (row plane-row-size)
  154.     (dotimes (col plane-col-size)
  155.       (let ((val (aref plane-array row col)))
  156.         (when (> row (aref maxrow val)) (setf (aref maxrow val) row))
  157.         (when (< row (aref minrow val)) (setf (aref minrow val) row))
  158.         (when (> col (aref maxcol val)) (setf (aref maxcol val) col))
  159.         (when (< col (aref mincol val)) (setf (aref mincol val) col)))))
  160.       (dotimes (ctr max-label minrow)
  161.     (setf (aref minrow ctr) 
  162.           (make-pixelmap-extents (aref mincol ctr) (aref minrow ctr)
  163.                      (aref maxcol ctr) (aref maxrow ctr)))))))
  164.  
  165. (defun max-label (plane-array)
  166.   (let ((max-label 0)
  167.     (plane-row-size (array-dimension plane-array 0))
  168.     (plane-col-size (array-dimension plane-array 1)))
  169.     (dotimes (row plane-row-size max-label)
  170.       (dotimes (col plane-col-size)
  171.     (when (> (aref plane-array row col) max-label)
  172.       (setf max-label (aref plane-array row col)))))))
  173.  
  174.  
  175.  
  176.