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 / new-rasterize.lisp < prev    next >
Lisp/Scheme  |  1995-07-04  |  8KB  |  181 lines
  1. ;;; -*- Mode:Common-Lisp; Package:ISR2;  Base:10 -*-
  2. ;;;
  3. ;;; 7/4/95  - Bob Collins
  4. ;;;  Fixed a bug in rasterize line which was causing problems when
  5. ;;;  grid-row-min and grid-col-min were nonzero
  6. ;;;
  7.  
  8. (in-package "ISR2")
  9.  
  10. ;;;;;;;;;;; Points
  11.  
  12. (defun cell-index (grid row col)
  13.   (cond ((gss-p grid) (setf grid (gss-grid grid)))
  14.     ((grid-p grid) t)
  15.     (t (error "Argument is neither a grid nor a gss.")))
  16.   (+ (* (floor (- row (grid-row-min grid)) (grid-row-size grid))
  17.     (grid-row-cell-count grid))
  18.      (floor (- col (grid-col-min grid)) (grid-col-size grid))))
  19.  
  20.  
  21. (defun rasterize-point (gss row col &optional (initialize t))
  22.   (let (grid)
  23.     (cond ((gss-p gss) (setf grid (gss-grid gss)))
  24.       ((grid-p gss) (setf grid gss)
  25.             (setf gss (grid-gss gss)))
  26.       (t (error "Argument is neither a grid nor a gss.")))
  27.     (when initialize (grid-unselect gss))
  28.     (grid-select gss (cell-index grid row col))
  29.     gss))
  30.  
  31.  
  32. ;;;;;;;;;;;;;; Lines
  33.  
  34. (defun rasterize-line (gss row1 col1 row2 col2 &optional (initialize t) (out-of-bounds-error nil))
  35.   (let (grid)
  36.     (cond ((gss-p gss) (setf grid (gss-grid gss)))
  37.       ((grid-p gss) (setf grid gss)
  38.             (setf gss (grid-gss gss)))
  39.       (t (error "Argument is neither a grid nor a gss.")))
  40.     (when initialize (grid-unselect gss))
  41.     (multiple-value-bind (rowA colA rowB colB)
  42.     (if (> col1 col2) 
  43.         (values row2 col2 row1 col1)
  44.         (values row1 col1 row2 col2))
  45.       (let* ((rowA-cell (floor (- rowA (grid-row-min grid)) (grid-row-size grid)))
  46.          (rowB-cell (floor (- rowB (grid-row-min grid)) (grid-row-size grid)))
  47.          (colA-cell (floor (- colA (grid-col-min grid)) (grid-col-size grid)))
  48.          (colB-cell (floor (- colB (grid-col-min grid)) (grid-col-size grid))))
  49.     (cond ((= rowA-cell rowB-cell)
  50.            (let ((start-cell (+ colA-cell (* rowA-cell (grid-row-cell-count grid)))))
  51.          (dotimes (ctr (1+ (- colB-cell colA-cell)))
  52.            (grid-select gss (+ start-cell ctr) out-of-bounds-error))))
  53.           ((= colA-cell colB-cell)
  54.            (let ((row-max-cell (max rowA-cell rowB-cell))
  55.              (row-min-cell (min rowA-cell rowB-cell)))
  56.          (dotimes (ctr (1+ (- row-max-cell row-min-cell)))
  57.            (grid-select gss (+ colA-cell (* (grid-row-cell-count grid) (+ row-min-cell ctr))) 
  58.                 out-of-bounds-error))))
  59.           ((< rowB rowA)     ;; AB is 1st quad. vector.
  60.            (let ((rowD (- rowB rowA))
  61.              (colD (- colB colA))
  62.              (row-point (- (+ (* rowA-cell (grid-row-size grid))
  63.                       (grid-row-min grid))
  64.                    rowA))
  65.              (col-point (- (+ (* (1+ colA-cell) (grid-col-size grid))
  66.                       (grid-col-min grid))
  67.                    colA))
  68.              rowDcolP colDrowP)
  69.          (loop
  70.            (grid-select gss (+ colA-cell (* rowA-cell (grid-row-cell-count grid))) out-of-bounds-error)
  71.            (when (and (= colA-cell colB-cell) (= rowA-cell rowB-cell))
  72.              (return-from rasterize-line))
  73.            (setf rowDcolP (* rowD col-point)
  74.              colDrowP (* colD row-point))
  75.            (cond ((= rowDcolP colDrowP)    ;;zero cross-product
  76.               (incf colA-cell)
  77.               (incf col-point (grid-col-size grid))
  78.               (decf rowA-cell)
  79.               (decf row-point (grid-row-size grid)))
  80.              ((> rowDcolP colDrowP)    ;; positive cross-product
  81.               (incf colA-cell)
  82.               (incf col-point (grid-col-size grid)))
  83.              (t (decf rowA-cell)
  84.                 (decf row-point (grid-row-size grid)))))))
  85.           (t                ;; AB is 4th quad vector
  86.            (let ((rowD (- rowB rowA))
  87.              (colD (- colB colA))
  88.              (row-point (- (+ (* (1+ rowA-cell) (grid-row-size grid))
  89.                       (grid-row-min grid))
  90.                    rowA))
  91.              (col-point (- (+ (* (1+ colA-cell) (grid-col-size grid))
  92.                       (grid-col-min grid))
  93.                    colA))
  94.              rowDcolP colDrowP)
  95.          (loop
  96.            (grid-select gss (+ colA-cell (* rowA-cell (grid-row-cell-count grid))) out-of-bounds-error)
  97.            (when (and (= colA-cell colB-cell) (= rowA-cell rowB-cell))
  98.              (return-from rasterize-line))
  99.            (setf rowDcolP (* rowD col-point)
  100.              colDrowP (* colD row-point))
  101.            (cond ((= rowDcolP colDrowP)    ;;zero cross-product
  102.               (incf colA-cell)
  103.               (incf col-point (grid-col-size grid))
  104.               (incf rowA-cell)
  105.               (incf row-point (grid-row-size grid)))
  106.              ((> rowDcolP colDrowP)    ;; positive cross-product
  107.               (incf rowA-cell)
  108.               (incf row-point (grid-row-size grid)))
  109.              (t (incf colA-cell)       ;; negative cross-product
  110.                 (incf col-point (grid-col-size grid))))))))))))
  111.  
  112.  
  113.  
  114.  
  115. ;;;;;;;;;;;;;;;;;;;;
  116.  
  117. (defun rasterize-pixelmap (grid-or-gss pixelmap &optional (initialize t) (error-out-of-bounds-p nil))
  118.   (multiple-value-bind (grid gss)
  119.       (cond ((grid-p grid-or-gss) (values grid-or-gss (grid-gss grid-or-gss)))
  120.         ((gss-p grid-or-gss) (values (gss-grid grid-or-gss) grid-or-gss))
  121.         (t (error "Argument is neither a grid nor a gss.")))
  122.     (when initialize (grid-unselect gss))
  123.     (let* ((extents (pixelmap-extents pixelmap))
  124.        (min-row-cell (floor (max 0 (- (extents-miny extents) (grid-row-min grid))) (grid-row-size grid)))
  125.        (max-row-cell (floor (max 0 (- (extents-maxy extents) (grid-row-min grid))) (grid-row-size grid)))
  126.        (min-col-cell (floor (max 0 (- (extents-minx extents) (grid-col-min grid))) (grid-col-size grid)))
  127.        (max-col-cell (floor (max 0 (- (extents-maxx extents) (grid-col-min grid))) (grid-col-size grid))))
  128.       (do ((row-cell min-row-cell (1+ row-cell)))
  129.       ((> row-cell max-row-cell) gss)
  130.     (do ((col-cell min-col-cell (1+ col-cell)))
  131.         ((> col-cell max-col-cell))
  132.       (when (grid-cell-in-pixelmap-p row-cell col-cell grid pixelmap)
  133.         (grid-select gss (+ col-cell (* row-cell (grid-row-cell-count grid))) 
  134.              error-out-of-bounds-p ))))))) 
  135.  
  136. (defun grid-cell-in-pixelmap-p (row-cell col-cell grid pixelmap)
  137.   (let ((max-col (1- (+ (grid-col-min grid) (* (1+ col-cell) (grid-col-size grid)))))
  138.     (max-row (1- (+ (grid-row-min grid) (* (1+ row-cell) (grid-row-size grid))))))
  139.     (do ((col (+ (grid-col-min grid) (* col-cell (grid-col-size grid))) (1+ col)))
  140.     ((> col max-col))
  141.       (do ((row (+ (grid-row-min grid) (* row-cell (grid-row-size grid))) (1+ row)))
  142.       ((> row max-row))
  143.     (when (pix-aref row col pixelmap)
  144.       (return-from grid-cell-in-pixelmap-p t))))))
  145.  
  146.  
  147. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  148.  
  149. (defun rasterize-polygon (grid-or-gss edge-list &optional (initialize t) (error-out-of-bounds-p nil))
  150.   (multiple-value-bind (grid gss)
  151.       (cond ((grid-p grid-or-gss) (values grid-or-gss (grid-gss grid-or-gss)))
  152.         ((gss-p grid-or-gss) (values (gss-grid grid-or-gss) grid-or-gss))
  153.         (t (error "Argument is neither a grid nor a gss.")))
  154.     (when initialize (grid-unselect gss))
  155.     (let ((adjusted-list nil) (pixelmap nil))
  156.       (dolist (pt edge-list)
  157.     (push (list (/ (- (car pt) (grid-row-min grid)) (grid-row-size grid))
  158.             (/ (- (cadr pt) (grid-col-min grid)) (grid-col-size grid)))
  159.           adjusted-list))
  160.       (setf pixelmap (apply #'specify-pixelmap adjusted-list))
  161.       (let ((1-grid-min-row -1)
  162.         (1-grid-min-col -1)
  163.         (grid-max-row (ceiling (- (grid-row-max grid) (grid-row-min grid))
  164.                    (grid-row-size grid)))
  165.         (grid-max-col (ceiling (- (grid-col-max grid) (grid-col-min grid))
  166.                    (grid-col-size grid))))
  167.     (print (list "row" 1-grid-min-row grid-max-row ))
  168.     (print (list "col" 1-grid-min-col grid-max-col))
  169.     (for-each-pixel pixelmap
  170.           (print (list user::$pixel$ user::$row$ user::$col$))
  171.       (cond ((and (= 1 user::$PIXEL$)
  172.               (< 1-grid-min-row user::$ROW$ grid-max-row)
  173.               (< 1-grid-min-col user::$COL$ grid-max-col))
  174.            (grid-select gss 
  175.                 (+ user::$COL$ (* user::$ROW$ (grid-row-cell-count grid))) 
  176.                 error-out-of-bounds-p))
  177.         ((and (= 1 user::$PIXEL$)
  178.               error-out-of-bounds-p )
  179.            (error "Polygon out of bounds: ~D ~D" user::$ROW$ user::$COL$))
  180.         (t nil)))))))
  181.