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
/
rasterize.lisp
< prev
Wrap
Lisp/Scheme
|
1995-07-04
|
7KB
|
178 lines
;;; -*- Mode:Common-Lisp; Package:ISR2; Base:10 -*-
;;;
;;; 7/4/95 - Bob Collins
;;; Fixed bugs in rasterize-line and rasterize-polygon which were
;;; causing problems when grid-row-min and grid-col-min were nonzero
;;;
(in-package "ISR2")
;;;;;;;;;;; Points
(defun cell-index (grid row col)
(cond ((gss-p grid) (setf grid (gss-grid grid)))
((grid-p grid) t)
(t (error "Argument is neither a grid nor a gss.")))
(+ (* (floor (- row (grid-row-min grid)) (grid-row-size grid))
(grid-row-cell-count grid))
(floor (- col (grid-col-min grid)) (grid-col-size grid))))
(defun rasterize-point (gss row col &optional (initialize t))
(let (grid)
(cond ((gss-p gss) (setf grid (gss-grid gss)))
((grid-p gss) (setf grid gss)
(setf gss (grid-gss gss)))
(t (error "Argument is neither a grid nor a gss.")))
(when initialize (grid-unselect gss))
(grid-select gss (cell-index grid row col))
gss))
;;;;;;;;;;;;;; Lines
(defun rasterize-line (gss row1 col1 row2 col2 &optional (initialize t) (out-of-bounds-error nil))
(let (grid)
(cond ((gss-p gss) (setf grid (gss-grid gss)))
((grid-p gss) (setf grid gss)
(setf gss (grid-gss gss)))
(t (error "Argument is neither a grid nor a gss.")))
(when initialize (grid-unselect gss))
(multiple-value-bind (rowA colA rowB colB)
(if (> col1 col2)
(values row2 col2 row1 col1)
(values row1 col1 row2 col2))
(let* ((rowA-cell (floor (- rowA (grid-row-min grid)) (grid-row-size grid)))
(rowB-cell (floor (- rowB (grid-row-min grid)) (grid-row-size grid)))
(colA-cell (floor (- colA (grid-col-min grid)) (grid-col-size grid)))
(colB-cell (floor (- colB (grid-col-min grid)) (grid-col-size grid))))
(cond ((= rowA-cell rowB-cell)
(let ((start-cell (+ colA-cell (* rowA-cell (grid-row-cell-count grid)))))
(dotimes (ctr (1+ (- colB-cell colA-cell)))
(grid-select gss (+ start-cell ctr) out-of-bounds-error))))
((= colA-cell colB-cell)
(let ((row-max-cell (max rowA-cell rowB-cell))
(row-min-cell (min rowA-cell rowB-cell)))
(dotimes (ctr (1+ (- row-max-cell row-min-cell)))
(grid-select gss (+ colA-cell (* (grid-row-cell-count grid) (+ row-min-cell ctr)))
out-of-bounds-error))))
((< rowB rowA) ;; AB is 1st quad. vector.
(let ((rowD (- rowB rowA))
(colD (- colB colA))
(row-point (- (+ (* rowA-cell (grid-row-size grid))
(grid-row-min grid))
rowA))
(col-point (- (+ (* (1+ colA-cell) (grid-col-size grid))
(grid-col-min grid))
colA))
rowDcolP colDrowP)
(loop
(grid-select gss (+ colA-cell (* rowA-cell (grid-row-cell-count grid))) out-of-bounds-error)
(when (and (= colA-cell colB-cell) (= rowA-cell rowB-cell))
(return-from rasterize-line))
(setf rowDcolP (* rowD col-point)
colDrowP (* colD row-point))
(cond ((= rowDcolP colDrowP) ;;zero cross-product
(incf colA-cell)
(incf col-point (grid-col-size grid))
(decf rowA-cell)
(decf row-point (grid-row-size grid)))
((> rowDcolP colDrowP) ;; positive cross-product
(incf colA-cell)
(incf col-point (grid-col-size grid)))
(t (decf rowA-cell)
(decf row-point (grid-row-size grid)))))))
(t ;; AB is 4th quad vector
(let ((rowD (- rowB rowA))
(colD (- colB colA))
(row-point (- (+ (* (1+ rowA-cell) (grid-row-size grid))
(grid-row-min grid))
rowA))
(col-point (- (+ (* (1+ colA-cell) (grid-col-size grid))
(grid-col-min grid))
colA))
rowDcolP colDrowP)
(loop
(grid-select gss (+ colA-cell (* rowA-cell (grid-row-cell-count grid))) out-of-bounds-error)
(when (and (= colA-cell colB-cell) (= rowA-cell rowB-cell))
(return-from rasterize-line))
(setf rowDcolP (* rowD col-point)
colDrowP (* colD row-point))
(cond ((= rowDcolP colDrowP) ;;zero cross-product
(incf colA-cell)
(incf col-point (grid-col-size grid))
(incf rowA-cell)
(incf row-point (grid-row-size grid)))
((> rowDcolP colDrowP) ;; positive cross-product
(incf rowA-cell)
(incf row-point (grid-row-size grid)))
(t (incf colA-cell) ;; negative cross-product
(incf col-point (grid-col-size grid))))))))))))
;;;;;;;;;;;;;;;;;;;;
(defun rasterize-pixelmap (grid-or-gss pixelmap &optional (initialize t) (error-out-of-bounds-p nil))
(multiple-value-bind (grid gss)
(cond ((grid-p grid-or-gss) (values grid-or-gss (grid-gss grid-or-gss)))
((gss-p grid-or-gss) (values (gss-grid grid-or-gss) grid-or-gss))
(t (error "Argument is neither a grid nor a gss.")))
(when initialize (grid-unselect gss))
(let* ((extents (pixelmap-extents pixelmap))
(min-row-cell (floor (max 0 (- (extents-miny extents) (grid-row-min grid))) (grid-row-size grid)))
(max-row-cell (floor (max 0 (- (extents-maxy extents) (grid-row-min grid))) (grid-row-size grid)))
(min-col-cell (floor (max 0 (- (extents-minx extents) (grid-col-min grid))) (grid-col-size grid)))
(max-col-cell (floor (max 0 (- (extents-maxx extents) (grid-col-min grid))) (grid-col-size grid))))
(do ((row-cell min-row-cell (1+ row-cell)))
((> row-cell max-row-cell) gss)
(do ((col-cell min-col-cell (1+ col-cell)))
((> col-cell max-col-cell))
(when (grid-cell-in-pixelmap-p row-cell col-cell grid pixelmap)
(grid-select gss (+ col-cell (* row-cell (grid-row-cell-count grid)))
error-out-of-bounds-p )))))))
(defun grid-cell-in-pixelmap-p (row-cell col-cell grid pixelmap)
(let ((max-col (1- (+ (grid-col-min grid) (* (1+ col-cell) (grid-col-size grid)))))
(max-row (1- (+ (grid-row-min grid) (* (1+ row-cell) (grid-row-size grid))))))
(do ((col (+ (grid-col-min grid) (* col-cell (grid-col-size grid))) (1+ col)))
((> col max-col))
(do ((row (+ (grid-row-min grid) (* row-cell (grid-row-size grid))) (1+ row)))
((> row max-row))
(when (pix-aref row col pixelmap)
(return-from grid-cell-in-pixelmap-p t))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun rasterize-polygon (grid-or-gss edge-list &optional (initialize t) (error-out-of-bounds-p nil))
(multiple-value-bind (grid gss)
(cond ((grid-p grid-or-gss) (values grid-or-gss (grid-gss grid-or-gss)))
((gss-p grid-or-gss) (values (gss-grid grid-or-gss) grid-or-gss))
(t (error "Argument is neither a grid nor a gss.")))
(when initialize (grid-unselect gss))
(let ((adjusted-list nil) (pixelmap nil))
(dolist (pt edge-list)
(push (list (/ (- (car pt) (grid-row-min grid)) (grid-row-size grid))
(/ (- (cadr pt) (grid-col-min grid)) (grid-col-size grid)))
adjusted-list))
(setf pixelmap (apply #'specify-pixelmap adjusted-list))
(let ((1-grid-min-row -1)
(1-grid-min-col -1)
(grid-max-row (ceiling (- (grid-row-max grid) (grid-row-min grid))
(grid-row-size grid)))
(grid-max-col (ceiling (- (grid-col-max grid) (grid-col-min grid))
(grid-col-size grid))))
(for-each-pixel pixelmap
(cond ((and (= 1 user::$PIXEL$)
(< 1-grid-min-row user::$ROW$ grid-max-row)
(< 1-grid-min-col user::$COL$ grid-max-col))
(grid-select gss
(+ user::$COL$ (* user::$ROW$ (grid-row-cell-count grid)))
error-out-of-bounds-p))
((and (= 1 user::$PIXEL$)
error-out-of-bounds-p )
(error "Polygon out of bounds: ~D ~D" user::$ROW$ user::$COL$))
(t nil)))))))