(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "PLOT")
(il:filecreated " 1-Dec-88 12:04:21" il:{qv}<idl>next>plot-objects.\;24 70027
il:|changes| il:|to:| (il:functions define-plot-object symbol-to-bitmap l1-metric l1-metric-xy
sine-wave plot-points get-compound draw-graph)
il:|previous| il:|date:| "15-Nov-88 18:51:12" il:{qv}<idl>next>plot-objects.\;22)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:plot-objectscoms)
(il:rpaqq il:plot-objectscoms
(
(il:* il:|;;| "Definer for plot-objects")
(il:coms (il:variables *plot-object-types* *plot-object-type-table*
*plot-object-constructor-table* *plot-object-menus*)
(il:functions define-plot-object)
(il:functions type-of-object))
(il:* il:|;;| "Utilities")
(il:coms
(il:* il:|;;| "Bitmaps")
(il:variables *star* *circle* *cross*)
(il:functions bitmap-to-symbol symbol-to-bitmap)
(il:functions make-symbol-menu)
(il:* il:|;;| "Line styles")
(il:variables *dash* *dot* *dot-dash*)
(il:functions make-dashing-menu)
(il:* il:|;;| "Textures")
(il:variables *shade-1* *shade-2* *shade-3* *shade-4* *shade-5* *shade-6* *shade-7*
*shade-8*)
(il:functions make-texture-menu)
(il:* il:|;;| "Line styles")
(il:structures line-style)
(il:functions change-style-width change-style-dashing)
(il:* il:|;;| "Generic labeling")
(il:functions label-generic)
(il:* il:|;;| "Distance utilities")
(il:functions l1-metric l1-metric-xy positions-list-extent positions-list-distance
no-extent)
(il:* il:|;;| "Rendering Utilities")
(il:functions connect-positions)
(il:* il:|;;| "Debugging")
(il:functions sine-wave plot-object-error))
(il:* il:|;;| "Points")
(il:coms (il:structures point)
(il:functions make-point)
(il:functions draw-point erase-point highlight-point extent-of-point
distance-to-point label-point move-point copy-point put-point get-point)
(il:functions plot-point plot-points change-point-symbol))
(il:* il:|;;| "Curves")
(il:coms (il:structures curve)
(il:functions make-curve)
(il:functions draw-curve erase-curve highlight-curve extent-of-curve
distance-to-curve move-curve copy-curve put-curve get-curve)
(il:functions plot-curve change-curve-width change-curve-dashing))
(il:* il:|;;| "Polygons")
(il:coms (il:structures polygon)
(il:functions make-polygon)
(il:functions draw-polygon erase-polygon highlight-polygon extent-of-polygon
distance-to-polygon move-polygon copy-polygon put-polygon get-polygon)
(il:functions plot-polygon change-polygon-width change-polygon-dashing))
(il:* il:|;;| "Filled rectangles")
(il:coms (il:structures rectangle)
(il:functions rectangle-right rectangle-stream-right rectangle-top
rectangle-stream-top)
(il:functions make-rectangle)
(il:functions draw-rectangle erase-rectangle highlight-rectangle
extent-of-rectangle distance-to-rectangle move-rectangle copy-rectangle
put-rectangle get-rectangle)
(il:functions plot-rectangle change-rectangle-border change-rectangle-texture))
(il:* il:|;;| "Text")
(il:coms (il:structures text)
(il:functions make-text)
(il:functions draw-text erase-text highlight-text extent-of-text distance-to-text
move-text copy-text put-text get-text)
(il:functions plot-text))
(il:* il:|;;| "Compound objects")
(il:coms (il:structures compound)
(il:functions make-compound)
(il:functions draw-compound erase-compound highlight-compound extent-of-compound
distance-to-compound move-compound copy-compound put-compound get-compound)
(il:functions plot-compound))
(il:* il:|;;| "Analytic lines")
(il:coms (il:structures line)
(il:functions make-line)
(il:functions draw-analytic-line erase-analytic-line highlight-line
distance-to-line copy-line extent-of-line put-line get-line)
(il:functions plot-line change-line-width change-line-dashing))
(il:* il:|;;| "Graphs")
(il:coms (il:structures graph)
(il:functions make-graph)
(il:functions draw-graph erase-graph highlight-graph distance-to-graph copy-graph
extent-of-graph)
(il:functions plot-graph change-graph-width change-graph-dashing))
(xcl:file-environments "PLOT-OBJECTS")))
(il:* il:|;;| "Definer for plot-objects")
(defvar *plot-object-types* nil)
(defvar *plot-object-type-table* (make-hash-table :test #'eq))
(defvar *plot-object-constructor-table* (make-hash-table :test #'eq))
(defvar *plot-object-menus* (make-hash-table :test #'eq))
(xcl:defdefiner define-plot-object il:structures (type &key methods instance-vars menu-items)
(let* ((type-package (symbol-package type))
(type-string (string type))
(type-keyword (intern type-string (find-package "KEYWORD")))
(stucture-name (intern (concatenate 'string type-string "-PLOT-OBJECT")
type-package))
(conc-name (concatenate 'string type-string "-"))
(constructor (intern (concatenate 'string "%MAKE-" type-string)
type-package))
(copier (intern (concatenate 'string "%COPY-" type-string)
type-package))
(methods-name (intern (concatenate 'string "*" type-string "-OBJECT-METHODS*")
type-package))
(methods-alist '((:draw-fn . "DRAW-")
(:erase-fn . "ERASE-")
(:highlight-fn . "HIGHLIGHT-")
(:lowlight-fn . "HIGHLIGHT-")
(:extent-fn . "EXTENT-OF-")
(:distance-fn . "DISTANCE-TO-")
(:label-fn . "LABEL-")
(:move-fn . "MOVE-")
(:copy-fn . "COPY-")
(:put-fn . "PUT-")
(:get-fn . "GET-"))))
(setq methods
(mapcan #'(lambda (pair)
(let* ((keyword (car pair))
(prefix (cdr pair))
(supplied (cdr (pt:memq keyword methods))))
(if supplied
(let ((value (car supplied)))
(if value
`(,keyword ',value)))
`(,keyword ',(intern (concatenate 'string prefix
type-string)
type-package)))))
methods-alist))
`(progn (defparameter ,methods-name (make-plot-methods ,@methods))
(defstruct (,stucture-name (:include plot-object (methods ,methods-name))
(:conc-name ,conc-name)
(:constructor ,constructor)
(:copier ,copier))
,@instance-vars)
(pushnew ',type-keyword *plot-object-types*)
(setf (gethash ',stucture-name *plot-object-type-table*)
',type-keyword)
(setf (gethash ',type-keyword *plot-object-constructor-table*)
',constructor)
,@(if menu-items
`((setf (gethash ',type-keyword *plot-object-menus*)
(make-menu :items (append (menu-items *default-middle-menu*)
',menu-items)
:when-selected-fn
'default-when-selected-fn :track-cursor-p t)))))))
(defun type-of-object (plot-object)
(gethash (type-of plot-object)
*plot-object-type-table*))
(il:* il:|;;| "Utilities")
(il:* il:|;;| "Bitmaps")
(defvar *star* '#*(5 5)JH@@G@@@OH@@G@@@JH@@)
(defvar *circle* '#*(5 5)G@@@HH@@HH@@HH@@G@@@)
(defvar *cross* '#*(5 5)B@@@B@@@OH@@B@@@B@@@)
(defun bitmap-to-symbol (bitmap)
(let ((sym-tail (member bitmap '(*star* *circle* *cross*)
:key
'symbol-value)))
(if sym-tail
(car sym-tail)
bitmap)))
(defun symbol-to-bitmap (symbol)
(let ((sym-tail (pt:memq symbol '(*star* *circle* *cross*))))
(if sym-tail
(symbol-value (car sym-tail))
symbol)))
(defun make-symbol-menu ()
(flet ((bitmap-icon (bitmap &optional (scale-factor 2))
(let* ((width (bitmap-width bitmap))
(height (bitmap-height bitmap))
(icon (make-bitmap (* scale-factor width)
(* scale-factor height))))
(stream-bitblt bitmap icon :destination-left (truncate (- (bitmap-width icon)
width)
2)
:destination-bottom
(truncate (- (bitmap-height icon)
height)
2))
icon)))
(make-menu :items `((,(bitmap-icon *star* 4)
*star*)
(,(bitmap-icon *circle* 4)
*circle*)
(,(bitmap-icon *cross* 4)
*cross*))
:border-size 1 :track-cursor-p t)))
(il:* il:|;;| "Line styles")
(defvar *dash* '(5))
(defvar *dot* '(1 5))
(defvar *dot-dash* '(5 5 1 5))
(defun make-dashing-menu ()
(flet ((fill-bitmap-with-dashing (dashing &optional (width 50)
(height 10)
(thickness 2))
(let* ((bitmap (make-bitmap width height))
(stream (il:dspcreate bitmap))
(y (truncate height 2)))
(stream-draw-line 0 y width y stream :width thickness :operation boole-1
:dashing dashing)
bitmap)))
(make-menu :items `((,(fill-bitmap-with-dashing nil)
:solid)
(,(fill-bitmap-with-dashing *dash*)
*dash*)
(,(fill-bitmap-with-dashing *dot*)
*dot*)
(,(fill-bitmap-with-dashing *dot-dash*)
*dot-dash*))
:border-size 1 :track-cursor-p t)))
(il:* il:|;;| "Textures")
(defvar *shade-1* 64)
(defvar *shade-2* 576)
(defvar *shade-3* 4680)
(defvar *shade-4* 37449)
(defvar *shade-5* 55899)
(defvar *shade-6* 31710)
(defvar *shade-7* 64479)
(defvar *shade-8* 65023)
(defun make-texture-menu ()
(flet ((texture-bitmap (texture &optional (width 30)
(height 20))
(let* ((bitmap (make-bitmap width height)))
(stream-bltshade texture bitmap)
bitmap)))
(make-menu :items `((,(texture-bitmap *shade-1*)
*shade-1*)
(,(texture-bitmap *shade-2*)
*shade-2*)
(,(texture-bitmap *shade-3*)
*shade-3*)
(,(texture-bitmap *shade-4*)
*shade-4*)
(,(texture-bitmap *shade-5*)
*shade-5*)
(,(texture-bitmap *shade-6*)
*shade-6*)
(,(texture-bitmap *shade-7*)
*shade-7*)
(,(texture-bitmap *shade-8*)
*shade-8*))
:border-size 1 :track-cursor-p t)))
(il:* il:|;;| "Line styles")
(defstruct (line-style (:type list)
(:conc-name "STYLE-"))
(width 1)
dashing color)
(defun change-style-width (new-width style plot-object plot)
(il:* il:|;;| "Assumes an open plot-window")
(when (null new-width)
(print-plot-prompt "Indicate new width" plot)
(setq new-width (il:rnumber nil nil nil nil t nil t))
(print-plot-prompt "" plot))
(when new-width
(let ((view-port (plot-view-port plot)))
(erase-plot-object plot-object view-port plot)
(setf (style-width style)
new-width)
(draw-plot-object plot-object view-port plot))))
(defun change-style-dashing (new-dashing style plot-object plot)
(il:* il:|;;| "Assumes an open plot-window")
(when (null new-dashing)
(print-plot-prompt "Indicate new dashing" plot)
(setq new-dashing (pop-up-menu (il:constant (make-dashing-menu))))
(print-plot-prompt "" plot))
(when new-dashing
(let ((view-port (plot-view-port plot)))
(erase-plot-object plot-object view-port plot)
(setf (style-dashing style)
(if (eq new-dashing :solid)
nil
new-dashing))
(draw-plot-object plot-object view-port plot))))
(il:* il:|;;| "Generic labeling")
(defun label-generic (object plot) (il:* il:\; "Edited 5-May-87 17:56 by jop")
(il:* il:|;;| "Generic label routine. Intended for interactive use only")
(let ((view-port (plot-view-port plot))
(text-object (plot-object-prop object :label-object)))
(if text-object
(draw-plot-object text-object view-port plot)
(let ((label (plot-object-label object))
(label-position (progn (print-plot-prompt "Select a position for label: " plot)
(stream-to-world (get-position (plot-window plot))
view-port))))
(setq text-object (make-text label-position label :font *small-plot-font*))
(draw-plot-object text-object view-port plot)
(setf (plot-object-prop object :label-object)
text-object)))))
(il:* il:|;;| "Distance utilities")
(defmacro l1-metric (position-1 position-2)
(pt:once-only (position-1 position-2)
`(+ (abs (- (position-x ,position-1)
(position-x ,position-2)))
(abs (- (position-y ,position-1)
(position-y ,position-2))))))
(defmacro l1-metric-xy (position-1 x y)
(pt:once-only (position-1)
`(+ (abs (- (position-x ,position-1)
,x))
(abs (- (position-y ,position-1)
,y)))))
(defun positions-list-extent (positions)
(let* ((first-position (car positions))
(min-x (position-x first-position))
(max-x min-x)
(min-y (position-y first-position))
(max-y min-y))
(dolist (position (cdr positions))
(let ((x (position-x position))
(y (position-y position)))
(if (< x min-x)
(setq min-x x)
(if (> x max-x)
(setq max-x x)))
(if (< y min-y)
(setq min-y y)
(if (> y max-y)
(setq max-y y)))))
(make-extent :min-x min-x :max-x max-x :min-y min-y :max-y max-y)))
(defun positions-list-distance (positions target)
(let ((min (l1-metric (car positions)
target)))
(dolist (position (cdr positions))
(let ((candidate (l1-metric position target)))
(if (< candidate min)
(setq min candidate))))
min))
(defun no-extent (plot-object)
(declare (ignore plot-object))
nil)
(il:* il:|;;| "Rendering Utilities")
(defun connect-positions (stream-positions stream stream-subregion operation line-width color
dashing &optional close-loop-p)
(let ((first-position (car stream-positions))
(rest-positions (cdr stream-positions)))
(stream-move-to (position-x first-position)
(position-y first-position)
stream)
(dolist (position rest-positions)
(clipped-draw-to (position-x position)
(position-y position)
stream stream-subregion :width line-width :operation operation :color color
:dashing dashing))
(if close-loop-p
(clipped-draw-to (position-x first-position)
(position-y first-position)
stream stream-subregion :width line-width :operation operation :color color
:dashing dashing))))
(il:* il:|;;| "Debugging")
(defun sine-wave (n from to &optional (frequency 1)
(amplitude 1))
(il:* il:|;;| "produce N points on a sine wave")
(let* ((twopi (* 2.0 pi))
(range (- to from))
(x from)
(inc (/ (float range)
n)))
(pt:with-collection (dotimes (i n)
(pt:collect (make-position x (* amplitude (sin (* frequency x)))))
(incf x inc)))))
(defun plot-object-error (&rest args)
(error "Unimplemented method"))
(il:* il:|;;| "Points")
(define-plot-object point :instance-vars (position stream-position symbol)
:menu-items (("Symbol" change-point-symbol "Change point symbol")))
(defun make-point (position &key (symbol *star*)
label menu)
(%make-point :menu menu :label label :position position :symbol symbol))
(defun draw-point (point view-port plot)
(il:* il:|;;| "Draw a glyph at POINT-POSITION. SYMBOL is the glyph to be drawn.")
(let ((stream (vp-parent-stream view-port))
(stream-subregion (vp-stream-subregion view-port))
(symbol (point-symbol point))
(stream-point (world-to-stream (point-position point)
view-port)))
(clipped-plot-at stream-point symbol stream stream-subregion)
(if (eq stream (window-dsp (plot-window plot)))
(setf (point-stream-position point)
stream-point))))
(defun erase-point (point view-port plot)
(il:* il:|;;| "Erase POINT, using cached stream coordinates")
(clipped-plot-at (point-stream-position point)
(point-symbol point)
(vp-parent-stream view-port)
(vp-stream-subregion view-port)
boole-andc1))
(defun highlight-point (point view-port plot) (il:* il:\; "Edited 5-May-87 17:56 by jop")
(il:* il:|;;| "Highlight POINT")
(let* ((symbol (point-symbol point))
(stream-position (point-stream-position point))
(glyph-width (bitmap-width symbol))
(glyph-height (bitmap-height symbol))
(x-offset (- (position-x stream-position)
(truncate glyph-width 2)))
(y-offset (- (position-y stream-position)
(truncate glyph-height 2))))
(clipped-bltshade *black-shade* (vp-parent-stream view-port)
(vp-stream-subregion view-port)
:destination-left x-offset :destination-bottom y-offset :width glyph-width :height
glyph-height :operation boole-xor)))
(defun extent-of-point (point plot)
(declare (ignore plot))
(point-position point))
(defun distance-to-point (point stream-position plot)
(l1-metric (point-stream-position point)
stream-position))
(defun label-point (point plot)
(il:* il:|;;| "Label a POINT")
(let ((view-port (plot-view-port plot))
(text-object (plot-object-prop point :label-object)))
(il:* il:|;;| "Displace Label to right of point object")
(if text-object
(draw-plot-object text-object view-port plot)
(let* ((label (point-label point))
(position (point-position point))
(label-position (make-position (+ (position-x position)
(* 2 (stream-to-world-length-x
(bitmap-width (point-symbol point))
view-port)))
(position-y position))))
(setq text-object (make-text label-position label :font *small-plot-font*))
(draw-plot-object text-object view-port plot)
(il:* il:|;;| "CACHE LABEL ON PROP LIST OF OBJECT")
(setf (plot-object-prop point :label-object)
text-object)))))
(defun move-point (point dx dy plot)
(let ((position (point-position point)))
(incf (position-x position)
dx)
(incf (position-y position)
dy)))
(defun copy-point (point)
(let ((new-point (%copy-point point)))
(setf (point-position new-point)
(copy-position (point-position point)))
(setf (point-stream-position new-point)
nil)
new-point))
(defun put-point (point stream)
(prin1 (point-position point)
stream)
(write-char #\Space stream)
(prin1 (bitmap-to-symbol (point-symbol point))
stream))
(defun get-point (point stream)
(setf (point-position point)
(read stream))
(setf (point-symbol point)
(symbol-to-bitmap (read stream))))
(defun plot-point (plot position &key label (symbol *star*)
menu no-update-p)
(il:* il:|;;| "User entry point. Add a point to PLOT, at world position POSITION, with Label LABEL and plotting symbol SYMBOL")
(add-plot-object (make-point position :symbol symbol :label label :menu menu)
plot no-update-p))
(defun plot-points (plot positions &key labels (symbol *star*)
menu no-update-p)
(il:* il:|;;| "User Entry Point. Draw the POINTs at POSITIONS in a Plotting WINDOW.")
(let ((points (pt:with-collection (let ((label labels))
(dolist (position positions)
(pt:collect (make-point position :symbol symbol :label
(car label)
:menu menu))
(setq label (cdr label)))))))
(add-plot-objects points plot no-update-p)))
(defun change-point-symbol (point plot &optional new-sym)
(when (null new-sym)
(print-plot-prompt "Indicate new symbol" plot)
(setq new-sym (pop-up-menu (il:constant (make-symbol-menu))))
(print-plot-prompt "" plot))
(when new-sym
(let ((view-port (plot-view-port plot)))
(erase-plot-object point view-port plot)
(setf (point-symbol point)
new-sym)
(draw-plot-object point view-port plot))))
(il:* il:|;;| "Curves")
(define-plot-object curve :instance-vars (positions stream-positions style)
:methods (:label-fn label-generic)
:menu-items (("Width" change-curve-width "Change width")
("Dashing" change-curve-dashing "Change dashing")))
(defun make-curve (positions &key (style (make-line-style))
label menu)
(if (null positions)
(error "A curve must have at least one position"))
(%make-curve :menu menu :label label :positions positions :style (if (integerp style)
(make-line-style :width style
)
style)))
(defun draw-curve (curve view-port plot)
(il:* il:|;;| "Draw a series of connected lines in VIEW-PORT.")
(let* ((stream (vp-parent-stream view-port))
(stream-positions (mapcar #'(lambda (position)
(world-to-stream position view-port))
(curve-positions curve)))
(style (curve-style curve))
(line-width (* (stream-scale stream)
(style-width style))))
(connect-positions stream-positions stream (vp-stream-subregion view-port)
boole-1 line-width (style-color style)
(style-dashing style))
(if (eq stream (window-dsp (plot-window plot)))
(setf (curve-stream-positions curve)
stream-positions))))
(defun erase-curve (curve view-port plot)
(il:* il:|;;| "Erase the CURVEOBJECT, using the cached stream coordinates")
(let* ((stream (vp-parent-stream view-port))
(style (curve-style curve))
(line-width (* (stream-scale stream)
(+ 2 (style-width style)))))
(connect-positions (curve-stream-positions curve)
stream
(vp-stream-subregion view-port)
boole-andc1 line-width (style-color style)
nil)))
(defun highlight-curve (curve view-port plot) (il:* il:\; "Edited 5-May-87 17:55 by jop")
(il:* il:|;;|
"Highlight the CURVEOBJECT, by redrawing in invert mode with slightly fatter lines")
(let* ((stream (vp-parent-stream view-port))
(style (curve-style curve))
(line-width (* (stream-scale stream)
(+ 2 (style-width style)))))
(connect-positions (curve-stream-positions curve)
stream
(vp-stream-subregion view-port)
boole-xor line-width (style-color style)
nil)))
(defun extent-of-curve (curve)
(il:* il:|;;| "Assumes each curve has at least one point")
(positions-list-extent (curve-positions curve)))
(defun distance-to-curve (curve stream-position plot)
(positions-list-distance (curve-stream-positions curve)
stream-position))
(defun move-curve (curve dx dy plot)
(let ((positions (curve-positions curve)))
(dolist (position positions)
(incf (position-x position)
dx)
(incf (position-y position)
dy))))
(defun copy-curve (curve)
(il:* il:|;;| "Copyfn for CURVE objects")
(let ((new-curve (%copy-curve curve)))
(setf (curve-positions new-curve)
(mapcar #'(lambda (position)
(copy-position position))
(curve-positions curve)))
(setf (curve-stream-positions new-curve)
nil)
(setf (curve-style new-curve)
(copy-line-style (curve-style curve)))
new-curve))
(defun put-curve (curve stream)
(prin1 (curve-positions curve)
stream)
(write-char #\Space stream)
(prin1 (curve-style curve)
stream))
(defun get-curve (curve stream)
(setf (curve-positions curve)
(read stream))
(setf (curve-style curve)
(read stream)))
(defun plot-curve (plot positions &key label (style 1)
menu no-update-p)
(il:* il:|;;| "User Entry Point. Draw a piecewise linear curve in PLOT. Style is either the line width to use or a list (width dashing color). POSITIONS is a list of positions to be connected.")
(add-plot-object (make-curve positions :style style :label label :menu menu)
plot no-update-p))
(defun change-curve-width (curve plot &optional new-width)
(change-style-width new-width (curve-style curve)
curve plot))
(defun change-curve-dashing (curve plot &optional new-dashing)
(change-style-dashing new-dashing (curve-style curve)
curve plot))
(il:* il:|;;| "Polygons")
(define-plot-object polygon :instance-vars (positions stream-positions style)
:methods (:label-fn label-generic)
:menu-items (("Width" change-polygon-width "Change width")
("Dashing" change-polygon-dashing "Change dashing")))
(defun make-polygon (positions &key (style (make-line-style))
label menu)
(if (null positions)
(error "A polygon must have at least one position"))
(%make-polygon :menu menu :label label :positions positions :style (if (integerp style)
(make-line-style :width
style)
style)))
(defun draw-polygon (polygon view-port plot)
(il:* il:|;;| "Draw a series of connected lines in VIEW-PORT.")
(let* ((stream (vp-parent-stream view-port))
(stream-positions (mapcar #'(lambda (position)
(world-to-stream position view-port))
(polygon-positions polygon)))
(style (polygon-style polygon))
(line-width (* (stream-scale stream)
(style-width style)))
(dashing (style-dashing style)))
(connect-positions stream-positions stream (vp-stream-subregion view-port)
boole-1 line-width (style-color style)
(style-dashing style)
t)
(if (eq stream (window-dsp (plot-window plot)))
(setf (polygon-stream-positions polygon)
stream-positions))))
(defun erase-polygon (polygon view-port plot)
(il:* il:|;;| "Erase the CURVEOBJECT, using the cached stream coordinates")
(let* ((stream (vp-parent-stream view-port))
(style (polygon-style polygon))
(line-width (* (stream-scale stream)
(+ 2 (style-width style)))))
(connect-positions (polygon-stream-positions polygon)
stream
(vp-stream-subregion view-port)
boole-andc1 line-width (style-color style)
nil t)))
(defun highlight-polygon (polygon view-port plot)
(il:* il:\; "Edited 5-May-87 17:55 by jop")
(let* ((stream (vp-parent-stream view-port))
(style (polygon-style polygon))
(line-width (* (stream-scale stream)
(+ 2 (style-width style)))))
(connect-positions (polygon-stream-positions polygon)
stream
(vp-stream-subregion view-port)
boole-xor line-width (style-color style)
nil t)))
(defun extent-of-polygon (polygon)
(il:* il:|;;| "Assumes each curve has at least one point")
(positions-list-extent (polygon-positions polygon)))
(defun distance-to-polygon (polygon stream-position plot)
(positions-list-distance (polygon-stream-positions polygon)
stream-position))
(defun move-polygon (polygon dx dy plot)
(let ((positions (polygon-positions polygon)))
(dolist (position positions)
(incf (position-x position)
dx)
(incf (position-y position)
dy))))
(defun copy-polygon (polygon)
(let ((new-polygon (%copy-polygon polygon)))
(setf (polygon-positions new-polygon)
(mapcar #'(lambda (position)
(copy-position position))
(polygon-positions polygon)))
(setf (polygon-stream-positions new-polygon)
nil)
(setf (polygon-style new-polygon)
(copy-line-style (polygon-style polygon)))
new-polygon))
(defun put-polygon (polygon stream)
(prin1 (polygon-positions polygon)
stream)
(write-char #\Space stream)
(prin1 (polygon-style polygon)
stream))
(defun get-polygon (polygon stream)
(setf (polygon-positions polygon)
(read stream))
(setf (polygon-style polygon)
(read stream)))
(defun plot-polygon (plot positions &key label (style 1)
menu no-update-p)
(il:* il:|;;| "User Entry Point. Draw a piecewise linear polygon in PLOT. Style is either the line width to use or a list (width dashing color). POSITIONS is a list of positions to be connected by a closed set of lines.")
(add-plot-object (make-polygon positions :style style :label label :menu menu)
plot no-update-p))
(defun change-polygon-width (polygon plot &optional new-width)
(change-style-width new-width (polygon-style polygon)
polygon plot))
(defun change-polygon-dashing (polygon plot &optional new-dashing)
(change-style-dashing new-dashing (polygon-style polygon)
polygon plot))
(il:* il:|;;| "Filled rectangles")
(define-plot-object rectangle :instance-vars (left bottom width height border-width texture
stream-left stream-bottom stream-width
stream-height)
:methods (:label-fn label-generic)
:menu-items (("Border" change-rectangle-border "Change border width")
("Texture" change-rectangle-texture "Change rectangle texture")))
(defun rectangle-right (rectangle)
(+ (rectangle-left rectangle)
(rectangle-width rectangle)))
(defun rectangle-stream-right (rectangle)
(+ (rectangle-stream-left rectangle)
(rectangle-stream-width rectangle)))
(defun rectangle-top (rectangle)
(+ (rectangle-bottom rectangle)
(rectangle-height rectangle)))
(defun rectangle-stream-top (rectangle)
(+ (rectangle-stream-bottom rectangle)
(rectangle-stream-height rectangle)))
(defun make-rectangle (left bottom width height &key label (border-width 1)
(texture *shade-3*)
menu)
(%make-rectangle :menu menu :label label :left left :bottom bottom :width width :height height
:border-width border-width :texture texture))
(defun draw-rectangle (rectangle view-port plot)
(let* ((stream (vp-parent-stream view-port))
(stream-subregion (vp-stream-subregion view-port))
(texture (rectangle-texture rectangle))
(border-width (* (stream-scale stream)
(rectangle-border-width rectangle)))
(stream-left (world-to-stream-x (rectangle-left rectangle)
view-port))
(stream-bottom (world-to-stream-y (rectangle-bottom rectangle)
view-port))
(stream-width (- (world-to-stream-x (+ (rectangle-left rectangle)
(rectangle-width rectangle))
view-port)
stream-left))
(stream-height (- (world-to-stream-y (+ (rectangle-bottom rectangle)
(rectangle-height rectangle))
view-port)
stream-bottom))
(stream-right (+ stream-left stream-width))
(stream-top (+ stream-bottom stream-height)))
(clipped-bltshade texture stream stream-subregion :destination-left stream-left
:destination-bottom stream-bottom :width stream-width :height stream-height
:operation boole-ior)
(stream-move-to stream-left stream-bottom stream)
(clipped-draw-to stream-right stream-bottom stream stream-subregion :width border-width
:operation boole-1)
(clipped-draw-to stream-right stream-top stream stream-subregion :width border-width
:operation boole-1)
(clipped-draw-to stream-left stream-top stream stream-subregion :width border-width
:operation boole-1)
(clipped-draw-to stream-left stream-bottom stream stream-subregion :width border-width
:operation boole-1)
(when (eq stream (window-dsp (plot-window plot)))
(setf (rectangle-stream-left rectangle)
stream-left)
(setf (rectangle-stream-bottom rectangle)
stream-bottom)
(setf (rectangle-stream-width rectangle)
stream-width)
(setf (rectangle-stream-height rectangle)
stream-height))))
(defun erase-rectangle (rectangle view-port plot)
(let* ((stream (vp-parent-stream view-port))
(stream-subregion (vp-stream-subregion view-port))
(texture (rectangle-texture rectangle))
(border-width (* (stream-scale stream)
(rectangle-border-width rectangle)))
(stream-left (rectangle-stream-left rectangle))
(stream-bottom (rectangle-stream-bottom rectangle))
(stream-width (rectangle-stream-width rectangle))
(stream-height (rectangle-stream-height rectangle))
(stream-right (+ stream-left stream-width))
(stream-top (+ stream-bottom stream-height)))
(clipped-bltshade texture stream stream-subregion :destination-left stream-left
:destination-bottom stream-bottom :width stream-width :height stream-height
:operation boole-xor)
(stream-move-to stream-left stream-bottom stream)
(clipped-draw-to stream-right stream-bottom stream stream-subregion :width border-width
:operation boole-andc1)
(clipped-draw-to stream-right stream-top stream stream-subregion :width border-width
:operation boole-andc1)
(clipped-draw-to stream-left stream-top stream stream-subregion :width border-width
:operation boole-andc1)
(clipped-draw-to stream-left stream-bottom stream stream-subregion :width border-width
:operation boole-andc1)))
(defun highlight-rectangle (rectangle view-port plot)
(let* ((stream (vp-parent-stream view-port))
(stream-subregion (vp-stream-subregion view-port))
(texture (rectangle-texture rectangle))
(border-width (* (stream-scale stream)
(+ 2 (rectangle-border-width rectangle))))
(stream-left (rectangle-stream-left rectangle))
(stream-bottom (rectangle-stream-bottom rectangle))
(stream-width (rectangle-stream-width rectangle))
(stream-height (rectangle-stream-height rectangle))
(stream-right (+ stream-left stream-width))
(stream-top (+ stream-bottom stream-height)))
(clipped-bltshade *black-shade* stream stream-subregion :destination-left stream-left
:destination-bottom stream-bottom :width stream-width :height stream-height
:operation boole-xor)
(stream-move-to stream-left stream-bottom stream)
(clipped-draw-to stream-right stream-bottom stream stream-subregion :width border-width
:operation boole-xor)
(clipped-draw-to stream-right stream-top stream stream-subregion :width border-width
:operation boole-xor)
(clipped-draw-to stream-left stream-top stream stream-subregion :width border-width
:operation boole-xor)
(clipped-draw-to stream-left stream-bottom stream stream-subregion :width border-width
:operation boole-xor)))
(defun extent-of-rectangle (rectangle)
(make-extent :min-x (rectangle-left rectangle)
:max-x
(rectangle-right rectangle)
:min-y
(rectangle-bottom rectangle)
:max-y
(rectangle-top rectangle)))
(defun distance-to-rectangle (rectangle stream-position plot)
(let ((stream-x (position-x stream-position))
(stream-y (position-y stream-position))
(stream-left (rectangle-stream-left rectangle))
(stream-bottom (rectangle-stream-bottom rectangle))
(stream-right (rectangle-stream-right rectangle))
(stream-top (rectangle-stream-top rectangle))
(inside-p nil)
x-closest y-closest)
(setq x-closest (cond
((> stream-x stream-right)
stream-right)
((< stream-x stream-left)
stream-left)
(t (if (or (> stream-y stream-top)
(< stream-y stream-bottom))
(il:* il:|;;| "outside ")
stream-x
(il:* il:|;;| "Inside ")
(progn (setq inside-p t)
(if (< (min (- stream-top stream-y)
(- stream-y stream-bottom))
(min (- stream-right stream-x)
(- stream-x stream-left)))
(il:* il:|;;| "closer to top or bottom")
stream-x
(if (< (- stream-right stream-x)
(- stream-x stream-left))
(il:* il:|;;| "Closest to right edge")
stream-right
(il:* il:|;;| "Closest to left edge")
stream-left)))))))
(setq y-closest (cond
((> stream-y stream-top)
stream-top)
((< stream-y stream-bottom)
stream-bottom)
(t (if (or (> stream-x stream-right)
(< stream-x stream-left))
(il:* il:|;;| "outside ")
stream-y
(il:* il:|;;| "Inside ")
(progn (setq inside-p t)
(if (< (min (- stream-right stream-x)
(- stream-x stream-left))
(min (- stream-top stream-y)
(- stream-y stream-bottom)))
(il:* il:|;;| "closer to right or left")
stream-y
(if (< (- stream-top stream-y)
(- stream-y stream-bottom))
(il:* il:|;;| "Closest to right edge")
stream-top
(il:* il:|;;| "Closest to left edge")
stream-bottom)))))))
(let ((raw-distance (l1-metric-xy stream-position x-closest y-closest)))
(if inside-p
(il:* il:|;;| "Hack to deal with the case of adjacent rectangles. Bonus subtracted from metric if cursor inside rectangle")
(- raw-distance 2)
raw-distance))))
(defun move-rectangle (rectangle dx dy plot)
(incf (rectangle-left rectangle)
dx)
(incf (rectangle-bottom rectangle)
dy))
(defun copy-rectangle (rectangle)
(il:* il:|;;| "Copyfn for CURVE objects")
(let ((new-rectangle (%copy-rectangle rectangle)))
(setf (rectangle-stream-left new-rectangle)
nil)
(setf (rectangle-stream-bottom new-rectangle)
nil)
(setf (rectangle-stream-width new-rectangle)
nil)
(setf (rectangle-stream-height new-rectangle)
nil)
new-rectangle))
(defun put-rectangle (rectangle stream)
(prin1 (rectangle-left rectangle)
stream)
(write-char #\Space stream)
(prin1 (rectangle-bottom rectangle)
stream)
(write-char #\Space stream)
(prin1 (rectangle-width rectangle)
stream)
(write-char #\Space stream)
(prin1 (rectangle-height rectangle)
stream)
(write-char #\Space stream)
(prin1 (rectangle-border-width rectangle)
stream)
(write-char #\Space stream)
(prin1 (rectangle-texture rectangle)
stream))
(defun get-rectangle (rectangle stream)
(setf (rectangle-left rectangle)
(read stream))
(setf (rectangle-bottom rectangle)
(read stream))
(setf (rectangle-width rectangle)
(read stream))
(setf (rectangle-height rectangle)
(read stream))
(setf (rectangle-border-width rectangle)
(read stream))
(setf (rectangle-texture rectangle)
(read stream)))
(defun plot-rectangle (plot left bottom width height &key label (texture *shade-3*)
(border-width 1)
menu no-update-p)
(add-plot-object (make-rectangle left bottom width height :label label :border-width border-width
:texture texture :menu menu)
plot no-update-p))
(defun change-rectangle-border (rectangle plot &optional new-width)
(il:* il:|;;| "Assumes an open plot-window")
(when (null new-width)
(print-plot-prompt "Indicate new border width" plot)
(setq new-width (il:rnumber nil nil nil nil t nil t))
(print-plot-prompt "" plot))
(when new-width
(let ((view-port (plot-view-port plot)))
(erase-plot-object rectangle view-port plot)
(setf (rectangle-border-width rectangle)
new-width)
(draw-plot-object rectangle view-port plot))))
(defun change-rectangle-texture (rectangle plot &optional new-texture)
(when (null new-texture)
(print-plot-prompt "Indicate new texture" plot)
(setq new-texture (pop-up-menu (il:constant (make-texture-menu))))
(print-plot-prompt "" plot))
(when new-texture
(let ((view-port (plot-view-port plot)))
(erase-plot-object rectangle view-port plot)
(setf (rectangle-texture rectangle)
new-texture)
(draw-plot-object rectangle view-port plot))))
(il:* il:|;;| "Text")
(define-plot-object text :instance-vars (position stream-position string font)
:methods (:label-fn plot-object-error))
(defun make-text (position string &key (font *small-plot-font*)
menu)
(%make-text :menu menu :position position :string (string string)
:font font))
(defun draw-text (text-object view-port plot)
(let* ((stream (vp-parent-stream view-port))
(position (text-position text-object))
(stream-x (world-to-stream-x (position-x position)
view-port))
(stream-y (world-to-stream-y (position-y position)
view-port))
(stream-font (stream-font stream)))
(setf (stream-font stream)
(text-font text-object))
(stream-move-to stream-x stream-y stream)
(clipped-princ (text-string text-object)
stream
(vp-stream-subregion view-port))
(setf (stream-font stream)
stream-font)
(if (eq stream (window-dsp (plot-window plot)))
(setf (text-stream-position text-object)
(make-position stream-x stream-y)))))
(defun erase-text (text-object view-port plot)
(il:* il:|;;| "ERASE the TEXTOBJECT")
(let* ((stream (vp-parent-stream view-port))
(stream-position (text-stream-position text-object))
(stream-x (position-x stream-position))
(stream-y (position-y stream-position))
(stream-font (stream-font stream)))
(setf (stream-font stream)
(text-font text-object))
(stream-move-to stream-x stream-y stream)
(let ((string-region (string-region (text-string text-object)
stream)))
(clipped-bltshade (stream-texture stream)
stream
(vp-stream-subregion view-port)
:destination-left
(region-left string-region)
:destination-bottom
(region-bottom string-region)
:width
(region-width string-region)
:height
(region-height string-region)
:operation boole-1))
(setf (stream-font stream)
stream-font)))
(defun highlight-text (text-object view-port plot)
(il:* il:|;;| "ERASE the TEXTOBJECT")
(let* ((stream (vp-parent-stream view-port))
(stream-position (text-stream-position text-object))
(stream-x (position-x stream-position))
(stream-y (position-y stream-position))
(stream-font (stream-font stream)))
(setf (stream-font stream)
(text-font text-object))
(stream-move-to stream-x stream-y stream)
(let ((string-region (string-region (text-string text-object)
stream)))
(clipped-bltshade *black-shade* stream (vp-stream-subregion view-port)
:destination-left
(region-left string-region)
:destination-bottom
(region-bottom string-region)
:width
(region-width string-region)
:height
(region-height string-region)
:operation boole-xor))
(setf (stream-font stream)
stream-font)))
(defun extent-of-text (text-object)
(text-position text-object))
(defun distance-to-text (text-object stream-position plot)
(l1-metric (text-stream-position text-object)
stream-position))
(defun move-text (text-object dx dy plot)
(let ((position (text-position text-object)))
(incf (position-x position)
dx)
(incf (position-y position)
dy)))
(defun copy-text (text)
(il:* il:|;;| "Copyfn for CURVE objects")
(let ((new-text (%copy-text text)))
(setf (text-position new-text)
(copy-position (text-position text)))
(setf (text-stream-position new-text)
nil)
(setf (text-string new-text)
(copy-seq (text-string text)))
new-text))
(defun put-text (text stream)
(prin1 (text-position text)
stream)
(write-char #\Space stream)
(prin1 (text-string text)
stream)
(write-char #\Space stream)
(print-font (text-font text)
stream))
(defun get-text (text stream)
(setf (text-position text)
(read stream))
(setf (text-string text)
(read stream))
(setf (text-font text)
(read-font stream)))
(defun plot-text (plot position text &key (font *small-plot-font*)
menu no-update-p)
(add-plot-object (make-text position text :font font :menu menu)
plot no-update-p))
(il:* il:|;;| "Compound objects")
(define-plot-object compound :instance-vars (components)
:methods (:label-fn label-generic))
(defun make-compound (components &key label menu)
(if (null components)
(error "A compound must have at least one component"))
(%make-compound :menu menu :label label :components components))
(defun draw-compound (compound view-port plot)
(dolist (object (compound-components compound))
(draw-plot-object object view-port plot)))
(defun erase-compound (compound view-port plot)
(dolist (object (compound-components compound))
(erase-plot-object object view-port plot)))
(defun highlight-compound (compound view-port plot)
(dolist (object (compound-components compound))
(highlight-plot-object object view-port plot)))
(defun extent-of-compound (compound plot)
(plot-objects-extent (compound-components compound)
plot))
(defun distance-to-compound (compound stream-position plot)
(let* ((components (compound-components compound))
(min (distance-to-plot-object (car components)
stream-position plot)))
(dolist (part (cdr components)
min)
(let ((new-min (distance-to-plot-object part stream-position plot)))
(if (< new-min min)
(setq min new-min))))))
(defun move-compound (compound dx dy plot)
(dolist (object (compound-components compound))
(move-plot-object object dx dy plot)))
(defun copy-compound (compound)
(il:* il:|;;| "Copyfn for CURVE objects")
(let ((new-compound (%copy-compound compound)))
(setf (compound-components new-compound)
(mapcar #'(lambda (object)
(copy-plot-object object))
(compound-components compound)))
new-compound))
(defun put-compound (compound stream)
(prin1 (length (compound-components compound))
stream)
(write-char #\Space stream)
(dolist (object (compound-components compound))
(print-plot-object object stream)
(write-char #\Space stream)))
(defun get-compound (compound stream)
(let ((n-objects (read stream)))
(setf (compound-components compound)
(pt:with-collection (dotimes (i n-objects)
(pt:collect (read-plot-object stream)))))))
(defun plot-compound (plot &rest args)
(let* ((first-keyword-arg (position-if #'(lambda (x)
(member x '(:label :menu :no-update-p)))
args))
(components (subseq args 0 (or first-keyword-arg (length args))))
(label (cdr (member :label args)))
(menu (cdr (member :menu args)))
(no-update-p (cdr (member :no-update-p args))))
(add-plot-object (make-compound components :label label :menu menu)
plot no-update-p)))
(il:* il:|;;| "Analytic lines")
(define-plot-object line :instance-vars (slope constant infinite-slope-p style stream-slope
stream-constant stream-position-1
stream-position-2)
:methods (:draw-fn draw-analytic-line :erase-fn erase-analytic-line :label-fn label-generic
:move-fn plot-object-error)
:menu-items (("Width" change-line-width "Change width")
("Dashing" change-line-dashing "Change dashing")))
(defun make-line (slope constant &key extent-fn label (style (make-line-style))
menu)
(il:* il:|;;| "Create a line plot object")
(%make-line :menu menu :label label :slope (or slope 0.0)
:constant constant :infinite-slope-p (null slope)
:style
(if (integerp style)
(make-line-style :width style)
style)
:prop-list
(if extent-fn (list :extent-fn extent-fn))))
(defun draw-analytic-line (line view-port plot)
(let* ((stream (vp-parent-stream view-port))
(stream-subregion (vp-stream-subregion view-port))
(style (line-style line))
(linewidth (* (stream-scale stream)
(style-width style)))
(infinite-slope-p (line-infinite-slope-p line))
(slope (line-slope line))
(constant (line-constant line))
(x1 (if infinite-slope-p
constant
(plot-x-lower plot)))
(y1 (if infinite-slope-p
(plot-y-lower plot)
(+ constant (* slope x1))))
(x2 (if infinite-slope-p
constant
(plot-x-upper plot)))
(y2 (if infinite-slope-p
(plot-y-upper plot)
(+ constant (* slope x2))))
(stream-position-1 (make-position (world-to-stream-x x1 view-port)
(world-to-stream-y y1 view-port)))
(stream-position-2 (make-position (world-to-stream-x x2 view-port)
(world-to-stream-y y2 view-port)))
(stream-slope (unless infinite-slope-p
(* slope (/ (lt-m (vp-world-to-stream-y view-port))
(lt-m (vp-world-to-stream-x view-port))))))
(stream-constant (if infinite-slope-p
(world-to-stream-x constant view-port)
(- (world-to-stream-y constant view-port)
(* stream-slope (lt-a (vp-world-to-stream-x view-port)))))))
(clipped-draw-between stream-position-1 stream-position-2 stream stream-subregion :width
linewidth :operation boole-1 :color (style-color style)
:dashing
(style-dashing style))
(when (eq stream (window-dsp (plot-window plot)))
(setf (line-stream-slope line)
stream-slope)
(setf (line-stream-constant line)
stream-constant)
(setf (line-stream-position-1 line)
stream-position-1)
(setf (line-stream-position-2 line)
stream-position-2))))
(defun erase-analytic-line (line view-port plot)
(let* ((stream (vp-parent-stream view-port))
(stream-subregion (vp-stream-subregion view-port))
(style (line-style line))
(linewidth (* (stream-scale stream)
(+ 2 (style-width style))))
(stream-position-1 (line-stream-position-1 line))
(stream-position-2 (line-stream-position-2 line)))
(clipped-draw-between stream-position-1 stream-position-2 stream stream-subregion :width
linewidth :operation boole-andc1 :color (style-color style)
:dashing
(style-dashing style))))
(defun highlight-line (line view-port plot)
(let* ((stream (vp-parent-stream view-port))
(stream-subregion (vp-stream-subregion view-port))
(style (line-style line))
(linewidth (* (stream-scale stream)
(+ 2 (style-width style))))
(stream-position-1 (line-stream-position-1 line))
(stream-position-2 (line-stream-position-2 line)))
(clipped-draw-between stream-position-1 stream-position-2 stream stream-subregion :width
linewidth :operation boole-xor :color (style-color style)
:dashing
(style-dashing style))))
(defun distance-to-line (line stream-position plot)
(il:* il:|;;| "Assumes use of the L1 metric")
(let ((x0 (position-x stream-position))
(y0 (position-y stream-position))
(stream-slope (line-stream-slope line))
(stream-constant (line-stream-constant line)))
(truncate (if (line-infinite-slope-p line)
(abs (- x0 stream-constant))
(il:* il:|;;|
"Compute the intersection of the perpendicular going through (x0 , y0) and the line. ")
(let* ((mp (- (/ 1.0 stream-slope)))
(bp (- y0 (* mp x0)))
(xi (/ (- bp stream-constant)
(- stream-slope mp)))
(yi (+ (* mp xi)
bp)))
(l1-metric-xy stream-position xi yi))))))
(defun copy-line (line)
(il:* il:|;;| "Copyfn for CURVE objects")
(let ((new-line (%copy-line line)))
(setf (line-style new-line)
(copy-line-style (line-style line)))
(setf (line-stream-slope new-line)
nil)
(setf (line-stream-constant new-line)
nil)
(setf (line-stream-position-1 new-line)
nil)
(setf (line-stream-position-2 new-line)
nil)
new-line))
(defun extent-of-line (line plot)
(let ((extent-fn (plot-object-prop line :extent-fn)))
(if extent-fn (funcall extent-fn plot))))
(defun put-line (line stream)
(prin1 (line-slope line)
stream)
(write-char #\Space stream)
(prin1 (line-constant line)
stream)
(write-char #\Space stream)
(prin1 (line-infinite-slope-p line)
stream)
(write-char #\Space stream)
(prin1 (line-style line)
stream))
(defun get-line (line stream)
(setf (line-slope line)
(read stream))
(setf (line-constant line)
(read stream))
(setf (line-infinite-slope-p line)
(read stream))
(setf (line-style line)
(read stream)))
(defun plot-line (plot slope constant &key label (style 1)
menu no-update-p)
(add-plot-object (make-line slope constant :label label :style style :menu menu)
plot no-update-p))
(defun change-line-width (line plot &optional new-width)
(change-style-width new-width (line-style line)
line plot))
(defun change-line-dashing (line plot &optional new-dashing)
(change-style-dashing new-dashing (line-style line)
line plot))
(il:* il:|;;| "Graphs")
(define-plot-object graph :instance-vars (fn n-samples style stream-positions)
:methods (:label-fn label-generic :move-fn plot-object-error :put-fn plot-object-error :get-fn
plot-object-error)
:menu-items (("Width" change-graph-width "Change width")
("Dashing" change-graph-dashing "Change dashing")))
(defun make-graph (fn &key (n-samples 100)
extent-fn label (style (make-line-style))
menu)
(%make-graph :menu menu :label label :fn fn :n-samples n-samples :style (if (integerp style)
(make-line-style
:width style)
style)
:prop-list
(if extent-fn (list :extent-fn extent-fn))))
(defun draw-graph (graph view-port plot)
(let* ((stream (vp-parent-stream view-port))
(style (graph-style graph))
(line-width (* (stream-scale stream)
(style-width style)))
(stream-positions (let ((x-upper (plot-x-upper plot))
(x-lower (plot-x-lower plot))
(graph-fn (graph-fn graph))
(n-samples (graph-n-samples graph)))
(let ((inc (/ (- x-upper x-lower)
(1- n-samples)))
(x x-lower))
(pt:with-collection (dotimes (i (1- n-samples))
(pt:collect (make-position
(world-to-stream-x x
view-port)
(world-to-stream-y
(funcall graph-fn x)
view-port)))
(incf x inc))
(pt:collect (make-position (world-to-stream-x x-upper
view-port)
(world-to-stream-y (funcall graph-fn
x-upper)
view-port))))))))
(connect-positions stream-positions stream (vp-stream-subregion view-port)
boole-1 line-width (style-color style)
(style-dashing style))
(if (eq stream (window-dsp (plot-window plot)))
(setf (graph-stream-positions graph)
stream-positions))))
(defun erase-graph (graph view-port plot)
(let* ((stream (vp-parent-stream view-port))
(style (graph-style graph))
(line-width (* (stream-scale stream)
(+ 2 (style-width style)))))
(connect-positions (graph-stream-positions graph)
stream
(vp-stream-subregion view-port)
boole-andc1 line-width (style-color style)
nil)))
(defun highlight-graph (graph view-port plot)
(let* ((stream (vp-parent-stream view-port))
(style (graph-style graph))
(line-width (* (stream-scale stream)
(+ 2 (style-width style)))))
(connect-positions (graph-stream-positions graph)
stream
(vp-stream-subregion view-port)
boole-xor line-width (style-color style)
nil)))
(defun distance-to-graph (graph stream-position plot)
(positions-list-distance (graph-stream-positions graph)
stream-position))
(defun copy-graph (graph)
(il:* il:|;;| "Copyfn for CURVE objects")
(let ((new-graph (%copy-graph graph)))
(setf (graph-style new-graph)
(copy-line-style (graph-style graph)))
(setf (graph-stream-positions new-graph)
nil)
new-graph))
(defun extent-of-graph (graph plot)
(let ((extent-fn (plot-object-prop graph :extent-fn)))
(if extent-fn (funcall extent-fn plot))))
(defun plot-graph (plot fn &optional (n-samples 100)
label
(style 1)
menu no-update-p)
(il:* il:|;;| "User Entry Point. Draw a piecewise linear curve in PLOT. Style is either the line width to use or a list (width dashing color). POSITIONS is a list of positions to be connected.")
(add-plot-object (make-graph fn :n-samples n-samples :style style :label label :menu menu)
plot no-update-p))
(defun change-graph-width (graph plot &optional new-width)
(change-style-width new-width (graph-style graph)
graph plot))
(defun change-graph-dashing (graph plot &optional new-dashing)
(change-style-dashing new-dashing (graph-style graph)
graph plot))
(xcl:define-file-environment "PLOT-OBJECTS" :package "PLOT"
:compiler :compile-file
:readtable "XCL")
(il:putprops il:plot-objects il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop