(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(filecreated " 7-Oct-88 12:26:27" {indigo}<gslws>lyric>library>plotobjects2.\;6 23088
|changes| |to:| (fns clipped.fillpolygon clipped.polygon finish-clip-polygon
clip-polygon-vertex clip-insidep clip-intersect getfilledpolygon
drawfilledpolygon createfilledpolygon distancetofilledpolygon
erasefilledpolygon extentoffilledpolygon highlightfilledpolygon
plotfilledpolygon clipped.findto clipped.findline copyfilledpolygon
movefilledpolygon putfilledpolygon)
(vars plotobjects2coms)
(records clipedgeinfo filledpolygondata)
|previous| |date:| " 5-Oct-88 11:21:10" {indigo}<gslws>lyric>library>plotobjects2.\;1)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(prettycomprint plotobjects2coms)
(rpaqq plotobjects2coms
((fns copyfilledpolygon createfilledpolygon distancetofilledpolygon drawfilledpolygon
erasefilledpolygon extentoffilledpolygon getfilledpolygon highlightfilledpolygon
movefilledpolygon plotfilledpolygon putfilledpolygon)
(vars object2opstable)
(records filledpolygondata)
(p (plot.setup object2opstable))
(fns clipped.fillpolygon clipped.polygon clip-polygon-vertex finish-clip-polygon clip-insidep
clip-intersect)
(records clipedgeinfo)))
(defineq
(copyfilledpolygon
(lambda (plotobject plot) (* \; "Edited 5-Oct-88 10:23 by thh:")
(* |;;| "Copyfn for FILLEDPOLYGON objects")
(let ((objectdata (fetch (plotobject objectdata) of plotobject)))
(create filledpolygondata
polygonpoints ← (copyall (fetch (filledpolygondata polygonpoints) of objectdata))
style ← (copyall (fetch (filledpolygondata style) of objectdata))
texture ← (fetch (filledpolygondata texture) of objectdata)))))
(createfilledpolygon
(lambda (positions label style texture menu) (* \; "Edited 5-Oct-88 12:49 by thh:")
(createplotobject filledpolygonfns 'filledpolygon label menu
(|create| filledpolygondata
polygonpoints ← 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)))
texture ← texture))))
(distancetofilledpolygon
(lambda (filledpolygon streamposition plot) (* \; "Edited 5-Oct-88 10:32 by thh:")
(l1metric streamposition (|for| point |in| (|fetch| (filledpolygondata streampoints)
|of| (|fetch| objectdata |of| filledpolygon))
|smallest| (l1metric point streamposition)))))
(drawfilledpolygon
(lambda (filledpolygon viewport plot) (* \; "Edited 5-Oct-88 13:05 by thh:")
(let* ((stream (|fetch| (viewport parentstream) |of| viewport))
(streamsubregion (|fetch| (viewport streamsubregion) |of| viewport))
(objectdata (|fetch| (plotobject objectdata) |of| filledpolygon))
(points (|fetch| (filledpolygondata polygonpoints) |of| objectdata))
(streampoints (|for| pt |in| points |collect| (worldtostream pt viewport)))
(style (|fetch| (filledpolygondata 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)))
(clipped.fillpolygon streamsubregion streampoints (|fetch| (filledpolygondata texture)
|of| objectdata)
stream
'replace nil (< 0 linewidth)
linewidth
'replace color dashing)
(cond
((eq stream (windowprop (|fetch| (plot plotwindow) |of| plot)
'dsp))
(|replace| (filledpolygondata streampoints) |of| objectdata |with| streampoints))))))
(erasefilledpolygon
(lambda (filledpolygon viewport plot) (* \; "Edited 5-Oct-88 13:05 by thh:")
(* |;;| "Erase a FILLEDPOLYGONDATA")
(let* ((stream (|fetch| (viewport parentstream) |of| viewport))
(streamsubregion (|fetch| (viewport streamsubregion) |of| viewport))
(objectdata (|fetch| (plotobject objectdata) |of| filledpolygon))
(streampoints (|fetch| (filledpolygondata streampoints) |of| objectdata))
(style (|fetch| (filledpolygondata style) |of| objectdata))
(linewidth (iplus 2 (|fetch| (plot.style linewidth) |of| style)))
(color (|fetch| (plot.style color) |of| style)))
(clipped.fillpolygon streamsubregion streampoints (|fetch| (filledpolygondata texture)
|of| objectdata)
stream
'erase nil (< 0 (|fetch| (plot.style linewidth) |of| style))
linewidth
'erase color))))
(extentoffilledpolygon
(lambda (filledpolygon) (* \; "Edited 5-Oct-88 10:50 by thh:")
(|bind| (minx ← max.float)
(maxx ← min.float)
(miny ← max.float)
(maxy ← min.float)
x y |for| position |in| (|fetch| (filledpolygondata polygonpoints)
|of| (|fetch| objectdata |of| filledpolygon))
|declare| (type floating minx maxx miny maxy x y) |do| (setq x (|fetch| xcoord |of| position))
(setq y (|fetch| ycoord |of| position))
(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| (return (|create| extent
minx ← minx
maxx ← maxx
miny ← miny
maxy ← maxy)))))
(getfilledpolygon
(lambda (proplst) (* \; "Edited 5-Oct-88 13:22 by thh:")
(let ((stylelst (listget proplst 'style)))
(|create| filledpolygondata
polygonpoints ← (listget proplst 'polygonpoints)
style ← (|create| plot.style
linewidth ← (car stylelst)
dashing ← (cadr stylelst)
color ← (caddr stylelst))
texture ← (listget proplst 'texture)))))
(highlightfilledpolygon
(lambda (filledpolygon viewport plot) (* \; "Edited 5-Oct-88 13:12 by thh:")
(let* ((stream (|fetch| (viewport parentstream) |of| viewport))
(streamsubregion (|fetch| (viewport streamsubregion) |of| viewport))
(objectdata (|fetch| (plotobject objectdata) |of| filledpolygon))
(streampoints (|fetch| (filledpolygondata streampoints) |of| objectdata))
(style (|fetch| (filledpolygondata style) |of| objectdata))
(linewidth (iplus 2 (|fetch| (plot.style linewidth) |of| style)))
(color (|fetch| (plot.style color) |of| style)))
(clipped.fillpolygon streamsubregion streampoints blackshade stream 'invert nil
(< 0 (|fetch| (plot.style linewidth) |of| style))
linewidth
'invert color))))
(movefilledpolygon
(lambda (filledpolygon dx dy plot) (* \; "Edited 5-Oct-88 11:09 by thh:")
(let ((points (fetch (filledpolygondata polygonpoints) of (fetch objectdata of filledpolygon))))
(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)))))))
(plotfilledpolygon
(lambda (plot positions label style texture menu nodrawflg)(* \; "Edited 5-Oct-88 11:11 by thh:")
(cond
((not (|type?| plot plot))
(help "NOT a PLOT" plot)))
(addplotobject (createfilledpolygon positions label style texture menu)
plot nodrawflg)))
(putfilledpolygon
(lambda (plotobject plot stream) (* \; "Edited 5-Oct-88 11:13 by thh:")
(prog ((objectdata (|fetch| (plotobject objectdata) |of| plotobject))
style)
(setq style (|fetch| (filledpolygondata style) |of| objectdata))
(printout stream "(" \, "POLYGONPOINTS" \, |.P2| (|fetch| (filledpolygondata polygonpoints)
|of| objectdata)
\, "TEXTURE" \, |.P2| (|fetch| (filledpolygondata texture) |of| objectdata)
\, "STYLE" \, |.P2| (list (|fetch| (plot.style linewidth) |of| style)
(|fetch| (plot.style dashing) |of| style)
(|fetch| (plot.style color) |of| style))
\, ")"))))
)
(rpaqq object2opstable
((filledpolygon (drawfn drawfilledpolygon)
(erasefn erasefilledpolygon)
(highlightfn highlightfilledpolygon)
(movefn movefilledpolygon)
(labelfn labelgeneric)
(extentfn extentoffilledpolygon)
(distancefn distancetofilledpolygon)
(copyfn copyfilledpolygon)
(putfn putfilledpolygon)
(getfn getfilledpolygon))))
(declare\: eval@compile
(datatype filledpolygondata (polygonpoints streampoints style texture)
style ← 1)
)
(/declaredatatype 'filledpolygondata '(pointer pointer pointer pointer)
'((filledpolygondata 0 pointer)
(filledpolygondata 2 pointer)
(filledpolygondata 4 pointer)
(filledpolygondata 6 pointer))
'8)
(plot.setup object2opstable)
(defineq
(clipped.fillpolygon
(lambda (clippingregion points texture stream operation windnumber draw? width drawoperation color
dashing) (* \; "Edited 7-Oct-88 09:03 by thh:")
(* |;;| "Clip filled polygon against CLIPPINGREGION. If DRAW? is non-NIL, the clipped perimeter of the polygon is drawn as well using the remaining parameters.")
(let ((clippedpoints (clipped.polygon clippingregion points)))
(* \;
"CLIPPEDPOINTS is NIL if polygon doesn't intersect CLIPPINGREGION")
(cond
(clippedpoints
(* |;;| "fill clipped polygon")
(fillpolygon clippedpoints texture stream operation windnumber)
(* |;;| "draw if requested")
(and draw? (|bind| (start ← (car points))
|first| (moveto (|fetch| xcoord |of| start)
(|fetch| ycoord |of| start)
stream) |for| pt |in| (cdr points)
|do| (clipped.drawto clippingregion (|fetch| xcoord |of| pt)
(|fetch| ycoord |of| pt)
width drawoperation stream color dashing)
|finally| (clipped.drawto clippingregion (|fetch| xcoord
|of| start)
(|fetch| ycoord |of| start)
width drawoperation stream color dashing))))))))
(clipped.polygon
(lambda (clippingregion points) (* \; "Edited 6-Oct-88 17:10 by thh:")
(* |;;| "clips polygon whose vertices are given in POINTS to CLIPPINGREGION using Sutherland-Hodgman algorithm. cf. p.450 of Foley and Van Dam")
(let* ((left (|fetch| left |of| clippingregion))
(right (|fetch| right |of| clippingregion))
(top (|fetch| top |of| clippingregion))
(bottom (|fetch| bottom |of| clippingregion))
(edges (list (|create| clipedgeinfo
x ← left
y ← bottom
end ← top
vertical? ← t)
(|create| clipedgeinfo
x ← left
y ← top
end ← right
vertical? ← nil)
(|create| clipedgeinfo
x ← right
y ← top
end ← bottom
vertical? ← t)
(|create| clipedgeinfo
x ← right
y ← bottom
end ← left
vertical? ← nil)))
clippedpoints)
(* |;;| "each edge in EDGES is a pair of points such that on moving from first to second, inside of CLIPPINGREGION is on the right. THESE ARE LEFT, TOP, RIGHT AND BOTTOM EDGES RESPECTIVELY.")
(for pt in points do (setq clippedpoints (clip-polygon-vertex pt edges clippedpoints)))
(finish-clip-polygon edges clippedpoints))))
(clip-polygon-vertex
(lambda (point edges clippedpoints) (* \; "Edited 6-Oct-88 16:02 by thh:")
(* |;;;| "implements single step of Sutherland-Hodgman algorithm")
(cond
(edges (let* ((edge (car edges))
(prevpoint (|fetch| (clipedgeinfo prevpt) |of| edge))
(previnside? (|fetch| (clipedgeinfo previnside?) |of| edge))
(inside? (clip-insidep point edge)))
(* |;;| "update points and check for intersection")
(cond
((|fetch| (clipedgeinfo firstpt) |of| edge)
(* |;;| "this is not first point of polygon to be clipped with this edge")
(cond
((neq previnside? inside?) (* \; "polygon side crosses edge")
(setq clippedpoints (clip-polygon-vertex (clip-intersect prevpoint point
edge)
(cdr edges)
clippedpoints)))))
(t
(* |;;| "this is first point of the polygon for this edge")
(|replace| (clipedgeinfo firstpt) |of| edge |with| point)
(|replace| (clipedgeinfo firstinside?) |of| edge |with| inside?)))
(|replace| (clipedgeinfo prevpt) |of| edge |with| point)
(|replace| (clipedgeinfo previnside?) |of| edge |with| inside?)
(* |;;| "")
(* |;;| "check if new point should be included")
(cond
(inside? (setq clippedpoints (clip-polygon-vertex point (cdr edges)
clippedpoints))))))
(t (* \; "nothing to clip against")
(push clippedpoints point)))
clippedpoints))
(finish-clip-polygon
(lambda (edges clippedpoints) (* \; "Edited 6-Oct-88 16:10 by thh:")
(cond
(edges (let ((edge (car edges)))
(cond
((and clippedpoints (neq (|fetch| (clipedgeinfo firstinside?) |of| edge)
(|fetch| (clipedgeinfo previnside?) |of| edge)))
(* \;
"last side of polygon crosses edge")
(setq clippedpoints (clip-polygon-vertex (clip-intersect (|fetch| (
clipedgeinfo
firstpt)
|of| edge)
(|fetch| (clipedgeinfo prevpt)
|of| edge)
edge)
(cdr edges)
clippedpoints))))
(|replace| (clipedgeinfo firstpt) |of| edge |with| nil)
(finish-clip-polygon (cdr edges)
clippedpoints)))
(t clippedpoints))))
(clip-insidep
(lambda (pt edge) (* \; "Edited 6-Oct-88 16:32 by thh:")
(* |;;| "T if PT is on or to the right of the directed EDGE (which is the inside of the region of which it is a part)")
(cond
((|fetch| (clipedgeinfo vertical?) |of| edge) (* \; "vertical edge")
(cond
((greaterp (|fetch| (clipedgeinfo end) |of| edge)
(|fetch| (clipedgeinfo y) |of| edge)) (* \;
"edge is going up, right is positive x-axis")
(geq (|fetch| xcoord |of| pt)
(|fetch| (clipedgeinfo x) |of| edge)))
(t (leq (|fetch| xcoord |of| pt)
(|fetch| (clipedgeinfo x) |of| edge)))))
(t (* \; "horizontal edge")
(cond
((greaterp (|fetch| (clipedgeinfo end) |of| edge)
(|fetch| (clipedgeinfo x) |of| edge)) (* \;
"edge is going right, right is negative y-axis")
(leq (|fetch| ycoord |of| pt)
(|fetch| (clipedgeinfo y) |of| edge)))
(t (geq (|fetch| ycoord |of| pt)
(|fetch| (clipedgeinfo y) |of| edge))))))))
(clip-intersect
(lambda (p1 p2 edge) (* \; "Edited 6-Oct-88 16:42 by thh:")
(* |;;| "returns point where segment between P1 and P2 intersect EDGE (the two points are on opposite sides of the edge)")
(cond
((|fetch| (clipedgeinfo vertical?) |of| edge) (* \; "vertical edge")
(let ((x (|fetch| (clipedgeinfo x) |of| edge)))
(|create| position
xcoord ← x
ycoord ← (plus (|fetch| ycoord |of| p1)
(quotient (times (difference x (|fetch| xcoord |of| p1))
(difference (|fetch| ycoord |of| p2)
(|fetch| ycoord |of| p1)))
(difference (|fetch| xcoord |of| p2)
(|fetch| xcoord |of| p1)))))))
(t (* \; "horizontal edge")
(let ((y (|fetch| (clipedgeinfo y) |of| edge)))
(|create| position
xcoord ← (plus (|fetch| xcoord |of| p1)
(quotient (times (difference y (|fetch| ycoord |of| p1))
(difference (|fetch| xcoord |of| p2)
(|fetch| xcoord |of| p1)))
(difference (|fetch| ycoord |of| p2)
(|fetch| ycoord |of| p1))))
ycoord ← y))))))
)
(declare\: eval@compile
(record clipedgeinfo (x y end vertical? firstpt firstinside? prevpt previnside?))
)
(putprops plotobjects2 copyright ("Xerox Corporation" 1988))
(declare\: dontcopy
(filemap (nil (1540 11177 (copyfilledpolygon 1550 . 2136) (createfilledpolygon 2138 . 3044) (
distancetofilledpolygon 3046 . 3475) (drawfilledpolygon 3477 . 4973) (erasefilledpolygon 4975 . 6088)
(extentoffilledpolygon 6090 . 7929) (getfilledpolygon 7931 . 8492) (highlightfilledpolygon 8494 . 9435
) (movefilledpolygon 9437 . 9937) (plotfilledpolygon 9939 . 10262) (putfilledpolygon 10264 . 11175)) (
12069 22891 (clipped.fillpolygon 12079 . 13948) (clipped.polygon 13950 . 15777) (clip-polygon-vertex
15779 . 17993) (finish-clip-polygon 17995 . 19602) (clip-insidep 19604 . 21079) (clip-intersect 21081
. 22889)))))
stop