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 >
Lisp/Scheme  |  1996-04-25  |  4KB  |  122 lines
  1. ;;; hypothesis-arbitration.lisp
  2. ;;; Arbitrate among alternative 3D hypotheses for the same building
  3. ;;;
  4. ;;; Author: Bob Collins  Date: Mon Feb 26 13:50:23 EST 1996
  5. ;;; Copyright: University of Massachusetts, 1996, all rights reserved
  6.  
  7. (in-package 'cme)
  8.  
  9. (defun face-min-zvalue (face)
  10.   (apply #'min
  11.      (mapcar #'(lambda (v) (elt v 2)) 
  12.          (cme::object-face-vertices face))))
  13.  
  14. (defun face-with-max-min-zvalue (object &optional (ignore-i -1))
  15.   (let ((minvals nil)
  16.     (facearray (cme::faces object)))
  17.     (dotimes (i (length facearray))
  18.       (push (face-min-zvalue (elt facearray i)) minvals))
  19.     (setf minvals (nreverse minvals))
  20.     (let* ((imax (if (zerop ignore-i) 1 0))
  21.        (maxval (elt minvals imax)))
  22.       (dotimes (i (length minvals))
  23.     (when (and (> (elt minvals i) maxval)
  24.            (not (= i ignore-i)))
  25.           (setf maxval (elt minvals i) imax i)))
  26.       (values (elt facearray imax) imax))))
  27.  
  28.  
  29. (defvar *%%tmp-4d-vector%%* (cme::make-coordinate-vector 4))
  30.  
  31. (defun object-verts-to-world-verts (object vertlist)
  32.   (let ((trans (cme::object-to-world-transform object)))
  33.     (mapcar #'(lambda (vert)
  34.         (cme::bind-vector-elements 
  35.                  (x y z)(cme::transform-vector trans vert *%%tmp-4d-vector%%*)
  36.            (list x y z)))
  37.         vertlist)))
  38.  
  39. (defun face-to-polygon (object face)
  40.   (object-verts-to-world-verts object (cme::object-face-vertices face)))
  41.  
  42. (defun house-roof-faces (house-object)
  43.   (multiple-value-bind (roof1 index) (face-with-max-min-zvalue house-object)
  44.     (let ((roof2 (face-with-max-min-zvalue house-object index)))
  45.       (list roof1 roof2))))
  46.  
  47. (defun extract-object-roof-polygon (object)
  48.   "Returns a list of polygon vertices (3D world pts)."
  49.   (let ((poly (ic::get-prop object :roof-polygon)))
  50.     (unless poly
  51.       (setf poly 
  52.      (ecase (type-of object)
  53.         (cme::cube-object 
  54.          (face-to-polygon object (face-with-max-min-zvalue object)))
  55.         (cme::house-object  
  56. ;; not sure what to do, since a house object has 2 roof polygons 
  57. ;;       (mapcar #'(lambda (f) (face-to-polygon object f))
  58. ;;           (house-roof-faces object)))
  59.          nil)
  60.         (cme::extruded-object 
  61.          (face-to-polygon object (face-with-max-min-zvalue object)))))
  62.       (ic::put-prop object poly :roof-polygon))
  63.     poly))
  64.  
  65.  
  66. (defun competing-hypotheses-aux (poly1 poly2 &optional (threshold 0.8))
  67.   (let ((intersect-area (cg::polygon-intersection-area poly1 poly2)))
  68.     (unless (or (zerop intersect-area)
  69.         (badpoly poly1) 
  70.         (badpoly poly2))
  71.       (let ((overlap1 nil) (overlap2 nil))
  72.     (when (and (> (setf overlap1 (/ intersect-area (cg::polygon-area poly1)))
  73.               threshold)
  74.            (> (setf overlap2 (/ intersect-area (cg::polygon-area poly2)))
  75.               threshold))
  76.           (+ overlap1 overlap2))))))
  77.         
  78. (defun competing-hypotheses (polygon feature-set &optional (threshold 0.8))
  79.   (mapcan #'(lambda (obj)
  80.           (let* ((roof (extract-object-roof-polygon obj))
  81.              (compval (competing-hypotheses-aux polygon roof threshold)))
  82.         (when compval
  83.               (list (list compval obj)))))
  84.       (inferiors feature-set)))
  85.  
  86. (defun badpoly (poly)
  87.      (if (eq (length poly) 0)
  88.        nil
  89.        (let ((front (car poly)))
  90.        (write front)
  91.      (terpri)
  92.          (if (or (null (car front)) (null (second front)) (null (third front)))
  93.        t
  94.        (badpoly (cdr poly))))))
  95.  
  96.  
  97.  
  98. #|
  99. (defun cl (&optional (all nil))
  100.   (when all
  101.     (load (compile-file "UMass/Arbitrate/compgeom.lisp")))
  102.   (load (compile-file "UMass/Arbitrate/hypothesis-arbitration.lisp")))
  103.  
  104.  
  105. (defun test-break-polygon (curve fs &optional (verts nil))
  106.   (let* ((verts (or verts (cme::make-vertex-list-from-vertex-array (cme::vertices curve))))
  107.      (triangles (break-polygon-into-triangles verts))
  108.      (trans (cme::object-to-world-transform curve)))
  109.     (format t "curve broken into ~d triangles~%" (length triangles))
  110.     (dolist (tri triangles triangles)
  111.        (cme::add-object 
  112.        (cme::make-2d-curve
  113.          :vertices (cme::make-vertex-array-from-vertex-list tri)
  114.          :closed-p t
  115.          :world (cme::world fs)
  116.          :object-to-world-transform trans)
  117.       fs))))
  118.  
  119. (defun cme::foo (c &optional v) (test-break-polygon c cme::testfs v))
  120.  
  121. |#
  122.