(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "PLOT")

(il:filecreated " 1-Dec-88 12:04:21" il:{qv}<idl>next>plot-objects.\;24
 70027  

      il:|changes| il:|to:|  (il:functions define-plot-object symbol-to-bitmap l1-metric l1-metric-xy
                                    sine-wave plot-points get-compound draw-graph)

      il:|previous| il:|date:| "15-Nov-88 18:51:12" il:{qv}<idl>next>plot-objects.\;22)


; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:plot-objectscoms)

(il:rpaqq il:plot-objectscoms

          (
           (il:* il:|;;| "Definer for plot-objects")


           (il:coms (il:variables *plot-object-types* *plot-object-type-table* 
                           *plot-object-constructor-table* *plot-object-menus*)
                  (il:functions define-plot-object)
                  (il:functions type-of-object))
           
           (il:* il:|;;| "Utilities")


           (il:coms 

                  (il:* il:|;;| "Bitmaps")


                  (il:variables *star* *circle* *cross*)
                  (il:functions bitmap-to-symbol symbol-to-bitmap)
                  (il:functions make-symbol-menu)
                  
                  (il:* il:|;;| "Line styles")


                  (il:variables *dash* *dot* *dot-dash*)
                  (il:functions make-dashing-menu)
                  
                  (il:* il:|;;| "Textures")


                  (il:variables *shade-1* *shade-2* *shade-3* *shade-4* *shade-5* *shade-6* *shade-7*
                         *shade-8*)
                  (il:functions make-texture-menu)
                  
                  (il:* il:|;;| "Line styles")


                  (il:structures line-style)
                  (il:functions change-style-width change-style-dashing)
                  
                  (il:* il:|;;| "Generic labeling")


                  (il:functions label-generic)
                  
                  (il:* il:|;;| "Distance utilities")


                  (il:functions l1-metric l1-metric-xy positions-list-extent positions-list-distance
                         no-extent)
                  
                  (il:* il:|;;| "Rendering Utilities")


                  (il:functions connect-positions)
                  
                  (il:* il:|;;| "Debugging")


                  (il:functions sine-wave plot-object-error))
           
           (il:* il:|;;| "Points")


           (il:coms (il:structures point)
                  (il:functions make-point)
                  (il:functions draw-point erase-point highlight-point extent-of-point 
                         distance-to-point label-point move-point copy-point put-point get-point)
                  (il:functions plot-point plot-points change-point-symbol))
           
           (il:* il:|;;| "Curves")


           (il:coms (il:structures curve)
                  (il:functions make-curve)
                  (il:functions draw-curve erase-curve highlight-curve extent-of-curve 
                         distance-to-curve move-curve copy-curve put-curve get-curve)
                  (il:functions plot-curve change-curve-width change-curve-dashing))
           
           (il:* il:|;;| "Polygons")


           (il:coms (il:structures polygon)
                  (il:functions make-polygon)
                  (il:functions draw-polygon erase-polygon highlight-polygon extent-of-polygon 
                         distance-to-polygon move-polygon copy-polygon put-polygon get-polygon)
                  (il:functions plot-polygon change-polygon-width change-polygon-dashing))
           
           (il:* il:|;;| "Filled rectangles")


           (il:coms (il:structures rectangle)
                  (il:functions rectangle-right rectangle-stream-right rectangle-top 
                         rectangle-stream-top)
                  (il:functions make-rectangle)
                  (il:functions draw-rectangle erase-rectangle highlight-rectangle 
                         extent-of-rectangle distance-to-rectangle move-rectangle copy-rectangle 
                         put-rectangle get-rectangle)
                  (il:functions plot-rectangle change-rectangle-border change-rectangle-texture))
           
           (il:* il:|;;| "Text")


           (il:coms (il:structures text)
                  (il:functions make-text)
                  (il:functions draw-text erase-text highlight-text extent-of-text distance-to-text 
                         move-text copy-text put-text get-text)
                  (il:functions plot-text))
           
           (il:* il:|;;| "Compound objects")


           (il:coms (il:structures compound)
                  (il:functions make-compound)
                  (il:functions draw-compound erase-compound highlight-compound extent-of-compound 
                         distance-to-compound move-compound copy-compound put-compound get-compound)
                  (il:functions plot-compound))
           
           (il:* il:|;;| "Analytic lines")


           (il:coms (il:structures line)
                  (il:functions make-line)
                  (il:functions draw-analytic-line erase-analytic-line highlight-line 
                         distance-to-line copy-line extent-of-line put-line get-line)
                  (il:functions plot-line change-line-width change-line-dashing))
           
           (il:* il:|;;| "Graphs")


           (il:coms (il:structures graph)
                  (il:functions make-graph)
                  (il:functions draw-graph erase-graph highlight-graph distance-to-graph copy-graph 
                         extent-of-graph)
                  (il:functions plot-graph change-graph-width change-graph-dashing))
           (xcl:file-environments "PLOT-OBJECTS")))



(il:* il:|;;| "Definer for plot-objects")



(defvar *plot-object-types*
 nil)

(defvar *plot-object-type-table*
 (make-hash-table :test #'eq))

(defvar *plot-object-constructor-table*
 (make-hash-table :test #'eq))

(defvar *plot-object-menus*
 (make-hash-table :test #'eq))

(xcl:defdefiner define-plot-object
 il:structures (type &key methods instance-vars menu-items)
   (let* ((type-package (symbol-package type))
          (type-string (string type))
          (type-keyword (intern type-string (find-package "KEYWORD")))
          (stucture-name (intern (concatenate 'string type-string "-PLOT-OBJECT")
                                type-package))
          (conc-name (concatenate 'string type-string "-"))
          (constructor (intern (concatenate 'string "%MAKE-" type-string)
                              type-package))
          (copier (intern (concatenate 'string "%COPY-" type-string)
                         type-package))
          (methods-name (intern (concatenate 'string "*" type-string "-OBJECT-METHODS*")
                               type-package))
          (methods-alist '((:draw-fn . "DRAW-")
                           (:erase-fn . "ERASE-")
                           (:highlight-fn . "HIGHLIGHT-")
                           (:lowlight-fn . "HIGHLIGHT-")
                           (:extent-fn . "EXTENT-OF-")
                           (:distance-fn . "DISTANCE-TO-")
                           (:label-fn . "LABEL-")
                           (:move-fn . "MOVE-")
                           (:copy-fn . "COPY-")
                           (:put-fn . "PUT-")
                           (:get-fn . "GET-"))))
         (setq methods
               (mapcan #'(lambda (pair)
                                (let* ((keyword (car pair))
                                       (prefix (cdr pair))
                                       (supplied (cdr (pt:memq keyword methods))))
                                      (if supplied
                                          (let ((value (car supplied)))
                                               (if value
                                                   `(,keyword ',value)))
                                          `(,keyword ',(intern (concatenate 'string prefix 
                                                                      type-string)
                                                              type-package)))))
                      methods-alist))
         `(progn (defparameter ,methods-name (make-plot-methods ,@methods))
                 (defstruct (,stucture-name (:include plot-object (methods ,methods-name))
                                   (:conc-name ,conc-name)
                                   (:constructor ,constructor)
                                   (:copier ,copier))
                    ,@instance-vars)
                 (pushnew ',type-keyword *plot-object-types*)
                 (setf (gethash ',stucture-name *plot-object-type-table*)
                       ',type-keyword)
                 (setf (gethash ',type-keyword *plot-object-constructor-table*)
                       ',constructor)
                 ,@(if menu-items
                       `((setf (gethash ',type-keyword *plot-object-menus*)
                               (make-menu :items (append (menu-items *default-middle-menu*)
                                                        ',menu-items)
                                      :when-selected-fn
                                      'default-when-selected-fn :track-cursor-p t)))))))

(defun type-of-object
 (plot-object)
   (gethash (type-of plot-object)
          *plot-object-type-table*))



(il:* il:|;;| "Utilities")





(il:* il:|;;| "Bitmaps")



(defvar *star*
 '#*(5 5)JH@@G@@@OH@@G@@@JH@@)

(defvar *circle*
 '#*(5 5)G@@@HH@@HH@@HH@@G@@@)

(defvar *cross*
 '#*(5 5)B@@@B@@@OH@@B@@@B@@@)

(defun bitmap-to-symbol
 (bitmap)
   (let ((sym-tail (member bitmap '(*star* *circle* *cross*)
                          :key
                          'symbol-value)))
        (if sym-tail
            (car sym-tail)
            bitmap)))

(defun symbol-to-bitmap
 (symbol)
   (let ((sym-tail (pt:memq symbol '(*star* *circle* *cross*))))
        (if sym-tail
            (symbol-value (car sym-tail))
            symbol)))

(defun make-symbol-menu
 ()
   (flet ((bitmap-icon (bitmap &optional (scale-factor 2))
                 (let* ((width (bitmap-width bitmap))
                        (height (bitmap-height bitmap))
                        (icon (make-bitmap (* scale-factor width)
                                     (* scale-factor height))))
                       (stream-bitblt bitmap icon :destination-left (truncate (- (bitmap-width icon)
                                                                                 width)
                                                                           2)
                              :destination-bottom
                              (truncate (- (bitmap-height icon)
                                           height)
                                     2))
                       icon)))
         (make-menu :items `((,(bitmap-icon *star* 4)
                              *star*)
                             (,(bitmap-icon *circle* 4)
                              *circle*)
                             (,(bitmap-icon *cross* 4)
                              *cross*))
                :border-size 1 :track-cursor-p t)))



(il:* il:|;;| "Line styles")



(defvar *dash*
 '(5))

(defvar *dot*
 '(1 5))

(defvar *dot-dash*
 '(5 5 1 5))

(defun make-dashing-menu
 ()
   (flet ((fill-bitmap-with-dashing (dashing &optional (width 50)
                                           (height 10)
                                           (thickness 2))
                 (let* ((bitmap (make-bitmap width height))
                        (stream (il:dspcreate bitmap))
                        (y (truncate height 2)))
                       (stream-draw-line 0 y width y stream :width thickness :operation boole-1 
                              :dashing dashing)
                       bitmap)))
         (make-menu :items `((,(fill-bitmap-with-dashing nil)
                              :solid)
                             (,(fill-bitmap-with-dashing *dash*)
                              *dash*)
                             (,(fill-bitmap-with-dashing *dot*)
                              *dot*)
                             (,(fill-bitmap-with-dashing *dot-dash*)
                              *dot-dash*))
                :border-size 1 :track-cursor-p t)))



(il:* il:|;;| "Textures")



(defvar *shade-1*
 64)

(defvar *shade-2*
 576)

(defvar *shade-3*
 4680)

(defvar *shade-4*
 37449)

(defvar *shade-5*
 55899)

(defvar *shade-6*
 31710)

(defvar *shade-7*
 64479)

(defvar *shade-8*
 65023)

(defun make-texture-menu
 ()
   (flet ((texture-bitmap (texture &optional (width 30)
                                 (height 20))
                 (let* ((bitmap (make-bitmap width height)))
                       (stream-bltshade texture bitmap)
                       bitmap)))
         (make-menu :items `((,(texture-bitmap *shade-1*)
                              *shade-1*)
                             (,(texture-bitmap *shade-2*)
                              *shade-2*)
                             (,(texture-bitmap *shade-3*)
                              *shade-3*)
                             (,(texture-bitmap *shade-4*)
                              *shade-4*)
                             (,(texture-bitmap *shade-5*)
                              *shade-5*)
                             (,(texture-bitmap *shade-6*)
                              *shade-6*)
                             (,(texture-bitmap *shade-7*)
                              *shade-7*)
                             (,(texture-bitmap *shade-8*)
                              *shade-8*))
                :border-size 1 :track-cursor-p t)))



(il:* il:|;;| "Line styles")



(defstruct (line-style
 (:type list)
                           (:conc-name "STYLE-"))
   (width 1)
   dashing color)

(defun change-style-width
 (new-width style plot-object plot)

   (il:* il:|;;| "Assumes an open plot-window")


   (when (null new-width)
       (print-plot-prompt "Indicate new width" plot)
       (setq new-width (il:rnumber nil nil nil nil t nil t))
       (print-plot-prompt "" plot))
   (when new-width
       (let ((view-port (plot-view-port plot)))
            (erase-plot-object plot-object view-port plot)
            (setf (style-width style)
                  new-width)
            (draw-plot-object plot-object view-port plot))))

(defun change-style-dashing
 (new-dashing style plot-object plot)

   (il:* il:|;;| "Assumes an open plot-window")


   (when (null new-dashing)
       (print-plot-prompt "Indicate new dashing" plot)
       (setq new-dashing (pop-up-menu (il:constant (make-dashing-menu))))
       (print-plot-prompt "" plot))
   (when new-dashing
       (let ((view-port (plot-view-port plot)))
            (erase-plot-object plot-object view-port plot)
            (setf (style-dashing style)
                  (if (eq new-dashing :solid)
                      nil
                      new-dashing))
            (draw-plot-object plot-object view-port plot))))



(il:* il:|;;| "Generic labeling")



(defun label-generic
 (object plot)
              (il:* il:\; "Edited  5-May-87 17:56 by jop")


   (il:* il:|;;| "Generic label routine.  Intended for interactive use only")


   (let ((view-port (plot-view-port plot))
         (text-object (plot-object-prop object :label-object)))
        (if text-object
            (draw-plot-object text-object view-port plot)
            (let ((label (plot-object-label object))
                  (label-position (progn (print-plot-prompt "Select a position for label: " plot)
                                         (stream-to-world (get-position (plot-window plot))
                                                view-port))))
                 (setq text-object (make-text label-position label :font *small-plot-font*))
                 (draw-plot-object text-object view-port plot)
                 (setf (plot-object-prop object :label-object)
                       text-object)))))



(il:* il:|;;| "Distance utilities")



(defmacro l1-metric
 (position-1 position-2)
   (pt:once-only (position-1 position-2)
          `(+ (abs (- (position-x ,position-1)
                      (position-x ,position-2)))
              (abs (- (position-y ,position-1)
                      (position-y ,position-2))))))

(defmacro l1-metric-xy
 (position-1 x y)
   (pt:once-only (position-1)
          `(+ (abs (- (position-x ,position-1)
                      ,x))
              (abs (- (position-y ,position-1)
                      ,y)))))

(defun positions-list-extent
 (positions)
   (let* ((first-position (car positions))
          (min-x (position-x first-position))
          (max-x min-x)
          (min-y (position-y first-position))
          (max-y min-y))
         (dolist (position (cdr positions))
             (let ((x (position-x position))
                   (y (position-y position)))
                  (if (< x min-x)
                      (setq min-x x)
                      (if (> x max-x)
                          (setq max-x x)))
                  (if (< y min-y)
                      (setq min-y y)
                      (if (> y max-y)
                          (setq max-y y)))))
         (make-extent :min-x min-x :max-x max-x :min-y min-y :max-y max-y)))

(defun positions-list-distance
 (positions target)
   (let ((min (l1-metric (car positions)
                     target)))
        (dolist (position (cdr positions))
            (let ((candidate (l1-metric position target)))
                 (if (< candidate min)
                     (setq min candidate))))
        min))

(defun no-extent
 (plot-object)
   (declare
 (ignore plot-object))
   nil)



(il:* il:|;;| "Rendering Utilities")



(defun connect-positions
 (stream-positions stream stream-subregion operation line-width color 
                                    dashing &optional close-loop-p)
   (let ((first-position (car stream-positions))
         (rest-positions (cdr stream-positions)))
        (stream-move-to (position-x first-position)
               (position-y first-position)
               stream)
        (dolist (position rest-positions)
            (clipped-draw-to (position-x position)
                   (position-y position)
                   stream stream-subregion :width line-width :operation operation :color color 
                   :dashing dashing))
        (if close-loop-p
            (clipped-draw-to (position-x first-position)
                   (position-y first-position)
                   stream stream-subregion :width line-width :operation operation :color color 
                   :dashing dashing))))



(il:* il:|;;| "Debugging")



(defun sine-wave
 (n from to &optional (frequency 1)
                        (amplitude 1))

   (il:* il:|;;| "produce N points on a sine wave")


   (let* ((twopi (* 2.0 pi))
          (range (- to from))
          (x from)
          (inc (/ (float range)
                  n)))
         (pt:with-collection (dotimes (i n)
                                 (pt:collect (make-position x (* amplitude (sin (* frequency x)))))
                                 (incf x inc)))))

(defun plot-object-error
 (&rest args)
   (error "Unimplemented method"))



(il:* il:|;;| "Points")



(define-plot-object point
 :instance-vars (position stream-position symbol)
   :menu-items (("Symbol" change-point-symbol "Change point symbol")))

(defun make-point
 (position &key (symbol *star*)
                             label menu)
   (%make-point :menu menu :label label :position position :symbol symbol))

(defun draw-point
 (point view-port plot)

   (il:* il:|;;| "Draw a glyph at POINT-POSITION.  SYMBOL is the glyph to be drawn.")


   (let ((stream (vp-parent-stream view-port))
         (stream-subregion (vp-stream-subregion view-port))
         (symbol (point-symbol point))
         (stream-point (world-to-stream (point-position point)
                              view-port)))
        (clipped-plot-at stream-point symbol stream stream-subregion)
        (if (eq stream (window-dsp (plot-window plot)))
            (setf (point-stream-position point)
                  stream-point))))

(defun erase-point
 (point view-port plot)

   (il:* il:|;;| "Erase POINT, using cached stream coordinates")


   (clipped-plot-at (point-stream-position point)
          (point-symbol point)
          (vp-parent-stream view-port)
          (vp-stream-subregion view-port)
          boole-andc1))

(defun highlight-point
 (point view-port plot)
   (il:* il:\; "Edited  5-May-87 17:56 by jop")


   (il:* il:|;;| "Highlight POINT")


   (let* ((symbol (point-symbol point))
          (stream-position (point-stream-position point))
          (glyph-width (bitmap-width symbol))
          (glyph-height (bitmap-height symbol))
          (x-offset (- (position-x stream-position)
                       (truncate glyph-width 2)))
          (y-offset (- (position-y stream-position)
                       (truncate glyph-height 2))))
         (clipped-bltshade *black-shade* (vp-parent-stream view-port)
                (vp-stream-subregion view-port)
                :destination-left x-offset :destination-bottom y-offset :width glyph-width :height 
                glyph-height :operation boole-xor)))

(defun extent-of-point
 (point plot)
   (declare
 (ignore plot))
   (point-position point))

(defun distance-to-point
 (point stream-position plot)
   (l1-metric (point-stream-position point)
          stream-position))

(defun label-point
 (point plot)

   (il:* il:|;;| "Label a POINT")


   (let ((view-port (plot-view-port plot))
         (text-object (plot-object-prop point :label-object)))

        (il:* il:|;;| "Displace Label to right of point object")


        (if text-object
            (draw-plot-object text-object view-port plot)
            (let* ((label (point-label point))
                   (position (point-position point))
                   (label-position (make-position (+ (position-x position)
                                                     (* 2 (stream-to-world-length-x
                                                           (bitmap-width (point-symbol point))
                                                           view-port)))
                                          (position-y position))))
                  (setq text-object (make-text label-position label :font *small-plot-font*))
                  (draw-plot-object text-object view-port plot)

                  (il:* il:|;;| "CACHE LABEL ON PROP LIST OF OBJECT")


                  (setf (plot-object-prop point :label-object)
                        text-object)))))

(defun move-point
 (point dx dy plot)
   (let ((position (point-position point)))
        (incf (position-x position)
              dx)
        (incf (position-y position)
              dy)))

(defun copy-point
 (point)
   (let ((new-point (%copy-point point)))
        (setf (point-position new-point)
              (copy-position (point-position point)))
        (setf (point-stream-position new-point)
              nil)
        new-point))

(defun put-point
 (point stream)
   (prin1 (point-position point)
          stream)
   (write-char #\Space stream)
   (prin1 (bitmap-to-symbol (point-symbol point))
          stream))

(defun get-point
 (point stream)
   (setf (point-position point)
         (read stream))
   (setf (point-symbol point)
         (symbol-to-bitmap (read stream))))

(defun plot-point
 (plot position &key label (symbol *star*)
                            menu no-update-p)

   (il:* il:|;;| "User entry point.  Add a point to PLOT, at world position POSITION, with Label LABEL and plotting symbol SYMBOL")


   (add-plot-object (make-point position :symbol symbol :label label :menu menu)
          plot no-update-p))

(defun plot-points
 (plot positions &key labels (symbol *star*)
                             menu no-update-p)

   (il:* il:|;;| "User Entry Point.  Draw the POINTs at POSITIONS in a Plotting WINDOW.")


   (let ((points (pt:with-collection (let ((label labels))
                                          (dolist (position positions)
                                              (pt:collect (make-point position :symbol symbol :label
                                                                 (car label)
                                                                 :menu menu))
                                              (setq label (cdr label)))))))
        (add-plot-objects points plot no-update-p)))

(defun change-point-symbol
 (point plot &optional new-sym)
   (when (null new-sym)
       (print-plot-prompt "Indicate new symbol" plot)
       (setq new-sym (pop-up-menu (il:constant (make-symbol-menu))))
       (print-plot-prompt "" plot))
   (when new-sym
       (let ((view-port (plot-view-port plot)))
            (erase-plot-object point view-port plot)
            (setf (point-symbol point)
                  new-sym)
            (draw-plot-object point view-port plot))))



(il:* il:|;;| "Curves")



(define-plot-object curve
 :instance-vars (positions stream-positions style)
   :methods (:label-fn label-generic)
   :menu-items (("Width" change-curve-width "Change width")
                ("Dashing" change-curve-dashing "Change dashing")))

(defun make-curve
 (positions &key (style (make-line-style))
                             label menu)
   (if (null positions)
       (error "A curve must have at least one position"))
   (%make-curve :menu menu :label label :positions positions :style (if (integerp style)
                                                                        (make-line-style :width style
                                                                               )
                                                                        style)))

(defun draw-curve
 (curve view-port plot)

   (il:* il:|;;| "Draw a series of connected lines in VIEW-PORT.")


   (let* ((stream (vp-parent-stream view-port))
          (stream-positions (mapcar #'(lambda (position)
                                             (world-to-stream position view-port))
                                   (curve-positions curve)))
          (style (curve-style curve))
          (line-width (* (stream-scale stream)
                         (style-width style))))
         (connect-positions stream-positions stream (vp-stream-subregion view-port)
                boole-1 line-width (style-color style)
                (style-dashing style))
         (if (eq stream (window-dsp (plot-window plot)))
             (setf (curve-stream-positions curve)
                   stream-positions))))

(defun erase-curve
 (curve view-port plot)

   (il:* il:|;;| "Erase the CURVEOBJECT, using the cached stream coordinates")


   (let* ((stream (vp-parent-stream view-port))
          (style (curve-style curve))
          (line-width (* (stream-scale stream)
                         (+ 2 (style-width style)))))
         (connect-positions (curve-stream-positions curve)
                stream
                (vp-stream-subregion view-port)
                boole-andc1 line-width (style-color style)
                nil)))

(defun highlight-curve
 (curve view-port plot)
   (il:* il:\; "Edited  5-May-87 17:55 by jop")


   (il:* il:|;;| 

 "Highlight the CURVEOBJECT, by redrawing in invert mode with slightly fatter lines")


   (let* ((stream (vp-parent-stream view-port))
          (style (curve-style curve))
          (line-width (* (stream-scale stream)
                         (+ 2 (style-width style)))))
         (connect-positions (curve-stream-positions curve)
                stream
                (vp-stream-subregion view-port)
                boole-xor line-width (style-color style)
                nil)))

(defun extent-of-curve
 (curve)

   (il:* il:|;;| "Assumes each curve has at least one point")


   (positions-list-extent (curve-positions curve)))

(defun distance-to-curve
 (curve stream-position plot)
   (positions-list-distance (curve-stream-positions curve)
          stream-position))

(defun move-curve
 (curve dx dy plot)
   (let ((positions (curve-positions curve)))
        (dolist (position positions)
            (incf (position-x position)
                  dx)
            (incf (position-y position)
                  dy))))

(defun copy-curve
 (curve)

   (il:* il:|;;| "Copyfn for CURVE objects")


   (let ((new-curve (%copy-curve curve)))
        (setf (curve-positions new-curve)
              (mapcar #'(lambda (position)
                               (copy-position position))
                     (curve-positions curve)))
        (setf (curve-stream-positions new-curve)
              nil)
        (setf (curve-style new-curve)
              (copy-line-style (curve-style curve)))
        new-curve))

(defun put-curve
 (curve stream)
   (prin1 (curve-positions curve)
          stream)
   (write-char #\Space stream)
   (prin1 (curve-style curve)
          stream))

(defun get-curve
 (curve stream)
   (setf (curve-positions curve)
         (read stream))
   (setf (curve-style curve)
         (read stream)))

(defun plot-curve
 (plot positions &key label (style 1)
                            menu no-update-p)

   (il:* il:|;;| "User Entry Point.  Draw a piecewise linear curve in PLOT.  Style is either the line width to use or a list (width dashing color).  POSITIONS is a list of positions to be connected.")


   (add-plot-object (make-curve positions :style style :label label :menu menu)
          plot no-update-p))

(defun change-curve-width
 (curve plot &optional new-width)
   (change-style-width new-width (curve-style curve)
          curve plot))

(defun change-curve-dashing
 (curve plot &optional new-dashing)
   (change-style-dashing new-dashing (curve-style curve)
          curve plot))



(il:* il:|;;| "Polygons")



(define-plot-object polygon
 :instance-vars (positions stream-positions style)
   :methods (:label-fn label-generic)
   :menu-items (("Width" change-polygon-width "Change width")
                ("Dashing" change-polygon-dashing "Change dashing")))

(defun make-polygon
 (positions &key (style (make-line-style))
                               label menu)
   (if (null positions)
       (error "A polygon must have at least one position"))
   (%make-polygon :menu menu :label label :positions positions :style (if (integerp style)
                                                                          (make-line-style :width 
                                                                                 style)
                                                                          style)))

(defun draw-polygon
 (polygon view-port plot)

   (il:* il:|;;| "Draw a series of connected lines in VIEW-PORT.")


   (let* ((stream (vp-parent-stream view-port))
          (stream-positions (mapcar #'(lambda (position)
                                             (world-to-stream position view-port))
                                   (polygon-positions polygon)))
          (style (polygon-style polygon))
          (line-width (* (stream-scale stream)
                         (style-width style)))
          (dashing (style-dashing style)))
         (connect-positions stream-positions stream (vp-stream-subregion view-port)
                boole-1 line-width (style-color style)
                (style-dashing style)
                t)
         (if (eq stream (window-dsp (plot-window plot)))
             (setf (polygon-stream-positions polygon)
                   stream-positions))))

(defun erase-polygon
 (polygon view-port plot)

   (il:* il:|;;| "Erase the CURVEOBJECT, using the cached stream coordinates")


   (let* ((stream (vp-parent-stream view-port))
          (style (polygon-style polygon))
          (line-width (* (stream-scale stream)
                         (+ 2 (style-width style)))))
         (connect-positions (polygon-stream-positions polygon)
                stream
                (vp-stream-subregion view-port)
                boole-andc1 line-width (style-color style)
                nil t)))

(defun highlight-polygon
 (polygon view-port plot)

                                                        (il:* il:\; "Edited  5-May-87 17:55 by jop")

   (let* ((stream (vp-parent-stream view-port))
          (style (polygon-style polygon))
          (line-width (* (stream-scale stream)
                         (+ 2 (style-width style)))))
         (connect-positions (polygon-stream-positions polygon)
                stream
                (vp-stream-subregion view-port)
                boole-xor line-width (style-color style)
                nil t)))

(defun extent-of-polygon
 (polygon)

   (il:* il:|;;| "Assumes each curve has at least one point")


   (positions-list-extent (polygon-positions polygon)))

(defun distance-to-polygon
 (polygon stream-position plot)
   (positions-list-distance (polygon-stream-positions polygon)
          stream-position))

(defun move-polygon
 (polygon dx dy plot)
   (let ((positions (polygon-positions polygon)))
        (dolist (position positions)
            (incf (position-x position)
                  dx)
            (incf (position-y position)
                  dy))))

(defun copy-polygon
 (polygon)
   (let ((new-polygon (%copy-polygon polygon)))
        (setf (polygon-positions new-polygon)
              (mapcar #'(lambda (position)
                               (copy-position position))
                     (polygon-positions polygon)))
        (setf (polygon-stream-positions new-polygon)
              nil)
        (setf (polygon-style new-polygon)
              (copy-line-style (polygon-style polygon)))
        new-polygon))

(defun put-polygon
 (polygon stream)
   (prin1 (polygon-positions polygon)
          stream)
   (write-char #\Space stream)
   (prin1 (polygon-style polygon)
          stream))

(defun get-polygon
 (polygon stream)
   (setf (polygon-positions polygon)
         (read stream))
   (setf (polygon-style polygon)
         (read stream)))

(defun plot-polygon
 (plot positions &key label (style 1)
                              menu no-update-p)

   (il:* il:|;;| "User Entry Point.  Draw a piecewise linear polygon in PLOT.  Style is either the line width to use or a list (width dashing color).  POSITIONS is a list of positions to be connected by a closed set of lines.")


   (add-plot-object (make-polygon positions :style style :label label :menu menu)
          plot no-update-p))

(defun change-polygon-width
 (polygon plot &optional new-width)
   (change-style-width new-width (polygon-style polygon)
          polygon plot))

(defun change-polygon-dashing
 (polygon plot &optional new-dashing)
   (change-style-dashing new-dashing (polygon-style polygon)
          polygon plot))



(il:* il:|;;| "Filled rectangles")



(define-plot-object rectangle
 :instance-vars (left bottom width height border-width texture 
                                                       stream-left stream-bottom stream-width 
                                                       stream-height)
   :methods (:label-fn label-generic)
   :menu-items (("Border" change-rectangle-border "Change border width")
                ("Texture" change-rectangle-texture "Change rectangle texture")))

(defun rectangle-right
 (rectangle)
   (+ (rectangle-left rectangle)
      (rectangle-width rectangle)))

(defun rectangle-stream-right
 (rectangle)
   (+ (rectangle-stream-left rectangle)
      (rectangle-stream-width rectangle)))

(defun rectangle-top
 (rectangle)
   (+ (rectangle-bottom rectangle)
      (rectangle-height rectangle)))

(defun rectangle-stream-top
 (rectangle)
   (+ (rectangle-stream-bottom rectangle)
      (rectangle-stream-height rectangle)))

(defun make-rectangle
 (left bottom width height &key label (border-width 1)
                                (texture *shade-3*)
                                menu)
   (%make-rectangle :menu menu :label label :left left :bottom bottom :width width :height height 
          :border-width border-width :texture texture))

(defun draw-rectangle
 (rectangle view-port plot)
   (let* ((stream (vp-parent-stream view-port))
          (stream-subregion (vp-stream-subregion view-port))
          (texture (rectangle-texture rectangle))
          (border-width (* (stream-scale stream)
                           (rectangle-border-width rectangle)))
          (stream-left (world-to-stream-x (rectangle-left rectangle)
                              view-port))
          (stream-bottom (world-to-stream-y (rectangle-bottom rectangle)
                                view-port))
          (stream-width (- (world-to-stream-x (+ (rectangle-left rectangle)
                                                 (rectangle-width rectangle))
                                  view-port)
                           stream-left))
          (stream-height (- (world-to-stream-y (+ (rectangle-bottom rectangle)
                                                  (rectangle-height rectangle))
                                   view-port)
                            stream-bottom))
          (stream-right (+ stream-left stream-width))
          (stream-top (+ stream-bottom stream-height)))
         (clipped-bltshade texture stream stream-subregion :destination-left stream-left 
                :destination-bottom stream-bottom :width stream-width :height stream-height 
                :operation boole-ior)
         (stream-move-to stream-left stream-bottom stream)
         (clipped-draw-to stream-right stream-bottom stream stream-subregion :width border-width 
                :operation boole-1)
         (clipped-draw-to stream-right stream-top stream stream-subregion :width border-width 
                :operation boole-1)
         (clipped-draw-to stream-left stream-top stream stream-subregion :width border-width 
                :operation boole-1)
         (clipped-draw-to stream-left stream-bottom stream stream-subregion :width border-width 
                :operation boole-1)
         (when (eq stream (window-dsp (plot-window plot)))
             (setf (rectangle-stream-left rectangle)
                   stream-left)
             (setf (rectangle-stream-bottom rectangle)
                   stream-bottom)
             (setf (rectangle-stream-width rectangle)
                   stream-width)
             (setf (rectangle-stream-height rectangle)
                   stream-height))))

(defun erase-rectangle
 (rectangle view-port plot)
   (let* ((stream (vp-parent-stream view-port))
          (stream-subregion (vp-stream-subregion view-port))
          (texture (rectangle-texture rectangle))
          (border-width (* (stream-scale stream)
                           (rectangle-border-width rectangle)))
          (stream-left (rectangle-stream-left rectangle))
          (stream-bottom (rectangle-stream-bottom rectangle))
          (stream-width (rectangle-stream-width rectangle))
          (stream-height (rectangle-stream-height rectangle))
          (stream-right (+ stream-left stream-width))
          (stream-top (+ stream-bottom stream-height)))
         (clipped-bltshade texture stream stream-subregion :destination-left stream-left 
                :destination-bottom stream-bottom :width stream-width :height stream-height 
                :operation boole-xor)
         (stream-move-to stream-left stream-bottom stream)
         (clipped-draw-to stream-right stream-bottom stream stream-subregion :width border-width 
                :operation boole-andc1)
         (clipped-draw-to stream-right stream-top stream stream-subregion :width border-width 
                :operation boole-andc1)
         (clipped-draw-to stream-left stream-top stream stream-subregion :width border-width 
                :operation boole-andc1)
         (clipped-draw-to stream-left stream-bottom stream stream-subregion :width border-width 
                :operation boole-andc1)))

(defun highlight-rectangle
 (rectangle view-port plot)
   (let* ((stream (vp-parent-stream view-port))
          (stream-subregion (vp-stream-subregion view-port))
          (texture (rectangle-texture rectangle))
          (border-width (* (stream-scale stream)
                           (+ 2 (rectangle-border-width rectangle))))
          (stream-left (rectangle-stream-left rectangle))
          (stream-bottom (rectangle-stream-bottom rectangle))
          (stream-width (rectangle-stream-width rectangle))
          (stream-height (rectangle-stream-height rectangle))
          (stream-right (+ stream-left stream-width))
          (stream-top (+ stream-bottom stream-height)))
         (clipped-bltshade *black-shade* stream stream-subregion :destination-left stream-left 
                :destination-bottom stream-bottom :width stream-width :height stream-height 
                :operation boole-xor)
         (stream-move-to stream-left stream-bottom stream)
         (clipped-draw-to stream-right stream-bottom stream stream-subregion :width border-width 
                :operation boole-xor)
         (clipped-draw-to stream-right stream-top stream stream-subregion :width border-width 
                :operation boole-xor)
         (clipped-draw-to stream-left stream-top stream stream-subregion :width border-width 
                :operation boole-xor)
         (clipped-draw-to stream-left stream-bottom stream stream-subregion :width border-width 
                :operation boole-xor)))

(defun extent-of-rectangle
 (rectangle)
   (make-extent :min-x (rectangle-left rectangle)
          :max-x
          (rectangle-right rectangle)
          :min-y
          (rectangle-bottom rectangle)
          :max-y
          (rectangle-top rectangle)))

(defun distance-to-rectangle
 (rectangle stream-position plot)
   (let ((stream-x (position-x stream-position))
         (stream-y (position-y stream-position))
         (stream-left (rectangle-stream-left rectangle))
         (stream-bottom (rectangle-stream-bottom rectangle))
         (stream-right (rectangle-stream-right rectangle))
         (stream-top (rectangle-stream-top rectangle))
         (inside-p nil)
         x-closest y-closest)
        (setq x-closest (cond
                           ((> stream-x stream-right)
                            stream-right)
                           ((< stream-x stream-left)
                            stream-left)
                           (t (if (or (> stream-y stream-top)
                                      (< stream-y stream-bottom))

                                  (il:* il:|;;| "outside ")


                                  stream-x

                                  (il:* il:|;;| "Inside ")


                                  (progn (setq inside-p t)
                                         (if (< (min (- stream-top stream-y)
                                                     (- stream-y stream-bottom))
                                                (min (- stream-right stream-x)
                                                     (- stream-x stream-left)))

                                             (il:* il:|;;| "closer  to top or bottom")


                                             stream-x
                                             (if (< (- stream-right stream-x)
                                                    (- stream-x stream-left))

                                                 (il:* il:|;;| "Closest to right edge")


                                                 stream-right

                                                 (il:* il:|;;| "Closest to left edge")


                                                 stream-left)))))))
        (setq y-closest (cond
                           ((> stream-y stream-top)
                            stream-top)
                           ((< stream-y stream-bottom)
                            stream-bottom)
                           (t (if (or (> stream-x stream-right)
                                      (< stream-x stream-left))

                                  (il:* il:|;;| "outside ")


                                  stream-y

                                  (il:* il:|;;| "Inside ")


                                  (progn (setq inside-p t)
                                         (if (< (min (- stream-right stream-x)
                                                     (- stream-x stream-left))
                                                (min (- stream-top stream-y)
                                                     (- stream-y stream-bottom)))

                                             (il:* il:|;;| "closer  to right or left")


                                             stream-y
                                             (if (< (- stream-top stream-y)
                                                    (- stream-y stream-bottom))

                                                 (il:* il:|;;| "Closest to right edge")


                                                 stream-top

                                                 (il:* il:|;;| "Closest to left edge")


                                                 stream-bottom)))))))
        (let ((raw-distance (l1-metric-xy stream-position x-closest y-closest)))
             (if inside-p

                 (il:* il:|;;| "Hack to deal with the case of adjacent rectangles.  Bonus subtracted from metric if cursor inside rectangle")


                 (- raw-distance 2)
                 raw-distance))))

(defun move-rectangle
 (rectangle dx dy plot)
   (incf (rectangle-left rectangle)
         dx)
   (incf (rectangle-bottom rectangle)
         dy))

(defun copy-rectangle
 (rectangle)

   (il:* il:|;;| "Copyfn for CURVE objects")


   (let ((new-rectangle (%copy-rectangle rectangle)))
        (setf (rectangle-stream-left new-rectangle)
              nil)
        (setf (rectangle-stream-bottom new-rectangle)
              nil)
        (setf (rectangle-stream-width new-rectangle)
              nil)
        (setf (rectangle-stream-height new-rectangle)
              nil)
        new-rectangle))

(defun put-rectangle
 (rectangle stream)
   (prin1 (rectangle-left rectangle)
          stream)
   (write-char #\Space stream)
   (prin1 (rectangle-bottom rectangle)
          stream)
   (write-char #\Space stream)
   (prin1 (rectangle-width rectangle)
          stream)
   (write-char #\Space stream)
   (prin1 (rectangle-height rectangle)
          stream)
   (write-char #\Space stream)
   (prin1 (rectangle-border-width rectangle)
          stream)
   (write-char #\Space stream)
   (prin1 (rectangle-texture rectangle)
          stream))

(defun get-rectangle
 (rectangle stream)
   (setf (rectangle-left rectangle)
         (read stream))
   (setf (rectangle-bottom rectangle)
         (read stream))
   (setf (rectangle-width rectangle)
         (read stream))
   (setf (rectangle-height rectangle)
         (read stream))
   (setf (rectangle-border-width rectangle)
         (read stream))
   (setf (rectangle-texture rectangle)
         (read stream)))

(defun plot-rectangle
 (plot left bottom width height &key label (texture *shade-3*)
                                (border-width 1)
                                menu no-update-p)
   (add-plot-object (make-rectangle left bottom width height :label label :border-width border-width
                           :texture texture :menu menu)
          plot no-update-p))

(defun change-rectangle-border
 (rectangle plot &optional new-width)

   (il:* il:|;;| "Assumes an open plot-window")


   (when (null new-width)
       (print-plot-prompt "Indicate new border width" plot)
       (setq new-width (il:rnumber nil nil nil nil t nil t))
       (print-plot-prompt "" plot))
   (when new-width
       (let ((view-port (plot-view-port plot)))
            (erase-plot-object rectangle view-port plot)
            (setf (rectangle-border-width rectangle)
                  new-width)
            (draw-plot-object rectangle view-port plot))))

(defun change-rectangle-texture
 (rectangle plot &optional new-texture)
   (when (null new-texture)
       (print-plot-prompt "Indicate new texture" plot)
       (setq new-texture (pop-up-menu (il:constant (make-texture-menu))))
       (print-plot-prompt "" plot))
   (when new-texture
       (let ((view-port (plot-view-port plot)))
            (erase-plot-object rectangle view-port plot)
            (setf (rectangle-texture rectangle)
                  new-texture)
            (draw-plot-object rectangle view-port plot))))



(il:* il:|;;| "Text")



(define-plot-object text
 :instance-vars (position stream-position string font)
   :methods (:label-fn plot-object-error))

(defun make-text
 (position string &key (font *small-plot-font*)
                            menu)
   (%make-text :menu menu :position position :string (string string)
          :font font))

(defun draw-text
 (text-object view-port plot)
   (let* ((stream (vp-parent-stream view-port))
          (position (text-position text-object))
          (stream-x (world-to-stream-x (position-x position)
                           view-port))
          (stream-y (world-to-stream-y (position-y position)
                           view-port))
          (stream-font (stream-font stream)))
         (setf (stream-font stream)
               (text-font text-object))
         (stream-move-to stream-x stream-y stream)
         (clipped-princ (text-string text-object)
                stream
                (vp-stream-subregion view-port))
         (setf (stream-font stream)
               stream-font)
         (if (eq stream (window-dsp (plot-window plot)))
             (setf (text-stream-position text-object)
                   (make-position stream-x stream-y)))))

(defun erase-text
 (text-object view-port plot)

   (il:* il:|;;| "ERASE the TEXTOBJECT")


   (let* ((stream (vp-parent-stream view-port))
          (stream-position (text-stream-position text-object))
          (stream-x (position-x stream-position))
          (stream-y (position-y stream-position))
          (stream-font (stream-font stream)))
         (setf (stream-font stream)
               (text-font text-object))
         (stream-move-to stream-x stream-y stream)
         (let ((string-region (string-region (text-string text-object)
                                     stream)))
              (clipped-bltshade (stream-texture stream)
                     stream
                     (vp-stream-subregion view-port)
                     :destination-left
                     (region-left string-region)
                     :destination-bottom
                     (region-bottom string-region)
                     :width
                     (region-width string-region)
                     :height
                     (region-height string-region)
                     :operation boole-1))
         (setf (stream-font stream)
               stream-font)))

(defun highlight-text
 (text-object view-port plot)

   (il:* il:|;;| "ERASE the TEXTOBJECT")


   (let* ((stream (vp-parent-stream view-port))
          (stream-position (text-stream-position text-object))
          (stream-x (position-x stream-position))
          (stream-y (position-y stream-position))
          (stream-font (stream-font stream)))
         (setf (stream-font stream)
               (text-font text-object))
         (stream-move-to stream-x stream-y stream)
         (let ((string-region (string-region (text-string text-object)
                                     stream)))
              (clipped-bltshade *black-shade* stream (vp-stream-subregion view-port)
                     :destination-left
                     (region-left string-region)
                     :destination-bottom
                     (region-bottom string-region)
                     :width
                     (region-width string-region)
                     :height
                     (region-height string-region)
                     :operation boole-xor))
         (setf (stream-font stream)
               stream-font)))

(defun extent-of-text
 (text-object)
   (text-position text-object))

(defun distance-to-text
 (text-object stream-position plot)
   (l1-metric (text-stream-position text-object)
          stream-position))

(defun move-text
 (text-object dx dy plot)
   (let ((position (text-position text-object)))
        (incf (position-x position)
              dx)
        (incf (position-y position)
              dy)))

(defun copy-text
 (text)

   (il:* il:|;;| "Copyfn for CURVE objects")


   (let ((new-text (%copy-text text)))
        (setf (text-position new-text)
              (copy-position (text-position text)))
        (setf (text-stream-position new-text)
              nil)
        (setf (text-string new-text)
              (copy-seq (text-string text)))
        new-text))

(defun put-text
 (text stream)
   (prin1 (text-position text)
          stream)
   (write-char #\Space stream)
   (prin1 (text-string text)
          stream)
   (write-char #\Space stream)
   (print-font (text-font text)
          stream))

(defun get-text
 (text stream)
   (setf (text-position text)
         (read stream))
   (setf (text-string text)
         (read stream))
   (setf (text-font text)
         (read-font stream)))

(defun plot-text
 (plot position text &key (font *small-plot-font*)
                           menu no-update-p)
   (add-plot-object (make-text position text :font font :menu menu)
          plot no-update-p))



(il:* il:|;;| "Compound objects")



(define-plot-object compound
 :instance-vars (components)
   :methods (:label-fn label-generic))

(defun make-compound
 (components &key label menu)
   (if (null components)
       (error "A compound must have at least one component"))
   (%make-compound :menu menu :label label :components components))

(defun draw-compound
 (compound view-port plot)
   (dolist (object (compound-components compound))
       (draw-plot-object object view-port plot)))

(defun erase-compound
 (compound view-port plot)
   (dolist (object (compound-components compound))
       (erase-plot-object object view-port plot)))

(defun highlight-compound
 (compound view-port plot)
   (dolist (object (compound-components compound))
       (highlight-plot-object object view-port plot)))

(defun extent-of-compound
 (compound plot)
   (plot-objects-extent (compound-components compound)
          plot))

(defun distance-to-compound
 (compound stream-position plot)
   (let* ((components (compound-components compound))
          (min (distance-to-plot-object (car components)
                      stream-position plot)))
         (dolist (part (cdr components)
                       min)
             (let ((new-min (distance-to-plot-object part stream-position plot)))
                  (if (< new-min min)
                      (setq min new-min))))))

(defun move-compound
 (compound dx dy plot)
   (dolist (object (compound-components compound))
       (move-plot-object object dx dy plot)))

(defun copy-compound
 (compound)

   (il:* il:|;;| "Copyfn for CURVE objects")


   (let ((new-compound (%copy-compound compound)))
        (setf (compound-components new-compound)
              (mapcar #'(lambda (object)
                               (copy-plot-object object))
                     (compound-components compound)))
        new-compound))

(defun put-compound
 (compound stream)
   (prin1 (length (compound-components compound))
          stream)
   (write-char #\Space stream)
   (dolist (object (compound-components compound))
       (print-plot-object object stream)
       (write-char #\Space stream)))

(defun get-compound
 (compound stream)
   (let ((n-objects (read stream)))
        (setf (compound-components compound)
              (pt:with-collection (dotimes (i n-objects)
                                      (pt:collect (read-plot-object stream)))))))

(defun plot-compound
 (plot &rest args)
   (let* ((first-keyword-arg (position-if #'(lambda (x)
                                                   (member x '(:label :menu :no-update-p)))
                                    args))
          (components (subseq args 0 (or first-keyword-arg (length args))))
          (label (cdr (member :label args)))
          (menu (cdr (member :menu args)))
          (no-update-p (cdr (member :no-update-p args))))
         (add-plot-object (make-compound components :label label :menu menu)
                plot no-update-p)))



(il:* il:|;;| "Analytic lines")



(define-plot-object line
 :instance-vars (slope constant infinite-slope-p style stream-slope 
                                                   stream-constant stream-position-1 
                                                   stream-position-2)
   :methods (:draw-fn draw-analytic-line :erase-fn erase-analytic-line :label-fn label-generic 
                   :move-fn plot-object-error)
   :menu-items (("Width" change-line-width "Change width")
                ("Dashing" change-line-dashing "Change dashing")))

(defun make-line
 (slope constant &key extent-fn label (style (make-line-style))
                            menu)

   (il:* il:|;;| "Create a line plot object")


   (%make-line :menu menu :label label :slope (or slope 0.0)
          :constant constant :infinite-slope-p (null slope)
          :style
          (if (integerp style)
              (make-line-style :width style)
              style)
          :prop-list
          (if extent-fn (list :extent-fn extent-fn))))

(defun draw-analytic-line
 (line view-port plot)
   (let* ((stream (vp-parent-stream view-port))
          (stream-subregion (vp-stream-subregion view-port))
          (style (line-style line))
          (linewidth (* (stream-scale stream)
                        (style-width style)))
          (infinite-slope-p (line-infinite-slope-p line))
          (slope (line-slope line))
          (constant (line-constant line))
          (x1 (if infinite-slope-p
                  constant
                  (plot-x-lower plot)))
          (y1 (if infinite-slope-p
                  (plot-y-lower plot)
                  (+ constant (* slope x1))))
          (x2 (if infinite-slope-p
                  constant
                  (plot-x-upper plot)))
          (y2 (if infinite-slope-p
                  (plot-y-upper plot)
                  (+ constant (* slope x2))))
          (stream-position-1 (make-position (world-to-stream-x x1 view-port)
                                    (world-to-stream-y y1 view-port)))
          (stream-position-2 (make-position (world-to-stream-x x2 view-port)
                                    (world-to-stream-y y2 view-port)))
          (stream-slope (unless infinite-slope-p
                            (* slope (/ (lt-m (vp-world-to-stream-y view-port))
                                        (lt-m (vp-world-to-stream-x view-port))))))
          (stream-constant (if infinite-slope-p
                               (world-to-stream-x constant view-port)
                               (- (world-to-stream-y constant view-port)
                                  (* stream-slope (lt-a (vp-world-to-stream-x view-port)))))))
         (clipped-draw-between stream-position-1 stream-position-2 stream stream-subregion :width 
                linewidth :operation boole-1 :color (style-color style)
                :dashing
                (style-dashing style))
         (when (eq stream (window-dsp (plot-window plot)))
             (setf (line-stream-slope line)
                   stream-slope)
             (setf (line-stream-constant line)
                   stream-constant)
             (setf (line-stream-position-1 line)
                   stream-position-1)
             (setf (line-stream-position-2 line)
                   stream-position-2))))

(defun erase-analytic-line
 (line view-port plot)
   (let* ((stream (vp-parent-stream view-port))
          (stream-subregion (vp-stream-subregion view-port))
          (style (line-style line))
          (linewidth (* (stream-scale stream)
                        (+ 2 (style-width style))))
          (stream-position-1 (line-stream-position-1 line))
          (stream-position-2 (line-stream-position-2 line)))
         (clipped-draw-between stream-position-1 stream-position-2 stream stream-subregion :width 
                linewidth :operation boole-andc1 :color (style-color style)
                :dashing
                (style-dashing style))))

(defun highlight-line
 (line view-port plot)
   (let* ((stream (vp-parent-stream view-port))
          (stream-subregion (vp-stream-subregion view-port))
          (style (line-style line))
          (linewidth (* (stream-scale stream)
                        (+ 2 (style-width style))))
          (stream-position-1 (line-stream-position-1 line))
          (stream-position-2 (line-stream-position-2 line)))
         (clipped-draw-between stream-position-1 stream-position-2 stream stream-subregion :width 
                linewidth :operation boole-xor :color (style-color style)
                :dashing
                (style-dashing style))))

(defun distance-to-line
 (line stream-position plot)

   (il:* il:|;;| "Assumes use of the L1 metric")


   (let ((x0 (position-x stream-position))
         (y0 (position-y stream-position))
         (stream-slope (line-stream-slope line))
         (stream-constant (line-stream-constant line)))
        (truncate (if (line-infinite-slope-p line)
                      (abs (- x0 stream-constant))

                      (il:* il:|;;| 

             "Compute the intersection of the perpendicular going through (x0 , y0) and the line. ")


                      (let* ((mp (- (/ 1.0 stream-slope)))
                             (bp (- y0 (* mp x0)))
                             (xi (/ (- bp stream-constant)
                                    (- stream-slope mp)))
                             (yi (+ (* mp xi)
                                    bp)))
                            (l1-metric-xy stream-position xi yi))))))

(defun copy-line
 (line)

   (il:* il:|;;| "Copyfn for CURVE objects")


   (let ((new-line (%copy-line line)))
        (setf (line-style new-line)
              (copy-line-style (line-style line)))
        (setf (line-stream-slope new-line)
              nil)
        (setf (line-stream-constant new-line)
              nil)
        (setf (line-stream-position-1 new-line)
              nil)
        (setf (line-stream-position-2 new-line)
              nil)
        new-line))

(defun extent-of-line
 (line plot)
   (let ((extent-fn (plot-object-prop line :extent-fn)))
        (if extent-fn (funcall extent-fn plot))))

(defun put-line
 (line stream)
   (prin1 (line-slope line)
          stream)
   (write-char #\Space stream)
   (prin1 (line-constant line)
          stream)
   (write-char #\Space stream)
   (prin1 (line-infinite-slope-p line)
          stream)
   (write-char #\Space stream)
   (prin1 (line-style line)
          stream))

(defun get-line
 (line stream)
   (setf (line-slope line)
         (read stream))
   (setf (line-constant line)
         (read stream))
   (setf (line-infinite-slope-p line)
         (read stream))
   (setf (line-style line)
         (read stream)))

(defun plot-line
 (plot slope constant &key label (style 1)
                           menu no-update-p)
   (add-plot-object (make-line slope constant :label label :style style :menu menu)
          plot no-update-p))

(defun change-line-width
 (line plot &optional new-width)
   (change-style-width new-width (line-style line)
          line plot))

(defun change-line-dashing
 (line plot &optional new-dashing)
   (change-style-dashing new-dashing (line-style line)
          line plot))



(il:* il:|;;| "Graphs")



(define-plot-object graph
 :instance-vars (fn n-samples style stream-positions)
   :methods (:label-fn label-generic :move-fn plot-object-error :put-fn plot-object-error :get-fn 
                   plot-object-error)
   :menu-items (("Width" change-graph-width "Change width")
                ("Dashing" change-graph-dashing "Change dashing")))

(defun make-graph
 (fn &key (n-samples 100)
                          extent-fn label (style (make-line-style))
                          menu)
   (%make-graph :menu menu :label label :fn fn :n-samples n-samples :style (if (integerp style)
                                                                               (make-line-style
                                                                                :width style)
                                                                               style)
          :prop-list
          (if extent-fn (list :extent-fn extent-fn))))

(defun draw-graph
 (graph view-port plot)
   (let* ((stream (vp-parent-stream view-port))
          (style (graph-style graph))
          (line-width (* (stream-scale stream)
                         (style-width style)))
          (stream-positions (let ((x-upper (plot-x-upper plot))
                                  (x-lower (plot-x-lower plot))
                                  (graph-fn (graph-fn graph))
                                  (n-samples (graph-n-samples graph)))
                                 (let ((inc (/ (- x-upper x-lower)
                                               (1- n-samples)))
                                       (x x-lower))
                                      (pt:with-collection (dotimes (i (1- n-samples))
                                                              (pt:collect (make-position
                                                                           (world-to-stream-x x 
                                                                                  view-port)
                                                                           (world-to-stream-y
                                                                            (funcall graph-fn x)
                                                                            view-port)))
                                                              (incf x inc))
                                             (pt:collect (make-position (world-to-stream-x x-upper 
                                                                               view-port)
                                                                (world-to-stream-y (funcall graph-fn
                                                                                          x-upper)
                                                                       view-port))))))))
         (connect-positions stream-positions stream (vp-stream-subregion view-port)
                boole-1 line-width (style-color style)
                (style-dashing style))
         (if (eq stream (window-dsp (plot-window plot)))
             (setf (graph-stream-positions graph)
                   stream-positions))))

(defun erase-graph
 (graph view-port plot)
   (let* ((stream (vp-parent-stream view-port))
          (style (graph-style graph))
          (line-width (* (stream-scale stream)
                         (+ 2 (style-width style)))))
         (connect-positions (graph-stream-positions graph)
                stream
                (vp-stream-subregion view-port)
                boole-andc1 line-width (style-color style)
                nil)))

(defun highlight-graph
 (graph view-port plot)
   (let* ((stream (vp-parent-stream view-port))
          (style (graph-style graph))
          (line-width (* (stream-scale stream)
                         (+ 2 (style-width style)))))
         (connect-positions (graph-stream-positions graph)
                stream
                (vp-stream-subregion view-port)
                boole-xor line-width (style-color style)
                nil)))

(defun distance-to-graph
 (graph stream-position plot)
   (positions-list-distance (graph-stream-positions graph)
          stream-position))

(defun copy-graph
 (graph)

   (il:* il:|;;| "Copyfn for CURVE objects")


   (let ((new-graph (%copy-graph graph)))
        (setf (graph-style new-graph)
              (copy-line-style (graph-style graph)))
        (setf (graph-stream-positions new-graph)
              nil)
        new-graph))

(defun extent-of-graph
 (graph plot)
   (let ((extent-fn (plot-object-prop graph :extent-fn)))
        (if extent-fn (funcall extent-fn plot))))

(defun plot-graph
 (plot fn &optional (n-samples 100)
                            label
                            (style 1)
                            menu no-update-p)

   (il:* il:|;;| "User Entry Point.  Draw a piecewise linear curve in PLOT.  Style is either the line width to use or a list (width dashing color).  POSITIONS is a list of positions to be connected.")


   (add-plot-object (make-graph fn :n-samples n-samples :style style :label label :menu menu)
          plot no-update-p))

(defun change-graph-width
 (graph plot &optional new-width)
   (change-style-width new-width (graph-style graph)
          graph plot))

(defun change-graph-dashing
 (graph plot &optional new-dashing)
   (change-style-dashing new-dashing (graph-style graph)
          graph plot))

(xcl:define-file-environment "PLOT-OBJECTS"
 :package "PLOT"
   :compiler :compile-file
   :readtable "XCL")
(il:putprops il:plot-objects il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop