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

(il:filecreated " 1-Dec-88 12:09:49" il:{qv}<idl>next>plot-fns.\;38
 112101 

      il:|changes| il:|to:|  (il:functions interval-length ti-length apply-after-method copy-plot 
                                    default-tic-list-fn copy-plot-object icon-fn track-plot-object 
                                    effective-middle-menu delete-plot-objects delete-selected-object
                                    default-menu setf-default-menu delete-plot-object)

      il:|previous| il:|date:| "30-Nov-88 18:31:02" il:{qv}<idl>next>plot-fns.\;37)


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

(il:prettycomprint il:plot-fnscoms)

(il:rpaqq il:plot-fnscoms

          ((il:coms 

                  (il:* il:|;;| "datatype def's")


                  (il:structures plot scale-info axis-interval axis-info tic-info margin extent)
                  
                  (il:* il:|;;| "extended access functions")


                  (il:functions plot-x-lower plot-x-upper plot-y-lower plot-y-upper interval-length 
                         ti-length)
                  (il:structures plot-object plot-methods))
           (il:coms 

                  (il:* il:|;;| "plot properties ")


                  (il:functions plot-prop setf-plot-prop)
                  (il:setfs plot-prop)
                  
                  (il:* il:|;;| "plot-object props ")


                  (il:functions plot-object-prop setf-plot-object-prop)
                  (il:setfs plot-object-prop))
           (il:functions apply-after-method)
           (il:functions make-plot copy-plot)
           (il:coms 

                  (il:* il:|;;| "Plot windows")


                  (il:functions open-plot-window close-plot-window redraw-plot-window 
                         min-stream-region-size)
                  (il:functions closest-plot-object)
                  (il:functions repaint-fn close-fn copy-button-event-fn hardcopy-fn icon-fn)
                  (il:functions button-event-fn track-plot-object effective-middle-menu)
                  (il:functions print-plot-prompt))
           (il:coms 

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


                  (il:variables *small-plot-font* *large-plot-font*)
                  (il:functions draw-plot)
                  (il:functions update-view-port box-region)
                  
                  (il:* il:|;;| "Tics")


                  (il:functions tics-p setf-tics-p)
                  (il:functions make-tic-lists normalize-tic-list float-to-string enum-to-string 
                         fnum-to-string)
                  (il:functions get-tic-list tic-list-fn setf-tic-list-fn default-tic-list-fn)
                  
                  (il:* il:|;;| "margins")


                  (il:functions compute-top-bottom-margin compute-left-right-margin)
                  (il:functions draw-top-margin draw-bottom-margin draw-left-margin draw-right-margin
                         )
                  (il:functions draw-tics-top-bottom draw-tics-left-right)
                  (il:functions draw-label-top-bottom draw-label-left-right)
                  
                  (il:* il:|;;| "Plot scaling")


                  (il:functions rescale-plot rescale-x-axis rescale-y-axis)
                  (il:functions tic-info-fn setf-tic-info-fn default-tic-info-fn)
                  (il:functions interval-fn setf-interval-fn default-interval-fn 
                         no-change-interval-fn)
                  (il:functions scale plot-objects-extent)
                  (il:functions adjust-scale-p update-extent add-extent-to-extent 
                         add-position-to-extent)
                  (il:functions extend-axis extended-interval-fn)
                  (il:functions plot-world-extent setf-plot-world-extent plot-interval 
                         setf-plot-interval)
                  (il:functions region-to-extent extent-to-region))
           (il:coms 

                  (il:* il:|;;| "plot labels")


                  (il:functions plot-label setf-plot-label))
           (il:coms 

                  (il:* il:|;;| "Plot object methods")


                  (il:functions draw-plot-object erase-plot-object highlight-plot-object 
                         lowlight-plot-object plot-object-extent distance-to-plot-object 
                         label-plot-object unlabel-plot-object move-plot-object copy-plot-object)
                  (il:functions add-plot-object add-plot-objects)
                  (il:functions delete-plot-object delete-plot-objects)
                  (il:functions relabel-selected-object delete-selected-object undelete-last-object)
                  (il:functions translate-plot-object)
                  (il:functions select-plot-object deselect-plot-object))
           (il:coms 

                  (il:* il:|;;| "Plot menus ")


                  (il:functions default-when-selected-fn)
                  (il:functions plot-menu setf-plot-menu)
                  (il:functions plot-menu-items setf-plot-menu-items add-plot-menu-items 
                         delete-plot-menu-items)
                  (il:coms (il:variables *default-middle-menu* *default-right-menu*)
                         (il:functions manually-rescale-plot ask-for-scale toggle-label ask-for-label
                                ask-for-which-label toggle-tics toggle-fixed-right-menu))
                  (il:functions default-menu setf-default-menu)
                  
                  (il:* il:|;;| "Do we want this setf?")


                  (il:setfs default-menu)
                  (il:functions fix-right-menu unfix-right-menu remove-fixed-right-menu))
           (il:coms 

                  (il:* il:|;;| "Misc functions")


                  (il:functions which-plot))
           (xcl:file-environments "PLOT-FNS")))



(il:* il:|;;| "datatype def's")



(defstruct (plot
 (:constructor %make-plot)
                     (:copier %copy-plot))
   objects
   window
   view-port
   prompt-window
   scale-info
   left-margin
   right-margin
   top-margin
   bottom-margin
   middle-menu
   right-menu
   other-menus
   selected-object
   save-list
   prop-list)

(defstruct (scale-info
 (:conc-name "SI-"))
   x-interval
   x-axis-info
   x-tic-info
   y-interval
   y-axis-info
   y-tic-info)

(defstruct (axis-interval
 (:conc-name "INTERVAL-")
                              (:type list))
   min
   max)

(defstruct (axis-info
 (:conc-name "AI-")
                          (:type list))
   (interval-fn 'default-interval-fn)
   (tic-info-fn 'default-tic-info-fn))

(defstruct (tic-info
 (:conc-name "TI-"))
   min
   max
   inc
   n)

(defstruct margin

   label
   tic-list
   (tic-list-fn 'default-tic-list-fn)
   tics-p)

(defstruct extent

   min-x
   max-x
   min-y
   max-y)



(il:* il:|;;| "extended access functions")



(defmacro plot-x-lower
 (plot)
   `(interval-min (si-x-interval (plot-scale-info ,plot))))

(defmacro plot-x-upper
 (plot)
   `(interval-max (si-x-interval (plot-scale-info ,plot))))

(defmacro plot-y-lower
 (plot)
   `(interval-min (si-y-interval (plot-scale-info ,plot))))

(defmacro plot-y-upper
 (plot)
   `(interval-max (si-y-interval (plot-scale-info ,plot))))

(defmacro interval-length
 (interval)
   (pt:once-only (interval)
          `(- (interval-max ,interval)
              (interval-min ,interval))))

(defmacro ti-length
 (ti)
   (pt:once-only (ti)
          `(- (ti-max ,ti)
              (ti-min ,ti))))

(defstruct (plot-object
 (:constructor nil)
                            (:copier nil))
   methods
   menu
   label
   prop-list)

(defstruct (plot-methods
 (:conc-name "PM-"))
   draw-fn
   erase-fn
   highlight-fn
   lowlight-fn
   extent-fn
   distance-fn
   label-fn
   move-fn
   copy-fn
   put-fn
   get-fn)



(il:* il:|;;| "plot properties ")



(defmacro plot-prop
 (plot prop)
   `(getf (plot-prop-list ,plot)
          ,prop))

(defun setf-plot-prop
 (plot prop new-value)
   (setf (getf (plot-prop-list plot)
               prop)
         new-value))

(defsetf plot-prop
 setf-plot-prop)



(il:* il:|;;| "plot-object props ")



(defmacro plot-object-prop
 (object prop)
   `(getf (plot-object-prop-list ,object)
          ,prop))

(defun setf-plot-object-prop
 (object prop new-value)
   (setf (getf (plot-object-prop-list object)
               prop)
         new-value))

(defsetf plot-object-prop
 setf-plot-object-prop)

(defmacro apply-after-method
 (method &rest args)
   (pt:once-only (method)
          `(and ,method (funcall ,method ,@args))))

(defun make-plot
 (&key region title border open-window-p
                           (initial-world-extent (make-extent :min-x 0.0 :max-x 1.0 :min-y 0.0 :max-y
                                                        1.0)))

   (il:* il:|;;| "Creates a PLOT.  If OPEN-WINDOW-P is T then the PLOT's asssociated window is opened.  The other arguments are passed to make-window.")


   (let ((plot (%make-plot :scale-info (let ((min-x (extent-min-x initial-world-extent))
                                             (max-x (extent-max-x initial-world-extent))
                                             (min-y (extent-min-y initial-world-extent))
                                             (max-y (extent-max-y initial-world-extent)))
                                            (make-scale-info :x-interval (make-axis-interval :min 
                                                                                min-x :max max-x)
                                                   :x-axis-info
                                                   (make-axis-info)
                                                   :x-tic-info
                                                   (default-tic-info-fn min-x max-x)
                                                   :y-interval
                                                   (make-axis-interval :min min-y :max max-y)
                                                   :y-axis-info
                                                   (make-axis-info)
                                                   :y-tic-info
                                                   (default-tic-info-fn min-y max-y)))
                      :left-margin
                      (make-margin)
                      :right-margin
                      (make-margin)
                      :top-margin
                      (make-margin)
                      :bottom-margin
                      (make-margin)
                      :middle-menu
                      (default-menu :middle)
                      :right-menu
                      (default-menu :right))))

        (il:* il:|;;| "Cache display parameters until OPENPLOTWINDOW is called")


        (if (or region title border)
            (setf (plot-window plot)
                  (list region title border)))
        (if open-window-p (open-plot-window plot))
        plot))

(defun copy-plot
 (plot &key region title border open-p)

   (il:* il:|;;| "Copies a PLOT.  Copying of PLOT-PROP's is handled as follows.  If PLOT has a COPY-FN, calls it with NEW-PLOT, PLOT as args, and expects it to copy the PLOT-PROPS intelligently, else only copies the top-level list structure.")


   (let ((new-plot (%copy-plot plot)))

        (il:* il:|;;| "Plot objects are not shared since they may be destructively modified")


        (setf (plot-objects new-plot)
              (mapcar #'(lambda (object)
                               (copy-plot-object object))
                     (plot-objects plot)))

        (il:* il:|;;| "Don't share any display associated objects")


        (setf (plot-window new-plot)
              nil)
        (setf (plot-view-port new-plot)
              nil)
        (setf (plot-prompt-window new-plot)
              nil)

        (il:* il:|;;| "scale-info and margins are side-effected, hence must be copied")


        (setf (plot-scale-info new-plot)
              (copy-scale-info (plot-scale-info plot)))
        (setf (plot-left-margin new-plot)
              (copy-margin (plot-left-margin plot)))
        (setf (plot-right-margin new-plot)
              (copy-margin (plot-right-margin plot)))
        (setf (plot-top-margin new-plot)
              (copy-margin (plot-top-margin plot)))
        (setf (plot-bottom-margin new-plot)
              (copy-margin (plot-bottom-margin plot)))

        (il:* il:|;;| "OK to share Menus")


        (setf (plot-selected-object new-plot)
              nil)
        (setf (plot-save-list new-plot)
              nil)

        (il:* il:|;;| "Hook for copying plot props")


        (setf (plot-prop-list new-plot)
              (pt:with-collection (do* ((prop-name-tail (plot-prop-list plot)
                                               (cddr prop-name-tail))
                                        (prop-name (car prop-name-tail)
                                               (car prop-name-tail))
                                        (prop-value-tail (cdr prop-name-tail)
                                               (cdr prop-name-tail))
                                        (prop-value (car prop-value-tail)
                                               (car prop-value-tail)))
                                       ((null prop-name-tail))
                                     (when prop-value
                                         (pt:collect prop-name)
                                         (pt:collect prop-value)))))
        (if (or region title border)

            (il:* il:|;;| "Cache the display parameters")


            (setf (plot-window new-plot)
                  (list region title border)))
        (apply-after-method (plot-prop plot :when-copied)
               plot new-plot)
        (if open-p (open-plot-window new-plot))
        new-plot))



(il:* il:|;;| "Plot windows")



(defun open-plot-window
 (plot)

   (il:* il:|;;| 

 "Open window associated with PLOT.  Creates circularities later broken by PLOT-CLOSE-FN")


   (let ((window (plot-window plot)))
        (unless (open-window-p window)
            (if (shrunken-window-p window)

                (il:* il:|;;| "Shrunken window")


                (expand-window window)

                (il:* il:|;;| "Closed window")


                (let ((prompt-window (plot-prompt-window plot))
                      reshape-p prompt-created-p)
                     (if (not (window-p window))
                         (let ((region (if (consp window)
                                           (first window)
                                           (make-region 0 0 100 100)))
                               (title (if (consp window)
                                          (second window)
                                          "Plot Window"))
                               (border (if (consp window)
                                           (third window))))
                              (if (null window)
                                  (setq reshape-p t))
                              (setf (plot-window plot)
                                    (setq window (make-window :region region :title title 
                                                        :border-size border :not-open-p t)))))

                     (il:* il:|;;| "setup plot window methods")


                     (setf (window-method window :repaint)
                           'repaint-fn)
                     (add-window-method window :reshape 'repaint-fn)
                     (add-window-method window :close 'close-fn)
                     (setf (window-method window :button-event)
                           'button-event-fn)
                     (setf (window-method window :right-button-event)
                           'button-event-fn)
                     (setf (window-method window :copy-button-event)
                           'copy-button-event-fn)
                     (setf (window-method window :hardcopy)
                           'hardcopy-fn)
                     (setf (window-method window :shrink)
                           'icon-fn)

                     (il:* il:|;;| "setup plot window props")


                     (setf (window-prop window ':plot)
                           plot)

                     (il:* il:|;;| "Rest of VIEWPORT initializations in REDRAWPLOTWINDOW")


                     (setf (plot-view-port plot)
                           (make-view-port (window-dsp window)))

                     (il:* il:|;;| "Get a prompt window, if none exists")


                     (when (null prompt-window)
                         (setf (plot-prompt-window plot)
                               (setq prompt-window (make-window :region
                                                          (make-region 0 0 100
                                                                 (height-if-window
                                                                  (font-height (default-font :display
                                                                                      ))))
                                                          :not-open-p t)))
                         (setf (stream-scroll prompt-window)
                               :on)
                         (setf (window-method prompt-window :page-full)
                               'identity)
                         (setf (window-max-size prompt-window)
                               (cons most-positive-fixnum (region-height (window-region prompt-window
                                                                                ))))
                         (setq prompt-created-p t))

                     (il:* il:|;;| "Establish a min size for the window")


                     (make-tic-lists plot)
                     (let* ((min-size (min-stream-region-size (window-dsp window)
                                             plot))
                            (min-extent (cons (width-if-window (car min-size)
                                                     (window-border window))
                                              (height-if-window (cdr min-size)
                                                     (window-title window)
                                                     (window-border window)))))
                           (if (null (attached-windows window))
                               (setf (window-min-size window)
                                     min-extent)
                               (setf (main-window-min-size window)
                                     min-extent))
                           (when (and (not reshape-p)
                                      (or (< (window-width window)
                                             (car min-size))
                                          (< (window-height window)
                                             (cdr min-size))))
                               (setq reshape-p t)
                               (print-prompt "Window too small: reshape")))
                     (if reshape-p

                         (il:* il:|;;| "Shaping window implies redrawing it")


                         (reshape-window window)
                         (let ((view-port (plot-view-port plot))
                               (selected-object (plot-selected-object plot)))
                              (open-window window)
                              (update-view-port view-port (stream-clipping-region window)
                                     plot)
                              (draw-plot plot (window-dsp window)
                                     view-port
                                     (stream-clipping-region window))
                              (if selected-object (highlight-plot-object selected-object plot))))

                     (il:* il:|;;| "Attach the promptwindow if necessary")


                     (attach-window prompt-window window :top)

                     (il:* il:|;;| "attach the fixed menu")


                     (if (plot-prop plot :fixed-right-menu-p)
                         (fix-right-menu plot))

                     (il:* il:|;;| "A user hook")


                     (apply-after-method (plot-prop plot :when-opened)
                            plot))))
        window))

(defun close-plot-window
 (plot)
   (let ((plot-window (plot-window plot)))

        (il:* il:|;;| "Unfix the right menu")


        (unfix-right-menu plot)

        (il:* il:|;;| "Cleanup window methods and props ")


        (when (window-p plot-window)
            (setf (window-prop plot-window :plot)
                  nil)
            (delete-window-method plot-window :reshape 'repaint-fn)
            (delete-window-method plot-window :close 'close-fn)
            (setf (window-method plot-window :button-event)
                  'il:totopw)
            (setf (window-method plot-window :repaint)
                  nil)
            (setf (window-method plot-window :right-button-event)
                  nil)
            (setf (window-method plot-window :copy-button-event)
                  nil)
            (setf (window-method plot-window :hardcopy)
                  nil)
            (setf (window-method plot-window :shrink)
                  nil)
            (detach-all-windows plot-window)
            (close-window plot-window))

        (il:* il:|;;| "A user hook")


        (apply-after-method (plot-prop plot ':when-closed)
               plot)))

(defun redraw-plot-window
 (plot)

   (il:* il:|;;| "Redraws the PLOTWINDOW of a PLOT")


   (let ((plot-window (plot-window plot)))
        (if (not (open-window-p plot-window))

            (il:* il:|;;| "Assumes OPENPLOTWINDOW will call REDRAWPLOTWINDOW")


            (open-plot-window plot)
            (let ((view-port (plot-view-port plot))
                  (selected-object (plot-selected-object plot))
                  min-size)

                 (il:* il:|;;| "Setup the tic lists ")


                 (make-tic-lists plot)

                 (il:* il:|;;| "Establish a min size for the WINDOW")


                 (setq min-size (min-stream-region-size (window-dsp plot-window)
                                       plot))

                 (il:* il:|;;| 

               "Uses MAINWINDOWMINSIZE since PLOTWINDOW is the main window of a group")


                 (setf (main-window-min-size plot-window)
                       (cons (width-if-window (car min-size)
                                    (window-border plot-window))
                             (height-if-window (cdr min-size)
                                    (window-title plot-window)
                                    (window-border plot-window))))
                 (if (or (< (window-width plot-window)
                            (car min-size))
                         (< (window-height plot-window)
                            (cdr min-size)))
                     (progn (print-prompt "Plotwindow too small: reshape")

                            (il:* il:|;;| "Assumes RESHAPE-WINDOW will call REDRAW-PLOT-WINDOW")


                            (reshape-window plot-window))
                     (progn (update-view-port view-port (stream-clipping-region plot-window)
                                   plot)
                            (clear-window plot-window)
                            (draw-plot plot (window-dsp plot-window)
                                   view-port
                                   (stream-clipping-region plot-window))
                            (if selected-object (highlight-plot-object selected-object view-port plot
                                                       ))))))))

(defun min-stream-region-size
 (stream plot)

   (il:* il:|;;| "Compute the minimun acceptable size for a plot STREAMREGION.  In the case of PLOTWINDOWS, corresponds to the min exceptable interior size of the WINDOW.  Returns a dotted pair (MINX  . MINY)")


   (il:* il:|;;| "Sizes are (width  . height) pairs")


   (let ((bottom-margin-size (compute-top-bottom-margin stream (plot-bottom-margin plot)
                                    plot))
         (left-margin-size (compute-left-right-margin stream (plot-left-margin plot)
                                  plot))
         (right-margin-size (compute-left-right-margin stream (plot-right-margin plot)
                                   plot))
         (top-margin-size (compute-top-bottom-margin stream (plot-top-margin plot)
                                 plot))
         min-x min-y)

        (il:* il:|;;| "The constant 100 is heuristic")


        (setq min-x (+ (car left-margin-size)
                       (max (car bottom-margin-size)
                            (car top-margin-size)
                            100)
                       (car right-margin-size)))
        (setq min-y (+ (cdr bottom-margin-size)
                       (max (cdr left-margin-size)
                            (cdr right-margin-size)
                            100)
                       (cdr top-margin-size)))
        (cons min-x min-y)))

(defun closest-plot-object
 (plot stream-position)
   (let (min min-object)
        (dolist (object (plot-objects plot))
            (let ((dist (distance-to-plot-object object stream-position plot)))
                 (if (or (null min)
                         (< dist min))
                     (setq min dist min-object object))))
        min-object))

(defun repaint-fn
 (window)

   (il:* il:|;;| "Redraws a PLOT WINDOW based on data stored on property list of WINDOW")


   (redraw-plot-window (window-prop window ':plot)))

(defun close-fn
 (window)
   (close-plot-window (window-prop window ':plot)))

(defun copy-button-event-fn
 (window)

   (il:* il:|;;| "Allows plots to be copy selected")


   (let ((plot (window-prop window ':plot)))
        (invert-window window)
        (until-mouse-state :up)
        (invert-window window)
        (when (inside-p window (window-cursor window))
            (let ((imageobj (case (pop-up-menu (il:constant (make-menu :items
                                                                   '(("Plot" 'plot)
                                                                     ("Bitmap" 'bitmap)))))
                                (plot (make-plot-image-object plot))
                                (bitmap (make-plot-bitmap-object plot)))))
                 (if imageobj (il:copyinsert imageobj))))))

(defun hardcopy-fn
 (window printer-stream)

   (il:* il:|;;| "Modified to allow hardcopy of plots on PRESS printers -- no landscape drawing")


   (il:* il:|;;| "Modified to center plot on page")


   (let ((window-region (stream-clipping-region window))
         (plot (window-prop window ':plot))
         (printer-view-port (make-view-port printer-stream))
         printer-clipping-region stream-region)
        (if (eq (il:imagestreamtype printer-stream)
                'il:interpress)
            (let ((micasperinch 2540))
                 (if (> (region-width window-region)
                        (region-height window-region))
                     (progn 
                            (il:* il:|;;| "Print in landscape mode")


                            (il:rotate.ip printer-stream 90)
                            (il:concatt.ip printer-stream)
                            (il:translate.ip printer-stream 0 (truncate (- (* 8.5 micasperinch))))
                            (il:concatt.ip printer-stream)

                            (il:* il:|;;| "Make sure the clippingregion is rational")


                            (il:dspclippingregion (make-region (truncate (* 0.5 micasperinch))
                                                         (truncate (* 0.5 micasperinch))
                                                         (truncate (* 10 micasperinch))
                                                         (truncate (* 7.5 micasperinch)))
                                   printer-stream))

                     (il:* il:|;;| "Make sure the clippingregion is rational")


                     (il:dspclippingregion (make-region (truncate (* 0.5 micasperinch))
                                                  (truncate (* 0.5 micasperinch))
                                                  (truncate (* 7.5 micasperinch))
                                                  (truncate (* 10 micasperinch)))
                            printer-stream))))
        (setq printer-clipping-region (stream-clipping-region printer-stream))

        (il:* il:|;;| "Reset the margins")


        (setf (stream-margin printer-stream :left)
              (region-left printer-clipping-region))
        (setf (stream-margin printer-stream :bottom)
              (region-bottom printer-clipping-region))
        (setf (stream-margin printer-stream :right)
              (1- (+ (region-left printer-clipping-region)
                     (region-width printer-clipping-region))))
        (setf (stream-margin printer-stream :top)
              (1- (+ (region-bottom printer-clipping-region)
                     (region-height printer-clipping-region))))
        (setq stream-region (let* ((k 
                                      (il:* il:|;;| "maintain the PLOTWINDOW's aspect ratio")


                                      (min (truncate (region-width printer-clipping-region)
                                                  (region-width window-region))
                                           (truncate (region-height printer-clipping-region)
                                                  (region-height window-region))))
                                   (swidth (* k (region-width window-region)))
                                   (sheight (* k (region-height window-region))))

                                  (il:* il:|;;| "Center plot on page")


                                  (make-region (+ (region-left printer-clipping-region)
                                                  (truncate (- (region-width printer-clipping-region)
                                                               swidth)
                                                         2))
                                         (+ (region-bottom printer-clipping-region)
                                            (truncate (- (region-height printer-clipping-region)
                                                         sheight)
                                                   2))
                                         swidth sheight)))
        (make-tic-lists plot)
        (update-view-port printer-view-port stream-region plot)
        (draw-plot plot printer-stream printer-view-port stream-region)))

(defun icon-fn
 (window old-icon)
   (let ((plot (window-prop window ':plot))
         (title-font (il:windowtitlefont))
         icon-width icon-height subregion iconw view-port)
        (if (> (window-width window)
               (window-height window))
            (setq icon-width (width-if-window 100)
                  icon-height
                  (height-if-window (truncate (* 100 (/ (window-height window)
                                                        (window-width window))))))
            (setq icon-width (width-if-window (truncate (* 100 (/ (window-width window)
                                                                  (window-height window)))))
                  icon-height
                  (height-if-window 100)))
        (if old-icon
            (progn (reshape-window old-icon (make-region (region-left (window-region old-icon))
                                                   (region-bottom (window-region old-icon))
                                                   icon-width icon-height))
                   (setq iconw old-icon))
            (progn (setq iconw (make-window :region (position-region icon-width icon-height)))
                   (il:dspfont title-font iconw)))
        (clear-window iconw)
        (setq subregion (make-region (truncate (* 0.1 (window-width iconw)))
                               (truncate (* 0.1 (window-height iconw)))
                               (truncate (* 0.8 (window-width iconw)))
                               (truncate (* 0.8 (window-height iconw)))))
        (setq view-port (make-view-port (window-dsp iconw)
                               subregion
                               (vp-world-region (plot-view-port plot))))
        (box-region subregion iconw)
        (let* ((objects (plot-objects plot))
               (n (length objects)))
              (if (< n 50)

                  (il:* il:|;;| "few enough objects so that all of them may be drawn")


                  (dolist (object objects)
                      (draw-plot-object object view-port plot))

                  (il:* il:|;;| "Sample the display list")


                  (let ((sampling-rate (truncate n 50))
                        (i 0))
                       (dolist (object objects)
                           (if (pt:fixnum-eq i sampling-rate)
                               (progn (draw-plot-object object view-port plot)
                                      (setq i 0))
                               (incf i))))))
        (il:centerprintinregion (or (plot-label plot ':top)
                                    (if (not (string= (window-title window)
                                                    "Plot Window"))
                                        (window-title window))
                                    "Plot Icon")
               nil iconw)
        iconw))

(defun button-event-fn
 (window)
   (to-top-window window)
   (let* ((plot (window-prop window ':plot))
          (view-port (plot-view-port plot))
          (prompt-window (plot-prompt-window plot))
          (selected-object (plot-selected-object plot)))
         (cond
            ((last-mouse-state-p :left)

             (il:* il:|;;| "Plot object tracking")


             (track-plot-object window))
            ((last-mouse-state-p :middle)
             (when selected-object
                 (let ((menu (effective-middle-menu selected-object plot)))
                      (when menu

                          (il:* il:|;;| "establish then break circularities")


                          (setf (menu-prop menu ':plot)
                                plot)
                          (setf (menu-prop menu ':mode)
                                :middle)
                          (pop-up-menu menu)
                          (setf (menu-prop menu ':mode)
                                nil)
                          (setf (menu-prop menu ':plot)
                                nil)))))
            ((last-mouse-state-p :right)
             (let ((right-menu (plot-right-menu plot)))
                  (if (or (plot-prop plot ':fixed-right-menu-p)
                          (> (position-y (window-cursor window))
                             (window-height window))
                          (null right-menu))

                      (il:* il:|;;| "bring up the window-manager menu")


                      (il:dowindowcom window)
                      (progn (setf (menu-prop right-menu ':plot)
                                   plot)
                             (pop-up-menu right-menu)
                             (setf (menu-prop right-menu ':plot)
                                   nil))))))))

(defun track-plot-object
 (window)
   (let* ((plot (window-prop window ':plot))
          (view-port (plot-view-port plot))
          (prompt-window (plot-prompt-window plot))
          (selected-object (plot-selected-object plot))
          (old-x 0)
          (old-y 0)
          (stream-subregion (vp-stream-subregion view-port))
          (position (make-position))
          new-x new-y new-selected-object)
         (loop (unless (mouse-state-p :left)
                      (return nil))
               (setf (position-x position)
                     (setq new-x (last-mouse-x window)))
               (setf (position-y position)
                     (setq new-y (last-mouse-y window)))
               (if (inside-p stream-subregion position)
                   (unless (and (pt:fixnum-eq old-x new-x)
                                (pt:fixnum-eq old-y new-y))
                       (setq new-selected-object (closest-plot-object plot position))
                       (when (and new-selected-object (not (eq new-selected-object selected-object)))
                           (if selected-object (lowlight-plot-object selected-object view-port plot))
                           (highlight-plot-object new-selected-object view-port plot)
                           (setf (plot-selected-object plot)
                                 (setq selected-object new-selected-object))

                           (il:* il:|;;| 

                         "Try to print a meaningfull message in the PLOTPROMPTWINDOW")


                           (let ((label (plot-object-label new-selected-object)))
                                (if label
                                    (print-plot-prompt label plot)
                                    (terpri prompt-window)))))
                   (when selected-object
                       (lowlight-plot-object selected-object view-port plot)
                       (setf (plot-selected-object plot)
                             (setq selected-object nil))))
               (setq old-x new-x)
               (setq old-y new-y))))

(defun effective-middle-menu
 (selected-object plot)
   (let* ((object-menu (plot-object-menu selected-object))
          (other-menus (plot-other-menus plot)))
         (if object-menu
             (if (menu-p object-menu)
                 object-menu

                 (il:* il:|;;| "Should be a symbol")


                 (getf other-menus object-menu))
             (let ((object-type (type-of-object selected-object)))
                  (or (getf other-menus object-type)
                      (if (pt:memq object-type *plot-object-types*)
                          (let ((default-menu (default-menu object-type)))
                               (and default-menu (setf-plot-menu plot object-type default-menu t))))
                      (plot-middle-menu plot))))))

(defun print-plot-prompt
 (text plot)
   (let ((prompt-window (plot-prompt-window plot)))
        (terpri prompt-window)
        (princ text prompt-window)))



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



(defvar *small-plot-font*
 (make-font :family '(:gacha 8 :mrr)))

(defvar *large-plot-font*
 (make-font :family '(:gacha 12 :brr)))

(defun draw-plot
 (plot stream view-port stream-region)

   (il:* il:|;;| "Draws a plot on STREAM.  STREAM-REGION is the region the PLOT will occupy.  Does not clear STREAM-REGION before drawing.")


   (il:* il:|;;| "Will not check, for the moment, that the stream-region is large enough")


   (box-region (vp-stream-subregion view-port)
          stream)
   (draw-bottom-margin stream view-port stream-region plot)
   (draw-left-margin stream view-port stream-region plot)
   (draw-top-margin stream view-port stream-region plot)
   (draw-right-margin stream view-port stream-region plot)
   (dolist (object (plot-objects plot))
       (draw-plot-object object view-port plot)))

(defun update-view-port
 (view-port stream-region plot)
   (let* ((scale-info (plot-scale-info plot))
          (parent-stream (vp-parent-stream view-port))
          (top-margin-size (compute-top-bottom-margin parent-stream (plot-top-margin plot)
                                  plot))
          (bottom-margin-size (compute-top-bottom-margin parent-stream (plot-bottom-margin plot)
                                     plot))
          (left-margin-size (compute-left-right-margin parent-stream (plot-left-margin plot)
                                   plot))
          (right-margin-size (compute-left-right-margin parent-stream (plot-right-margin plot)
                                    plot)))
         (setf (vp-world-region view-port)
               (make-region (interval-min (si-x-interval scale-info))
                      (interval-min (si-y-interval scale-info))
                      (interval-length (si-x-interval scale-info))
                      (interval-length (si-y-interval scale-info))))
         (setf (vp-stream-subregion view-port)
               (make-region (+ (region-left stream-region)
                               (car left-margin-size))
                      (+ (region-bottom stream-region)
                         (cdr bottom-margin-size))
                      (- (region-width stream-region)
                         (+ (car left-margin-size)
                            (car right-margin-size)))
                      (- (region-height stream-region)
                         (+ (cdr bottom-margin-size)
                            (cdr top-margin-size)))))
         (compute-transform view-port)))

(defun box-region
 (region stream)
               (il:* il:\; "Edited  5-May-87 18:16 by jop")


   (il:* il:|;;| "Draw a box around a region in STREAM")


   (let ((rleft (region-left region))
         (rbottom (region-bottom region))
         (rright (region-right region))
         (rtop (region-top region))
         (linewidth (stream-scale stream)))
        (stream-draw-line rleft rbottom rright rbottom stream :width linewidth :operation boole-1)
        (stream-draw-line rright rbottom rright rtop stream :width linewidth :operation boole-1)
        (stream-draw-line rright rtop rleft rtop stream :width linewidth :operation boole-1)
        (stream-draw-line rleft rtop rleft rbottom stream :width linewidth :operation boole-1)))



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



(defun tics-p
 (plot margin-name)
   (margin-tics-p (ecase margin-name
                      (:bottom (plot-bottom-margin plot))
                      (:left (plot-left-margin plot))
                      (:top (plot-top-margin plot))
                      (:right (plot-right-margin plot)))))

(defun setf-tics-p
 (plot margin-name new-state &optional no-update-p)
   (let ((margin (ecase margin-name
                     (:bottom (plot-bottom-margin plot))
                     (:left (plot-left-margin plot))
                     (:top (plot-top-margin plot))
                     (:right (plot-right-margin plot)))))
        (setf (margin-tics-p margin)
              new-state)
        (if (null no-update-p)
            (redraw-plot-window plot))
        new-state))

(defun make-tic-lists
 (plot)
                    (il:* il:\; "Edited  7-May-87 18:08 by jop")

   (flet ((make-margin-tics (margin tic-info scale-info plot)
                 (if (margin-tics-p margin)
                     (setf (margin-tic-list margin)
                           (normalize-tic-list (get-tic-list margin tic-info scale-info plot))))))
         (let ((scale-info (plot-scale-info plot)))
              (make-margin-tics (plot-bottom-margin plot)
                     (si-x-tic-info scale-info)
                     scale-info plot)
              (make-margin-tics (plot-left-margin plot)
                     (si-y-tic-info scale-info)
                     scale-info plot)
              (make-margin-tics (plot-right-margin plot)
                     (si-y-tic-info scale-info)
                     scale-info plot)
              (make-margin-tics (plot-top-margin plot)
                     (si-x-tic-info scale-info)
                     scale-info plot)
              nil)))

(defun normalize-tic-list
 (tic-list)
            (il:* il:\; "Edited 27-May-87 18:19 by jop")

   (mapcar #'(lambda (tic)
                    (let (value label)
                         (if (consp tic)
                             (setq value (car tic)
                                   label
                                   (cdr tic))
                             (setq value (setq label tic)))
                         (cons value (if (floatp label)
                                         (float-to-string label)
                                         label))))
          tic-list))

(defun float-to-string
 (x)
                      (il:* il:\; "Edited  7-May-87 17:23 by jop")

   (setq x (float x))

   (il:* il:|;;| "Pure common lisp would be: ")


   (il:* il:|;;| "(string-left-trim '(#\\Space) (if (let ((abs-x (abs x))) (and (not (zerop abs-x)) (or (< abs-x 0.001) (>= abs-x 1.0E+7)))) (format nil \"~10e\" x) (format nil \"~7f\" x)))")


   (let ((string (make-array 14 :element-type 'string-char :fill-pointer 0))
         (minus-p (and (< x 0.0)
                       (setq x (- x))))
         (round 6)
         numstr intexp)
        (if (and (not (zerop x))
                 (or (< x 0.001)
                     (>= x 1.0E+7)))
            (multiple-value-bind (numstr intexp)
                   (il:fltstr x round)
                   (enum-to-string string numstr intexp minus-p))
            (multiple-value-bind (numstr intexp)
                   (il:fltstr x round)
                   (fnum-to-string string numstr intexp minus-p)))))

(defun enum-to-string
 (output-string mantissa-string integer-exponent minus-p)

   (il:* il:|;;| "Prints exponential notation observing rounding & exponent spacing")


   (macrolet ((push-output (char)
                     `(progn (setf (aref output-string index)
                                   ,char)
                             (setq index (1+ index)))))
          (let ((digits (length mantissa-string))
                (index 0)
                exp-offset)
               (when minus-p (push-output #\-))

               (il:* il:|;;| "Print the mantissa")


               (push-output (aref mantissa-string 0))
               (push-output #\.)
               (do ((i 1 (1+ i)))
                   ((eq i digits))
                 (push-output (aref mantissa-string i)))

               (il:* il:|;;| "Trim off extraneous zeros")


               (do ((i (1- index)
                       (1- i)))
                   ((not (eq (aref output-string i)
                             #\0))
                    (if (not (eq (aref output-string i)
                                 #\.))
                        (setq index (1+ i))
                        (setq index (+ i 2)))))

               (il:* il:|;;| "mantissa done - now for the exponent")


               (setq exp-offset (il:mkstring (- (+ integer-exponent digits)
                                                1)))
               (push-output #\E)
               (dotimes (i (length exp-offset))
                   (push-output (aref exp-offset i)))
               (setf (fill-pointer output-string)
                     index)
               output-string)))

(defun fnum-to-string
 (output-string mantissa-string integer-exponent minus-p)
   (macrolet ((push-output (char)
                     `(progn (setf (aref output-string index)
                                   ,char)
                             (setq index (1+ index)))))
          (let* ((digits (length mantissa-string))
                 (point-place (+ digits integer-exponent))
                 (index 0))
                (if minus-p (push-output #\-))
                (cond
                   ((< point-place 0)
                    (push-output #\0)
                    (push-output #\.)
                    (dotimes (i (- point-place))
                        (push-output #\0))
                    (dotimes (i digits)
                        (push-output (aref mantissa-string i))))
                   ((< integer-exponent 0)
                    (dotimes (i point-place)
                        (push-output (aref mantissa-string i)))
                    (push-output #\.)
                    (do ((i point-place (1+ i)))
                        ((eq i digits))
                      (push-output (aref mantissa-string i))))
                   (t (dotimes (i digits)
                          (push-output (aref mantissa-string i)))
                      (dotimes (i integer-exponent)
                          (push-output #\0))
                      (push-output #\.)
                      (push-output #\0)))
                (if (or (< point-place 0)
                        (< integer-exponent 0))

                    (il:* il:|;;| "Trim off extraneous zeros")


                    (do ((i (1- index)
                            (1- i)))
                        ((not (eq (aref output-string i)
                                  #\0))
                         (if (not (eq (aref output-string i)
                                      #\.))
                             (setq index (1+ i))
                             (setq index (+ i 2))))))
                (setf (fill-pointer output-string)
                      index)
                output-string)))

(defun get-tic-list
 (margin tic-info scale-info plot)
   (let ((ticmethod (margin-tic-list-fn margin)))
        (if (and (consp ticmethod)
                 (not (eq (car ticmethod)
                          'lambda)))
            ticmethod
            (funcall ticmethod tic-info scale-info plot))))

(defun tic-list-fn
 (plot margin-name)
   (margin-tic-list-fn (ecase margin-name
                           (:bottom (plot-bottom-margin plot))
                           (:left (plot-left-margin plot))
                           (:top (plot-top-margin plot))
                           (:right (plot-right-margin plot)))))

(defun setf-tic-list-fn
 (plot margin-name new-method &optional no-update-p)

   (il:* il:|;;| "NEW-METHOD may be a list of numbers, or a list of CONS pairs (VALUE  . LABEL), or a function to be APPLIED to MARGIN SCALE-INFO PLOT.")


   (let ((margin (ecase margin-name
                     (:bottom (plot-bottom-margin plot))
                     (:left (plot-left-margin plot))
                     (:top (plot-top-margin plot))
                     (:right (plot-right-margin plot)))))
        (setf (margin-tic-list-fn margin)
              new-method)
        (if (and (null no-update-p)
                 (margin-tics-p margin))
            (redraw-plot-window plot))
        new-method))

(defun default-tic-list-fn
 (tic-info scale-info &optional plot)
   (declare
 (ignore scale-info plot))

   (il:* il:|;;| "Return the default tic list based on the values of PLOTSCALE")


   (let ((tic-inc (ti-inc tic-info)))
        (cond
           ((consp tic-inc)
            tic-inc)
           ((numberp tic-inc)

            (il:* il:|;;| "Be carefull that min and max tics correspond to min and max of interval")


            (nconc (let ((x (ti-min tic-info)))
                        (pt:with-collection (dotimes (i (1- (ti-n tic-info)))
                                                (pt:collect x)
                                                (incf x tic-inc))))
                   (list (ti-max tic-info))))
           (t (error "Invalid increment: ~s" tic-inc)))))



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



(defun compute-top-bottom-margin
 (stream top-bottom-margin plot)

   (il:* il:|;;| "Returns a size cons pair (width  . height) in stream coordinates")


   (let* ((small-font (coerce-font *small-plot-font* stream))
          (large-font (coerce-font *large-plot-font* stream))
          (tics-p (margin-tics-p top-bottom-margin))
          (label (margin-label top-bottom-margin))
          (width 0)
          (small-ascent (font-ascent small-font))
          (large-height (font-height large-font))
          (height (if (or tics-p label)
                      large-height

                      (il:* il:|;;| "margin of at least one LARGE-HEIGHT")


                      (* 2 large-height))))
         (if tics-p
             (incf height (* 3 small-ascent)))
         (if label
             (setq height (+ height (* 2 large-height))
                   width
                   (string-width label large-font)))
         (cons width height)))

(defun compute-left-right-margin
 (stream left-right-margin plot)

   (il:* il:|;;| "Returns a size cons pair (width  . height) in stream coordinates")


   (let* ((small-font (coerce-font *small-plot-font* stream))
          (large-font (coerce-font *large-plot-font* stream))
          (tics-p (margin-tics-p left-right-margin))
          (tic-list (margin-tic-list left-right-margin))
          (label (margin-label left-right-margin))
          (height 0)

          (il:* il:|;;| "Assumes fixed-pitch font")


          (small-width (string-width #\a small-font))
          (large-width (string-width #\a large-font))
          (width (if (or tics-p label)
                     large-width
                     (* 2 large-width))))
         (if tics-p
             (incf width (+ (* 2 small-width)
                            (let ((tic-width-max 0))
                                 (dolist (pair tic-list)
                                     (let ((length (string-width (cdr pair)
                                                          small-font)))
                                          (if (> length tic-width-max)
                                              (setq tic-width-max length))))
                                 tic-width-max))))
         (if label
             (setq width (+ width (* 2 large-width))
                   height
                   (* (length label)
                      (font-height large-font))))
         (cons width height)))

(defun draw-top-margin
 (stream view-port stream-region plot)

   (il:* il:|;;| "DRAW the Top MARGIN")


   (let* ((top-margin (plot-top-margin plot))
          (small-font (coerce-font *small-plot-font* stream))
          (large-font (coerce-font *large-plot-font* stream))
          (label (margin-label top-margin))
          (x-interval (si-x-interval (plot-scale-info plot)))
          (small-ascent (font-ascent small-font))
          (top (region-top (vp-stream-subregion view-port))))
         (if (margin-tics-p top-margin)

             (il:* il:|;;| "DRAW TICS and TIC labels if necessary")


             (draw-tics-top-bottom (margin-tic-list top-margin)
                    (interval-min x-interval)
                    (interval-max x-interval)
                    (+ small-ascent top)
                    (- top small-ascent)
                    small-ascent small-font stream view-port))
         (if label
             (draw-label-top-bottom label large-font (- (region-top stream-region)
                                                        (+ (font-height large-font)
                                                           (font-ascent stream)))
                    stream-region stream))))

(defun draw-bottom-margin
 (stream view-port stream-region plot)

   (il:* il:|;;| "DRAW the bottom MARGIN")


   (let* ((bottom-margin (plot-bottom-margin plot))
          (small-font (coerce-font *small-plot-font* stream))
          (large-font (coerce-font *large-plot-font* stream))
          (label (margin-label bottom-margin))
          (x-interval (si-x-interval (plot-scale-info plot)))
          (small-ascent (font-ascent small-font))
          (bottom (region-bottom (vp-stream-subregion view-port))))
         (if (margin-tics-p bottom-margin)

             (il:* il:|;;| "DRAW TICS and TIC labels if necessary")


             (draw-tics-top-bottom (margin-tic-list bottom-margin)
                    (interval-min x-interval)
                    (interval-max x-interval)
                    (+ small-ascent bottom)
                    (- bottom small-ascent)
                    (* 2 small-ascent)
                    small-font stream view-port t))
         (if label
             (draw-label-top-bottom label large-font (+ (region-bottom stream-region)
                                                        (+ (font-descent stream)
                                                           (font-height large-font)))
                    stream-region stream))))

(defun draw-left-margin
 (stream view-port stream-region plot)

   (il:* il:|;;| "DRAW the left MARGIN")


   (let* ((left-margin (plot-left-margin plot))
          (small-font (coerce-font *small-plot-font* stream))
          (large-font (coerce-font *large-plot-font* stream))
          (label (margin-label left-margin))
          (y-interval (si-y-interval (plot-scale-info plot)))
          (small-width (string-width #\a small-font))
          (left (region-left (vp-stream-subregion view-port))))
         (if (margin-tics-p left-margin)

             (il:* il:|;;| "DRAW TICS and TIC labels if necessary")


             (draw-tics-left-right (margin-tic-list left-margin)
                    (interval-min y-interval)
                    (interval-max y-interval)
                    (+ small-width left)
                    (- left small-width)
                    small-width small-font stream view-port t))
         (if label
             (draw-label-left-right label large-font (+ (region-left stream-region)
                                                        (string-width #\a large-font))
                    stream-region stream))))

(defun draw-right-margin
 (stream view-port stream-region plot)

   (il:* il:|;;| "DRAW the right MARGIN")


   (let* ((right-margin (plot-right-margin plot))
          (small-font (coerce-font *small-plot-font* stream))
          (large-font (coerce-font *large-plot-font* stream))
          (label (margin-label right-margin))
          (y-interval (si-y-interval (plot-scale-info plot)))
          (small-width (string-width #\a small-font))
          (right (region-right (vp-stream-subregion view-port))))
         (if (margin-tics-p right-margin)

             (il:* il:|;;| "DRAW TICS and TIC labels if necessary")


             (draw-tics-left-right (margin-tic-list right-margin)
                    (interval-min y-interval)
                    (interval-max y-interval)
                    (+ small-width right)
                    (- right small-width)
                    small-width small-font stream view-port))
         (if label
             (draw-label-left-right label large-font (- (region-right stream-region)
                                                        (* 2 (string-width #\a large-font)))
                    stream-region stream))))

(defun draw-tics-top-bottom
 (ticlist min max top-of-tic bottom-of-tic tic-offset tic-font stream
                                       view-port bottom-p)
   (let ((font (stream-font stream)))
        (setf (stream-font stream)
              tic-font)
        (let (x-window-loc)
             (dolist (ticpair ticlist)
                 (let ((tic-value (car ticpair))
                       (tic-label (cdr ticpair)))
                      (when (and (>= tic-value min)
                                 (<= tic-value max))
                          (setq x-window-loc (world-to-stream-x tic-value view-port))

                          (il:* il:|;;| "always draw the tic mark")


                          (stream-move-to x-window-loc top-of-tic stream)
                          (stream-draw-to x-window-loc bottom-of-tic stream :width (stream-scale
                                                                                    stream)
                                 :operation boole-1)
                          (when tic-label
                              (if bottom-p
                                  (stream-move-to x-window-loc (- bottom-of-tic tic-offset)
                                         stream)
                                  (stream-move-to x-window-loc (+ top-of-tic tic-offset)
                                         stream))
                              (stream-relative-move-to (- (truncate (string-width tic-label tic-font)
                                                                 2))
                                     0 stream)
                              (princ tic-label stream))))))
        (setf (stream-font stream)
              font)))

(defun draw-tics-left-right
 (ticlist min max right-tic left-tic tic-offset tic-font stream 
                                       view-port left-p)
   (let ((font (stream-font stream)))
        (setf (stream-font stream)
              tic-font)
        (let (y-window-loc)
             (dolist (ticpair ticlist)
                 (let ((tic-value (car ticpair))
                       (tic-label (cdr ticpair)))
                      (when (and (>= tic-value min)
                                 (<= tic-value max))
                          (setq y-window-loc (world-to-stream-y tic-value view-port))
                          (stream-move-to left-tic y-window-loc stream)
                          (stream-draw-to right-tic y-window-loc stream :width (stream-scale stream)
                                 :operation boole-1)
                          (when tic-label
                              (if left-p
                                  (stream-move-to (- left-tic (+ tic-offset (string-width tic-label 
                                                                                   stream)))
                                         y-window-loc stream)
                                  (stream-move-to (+ right-tic tic-offset)
                                         y-window-loc stream))
                              (princ tic-label stream))))))
        (setf (stream-font stream)
              font)))

(defun draw-label-top-bottom
 (label label-font y-offset stream-region stream)
   (let ((font (stream-font stream)))
        (setf (stream-font stream)
              label-font)
        (stream-move-to (+ (region-left stream-region)
                           (max 0 (truncate (- (region-width stream-region)
                                               (string-width label stream))
                                         2)))
               y-offset stream)
        (princ label stream)
        (setf (stream-font stream)
              font)))

(defun draw-label-left-right
 (label label-font x-offset stream-region stream)
   (let ((font (stream-font stream)))
        (setf (stream-font stream)
              label-font)
        (stream-move-to x-offset (- (region-top stream-region)
                                    (truncate (- (region-height stream-region)
                                                 (* (font-height stream)
                                                    (length label)))
                                           2))
               stream)
        (let ((lf (stream-line-feed stream)))
             (dotimes (i (length label))
                 (princ (aref label i)
                        stream)
                 (stream-move-to x-offset (+ (stream-y stream)
                                             lf)
                        stream)))
        (setf (stream-font stream)
              font)))



(il:* il:|;;| "Plot scaling")



(defun rescale-plot
 (plot &optional (axis :both)
                              no-update-p)
   (let ((plot-extent (plot-objects-extent (plot-objects plot)
                             plot)))
        (when plot-extent
            (let ((min-x (extent-min-x plot-extent))
                  (max-x (extent-max-x plot-extent))
                  (min-y (extent-min-y plot-extent))
                  (max-y (extent-max-y plot-extent)))
                 (if (and (or (eq axis ':both)
                              (eq axis ':x))
                          (> max-x min-x))
                     (rescale-x-axis plot min-x max-x))
                 (if (and (or (eq axis ':both)
                              (eq axis ':y))
                          (> max-y min-y))
                     (rescale-y-axis plot min-y max-y))
                 (if (null no-update-p)
                     (redraw-plot-window plot))))))

(defun rescale-x-axis
 (plot min max &key tic-info-fn interval-fn)
   (let* ((scale-info (plot-scale-info plot))
          (axis-info (si-x-axis-info scale-info))
          (tic-info (funcall (or tic-info-fn (ai-tic-info-fn axis-info))
                           min max plot))
          (interval (funcall (or interval-fn (ai-interval-fn axis-info))
                           min max tic-info plot)))
         (setf (si-x-tic-info scale-info)
               tic-info)
         (setf (si-x-interval scale-info)
               interval)))

(defun rescale-y-axis
 (plot min max &key tic-info-fn interval-fn)
   (let* ((scale-info (plot-scale-info plot))
          (axis-info (si-y-axis-info scale-info))
          (tic-info (funcall (or tic-info-fn (ai-tic-info-fn axis-info))
                           min max plot))
          (interval (funcall (or interval-fn (ai-interval-fn axis-info))
                           min max tic-info plot)))
         (setf (si-y-tic-info scale-info)
               tic-info)
         (setf (si-y-interval scale-info)
               interval)))

(defun tic-info-fn
 (plot axis)
   (ai-tic-info-fn (ecase axis
                       (:x (si-x-axis-info (plot-scale-info plot)))
                       (:y (si-y-axis-info (plot-scale-info plot))))))

(defun setf-tic-info-fn
 (plot axis new-fn &optional no-update-p)
   (let ((axis-info (ecase axis
                        (:x (si-x-axis-info (plot-scale-info plot)))
                        (:y (si-y-axis-info (plot-scale-info plot))))))
        (setf (ai-tic-info-fn axis-info)
              new-fn)
        (rescale-plot plot axis no-update-p)
        new-fn))

(defun default-tic-info-fn
 (min max &optional plot (tics '(3 4 5 6 7 8)))
   (declare
 (ignore plot default-tic-info-fn))

   (il:* il:|;;| "Computes an interval that includes (MIN,MAX) and can be exactly spanned by (NTICS-1) *some increment.")


   (let* ((shortest (scale min max (car tics)))
          (shortest-length (ti-length shortest)))
         (dolist (n-tics (cdr tics))
             (let* ((current (scale min max n-tics))
                    (current-length (ti-length current)))
                   (if (< current-length shortest-length)
                       (setq shortest-length current-length shortest current))))
         shortest))

(defun interval-fn
 (plot axis)
   (ai-interval-fn (ecase axis
                       (:x (si-x-axis-info (plot-scale-info plot)))
                       (:y (si-y-axis-info (plot-scale-info plot))))))

(defun setf-interval-fn
 (plot axis new-fn &optional no-update-p)
   (let ((axis-info (ecase axis
                        (:x (si-x-axis-info (plot-scale-info plot)))
                        (:y (si-y-axis-info (plot-scale-info plot))))))
        (setf (ai-interval-fn axis-info)
              new-fn)
        (rescale-plot plot axis no-update-p)
        new-fn))

(defun default-interval-fn
 (min max tic-info &optional plot)
   (declare
 (ignore min max plot))
   (make-axis-interval :min (ti-min tic-info)
          :max
          (ti-max tic-info)))

(defun no-change-interval-fn
 (min max tic-info plot)
   (declare
 (ignore tic-info plot))
   (make-axis-interval :min min :max max))

(defun scale
 (min max n-tics &optional (round 
                                                  (il:* il:|;;| 

                   "Rounding Constants.  Notice that they are in decreasing order and end with 1.0")


                                                  '(5.0 2.5 2.0 1.5 1.0))
                      power)

   (il:* il:|;;| "Scaling algorithm for plots.  NTICS is the desired number of tics.  Round is a list of acceptable scaling factors.  POWER is the power of ten to use.  Returns a TICINFO including NEWMAX, NEWMIN, INC, and NTICS")


   (let* ((n-inc (1- n-tics))
          (raw-inc (/ (float (- max min))
                      n-inc))
          mantissa index)

         (il:* il:|;;| "POWER is the power of ten")


         (setq power (expt 10.0 (or power (floor (log raw-inc 10.0)))))

         (il:* il:|;;| "MANTISSA is the scale factor")


         (setq mantissa (/ raw-inc power))
         (if (> mantissa (first round))
             (setq power (* 10.0 power)
                   index
                   (last round))
             (setq index (do ((mark round (cdr mark)))
                             ((null (cdr mark))
                              mark)
                           (if (> mantissa (second mark))
                               (return mark)))))

         (il:* il:|;;| "Find new max and new min")


         (let ((new-max min)
               new-min inc factor lower-mult upper-mult)
              (loop (unless (< new-max max)
                        (return (make-tic-info :min new-min :max new-max :inc inc :n n-tics)))
                    (setq inc (* (first index)
                                 power))
                    (setq factor (/ (- (+ max min)
                                       (* n-inc inc))
                                    (* 2.0 inc)))
                    (setq new-min (* inc (setq lower-mult (ceiling factor))))
                    (if (> new-min min)
                        (setq new-min (* inc (setq lower-mult (1- lower-mult)))))
                    (if (and (>= min 0.0)
                             (minusp new-min))
                        (setq lower-mult 0 new-min 0.0))
                    (setq upper-mult (+ lower-mult n-inc))
                    (setq new-max (* inc upper-mult))
                    (if (and (<= max 0.0)
                             (> new-max 0.0))
                        (setq upper-mult 0 new-max 0.0 lower-mult (- n-inc)
                              new-min
                              (* inc lower-mult)))
                    (if (eq round index)
                        (setq index (last round)
                              power
                              (* 10.0 power))
                        (setq index (do ((mark round (cdr mark)))
                                        ((eq (cdr mark)
                                             index)
                                         mark))))))))

(defun plot-objects-extent
 (objects plot)

   (il:* il:|;;| "May return NIL if no objects report a bounding box.")


   (let (extent)
        (dolist (object objects)
            (let ((object-info (plot-object-extent object plot)))
                 (when object-info
                     (setq extent (if (null extent)
                                      object-info
                                      (if (
                                           (il:* il:|;;| "should be position-p")


                                           consp object-info)

                                          (il:* il:|;;| "A position reported")


                                          (if (consp extent)
                                              (make-extent :min-x (min (position-x extent)
                                                                       (position-x object-info))
                                                     :max-x
                                                     (max (position-x extent)
                                                          (position-x object-info))
                                                     :min-y
                                                     (min (position-y extent)
                                                          (position-y object-info))
                                                     :max-y
                                                     (max (position-y extent)
                                                          (position-y object-info)))
                                              (add-position-to-extent extent object-info))

                                          (il:* il:|;;| "an extent reported")


                                          (if (consp extent)
                                              (add-position-to-extent (copy-extent object-info)
                                                     extent)
                                              (add-extent-to-extent extent object-info))))))))
        (if (consp extent)
            (add-position-to-extent (plot-world-extent plot)
                   extent)
            extent)))

(defun adjust-scale-p
 (extent plot)

   (il:* il:|;;| "Determines whether the plotting scale must be adjusted to included the extrema 'min-x' , 'max-x' , etc.  If so returns T.  Side effects the scale-info of PLOT")


   (when extent
       (let* ((scale-info (plot-scale-info plot))
              (x-interval (si-x-interval scale-info))
              (y-interval (si-y-interval scale-info))
              min-x max-x min-y max-y changed-p)
             (if (position-p extent)
                 (setq min-x (position-x extent)
                       max-x
                       (position-x extent)
                       min-y
                       (position-y extent)
                       max-y
                       (position-y extent))
                 (setq min-x (extent-min-x extent)
                       max-x
                       (extent-max-x extent)
                       min-y
                       (extent-min-y extent)
                       max-y
                       (extent-max-y extent)))
             (when (or (< min-x (interval-min x-interval))
                       (> max-x (interval-max x-interval)))
                 (setq changed-p t)
                 (rescale-x-axis plot (min min-x (interval-min x-interval))
                        (max max-x (interval-max x-interval))))
             (when (or (< min-y (interval-min y-interval))
                       (> max-y (interval-max y-interval)))
                 (setq changed-p t)
                 (rescale-y-axis plot (min min-y (interval-min y-interval))
                        (max max-y (interval-max y-interval))))
             changed-p)))

(defun update-extent
 (old-extent new-extent)

   (il:* il:|;;| "side effects OLD-EXTENT")


   (if (< (extent-min-x new-extent)
          (extent-min-x old-extent))
       (setf (extent-min-x old-extent)
             (extent-min-x new-extent)))
   (if (> (extent-max-x new-extent)
          (extent-max-x old-extent))
       (setf (extent-max-x old-extent)
             (extent-max-x new-extent)))
   (if (< (extent-min-y new-extent)
          (extent-min-y old-extent))
       (setf (extent-min-y old-extent)
             (extent-min-y new-extent)))
   (if (> (extent-max-y new-extent)
          (extent-max-y old-extent))
       (setf (extent-max-y old-extent)
             (extent-max-y new-extent)))
   old-extent)

(defun add-extent-to-extent
 (old-extent new-extent)

   (il:* il:|;;| "side effects OLD-EXTENT")


   (if (< (extent-min-x new-extent)
          (extent-min-x old-extent))
       (setf (extent-min-x old-extent)
             (extent-min-x new-extent)))
   (if (> (extent-max-x new-extent)
          (extent-max-x old-extent))
       (setf (extent-max-x old-extent)
             (extent-max-x new-extent)))
   (if (< (extent-min-y new-extent)
          (extent-min-y old-extent))
       (setf (extent-min-y old-extent)
             (extent-min-y new-extent)))
   (if (> (extent-max-y new-extent)
          (extent-max-y old-extent))
       (setf (extent-max-y old-extent)
             (extent-max-y new-extent)))
   old-extent)

(defun add-position-to-extent
 (old-extent position)

   (il:* il:|;;| "side effects OLD-EXTENT")


   (let ((x (position-x position))
         (y (position-y position)))
        (if (< x (extent-min-x old-extent))
            (setf (extent-min-x old-extent)
                  x)
            (if (> x (extent-max-x old-extent))
                (setf (extent-max-x old-extent)
                      x)))
        (if (< y (extent-min-y old-extent))
            (setf (extent-min-y old-extent)
                  y)
            (if (> y (extent-max-y old-extent))
                (setf (extent-max-y old-extent)
                      y))))
   old-extent)

(defun extend-axis
 (plot axis &optional no-update-p)
   (ecase axis
       (:x (rescale-x-axis plot (plot-x-lower plot)
                  (plot-x-upper plot)
                  :interval-fn
                  'extended-interval-fn))
       (:y (rescale-y-axis plot (plot-y-lower plot)
                  (plot-y-upper plot)
                  :interval-fn
                  'extended-interval-fn)))
   (if (null no-update-p)
       (redraw-plot-window plot)))

(defun extended-interval-fn
 (min max tic-info)
   (let* ((new-min (ti-min tic-info))
          (new-max (ti-max tic-info))
          (episilon 0.05)
          (delta (* episilon (- new-max new-min))))
         (make-axis-interval :min (- new-min delta)
                :max
                (+ new-max delta))))

(defun plot-world-extent
 (plot)
   (make-extent :min-x (plot-x-lower plot)
          :max-x
          (plot-x-upper plot)
          :min-y
          (plot-y-lower plot)
          :max-y
          (plot-y-upper plot)))

(defun setf-plot-world-extent
 (plot new-extent &optional no-update-p)
   (let* ((x-lower (extent-min-x new-extent))
          (x-upper (extent-max-x new-extent))
          (y-lower (extent-min-y new-extent))
          (y-upper (extent-max-y new-extent)))
         (rescale-x-axis plot x-lower x-upper :interval-fn 'no-change-interval-fn)
         (rescale-y-axis plot y-lower y-upper :interval-fn 'no-change-interval-fn)
         (if (null no-update-p)
             (redraw-plot-window plot))))

(defun plot-interval
 (plot axis)
   (ecase axis
       (:x (copy-axis-interval (si-x-interval (plot-scale-info plot))))
       (:y (copy-axis-interval (si-y-interval (plot-scale-info plot))))))

(defun setf-plot-interval
 (plot axis new-interval &optional no-update-p)
   (ecase axis
       (:x (rescale-x-axis plot (interval-min new-interval)
                  (interval-max new-interval)
                  :interval-fn
                  'no-change-interval-fn))
       (:y (rescale-y-axis plot (interval-min new-interval)
                  (interval-max new-interval)
                  :interval-fn
                  'no-change-interval-fn)))
   (if (null no-update-p)
       (redraw-plot-window plot)))

(defun region-to-extent
 (region)
   (let ((min-x (region-left region))
         (min-y (region-bottom region)))
        (make-extent :min-x min-x :max-x (+ min-x (region-width region))
               :min-y min-y :max-y (+ min-y (region-height region)))))

(defun extent-to-region
 (extent)
   (let ((min-x (extent-min-x extent))
         (min-y (extent-min-y extent)))
        (make-region min-x min-y (- (extent-max-x extent)
                                    min-x)
               (- (extent-max-y extent)
                  min-y))))



(il:* il:|;;| "plot labels")



(defun plot-label
 (plot label-position)
   (margin-label (ecase label-position
                     (:bottom (plot-bottom-margin plot))
                     (:left (plot-left-margin plot))
                     (:top (plot-top-margin plot))
                     (:right (plot-right-margin plot)))))

(defun setf-plot-label
 (plot label-position new-label &optional no-update-p)
   (let ((margin (ecase label-position
                     (:bottom (plot-bottom-margin plot))
                     (:left (plot-left-margin plot))
                     (:top (plot-top-margin plot))
                     (:right (plot-right-margin plot)))))
        (setf (margin-label margin)
              (and new-label (string new-label)))
        (if (null no-update-p)
            (redraw-plot-window plot))))



(il:* il:|;;| "Plot object methods")



(defun draw-plot-object
 (object view-port plot)
   (let ((text-object (plot-object-prop object :label-object)))
        (funcall (pm-draw-fn (plot-object-methods object))
               object view-port plot)
        (if text-object (draw-plot-object text-object view-port plot))
        (apply-after-method (plot-object-prop object ':when-drawn)
               object view-port plot)))

(defun erase-plot-object
 (object view-port plot)
   (let ((text-object (plot-object-prop object :label-object)))
        (funcall (pm-erase-fn (plot-object-methods object))
               object view-port plot)
        (if text-object (erase-plot-object text-object view-port plot))
        (apply-after-method (plot-object-prop object ':when-erased)
               object view-port plot)))

(defun highlight-plot-object
 (object view-port plot)
   (let ((text-object (plot-object-prop object :label-object)))
        (funcall (pm-highlight-fn (plot-object-methods object))
               object view-port plot)
        (if text-object (highlight-plot-object text-object view-port plot))
        (apply-after-method (plot-object-prop object ':when-highlighted)
               object view-port plot)))

(defun lowlight-plot-object
 (object view-port plot)
   (let ((text-object (plot-object-prop object :label-object)))
        (funcall (pm-lowlight-fn (plot-object-methods object))
               object view-port plot)
        (if text-object (lowlight-plot-object text-object view-port plot))
        (apply-after-method (plot-object-prop object ':when-lowlighted)
               object view-port plot)))

(defun plot-object-extent
 (object plot)

   (il:* il:|;;| "May return NIL, a position or an extent")


   (funcall (pm-extent-fn (plot-object-methods object))
          object plot))

(defun distance-to-plot-object
 (object stream-position plot)
   (funcall (pm-distance-fn (plot-object-methods object))
          object stream-position plot))

(defun label-plot-object
 (object plot)
   (if (plot-object-label object)
       (progn (setf (plot-object-prop object :label-object)
                    (funcall (pm-label-fn (plot-object-methods object))
                           object plot))
              (apply-after-method (plot-object-prop object :when-labeled)
                     object plot))
       (print-plot-prompt "Object has no label" plot)))

(defun unlabel-plot-object
 (object plot)
   (let ((text-object (plot-object-prop object ':label-object)))
        (if text-object
            (let ((view-port (plot-view-port plot)))
                 (erase-plot-object text-object view-port plot)
                 (setf (plot-object-prop object ':label-object)
                       nil)
                 (apply-after-method (plot-object-prop object :when-unlabeled)
                        object plot))
            (print-plot-prompt "Not a labeled object" plot))))

(defun move-plot-object
 (object dx dy plot)
   (funcall (pm-move-fn (plot-object-methods object))
          object dx dy plot))

(defun copy-plot-object
 (plot-object)

   (il:* il:|;;| "Returns a copy of PLOT-OBJECT.  PLOT-OBJECT props are handled as follows.  If the PLOT-OBJECT has a COPY-FN on its prop list, apply it to NEW-PLOT-OBJECT, PLOT-OBJECT and PROP-NAME by PROP and expect it to copy the PROP's, else just copy the top-level list structure.")


   (let ((new-plot-object (funcall (pm-copy-fn (plot-object-methods plot-object))
                                 plot-object)))
        (setf (plot-object-prop-list new-plot-object)
              (pt:with-collection (do* ((prop-name-tail (plot-object-prop-list plot-object)
                                               (cddr prop-name-tail))
                                        (prop-name (car prop-name-tail)
                                               (car prop-name-tail))
                                        (prop-value-tail (cdr prop-name-tail)
                                               (cdr prop-name-tail))
                                        (prop-value (car prop-value-tail)
                                               (car prop-value-tail)))
                                       ((null prop-name-tail))
                                     (when prop-value
                                         (pt:collect prop-name)
                                         (pt:collect (if (eq prop-name :label-object)

                                                         (il:* il:|;;| "Cached label")


                                                         (copy-plot-object prop-value)
                                                         prop-value))))))
        (apply-after-method (plot-object-prop plot-object :when-copied)
               plot-object new-plot-object)
        new-plot-object))

(defun add-plot-object
 (object plot &optional no-update-p)
   (let ((plot-objects (plot-objects plot))
         (redraw-p nil))
        (push object (plot-objects plot))
        (if (adjust-scale-p (plot-object-extent object plot)
                   plot)
            (setq redraw-p t))
        (if (null no-update-p)
            (if (or redraw-p (not (open-window-p (plot-window plot))))
                (redraw-plot-window plot)
                (draw-plot-object object (plot-view-port plot)
                       plot)))
        (apply-after-method (plot-object-prop object :when-added)
               object plot no-update-p)
        object))

(defun add-plot-objects
 (objects plot &optional no-update-p)
   (let* ((plot-objects (plot-objects plot))
          (redraw-p nil))

         (il:* il:|;;| "Update display list")


         (setf (plot-objects plot)
               (append objects plot-objects))
         (if (adjust-scale-p (plot-objects-extent objects plot)
                    plot)
             (setq redraw-p t))
         (if (null no-update-p)
             (if (or redraw-p (not (open-window-p (plot-window plot))))
                 (redraw-plot-window plot)
                 (let ((view-port (plot-view-port plot)))
                      (dolist (object objects)
                          (draw-plot-object object view-port plot)))))
         (dolist (object objects)
             (apply-after-method (plot-object-prop object :when-added)
                    object plot no-update-p))
         objects))

(defun delete-plot-object
 (object plot &optional no-update-p no-save-p)

   (il:* il:|;;| "Delete object from display list of plot.  If (NULL NO-UPDATE-P) then update the associated display (open it if necessary). If SAVE-P then intern the object on the plot's save list.")


   (let ((plot-objects (plot-objects plot)))
        (let ((plot-window (plot-window plot))
              (view-port (plot-view-port plot))
              (selected-object (plot-selected-object plot)))
             (when (eq object selected-object)
                 (if (and (null no-update-p)
                          (open-window-p plot-window))
                     (lowlight-plot-object object view-port plot))
                 (setf (plot-selected-object plot)
                       nil))
             (setf (plot-objects plot)
                   (delete object plot-objects))
             (if (null no-save-p)
                 (push object (plot-save-list plot)))
             (if (null no-update-p)
                 (if (not (open-window-p plot-window))
                     (open-plot-window plot)
                     (erase-plot-object object view-port plot)))
             (apply-after-method (plot-object-prop object :when-deleted)
                    object plot no-update-p no-save-p)
             object)))

(defun delete-plot-objects
 (objects plot &optional no-update-p no-save-p)

   (il:* il:|;;| "Delete object from display list of plot.  If (NULL NO-UPDATE-P) then update the associated display (open it if necessary). If SAVE-P then intern the object on the plot's save list.")


   (let* ((plot-objects (plot-objects plot))
          (trimmed-objects (mapcan #'(lambda (object)
                                            (if (pt:memq object plot-objects)
                                                (list object)))
                                  (delete-duplicates objects))))
         (when trimmed-objects
             (let ((plot-window (plot-window plot))
                   (view-port (plot-view-port plot))
                   (selected-object (plot-selected-object plot)))
                  (when (pt:memq selected-object trimmed-objects)
                      (if (and (null no-update-p)
                               (open-window-p plot-window))
                          (lowlight-plot-object selected-object view-port plot))
                      (setf (plot-selected-object plot)
                            nil))
                  (setf (plot-objects plot)
                        (nset-difference plot-objects trimmed-objects))
                  (if (null no-save-p)
                      (setf (plot-save-list plot)
                            (append trimmed-objects (plot-save-list plot))))
                  (if (null no-update-p)
                      (if (not (open-window-p plot-window))
                          (open-plot-window plot)
                          (dolist (object trimmed-objects)
                              (erase-plot-object object view-port plot))))
                  (dolist (object trimmed-objects)
                      (apply-after-method (plot-object-prop object :when-deleted)
                             object plot no-update-p no-save-p))
                  objects))))

(defun relabel-selected-object
 (selected-object plot)
   (let ((plot-prompt-window (plot-prompt-window plot))
         label)

        (il:* il:|;;| "If the object is labeled, delete the label.")


        (if (plot-object-prop selected-object :label-object)
            (unlabel-plot-object selected-object plot))
        (terpri plot-prompt-window)
        (let ((new-label (il:promptforword "Type new label :" (plot-object-label selected-object)
                                "Enter NIL for no label" plot-prompt-window nil nil
                                (il:constant (list (char-code #\Newline)
                                                   (char-code #\Linefeed)
                                                   (char-code #\Escape)
                                                   (char-code #\Tab))))))
             (when (setf (plot-object-label selected-object)
                         new-label)
                   (label-plot-object selected-object plot)))))

(defun delete-selected-object
 (object plot &optional no-update-p no-save-p)
   (let ((plot-objects (plot-objects plot))
         (plot-window (plot-window plot)))
        (when (pt:memq object plot-objects)
            (when (eq object (plot-selected-object plot))
                (if (null no-update-p)
                    (if (open-window-p plot-window)
                        (lowlight-plot-object object plot)))
                (setf (plot-selected-object plot)
                      nil))
            (setf (plot-objects plot)
                  (delete object plot-objects))
            (if (null no-save-p)
                (push object (plot-save-list plot)))
            (if (null no-update-p)
                (if (not (open-window-p plot-window))
                    (open-plot-window plot)
                    (erase-plot-object object (plot-view-port plot)
                           plot)))
            (apply-after-method (plot-object-prop object :when-deleted)
                   object plot no-update-p no-save-p)
            object)))

(defun undelete-last-object
 (plot)
   (let ((object (pop (plot-save-list plot))))
        (if object
            (add-plot-object object plot)
            (print-plot-prompt "No object to undelete" plot))))

(defun translate-plot-object
 (object dx dy plot &optional no-update-p)
   (let ((text-object (plot-object-prop object ':label-object))
         (view-port (plot-view-port plot)))
        (if (null no-update-p)
            (let ((selected-object (plot-selected-object plot)))
                 (when (eq object selected-object)
                     (lowlight-plot-object selected-object view-port plot)
                     (setf (plot-selected-object plot)
                           nil))
                 (erase-plot-object object view-port plot)))

        (il:* il:|;;| "Destructively modify the data structure for OBJECT")


        (move-plot-object object dx dy plot)
        (if (null no-update-p)
            (draw-plot-object object view-port plot))
        (if text-object (translate-plot-object text-object dx dy plot no-update-p))
        (apply-after-method (plot-object-prop object ':when-translated)
               object dx dy plot no-update-p)))

(defun select-plot-object
 (plot-object plot)
   (let ((selected-object (plot-selected-object plot))
         (view-port (plot-view-port plot)))
        (when selected-object
            (lowlight-plot-object selected-object view-port)
            (setf (plot-selected-object plot)
                  nil))
        (when plot-object
            (highlight-plot-object plot-object view-port plot)
            (setf (plot-selected-object plot)
                  plot-object))))

(defun deselect-plot-object
 (plot-object plot)
   (let ((selected-object (plot-selected-object plot)))
        (when (and selected-object (eq selected-object plot-object))
            (lowlight-plot-object selected-object (plot-view-port plot))
            (setf (plot-selected-object plot)
                  nil))))



(il:* il:|;;| "Plot menus ")



(defun default-when-selected-fn
 (item menu)
   (let* ((plot (or (menu-prop menu :plot)
                    (window-prop (main-window (window-from-menu menu))
                           :plot)))
          (mode (menu-prop menu :mode))
          (selected-object (plot-selected-object plot))
          (selected-fn (second item))
          extra-args args-to-pass)
         (when (consp selected-fn)
             (setq extra-args (cdr selected-fn))
             (setq selected-fn (car selected-fn)))
         (setq args-to-pass (mapcar #'eval extra-args))
         (if (eq mode :middle)
             (progn (lowlight-plot-object selected-object (plot-view-port plot)
                           plot)
                    (setf (plot-selected-object plot)
                          nil)
                    (apply selected-fn selected-object plot args-to-pass))
             (apply selected-fn plot args-to-pass))))

(defun plot-menu
 (plot menu-name)
   (case menu-name
       (:middle (plot-middle-menu plot))
       (:right (plot-right-menu plot))
       (otherwise (getf (plot-other-menus plot)
                        menu-name))))

(defun setf-plot-menu
 (plot menu-position new-menu &optional no-update-p)
   (if (not (or (null new-menu)
                (menu-p new-menu)))
       (error "Not a menu: ~s" new-menu)
       (if (and new-menu (null (menu-when-selected-fn new-menu)))
           (setf (menu-when-selected-fn new-menu)
                 'default-when-selected-fn)))
   (case menu-position
       (:middle (setf (plot-middle-menu plot)
                      new-menu))
       (:right (setf (plot-right-menu plot)
                     new-menu))
       (otherwise (setf (getf (plot-other-menus plot)
                              menu-position)
                        new-menu)))
   (when (and (eq menu-position :right)
              (plot-prop plot :fixed-right-menu-p)
              (null no-update-p)
              (open-window-p (plot-window plot)))

       (il:* il:|;;| "Update the fixed menu")


       (unfix-right-menu plot)
       (fix-right-menu plot))
   new-menu)

(defun plot-menu-items
 (plot menu-position)
   (case menu-position
       (:middle (menu-items (plot-middle-menu plot)))
       (:right (menu-items (plot-right-menu plot)))
       (otherwise (let ((menu (getf (plot-other-menus plot)
                                    menu-position)))
                       (and menu (menu-items menu))))))

(defun setf-plot-menu-items
 (plot menu-position new-items &optional no-update-p)

   (il:* il:|;;| "Replace the cached menu with the new list of items")


   (let ((menu (case menu-position
                   (:middle (plot-middle-menu plot))
                   (:right (plot-right-menu plot))
                   (otherwise (getf (plot-other-menus plot)
                                    menu-position)))))
        (setq menu (and new-items (if menu
                                      (copy-menu menu :new-items new-items)
                                      (make-menu :items new-items))))
        (setf-plot-menu plot menu-position menu no-update-p)
        new-items))

(defun add-plot-menu-items
 (plot menu-name items-to-add &optional no-update-p)

   (il:* il:|;;| "Add ITEMSTOADD to end of menu MENUNAME item list")


   (let* ((menu (case menu-name
                    (:middle (plot-middle-menu plot))
                    (:right (plot-right-menu plot))
                    (otherwise (getf (plot-other-menus plot)
                                     menu-name))))
          (menu-items (plot-menu-items plot menu-name)))
         (when items-to-add
             (setq items-to-add (mapcan #'(lambda (item)
                                                 (if (not (member item menu-items :test 'equal))
                                                     (list item)))
                                       items-to-add))
             (setf-plot-menu-items plot menu-name (append menu-items items-to-add)
                    no-update-p))
         items-to-add))

(defun delete-plot-menu-items
 (plot menu-name items-to-delete &optional no-update-p)

   (il:* il:|;;| "Delete ITEMSTODELETE from menu MENUNAME item list.  RETURNS new item list if something deleted or else NIL.  ITEMSTODELETE may be a list of lists or of atoms, in which case the atoms are compared to secessive CARS of MENUNAME's item list")


   (let ((menu (case menu-name
                   (:middle (plot-middle-menu plot))
                   (:right (plot-right-menu plot))
                   (otherwise (getf (plot-other-menus plot)
                                    menu-name))))
         (menu-items (plot-menu-items plot menu-name)))
        (setq items-to-delete
              (mapcan #'(lambda (item)
                               (let ((target (car (if (consp item)
                                                      (member item menu-items :test 'equal)
                                                      (member item menu-items :test 'equal :key
                                                             'car)))))
                                    (if target (list target))))
                     (if (listp items-to-delete)
                         items-to-delete
                         (list items-to-delete))))
        (setf-plot-menu-items plot menu-name (set-difference menu-items items-to-delete)
               no-update-p)
        items-to-delete))

(defvar *default-middle-menu*

   (make-menu :items '(("Label" toggle-label "Toggle label on/off" (:subitems ("Relabel" 
                                                                              relabel-selected-object
                                                                                     "Change label"))
                              )
                       ("Delete" delete-selected-object "Delete object"))
          :when-selected-fn
          'default-when-selected-fn :track-cursor-p t))

(defvar *default-right-menu*

   (make-menu :items '(("Layout" make-plot-sketch "Create a sketch of the PLOT")
                       ("Redraw" redraw-plot-window "Redraw plot")
                       ("Rescale" rescale-plot "Rescale plot axes"
                              (:subitems ("X Axis" (rescale-plot :x)
                                                "Rescale X axis"
                                                (:subitems ("Automatic" (rescale-plot :x)
                                                                  "Rescale automatically")
                                                       ("Manual" (manually-rescale-plot :x)
                                                              "Rescale manually")))
                                     ("Y Axis" (rescale-plot :y)
                                            "Rescale Y axis"
                                            (:subitems ("Automatic" (rescale-plot :y)
                                                              "Rescale automatically")
                                                   ("Manual" (manually-rescale-plot :y)
                                                          "Rescale manually")))))
                       ("Extend" extend-axis "Extend plot axes on/off" (:subitems ("X Axis"
                                                                                   (extend-axis
                                                                                    :x)
                                                                                   
                                                                               "Extend X axis on/off"
                                                                                   )
                                                                              ("Y Axis" (extend-axis
                                                                                         :y)
                                                                                     
                                                                               "Extend Y axis on/off"
                                                                                     )))
                       ("Labels" ask-for-which-label "Relabel plot" (:subitems ("Title" (
                                                                                        ask-for-label
                                                                                         :top)
                                                                                      "Title plot")
                                                                           ("Left" (ask-for-label
                                                                                    :left)
                                                                                  
                                                                                 "Label left of plot"
                                                                                  )
                                                                           ("Bottom" (ask-for-label
                                                                                      :bottom)
                                                                                  
                                                                               "Label bottom of plot"
                                                                                  )
                                                                           ("Right" (ask-for-label
                                                                                     :right)
                                                                                  
                                                                                "Label right of plot"
                                                                                  )))
                       ("Tics" toggle-tics "Tics on or off" (:subitems ("Top" (toggle-tics :top)
                                                                              "Top tics on/off")
                                                                   ("Left" (toggle-tics :left)
                                                                          "Left tics on/off")
                                                                   ("Bottom" (toggle-tics :bottom)
                                                                          "Bottom tics on/off")
                                                                   ("Right" (toggle-tics :right)
                                                                          "Right tics on/off")))
                       ("Undelete" undelete-last-object "Undelete last deleted object")
                       ("Fixed Menu" toggle-fixed-right-menu "Fix right plot menu"))
          :when-selected-fn
          'default-when-selected-fn :track-cursor-p t))

(defun manually-rescale-plot
 (plot &optional (axis :both))
   (let ((scale-info (plot-scale-info plot))
         (plot-objects (plot-objects plot)))
        (if (or (eq axis ':both)
                (eq axis ':x))
            (let ((new-interval (ask-for-scale plot ':x)))
                 (when (> (interval-max new-interval)
                          (interval-min new-interval))
                       (setf-plot-interval plot :x new-interval t))))
        (if (or (eq axis ':both)
                (eq axis ':y))
            (let ((new-interval (ask-for-scale plot ':y)))
                 (when (> (interval-max new-interval)
                          (interval-min new-interval))
                       (setf-plot-interval plot :y new-interval t))))
        (redraw-plot-window plot)))

(defun ask-for-scale
 (plot axis)
   (let ((eol-chars (il:constant (list (char-code #\Newline)
                                       (char-code #\Linefeed)
                                       (char-code #\Escape)
                                       (char-code #\Tab))))
         (plot-prompt-window (plot-prompt-window plot))
         (upper (ecase axis
                    (:x (plot-x-upper plot))
                    (:y (plot-y-upper plot))))
         (lower (case axis
                    (:x (plot-x-lower plot))
                    (:y (plot-y-lower plot)))))
        (terpri plot-prompt-window)
        (setq lower (read-from-string (il:promptforword (concatenate 'string (string axis)
                                                               " axis: From ")
                                             lower "Type a number" plot-prompt-window nil nil 
                                             eol-chars)))
        (setq upper (read-from-string (il:promptforword " to " upper "Type a number" 
                                             plot-prompt-window nil nil eol-chars)))
        (make-axis-interval :min lower :max upper)))

(defun toggle-label
 (selected-object plot)
   (if (plot-object-prop selected-object :label-object)
       (unlabel-plot-object selected-object plot)
       (label-plot-object selected-object plot)))

(defun ask-for-label
 (plot margin-name)

   (il:* il:|;;| "Prompt for new label and make the required call to LABELPLOT")


   (if (eq margin-name ':title)
       (setq margin-name ':top))
   (let ((plot-prompt (plot-prompt-window plot))
         (margin (ecase margin-name
                     (:bottom (plot-bottom-margin plot))
                     (:left (plot-left-margin plot))
                     (:top (plot-top-margin plot))
                     (:right (plot-right-margin plot))))
         newlabel)
        (terpri plot-prompt)
        (setq newlabel (il:promptforword (case margin-name
                                             (:bottom "Bottom margin label?")
                                             (:left "Left margin label?")
                                             (:top "Title?")
                                             (:right "Right margin label?"))
                              (margin-label margin)
                              "Type a label" plot-prompt nil nil (il:constant (list (char-code 
                                                                                           #\Newline)
                                                                                    (char-code 
                                                                                           #\Linefeed
                                                                                           )
                                                                                    (char-code 
                                                                                           #\Escape)
                                                                                    (char-code #\Tab)
                                                                                    ))))
        (if (or (null newlabel)
                (not (string= newlabel (margin-label margin))))
            (setf-plot-label plot margin-name newlabel))))

(defun ask-for-which-label
 (plot)

   (il:* il:|;;| "Prompt for new label and make the required call to ASKFORLABEL")


   (let ((lmenu (il:constant (make-menu :items '(:top :left :bottom :right))))
         margin)
        (print-plot-prompt "Select a margin" plot)
        (setq margin (pop-up-menu lmenu))
        (and margin (ask-for-label plot margin))))

(defun toggle-tics
 (plot &optional margin-name no-update-p)
   (if (null margin-name)
       (progn (toggle-tics plot :bottom t)
              (toggle-tics plot :left))
       (setf-tics-p plot margin-name (not (tics-p plot margin-name))
              no-update-p)))

(defun toggle-fixed-right-menu
 (plot)
   (if (plot-prop plot :fixed-right-menu-p)
       (unfix-right-menu plot)
       (fix-right-menu plot)))

(defun default-menu
 (menu-position)
   (case menu-position
       (:middle (and *default-middle-menu* (copy-menu *default-middle-menu*)))
       (:right (and *default-middle-menu* (copy-menu *default-right-menu*)))
       (otherwise (if (pt:memq menu-position *plot-object-types*)
                      (let ((menu (gethash menu-position *plot-object-menus*)))
                           (and menu (copy-menu menu)))))))

(defun setf-default-menu
 (menu-position new-menu)
   (let ((new-value (and new-menu (copy-menu new-menu))))
        (case menu-position
            (:middle (setq *default-middle-menu* new-value))
            (:right (setq *default-right-menu* new-value))
            (otherwise (if (pt:memq menu-position *plot-object-types*)
                           (setf (gethash menu-position *plot-object-menus*)
                                 new-value))))))



(il:* il:|;;| "Do we want this setf?")



(defsetf default-menu
 setf-default-menu)

(defun fix-right-menu
 (plot)
   (if (null (plot-prop plot :fixed-right-menu-p))
       (let ((plot-window (plot-window plot)))
            (setf (plot-prop plot :fixed-right-menu-p)
                  (and (open-window-p (plot-window plot))
                       (attach-menu (plot-right-menu plot)
                              plot-window :right :top))))))

(defun unfix-right-menu
 (plot)
   (let ((fixed-menu (plot-prop plot :fixed-right-menu-p)))
        (when fixed-menu
            (close-window fixed-menu)
            (detach-window fixed-menu)
            (setf (plot-prop plot :fixed-right-menu-p)
                  nil))))

(defun remove-fixed-right-menu
 (plot)
   (let ((fixed-menu (plot-prop plot :fixed-right-menu-p)))
        (when fixed-menu
            (close-window fixed-menu)
            (detach-window fixed-menu)
            (setf (plot-prop plot :fixed-right-menu-p)
                  nil))))



(il:* il:|;;| "Misc functions")



(defun which-plot
 (&optional window-or-x y)
     (il:* il:\; "Edited  6-May-87 09:27 by jop")


   (il:* il:|;;| "like WHICHW but returns corresponding plot.  First arg may be a window")


   (let* ((w (or (window-p window-or-x)
                 (il:whichw window-or-x y)))
          (plot (or (window-prop w :plot)
                    (window-prop (window-prop w 'il:iconfor)
                           :plot))))
         (if (typep plot 'plot)
             plot)))

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