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 / isr2extents.lisp < prev    next >
Lisp/Scheme  |  1995-04-11  |  16KB  |  387 lines
  1. ;;; -*- Mode:Common-Lisp; Package:ISR2;  Base:10 -*-
  2. ;;;
  3. ;;; isr2extents.lisp
  4. ;;; author:  Bruce Draper
  5. ;;; revisions:  John Brolio, Bob Collins
  6. ;;; re-write for ISR2:  Robert Heller - Mon May 23 15:05:59 1988
  7. ;;; Copyright 1987, 1988 by University of Massachusetts
  8. ;;; 
  9. ;;;
  10.  
  11. (in-package "ISR2")
  12.  
  13. (export '(make-pixelmap pixelmap-extents pixelmap-bitplane pixelmap pixelmap-p
  14.       copy-pixelmap make-extents make-bitplane-array))
  15.  
  16. (eval-when (load compile eval)
  17.   (defconstant *scratch-array-size* 384))
  18. (defvar *scratch-bitplane* (make-array `(,*scratch-array-size* ,*scratch-array-size*) 
  19.                        :element-type 'bit :initial-element 0))
  20. (defvar *clean-bitplane* (make-array `(,*scratch-array-size* ,*scratch-array-size*) 
  21.                      :element-type 'bit :initial-element 0))
  22. (defconstant *col-offset* 64)
  23. (defconstant *row-offset* 64)
  24.  
  25. (defvar *scratch-bitplane-lock* nil)
  26.  
  27. (defmacro check-bitplane-and-extents (extents1 bitplane1 &optional extents2 bitplane2)
  28.   `(unless (and (extents-p ,extents1)
  29.         (or (null ,extents2)
  30.             (extents-p ,extents2))
  31.         (arrayp ,bitplane1)
  32.         (or (null ,bitplane2)
  33.             (arrayp ,bitplane2)))
  34.      (error "attempt to operate on non-existent bitplane or extents")))
  35.  
  36. (defun make-extents (pixel-count minx miny maxx maxy)
  37.   (let* ((byte-bound (* 8 (floor minx 8)))
  38.      (vax-byte-width (1+ (floor (- maxx byte-bound) 8)))
  39.      #+:EXPLORER (default-cons-area *bitplane-area*)
  40.      (extents (make-extents-struct :byte-bound byte-bound
  41.                       :byte-width (* (ceiling vax-byte-width 4) 4)
  42.                       :pixel-count pixel-count
  43.                       :minx minx
  44.                       :miny miny
  45.                       :maxx maxx
  46.                       :maxy maxy)))
  47.     #+:EXPLORER (declare (special default-cons-area))
  48.     extents))
  49.  
  50. (defun make-bitplane-array (x y)
  51.   (let (#+:EXPLORER (default-cons-area *bitplane-area*))
  52.     #+:EXPLORER (declare (special default-cons-area))
  53.     (make-array (list y x) :element-type 'bit)))
  54.  
  55. (defun nullp (extents) 
  56.   (unless (extents-p extents) (error "Attempt to access unidentified structure as extents"))
  57.   (zerop (pixel-count-of extents)))
  58.  
  59. (defun bitplane-to-scratch-plane (extents bitplane &key (alu #+:EXPLORER 'logand 
  60.                                  #-:EXPLORER :and))
  61.   (let ((to-x (+ (byte-bound-of extents) *col-offset*))
  62.     (to-y (+ (miny-of extents) *row-offset*))
  63.     (width (* 8 (byte-width-of extents)))
  64.     (height (1+ (- (maxy-of extents)(miny-of extents)))))
  65.     (unless (zerop (mod width 32))
  66.       (error "bitplane is not a multiple of 4 bytes (32 bits) wide"))
  67.     (bitblt alu width height bitplane 0 0 *scratch-bitplane* to-x to-y)))
  68.  
  69. (defun scratch-plane-emptyp (width height from-x from-y)
  70.   (when (or (minusp width) (minusp height)) (error "internal counting error -- call Bruce"))
  71.   (block top-level
  72.     (do ((x (+ from-x *col-offset*) (1+ x))
  73.      (x-stop (+ width from-x *col-offset*)))
  74.     ((<= x-stop x) nil)
  75.       (do ((y (+ *row-offset* from-y) (1+ y))
  76.        (y-stop (+ height from-y *row-offset*)))
  77.       ((<= y-stop y) nil)
  78.     (when (/= 0 (aref *scratch-bitplane* y x))
  79.       (return-from top-level t))))))
  80.  
  81. (defun scratch-bitplane-count (width height from-x from-y &aux (sum 0))
  82.   (when (or (minusp width) (minusp height)) (error "internal counting error -- call Bruce"))
  83.   (do ((x (+ from-x *col-offset*) (1+ x))
  84.        (x-stop (+ width from-x *col-offset*)))
  85.       ((<= x-stop x) sum)
  86.     (do ((y (+ *row-offset* from-y) (1+ y))
  87.      (y-stop (+ height from-y *row-offset*)))
  88.     ((<= y-stop y) nil)
  89.       (when (/= 0 (aref *scratch-bitplane* y x))
  90.     (incf sum)))))
  91.  
  92. (defun scratch-bitplane-to-bitplane (width height from-x from-y)
  93.     (loop (if (or (<= height 0)
  94.           (scratch-plane-emptyp width 1 from-x from-y))
  95.           (return nil)
  96.           (progn (incf from-y)
  97.              (decf height))))
  98.     (loop (if (or (<= width 0)
  99.           (scratch-plane-emptyp 1 height from-x from-y))
  100.           (return nil)
  101.           (progn (incf from-x)
  102.              (decf width))))
  103.     (loop (if (or (<= height 0)
  104.           (scratch-plane-emptyp width 1 from-x (+ from-y height -1)))
  105.           (return nil)
  106.           (decf height)))
  107.     (loop (if (or (<= width 0)
  108.           (scratch-plane-emptyp 1 height (+ from-x width -1) from-y))
  109.           (return nil)
  110.           (decf width)))
  111.     (let ((extents nil)(bitplane nil))
  112.       (if (or (<= width 0) (<= height 0))
  113.       ;;make an empty bitplane
  114.       (progn
  115.         (setf extents (make-extents 0 from-x from-y from-x from-y))
  116.         (setf bitplane (make-bitplane-array 32 1)))
  117.       ;;else make and a real bitplane and fill it in
  118.       (progn
  119.         (setf extents (make-extents 0 from-x from-y (+ from-x width -1) (+ from-y height -1)))
  120.         (setf bitplane (make-bitplane-array (* 8 (byte-width-of extents)) height))
  121.         (bitblt #+:EXPLORER tv::alu-seta #-:EXPLORER :set width height
  122.             *scratch-bitplane* (+ from-x *col-offset*) (+ from-y *row-offset*)
  123.             bitplane (- from-x (byte-bound-of extents)) 0)))
  124.       (values extents bitplane)))
  125.  
  126. (defun clear-scratch-bitplane ()
  127.   (bitblt #+:EXPLORER tv::alu-seta
  128.       #-:EXPLORER :set
  129.       *scratch-array-size* *scratch-array-size* *clean-bitplane* 0 0
  130.       *scratch-bitplane* 0 0))
  131.  
  132. (defstruct pixelmap
  133.        extents
  134.        bitplane
  135.        )
  136.  
  137. (defun pixel-count (token-pixelmap-path)
  138.   (with-lock (*scratch-bitplane-lock*)
  139.     (let* ((pixelmap (if (pixelmap-p token-pixelmap-path)
  140.              token-pixelmap-path
  141.              (value token-pixelmap-path)))
  142.        (extents (pixelmap-extents pixelmap))
  143.        (bitplane (pixelmap-bitplane pixelmap)))
  144.       (check-bitplane-and-extents extents bitplane)
  145.       (let ((min-x (minx-of extents))
  146.         (max-x (maxx-of extents))
  147.         (min-y (miny-of extents))
  148.         (max-y (maxy-of extents)))
  149.     (clear-scratch-bitplane)
  150.     (bitplane-to-scratch-plane extents bitplane :alu #-:EXPLORER :set 
  151.                    #+:EXPLORER tv::alu-seta)
  152.     (scratch-bitplane-count (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y)))))
  153.  
  154. (defun intersectp (token-pixelmap-path1 token-pixelmap-path2)
  155.   (with-lock (*scratch-bitplane-lock*)
  156.     (let* ((pixelmap1 (value token-pixelmap-path1))
  157.        (extents1 (pixelmap-extents pixelmap1))
  158.        (bitplane1 (pixelmap-bitplane pixelmap1))
  159.        (pixelmap2 (value token-pixelmap-path2))
  160.        (extents2 (pixelmap-extents pixelmap2))
  161.        (bitplane2 (pixelmap-bitplane pixelmap2)))
  162.       (check-bitplane-and-extents extents1 bitplane1 extents2 bitplane2)
  163.       (let ((min-x (max (minx-of extents1)(minx-of extents2)))
  164.         (max-x (min (maxx-of extents1)(maxx-of extents2)))
  165.         (min-y (max (miny-of extents1)(miny-of extents2)))
  166.         (max-y (min (maxy-of extents1)(maxy-of extents2))))
  167.     (if (or (< max-x min-x) (< max-y min-y))
  168.         nil
  169.         (progn
  170.           (clear-scratch-bitplane)
  171.           (bitplane-to-scratch-plane extents1 bitplane1 :alu #-:EXPLORER :set
  172.                                    #+:EXPLORER tv::alu-seta)
  173.         (bitplane-to-scratch-plane extents2 bitplane2 :alu #-:EXPLORER :and
  174.                        #+:EXPLORER tv::boole-and)
  175.         (scratch-plane-emptyp (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y)))))))
  176.  
  177. (defun intersect-count (token-pixelmap-path1 token-pixelmap-path2)
  178.   (with-lock (*scratch-bitplane-lock*)
  179.     (let* ((pixelmap1 (value token-pixelmap-path1))
  180.        (extents1 (pixelmap-extents pixelmap1))
  181.        (bitplane1 (pixelmap-bitplane pixelmap1))
  182.        (pixelmap2 (value token-pixelmap-path2))
  183.        (extents2 (pixelmap-extents pixelmap2))
  184.        (bitplane2 (pixelmap-bitplane pixelmap2)))
  185.       (check-bitplane-and-extents extents1 bitplane1 extents2 bitplane2)
  186.       (let ((min-x (max (minx-of extents1)(minx-of extents2)))
  187.         (max-x (min (maxx-of extents1)(maxx-of extents2)))
  188.         (min-y (max (miny-of extents1)(miny-of extents2)))
  189.         (max-y (min (maxy-of extents1)(maxy-of extents2))))
  190.     (if (or (< max-x min-x) (< max-y min-y))
  191.         0
  192.         (progn
  193.           (clear-scratch-bitplane)
  194.           (bitplane-to-scratch-plane extents1 bitplane1 :alu #-:EXPLORER :set 
  195.                      #+:EXPLORER tv::alu-seta)
  196.           (bitplane-to-scratch-plane extents2 bitplane2 :alu #-:EXPLORER :and
  197.                      #+:EXPLORER tv::boole-and)
  198.           (scratch-bitplane-count (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y)))))))
  199.  
  200. (defun intersectp-with-token (token-pixelmap-path1 token-pixelmap-path2 resulting-token-pixelmap-path)
  201.   (with-lock (*scratch-bitplane-lock*)
  202.     (let* ((pixelmap1 (value token-pixelmap-path1))
  203.        (extents1 (pixelmap-extents pixelmap1))
  204.        (bitplane1 (pixelmap-bitplane pixelmap1))
  205.        (pixelmap2 (value token-pixelmap-path2))
  206.        (extents2 (pixelmap-extents pixelmap2))
  207.        (bitplane2 (pixelmap-bitplane pixelmap2))
  208.        (bitplane nil) (extents nil))
  209.       (check-bitplane-and-extents extents1 bitplane1 extents2 bitplane2)
  210.       (let ((min-x (max (minx-of extents1)(minx-of extents2)))
  211.         (max-x (min (maxx-of extents1)(maxx-of extents2)))
  212.         (min-y (max (miny-of extents1)(miny-of extents2)))
  213.         (max-y (min (maxy-of extents1)(maxy-of extents2))))
  214.     (clear-scratch-bitplane)
  215.     (if (or (< max-x min-x) (< max-y min-y))
  216.         (progn
  217.           (multiple-value-setq (extents bitplane)
  218.         (scratch-bitplane-to-bitplane 
  219.           0 0 min-x min-y))
  220.           (setf (extents-pixel-count extents) 0))
  221.         (progn
  222.           (bitplane-to-scratch-plane extents1 bitplane1 :alu #-:EXPLORER :set
  223.                      #+:EXPLORER tv::alu-seta)
  224.           (bitplane-to-scratch-plane extents2 bitplane2 :alu #-:EXPLORER :and
  225.                      #+:EXPLORER tv::boole-and)
  226.           (multiple-value-setq (extents bitplane)
  227.         (scratch-bitplane-to-bitplane 
  228.           (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y))
  229.           (setf (extents-pixel-count extents)
  230.             (scratch-bitplane-count 
  231.               (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y))))
  232.     (setf (value resulting-token-pixelmap-path)
  233.           (make-pixelmap :extents extents
  234.                  :bitplane bitplane))
  235.     (not (zerop (extents-pixel-count extents)))))))
  236.  
  237. (defun unionp (token-pixelmap-path1 token-pixelmap-path2)
  238.   (with-lock (*scratch-bitplane-lock*)
  239.     (let* ((pixelmap1 (value token-pixelmap-path1))
  240.        (extents1 (pixelmap-extents pixelmap1))
  241.        (pixelmap2 (value token-pixelmap-path2))
  242.        (extents2 (pixelmap-extents pixelmap2)))
  243.       (not (and (nullp extents1)(nullp extents2))))))
  244.  
  245. (defun union-count (token-pixelmap-path1 token-pixelmap-path2)
  246.   (with-lock (*scratch-bitplane-lock*)
  247.     (let* ((pixelmap1 (value token-pixelmap-path1))
  248.        (extents1 (pixelmap-extents pixelmap1))
  249.        (bitplane1 (pixelmap-bitplane pixelmap1))
  250.        (pixelmap2 (value token-pixelmap-path2))
  251.        (extents2 (pixelmap-extents pixelmap2))
  252.        (bitplane2 (pixelmap-bitplane pixelmap2)))
  253.       (check-bitplane-and-extents extents1 bitplane1 extents2 bitplane2)
  254.       (let ((min-x (min (minx-of extents1)(minx-of extents2)))
  255.         (max-x (max (maxx-of extents1)(maxx-of extents2)))
  256.         (min-y (min (miny-of extents1)(miny-of extents2)))
  257.         (max-y (max (maxy-of extents1)(maxy-of extents2))))
  258.     (clear-scratch-bitplane)
  259.     (bitplane-to-scratch-plane extents1 bitplane1 :alu #-:EXPLORER :ior
  260.                    #+:EXPLORER tv::boole-ior)
  261.     (bitplane-to-scratch-plane extents2 bitplane2 :alu #-:EXPLORER :ior
  262.                    #+:EXPLORER tv::boole-ior)
  263.     (scratch-bitplane-count (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y)))))
  264.  
  265.  
  266. (defun unionp-with-token (token-pixelmap-path1 token-pixelmap-path2 resulting-token-pixelmap-path)
  267.   (with-lock (*scratch-bitplane-lock*)
  268.     (let* ((pixelmap1 (value token-pixelmap-path1))
  269.        (extents1 (pixelmap-extents pixelmap1))
  270.        (bitplane1 (pixelmap-bitplane pixelmap1))
  271.        (pixelmap2 (value token-pixelmap-path2))
  272.        (extents2 (pixelmap-extents pixelmap2))
  273.        (bitplane2 (pixelmap-bitplane pixelmap2)))
  274.       (check-bitplane-and-extents extents1 bitplane1 extents2 bitplane2)
  275.       (let ((min-x (min (minx-of extents1)(minx-of extents2)))
  276.         (max-x (max (maxx-of extents1)(maxx-of extents2)))
  277.         (min-y (min (miny-of extents1)(miny-of extents2)))
  278.         (max-y (max (maxy-of extents1)(maxy-of extents2))))
  279.     (clear-scratch-bitplane)
  280.     (bitplane-to-scratch-plane extents1 bitplane1 :alu #-:EXPLORER :ior 
  281.                    #+:EXPLORER tv::boole-ior)
  282.     (bitplane-to-scratch-plane extents2 bitplane2 :alu #-:EXPLORER :ior
  283.                    #+:EXPLORER tv::boole-ior)
  284.     (multiple-value-bind (extents bitplane)
  285.         (scratch-bitplane-to-bitplane 
  286.           (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y)
  287.       (setf (extents-pixel-count extents)
  288.         (scratch-bitplane-count
  289.           (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y))
  290.       (setf (value resulting-token-pixelmap-path)
  291.         (make-pixelmap :extents extents
  292.                    :bitplane bitplane))
  293.       (not (zerop (extents-pixel-count extents))))))))
  294.  
  295.  
  296. (defun differencep (token-pixelmap-path1 token-pixelmap-path2)
  297.   (with-lock (*scratch-bitplane-lock*)
  298.     (let* ((pixelmap1 (value token-pixelmap-path1))
  299.        (extents1 (pixelmap-extents pixelmap1))
  300.        (bitplane1 (pixelmap-bitplane pixelmap1))
  301.        (pixelmap2 (value token-pixelmap-path2))
  302.        (extents2 (pixelmap-extents pixelmap2))
  303.        (bitplane2 (pixelmap-bitplane pixelmap2)))
  304.       (check-bitplane-and-extents extents1 bitplane1 extents2 bitplane2)
  305.       (let ((min-x (minx-of extents1))
  306.         (max-x (maxx-of extents1))
  307.         (min-y (miny-of extents1))
  308.         (max-y (maxy-of extents1)))
  309.     (clear-scratch-bitplane)
  310.     (bitplane-to-scratch-plane extents1 bitplane1 :alu #-:EXPLORER :set
  311.                    #+:EXPLORER tv::alu-seta)
  312.     (bitplane-to-scratch-plane extents2 bitplane2 :alu #-:EXPLORER :andc1
  313.                    #+:EXPLORER tv::boole-andc1)
  314.     (scratch-plane-emptyp (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y)))))
  315.  
  316. (defun difference-count (token-pixelmap-path1 token-pixelmap-path2)
  317.   (with-lock (*scratch-bitplane-lock*)
  318.     (let* ((pixelmap1 (value token-pixelmap-path1))
  319.        (extents1 (pixelmap-extents pixelmap1))
  320.        (bitplane1 (pixelmap-bitplane pixelmap1))
  321.        (pixelmap2 (value token-pixelmap-path2))
  322.        (extents2 (pixelmap-extents pixelmap2))
  323.        (bitplane2 (pixelmap-bitplane pixelmap2)))
  324.       (check-bitplane-and-extents extents1 bitplane1 extents2 bitplane2)
  325.       (let ((min-x (minx-of extents1))
  326.         (max-x (maxx-of extents1))
  327.         (min-y (miny-of extents1))
  328.         (max-y (maxy-of extents1)))
  329.     (clear-scratch-bitplane)
  330.     (bitplane-to-scratch-plane extents1 bitplane1 :alu #-:EXPLORER :set
  331.                    #+:EXPLORER tv::alu-seta)
  332.     (bitplane-to-scratch-plane extents2 bitplane2 :alu #-:EXPLORER :andc1
  333.                    #+:EXPLORER tv::boole-andc1)
  334.     (scratch-bitplane-count (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y)))))
  335.  
  336.  
  337. (defun differencep-with-token (token-pixelmap-path1 token-pixelmap-path2 resulting-token-pixelmap-path)
  338.   (with-lock (*scratch-bitplane-lock*)
  339.     (let* ((pixelmap1 (value token-pixelmap-path1))
  340.        (extents1 (pixelmap-extents pixelmap1))
  341.        (bitplane1 (pixelmap-bitplane pixelmap1))
  342.        (pixelmap2 (value token-pixelmap-path2))
  343.        (extents2 (pixelmap-extents pixelmap2))
  344.        (bitplane2 (pixelmap-bitplane pixelmap2)))
  345.       (check-bitplane-and-extents extents1 bitplane1 extents2 bitplane2)
  346.       (let ((min-x (minx-of extents1))
  347.         (max-x (maxx-of extents1))
  348.         (min-y (miny-of extents1))
  349.         (max-y (maxy-of extents1)))
  350.     (clear-scratch-bitplane)
  351.     (bitplane-to-scratch-plane extents1 bitplane1 :alu #-:EXPLORER :set
  352.                    #+:EXPLORER tv::alu-seta)
  353.     (bitplane-to-scratch-plane extents2 bitplane2 :alu #-:EXPLORER :andc1
  354.                    #+:EXPLORER tv::boole-andc1)
  355.     (multiple-value-bind (extents bitplane)
  356.         (scratch-bitplane-to-bitplane 
  357.           (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y)
  358.       (setf (extents-pixel-count extents)
  359.         (scratch-bitplane-count (1+ (- max-x min-x)) (1+ (- max-y min-y)) min-x min-y))
  360.       (setf (value resulting-token-pixelmap-path)
  361.         (make-pixelmap :extents extents
  362.                    :bitplane bitplane))
  363.       (not (zerop (extents-pixel-count extents))))))))
  364.  
  365. (defun print-bitplane (token-pixelmap-path)
  366.   (with-lock (*scratch-bitplane-lock*)
  367.     (let* ((pixelmap (value token-pixelmap-path))
  368.        (bitplane (pixelmap-bitplane pixelmap))
  369.        (extents (pixelmap-extents pixelmap)))
  370.       (check-bitplane-and-extents extents bitplane)
  371.       (format t "~%BYTE BOUND = ~A; BYTE WIDTH = ~A; MINY = ~A; MINX = ~A; MAXY = ~A; MAXX = ~A~% "
  372.           (byte-bound-of extents)(byte-width-of extents)
  373.           (miny-of extents)(minx-of extents)
  374.           (maxy-of extents)(maxx-of extents))
  375.       (dotimes (x (* 8 (byte-width-of extents))) (format t "-"))
  376.       (dotimes (y (1+ (- (maxy-of extents)(miny-of extents))))
  377.     (format t  "~%|")
  378.     (dotimes (x (* 8 (byte-width-of extents)))
  379.       (if (= 1 (aref bitplane y x))
  380.           (format t "*")
  381.           (format t " ")))
  382.     (format t "|"))
  383.       (format t "~% ")
  384.       (dotimes (x (* 8 (byte-width-of extents)) t) (format t "-")))))
  385.  
  386.  
  387.