(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(filecreated "30-Jun-88 16:35:35" {erinyes}<lispusers>lyric>plotobjects1.\;1 52951
|changes| |to:| (vars plotobjects1coms)
(fns log-error-bar make-position-range log-error-range-list log-error-range)
|previous| |date:| " 5-Jun-87 09:29:30" {phylum}<lisp>lyric>lispusers>plotobjects1.\;1)
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
(prettycomprint plotobjects1coms)
(rpaqq plotobjects1coms
(
(* |;;;| "errorpoint functions")
(fns createerrorpoint ploterrorpoint ploterrorpoints drawerrorpointobject
eraseerrorpointobject highlighterrorpoint moveerrorpoint extentoferrorpoint
distancetoerrorpoint copyerrorpoint puterrorpoint geterrorpoint)
(fns log-error-bar log-error-range log-error-range-list make-position-range)
(* |;;;| "sample set functions")
(fns createsampleset plotsampleset drawsamplesetobject erasesamplesetobject
highlightsampleset movesampleset extentofsampleset distancetosampleset copysampleset
putsampleset getsampleset)
(vars object1opstable)
(records errorpointdata samplesetdata)
(* |;;;| "initialization")
(p (plot.setup object1opstable))))
(* |;;;| "errorpoint functions")
(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
(log-error-bar
(lambda (p range base) (* \; "Edited 30-Jun-88 16:22 by thh:")
(cl:assert (cl:plusp p)
(p)
"Position ~G must be positive to take log." p)
(cl:if (null range)
nil
(let (plus minus)
(cond
((numberp range)
(setq minus range)
(setq plus range))
(t (setq minus (car range))
(setq plus (cdr range))))
(cl:assert (cl:plusp (- 1 (/ minus p)))
(minus)
"Error bar of length ~G from point ~G gives negative value: can't take log."
minus p)
(cons (abs (cl:log (- 1 (/ minus p))
base))
(cl:log (+ 1 (/ plus p))
base))))))
(log-error-range
(lambda (position-range axis base) (* \; "Edited 30-Jun-88 16:24 by thh:")
(* |;;;| "converts POSITION-RANGE to log scale: AXIS specifies which axis to convert (:X, :Y or NIL for both)")
(or base (setq base 10))
(let ((position (car position-range))
(xrange (cadr position-range))
(yrange (caddr position-range))
x y)
(setq x (|fetch| (position xcoord) |of| position))
(setq y (|fetch| (position ycoord) |of| position))
(cl:unless (eq axis :y) (* \; "convert the x-coord")
(setq xrange (log-error-bar x xrange base))
(setq x (cl:log x base)))
(cl:unless (eq axis :x) (* \; "convert the y-coord")
(setq yrange (log-error-bar y yrange base))
(setq y (cl:log y base)))
(make-position-range (|create| position
xcoord ← x
ycoord ← y)
xrange yrange))))
(log-error-range-list
(lambda (position-ranges axis base) (* \; "Edited 30-Jun-88 16:05 by thh:")
(|for| p |in| position-ranges |collect| (log-error-range p axis base))))
(make-position-range
(lambda (position xrange yrange) (* \; "Edited 30-Jun-88 15:54 by thh:")
(list position xrange yrange)))
)
(* |;;;| "sample set functions")
(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 1988))
(declare\: dontcopy
(filemap (nil (1388 21815 (createerrorpoint 1398 . 3969) (ploterrorpoint 3971 . 4445) (ploterrorpoints
4447 . 8009) (drawerrorpointobject 8011 . 11268) (eraseerrorpointobject 11270 . 13382) (
highlighterrorpoint 13384 . 16028) (moveerrorpoint 16030 . 17186) (extentoferrorpoint 17188 . 18132) (
distancetoerrorpoint 18134 . 18553) (copyerrorpoint 18555 . 19342) (puterrorpoint 19344 . 20920) (
geterrorpoint 20922 . 21813)) (21816 24266 (log-error-bar 21826 . 22734) (log-error-range 22736 .
23864) (log-error-range-list 23866 . 24093) (make-position-range 24095 . 24264)) (24308 50438 (
createsampleset 24318 . 25407) (plotsampleset 25409 . 26028) (drawsamplesetobject 26030 . 31509) (
erasesamplesetobject 31511 . 36150) (highlightsampleset 36152 . 40869) (movesampleset 40871 . 41973) (
extentofsampleset 41975 . 45083) (distancetosampleset 45085 . 47760) (copysampleset 47762 . 48525) (
putsampleset 48527 . 49720) (getsampleset 49722 . 50436)))))
stop