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 / BoldtNew / canny-boldt.lisp < prev    next >
Lisp/Scheme  |  1996-03-08  |  12KB  |  298 lines
  1.  
  2. (in-package 'boldt)
  3.  
  4. ;; CANNY-BOLDT.LISP - runs the boldt line linking algorithm on canny edgels
  5. ;; Bob Collins  Tue Jan 23 11:22:14 EST 1996
  6. ;; Copyright: University of Massachusetts, 1996
  7.  
  8. ;; relies on code in $CME/code/CME-6d/UMass/LineFinder/topdown-line-finder.lisp
  9. ;; which relies on $CMEHOME/ic/canny.lisp
  10.  
  11. (defun write-boldt-edgel (stream u v gradx grady mag)
  12.   "Write out boldt edgel info: x1 y1 x2 y2 theta contrast length."
  13.   (let ((x u)(y v))
  14.     ;;length of edgel is 1.4 so that diagonal lines get grouped OK
  15.     ;;note: grouping wasn't working for them when the length was 1.0
  16.    (let* ((dx (* 1.4 (/ grady mag 2.0)))
  17.       (dy (* 1.4 (/ (- gradx) mag 2.0)))
  18.       (theta (atan (- dy) dx)))
  19.      (when (minusp theta) (setf theta (+ theta pi pi)))
  20.      (format stream "~,2f ~,2f ~,2f ~,2f ~,5f ~,2f 1.4~%"
  21.          (- x dx) (- y dy) (+ x dx) (+ y dy)
  22.          theta mag))))
  23.  
  24. (defun edges-to-boldt-file (edges filename &optional
  25.              (startx 0)(starty 0)
  26.              (endx (1- (ic::image-x-dim (cme::edgeimg-bit edges))))
  27.              (endy (1- (ic::image-y-dim (cme::edgeimg-bit edges))))
  28.              (xdim (ic::image-x-dim (cme::edgeimg-bit edges)))
  29.              (ydim (ic::image-y-dim (cme::edgeimg-bit edges))))
  30.   "Write edges out to a file to be input by the Boldt linking algorithm."
  31.   ;first count number of edges
  32.   (let ((edgebits (cme::edgeimg-bit edges))
  33.     (gradx (cme::edgeimg-gradx edges))
  34.     (grady (cme::edgeimg-grady edges))
  35.     (gradmag (cme::edgeimg-mag edges))
  36.     (numedges 0))
  37.     (setf startx (max 0 startx) starty (max 0 starty)
  38.       endx (min (1- (ic::image-x-dim edgebits)) endx)
  39.       endy (min (1- (ic::image-y-dim edgebits)) endy))
  40.     (ic::with-image-elements (edgebits)  ;;FIRST COUNT NUMBER OF EDGELS
  41.       (do ((y starty (1+ y)))
  42.       ((> y endy) nil)
  43.     (do ((x startx (1+ x)))
  44.         ((> x endx) nil)
  45.       (when (= (ic::iref edgebits x y) 1)
  46.         (incf numedges)))))
  47.     (with-open-file (file filename :direction :output)
  48.       ;;WRITE OUT HEADER
  49.       (format file "~d ~d ~d ~d ~d~%" numedges 0 0 xdim ydim)
  50.       ;;THEN LOOP THROUGH EDGELS AND WRITE THEM OUT ONE BY ONE
  51.       (ic::with-image-elements (edgebits gradx grady gradmag) 
  52.         (do ((y starty (1+ y)))
  53.         ((> y endy) nil)
  54.       (do ((x startx (1+ x)))
  55.           ((> x endx) nil)
  56.         (when (= (ic::iref edgebits x y) 1)
  57.         ;;WRITE OUT THE EDGEL
  58.         (write-boldt-edgel file 
  59.             (+ x 0.5) (+ y 0.5)
  60.             (ic::iref gradx x y) (ic::iref grady x y) 
  61.             (ic::iref gradmag x y)))))))
  62.     numedges))
  63.  
  64.  
  65. (defun read-lines-into-fs (stream fs world &key (transform nil) (swap-xy nil))
  66.   "Reads in a set of ascii lines from a stream into a feature set."
  67.   (let ((numlines (read stream))
  68.     (namestring (string (cme::name world))))
  69.     (read-line stream) ;;skip rest of header
  70.     (multiple-value-bind (ignore tksname) (cme::get-or-make-ISR-tokenset fs)
  71.       ignore
  72.       (cme::read-ascii-lines-into-isr
  73.      tksname stream numlines :docstring namestring
  74.      :transform transform :swap-xy swap-xy))
  75.     (cme::process-object-updates) ;;BobC 2/20/96
  76.     (map 'nil #'cme::refresh-view (cme::view-list world))
  77.     fs))
  78.  
  79. (defun sensitivity-params (&optional (sensitivity (cadr '(:low :medium :high))))
  80.   "  Return parameters are canny mask size, lo threshold, high threshold,
  81.   and final line length threshold."
  82.   (ecase sensitivity
  83.     (:low (list 4 2 4 10))
  84.     (:medium (list 4 1 4 5))
  85.     (:high (list 4 1 2 3))))
  86.  
  87. (defun full-filename (string &optional (dir user::*temp-directory*))
  88.   (cme::translated-unix-path (format nil "~a~a" dir string)))
  89.  
  90. (defun boldt-filename (string)
  91.   (full-filename string user::*boldt-directory*))
  92.  
  93. (defun temp-filename (string)
  94.   (full-filename string user::*temp-directory*))
  95.  
  96.  
  97. (defvar *max-block* 300)
  98.  
  99. (defun canny-boldt-uv (image u1 v1 u2 v2 fs &key (sensitivity :medium) 
  100.               (minlength nil))
  101.   "  Run Canny-Boldt line extraction on the given image, within the
  102.   bounding box (u1,v1)-(u2,v2), specified in image coordinates.
  103.   Resulting lines are put in the feature set specified by fs.
  104.   Sensitivity can be :low, :medium (default), or :high."
  105.   (when (> u1 u2) (rotatef u1 u2))
  106.   (when (> v1 v2) (rotatef v1 v2))
  107.   (let ((xdim (ic::image-x-dim image))
  108.     (ydim (ic::image-y-dim image)))
  109.    (setf u1 (min (max u1 0) xdim) v1 (min (max v1 0) ydim)
  110.      u2 (max 0 (min u2 (1- xdim))) v2 (max 0 (min v2 (1- ydim))))
  111.    (multiple-value-bind (mask-size low-thresh high-thresh length-thresh)
  112.             (values-list (sensitivity-params sensitivity))
  113.     (when (> minlength length-thresh) (setf length-thresh minlength))
  114.     (let* ((du (- u2 u1))(dv (- v2 v1))(pixsize (* du dv))
  115.         (Ublocks (ceiling du *max-block*))
  116.         (Vblocks (ceiling dv *max-block*))
  117.         (pixsofar 0)(pixthistime 0))
  118. ;;       (print (list u1 v1 u2 v2 du dv Ublocks vblocks))
  119.        (ic::noting-progress ("Boldt" pixsize :progress-var bvar)
  120.     (do ((Vcnt 1 (1+ vcnt))
  121.          (vstart v1 (+ vstart *max-block*))
  122.          (vend (min v2 (+ v1 *max-block*)) 
  123.            (min v2 (+ vend *max-block*))))
  124.         ((> Vcnt Vblocks) nil)
  125.       (do ((ucnt 1 (1+ ucnt))
  126.            (ustart u1 (+ ustart *max-block*))
  127.            (uend (min u2 (+ u1 *max-block*)) 
  128.              (min u2 (+ uend *max-block*))))
  129.           ((> ucnt ublocks) nil)
  130.           (setf pixthistime (* (- uend ustart) (- vend vstart)))
  131.           (let* ((edges (cme::compute-imageuv-canny-edges
  132.                  image ustart vstart uend vend
  133.                  :mask-size mask-size
  134.                  :lo-threshold low-thresh
  135.                  :hi-threshold high-thresh))
  136.              (xdim (ic::image-x-dim (cme::edgeimg-image edges)))
  137.              (ydim (ic::image-y-dim (cme::edgeimg-image edges)))
  138.              (halfsize (1+ (ash mask-size -1))))
  139.         (ic::note-progress (+ pixsofar (* 0.2 pixthistime)) bvar)
  140.         (edges-to-boldt-file 
  141.          edges (temp-filename "cannyedges.asc")
  142.          halfsize halfsize (- xdim halfsize 2) (- ydim halfsize 2))
  143.         (ic::note-progress (+ pixsofar (* 0.4 pixthistime)) bvar)
  144.         (let ((trans (cme::image-to-2d-transform 
  145.                   (cme::edgeimg-image edges))))
  146.           (cme::free-edgeimg edges)
  147.           (unless (zerop (shell (format nil "~a ~a ~d ~d ~d"
  148.                        (boldt-filename "runboldt")
  149.                        (temp-filename "") 
  150.                        xdim ydim length-thresh)))
  151.               (warn "Error calling Boldt line algorithm"))
  152.           (ic::note-progress (+ pixsofar (* 0.8 pixthistime)) bvar)
  153.           (with-open-file (file (temp-filename "boldtlines.asc")
  154.                     :direction :input)
  155.             (read-lines-into-fs file  fs (cme::2d-world image)
  156.                     :transform trans :swap-xy t))
  157.           (incf pixsofar pixthistime)
  158.           (ic::note-progress pixsofar bvar))))))
  159.        fs))))
  160.  
  161. (defun canny-boldt (image x1 y1 x2 y2 fs &key (sensitivity :medium) 
  162.               (minlength nil))
  163.   "  Run Canny-Boldt line extraction on the given image, within the
  164.   bounding box (x1,y1)-(x2,y2), specified in 2d-world coordinates.
  165.   Resulting lines are put in the feature set specified by fs.
  166.   Sensitivity can be :low, :medium (default), or :high."
  167.   (when (> x1 x2) (rotatef x1 x2))
  168.   (when (> y1 y2) (rotatef y1 y2))
  169.    (multiple-value-bind (u1 v1 u2 v2)
  170.      (cme::transform-2dworld-bounding-box image x1 y1 x2 y2)
  171.      (canny-boldt-uv image u1 v1 u2 v2 fs
  172.          :sensitivity sensitivity :minlength minlength)))
  173.  
  174. (defun run-boldt-from-menu ()
  175.   (ic::with-cvv-items
  176.    (((sens "Sensitivity" :assoc :alist
  177.        (("Low" :low "Low sensitivity")
  178.         ("Medium" :medium "Medium sensitivity")
  179.         ("High" :high "High sensitivity"))
  180.        :documentation "Choose a sensitivity setting"
  181.        :initial-value :medium)
  182.      (minlength "Min Length" :float :initial-value 5.0
  183.         :documentation "Minimum desired line length")
  184.      (maxres "Max Resolution"
  185.         :yes-or-no :initial-value t
  186.         :documentation "use highest available image resolution?"))
  187.     :label "Boldt Lines")
  188.   (multiple-value-bind (bbox panechoice) (cme::pick-bounding-box-and-pane)
  189.    (let* ((topview (cme::top-view panechoice))
  190.       (image (if maxres 
  191.              (ic::top-of-image-hierarchy (cme::view-image topview))
  192.              (cme::view-image topview)))
  193.       (world (cme::2d-world image))
  194.       (fs (cme::get-or-make-2d-feature-set world cme::*2d-line-fsname*))
  195.       (2dtoim-trans (cme::inverse-transform 
  196.              (cme::image-to-2d-transform image)))
  197.       (winto2d-trans (cme::inverse-transform 
  198.               (cme::2d-to-window-transform topview)))
  199.       (wintoim-trans (cme::make-composite-coordinate-transform 
  200.               (list winto2d-trans 2dtoim-trans))))
  201.      (multiple-value-bind (u1 v1 u2 v2)
  202.        (apply #'cme::transform-2d-bounding-box wintoim-trans bbox)
  203.        (canny-boldt-uv image u1 v1 u2 v2 fs
  204.             :sensitivity sens :minlength minlength))))))
  205.  
  206.  
  207. #|======================================================================
  208.  
  209. (defun test-canny-boldt (&key (sensitivity (cadr '(:low :medium :high))))
  210.   (multiple-value-bind (bbox panechoice) (cme::pick-bounding-box-and-pane)
  211.     (let* ((topview (cme::top-view panechoice))
  212.        (image (ic::top-of-image-hierarchy (cme::view-image topview)))
  213.        (world (cme::2d-world image))
  214.        (fs (cme::find-fs-named world cme::*2d-line-fsname*))
  215.        (pane-trans (cme::inverse-transform
  216.             (cme::2d-to-window-transform topview))) 
  217.        (world-bbox (multiple-value-list
  218.         (apply #'cme::transform-2d-bounding-box pane-trans bbox)))
  219.        (sensparams (sensitivity-params sensitivity))
  220.        (mask-size (car sensparams))
  221.        (low-thresh (cadr sensparams))
  222.        (high-thresh (third sensparams))
  223.        (length-thresh (fourth sensparams))
  224.        (halfsize (1+ (ash mask-size -1)))
  225.        (edges nil)(xdim nil) (ydim nil) (trans nil))
  226.       (setf edges (cme::compute-2dworld-canny-edges 
  227.            image (car world-bbox) (cadr world-bbox)
  228.            (third world-bbox) (fourth world-bbox)
  229.            :mask-size mask-size
  230.            :lo-threshold low-thresh
  231.            :hi-threshold high-thresh))
  232.       (setf xdim (ic::image-x-dim (cme::edgeimg-image edges)))
  233.       (setf ydim (ic::image-y-dim (cme::edgeimg-image edges)))
  234.       (edges-to-boldt-file edges (temp-filename "cannyedges.asc")
  235.                halfsize halfsize 
  236.                (- xdim halfsize 2) (- ydim halfsize 2))
  237.       (setf trans (cme::image-to-2d-transform (cme::edgeimg-image edges)))
  238.       (cme::free-edgeimg edges)
  239.       (shell (format nil "~a ~a ~d ~d ~d" (boldt-filename "runboldt")
  240.              (temp-filename "") xdim ydim length-thresh))
  241.       (read-lines-into-fs (temp-filename "boldtlines.asc") trans fs world)
  242.       t)))
  243.  
  244. |#
  245.  
  246.       
  247.  
  248. #|
  249.  
  250. (defun cme::cl () 
  251.   (load (compile-file (boldt::boldt-filename "canny-boldt.lisp"))))
  252.  
  253. (defun foo (imax)
  254.   (ic::noting-progress ("Test" imax :progress-var my-progress)
  255.      (dotimes (i imax)
  256.     (print (list i (log (+ 1.0 (sqrt i)))))
  257.     (sleep 0.5)
  258.     (ic::note-progress i  my-progress ))))
  259.  
  260.  
  261. (defun write-lines-from-fs (stream fs)
  262.   "Writes a set of ascii lines from a feature set to a stream."
  263.   (let ((numlines 0))
  264.     (dolist (obj (cme::inferiors fs))
  265.       (when (eq (type-of obj) 'cme::2d-curve)
  266.         (incf numlines)))
  267.     (format stream "~d curves~%" numlines)
  268.     (dolist (obj (cme::inferiors fs) fs)
  269.       (when (eq (type-of obj) 'cme::2d-curve)
  270.         (let ((verts (cme::make-vertex-list-from-vertex-array
  271.               (cme::vertices obj))))
  272.       (let ((x1 (car (car verts)))
  273.         (y1 (cadr (car verts)))
  274.         (x2 (car (cadr verts)))
  275.         (y2 (cadr (cadr verts)))
  276.         (cont 0.0))
  277.         (format stream "~,4f ~,4f ~,4f ~,4f ~,4f~%" x1 y1 x2 y2 cont)))))))
  278.  
  279.  
  280. (defun convert-isr-tokens-to-cme-curves (tokenset fs)
  281.   (let ((world (2d-world fs)))
  282.     (isr2::for-every-token (tok tokenset (x1 y1 x2 y2))
  283.       (let ((vx1 (isr2::value x1))
  284.         (vy1 (isr2::value y1))
  285.         (vx2 (isr2::value x2))
  286.         (vy2 (isr2::value y2)))
  287.         (add-object
  288.       (make-2d-curve
  289.        :vertices (cme::make-vertex-array-from-vertex-list
  290.               (list (list vx1 vy1 0.0)
  291.                 (list vx2 vy2 0.0)))
  292.        :closed-p t
  293.        :world world)
  294.       fs)))
  295.     fs))
  296.  
  297.  
  298. |#