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 / isr2specifypixelmap.lisp < prev    next >
Lisp/Scheme  |  1995-04-11  |  12KB  |  277 lines
  1. ;;; -*- Mode:Common-Lisp; Package:ISR2;  Base:10 -*-
  2. ;;;
  3. ;;; ISR2SPECIFYBITPLANE.LISP - make a bitplane from a specified geometric shape
  4. ;;; author: Bob Collins
  5. ;;; Copyright 1988 by University of Massachusetts
  6. ;;; 
  7. ;;; Modifications
  8.  
  9.  
  10. (in-package "ISR2")
  11.  
  12.  
  13. (defvar *bits-table*
  14.    (make-array 256 :element-type '(unsigned-byte 4) :initial-contents
  15.      '( 0  1  1  2  1  2  2  3  1  2  2  3  2  3  3  4   ;/* 00 - 0F */
  16.         1  2  2  3  2  3  3  4  2  3  3  4  3  4  4  5   ;/* 10 - 1F */
  17.     1  2  2  3  2  3  3  4  2  3  3  4  3  4  4  5   ;/* 20 - 2F */
  18.     2  3  3  4  3  4  4  5  3  4  4  5  4  5  5  6   ;/* 30 - 3F */
  19.     1  2  2  3  2  3  3  4  2  3  3  4  3  4  4  5   ;/* 40 - 4F */
  20.     2  3  3  4  3  4  4  5  3  4  4  5  4  5  5  6   ;/* 50 - 5F */
  21.     2  3  3  4  3  4  4  5  3  4  4  5  4  5  5  6   ;/* 60 - 6F */
  22.     3  4  4  5  4  5  5  6  4  5  5  6  5  6  6  7   ;/* 70 - 7F */
  23.     1  2  2  3  2  3  3  4  2  3  3  4  3  4  4  5   ;/* 80 - 8F */
  24.     2  3  3  4  3  4  4  5  3  4  4  5  4  5  5  6   ;/* 90 - 9F */
  25.     2  3  3  4  3  4  4  5  3  4  4  5  4  5  5  6   ;/* A0 - AF */
  26.     3  4  4  5  4  5  5  6  4  5  5  6  5  6  6  7   ;/* B0 - BF */
  27.     2  3  3  4  3  4  4  5  3  4  4  5  4  5  5  6   ;/* C0 - CF */
  28.     3  4  4  5  4  5  5  6  4  5  5  6  5  6  6  7   ;/* D0 - DF */
  29.     3  4  4  5  4  5  5  6  4  5  5  6  5  6  6  7   ;/* E0 - EF */
  30.     4  5  5  6  5  6  6  7  5  6  6  7  6  7  7  8   ;/* F0 - FF */
  31.     ))
  32.   "This is a lookup table which tells how many bits are set in the binary representation of a given byte."
  33.   )
  34.  
  35. (defun specify-pixelmap (&rest row-col-points)
  36.   (declare (optimize (speed 3) (safety 0)))
  37.   (let* ((col-row-point-list (mapcar #'(lambda (pair)
  38.                      (list (cadr pair) (car pair)))
  39.                      row-col-points))
  40.      (extents-and-bitplane (specify-bitplane col-row-point-list)))
  41.     (make-pixelmap :extents (car extents-and-bitplane) :bitplane (cadr extents-and-bitplane)))) 
  42.  
  43. (defun specify-bitplane (point-list)
  44.   "  POINT-LIST is a list of vertex points defining a walk around the edges of
  45.   a polygon.  Points are given in the form (col row) in the screen coordinate 
  46.   system, that is, point (col=0,row=0) is in the upper left hand corner of the
  47.   image.  A bitplane and extents structure are created to represent the given 
  48.   geometric object. A list containing the extents structure and the bitplane array
  49.   is returned.
  50.   SPECIAL CASES: If only two points are given, a line is drawn.  If just one point
  51.   is specified, a single pixel is turned on."
  52.   (unless point-list (error "null point-list argument passed to specify-bitplane"))
  53.   (multiple-value-bind (minx miny maxx maxy) (find-extents point-list)
  54.     (let* ((extents (make-extents 0 minx miny maxx maxy))
  55.        (bitplane (make-bitplane-array (* 8 (byte-width-of extents))
  56.                       (1+ (- maxy miny -1)))))
  57.       (bitmap-polygon-w-extents bitplane 1 point-list minx miny maxx maxy
  58.                 :x-offset (byte-bound-of extents) :y-offset miny)
  59.       (setf (extents-pixel-count extents)
  60.         (count-bitplane-pixels bitplane))
  61.       (list extents bitplane))))
  62.  
  63. #-(or :ALLEGRO :lispworks)
  64. (defun count-bitplane-pixels (bitplane)
  65.   "Count the number of set pixels in the given bitplane."
  66.   ;;turn the bit array into a one dimensional array of bytes then blow down
  67.   ;;the array counting bits.  This only works when the number of elements in
  68.   ;;the bitplane array is an even multiple of 8.  Since bitplane arrays are
  69.   ;;currently forced to have a width of 32 bits, this is true.
  70.   (let* ((num-bytes (/ (reduce #'* (array-dimensions bitplane)) 8))
  71.      (byte-array (make-array num-bytes :element-type '(unsigned-byte 8)
  72.                  :displaced-to bitplane))
  73.      (count 0))
  74.     (dotimes (i num-bytes count)
  75.       (incf count (aref *bits-table* (aref byte-array i))))))
  76. #+(or :ALLEGRO :lispworks)
  77. (defun count-bitplane-pixels (bitplane)
  78.   "Count the number of set pixels in the given bitplane."
  79.   (let* ((num-bits (reduce #'* (array-dimensions bitplane)))
  80.      (flat-array (make-array num-bits :element-type 'bit :displaced-to bitplane))
  81.      (count 0))
  82.     (dotimes (i num-bits count)
  83.        (incf count (aref flat-array i)))))
  84.  
  85.  
  86.  
  87. (defun find-extents (point-list)
  88.   "return 4 values, MINX, MINY, MAXX, and MAXY, in that order."
  89.   (multiple-value-bind (lowx lowy highx highy) (find-extrema point-list)
  90.     (let ((minx (floor lowx))
  91.       (miny (floor lowy)))
  92.       (values minx miny (max minx (1- (ceiling highx))) (max miny (1- (ceiling highy)))))))
  93.  
  94. (defun bitmap-polygon (array value vertex-list &key (x-offset 0)(y-offset 0))
  95.   "  Puts VALUE into cells of ARRAY which correspond to the polygon
  96.   specified by VERTEX-LIST.  VERTEX-LIST should be a list of vertex
  97.   points corresponding to a walk around the edges of the polygon.
  98.   Points are given in the screen coordinate system, that is, point (0,0)
  99.   of the screen is in the upper left hand corner.  Element (0,0) of the 
  100.   array corresponds to (X-OFFSET,Y-OFFSET) of the screen."
  101.   (multiple-value-bind (minx miny maxx maxy) (find-extents vertex-list)
  102.     (bitmap-polygon-w-extents array value vertex-list minx miny maxx maxy
  103.                   :x-offset x-offset :y-offset y-offset)))
  104.  
  105. (defun bitmap-polygon-w-extents (array value vertex-list minx miny maxx maxy &key (x-offset 0)(y-offset 0))
  106.   "  See documentation for BITMAP-POLYGON."
  107.   ;; force vertex-list to specify a counterclockwise walk around the polygon
  108.   (unless (counterclockwise-p vertex-list)
  109.     (setf vertex-list (reverse vertex-list)))
  110.   (case (length vertex-list)
  111.     ;; NOTHING AT ALL
  112.     (0 nil)
  113.     ;; A SINGLE POINT
  114.     (1 (bitmap-line array value
  115.             (car (first vertex-list)) (cadr (first vertex-list))
  116.             (car (first vertex-list)) (cadr (first vertex-list))
  117.             :x-offset x-offset :y-offset y-offset))
  118.     ;; A LINE
  119.     (2 (bitmap-line array value
  120.             (car (first vertex-list)) (cadr (first vertex-list))
  121.             (car (second vertex-list)) (cadr (second vertex-list))
  122.             :x-offset x-offset :y-offset y-offset))
  123.     ;; A POLYGON
  124.     (t (progn
  125.      ;; draw edges
  126.      (for-each-edge (vertex-list x1 y1 x2 y2)
  127.        (bitmap-line array value x1 y1 x2 y2 :x-offset x-offset :y-offset y-offset))
  128.      ;; fill in the polygon
  129.      (fill-in-polygon array value vertex-list minx miny maxx maxy 
  130.               :x-offset x-offset :y-offset y-offset))))
  131.   array)
  132.  
  133. #-:EXPLORER
  134. (eval-when (load eval compile)
  135.    (defconstant 0%-gray (make-array '(1 32) :element-type 'bit :initial-element 0))
  136.    (defconstant 100%-gray (make-array '(1 32) :element-type 'bit :initial-element 1))
  137.    )
  138.  
  139. (defun fill-in-polygon (array value vertex-list minx miny maxx maxy &key (x-offset 0)(y-offset 0))
  140.   (let ((lag (construct-lag array value
  141.                 (- miny y-offset) (- minx x-offset) 
  142.                 (- maxy y-offset) (- maxx x-offset)
  143.                 :background t))
  144.     (fill-value (case value
  145.               (0 #+:EXPLORER w::0%-gray #-:EXPLORER 0%-gray)
  146.               (1 #+:EXPLORER w::100%-gray #-:EXPLORER 100%-gray)
  147.               (t (error "VALUE argument must be either 0 or 1")))))
  148.     (clear-lag-segment-marks lag)
  149.     (for-each-unmarked-lag-segment (lag ycoord segment)
  150.       (if (point-inside-polygon-p (+ (segment-entry-startx segment) x-offset 1/10)
  151.                     (+ ycoord y-offset 1/10)
  152.                     vertex-list)
  153.       (mark-each-connected-segment
  154.         segment ycoord
  155.         :function #'(lambda (segment y) 
  156.               (bitblt #+:EXPLORER w::alu-seta #-:EXPLORER :set
  157.                   (- (segment-entry-endx segment)
  158.                      (segment-entry-startx segment) -1) 1
  159.                   fill-value 0 0
  160.                   array (segment-entry-startx segment) y)))
  161.       (mark-each-connected-segment segment ycoord)))))
  162.  
  163.  
  164. ;;(defun fill-array-row (array value row startcol endcol)
  165. ;; (do ((col startcol (1+ col)))
  166. ;;      ((> col endcol) array)
  167. ;;    (setf (aref array row col) value)))
  168.  
  169. (defun bitmap-line (array value x1 y1 x2 y2 &key (x-offset 0)(y-offset 0))
  170.   "  Puts VALUE into cells of ARRAY which correspond to the directed line 
  171.   starting at (SCREEN-X1,SCREEN-Y1) and ending at (SCREEN-X2,SCREEN-Y2).
  172.   Element (0,0) of the array corresponds to (X-OFFSET,Y-OFFSET) of the screen."
  173.   (declare (arglist array value screen-x1 screen-y1 screen-x2 screen-y2 &key (x-offset 0)(y-offset 0)))
  174.   (let ((xoff (round x-offset))
  175.     (yoff (round y-offset)))
  176.     (cond
  177.       ((or (and (> x2 x1) (>= y2 y1))   ;FIRST-QUADRANT
  178.        (and (= x2 x1) (= y2 y1)))   ;OR A SINGLE POINT
  179.          (bitmap-line-normalized
  180.        array x1 y1 x2 y2 value
  181.        (- (floor x1) xoff) (- (floor y1) yoff) 1))
  182.       ((and (<= x2 x1) (> y2 y1))       ;SECOND-QUADRANT
  183.          (bitmap-line-normalized
  184.        array y1 (- x1) y2 (- x2) value
  185.            (max 0 (- (ceiling x1) 1 xoff))
  186.            (- (floor y1) yoff) 2))
  187.       ((and (< x2 x1) (<= y2 y1))       ;THIRD-QUADRANT
  188.          (bitmap-line-normalized
  189.        array (- x1) (- y1) (- x2) (- y2) value
  190.        (max 0 (- (ceiling x1) 1 xoff)) (- (ceiling y1) 1 yoff) 3))
  191.       ((and (>= x2 x1) (< y2 y1))       ;FOURTH-QUADRANT
  192.          (bitmap-line-normalized
  193.        array (- y1) x1 (- y2) x2 value
  194.        (- (floor x1) xoff) (- (ceiling y1) 1 yoff) 4))
  195.       (t (error "how did you ever get here?")))))
  196.  
  197. (defmacro FILL-RELATIVE (direction array basecol baserow relcol relrow fill-length fill-value quadrant)
  198.   `(case ,quadrant
  199.      (1 (let ((col (max 0 (+ ,basecol ,relcol)))
  200.           (row (max 0 (+ ,baserow ,relrow))))
  201.       (dotimes (i ,fill-length)
  202.         (setf (aref ,array row col) ,fill-value)
  203.         ,(if (eq direction :row)
  204.          `(incf col)
  205.          `(incf row)))))
  206.      (2 (let ((col (max 0 (- ,basecol ,relrow)))
  207.           (row (max 0 (+ ,baserow ,relcol))))
  208.       (dotimes (i ,fill-length)
  209.         (setf (aref ,array row col) ,fill-value)
  210.         ,(if (eq direction :row)
  211.         `(incf row)
  212.         `(decf col)))))
  213.      (3 (let ((col (max 0 (- ,basecol ,relcol)))
  214.           (row (max 0 (- ,baserow ,relrow))))
  215.       (dotimes (i ,fill-length)
  216.         (setf (aref ,array row col) ,fill-value)
  217.         ,(if (eq direction :row)
  218.         `(decf col)
  219.         `(decf row)))))
  220.      (4 (let ((col (max 0 (+ ,basecol ,relrow)))
  221.           (row (max 0 (- ,baserow ,relcol))))
  222.       (dotimes (i ,fill-length)
  223.         (setf (aref ,array row col) ,fill-value)
  224.         ,(if (eq direction :row)
  225.         `(decf row)
  226.         `(incf col)))))
  227.      (t (error "invalid quadrant number: ~d, must be 1 2 3 or 4." ,quadrant))))
  228.  
  229. (defun bitmap-line-normalized (array x1 y1 x2 y2 value basecol baserow quadrant-number)
  230.   "  Endpoints X1, Y1, X2, Y2 describe a line in the first quadrant, starting near the origin,
  231.   that is, the condition (x2 > x1, y2 >= y1) holds. BASECOL and BASEROW specify the actual array
  232.   indices of the start of the line, and the actual quadrant of the line (1 2 3 or 4) is specified 
  233.   by QUADRANT-NUMBER.  Top level calls should be made to BITMAP-LINE rather than to this routine."
  234. ;;;;Note: BITMAP-LINE relies on this routine also working when both x1=x2 and y1=y2.
  235.   (setf basecol (max 0 basecol))
  236.   (setf baserow (max 0 baserow))
  237.   (let ((deltax (- x2 x1))
  238.     (deltay (- y2 y1))
  239.     (startcol (floor x1))
  240.     (startrow (floor y1)))
  241.     (if (>= deltax deltay)
  242.     ;;FIRST OCTANT, STEP ALONG ROWS
  243.     (let ((slope (unless (zerop deltay) (/ deltax deltay)))
  244.           (endrow (max (1+ startrow) (ceiling y2))))
  245.       (do ((row (1+ startrow) (1+ row))
  246.            (oldcol startcol (floor x))
  247.            (x 0.0))
  248.           ((> row endrow))
  249.         (setf x (if (= row endrow) x2 (+ x1 (* (- row y1) slope))))
  250.         (FILL-RELATIVE :row                            ;fill a row or a col
  251.                array basecol baserow           ;array and its base indices
  252.                (- oldcol startcol)             ;relative col
  253.                (- row startrow 1)              ;relative row
  254.                (max 1 (- (ceiling x) oldcol))  ;length of fill
  255.                value                           ;fill value to use
  256.                quadrant-number)))              ;quadrant 1,2,3,4
  257.     ;;SECOND OCTANT, STEP ALONG COLUMNS
  258.     (let ((slope (unless (zerop deltax) (/ deltay deltax)))
  259.           (endcol (max (1+ startcol) (ceiling x2))))
  260.       (do ((col (1+ startcol) (1+ col))
  261.            (oldrow startrow (floor y))
  262.            (y 0.0))
  263.           ((> col endcol))
  264.         (setf y (if (= col endcol) y2 (+ y1 (* (- col x1) slope))))
  265.         (FILL-RELATIVE  :col                            ;fill a row or a col
  266.                 array basecol baserow           ;array and its base indices
  267.                 (- col startcol 1)              ;relative col
  268.                 (- oldrow startrow)             ;relative row
  269.                 (max 1 (- (ceiling y) oldrow))  ;length of fill
  270.                 value                           ;fill value to use
  271.                 quadrant-number))               ;quadrant 1,2,3,4
  272.       array))))
  273.  
  274.  
  275.  
  276.  
  277.