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 / isr2pix.lisp < prev    next >
Lisp/Scheme  |  1995-04-11  |  19KB  |  362 lines
  1. ;;; -*- Mode:Common-Lisp; Package:ISR2;  Base:10 -*-
  2.  
  3. (in-package "ISR2")
  4.  
  5. #-:EXPLORER
  6.  
  7. (defun bitblt (alu width height from-array from-x from-y to-array to-x to-y)
  8.   "Replace the functionality of the lisp machine's bitblt function,
  9.    albeit slower. In other words, copy a rectangular portion of from-array
  10.    to to-array according to a boolean function. ALU must be one of
  11.    :set :and, :ior, :xor or :andc1"
  12.   (dotimes (w width)
  13.      (dotimes (h height)
  14.         (setf (aref to-array (+ to-y h) (+ to-x w))
  15.           (case alu
  16.          ((:set) (aref from-array (+ from-y h) (+ from-x w)))
  17.          ((:and) (and (aref to-array (+ to-y h) (+ to-x w))
  18.                   (aref from-array (+ from-y h) (+ from-x w))))
  19.          ((:ior) (or (aref to-array (+ to-y h) (+ to-x w))
  20.                  (aref from-array (+ from-y h) (+ from-x w))))
  21.          ((:xor) 
  22.                   (let ((both? (and (aref to-array (+ to-y h) (+ to-x w))
  23.                      (aref from-array (+ from-y h) (+ from-x w)))))
  24.                 (if both?
  25.                         0
  26.                 (or (aref to-array (+ to-y h) (+ to-x w))
  27.                 (aref from-array (+ from-y h) (+ from-x w))))))
  28.              ((:andc1 :andca) 
  29.               (and (aref to-array (+ to-y h) (+ to-x w))
  30.                (mod (1+ (aref from-array (+ from-y h) (+ from-x w)))
  31.                         2)))
  32.          (t (error "Unimplemented ALU function")))))))
  33.  
  34. (defun make-pixelmap-extents (minx miny maxx maxy)
  35.   (let* ((byte-bound (* 8 (floor minx 8)))
  36.      (vax-byte-width (1+ (floor (- maxx byte-bound) 8)))
  37.      #-:LUCIS (default-cons-area *bitplane-area*)
  38.      (extents (make-extents-struct :byte-bound byte-bound
  39.                       :byte-width (* (ceiling vax-byte-width 4) 4)
  40.                       :minx minx
  41.                       :miny miny
  42.                       :maxx maxx
  43.                       :maxy maxy)))
  44.     #+:EXPLORER (declare (special default-cons-area))
  45.     extents))
  46.  
  47. (defun make-bitplane (extents)
  48.   (make-array (list (- (extents-maxy extents) (extents-miny extents) -1)
  49.             (* 8 (extents-byte-width extents)))
  50.           :element-type 'bit :initial-element 0))
  51.  
  52. (defun extract-bitplane-and-extents (pixelmap)
  53.   (unless (pixelmap-p pixelmap)
  54.     (error "Object is not a pixelmap: ~A" pixelmap))
  55.   (let ((extents (pixelmap-extents pixelmap))
  56.     (bitplane (pixelmap-bitplane pixelmap)))
  57.     (cond ((and (not (extents-p extents))
  58.         (not (extents-p extents)))
  59.        (error "Pixelmap does not contain an extents: ~A" pixelmap))
  60.       ((not (arrayp extents))
  61.        (error "Pixelmap does not contain a bitplane: ~A" pixelmap))
  62.       (t (values bitplane extents)))))
  63.  
  64.  
  65. (defun bitplane-emptyp (bitplane)
  66.   (dotimes (x (array-dimension bitplane 0) t)
  67.     (dotimes (y (array-dimension bitplane 1))
  68.       (when (= 1 (aref bitplane x y))
  69.     (return-from bitplane-emptyp nil)))))
  70.  
  71. (defun bitplane-count (bitplane &aux (sum 0))
  72.   (dotimes (x (array-dimension bitplane 0) sum)
  73.     (dotimes (y (array-dimension bitplane 1))
  74.       (when (= 1 (aref bitplane x y))
  75.     (incf sum)))))
  76.  
  77. (defun pix-emptyp (pixelmap)
  78.   (cond ((not (pixelmap-p pixelmap)) 
  79.      (error "Object is not a pixelmap: ~A" pixelmap))
  80.     ((not (arrayp (pixelmap-bitplane pixelmap)))
  81.      (error "Pixelmap does not contain bitplane"))
  82.     (t (bitplane-emptyp (pixelmap-bitplane pixelmap)))))
  83.  
  84. (defun pix-count (pixelmap)
  85.   (cond ((not (pixelmap-p pixelmap)) 
  86.      (error "Object is not a pixelmap: ~A" pixelmap))
  87.     ((not (arrayp (pixelmap-bitplane pixelmap)))
  88.      (error "Pixelmap does not contain bitplane"))
  89.     (t (setf (extents-pixel-count (pixelmap-extents pixelmap))
  90.          (bitplane-count (pixelmap-bitplane pixelmap))))))
  91.  
  92. (defun pix-aref (row col pixelmap)
  93.   (when (and (<= (extents-miny (pixelmap-extents pixelmap))
  94.          row
  95.          (extents-maxy (pixelmap-extents pixelmap)))
  96.          (<= (extents-minx (pixelmap-extents pixelmap))
  97.          col
  98.          (extents-maxx (pixelmap-extents pixelmap))))
  99.     (= 1 (aref (pixelmap-bitplane pixelmap) 
  100.            (round (- row (extents-miny (pixelmap-extents pixelmap))))
  101.            (round (- col (extents-byte-bound (pixelmap-extents pixelmap))))))))
  102.  
  103. (defun set-pix-aref (row col pixelmap value)
  104.   (if (and (<= (extents-miny (pixelmap-extents pixelmap))
  105.          row
  106.          (extents-maxy (pixelmap-extents pixelmap)))
  107.          (<= (extents-minx (pixelmap-extents pixelmap))
  108.          col
  109.          (extents-maxx (pixelmap-extents pixelmap))))
  110.       (setf (aref (pixelmap-bitplane pixelmap) 
  111.            (round (- row (extents-miny (pixelmap-extents pixelmap))))
  112.            (round (- col (extents-byte-bound (pixelmap-extents pixelmap)))))
  113.         value)
  114.       (error "Row and Col specify a point outside the extents of Pixelmap")))
  115.  
  116. (defsetf pix-aref set-pix-aref)
  117.  
  118. (defun update-min-values (bitplane extents)
  119.   "This function determines whether a bitplane `fills up' an extents structure. It
  120.     checks to see if miny, minx are smaller then they ought to be, or if maxy and maxx
  121.     are bigger then they ought to be. Returns as four values delta-miny, delta-maxy,
  122.     delta-minx, delta-maxx, where delta-min's are the number to be added to the min
  123.     values and delta-max's should be subtracted from the max values."
  124.   (let ((x-dimension (array-dimension bitplane 1))
  125.     (y-dimension (array-dimension bitplane 0))
  126.     (x-start (- (extents-minx extents) (extents-byte-bound extents)))
  127.     (x-stop (- ( + (* 8 (extents-byte-width extents)) (extents-byte-bound extents))
  128.            (extents-maxx extents)))
  129.     (delta-miny 0)
  130.     (delta-maxy 0)
  131.     (delta-minx 0)
  132.     (delta-maxx 0))
  133.     (block miny
  134.       (dotimes (y y-dimension)
  135.     (dotimes (x x-dimension)
  136.       (when (= 1 (aref bitplane y x))
  137.         (return-from miny)))
  138.     (incf delta-miny)))
  139.     (block maxy
  140.       (dotimes (y y-dimension)
  141.     (dotimes (x x-dimension)
  142.       (when (= 1 (aref bitplane (- y-dimension y 1) x))
  143.         (return-from maxy)))
  144.     (incf delta-maxy)))
  145.     (block minx
  146.       (dotimes (x x-dimension)
  147.     (dotimes (y y-dimension)
  148.       (when (= 1 (aref bitplane y (+ x-start x)))
  149.         (return-from minx)))
  150.     (incf delta-minx)))
  151.     (block maxx
  152.       (dotimes (x x-dimension)
  153.     (dotimes (y y-dimension)
  154.       (when (= 1 (aref bitplane y (- x-stop x 1)))
  155.         (return-from maxx)))
  156.     (incf delta-maxx)))
  157.     (values delta-miny delta-maxy delta-minx delta-maxx)))
  158.  
  159. (defun trim-bitplane-and-extents! (bitplane extents)
  160.   "`Trims' a pixelmap if this is possible. That is, it sees if the min and max variables
  161.     in the extents structure can be tightened. If a smaller bitplane can be used, makes
  162.     a smaller bitplane to substitute for the original. If the bitplane is completely
  163.     empty return NIL. This routine is destructive to its extents argument only; it does 
  164.     not modify -- although it may replace -- the original bitplane."
  165.   (multiple-value-bind (delta-miny delta-maxy delta-minx delta-maxx)
  166.       (update-min-values bitplane extents)
  167.     (let* ((new-byte-bound (* 8 (floor (+ (extents-minx extents) delta-minx) 8)))
  168.        (new-byte-width (1+ (floor (- (- (extents-maxx extents) delta-maxx) new-byte-bound) 8))))
  169.       (unless (bitplane-emptyp bitplane)   ;; return nil if no pixels are set!
  170.     (when (or (< 0 delta-miny)
  171.           (< 0 delta-maxy)
  172.           (/= new-byte-bound (extents-byte-bound extents))
  173.           (/= new-byte-width (extents-byte-width extents)))
  174.       (let* ((new-height (- (extents-maxy extents) (extents-miny extents) -1 delta-miny delta-maxy))
  175.          (new-bitplane (make-array (list new-height (* 8 new-byte-width))
  176.                        :element-type 'bit :initial-element 0)))
  177.         (bitblt #-:EXPLORER :set #+:EXPLORER boole-1 (* 8 new-byte-width) new-height
  178.             bitplane (- (extents-byte-bound extents) new-byte-bound) delta-miny
  179.             new-bitplane 0 0)
  180.         (setf bitplane new-bitplane)
  181.         (setf (extents-miny extents) (+ (extents-miny extents) delta-miny))
  182.         (setf (extents-maxy extents) (+ (extents-maxy extents) delta-maxy))
  183.         (setf (extents-byte-bound extents) new-byte-bound)
  184.         (setf (extents-byte-width extents) new-byte-width)))
  185.     (setf (extents-minx extents) (+ (extents-minx extents) delta-minx))
  186.     (setf (extents-maxx extents) (+ (extents-maxx extents) delta-maxx))
  187.     (values bitplane extents)))))
  188.  
  189. (defun pix-union! (pixelmap1 pixelmap2)
  190.   "Returns a pixelmap containing the union of the pixels in pixelmap1 and pixelmap2.
  191.     If the extents box of pixelmap1 does not completely contain the extents box of pixelmap2,
  192.     then a new pixelmap is created and neither argument is altered. If Pixelmap1's extents box
  193.     does contain that of pixelmap2, then pixelmap1 is destructively altered."
  194.   (declare (notinline bitblt))
  195.   (let ((extents1 (pixelmap-extents pixelmap1))
  196.     (extents2 (pixelmap-extents pixelmap2)))
  197.     (if (or (> (extents-byte-bound extents1) (extents-byte-bound extents2))
  198.         (< (+ (extents-byte-bound extents1) (* 8 (extents-byte-width extents1)))
  199.            (+ (extents-byte-bound extents2) (* 8 (extents-byte-width extents2))))
  200.         (> (extents-miny extents1) (extents-miny extents2))
  201.         (< (extents-maxy extents1) (extents-maxy extents2)))
  202.     (pix-union pixelmap1 pixelmap2)
  203.     (let ((transfer-width (- (extents-maxx extents2) (extents-byte-bound extents2) -1))
  204.           (transfer-height (- (extents-maxy extents2) (extents-miny extents2) -1))
  205.           (new-x-offset (- (extents-byte-bound extents2) (extents-byte-bound extents1)))
  206.           (new-y-offset (- (extents-miny extents2) (extents-miny extents1)))
  207.           (bitplane1 (pixelmap-bitplane pixelmap1))
  208.           (bitplane2 (pixelmap-bitplane pixelmap2)))
  209.       (bitblt #-:EXPLORER :ior #+:EXPLORER boole-ior                                                              ;;; ALU
  210.           transfer-width                                                         ;;; width
  211.           transfer-height                                                        ;;; height
  212.           bitplane2                                                              ;;; source
  213.           0                                                                      ;;; from-x
  214.           0                                                                      ;;; from-y
  215.           bitplane1                                                              ;;; destination
  216.           new-x-offset                                                           ;;; to-x
  217.           new-y-offset)
  218.       pixelmap1))))
  219.  
  220. (defun pix-union (pixelmap1 pixelmap2)
  221.   "Returns a pixelmap containing the union of the pixels in pixelmap1 and pixelmap2.
  222.     Neither of the arguments are altered."
  223.   (declare (notinline bitblt))
  224.   (multiple-value-bind (bitplane1 extents1)
  225.       (extract-bitplane-and-extents pixelmap1)
  226.     (multiple-value-bind (bitplane2 extents2)
  227.     (extract-bitplane-and-extents pixelmap2)
  228.       (let* ((new-extents (make-pixelmap-extents (min (extents-minx extents1) (extents-minx extents2))
  229.                          (min (extents-miny extents1) (extents-miny extents2))
  230.                          (max (extents-maxx extents1) (extents-maxx extents2))
  231.                          (max (extents-maxy extents1) (extents-maxy extents2))))
  232.          (new-bitplane (make-bitplane new-extents)))
  233.     (let ((transfer-width (- (extents-maxx extents1) (extents-byte-bound extents1) -1))
  234.           (transfer-height (- (extents-maxy extents1) (extents-miny extents1) -1))
  235.           (new-x-offset (- (extents-byte-bound extents1) (extents-byte-bound new-extents)))
  236.           (new-y-offset (- (extents-miny extents1) (extents-miny new-extents))))
  237.       (bitblt #-:EXPLORER :set #+:EXPLORER boole-1                                                                ;;; ALU
  238.           transfer-width                                                         ;;; width
  239.           transfer-height                                                        ;;; height
  240.           bitplane1                                                              ;;; source
  241.           0                                                                      ;;; from-x
  242.           0                                                                      ;;; from-y
  243.           new-bitplane                                                           ;;; destination
  244.           new-x-offset                                                           ;;; to-x
  245.           new-y-offset))                                                         ;;; to-y
  246.     (let ((transfer-width (- (extents-maxx extents2) (extents-byte-bound extents2) -1))
  247.           (transfer-height (- (extents-maxy extents2) (extents-miny extents2) -1))
  248.           (new-x-offset (- (extents-byte-bound extents2) (extents-byte-bound new-extents)))
  249.           (new-y-offset (- (extents-miny extents2) (extents-miny new-extents))))
  250.       (bitblt #-:EXPLORER :ior #+:EXPLORER boole-ior                                                              ;;; ALU
  251.           transfer-width                                                         ;;; width
  252.           transfer-height                                                        ;;; height
  253.           bitplane2                                                              ;;; source
  254.           0                                                                      ;;; from-x
  255.           0                                                                      ;;; from-y
  256.           new-bitplane                                                           ;;; destination
  257.           new-x-offset                                                           ;;; to-x
  258.           new-y-offset))                                                         ;;; to-y
  259.     (make-pixelmap :extents new-extents :bitplane new-bitplane)))))
  260.  
  261.  
  262. (defun pix-intersection (pixelmap1 pixelmap2)
  263.   (multiple-value-bind (bitplane1 extents1)
  264.       (extract-bitplane-and-extents pixelmap1)
  265.     (multiple-value-bind (bitplane2 extents2)
  266.     (extract-bitplane-and-extents pixelmap2)
  267.       (let ((new-extents (make-pixelmap-extents (max (extents-minx extents1) (extents-minx extents2))
  268.                         (max (extents-miny extents1) (extents-miny extents2))
  269.                         (min (extents-maxx extents1) (extents-maxx extents2))
  270.                         (min (extents-maxy extents1) (extents-maxy extents2)))))
  271.     (when (and (>= (extents-maxx new-extents) (extents-minx new-extents))
  272.            (>= (extents-maxy new-extents) (extents-miny new-extents)))
  273.       (let ((new-bitplane (make-bitplane new-extents)))
  274.         (bitblt #-:EXPLORER :set #+:EXPLORER boole-1                                                                ;;; ALU
  275.             (- (extents-maxx new-extents) (extents-byte-bound new-extents) -1)           ;;; width
  276.             (- (extents-maxy new-extents) (extents-miny new-extents) -1)           ;;; height
  277.             bitplane1                                                              ;;; source
  278.             (- (extents-byte-bound new-extents) (extents-byte-bound extents1))     ;;; from-x
  279.             (- (extents-miny new-extents) (extents-miny extents1))                 ;;; from-y
  280.             new-bitplane                                                           ;;; destination
  281.             0                                                                      ;;; to-x
  282.             0)                                                                     ;;; to-y
  283.         (bitblt #-:EXPLORER :and #+:EXPLORER boole-and                                                              ;;; ALU
  284.             (- (extents-maxx new-extents) (extents-byte-bound new-extents) -1)
  285.             (- (extents-maxy new-extents) (extents-miny new-extents) -1)           ;;; height
  286.             bitplane2                                                              ;;; source
  287.             (- (extents-byte-bound new-extents) (extents-byte-bound extents2))     ;;; from-x
  288.             (- (extents-miny new-extents) (extents-miny extents2))                 ;;; from-y
  289.             new-bitplane                                                           ;;; destination
  290.             0                                                                      ;;; to-x
  291.             0)                                                                     ;;; to-y
  292.         
  293.         (unless (bitplane-emptyp new-bitplane)
  294.           (make-pixelmap :extents new-extents :bitplane new-bitplane))))))))
  295.  
  296.  
  297.  
  298.  
  299. (defun pix-set-difference! (pixelmap1 pixelmap2)
  300.   (multiple-value-bind (bitplane1 extents1)
  301.       (extract-bitplane-and-extents pixelmap1)
  302.     (multiple-value-bind (bitplane2 extents2)
  303.     (extract-bitplane-and-extents pixelmap2)
  304.       (let ((width-to-copy (- (min (+ (extents-byte-bound extents1) (* 8 (extents-byte-width extents1)))
  305.                    (+ (extents-byte-bound extents2) (* 8 (extents-byte-width extents2))))
  306.                   (max (extents-byte-bound extents1) (extents-byte-bound extents2))))
  307.         (height-to-copy (- (min (extents-maxy extents1) (extents-maxy extents2))
  308.                    (max (extents-miny extents1) (extents-miny extents2))
  309.                    -1)))
  310.     (unless (or (>= 0 width-to-copy)
  311.             (>= 0 height-to-copy))
  312.       (bitblt #-:EXPLORER :andc1 #+:EXPLORER boole-andc1                                                            ;;; ALU
  313.           width-to-copy                                                          ;;; width
  314.           height-to-copy                                                         ;;; height
  315.           bitplane2                                                              ;;; source
  316.           (max 0 (- (extents-byte-bound extents1) (extents-byte-bound extents2)));;; from-x
  317.           (max 0 (- (extents-miny extents1) (extents-miny extents2)))            ;;; from-y
  318.           bitplane1                                                              ;;; destination
  319.           (max 0 (- (extents-byte-bound extents2) (extents-byte-bound extents1)));;; to-x
  320.           (max 0 (- (extents-miny extents2) (extents-miny extents1)))))          ;;; to-y
  321.     pixelmap1))))
  322.  
  323.  
  324. (defun pix-set-difference (pixelmap1 pixelmap2)
  325.   (multiple-value-bind (bitplane1 extents1)
  326.       (extract-bitplane-and-extents pixelmap1)
  327.     (let ((new-extents (make-pixelmap-extents (extents-minx extents1)
  328.                           (extents-miny extents1)
  329.                           (extents-maxx extents1)
  330.                           (extents-maxy extents1)))
  331.       (new-bitplane (make-bitplane extents1)))
  332.       (bitblt #-:EXPLORER :set #+:EXPLORER boole-1                                                                ;;; ALU
  333.           (* 8 (extents-byte-width extents1))                                    ;;; width
  334.           (- (extents-maxy extents1) (extents-miny extents1) -1)                 ;;; height
  335.           bitplane1                                                              ;;; source
  336.           0                                                                      ;;; from-x
  337.           0                                                                      ;;; from-y
  338.           new-bitplane                                                           ;;; destination
  339.           0                                                                      ;;; to-x
  340.           0)                                                                     ;;; to-y
  341.       (pix-set-difference! (make-pixelmap :bitplane new-bitplane :extents new-extents) pixelmap2))))
  342.  
  343.  
  344.  
  345. (defun print-pixelmap (pixelmap &optional (stream t))
  346.   (let ((bitplane (pixelmap-bitplane pixelmap))
  347.     (extents (pixelmap-extents pixelmap)))
  348.     (format stream "~%BYTE BOUND = ~A; BYTE WIDTH = ~A; MINY = ~A; MINX = ~A; MAXY = ~A; MAXX = ~A~% "
  349.         (extents-byte-bound extents)(extents-byte-width extents)
  350.         (extents-miny extents)(extents-minx extents)
  351.         (extents-maxy extents)(extents-maxx extents))
  352.     (dotimes (x (* 8 (extents-byte-width extents))) (format stream "-"))
  353.     (dotimes (y (1+ (- (extents-maxy extents)(extents-miny extents))))
  354.       (format stream  "~%|")
  355.       (dotimes (x (* 8 (extents-byte-width extents)))
  356.     (if (= 1 (aref bitplane y x))
  357.         (format stream "*")
  358.         (format stream " ")))
  359.       (format stream "|"))
  360.     (format stream "~% ")
  361.     (dotimes (x (* 8 (extents-byte-width extents)) t) (format stream "-"))))
  362.