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 / umass-system.lisp < prev   
Lisp/Scheme  |  1996-03-08  |  22KB  |  576 lines
  1. ;;; UMass Building Extraction System
  2. ;;; Copyright 1995, University of Massachusetts, Amherst MA.
  3. ;;; (c) all rights reserved.
  4.  
  5. (in-package 'cme)
  6.  
  7. (defvar *umass-base-path* "$RADIUSCODE/UMass/")
  8.  
  9. (defun full-umass-path (filename &optional (base-path *umass-base-path*))
  10.   (concatenate 'string base-path filename))
  11.  
  12. (defun translated-unix-path (pathname)
  13.   (format nil "~a" (ic::translate-pathname pathname)))
  14.  
  15. (defvar user::*boldt-directory* (full-umass-path "BoldtNew/")
  16.   "directory containing Boldt Line code")
  17. (defvar user::*isr2-directory* (full-umass-path "ISR/")
  18.   "directory containing ISR database system")
  19. (defvar user::*epipolar-directory* (full-umass-path "Epipolar/")
  20.   "directory containing epipolar matcher")
  21. (defvar user::*base-temp-directory* (full-umass-path "Temp/")
  22.   "directory for scratch files")
  23. (defvar user::*temp-directory* (full-umass-path "Temp/")
  24.   "directory for scratch files")
  25.  
  26. (defvar user::*umass-compile* nil "used by UMass to recompile system")
  27.  
  28. (defvar *2dlines-propname* :2dlines)
  29. (defvar *2dlines-filename* "temp_2d_lines.lines")
  30. (defvar *2_5dlines-propname* :2_5dlines)
  31. (defvar *2_5dlines-filename* "temp_2pt5d_lines.lines")
  32. (defvar *tempdir-propname* :tempdir)
  33.  
  34.  
  35. (defvar *2d-line-fsname* "UMass Boldt Lines")
  36. (defvar *2d-building-fsname* "UMass 2d Buildings")
  37. (defvar *3d-building-fsname* "UMass 3d Buildings")
  38. (defvar *3d-hypotheses-fsname* "UMass 3d Hypotheses")
  39.  
  40. (defvar *triang-in-filename* "triangin.dat")
  41. (defvar *triang-out-filename* "triangout.dat")
  42. (defvar *triang-c-filename*  (full-umass-path "Triangulate/tri"))
  43. (defvar *triang-infile* nil)
  44. (defvar *triang-outfile* nil)
  45.  
  46.  
  47. (defvar *site-3d-world* nil "3d world of site model currently being constructed")
  48.  
  49. ;;;Get package names defined right now to avoid problems later on
  50. (unless (find-package 'isr2) (make-package 'isr2))
  51. (unless (find-package 'epipolar) (make-package 'epipolar :nicknames '(epi)))
  52. (unless (find-package 'boldt) (make-package 'boldt))
  53. (unless (find-package 'cg) (make-package 'cg))  ;;computational geometry
  54.  
  55.  
  56. (defun load-umass-file (filename &optional (base-path *umass-base-path*))
  57.   (load (full-umass-path filename base-path)))
  58.  
  59. (defun load-umass-system ()
  60.   (print "Loading UMass system...")
  61.   (load-umass-file "load-isr2" user::*isr2-directory*)
  62.   (load-umass-file "load-epipolar" user::*epipolar-directory*)
  63.   (load-umass-file "LineFinder/topdown-line-finder")
  64.   (load-umass-file "BoldtNew/canny-boldt")
  65.   (load-umass-file "Arbitrate/arbitration")
  66.   (let ((working-directory (pwd)))
  67.     (lci::load-project (full-umass-path "BuildingFinder/poly.proj"))
  68. ;;  (lci::load-project (full-umass-path "Triangulate/tri.proj"))
  69.     (load-umass-file "BuildingFinder/functions.lisp")
  70. ;;(load-umass-file "Triangulate/support.lisp")
  71.     (load-umass-file "BuildingFinder/Lisp/top-down-vrfy.lisp")
  72.     (set-working-directory working-directory))
  73.   (load-umass-file "Acquire/acquire-model")
  74.   t)
  75.  
  76. (define-image-calc-interaction-method com-load-umass-system ()
  77.   "Load UMass system into RCDE"
  78.   (load-umass-system))
  79.  
  80. (defun put-pathname-property (world pathname property-name)
  81.   (let ((pathname (translated-unix-path pathname)))
  82.     (ic::put-prop world pathname property-name)))
  83.  
  84. (defun find-fs-named (world namestring)
  85.   "Return feature set with the given name, else nil."
  86.   (find (string namestring) (feature-sets world)
  87.     :key #'name :test #'string-equal))
  88.  
  89. (defun get-or-make-2d-feature-set (2dworld fsname)
  90.   (let ((fs (find-fs-named 2dworld fsname)))
  91.     (unless fs
  92.       (setf fs (make-2d-feature-set :world 2dworld :name fsname))
  93.       (dolist (view (view-list 2dworld))
  94.      (add-view fs view :sensitize t)))
  95.     fs))
  96.  
  97. (defun clear-fs (fs)
  98.   (mapc 
  99.     #'(lambda (x) 
  100.     (when (equal (type-of x) 'ISR-LINE-TOKENSET-OBJECT)  ;;BobC 2/21/96
  101.        (isr2::destroy* (tokenset x)))  ;;reclaim memory from ISR
  102.     (remove-object x fs))
  103.     (inferiors fs)))
  104.  
  105. ;;;-------------------------------------------------------
  106.  
  107. (defun init-umass-site-model (3dworld)
  108.   (format t "Initializing UMass site model for ~a~%" (name 3dworld))
  109.   (setf user::*temp-directory*
  110.     (concatenate 'string user::*base-temp-directory* 
  111.              (string (gensym "DIR")) "/"))
  112.   (format t "Creating temp directory ~s~%" user::*temp-directory*)
  113.   (ic::create-directory user::*temp-directory*)
  114.   (put-pathname-property 3dworld user::*temp-directory* *tempdir-propname*)
  115.   (setf *site-3d-world* 3dworld)
  116.   (let ((3dfs (make-3d-feature-set :world 3dworld 
  117.                    :name *3d-building-fsname*))
  118.     (3dhyp-fs (make-3d-feature-set :world 3dworld 
  119.                        :name *3d-hypotheses-fsname*)))
  120.     (dolist (view (view-list 3dworld))
  121.        (add-view 3dfs view :sensitize t))
  122.     (dolist (view (view-list 3dworld))
  123.        (add-view 3dhyp-fs view :sensitize nil))
  124.     (select-fs 3dworld 3dfs))
  125.   (dolist (2dworld (2d-worlds 3dworld))
  126.     (mapcar #'(lambda (name)
  127.         (make-2d-feature-set :world 2dworld :name name))
  128.         (list *2d-building-fsname*))
  129.     (let ((2dfs (find-fs-named 2dworld *2d-building-fsname*)))
  130.       (dolist (view (view-list 2dworld))
  131.           (add-view 2dfs view :sensitize t))
  132.       (select-fs 2dworld 2dfs))) 
  133.   (rcde-init-epipolar-views 3dworld)
  134.   (setf *triang-infile* (translated-unix-path
  135.        (concatenate 'string user::*temp-directory* *triang-in-filename*)))
  136.   (setf *triang-outfile* (translated-unix-path
  137.           (concatenate 'string user::*temp-directory* *triang-out-filename*)))
  138.   (ic::put-prop 3dworld t :umass-site-model)
  139.   3dworld)
  140.  
  141. (define-image-calc-interaction-method com-init-umass-site-model ()
  142.   "Initialize a new UMass site model"
  143.   (let* ((pane (ic::pick-a-pane ic::self "Pick any pane showing the site"))
  144.      (topview (top-view pane))
  145.      (3dworld (3d-world topview)))
  146.     (init-umass-site-model 3dworld)))
  147.  
  148. (define-image-calc-interaction-method com-extract-boldt-lines ()
  149.   "Run Boldt line segment extractor."
  150.   (boldt::run-boldt-from-menu))
  151.  
  152. (defun makenewpath (pathname &key newtype newdir)
  153.   (merge-pathnames (make-pathname 
  154.             :name (pathname-name pathname)
  155.             :type (or newtype (pathname-type pathname)))
  156.            (or newdir (directory-namestring pathname))))
  157.  
  158. (define-image-calc-interaction-method com-save-line-featuresets ()
  159.   "Save all 2D line featuresets."
  160.   (let* ((pane (ic::pick-a-pane ic::self "Pick any pane showing the site"))
  161.      (topview (top-view pane))
  162.      (3dworld (3d-world topview))
  163.      (fslist nil)
  164.      (defaultname (concatenate 'string
  165.                 (replace-spaces-with-hyphens (string (name 3dworld)))
  166.             ".linesets"))
  167.      (pathname nil))
  168.     (setf fslist (mapcan #'(lambda (w)
  169.                  (let ((foo (find-fs-named w *2d-line-fsname*)))
  170.                    (when foo (list foo))))
  171.              (2d-worlds 3dworld)))
  172.     (ic::with-cvv-items
  173.      (((directory "Directory: " :string :initial-value (format nil "~a" (pwd))
  174.          :documentation "Directory to save feature sets in")
  175.        (filename "Filename: " :string :value defaultname
  176.          :documentation "Filename for saving feature sets"))
  177.       :label "Save line featuresets")
  178.      (unless (probe-file directory)
  179.          (error "Directory ~a does not exist!" directory))
  180.      (format t "Saving ~d line featuresets for ~a~%" 
  181.          (length fslist) (name 3dworld))
  182.      (setf pathname (makenewpath defaultname :newdir directory))
  183.      (with-open-file (file pathname :direction :output)
  184.        (format t "Saving into file ~a~%" pathname)
  185.        (format file ":ascender_line_file~%")
  186.        (format file "~d feature sets~%" (length fslist))
  187.        (dolist (fs fslist)
  188.      (let* ((tks (get-or-make-ISR-tokenset fs))
  189.         (newpath (makenewpath (tokensetname tks) :newtype "isr2"
  190.                       :newdir directory)))
  191.        (setf (load-filename tks) (format nil "~a" newpath))
  192.        (format file "~s~%" (string (cme::name (cme::world fs))))
  193.        (write-isr-line-tokenset file tks :write-load-file t)))))))
  194.  
  195. (defun load-old-line-featuresets (3dworld pathname)
  196.   (format t "Loading line featuresets for ~a~%" (name 3dworld))
  197.   (load pathname)
  198.   (mapcar
  199.    #'(lambda (linefs)
  200.        (when linefs
  201.          (let ((isrobject
  202.             (find 'ISR-LINE-TOKENSET-OBJECT (inferiors linefs) 
  203.               :key #'type-of :test #'equal))
  204.            (2dworld (world linefs)))
  205.            (dolist (view (view-list 2dworld))
  206.            (add-view linefs view)
  207.            (when isrobject
  208.              (put-pathname-property 
  209.               2dworld
  210.               (c-filename isrobject)
  211.               *2dlines-propname*)
  212.              (put-pathname-property
  213.               2dworld 
  214.               (c-filename isrobject)
  215.               *2_5dlines-propname*)))
  216.            )))
  217.    cme::*object-feature-sets*))
  218.  
  219. ;;to be compatible with old files
  220. (defun load-line-featuresets (3dworld pathname) 
  221.   (load-old-line-featuresets 3dworld pathname))
  222.  
  223. (defun load-new-line-featuresets (3dworld pathname &key (clear-fs t))
  224.   (with-open-file (file pathname :direction :input)
  225.     (read-line file) ;;skip format header
  226.     (let ((numfs (read file)))
  227.       (read-line file) ;;skip rest of line
  228.       (format t "Loading ~d line featuresets for ~a~%" numfs (name 3dworld))
  229.       (dotimes (i numfs pathname)
  230.     (let* ((2dworldname (read file))
  231.            (2d-world (get-2d-world-named 2dworldname))
  232.            (fs (get-or-make-2d-feature-set 2d-world *2d-line-fsname*)))
  233.       (when clear-fs (clear-fs fs))
  234.       (add-object (read-isr-line-tokenset file) fs)
  235.       (process-object-updates)
  236.       (map 'nil #'refresh-view (view-list 2d-world)))))))
  237.  
  238. (define-image-calc-interaction-method com-load-line-featuresets ()
  239.   "Load 2D line featuresets."
  240.   (let* ((pane (ic::pick-a-pane ic::self "Pick any pane showing the site"))
  241.      (topview (top-view pane))
  242.      (3dworld (3d-world topview))
  243.      (old-format? nil))
  244.     (ic::with-cvv-items
  245.      (((pathname "Pathname: " :string :value (format nil "~a" (pwd))
  246.          :documentation "Full pathname for loading feature sets"))
  247. ;       (clear-fs "Previous lines:"  :assoc :alist
  248. ;       (("Replace" :replace "Replace previous lines")
  249. ;        ("Append" :append "Add to previous lines"))
  250. ;       :documentation "What to do with previous line features"
  251. ;       :initial-value :replace))
  252.       :label "Load line featuresets")
  253.      (with-open-file (file pathname :direction :input)
  254.        (unless (eq (read file) :ascender_line_file)
  255.      (setf old-format? t)))
  256.      (if old-format?
  257.     (load-old-line-featuresets 3dworld pathname)
  258.     (load-new-line-featuresets 3dworld pathname 
  259.                    :clear-fs t
  260. ;;                   :clear-fs (eq clear-fs :replace)
  261.     )))
  262.  
  263.     t))
  264.  
  265. (defun read-tri-vert-list (filename)
  266.   (with-open-file (file filename :direction :input)
  267.     (let ((numverts (read file))
  268.       (vertlist nil))
  269.       (dotimes (i numverts vertlist)
  270.      (push (list (read file) (read file) (read file))
  271.            vertlist)))))
  272.  
  273. (defun read-init-guess-list (filename)
  274.   (with-open-file (file filename :direction :input)
  275.     (let ((numverts (read file))
  276.       (vertlist nil))
  277.       (dotimes (i numverts vertlist)
  278.      (push (list (read file) (read file) (read file))
  279.            vertlist)
  280.      (read file) (read file) (read file)))))
  281.  
  282. (defvar *arbitration-threshold* 0.5)
  283.  
  284. ;;install-triangulated-building:
  285. ;;changed to select feature set first before creating the object, then
  286. ;;setting the selected feature set back to what it was.  Not sure
  287. ;;why I have to do this, but the building was always ending up in
  288. ;;the selected feature set, in addition to the feature set I am 
  289. ;;explicitly adding it to. --BobC Fri Sep 22,1995
  290. ;;added hypothesis arbitration -- Bob C Wed Feb 28
  291.  
  292. (defun add-building-to-featureset (object featureset)
  293.   (let ((selected-fs (selected-feature-set *site-3d-world*)))
  294.     (select-fs *site-3d-world* featureset)
  295.     (add-object object featureset)
  296.     (select-fs *site-3d-world* selected-fs)))
  297.  
  298. (defun install-triangulated-building (filename conf &key (initguess nil))
  299.   (let* ((selected-fs (selected-feature-set *site-3d-world*))
  300.      (hyp-fs (find-fs-named *site-3d-world* *3d-hypotheses-fsname*))
  301.      (build-fs (find-fs-named *site-3d-world* *3d-building-fsname*))
  302.      (vlist (if initguess
  303.             (read-init-guess-list filename)
  304.             (read-tri-vert-list filename))))
  305.    (when (and vlist (numberp (caar vlist)))
  306.     (select-fs *site-3d-world* hyp-fs)
  307.     (let* ((curve (make-3d-closed-curve 
  308.            :vertices (make-vertex-array-from-vertex-list vlist)
  309.            :world *site-3d-world*))
  310.        (building (extrude-roof-curve curve))
  311.        (alternates (sort (competing-hypotheses vlist build-fs
  312.                            *arbitration-threshold*)
  313.                  #'> :key #'car)))
  314.       (ic::put-prop building conf :match-score)
  315.       (cond
  316.        ((null alternates) 
  317.     ;;no competing hypotheses, just put wireframe in the site model
  318.     (add-building-to-featureset building build-fs))
  319.        ((> (ic::get-prop (cadar alternates) :match-score) conf)
  320.     ;;current site model building is better than the wireframe
  321.     (add-building-to-featureset building hyp-fs))
  322.        (t
  323.     ;;replace current site model building with new wireframe
  324.     (remove-object (cadar alternates) build-fs)
  325.     (add-building-to-featureset (cadar alternates) hyp-fs)
  326.     (add-building-to-featureset building build-fs)))
  327.       (process-object-updates)  ;;BobC 2/20/96 
  328.       (select-fs *site-3d-world* selected-fs)
  329.       ))))
  330.  
  331.  
  332. (defvar *last-epi-slop* 1.0)
  333. (defvar *last-epi-dtheta* 0.1)
  334. (defvar *last-epi-support-percentage* 0.3)
  335. (defvar *last-epi-minz* nil)
  336. (defvar *last-epi-maxz* nil)
  337.  
  338.  
  339. (defun popup-epipolar-menu ()
  340.   (ic::with-cvv-items
  341.    (((zmin "Min Z value: " :float :value *last-epi-minz*
  342.       :documentation "Minimum Z coordinate of a building rooftop")
  343.      (zmax "Max Z value: " :float :value *last-epi-maxz*
  344.        :documentation "Maximum Z coordinate of a building rooftop")
  345.      (support "Line support:" :float :value *last-epi-support-percentage*
  346.           :documentation "Minimum line support percentage allowed")
  347.      (slop "Pixel error: " :float :value *last-epi-slop*
  348.        :documentation "Amount of perpendicular slop in line endpoints")
  349.      (dtheta "Radian error: " :float :value *last-epi-dtheta*
  350.          :documentation "Amount of slop in line orientation (radians)")
  351.      (arb "Arbitration: " :float :value *arbitration-threshold*
  352.       :documentation "Amount of overlap defining alternate hypotheses"))
  353.     :label "Enter values for epipolar search")
  354.    (setf *last-epi-slop* slop *last-epi-dtheta* dtheta)
  355.    (setf *last-epi-minz* zmin *last-epi-maxz* zmax)
  356.    (setf *last-epi-support-percentage* support)
  357.    (setf *arbitration-threshold* arb)
  358.    (rcde-init-height-histograms zmin zmax)))
  359.  
  360.  
  361. (define-image-calc-interaction-method com-match-triang-rooftops ()
  362.   "Match/triangulate rooftops from multiple views."
  363.   (let* ((pane (ic::pick-a-pane ic::self "Pick a pane containing 2d rooftops"))
  364.      (topview (top-view pane))
  365.      (2dworld (2d-world topview))
  366.      (3d-world (3d-world 2dworld)))
  367.     (unless (ic::get-prop 3d-world :umass-site-model)
  368.        (error "No UMass site model has been initialized for this 3D world"))
  369.      (popup-epipolar-menu)
  370.      (let* ((2dfs (find-fs-named 2dworld *2d-building-fsname*))
  371.         (count 0)
  372.         (curves (mapcan  #'(lambda (x) 
  373.                  (when (eq (type-of x) 'cme::2d-curve) (list x)))
  374.                  (inferiors 2dfs))))
  375.        (format t "~d curves to be matched/triangulated~%" 
  376.            (length curves))
  377.        (dolist (curve curves)
  378.       (format t "Running matcher on curve ~d~%" (incf count))
  379.       (let ((match (rcde-run-epipolar-matcher 2dworld curve
  380.                   :filename *triang-infile*
  381.                   :endpoint-slop *last-epi-slop*
  382.                   :delta-theta *last-epi-dtheta*)))
  383.       (format t "height estimate: ~,3f,  match support: ~,3f~%"
  384.           (epi::epimatch-rough-zvalue match)
  385.           (epi::epimatch-peak-confidence match))
  386. ;;
  387. ;; Modified: Feb. 27, 1996
  388. ;;          Christopher Jaynes
  389. ;;         The triangulator was compiled as a standalone 'c' program
  390. ;;         and is now called through a simple shell fork.
  391. ;;
  392. ;;
  393.       (shell (format nil "~a ~a ~a"
  394.          (translated-unix-path *triang-c-filename*)
  395.          *triang-infile*
  396.          *triang-outfile*))
  397. ;;      (lci::triangulation *triang-infile* *triang-outfile*)
  398.       (remove-object curve 2dfs)     ;;remove 2d roof hypothesis
  399.       (install-triangulated-building ;;and install 3D wireframe
  400.          *triang-outfile*
  401.          (epi::epimatch-peak-confidence match)))))
  402.      (epi::synch-epipolar-screen topview)
  403.      t))
  404.  
  405.  
  406. (define-image-calc-interaction-method com-detect-rooftops ()
  407.   "Detect building rooftops in an image."
  408.   (popup-building-finder-menu)
  409.   t)
  410.  
  411. (define-image-calc-interaction-method com-acquire-model ()
  412.   "Acquire site model from this image."
  413. ;;  (popup-acquire-buildings-menu))
  414.   (acquire-site-model))
  415.  
  416. (defparameter cme::*umass-menu-item-list*
  417.   (ic::make-menu-item-list
  418.    '("Reload Umass System" cme::com-load-umass-system
  419.      "Extract Boldt Lines" cme::com-extract-boldt-lines
  420. ;;;; "Install Image Lines" cme::com-install-line-file
  421.      "Save Line Featuresets" cme::com-save-line-featuresets
  422.      "Load Line Featuresets" cme::com-load-line-featuresets
  423.      "Initialize Site Model" cme::com-init-umass-site-model
  424.      "Detect Building Rooftops" cme::com-detect-rooftops
  425.      "Match/Triangulate Rooftops" cme::com-match-triang-rooftops
  426.      "Acquire Site Model" cme::com-acquire-model)))
  427.  
  428. (defun install-umass-pulldown-menu ()
  429.   (when (find "UMass" xw::*pulldown-menu-bar-item-list*
  430.           :key #'car :test #'string-equal)
  431.     (delete "UMass" xw::*pulldown-menu-bar-item-list*
  432.         :key #'car :test #'string-equal))
  433.   (when (find "LCI" xw::*pulldown-menu-bar-item-list*
  434.               :key #'car :test #'string-equal)
  435.         (delete "LCI" xw::*pulldown-menu-bar-item-list*
  436.                 :key #'car :test #'string-equal))
  437.   (setf xw::*pulldown-menu-bar-item-list*
  438.     (ic::add-item-to-item-list
  439.      '("UMass" :menu cme::*umass-menu-item-list* 
  440.        :documentation ("UMass Building Extraction System" ""))
  441.        xw::*pulldown-menu-bar-item-list* 
  442.      :after-item-named "Panels"))
  443.   (setf xw::*pulldown-menu-bar-item-list*
  444.         (ic::add-item-to-item-list
  445.          '("LCI" :MENU *INTERFACE-MENU-ITEM-LIST*
  446.          :DOCUMENTATION ("Lisp-C/C++ Interface" ""))
  447.            xw::*pulldown-menu-bar-item-list* 
  448.          :after-item-named "UMass"))
  449.   (ic::install-menus)
  450.   ;;this is hokey, but the core-dumping bug is in CME's code
  451.   (when (probe-file "core")
  452.     (delete-file "core"))
  453.   t)
  454.  
  455.  
  456. (defvar *already-loaded* nil)
  457.  
  458. (eval-when (eval load)
  459.   (print "Installing UMass pulldown menu")
  460.   (unless *already-loaded*
  461.       (load-umass-system)
  462.       (setf *already-loaded* t))
  463.   (install-umass-pulldown-menu))
  464.  
  465.  
  466. ;;======================================================================
  467. #| OLD CODE THAT ISN'T USED ANYMORE -- BobC 2/6/96
  468.  
  469. (define-image-calc-interaction-method com-save-line-featuresets ()
  470.   "Save all installed 2D line featuresets."
  471.   (let* ((pane (ic::pick-a-pane ic::self "Pick any pane showing the site"))
  472.      (topview (top-view pane))
  473.      (3dworld (3d-world topview))
  474.      (fslist nil))
  475.     (setf fslist (mapcan #'(lambda (w)
  476.                  (let ((foo (find-fs-named w *2d-line-fsname*)))
  477.                    (when foo (list foo))))
  478.              (2d-worlds 3dworld)))
  479.     (ic::with-cvv-items
  480.      (((pathname "Pathname: " :string :value (format nil "~a" (pwd))
  481.          :documentation "Full pathname for saving feature sets"))
  482.       :label "Save line featuresets")
  483.      (format t "Saving ~d line featuresets for ~a~%" 
  484.          (length fslist) (name 3dworld))
  485.      (dump-feature-sets pathname fslist))))
  486.  
  487. (defun load-line-featuresets (3dworld pathname)
  488.   (format t "Loading line featuresets for ~a~%" (name 3dworld))
  489.   (load pathname)
  490.   (mapcar
  491.    #'(lambda (linefs)
  492.        (when linefs
  493.          (let ((isrobject
  494.             (find 'ISR-LINE-TOKENSET-OBJECT (inferiors linefs) 
  495.               :key #'type-of :test #'equal))
  496.            (2dworld (world linefs)))
  497.            (dolist (view (view-list 2dworld))
  498.            (add-view linefs view)
  499.            (when isrobject
  500.              (put-pathname-property 
  501.               2dworld
  502.               (c-filename isrobject)
  503.               *2dlines-propname*)
  504.              (put-pathname-property
  505.               2dworld 
  506.               (c-filename isrobject)
  507.               *2_5dlines-propname*))
  508.            ))))
  509.    cme::*object-feature-sets*))
  510.  
  511. (defvar *last-line-filename* nil)
  512. (defvar *last-image-filename* nil)
  513. (defvar *last-archival-dir* nil)
  514.  
  515. (define-image-calc-interaction-method com-install-line-file ()
  516.   "Associate a file of 2D line segments with a 2D world."
  517.   (let* ((pane (ic::pick-a-pane ic::self "Pick a pane containing the 2d world"))
  518.      (topview (top-view pane))
  519.      (2dworld (2d-world topview))
  520.      (linefile (or (ic::get-prop 2dworld *2dlines-propname*)
  521.                *last-line-filename*)))
  522.     (ic::with-cvv-items
  523.       (((pathname "Line Pathname: " :string :value linefile
  524.            :documentation "Full pathname of 2d line segment file")
  525.     (image "Image Pathname: " :string :value *last-image-filename*
  526.            :documentation "RCDE image file that lines were computed from")
  527.     (directory "Archival Directory: " :string
  528.            :value *last-archival-dir*
  529.            :documentation "Directory for storing line file results"))
  530.     :label (format nil "~a: Install line file" (name 2dworld)))
  531.     (setf *last-line-filename* pathname)
  532.     (unless (probe-file pathname)
  533.         (error "Line file ~a does not exist!" pathname))
  534.     (setf *last-image-filename* image)
  535.     (unless (probe-file image)
  536.         (error "Image file ~a does not exist!" image))
  537.     (setf *last-archival-dir* directory)
  538.     (unless (probe-file directory)
  539.         (error "Directory ~a does not exist!" directory))
  540.     (format t "installing ~a into ~a~%" pathname (name 2dworld))
  541.     (let ((newpath (makenewpath pathname :newtype "lines" :newdir directory))
  542.           (isrpath (makenewpath pathname :newtype "isr2" :newdir directory)))
  543.       (format t "will create files ~a~%" newpath)
  544.       (format t "   and ~a~%" isrpath)
  545.       (read-and-install-line-featureset
  546.          2dworld pathname image newpath isrpath *2d-line-fsname*)
  547.       (put-pathname-property 2dworld newpath *2dlines-propname*)
  548.       (put-pathname-property 2dworld newpath *2_5dlines-propname*)))))
  549.  
  550. ;;;---------- something for reporting progress -----------
  551.  
  552. (defun overstrike-expression (oldexpr newexpr)
  553.   (let ((len (length (format nil "~a" oldexpr))))
  554.     (dotimes (i len)
  555.       (princ #\backspace))
  556.     (dotimes (i len)
  557.       (princ #\space))
  558.     (dotimes (i len)
  559.       (princ #\backspace)))
  560.   (format t "~a" newexpr))
  561.  
  562. (defvar *last-reported-number* nil)
  563.  
  564. (defun init-number-report (info-string number)
  565.   (format t "~a~d" info-string number)
  566.   (setf *last-reported-number* number))
  567.  
  568. (defun update-number-report (number)
  569.   (overstrike-expression *last-reported-number* number)
  570.   (setf *last-reported-number* number))
  571.  
  572. (defun end-number-report (&optional (end-string nil))
  573.   (format t "~a~%" (or end-string "")))
  574.  
  575. |#
  576.