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 / BuildingFinder / Lisp / top-down-vrfy.lisp < prev   
Lisp/Scheme  |  1995-11-17  |  7KB  |  216 lines
  1. ;;; TOP-DOWN-VRFY.LISP
  2. ;;;
  3. ;;; Routines to verify the existence of an edge in an image
  4. ;;; between to features that may be grouped together.
  5. ;;;
  6. ;;; Makes use of a top-down/local edge detector.
  7. ;;;
  8. ;;;
  9. ;;; Author: Christopher O. Jaynes
  10. ;;; Date: June 11, 1995
  11. ;;;
  12. ;;
  13. ;------------------------------------------------------------
  14. ; (c) Copyright 1995 by The University of Massachusetts
  15. ;------------------------------------------------------------
  16.  
  17. (in-package 'cme)
  18.  
  19.  
  20.  
  21. ;;
  22. ;; Local line support is determined through an analysis of the local
  23. ;; intensity gradient.  Lines are extracted, projected to the support
  24. ;; line and then a coverage length is computed.
  25. ;;
  26. (defun image-line-support (image u1 v1 u2 v2 column-width percentage)
  27.    (let ((support (line-support-overlap image u1 v1 u2 v2 column-width)))
  28.      (if (> support percentage)
  29.        support
  30.        0.0)))
  31.  
  32.  
  33. (defun line-support-overlap (image u1 v1 u2 v2 column-width)
  34.    (let* ((linevec (make-vec-2d u1 v1 u2 v2))
  35.       (pairs  (sort-pairs (supporting-line-begin-end-pairs image u1 v1 u2 v2
  36.                                                         column-width)))
  37.           (gaplength
  38.         (compute-support-gaps (car pairs) (cdr pairs) u1 v1 u2 v2)))
  39.     (- 1.0 (/ gaplength (linear-algebra::vector-length linevec)))))
  40.         
  41.  
  42. (defun compute-support-gaps (first pairlist u1 v1 u2 v2)
  43.   (if (null first) 
  44.     (linear-algebra::vector-length (make-vec-2d u1 v1 u2 v2))
  45.     (+ (car first) (compute-gap-lengths first pairlist) 
  46.             (- (linear-algebra::vector-length
  47.                  (make-vec-2d u1 v1 u2 v2))
  48.                  (last-endpoint (cons first pairlist)))) ))
  49.  
  50. (defun compute-gap-lengths (first pairs)
  51.   (let  ((next (car pairs)))
  52.     (if (null next)
  53.     0
  54.     (if (> (cadr next) (cadr first))
  55.        (+ (gap-distance first next)
  56.          (compute-gap-lengths next (cdr pairs)))
  57.        (compute-gap-lengths first (cdr pairs))))))
  58.  
  59. (defun sort-by-end (pairs)
  60.   (sort pairs '>' :key 'cadr))
  61.  
  62. (defun last-endpoint (pairs)
  63.   (cadr (car (sort-by-end pairs))))
  64.  
  65.  
  66.  
  67. (defun gap-distance (p1 p2)
  68.     (if (< (cadr p1) (car p2))
  69.     (- (car p2) (cadr p1))
  70.     0))
  71.  
  72. (defun sort-pairs (pairs)
  73.   (let ((swapped (swap-pairs pairs)))
  74.    (sort swapped '< :key 'car)))
  75.  
  76.  
  77. (defun swap-pairs (pairs)
  78.   (let ((result-list nil))
  79.     (dolist (pair pairs)
  80.       (if (< (cadr pair) (car pair))
  81.     (push (list (cadr pair) (car pair)) result-list)
  82.     (push pair result-list)))
  83.    result-list))
  84.  
  85. ;;
  86. ;;
  87. ;; Detect lines within the bounding region around the 
  88. ;; grouping line.  Transform the lines to a local coordinate
  89. ;; system (local to grouping line) by projecting the 
  90. ;; detected lines onto the grouping line.
  91. ;;
  92. ;; These lines can then be summed along their length for 
  93. ;; support information.
  94.  
  95. (defun supporting-line-begin-end-pairs (image u1 v1 u2 v2 width)
  96.   (let* ((result-line-list nil)
  97.          (linelist (clip-lines-to-quad
  98.                    (local-intensity-edges image u1 v1 u2 v2 width)
  99.                    u1 v1 u2 v2 width)))
  100.     (dolist  (line linelist)
  101.                 (push (project-line-1d u1 v1 u2 v2 line) result-line-list))
  102.    result-line-list))
  103.  
  104. ;;
  105. ;; Project line endpoints of 'line' onto the 1D line (u1 v1 u2 v2)
  106. ;; the result for each point is a positive 1D scalar that represents
  107. ;; the distance along the cooordinate line. (b1 e1)
  108. ;;
  109.  
  110. (defun project-line-1d (u1 v1 u2 v2 line)
  111.   (let* ((basevec (unit-vector-2d (make-vec-2d u1 v1 u2 v2)))
  112.          (vec1 (make-vec-2d u1 v1 (car line) (cadr line)))
  113.          (vec2 (make-vec-2d u1 v1 (third line) (fourth line)))
  114.          (cos1 (cos-angle-2d basevec vec1))
  115.          (cos2 (cos-angle-2d basevec vec2))
  116.          (b (* cos1 (linear-algebra::vector-length vec1)))
  117.          (e (* cos2 (linear-algebra::vector-length vec2))))
  118.     (list b e)))
  119.  
  120. (defun project-line (u1 v1 u2 v2 line)
  121.   (let* ((basevec (unit-vector-2d (make-vec-2d u1 v1 u2 v2)))
  122.      (vec1 (make-vec-2d u1 v1 (car line) (cadr line)))
  123.      (vec2 (make-vec-2d u1 v1 (third line) (fourth line)))
  124.      (cos1 (cos-angle-2d basevec vec1))
  125.      (cos2 (cos-angle-2d basevec vec2))
  126.      (len1 (* cos1 (linear-algebra::vector-length vec1)))
  127.      (len2 (* cos2 (linear-algebra::vector-length vec2))))
  128.      (list (+ u1 (* (car basevec) len1)) (+ v1 (* (cadr basevec) len1))
  129.          (+ u1 (* (car basevec) len2)) (+ v1 (* (cadr basevec) len2)))))
  130.  
  131. (defun unit-vector-2d (vec)
  132.   (let ((len (linear-algebra::vector-length vec)))
  133.     (list (/ (car vec) len) (/ (cadr vec) len))))
  134.  
  135. (defun line-length (line)
  136.   (let ((vec (make-vec-2d (car line) (cadr line) (third line) (fourth line))))
  137.      (linear-algebra::vector-length vec)))
  138.  
  139.  
  140.        
  141. ;;
  142. ;; Return the local intensity edge list for the bounding box around
  143. ;; u1 v1 and u2 v2.
  144. ;;
  145. ;;
  146. ;; Note: The variable *topdown-edgels-for-bdetect* has been initalized
  147. ;;      by the "compute-2dworld-canny-edges" routine for the entire
  148. ;;    bounding box;
  149. ;;        C. Jaynes (Aug. 11)
  150. ;;
  151. (defun local-intensity-edges (image u1 v1 u2 v2 width)
  152.    (let* ((startx (- (min u1 u2) width))
  153.       (starty (- (min v1 v2) width))
  154.       (stopx  (+ (max u1 u2) width))
  155.       (stopy  (+ (max v1 v2) width)))
  156. ;;        (edges  (compute-2dworld-canny-edges image startx starty 
  157. ;;                stopx stopy)))
  158.       (find-oriented-2dworld-lines *topdown-edgels-for-bdetect*
  159.             (compute-angle u1 v1 u2 v2) startx starty stopx stopy)))
  160.  
  161.  
  162. ;;
  163. ;;    Sort lines from min->max values of 
  164. ;;
  165. ;;
  166. ;;
  167.  
  168.  
  169.  
  170.  
  171. (defun compute-angle (u1 v1 u2 v2)
  172.    (let ((xaxis (make-vec-2d 0.0 0.0 1.0 0.0)))
  173.       (if (< u1 u2)
  174.         (degrees (acos (cos-angle-2d
  175.              (make-vec-2d u1 v1 u2 v2) xaxis)))
  176.         (degrees (acos (cos-angle-2d
  177.              (make-vec-2d u2 v2 u1 v1) xaxis))))))
  178.  
  179. ;;
  180. ;;
  181. ;; CLIP LINES TO ORIENTED QUAD.
  182. ;;
  183. (defun clip-lines-to-quad (lines u1 v1 u2 v2 width)
  184.    (multiple-value-bind (box1 box2 box3 box4) 
  185.      (compute-bounding-quad u1 v1 u2 v2 width)
  186.    (clip-function lines box1 box2 box3 box4)))
  187.    
  188.  
  189.  
  190. (defun compute-bounding-quad (u1 v1 u2 v2 width)
  191.    (let* ((r1 (perp-line-point u1 v1 u2 v2 u1 v1 width))
  192.           (r2 (perp-line-point u1 v1 u2 v2 u2 v2 width))
  193.           (r3 (perp-line-point u1 v1 u2 v2 u2 v2
  194.         (- width)))
  195.           (r4 (perp-line-point u1 v1 u2 v2 u1 v1 (- width))))
  196.       (values r1 r2 r3 r4)))
  197.  
  198. (defun perp-line-point (u1 v1 u2 v2 x y dist)
  199.   (multiple-value-bind (px py) 
  200.     (snakes::perpendicular-from-point-on-line u1 v1 u2 v2 x y dist)
  201.    (list px py)))
  202.  
  203.     
  204. (defun clip-function (list-of-lines pt1 pt2 pt3 pt4)
  205.   (let ((result-line-list nil))
  206.    (multiple-value-bind (l1 l2 l3 l4)
  207.     (epi::clip-to-quad-init pt1 pt2 pt3 pt4)
  208.  
  209.     (dolist (line list-of-lines)
  210.       (multiple-value-bind (x1 y1 x2 y2 ok)
  211.         (epi::clip-to-quad (car line) (cadr line) (third line) (fourth line)
  212.                       l1 l2 l3 l4)
  213.           (when ok
  214.                 (push (list x1 y1 x2 y2) result-line-list)))))
  215.    result-line-list))
  216.