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 / episearch.lisp < prev    next >
Lisp/Scheme  |  1996-04-24  |  19KB  |  501 lines
  1. ;; EPISEARCH.LISP
  2. ;;;
  3. ;;; Forming and searching epipolar regions for compatible lines
  4. ;;;
  5. ;;; Author: Robert T. Collins
  6. ;;; Date: Mar 1, 1995
  7. ;;; based on my earlier epipolar.lisp, written Dec 28, 1993
  8. ;;;
  9. ;-----------------------------------------------------------------
  10. ; (c) Copyright 1995 by The University of Massachusetts
  11. ;------------------------------------------------------------------
  12.  
  13. (in-package 'epipolar :nicknames '(epi))
  14.  
  15.  
  16. ;;;;****************************************************************
  17. ;;;; READING LINE DATA AND FORMING SPATIAL ACCESS GRIDS
  18.  
  19. (defun read-raw-data-lines-rc (tksname numrows numcols label filename
  20.         &optional (directory "/home/vidi/vis_radius_common/Boldt/"))
  21.   "  Read an ascii file of data lines in row1 col1 row2 col2 contrast
  22.   format, and create an isr2 tokenset in x1 y1 x2 y2 contrast format.
  23.   Numrows and numcols specify the pixel height and width of the image."
  24.   (with-open-file (file (format nil "~a~a" directory filename) :direction :input)
  25.     (isr2:create tksname 
  26.     :token-features 
  27.         '((x1 "" :real) (y1 "" :real)
  28.           (x2 "" :real) (y2 "" :real)
  29.           (contrast "" :real))
  30.     :frame-features
  31.         '((numrows "" :integer) (numcols "" :integer)
  32.           (label "" :string)))
  33.     (setf (isr2:value (isr2:handle (list tksname 'numrows))) (round numrows))
  34.     (setf (isr2:value (isr2:handle (list tksname 'numcols))) (round numcols))
  35.     (setf (isr2:value (isr2:handle (list tksname 'label))) label)    
  36.     (do ((row1 (read file nil :eof) (read file nil :eof)))
  37.     ((eq row1 :eof) tksname)
  38.       (let ((col1 (read file))
  39.         (row2 (read file))
  40.         (col2 (read file))
  41.         (contrast (read file)))
  42.     (let ((newtok (isr2:create-new-token tksname)))
  43.       (setf (isr2:value (list newtok 'x1)) 
  44.         (coerce col1 'single-float))
  45.       (setf (isr2:value (list newtok 'y1)) 
  46.         (coerce (- numrows row1) 'single-float))
  47.       (setf (isr2:value (list newtok 'x2))
  48.         (coerce col2 'single-float))
  49.       (setf (isr2:value (list newtok 'y2)) 
  50.         (coerce (- numrows row2) 'single-float))
  51.       (setf (isr2:value (list newtok 'contrast)) 
  52.         (coerce contrast 'single-float)))))))
  53.  
  54. (defun compute-line-tokenset-bounding-box (tksname)
  55.   (let ((minx 99999999.9) (miny 99999999.9)
  56.     (maxx -99999999.9) (maxy -99999999.9))
  57.     (isr2::for-every-token (ignore tksname (x1 y1 x2 y2))
  58.       (let ((vx1 (isr2::value x1)) (vy1 (isr2::value y1))
  59.         (vx2 (isr2::value x2)) (vy2 (isr2::value y2)))
  60.     (setf minx (min minx vx1 vx2))
  61.     (setf miny (min miny vy1 vy2))
  62.            (setf maxx (max maxx vx1 vx2))
  63.            (setf maxy (max maxy vy1 vy2))))
  64.     (values minx miny maxx maxy)))
  65.  
  66. (defun gridify-data-lines (tksname &key (rowbuckets 10) (colbuckets 10))
  67.   "Store lines in a grid structure for fast spatial access."
  68. ;;note: I'm calling make-grid with cols and rows switched, because 
  69. ;;later I will access it using (x y) pairs rather than (row col) pairs.
  70.   (multiple-value-bind (minx miny maxx maxy) 
  71.      (compute-line-tokenset-bounding-box tksname)
  72.      (let* ((numcols (- maxx minx))
  73.         (numrows (- maxy miny))
  74.         (colsize (ceiling numcols colbuckets))
  75.         (rowsize (ceiling numrows rowbuckets))
  76.         (grid (isr2::make-grid 
  77.            tksname
  78.            minx maxx colsize
  79.            miny maxy rowsize))
  80.         (gss (isr2::grid-gss grid)))
  81.        (isr2:for-every-token (tok tksname (x1 y1 x2 y2))
  82.      (isr2::grid-unselect gss)
  83.      (isr2::rasterize-line gss (isr2:value x1) (isr2:value y1)
  84.                    (isr2:value x2) (isr2:value y2) nil)
  85.      (isr2::grid-store gss (isr2::copy-handle tok)))
  86.        grid)))
  87.  
  88.  
  89. ;;;;****************************************************************
  90. ;;;; CLIPPING LINES INSIDE A QUADRILATERAL
  91.  
  92.  
  93. (defsubst ccw-p (x1 y1 x2 y2 x3 y3)
  94.   "  Returns T iff (x1,y1)-(x2,y2)-(x3,y3)-(x1,y1) is a counterclockwise 
  95.   walk, NIL otherwise."
  96. ;;;;Note: computed by taking the determinant of the matrix
  97. ;;;;   x1 y1 1 
  98. ;;;;   x2 y2 1 
  99. ;;;;   x3 y3 1 
  100. ;;;;The determinant is positive iff p1-p2-p3 form a CCW cycle.
  101.   (plusp (+ (* x1 (- y2 y3)) 
  102.         (* y1 (- x3 x2)) 
  103.         (- (* x2 y3) (* y2 x3)))))
  104.  
  105. (defun clip-to-quad-init (pt1 pt2 pt3 pt4)
  106.   "  Initialize the four homogeneous coordinate line vectors in the form 
  107.   needed by clip-to-quad-aux.  The given points must represent a walk around
  108.   the quadrilateral."
  109.   (unless (apply #'ccw-p (append pt1 pt2 pt3))
  110.     (rotatef pt1 pt2)
  111.     (rotatef pt3 pt4))
  112.   (values (endpoints-to-line pt1 pt2)  ;\
  113.       (endpoints-to-line pt2 pt3)  ; \ a CCW walk around the quadrilateral
  114.       (endpoints-to-line pt3 pt4)  ; /
  115.       (endpoints-to-line pt4 pt1)  ;/
  116.       ))
  117.  
  118. (defconstant topclipcode 8)
  119. (defconstant botclipcode 4)
  120. (defconstant rightclipcode 2)
  121. (defconstant leftclipcode 1)
  122.  
  123. (defsubst clip-to-quad-outcodes (x y top left bot right)
  124.   (let ((vec (list x y 1.0))) 
  125.     (+
  126.       (if (minusp (la:dot-product top vec)) topclipcode 0)
  127.       (if (minusp (la:dot-product bot vec)) botclipcode 0)
  128.       (if (minusp (la:dot-product right vec)) rightclipcode 0)
  129.       (if (minusp (la:dot-product left vec)) leftclipcode 0))))
  130.  
  131. (defsubst clip-to-quad-line-intersect (line clipline)
  132.   (let ((nvec (la:cross-product line clipline)))
  133.     (when (zerop (third nvec))
  134.        (setf nvec (list (car nvec) (cadr nvec) 0.000001)))
  135.     (nvec-to-pt-values (la:cross-product line clipline))))
  136.  
  137.  
  138. (defsubst clip-to-quad-reject-check (outcode1 outcode2)
  139.   (not (zerop (logand outcode1 outcode2))))
  140.  
  141. (defsubst clip-to-quad-accept-check (outcode1 outcode2)
  142.   (and (zerop outcode1) (zerop outcode2)))
  143.  
  144.  
  145. (defun clip-to-quad (x1 y1 x2 y2 top left bot right
  146.             &key (ignorecode1 0) (ignorecode2 0)) 
  147.   "  Clip line x1 y1 x2 y2 to a quadrilateral defined by 
  148.   homogeneous coordinate lines top,left,bot,right which are 
  149.   calculated by clip-to-quad-init."
  150.   (let ((accept nil) (reject nil) 
  151.     (line (endpoints-to-line (list x1 y1) (list x2 y2))))
  152.     (do ((done nil))
  153.     (done t)  ;;loop until done
  154.       (let ((outcode1 (logandc1
  155.                 ignorecode1
  156.             (clip-to-quad-outcodes x1 y1 top left bot right)))
  157.         (outcode2 (logandc1
  158.                 ignorecode2
  159.             (clip-to-quad-outcodes x2 y2 top left bot right))))
  160.     (setf reject (clip-to-quad-reject-check outcode1 outcode2))
  161.     (if reject
  162.         (setf done t)
  163.         (progn
  164.           (setf accept (clip-to-quad-accept-check outcode1 outcode2))
  165.           (if accept
  166.           (setf done t)
  167.           (progn
  168.             (when (= outcode1 0)
  169.               (rotatef x1 x2)
  170.               (rotatef y1 y2)
  171.               (rotatef outcode1 outcode2)
  172.               (rotatef ignorecode1 ignorecode2))
  173.             (cond
  174.               ((logtest topclipcode outcode1)
  175.                (multiple-value-setq (x1 y1)
  176.               (clip-to-quad-line-intersect line top))
  177.                (incf ignorecode1 topclipcode))
  178.               ((logtest botclipcode outcode1)
  179.                (multiple-value-setq (x1 y1)
  180.               (clip-to-quad-line-intersect line bot))
  181.                (incf ignorecode1 botclipcode))
  182.               ((logtest rightclipcode outcode1)
  183.                (multiple-value-setq (x1 y1)
  184.               (clip-to-quad-line-intersect line right))
  185.                (incf ignorecode1 rightclipcode))
  186.               ((logtest leftclipcode outcode1)
  187.                (multiple-value-setq (x1 y1) 
  188.               (clip-to-quad-line-intersect line left))
  189.                (incf ignorecode1 leftclipcode)))))))))
  190.     (if accept
  191.     (values x1 y1 x2 y2 t)
  192.     (values 0 0 0 0 nil))))
  193.  
  194.  
  195.  
  196. #|
  197.  
  198. (defun test-clip-to-quad (w pt1 pt2 pt3 pt4)
  199.   (declare (special l1 l2 l3 l4))
  200.   (send w :clear)
  201.   (send w :display-line (car pt1) (cadr pt1) (car pt2) (cadr pt2) :color w:black)
  202.   (send w :display-line (car pt2) (cadr pt2) (car pt3) (cadr pt3) :color w:black)
  203.   (send w :display-line (car pt3) (cadr pt3) (car pt4) (cadr pt4) :color w:black)
  204.   (send w :display-line (car pt4) (cadr pt4) (car pt1) (cadr pt1) :color w:black)
  205.   (multiple-value-setq (l1 l2 l3 l4)
  206.     (clip-to-quad-init pt1 pt2 pt3 pt4))
  207.   (loop
  208.    (let ((input (list (random 10.0) (random 10.0) (random 10.0) (random 10.0))))
  209.      (multiple-value-bind (x1 y1 x2 y2 ok)
  210.        (clip-to-quad (car input) (cadr input) (third input) (fourth input)
  211.              l1 l2 l3 l4)
  212.        (when ok
  213.       (send w :display-line x1 y1 x2 y2 :color w:green))))))
  214.  
  215. |#
  216.  
  217.  
  218. ;;;;****************************************************************
  219. ;;;; SEARCHING FOR CANDIDATE EPIPOLAR MATCHES
  220.  
  221. (defun isr-coarse-get-lines-in-quad (grid pt1 pt2 pt3 pt4)
  222.   (let ((gss (isr2::grid-gss grid))
  223.     (linelist nil))
  224.     (isr2::grid-unselect gss)
  225.     (isr2::rasterize-polygon gss (list pt1 pt2 pt3 pt4))
  226.     (let ((candidates (isr2::grid-retrieve gss)))
  227.       (isr2:for-every-token (tok candidates (x1 y1 x2 y2))
  228.     (push (list (isr2:value x1) (isr2:value y1)
  229.             (isr2:value x2) (isr2:value y2))
  230.           linelist)))
  231.     linelist))
  232.  
  233. (defun epipolar-search-area (projection1 projection2 x1 y1 x2 y2
  234.                &optional (zlow *lowz*) (zmid *midz*) (zhigh *highz*))
  235.   "Form the boundaries of an epipolar search region for the given line segment."
  236.   (values (apply #'project-point projection2 
  237.          (backproject-point projection1 x1 y1 zlow))
  238.       (apply #'project-point projection2
  239.          (backproject-point projection1 x2 y2 zlow))
  240.       (apply #'project-point projection2 
  241.          (backproject-point projection1 x1 y1 zmid))
  242.       (apply #'project-point projection2
  243.          (backproject-point projection1 x2 y2 zmid))
  244.       (apply #'project-point projection2
  245.          (backproject-point projection1 x1 y1 zhigh))
  246.       (apply #'project-point projection2
  247.          (backproject-point projection1 x2 y2 zhigh))))
  248.  
  249. (defun epipolar-search-area-bbox (view1 view2 linelist)
  250.   (let ((coordlist (mapcan #'(lambda (line) 
  251.                    (multiple-value-list
  252.                 (apply #'epipolar-search-area 
  253.                        (view-projection view1)
  254.                        (view-projection view2)
  255.                        line)))
  256.                linelist)))
  257.     (let ((minx (reduce #'min coordlist :key #'car))
  258.       (miny (reduce #'min coordlist :key #'cadr))
  259.       (maxx (reduce #'max coordlist :key #'car))
  260.       (maxy (reduce #'max coordlist :key #'cadr)))
  261.       (list minx miny maxx maxy))))
  262.  
  263.  
  264. (defun sloppy-points (pt1 pt2 trueline endpoint-slop)
  265.   (let ((x1 (car pt1))
  266.     (y1 (cadr pt1))
  267.     (x2 (car pt2))
  268.     (y2 (cadr pt2))
  269.     (slopx (* (car trueline) endpoint-slop))
  270.     (slopy (* (cadr trueline) endpoint-slop)))
  271.     (if (minusp (la:dot-product trueline (pt-to-nvec x1 y1)))
  272.     (values
  273.       (list (- x1 slopx) (- y1 slopy))
  274.       (list (+ x2 slopx) (+ y2 slopy)))
  275.     (values
  276.       (list (+ x1 slopx) (+ y1 slopy))
  277.       (list (- x2 slopx) (- y2 slopy))))))
  278.  
  279. (defun cos-line-angle (nvec1 nvec2)
  280.   (abs (la:dot-product (list (car nvec1) (cadr nvec1))
  281.                (list (car nvec2) (cadr nvec2)))))
  282.  
  283. (defun line-length (x1 y1 x2 y2)
  284.   (la:vector-length (list (- x2 x1) (- y2 y1))))
  285.  
  286. ;;based on terms of Taylor series approx to 1/Sqrt(1+4*d*d/l*l)
  287. (defun adjusted-cos-threshold (length pixslop)
  288.   (let ((a (/ (* 4 pixslop pixslop) (* length length))))
  289.     (/ 1.0 (+ 1 (/ a 2.0)))))  
  290.  
  291. ;;;;======================================================================
  292.  
  293. (defun collect-line-candidates (view low1 low2 mid1 mid2 high1 high2
  294.                  &key (deltatheta .1)
  295.                  (relative-length-thresh .25)
  296.                  (endpoint-slop 1) 
  297.                  (clip-to-zrange t)
  298.                  (only-display-matches nil) (zoom t)
  299.                  &allow-other-keys)
  300.   (when (> (la::vector-length (la::v- low1 high1)) 0.0000001)
  301.   (multiple-value-bind (lowline epi2line highline epi1line)
  302.      (clip-to-quad-init low1 low2 high2 high1)
  303.    (let* ((vp (la:unit-normal lowline highline))
  304.       (midline (endpoints-to-line mid1 mid2))
  305.       (candidates nil) (line nil) (candidate-list nil)
  306.       (trueline nil) (relative-len nil)
  307.       (window (view-window view))
  308.       (cos-theta-thresh (cos (abs deltatheta))))
  309.      (multiple-value-bind (sloplow1 slophigh2)
  310.           (sloppy-points low1 high2 midline endpoint-slop)
  311.      (multiple-value-bind (sloplow2 slophigh1)
  312.           (sloppy-points low2 high1 midline endpoint-slop)
  313.      (multiple-value-bind (sloplowline slopepi2line slophighline slopepi1line)
  314.         (clip-to-quad-init sloplow1 sloplow2 slophigh2 slophigh1)
  315.      (setf candidates
  316.     (if *topdown-line-finder*
  317.       (cme::find-oriented-2dworld-lines 
  318.          (view-topdown-edgels view)
  319.          (/ (* (atan (- (cadr mid1) (cadr mid2)) 
  320.              (- (car mid1) (car mid2)))
  321.            180.0) pi)
  322.          (reduce #'min (list low1 low2 high1 high2) :key #'car)
  323.          (reduce #'min (list low1 low2 high1 high2) :key #'cadr)
  324.          (reduce #'max (list low1 low2 high1 high2) :key #'car)
  325.          (reduce #'max (list low1 low2 high1 high2) :key #'cadr))
  326.       (isr-coarse-get-lines-in-quad (view-line-grid view)
  327.               sloplow1 sloplow2 slophigh2 slophigh1)))
  328.      (when (and *demo-mode* window (not only-display-matches))
  329.        (epipolar-display window sloplow1 sloplow2
  330.                  slophigh1 slophigh2 :zoom zoom))
  331.      (setf *candidates* candidates)
  332.      (dolist (endpts candidates)
  333.        (multiple-value-bind (x1 y1 x2 y2) (values-list endpts)
  334.      (multiple-value-bind (clx1 cly1 clx2 cly2 ok?)
  335.            (clip-to-quad x1 y1 x2 y2 sloplowline slopepi2line
  336.                  slophighline slopepi1line)
  337.        (when ok?
  338.         (when (and *demo-mode* window (not only-display-matches))
  339.           (display-line window x1 y1 x2 y2 :color *line-color*
  340.                     :thickness *line-thickness*))
  341.         (when (not clip-to-zrange)
  342.            (multiple-value-setq (clx1 cly1 clx2 cly2)
  343.            (clip-to-quad x1 y1 x2 y2 sloplowline slopepi2line
  344.                  slophighline slopepi1line
  345.                  :ignorecode1 (+ topclipcode botclipcode)
  346.                  :ignorecode2 (+ topclipcode botclipcode))))
  347.         (let ((pt1 (list clx1 cly1))
  348.           (pt2 (list clx2 cly2))
  349.           (midpt (list (/ (+ clx1 clx2) 2.0) (/ (+ cly1 cly2) 2.0))))
  350.           (setf line (endpoints-to-line pt1 pt2))
  351.           (setf trueline (pt-vec-to-line midpt vp))
  352.           (when *debug-mode*
  353.             (format t "Candidate (~,2f ~,2f ~,2f ~,2f)"
  354.                    (car pt1) (cadr pt1) (car pt2) (cadr pt2))
  355.             (format t " cos test ~,3f < ~,3f~%" 
  356.                 cos-theta-thresh (cos-line-angle line trueline)))
  357.           (when (< cos-theta-thresh (cos-line-angle line trueline))
  358.         (setf relative-len 
  359.               (min 1.0
  360.                (/ (line-length clx1 cly1 clx2 cly2)
  361.                   (apply #'line-length
  362.                      (append 
  363.                       (line-intersection-pt trueline epi1line)
  364.                       (line-intersection-pt trueline epi2line))))))
  365.         (when *debug-mode*
  366.               (format t "             relative len test ~,3f >= ~,3f~%" 
  367.                 relative-len relative-length-thresh))
  368.         (when (>= relative-len relative-length-thresh)
  369.            (when (and *demo-mode* window)
  370.               (display-line window clx1 cly1 clx2 cly2
  371.                     :color *match-color*
  372.                     :thickness *match-thickness*))
  373.            (push (list (list pt1 pt2) trueline relative-len)
  374.              candidate-list))))))))
  375.      candidate-list)))))))
  376.  
  377.  
  378.                   
  379. (defun histogram-line-candidates (view1 u1 v1 u2 v2 view2
  380.                   &key (histogram *current-histogram*) 
  381.                   (deltatheta .1)
  382.                   (relative-length-thresh .25)
  383.                   (peak-weight? nil)
  384.                   (lowz *lowz*) (midz *midz*)(highz *highz*)
  385.                   (endpoint-slop 1)
  386.                   (zoom t))
  387.   (multiple-value-bind (low1 low2 mid1 mid2 high1 high2)
  388.      (epipolar-search-area (view-projection view1) (view-projection view2)
  389.                u1 v1 u2 v2 lowz midz highz)
  390.      (when (> (la::vector-length (la::v- low1 high1)) 0.0000001)
  391.      (multiple-value-bind (lowline epi2line highline epi1line)
  392.       (clip-to-quad-init low1 low2 high2 high1)
  393.         (let* ((vp (la:unit-normal lowline highline))
  394.            (midline (endpoints-to-line mid1 mid2))
  395.            (cr-reference-line
  396.            (cr-reference-line lowline epi2line highline epi1line))
  397.            (lowcr (cr-reference-value cr-reference-line lowline))
  398.            (midcr (cr-reference-value cr-reference-line midline))
  399.            (highcr (cr-reference-value cr-reference-line highline))
  400.            (candidate-list nil)
  401.            (expected-len (apply #'line-length
  402.                     (append 
  403.                      (line-intersection-pt midline epi1line)
  404.                      (line-intersection-pt midline epi2line))))
  405.            (deltatheta (max deltatheta
  406.                 (min (atan (/ (* 2.0 endpoint-slop)
  407.                           expected-len))
  408.                      (* 3.0 deltatheta)))))
  409.       (setf candidate-list 
  410.         (collect-line-candidates view2
  411.            low1 low2 mid1 mid2 high1 high2
  412.            :deltatheta deltatheta :endpoint-slop 0
  413.            :relative-length-thresh relative-length-thresh
  414.            :zoom zoom))
  415.       (dolist (candidate candidate-list histogram)
  416.      (let ((pt1 (car (car candidate)))
  417.            (pt2 (cadr (car candidate)))
  418.            (trueline (second candidate))
  419.            (relative-len (third candidate)))
  420.        (multiple-value-setq (pt1 pt2)
  421.            (sloppy-points pt1 pt2 trueline endpoint-slop))
  422.        (let ((zvalue1 (cr-reference-value cr-reference-line
  423.                           (pt-vec-to-line pt1 vp)))
  424.          (zvalue2 (cr-reference-value cr-reference-line
  425.                           (pt-vec-to-line pt2 vp))))
  426.          (multiple-value-bind (lowheight highheight)
  427.          (vote-for-height-range 
  428.             (height-invariant lowcr midcr highcr zvalue1)
  429.             (height-invariant lowcr midcr highcr zvalue2)
  430.             lowz midz highz
  431.             :weight relative-len
  432.             :peak-weight? peak-weight?
  433.             :histogram histogram)
  434.          (when *debug-mode*
  435.                (format t "Line (~,2f ~,2f ~,2f ~,2f)"
  436.                    (car pt1) (cadr pt1) (car pt2) (cadr pt2))
  437.                (format t " votes ~,3f for height range (~,2f,~,2f)~%" 
  438.                    relative-len lowheight highheight)))))
  439.      ))))))
  440.  
  441.  
  442. (defun histogram-linelist-candidates (view1 linelist view2 &rest keys)
  443.   (let ((firstline nil)
  444.     (window (view-window view2)))
  445.     (when (and *demo-mode* window)
  446.       (let ((boundingbox (epipolar-search-area-bbox view1 view2 linelist)))
  447.     (setf firstline t)
  448.     (activate-window window)
  449.     (apply #'cme::zoom-to-bounding-box window boundingbox)))
  450.     (dolist (line linelist)
  451.        (when (and *demo-mode* window (not firstline))
  452.       (activate-window window :refresh t))
  453.        (apply #'histogram-line-candidates
  454.         view1 (first line) (second line) (third line) (fourth line)
  455.         view2
  456.         :zoom nil
  457.         keys)
  458.        (when (and *demo-mode* (eq *pause-mode* :lines))
  459.       (setf firstline nil)
  460. ;;;          (plot-histogram *plot1* *accum-histogram* :max 3)
  461.       (synch-epipolar-screen window)
  462.       (setf *pause-mode* 
  463.          (if (yes-or-no-p "Pause between lines?") :lines :views))))))
  464.  
  465.  
  466. (defun collect-matches (view1 u1 v1 u2 v2 view2
  467.               &rest keys 
  468.               &key (lowz *lowz*) (midz *midz*) (highz *highz*)
  469.               &allow-other-keys)
  470.   (multiple-value-bind (low1 low2 mid1 mid2 high1 high2)
  471.      (epipolar-search-area 
  472.         (view-projection view1)
  473.     (view-projection view2)
  474.     u1 v1 u2 v2 lowz midz highz)
  475.      (let ((match-list (apply #'collect-line-candidates view2
  476.                   low1 low2 mid1 mid2 high1 high2
  477.                   :clip-to-zrange nil
  478.                   :zoom nil
  479.                   keys)))
  480.        (mapcar #'car match-list))))
  481.  
  482. (defun collect-linelist-matches (view1 linelist view2 &rest keys)
  483.   (let ((window (view-window view2)))
  484.     (when (and *demo-mode* window)
  485.       (activate-window window)
  486.       (let ((boundingbox (epipolar-search-area-bbox view1 view2 linelist)))
  487.     (apply #'cme::zoom-to-bounding-box window boundingbox)))
  488.     (let ((match-list nil))
  489.       (dotimes (i (length linelist))
  490.      (let* ((line (elt linelist i))
  491.         (matches
  492.           (apply #'collect-matches
  493.              view1
  494.              (first line) (second line) (third line) (fourth line)
  495.              view2
  496.              keys)))
  497.        (when matches
  498.           (push (list (+ i 1) matches) match-list))))
  499.       match-list)))
  500.  
  501.