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 / model.tar / model-board-1 / camera-models.lisp < prev    next >
Lisp/Scheme  |  1994-04-11  |  2KB  |  81 lines
  1. (in-package 'cme)
  2.  
  3. #|
  4. (user::maybe-compile-file-load "~/cme/radius/model-board-1/camera-models.lisp")
  5.  
  6. |#
  7.  
  8. (defvar *model-units-to-feet* (/ 500.0 12))
  9.  
  10. (defun read-control-points (path)
  11.   (with-open-file (st path)
  12.     (loop for line = (read-line st nil nil)
  13.       while line
  14.       for control-point
  15.         = (let* ((pos 0)
  16.              thing)
  17.         (flet ((read-number (&optional (scale *model-units-to-feet*))
  18.              (multiple-value-setq (thing pos) (read-from-string line nil nil :start pos))
  19.              (and (numberp thing) (* scale thing))))
  20.           (let ((control-point (list (read-number 1) (read-number) (read-number) (read-number)
  21.                          (ic::substring line pos ))))
  22.             (when (cadr control-point)
  23.               control-point))))
  24.       when control-point collect control-point)))
  25.             
  26. (defun get-gcp-with-id (fs id)
  27.   (loop for cp in (inferiors fs)
  28.     when (equal (control-pt-id cp) id)
  29.       return cp))
  30.  
  31. (defun add-control-points-from-table (control-point-list)
  32.   (loop with fs = (or (car (feature-sets *mb1-3d-world*))
  33.               (let ((fs (make-instance '3d-feature-set :name "MB1 GCPs")))
  34.             (add-feature-set fs *mb1-3d-world*)
  35.             fs))
  36.               
  37.     for (id x y z descr) in control-point-list
  38.     for cp = (or (get-gcp-with-id fs id)
  39.              (add-object (make-instance 'conjugate-point-object :x x :y y :z z
  40.                       :world (world fs)
  41.                       :name (format nil "GCP ~d" id)
  42.                       :control-pt-id id
  43.                       )
  44.              
  45.              fs))
  46.     
  47.     do (set-origin cp x y z)
  48.        (setf (get-prop cp :description) descr)
  49.     ))
  50.        
  51. (defun fix-control-pt-ids (fs)
  52.   (loop for cp in (inferiors fs)
  53.     unless (control-pt-id cp)
  54.       do (let ((name (object-name cp)))
  55.            (setf (control-pt-id cp) (read-from-string name nil nil :start 4)))))
  56.  
  57. (defparameter *model-board-1-control-points*
  58.           (read-control-points (merge-model-board-1-pathname "bd1gt.dat")))
  59.  
  60. (setf (get-prop *mb1-3d-world* :control-points) *model-board-1-control-points*)
  61.  
  62.  
  63. #|
  64. (dump-feature-sets (merge-model-board-1-pathname "gcp.fs")
  65.            (feature-sets *mb1-3d-world*))
  66.  
  67. (dump-site *mb1-3d-world* (merge-model-board-1-pathname "mb1.site"))
  68. |#
  69.  
  70. #|
  71. (let ((*2d-world-mapping-alist* '(("2d World j1.g" . "MB1-j1 2d World"))))
  72.   (setf (feature-sets *mb1-3d-world*) (load-feature-sets (merge-model-board-1-pathname "gcp.fs"))))
  73. (setf (feature-sets *mb1-3d-world*) nil)
  74. (fix-control-pt-ids (car (feature-sets *mb1-3d-world*)))
  75. (add-control-points-from-table *model-board-1-control-points*)
  76.  
  77. (load-site (merge-model-board-1-pathname "mb1.site"))
  78. |#
  79.  
  80.          
  81.