(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