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 / orientation.lisp < prev    next >
Lisp/Scheme  |  1995-04-12  |  4KB  |  111 lines
  1. (in-package 'cme)
  2.  
  3.  
  4. (defvar *tmpvec* (make-coordinate-vector 3))
  5.  
  6. (defun load-mb1 ()
  7.   (load "/home/rcde/RCDE_2.0/radius/model-board-1/mb1.site"))
  8.  
  9. (defun get-2d-image-world (idnum)
  10.   (cme::get-2d-world-named (format nil "MB1-j~d" idnum)))
  11.  
  12.  
  13. (defun get-proj-matrix (world2d)
  14.    (ic::3d-to-2d-projection world2d))
  15.  
  16. (defun mb1-scale (lis)
  17.   (mapcar #'(lambda (p) 
  18.           (list (* (/ 500 12.0) (car p))
  19.             (* (/ 500 12.0) (cadr p))
  20.             (* (/ 500 12.0) (caddr p))))
  21.       lis))
  22.  
  23. (defun project-truth (idnum x y z)
  24.  (let ((proj (3d-to-2d-projection (get-2d-image-world idnum))))
  25.     (setf (aref *tmpvec* 0) (coerce (* x (/ 500 12.0)) 'double-float))
  26.     (setf (aref *tmpvec* 1) (coerce (* y (/ 500 12.)) 'double-float))
  27.     (setf (aref *tmpvec* 2) (coerce (* z (/ 500 12.)) 'double-float))
  28.     (cme::project-vector proj *tmpvec* *tmpvec*)
  29.     (list (aref *tmpvec* 0) (aref *tmpvec* 1))))
  30.  
  31.  
  32. (defun project-point (idnum x y z)
  33.   (let ((proj (3d-to-2d-projection (get-2d-image-world idnum))))
  34.     (setf (aref *tmpvec* 0) (coerce x 'double-float))
  35.     (setf (aref *tmpvec* 1) (coerce y 'double-float))
  36.     (setf (aref *tmpvec* 2) (coerce z 'double-float))
  37.     (cme::project-vector proj *tmpvec* *tmpvec*)
  38.     (list (aref *tmpvec* 0) (aref *tmpvec* 1))))
  39.  
  40. (defun backproject-point (idnum u v)
  41.   (let ((2dworld (get-2d-image-world idnum)))
  42.     (multiple-value-bind (x y z)
  43.        (project-to-world 
  44.           (3d-to-2d-projection 2dworld)
  45.         (coerce u 'double-float)
  46.       (coerce v 'double-float)
  47.           (3d-world 2dworld))
  48.        (list x y z))))
  49.  
  50.  
  51. (defun normalize2 (du dv)
  52.   (let ((len (sqrt (+ (* du du) (* dv dv)))))
  53.     (list (/ du len) (/ dv len))))
  54.  
  55. (defun image-corner-vectors (idnum u v)
  56.   (multiple-value-bind (x y z)
  57.      (values-list (backproject-point idnum u v))
  58.    (multiple-value-bind (ux vx)
  59.        (values-list (project-point idnum (+ 1.0 x) y z))
  60.      (multiple-value-bind (uy vy)
  61.          (values-list (project-point idnum x (+ 1.0 y) z))
  62.        (multiple-value-bind (uz vz)
  63.        (values-list (project-point idnum x y (+ 1.0 z)))
  64.      (list
  65.        (normalize2 (- ux u) (- vx v))
  66.        (normalize2 (- uy u) (- vy v))
  67.        (normalize2 (- uz u) (- vz v))))))))
  68.  
  69. ;;
  70. ;; Added to allow projective camera model from the TEC images.
  71. ;;
  72. ;; Sept. 12, 1994
  73. ;; Christopher Jaynes
  74. ;;
  75. (defun read-tec-projection (header-filename)
  76.   (MAKE-CAMERA-MODEL-FROM-TEC-HEADER
  77.     (read-1993-tec-image-header header-filename)))
  78.  
  79. (defun tec-project-point (projection x y z)
  80.   (setf (aref *tmpvec* 0) (coerce x 'double-float))
  81.   (setf (aref *tmpvec* 1) (coerce y 'double-float))
  82.   (setf (aref *tmpvec* 2) (coerce z 'double-float))
  83.   (cme::project-vector projection *tmpvec* *tmpvec*)
  84.   *tmpvec*)
  85.  
  86. (defun tec-backproject-point (projection u v zvalue)
  87.     (multiple-value-bind (x y z)
  88.        (project-to-world
  89.           projection
  90.           (coerce u 'double-float)
  91.           (coerce v 'double-float)
  92.           zvalue)
  93.   (setf (aref *tmpvec* 0) (coerce x 'double-float))
  94.   (setf (aref *tmpvec* 1) (coerce y 'double-float))
  95.   (setf (aref *tmpvec* 2) (coerce z 'double-float))
  96.        *tmpvec*))
  97.  
  98. (defun tec-image-corner-vectors (projection u v nominal-z-value )
  99.   (multiple-value-bind (x y z)
  100.      (values-list (tec-backproject-point projection u v nominal-z-value))
  101.    (multiple-value-bind (ux vx)
  102.        (values-list (tec-project-point projection (+ 1.0 x) y z))
  103.      (multiple-value-bind (uy vy)
  104.          (values-list (tec-project-point projection x (+ 1.0 y) z))
  105.        (multiple-value-bind (uz vz)
  106.            (values-list (tec-project-point projection x y (+ 1.0 z)))
  107.          (list
  108.            (normalize2 (- ux u) (- vx v))
  109.            (normalize2 (- uy u) (- vy v))
  110.            (normalize2 (- uz u) (- vz v))))))))
  111.