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 / Acquire / acquire-model.lisp < prev   
Lisp/Scheme  |  1996-03-08  |  14KB  |  330 lines
  1.  
  2. ;;Acquire-model.lisp - acquire a full site model in as automatic
  3. ;;a manner as possible.  Once you set the system parameters, this
  4. ;;runs pretty much as a batch job.
  5.  
  6. (in-package 'cme)
  7.  
  8. (defun display-work-area-rectangle (view u1 v1 u2 v2 color thickness transform)
  9.   (display-line view u1 v1 u1 v2 
  10.       :color color :thickness thickness :transform transform)
  11.   (display-line view u1 v2 u2 v2 
  12.       :color color :thickness thickness :transform transform)
  13.   (display-line view u2 v2 u2 v1 
  14.       :color color :thickness thickness :transform transform)
  15.   (display-line view u2 v1 u1 v1 
  16.       :color color :thickness thickness :transform transform)
  17.   )
  18.  
  19. (defvar *max-acquire-blocksize* 256)
  20. (defvar *acquire-blocksize* 256)
  21. (defvar *site-save-filename* "site-model.fs")
  22. (defvar *boldt-sens* :medium)
  23. (defvar *boldt-minlength* 5.0)
  24.  
  25. (defun set-acquire-parameters-via-menu ()
  26.   (ic::with-cvv-items
  27.    (((blocksize "Acquire Site Model:     Block Size: "
  28.     :integer :initial-value *max-acquire-blocksize*
  29.     :documentation "Width (in pixels) of subwindow for building detection")
  30.      (savefilename "Save Site Filename: "
  31.     :string :initial-value *site-save-filename*
  32.     :documentation "Filename for saving site model feature set")
  33.      (ignore1 nil :separator)
  34.      (sens "Boldt Line Extraction: Sensitivity: " :assoc :alist
  35.        (("Low" :low "Low sensitivity")
  36.         ("Medium" :medium "Medium sensitivity")
  37.         ("High" :high "High sensitivity"))
  38.        :documentation "Choose a sensitivity setting"
  39.       :initial-value :medium)
  40.      (minlength "Min Length: " :float :initial-value 5.0
  41.       :documentation "Minimum desired line length")
  42.      (ignore2 nil :separator)
  43.      (sensitivity "2D Building Detection: Sensitivity: "
  44.       :double-float-slider
  45.       :value *bf-sensitivity*
  46.       :format "%3g"
  47.       :min 0.0
  48.       :max 1.0
  49.       :documentation "Adjust sensitivity of the building detector")
  50.      (constrain "Shape Refinement: "
  51.       :yes-or-no
  52.       :value *bf-constrain-p*
  53.       :documentation
  54.       "Use Least Squares Constraints to modify final polygon shape")
  55.      (manual "Manually adjust parameters: "
  56.       :yes-or-no :value *bf-param-adjust*
  57.       :documentation
  58.       "Ignore the sensitivity slider, set each parameter individually")
  59.      (topcycles "Output Best K cycles: "
  60.       :yes-or-no :value *bf-best-k*
  61.       :documentation "Ignore hypothesis conflicts, output k best cycles")
  62.      (k-cycles "K: "
  63.       :integer :value *bf-k-cycles*
  64.       :documentation "Number of best cycles to display")
  65.      (2.5dlines "Use 2.5d line data: "
  66.       :yes-or-no :value *bf-2.5d-lines*
  67.       :documentation
  68.       "Match image lines to compute height before building detection")
  69.      (ignore3 nil :separator)
  70.      (zmin "Match/Triangulate:     Min Z value: " :float :value *last-epi-minz*
  71.       :documentation "Minimum Z coordinate of a building rooftop")
  72.      (zmax "Max Z value: " :float :value *last-epi-maxz*
  73.       :documentation "Maximum Z coordinate of a building rooftop")
  74.      (support "Line support:" :float :value *last-epi-support-percentage*
  75.           :documentation "Minimum line support percentage allowed")
  76.      (slop "Pixel error: " :float :value *last-epi-slop*
  77.       :documentation "Amount of perpendicular slop in line endpoints")
  78.      (dtheta "Radian error: " :float :value *last-epi-dtheta*
  79.          :documentation "Amount of slop in line orientation (radians)")
  80.      (arb "Arbitration: " :float :value *arbitration-threshold*
  81.       :documentation "Amount of overlap defining alternate hypotheses")
  82.      )
  83.     :label "Acquire Site Model")
  84.    (declare (ignore ignore1 ignore2 ignore3))
  85.    (when (> blocksize *max-acquire-blocksize*)
  86.       (warn "Setting blocksize to ~d" *max-acquire-blocksize*) 
  87.       (setf blocksize *max-acquire-blocksize*))
  88.    (setf blocksize (* 2 (floor blocksize 2))) ;;make sure it's an even number
  89.    (setf *acquire-blocksize* blocksize)
  90.    (setf *site-save-filename* savefilename)
  91.    (setf *boldt-sens* sens)
  92.    (setf *boldt-minlength* minlength)
  93.    (when manual (popup-building-parameters-menu))
  94.    (setf *bf-sensitivity* sensitivity)
  95.    (setf *bf-constrain-p* constrain)
  96.    (setf *bf-2.5d-lines* 2.5dlines)
  97.    (setf *bf-param-adjust* manual)
  98.    (setf *bf-best-k* topcycles)
  99.    (when (null topcycles) (setf k-cycles 0))
  100.    (setf *bf-k-cycles* k-cycles)
  101.    (setf *last-epi-slop* slop)
  102.    (setf *last-epi-dtheta* dtheta)
  103.    (setf *last-epi-minz* zmin)
  104.    (setf *last-epi-maxz* zmax)
  105.    (setf *last-epi-support-percentage* support)
  106.    (setf *arbitration-threshold* arb)
  107.    (rcde-init-height-histograms zmin zmax)))
  108.  
  109.  
  110. (defun active-image-view (image)
  111.   (let ((viewlist (view-list (2d-world image))))
  112.     (or (find nil viewlist 
  113.           :test #'(lambda (x y) (declare (ignore x)) (active-p y)))
  114.     (car viewlist))))
  115.  
  116.  
  117. (defun acquire-model-in-block (image ustart vstart uend vend &key (pane nil)
  118.                (clear-lines-before nil)(clear-lines-after t)
  119.                (use-previous-lines nil))
  120.   (let* ((topview (if pane (cme::top-view pane) (active-image-view image)))
  121.      (panechoice (or pane (view-window topview)))
  122.      (2d-world (2d-world image))
  123.      (view1 (find-epi-view-for-world 2d-world))
  124.      (otherviews (find-the-other-epi-views 2d-world))
  125.      (boldt-fs (get-or-make-2d-feature-set 2d-world *2d-line-fsname*))
  126.      (2droof-fs (find-fs-named 2d-world *2d-building-fsname*))
  127.      (imto2d-trans (image-to-2d-transform image))
  128.      (2dtoim-trans (inverse-transform (image-to-2d-transform image)))
  129.      (winto2d-trans (inverse-transform (2d-to-window-transform topview)))
  130.      (wintoim-trans (make-composite-coordinate-transform 
  131.              (list winto2d-trans 2dtoim-trans)))
  132.      (imtowin-trans (inverse-transform wintoim-trans))
  133.      (world-bbox (multiple-value-list
  134.               (transform-2d-bounding-box imto2d-trans
  135.                    ustart vstart uend vend)))
  136.      (pane-bbox (multiple-value-list
  137.              (transform-2d-bounding-box imtowin-trans
  138.                    ustart vstart uend vend))))
  139.     (when clear-lines-before (clear-fs boldt-fs) (process-object-updates))
  140.     (display-work-area-rectangle topview ustart vstart uend vend
  141.                  "GREEN" 1 imtowin-trans)
  142.     (epi::synch-epipolar-screen topview)
  143.     (unless use-previous-lines
  144.       (boldt::canny-boldt-uv image ustart vstart uend vend boldt-fs 
  145.             :sensitivity *boldt-sens* :minlength *boldt-minlength*))
  146.     (process-object-updates)
  147.     (if *bf-2.5d-lines*
  148.     (compute-2.5dlines-for-building-detect panechoice pane-bbox)
  149.         (write-2dlines-for-building-detect panechoice pane-bbox))
  150.     (setf *topdown-edgels-for-bdetect*
  151.       (apply #'compute-2dworld-canny-edges image world-bbox))
  152.     (find-polygons *bf-sensitivity* *bf-constrain-p*
  153.            *bf-param-adjust* *bf-2.5d-lines*
  154.            (floor (car pane-bbox)) (floor (cadr pane-bbox))
  155.            (ceiling (third pane-bbox)) (ceiling (fourth pane-bbox))
  156.            *bf-k-cycles* (lci::create-c-handle panechoice))
  157.     (free-edgeimg *topdown-edgels-for-bdetect*)
  158.     (when clear-lines-after (clear-fs boldt-fs))
  159.     (process-object-updates)
  160.     (let* ((curves (mapcan  #'(lambda (x) 
  161.                 (when (eq (type-of x) 'cme::2d-curve) (list x)))
  162.                 (inferiors 2droof-fs)))
  163.        (count 0)
  164.        (numcurves (length curves))
  165.        (linelist (mapcan #'linelist-from-2dcurve curves)))
  166.       (when curves
  167.      (dolist (view2 otherviews)
  168.         (let ((boundingbox (epi::epipolar-search-area-bbox 
  169.                 view1 view2 linelist)))
  170.           (setf (epi::view-topdown-edgels view2)
  171.             (apply #'compute-2dworld-canny-edges 
  172.                (epi::view-image view2)
  173.                boundingbox)))))
  174.       (dolist (curve curves)
  175.      (format t "Running matcher on 2d roof curve: ~d of ~d~%" 
  176.          (incf count) numcurves)
  177.      (let ((match (rcde-run-epipolar-matcher 2d-world curve
  178.                 :filename *triang-infile*
  179.                 :endpoint-slop *last-epi-slop*
  180.                 :delta-theta *last-epi-dtheta*
  181.                 :run-canny? nil)))
  182.        (shell (format nil "~a ~a ~a"
  183.               (translated-unix-path *triang-c-filename*)
  184.               *triang-infile*  *triang-outfile*))
  185.        (remove-object curve 2droof-fs) ;;remove 2d roof hypothesis
  186.        (install-triangulated-building  ;;and install 3D wireframe
  187.             *triang-outfile*
  188.         (epi::epimatch-peak-confidence match))))
  189.       (when curves
  190.      (dolist (view2 otherviews)
  191.          (free-edgeimg (epi::view-topdown-edgels view2)))))
  192.     (epi::synch-epipolar-screen topview)
  193.     (process-object-updates)))
  194.  
  195. ;;could probably figure out a formula for this, but I'm too lazy right now.
  196. (defun determine-numblocks (size block &optional (overlap (floor block 2)))
  197.   (do ((count 1 (+ count 1))
  198.        (bstart 0 (+ bstart overlap))
  199.        (bend block (+ bend overlap)))
  200.       ((> bend size) count)))
  201.  
  202. (defun image-numblocks (im block &optional (overlap (floor block 2)))
  203.   (* (determine-numblocks (ic::image-x-dim im) block overlap)
  204.      (determine-numblocks (ic::image-y-dim im) block overlap)))
  205.  
  206. (defun bbox-numblocks (image panechoice bbox &optional 
  207.               (blocksize *acquire-blocksize*)
  208.               (overlap (floor blocksize 2)))
  209.   (let* ((topview (cme::top-view panechoice))
  210.      (xdim (ic::image-x-dim image))
  211.      (ydim (ic::image-y-dim image))
  212.      (2dtoim-trans (inverse-transform (image-to-2d-transform image)))
  213.      (winto2d-trans (inverse-transform 
  214.              (2d-to-window-transform topview)))
  215.      (wintoim-trans (make-composite-coordinate-transform 
  216.              (list winto2d-trans 2dtoim-trans))))
  217.     (multiple-value-bind (u1 v1 u2 v2) 
  218.       (apply #'transform-2d-bounding-box wintoim-trans bbox)
  219.       (setf u1 (min (max u1 0) xdim) v1 (min (max v1 0) ydim)
  220.         u2 (max 0 (min u2 xdim)) v2 (max 0 (min v2 ydim)))
  221.       (let* ((du (- u2 u1)) 
  222.          (dv (- v2 v1))
  223.          (Ublocks (determine-numblocks du blocksize overlap))
  224.          (Vblocks (determine-numblocks dv blocksize overlap)))
  225.     (* Ublocks Vblocks)))))
  226.  
  227. (defun image-resolution-list (image panechoice bbox &optional 
  228.               (blocksize *acquire-blocksize*)
  229.               (overlap (floor blocksize 2)))
  230.   (let* ((list (list image))
  231.      (nblks (bbox-numblocks image panechoice bbox blocksize overlap))
  232.      (count nblks))
  233.     (do ()
  234.     ((= nblks 1) (values (reverse list) count))
  235.       (setf image (ic::image-zoom-out image))
  236.       (push image list)
  237.       (setf nblks (bbox-numblocks image panechoice bbox blocksize overlap))
  238.       (incf count nblks))))
  239.  
  240. (defun acquire-site-model ()
  241.   (set-acquire-parameters-via-menu)
  242.   (multiple-value-bind (bbox panechoice) (pick-bounding-box-and-pane)
  243.    (let* ((topview (cme::top-view panechoice))
  244.       (2d-world (2d-world (view-image topview)))
  245.       (3d-world (3d-world 2d-world))
  246.       (blocksize *acquire-blocksize*)
  247.       (halfblocksize (floor blocksize 2))
  248.       (blocksofar 0)
  249.       imagelist numblocks)
  250.     (unless (ic::get-prop 3d-world :umass-site-model)
  251.        (error "No UMass site model has been initialized for this 3D world"))
  252.     (multiple-value-setq (imagelist numblocks)
  253.              (image-resolution-list 
  254.                 (ic::top-of-image-hierarchy (view-image topview))
  255.                 panechoice bbox blocksize halfblocksize))
  256.     (ic::noting-progress ("Acquire Model" numblocks :progress-var acqvar)
  257.      (dolist (image imagelist)
  258.       (let* ((boldt-fs (get-or-make-2d-feature-set 2d-world *2d-line-fsname*))
  259.          (3dhyp-fs (find-fs-named 3d-world *3d-hypotheses-fsname*))
  260.          (3dsite-fs (find-fs-named 3d-world *3d-building-fsname*))
  261.          (xdim (ic::image-x-dim image))
  262.          (ydim (ic::image-y-dim image))
  263.          (2dtoim-trans (inverse-transform (image-to-2d-transform image)))
  264.          (winto2d-trans (inverse-transform 
  265.                  (2d-to-window-transform topview)))
  266.          (wintoim-trans (make-composite-coordinate-transform 
  267.                  (list winto2d-trans 2dtoim-trans)))
  268.         u1 v1 u2 v2)
  269.        (clear-fs boldt-fs)
  270.        (process-object-updates)
  271.        (multiple-value-setq (u1 v1 u2 v2) 
  272.      (apply #'transform-2d-bounding-box wintoim-trans bbox))
  273.        (setf u1 (min (max u1 0) xdim) v1 (min (max v1 0) ydim)
  274.          u2 (max 0 (min u2 xdim)) v2 (max 0 (min v2 ydim)))
  275.        (let* ((du (- u2 u1)) 
  276.           (dv (- v2 v1))
  277.           (Ublocks (determine-numblocks du blocksize halfblocksize))
  278.           (Vblocks (determine-numblocks dv blocksize halfblocksize)))
  279.      (do ((Vcnt 1 (1+ vcnt))
  280.           (vstart v1 (+ vstart halfblocksize))
  281.           (vend (min v2 (+ v1 blocksize)) 
  282.             (min v2 (+ vend halfblocksize))))
  283.          ((> Vcnt Vblocks) nil)
  284.        (do ((ucnt 1 (1+ ucnt))
  285.         (ustart u1 (+ ustart halfblocksize))
  286.         (uend (min u2 (+ u1 blocksize)) 
  287.               (min u2 (+ uend halfblocksize))))
  288.            ((> ucnt ublocks) nil)
  289.          (acquire-model-in-block image ustart vstart uend vend
  290.                      :pane panechoice)
  291.          (dump-feature-sets *site-save-filename* (list 3dhyp-fs 3dsite-fs))
  292.          (ic::note-progress (incf blocksofar) acqvar))))))))))
  293.  
  294.  
  295. #|
  296. (defun cl () 
  297.   (load (compile-file "$RADIUSCODE/UMass/Acquire/acquire-model.lisp")))
  298. (defun foo () (acquire-site-model))
  299. |#
  300.  
  301.  
  302. #|
  303. (defun just-draw-box (image ustart vstart uend vend &key (pane nil)
  304.                (clear-lines-before nil)(clear-lines-after t)
  305.                (use-previous-lines nil))
  306.   (let* ((topview (if pane (cme::top-view pane) (active-image-view image)))
  307.      (panechoice (or pane (view-window topview)))
  308.      (2d-world (2d-world image))
  309.      (view1 (find-epi-view-for-world 2d-world))
  310.      (otherviews (find-the-other-epi-views 2d-world))
  311.      (boldt-fs (get-or-make-2d-feature-set 2d-world *2d-line-fsname*))
  312.      (2droof-fs (find-fs-named 2d-world *2d-building-fsname*))
  313.      (imto2d-trans (image-to-2d-transform image))
  314.      (2dtoim-trans (inverse-transform (image-to-2d-transform image)))
  315.      (winto2d-trans (inverse-transform (2d-to-window-transform topview)))
  316.      (wintoim-trans (make-composite-coordinate-transform 
  317.              (list winto2d-trans 2dtoim-trans)))
  318.      (imtowin-trans (inverse-transform wintoim-trans))
  319.      (world-bbox (multiple-value-list
  320.               (transform-2d-bounding-box imto2d-trans
  321.                    ustart vstart uend vend)))
  322.      (pane-bbox (multiple-value-list
  323.              (transform-2d-bounding-box imtowin-trans
  324.                    ustart vstart uend vend))))
  325.     (when clear-lines-before (clear-fs boldt-fs) (process-object-updates))
  326.     (display-work-area-rectangle topview ustart vstart uend vend
  327.                  "GREEN" 1 imtowin-trans)
  328.     ))
  329. |#
  330.