(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(filecreated " 5-Jun-87 09:29:30" {phylum}<lispusers>lyric>plotobjects1.\;5 51192
|changes| |to:| (fns ploterrorpoints movesampleset distancetosampleset copysampleset
highlighterrorpoint createsampleset plotsampleset drawsamplesetobject
erasesamplesetobject highlightsampleset extentofsampleset putsampleset
getsampleset createerrorpoint ploterrorpoint drawerrorpointobject
eraseerrorpointobject moveerrorpoint extentoferrorpoint
distancetoerrorpoint copyerrorpoint puterrorpoint geterrorpoint)
(vars plotobjects1coms object1opstable)
(records samplesetdata errorpointdata)
|previous| |date:| " 4-Jun-87 15:19:25" {phylum}<lispusers>lyric>plotobjects1.\;1)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(prettycomprint plotobjects1coms)
(rpaqq plotobjects1coms ((fns createerrorpoint ploterrorpoint ploterrorpoints drawerrorpointobject
eraseerrorpointobject highlighterrorpoint moveerrorpoint
extentoferrorpoint distancetoerrorpoint copyerrorpoint puterrorpoint
geterrorpoint)
(fns createsampleset plotsampleset drawsamplesetobject erasesamplesetobject
highlightsampleset movesampleset extentofsampleset distancetosampleset
copysampleset putsampleset getsampleset)
(vars object1opstable)
(records errorpointdata samplesetdata)
(* |;;;| "initialization")
(p (plot.setup object1opstable))))
(defineq
(createerrorpoint
(lambda (position-range label symbol style menu) (* \; "Edited 4-Jun-87 15:27 by thh:")
(* |;;| "Create a errorpoint plot object")
(* |;;| "POSITION-RANGE is of the form (POSITION XRANGE YRANGE) where a range is either (negShift . posShift) or a nonnegative number n which is equivalent to (n . n), or NIL")
(cond
((null symbol)
(setq symbol star)))
(let ((position (car position-range))
(x (cadr position-range))
(y (caddr position-range)))
(createplotobject errorpointfns 'errorpoint label menu
(|create| errorpointdata
pointposition ← position
symbol ← symbol
style ← (cond
((fixp style)
(|create| plot.style
linewidth ← style))
((listp style)
(|create| plot.style
linewidth ← (car style)
dashing ← (cadr style)
color ← (caddr style)))
(t (|create| plot.style
linewidth ← 1)))
xrange ← (cond
(x (let ((c (|fetch| (position xcoord) |of| position)))
(cons (difference c (or (numberp x)
(car x)))
(plus c (or (numberp x)
(cdr x))))))
(t (* \; "no range specified")
nil))
yrange ← (cond
(y (let ((c (|fetch| (position ycoord) |of| position)))
(cons (difference c (or (numberp y)
(car y)))
(plus c (or (numberp y)
(cdr y))))))
(t (* \; "no range specified")
nil)))))))
(ploterrorpoint
(lambda (plot position-range label symbol style menu nodrawflg)
(* \; "Edited 4-Jun-87 14:09 by thh:")
(* |;;| "User entry point. Add an errorpoint to the plot.")
(cond
((not (|type?| plot plot))
(help "NOT a PLOT " plot)))
(addplotobject (createerrorpoint position-range label symbol style menu)
plot nodrawflg)))
(ploterrorpoints
(lambda (plot position-ranges labels symbol style menu nodrawflg)
(* \; "Edited 5-Jun-87 09:26 by thh:")
(* |;;| "User entry point. Draw the errorpoints in plot.")
(cond
((not (|type?| plot plot))
(help "NOT a PLOT " plot)))
(prog (extent newscales objects)
(setq extent
(|bind| (minx ← max.float)
(maxx ← min.float)
(miny ← max.float)
(maxy ← min.float) |for| pt |in| position-ranges |bind| p v range
|do| (setq p (car pt))
(* |;;| "check x coords")
(setq range (cadr pt))
(setq v (difference (|fetch| xcoord |of| p)
(or (numberp range)
(car range)
0)))
(cond
((lessp v minx)
(setq minx v)))
(setq v (plus (|fetch| xcoord |of| p)
(or (numberp range)
(cdr range)
0)))
(cond
((greaterp v maxx)
(setq maxx v)))
(* |;;| "check y coords")
(setq range (caddr pt))
(setq v (difference (|fetch| ycoord |of| p)
(or (numberp range)
(car range)
0)))
(cond
((lessp v miny)
(setq miny v)))
(setq v (plus (|fetch| ycoord |of| p)
(or (numberp range)
(cdr range)
0)))
(cond
((greaterp v maxy)
(setq maxy v)))
|finally| (return (|create| extent
minx ← minx
maxx ← maxx
miny ← miny
maxy ← maxy))))
(adjustscale? extent plot) (* \;
"Scale up the plot so that each ADDPLOTOBJECT need not rescale")
(setq objects (|bind| (label ← labels) |for| position-range |in| position-ranges
|collect| (prog1 (createerrorpoint position-range (car label)
symbol style menu)
(setq label (cdr label))
(* \;
"note that LABELS can be a shorter list than POSITION-RANGES")
)))
(* |;;| "Add the objects to the display list of the plot")
(|replace| (plot plotobjects) |of| plot |with| (append objects (|fetch| (plot plotobjects)
|of| plot)))
(cond
((null nodrawflg)
(redrawplotwindow plot)))
(return objects))))
(drawerrorpointobject
(lambda (errorpoint viewport plot) (* \; "Edited 4-Jun-87 10:15 by thh:")
(* |;;| "Draw a glyph at point and error bars.")
(let* ((stream (|fetch| (viewport parentstream) |of| viewport))
(streamsubregion (|fetch| (viewport streamsubregion) |of| viewport))
(objectdata (|fetch| (plotobject objectdata) |of| errorpoint))
(symbol (|fetch| (errorpointdata symbol) |of| objectdata))
(style (|fetch| (errorpointdata style) |of| objectdata))
(linewidth (times (dspscale nil stream)
(|fetch| (plot.style linewidth) |of| style)))
(dashing (|fetch| (plot.style dashing) |of| style))
(color (|fetch| (plot.style color) |of| style))
(pt (|fetch| (errorpointdata pointposition) |of| objectdata))
(xrange (|fetch| (errorpointdata xrange) |of| objectdata))
(yrange (|fetch| (errorpointdata yrange) |of| objectdata))
(streampt (worldtostream pt viewport))
sxmin sxmax symin symax)
(clipped.plotat streamsubregion streampt symbol stream)
(cond
(xrange (* \; "draw horizontal bar")
(setq sxmin (worldtostreamx (car xrange)
viewport))
(setq sxmax (worldtostreamx (cdr xrange)
viewport))
(clipped.drawline streamsubregion sxmin (|fetch| (position ycoord) |of| streampt)
sxmax
(|fetch| (position ycoord) |of| streampt)
linewidth
'replace stream color dashing)))
(cond
(yrange (* \; "draw vertical bar")
(setq symin (worldtostreamy (car yrange)
viewport))
(setq symax (worldtostreamy (cdr yrange)
viewport))
(clipped.drawline streamsubregion (|fetch| (position xcoord) |of| streampt)
symin
(|fetch| (position xcoord) |of| streampt)
symax linewidth 'replace stream color dashing)))
(* |;;| "")
(* |;;| "cache stream coords if this is drawn in the plotwindow")
(cond
((eq stream (windowprop (|fetch| (plot plotwindow) |of| plot)
'dsp))
(|replace| (errorpointdata streamposition) |of| objectdata |with| streampt)
(cond
(xrange (|replace| (errorpointdata xstreamrange) |of| objectdata
|with| (cons sxmin sxmax))))
(cond
(yrange (|replace| (errorpointdata ystreamrange) |of| objectdata
|with| (cons symin symax)))))))))
(eraseerrorpointobject
(lambda (errorpoint viewport plot) (* \; "Edited 4-Jun-87 10:20 by thh:")
(* |;;| "Erase errorpoint object using cached stream coords.")
(let* ((stream (|fetch| (viewport parentstream) |of| viewport))
(streamsubregion (|fetch| (viewport streamsubregion) |of| viewport))
(objectdata (|fetch| (plotobject objectdata) |of| errorpoint))
(symbol (|fetch| (errorpointdata symbol) |of| objectdata))
(style (|fetch| (errorpointdata style) |of| objectdata))
(linewidth (times (dspscale nil stream)
(|fetch| (plot.style linewidth) |of| style)))
(color (|fetch| (plot.style color) |of| style))
(streampt (|fetch| (errorpointdata streamposition) |of| objectdata))
(xstreamrange (|fetch| (errorpointdata xstreamrange) |of| objectdata))
(ystreamrange (|fetch| (errorpointdata ystreamrange) |of| objectdata)))
(clipped.plotat streamsubregion streampt symbol stream 'erase)
(cond
(xstreamrange (* \; "erase horizontal bar")
(clipped.drawline streamsubregion (car xstreamrange)
(|fetch| (position ycoord) |of| streampt)
(cdr xstreamrange)
(|fetch| (position ycoord) |of| streampt)
linewidth
'erase stream color)))
(cond
(ystreamrange (* \; "erase vertical bar")
(clipped.drawline streamsubregion (|fetch| (position xcoord) |of| streampt)
(car ystreamrange)
(|fetch| (position xcoord) |of| streampt)
(cdr ystreamrange)
linewidth
'erase stream color))))))
(highlighterrorpoint
(lambda (errorpoint viewport plot) (* \; "Edited 4-Jun-87 16:42 by thh:")
(let* ((stream (|fetch| (viewport parentstream) |of| viewport))
(streamsubregion (|fetch| (viewport streamsubregion) |of| viewport))
(objectdata (|fetch| (plotobject objectdata) |of| errorpoint))
(symbol (|fetch| (errorpointdata symbol) |of| objectdata))
(style (|fetch| (errorpointdata style) |of| objectdata))
(linewidth (iplus 2 (|fetch| (plot.style linewidth) |of| style))
(* \; "this is called on display streams only -- extra line width so inversion will be visible against white background")
)
(color (|fetch| (plot.style color) |of| style))
(streampt (|fetch| (errorpointdata streamposition) |of| objectdata))
(xsrange (|fetch| (errorpointdata xstreamrange) |of| objectdata))
(ysrange (|fetch| (errorpointdata ystreamrange) |of| objectdata))
(widthglyph (bitmapwidth symbol))
(heightglyph (bitmapheight symbol))
(offsetx (idifference (|fetch| xcoord |of| streampt)
(iquotient widthglyph 2)))
(offsety (idifference (|fetch| ycoord |of| streampt)
(iquotient heightglyph 2))))
(clipped.bitblt streamsubregion nil nil nil stream offsetx offsety widthglyph heightglyph
'texture
'invert blackshade)
(* |;;| "invert the error bars")
(cond
(xsrange (* \; "draw horizontal bar")
(clipped.drawline streamsubregion (car xsrange)
(|fetch| (position ycoord) |of| streampt)
(cdr xsrange)
(|fetch| (position ycoord) |of| streampt)
linewidth
'invert stream color)))
(cond
(ysrange (* \; "draw vertical bar")
(clipped.drawline streamsubregion (|fetch| (position xcoord) |of| streampt)
(car ysrange)
(|fetch| (position xcoord) |of| streampt)
(cdr ysrange)
linewidth
'invert stream color))))))
(moveerrorpoint
(lambda (errorpoint dx dy plot) (* \; "Edited 4-Jun-87 13:41 by thh:")
(let* ((objectdata (|fetch| (plotobject objectdata) |of| errorpoint))
(position (|fetch| (errorpointdata pointposition) |of| objectdata))
(xrange (|fetch| (errorpointdata xrange) |of| objectdata))
(yrange (|fetch| (errorpointdata yrange) |of| objectdata)))
(|replace| xcoord |of| position |with| (plus dx (|fetch| xcoord |of| position)))
(|replace| ycoord |of| position |with| (plus dy (|fetch| ycoord |of| position)))
(|if| xrange
|then| (|replace| (errorpointdata xrange) |of| objectdata
|with| (cons (plus dx (car xrange))
(plus dx (cdr xrange)))))
(|if| yrange
|then| (|replace| (errorpointdata yrange) |of| objectdata
|with| (cons (plus dy (car yrange))
(plus dy (cdr yrange))))))))
(extentoferrorpoint
(lambda (errorpoint) (* \; "Edited 4-Jun-87 15:13 by thh:")
(let* ((objectdata (|fetch| (plotobject objectdata) |of| errorpoint))
(pt (|fetch| (errorpointdata pointposition) |of| objectdata))
(xrange (|fetch| (errorpointdata xrange) |of| objectdata))
(yrange (|fetch| (errorpointdata yrange) |of| objectdata)))
(|create| extent
minx ← (or (car xrange)
(|fetch| (position xcoord) |of| pt))
maxx ← (or (cdr xrange)
(|fetch| (position xcoord) |of| pt))
miny ← (or (car yrange)
(|fetch| (position ycoord) |of| pt))
maxy ← (or (cdr yrange)
(|fetch| (position ycoord) |of| pt))))))
(distancetoerrorpoint
(lambda (errorpoint streamposition plot) (* \; "Edited 4-Jun-87 13:49 by thh:")
(* |;;| "distance is to central point")
(l1metric (|fetch| (errorpointdata streamposition) |of| (|fetch| (plotobject objectdata)
|of| errorpoint))
streamposition)))
(copyerrorpoint
(lambda (plotobject plot) (* \; "Edited 4-Jun-87 13:54 by thh:")
(* |;;| " Copyfn for ERRORPOINT objects")
(let ((objectdata (|fetch| (plotobject objectdata) |of| plotobject)))
(|create| errorpointdata
pointposition ← (copyall (|fetch| (errorpointdata pointposition) |of| objectdata))
symbol ← (|fetch| (errorpointdata symbol) |of| objectdata)
style ← (copyall (|fetch| (errorpointdata style) |of| objectdata))
xrange ← (copyall (|fetch| (errorpointdata xrange) |of| objectdata))
yrange ← (copyall (|fetch| (errorpointdata yrange) |of| objectdata))))))
(puterrorpoint
(lambda (plotobject plot stream) (* \; "Edited 4-Jun-87 14:01 by thh:")
(* |;;| "Putfn for ERRORPOINT objects")
(prog ((objectdata (|fetch| (plotobject objectdata) |of| plotobject))
symbol lab style)
(setq symbol (|fetch| (errorpointdata symbol) |of| objectdata))
(setq style (|fetch| (errorpointdata style) |of| objectdata))
(setq lab (cond
((eq symbol star)
'star)
((eq symbol cross)
'cross)
((eq symbol circle)
'circle)))
(printout stream "(" \, "POINTPOSITION" \, |.P2| (|fetch| (errorpointdata pointposition)
|of| objectdata)
\, "XRANGE" \, |.P2| (|fetch| (errorpointdata xrange) |of| objectdata)
\, "YRANGE" \, |.P2| (|fetch| (errorpointdata yrange) |of| objectdata)
\, "SYMBOL" \,)
(cond
(lab (printout stream |.P2| lab \,))
(t (hprint symbol stream t t)))
(printout stream \, "STYLE" \, |.P2| (list (|fetch| (plot.style linewidth) |of| style)
(|fetch| (plot.style dashing) |of| style)
(|fetch| (plot.style color) |of| style))
\, ")"))))
(geterrorpoint
(lambda (proplst) (* \; "Edited 4-Jun-87 14:07 by thh:")
(* |;;| " Getfn for ERRORPOINT objects.")
(|create| errorpointdata
pointposition ← (listget proplst 'pointposition)
symbol ← (let ((symbol (listget proplst 'symbol)))
(cond
((litatom symbol)
(eval symbol))
(t symbol)))
xrange ← (listget proplst 'xrange)
yrange ← (listget proplst 'yrange)
style ← (let ((stylelst (listget proplst 'style)))
(|create| plot.style
linewidth ← (car stylelst)
dashing ← (cadr stylelst)
color ← (caddr stylelst))))))
)
(defineq
(createsampleset
(lambda (positions constant vertical? side label style menu)
(* \; "Edited 4-Jun-87 17:45 by thh:")
(* |;;| "Create a sample plot object")
(createplotobject samplesetfns 'sampleset label menu
(|create| samplesetdata
samplepoints ← positions
style ← (cond
((fixp style)
(|create| plot.style
linewidth ← style))
((listp style)
(|create| plot.style
linewidth ← (car style)
dashing ← (cadr style)
color ← (caddr style)))
(t (|create| plot.style
linewidth ← 1)))
constant ← constant
vertical? ← vertical?
side ← side))))
(plotsampleset
(lambda (plot positions constant vertical? side label style menu)
(* \; "Edited 4-Jun-87 17:42 by thh:")
(* |;;| "User Entry Point. Plots samples with line segments to specified constant. SIDE is NIL to plot only values greater than constant, T to plot only those less and otherwise all values are plotted")
(cond
((not (|type?| plot plot))
(help "NOT a PLOT " plot)))
(addplotobject (createsampleset positions constant vertical? side label style menu)
plot)))
(drawsamplesetobject
(lambda (sampleset viewport plot) (* \; "Edited 4-Jun-87 16:37 by thh:")
(* |;;| "Draw line segments from positions to constant value.")
(let* ((stream (|fetch| (viewport parentstream) |of| viewport))
(streamsubregion (|fetch| (viewport streamsubregion) |of| viewport))
(objectdata (|fetch| (plotobject objectdata) |of| sampleset))
(style (|fetch| (samplesetdata style) |of| objectdata))
(linewidth (times (dspscale nil stream)
(|fetch| (plot.style linewidth) |of| style)))
(dashing (|fetch| (plot.style dashing) |of| style))
(color (|fetch| (plot.style color) |of| style))
(points (|fetch| (samplesetdata samplepoints) |of| objectdata))
(streampoints (|for| pt |in| points |collect| (worldtostream pt viewport)))
(constant (|fetch| (samplesetdata constant) |of| objectdata))
(vertical? (|fetch| (samplesetdata vertical?) |of| objectdata))
(streamconstant (cond
(vertical? (worldtostreamx constant viewport))
(t (worldtostreamy constant viewport))))
(side (|fetch| (samplesetdata side) |of| objectdata)))
(cond
(vertical? (|for| pt |in| streampoints |when| (cond
((null side)
(* \; "plot values > constant")
(greaterp (|fetch| (position xcoord)
|of| pt)
streamconstant))
((eq side t)
(* \; "plot values < constant")
(lessp (|fetch| (position xcoord)
|of| pt)
streamconstant))
(t
(* \; "plot all values")
t))
|do| (clipped.drawline streamsubregion (|fetch| (position xcoord)
|of| pt)
(|fetch| (position ycoord) |of| pt)
streamconstant
(|fetch| (position ycoord) |of| pt)
linewidth
'replace stream color dashing)))
(t (|for| pt |in| streampoints |when| (cond
((null side)
(* \; "plot values > constant")
(greaterp (|fetch| (position ycoord)
|of| pt)
streamconstant))
((eq side t)
(* \; "plot values < constant")
(lessp (|fetch| (position ycoord) |of| pt)
streamconstant))
(t (* \; "plot all values")
t)) |do| (clipped.drawline
streamsubregion
(|fetch| (position xcoord)
|of| pt)
(|fetch| (position ycoord)
|of| pt)
(|fetch| (position xcoord)
|of| pt)
streamconstant linewidth
'replace stream color dashing))))
(* |;;| "")
(* |;;| "cache stream coords if this is drawn in the plotwindow")
(cond
((eq stream (windowprop (|fetch| (plot plotwindow) |of| plot)
'dsp))
(|replace| (samplesetdata streampoints) |of| objectdata |with| streampoints)
(|replace| (samplesetdata streamconstant) |of| objectdata |with| streamconstant))))))
(erasesamplesetobject
(lambda (sampleset viewport plot) (* \; "Edited 4-Jun-87 16:40 by thh:")
(* |;;| "Erase sampleset using cached stream coords.")
(let* ((stream (|fetch| (viewport parentstream) |of| viewport))
(streamsubregion (|fetch| (viewport streamsubregion) |of| viewport))
(objectdata (|fetch| (plotobject objectdata) |of| sampleset))
(style (|fetch| (samplesetdata style) |of| objectdata))
(linewidth (times (dspscale nil stream)
(|fetch| (plot.style linewidth) |of| style)))
(color (|fetch| (plot.style color) |of| style))
(streampoints (|fetch| (samplesetdata streampoints) |of| objectdata))
(streamconstant (|fetch| (samplesetdata streamconstant) |of| objectdata))
(vertical? (|fetch| (samplesetdata vertical?) |of| objectdata))
(side (|fetch| (samplesetdata side) |of| objectdata)))
(cond
(vertical? (|for| pt |in| streampoints |when| (cond
((null side)
(* \; "plot values > constant")
(greaterp (|fetch| (position xcoord)
|of| pt)
streamconstant))
((eq side t)
(* \; "plot values < constant")
(lessp (|fetch| (position xcoord)
|of| pt)
streamconstant))
(t
(* \; "plot all values")
t))
|do| (clipped.drawline streamsubregion (|fetch| (position xcoord)
|of| pt)
(|fetch| (position ycoord) |of| pt)
streamconstant
(|fetch| (position ycoord) |of| pt)
linewidth
'erase stream color)))
(t (|for| pt |in| streampoints |when| (cond
((null side)
(* \; "plot values > constant")
(greaterp (|fetch| (position ycoord)
|of| pt)
streamconstant))
((eq side t)
(* \; "plot values < constant")
(lessp (|fetch| (position ycoord) |of| pt)
streamconstant))
(t (* \; "plot all values")
t)) |do| (clipped.drawline
streamsubregion
(|fetch| (position xcoord)
|of| pt)
(|fetch| (position ycoord)
|of| pt)
(|fetch| (position xcoord)
|of| pt)
streamconstant linewidth
'erase stream color)))))))
(highlightsampleset
(lambda (sampleset viewport plot) (* \; "Edited 4-Jun-87 16:48 by thh:")
(let* ((stream (|fetch| (viewport parentstream) |of| viewport))
(streamsubregion (|fetch| (viewport streamsubregion) |of| viewport))
(objectdata (|fetch| (plotobject objectdata) |of| sampleset))
(style (|fetch| (samplesetdata style) |of| objectdata))
(linewidth (iplus 2 (|fetch| (plot.style linewidth) |of| style))
(* \; "this is called on display streams only -- extra line width so inversion will be visible against white background")
)
(color (|fetch| (plot.style color) |of| style))
(streampoints (|fetch| (samplesetdata streampoints) |of| objectdata))
(streamconstant (|fetch| (samplesetdata streamconstant) |of| objectdata))
(vertical? (|fetch| (samplesetdata vertical?) |of| objectdata))
(side (|fetch| (samplesetdata side) |of| objectdata)))
(cond
(vertical? (|for| pt |in| streampoints |when| (cond
((null side)
(* \; "plot values > constant")
(greaterp (|fetch| (position xcoord)
|of| pt)
streamconstant))
((eq side t)
(* \; "plot values < constant")
(lessp (|fetch| (position xcoord)
|of| pt)
streamconstant))
(t
(* \; "plot all values")
t))
|do| (clipped.drawline streamsubregion (|fetch| (position xcoord)
|of| pt)
(|fetch| (position ycoord) |of| pt)
streamconstant
(|fetch| (position ycoord) |of| pt)
linewidth
'invert stream color)))
(t (|for| pt |in| streampoints |when| (cond
((null side)
(* \; "plot values > constant")
(greaterp (|fetch| (position ycoord)
|of| pt)
streamconstant))
((eq side t)
(* \; "plot values < constant")
(lessp (|fetch| (position ycoord) |of| pt)
streamconstant))
(t (* \; "plot all values")
t)) |do| (clipped.drawline
streamsubregion
(|fetch| (position xcoord)
|of| pt)
(|fetch| (position ycoord)
|of| pt)
(|fetch| (position xcoord)
|of| pt)
streamconstant linewidth
'invert stream color)))))))
(movesampleset
(lambda (sampleset dx dy plot) (* \; "Edited 5-Jun-87 09:25 by thh:")
(let* ((objectdata (|fetch| (plotobject objectdata) |of| sampleset))
(points (|fetch| (samplesetdata samplepoints) |of| objectdata))
(constant (|fetch| (samplesetdata constant) |of| objectdata))
(vertical? (|fetch| (samplesetdata vertical?) |of| objectdata)))
(|for| point |in| points |do| (|replace| xcoord |of| point
|with| (plus dx (|fetch| xcoord |of| point)))
(|replace| ycoord |of| point
|with| (plus dy (|fetch| ycoord |of| point))))
(cond
(vertical? (|replace| (samplesetdata constant) |of| objectdata |with| (plus dx constant)
))
(t (|replace| (samplesetdata constant) |of| objectdata |with| (plus dy constant)))))))
(extentofsampleset
(lambda (sampleset) (* \; "Edited 4-Jun-87 17:04 by thh:")
(let* ((objectdata (|fetch| (plotobject objectdata) |of| sampleset))
(points (|fetch| (samplesetdata samplepoints) |of| objectdata))
(vertical? (|fetch| (samplesetdata vertical?) |of| objectdata))
(side (|fetch| (samplesetdata side) |of| objectdata)))
(|bind| (minx ← max.float)
(maxx ← min.float)
(miny ← max.float)
(maxy ← min.float)
(constant ← (|fetch| (samplesetdata constant) |of| objectdata))
x y |for| position |in| points
|declare| (type floating minx maxx miny maxy x y constant)
|do| (setq x (|fetch| xcoord |of| position))
(setq y (|fetch| ycoord |of| position))
(cond
((cond
(vertical? (cond
((null side) (* \; "plot values > constant")
(fgreaterp x constant))
((eq side t) (* \; "plot values < constant")
(flessp x constant))
(t (* \; "plot all values")
t)))
(t (cond
((null side) (* \; "plot values > constant")
(fgreaterp y constant))
((eq side t) (* \; "plot values < constant")
(flessp y constant))
(t (* \; "plot all values")
t)))) (* \;
" count this point only if it is actually drawn")
(cond
((flessp x minx)
(setq minx x)))
(cond
((fgreaterp x maxx)
(setq maxx x)))
(cond
((flessp y miny)
(setq miny y)))
(cond
((fgreaterp y maxy)
(setq maxy y)))))
|finally| (cond
(vertical? (setq minx (min minx constant))
(setq maxx (max maxx constant)))
(t (setq miny (min miny constant))
(setq maxy (max maxy constant))))
(return (|create| extent
minx ← minx
maxx ← maxx
miny ← miny
maxy ← maxy))))))
(distancetosampleset
(lambda (sampleset streamposition plot) (* \; "Edited 5-Jun-87 09:24 by thh:")
(* |;;| "distance is to actual points that are plotted")
(let* ((objectdata (|fetch| (plotobject objectdata) |of| sampleset))
(streampoints (|fetch| (samplesetdata streampoints) |of| objectdata))
(streamconstant (|fetch| (samplesetdata streamconstant) |of| objectdata))
(vertical? (|fetch| (samplesetdata vertical?) |of| objectdata))
(side (|fetch| (samplesetdata side) |of| objectdata)))
(l1metric streamposition (|for| pt |in| streampoints
|when| (cond
(vertical? (cond
((null side)
(greaterp (|fetch| (position xcoord)
|of| pt)
streamconstant))
((eq side t)
(lessp (|fetch| (position xcoord)
|of| pt)
streamconstant))
(t
(* \; "plot all points")
t)))
(t (cond
((null side)
(greaterp (|fetch| (position ycoord)
|of| pt)
streamconstant))
((eq side t)
(lessp (|fetch| (position ycoord) |of| pt)
streamconstant))
(t (* \; "plot all points")
t)))) |smallest| (l1metric pt streamposition
))))))
(copysampleset
(lambda (plotobject plot) (* \; "Edited 5-Jun-87 08:45 by thh:")
(* |;;| " Copyfn for SAMPLESET objects")
(let ((objectdata (|fetch| (plotobject objectdata) |of| plotobject)))
(|create| samplesetdata
samplepoints ← (copyall (|fetch| (samplesetdata samplepoints) |of| objectdata))
style ← (copyall (|fetch| (samplesetdata style) |of| objectdata))
constant ← (|fetch| (samplesetdata constant) |of| objectdata)
vertical? ← (|fetch| (samplesetdata vertical?) |of| objectdata)
side ← (|fetch| (samplesetdata side) |of| objectdata)))))
(putsampleset
(lambda (plotobject plot stream) (* \; "Edited 4-Jun-87 17:23 by thh:")
(* |;;| "Putfn for SAMPLESET objects")
(prog ((objectdata (|fetch| (plotobject objectdata) |of| plotobject))
style)
(setq style (|fetch| (samplesetdata style) |of| objectdata))
(printout stream "(" \, "SAMPLEPOINTS" \, |.P2| (|fetch| (samplesetdata samplepoints)
|of| objectdata)
\, "CONSTANT" \, |.P2| (|fetch| (samplesetdata constant) |of| objectdata)
\, "VERTICAL?" \, |.P2| (|fetch| (samplesetdata vertical?) |of| objectdata)
\, "SIDE" \, |.P2| (|fetch| (samplesetdata side) |of| objectdata)
\,)
(printout stream "STYLE" \, |.P2| (list (|fetch| (plot.style linewidth) |of| style)
(|fetch| (plot.style dashing) |of| style)
(|fetch| (plot.style color) |of| style))
\, ")"))))
(getsampleset
(lambda (proplst) (* \; "Edited 4-Jun-87 17:27 by thh:")
(* |;;| " Getfn for SAMPLESET objects.")
(|create| samplesetdata
samplepoints ← (listget proplst 'samplepoints)
constant ← (listget proplst 'constant)
vertical? ← (listget proplst 'vertical?)
side ← (listget proplst 'side)
style ← (let ((stylelst (listget proplst 'style)))
(|create| plot.style
linewidth ← (car stylelst)
dashing ← (cadr stylelst)
color ← (caddr stylelst))))))
)
(rpaqq object1opstable ((errorpoint (drawfn drawerrorpointobject)
(erasefn eraseerrorpointobject)
(highlightfn highlighterrorpoint)
(movefn moveerrorpoint)
(labelfn labelgeneric)
(extentfn extentoferrorpoint)
(distancefn distancetoerrorpoint)
(copyfn copyerrorpoint)
(putfn puterrorpoint)
(getfn geterrorpoint))
(sampleset (drawfn drawsamplesetobject)
(erasefn erasesamplesetobject)
(highlightfn highlightsampleset)
(movefn movesampleset)
(labelfn labelgeneric)
(extentfn extentofsampleset)
(distancefn distancetosampleset)
(copyfn copysampleset)
(putfn putsampleset)
(getfn getsampleset))))
(declare\: eval@compile
(datatype errorpointdata
(* |;;| "range is of the form (minValue . maxValue)")
(pointposition streamposition symbol style xrange yrange xstreamrange
ystreamrange)
symbol ← star)
(datatype samplesetdata (samplepoints streampoints style (constant floating)
(streamconstant floating)
(vertical? flag (* \;
"non-NIL if bound is a vertical line (i.e. segments are to be drawn horizontally) ")
)
side))
)
(/declaredatatype 'errorpointdata '(pointer pointer pointer pointer pointer pointer pointer pointer)
'((errorpointdata 0 pointer)
(errorpointdata 2 pointer)
(errorpointdata 4 pointer)
(errorpointdata 6 pointer)
(errorpointdata 8 pointer)
(errorpointdata 10 pointer)
(errorpointdata 12 pointer)
(errorpointdata 14 pointer))
'16)
(/declaredatatype 'samplesetdata '(pointer pointer pointer floatp floatp flag pointer)
'((samplesetdata 0 pointer)
(samplesetdata 2 pointer)
(samplesetdata 4 pointer)
(samplesetdata 6 floatp)
(samplesetdata 8 floatp)
(samplesetdata 4 (flagbits . 0))
(samplesetdata 10 pointer))
'12)
(* |;;;| "initialization")
(plot.setup object1opstable)
(putprops plotobjects1 copyright ("Xerox Corporation" 1987))
(declare\: dontcopy
(filemap (nil (1874 22301 (createerrorpoint 1884 . 4455) (ploterrorpoint 4457 . 4931) (ploterrorpoints
4933 . 8495) (drawerrorpointobject 8497 . 11754) (eraseerrorpointobject 11756 . 13868) (
highlighterrorpoint 13870 . 16514) (moveerrorpoint 16516 . 17672) (extentoferrorpoint 17674 . 18618) (
distancetoerrorpoint 18620 . 19039) (copyerrorpoint 19041 . 19828) (puterrorpoint 19830 . 21406) (
geterrorpoint 21408 . 22299)) (22302 48432 (createsampleset 22312 . 23401) (plotsampleset 23403 .
24022) (drawsamplesetobject 24024 . 29503) (erasesamplesetobject 29505 . 34144) (highlightsampleset
34146 . 38863) (movesampleset 38865 . 39967) (extentofsampleset 39969 . 43077) (distancetosampleset
43079 . 45754) (copysampleset 45756 . 46519) (putsampleset 46521 . 47714) (getsampleset 47716 . 48430)
))))
stop