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 / .#model-board-1.lisp.1.1 < prev    next >
Lisp/Scheme  |  1995-07-24  |  6KB  |  199 lines
  1. (in-package 'cme)
  2.  
  3. #|
  4. (user::maybe-compile-file-load "~/cme/radius/model-board-1/model-board-1.lisp")
  5. |#
  6.  
  7. (defparameter *model-board-1-path* "$CMEHOME/radius/model-board-1/")
  8.  
  9. (ic::ev-pathname-register *model-board-1-path*)
  10.  
  11. (defun merge-model-board-1-pathname (path)
  12.   (ic::ev-pathname-translate (format nil "~a~A" *model-board-1-path* path)))
  13.  
  14. (defparameter *model-board-1-image-path* "$CME/images/radius/model-board-1/")
  15.  
  16. (ic::ev-pathname-register "$CME/images/radius/")
  17.  
  18. (defun merge-model-board-1-image-pathname (path)
  19.   (format nil "~a~A" *model-board-1-image-path* path))
  20.     
  21.  
  22. #|
  23. (proclaim '(special *mb1-j1* *mb1-j2* *mb1-j1* *mb1-j3* *mb1-j4* *mb1-j5* *mb1-j6* *mb1-j7* *mb1-j8*))
  24.  
  25.     
  26. ;;; First Time Only Site Creation
  27.  
  28. ;;; See the file $CMEHOME/radius/model-board-1/camera-models.lisp for control-point setup
  29.  
  30. (defparameter *mb1-3d-world*
  31.           (make-site :name "Radius Model Board 1"
  32.              :units :feet
  33.              :terrain-model (make-phoney-terrain-model -1600.0 -1000.0 40 40 -85.0 100.0)))
  34.  
  35. (setf (get-prop *mb1-3d-world* :terrain-model)
  36.       (make-phoney-terrain-model -1600.0 -1000.0 40 40 -85.0 100.0))
  37.  
  38. ;;; *****************  READING GROUND CONTROL POINTS FILES  *****************
  39. ;;; This is relatively generic,
  40. ;;; Other sites might define control points using the same file format.
  41.  
  42. (defvar *model-units-to-feet* (/ 500.0 12))
  43.  
  44. (defun read-control-points (path)
  45.   (with-open-file (st path)
  46.     (loop for line = (read-line st nil nil)
  47.       while line
  48.       for control-point
  49.         = (let* ((pos 0)
  50.              thing)
  51.         (flet ((read-number (&optional (scale *model-units-to-feet*))
  52.              (multiple-value-setq (thing pos) (read-from-string line nil nil :start pos))
  53.              (and (numberp thing) (* scale thing))))
  54.           (let ((control-point (list (read-number 1) (read-number) (read-number) (read-number)
  55.                          (ic::substring line pos ))))
  56.             (when (cadr control-point)
  57.               control-point))))
  58.       when control-point collect control-point)))
  59.  
  60. (setf (get-prop *mb1-3d-world* :control-points) *mode
  61.       (read-control-points (merge-model-board-1-pathname "bd1gt.dat")))
  62.  
  63. (defparameter *mb1-image-symbol-path-list*
  64.   '((*mb1-j1* "j1.g" "j1" )
  65.     (*mb1-j2* "j2.g" "j2" )
  66.     (*mb1-j3* "j3.g" "j3" )
  67.     (*mb1-j4* "j4.g" "j4" )
  68.     (*mb1-j5* "j5.g" "j5" )
  69.     (*mb1-j6* "j6.g" "j6" )
  70.     (*mb1-j7* "j7.g" "j7" )
  71.     (*mb1-j8* "j8.g" "j8" )))
  72.     
  73. (defun load-mb1-images ()
  74.   (flet ((load-img (path name)
  75.        (let ((image-list
  76.           (ic::load-image-hierarchy (merge-model-board-1-image-pathname path) 0 0)))
  77.          (loop for img in image-list
  78.            do (setf (image-prop img :name) (format nil "MB1-~a" name)))
  79.          (car image-list))))
  80.     (loop for (symbol path name) in *mb1-image-symbol-path-list*
  81.       do (setf (symbol-value symbol) (load-img path name)))
  82.     ))
  83.  
  84. (defun add-image-to-3d-world (image 3d-world )
  85.   (unless (image-prop image :image-to-2d-transform)
  86.     (setf (image-prop image :image-to-2d-transform) (make-coordinate-transform)))
  87.   (let ((image-name (get-prop image :name))
  88.     (2d-world (or (get-prop image :2d-world)
  89.               (make-instance '2d-world
  90.                      :name (format nil "~a 2d World" image-name)
  91.                      :base-image image
  92.                      :3d-world 3d-world ))))      
  93.     (setup-image-worlds image
  94.             :3d-to-2d-projection nil
  95.             :3d-world 3d-world
  96.             :2d-world 2d-world
  97.             )
  98.     image ))
  99.  
  100. (loop for (symbol) in *mb1-image-symbol-path-list*
  101.       do (add-image-to-3d-world (symbol-value symbol)
  102.                 (get-3d-world-named "Radius Model Board 1") ))
  103.  
  104.  
  105. ;;; TO DEMONSTRATE CAMERA MODEL SETUP::
  106.  
  107. (add-image-to-3d-world (ic::copy-image *mb1-j8*) (get-3d-world-named "Radius Model Board 1"))
  108. (let ((image (ic::copy-image *)))
  109.   (setf (get-prop image :name) "j8b")
  110.   (add-image-to-3d-world image (get-3d-world-named "Radius Model Board 1"))
  111.   image)
  112.  
  113. |#
  114.  
  115.  
  116. #|
  117. (defvar *mb1-3d-world* nil)
  118. (defvar *mb1-cme-frame* nil)
  119.  
  120. (defun start-mb1-cme ()
  121.   (unless (and (boundp '*mb1-cme-frame*) *mb1-cme-frame*)
  122.     (initialize-cme)
  123.     (setq *mb1-cme-frame* (make-cme-frame "Model Board 1 2x2"))
  124.     )
  125.   (unless *mb1-3d-world*
  126.     (setq *mb1-3d-world* (load-site (merge-model-board-1-pathname "mb1.site"))))
  127.   (get-site-images *mb1-3d-world* *mb1-cme-frame*)
  128.   (unless ic::*inside-repl*
  129.     (ic::force-read-form '(in-package 'cme))
  130.     (ic::repl))
  131.   )
  132. |#
  133.  
  134. ;;(start-mb1-cme)
  135.  
  136. #|
  137. (start-mb1-cme) ;;; ***************
  138.  
  139. (setq *mb1-3d-world* (load-site (merge-model-board-1-pathname "mb1.site")))
  140.  
  141. (get-site-images *mb1-3d-world* *mb1-cme-frame*)
  142. (get-site-images (GET-3D-WORLD-NAMED '"Radius Model Board 1") )
  143. (get-site-images *mb1-3d-world*)
  144.  
  145. (time (dump-site (3d-world (top-view))
  146.          (merge-model-board-1-pathname "mb1.site") :print-function 'pprint))
  147.  
  148. (load-site (merge-model-board-1-pathname "mb1.site"))
  149.  
  150. (setf (get-prop *mb1-3d-world* :control-points) *model-board-1-control-points*)
  151.  
  152. (setq *mb1-images*
  153.       (reverse
  154.        (loop for 2d-world in (2d-worlds (GET-3D-WORLD-NAMED '"Radius Model Board 1"))
  155.          for image = (base-image 2d-world)
  156.          when image collect image )))
  157.  
  158. (ic::display-image-sequence (selected-pane) *mb1-images* :pause .5 :REPEAT-COUNT 20 :delta-t 0)
  159.  
  160. (ic::display-image-sequence (selected-pane) *mb1-images* :interactive nil
  161.                 :pause .5 :REPEAT-COUNT 2 :delta-t 0)
  162.  
  163. (progn *mb1-images*)
  164. (length *mb1-images*)
  165. |#
  166.  
  167.  
  168.  
  169.  
  170. ;;;================================================================================
  171. ;;;     Set up sun vectors for Model Board imagery
  172. ;;;================================================================================
  173.  
  174. (defun tand (x)
  175.   (/ (cosd x) (sind x)))
  176.   
  177. (defun set-sun-ray-of-2d-world (2d-world sun-az sun-el)
  178.   (let ((sun-vector (list-vector
  179.              (normalize-coordinate-vector
  180.               (position-to-vector
  181.                `(,(cosd sun-az) ,(sind sun-az) ,(tand sun-el)))))))
  182.     (loop for image in (image-list 2d-world)
  183.       do
  184.        (setf (sun-vector image) sun-vector))
  185.     (setf (sun-vector (base-image 2d-world )) sun-vector)
  186.     2d-world ))
  187.  
  188.  
  189. (set-sun-ray-of-2d-world (get-2d-world-named "MB1-j1 2d World")  40 27)
  190. (set-sun-ray-of-2d-world (get-2d-world-named "MB1-j2 2d World") 320 30)
  191. (set-sun-ray-of-2d-world (get-2d-world-named "MB1-j3 2d World")  60 48)
  192. (set-sun-ray-of-2d-world (get-2d-world-named "MB1-j4 2d World") 140 42)
  193. (set-sun-ray-of-2d-world (get-2d-world-named "MB1-j5 2d World") 140 42)
  194. (set-sun-ray-of-2d-world (get-2d-world-named "MB1-j6 2d World") 140 50)
  195. (set-sun-ray-of-2d-world (get-2d-world-named "MB1-j7 2d World") 140 50)
  196. (set-sun-ray-of-2d-world (get-2d-world-named "MB1-j8 2d World") 240 45))
  197.  
  198.  
  199.