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
/
hypothesis-arbitration.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1996-04-25
|
4KB
|
122 lines
;;; hypothesis-arbitration.lisp
;;; Arbitrate among alternative 3D hypotheses for the same building
;;;
;;; Author: Bob Collins Date: Mon Feb 26 13:50:23 EST 1996
;;; Copyright: University of Massachusetts, 1996, all rights reserved
(in-package 'cme)
(defun face-min-zvalue (face)
(apply #'min
(mapcar #'(lambda (v) (elt v 2))
(cme::object-face-vertices face))))
(defun face-with-max-min-zvalue (object &optional (ignore-i -1))
(let ((minvals nil)
(facearray (cme::faces object)))
(dotimes (i (length facearray))
(push (face-min-zvalue (elt facearray i)) minvals))
(setf minvals (nreverse minvals))
(let* ((imax (if (zerop ignore-i) 1 0))
(maxval (elt minvals imax)))
(dotimes (i (length minvals))
(when (and (> (elt minvals i) maxval)
(not (= i ignore-i)))
(setf maxval (elt minvals i) imax i)))
(values (elt facearray imax) imax))))
(defvar *%%tmp-4d-vector%%* (cme::make-coordinate-vector 4))
(defun object-verts-to-world-verts (object vertlist)
(let ((trans (cme::object-to-world-transform object)))
(mapcar #'(lambda (vert)
(cme::bind-vector-elements
(x y z)(cme::transform-vector trans vert *%%tmp-4d-vector%%*)
(list x y z)))
vertlist)))
(defun face-to-polygon (object face)
(object-verts-to-world-verts object (cme::object-face-vertices face)))
(defun house-roof-faces (house-object)
(multiple-value-bind (roof1 index) (face-with-max-min-zvalue house-object)
(let ((roof2 (face-with-max-min-zvalue house-object index)))
(list roof1 roof2))))
(defun extract-object-roof-polygon (object)
"Returns a list of polygon vertices (3D world pts)."
(let ((poly (ic::get-prop object :roof-polygon)))
(unless poly
(setf poly
(ecase (type-of object)
(cme::cube-object
(face-to-polygon object (face-with-max-min-zvalue object)))
(cme::house-object
;; not sure what to do, since a house object has 2 roof polygons
;; (mapcar #'(lambda (f) (face-to-polygon object f))
;; (house-roof-faces object)))
nil)
(cme::extruded-object
(face-to-polygon object (face-with-max-min-zvalue object)))))
(ic::put-prop object poly :roof-polygon))
poly))
(defun competing-hypotheses-aux (poly1 poly2 &optional (threshold 0.8))
(let ((intersect-area (cg::polygon-intersection-area poly1 poly2)))
(unless (or (zerop intersect-area)
(badpoly poly1)
(badpoly poly2))
(let ((overlap1 nil) (overlap2 nil))
(when (and (> (setf overlap1 (/ intersect-area (cg::polygon-area poly1)))
threshold)
(> (setf overlap2 (/ intersect-area (cg::polygon-area poly2)))
threshold))
(+ overlap1 overlap2))))))
(defun competing-hypotheses (polygon feature-set &optional (threshold 0.8))
(mapcan #'(lambda (obj)
(let* ((roof (extract-object-roof-polygon obj))
(compval (competing-hypotheses-aux polygon roof threshold)))
(when compval
(list (list compval obj)))))
(inferiors feature-set)))
(defun badpoly (poly)
(if (eq (length poly) 0)
nil
(let ((front (car poly)))
(write front)
(terpri)
(if (or (null (car front)) (null (second front)) (null (third front)))
t
(badpoly (cdr poly))))))
#|
(defun cl (&optional (all nil))
(when all
(load (compile-file "UMass/Arbitrate/compgeom.lisp")))
(load (compile-file "UMass/Arbitrate/hypothesis-arbitration.lisp")))
(defun test-break-polygon (curve fs &optional (verts nil))
(let* ((verts (or verts (cme::make-vertex-list-from-vertex-array (cme::vertices curve))))
(triangles (break-polygon-into-triangles verts))
(trans (cme::object-to-world-transform curve)))
(format t "curve broken into ~d triangles~%" (length triangles))
(dolist (tri triangles triangles)
(cme::add-object
(cme::make-2d-curve
:vertices (cme::make-vertex-array-from-vertex-list tri)
:closed-p t
:world (cme::world fs)
:object-to-world-transform trans)
fs))))
(defun cme::foo (c &optional v) (test-break-polygon c cme::testfs v))
|#