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 / ISR / isr2rcde.lisp < prev    next >
Lisp/Scheme  |  1996-02-21  |  15KB  |  374 lines
  1. ;;; ISR2RCDE.LISP
  2. ;;; Interface between ISR2 and RCDE graphics routines
  3. ;;;
  4. ;;; Author: Robert T. Collins
  5. ;;; Date: April 3, 1995
  6. ;;;
  7. ;-----------------------------------------------------------------
  8. ; (c) Copyright 1995 by The University of Massachusetts
  9. ;------------------------------------------------------------------
  10.  
  11. ;8/28/95 - Bob Collins
  12. ;  updated read-raw-XY-data-lines-into-isr to print out a count of the
  13. ;  number of lines being updated as they are processed, so that the user
  14. ;  can see that something is really happening.
  15. ;7/4/95 - Bob Collins
  16. ;  added approx-line-not-visible-p and modified the isr line tokenset object's
  17. ;  draw-on-view-internal to display faster by ignoring lines outside of the
  18. ;  view bounding box.  To display portions of large linesets any faster
  19. ;  will probably require the use of ISR grid structures.
  20.  
  21.  
  22. (in-package 'cme)
  23.  
  24. (defclass isr-line-tokenset-object
  25.   (2d-object)
  26.   ((tokenset :initform nil :initarg :tokenset :accessor tokenset)
  27.    (tokensetname :initform nil :initarg :tokensetname :accessor tokensetname)
  28.    (load-filename :initform nil :initarg :load-filename :accessor load-filename)
  29.    (c-filename :initform nil :initarg :c-filename :accessor c-filename)
  30.    (color :initform nil :initarg :color :accessor color)
  31.    (thickness :initform nil :initarg :thickness :accessor thickness)
  32.    )
  33.   (:default-initargs :color "GREEN" :thickness 1))
  34.  
  35.  
  36. (define-fasd-form-init-plist isr-line-tokenset-object
  37.     (with-slot-values (tokenset tokensetname load-filename c-filename
  38.                 color thickness) self
  39.       `(:tokenset (internal-read-tokenset ,tokensetname ,load-filename
  40.               ,(isr2:token-count tokenset))
  41.     :tokensetname ,tokensetname
  42.     :load-filename ,load-filename
  43.     :c-filename ,c-filename
  44.     :color ,color
  45.     :thickness ,thickness)))
  46.  
  47. (defun get-or-make-ISR-tokenset (2dfs)
  48.   (let ((isrobject (find 'ISR-LINE-TOKENSET-OBJECT (inferiors 2dfs) 
  49.              :key #'type-of :test #'equal)))
  50.     (unless isrobject
  51.       (let* ((2dworld (world 2dfs))
  52.          (tksname (concatenate 'string
  53.             (replace-spaces-with-hyphens (string (name 2dworld)))
  54.             (string (gensym "-lines"))))
  55.          (tks (isr2:create tksname 
  56.             :token-features 
  57.             '((x1 "" :real)(y1 "" :real)
  58.               (x2 "" :real)(y2 "" :real)(contrast "" :real))
  59.             :frame-features
  60.             '((numrows "" :integer) (numcols "" :integer)
  61.               (label "" :string))))
  62.          (image (car (base-image-list 2dworld))))
  63.     tks
  64.     (setf (isr2:value (isr2:handle (list tksname 'numrows)))
  65.           (if image (ceiling (image-x-dim image)) 0))
  66.     (setf (isr2:value (isr2:handle (list tksname 'numcols))) 
  67.           (if image (ceiling (image-y-dim image)) 0))
  68.     (setf (isr2:value (isr2:handle (list tksname 'label))) "unused")
  69.     (setf isrobject
  70.           (make-instance 'isr-line-tokenset-object
  71.          :tokenset (isr2:handle tksname)
  72.          :tokensetname tksname
  73.          :load-filename nil
  74.          :c-filename nil
  75.          :color "GREEN"
  76.          :thickness 1))
  77.     (add-object isrobject 2dfs)))
  78.     (values isrobject (tokensetname isrobject))))
  79.  
  80. (defun write-isr-line-tokenset (stream isrobject &key (write-load-file t))
  81.   (format stream "(make-instance 'isr-line-tokenset-object~%")
  82.   (format stream "  :tokenset (internal-read-tokenset ~s ~s ~d)~%"
  83.       (tokensetname isrobject) (load-filename isrobject) 
  84.       (isr2::token-count (tokenset isrobject)))
  85.   (format stream "  :tokensetname ~s~%" (tokensetname isrobject))
  86.   (format stream "  :load-filename ~s~%" (load-filename isrobject))
  87.   (format stream "  :c-filename ~s~%" (c-filename isrobject))
  88.   (format stream "  :color ~s~%" (color isrobject))
  89.   (format stream "  :thickness ~s~%" (thickness isrobject))
  90.   (format stream ")~%")
  91.   (when write-load-file
  92.     (unless (load-filename isrobject)
  93.     (error "ISR tokenset load-filename has not been specified!"))
  94.     (format t "Saving fast-load isr2 file ~a~%" (load-filename isrobject))
  95.     (isr2:store (tokensetname isrobject) (load-filename isrobject)))
  96.   isrobject)
  97.  
  98. (defun read-isr-line-tokenset (stream)
  99.   (eval (read stream)))
  100.  
  101. (defvar isr2rcde*%%tmpvec* (cme::make-coordinate-vector 3))
  102.  
  103. (defmacro isr2rcde-inline-transform (transform position &optional to-vector)
  104.   `(let ((transform ,transform)
  105.          (position ,position)
  106.          (to-vector ,to-vector) )
  107.      (unless to-vector (setf to-vector isr2rcde*%%tmpvec*))
  108.      (unless (vectorp position)
  109.        (setq position (cme::position-to-vector position to-vector )))
  110.      (if (null transform)
  111.          position
  112.          (cme::transform-vector transform position to-vector))))
  113.  
  114.  
  115. (defun approx-line-not-visible-p (minx miny maxx maxy x1 y1 x2 y2)
  116.   "  Quick, approximate check to see if a line segment could possibly
  117.   pass through the given rectangular region."
  118.   (if (< x1 x2)
  119.       (or (< x2 minx) (> x1 maxx)
  120.       (if (< y1 y2) 
  121.           (or (< y2 miny) (> y1 maxy))
  122.           (or (< y1 miny) (> y2 maxy))))
  123.       (or (< x1 minx) (> x2 maxx)
  124.       (if (< y1 y2) 
  125.           (or (< y2 miny) (> y1 maxy))
  126.           (or (< y1 miny) (> y2 maxy))))))
  127.  
  128. (defmethod draw-on-view-internal ((self isr-line-tokenset-object)
  129.                   view drawing-context)
  130.   (with-slot-values (tokenset color thickness) self
  131.   (let ((transform (2d-to-window-transform view)))
  132.     (ic::with-drawing-context-line-width (drawing-context thickness)
  133.       (with-drawing-context-color (drawing-context color)
  134.         (bind-vector-elements (minx maxx miny maxy) (window-2d-bbox view)
  135.           (isr2::for-every-token (tok tokenset (x1 y1 x2 y2))
  136.         (let ((vx1 (isr2::value x1))
  137.           (vy1 (isr2::value y1))
  138.           (vx2 (isr2::value x2))
  139.           (vy2 (isr2::value y2)))
  140.           (unless (approx-line-not-visible-p minx miny maxx maxy
  141.                          vx1 vy1 vx2 vy2)
  142.            (bind-vector-elements 
  143.         (u1 v1)(isr2rcde-inline-transform transform (list vx1 vy1))
  144.         (bind-vector-elements
  145.          (u2 v2)(isr2rcde-inline-transform transform (list vx2 vy2))
  146.          (dc-draw-line drawing-context u1 v1 u2 v2))))))))))))
  147.  
  148.  
  149. (defun read-ascii-lines-into-isr (tksname stream numlines &key 
  150.                    (docstring "Read Lines")
  151.                    (transform nil)(swap-xy nil))
  152.   "Read a file of ascii data lines (x1 y1 x2 y2 contrast) into an isr2 tokenset."
  153.   (ic::noting-progress (docstring numlines :progress-var readvar)
  154.     (dotimes (i numlines tksname)
  155.       (let ((u1 (read stream))
  156.         (v1 (read stream))
  157.         (u2 (read stream))
  158.         (v2 (read stream))
  159.         (cont (read stream))
  160.         x1 y1 x2 y2)
  161.     (when swap-xy (rotatef u1 v1) (rotatef u2 v2))
  162.     (if transform
  163.         (cme::bind-vector-elements 
  164.          (x y)(cme::isr2rcde-inline-transform transform 
  165.             (list (coerce u1 'single-float) (coerce v1 'single-float)))
  166.          (setf x1 x y1 y)
  167.          (cme::bind-vector-elements 
  168.           (x y)(cme::isr2rcde-inline-transform transform 
  169.              (list (coerce u2 'single-float) (coerce v2 'single-float)))
  170.           (setf x2 x y2 y)))
  171.       ;;else
  172.       (setf x1 u1 x2 u2 y1 v1 y2 v2))
  173.         (let ((newtok (isr2:create-new-token tksname)))
  174.       (setf (isr2:value (list newtok 'x1)) x1)
  175.       (setf (isr2:value (list newtok 'y1)) y1)
  176.       (setf (isr2:value (list newtok 'x2)) x2)
  177.       (setf (isr2:value (list newtok 'y2)) y2)
  178.       (setf (isr2:value (list newtok 'contrast)) 
  179.           (coerce cont 'single-float))))
  180.       (ic::note-progress i readvar))))
  181.  
  182.  
  183. (defun make-quad-from-bbox (x1 y1 x2 y2)
  184.   (list (list x1 y1) (list x1 y2) (list x2 y2) (list x2 y1)))
  185.  
  186.  
  187. (defun write-ascii-2dlines-in-pane-bbox (stream pane bbox)
  188.   (let* ((topview (cme::top-view pane))
  189.      (2dworld (cme::2d-world topview))
  190.      (pane-trans (cme::inverse-transform
  191.               (cme::2d-to-window-transform topview))))
  192.     (multiple-value-bind (minx miny maxx maxy)
  193.        (apply #'cme::transform-2d-bounding-box pane-trans bbox)
  194.        (multiple-value-bind (ignore tokenset)
  195.       (get-or-make-ISR-tokenset (find-fs-named 2dworld *2d-line-fsname*))
  196.       ignore
  197.       (isr2::for-every-token (tok tokenset (x1 y1 x2 y2 contrast))
  198.         (let ((vx1 (isr2::value x1))
  199.           (vy1 (isr2::value y1))
  200.           (vx2 (isr2::value x2))
  201.           (vy2 (isr2::value y2)))
  202.           (unless (approx-line-not-visible-p minx miny maxx maxy
  203.                          vx1 vy1 vx2 vy2)
  204.          (format stream "~,2f ~,2f ~,2f ~,2f ~,2f~%" 
  205.              vx1 vy1 vx2 vy2
  206.              (isr2:value contrast)))))))))
  207.  
  208.  
  209. (defun create-updated-ascii-line-file (inasciifile isrtokenset outasciifile)
  210.   (with-open-file (outfile outasciifile :direction :output)
  211.     (with-open-file (file inasciifile :direction :input)
  212.       (do ((line (read-line file) (read-line file)))
  213.       ((string-equal line "DATA:") (format outfile "~a~%" line))
  214.     (format outfile "~a~%" line)))
  215.     (isr2::for-every-token (tok isrtokenset (x1 y1 x2 y2 contrast))
  216.       (format outfile "~,2f ~,2f ~,2f ~,2f ~,2f~%" (isr2:value x1) (isr2:value y1)
  217.           (isr2:value x2) (isr2:value y2) (isr2:value contrast)))))
  218.  
  219.  
  220. (defun internal-read-tokenset (tokensetname filename numlines)
  221.   (format t "Reading tokenset ~a containing ~d lines~%" tokensetname numlines)
  222.   (isr2::restore tokensetname filename)
  223.   (isr2::handle tokensetname))
  224.  
  225. (defun replace-spaces-with-hyphens (string)
  226.   (substitute #\- #\Space string))
  227.  
  228. (defun read-image-to-2d-transform (imagefilename)
  229.   (let ((plist  (ic::get-image-file-property-list imagefilename)))
  230.     (let ((pos (position :IMAGE-TO-2D-TRANSFORM plist)))
  231.       (when pos (elt plist (+ pos 1))))))
  232.  
  233.  
  234. #|==================== OLD CODE, AND CODE FOR TESTING ====================
  235.  
  236. (defun read-raw-XY-data-lines-into-isr (tksname filename &key
  237.                      (numrows 0)(numcols 0)(transform nil))
  238.   "Read a file of ascii data lines (x1 y1 x2 y2 contrast) into an isr2 tokenset."
  239.   (init-number-report 
  240.      (format nil "~%Loading tokenset ~a into the ISR... " tksname) 0)
  241.   (let ((tokcount 0))
  242.    (with-open-file (file filename :direction :input)
  243.     (do ((line (read-line file) (read-line file)))
  244.     ((string-equal line "DATA:") nil))
  245.     (isr2:create tksname 
  246.         :token-features 
  247.       '((x1 "" :real)(y1 "" :real)
  248.         (x2 "" :real)(y2 "" :real)(contrast "" :real))
  249.         :frame-features
  250.             '((numrows "" :integer) (numcols "" :integer) (label "" :string)))
  251.     (setf (isr2:value (isr2:handle (list tksname 'numrows))) (ceiling numrows))
  252.     (setf (isr2:value (isr2:handle (list tksname 'numcols))) (ceiling numcols))
  253.     (setf (isr2:value (isr2:handle (list tksname 'label))) "unused")    
  254.     (do ((x1 (read file nil :eof) (read file nil :eof)))
  255.         ((eq x1 :eof) tksname)
  256.       (let ((y1 (read file))
  257.             (x2 (read file))
  258.             (y2 (read file))
  259.         (contrast (read file)))
  260.     (when (zerop (mod (incf tokcount) 100))
  261.           (update-number-report tokcount))
  262.         (let ((newtok (isr2:create-new-token tksname)))
  263.       (bind-vector-elements 
  264.        (u1 v1)(isr2rcde-inline-transform transform
  265.                    (list (coerce x1 'single-float) (coerce y1 'single-float)))
  266.        (bind-vector-elements 
  267.         (u2 v2)(isr2rcde-inline-transform transform
  268.                 (list (coerce x2 'single-float) (coerce y2 'single-float)))
  269.         (setf (isr2:value (list newtok 'x1)) u1)
  270.         (setf (isr2:value (list newtok 'y1)) v1)
  271.         (setf (isr2:value (list newtok 'x2)) u2)
  272.         (setf (isr2:value (list newtok 'y2)) v2)
  273.         (setf (isr2:value (list newtok 'contrast)) 
  274.           (coerce contrast 'single-float))
  275.         ))))))
  276.   (update-number-report (isr2::token-count tksname))
  277.   (end-number-report " lines") 
  278.   tksname))
  279.  
  280. (defun read-and-install-line-featureset (2dworld filename image
  281.                      newasciifile newisrfile fsname)
  282.   (let* ((transform (read-image-to-2d-transform image))
  283.      (tksname (read-raw-XY-data-lines-into-isr
  284.             (concatenate 'string
  285.                (replace-spaces-with-hyphens (string (name 2dworld)))
  286.                "-lines")
  287.             filename
  288.             :transform transform
  289.             :numrows (image-x-dim (or (car (base-image-list 2dworld))
  290.                           image))
  291.             :numcols (image-y-dim (or (car (base-image-list 2dworld))
  292.                           image))))
  293.      (isrobject (make-instance 'isr-line-tokenset-object
  294.             :tokenset (isr2:handle tksname)
  295.             :tokensetname tksname
  296.             :load-filename (namestring newisrfile)
  297.             :c-filename (namestring newasciifile)
  298.             :color "GREEN")))
  299.     (format t "Saving updated ascii line file ~a~%" newasciifile)
  300.     (create-updated-ascii-line-file filename tksname newasciifile)
  301.     (format t "Saving fast-load isr2 file ~a~%" newisrfile)
  302.     (isr2:store tksname newisrfile) 
  303.     (format t "Adding lines to view-list~%")
  304.     (let ((fs (make-2d-feature-set :world 2dworld :name fsname
  305.                    :inferiors (list isrobject))))
  306.       (dolist (view (view-list 2dworld))
  307.           (add-view fs view :sensitize t)))))
  308.  
  309.  
  310. >  (time (cme::read-raw-XY-data-lines-into-isr 'foo file))
  311.  
  312. Loading tokenset FOO into the ISR...  4178 lines
  313. Elapsed Real Time = 63.35 seconds (1 minute, 3.35 seconds)
  314. Total Run Time    = 59.60 seconds
  315. User Run Time     = 59.54 seconds
  316. System Run Time   = 0.06 seconds
  317. Process Page Faults    =        406
  318. Dynamic Bytes Consed   =          0
  319. Ephemeral Bytes Consed =  5,111,856
  320. There were 9 ephemeral GCs
  321.  
  322. (defun test-load-isr (tksname filename)
  323.   "Read a file of ascii data lines (x1 y1 x2 y2 contrast) into an isr2 tokenset."
  324.   (format t "~%Loading tokenset ~a into the ISR... " tksname)
  325.   (with-open-file (file filename :direction :input)
  326.     (isr2:create tksname 
  327.         :token-features 
  328.       '((x1 "" :real)(y1 "" :real)(x2 "" :real)(y2 "" :real)(contrast "" :real))
  329.         :frame-features
  330.             '((numrows "" :integer) (numcols "" :integer) (label "" :string)))
  331.     (setf (isr2:value (isr2:handle (list tksname 'numrows))) 0)
  332.     (setf (isr2:value (isr2:handle (list tksname 'numcols))) 0)
  333.     (setf (isr2:value (isr2:handle (list tksname 'label))) "unused")    
  334.     (let ((x1hand (isr2:handle (list tksname "<?>x1")))
  335.       (y1hand (isr2:handle (list tksname "<?>y1")))
  336.       (x2hand (isr2:handle (list tksname "<?>x2")))
  337.       (y2hand (isr2:handle (list tksname "<?>y2")))
  338.       (cohand (isr2:handle (list tksname "<?>contrast"))))
  339.       (do ((x1 (read file nil :eof) (read file nil :eof))
  340.        (index 0 (+ index 1)))
  341.       ((eq x1 :eof) tksname)
  342.      (let ((y1 (read file))
  343.            (x2 (read file))
  344.            (y2 (read file))
  345.            (contrast (read file)))
  346.        (let ((newtok (isr2:create-new-token tksname)))
  347.          (setf (isr2::handle-token x1hand) index)
  348.          (setf (isr2::handle-token x2hand) index)
  349.          (setf (isr2::handle-token y1hand) index)
  350.          (setf (isr2::handle-token y2hand) index)
  351.          (setf (isr2::handle-token cohand) index)
  352.          (setf (isr2:value x1hand) (coerce x1 'single-float))
  353.          (setf (isr2:value y1hand) (coerce y1 'single-float))
  354.          (setf (isr2:value x2hand) (coerce x2 'single-float))
  355.          (setf (isr2:value y2hand) (coerce y2 'single-float))
  356.          (setf (isr2:value cohand) (coerce contrast 'single-float))
  357.       )))))
  358.   (format t " ~d lines~%" (isr2::token-count tksname))
  359.   tksname)
  360.  
  361. > (time (cme::test-load-isr 'bar file))
  362.  
  363. Loading tokenset BAR into the ISR...  4178 lines
  364. Elapsed Real Time = 56.69 seconds
  365. Total Run Time    = 55.55 seconds
  366. User Run Time     = 55.49 seconds
  367. System Run Time   = 0.06 seconds
  368. Process Page Faults    =         86
  369. Dynamic Bytes Consed   =          0
  370. Ephemeral Bytes Consed =  4,210,136
  371. There were 8 ephemeral GCs
  372.  
  373. |#
  374.