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
/
LineFinder
/
topdown-line-finder.lisp
< prev
Wrap
Lisp/Scheme
|
1996-03-05
|
16KB
|
432 lines
;;; topdown-line-finder.lisp
;;; find lines with a particular orientation, in an image subarea
;;;
;;; relies on routines in RCDE for computing canny edges
;;; relies on routines in ISR2 for computing connected components
;;;
;;; Author: Bob Collins Date: 7/5/95
;;; Copyright: University of Massachusetts, 1995, all rights reserved
;;;
;;; Modifications:
;;; Bob Collins Tue Nov 7 14:43:31 EST 1995
;;; Changed transform-2d-bounding-box to work correctly for transforms
;;; that rotate the image (actually, I have changed it so it will work
;;; form arbitary transforms). It now explicitly transforms all four
;;; corners of the old bounding box, then computes a new bounding box
;;; that circumscribes this quadrilateral. Added function
;;; transform-2d-angle for the same reason.
(in-package 'cme)
(defstruct edgeimg
(image nil) ;subimage for which edges were computed
(bit nil) ;binary image containing on/off edges
(gradx nil) ;x component of gradient
(grady nil) ;y component of gradient
(mag nil) ;magnitude of gradient
(filtered nil)) ;temp space for filtered canny edgels
;;;=============================================================================
;;; CANNY EDGE DETECTION
;;;the following is a rewrite of canny-edges from $CMEHOME/ic/canny.lisp
;;;in order to return the images I want.
(in-package 'canny)
(defvar *mask-size* 4 "size of canny mask")
(defvar *low-threshold* 1.0 "canny low threshold")
(defvar *high-threshold* 4.0 "canny high threshold")
(defun cme::extract-canny-edges-and-grads (image &key
(mask-size *mask-size*)
(lo-threshold *low-threshold*)
(hi-threshold *high-threshold*))
" Returns in a structure the canny edges, the x components of
the gradient vector, the y components of the gradient vector,
and the gradient magnitudes."
(multiple-value-bind (x-image y-image mag-image smooth)
(grads-phase image mask-size)
(ic::unmake-image smooth)
(let ((edges (nms-phase x-image y-image mag-image
lo-threshold hi-threshold)))
(cme::make-edgeimg
:image image
:bit edges
:gradx x-image
:grady y-image
:mag mag-image
:filtered nil))))
(in-package 'cme)
;;;=============================================================================
;;; FREE UP IMAGE MEMORY
(defun free-edgeimg (edges)
(when edges
(when (edgeimg-image edges) (ic::unmake-image (edgeimg-image edges)))
(when (edgeimg-bit edges) (ic::unmake-image (edgeimg-bit edges)))
(when (edgeimg-gradx edges) (ic::unmake-image (edgeimg-gradx edges)))
(when (edgeimg-grady edges) (ic::unmake-image (edgeimg-grady edges)))
(when (edgeimg-mag edges) (ic::unmake-image (edgeimg-mag edges)))
(when (edgeimg-filtered edges) (ic::unmake-image (edgeimg-filtered edges))))
edges)
;;;=============================================================================
;;; THRESHOLDING EDGES BASED ON ORIENTATION
(defun filter-edges-by-orientation (edges mean-grad-angle
&key (delta-angle 20) (directional? nil)
(startx 0)(starty 0)
(endx (1- (image-x-dim (edgeimg-bit edges))))
(endy (1- (image-y-dim (edgeimg-bit edges)))))
"Returns a new binary edge image that only contains edges passing an orientation
test, namely they gradient at that pixel must fall within delta-angle degrees of
mean-grad-angle. Normally we filter on unsigned orientations, so that all
angles are considered to be (mod angle 180), however if directional-p? is
nonnil, all angles will be considered to be (mod angle 360). Input is a
structure of type edgeimg, output is a binary image."
(let ((edgebits (edgeimg-bit edges))
(gradx (edgeimg-gradx edges))
(grady (edgeimg-grady edges))
(gradmag (edgeimg-mag edges))
(filtered-edges (edgeimg-filtered edges)))
(unless filtered-edges
(setf filtered-edges (ic::similar-image edgebits))
(setf (edgeimg-filtered edges) filtered-edges))
(setf startx (max 0 startx) starty (max 0 starty)
endx (min (1- (image-x-dim edgebits)) endx)
endy (min (1- (image-y-dim edgebits)) endy))
(flet ((deg2rad (deg) (/ (* deg pi) 180.0)))
(setf mean-grad-angle (deg2rad mean-grad-angle))
(setf delta-angle (deg2rad delta-angle))
(let ((unit-mean-x (cos mean-grad-angle))
(unit-mean-y (sin mean-grad-angle))
(cosdelta (cos (abs delta-angle))))
(do ((y starty (1+ y)))
((> y endy) nil)
(do ((x startx (1+ x)))
((> x endx) nil)
(setf (iref filtered-edges x y)
(if (= (iref edgebits x y) 1)
(let* ((mag (iref gradmag x y))
(unit-x (/ (iref gradx x y) mag))
(unit-y (/ (iref grady x y) mag))
(cosangle (+ (* unit-x unit-mean-x)
(* unit-y unit-mean-y))))
(if (< (if directional? cosangle (abs cosangle))
cosdelta)
0
1))
0))))))
filtered-edges))
;;;=========================================================================
;;; CONNECTED COMPONENTS
;;; the following functions use code in $CME/code/UMass/ISR/
;;; for generating line adjacency graphs.
(defun construct-edgel-lag (edgeimage startx starty endx endy 8-connect?)
"Construct a line adjacency graph of the edgels."
(let ((lag (isr2::make-lag 0 (- endy starty -1))))
(do ((y starty (1+ y))
(in-segment nil nil)
(segment-start))
((> y endy) nil)
(do ((x startx (1+ x)))
((> x endx) nil)
(cond
((and in-segment (zerop (iref edgeimage x y)))
(if 8-connect?
(isr2::enter-8-connected-segment-into-lag
lag (- y starty) segment-start (1- x))
(isr2::enter-4-connected-segment-into-lag
lag (- y starty) segment-start (1- x)))
(setf in-segment nil))
((and (not in-segment) (= (iref edgeimage x y) 1))
(setf segment-start x)
(setf in-segment t))
(t nil)))
(when in-segment
(if 8-connect?
(isr2::enter-8-connected-segment-into-lag
lag (- y starty) segment-start endx)
(isr2::enter-4-connected-segment-into-lag
lag (- y starty) segment-start endx))))
lag))
(defun extract-edgel-chains (edgeimage &key (8-connect? t) (size-thresh 3)
(startx 0)(starty 0)
(endx (1- (image-x-dim edgeimage)))
(endy (1- (image-y-dim edgeimage))))
"Extract edgel chains from edge image via connected components."
(setf startx (max 0 startx) starty (max 0 starty)
endx (min (1- (image-x-dim edgeimage)) endx)
endy (min (1- (image-y-dim edgeimage)) endy))
(unless (or (> startx endx) (> starty endy))
(let ((lag (construct-edgel-lag edgeimage
startx starty endx endy 8-connect?))
(list-of-chains nil)
(pixlist nil))
(isr2::clear-lag-segment-marks lag)
(isr2::for-each-unmarked-lag-segment (lag ycoord segment)
(setf pixlist nil)
(isr2::mark-each-connected-segment
segment ycoord
:function
#'(lambda (segment y)
(do ((x (isr2::segment-entry-startx segment) (1+ x)))
((> x (isr2::segment-entry-endx segment)))
(push (list x (+ y starty)) pixlist))))
(when (> (length pixlist) size-thresh)
(push pixlist list-of-chains)))
list-of-chains)))
;;;=========================================================================
;;; LINE FITTING TO A SET OF EDGELS -- SIMPLE LEAST-SQUARES
(defun max-unit-eigenvector (a b c)
" Returns x and y components of the unit eigenvector associated
with the largest eigenvalue of symmetric matrix ((a b)(b c))"
(if (zerop b)
(if (<= a c)
(values 0.0 1.0)
(values 1.0 0.0))
;;the following calculation is based on an article by T. A. Newton in
;;the Jan 1990 issue of the American Mathematical Monthly.
(let* ((me (/ (- c a) b))
(m (if (minusp b)
(/ (+ me (sqrt (+ (* me me) 4.0))) 2.0)
(/ (- me (sqrt (+ (* me me) 4.0))) 2.0)))
(mag (sqrt (+ (* m m) 1.0))))
(values (/ m mag) (- (/ 1.0 mag))))))
#|
(defun eigen-2by2 (a b c)
" Eigendecomposition of a 2 by 2 symmetric matrix ((a b)(b c)).
Multiple values returned are max eigenvalue, min eigenvalue,
x component of max unit eigenvector, y component of max unit eigenvector."
(let* ((trace (+ a c))
(det (- (* a c) (* b b)))
(temp (sqrt (- (* trace trace) (* 4 det))))
(eigmax (/ (+ trace temp) 2))
(eigmin (/ (- trace temp) 2))
(dely (- eigmax a))
(delx b)
(norm (sqrt (+ (* delx delx) (* dely dely)))))
(if (zerop delx)
(values eigmax eigmin 1 0)
(values eigmax eigmin (/ delx norm) (/ dely norm)))))
|#
(defun fit-line-to-pixlist (pixlist &key (pixextension 1.0))
"Least squares fitting of a line segment to a list of pixels coordinates."
(let ((xsum 0)(ysum 0)
(numsamples (length pixlist)))
(dolist (xypair pixlist)
(incf xsum (first xypair))
(incf ysum (second xypair)))
(let ((xmean (/ xsum (float numsamples)))
(ymean (/ ysum (float numsamples)))
(xx 0.0)(xy 0.0)(yy 0.0))
(dolist (xypair pixlist)
(let ((x (- (first xypair) xmean))
(y (- (second xypair) ymean)))
(incf xx (* x x))
(incf xy (* x y))
(incf yy (* y y))))
(multiple-value-bind (ux uy) (max-unit-eigenvector xx xy yy)
(let ((minproj 999999.9)(maxproj -999999.9))
(mapcar #'(lambda (xy)
(let ((proj (+ (* ux (- (car xy) xmean))
(* uy (- (cadr xy) ymean)))))
(when (< proj minproj) (setf minproj proj))
(when (> proj maxproj) (setf maxproj proj))))
pixlist)
(incf minproj (* (signum minproj) pixextension))
(incf maxproj (* (signum maxproj) pixextension))
(list (+ xmean (* minproj ux) 0.5)
(+ ymean (* minproj uy) 0.5)
(+ xmean (* maxproj ux) 0.5)
(+ ymean (* maxproj uy) 0.5)))))))
(defun transform-linelist-coordinates (linelist transform)
(mapcar #'(lambda (endpts)
(bind-vector-elements
(u1 v1)(isr2rcde-inline-transform
transform (list (car endpts) (cadr endpts)))
(bind-vector-elements
(u2 v2)(isr2rcde-inline-transform
transform (list (third endpts) (fourth endpts)))
(list u1 v1 u2 v2))))
linelist))
;;;=========================================================================
;;; FIND ORIENTED LINE SEGMENT FEATURES
(defun transform-2d-bounding-box (transform x1 y1 x2 y2)
(bind-vector-elements
(u1 v1)(isr2rcde-inline-transform transform (list x1 y1))
(bind-vector-elements
(u2 v2)(isr2rcde-inline-transform transform (list x2 y2))
(bind-vector-elements
(u3 v3)(isr2rcde-inline-transform transform (list x2 y1))
(bind-vector-elements
(u4 v4)(isr2rcde-inline-transform transform (list x1 y2))
(values (min u1 u2 u3 u4)
(min v1 v2 v3 v4)
(max u1 u2 u3 u4)
(max v1 v2 v3 v4)))))))
(defun transform-2d-angle (transform x y angle-degrees)
(let ((rad (radians angle-degrees)))
(let ((x1 x)
(y1 y)
(x2 (+ x (cos rad)))
(y2 (+ y (sin rad))))
(bind-vector-elements
(u1 v1)(isr2rcde-inline-transform transform (list x1 y1))
(bind-vector-elements
(u2 v2)(isr2rcde-inline-transform transform (list x2 y2))
(degrees (atan (- v2 v1) (- u2 u1))))))))
(defun transform-2dworld-bounding-box (image startx starty endx endy)
(let ((transform (inverse-transform (image-to-2d-transform image))))
(multiple-value-bind (u1 v1 u2 v2)
(transform-2d-bounding-box transform startx starty endx endy)
(values (floor u1) (floor v1) (ceiling u2) (ceiling v2)))))
(defun transform-2dworld-angle (image x y angle-degrees)
(let ((transform (inverse-transform (image-to-2d-transform image))))
(transform-2d-angle transform x y angle-degrees)))
(defun compute-2dworld-canny-edges (image startx starty endx endy
&key (mask-size canny::*mask-size*)
(lo-threshold canny::*low-threshold*)
(hi-threshold canny::*high-threshold*))
" Compute canny edges for the given image within bounding box
startx starty endx endy, specified in 2d-world coordinates."
(let ((x1 (min startx endx))
(x2 (max startx endx))
(y1 (min starty endy))
(y2 (max starty endy)))
(multiple-value-bind (u1 v1 u2 v2)
(transform-2dworld-bounding-box image x1 y1 x2 y2)
(unless (or (< u2 0) (< v2 0)
(>= u1 (image-x-dim image))
(>= v1 (image-y-dim image)))
(let* ((halfsize (1+ (ash mask-size -1)))
(subimage (ic::image-window image
(- u1 halfsize) (- v1 halfsize)
(+ (- u2 u1 -1) (* 2 halfsize) 1)
(+ (- v2 v1 -1) (* 2 halfsize) 1))))
(extract-canny-edges-and-grads
subimage
:mask-size mask-size
:lo-threshold lo-threshold
:hi-threshold hi-threshold))))))
(defun compute-imageuv-canny-edges (image startu startv endu endv
&key (mask-size canny::*mask-size*)
(lo-threshold canny::*low-threshold*)
(hi-threshold canny::*high-threshold*))
" Compute canny edges for the given image within bounding box
startx starty endx endy, specified in 2d-world coordinates."
(let ((u1 (min startu endu))
(u2 (max startu endu))
(v1 (min startv endv))
(v2 (max startv endv)))
(unless (or (< u2 0) (< v2 0)
(>= u1 (image-x-dim image))
(>= v1 (image-y-dim image)))
(let* ((halfsize (1+ (ash mask-size -1)))
(subimage (ic::image-window image
(- u1 halfsize) (- v1 halfsize)
(+ (- u2 u1 -1) (* 2 halfsize) 1)
(+ (- v2 v1 -1) (* 2 halfsize) 1))))
(extract-canny-edges-and-grads
subimage
:mask-size mask-size
:lo-threshold lo-threshold
:hi-threshold hi-threshold)))))
(defun find-oriented-2dworld-lines (edges orientation startx starty endx endy)
" Edges are computed previously, for example by compute-2dworld-canny-edges.
Note: bounding box startx starty endx endy is given in 2d-world coordinates."
(when edges
(let ((image (edgeimg-image edges)))
(multiple-value-bind (u1 v1 u2 v2)
(transform-2dworld-bounding-box image startx starty endx endy)
(setf orientation (transform-2dworld-angle image startx starty orientation))
(let* ((filtered (filter-edges-by-orientation edges (+ 90.0 orientation)
:startx u1 :starty v1
:endx u2 :endy v2))
(chains (extract-edgel-chains filtered
:startx u1 :starty v1
:endx u2 :endy v2))
(lines (mapcar #'fit-line-to-pixlist chains)))
(transform-linelist-coordinates
lines (image-to-2d-transform image)))))))
(defun put-lines-in-fs (linelist image-or-view fs)
(mapc #'(lambda (endpts)
(add-object
(make-2d-curve
:vertices (make-vertex-array-from-vertex-list
;(list (list (car endpts) (cadr endpts) 0.0)
; (list (third endpts) (fourth endpts) 0.0)))
(list (list (car endpts) (cadr endpts) 0.0)
(list (third endpts) (fourth endpts) 0.0)))
:closed-p t
:world (2d-world image-or-view))
fs))
linelist)
fs)
(defun put-2.5d-lines-in-fs (linelist image-or-view fs)
(let ((trans (3d-to-2d-projection (2d-world image-or-view))))
(mapc #'(lambda (line)
(let ((x1y1 (epi::backproject-point
trans (car line) (cadr line) (fifth line)))
(x2y2 (epi::backproject-point
trans (third line) (fourth line) (fifth line))))
(add-object
(make-3d-curve
:vertices
(make-vertex-array-from-vertex-list
(list (list (car x1y1) (cadr x1y1) (fifth line))
(list (car x2y2) (cadr x2y2) (fifth line))))
:closed-p t
:world (3d-world image-or-view))
fs)))
linelist)
fs))
#|
(progn
(setf pane1 (ic::get-pane-named "pane-0-0"))
(setf pane2 (ic::get-pane-named "pane-1-0"))
(setf pane3 (ic::get-pane-named "pane-0-1"))
(setf pane4 (ic::get-pane-named "pane-1-1")))
(defun testlines (image fs orientation startx starty endx endy)
(put-lines-in-fs
(find-oriented-lines image orientation
:startx startx :starty starty :endx endx :endy endy)
image fs))
|#
#|
(defun cle ()
(load (compile-file "/home/colossus/rcollins/topdown-line-finder")))
|#