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 / isr2lag.lisp < prev    next >
Lisp/Scheme  |  1995-07-06  |  7KB  |  190 lines
  1. ;;; -*- Mode:Common-Lisp; Package:ISR2; Base:10 -*-
  2.  
  3. (in-package "ISR2")
  4.  
  5. ;;;; Part of building Pixel Maps involves LAGs - see below - therefore, here 
  6. ;;;; it is, part of the ISR2.
  7. ;;;;
  8. ;;;; 6/19/91 Bob Collins
  9.  
  10. ;;;; A Line Adjacency Graph (LAG) is a graph where horizontal line segments
  11. ;;;; are represented as nodes, and above/below adjacency of the line segments
  12. ;;;; is explicitly represented by pointers.
  13.  
  14.  
  15.  
  16. ;; Line Adjacency Graph (LAG) 
  17. (defstruct (lag (:constructor make-lag-struct))
  18.   (array nil)  ;each full horizontal line has a slot in the lag-array.
  19.                ;the slot contains a list of segment-entries, one for
  20.                ;each line segment within the full horizontal line.
  21.   (starty 0))  ;lag-array element 0 corresponds to screen-array line starty.
  22.  
  23.  
  24. (defun make-lag (starty height)
  25.   (make-lag-struct
  26.     ;;one slot for each horizontal line
  27.     :array (make-array height :initial-element nil)
  28.     :starty starty))
  29.  
  30. ;; a horizontal line segment in the line adjacency graph
  31. (defstruct segment-entry
  32.   (startx 0)         ;starting x coord of this segment block
  33.   (endx 0)           ;ending x coord of this segment block
  34.   (above-list nil)   ;list of segment entries adjacent to and above this one
  35.   (below-list nil)   ;list of segment entries adjacent to and below this one
  36.   (marked nil))      ;a boolean flag
  37.  
  38. (defmacro for-each-lag-segment ((lag y segment) &body body)
  39.   "  Perform the body once for each segment in the LAG, with the
  40.   variables Y and SEGMENT bound to the y coord of the segment,
  41.   and the segment entry itself, respectively."
  42.   (let ((numrows (gensym))
  43.     (thelag (gensym))
  44.     (index (gensym)))
  45.     `(let ((,thelag ,lag))
  46.        (do ((,numrows (length (lag-array ,thelag)) (1- ,numrows))
  47.         (,y (lag-starty ,thelag) (1+ ,y))
  48.         (,index 0 (1+ ,index)))
  49.        ((zerop ,numrows) ,thelag)
  50.      (dolist (,segment (aref (lag-array ,thelag) ,index))
  51.        ,@body)))))
  52.  
  53. (defmacro for-each-unmarked-lag-segment ((lag y segment) &body body)
  54.   "  Performs body once for each unmarked segment in the LAG, with
  55.   variables Y and SEGMENT bound to the y coord of the segment,
  56.   and the segment entry itself, respectively."
  57.   `(for-each-lag-segment (,lag ,y ,segment)
  58.      (unless (segment-entry-marked ,segment)
  59.        ,@body)))
  60.  
  61. (defun mark-each-connected-segment (initial-segment initial-y &key (function nil))
  62.   "  Marks each segment connected to the INITIAL-SEGMENT which resides at y-coordinate
  63.   INITIAL-Y.  If a FUNCTION is specified, it is applied to the segment and all connected
  64.   segments before they are marked.  The function must take two arguments, the first
  65.   will be the current segment structure, the second will be the y coordinate of the segment.
  66.   Note:  if the initial-segment is already marked, nothing will be done."
  67.   (unless (segment-entry-marked initial-segment)
  68.     (when function
  69.       (funcall function initial-segment initial-y))
  70.     (setf (segment-entry-marked initial-segment) t)
  71.     (dolist (above (segment-entry-above-list initial-segment))
  72.       (mark-each-connected-segment above (1- initial-y) :function function))
  73.     (dolist (below (segment-entry-below-list initial-segment))
  74.       (mark-each-connected-segment below (1+ initial-y) :function function))))
  75.  
  76. (defun clear-lag-segment-marks (lag)
  77.   "Unmark all lag segment flags."
  78.   (for-each-lag-segment (lag y segment)
  79.     (setf (segment-entry-marked segment) nil)))
  80.  
  81. (defun print-lag (lag)
  82.   (let ((y (lag-starty lag))
  83.     (numrows (length (lag-array lag))))
  84.     (dotimes (i numrows nil)
  85.       (format t "~% row ~d:" (+ i y))
  86.       (dolist (segment (aref (lag-array lag) i))
  87.     (format t " (~d,~d)" (segment-entry-startx segment) (segment-entry-endx segment))))))
  88.  
  89.  
  90.  
  91. (defun enter-4-connected-segment-into-lag (lag y startx endx)
  92.   "returns segment structure constructed."
  93.   (let ((current (make-segment-entry :startx startx :endx endx))
  94.     (index (- y (lag-starty lag))))
  95.     (setf (aref (lag-array lag) index) (nconc (aref (lag-array lag) index)
  96.                           (list current)))
  97.     (when (> index 0)
  98.       (dolist (above (aref (lag-array lag) (1- index)))
  99.     (unless (or (> (segment-entry-startx above) endx)
  100.             (< (segment-entry-endx above) startx))
  101.       (push current (segment-entry-below-list above))
  102.       (push above (segment-entry-above-list current)))))))
  103.  
  104.  
  105. (defun enter-8-connected-segment-into-lag (lag y startx endx)
  106.   "returns segment structure constructed."
  107.   (let ((current (make-segment-entry :startx startx :endx endx))
  108.     (index (- y (lag-starty lag))))
  109.     (setf (aref (lag-array lag) index) (nconc (aref (lag-array lag) index)
  110.                           (list current)))
  111.     (when (> index 0)
  112.       (dolist (above (aref (lag-array lag) (1- index)))
  113.     (unless (or (> (segment-entry-startx above) (1+ endx))
  114.             (< (segment-entry-endx above) (1- startx)))
  115.       (push current (segment-entry-below-list above))
  116.       (push above (segment-entry-above-list current)))))))
  117.  
  118.  
  119. (defun construct-lag (array value startrow startcol endrow endcol &key (background nil))
  120.   "  Given a specification of a rectangular portion of an array, create a
  121.   line adjacency graph (LAG) for that array area.  VALUE is the value which
  122.   corresponds to the foreground object in the array.  If BACKGROUND is t,
  123.   then a lag of the background will be produced, by default the foreground
  124.   lag is constructed.  Foreground pixels are considered to have 8-connected
  125.   neighborhoods while background pixels are only 4-connected."
  126.   (if background
  127.       (construct-background-lag array value startrow startcol endrow endcol)
  128.       (construct-foreground-lag array value startrow startcol endrow endcol)))
  129.  
  130. (defun construct-foreground-lag (array value startrow startcol endrow endcol)
  131.   "See CONSTRUCT-LAG."
  132.   ;;foreground is 8 connected.
  133.   (let ((lag (make-lag startrow (- endrow startrow -1))))
  134.     (do ((y startrow (1+ y)))
  135.     ((> y endrow) nil)
  136.       (do ((x startcol (1+ x))
  137.        (in-segment nil)
  138.        (segment-start))
  139.       ((> x endcol)
  140.          (when in-segment
  141.         (enter-8-connected-segment-into-lag 
  142.           lag y
  143.           segment-start
  144.           endcol)))
  145.     (cond
  146.       ((and in-segment (not (= (aref array y x) value)))
  147.           (enter-8-connected-segment-into-lag lag y segment-start (1- x))
  148.           (setf in-segment nil))
  149.       ((and (not in-segment) (= (aref array y x) value))
  150.           (setf segment-start x)
  151.           (setf in-segment t))
  152.       (t nil))))
  153.     lag))
  154.  
  155.  
  156. (defun construct-background-lag (array value startrow startcol endrow endcol)
  157.   "See CONSTRUCT-LAG."
  158.   ;;background is 4 connected.
  159.   ;;the lag artificially includes a one pixel buffer all the way around the
  160.   ;;specified rectangle so that the rectangle boundaries do not cause the
  161.   ;;background to be broken up into unconnected patches.
  162.   (let ((lag (make-lag (1- startrow) (- endrow startrow -3))))
  163.     (enter-4-connected-segment-into-lag lag (1- startrow) (1- startcol) (1+ endcol))
  164.     (do ((y startrow (1+ y)))
  165.     ((> y endrow) nil)
  166.       (do ((x startcol (1+ x))
  167.        (in-segment t)
  168.        (segment-start (1- startcol)))
  169.       ((> x endcol)
  170.          (enter-4-connected-segment-into-lag 
  171.            lag y
  172.            (if in-segment segment-start (1+ endcol))
  173.            (1+ endcol)))
  174.     (cond
  175.       ((and in-segment (= (aref array y x) value))
  176.           (enter-4-connected-segment-into-lag lag y segment-start (1- x))
  177.           (setf in-segment nil))
  178.       ((and (not in-segment) (not (= (aref array y x) value)))
  179.           (setf segment-start x)
  180.           (setf in-segment t))
  181.       (t nil))))
  182.     (enter-4-connected-segment-into-lag lag (1+ endrow) (1- startcol) (1+ endcol))
  183.     lag))
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.